--- a/CBrowser.st Mon Mar 06 20:30:54 1995 +0100
+++ b/CBrowser.st Mon Mar 06 20:32:18 1995 +0100
@@ -25,7 +25,7 @@
COPYRIGHT (c) 1990 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libtool/Attic/CBrowser.st,v 1.25 1995-02-28 21:54:57 claus Exp $
+$Header: /cvs/stx/stx/libtool/Attic/CBrowser.st,v 1.26 1995-03-06 19:31:02 claus Exp $
'!
!ChangesBrowser class methodsFor:'documentation'!
@@ -46,7 +46,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/Attic/CBrowser.st,v 1.25 1995-02-28 21:54:57 claus Exp $
+$Header: /cvs/stx/stx/libtool/Attic/CBrowser.st,v 1.26 1995-03-06 19:31:02 claus Exp $
"
!
@@ -1442,7 +1442,7 @@
self raise.
box := YesNoBox new.
- box title:(resources at:'ChangesBrowser:\changefile has not been updated from the modified changelist.\\Update before exiting ?') withCRs.
+ box title:(resources at:'changefile has not been updated from the modified changelist.\\Update before exiting ?') withCRs.
box noText:(resources at:'don''t update').
box okText:(resources at:'update').
box yesAction:[self writeBackChanges]
@@ -1551,7 +1551,7 @@
request:(resources at:'changefile has not been updated from the modified changelist.\\Update before closing ?') withCRs
label:'ChangesBrowser'
form:(WarningBox iconBitmap)
- buttonLabels:#('abort' 'don''t update' 'update')
+ buttonLabels:(resources array:#('abort' 'don''t update' 'update'))
values:#(#abort #ignore #save).
action == #abort ifTrue:[^ self].
action == #save ifTrue:[
--- a/ChangesBrowser.st Mon Mar 06 20:30:54 1995 +0100
+++ b/ChangesBrowser.st Mon Mar 06 20:32:18 1995 +0100
@@ -25,7 +25,7 @@
COPYRIGHT (c) 1990 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libtool/ChangesBrowser.st,v 1.25 1995-02-28 21:54:57 claus Exp $
+$Header: /cvs/stx/stx/libtool/ChangesBrowser.st,v 1.26 1995-03-06 19:31:02 claus Exp $
'!
!ChangesBrowser class methodsFor:'documentation'!
@@ -46,7 +46,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/ChangesBrowser.st,v 1.25 1995-02-28 21:54:57 claus Exp $
+$Header: /cvs/stx/stx/libtool/ChangesBrowser.st,v 1.26 1995-03-06 19:31:02 claus Exp $
"
!
@@ -1442,7 +1442,7 @@
self raise.
box := YesNoBox new.
- box title:(resources at:'ChangesBrowser:\changefile has not been updated from the modified changelist.\\Update before exiting ?') withCRs.
+ box title:(resources at:'changefile has not been updated from the modified changelist.\\Update before exiting ?') withCRs.
box noText:(resources at:'don''t update').
box okText:(resources at:'update').
box yesAction:[self writeBackChanges]
@@ -1551,7 +1551,7 @@
request:(resources at:'changefile has not been updated from the modified changelist.\\Update before closing ?') withCRs
label:'ChangesBrowser'
form:(WarningBox iconBitmap)
- buttonLabels:#('abort' 'don''t update' 'update')
+ buttonLabels:(resources array:#('abort' 'don''t update' 'update'))
values:#(#abort #ignore #save).
action == #abort ifTrue:[^ self].
action == #save ifTrue:[
--- a/DebugView.st Mon Mar 06 20:30:54 1995 +0100
+++ b/DebugView.st Mon Mar 06 20:32:18 1995 +0100
@@ -14,12 +14,12 @@
StandardSystemView subclass:#DebugView
instanceVariableNames:'busy haveControl exitAction canContinue contextView codeView
- receiverInspector contextInspector contextArray selectedContext
- catchBlock grabber traceView tracing bigStep skipLineNr
- steppedContextAddress canAbort abortButton terminateButton
- continueButton stepButton sendButton returnButton restartButton
- exclusive inspecting nChainShown inspectedProcess updateProcess
- monitorToggle stepping steppedContextLineno actualContext inWrap'
+ receiverInspector contextInspector contextArray selectedContext
+ catchBlock grabber traceView tracing bigStep skipLineNr
+ steppedContextAddress canAbort abortButton terminateButton
+ continueButton stepButton sendButton returnButton restartButton
+ exclusive inspecting nChainShown inspectedProcess updateProcess
+ monitorToggle stepping steppedContextLineno actualContext inWrap'
classVariableNames:'CachedDebugger CachedExclusive OpenDebuggers MoreDebuggingDetail'
poolDictionaries:''
category:'Interface-Debugger'
@@ -29,7 +29,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libtool/DebugView.st,v 1.27 1995-02-28 21:55:50 claus Exp $
+$Header: /cvs/stx/stx/libtool/DebugView.st,v 1.28 1995-03-06 19:31:13 claus Exp $
'!
!DebugView class methodsFor:'documentation'!
@@ -50,7 +50,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/DebugView.st,v 1.27 1995-02-28 21:55:50 claus Exp $
+$Header: /cvs/stx/stx/libtool/DebugView.st,v 1.28 1995-03-06 19:31:13 claus Exp $
"
!
@@ -407,8 +407,9 @@
'remove breakpoint'
'remove all trace & breakpoints'
'-'
- 'implementors ...'
- 'senders ...'
+ 'browse class'
+ 'implementors'
+ 'senders'
'-'
'inspect context'
'-'
@@ -632,7 +633,7 @@
setContext:aContext
"show calling chain from aContext in the walk-back listview"
- |con text method caller caller2 m|
+ |con text method caller caller2 m count|
(contextArray notNil and:[aContext == (contextArray at:1)]) ifTrue:[
"no change"
@@ -655,8 +656,9 @@
"
get them all
"
- [con notNil and:[contextArray size <= nChainShown]] whileTrue:[
- contextArray add:con.
+ count := 0.
+ [con notNil and:[count <= nChainShown]] whileTrue:[
+ contextArray add:con. count := count + 1.
(MoreDebuggingDetail == true) ifTrue:[
text add:(((ObjectMemory addressOf:con) printStringRadix:16) , ' ' , con printString).
] ifFalse:[
@@ -793,28 +795,28 @@
us here
"
(grabber := device activePointerGrab) notNil ifTrue:[
- device ungrabPointer
+ device ungrabPointer
].
terminateButton enable.
drawableId notNil ifTrue:[
- "not the first time - realize at old position"
- terminateButton turnOffWithoutRedraw.
- continueButton turnOffWithoutRedraw.
- returnButton turnOffWithoutRedraw.
- restartButton turnOffWithoutRedraw.
- abortButton turnOffWithoutRedraw.
- stepButton turnOffWithoutRedraw.
- sendButton turnOffWithoutRedraw.
+ "not the first time - realize at old position"
+ terminateButton turnOffWithoutRedraw.
+ continueButton turnOffWithoutRedraw.
+ returnButton turnOffWithoutRedraw.
+ restartButton turnOffWithoutRedraw.
+ abortButton turnOffWithoutRedraw.
+ stepButton turnOffWithoutRedraw.
+ sendButton turnOffWithoutRedraw.
] ifFalse:[
- exclusive ifFalse:[
- windowGroup isNil ifTrue:[
- windowGroup := WindowGroup new.
- windowGroup addTopView:self.
- ].
- ].
- self iconLabel:'Debugger'.
+ exclusive ifFalse:[
+ windowGroup isNil ifTrue:[
+ windowGroup := WindowGroup new.
+ windowGroup addTopView:self.
+ ].
+ ].
+ self iconLabel:'Debugger'.
].
"
@@ -831,76 +833,76 @@
in the context where the raise actually occured.
"
exitAction == #step ifTrue:[
- selection := 1.
- steppedContextAddress notNil ifTrue:[
- "
- if we came here by a big-step, show the method where we are
- "
- (ObjectMemory addressOf:aContext) == steppedContextAddress ifTrue:[
- selection := 1
- ] ifFalse:[
- (ObjectMemory addressOf:aContext sender) == steppedContextAddress ifTrue:[
- selection := 2
- ]
- ].
- "
- for bigStep, we could also be in a block below the actual method ...
- "
- (aContext home notNil and:[
- (ObjectMemory addressOf:aContext home) == steppedContextAddress]) ifTrue:[
- selection := 1
- ] ifFalse:[
- (aContext sender home notNil and:[
- (ObjectMemory addressOf:aContext sender home) == steppedContextAddress]) ifTrue:[
- selection := 2
- ]
- ].
- ]
+ selection := 1.
+ steppedContextAddress notNil ifTrue:[
+ "
+ if we came here by a big-step, show the method where we are
+ "
+ (ObjectMemory addressOf:aContext) == steppedContextAddress ifTrue:[
+ selection := 1
+ ] ifFalse:[
+ (ObjectMemory addressOf:aContext sender) == steppedContextAddress ifTrue:[
+ selection := 2
+ ]
+ ].
+ "
+ for bigStep, we could also be in a block below the actual method ...
+ "
+ (aContext home notNil and:[
+ (ObjectMemory addressOf:aContext home) == steppedContextAddress]) ifTrue:[
+ selection := 1
+ ] ifFalse:[
+ (aContext sender home notNil and:[
+ (ObjectMemory addressOf:aContext sender home) == steppedContextAddress]) ifTrue:[
+ selection := 2
+ ]
+ ].
+ ]
] ifFalse:[
- steppedContextAddress isNil ifTrue:[
- "
- preselect a more interresting context, (where halt/raise was ...)
- "
- selection := self interrestingContextFrom:aContext.
- ] ifFalse:[
- "
- if we came here by a big-step, show the method where we are
- "
- (ObjectMemory addressOf:aContext) == steppedContextAddress ifTrue:[
- selection := 1
- ] ifFalse:[
- (ObjectMemory addressOf:aContext sender) == steppedContextAddress ifTrue:[
- selection := 2
- ]
- ]
- ]
+ steppedContextAddress isNil ifTrue:[
+ "
+ preselect a more interresting context, (where halt/raise was ...)
+ "
+ selection := self interrestingContextFrom:aContext.
+ ] ifFalse:[
+ "
+ if we came here by a big-step, show the method where we are
+ "
+ (ObjectMemory addressOf:aContext) == steppedContextAddress ifTrue:[
+ selection := 1
+ ] ifFalse:[
+ (ObjectMemory addressOf:aContext sender) == steppedContextAddress ifTrue:[
+ selection := 2
+ ]
+ ]
+ ]
].
selection notNil ifTrue:[
- self showSelection:selection.
- contextView selection:selection.
- selection > 1 ifTrue:[
- contextView scrollToLine:(selection - 1)
- ]
+ self showSelection:selection.
+ contextView selection:selection.
+ selection > 1 ifTrue:[
+ contextView scrollToLine:(selection - 1)
+ ]
].
m := contextView middleButtonMenu.
m notNil ifTrue:[
- canAbort := inspecting or:[Object abortSignal isHandled].
- canAbort ifTrue:[
- abortButton enable.
- m enable:#doAbort.
- ] ifFalse:[
- abortButton disable.
- m disable:#doAbort.
- ].
- exclusive ifTrue:[
- terminateButton disable.
- m disable:#doTerminate.
- ] ifFalse:[
- terminateButton enable.
- m enable:#doTerminate.
- ]
+ canAbort := inspecting or:[Object abortSignal isHandled].
+ canAbort ifTrue:[
+ abortButton enable.
+ m enable:#doAbort.
+ ] ifFalse:[
+ abortButton disable.
+ m disable:#doAbort.
+ ].
+ exclusive ifTrue:[
+ terminateButton disable.
+ m disable:#doTerminate.
+ ] ifFalse:[
+ terminateButton enable.
+ m enable:#doTerminate.
+ ]
].
"
@@ -910,9 +912,9 @@
position again
"
drawableId notNil ifTrue:[
- self rerealize
+ self rerealize
] ifFalse:[
- self realize.
+ self realize.
].
"
@@ -944,30 +946,30 @@
contextInspector release.
(exitAction ~~ #step) ifTrue:[
- self unrealize.
- device synchronizeOutput.
+ self unrealize.
+ device synchronizeOutput.
- (exitAction == #abort) ifTrue:[
- self cacheMyself.
- "
- have to catch errors occuring in unwind-blocks
- "
- Object errorSignal handle:[:ex |
- 'ignored error while unwinding: ' errorPrint.
- ex errorString errorPrintNL.
- ex proceed
- ] do:[
- Object abortSignal raise.
- ].
- 'abort failed' errorPrintNL
- ].
+ (exitAction == #abort) ifTrue:[
+ self cacheMyself.
+ "
+ have to catch errors occuring in unwind-blocks
+ "
+ Object errorSignal handle:[:ex |
+ 'ignored error while unwinding: ' errorPrint.
+ ex errorString errorPrintNL.
+ ex proceed
+ ] do:[
+ Object abortSignal raise.
+ ].
+ 'abort failed' errorPrintNL
+ ].
- (exitAction == #return) ifTrue:[
- selectedContext notNil ifTrue:[
- "
- if there is a selection in the codeView,
- evaluate it and use the result as return value
- "
+ (exitAction == #return) ifTrue:[
+ selectedContext notNil ifTrue:[
+ "
+ if there is a selection in the codeView,
+ evaluate it and use the result as return value
+ "
"/ disabled for now, there is almost always a selection (the current line)
"/ and that is syntactically incorrect ...
"/ ... leading to a popup warning from the codeView
@@ -983,106 +985,106 @@
"/ ].
"/ ].
- con := selectedContext.
- self cacheMyself.
- "
- have to catch errors occuring in unwind-blocks
- "
- Object errorSignal handle:[:ex |
- 'ignored error while unwinding: ' errorPrint.
- ex errorString errorPrintNL.
- ex proceed
- ] do:[
- con unwind:retval.
- ].
- 'cannot return from selected context' errorPrintNL
- ]
- ].
+ con := selectedContext.
+ self cacheMyself.
+ "
+ have to catch errors occuring in unwind-blocks
+ "
+ Object errorSignal handle:[:ex |
+ 'ignored error while unwinding: ' errorPrint.
+ ex errorString errorPrintNL.
+ ex proceed
+ ] do:[
+ con unwind:retval.
+ ].
+ 'cannot return from selected context' errorPrintNL
+ ]
+ ].
- (exitAction == #restart) ifTrue:[
- selectedContext notNil ifTrue:[
- con := selectedContext.
- self cacheMyself.
- "
- have to catch errors occuring in unwind-blocks
- "
- Object errorSignal handle:[:ex |
- 'ignored error while unwinding: ' errorPrint.
- ex errorString errorPrintNL.
- ex proceed
- ] do:[
- con unwindAndRestart.
- ].
- 'cannot restart selected context' errorPrintNL
- ]
- ].
+ (exitAction == #restart) ifTrue:[
+ selectedContext notNil ifTrue:[
+ con := selectedContext.
+ self cacheMyself.
+ "
+ have to catch errors occuring in unwind-blocks
+ "
+ Object errorSignal handle:[:ex |
+ 'ignored error while unwinding: ' errorPrint.
+ ex errorString errorPrintNL.
+ ex proceed
+ ] do:[
+ con unwindAndRestart.
+ ].
+ 'cannot restart selected context' errorPrintNL
+ ]
+ ].
- (exitAction == #quickTerminate) ifTrue:[
- self cacheMyself.
- Processor activeProcess terminateNoSignal
- ].
+ (exitAction == #quickTerminate) ifTrue:[
+ self cacheMyself.
+ Processor activeProcess terminateNoSignal
+ ].
- (exitAction == #terminate) ifTrue:[
- self cacheMyself.
- "
- have to catch errors occuring in unwind-blocks
- "
- Object errorSignal handle:[:ex |
- 'ignored error while unwinding: ' errorPrint.
- ex errorString errorPrintNL.
- ex proceed
- ] do:[
- Processor activeProcess terminate.
- ].
- 'cannot terminate process' errorPrintNL
- ]
+ (exitAction == #terminate) ifTrue:[
+ self cacheMyself.
+ "
+ have to catch errors occuring in unwind-blocks
+ "
+ Object errorSignal handle:[:ex |
+ 'ignored error while unwinding: ' errorPrint.
+ ex errorString errorPrintNL.
+ ex proceed
+ ] do:[
+ Processor activeProcess terminate.
+ ].
+ 'cannot terminate process' errorPrintNL
+ ]
].
selectedContext := actualContext := nil.
grabber notNil ifTrue:[
- device grabPointerInView:grabber.
- grabber := nil.
+ device grabPointerInView:grabber.
+ grabber := nil.
].
(exitAction == #step) ifTrue:[
- "
- schedule another stepInterrupt
- - must enter myself into the collection of open debuggers,
- in case the stepping process comes back again via a halt or signal
- before the step is finished. In this case, the stepping debugger should
- come up (instead of a new one)
- - must flush caches since optimized methods not always
- look for pending interrupts
- "
- OpenDebuggers isNil ifTrue:[
- OpenDebuggers := WeakArray with:self
- ] ifFalse:[
- (OpenDebuggers includes:self) ifFalse:[
- idx := OpenDebuggers identityIndexOf:nil.
- idx ~~ 0 ifTrue:[
- OpenDebuggers at:idx put:self
- ] ifFalse:[
- OpenDebuggers := OpenDebuggers copyWith:self
- ]
- ]
- ].
- self label:'single stepping - please wait ...'.
- stepping := true.
+ "
+ schedule another stepInterrupt
+ - must enter myself into the collection of open debuggers,
+ in case the stepping process comes back again via a halt or signal
+ before the step is finished. In this case, the stepping debugger should
+ come up (instead of a new one)
+ - must flush caches since optimized methods not always
+ look for pending interrupts
+ "
+ OpenDebuggers isNil ifTrue:[
+ OpenDebuggers := WeakArray with:self
+ ] ifFalse:[
+ (OpenDebuggers includes:self) ifFalse:[
+ idx := OpenDebuggers identityIndexOf:nil.
+ idx ~~ 0 ifTrue:[
+ OpenDebuggers at:idx put:self
+ ] ifFalse:[
+ OpenDebuggers := OpenDebuggers copyWith:self
+ ]
+ ]
+ ].
+ self label:'single stepping - please wait ...'.
+ stepping := true.
- ObjectMemory stepInterruptHandler:self.
- ObjectMemory flushInlineCaches.
- StepInterruptPending := 1.
- InterruptPending := 1.
- InStepInterrupt := nil
+ ObjectMemory stepInterruptHandler:self.
+ ObjectMemory flushInlineCaches.
+ StepInterruptPending := 1.
+ InterruptPending := 1.
+ InStepInterrupt := nil
] ifFalse:[
- OpenDebuggers notNil ifTrue:[
- idx := OpenDebuggers identityIndexOf:self.
- idx ~~ 0 ifTrue:[
- OpenDebuggers at:idx put:nil
- ]
- ].
- self cacheMyself.
+ OpenDebuggers notNil ifTrue:[
+ idx := OpenDebuggers identityIndexOf:self.
+ idx ~~ 0 ifTrue:[
+ OpenDebuggers at:idx put:nil
+ ]
+ ].
+ self cacheMyself.
]
!
@@ -1840,21 +1842,21 @@
"return - the selected context will do a ^nil"
inspecting ifTrue:[
- selectedContext isNil ifTrue:[
- ^ self showError:'** select a context first **'
- ].
- self interruptProcessWith:[selectedContext unwind].
- ^ self
+ selectedContext isNil ifTrue:[
+ ^ self showError:'** select a context first **'
+ ].
+ self interruptProcessWith:[selectedContext unwind].
+ ^ self
].
steppedContextAddress := nil.
haveControl := false.
exitAction := #return.
ProcessorScheduler isPureEventDriven ifFalse:[
- "exit private event-loop"
- catchBlock notNil ifTrue:[catchBlock value].
- 'DEBUGGER: oops, return failed' errorPrintNL.
- returnButton turnOff.
+ "exit private event-loop"
+ catchBlock notNil ifTrue:[catchBlock value].
+ 'DEBUGGER: oops, return failed' errorPrintNL.
+ returnButton turnOff.
].
!
@@ -2042,4 +2044,3 @@
]
! !
-
--- a/FBrowser.st Mon Mar 06 20:30:54 1995 +0100
+++ b/FBrowser.st Mon Mar 06 20:32:18 1995 +0100
@@ -29,7 +29,7 @@
COPYRIGHT (c) 1991 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libtool/Attic/FBrowser.st,v 1.31 1995-02-28 21:56:54 claus Exp $
+$Header: /cvs/stx/stx/libtool/Attic/FBrowser.st,v 1.32 1995-03-06 19:31:30 claus Exp $
'!
!FileBrowser class methodsFor:'documentation'!
@@ -50,7 +50,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/Attic/FBrowser.st,v 1.31 1995-02-28 21:56:54 claus Exp $
+$Header: /cvs/stx/stx/libtool/Attic/FBrowser.st,v 1.32 1995-03-06 19:31:30 claus Exp $
"
!
@@ -151,7 +151,6 @@
myName := (resources string:self class name).
self label:myName.
- self icon:self class defaultIcon.
labelFrame := View origin:(0.0 @ 0.0)
corner:(1.0 @ (font height * 2))
@@ -1681,6 +1680,15 @@
'create file ...'
).
+ showDotFiles ifTrue:[
+ labels := labels copy.
+ labels at:18 put:'hide hidden files'
+ ].
+ showLongList ifTrue:[
+ labels := labels copy.
+ labels at:17 put:'display short list'
+ ].
+
selectors := #(
fileSpawn
nil
@@ -1705,7 +1713,6 @@
newFile
).
-
m := PopUpMenu
labels:(resources array:labels)
selectors:selectors
@@ -1973,35 +1980,13 @@
changeDisplayMode
"toggle from long to short listing (and vice-versa)"
- |long short oldLabel newLabel|
-
- long := (resources at:'display long list').
- short := (resources at:'display short list').
-
showLongList := showLongList not.
- showLongList ifFalse:[
- oldLabel := short. newLabel := long
- ] ifTrue:[
- oldLabel := long. newLabel := short
- ].
- fileListView middleButtonMenu labelAt:oldLabel put:newLabel.
self updateCurrentDirectory
!
changeDotFileVisibility
"turn on/off visibility of files whose name starts with '.'"
- |show dontShow oldLabel newLabel|
-
- show := (resources at:'show all files').
- dontShow := (resources at:'hide hidden files').
-
showDotFiles := showDotFiles not.
- showDotFiles ifFalse:[
- oldLabel := dontShow. newLabel := show
- ] ifTrue:[
- oldLabel := show. newLabel := dontShow
- ].
- fileListView middleButtonMenu labelAt:oldLabel put:newLabel.
self updateCurrentDirectory
! !
--- a/FileBrowser.st Mon Mar 06 20:30:54 1995 +0100
+++ b/FileBrowser.st Mon Mar 06 20:32:18 1995 +0100
@@ -29,7 +29,7 @@
COPYRIGHT (c) 1991 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libtool/FileBrowser.st,v 1.31 1995-02-28 21:56:54 claus Exp $
+$Header: /cvs/stx/stx/libtool/FileBrowser.st,v 1.32 1995-03-06 19:31:30 claus Exp $
'!
!FileBrowser class methodsFor:'documentation'!
@@ -50,7 +50,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/FileBrowser.st,v 1.31 1995-02-28 21:56:54 claus Exp $
+$Header: /cvs/stx/stx/libtool/FileBrowser.st,v 1.32 1995-03-06 19:31:30 claus Exp $
"
!
@@ -151,7 +151,6 @@
myName := (resources string:self class name).
self label:myName.
- self icon:self class defaultIcon.
labelFrame := View origin:(0.0 @ 0.0)
corner:(1.0 @ (font height * 2))
@@ -1681,6 +1680,15 @@
'create file ...'
).
+ showDotFiles ifTrue:[
+ labels := labels copy.
+ labels at:18 put:'hide hidden files'
+ ].
+ showLongList ifTrue:[
+ labels := labels copy.
+ labels at:17 put:'display short list'
+ ].
+
selectors := #(
fileSpawn
nil
@@ -1705,7 +1713,6 @@
newFile
).
-
m := PopUpMenu
labels:(resources array:labels)
selectors:selectors
@@ -1973,35 +1980,13 @@
changeDisplayMode
"toggle from long to short listing (and vice-versa)"
- |long short oldLabel newLabel|
-
- long := (resources at:'display long list').
- short := (resources at:'display short list').
-
showLongList := showLongList not.
- showLongList ifFalse:[
- oldLabel := short. newLabel := long
- ] ifTrue:[
- oldLabel := long. newLabel := short
- ].
- fileListView middleButtonMenu labelAt:oldLabel put:newLabel.
self updateCurrentDirectory
!
changeDotFileVisibility
"turn on/off visibility of files whose name starts with '.'"
- |show dontShow oldLabel newLabel|
-
- show := (resources at:'show all files').
- dontShow := (resources at:'hide hidden files').
-
showDotFiles := showDotFiles not.
- showDotFiles ifFalse:[
- oldLabel := dontShow. newLabel := show
- ] ifTrue:[
- oldLabel := show. newLabel := dontShow
- ].
- fileListView middleButtonMenu labelAt:oldLabel put:newLabel.
self updateCurrentDirectory
! !
--- a/Make.proto Mon Mar 06 20:30:54 1995 +0100
+++ b/Make.proto Mon Mar 06 20:32:18 1995 +0100
@@ -84,6 +84,7 @@
OBJECT=$(I)/Object.H $(I)/stc.h $(I)/stcIntern.h $(CPUINTERN_H)
VIEW=$(I)/View.H $(OBJECT)
STDSYSVIEW=$(I)/StdSysV.H $(VIEW)
+MODEL=$(I)/Model.H $(OBJECT)
InspView.$(O): InspView.st $(VIEW)
DictInspV.$(O): DictInspV.st $(I)/InspView.H $(VIEW)
@@ -93,7 +94,8 @@
DebugView.$(O): DebugView.st $(STDSYSVIEW)
Launcher.$(O): Launcher.st $(STDSYSVIEW)
ProjectV.$(O): ProjectV.st $(STDSYSVIEW)
-SBrowser.$(O): SBrowser.st $(STDSYSVIEW)
+SBrowser.$(O): SBrowser.st $(STDSYSVIEW) $(MODEL)
+BrwsrView.$(O): BrwsrView.st $(STDSYSVIEW)
CBrowser.$(O): CBrowser.st $(STDSYSVIEW)
FBrowser.$(O): FBrowser.st $(STDSYSVIEW)
DirBrwsr.$(O): DirBrwsr.st $(STDSYSVIEW)
--- a/MemMonitor.st Mon Mar 06 20:30:54 1995 +0100
+++ b/MemMonitor.st Mon Mar 06 20:32:18 1995 +0100
@@ -24,7 +24,7 @@
COPYRIGHT (c) 1991 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libtool/Attic/MemMonitor.st,v 1.9 1995-02-19 15:54:18 claus Exp $
+$Header: /cvs/stx/stx/libtool/Attic/MemMonitor.st,v 1.10 1995-03-06 19:31:50 claus Exp $
'!
!MemoryMonitor class methodsFor:'documentation'!
@@ -45,7 +45,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/Attic/MemMonitor.st,v 1.9 1995-02-19 15:54:18 claus Exp $
+$Header: /cvs/stx/stx/libtool/Attic/MemMonitor.st,v 1.10 1995-03-06 19:31:50 claus Exp $
"
!
@@ -295,7 +295,8 @@
y := y + fontHeight.
n := ObjectMemory lastScavangeReclamation / ObjectMemory newSpaceSize * 100.0.
n := 100 - n asInteger.
- s := (n printStringLeftPaddedTo:2) , '%'.
+ s := (ObjectMemory scavengeCount printStringLeftPaddedTo:5)
+ , (n printStringLeftPaddedTo:3) , '%'.
self displayOpaqueString:s x:0 y:y.
!
@@ -506,27 +507,38 @@
self font:(Font family:'courier' face:'medium' style:'roman' size:10).
+ self model:self.
+ self menu:#memoryMenu
+
"
MemoryMonitor open
"
!
-initializeMiddleButtonMenu
- self middleButtonMenu:
- (PopUpMenu labels:(resources array:#(
- 'collect Garbage'
- 'collect Garbage & compress'
- '-'
- 'background collect'
- ))
- selectors:#(
- garbageCollect
- compressingGarbageCollect
- nil
- backgroundCollect
- )
+memoryMenu
+ |labels selectors|
+
+ labels := #(
+ 'collect Garbage'
+ 'collect Garbage & compress'
+ '-'
+ 'background collect'
+ '-'
+ 'compress sources '
+ ).
+
+ selectors := #(
+ garbageCollect
+ compressingGarbageCollect
+ nil
+ backgroundCollect
+ nil
+ compressSources
+ ).
+
+ ^ PopUpMenu labels:(resources array:labels)
+ selectors:selectors
receiver:self
- for:self)
! !
!MemoryMonitor methodsFor:'menu functions'!
@@ -541,5 +553,10 @@
backgroundCollect
[ObjectMemory incrementalGC] forkAt:4
+!
+
+compressSources
+ Smalltalk compressSources.
+ ObjectMemory markAndSweep
! !
--- a/MemoryMonitor.st Mon Mar 06 20:30:54 1995 +0100
+++ b/MemoryMonitor.st Mon Mar 06 20:32:18 1995 +0100
@@ -24,7 +24,7 @@
COPYRIGHT (c) 1991 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libtool/MemoryMonitor.st,v 1.9 1995-02-19 15:54:18 claus Exp $
+$Header: /cvs/stx/stx/libtool/MemoryMonitor.st,v 1.10 1995-03-06 19:31:50 claus Exp $
'!
!MemoryMonitor class methodsFor:'documentation'!
@@ -45,7 +45,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/MemoryMonitor.st,v 1.9 1995-02-19 15:54:18 claus Exp $
+$Header: /cvs/stx/stx/libtool/MemoryMonitor.st,v 1.10 1995-03-06 19:31:50 claus Exp $
"
!
@@ -295,7 +295,8 @@
y := y + fontHeight.
n := ObjectMemory lastScavangeReclamation / ObjectMemory newSpaceSize * 100.0.
n := 100 - n asInteger.
- s := (n printStringLeftPaddedTo:2) , '%'.
+ s := (ObjectMemory scavengeCount printStringLeftPaddedTo:5)
+ , (n printStringLeftPaddedTo:3) , '%'.
self displayOpaqueString:s x:0 y:y.
!
@@ -506,27 +507,38 @@
self font:(Font family:'courier' face:'medium' style:'roman' size:10).
+ self model:self.
+ self menu:#memoryMenu
+
"
MemoryMonitor open
"
!
-initializeMiddleButtonMenu
- self middleButtonMenu:
- (PopUpMenu labels:(resources array:#(
- 'collect Garbage'
- 'collect Garbage & compress'
- '-'
- 'background collect'
- ))
- selectors:#(
- garbageCollect
- compressingGarbageCollect
- nil
- backgroundCollect
- )
+memoryMenu
+ |labels selectors|
+
+ labels := #(
+ 'collect Garbage'
+ 'collect Garbage & compress'
+ '-'
+ 'background collect'
+ '-'
+ 'compress sources '
+ ).
+
+ selectors := #(
+ garbageCollect
+ compressingGarbageCollect
+ nil
+ backgroundCollect
+ nil
+ compressSources
+ ).
+
+ ^ PopUpMenu labels:(resources array:labels)
+ selectors:selectors
receiver:self
- for:self)
! !
!MemoryMonitor methodsFor:'menu functions'!
@@ -541,5 +553,10 @@
backgroundCollect
[ObjectMemory incrementalGC] forkAt:4
+!
+
+compressSources
+ Smalltalk compressSources.
+ ObjectMemory markAndSweep
! !
--- a/OldLauncher.st Mon Mar 06 20:30:54 1995 +0100
+++ b/OldLauncher.st Mon Mar 06 20:32:18 1995 +0100
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1991 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libtool/OldLauncher.st,v 1.21 1995-02-28 21:56:59 claus Exp $
+$Header: /cvs/stx/stx/libtool/OldLauncher.st,v 1.22 1995-03-06 19:31:44 claus Exp $
'!
!Launcher class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/OldLauncher.st,v 1.21 1995-02-28 21:56:59 claus Exp $
+$Header: /cvs/stx/stx/libtool/OldLauncher.st,v 1.22 1995-03-06 19:31:44 claus Exp $
"
!
@@ -344,7 +344,7 @@
'Address Book'
"
'-'
- 'Calendar '
+ 'Calendar'
'Directory View'
'MailTool'
'NewsTool'
--- a/SBrowser.st Mon Mar 06 20:30:54 1995 +0100
+++ b/SBrowser.st Mon Mar 06 20:32:18 1995 +0100
@@ -10,27 +10,39 @@
hereby transferred.
"
-'From Smalltalk/X, Version:2.10.4 on 7-nov-1994 at 14:56:27'!
+'From Smalltalk/X, Version:2.10.4 on 24-feb-1995 at 5:09:20 am'!
-StandardSystemView subclass:#SystemBrowser
- instanceVariableNames:'classCategoryListView classListView methodCategoryListView
- methodListView classMethodListView codeView classToggle
- instanceToggle currentClassCategory currentClassHierarchy
- currentClass currentMethodCategory currentMethod currentSelector
- showInstance actualClass fullClass lastMethodCategory aspect
- variableListView fullProtocol lockUpdates autoSearch myLabel
- acceptClass'
+Model subclass:#SystemBrowser
+ instanceVariableNames:'currentClass currentMethodCategory currentMethod currentSelector
+ showInstance actualClasslastMethodCategory aspect lockUpdates
+ autoSearch myLabel acceptClass'
classVariableNames:'CheckForInstancesWhenRemovingClasses'
poolDictionaries:''
category:'Interface-Browsers'
!
-SystemBrowser comment:'
-COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+!SystemBrowser class methodsFor:'initialization'!
+
+initialize
+ "Browser configuration;
+ (values can be changed from your private startup file)"
-$Header: /cvs/stx/stx/libtool/Attic/SBrowser.st,v 1.25 1995-02-24 17:00:43 claus Exp $
-'!
+ "
+ setting this to false, the removeClass function will remove
+ classes WITHOUT checking for instances. Otherwise,
+ it will check and let you confirm in case there are instances.
+ Checking for instances may be a bit time consuming, though.
+ The default is true - therefore, it will check
+ "
+ CheckForInstancesWhenRemovingClasses := true
+
+ "
+ CheckForInstancesWhenRemovingClasses := true
+ CheckForInstancesWhenRemovingClasses := false
+
+ Browser initialize
+ "
+! !
!SystemBrowser class methodsFor:'documentation'!
@@ -50,7 +62,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/Attic/SBrowser.st,v 1.25 1995-02-24 17:00:43 claus Exp $
+$Header: /cvs/stx/stx/libtool/Attic/SBrowser.st,v 1.26 1995-03-06 19:32:08 claus Exp $
"
!
@@ -69,25 +81,27 @@
"
! !
-!SystemBrowser class methodsFor:'initialization'!
+!SystemBrowser class methodsFor:'instance creation'!
-initialize
- "SystemBrowser configuration;
- (values can be changed from your private startup file)"
+openOnDisplay:aDisplay
+ "launch a standard browser on another display.
+ Does not work currently - still being developped."
+
+ ^ self newWithLabel:(BrowserView classResources string:'System Browser')
+ setupBlock:[:browser | browser setupForAll]
+ on:aDisplay
"
- setting this to false, the removeClass function will remove
- classes WITHOUT checking for instances. Otherwise,
- it will check and let you confirm in case there are instances.
- Checking for instances may be a bit time consuming, though.
- The default is true - therefore, it will check
+ SystemBrowser openOnDisplay:(XWorkstation new initializeFor:'porty:0')
"
- CheckForInstancesWhenRemovingClasses := true
+!
- "
- CheckForInstancesWhenRemovingClasses := true
- CheckForInstancesWhenRemovingClasses := false
- "
+open
+ "launch a standard browser"
+
+ ^ self openOnDisplay:Display
+
+ "SystemBrowser open"
! !
!SystemBrowser class methodsFor:'startup'!
@@ -116,7 +130,6 @@
'Setclass new:')
title:'some new: methods'
"
-
!
browseMethodsIn:aCollectionOfClasses inst:wantInst class:wantClass where:aBlock title:title
@@ -177,6 +190,7 @@
The block is called with 3 arguments, class, method and seelctor."
^ self browseMethodsIn:aCollectionOfClasses inst:true class:true where:aBlock title:title
+
!
browseClassCategory:aClassCategory
@@ -619,6 +633,7 @@
"
^ self browseForSymbol:aGlobalName title:('users of: ' , aGlobalName) warnIfNone:doWarn
+
!
browseReferendsOf:aGlobalName
@@ -631,6 +646,7 @@
"
Browser browseReferendsOf:#Transcript
"
+
!
browseUsesOf:aClass
@@ -742,6 +758,7 @@
newDict inspect
+
!
browseForString:aString in:aCollectionOfClasses
@@ -774,6 +791,7 @@
SystemBrowser browseForString:'should' in:(Array with:Object)
SystemBrowser browseForString:'[eE]rror' in:(Array with:Object)
"
+
!
browseForString:aString
@@ -781,6 +799,7 @@
This may be slow, since source-code has to be scanned."
^ self browseForString:aString in:(Smalltalk allClasses)
+
!
browseInstRefsTo:varName in:aCollectionOfClasses modificationsOnly:modsOnly title:title
@@ -797,6 +816,7 @@
browser autoSearch:varName
].
^ browser
+
!
aproposSearch:aString in:aCollectionOfClasses
@@ -844,6 +864,7 @@
SystemBrowser aproposSearch:'sort' in:(Collection withAllSubclasses)
SystemBrowser aproposSearch:'[Aa]bsent' in:(Collection withAllSubclasses)
"
+
!
aproposSearch:aString
@@ -852,6 +873,7 @@
This is relatively slow, since all source must be processed."
^ self aproposSearch:aString in:(Smalltalk allClasses)
+
!
browseInstRefsTo:aString in:aCollectionOfClasses modificationsOnly:modsOnly
@@ -870,6 +892,7 @@
in:aCollectionOfClasses
modificationsOnly:modsOnly
title:(title , aString)
+
!
browseInstRefsTo:aString under:aClass modificationsOnly:modsOnly
@@ -878,6 +901,7 @@
if modsOnly is true, browse only methods where the instvar is modified"
^ self browseInstRefsTo:aString in:(aClass withAllSubclasses) modificationsOnly:modsOnly
+
!
browseClassRefsTo:varName in:aCollectionOfClasses modificationsOnly:modsOnly title:title
@@ -894,6 +918,7 @@
browser autoSearch:varName
].
^ browser
+
!
browseClassRefsTo:aString in:aCollectionOfClasses modificationsOnly:modsOnly
@@ -909,6 +934,7 @@
title := 'references to '
].
^ self browseClassRefsTo:aString in:aCollectionOfClasses modificationsOnly:modsOnly title:(title , aString)
+
!
browseClassRefsTo:aString under:aClass modificationsOnly:modsOnly
@@ -917,6 +943,7 @@
if modsOnly is true, browse only methods where the classvar is modified"
^ self browseClassRefsTo:aString in:(aClass withAllSubclasses) modificationsOnly:modsOnly
+
!
filterToSearchClassRefsTo:varName modificationsOnly:modsOnly
@@ -967,4896 +994,45 @@
result
].
^ searchBlock
+
! !
-!SystemBrowser class methodsFor:'private'!
+!SystemBrowser class methodsFor:'private instance creation'!
newWithLabel:aString setupBlock:aBlock on:aWorkstation
"common helper method for all creation methods"
|newBrowser|
- newBrowser := self on:aWorkstation.
+ newBrowser := BrowserView on:aWorkstation.
newBrowser title:aString.
aBlock value:newBrowser.
newBrowser open.
^ newBrowser
+
+
!
newWithLabel:aString setupBlock:aBlock
"common helper method for all creation methods"
^ self newWithLabel:aString setupBlock:aBlock on:Display
-!
-showNoneFound:what
-"/ DialogView warn:(self classResources string:('no ' , what , ' found')).
- self showNoneFound
-!
-
-showNoneFound
- DialogView warn:(self classResources string:'None found').
-! !
-
-!SystemBrowser class methodsFor:'general startup'!
-
-openOnDisplay:aDisplay
- "launch a standard browser on another display.
- Does not work currently - still being developped."
-
- ^ self newWithLabel:(self classResources string:'System Browser')
- setupBlock:[:browser | browser setupForAll]
- on:aDisplay
-
- "
- SystemBrowser openOnDisplay:(XWorkstation new initializeFor:'porty:0')
- "
-!
-
-open
- "launch a standard browser"
-
- ^ self openOnDisplay:Display
-
- "SystemBrowser open"
-! !
-
-!SystemBrowser methodsFor:'dependencies'!
-
-update:something with:someArgument from:changedObject
- "
- avoid update/warn after my own changes
- "
- lockUpdates == true ifTrue:[
-"/ 'ignored my change' printNL.
- ^ self
- ].
-
-"/ changedObject print. ' ' print. someArgument print. ' ' print.
-"/ something printNL.
-
- (changedObject == Smalltalk) ifTrue:[
- something == #newClass ifTrue:[
- (currentClass notNil
- and:[someArgument name = currentClass name]) ifTrue:[
- "
- the current class was autoloaded
- "
- self warnLabel:'the selected class has changed'.
- self updateClassListWithScroll:false.
- ].
-
- ((someArgument category = currentClassCategory)
- or:[currentClassCategory notNil
- and:[currentClassCategory startsWith:'*']]) ifTrue:[
- self updateClassListWithScroll:false.
- ].
-
- someArgument category ~= currentClassCategory ifTrue:[
- "
- category new ?
- "
- (classCategoryListView notNil
- and:[classCategoryListView list notNil
- and:[(classCategoryListView list includes:someArgument category) not]])
- ifTrue:[
- self updateClassCategoryListWithScroll:false.
- ]
- ].
- ^ self
- ].
-
- something == #classRemove ifTrue:[
- someArgument = currentClass ifTrue:[
- self warnLabel:'the selected class was removed'.
- ^ self
- ].
- " fall into general update "
- ].
-
- "
- any other (unknown) change
- with the Smalltalk dictionary ...
- "
- self updateClassCategoryListWithScroll:false.
- self updateClassListWithScroll:false.
- ^ self
- ].
-
- changedObject isBehavior ifTrue:[
- "
- its a class, that has changed
- "
- (currentClass notNil
- and:[changedObject name = currentClass name]) ifTrue:[
- "
- its the current class that has changed
- "
- something == #methodDictionary ifTrue:[
- (someArgument isSymbol) ifTrue:[
- |changedMethod|
-
- "
- the method with selector someArgument was changed or removed
- "
- self updateMethodCategoryListWithScroll:false.
- self updateMethodListWithScroll:false.
-
- someArgument == currentSelector ifTrue:[
- "
- special care here: the currently shown method has been
- changed somehow in another browser (or via fileIn)
- "
- changedMethod := currentClass compiledMethodAt:currentSelector.
- changedMethod isNil ifTrue:[
- self warnLabel:'the method shown was removed'.
- ^ self
- ].
- "compare the source codes"
- self warnLabel:'the code shown may not up to date'.
- ^ self
- ].
- ^ self
- ]
- ].
-
- something == #comment ifTrue:[
- "
- the class has changed its comment; we dont care, except if
- currently showing the comment
- "
- aspect == #comment ifTrue:[
- self warnLabel:'the comment shown may not up to date'.
- ].
- ^ self
- ].
- something == #definition ifTrue:[
- "
- the class has changed its definition.
- Warn, except if showing a method.
- "
- aspect notNil ifTrue:[
- self warnLabel:'the classes definition has changed'.
- ].
-"/ ^ self
- ].
-
- "
- get the class again - in case of a changed class definition,
- we are otherwise refering to the obsolete old class
- "
- currentClass := Smalltalk at:(currentClass name asSymbol).
- showInstance ifTrue:[
- actualClass := currentClass
- ] ifFalse:[
- actualClass := currentClass class
- ].
-
- self updateMethodCategoryListWithScroll:false.
-
- "dont update codeView ...."
- "self update"
- ^ self
- ].
-
- "
- any other class has changed (but not its organization, since
- that is cought in the above case).
- We are not interrested in it - except, if showing fullProtocol
- or hierarchy ...
- "
- currentClassHierarchy notNil ifTrue:[
- fullProtocol ifTrue:[
- (currentClass isSubclassOf:changedObject) ifTrue:[
- ]
- ] ifFalse:[
- ((currentClass isSubclassOf:changedObject)
- or:[changedObject isSubclassOf:currentClass]) ifTrue:[
- ]
- ]
- ].
-
- ^ self
- ].
-
- (changedObject isMethod) ifTrue:[
-
- ]
! !
-!SystemBrowser methodsFor:'private'!
-
-normalLabel
- "set the normal (inactive) window- and icon labels"
-
- |l il|
-
- myLabel notNil ifTrue:[
- l := il := myLabel
- ] ifFalse:[
- l := resources string:'System Browser'.
-
- currentClass notNil ifTrue:[
- l := l, ': ', currentClass name.
- classListView isNil ifTrue:[
- currentSelector notNil ifTrue:[
- l := l , ' ' , currentSelector
- ]
- ].
- il := currentClass name
- ] ifFalse:[
- il := l.
- ]
- ].
- self label:l.
- self iconLabel:il.
-!
-
-setDoitActionForClass
- "tell the codeView what to do on doIt"
-
- "set self for doits. This allows accessing the current class
- as self, and access to the class variables by name.
- "
- codeView doItAction:[:theCode |
- |compiler|
-
- currentClass isNil ifTrue:[
- compiler := Compiler
- ] ifFalse:[
- compiler := currentClass compilerClass
- ].
- compiler
- evaluate:theCode
- in:nil
- receiver:currentClass
- notifying:codeView
- logged:false
- ifFail:nil
- ].
-!
-
-setAcceptAndExplainActionsForMethod
- "tell the codeView what to do on accept and explain"
-
- codeView acceptAction:[:theCode |
- |cat cls|
-
- codeView cursor:Cursor execute.
-
- (cat := currentMethodCategory) = '* all *' ifTrue:[
- "must check from which category this code came from ...
- ... thanks to Arno for pointing this out"
-
- cat := self askForMethodCategory.
- ].
- (cat notNil and:[cat notEmpty]) ifTrue:[
- fullProtocol ifTrue:[
- cls := acceptClass "/actualClass whichClassImplements:currentSelector.
- ].
- cls isNil ifTrue:[
- cls := actualClass
- ].
-
- Object abortSignal catch:[
- lockUpdates := true.
-
- actualClass compilerClass
- compile:theCode asString
- forClass:cls
- inCategory:cat
- notifying:codeView.
-
- codeView modified:false.
- self updateMethodListWithScroll:false.
- ].
- lockUpdates := false.
- ].
- codeView cursor:Cursor normal.
- ].
-
- codeView explainAction:[:theCode :theSelection |
- self showExplanation:(Explainer
- explain:theSelection
- in:theCode
- forClass:actualClass)
- ].
-!
-
-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 action|
-
- codeView modified ifFalse:[
- ^ true
- ].
- action := OptionBox
- request:(resources at:'text has not been accepted.\\Your modifications will be lost when continuing.') withCRs
- label:'Attention'
- form:(WarningBox iconBitmap)
- buttonLabels:#('abort' 'accept' 'continue')
- values:#(false #accept true).
- action ~~ #accept ifTrue:[
- ^ action
- ].
- codeView accept. ^ true
-!
-
-selectorToSearchFor
- "look in codeView and methodListView for a search-string when searching for selectors"
-
- |sel t|
-
- sel := codeView selection.
- sel notNil ifTrue:[
- sel := sel asString.
- t := Parser selectorInExpression:sel.
- t notNil ifTrue:[
- sel := t
- ].
- sel := sel withoutSpaces.
- sel == #>> ifTrue:[
- "oops - thats probably not what we want here ..."
- self extractClassAndSelectorFromSelectionInto:[:c :s :m |
- sel := s
- ]
- ]
- ] ifFalse:[
- methodListView notNil ifTrue:[
- sel := methodListView selectionValue
- ] ifFalse:[
- classMethodListView notNil ifTrue:[
- sel := classMethodListView selectionValue.
- sel notNil ifTrue:[
- sel := self selectorFromClassMethodString:sel
- ]
- ]
- ].
- sel notNil ifTrue:[
- sel := sel withoutSpaces
- ] ifFalse:[
- sel := ''
- ]
- ].
- ^ sel
-!
-
-enterBoxTitle:title okText:okText
- "convenient method: setup enterBox"
-
- |box|
-
- box := EnterBox new.
- box title:(resources string:title) okText:(resources string:okText).
- ^ box
-!
-
-askAndBrowseSelectorTitle:title action:aBlock
- "convenient method: setup enterBox with text from codeView or selected
- method for browsing based on a selector. Set action and launch box"
-
- |box|
-
- box := self enterBoxTitle:title okText:'browse'.
- box initialText:(self selectorToSearchFor).
- box action:[:aString | self withCursor:(Cursor questionMark) do:[aBlock value:aString]].
- box showAtPointer
-!
-
-setSearchPattern:aString
- codeView setSearchPattern:aString
-!
-
-listBoxTitle:title okText:okText list:aList
- "convenient method: setup a listBox & return it"
-
- |box|
-
- box := ListSelectionBox new.
- box okText:(resources string:okText).
- box title:(resources string:title).
- box list:aList.
- ^ box
-!
-
-showExplanation:someText
- "show explanation from Parser"
+!SystemBrowser class methodsFor:'private helpers'!
- self notify:someText
-!
-
-stringToSearchFor
- "look in codeView and methodListView for a search-string when searching for classes/names"
-
- |sel|
-
- sel := codeView selection.
- sel notNil ifTrue:[
- sel := sel asString withoutSpaces
- ] ifFalse:[
- sel isNil ifTrue:[
- currentClass notNil ifTrue:[
- sel := currentClass name
- ]
- ].
- sel notNil ifTrue:[
- sel := sel withoutSpaces
- ] ifFalse:[
- sel := ''
- ]
- ].
- ^ sel
-!
-
-findClassOfVariable:aVariableName accessWith:aSelector
- "this method returns the class, in which a variable
- is defined;
- needs either #instVarNames or #classVarNames as aSelector."
-
- |cls homeClass|
-
- "
- first, find the class, where the variable is declared
- "
- cls := currentClass.
- [cls notNil] whileTrue:[
- ((cls perform:aSelector) includes:aVariableName) ifTrue:[
- homeClass := cls.
- cls := nil.
- ] ifFalse:[
- cls := cls superclass
- ]
- ].
- homeClass isNil ifTrue:[
- "nope, must be one below ... (could optimize a bit, by searching down
- for the declaring class ...
- "
- homeClass := currentClass
- ] ifFalse:[
-"/ Transcript showCr:'starting search in ' , homeClass name.
- ].
- ^ homeClass
-!
-
-enterBoxForSearchSelectorTitle:title
- "convenient method: setup enterBox with text from codeView or selected
- method for browsing based on a selector"
-
- |box|
-
- box := self enterBoxTitle:title okText:'search'.
- box initialText:(self selectorToSearchFor).
- ^ box
-!
-
-enterBoxForCodeSelectionTitle:title okText:okText
- "convenient method: setup enterBox with text from codeview"
-
- |sel box|
-
- box := self enterBoxTitle:(resources string:title) okText:(resources string:okText).
- sel := codeView selection.
- sel notNil ifTrue:[
- box initialText:(sel asString withoutSeparators)
- ].
- ^ box
-!
-
-classesInFullProtocolHierarchy:aClass do:aBlock
- "evaluate aBlock for all non-striked out classes in
- the hierarchy"
-
- |index|
-
- index := (classListView list size).
- aClass withAllSuperclasses do:[:c |
- (classListView isInSelection:index) ifFalse:[
- aBlock value:c
- ].
- index := index - 1
- ]
-
-!
-
-enterBoxForBrowseTitle:title action:aBlock
- "convenient method: setup enterBox with text from codeView or selected
- method for method browsing based on className/variable"
-
- |box|
-
- box := self enterBoxTitle:title okText:'browse'.
- box initialText:(self stringToSearchFor).
- box action:[:aString | self withWaitCursorDo:[aBlock value:aString]].
- box showAtPointer
-!
-
-askAndBrowseMethodCategory:title action:aBlock
- "convenient method: setup enterBox with initial being current method category"
-
- |sel box|
-
- box := self enterBoxTitle:title okText:'browse'.
- sel := codeView selection.
- sel isNil ifTrue:[
- currentMethodCategory notNil ifTrue:[
- sel := currentMethodCategory
- ]
- ].
- sel notNil ifTrue:[
- box initialText:(sel asString withoutSpaces)
- ].
- box action:[:aString | self withWaitCursorDo:[aBlock value:aString]].
- box showAtPointer
-!
-
-classHierarchyDo:aBlock
- "eavluate the 2-arg block for every class,
- starting at Object; passing class and nesting level to the block."
-
- |classes s classDict l|
-
- classes := Smalltalk allClasses.
- classDict := IdentityDictionary new:classes size.
- classes do:[:aClass |
- s := aClass superclass.
- s notNil ifTrue:[
- l := classDict at:s ifAbsent:[nil].
- l isNil ifTrue:[
- l := OrderedCollection new:5.
- classDict at:s put:l
- ].
- l add:aClass
- ]
- ].
- self classHierarchyOf:Object level:0 do:aBlock using:classDict
-!
-
-classHierarchyOf:aClass level:level do:aBlock using:aDictionary
- "evaluate the 2-arg block for every subclass of aClass,
- passing class and nesting level to the block."
-
- |names subclasses|
-
- aBlock value:aClass value:level.
- subclasses := aDictionary at:aClass ifAbsent:[nil].
- (subclasses size == 0) ifFalse:[
- names := subclasses collect:[:class | class name].
- names sortWith:subclasses.
- subclasses do:[:aSubClass |
- self classHierarchyOf:aSubClass level:(level + 1) do:aBlock using:aDictionary
- ]
- ]
-!
-
-compileCode:someCode
- (ReadStream on:someCode) fileIn
-!
-
-extractClassAndSelectorFromSelectionInto:aBlock
- "given a string which can be either 'class>>sel' or
- 'class sel', extract className and selector, and call aBlock with
- the result."
-
- |sel clsName isMeta sep s|
-
- sel := codeView selection.
- sel notNil ifTrue:[
- sel := sel asString withoutSeparators.
- ('*>>*' match:sel) ifTrue:[
- sep := $>
- ] ifFalse:[
- ('* *' match:sel) ifTrue:[
- sep := Character space
- ]
- ].
- sep notNil ifTrue:[
- "
- extract class/sel from selection
- "
- s := ReadStream on:sel.
- clsName := s upTo:sep.
- [s peek == sep] whileTrue:[s next].
- sel := s upToEnd.
-
- (clsName endsWith:'class') ifTrue:[
- isMeta := true.
- clsName := clsName copyTo:(clsName size - 5)
- ] ifFalse:[
- isMeta := false
- ].
- ]
- ].
- aBlock value:clsName value:sel value:isMeta
+showNoneFound:what
+ self showNoneFound
!
-classesInHierarchy:aClass do:aBlock
- |index|
-
- index := (classListView list size).
- aClass withAllSuperclasses do:[:c |
- (classListView isInSelection:index) ifFalse:[
- aBlock value:c
- ].
- index := index - 1
- ]
-
-!
-
-askForMethodCategory
- |someCategories box txt|
-
- someCategories := actualClass categories sort.
- box := self listBoxTitle:'accept in which method category ?' okText:'accept' list:someCategories.
-
- lastMethodCategory isNil ifTrue:[
- txt := 'new methods'
- ] ifFalse:[
- txt := lastMethodCategory
- ].
- box initialText:txt.
- box action:[:aString |
- ^ aString
- ].
- box showAtPointer.
- ^ nil
-!
-
-warnLabel:what
- "set the title for some warning"
-
- self label:('System Browser WARNING: ' , what)
-!
-
-busyLabel:what with:someArgument
- "set the title for some warning"
-
- self label:('System Browser:' , (resources string:what with:someArgument))
-
-! !
-
-!SystemBrowser methodsFor:'method stuff'!
-
-updateMethodListWithScroll:scroll
- |selectors scr first last|
-
- methodListView notNil ifTrue:[
- currentMethodCategory notNil ifTrue:[
- fullProtocol ifTrue:[
- selectors := self listOfAllSelectorsInCategory:currentMethodCategory
- inFullProtocolHierarchyOfClass:actualClass
- ] ifFalse:[
- selectors := self listOfAllSelectorsInCategory:currentMethodCategory
- ofClass:actualClass
- ]
- ].
- scr := scroll.
- first := methodListView firstLineShown.
- first ~~ 1 ifTrue:[
- last := methodListView lastLineShown.
- selectors size <= (last - first + 1) ifTrue:[
- scr := true
- ]
- ].
- methodListView list = selectors ifFalse:[
- scr ifTrue:[
- methodListView contents:selectors
- ] ifFalse:[
- methodListView setContents:selectors
- ]
- ].
- ]
-!
-
-methodSelectionChanged
- "method selection has changed - update dependent views"
-
- self withWaitCursorDo:[
- |index cls|
-
- self updateCodeView.
- self setAcceptAndExplainActionsForMethod.
-
- "
- if there is any autoSearch string, do the search
- "
- autoSearch notNil ifTrue:[
- codeView searchFwd:autoSearch startingAtLine:1 col:0 ifAbsent:[]
- ].
-
- fullProtocol ifTrue:[
- "
- remove any bold attribute from classList
- "
- 1 to:classListView list size do:[:i |
- classListView attributeAt:i remove:#bold.
- ].
- "
- boldify the class where this method is implemented
- "
- currentMethod notNil ifTrue:[
- cls := currentMethod who at:1.
- index := classListView list indexOf:(cls name).
- (index == 0
- and:[cls isMeta
- and:[cls name endsWith:'class']]) ifTrue:[
- index := classListView list indexOf:(cls name copyWithoutLast:5).
- ].
- index ~~ 0 ifTrue:[
- classListView attributeAt:index add:#bold.
- ].
- currentClass := acceptClass := cls.
- ]
- ].
- ]
-!
-
-updateMethodList
- self updateMethodListWithScroll:true
-!
-
-methodSelection:lineNr
- "user clicked on a method line - show code"
-
- |selectorString selectorSymbol|
-
- (fullProtocol not and:[currentClass isNil]) ifTrue:[^ self].
-
- selectorString := methodListView selectionValue.
- "
- kludge: check if its a wrapped one
- "
- (selectorString endsWith:' !!') ifTrue:[
- selectorString := selectorString copyTo:(selectorString size - 2)
- ].
- selectorSymbol := selectorString asSymbol.
- fullProtocol ifTrue:[
- currentMethod := currentSelector := nil.
- "
- search which class implements the selector
- "
- self classesInFullProtocolHierarchy:actualClass do:[:c |
- (currentMethod isNil
- and:[c implements:selectorSymbol]) ifTrue:[
- currentSelector := selectorSymbol.
- currentMethod := c compiledMethodAt:selectorSymbol.
- acceptClass := c
- ]
- ]
- ] ifFalse:[
- currentSelector := selectorSymbol.
- currentMethod := actualClass compiledMethodAt:selectorSymbol.
- ].
-
- methodCategoryListView notNil ifTrue:[
- currentMethod notNil ifTrue:[
- (currentMethodCategory = currentMethod category) ifFalse:[
- currentMethodCategory := currentMethod category.
- methodCategoryListView selectElement:currentMethodCategory
- ]
- ]
- ].
-
- self methodSelectionChanged
-!
-
-listOfAllSelectorsInCategory:aCategory ofClass:aClass
- "answer a list of all selectors in a given method category
- of the argument, aClass"
-
- |newList searchCategory|
-
- (aCategory = '* all *') ifTrue:[
- newList := aClass selectorArray asOrderedCollection
- ] ifFalse:[
- (aCategory = '* no category *') ifTrue:[
- searchCategory := nil
- ] ifFalse:[
- searchCategory := aCategory
- ].
- newList := OrderedCollection new.
- aClass methodArray with:aClass selectorArray do:[:aMethod :selector |
- |sel|
-
- (aMethod category = searchCategory) ifTrue:[
- aMethod isWrapped ifTrue:[
- sel := selector , ' !!'
- ] ifFalse:[
- sel := selector
- ].
-
- "mhmh - can this happen ?"
-"/ (newList includes:sel) ifFalse:[
- newList add:sel
-"/ ]
- ]
- ]
- ].
- (newList size == 0) ifTrue:[^ nil].
- ^ newList sort
-!
-
-template
- "return a method definition template"
-
- ^
-'message selector and argument names
- "comment stating purpose of message"
-
-
- |temporaries|
- statements
-
-
-"
- change above template into real code.
- Then ''accept'' either via the menu
- or via the keyboard (usually CMD-A).
-
- You do not need this template; you can also
- select any existing methods code, change it,
- and finally ''accept''.
-"
-'
-!
-
-listOfAllSelectorsInCategory:aCategory inFullProtocolHierarchyOfClass:aClass
- "answer a list of all selectors in a given method category
- of the argument, aClass and its superclasses.
- Used with fullProtocol browsing."
-
- |newList|
-
- newList := Set new.
- self classesInFullProtocolHierarchy:aClass do:[:c |
- |searchCategory|
-
- (aCategory = '* all *') ifTrue:[
- newList addAll:(c selectorArray)
- ] ifFalse:[
- (aCategory = '* no category *') ifTrue:[
- searchCategory := nil
- ] ifFalse:[
- searchCategory := aCategory
- ].
- c methodArray with:c selectorArray do:[:aMethod :selector |
- (aMethod category = searchCategory) ifTrue:[
- newList add:selector
- ]
- ]
- ].
- ].
- (newList size == 0) ifTrue:[^ nil].
- ^ newList asOrderedCollection sort
-!
-
-checkMethodSelected
- currentMethod isNil ifTrue:[
- self warn:'select a method first'.
- ^ false
- ].
- ^ true
-!
-
-switchToMethodNamed:matchString
- |aSelector method cat index classToSearch selectors|
-
- currentClass notNil ifTrue:[
- showInstance ifTrue:[
- classToSearch := currentClass
- ] ifFalse:[
- classToSearch := currentClass class
- ].
- selectors := classToSearch selectorArray.
-
- ((matchString ~= '*') and:[matchString includesMatchCharacters]) ifTrue:[
- index := selectors findFirst:[:element | matchString match:element]
- ] ifFalse:[
- index := selectors indexOf:matchString
- ].
-
- (index ~~ 0) ifTrue:[
- aSelector := selectors at:index.
- method := classToSearch methodArray at:index.
- cat := method category.
- cat isNil ifTrue:[cat := '* all *'].
- methodCategoryListView selectElement:cat.
- currentMethodCategory := cat.
- self methodCategorySelectionChanged.
-
- currentMethod := classToSearch compiledMethodAt:aSelector.
- currentMethod notNil ifTrue:[
- currentSelector := aSelector.
- methodListView selectElement:aSelector.
- ].
- self methodSelectionChanged
- ]
- ]
-!
-
-switchToAnyMethodNamed:aString
- |aSelector classToStartSearch aClass nm|
-
- aSelector := aString asSymbol.
- currentClass isNil ifTrue:[
- currentClassHierarchy notNil ifTrue:[
- classToStartSearch := currentClassHierarchy
- ]
- ] ifFalse:[
- classToStartSearch := currentClass
- ].
- classToStartSearch notNil ifTrue:[
- showInstance ifFalse:[
- classToStartSearch := classToStartSearch class
- ].
- aClass := classToStartSearch whichClassImplements:aSelector.
- aClass notNil ifTrue:[
- nm := aClass name.
- showInstance ifFalse:[
- ((nm ~= 'Metaclass') and:[nm endsWith:'class']) ifTrue:[
- nm := nm copyTo:(nm size - 5)
- ]
- ].
- self switchToClassNamed:nm.
- self switchToMethodNamed:aString
- ]
- ]
-! !
-
-!SystemBrowser methodsFor:'misc'!
-
-updateCodeView
- |code|
-
- fullClass ifTrue:[
- currentClass notNil ifTrue:[
- code := currentClass source.
- ]
- ] ifFalse:[
- currentMethod notNil ifTrue:[
- (codeView acceptAction isNil
- and:[actualClass notNil
- and:[currentMethodCategory notNil]]) ifTrue:[
- self setAcceptAndExplainActionsForMethod.
- ].
-
- code := currentMethod source.
-
- ]
- ].
- codeView contents:code.
- codeView modified:false.
-
- self normalLabel.
-!
-
-instanceProtocol:aBoolean
- "switch between instance and class protocol"
-
- showInstance ~~ aBoolean ifTrue:[
- self checkSelectionChangeAllowed ifTrue:[
- aBoolean ifTrue:[
- classToggle turnOff.
- instanceToggle turnOn.
- ] ifFalse:[
- classToggle turnOn.
- instanceToggle turnOff
- ].
- showInstance := aBoolean.
-
- (variableListView notNil
- and:[variableListView hasSelection]) ifTrue:[
- self unhilightMethodCategories.
- self unhilightMethods.
- variableListView deselect
- ].
-
- fullProtocol ifTrue:[
- showInstance ifTrue:[
- actualClass := acceptClass := currentClassHierarchy.
- ] ifFalse:[
- actualClass := acceptClass := currentClassHierarchy class.
- ].
-
- self updateClassList.
- self updateMethodCategoryListWithScroll:false.
- self updateMethodListWithScroll:false.
- self updateVariableList.
- ^ self
- ].
- currentClass notNil ifTrue:[
- self classSelectionChanged
- ].
- codeView modified:false.
- ] ifFalse:[
- aBoolean ifTrue:[
- classToggle turnOn.
- instanceToggle turnOff
- ] ifFalse:[
- classToggle turnOff.
- instanceToggle turnOn.
- ].
- ]
- ]
-!
-
-instanceProtocol
- "switch to instance protocol"
-
- self instanceProtocol:true
-!
-
-classProtocol
- "switch to class protocol"
-
- self instanceProtocol:false
-! !
-
-!SystemBrowser methodsFor:'method category stuff'!
-
-updateMethodCategoryListWithScroll:scroll
- |categories|
-
- methodCategoryListView notNil ifTrue:[
- fullProtocol ifTrue:[
- currentClassHierarchy notNil ifTrue:[
- categories := self listOfAllMethodCategoriesInFullProtocolHierarchy:actualClass
- ]
- ] ifFalse:[
- currentClass notNil ifTrue:[
- categories := self listOfAllMethodCategoriesInClass:actualClass
- ]
- ].
- methodCategoryListView list = categories ifFalse:[
- scroll ifTrue:[
- methodCategoryListView contents:categories
- ] ifFalse:[
- methodCategoryListView setContents:categories
- ].
- currentMethodCategory notNil ifTrue:[
- methodCategoryListView selectElement:currentMethodCategory
- ]
- ]
- ]
-!
-
-listOfAllMethodCategoriesInClass:aClass
- "answer a list of all method categories of the argument, aClass"
-
- |newList|
-
- newList := OrderedCollection new.
- aClass methodArray do:[:aMethod |
- |cat|
-
- cat := aMethod category.
- cat isNil ifTrue:[
- cat := '* no category *'
- ].
- (newList includes:cat) ifFalse:[newList add:cat]
- ].
- (newList size == 0) ifTrue:[^ nil].
- newList add:'* all *'.
- ^ newList sort
-!
-
-methodCategorySelection:lineNr
- "user clicked on a method category line - show selectors"
-
- |oldSelector|
-
-"/ oldSelector := currentSelector.
-
- (fullProtocol not and:[currentClass isNil]) ifTrue:[^ self].
-
- currentMethodCategory := methodCategoryListView selectionValue.
- self methodCategorySelectionChanged.
-
- "if there is only one method, show it right away"
- methodListView list size == 1 ifTrue:[
- methodListView selection:1.
- self methodSelection:1
- ] ifFalse:[
- oldSelector notNil ifTrue:[
- methodListView selectElement:oldSelector.
- methodListView hasSelection ifTrue:[
- self methodSelection:methodListView selection.
- ]
- ]
- ]
-!
-
-updateMethodCategoryList
- self updateMethodCategoryListWithScroll:true
-!
-
-methodCategorySelectionChanged
- "method category selection has changed - update dependant views"
-
- self withWaitCursorDo:[
- currentMethod := currentSelector := nil.
-
- self updateMethodList.
- self updateCodeView.
-
- currentMethodCategory notNil ifTrue:[
- methodCategoryListView selectElement:currentMethodCategory
- ].
-
- self setAcceptAndExplainActionsForMethod.
- self hilightMethodsInMethodCategoryList:false inMethodList:true.
- ]
-!
-
-listOfAllMethodCategoriesInFullProtocolHierarchy:aClass
- "answer a list of all method categories of the argument, aClass,
- and all of its superclasses.
- Used with fullProtocol browsing."
-
- |newList|
-
- newList := OrderedCollection new.
- self classesInFullProtocolHierarchy:aClass do:[:c |
- |cat|
-
- c methodArray do:[:aMethod |
- cat := aMethod category.
- cat isNil ifTrue:[
- cat := '* no category *'
- ].
- (newList includes:cat) ifFalse:[newList add:cat]
- ]
- ].
- (newList size == 0) ifTrue:[^ nil].
- newList add:'* all *'.
- ^ newList sort
-!
-
-checkMethodCategorySelected
- currentMethodCategory isNil ifTrue:[
- self warn:'select a method category first'.
- ^ false
- ].
- ^ true
-!
-
-whenMethodCategorySelected:aBlock
- self checkMethodCategorySelected ifTrue:[
- self withWaitCursorDo:aBlock
- ]
-!
-
-copyMethodsFromClass:aClassName
- |class box|
-
- currentClass notNil ifTrue:[
- class := Smalltalk classNamed:aClassName.
- class isBehavior ifFalse:[
- self warn:'no class named %1' with:aClassName.
- ^ self
- ].
-
- showInstance ifFalse:[
- class := class class
- ].
-
- "show enterbox for category to copy from"
-
- box := self enterBoxTitle:'name of category to copy from (matchpattern allowed, * for all):'
- okText:'copy'.
- box action:[:aString | self copyMethodsFromClass:class category:aString].
- box showAtPointer.
- ]
-!
-
-copyMethodsFromClass:class category:category
- currentClass notNil ifTrue:[
- Object abortSignal catch:[
- class methodArray do:[:aMethod |
- |source|
-
- (category match:aMethod category) ifTrue:[
- source := aMethod source.
- codeView contents:source.
- codeView modified:false.
- actualClass compilerClass
- compile:source
- forClass:actualClass
- inCategory:aMethod category
- notifying:codeView.
- self updateMethodCategoryListWithScroll:false.
- self updateMethodListWithScroll:false.
- ]
- ]
- ]
- ]
-!
-
-newMethodCategory:aString
- |categories|
-
- currentClass isNil ifTrue:[
- ^ self warn:'select/create a class first'.
- ].
- categories := methodCategoryListView list.
- categories isNil ifTrue:[categories := OrderedCollection new].
- (categories includes:aString) ifFalse:[
- categories add:aString.
- categories sort.
- methodCategoryListView contents:categories
- ].
- currentMethodCategory := aString.
- self methodCategorySelectionChanged
-! !
-
-!SystemBrowser methodsFor:'initialize / release'!
-
-initialize
- super initialize.
-
- self icon:(Form fromFile:(resources at:'ICON_FILE' default:'SBrowser.xbm')
- resolution:100).
-
- showInstance := true.
- fullClass := false.
- fullProtocol := false.
- aspect := nil.
-
- "inform me, when Smalltalk changes"
- Smalltalk addDependent:self
-!
-
-realize
- |v checkBlock|
-
- super realize.
-
- checkBlock := [:lineNr | self checkSelectionChangeAllowed].
-
- v := classCategoryListView.
- v notNil ifTrue:[
- v action:[:lineNr | self classCategorySelection:lineNr].
- v selectConditionBlock:checkBlock.
- v ignoreReselect:false.
- v contents:(self listOfAllClassCategories).
- "
- tell classCategoryListView to ask for the menu
- "
- v model:self.
- v menu:#classCategoryMenu.
- ].
-
- v := classListView.
- v notNil ifTrue:[
- v action:[:lineNr | self classSelection:lineNr].
- v selectConditionBlock:checkBlock.
- v ignoreReselect:false.
- "
- tell classListView to ask for the menu
- "
- v model:self.
- v menu:#classMenu.
- self initializeVariableListMenu.
- ].
-
- v := methodCategoryListView.
- v notNil ifTrue:[
- v action:[:lineNr | self methodCategorySelection:lineNr].
- v selectConditionBlock:checkBlock.
- v ignoreReselect:false.
- "
- tell methodCategoryListView to ask for the menu
- "
- v model:self.
- v menu:#methodCategoryMenu.
- ].
-
- v := methodListView.
- v notNil ifTrue:[
- v action:[:lineNr | self methodSelection:lineNr].
- v selectConditionBlock:checkBlock.
- v ignoreReselect:false.
- self initializeMethodMenu
- "
- tell methodListView to ask for the menu
- "
- v model:self.
- v menu:#methodMenu.
- ].
-
- v := classMethodListView.
- v notNil ifTrue:[
- v action:[:lineNr | self classMethodSelection:lineNr].
- v selectConditionBlock:checkBlock.
- v ignoreReselect:false.
- "
- tell classMethodListView to ask for the menu
- "
- v model:self.
- v menu:#classMethodMenu.
- ].
-
- v := variableListView.
- v notNil ifTrue:[
- v action:[:lineNr | self variableSelection:lineNr].
- v ignoreReselect:false.
- v toggleSelect:true
- ].
-
- "
- normal browsers show the top at first;
- hierarchy and fullProtocol browsers better show the end
- initially
- "
- currentClassHierarchy notNil ifTrue:[
- classListView scrollToBottom.
- ]
-!
-
-terminate
- (self checkSelectionChangeAllowed) ifTrue:[
- super terminate
- ]
-!
-
-destroy
- "relese dependant - destroy popups"
-
- Smalltalk removeDependent:self.
- currentClass notNil ifTrue:[
- currentClass removeDependent:self.
- currentClass := nil
- ].
- super destroy
-!
-
-autoSearch:aString
- "used with class-method list browsing. If true,
- selecting an entry from the list will automatically
- search for the searchstring in the codeView"
-
- self setSearchPattern:aString.
- autoSearch := aString
-!
-
-title:someString
- myLabel := someString.
- self label:someString.
-! !
-
-!SystemBrowser methodsFor:'initialize subviews'!
-
-createClassListViewIn:frame
- "setup the classlist subview, with its toggles"
-
- |v panel oldStyle|
-
- self createTogglesIn:frame.
-
- "
- oldstyle had no variableList ...
- "
-"/ oldStyle := true.
- oldStyle := false.
-
- oldStyle ifTrue:[
- v := ScrollableView for:SelectionInListView in:frame.
- v origin:(0.0 @ 0.0)
- extent:[frame width
- @
- (frame height
- - ViewSpacing
- - instanceToggle height
- - instanceToggle borderWidth
- + v borderWidth)].
-
- classListView := v scrolledView
- ] ifFalse:[
- panel := VariableVerticalPanel
- origin:(0.0 @ 0.0)
- corner:[frame width
- @
- (frame height
- - ViewSpacing
- - instanceToggle height
- - instanceToggle borderWidth
- + v borderWidth)]
- in:frame.
-
- v := ScrollableView for:SelectionInListView in:panel.
- v origin:(0.0 @ 0.0) corner:(1.0 @ 0.7).
- classListView := v scrolledView.
-
-
- v := ScrollableView for:SelectionInListView in:panel.
- v origin:(0.0 @ 0.7) corner:(1.0 @ 1.0).
-
- variableListView := v scrolledView
- ]
-!
-
-createCodeViewIn:aView at:relY
- "setup the code view"
- |v|
-
- v := HVScrollableView for:CodeView miniScrollerH:true miniScrollerV:false in:aView.
- v origin:(0.0 @ relY) corner:(1.0 @ 1.0).
- codeView := v scrolledView
-!
-
-createTogglesIn:aFrame
- "create and setup the class/instance toggles"
-
- |h halfSpace classAction instanceAction|
-
- classAction := [self classProtocol].
- instanceAction := [self instanceProtocol].
-
- halfSpace := ViewSpacing // 2.
-
- instanceToggle := Toggle label:(resources at:'instance') in:aFrame.
- h := instanceToggle height.
- instanceToggle origin:(0.0 @ 1.0) corner:(0.5 @ 1.0).
- instanceToggle topInset:h negated.
- instanceToggle bottomInset:halfSpace.
-
- instanceToggle turnOn.
- instanceToggle pressAction:instanceAction.
- instanceToggle releaseAction:classAction.
-
- classToggle := Toggle label:(resources at:'class') in:aFrame.
- h := classToggle height.
- classToggle origin:(0.5 @ 1.0) corner:(1.0 @ 1.0).
- classToggle topInset:h negated.
- classToggle bottomInset:halfSpace.
-
- classToggle turnOff.
- classToggle pressAction:classAction.
- classToggle releaseAction:instanceAction.
-
- StyleSheet is3D ifTrue:[
- instanceToggle leftInset:halfSpace.
- classToggle leftInset:halfSpace.
- instanceToggle rightInset:ViewSpacing - halfSpace.
- classToggle rightInset:ViewSpacing - halfSpace.
- ].
-!
-
-createCodeViewIn:aView
- "setup the code view"
-
- ^ self createCodeViewIn:aView at:0.25
-!
-
-setupForList:aList
- "setup subviews to browse methods from a list"
-
- |vpanel v|
-
- vpanel := VariableVerticalPanel
- origin:(0.0 @ 0.0)
- corner:(1.0 @ 1.0)
- in:self.
-
- v := ScrollableView for:SelectionInListView in:vpanel.
- v origin:(0.0 @ 0.0) corner:(1.0 @ 0.25).
- classMethodListView := v scrolledView.
- classMethodListView contents:aList.
-
- self createCodeViewIn:vpanel.
- self updateCodeView
-!
-
-setupForAll
- "create subviews for a full browser"
-
- |vpanel hpanel frame v|
-
- vpanel := VariableVerticalPanel origin:(0.0 @ 0.0) corner:(1.0 @ 1.0)
- in:self.
- hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
-
- v := HVScrollableView for:SelectionInListView
- miniScrollerH:true miniScrollerV:false
- in:hpanel.
- v origin:(0.0 @ 0.0) corner:(0.25 @ 1.0).
- classCategoryListView := v scrolledView.
-
- frame := View origin:(0.25 @ 0.0) corner:(0.5 @ 1.0) in:hpanel.
- self createClassListViewIn:frame.
-
- v := HVScrollableView for:SelectionInListView miniScrollerH:true miniScrollerV:false in:hpanel.
- v origin:(0.5 @ 0.0) corner:(0.75 @ 1.0).
- methodCategoryListView := v scrolledView.
-
- v := HVScrollableView for:SelectionInListView miniScrollerH:true miniScrollerV:false in:hpanel.
- v origin:(0.75 @ 0.0) corner:(1.0 @ 1.0).
- methodListView := v scrolledView.
-
- self createCodeViewIn:vpanel
-!
-
-setupForClassHierarchy:aClass
- "setup subviews to browse a class hierarchy"
-
- |vpanel hpanel frame v|
-
- vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
- corner:(1.0 @ 1.0)
- in:self.
-
- "
- notice: we use a different ratio here
- "
- hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.4) in:vpanel.
- frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
-
- self createClassListViewIn:frame.
-
- v := ScrollableView for:SelectionInListView in:hpanel.
- v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
- methodCategoryListView := v scrolledView.
-
- v := ScrollableView for:SelectionInListView in:hpanel.
- v origin:(0.66 @ 0.0) corner:(1.0 @ 1.0).
- methodListView := v scrolledView.
-
- self createCodeViewIn:vpanel at:0.4.
-
- currentClassHierarchy := aClass.
- self updateClassList.
- self updateMethodCategoryList.
- self updateMethodList.
- self updateCodeView
-!
-
-setupForFullClass
- "setup subviews to browse a class as full text"
-
- |vpanel hpanel v|
-
- vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
- corner:(1.0 @ 1.0)
- in:self.
-
- hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
-
- v := ScrollableView for:SelectionInListView in:hpanel.
- v origin:(0.0 @ 0.0) corner:(0.5 @ 1.0).
- classCategoryListView := v scrolledView.
- classCategoryListView contents:(self listOfAllClassCategories).
-
- v := ScrollableView for:SelectionInListView in:hpanel.
- v origin:(0.5 @ 0.0) corner:(1.0 @ 1.0).
- classListView := v scrolledView.
-
- self createCodeViewIn:vpanel.
-
- fullClass := true.
- self updateCodeView
-!
-
-setupForClass:aClass
- "create subviews for browsing a single class"
-
- |vpanel hpanel frame v|
-
- vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
- corner:(1.0 @ 1.0)
- in:self.
-
- hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
- frame := View origin:(0.0 @ 0.0) corner:(0.5 @ 1.0)in:hpanel.
-
- self createTogglesIn:frame.
-
- v := ScrollableView for:SelectionInListView in:frame.
- v origin:(0.0 @ 0.0)
- extent:[frame width
- @
- (frame height
- - ViewSpacing
- - instanceToggle height
- - instanceToggle borderWidth
- + v borderWidth)].
- methodCategoryListView := v scrolledView.
-
- v := ScrollableView for:SelectionInListView in:hpanel.
- v origin:(0.5 @ 0.0) corner:(1.0 @ 1.0).
- methodListView := v scrolledView.
-
- self createCodeViewIn:vpanel.
-
- self switchToClass:aClass.
- actualClass := acceptClass := aClass.
- self updateMethodCategoryList.
- self updateMethodList.
- self updateCodeView
-!
-
-setupForClassCategory:aClassCategory
- "setup subviews to browse a class category"
-
- |vpanel hpanel frame v|
-
- vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
- corner:(1.0 @ 1.0)
- in:self.
-
- hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
- frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
-
- self createClassListViewIn:frame.
-
- v := ScrollableView for:SelectionInListView in:hpanel.
- v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
- methodCategoryListView := v scrolledView.
-
- v := ScrollableView for:SelectionInListView in:hpanel.
- v origin:(0.66 @ 0.0) corner:(1.0 @ 1.0).
- methodListView := v scrolledView.
-
- self createCodeViewIn:vpanel.
-
- currentClassCategory := aClassCategory.
- self updateClassList.
- self updateMethodCategoryList.
- self updateMethodList.
- self updateCodeView
-!
-
-setupForClass:aClass selector:selector
- "setup subviews to browse a single method"
-
- |v|
-
- v := ScrollableView for:CodeView in:self.
- v origin:(0.0 @ 0.0) corner:(1.0 @ 1.0).
- codeView := v scrolledView.
-
- currentClassCategory := aClass category.
- self switchToClass:aClass.
- actualClass := acceptClass := aClass.
- currentSelector := selector.
- currentMethod := currentClass compiledMethodAt:selector.
- currentMethodCategory := currentMethod category.
- self updateCodeView
-!
-
-setupForClassList:aList
- "setup subviews to browse classes from a list"
-
- |vpanel hpanel frame l v|
-
- vpanel := VariableVerticalPanel
- origin:(0.0 @ 0.0) corner:(1.0 @ 1.0) in:self.
-
- hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
- frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
-
- self createClassListViewIn:frame.
-
- v := ScrollableView for:SelectionInListView in:hpanel.
- v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
- methodCategoryListView := v scrolledView.
-
- v := ScrollableView for:SelectionInListView in:hpanel.
- v origin:(0.66 @ 0.0) corner:(1.0 @ 1.0).
- methodListView := v scrolledView.
-
- self createCodeViewIn:vpanel.
-
- l := aList collect:[:entry | entry name].
- classListView list:(l sort).
-
- self updateMethodCategoryList.
- self updateMethodList.
- self updateCodeView
-!
-
-setupForClass:aClass methodCategory:aMethodCategory
- "setup subviews to browse a method category"
-
- |vpanel v|
-
- vpanel := VariableVerticalPanel
- origin:(0.0 @ 0.0) corner:(1.0 @ 1.0)
- in:self.
-
- v := ScrollableView for:SelectionInListView in:vpanel.
- v origin:(0.0 @ 0.0) corner:(1.0 @ 0.25).
- methodListView := v scrolledView.
-
- self createCodeViewIn:vpanel.
-
- currentClassCategory := aClass category.
- self switchToClass:aClass.
- actualClass := acceptClass := aClass.
- currentMethodCategory := aMethodCategory.
- self updateMethodList.
- self updateCodeView
-!
-
-setupForFullClassProtocol:aClass
- "setup subviews to browse a classes full protocol"
-
- |vpanel hpanel frame v|
-
- vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
- corner:(1.0 @ 1.0)
- in:self.
-
- "
- notice: we use a different ratio here
- "
- hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.4) in:vpanel.
- frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
-
- self createClassListViewIn:frame.
- classListView multipleSelectOk:true.
- classListView toggleSelect:true.
- classListView strikeOut:true.
-
- v := ScrollableView for:SelectionInListView in:hpanel.
- v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
- methodCategoryListView := v scrolledView.
-
- v := ScrollableView for:SelectionInListView in:hpanel.
- v origin:(0.66 @ 0.0) corner:(1.0 @ 1.0).
- methodListView := v scrolledView.
-
- self createCodeViewIn:vpanel at:0.4.
-
- currentClassHierarchy := actualClass := acceptClass := currentClass := aClass.
- fullProtocol := true.
-
- self updateClassList.
- self updateMethodCategoryList.
- self updateMethodList.
- self updateCodeView.
- self updateVariableList.
-!
-
-focusSequence
- |s|
-
- s := OrderedCollection new.
-
- classCategoryListView notNil ifTrue:[
- s add:classCategoryListView
- ].
-
- classListView notNil ifTrue:[
- s add:classListView
- ].
-
-"/ variableListView notNil ifTrue:[
-"/ s add:variableListView
-"/ ].
-
- instanceToggle notNil ifTrue:[
- s add:instanceToggle.
- ].
-
- methodCategoryListView notNil ifTrue:[
- s add:methodCategoryListView
- ].
-
- methodListView notNil ifTrue:[
- s add:methodListView
- ].
-
- classMethodListView notNil ifTrue:[
- s add:classMethodListView
- ].
-
- s add:codeView.
- ^ s
-! !
-
-!SystemBrowser methodsFor:'unused'!
-
-listOfAllSelectorsInCategory:aCategory inHierarchyOfClass:aClass
- "answer a list of all selectors in a given method category
- of the argument, aClass and its superclasses"
-
- |newList|
-
- newList := Set new.
- self classesInHierarchy:aClass do:[:c |
- |searchCategory|
-
- (aCategory = '* all *') ifTrue:[
- newList addAll:(c selectorArray)
- ] ifFalse:[
- (aCategory = '* no category *') ifTrue:[
- searchCategory := nil
- ] ifFalse:[
- searchCategory := aCategory
- ].
- c methodArray with:c selectorArray do:[:aMethod :selector |
- (aMethod category = searchCategory) ifTrue:[
- newList add:selector
- ]
- ]
- ].
- ].
- (newList size == 0) ifTrue:[^ nil].
- ^ newList asOrderedCollection sort
-!
-
-listOfAllMethodCategoriesInHierarchy:aClass
- "answer a list of all method categories of the argument, aClass,
- and all of its superclasses"
-
- |newList cat|
-
- newList := OrderedCollection new.
- self classesInHierarchy:aClass do:[:c |
- c methodArray do:[:aMethod |
- cat := aMethod category.
- cat isNil ifTrue:[
- cat := '* no category *'
- ].
- (newList includes:cat) ifFalse:[newList add:cat]
- ]
- ].
- (newList size == 0) ifTrue:[^ nil].
- newList add:'* all *'.
- ^ newList sort
-
-! !
-
-!SystemBrowser methodsFor:'class stuff'!
-
-switchToClass:newClass
- fullProtocol ifTrue:[^ self].
- currentClass notNil ifTrue:[
- currentClass removeDependent:self
- ].
- currentClass := newClass.
- currentClass notNil ifTrue:[
- currentClass addDependent:self.
- ].
- self normalLabel
-!
-
-classSelectionChanged
- |oldMethodCategory oldMethod oldSelector|
-
- self withWaitCursorDo:[
- oldMethodCategory := currentMethodCategory.
- oldMethod := currentMethod.
- oldSelector := currentSelector.
-
- showInstance ifTrue:[
- actualClass := acceptClass := currentClass
- ] ifFalse:[
- actualClass := acceptClass := currentClass class
- ].
- currentMethodCategory := nil.
- currentMethod := nil.
- currentSelector := nil.
-
- self updateVariableList.
- self updateMethodCategoryList.
-
- oldMethodCategory notNil ifTrue:[
- methodCategoryListView selectElement:oldMethodCategory.
- methodCategoryListView hasSelection ifTrue:[
- currentMethodCategory := oldMethodCategory.
- self methodCategorySelectionChanged
- ]
- ].
- self updateMethodList.
- self updateCodeView.
-
- fullClass ifTrue:[
- codeView acceptAction:[:theCode |
- codeView cursor:Cursor execute.
- Object abortSignal catch:[
- self compileCode:theCode asString.
- codeView modified:false.
- ].
- codeView cursor:Cursor normal.
- ].
- ] ifFalse:[
- self classDefinition.
- codeView acceptAction:[:theCode |
- codeView cursor:Cursor execute.
- Object abortSignal catch:[
- (Compiler evaluate:theCode asString notifying:codeView compile:false)
- isBehavior ifTrue:[
- self classCategoryUpdate.
- self updateClassListWithScroll:false.
- codeView modified:false.
- ].
- ].
- codeView cursor:Cursor normal.
- ].
- ].
- codeView explainAction:nil.
-
- classCategoryListView notNil ifTrue:[
- (currentClassCategory = currentClass category) ifFalse:[
- currentClassCategory := currentClass category.
- classCategoryListView selectElement:currentClassCategory
- ]
- ].
-
- self setDoitActionForClass
- ]
-!
-
-updateClassListWithScroll:scroll
- |classes oldClassName|
-
- classListView notNil ifTrue:[
- "
- refetch in case we are not up to date
- "
- (currentClass notNil and:[fullProtocol not]) ifTrue:[
- oldClassName := currentClass name.
- currentClass := Smalltalk at:(oldClassName asSymbol).
- ].
-
- currentClassCategory notNil ifTrue:[
- classes := self listOfAllClassesInCategory:currentClassCategory
- ] ifFalse:[
- currentClassHierarchy notNil ifTrue:[
- classes := self listOfClassHierarchyOf:currentClassHierarchy
- ]
- ].
-
- classListView list = classes ifFalse:[
- scroll ifTrue:[
- classListView contents:classes
- ] ifFalse:[
- classListView setContents:classes
- ].
- oldClassName notNil ifTrue:[
- classListView setContents:classes.
- classListView selectElement:oldClassName
- ] ifFalse:[
- variableListView notNil ifTrue:[variableListView contents:nil]
- ]
- ].
- scroll ifTrue:[
- fullProtocol ifTrue:[
- classListView scrollToBottom
- ]
- ]
- ]
-!
-
-classSelection:lineNr
- "user clicked on a class line - show method categories"
-
- |classSymbol cls oldSelector|
-
- (currentClassHierarchy notNil
- and:[fullProtocol]) ifTrue:[
- oldSelector := currentSelector.
-
- self updateMethodCategoryListWithScroll:false.
- self updateMethodListWithScroll:false.
- self updateVariableList.
- ^ self
- ].
-
- cls := Smalltalk classNamed:classListView selectionValue withoutSpaces.
-"
- classSymbol := classListView selectionValue withoutSpaces asSymbol.
- (Smalltalk includesKey:classSymbol) ifTrue:[
- cls := Smalltalk at:classSymbol
- ].
-"
- cls notNil ifTrue:[
- self switchToClass:cls.
- self classSelectionChanged
- ]
-!
-
-listOfAllClassesInCategory:aCategory
- "return a list of all classes in a given category"
-
- |newList classList searchCategory string|
-
- newList := OrderedCollection new.
- (aCategory = '* all *') ifTrue:[
- Smalltalk allBehaviorsDo:[:aClass |
- string := aClass name.
- newList indexOf:string ifAbsent:[newList add:string]
- ]
- ] ifFalse:[
- (aCategory = '* hierarchy *') ifTrue:[
- classList := OrderedCollection new.
- self classHierarchyDo:[:aClass :lvl|
- string := aClass name.
- classList indexOf:string ifAbsent:[
- classList add:string.
- newList add:(String new:lvl) , string
- ]
- ].
- ^ newList
- ] ifFalse:[
- (aCategory = '* no category *') ifTrue:[
- searchCategory := nil
- ] ifFalse:[
- searchCategory := aCategory
- ].
- Smalltalk allBehaviorsDo:[:aClass |
- aClass isMeta ifFalse:[
- (aClass category = searchCategory) ifTrue:[
- string := aClass name.
- newList indexOf:string ifAbsent:[newList add:string]
- ]
- ]
- ]
- ]
- ].
- (newList size == 0) ifTrue:[^ nil].
- ^ newList sort
-!
-
-doClassMenu:aBlock
- "a helper - check if class is selected and evaluate aBlock
- while showing waitCursor"
-
- self checkClassSelected ifTrue:[
- self withWaitCursorDo:[aBlock value:currentClass]
- ]
-!
-
-checkClassSelected
- "warn and return false, if no class is selected"
-
- currentClass isNil ifTrue:[
- self warn:'select a class first'.
- ^ false
- ].
- ^ true
-!
-
-updateClassList
- self updateClassListWithScroll:true
-!
-
-listOfClassHierarchyOf:aClass
- "return a hierarchy class-list"
-
- |startClass classes thisOne|
-
- showInstance ifTrue:[
- startClass := aClass
- ] ifFalse:[
- startClass := aClass class.
- ].
- classes := startClass allSuperclasses.
- thisOne := Array with:startClass.
-
- classes notNil ifTrue:[
- classes := classes reverse , thisOne.
- ] ifFalse:[
- classes := thisOne
- ].
-
- fullProtocol ifFalse:[
- classes := classes , startClass allSubclassesInOrder
- ].
- ^ classes collect:[:c | c name]
-!
-
-templateFor:className in:cat
- "return a class definition template - be smart in what is offered initially"
-
- |aString name i|
-
- name := 'NewClass'.
- i := 1.
- [name knownAsSymbol and:[Smalltalk includesKey:name asSymbol]] whileTrue:[
- i := i + 1.
- name := 'NewClass' , i printString
- ].
-
- aString := className , ' subclass:#' , name , '
- instanceVariableNames: ''''
- classVariableNames: ''''
- poolDictionaries: ''''
- category: '''.
-
- cat notNil ifTrue:[
- aString := aString , cat
- ].
- aString := aString , '''
-
-
-
-
-
-"
- Replace ''' , className , ''', ''', name , ''' and
- the empty string arguments by true values.
-
- Install (or change) the class by ''accepting'',
- either via the menu or the keyboard (usually CMD-A).
-
- To be nice to others (and yourself later), do not forget to
- add some documentation; either under the classes documentation
- protocol, or as a class comment.
-"
-'.
- ^ aString
-!
-
-classClassDefinitionTemplateFor:name in:cat
- "common helper for newClass and newSubclass
- - show a template to define class name in category cat.
- Also, set acceptaction to install the class."
-
- currentMethodCategory := nil.
- currentMethod := currentSelector := nil.
-
- classListView deselect.
-
- fullClass ifFalse:[
- methodCategoryListView contents:nil.
- methodListView contents:nil
- ].
-
- codeView contents:(self templateFor:name in:cat).
- codeView modified:false.
-
- codeView acceptAction:[:theCode |
- codeView cursor:Cursor execute.
- Object abortSignal catch:[
- |cls|
-
- cls := (Compiler evaluate:theCode asString notifying:codeView compile:false).
- cls isBehavior ifTrue:[
- codeView modified:false.
- self classCategoryUpdate.
- self updateClassListWithScroll:false.
- self switchToClassNamed:(cls name).
- ]
- ].
- codeView cursor:(Cursor normal).
- ].
- codeView explainAction:nil.
- self switchToClass:nil
-!
-
-renameCurrentClassTo:aString
- "helper - do the rename"
-
- self doClassMenu:[:currentClass |
- |oldName oldSym newSym|
-
- oldName := currentClass name.
- oldSym := oldName asSymbol.
-"
- currentClass setName:aString.
- newSym := aString asSymbol.
- Smalltalk at:oldSym put:nil.
- Smalltalk removeKey:oldSym.
- Smalltalk at:newSym put:currentClass.
-"
-"
- currentClass renameTo:aString.
-"
- Smalltalk renameClass:currentClass to:aString.
-
- self updateClassList.
- self updateMethodCategoryListWithScroll:false.
- self updateMethodListWithScroll:false.
- self withWaitCursorDo:[
- Transcript showCr:('searching for users of ' , oldSym); endEntry.
- self class browseReferendsOf:oldSym warnIfNone:false
- ]
- ]
-!
-
-switchToClassNamed:aString
- |classSymbol theClass newCat|
-
- classSymbol := aString asSymbolIfInterned.
- classSymbol isNil ifTrue:[^ self].
-
- theClass := Smalltalk at:classSymbol.
- theClass isBehavior ifTrue:[
- classCategoryListView notNil ifTrue:[
- currentClassHierarchy isNil ifTrue:[
- ((newCat := theClass category) ~= currentClassCategory) ifTrue:[
- currentClassCategory := newCat.
- newCat isNil ifTrue:[
- classCategoryListView selectElement:'* no category *'
- ] ifFalse:[
- classCategoryListView selectElement:newCat.
- ].
- "/ classCategoryListView makeSelectionVisible.
- ]
- ]
- ].
- self updateClassList.
- self switchToClass:theClass.
- classListView selectElement:aString.
- self classSelectionChanged
- ]
-!
-
-switchToClassNameMatching:aMatchString
- |classNames thisName box|
-
- classNames := OrderedCollection new.
- Smalltalk allBehaviorsDo:[:aClass |
- thisName := aClass name.
- (aMatchString match:thisName) ifTrue:[
- classNames add:thisName
- ]
- ].
- (classNames size == 0) ifTrue:[^ nil].
- (classNames size == 1) ifTrue:[
- ^ self switchToClassNamed:(classNames at:1)
- ].
-
- box := self listBoxTitle:'select class to switch to:'
- okText:'ok'
- list:classNames sort.
- box action:[:aString | self switchToClassNamed:aString].
- box showAtPointer
-! !
-
-!SystemBrowser methodsFor:'variable stuff'!
-
-updateVariableList
- |l subList last nameAccessSelector class oldSelection|
-
- variableListView isNil ifTrue:[^ self].
-
- oldSelection := variableListView selectionValue.
-
- l := OrderedCollection new.
- "
- show classVars, if classProtocol is shown (instead of classInstance vars)
- "
- showInstance ifTrue:[
- nameAccessSelector := #instVarNames
- ] ifFalse:[
- nameAccessSelector := #classVarNames
- ].
-
-"/ class := currentClass notNil ifTrue:[currentClass] ifFalse:[actualClass].
-"/ class isNil ifTrue:[class := currentClassHierarchy].
-class := currentClassHierarchy notNil ifTrue:[currentClassHierarchy] ifFalse:[currentClass].
- class withAllSuperclasses do:[:aClass |
- |ignore|
-
- ignore := fullProtocol
- and:[classListView valueIsInSelection:(aClass name asString)].
- ignore ifFalse:[
- subList := aClass perform:nameAccessSelector.
- subList size ~~ 0 ifTrue:[
- l := l , (subList asOrderedCollection reverse).
- l := l , (OrderedCollection with:'---- ' , aClass name , ' ---------').
- ]
- ]
- ].
- l reverse.
- variableListView setAttributes:nil.
- variableListView list:l.
- l keysAndValuesDo:[:index :entry |
- (entry startsWith:'---') ifTrue:[
- variableListView attributeAt:index put:#disabled.
- last := index
- ]
- ].
- last notNil ifTrue:[variableListView scrollToLine:last].
-
- oldSelection notNil ifTrue:[
- variableListView selectElement:oldSelection.
- self hilightMethodsInMethodCategoryList:true inMethodList:true.
- ]
-!
-
-unhilightMethods
- "unhighlight items in method list"
-
- variableListView isNil ifTrue:[^ self].
-
- methodListView notNil ifTrue:[
- 1 to:methodListView list size do:[:entry |
- methodListView attributeAt:entry put:nil.
- ].
- ].
-
-
-!
-
-hilightMethodsInMethodCategoryList:inCat inMethodList:inMethods
- "search for methods which access the selected
- variable, and highlight them"
-
- |name redefinedSelectors|
-
- variableListView isNil ifTrue:[^ self].
-
- inCat ifTrue:[self unhilightMethodCategories].
- inMethods ifTrue:[self unhilightMethods].
-
- actualClass isNil ifTrue:[^ self].
- (methodCategoryListView isNil
- and:[methodListView isNil]) ifTrue:[^ self].
-
- name := variableListView selectionValue.
- name isNil ifTrue:[^ self].
-
- self withCursor:(Cursor questionMark) do:[
- |classes filter any|
-
- classes := Array with:actualClass.
- currentClassHierarchy notNil ifTrue:[
- classes := classes , actualClass allSuperclasses.
- redefinedSelectors := IdentitySet new.
- ].
-
- showInstance ifTrue:[
- filter := self class filterToSearchInstRefsTo:name modificationsOnly:false
- ] ifFalse:[
- filter := self class filterToSearchClassRefsTo:name modificationsOnly:false
- ].
-
- any := false.
- "
- highlight the method that ref this variable
- "
- classes do:[:someClass |
- (fullProtocol
- and:[classListView valueIsInSelection:(someClass name)]) ifFalse:[
- someClass methodArray with:someClass selectorArray
- do:[:method :selector |
-
- (inCat
- or:[methodListView list notNil
- and:[methodListView list includes:selector]])
- ifTrue:[
- (redefinedSelectors isNil
- or:[(redefinedSelectors includes:selector) not])
- ifTrue:[
- (filter value:someClass value:method value:selector) ifTrue:[
- |idx cat|
-
- (inCat
- and:[methodCategoryListView notNil
- and:[methodCategoryListView list notNil]]) ifTrue:[
- cat := method category.
- "
- highlight the methodCategory
- "
- idx := methodCategoryListView list indexOf:cat.
- idx ~~ 0 ifTrue:[
- methodCategoryListView attributeAt:idx put:#bold.
- ].
- ].
-
- (inMethods
- and:[methodListView notNil
- and:[methodListView list notNil]]) ifTrue:[
- "
- highlight the method
- "
- idx := methodListView list indexOf:selector.
- idx ~~ 0 ifTrue:[
- methodListView attributeAt:idx put:#bold.
- ].
- any := true
- ].
- ].
- redefinedSelectors notNil ifTrue:[
- redefinedSelectors add:selector
- ]
- ]
- ]
- ]
- ]
- ].
- any ifTrue:[
- self setSearchPattern:name
- ]
- ]
-!
-
-hilightMethodsInMethodCategoryList
- "search for methods which access the selected
- variable, and highlight them"
-
- self hilightMethodsInMethodCategoryList:true inMethodList:false
-
-
-
-!
-
-unhilightMethodCategories
- "unhighlight items in method list"
-
- variableListView isNil ifTrue:[^ self].
-
- methodCategoryListView notNil ifTrue:[
- 1 to:methodCategoryListView list size do:[:entry |
- methodCategoryListView attributeAt:entry put:nil.
- ]
- ].
-
-
-!
-
-hilightMethodsInMethodList
- "search for methods which access the selected
- variable, and highlight them"
-
- self hilightMethodsInMethodCategoryList:false inMethodList:true
-
+showNoneFound
+ DialogView warn:(BrowserView classResources string:'None found').
! !
-!SystemBrowser methodsFor:'class list menu'!
-
-classDefinition
- "show class definition in codeView and setup accept-action for
- a class-definition change.
- Extract documentation either from a documentation method or
- from the comment - not a biggy, but beginners will like
- it when exploring the system."
-
- self doClassMenu:[:currentClass |
- |m s aStream isComment|
-
- aStream := WriteStream on:(String new:200).
- currentClass fileOutDefinitionOn:aStream.
-
- currentClass isLoaded ifTrue:[
- "
- add documentation as a comment, if there is any
- "
- m := currentClass class compiledMethodAt:#documentation.
- m notNil ifTrue:[
- s := m comment.
- isComment := false.
- ] ifFalse:[
- "try comment"
- s := currentClass comment.
- s notNil ifTrue:[
- isComment := true
- ]
- ].
- ].
- s notNil ifTrue:[
- aStream cr.
- aStream cr.
- aStream cr.
- aStream cr.
- aStream cr.
- aStream nextPut:$" ; cr; nextPutAll:' Documentation:'; cr.
- aStream cr.
- aStream nextPutAll:s.
- aStream cr; cr.
- aStream nextPutAll:' Notice: '; cr.
- aStream nextPutAll:' the above string has been extracted from the classes '.
- aStream nextPutAll:(isComment ifTrue:['comment.'] ifFalse:['documentation method.']).
- aStream cr.
- aStream nextPutAll:' It will not be preserved when accepting a new class definition.'; cr.
- aStream nextPut:$".
- ].
-
- codeView contents:(aStream contents).
- codeView modified:false.
- codeView acceptAction:[:theCode |
- codeView cursor:Cursor execute.
- Object abortSignal catch:[
- (Compiler evaluate:theCode asString notifying:codeView compile:false)
- isBehavior ifTrue:[
- codeView modified:false.
- self classCategoryUpdate.
- self updateClassListWithScroll:false.
- ]
- ].
- codeView cursor:Cursor normal.
- ].
- codeView explainAction:nil.
-
- methodListView notNil ifTrue:[
- methodListView deselect
- ].
- aspect := #definition.
- self normalLabel
- ]
-!
-
-classMenu
- "sent by classListView to ask for the menu"
-
- |labels selectors|
-
- currentClass isNil ifTrue:[
- labels := #(
- 'new class'
- ).
- selectors := #(
- classNewClass
- ).
- ] ifFalse:[
- fullProtocol ifTrue:[
- labels := #(
- 'hierarchy'
- 'definition'
- 'comment'
- 'class instvars'
- ).
- selectors := #(
- classHierarchy
- classDefinition
- classComment
- classClassInstVars
- ).
- ] ifFalse:[
- labels := #(
- 'fileOut'
- 'printOut'
- 'printOut protocol'
- " 'printOut full protocol' "
- '-'
- 'SPAWN_CLASS'
- 'spawn full protocol'
- 'spawn hierarchy'
- 'spawn subclasses'
- '-'
- ).
- selectors := #(
- classFileOut
- classPrintOut
- classPrintOutProtocol
- " classPrintOutFullProtocol "
- nil
- classSpawn
- classSpawnFullProtocol
- classSpawnHierarchy
- classSpawnSubclasses
- nil
- ).
-
- fullClass ifFalse:[
- labels := labels , #(
- 'hierarchy'
- 'definition'
- 'comment'
- 'class instvars'
- "/ 'protocols'
- '-'
- ).
- selectors := selectors , #(
- classHierarchy
- classDefinition
- classComment
- classClassInstVars
- "/ classProtocols
- nil
- ).
- ].
-
- "
- dont offer this menu for now - you cannot recompile
- the stuff anyway. So there is only confusion in showing
- those ...
- "
- false "currentClass primitiveSpec notNil" ifTrue:[
- labels := labels , #(
- 'primitive definitions'
- 'primitive variables'
- 'primitive functions'
- '-'
- ).
- selectors := selectors , #(
- classPrimitiveDefinitions
- classPrimitiveVariables
- classPrimitiveFunctions
- nil
- ).
- ].
-
- labels := labels , #(
- "/ 'variable search'
- 'class refs'
- '-'
- 'new class'
- 'new subclass'
- 'rename ...'
- 'remove'
- ).
- selectors := selectors , #(
- "/ variables
- classRefs
- nil
- classNewClass
- classNewSubclass
- classRename
- classRemove
- ).
- ]
- ].
-
-
- ^ PopUpMenu labels:(resources array:labels)
- selectors:selectors
- receiver:self
- for:classListView.
-!
-
-classFileOut
- "fileOut the current class.
- Catch errors (sure, you like to know if it failed) and
- warn if any)"
-
- self doClassMenu:[:currentClass |
- self busyLabel:'saving %1' with:currentClass name.
- Class fileOutErrorSignal handle:[:ex |
- self warn:'cannot create: %1' with:ex parameter.
- ex return.
- ] do:[
- currentClass fileOut.
- ].
- self normalLabel.
- ]
-!
-
-doClassMenuWithSelection:aBlock
- "a helper - if there is a selection, which represents a classes name,
- evaluate aBlock, passing that class and optional selector as arguments.
- Otherwise, check if a class is selected and evaluate aBlock with the
- current class."
-
- |string words clsName cls sel isMeta|
-
- string := codeView selection.
- string notNil ifTrue:[
- self extractClassAndSelectorFromSelectionInto:[:c :s :m |
- clsName := c.
- sel := s.
- isMeta := m.
- ].
- clsName isNil ifTrue:[
- string := string asString withoutSeparators.
- words := string asCollectionOfWords.
- words notNil ifTrue:[
- clsName := words first.
- (clsName endsWith:'class') ifTrue:[
- isMeta := true.
- clsName := clsName copyTo:(clsName size - 5)
- ] ifFalse:[
- isMeta := false
- ].
- sel := Parser selectorInExpression:string.
- ]
- ].
- clsName notNil ifTrue:[
- (cls := Smalltalk classNamed:clsName) notNil ifTrue:[
- isMeta ifTrue:[
- cls := cls class
- ].
- self withWaitCursorDo:[
- aBlock value:cls value:sel.
- ].
- ^ self
- ] ifFalse:[
- self warn:'no class named: %1 - spawning current' with:clsName
- ]
- ].
- ].
-
- classMethodListView notNil ifTrue:[
- sel := classMethodListView selectionValue.
- sel notNil ifTrue:[
- sel := self selectorFromClassMethodString:sel
- ]
- ].
- self doClassMenu:[:currentClass | aBlock value:currentClass value:sel]
-!
-
-classSpawn
- "create a new SystemBrowser browsing current class,
- or if there is a selection, spawn a browser on the selected class
- even a class/selector pair can be specified."
-
- self doClassMenuWithSelection:[:cls :sel |
- |browser|
-
- cls isMeta ifTrue:[
- Smalltalk allBehaviorsDo:[:aClass |
- aClass class == cls ifTrue:[
- browser := self class browseClass:aClass.
- browser classProtocol.
- sel notNil ifTrue:[
- browser switchToMethodNamed:sel
- ].
- ^ self
- ].
- ].
- self warn:'oops, no class for this metaclass'.
- ^ self
- ].
- browser := self class browseClass:cls.
- cls hasMethods ifFalse:[
- browser classProtocol.
- ].
- sel notNil ifTrue:[
- browser switchToMethodNamed:sel
- ].
- ]
-
- "
- select 'Smalltalk allClassesDo:' and use spawn from the class menu
- select 'Smalltalk' and use spawn from the class menu
- "
-!
-
-classSpawnHierarchy
- "create a new HierarchyBrowser browsing current class"
-
- self doClassMenuWithSelection:[:cls :sel |
- self class browseClassHierarchy:cls
- ]
-!
-
-classSpawnSubclasses
- "create a new browser browsing current class's subclasses"
-
- self doClassMenuWithSelection:[:cls :sel |
- |subs|
-
- subs := cls allSubclasses.
- (subs notNil and:[subs size ~~ 0]) ifTrue:[
- self class browseClasses:subs title:('subclasses of ' , cls name)
- ]
- ]
-!
-
-classPrintOutFullProtocol
- self doClassMenu:[:currentClass |
- |printStream|
-
- printStream := Printer new.
- currentClass printOutFullProtocolOn:printStream.
- printStream close
- ]
-!
-
-classPrintOutProtocol
- self doClassMenu:[:currentClass |
- |printStream|
-
- printStream := Printer new.
- currentClass printOutProtocolOn:printStream.
- printStream close
- ]
-!
-
-classPrintOut
- self doClassMenu:[:currentClass |
- |printStream|
-
- printStream := Printer new.
- currentClass printOutOn:printStream.
- printStream close
- ]
-!
-
-classHierarchy
- "show current classes hierarchy in codeView"
-
- self doClassMenu:[:currentClass |
- |aStream|
-
- aStream := WriteStream on:(String new:200).
- actualClass printHierarchyOn:aStream.
- codeView contents:(aStream contents).
- codeView modified:false.
- codeView acceptAction:nil.
- codeView explainAction:nil.
- methodListView notNil ifTrue:[
- methodListView deselect
- ].
- aspect := #hierarchy.
- self normalLabel
- ]
-!
-
-classNewClass
- "create a class-definition prototype in codeview"
-
- |nm cat|
-
- currentClass notNil ifTrue:[
- nm := currentClass superclass name
- ] ifFalse:[
- nm := 'Object'
- ].
- cat := currentClassCategory.
- cat isNil ifTrue:[
- cat := 'no category'
- ].
- self classClassDefinitionTemplateFor:nm in:cat.
- aspect := nil.
-!
-
-classClassInstVars
- "show class instance variables in codeView and setup accept-action
- for a class-instvar-definition change"
-
- self doClassMenu:[:currentClass |
- |s|
-
- s := WriteStream on:(String new).
- currentClass fileOutClassInstVarDefinitionOn:s.
- codeView contents:(s contents).
- codeView modified:false.
- codeView acceptAction:[:theCode |
- codeView cursor:Cursor execute.
- Object abortSignal catch:[
- Compiler evaluate:theCode asString notifying:codeView compile:false.
- codeView modified:false.
- self updateClassList.
- ].
- codeView cursor:Cursor normal.
- ].
- codeView explainAction:nil.
- methodListView notNil ifTrue:[
- methodListView deselect
- ].
- aspect := #classInstVars.
- self normalLabel
- ]
-!
-
-classSpawnFullProtocol
- "create a new browser, browsing current classes full protocol"
-
- self doClassMenuWithSelection:[:cls :sel |
- self class browseFullClassProtocol:cls
- ]
-!
-
-classProtocols
- ^ self
-!
-
-classRemove
- "user requested remove of current class and all subclasses -
- count subclasses and let user confirm removal."
-
- |count t box|
-
- currentClass notNil ifTrue:[
- count := currentClass allSubclasses size.
- t := 'remove %1'.
- count ~~ 0 ifTrue:[
- t := t , '\(with %2 subclass'.
- count ~~ 1 ifTrue:[
- t := t , 'es'
- ].
- t := (t , ')')
- ].
- t := t , ' ?'.
- t := (resources string:t with:currentClass name with:count) withCRs.
-
- box := YesNoBox
- title:t
- yesText:(resources at:'remove')
- noText:(resources at:'abort').
- box confirm ifTrue:[
- "after querying user - do really remove current class
- and all subclasses
- "
- self doClassMenu:[:currentClass |
- |didRemove|
-
- didRemove := false.
-
- "
- query ?
- "
- currentClass allSubclassesDo:[:aSubClass |
- (CheckForInstancesWhenRemovingClasses not
- or:[aSubClass hasInstances not
- or:[self confirm:(aSubClass name , ' has instances - remove anyway ?')]])
- ifTrue:[
- Smalltalk removeClass:aSubClass
- ]
- ].
- (CheckForInstancesWhenRemovingClasses not
- or:[currentClass hasInstances not
- or:[self confirm:(currentClass name , ' has instances - remove anyway ?')]])
- ifTrue:[
- didRemove := true.
- Smalltalk removeClass:currentClass.
- ].
-
- self switchToClass:nil.
- Smalltalk changed.
- self updateClassList.
-
- "if it was the last in its category, update class category list"
-"
- classListView numberOfLines == 0 ifTrue:[
- self updateClassCategoryListWithScroll:false
- ].
-"
- didRemove ifTrue:[
- methodCategoryListView notNil ifTrue:[methodCategoryListView contents:nil].
- methodListView notNil ifTrue:[methodListView contents:nil].
- codeView contents:nil.
- codeView modified:false
- ]
- ]
- ]
- ]
-!
-
-classShowFrom:getSelector set:setSelector aspect:aspectSymbol
- "common helper for comment, primitive-stuff etc.
- show the string returned from the classes getSelector-method,
- Set acceptaction to change it via setSelector."
-
- self doClassMenu:[:currentClass |
- codeView contents:(currentClass perform:getSelector).
- codeView modified:false.
- codeView acceptAction:[:theCode |
- Object abortSignal catch:[
- lockUpdates := true.
- currentClass perform:setSelector with:theCode asString.
- codeView modified:false.
- ].
- lockUpdates := false.
- ].
- codeView explainAction:nil.
-
- methodListView notNil ifTrue:[
- methodListView deselect
- ].
- aspect := aspectSymbol.
- self normalLabel
- ]
-!
-
-classComment
- "show the classes comment in the codeView.
- Also, set acceptaction to change the comment."
-
- self classShowFrom:#comment set:#comment: aspect:#comment
-!
-
-classPrimitiveDefinitions
- "show the classes primitiveDefinition in the codeView.
- Also, set acceptaction to change it."
-
- self classShowFrom:#primitiveDefinitionsString set:#primitiveDefinitions: aspect:#primitiveDefinitions
-!
-
-classPrimitiveVariables
- "show the classes primitiveVariables in the codeView.
- Also, set acceptaction to change it."
-
- self classShowFrom:#primitiveVariablesString set:#primitiveVariables: aspect:#primitiveVariables
-!
-
-classPrimitiveFunctions
- "show the classes primitiveFunctions in the codeView.
- Also, set acceptaction to change it."
-
- self classShowFrom:#primitiveFunctionsString set:#primitiveFunctions: aspect:#primitiveFunctions
-!
-
-classRefs
- self doClassMenu:[:currentClass |
- self withCursor:(Cursor questionMark) do:[
- self class browseReferendsOf:currentClass name asSymbol
- ]
- ]
-!
-
-classNewSubclass
- "create a subclass-definition prototype in codeview"
-
- self doClassMenu:[:currentClass |
- self classClassDefinitionTemplateFor:(currentClass name)
- in:(currentClass category).
- aspect := nil
- ]
-!
-
-classUses
- "a powerful tool, when trying to learn more about where
- a class is used. This one searches all uses of a class,
- and shows a list of uses - try it and like it"
-
- self doClassMenu:[:currentClass |
- self withCursor:(Cursor questionMark) do:[
- self class browseUsesOf:currentClass
- ]
- ]
-!
-
-classRename
- "launch an enterBox for new name and query user"
-
- |box|
-
- self checkClassSelected ifFalse:[^ self].
- box := self enterBoxTitle:(resources string:'rename %1 to:' with:currentClass name) okText:'rename'.
- box initialText:(currentClass name).
- box action:[:aString | self renameCurrentClassTo:aString].
- box showAtPointer
-! !
-
-!SystemBrowser methodsFor:'class category stuff'!
-
-checkClassCategorySelected
- currentClassCategory isNil ifTrue:[
- self warn:'select a class category first'.
- ^ false
- ].
- ^ true
-!
-
-listOfAllClassCategories
- "return a list of all class categories"
-
- |newList cat|
-
- newList := OrderedCollection with:'* all *' with:'* hierarchy *'.
- Smalltalk allBehaviorsDo:[:aClass |
- cat := aClass category.
- cat isNil ifTrue:[
- cat := '* no category *'
- ].
- newList indexOf:cat ifAbsent:[newList add:cat]
- ].
- ^ newList asArray sort.
-!
-
-classCategorySelectionChanged
- "class category has changed - update dependent views"
-
- self withWaitCursorDo:[
- self switchToClass:nil.
- actualClass := acceptClass := nil.
- currentMethodCategory := nil.
- currentMethod := currentSelector := nil.
-
- self updateClassList.
- self updateMethodCategoryList.
- self updateMethodList.
- self updateCodeView.
-
- codeView explainAction:nil.
- codeView acceptAction:nil
- ]
-!
-
-classCategorySelection:lineNr
- "user clicked on a class category line - show classes.
- If switching to hierarchy or all, keep current selections"
-
- |newCategory oldClass oldName classIndex|
-
- newCategory := classCategoryListView selectionValue.
- (newCategory startsWith:'*') ifTrue:[
- "etiher all or hierarchy;
- remember current selections and switch after showing class list"
- oldClass := currentClass
- ].
- currentClassCategory := newCategory.
- oldClass isNil ifTrue:[
- self classCategorySelectionChanged
- ] ifFalse:[
- oldName := oldClass name.
- self withWaitCursorDo:[
- self updateClassList
- ].
- "stupid - search for class name in (indented) list"
- classIndex := classListView list findFirst:[:elem | elem endsWith:oldName].
- classIndex ~~ 0 ifTrue:[
- classListView selection:classIndex.
- self switchToClass:(Smalltalk at:(oldName asSymbol))
- ] ifFalse:[
- self normalLabel.
- ]
- ]
-!
-
-updateClassCategoryListWithScroll:scroll
- |oldClassCategory oldClass oldMethodCategory oldMethod
- oldSelector newCategoryList|
-
- classMethodListView notNil ifTrue:[ ^ self ].
-
- oldClassCategory := currentClassCategory.
- oldClass := currentClass.
- oldMethodCategory := currentMethodCategory.
- oldMethod := currentMethod.
- oldMethod notNil ifTrue:[
- oldSelector := currentSelector
- ].
-
- classCategoryListView notNil ifTrue:[
- newCategoryList := self listOfAllClassCategories.
- newCategoryList = classCategoryListView list ifFalse:[
- scroll ifTrue:[
- classCategoryListView contents:newCategoryList
- ] ifFalse:[
- classCategoryListView setContents:newCategoryList
- ]
- ]
- ].
-
- oldClassCategory notNil ifTrue:[
- classCategoryListView notNil ifTrue:[
- classCategoryListView selectElement:oldClassCategory
- ]
- ].
- classListView notNil ifTrue:[
- oldClass notNil ifTrue:[
- classListView selectElement:(oldClass name)
- ]
- ].
- oldMethodCategory notNil ifTrue:[
- methodCategoryListView notNil ifTrue:[
- methodCategoryListView selectElement:oldMethodCategory
- ].
- ].
- oldSelector notNil ifTrue:[
- methodListView notNil ifTrue:[
- methodListView selectElement:oldSelector
- ].
- ]
-!
-
-updateClassCategoryList
- self updateClassCategoryListWithScroll:true
-!
-
-allClassesInCurrentCategoryInOrderDo:aBlock
- "evaluate aBlock for all classes in the current class category;
- superclasses come first - then subclasses"
-
- |classes|
-
- currentClassCategory notNil ifTrue:[
- classes := OrderedCollection new.
- Smalltalk allBehaviorsDo:[:aClass |
- aClass isMeta ifFalse:[
- (aClass category = currentClassCategory) ifTrue:[
- classes add:aClass
- ]
- ]
- ].
- classes topologicalSort:[:a :b | b isSubclassOf:a].
- classes do:aBlock
- ]
-!
-
-allClassesInCurrentCategoryDo:aBlock
- "evaluate aBlock for all classes in the current class category;
- superclasses come first - then subclasses"
-
- currentClassCategory notNil ifTrue:[
- Smalltalk allBehaviorsDo:[:aClass |
- aClass isMeta ifFalse:[
- (aClass category = currentClassCategory) ifTrue:[
- aBlock value:aClass
- ]
- ]
- ].
- ]
-!
-
-renameCurrentClassCategoryTo:aString
- "helper - do the rename"
-
- |any categories|
-
- currentClassCategory notNil ifTrue:[
- any := false.
- Smalltalk allBehaviorsDo:[:aClass |
- aClass category = currentClassCategory ifTrue:[
- aClass category:aString.
- any := true
- ]
- ].
- any ifFalse:[
- categories := classCategoryListView list.
- categories remove:currentClassCategory.
- categories add:aString.
- categories sort.
- classCategoryListView setContents:categories.
- currentClassCategory := aString.
- classCategoryListView selectElement:aString.
- ] ifTrue:[
- currentClassCategory := aString.
- self updateClassCategoryList.
- self updateClassListWithScroll:false
- ]
- ]
-! !
-
-!SystemBrowser methodsFor:'class-method stuff'!
-
-classFromClassMethodString:aString
- "helper for classMethod-list - extract class name from the string"
-
- |pos|
-
- pos := aString indexOf:(Character space).
- ^ aString copyTo:(pos - 1)
-!
-
-selectorFromClassMethodString:aString
- "helper for classMethod-list - extract selector from the string"
-
- |pos|
-
- pos := aString indexOf:(Character space).
- ^ aString copyFrom:(pos + 1)
-!
-
-classMethodSelection:lineNr
- "user clicked on a class/method line - show code"
-
- |string classString selectorString|
-
- string := classMethodListView selectionValue.
- classString := self classFromClassMethodString:string.
- selectorString := self selectorFromClassMethodString:string.
- ((classString ~= 'Metaclass') and:[classString endsWith:'class']) ifTrue:[
- classString := classString copyTo:(classString size - 5).
- self switchToClass:(Smalltalk at:classString asSymbol).
- actualClass := acceptClass := currentClass class
- ] ifFalse:[
- self switchToClass:(Smalltalk at:classString asSymbol).
- actualClass := acceptClass := currentClass
- ].
- currentClass isNil ifTrue:[
- self warn:'oops class is gone'
- ] ifFalse:[
- currentClassCategory := currentClass category.
- currentSelector := selectorString asSymbol.
- currentMethod := actualClass compiledMethodAt:currentSelector.
- currentMethodCategory := currentMethod category.
-
- self methodSelectionChanged
- ].
-
- self setDoitActionForClass
-! !
-
-!SystemBrowser methodsFor:'class category list menu'!
-
-classCategoryMenu
- |labels selectors|
-
- currentClassCategory isNil ifTrue:[
- labels := #(
- 'spawn full class'
- '-'
- 'update'
- 'find class ...'
- '-'
- 'new class category ...'
- ).
- selectors := #(
- classCategorySpawnFullClass
- nil
- classCategoryUpdate
- classCategoryFindClass
- nil
- classCategoryNewCategory
- ).
- ] ifFalse:[
- labels := #(
- 'fileOut'
- 'fileOut each'
-"
- 'fileOut binary'
-"
- 'printOut'
- 'printOut protocol'
- '-'
- 'SPAWN_CATEGORY'
- 'spawn full class'
- '-'
- 'update'
- 'find class ...'
- '-'
- 'new class category ...'
- 'rename ...'
- 'remove'
- ).
- selectors := #(
- classCategoryFileOut
- classCategoryFileOutEach
- classCategoryPrintOut
- classCategoryPrintOutProtocol
- nil
- classCategorySpawn
- classCategorySpawnFullClass
- nil
- classCategoryUpdate
- classCategoryFindClass
- nil
- classCategoryNewCategory
- classCategoryRename
- classCategoryRemove
- ).
- ].
-
- ^ (PopUpMenu labels:(resources array:labels)
- selectors:selectors
- receiver:self)
-!
-
-classCategoryUpdate
- "update class category list and dependants"
-
- |oldClassName oldMethodCategory|
-
- classCategoryListView notNil ifTrue:[
- currentClass notNil ifTrue:[
- oldClassName := currentClass name.
- (oldClassName endsWith:'-old') ifTrue:[
- oldClassName := oldClassName copyTo:(oldClassName size - 4)
- ]
- ].
- oldMethodCategory := currentMethodCategory.
-
- classCategoryListView setContents:(self listOfAllClassCategories).
- currentClassCategory notNil ifTrue:[
- classCategoryListView selectElement:currentClassCategory.
- self classCategorySelectionChanged.
- oldClassName notNil ifTrue:[
- classListView selectElement:oldClassName.
- self switchToClass:(Smalltalk at:oldClassName asSymbol).
- self classSelectionChanged.
- oldMethodCategory notNil ifTrue:[
- methodCategoryListView selectElement:oldMethodCategory.
- currentMethodCategory := oldMethodCategory.
- self methodCategorySelectionChanged
- ]
- ]
- ]
- ]
-!
-
-classCategoryPrintOutProtocol
- |printStream|
-
- self allClassesInCurrentCategoryInOrderDo:[:aClass |
- printStream := Printer new.
- aClass printOutProtocolOn:printStream.
- printStream close
- ]
-!
-
-classCategoryPrintOut
- |printStream|
-
- self allClassesInCurrentCategoryDo:[:aClass |
- printStream := Printer new.
- aClass printOutOn:printStream.
- printStream close
- ]
-!
-
-classCategorySpawn
- "create a new SystemBrowser browsing current classCategory"
-
- currentClassCategory notNil ifTrue:[
- self withWaitCursorDo:[
- self class browseClassCategory:currentClassCategory
- ]
- ]
-!
-
-classCategoryFileOut
- "create a file 'categoryName' consisting of all classes in current category"
-
- |aStream fileName|
-
- self checkClassCategorySelected ifFalse:[^ self].
-
- fileName := currentClassCategory asString.
- fileName replaceAll:Character space by:$_.
- "
- this test allows a smalltalk to be built without Projects/ChangeSets
- "
- Project notNil ifTrue:[
- fileName := Project currentProjectDirectory , fileName.
- ].
-
- "
- if file exists, save original in a .sav file
- "
- fileName asFilename exists ifTrue:[
- fileName asFilename copyTo:(fileName , '.sav')
- ].
- aStream := FileStream newFileNamed:fileName.
- aStream isNil ifTrue:[
- ^ self warn:'cannot create: %1' with:fileName
- ].
- self withWaitCursorDo:[
- self busyLabel:'writing: %1' with:fileName.
- self allClassesInCurrentCategoryInOrderDo:[:aClass |
- aClass fileOutOn:aStream.
- ].
- aStream close.
- self normalLabel.
- ]
-!
-
-classCategorySpawnFullClass
- "create a new SystemBrowser browsing full class"
-
- |newBrowser|
-
- self withWaitCursorDo:[
- newBrowser := self class browseFullClasses
-" "
- .
- currentClass notNil ifTrue:[
- newBrowser switchToClassNamed:(currentClass name)
- ]
-" "
- ]
-!
-
-classCategoryFileOutEach
- self withWaitCursorDo:[
- self allClassesInCurrentCategoryDo:[:aClass |
- self busyLabel:'saving: ' with:aClass name.
- Class fileOutErrorSignal handle:[:ex |
- self warn:'cannot create: %1' with:ex parameter.
- ex return.
- ] do:[
- aClass fileOut
- ]
- ].
- self normalLabel.
- ]
-!
-
-classCategoryNewCategory
- |box|
-
- box := self enterBoxTitle:'name of new class category:' okText:'create'.
- box action:[:aString |
- |categories|
-
- currentClass notNil ifTrue:[
- categories := OrderedCollection new.
- currentClass withAllSuperclasses do:[:aClass |
- aClass methodArray do:[:aMethod |
- (categories includes:aMethod category) ifFalse:[
- categories add:aMethod category
- ]
- ]
- ].
- ].
- categories isNil ifTrue:[
- categories := classCategoryListView list.
- ].
- (categories includes:aString) ifFalse:[
- categories add:aString.
- categories sort.
- classCategoryListView setContents:categories.
- currentClassCategory := aString.
- classCategoryListView selectElement:aString.
- self switchToClass:nil.
- actualClass := acceptClass := nil.
- self classCategorySelectionChanged
- ]
- ].
- box showAtPointer
-!
-
-classCategoryFindClass
- |box|
-
- box := self enterBoxForCodeSelectionTitle:'class to find:' okText:'find'.
- box action:[:aString | self switchToClassNameMatching:aString].
- box showAtPointer
-!
-
-classCategoryRename
- "launch an enterBox to rename current class category"
-
- |box|
-
- self checkClassCategorySelected ifFalse:[^ self].
-
- box := self enterBoxTitle:'rename class category to:' okText:'rename'.
- box initialText:currentClassCategory.
- box action:[:aString | self renameCurrentClassCategoryTo:aString].
- box showAtPointer
-!
-
-classCategoryRemove
- "remove all classes in current category"
-
- |count t classesToRemove subclassesRemoved box|
-
- self checkClassCategorySelected ifFalse:[^ self].
-
- classesToRemove := OrderedCollection new.
- Smalltalk allBehaviorsDo:[:aClass |
- aClass category = currentClassCategory ifTrue:[
- classesToRemove add:aClass
- ]
- ].
- subclassesRemoved := OrderedCollection new.
- classesToRemove do:[:aClass |
- aClass allSubclassesDo:[:aSubclass |
- (classesToRemove includes:aSubclass) ifFalse:[
- (subclassesRemoved includes:aSubclass) ifFalse:[
- subclassesRemoved add:aSubclass
- ]
- ]
- ]
- ].
-
- count := classesToRemove size.
- t := resources string:'remove %1 ?' with:currentClassCategory.
- count ~~ 0 ifTrue:[
- t := t , (resources at:'\(with ') , count printString.
- count == 1 ifTrue:[
- t := t , (resources at:' class')
- ] ifFalse:[
- t := t , (resources at:' classes')
- ].
- t := (t , ')') withCRs
- ].
-
- count := subclassesRemoved size.
- count ~~ 0 ifTrue:[
- t := t , (resources at:'\(and ') , count printString.
- count == 1 ifTrue:[
- t := t , (resources at:' subclass ')
- ] ifFalse:[
- t := t , (resources at:' subclasses ')
- ].
- t := (t , ')') withCRs
- ].
-
- t := t withCRs.
-
- box := YesNoBox
- title:t
- yesText:(resources at:'remove')
- noText:(resources at:'abort').
- box confirm ifTrue:[
- "after querying user - do really remove classes in list1 and list2"
-
- subclassesRemoved do:[:aClass |
- (CheckForInstancesWhenRemovingClasses not
- or:[aClass hasInstances not
- or:[self confirm:(aClass name , ' has instances - remove anyway ?')]])
- ifTrue:[
- Smalltalk removeClass:aClass
- ]
- ].
- classesToRemove do:[:aClass |
- (CheckForInstancesWhenRemovingClasses not
- or:[aClass hasInstances not
- or:[self confirm:(aClass name , ' has instances - remove anyway ?')]])
- ifTrue:[
- Smalltalk removeClass:aClass
- ].
- ].
- currentClassCategory := nil.
- self switchToClass:nil.
- Smalltalk changed
- ]
-! !
-
-!SystemBrowser methodsFor:'method category list menu'!
-
-methodCategoryMenu
- |labels selectors i|
-
- currentClass isNil ifTrue:[
- methodCategoryListView flash.
- ^ nil
- ].
- currentMethodCategory isNil ifTrue:[
- labels := #(
- 'find method here ...'
- 'find method ...'
- '-'
- 'new category ...'
- 'create access methods'
- ).
- selectors := #(
- methodCategoryFindMethod
- methodCategoryFindAnyMethod
- nil
- methodCategoryNewCategory
- methodCategoryCreateAccessMethods
- ).
- ] ifFalse:[
- labels := #(
- 'fileOut'
- 'fileOut all'
- 'printOut'
- '-'
- 'SPAWN_METHODCATEGORY'
- 'spawn category'
- '-'
- 'find method here ...'
- 'find method ...'
- '-'
- 'new category ...'
- 'copy category ...'
- 'create access methods'
- 'rename ...'
- 'remove'
- ).
- selectors := #(
- methodCategoryFileOut
- methodCategoryFileOutAll
- methodCategoryPrintOut
- nil
- methodCategorySpawn
- methodCategorySpawnCategory
- nil
- methodCategoryFindMethod
- methodCategoryFindAnyMethod
- nil
- methodCategoryNewCategory
- methodCategoryCopyCategory
- methodCategoryCreateAccessMethods
- methodCategoryRename
- methodCategoryRemove
- ).
- ].
-
- showInstance ifFalse:[
- labels := labels copy.
- selectors := selectors copy.
- i := labels indexOf:'create access methods'.
- labels at:i put:'create documentation stubs'.
- selectors at:i put:#methodCategoryCreateDocumentationMethods
- ].
-
- ^ (PopUpMenu labels:(resources array:labels)
- selectors:selectors
- receiver:self)
-!
-
-methodCategoryFindAnyMethod
- |box|
-
- box := self enterBoxForSearchSelectorTitle:'method selector to search for:'.
- box action:[:aString | self switchToAnyMethodNamed:aString].
- box showAtPointer
-!
-
-methodCategoryFindMethod
- |box|
-
- box := self enterBoxForSearchSelectorTitle:'method selector to search for:'.
- box action:[:aString | self switchToMethodNamed:aString].
- box showAtPointer
-!
-
-methodCategoryPrintOut
- |printStream|
-
- self checkClassSelected ifFalse:[^ self].
- self whenMethodCategorySelected:[
- printStream := Printer new.
- actualClass printOutCategory:currentMethodCategory on:printStream.
- printStream close
- ]
-!
-
-methodCategoryFileOut
- "fileOut all methods in the selected methodcategory of
- the current class"
-
- self checkClassSelected ifFalse:[^ self].
- self whenMethodCategorySelected:[
- self busyLabel:'saving: %1' with:currentClass name , '-' , currentMethodCategory.
- Class fileOutErrorSignal handle:[:ex |
- self warn:'cannot create: %1' with:ex parameter.
- ex return.
- ] do:[
- actualClass fileOutCategory:currentMethodCategory.
- ].
- self normalLabel.
- ]
-!
-
-methodCategorySpawn
- "create a new SystemBrowser browsing current method category"
-
- currentMethodCategory notNil ifTrue:[
- self withWaitCursorDo:[
- self class browseClass:actualClass
- methodCategory:currentMethodCategory
- ]
- ]
-!
-
-methodCategoryFileOutAll
- "fileOut all methods in the selected methodcategory of
- the current class"
-
-
- self whenMethodCategorySelected:[
- |fileName outStream|
-
- fileName := currentMethodCategory , '.st'.
- fileName replaceAll:Character space by:$_.
- "
- this test allows a smalltalk to be built without Projects/ChangeSets
- "
- Project notNil ifTrue:[
- fileName := Project currentProjectDirectory , fileName.
- ].
- "
- if file exists, save original in a .sav file
- "
- fileName asFilename exists ifTrue:[
- fileName asFilename copyTo:(fileName , '.sav')
- ].
- outStream := FileStream newFileNamed:fileName.
- outStream isNil ifTrue:[
- ^ self warn:'cannot create: %1' with:fileName
- ].
-
- self busyLabel:'saving: ' with:currentMethodCategory.
- Class fileOutErrorSignal handle:[:ex |
- self warn:'cannot create: %1' with:ex parameter.
- ex return
- ] do:[
- Smalltalk allBehaviorsDo:[:class |
- |hasMethodsInThisCategory|
-
- hasMethodsInThisCategory := false.
- class methodArray do:[:method |
- method category = currentMethodCategory ifTrue:[
- hasMethodsInThisCategory := true
- ]
- ].
- hasMethodsInThisCategory ifTrue:[
- class fileOutCategory:currentMethodCategory on:outStream.
- outStream cr
- ].
- hasMethodsInThisCategory := false.
- class class methodArray do:[:method |
- method category = currentMethodCategory ifTrue:[
- hasMethodsInThisCategory := true
- ]
- ].
- hasMethodsInThisCategory ifTrue:[
- class class fileOutCategory:currentMethodCategory on:outStream.
- outStream cr
- ]
- ].
- ].
- outStream close.
- self normalLabel.
- ].
-!
-
-methodCategoryNewCategory
- "show the enter box to add a new method category.
- Offer existing superclass categories in box to help avoiding
- useless typing."
-
- |someCategories existingCategories box|
-
- actualClass notNil ifTrue:[
- someCategories := actualClass allCategories
- ] ifFalse:[
- "
- mhmh - offer some typical categories ...
- "
- showInstance ifTrue:[
- someCategories := #('accessing'
- 'initialization'
- 'private'
- 'printing & storing'
- 'queries'
- 'testing'
- )
- ] ifFalse:[
- someCategories := #(
- 'documentation'
- 'initialization'
- 'instance creation'
- ).
- ].
- ].
- someCategories sort.
-
- "
- remove existing categories
- "
- existingCategories := methodCategoryListView list.
- existingCategories notNil ifTrue:[
- someCategories := someCategories select:[:cat | (existingCategories includes:cat) not].
- ].
-
- box := self listBoxTitle:'name of new method category:'
- okText:'create'
- list:someCategories.
- box action:[:aString | self newMethodCategory:aString].
- box showAtPointer
-
-
-
-!
-
-methodCategorySpawnCategory
- "create a new SystemBrowser browsing all methods from all
- classes with same category as current method category"
-
- self askAndBrowseMethodCategory:'category to browse methods:'
- action:[:aString |
- self class browseMethodCategory:aString
- ]
-!
-
-methodCategoryCreateAccessMethods
- "create access methods for all instvars"
-
- self checkClassSelected ifFalse:[^ self].
-
- showInstance ifFalse:[
- self warn:'select instance - and try again'.
- ^ self.
- ].
-
- self withWaitCursorDo:[
- |nm names source|
-
- (variableListView notNil
- and:[(nm := variableListView selectionValue) notNil]) ifTrue:[
- names := Array with:nm
- ] ifFalse:[
- names := currentClass instVarNames
- ].
- names do:[:name |
- "check, if method is not already present"
- (currentClass implements:(name asSymbol)) ifFalse:[
- source := (name , '\ "return ' , name , '"\\ ^ ' , name) withCRs.
- Compiler compile:source forClass:currentClass inCategory:'accessing'.
- ] ifTrue:[
- Transcript showCr:'method ''', name , ''' already present'
- ].
- (currentClass implements:((name , ':') asSymbol)) ifFalse:[
- source := (name , ':something\ "set ' , name , '"\\ ' , name , ' := something.') withCRs.
- Compiler compile:source forClass:currentClass inCategory:'accessing'.
- ] ifTrue:[
- Transcript showCr:'method ''', name , ':'' already present'
- ].
- ].
- self updateMethodCategoryListWithScroll:false.
- self updateMethodListWithScroll:false
- ]
-!
-
-methodCategoryCreateDocumentationMethods
- "create empty documentation methods"
-
- |cls|
-
- self checkClassSelected ifFalse:[^ self].
-
- cls := currentClass class.
-
- self withWaitCursorDo:[
- |nm names source|
-
- (cls implements:#version) ifFalse:[
- Compiler compile:
-'version
-"
-$' , 'Header$
-"
-' forClass:cls inCategory:'documentation'.
- ].
- (cls implements:#documentation) ifFalse:[
- Compiler compile:
-'documentation
-"
- documentation to be added.
-"
-' forClass:cls inCategory:'documentation'.
- ].
- (cls implements:#examples) ifFalse:[
- Compiler compile:
-'examples
-"
- examples to be added.
-"
-' forClass:cls inCategory:'documentation'.
- ].
- self classProtocol.
- self switchToMethodNamed:#documentation
-"/ self updateMethodCategoryListWithScroll:false.
-"/ self updateMethodListWithScroll:false
- ]
-!
-
-methodCategoryCopyCategory
- "show the enter box to copy from an existing method category"
-
- |title box|
-
- showInstance ifTrue:[
- title := 'class to copy instance method category from:'
- ] ifFalse:[
- title := 'class to copy class method category from:'
- ].
-
- box := self listBoxTitle:title
- okText:'ok'
- list:(Smalltalk allClasses collect:[:cls | cls name]) asArray sort.
-
- box action:[:aString | self copyMethodsFromClass:aString].
- box showAtPointer
-!
-
-methodCategoryRename
- "launch an enterBox to rename current method category"
-
- |box|
-
- self checkMethodCategorySelected ifFalse:[^ self].
-
- box := self enterBoxTitle:(resources string:'rename method category %1 to:' with:currentMethodCategory)
- okText:(resources at:'rename').
- box initialText:currentMethodCategory.
- box action:[:aString |
- actualClass renameCategory:currentMethodCategory to:aString.
- currentMethodCategory := aString.
- currentMethod := currentSelector := nil.
- self updateMethodCategoryList.
- self updateMethodListWithScroll:false
- ].
- box showAtPointer
-!
-
-methodCategoryRemove
- "show number of methods to remove and query user"
-
- |count t box|
-
- currentMethodCategory notNil ifTrue:[
- count := 0.
- actualClass methodArray do:[:aMethod |
- (aMethod category = currentMethodCategory) ifTrue:[
- count := count + 1
- ]
- ].
- (count == 0) ifTrue:[
- currentMethodCategory := nil.
- currentMethod := currentSelector := nil.
- self updateMethodCategoryListWithScroll:false.
- self updateMethodList
- ] ifFalse:[
- (count == 1) ifTrue:[
- t := 'remove %1\(with 1 method) ?'
- ] ifFalse:[
- t := 'remove %1\(with %2 methods) ?'
- ].
- t := resources string:t with:currentMethodCategory with:count printString.
- t := t withCRs.
-
- box := YesNoBox
- title:t
- yesText:(resources at:'remove')
- noText:(resources at:'abort').
- box confirm ifTrue:[
- actualClass methodArray do:[:aMethod |
- (aMethod category = currentMethodCategory) ifTrue:[
- actualClass
- removeSelector:(actualClass selectorForMethod:aMethod)
- ]
- ].
- currentMethodCategory := nil.
- currentMethod := currentSelector := nil.
- self updateMethodCategoryList.
- self updateMethodList
- ]
- ]
- ]
-! !
-
-!SystemBrowser methodsFor:'method list menu'!
-
-methodMenu
- "return a popupmenu as appropriate for the methodList"
-
- |labels selectors
- newLabels newSelectors
- mthdLabels mthdSelectors
- brkLabels brkSelectors
- fileLabels fileSelectors
- searchLabels searchSelectors
- sepLocalLabels sepLocalSelectors
- localSearchLabels localSearchSelectors|
-
- sepLocalLabels := sepLocalSelectors := #().
-
- searchLabels := #(
- 'senders ...'
- 'implementors ...'
- 'globals ...'
- 'string search ...'
- 'apropos ...'
- ).
- searchSelectors := #(
- methodSenders
- methodImplementors
- methodGlobalReferends
- methodStringSearch
- methodAproposSearch
- ).
-
- currentClass notNil ifTrue:[
- localSearchLabels := #(
- '-'
- 'local senders ...'
- 'local implementors ...'
- 'local string search ...'
- 'local apropos ...'
- ).
- localSearchSelectors := #(
- nil
- methodLocalSenders
- methodLocalImplementors
- methodLocalStringSearch
- methodLocalAproposSearch
- ).
- ] ifFalse:[
- localSearchLabels := localSearchSelectors := #()
- ].
-
- currentMethodCategory notNil ifTrue:[
- sepLocalLabels := #('-'). sepLocalSelectors := #(nil).
-
- newLabels := #(
- 'new method'
- ).
-
- newSelectors := #(
- methodNewMethod
- ).
- ] ifFalse:[
- newLabels := newSelectors := #()
- ].
-
- currentMethod notNil ifTrue:[
- fileLabels := #(
- 'fileOut'
- 'printOut'
- '-'
- 'SPAWN_METHOD'
- '-'
- ).
-
- fileSelectors := #(
- methodFileOut
- methodPrintOut
- nil
- methodSpawn
- nil
- ).
-
- sepLocalLabels := #('-'). sepLocalSelectors := #(nil).
-
- mthdLabels := #(
- 'change category ...'
- 'remove'
- ).
-
- mthdSelectors := #(
- methodChangeCategory
- methodRemove
- ).
-
- currentMethod isWrapped ifTrue:[
- brkLabels := #(
- 'remove break/trace'
- '-'
- ).
-
- brkSelectors := #(
- methodRemoveBreakOrTrace
- nil
- )
- ] ifFalse:[
- brkLabels := #(
- 'breakpoint'
- 'trace'
- 'trace sender'
- '-'
- ).
-
- brkSelectors := #(
- methodBreakPoint
- methodTrace
- methodTraceSender
- nil
- )
- ]
- ] ifFalse:[
- fileLabels := fileSelectors := #().
- brkLabels := brkSelectors := #().
- mthdLabels := mthdSelectors := #().
- ].
-
-
-
- labels :=
- fileLabels ,
- searchLabels ,
- localSearchLabels ,
- sepLocalLabels ,
- brkLabels ,
- newLabels ,
- mthdLabels.
-
- selectors :=
- fileSelectors ,
- searchSelectors ,
- localSearchSelectors ,
- sepLocalSelectors ,
- brkSelectors ,
- newSelectors ,
- mthdSelectors.
-
-"
- labels := #(
- 'fileOut'
- 'printOut'
- '-'
- 'SPAWN_METHOD'
- '-'
- 'senders ...'
- 'implementors ...'
- 'globals ...'
- 'string search ...'
- 'apropos ...'
- '-'
- 'local senders ...'
- 'local implementors ...'
- 'local string search ...'
- 'local apropos ...'
- '-'
- 'breakpoint'
- 'trace'
- 'trace sender'
- '-'
- 'new method'
- 'change category ...'
- 'remove'
- ).
- selectors := #(
- methodFileOut
- methodPrintOut
- nil
- methodSpawn
- nil
- methodSenders
- methodImplementors
- methodGlobalReferends
- methodStringSearch
- methodAproposSearch
- nil
- methodLocalSenders
- methodLocalImplementors
- methodLocalStringSearch
- methodLocalAproposSearch
- nil
- methodBreakPoint
- methodTrace
- methodTraceSender
- nil
- methodNewMethod
- methodChangeCategory
- methodRemove
- )
-"
-
- ^ PopUpMenu
- labels:(resources array:labels)
- selectors:selectors
- receiver:self
- for:methodListView
-!
-
-methodImplementors
- "launch an enterBox for selector to search for"
-
- self askAndBrowseSelectorTitle:'selector to browse implementors of:'
- action:[:aString |
- self class browseImplementorsOf:aString
- ]
-!
-
-methodSenders
- "launch an enterBox for selector to search for"
-
- self askAndBrowseSelectorTitle:'selector to browse senders of:'
- action:[:aString |
- self class browseAllCallsOn:aString
- ]
-!
-
-methodRemove
- "remove the current method"
-
- self checkMethodSelected ifFalse:[^ self].
- actualClass removeSelector:(actualClass selectorForMethod:currentMethod).
- currentMethod := currentSelector := nil.
- self updateMethodListWithScroll:false
-!
-
-methodLocalSenders
- "launch an enterBox for selector to search for in current class & subclasses"
-
- self checkClassSelected ifFalse:[^ self].
- self askAndBrowseSelectorTitle:'selector to browse local senderss of:'
- action:[:aString |
- self class browseCallsOn:aString under:currentClass
- ]
-!
-
-methodPrintOut
- "print out the current method"
-
- |printStream|
-
- self checkMethodSelected ifFalse:[^ self].
-
- printStream := Printer new.
- actualClass printOutSource:(currentMethod source) on:printStream.
- printStream close
-!
-
-methodLocalImplementors
- "launch an enterBox for selector to search for"
-
- self checkClassSelected ifFalse:[^ self].
- self askAndBrowseSelectorTitle:'selector to browse local implementors of:'
- action:[:aString |
- self class browseImplementorsOf:aString under:currentClass
- ]
-!
-
-methodGlobalReferends
- "launch an enterBox for global symbol to search for"
-
- self enterBoxForBrowseTitle:'global variable to browse users of:'
- action:[:aString |
- self class browseReferendsOf:aString asSymbol
- ]
-!
-
-methodSpawn
- "create a new SystemBrowser browsing current method,
- or if the current selection is of the form 'class>>selector', spawan
- a browser on that method."
-
- |s sel selSymbol clsName clsSymbol cls isMeta w|
-
- classMethodListView notNil ifTrue:[
- s := classMethodListView selectionValue.
- clsName := self classFromClassMethodString:s.
- sel := self selectorFromClassMethodString:s.
- isMeta := false
- ].
-
- self extractClassAndSelectorFromSelectionInto:[:c :s :m |
- clsName := c.
- sel := s.
- isMeta := m
- ].
-
- (sel notNil and:[clsName notNil]) ifTrue:[
- (clsName knownAsSymbol and:[sel knownAsSymbol]) ifTrue:[
- clsSymbol := clsName asSymbol.
- (Smalltalk includesKey:clsSymbol) ifTrue:[
- cls := Smalltalk at:clsSymbol.
- isMeta ifTrue:[
- cls := cls class
- ].
- cls isBehavior ifFalse:[
- cls := cls class
- ].
- cls isBehavior ifTrue:[
- selSymbol := sel asSymbol.
- self withWaitCursorDo:[
- (cls implements:selSymbol) ifFalse:[
- cls := cls class.
- ].
- (cls implements:selSymbol) ifTrue:[
- self class browseClass:cls selector:selSymbol.
- ^ self
- ].
- w := ' does not implement #' , sel
- ]
- ] ifFalse:[
- w := ' is not a class'
- ]
- ] ifFalse:[
- w := ' is unknown'
- ]
- ] ifFalse:[
- w := ' and/or ' , sel , ' are unknown'
- ].
- self warn:(clsName , w).
- ^ self
- ].
-
- self checkMethodSelected ifFalse:[
- self warn:'select a method first'.
- ^ self
- ].
-
- self withWaitCursorDo:[
- w := currentMethod who.
- self class browseClass:(w at:1) selector:(w at:2)
- ]
-!
-
-methodFileOut
- "file out the current method"
-
- self checkMethodSelected ifFalse:[^ self].
-
- self busyLabel:'saving:' with:currentSelector.
- Class fileOutErrorSignal handle:[:ex |
- self warn:'cannot create: %1' with:ex parameter.
- ex return
- ] do:[
- actualClass fileOutMethod:currentMethod.
- ].
- self normalLabel.
-!
-
-methodChangeCategory
- "move the current method into another category -
- nothing done here, but a query for the new category.
- Remember the last category, to allow faster category change of a group of methods."
-
- |box txt|
-
- self checkMethodSelected ifFalse:[^ self].
-
- actualClass isNil ifTrue:[
- box := self enterBoxTitle:'' okText:'change'.
- ] ifFalse:[
- |someCategories|
-
- someCategories := actualClass categories sort.
- box := self listBoxTitle:'' okText:'change' list:someCategories.
- ].
- box title:('change category from ''' , currentMethod category , ''' to:').
- lastMethodCategory isNil ifTrue:[
- txt := currentMethod category.
- ] ifFalse:[
- txt := lastMethodCategory
- ].
- box initialText:txt.
- box action:[:aString |
- lastMethodCategory := aString.
-
- currentMethod category:aString asSymbol.
- currentClass changed.
- currentMethod changed:#category.
- currentClass addChangeRecordForMethodCategory:currentMethod category:aString.
- self updateMethodCategoryListWithScroll:false.
- self updateMethodListWithScroll:false
- ].
- box showAtPointer
-!
-
-methodStringSearch
- "launch an enterBox for string to search for"
-
- self askAndBrowseSelectorTitle:'string to search for in sources:'
- action:[:aString |
- self class browseForString:aString
- ]
-!
-
-methodLocalStringSearch
- "launch an enterBox for string to search for"
-
- self checkClassSelected ifFalse:[^ self].
- self askAndBrowseSelectorTitle:'string to search for in local methods:'
- action:[:aString |
- self class browseForString:aString in:(currentClass withAllSubclasses)
- ]
-!
-
-methodAproposSearch
- "launch an enterBox for a keyword search"
-
- self askAndBrowseSelectorTitle:'keyword to search for:'
- action:[:aString |
- self class aproposSearch:aString
- ]
-!
-
-methodLocalAproposSearch
- "launch an enterBox for a local keyword search"
-
- self askAndBrowseSelectorTitle:'keyword to search for:'
- action:[:aString |
- self class aproposSearch:aString in:(currentClass withAllSubclasses)
- ]
-!
-
-methodNewMethod
- "prepare for definition of a new method - put a template into
- code view and define accept-action to compile it"
-
- currentClass isNil ifTrue:[
- ^ self warn:'select/create a class first'.
- ].
- currentMethodCategory isNil ifTrue:[
- ^ self warn:'select/create a method category first'.
- ].
-
- currentMethod := currentSelector := nil.
-
- methodListView deselect.
- codeView contents:(self template).
- codeView modified:false.
-
- self setAcceptAndExplainActionsForMethod.
-!
-
-methodTrace
- "turn on tracing of the current method"
-
- |sel|
-
-currentClass notNil ifTrue:[
- currentSelector notNil ifTrue:[
- currentMethod := actualClass compiledMethodAt:currentSelector
- ]
-].
-
- (currentMethod notNil and:[currentMethod isWrapped not])
- ifTrue:[
- currentMethod := MessageTracer traceMethod:currentMethod.
- sel := methodListView selection.
- self updateMethodListWithScroll:false.
- methodListView selection:sel.
- currentClass changed:#methodDictionary with:currentSelector.
- ]
-!
-
-methodRemoveBreakOrTrace
- "turn off tracing of the current method"
-
- |sel|
-
- (currentMethod notNil and:[currentMethod isWrapped])
- ifTrue:[
- currentMethod := MessageTracer unwrapMethod:currentMethod.
- sel := methodListView selection.
- self updateMethodListWithScroll:false.
- methodListView selection:sel.
- currentClass changed:#methodDictionary with:currentSelector.
- ]
-!
-
-methodBreakPoint
- "set a breakpoint on the current method"
-
- |sel|
-
- currentSelector notNil ifTrue:[
- currentMethod := actualClass compiledMethodAt:currentSelector.
- currentMethod isWrapped ifFalse:[
- currentMethod := MessageTracer trapMethod:currentMethod.
- sel := methodListView selection.
- self updateMethodListWithScroll:false.
- methodListView selection:sel
- ].
- ]
-!
-
-methodTraceSender
- "turn on tracing of the current method"
-
- |sel|
-
- (currentMethod notNil and:[currentMethod isWrapped not])
- ifTrue:[
- currentMethod := MessageTracer traceMethodSender:currentMethod.
- sel := methodListView selection.
- self updateMethodListWithScroll:false.
- methodListView selection:sel.
- currentClass changed:#methodDictionary with:currentSelector.
- ]
-! !
-
-!SystemBrowser methodsFor:'variable list menu'!
-
-initializeVariableListMenu
- |varMenu|
-
- varMenu := (PopUpMenu labels:(resources array:#(
- 'instvar refs ...'
- 'classvar refs ...'
- 'all instvar refs ...'
- 'all classvar refs ...'
- '-'
- 'instvar mods ...'
- 'classvar mods ...'
- 'all instvar mods ...'
- 'all classvar mods ...'
- ))
- selectors:#(
- instVarRefs
- classVarRefs
- allInstVarRefs
- allClassVarRefs
- nil
- instVarMods
- classVarMods
- allInstVarMods
- allClassVarMods
- )
- receiver:self
- for:self).
-
- variableListView isNil ifTrue:[
- classListView notNil ifTrue:[
- |menu|
-
- menu := classListView middleButtonMenu.
- menu notNil ifTrue:[
- menu addLabel:(resources string:'variable search')
- selector:#variables
- before:#classRefs.
- menu subMenuAt:#variables put:varMenu.
- ]
- ]
- ] ifFalse:[
- variableListView middleButtonMenu:varMenu
- ]
-
-!
-
-variableSelection:lineNr
- "variable selection changed"
-
- |name idx|
-
- name := variableListView selectionValue.
- name isNil ifTrue:[
- self unhilightMethodCategories.
- self unhilightMethods.
- self autoSearch:nil.
- ^ self
- ].
-
- "
- first, check if the selected variable is really the one
- we get - reselect if its hidden (for example, a class variable
- with the same name could be defined in a subclass)
- "
- idx := variableListView list findLast:[:entry | entry = name].
- idx ~~ lineNr ifTrue:[
- "select it - user will see whats going on"
- variableListView selection:idx
- ].
-
- "search for methods in the current category, which access the selected
- variable, and highlight them"
-
- self hilightMethodsInMethodCategoryList:true inMethodList:true.
- self autoSearch:name.
-
-
-!
-
-enterBoxForVariableSearch:title
- |box sel|
-
- box := self enterBoxForCodeSelectionTitle:title okText:'browse'.
- variableListView notNil ifTrue:[
- codeView hasSelection ifFalse:[
- (sel := variableListView selectionValue) notNil ifTrue:[
- (sel startsWith:'---') ifFalse:[
- box initialText:sel
- ]
- ]
- ]
- ].
- ^ box
-!
-
-allClassOrInstVarRefsTitle:title access:access mods:modifications
- "show an enterbox for instVar to search for"
-
- self doClassMenu:[:currentClass |
- |box|
-
- box := self enterBoxForVariableSearch:title.
- box action:[:aVariableName |
- self withCursor:(Cursor questionMark) do:[
- |homeClass|
-
- homeClass := self findClassOfVariable:aVariableName
- accessWith:access.
- (self class) browseInstRefsTo:aVariableName
- under:homeClass
- modificationsOnly:modifications
- ]
- ].
- box showAtPointer
- ]
-!
-
-instVarRefsOrModsTitle:title mods:mods
- "show an enterbox for instvar to search for"
-
- self doClassMenu:[:currentClass |
- |box|
-
- box := self enterBoxForVariableSearch:title.
- box action:[:aString |
- self withCursor:(Cursor questionMark) do:[
- self class browseInstRefsTo:aString
- in:(Array with:currentClass)
- modificationsOnly:mods
- ]
- ].
- box showAtPointer
- ]
-!
-
-allClassVarMods
- "show an enterbox for classVar to search for"
-
- self allClassOrInstVarRefsTitle:'class variable to browse modifications of:'
- access:#classVarNames
- mods:true
-!
-
-instVarMods
- "show an enterbox for instVar to search for"
-
- self instVarRefsOrModsTitle:'instance variable to browse modifications of:'
- mods:true
-!
-
-instVarRefs
- "show an enterbox for instVar to search for"
-
- self instVarRefsOrModsTitle:'instance variable to browse references to:'
- mods:false
-!
-
-classVarRefsOrModsTitle:title mods:mods
- "show an enterbox for classVar to search for"
-
- self doClassMenu:[:currentClass |
- |box|
-
- box := self enterBoxForVariableSearch:title.
- box action:[:aString |
- self withCursor:(Cursor questionMark) do:[
- self class browseClassRefsTo:aString
- in:(Array with:currentClass)
- modificationsOnly:mods
- ]
- ].
- box showAtPointer
- ]
-!
-
-allInstVarRefs
- "show an enterbox for instVar to search for"
-
- self allClassOrInstVarRefsTitle:'instance variable to browse references to:'
- access:#instVarNames
- mods:false
-!
-
-classVarRefs
- "show an enterbox for classVar to search for"
-
- self classVarRefsOrModsTitle:'class variable to browse references to:'
- mods:false
-!
-
-classVarMods
- "show an enterbox for classVar to search for"
-
- self classVarRefsOrModsTitle:'class variable to browse modifications of:'
- mods:true
-!
-
-allInstVarMods
- "show an enterbox for instVar to search for"
-
- self allClassOrInstVarRefsTitle:'instance variable to browse modifications of:'
- access:#instVarNames
- mods:true
-!
-
-allClassVarRefs
- "show an enterbox for classVar to search for"
-
- self allClassOrInstVarRefsTitle:'class variable to browse references to:'
- access:#classVarNames
- mods:false
-! !
-
-!SystemBrowser methodsFor:'class-method list menu'!
-
-classMethodMenu
- |labels selectors|
-
- labels := #(
- 'fileOut'
- 'fileOut all'
- 'printOut'
- '-'
- 'spawn'
- 'spawn class'
- 'spawn full protocol'
- 'spawn hierarchy'
- '-'
- 'sender ...'
- 'implementors ...'
- 'globals ...'
-"/ '-'
-"/ 'breakpoint'
-"/ 'trace'
-"/ 'trace sender'
- ).
-
- selectors := #(
- methodFileOut
- classMethodFileOutAll
- methodPrintOut
- nil
- methodSpawn
- classSpawn
- classSpawnFullProtocol
- classSpawnHierarchy
- nil
- methodSenders
- methodImplementors
- methodGlobalReferends
-"/ nil
-"/ methodBreakPoint
-"/ methodTrace
-"/ methodTraceSender
- ).
-
- ^ (PopUpMenu labels:(resources array:labels)
- selectors:selectors
- receiver:self)
-!
-
-classMethodFileOutAll
- "fileout all methods into one source file"
-
- |list classString selectorString cls mth outStream fileName append
- fileBox|
-
- append := false.
- fileBox := FileSaveBox
- title:(resources string:'save methodss in:')
- okText:(resources string:'save')
- abortText:(resources string:'cancel')
- action:[:fName | fileName := fName].
- fileBox appendAction:[:fName | fileName := fName. append := true].
- fileBox initialText:'some_methods.st'.
- Project notNil ifTrue:[
- fileBox directory:Project currentProjectDirectory
- ].
- fileBox showAtPointer.
-
- fileName notNil ifTrue:[
- "
- if file exists, save original in a .sav file
- "
- fileName asFilename exists ifTrue:[
- fileName asFilename copyTo:(fileName , '.sav')
- ].
- append ifTrue:[
- outStream := FileStream appendingOldFileNamed:fileName
- ] ifFalse:[
- outStream := FileStream newFileNamed:fileName.
- ].
- outStream isNil ifTrue:[
- ^ self warn:'cannot create: %1' with:fileName
- ].
- self withWaitCursorDo:[
- list := classMethodListView list.
- list do:[:line |
- self busyLabel:'writing: ' with:line.
-
- classString := self classFromClassMethodString:line.
- selectorString := self selectorFromClassMethodString:line.
-
- ((classString ~= 'Metaclass') and:[classString endsWith:'class']) ifTrue:[
- classString := classString copyTo:(classString size - 5).
- cls := (Smalltalk at:classString asSymbol).
- cls := cls class
- ] ifFalse:[
- cls := (Smalltalk at:classString asSymbol).
- ].
-
- cls isNil ifTrue:[
- self warn:'oops class %1 is gone' with:classString
- ] ifFalse:[
- mth := cls compiledMethodAt:(selectorString asSymbol).
- Class fileOutErrorSignal handle:[:ex |
- |box|
- box := YesNoBox new.
- box yesText:'continue' noText:'abort'.
- (box confirm:('fileOut error: ' , ex errorString ,
- '\\continue anyway ?') withCRs) ifTrue:[
- ex proceed
- ].
- self normalLabel.
- ^ self
- ] do:[
- cls fileOutMethod:mth on:outStream.
- ]
- ]
- ].
- outStream close.
- self normalLabel.
- ]
- ]
-! !
-
SystemBrowser initialize!
--- a/SystemBrowser.st Mon Mar 06 20:30:54 1995 +0100
+++ b/SystemBrowser.st Mon Mar 06 20:32:18 1995 +0100
@@ -10,27 +10,39 @@
hereby transferred.
"
-'From Smalltalk/X, Version:2.10.4 on 7-nov-1994 at 14:56:27'!
+'From Smalltalk/X, Version:2.10.4 on 24-feb-1995 at 5:09:20 am'!
-StandardSystemView subclass:#SystemBrowser
- instanceVariableNames:'classCategoryListView classListView methodCategoryListView
- methodListView classMethodListView codeView classToggle
- instanceToggle currentClassCategory currentClassHierarchy
- currentClass currentMethodCategory currentMethod currentSelector
- showInstance actualClass fullClass lastMethodCategory aspect
- variableListView fullProtocol lockUpdates autoSearch myLabel
- acceptClass'
+Model subclass:#SystemBrowser
+ instanceVariableNames:'currentClass currentMethodCategory currentMethod currentSelector
+ showInstance actualClasslastMethodCategory aspect lockUpdates
+ autoSearch myLabel acceptClass'
classVariableNames:'CheckForInstancesWhenRemovingClasses'
poolDictionaries:''
category:'Interface-Browsers'
!
-SystemBrowser comment:'
-COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+!SystemBrowser class methodsFor:'initialization'!
+
+initialize
+ "Browser configuration;
+ (values can be changed from your private startup file)"
-$Header: /cvs/stx/stx/libtool/SystemBrowser.st,v 1.25 1995-02-24 17:00:43 claus Exp $
-'!
+ "
+ setting this to false, the removeClass function will remove
+ classes WITHOUT checking for instances. Otherwise,
+ it will check and let you confirm in case there are instances.
+ Checking for instances may be a bit time consuming, though.
+ The default is true - therefore, it will check
+ "
+ CheckForInstancesWhenRemovingClasses := true
+
+ "
+ CheckForInstancesWhenRemovingClasses := true
+ CheckForInstancesWhenRemovingClasses := false
+
+ Browser initialize
+ "
+! !
!SystemBrowser class methodsFor:'documentation'!
@@ -50,7 +62,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/SystemBrowser.st,v 1.25 1995-02-24 17:00:43 claus Exp $
+$Header: /cvs/stx/stx/libtool/SystemBrowser.st,v 1.26 1995-03-06 19:32:08 claus Exp $
"
!
@@ -69,25 +81,27 @@
"
! !
-!SystemBrowser class methodsFor:'initialization'!
+!SystemBrowser class methodsFor:'instance creation'!
-initialize
- "SystemBrowser configuration;
- (values can be changed from your private startup file)"
+openOnDisplay:aDisplay
+ "launch a standard browser on another display.
+ Does not work currently - still being developped."
+
+ ^ self newWithLabel:(BrowserView classResources string:'System Browser')
+ setupBlock:[:browser | browser setupForAll]
+ on:aDisplay
"
- setting this to false, the removeClass function will remove
- classes WITHOUT checking for instances. Otherwise,
- it will check and let you confirm in case there are instances.
- Checking for instances may be a bit time consuming, though.
- The default is true - therefore, it will check
+ SystemBrowser openOnDisplay:(XWorkstation new initializeFor:'porty:0')
"
- CheckForInstancesWhenRemovingClasses := true
+!
- "
- CheckForInstancesWhenRemovingClasses := true
- CheckForInstancesWhenRemovingClasses := false
- "
+open
+ "launch a standard browser"
+
+ ^ self openOnDisplay:Display
+
+ "SystemBrowser open"
! !
!SystemBrowser class methodsFor:'startup'!
@@ -116,7 +130,6 @@
'Setclass new:')
title:'some new: methods'
"
-
!
browseMethodsIn:aCollectionOfClasses inst:wantInst class:wantClass where:aBlock title:title
@@ -177,6 +190,7 @@
The block is called with 3 arguments, class, method and seelctor."
^ self browseMethodsIn:aCollectionOfClasses inst:true class:true where:aBlock title:title
+
!
browseClassCategory:aClassCategory
@@ -619,6 +633,7 @@
"
^ self browseForSymbol:aGlobalName title:('users of: ' , aGlobalName) warnIfNone:doWarn
+
!
browseReferendsOf:aGlobalName
@@ -631,6 +646,7 @@
"
Browser browseReferendsOf:#Transcript
"
+
!
browseUsesOf:aClass
@@ -742,6 +758,7 @@
newDict inspect
+
!
browseForString:aString in:aCollectionOfClasses
@@ -774,6 +791,7 @@
SystemBrowser browseForString:'should' in:(Array with:Object)
SystemBrowser browseForString:'[eE]rror' in:(Array with:Object)
"
+
!
browseForString:aString
@@ -781,6 +799,7 @@
This may be slow, since source-code has to be scanned."
^ self browseForString:aString in:(Smalltalk allClasses)
+
!
browseInstRefsTo:varName in:aCollectionOfClasses modificationsOnly:modsOnly title:title
@@ -797,6 +816,7 @@
browser autoSearch:varName
].
^ browser
+
!
aproposSearch:aString in:aCollectionOfClasses
@@ -844,6 +864,7 @@
SystemBrowser aproposSearch:'sort' in:(Collection withAllSubclasses)
SystemBrowser aproposSearch:'[Aa]bsent' in:(Collection withAllSubclasses)
"
+
!
aproposSearch:aString
@@ -852,6 +873,7 @@
This is relatively slow, since all source must be processed."
^ self aproposSearch:aString in:(Smalltalk allClasses)
+
!
browseInstRefsTo:aString in:aCollectionOfClasses modificationsOnly:modsOnly
@@ -870,6 +892,7 @@
in:aCollectionOfClasses
modificationsOnly:modsOnly
title:(title , aString)
+
!
browseInstRefsTo:aString under:aClass modificationsOnly:modsOnly
@@ -878,6 +901,7 @@
if modsOnly is true, browse only methods where the instvar is modified"
^ self browseInstRefsTo:aString in:(aClass withAllSubclasses) modificationsOnly:modsOnly
+
!
browseClassRefsTo:varName in:aCollectionOfClasses modificationsOnly:modsOnly title:title
@@ -894,6 +918,7 @@
browser autoSearch:varName
].
^ browser
+
!
browseClassRefsTo:aString in:aCollectionOfClasses modificationsOnly:modsOnly
@@ -909,6 +934,7 @@
title := 'references to '
].
^ self browseClassRefsTo:aString in:aCollectionOfClasses modificationsOnly:modsOnly title:(title , aString)
+
!
browseClassRefsTo:aString under:aClass modificationsOnly:modsOnly
@@ -917,6 +943,7 @@
if modsOnly is true, browse only methods where the classvar is modified"
^ self browseClassRefsTo:aString in:(aClass withAllSubclasses) modificationsOnly:modsOnly
+
!
filterToSearchClassRefsTo:varName modificationsOnly:modsOnly
@@ -967,4896 +994,45 @@
result
].
^ searchBlock
+
! !
-!SystemBrowser class methodsFor:'private'!
+!SystemBrowser class methodsFor:'private instance creation'!
newWithLabel:aString setupBlock:aBlock on:aWorkstation
"common helper method for all creation methods"
|newBrowser|
- newBrowser := self on:aWorkstation.
+ newBrowser := BrowserView on:aWorkstation.
newBrowser title:aString.
aBlock value:newBrowser.
newBrowser open.
^ newBrowser
+
+
!
newWithLabel:aString setupBlock:aBlock
"common helper method for all creation methods"
^ self newWithLabel:aString setupBlock:aBlock on:Display
-!
-showNoneFound:what
-"/ DialogView warn:(self classResources string:('no ' , what , ' found')).
- self showNoneFound
-!
-
-showNoneFound
- DialogView warn:(self classResources string:'None found').
-! !
-
-!SystemBrowser class methodsFor:'general startup'!
-
-openOnDisplay:aDisplay
- "launch a standard browser on another display.
- Does not work currently - still being developped."
-
- ^ self newWithLabel:(self classResources string:'System Browser')
- setupBlock:[:browser | browser setupForAll]
- on:aDisplay
-
- "
- SystemBrowser openOnDisplay:(XWorkstation new initializeFor:'porty:0')
- "
-!
-
-open
- "launch a standard browser"
-
- ^ self openOnDisplay:Display
-
- "SystemBrowser open"
-! !
-
-!SystemBrowser methodsFor:'dependencies'!
-
-update:something with:someArgument from:changedObject
- "
- avoid update/warn after my own changes
- "
- lockUpdates == true ifTrue:[
-"/ 'ignored my change' printNL.
- ^ self
- ].
-
-"/ changedObject print. ' ' print. someArgument print. ' ' print.
-"/ something printNL.
-
- (changedObject == Smalltalk) ifTrue:[
- something == #newClass ifTrue:[
- (currentClass notNil
- and:[someArgument name = currentClass name]) ifTrue:[
- "
- the current class was autoloaded
- "
- self warnLabel:'the selected class has changed'.
- self updateClassListWithScroll:false.
- ].
-
- ((someArgument category = currentClassCategory)
- or:[currentClassCategory notNil
- and:[currentClassCategory startsWith:'*']]) ifTrue:[
- self updateClassListWithScroll:false.
- ].
-
- someArgument category ~= currentClassCategory ifTrue:[
- "
- category new ?
- "
- (classCategoryListView notNil
- and:[classCategoryListView list notNil
- and:[(classCategoryListView list includes:someArgument category) not]])
- ifTrue:[
- self updateClassCategoryListWithScroll:false.
- ]
- ].
- ^ self
- ].
-
- something == #classRemove ifTrue:[
- someArgument = currentClass ifTrue:[
- self warnLabel:'the selected class was removed'.
- ^ self
- ].
- " fall into general update "
- ].
-
- "
- any other (unknown) change
- with the Smalltalk dictionary ...
- "
- self updateClassCategoryListWithScroll:false.
- self updateClassListWithScroll:false.
- ^ self
- ].
-
- changedObject isBehavior ifTrue:[
- "
- its a class, that has changed
- "
- (currentClass notNil
- and:[changedObject name = currentClass name]) ifTrue:[
- "
- its the current class that has changed
- "
- something == #methodDictionary ifTrue:[
- (someArgument isSymbol) ifTrue:[
- |changedMethod|
-
- "
- the method with selector someArgument was changed or removed
- "
- self updateMethodCategoryListWithScroll:false.
- self updateMethodListWithScroll:false.
-
- someArgument == currentSelector ifTrue:[
- "
- special care here: the currently shown method has been
- changed somehow in another browser (or via fileIn)
- "
- changedMethod := currentClass compiledMethodAt:currentSelector.
- changedMethod isNil ifTrue:[
- self warnLabel:'the method shown was removed'.
- ^ self
- ].
- "compare the source codes"
- self warnLabel:'the code shown may not up to date'.
- ^ self
- ].
- ^ self
- ]
- ].
-
- something == #comment ifTrue:[
- "
- the class has changed its comment; we dont care, except if
- currently showing the comment
- "
- aspect == #comment ifTrue:[
- self warnLabel:'the comment shown may not up to date'.
- ].
- ^ self
- ].
- something == #definition ifTrue:[
- "
- the class has changed its definition.
- Warn, except if showing a method.
- "
- aspect notNil ifTrue:[
- self warnLabel:'the classes definition has changed'.
- ].
-"/ ^ self
- ].
-
- "
- get the class again - in case of a changed class definition,
- we are otherwise refering to the obsolete old class
- "
- currentClass := Smalltalk at:(currentClass name asSymbol).
- showInstance ifTrue:[
- actualClass := currentClass
- ] ifFalse:[
- actualClass := currentClass class
- ].
-
- self updateMethodCategoryListWithScroll:false.
-
- "dont update codeView ...."
- "self update"
- ^ self
- ].
-
- "
- any other class has changed (but not its organization, since
- that is cought in the above case).
- We are not interrested in it - except, if showing fullProtocol
- or hierarchy ...
- "
- currentClassHierarchy notNil ifTrue:[
- fullProtocol ifTrue:[
- (currentClass isSubclassOf:changedObject) ifTrue:[
- ]
- ] ifFalse:[
- ((currentClass isSubclassOf:changedObject)
- or:[changedObject isSubclassOf:currentClass]) ifTrue:[
- ]
- ]
- ].
-
- ^ self
- ].
-
- (changedObject isMethod) ifTrue:[
-
- ]
! !
-!SystemBrowser methodsFor:'private'!
-
-normalLabel
- "set the normal (inactive) window- and icon labels"
-
- |l il|
-
- myLabel notNil ifTrue:[
- l := il := myLabel
- ] ifFalse:[
- l := resources string:'System Browser'.
-
- currentClass notNil ifTrue:[
- l := l, ': ', currentClass name.
- classListView isNil ifTrue:[
- currentSelector notNil ifTrue:[
- l := l , ' ' , currentSelector
- ]
- ].
- il := currentClass name
- ] ifFalse:[
- il := l.
- ]
- ].
- self label:l.
- self iconLabel:il.
-!
-
-setDoitActionForClass
- "tell the codeView what to do on doIt"
-
- "set self for doits. This allows accessing the current class
- as self, and access to the class variables by name.
- "
- codeView doItAction:[:theCode |
- |compiler|
-
- currentClass isNil ifTrue:[
- compiler := Compiler
- ] ifFalse:[
- compiler := currentClass compilerClass
- ].
- compiler
- evaluate:theCode
- in:nil
- receiver:currentClass
- notifying:codeView
- logged:false
- ifFail:nil
- ].
-!
-
-setAcceptAndExplainActionsForMethod
- "tell the codeView what to do on accept and explain"
-
- codeView acceptAction:[:theCode |
- |cat cls|
-
- codeView cursor:Cursor execute.
-
- (cat := currentMethodCategory) = '* all *' ifTrue:[
- "must check from which category this code came from ...
- ... thanks to Arno for pointing this out"
-
- cat := self askForMethodCategory.
- ].
- (cat notNil and:[cat notEmpty]) ifTrue:[
- fullProtocol ifTrue:[
- cls := acceptClass "/actualClass whichClassImplements:currentSelector.
- ].
- cls isNil ifTrue:[
- cls := actualClass
- ].
-
- Object abortSignal catch:[
- lockUpdates := true.
-
- actualClass compilerClass
- compile:theCode asString
- forClass:cls
- inCategory:cat
- notifying:codeView.
-
- codeView modified:false.
- self updateMethodListWithScroll:false.
- ].
- lockUpdates := false.
- ].
- codeView cursor:Cursor normal.
- ].
-
- codeView explainAction:[:theCode :theSelection |
- self showExplanation:(Explainer
- explain:theSelection
- in:theCode
- forClass:actualClass)
- ].
-!
-
-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 action|
-
- codeView modified ifFalse:[
- ^ true
- ].
- action := OptionBox
- request:(resources at:'text has not been accepted.\\Your modifications will be lost when continuing.') withCRs
- label:'Attention'
- form:(WarningBox iconBitmap)
- buttonLabels:#('abort' 'accept' 'continue')
- values:#(false #accept true).
- action ~~ #accept ifTrue:[
- ^ action
- ].
- codeView accept. ^ true
-!
-
-selectorToSearchFor
- "look in codeView and methodListView for a search-string when searching for selectors"
-
- |sel t|
-
- sel := codeView selection.
- sel notNil ifTrue:[
- sel := sel asString.
- t := Parser selectorInExpression:sel.
- t notNil ifTrue:[
- sel := t
- ].
- sel := sel withoutSpaces.
- sel == #>> ifTrue:[
- "oops - thats probably not what we want here ..."
- self extractClassAndSelectorFromSelectionInto:[:c :s :m |
- sel := s
- ]
- ]
- ] ifFalse:[
- methodListView notNil ifTrue:[
- sel := methodListView selectionValue
- ] ifFalse:[
- classMethodListView notNil ifTrue:[
- sel := classMethodListView selectionValue.
- sel notNil ifTrue:[
- sel := self selectorFromClassMethodString:sel
- ]
- ]
- ].
- sel notNil ifTrue:[
- sel := sel withoutSpaces
- ] ifFalse:[
- sel := ''
- ]
- ].
- ^ sel
-!
-
-enterBoxTitle:title okText:okText
- "convenient method: setup enterBox"
-
- |box|
-
- box := EnterBox new.
- box title:(resources string:title) okText:(resources string:okText).
- ^ box
-!
-
-askAndBrowseSelectorTitle:title action:aBlock
- "convenient method: setup enterBox with text from codeView or selected
- method for browsing based on a selector. Set action and launch box"
-
- |box|
-
- box := self enterBoxTitle:title okText:'browse'.
- box initialText:(self selectorToSearchFor).
- box action:[:aString | self withCursor:(Cursor questionMark) do:[aBlock value:aString]].
- box showAtPointer
-!
-
-setSearchPattern:aString
- codeView setSearchPattern:aString
-!
-
-listBoxTitle:title okText:okText list:aList
- "convenient method: setup a listBox & return it"
-
- |box|
-
- box := ListSelectionBox new.
- box okText:(resources string:okText).
- box title:(resources string:title).
- box list:aList.
- ^ box
-!
-
-showExplanation:someText
- "show explanation from Parser"
+!SystemBrowser class methodsFor:'private helpers'!
- self notify:someText
-!
-
-stringToSearchFor
- "look in codeView and methodListView for a search-string when searching for classes/names"
-
- |sel|
-
- sel := codeView selection.
- sel notNil ifTrue:[
- sel := sel asString withoutSpaces
- ] ifFalse:[
- sel isNil ifTrue:[
- currentClass notNil ifTrue:[
- sel := currentClass name
- ]
- ].
- sel notNil ifTrue:[
- sel := sel withoutSpaces
- ] ifFalse:[
- sel := ''
- ]
- ].
- ^ sel
-!
-
-findClassOfVariable:aVariableName accessWith:aSelector
- "this method returns the class, in which a variable
- is defined;
- needs either #instVarNames or #classVarNames as aSelector."
-
- |cls homeClass|
-
- "
- first, find the class, where the variable is declared
- "
- cls := currentClass.
- [cls notNil] whileTrue:[
- ((cls perform:aSelector) includes:aVariableName) ifTrue:[
- homeClass := cls.
- cls := nil.
- ] ifFalse:[
- cls := cls superclass
- ]
- ].
- homeClass isNil ifTrue:[
- "nope, must be one below ... (could optimize a bit, by searching down
- for the declaring class ...
- "
- homeClass := currentClass
- ] ifFalse:[
-"/ Transcript showCr:'starting search in ' , homeClass name.
- ].
- ^ homeClass
-!
-
-enterBoxForSearchSelectorTitle:title
- "convenient method: setup enterBox with text from codeView or selected
- method for browsing based on a selector"
-
- |box|
-
- box := self enterBoxTitle:title okText:'search'.
- box initialText:(self selectorToSearchFor).
- ^ box
-!
-
-enterBoxForCodeSelectionTitle:title okText:okText
- "convenient method: setup enterBox with text from codeview"
-
- |sel box|
-
- box := self enterBoxTitle:(resources string:title) okText:(resources string:okText).
- sel := codeView selection.
- sel notNil ifTrue:[
- box initialText:(sel asString withoutSeparators)
- ].
- ^ box
-!
-
-classesInFullProtocolHierarchy:aClass do:aBlock
- "evaluate aBlock for all non-striked out classes in
- the hierarchy"
-
- |index|
-
- index := (classListView list size).
- aClass withAllSuperclasses do:[:c |
- (classListView isInSelection:index) ifFalse:[
- aBlock value:c
- ].
- index := index - 1
- ]
-
-!
-
-enterBoxForBrowseTitle:title action:aBlock
- "convenient method: setup enterBox with text from codeView or selected
- method for method browsing based on className/variable"
-
- |box|
-
- box := self enterBoxTitle:title okText:'browse'.
- box initialText:(self stringToSearchFor).
- box action:[:aString | self withWaitCursorDo:[aBlock value:aString]].
- box showAtPointer
-!
-
-askAndBrowseMethodCategory:title action:aBlock
- "convenient method: setup enterBox with initial being current method category"
-
- |sel box|
-
- box := self enterBoxTitle:title okText:'browse'.
- sel := codeView selection.
- sel isNil ifTrue:[
- currentMethodCategory notNil ifTrue:[
- sel := currentMethodCategory
- ]
- ].
- sel notNil ifTrue:[
- box initialText:(sel asString withoutSpaces)
- ].
- box action:[:aString | self withWaitCursorDo:[aBlock value:aString]].
- box showAtPointer
-!
-
-classHierarchyDo:aBlock
- "eavluate the 2-arg block for every class,
- starting at Object; passing class and nesting level to the block."
-
- |classes s classDict l|
-
- classes := Smalltalk allClasses.
- classDict := IdentityDictionary new:classes size.
- classes do:[:aClass |
- s := aClass superclass.
- s notNil ifTrue:[
- l := classDict at:s ifAbsent:[nil].
- l isNil ifTrue:[
- l := OrderedCollection new:5.
- classDict at:s put:l
- ].
- l add:aClass
- ]
- ].
- self classHierarchyOf:Object level:0 do:aBlock using:classDict
-!
-
-classHierarchyOf:aClass level:level do:aBlock using:aDictionary
- "evaluate the 2-arg block for every subclass of aClass,
- passing class and nesting level to the block."
-
- |names subclasses|
-
- aBlock value:aClass value:level.
- subclasses := aDictionary at:aClass ifAbsent:[nil].
- (subclasses size == 0) ifFalse:[
- names := subclasses collect:[:class | class name].
- names sortWith:subclasses.
- subclasses do:[:aSubClass |
- self classHierarchyOf:aSubClass level:(level + 1) do:aBlock using:aDictionary
- ]
- ]
-!
-
-compileCode:someCode
- (ReadStream on:someCode) fileIn
-!
-
-extractClassAndSelectorFromSelectionInto:aBlock
- "given a string which can be either 'class>>sel' or
- 'class sel', extract className and selector, and call aBlock with
- the result."
-
- |sel clsName isMeta sep s|
-
- sel := codeView selection.
- sel notNil ifTrue:[
- sel := sel asString withoutSeparators.
- ('*>>*' match:sel) ifTrue:[
- sep := $>
- ] ifFalse:[
- ('* *' match:sel) ifTrue:[
- sep := Character space
- ]
- ].
- sep notNil ifTrue:[
- "
- extract class/sel from selection
- "
- s := ReadStream on:sel.
- clsName := s upTo:sep.
- [s peek == sep] whileTrue:[s next].
- sel := s upToEnd.
-
- (clsName endsWith:'class') ifTrue:[
- isMeta := true.
- clsName := clsName copyTo:(clsName size - 5)
- ] ifFalse:[
- isMeta := false
- ].
- ]
- ].
- aBlock value:clsName value:sel value:isMeta
+showNoneFound:what
+ self showNoneFound
!
-classesInHierarchy:aClass do:aBlock
- |index|
-
- index := (classListView list size).
- aClass withAllSuperclasses do:[:c |
- (classListView isInSelection:index) ifFalse:[
- aBlock value:c
- ].
- index := index - 1
- ]
-
-!
-
-askForMethodCategory
- |someCategories box txt|
-
- someCategories := actualClass categories sort.
- box := self listBoxTitle:'accept in which method category ?' okText:'accept' list:someCategories.
-
- lastMethodCategory isNil ifTrue:[
- txt := 'new methods'
- ] ifFalse:[
- txt := lastMethodCategory
- ].
- box initialText:txt.
- box action:[:aString |
- ^ aString
- ].
- box showAtPointer.
- ^ nil
-!
-
-warnLabel:what
- "set the title for some warning"
-
- self label:('System Browser WARNING: ' , what)
-!
-
-busyLabel:what with:someArgument
- "set the title for some warning"
-
- self label:('System Browser:' , (resources string:what with:someArgument))
-
-! !
-
-!SystemBrowser methodsFor:'method stuff'!
-
-updateMethodListWithScroll:scroll
- |selectors scr first last|
-
- methodListView notNil ifTrue:[
- currentMethodCategory notNil ifTrue:[
- fullProtocol ifTrue:[
- selectors := self listOfAllSelectorsInCategory:currentMethodCategory
- inFullProtocolHierarchyOfClass:actualClass
- ] ifFalse:[
- selectors := self listOfAllSelectorsInCategory:currentMethodCategory
- ofClass:actualClass
- ]
- ].
- scr := scroll.
- first := methodListView firstLineShown.
- first ~~ 1 ifTrue:[
- last := methodListView lastLineShown.
- selectors size <= (last - first + 1) ifTrue:[
- scr := true
- ]
- ].
- methodListView list = selectors ifFalse:[
- scr ifTrue:[
- methodListView contents:selectors
- ] ifFalse:[
- methodListView setContents:selectors
- ]
- ].
- ]
-!
-
-methodSelectionChanged
- "method selection has changed - update dependent views"
-
- self withWaitCursorDo:[
- |index cls|
-
- self updateCodeView.
- self setAcceptAndExplainActionsForMethod.
-
- "
- if there is any autoSearch string, do the search
- "
- autoSearch notNil ifTrue:[
- codeView searchFwd:autoSearch startingAtLine:1 col:0 ifAbsent:[]
- ].
-
- fullProtocol ifTrue:[
- "
- remove any bold attribute from classList
- "
- 1 to:classListView list size do:[:i |
- classListView attributeAt:i remove:#bold.
- ].
- "
- boldify the class where this method is implemented
- "
- currentMethod notNil ifTrue:[
- cls := currentMethod who at:1.
- index := classListView list indexOf:(cls name).
- (index == 0
- and:[cls isMeta
- and:[cls name endsWith:'class']]) ifTrue:[
- index := classListView list indexOf:(cls name copyWithoutLast:5).
- ].
- index ~~ 0 ifTrue:[
- classListView attributeAt:index add:#bold.
- ].
- currentClass := acceptClass := cls.
- ]
- ].
- ]
-!
-
-updateMethodList
- self updateMethodListWithScroll:true
-!
-
-methodSelection:lineNr
- "user clicked on a method line - show code"
-
- |selectorString selectorSymbol|
-
- (fullProtocol not and:[currentClass isNil]) ifTrue:[^ self].
-
- selectorString := methodListView selectionValue.
- "
- kludge: check if its a wrapped one
- "
- (selectorString endsWith:' !!') ifTrue:[
- selectorString := selectorString copyTo:(selectorString size - 2)
- ].
- selectorSymbol := selectorString asSymbol.
- fullProtocol ifTrue:[
- currentMethod := currentSelector := nil.
- "
- search which class implements the selector
- "
- self classesInFullProtocolHierarchy:actualClass do:[:c |
- (currentMethod isNil
- and:[c implements:selectorSymbol]) ifTrue:[
- currentSelector := selectorSymbol.
- currentMethod := c compiledMethodAt:selectorSymbol.
- acceptClass := c
- ]
- ]
- ] ifFalse:[
- currentSelector := selectorSymbol.
- currentMethod := actualClass compiledMethodAt:selectorSymbol.
- ].
-
- methodCategoryListView notNil ifTrue:[
- currentMethod notNil ifTrue:[
- (currentMethodCategory = currentMethod category) ifFalse:[
- currentMethodCategory := currentMethod category.
- methodCategoryListView selectElement:currentMethodCategory
- ]
- ]
- ].
-
- self methodSelectionChanged
-!
-
-listOfAllSelectorsInCategory:aCategory ofClass:aClass
- "answer a list of all selectors in a given method category
- of the argument, aClass"
-
- |newList searchCategory|
-
- (aCategory = '* all *') ifTrue:[
- newList := aClass selectorArray asOrderedCollection
- ] ifFalse:[
- (aCategory = '* no category *') ifTrue:[
- searchCategory := nil
- ] ifFalse:[
- searchCategory := aCategory
- ].
- newList := OrderedCollection new.
- aClass methodArray with:aClass selectorArray do:[:aMethod :selector |
- |sel|
-
- (aMethod category = searchCategory) ifTrue:[
- aMethod isWrapped ifTrue:[
- sel := selector , ' !!'
- ] ifFalse:[
- sel := selector
- ].
-
- "mhmh - can this happen ?"
-"/ (newList includes:sel) ifFalse:[
- newList add:sel
-"/ ]
- ]
- ]
- ].
- (newList size == 0) ifTrue:[^ nil].
- ^ newList sort
-!
-
-template
- "return a method definition template"
-
- ^
-'message selector and argument names
- "comment stating purpose of message"
-
-
- |temporaries|
- statements
-
-
-"
- change above template into real code.
- Then ''accept'' either via the menu
- or via the keyboard (usually CMD-A).
-
- You do not need this template; you can also
- select any existing methods code, change it,
- and finally ''accept''.
-"
-'
-!
-
-listOfAllSelectorsInCategory:aCategory inFullProtocolHierarchyOfClass:aClass
- "answer a list of all selectors in a given method category
- of the argument, aClass and its superclasses.
- Used with fullProtocol browsing."
-
- |newList|
-
- newList := Set new.
- self classesInFullProtocolHierarchy:aClass do:[:c |
- |searchCategory|
-
- (aCategory = '* all *') ifTrue:[
- newList addAll:(c selectorArray)
- ] ifFalse:[
- (aCategory = '* no category *') ifTrue:[
- searchCategory := nil
- ] ifFalse:[
- searchCategory := aCategory
- ].
- c methodArray with:c selectorArray do:[:aMethod :selector |
- (aMethod category = searchCategory) ifTrue:[
- newList add:selector
- ]
- ]
- ].
- ].
- (newList size == 0) ifTrue:[^ nil].
- ^ newList asOrderedCollection sort
-!
-
-checkMethodSelected
- currentMethod isNil ifTrue:[
- self warn:'select a method first'.
- ^ false
- ].
- ^ true
-!
-
-switchToMethodNamed:matchString
- |aSelector method cat index classToSearch selectors|
-
- currentClass notNil ifTrue:[
- showInstance ifTrue:[
- classToSearch := currentClass
- ] ifFalse:[
- classToSearch := currentClass class
- ].
- selectors := classToSearch selectorArray.
-
- ((matchString ~= '*') and:[matchString includesMatchCharacters]) ifTrue:[
- index := selectors findFirst:[:element | matchString match:element]
- ] ifFalse:[
- index := selectors indexOf:matchString
- ].
-
- (index ~~ 0) ifTrue:[
- aSelector := selectors at:index.
- method := classToSearch methodArray at:index.
- cat := method category.
- cat isNil ifTrue:[cat := '* all *'].
- methodCategoryListView selectElement:cat.
- currentMethodCategory := cat.
- self methodCategorySelectionChanged.
-
- currentMethod := classToSearch compiledMethodAt:aSelector.
- currentMethod notNil ifTrue:[
- currentSelector := aSelector.
- methodListView selectElement:aSelector.
- ].
- self methodSelectionChanged
- ]
- ]
-!
-
-switchToAnyMethodNamed:aString
- |aSelector classToStartSearch aClass nm|
-
- aSelector := aString asSymbol.
- currentClass isNil ifTrue:[
- currentClassHierarchy notNil ifTrue:[
- classToStartSearch := currentClassHierarchy
- ]
- ] ifFalse:[
- classToStartSearch := currentClass
- ].
- classToStartSearch notNil ifTrue:[
- showInstance ifFalse:[
- classToStartSearch := classToStartSearch class
- ].
- aClass := classToStartSearch whichClassImplements:aSelector.
- aClass notNil ifTrue:[
- nm := aClass name.
- showInstance ifFalse:[
- ((nm ~= 'Metaclass') and:[nm endsWith:'class']) ifTrue:[
- nm := nm copyTo:(nm size - 5)
- ]
- ].
- self switchToClassNamed:nm.
- self switchToMethodNamed:aString
- ]
- ]
-! !
-
-!SystemBrowser methodsFor:'misc'!
-
-updateCodeView
- |code|
-
- fullClass ifTrue:[
- currentClass notNil ifTrue:[
- code := currentClass source.
- ]
- ] ifFalse:[
- currentMethod notNil ifTrue:[
- (codeView acceptAction isNil
- and:[actualClass notNil
- and:[currentMethodCategory notNil]]) ifTrue:[
- self setAcceptAndExplainActionsForMethod.
- ].
-
- code := currentMethod source.
-
- ]
- ].
- codeView contents:code.
- codeView modified:false.
-
- self normalLabel.
-!
-
-instanceProtocol:aBoolean
- "switch between instance and class protocol"
-
- showInstance ~~ aBoolean ifTrue:[
- self checkSelectionChangeAllowed ifTrue:[
- aBoolean ifTrue:[
- classToggle turnOff.
- instanceToggle turnOn.
- ] ifFalse:[
- classToggle turnOn.
- instanceToggle turnOff
- ].
- showInstance := aBoolean.
-
- (variableListView notNil
- and:[variableListView hasSelection]) ifTrue:[
- self unhilightMethodCategories.
- self unhilightMethods.
- variableListView deselect
- ].
-
- fullProtocol ifTrue:[
- showInstance ifTrue:[
- actualClass := acceptClass := currentClassHierarchy.
- ] ifFalse:[
- actualClass := acceptClass := currentClassHierarchy class.
- ].
-
- self updateClassList.
- self updateMethodCategoryListWithScroll:false.
- self updateMethodListWithScroll:false.
- self updateVariableList.
- ^ self
- ].
- currentClass notNil ifTrue:[
- self classSelectionChanged
- ].
- codeView modified:false.
- ] ifFalse:[
- aBoolean ifTrue:[
- classToggle turnOn.
- instanceToggle turnOff
- ] ifFalse:[
- classToggle turnOff.
- instanceToggle turnOn.
- ].
- ]
- ]
-!
-
-instanceProtocol
- "switch to instance protocol"
-
- self instanceProtocol:true
-!
-
-classProtocol
- "switch to class protocol"
-
- self instanceProtocol:false
-! !
-
-!SystemBrowser methodsFor:'method category stuff'!
-
-updateMethodCategoryListWithScroll:scroll
- |categories|
-
- methodCategoryListView notNil ifTrue:[
- fullProtocol ifTrue:[
- currentClassHierarchy notNil ifTrue:[
- categories := self listOfAllMethodCategoriesInFullProtocolHierarchy:actualClass
- ]
- ] ifFalse:[
- currentClass notNil ifTrue:[
- categories := self listOfAllMethodCategoriesInClass:actualClass
- ]
- ].
- methodCategoryListView list = categories ifFalse:[
- scroll ifTrue:[
- methodCategoryListView contents:categories
- ] ifFalse:[
- methodCategoryListView setContents:categories
- ].
- currentMethodCategory notNil ifTrue:[
- methodCategoryListView selectElement:currentMethodCategory
- ]
- ]
- ]
-!
-
-listOfAllMethodCategoriesInClass:aClass
- "answer a list of all method categories of the argument, aClass"
-
- |newList|
-
- newList := OrderedCollection new.
- aClass methodArray do:[:aMethod |
- |cat|
-
- cat := aMethod category.
- cat isNil ifTrue:[
- cat := '* no category *'
- ].
- (newList includes:cat) ifFalse:[newList add:cat]
- ].
- (newList size == 0) ifTrue:[^ nil].
- newList add:'* all *'.
- ^ newList sort
-!
-
-methodCategorySelection:lineNr
- "user clicked on a method category line - show selectors"
-
- |oldSelector|
-
-"/ oldSelector := currentSelector.
-
- (fullProtocol not and:[currentClass isNil]) ifTrue:[^ self].
-
- currentMethodCategory := methodCategoryListView selectionValue.
- self methodCategorySelectionChanged.
-
- "if there is only one method, show it right away"
- methodListView list size == 1 ifTrue:[
- methodListView selection:1.
- self methodSelection:1
- ] ifFalse:[
- oldSelector notNil ifTrue:[
- methodListView selectElement:oldSelector.
- methodListView hasSelection ifTrue:[
- self methodSelection:methodListView selection.
- ]
- ]
- ]
-!
-
-updateMethodCategoryList
- self updateMethodCategoryListWithScroll:true
-!
-
-methodCategorySelectionChanged
- "method category selection has changed - update dependant views"
-
- self withWaitCursorDo:[
- currentMethod := currentSelector := nil.
-
- self updateMethodList.
- self updateCodeView.
-
- currentMethodCategory notNil ifTrue:[
- methodCategoryListView selectElement:currentMethodCategory
- ].
-
- self setAcceptAndExplainActionsForMethod.
- self hilightMethodsInMethodCategoryList:false inMethodList:true.
- ]
-!
-
-listOfAllMethodCategoriesInFullProtocolHierarchy:aClass
- "answer a list of all method categories of the argument, aClass,
- and all of its superclasses.
- Used with fullProtocol browsing."
-
- |newList|
-
- newList := OrderedCollection new.
- self classesInFullProtocolHierarchy:aClass do:[:c |
- |cat|
-
- c methodArray do:[:aMethod |
- cat := aMethod category.
- cat isNil ifTrue:[
- cat := '* no category *'
- ].
- (newList includes:cat) ifFalse:[newList add:cat]
- ]
- ].
- (newList size == 0) ifTrue:[^ nil].
- newList add:'* all *'.
- ^ newList sort
-!
-
-checkMethodCategorySelected
- currentMethodCategory isNil ifTrue:[
- self warn:'select a method category first'.
- ^ false
- ].
- ^ true
-!
-
-whenMethodCategorySelected:aBlock
- self checkMethodCategorySelected ifTrue:[
- self withWaitCursorDo:aBlock
- ]
-!
-
-copyMethodsFromClass:aClassName
- |class box|
-
- currentClass notNil ifTrue:[
- class := Smalltalk classNamed:aClassName.
- class isBehavior ifFalse:[
- self warn:'no class named %1' with:aClassName.
- ^ self
- ].
-
- showInstance ifFalse:[
- class := class class
- ].
-
- "show enterbox for category to copy from"
-
- box := self enterBoxTitle:'name of category to copy from (matchpattern allowed, * for all):'
- okText:'copy'.
- box action:[:aString | self copyMethodsFromClass:class category:aString].
- box showAtPointer.
- ]
-!
-
-copyMethodsFromClass:class category:category
- currentClass notNil ifTrue:[
- Object abortSignal catch:[
- class methodArray do:[:aMethod |
- |source|
-
- (category match:aMethod category) ifTrue:[
- source := aMethod source.
- codeView contents:source.
- codeView modified:false.
- actualClass compilerClass
- compile:source
- forClass:actualClass
- inCategory:aMethod category
- notifying:codeView.
- self updateMethodCategoryListWithScroll:false.
- self updateMethodListWithScroll:false.
- ]
- ]
- ]
- ]
-!
-
-newMethodCategory:aString
- |categories|
-
- currentClass isNil ifTrue:[
- ^ self warn:'select/create a class first'.
- ].
- categories := methodCategoryListView list.
- categories isNil ifTrue:[categories := OrderedCollection new].
- (categories includes:aString) ifFalse:[
- categories add:aString.
- categories sort.
- methodCategoryListView contents:categories
- ].
- currentMethodCategory := aString.
- self methodCategorySelectionChanged
-! !
-
-!SystemBrowser methodsFor:'initialize / release'!
-
-initialize
- super initialize.
-
- self icon:(Form fromFile:(resources at:'ICON_FILE' default:'SBrowser.xbm')
- resolution:100).
-
- showInstance := true.
- fullClass := false.
- fullProtocol := false.
- aspect := nil.
-
- "inform me, when Smalltalk changes"
- Smalltalk addDependent:self
-!
-
-realize
- |v checkBlock|
-
- super realize.
-
- checkBlock := [:lineNr | self checkSelectionChangeAllowed].
-
- v := classCategoryListView.
- v notNil ifTrue:[
- v action:[:lineNr | self classCategorySelection:lineNr].
- v selectConditionBlock:checkBlock.
- v ignoreReselect:false.
- v contents:(self listOfAllClassCategories).
- "
- tell classCategoryListView to ask for the menu
- "
- v model:self.
- v menu:#classCategoryMenu.
- ].
-
- v := classListView.
- v notNil ifTrue:[
- v action:[:lineNr | self classSelection:lineNr].
- v selectConditionBlock:checkBlock.
- v ignoreReselect:false.
- "
- tell classListView to ask for the menu
- "
- v model:self.
- v menu:#classMenu.
- self initializeVariableListMenu.
- ].
-
- v := methodCategoryListView.
- v notNil ifTrue:[
- v action:[:lineNr | self methodCategorySelection:lineNr].
- v selectConditionBlock:checkBlock.
- v ignoreReselect:false.
- "
- tell methodCategoryListView to ask for the menu
- "
- v model:self.
- v menu:#methodCategoryMenu.
- ].
-
- v := methodListView.
- v notNil ifTrue:[
- v action:[:lineNr | self methodSelection:lineNr].
- v selectConditionBlock:checkBlock.
- v ignoreReselect:false.
- self initializeMethodMenu
- "
- tell methodListView to ask for the menu
- "
- v model:self.
- v menu:#methodMenu.
- ].
-
- v := classMethodListView.
- v notNil ifTrue:[
- v action:[:lineNr | self classMethodSelection:lineNr].
- v selectConditionBlock:checkBlock.
- v ignoreReselect:false.
- "
- tell classMethodListView to ask for the menu
- "
- v model:self.
- v menu:#classMethodMenu.
- ].
-
- v := variableListView.
- v notNil ifTrue:[
- v action:[:lineNr | self variableSelection:lineNr].
- v ignoreReselect:false.
- v toggleSelect:true
- ].
-
- "
- normal browsers show the top at first;
- hierarchy and fullProtocol browsers better show the end
- initially
- "
- currentClassHierarchy notNil ifTrue:[
- classListView scrollToBottom.
- ]
-!
-
-terminate
- (self checkSelectionChangeAllowed) ifTrue:[
- super terminate
- ]
-!
-
-destroy
- "relese dependant - destroy popups"
-
- Smalltalk removeDependent:self.
- currentClass notNil ifTrue:[
- currentClass removeDependent:self.
- currentClass := nil
- ].
- super destroy
-!
-
-autoSearch:aString
- "used with class-method list browsing. If true,
- selecting an entry from the list will automatically
- search for the searchstring in the codeView"
-
- self setSearchPattern:aString.
- autoSearch := aString
-!
-
-title:someString
- myLabel := someString.
- self label:someString.
-! !
-
-!SystemBrowser methodsFor:'initialize subviews'!
-
-createClassListViewIn:frame
- "setup the classlist subview, with its toggles"
-
- |v panel oldStyle|
-
- self createTogglesIn:frame.
-
- "
- oldstyle had no variableList ...
- "
-"/ oldStyle := true.
- oldStyle := false.
-
- oldStyle ifTrue:[
- v := ScrollableView for:SelectionInListView in:frame.
- v origin:(0.0 @ 0.0)
- extent:[frame width
- @
- (frame height
- - ViewSpacing
- - instanceToggle height
- - instanceToggle borderWidth
- + v borderWidth)].
-
- classListView := v scrolledView
- ] ifFalse:[
- panel := VariableVerticalPanel
- origin:(0.0 @ 0.0)
- corner:[frame width
- @
- (frame height
- - ViewSpacing
- - instanceToggle height
- - instanceToggle borderWidth
- + v borderWidth)]
- in:frame.
-
- v := ScrollableView for:SelectionInListView in:panel.
- v origin:(0.0 @ 0.0) corner:(1.0 @ 0.7).
- classListView := v scrolledView.
-
-
- v := ScrollableView for:SelectionInListView in:panel.
- v origin:(0.0 @ 0.7) corner:(1.0 @ 1.0).
-
- variableListView := v scrolledView
- ]
-!
-
-createCodeViewIn:aView at:relY
- "setup the code view"
- |v|
-
- v := HVScrollableView for:CodeView miniScrollerH:true miniScrollerV:false in:aView.
- v origin:(0.0 @ relY) corner:(1.0 @ 1.0).
- codeView := v scrolledView
-!
-
-createTogglesIn:aFrame
- "create and setup the class/instance toggles"
-
- |h halfSpace classAction instanceAction|
-
- classAction := [self classProtocol].
- instanceAction := [self instanceProtocol].
-
- halfSpace := ViewSpacing // 2.
-
- instanceToggle := Toggle label:(resources at:'instance') in:aFrame.
- h := instanceToggle height.
- instanceToggle origin:(0.0 @ 1.0) corner:(0.5 @ 1.0).
- instanceToggle topInset:h negated.
- instanceToggle bottomInset:halfSpace.
-
- instanceToggle turnOn.
- instanceToggle pressAction:instanceAction.
- instanceToggle releaseAction:classAction.
-
- classToggle := Toggle label:(resources at:'class') in:aFrame.
- h := classToggle height.
- classToggle origin:(0.5 @ 1.0) corner:(1.0 @ 1.0).
- classToggle topInset:h negated.
- classToggle bottomInset:halfSpace.
-
- classToggle turnOff.
- classToggle pressAction:classAction.
- classToggle releaseAction:instanceAction.
-
- StyleSheet is3D ifTrue:[
- instanceToggle leftInset:halfSpace.
- classToggle leftInset:halfSpace.
- instanceToggle rightInset:ViewSpacing - halfSpace.
- classToggle rightInset:ViewSpacing - halfSpace.
- ].
-!
-
-createCodeViewIn:aView
- "setup the code view"
-
- ^ self createCodeViewIn:aView at:0.25
-!
-
-setupForList:aList
- "setup subviews to browse methods from a list"
-
- |vpanel v|
-
- vpanel := VariableVerticalPanel
- origin:(0.0 @ 0.0)
- corner:(1.0 @ 1.0)
- in:self.
-
- v := ScrollableView for:SelectionInListView in:vpanel.
- v origin:(0.0 @ 0.0) corner:(1.0 @ 0.25).
- classMethodListView := v scrolledView.
- classMethodListView contents:aList.
-
- self createCodeViewIn:vpanel.
- self updateCodeView
-!
-
-setupForAll
- "create subviews for a full browser"
-
- |vpanel hpanel frame v|
-
- vpanel := VariableVerticalPanel origin:(0.0 @ 0.0) corner:(1.0 @ 1.0)
- in:self.
- hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
-
- v := HVScrollableView for:SelectionInListView
- miniScrollerH:true miniScrollerV:false
- in:hpanel.
- v origin:(0.0 @ 0.0) corner:(0.25 @ 1.0).
- classCategoryListView := v scrolledView.
-
- frame := View origin:(0.25 @ 0.0) corner:(0.5 @ 1.0) in:hpanel.
- self createClassListViewIn:frame.
-
- v := HVScrollableView for:SelectionInListView miniScrollerH:true miniScrollerV:false in:hpanel.
- v origin:(0.5 @ 0.0) corner:(0.75 @ 1.0).
- methodCategoryListView := v scrolledView.
-
- v := HVScrollableView for:SelectionInListView miniScrollerH:true miniScrollerV:false in:hpanel.
- v origin:(0.75 @ 0.0) corner:(1.0 @ 1.0).
- methodListView := v scrolledView.
-
- self createCodeViewIn:vpanel
-!
-
-setupForClassHierarchy:aClass
- "setup subviews to browse a class hierarchy"
-
- |vpanel hpanel frame v|
-
- vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
- corner:(1.0 @ 1.0)
- in:self.
-
- "
- notice: we use a different ratio here
- "
- hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.4) in:vpanel.
- frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
-
- self createClassListViewIn:frame.
-
- v := ScrollableView for:SelectionInListView in:hpanel.
- v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
- methodCategoryListView := v scrolledView.
-
- v := ScrollableView for:SelectionInListView in:hpanel.
- v origin:(0.66 @ 0.0) corner:(1.0 @ 1.0).
- methodListView := v scrolledView.
-
- self createCodeViewIn:vpanel at:0.4.
-
- currentClassHierarchy := aClass.
- self updateClassList.
- self updateMethodCategoryList.
- self updateMethodList.
- self updateCodeView
-!
-
-setupForFullClass
- "setup subviews to browse a class as full text"
-
- |vpanel hpanel v|
-
- vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
- corner:(1.0 @ 1.0)
- in:self.
-
- hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
-
- v := ScrollableView for:SelectionInListView in:hpanel.
- v origin:(0.0 @ 0.0) corner:(0.5 @ 1.0).
- classCategoryListView := v scrolledView.
- classCategoryListView contents:(self listOfAllClassCategories).
-
- v := ScrollableView for:SelectionInListView in:hpanel.
- v origin:(0.5 @ 0.0) corner:(1.0 @ 1.0).
- classListView := v scrolledView.
-
- self createCodeViewIn:vpanel.
-
- fullClass := true.
- self updateCodeView
-!
-
-setupForClass:aClass
- "create subviews for browsing a single class"
-
- |vpanel hpanel frame v|
-
- vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
- corner:(1.0 @ 1.0)
- in:self.
-
- hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
- frame := View origin:(0.0 @ 0.0) corner:(0.5 @ 1.0)in:hpanel.
-
- self createTogglesIn:frame.
-
- v := ScrollableView for:SelectionInListView in:frame.
- v origin:(0.0 @ 0.0)
- extent:[frame width
- @
- (frame height
- - ViewSpacing
- - instanceToggle height
- - instanceToggle borderWidth
- + v borderWidth)].
- methodCategoryListView := v scrolledView.
-
- v := ScrollableView for:SelectionInListView in:hpanel.
- v origin:(0.5 @ 0.0) corner:(1.0 @ 1.0).
- methodListView := v scrolledView.
-
- self createCodeViewIn:vpanel.
-
- self switchToClass:aClass.
- actualClass := acceptClass := aClass.
- self updateMethodCategoryList.
- self updateMethodList.
- self updateCodeView
-!
-
-setupForClassCategory:aClassCategory
- "setup subviews to browse a class category"
-
- |vpanel hpanel frame v|
-
- vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
- corner:(1.0 @ 1.0)
- in:self.
-
- hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
- frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
-
- self createClassListViewIn:frame.
-
- v := ScrollableView for:SelectionInListView in:hpanel.
- v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
- methodCategoryListView := v scrolledView.
-
- v := ScrollableView for:SelectionInListView in:hpanel.
- v origin:(0.66 @ 0.0) corner:(1.0 @ 1.0).
- methodListView := v scrolledView.
-
- self createCodeViewIn:vpanel.
-
- currentClassCategory := aClassCategory.
- self updateClassList.
- self updateMethodCategoryList.
- self updateMethodList.
- self updateCodeView
-!
-
-setupForClass:aClass selector:selector
- "setup subviews to browse a single method"
-
- |v|
-
- v := ScrollableView for:CodeView in:self.
- v origin:(0.0 @ 0.0) corner:(1.0 @ 1.0).
- codeView := v scrolledView.
-
- currentClassCategory := aClass category.
- self switchToClass:aClass.
- actualClass := acceptClass := aClass.
- currentSelector := selector.
- currentMethod := currentClass compiledMethodAt:selector.
- currentMethodCategory := currentMethod category.
- self updateCodeView
-!
-
-setupForClassList:aList
- "setup subviews to browse classes from a list"
-
- |vpanel hpanel frame l v|
-
- vpanel := VariableVerticalPanel
- origin:(0.0 @ 0.0) corner:(1.0 @ 1.0) in:self.
-
- hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
- frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
-
- self createClassListViewIn:frame.
-
- v := ScrollableView for:SelectionInListView in:hpanel.
- v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
- methodCategoryListView := v scrolledView.
-
- v := ScrollableView for:SelectionInListView in:hpanel.
- v origin:(0.66 @ 0.0) corner:(1.0 @ 1.0).
- methodListView := v scrolledView.
-
- self createCodeViewIn:vpanel.
-
- l := aList collect:[:entry | entry name].
- classListView list:(l sort).
-
- self updateMethodCategoryList.
- self updateMethodList.
- self updateCodeView
-!
-
-setupForClass:aClass methodCategory:aMethodCategory
- "setup subviews to browse a method category"
-
- |vpanel v|
-
- vpanel := VariableVerticalPanel
- origin:(0.0 @ 0.0) corner:(1.0 @ 1.0)
- in:self.
-
- v := ScrollableView for:SelectionInListView in:vpanel.
- v origin:(0.0 @ 0.0) corner:(1.0 @ 0.25).
- methodListView := v scrolledView.
-
- self createCodeViewIn:vpanel.
-
- currentClassCategory := aClass category.
- self switchToClass:aClass.
- actualClass := acceptClass := aClass.
- currentMethodCategory := aMethodCategory.
- self updateMethodList.
- self updateCodeView
-!
-
-setupForFullClassProtocol:aClass
- "setup subviews to browse a classes full protocol"
-
- |vpanel hpanel frame v|
-
- vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
- corner:(1.0 @ 1.0)
- in:self.
-
- "
- notice: we use a different ratio here
- "
- hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.4) in:vpanel.
- frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
-
- self createClassListViewIn:frame.
- classListView multipleSelectOk:true.
- classListView toggleSelect:true.
- classListView strikeOut:true.
-
- v := ScrollableView for:SelectionInListView in:hpanel.
- v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
- methodCategoryListView := v scrolledView.
-
- v := ScrollableView for:SelectionInListView in:hpanel.
- v origin:(0.66 @ 0.0) corner:(1.0 @ 1.0).
- methodListView := v scrolledView.
-
- self createCodeViewIn:vpanel at:0.4.
-
- currentClassHierarchy := actualClass := acceptClass := currentClass := aClass.
- fullProtocol := true.
-
- self updateClassList.
- self updateMethodCategoryList.
- self updateMethodList.
- self updateCodeView.
- self updateVariableList.
-!
-
-focusSequence
- |s|
-
- s := OrderedCollection new.
-
- classCategoryListView notNil ifTrue:[
- s add:classCategoryListView
- ].
-
- classListView notNil ifTrue:[
- s add:classListView
- ].
-
-"/ variableListView notNil ifTrue:[
-"/ s add:variableListView
-"/ ].
-
- instanceToggle notNil ifTrue:[
- s add:instanceToggle.
- ].
-
- methodCategoryListView notNil ifTrue:[
- s add:methodCategoryListView
- ].
-
- methodListView notNil ifTrue:[
- s add:methodListView
- ].
-
- classMethodListView notNil ifTrue:[
- s add:classMethodListView
- ].
-
- s add:codeView.
- ^ s
-! !
-
-!SystemBrowser methodsFor:'unused'!
-
-listOfAllSelectorsInCategory:aCategory inHierarchyOfClass:aClass
- "answer a list of all selectors in a given method category
- of the argument, aClass and its superclasses"
-
- |newList|
-
- newList := Set new.
- self classesInHierarchy:aClass do:[:c |
- |searchCategory|
-
- (aCategory = '* all *') ifTrue:[
- newList addAll:(c selectorArray)
- ] ifFalse:[
- (aCategory = '* no category *') ifTrue:[
- searchCategory := nil
- ] ifFalse:[
- searchCategory := aCategory
- ].
- c methodArray with:c selectorArray do:[:aMethod :selector |
- (aMethod category = searchCategory) ifTrue:[
- newList add:selector
- ]
- ]
- ].
- ].
- (newList size == 0) ifTrue:[^ nil].
- ^ newList asOrderedCollection sort
-!
-
-listOfAllMethodCategoriesInHierarchy:aClass
- "answer a list of all method categories of the argument, aClass,
- and all of its superclasses"
-
- |newList cat|
-
- newList := OrderedCollection new.
- self classesInHierarchy:aClass do:[:c |
- c methodArray do:[:aMethod |
- cat := aMethod category.
- cat isNil ifTrue:[
- cat := '* no category *'
- ].
- (newList includes:cat) ifFalse:[newList add:cat]
- ]
- ].
- (newList size == 0) ifTrue:[^ nil].
- newList add:'* all *'.
- ^ newList sort
-
-! !
-
-!SystemBrowser methodsFor:'class stuff'!
-
-switchToClass:newClass
- fullProtocol ifTrue:[^ self].
- currentClass notNil ifTrue:[
- currentClass removeDependent:self
- ].
- currentClass := newClass.
- currentClass notNil ifTrue:[
- currentClass addDependent:self.
- ].
- self normalLabel
-!
-
-classSelectionChanged
- |oldMethodCategory oldMethod oldSelector|
-
- self withWaitCursorDo:[
- oldMethodCategory := currentMethodCategory.
- oldMethod := currentMethod.
- oldSelector := currentSelector.
-
- showInstance ifTrue:[
- actualClass := acceptClass := currentClass
- ] ifFalse:[
- actualClass := acceptClass := currentClass class
- ].
- currentMethodCategory := nil.
- currentMethod := nil.
- currentSelector := nil.
-
- self updateVariableList.
- self updateMethodCategoryList.
-
- oldMethodCategory notNil ifTrue:[
- methodCategoryListView selectElement:oldMethodCategory.
- methodCategoryListView hasSelection ifTrue:[
- currentMethodCategory := oldMethodCategory.
- self methodCategorySelectionChanged
- ]
- ].
- self updateMethodList.
- self updateCodeView.
-
- fullClass ifTrue:[
- codeView acceptAction:[:theCode |
- codeView cursor:Cursor execute.
- Object abortSignal catch:[
- self compileCode:theCode asString.
- codeView modified:false.
- ].
- codeView cursor:Cursor normal.
- ].
- ] ifFalse:[
- self classDefinition.
- codeView acceptAction:[:theCode |
- codeView cursor:Cursor execute.
- Object abortSignal catch:[
- (Compiler evaluate:theCode asString notifying:codeView compile:false)
- isBehavior ifTrue:[
- self classCategoryUpdate.
- self updateClassListWithScroll:false.
- codeView modified:false.
- ].
- ].
- codeView cursor:Cursor normal.
- ].
- ].
- codeView explainAction:nil.
-
- classCategoryListView notNil ifTrue:[
- (currentClassCategory = currentClass category) ifFalse:[
- currentClassCategory := currentClass category.
- classCategoryListView selectElement:currentClassCategory
- ]
- ].
-
- self setDoitActionForClass
- ]
-!
-
-updateClassListWithScroll:scroll
- |classes oldClassName|
-
- classListView notNil ifTrue:[
- "
- refetch in case we are not up to date
- "
- (currentClass notNil and:[fullProtocol not]) ifTrue:[
- oldClassName := currentClass name.
- currentClass := Smalltalk at:(oldClassName asSymbol).
- ].
-
- currentClassCategory notNil ifTrue:[
- classes := self listOfAllClassesInCategory:currentClassCategory
- ] ifFalse:[
- currentClassHierarchy notNil ifTrue:[
- classes := self listOfClassHierarchyOf:currentClassHierarchy
- ]
- ].
-
- classListView list = classes ifFalse:[
- scroll ifTrue:[
- classListView contents:classes
- ] ifFalse:[
- classListView setContents:classes
- ].
- oldClassName notNil ifTrue:[
- classListView setContents:classes.
- classListView selectElement:oldClassName
- ] ifFalse:[
- variableListView notNil ifTrue:[variableListView contents:nil]
- ]
- ].
- scroll ifTrue:[
- fullProtocol ifTrue:[
- classListView scrollToBottom
- ]
- ]
- ]
-!
-
-classSelection:lineNr
- "user clicked on a class line - show method categories"
-
- |classSymbol cls oldSelector|
-
- (currentClassHierarchy notNil
- and:[fullProtocol]) ifTrue:[
- oldSelector := currentSelector.
-
- self updateMethodCategoryListWithScroll:false.
- self updateMethodListWithScroll:false.
- self updateVariableList.
- ^ self
- ].
-
- cls := Smalltalk classNamed:classListView selectionValue withoutSpaces.
-"
- classSymbol := classListView selectionValue withoutSpaces asSymbol.
- (Smalltalk includesKey:classSymbol) ifTrue:[
- cls := Smalltalk at:classSymbol
- ].
-"
- cls notNil ifTrue:[
- self switchToClass:cls.
- self classSelectionChanged
- ]
-!
-
-listOfAllClassesInCategory:aCategory
- "return a list of all classes in a given category"
-
- |newList classList searchCategory string|
-
- newList := OrderedCollection new.
- (aCategory = '* all *') ifTrue:[
- Smalltalk allBehaviorsDo:[:aClass |
- string := aClass name.
- newList indexOf:string ifAbsent:[newList add:string]
- ]
- ] ifFalse:[
- (aCategory = '* hierarchy *') ifTrue:[
- classList := OrderedCollection new.
- self classHierarchyDo:[:aClass :lvl|
- string := aClass name.
- classList indexOf:string ifAbsent:[
- classList add:string.
- newList add:(String new:lvl) , string
- ]
- ].
- ^ newList
- ] ifFalse:[
- (aCategory = '* no category *') ifTrue:[
- searchCategory := nil
- ] ifFalse:[
- searchCategory := aCategory
- ].
- Smalltalk allBehaviorsDo:[:aClass |
- aClass isMeta ifFalse:[
- (aClass category = searchCategory) ifTrue:[
- string := aClass name.
- newList indexOf:string ifAbsent:[newList add:string]
- ]
- ]
- ]
- ]
- ].
- (newList size == 0) ifTrue:[^ nil].
- ^ newList sort
-!
-
-doClassMenu:aBlock
- "a helper - check if class is selected and evaluate aBlock
- while showing waitCursor"
-
- self checkClassSelected ifTrue:[
- self withWaitCursorDo:[aBlock value:currentClass]
- ]
-!
-
-checkClassSelected
- "warn and return false, if no class is selected"
-
- currentClass isNil ifTrue:[
- self warn:'select a class first'.
- ^ false
- ].
- ^ true
-!
-
-updateClassList
- self updateClassListWithScroll:true
-!
-
-listOfClassHierarchyOf:aClass
- "return a hierarchy class-list"
-
- |startClass classes thisOne|
-
- showInstance ifTrue:[
- startClass := aClass
- ] ifFalse:[
- startClass := aClass class.
- ].
- classes := startClass allSuperclasses.
- thisOne := Array with:startClass.
-
- classes notNil ifTrue:[
- classes := classes reverse , thisOne.
- ] ifFalse:[
- classes := thisOne
- ].
-
- fullProtocol ifFalse:[
- classes := classes , startClass allSubclassesInOrder
- ].
- ^ classes collect:[:c | c name]
-!
-
-templateFor:className in:cat
- "return a class definition template - be smart in what is offered initially"
-
- |aString name i|
-
- name := 'NewClass'.
- i := 1.
- [name knownAsSymbol and:[Smalltalk includesKey:name asSymbol]] whileTrue:[
- i := i + 1.
- name := 'NewClass' , i printString
- ].
-
- aString := className , ' subclass:#' , name , '
- instanceVariableNames: ''''
- classVariableNames: ''''
- poolDictionaries: ''''
- category: '''.
-
- cat notNil ifTrue:[
- aString := aString , cat
- ].
- aString := aString , '''
-
-
-
-
-
-"
- Replace ''' , className , ''', ''', name , ''' and
- the empty string arguments by true values.
-
- Install (or change) the class by ''accepting'',
- either via the menu or the keyboard (usually CMD-A).
-
- To be nice to others (and yourself later), do not forget to
- add some documentation; either under the classes documentation
- protocol, or as a class comment.
-"
-'.
- ^ aString
-!
-
-classClassDefinitionTemplateFor:name in:cat
- "common helper for newClass and newSubclass
- - show a template to define class name in category cat.
- Also, set acceptaction to install the class."
-
- currentMethodCategory := nil.
- currentMethod := currentSelector := nil.
-
- classListView deselect.
-
- fullClass ifFalse:[
- methodCategoryListView contents:nil.
- methodListView contents:nil
- ].
-
- codeView contents:(self templateFor:name in:cat).
- codeView modified:false.
-
- codeView acceptAction:[:theCode |
- codeView cursor:Cursor execute.
- Object abortSignal catch:[
- |cls|
-
- cls := (Compiler evaluate:theCode asString notifying:codeView compile:false).
- cls isBehavior ifTrue:[
- codeView modified:false.
- self classCategoryUpdate.
- self updateClassListWithScroll:false.
- self switchToClassNamed:(cls name).
- ]
- ].
- codeView cursor:(Cursor normal).
- ].
- codeView explainAction:nil.
- self switchToClass:nil
-!
-
-renameCurrentClassTo:aString
- "helper - do the rename"
-
- self doClassMenu:[:currentClass |
- |oldName oldSym newSym|
-
- oldName := currentClass name.
- oldSym := oldName asSymbol.
-"
- currentClass setName:aString.
- newSym := aString asSymbol.
- Smalltalk at:oldSym put:nil.
- Smalltalk removeKey:oldSym.
- Smalltalk at:newSym put:currentClass.
-"
-"
- currentClass renameTo:aString.
-"
- Smalltalk renameClass:currentClass to:aString.
-
- self updateClassList.
- self updateMethodCategoryListWithScroll:false.
- self updateMethodListWithScroll:false.
- self withWaitCursorDo:[
- Transcript showCr:('searching for users of ' , oldSym); endEntry.
- self class browseReferendsOf:oldSym warnIfNone:false
- ]
- ]
-!
-
-switchToClassNamed:aString
- |classSymbol theClass newCat|
-
- classSymbol := aString asSymbolIfInterned.
- classSymbol isNil ifTrue:[^ self].
-
- theClass := Smalltalk at:classSymbol.
- theClass isBehavior ifTrue:[
- classCategoryListView notNil ifTrue:[
- currentClassHierarchy isNil ifTrue:[
- ((newCat := theClass category) ~= currentClassCategory) ifTrue:[
- currentClassCategory := newCat.
- newCat isNil ifTrue:[
- classCategoryListView selectElement:'* no category *'
- ] ifFalse:[
- classCategoryListView selectElement:newCat.
- ].
- "/ classCategoryListView makeSelectionVisible.
- ]
- ]
- ].
- self updateClassList.
- self switchToClass:theClass.
- classListView selectElement:aString.
- self classSelectionChanged
- ]
-!
-
-switchToClassNameMatching:aMatchString
- |classNames thisName box|
-
- classNames := OrderedCollection new.
- Smalltalk allBehaviorsDo:[:aClass |
- thisName := aClass name.
- (aMatchString match:thisName) ifTrue:[
- classNames add:thisName
- ]
- ].
- (classNames size == 0) ifTrue:[^ nil].
- (classNames size == 1) ifTrue:[
- ^ self switchToClassNamed:(classNames at:1)
- ].
-
- box := self listBoxTitle:'select class to switch to:'
- okText:'ok'
- list:classNames sort.
- box action:[:aString | self switchToClassNamed:aString].
- box showAtPointer
-! !
-
-!SystemBrowser methodsFor:'variable stuff'!
-
-updateVariableList
- |l subList last nameAccessSelector class oldSelection|
-
- variableListView isNil ifTrue:[^ self].
-
- oldSelection := variableListView selectionValue.
-
- l := OrderedCollection new.
- "
- show classVars, if classProtocol is shown (instead of classInstance vars)
- "
- showInstance ifTrue:[
- nameAccessSelector := #instVarNames
- ] ifFalse:[
- nameAccessSelector := #classVarNames
- ].
-
-"/ class := currentClass notNil ifTrue:[currentClass] ifFalse:[actualClass].
-"/ class isNil ifTrue:[class := currentClassHierarchy].
-class := currentClassHierarchy notNil ifTrue:[currentClassHierarchy] ifFalse:[currentClass].
- class withAllSuperclasses do:[:aClass |
- |ignore|
-
- ignore := fullProtocol
- and:[classListView valueIsInSelection:(aClass name asString)].
- ignore ifFalse:[
- subList := aClass perform:nameAccessSelector.
- subList size ~~ 0 ifTrue:[
- l := l , (subList asOrderedCollection reverse).
- l := l , (OrderedCollection with:'---- ' , aClass name , ' ---------').
- ]
- ]
- ].
- l reverse.
- variableListView setAttributes:nil.
- variableListView list:l.
- l keysAndValuesDo:[:index :entry |
- (entry startsWith:'---') ifTrue:[
- variableListView attributeAt:index put:#disabled.
- last := index
- ]
- ].
- last notNil ifTrue:[variableListView scrollToLine:last].
-
- oldSelection notNil ifTrue:[
- variableListView selectElement:oldSelection.
- self hilightMethodsInMethodCategoryList:true inMethodList:true.
- ]
-!
-
-unhilightMethods
- "unhighlight items in method list"
-
- variableListView isNil ifTrue:[^ self].
-
- methodListView notNil ifTrue:[
- 1 to:methodListView list size do:[:entry |
- methodListView attributeAt:entry put:nil.
- ].
- ].
-
-
-!
-
-hilightMethodsInMethodCategoryList:inCat inMethodList:inMethods
- "search for methods which access the selected
- variable, and highlight them"
-
- |name redefinedSelectors|
-
- variableListView isNil ifTrue:[^ self].
-
- inCat ifTrue:[self unhilightMethodCategories].
- inMethods ifTrue:[self unhilightMethods].
-
- actualClass isNil ifTrue:[^ self].
- (methodCategoryListView isNil
- and:[methodListView isNil]) ifTrue:[^ self].
-
- name := variableListView selectionValue.
- name isNil ifTrue:[^ self].
-
- self withCursor:(Cursor questionMark) do:[
- |classes filter any|
-
- classes := Array with:actualClass.
- currentClassHierarchy notNil ifTrue:[
- classes := classes , actualClass allSuperclasses.
- redefinedSelectors := IdentitySet new.
- ].
-
- showInstance ifTrue:[
- filter := self class filterToSearchInstRefsTo:name modificationsOnly:false
- ] ifFalse:[
- filter := self class filterToSearchClassRefsTo:name modificationsOnly:false
- ].
-
- any := false.
- "
- highlight the method that ref this variable
- "
- classes do:[:someClass |
- (fullProtocol
- and:[classListView valueIsInSelection:(someClass name)]) ifFalse:[
- someClass methodArray with:someClass selectorArray
- do:[:method :selector |
-
- (inCat
- or:[methodListView list notNil
- and:[methodListView list includes:selector]])
- ifTrue:[
- (redefinedSelectors isNil
- or:[(redefinedSelectors includes:selector) not])
- ifTrue:[
- (filter value:someClass value:method value:selector) ifTrue:[
- |idx cat|
-
- (inCat
- and:[methodCategoryListView notNil
- and:[methodCategoryListView list notNil]]) ifTrue:[
- cat := method category.
- "
- highlight the methodCategory
- "
- idx := methodCategoryListView list indexOf:cat.
- idx ~~ 0 ifTrue:[
- methodCategoryListView attributeAt:idx put:#bold.
- ].
- ].
-
- (inMethods
- and:[methodListView notNil
- and:[methodListView list notNil]]) ifTrue:[
- "
- highlight the method
- "
- idx := methodListView list indexOf:selector.
- idx ~~ 0 ifTrue:[
- methodListView attributeAt:idx put:#bold.
- ].
- any := true
- ].
- ].
- redefinedSelectors notNil ifTrue:[
- redefinedSelectors add:selector
- ]
- ]
- ]
- ]
- ]
- ].
- any ifTrue:[
- self setSearchPattern:name
- ]
- ]
-!
-
-hilightMethodsInMethodCategoryList
- "search for methods which access the selected
- variable, and highlight them"
-
- self hilightMethodsInMethodCategoryList:true inMethodList:false
-
-
-
-!
-
-unhilightMethodCategories
- "unhighlight items in method list"
-
- variableListView isNil ifTrue:[^ self].
-
- methodCategoryListView notNil ifTrue:[
- 1 to:methodCategoryListView list size do:[:entry |
- methodCategoryListView attributeAt:entry put:nil.
- ]
- ].
-
-
-!
-
-hilightMethodsInMethodList
- "search for methods which access the selected
- variable, and highlight them"
-
- self hilightMethodsInMethodCategoryList:false inMethodList:true
-
+showNoneFound
+ DialogView warn:(BrowserView classResources string:'None found').
! !
-!SystemBrowser methodsFor:'class list menu'!
-
-classDefinition
- "show class definition in codeView and setup accept-action for
- a class-definition change.
- Extract documentation either from a documentation method or
- from the comment - not a biggy, but beginners will like
- it when exploring the system."
-
- self doClassMenu:[:currentClass |
- |m s aStream isComment|
-
- aStream := WriteStream on:(String new:200).
- currentClass fileOutDefinitionOn:aStream.
-
- currentClass isLoaded ifTrue:[
- "
- add documentation as a comment, if there is any
- "
- m := currentClass class compiledMethodAt:#documentation.
- m notNil ifTrue:[
- s := m comment.
- isComment := false.
- ] ifFalse:[
- "try comment"
- s := currentClass comment.
- s notNil ifTrue:[
- isComment := true
- ]
- ].
- ].
- s notNil ifTrue:[
- aStream cr.
- aStream cr.
- aStream cr.
- aStream cr.
- aStream cr.
- aStream nextPut:$" ; cr; nextPutAll:' Documentation:'; cr.
- aStream cr.
- aStream nextPutAll:s.
- aStream cr; cr.
- aStream nextPutAll:' Notice: '; cr.
- aStream nextPutAll:' the above string has been extracted from the classes '.
- aStream nextPutAll:(isComment ifTrue:['comment.'] ifFalse:['documentation method.']).
- aStream cr.
- aStream nextPutAll:' It will not be preserved when accepting a new class definition.'; cr.
- aStream nextPut:$".
- ].
-
- codeView contents:(aStream contents).
- codeView modified:false.
- codeView acceptAction:[:theCode |
- codeView cursor:Cursor execute.
- Object abortSignal catch:[
- (Compiler evaluate:theCode asString notifying:codeView compile:false)
- isBehavior ifTrue:[
- codeView modified:false.
- self classCategoryUpdate.
- self updateClassListWithScroll:false.
- ]
- ].
- codeView cursor:Cursor normal.
- ].
- codeView explainAction:nil.
-
- methodListView notNil ifTrue:[
- methodListView deselect
- ].
- aspect := #definition.
- self normalLabel
- ]
-!
-
-classMenu
- "sent by classListView to ask for the menu"
-
- |labels selectors|
-
- currentClass isNil ifTrue:[
- labels := #(
- 'new class'
- ).
- selectors := #(
- classNewClass
- ).
- ] ifFalse:[
- fullProtocol ifTrue:[
- labels := #(
- 'hierarchy'
- 'definition'
- 'comment'
- 'class instvars'
- ).
- selectors := #(
- classHierarchy
- classDefinition
- classComment
- classClassInstVars
- ).
- ] ifFalse:[
- labels := #(
- 'fileOut'
- 'printOut'
- 'printOut protocol'
- " 'printOut full protocol' "
- '-'
- 'SPAWN_CLASS'
- 'spawn full protocol'
- 'spawn hierarchy'
- 'spawn subclasses'
- '-'
- ).
- selectors := #(
- classFileOut
- classPrintOut
- classPrintOutProtocol
- " classPrintOutFullProtocol "
- nil
- classSpawn
- classSpawnFullProtocol
- classSpawnHierarchy
- classSpawnSubclasses
- nil
- ).
-
- fullClass ifFalse:[
- labels := labels , #(
- 'hierarchy'
- 'definition'
- 'comment'
- 'class instvars'
- "/ 'protocols'
- '-'
- ).
- selectors := selectors , #(
- classHierarchy
- classDefinition
- classComment
- classClassInstVars
- "/ classProtocols
- nil
- ).
- ].
-
- "
- dont offer this menu for now - you cannot recompile
- the stuff anyway. So there is only confusion in showing
- those ...
- "
- false "currentClass primitiveSpec notNil" ifTrue:[
- labels := labels , #(
- 'primitive definitions'
- 'primitive variables'
- 'primitive functions'
- '-'
- ).
- selectors := selectors , #(
- classPrimitiveDefinitions
- classPrimitiveVariables
- classPrimitiveFunctions
- nil
- ).
- ].
-
- labels := labels , #(
- "/ 'variable search'
- 'class refs'
- '-'
- 'new class'
- 'new subclass'
- 'rename ...'
- 'remove'
- ).
- selectors := selectors , #(
- "/ variables
- classRefs
- nil
- classNewClass
- classNewSubclass
- classRename
- classRemove
- ).
- ]
- ].
-
-
- ^ PopUpMenu labels:(resources array:labels)
- selectors:selectors
- receiver:self
- for:classListView.
-!
-
-classFileOut
- "fileOut the current class.
- Catch errors (sure, you like to know if it failed) and
- warn if any)"
-
- self doClassMenu:[:currentClass |
- self busyLabel:'saving %1' with:currentClass name.
- Class fileOutErrorSignal handle:[:ex |
- self warn:'cannot create: %1' with:ex parameter.
- ex return.
- ] do:[
- currentClass fileOut.
- ].
- self normalLabel.
- ]
-!
-
-doClassMenuWithSelection:aBlock
- "a helper - if there is a selection, which represents a classes name,
- evaluate aBlock, passing that class and optional selector as arguments.
- Otherwise, check if a class is selected and evaluate aBlock with the
- current class."
-
- |string words clsName cls sel isMeta|
-
- string := codeView selection.
- string notNil ifTrue:[
- self extractClassAndSelectorFromSelectionInto:[:c :s :m |
- clsName := c.
- sel := s.
- isMeta := m.
- ].
- clsName isNil ifTrue:[
- string := string asString withoutSeparators.
- words := string asCollectionOfWords.
- words notNil ifTrue:[
- clsName := words first.
- (clsName endsWith:'class') ifTrue:[
- isMeta := true.
- clsName := clsName copyTo:(clsName size - 5)
- ] ifFalse:[
- isMeta := false
- ].
- sel := Parser selectorInExpression:string.
- ]
- ].
- clsName notNil ifTrue:[
- (cls := Smalltalk classNamed:clsName) notNil ifTrue:[
- isMeta ifTrue:[
- cls := cls class
- ].
- self withWaitCursorDo:[
- aBlock value:cls value:sel.
- ].
- ^ self
- ] ifFalse:[
- self warn:'no class named: %1 - spawning current' with:clsName
- ]
- ].
- ].
-
- classMethodListView notNil ifTrue:[
- sel := classMethodListView selectionValue.
- sel notNil ifTrue:[
- sel := self selectorFromClassMethodString:sel
- ]
- ].
- self doClassMenu:[:currentClass | aBlock value:currentClass value:sel]
-!
-
-classSpawn
- "create a new SystemBrowser browsing current class,
- or if there is a selection, spawn a browser on the selected class
- even a class/selector pair can be specified."
-
- self doClassMenuWithSelection:[:cls :sel |
- |browser|
-
- cls isMeta ifTrue:[
- Smalltalk allBehaviorsDo:[:aClass |
- aClass class == cls ifTrue:[
- browser := self class browseClass:aClass.
- browser classProtocol.
- sel notNil ifTrue:[
- browser switchToMethodNamed:sel
- ].
- ^ self
- ].
- ].
- self warn:'oops, no class for this metaclass'.
- ^ self
- ].
- browser := self class browseClass:cls.
- cls hasMethods ifFalse:[
- browser classProtocol.
- ].
- sel notNil ifTrue:[
- browser switchToMethodNamed:sel
- ].
- ]
-
- "
- select 'Smalltalk allClassesDo:' and use spawn from the class menu
- select 'Smalltalk' and use spawn from the class menu
- "
-!
-
-classSpawnHierarchy
- "create a new HierarchyBrowser browsing current class"
-
- self doClassMenuWithSelection:[:cls :sel |
- self class browseClassHierarchy:cls
- ]
-!
-
-classSpawnSubclasses
- "create a new browser browsing current class's subclasses"
-
- self doClassMenuWithSelection:[:cls :sel |
- |subs|
-
- subs := cls allSubclasses.
- (subs notNil and:[subs size ~~ 0]) ifTrue:[
- self class browseClasses:subs title:('subclasses of ' , cls name)
- ]
- ]
-!
-
-classPrintOutFullProtocol
- self doClassMenu:[:currentClass |
- |printStream|
-
- printStream := Printer new.
- currentClass printOutFullProtocolOn:printStream.
- printStream close
- ]
-!
-
-classPrintOutProtocol
- self doClassMenu:[:currentClass |
- |printStream|
-
- printStream := Printer new.
- currentClass printOutProtocolOn:printStream.
- printStream close
- ]
-!
-
-classPrintOut
- self doClassMenu:[:currentClass |
- |printStream|
-
- printStream := Printer new.
- currentClass printOutOn:printStream.
- printStream close
- ]
-!
-
-classHierarchy
- "show current classes hierarchy in codeView"
-
- self doClassMenu:[:currentClass |
- |aStream|
-
- aStream := WriteStream on:(String new:200).
- actualClass printHierarchyOn:aStream.
- codeView contents:(aStream contents).
- codeView modified:false.
- codeView acceptAction:nil.
- codeView explainAction:nil.
- methodListView notNil ifTrue:[
- methodListView deselect
- ].
- aspect := #hierarchy.
- self normalLabel
- ]
-!
-
-classNewClass
- "create a class-definition prototype in codeview"
-
- |nm cat|
-
- currentClass notNil ifTrue:[
- nm := currentClass superclass name
- ] ifFalse:[
- nm := 'Object'
- ].
- cat := currentClassCategory.
- cat isNil ifTrue:[
- cat := 'no category'
- ].
- self classClassDefinitionTemplateFor:nm in:cat.
- aspect := nil.
-!
-
-classClassInstVars
- "show class instance variables in codeView and setup accept-action
- for a class-instvar-definition change"
-
- self doClassMenu:[:currentClass |
- |s|
-
- s := WriteStream on:(String new).
- currentClass fileOutClassInstVarDefinitionOn:s.
- codeView contents:(s contents).
- codeView modified:false.
- codeView acceptAction:[:theCode |
- codeView cursor:Cursor execute.
- Object abortSignal catch:[
- Compiler evaluate:theCode asString notifying:codeView compile:false.
- codeView modified:false.
- self updateClassList.
- ].
- codeView cursor:Cursor normal.
- ].
- codeView explainAction:nil.
- methodListView notNil ifTrue:[
- methodListView deselect
- ].
- aspect := #classInstVars.
- self normalLabel
- ]
-!
-
-classSpawnFullProtocol
- "create a new browser, browsing current classes full protocol"
-
- self doClassMenuWithSelection:[:cls :sel |
- self class browseFullClassProtocol:cls
- ]
-!
-
-classProtocols
- ^ self
-!
-
-classRemove
- "user requested remove of current class and all subclasses -
- count subclasses and let user confirm removal."
-
- |count t box|
-
- currentClass notNil ifTrue:[
- count := currentClass allSubclasses size.
- t := 'remove %1'.
- count ~~ 0 ifTrue:[
- t := t , '\(with %2 subclass'.
- count ~~ 1 ifTrue:[
- t := t , 'es'
- ].
- t := (t , ')')
- ].
- t := t , ' ?'.
- t := (resources string:t with:currentClass name with:count) withCRs.
-
- box := YesNoBox
- title:t
- yesText:(resources at:'remove')
- noText:(resources at:'abort').
- box confirm ifTrue:[
- "after querying user - do really remove current class
- and all subclasses
- "
- self doClassMenu:[:currentClass |
- |didRemove|
-
- didRemove := false.
-
- "
- query ?
- "
- currentClass allSubclassesDo:[:aSubClass |
- (CheckForInstancesWhenRemovingClasses not
- or:[aSubClass hasInstances not
- or:[self confirm:(aSubClass name , ' has instances - remove anyway ?')]])
- ifTrue:[
- Smalltalk removeClass:aSubClass
- ]
- ].
- (CheckForInstancesWhenRemovingClasses not
- or:[currentClass hasInstances not
- or:[self confirm:(currentClass name , ' has instances - remove anyway ?')]])
- ifTrue:[
- didRemove := true.
- Smalltalk removeClass:currentClass.
- ].
-
- self switchToClass:nil.
- Smalltalk changed.
- self updateClassList.
-
- "if it was the last in its category, update class category list"
-"
- classListView numberOfLines == 0 ifTrue:[
- self updateClassCategoryListWithScroll:false
- ].
-"
- didRemove ifTrue:[
- methodCategoryListView notNil ifTrue:[methodCategoryListView contents:nil].
- methodListView notNil ifTrue:[methodListView contents:nil].
- codeView contents:nil.
- codeView modified:false
- ]
- ]
- ]
- ]
-!
-
-classShowFrom:getSelector set:setSelector aspect:aspectSymbol
- "common helper for comment, primitive-stuff etc.
- show the string returned from the classes getSelector-method,
- Set acceptaction to change it via setSelector."
-
- self doClassMenu:[:currentClass |
- codeView contents:(currentClass perform:getSelector).
- codeView modified:false.
- codeView acceptAction:[:theCode |
- Object abortSignal catch:[
- lockUpdates := true.
- currentClass perform:setSelector with:theCode asString.
- codeView modified:false.
- ].
- lockUpdates := false.
- ].
- codeView explainAction:nil.
-
- methodListView notNil ifTrue:[
- methodListView deselect
- ].
- aspect := aspectSymbol.
- self normalLabel
- ]
-!
-
-classComment
- "show the classes comment in the codeView.
- Also, set acceptaction to change the comment."
-
- self classShowFrom:#comment set:#comment: aspect:#comment
-!
-
-classPrimitiveDefinitions
- "show the classes primitiveDefinition in the codeView.
- Also, set acceptaction to change it."
-
- self classShowFrom:#primitiveDefinitionsString set:#primitiveDefinitions: aspect:#primitiveDefinitions
-!
-
-classPrimitiveVariables
- "show the classes primitiveVariables in the codeView.
- Also, set acceptaction to change it."
-
- self classShowFrom:#primitiveVariablesString set:#primitiveVariables: aspect:#primitiveVariables
-!
-
-classPrimitiveFunctions
- "show the classes primitiveFunctions in the codeView.
- Also, set acceptaction to change it."
-
- self classShowFrom:#primitiveFunctionsString set:#primitiveFunctions: aspect:#primitiveFunctions
-!
-
-classRefs
- self doClassMenu:[:currentClass |
- self withCursor:(Cursor questionMark) do:[
- self class browseReferendsOf:currentClass name asSymbol
- ]
- ]
-!
-
-classNewSubclass
- "create a subclass-definition prototype in codeview"
-
- self doClassMenu:[:currentClass |
- self classClassDefinitionTemplateFor:(currentClass name)
- in:(currentClass category).
- aspect := nil
- ]
-!
-
-classUses
- "a powerful tool, when trying to learn more about where
- a class is used. This one searches all uses of a class,
- and shows a list of uses - try it and like it"
-
- self doClassMenu:[:currentClass |
- self withCursor:(Cursor questionMark) do:[
- self class browseUsesOf:currentClass
- ]
- ]
-!
-
-classRename
- "launch an enterBox for new name and query user"
-
- |box|
-
- self checkClassSelected ifFalse:[^ self].
- box := self enterBoxTitle:(resources string:'rename %1 to:' with:currentClass name) okText:'rename'.
- box initialText:(currentClass name).
- box action:[:aString | self renameCurrentClassTo:aString].
- box showAtPointer
-! !
-
-!SystemBrowser methodsFor:'class category stuff'!
-
-checkClassCategorySelected
- currentClassCategory isNil ifTrue:[
- self warn:'select a class category first'.
- ^ false
- ].
- ^ true
-!
-
-listOfAllClassCategories
- "return a list of all class categories"
-
- |newList cat|
-
- newList := OrderedCollection with:'* all *' with:'* hierarchy *'.
- Smalltalk allBehaviorsDo:[:aClass |
- cat := aClass category.
- cat isNil ifTrue:[
- cat := '* no category *'
- ].
- newList indexOf:cat ifAbsent:[newList add:cat]
- ].
- ^ newList asArray sort.
-!
-
-classCategorySelectionChanged
- "class category has changed - update dependent views"
-
- self withWaitCursorDo:[
- self switchToClass:nil.
- actualClass := acceptClass := nil.
- currentMethodCategory := nil.
- currentMethod := currentSelector := nil.
-
- self updateClassList.
- self updateMethodCategoryList.
- self updateMethodList.
- self updateCodeView.
-
- codeView explainAction:nil.
- codeView acceptAction:nil
- ]
-!
-
-classCategorySelection:lineNr
- "user clicked on a class category line - show classes.
- If switching to hierarchy or all, keep current selections"
-
- |newCategory oldClass oldName classIndex|
-
- newCategory := classCategoryListView selectionValue.
- (newCategory startsWith:'*') ifTrue:[
- "etiher all or hierarchy;
- remember current selections and switch after showing class list"
- oldClass := currentClass
- ].
- currentClassCategory := newCategory.
- oldClass isNil ifTrue:[
- self classCategorySelectionChanged
- ] ifFalse:[
- oldName := oldClass name.
- self withWaitCursorDo:[
- self updateClassList
- ].
- "stupid - search for class name in (indented) list"
- classIndex := classListView list findFirst:[:elem | elem endsWith:oldName].
- classIndex ~~ 0 ifTrue:[
- classListView selection:classIndex.
- self switchToClass:(Smalltalk at:(oldName asSymbol))
- ] ifFalse:[
- self normalLabel.
- ]
- ]
-!
-
-updateClassCategoryListWithScroll:scroll
- |oldClassCategory oldClass oldMethodCategory oldMethod
- oldSelector newCategoryList|
-
- classMethodListView notNil ifTrue:[ ^ self ].
-
- oldClassCategory := currentClassCategory.
- oldClass := currentClass.
- oldMethodCategory := currentMethodCategory.
- oldMethod := currentMethod.
- oldMethod notNil ifTrue:[
- oldSelector := currentSelector
- ].
-
- classCategoryListView notNil ifTrue:[
- newCategoryList := self listOfAllClassCategories.
- newCategoryList = classCategoryListView list ifFalse:[
- scroll ifTrue:[
- classCategoryListView contents:newCategoryList
- ] ifFalse:[
- classCategoryListView setContents:newCategoryList
- ]
- ]
- ].
-
- oldClassCategory notNil ifTrue:[
- classCategoryListView notNil ifTrue:[
- classCategoryListView selectElement:oldClassCategory
- ]
- ].
- classListView notNil ifTrue:[
- oldClass notNil ifTrue:[
- classListView selectElement:(oldClass name)
- ]
- ].
- oldMethodCategory notNil ifTrue:[
- methodCategoryListView notNil ifTrue:[
- methodCategoryListView selectElement:oldMethodCategory
- ].
- ].
- oldSelector notNil ifTrue:[
- methodListView notNil ifTrue:[
- methodListView selectElement:oldSelector
- ].
- ]
-!
-
-updateClassCategoryList
- self updateClassCategoryListWithScroll:true
-!
-
-allClassesInCurrentCategoryInOrderDo:aBlock
- "evaluate aBlock for all classes in the current class category;
- superclasses come first - then subclasses"
-
- |classes|
-
- currentClassCategory notNil ifTrue:[
- classes := OrderedCollection new.
- Smalltalk allBehaviorsDo:[:aClass |
- aClass isMeta ifFalse:[
- (aClass category = currentClassCategory) ifTrue:[
- classes add:aClass
- ]
- ]
- ].
- classes topologicalSort:[:a :b | b isSubclassOf:a].
- classes do:aBlock
- ]
-!
-
-allClassesInCurrentCategoryDo:aBlock
- "evaluate aBlock for all classes in the current class category;
- superclasses come first - then subclasses"
-
- currentClassCategory notNil ifTrue:[
- Smalltalk allBehaviorsDo:[:aClass |
- aClass isMeta ifFalse:[
- (aClass category = currentClassCategory) ifTrue:[
- aBlock value:aClass
- ]
- ]
- ].
- ]
-!
-
-renameCurrentClassCategoryTo:aString
- "helper - do the rename"
-
- |any categories|
-
- currentClassCategory notNil ifTrue:[
- any := false.
- Smalltalk allBehaviorsDo:[:aClass |
- aClass category = currentClassCategory ifTrue:[
- aClass category:aString.
- any := true
- ]
- ].
- any ifFalse:[
- categories := classCategoryListView list.
- categories remove:currentClassCategory.
- categories add:aString.
- categories sort.
- classCategoryListView setContents:categories.
- currentClassCategory := aString.
- classCategoryListView selectElement:aString.
- ] ifTrue:[
- currentClassCategory := aString.
- self updateClassCategoryList.
- self updateClassListWithScroll:false
- ]
- ]
-! !
-
-!SystemBrowser methodsFor:'class-method stuff'!
-
-classFromClassMethodString:aString
- "helper for classMethod-list - extract class name from the string"
-
- |pos|
-
- pos := aString indexOf:(Character space).
- ^ aString copyTo:(pos - 1)
-!
-
-selectorFromClassMethodString:aString
- "helper for classMethod-list - extract selector from the string"
-
- |pos|
-
- pos := aString indexOf:(Character space).
- ^ aString copyFrom:(pos + 1)
-!
-
-classMethodSelection:lineNr
- "user clicked on a class/method line - show code"
-
- |string classString selectorString|
-
- string := classMethodListView selectionValue.
- classString := self classFromClassMethodString:string.
- selectorString := self selectorFromClassMethodString:string.
- ((classString ~= 'Metaclass') and:[classString endsWith:'class']) ifTrue:[
- classString := classString copyTo:(classString size - 5).
- self switchToClass:(Smalltalk at:classString asSymbol).
- actualClass := acceptClass := currentClass class
- ] ifFalse:[
- self switchToClass:(Smalltalk at:classString asSymbol).
- actualClass := acceptClass := currentClass
- ].
- currentClass isNil ifTrue:[
- self warn:'oops class is gone'
- ] ifFalse:[
- currentClassCategory := currentClass category.
- currentSelector := selectorString asSymbol.
- currentMethod := actualClass compiledMethodAt:currentSelector.
- currentMethodCategory := currentMethod category.
-
- self methodSelectionChanged
- ].
-
- self setDoitActionForClass
-! !
-
-!SystemBrowser methodsFor:'class category list menu'!
-
-classCategoryMenu
- |labels selectors|
-
- currentClassCategory isNil ifTrue:[
- labels := #(
- 'spawn full class'
- '-'
- 'update'
- 'find class ...'
- '-'
- 'new class category ...'
- ).
- selectors := #(
- classCategorySpawnFullClass
- nil
- classCategoryUpdate
- classCategoryFindClass
- nil
- classCategoryNewCategory
- ).
- ] ifFalse:[
- labels := #(
- 'fileOut'
- 'fileOut each'
-"
- 'fileOut binary'
-"
- 'printOut'
- 'printOut protocol'
- '-'
- 'SPAWN_CATEGORY'
- 'spawn full class'
- '-'
- 'update'
- 'find class ...'
- '-'
- 'new class category ...'
- 'rename ...'
- 'remove'
- ).
- selectors := #(
- classCategoryFileOut
- classCategoryFileOutEach
- classCategoryPrintOut
- classCategoryPrintOutProtocol
- nil
- classCategorySpawn
- classCategorySpawnFullClass
- nil
- classCategoryUpdate
- classCategoryFindClass
- nil
- classCategoryNewCategory
- classCategoryRename
- classCategoryRemove
- ).
- ].
-
- ^ (PopUpMenu labels:(resources array:labels)
- selectors:selectors
- receiver:self)
-!
-
-classCategoryUpdate
- "update class category list and dependants"
-
- |oldClassName oldMethodCategory|
-
- classCategoryListView notNil ifTrue:[
- currentClass notNil ifTrue:[
- oldClassName := currentClass name.
- (oldClassName endsWith:'-old') ifTrue:[
- oldClassName := oldClassName copyTo:(oldClassName size - 4)
- ]
- ].
- oldMethodCategory := currentMethodCategory.
-
- classCategoryListView setContents:(self listOfAllClassCategories).
- currentClassCategory notNil ifTrue:[
- classCategoryListView selectElement:currentClassCategory.
- self classCategorySelectionChanged.
- oldClassName notNil ifTrue:[
- classListView selectElement:oldClassName.
- self switchToClass:(Smalltalk at:oldClassName asSymbol).
- self classSelectionChanged.
- oldMethodCategory notNil ifTrue:[
- methodCategoryListView selectElement:oldMethodCategory.
- currentMethodCategory := oldMethodCategory.
- self methodCategorySelectionChanged
- ]
- ]
- ]
- ]
-!
-
-classCategoryPrintOutProtocol
- |printStream|
-
- self allClassesInCurrentCategoryInOrderDo:[:aClass |
- printStream := Printer new.
- aClass printOutProtocolOn:printStream.
- printStream close
- ]
-!
-
-classCategoryPrintOut
- |printStream|
-
- self allClassesInCurrentCategoryDo:[:aClass |
- printStream := Printer new.
- aClass printOutOn:printStream.
- printStream close
- ]
-!
-
-classCategorySpawn
- "create a new SystemBrowser browsing current classCategory"
-
- currentClassCategory notNil ifTrue:[
- self withWaitCursorDo:[
- self class browseClassCategory:currentClassCategory
- ]
- ]
-!
-
-classCategoryFileOut
- "create a file 'categoryName' consisting of all classes in current category"
-
- |aStream fileName|
-
- self checkClassCategorySelected ifFalse:[^ self].
-
- fileName := currentClassCategory asString.
- fileName replaceAll:Character space by:$_.
- "
- this test allows a smalltalk to be built without Projects/ChangeSets
- "
- Project notNil ifTrue:[
- fileName := Project currentProjectDirectory , fileName.
- ].
-
- "
- if file exists, save original in a .sav file
- "
- fileName asFilename exists ifTrue:[
- fileName asFilename copyTo:(fileName , '.sav')
- ].
- aStream := FileStream newFileNamed:fileName.
- aStream isNil ifTrue:[
- ^ self warn:'cannot create: %1' with:fileName
- ].
- self withWaitCursorDo:[
- self busyLabel:'writing: %1' with:fileName.
- self allClassesInCurrentCategoryInOrderDo:[:aClass |
- aClass fileOutOn:aStream.
- ].
- aStream close.
- self normalLabel.
- ]
-!
-
-classCategorySpawnFullClass
- "create a new SystemBrowser browsing full class"
-
- |newBrowser|
-
- self withWaitCursorDo:[
- newBrowser := self class browseFullClasses
-" "
- .
- currentClass notNil ifTrue:[
- newBrowser switchToClassNamed:(currentClass name)
- ]
-" "
- ]
-!
-
-classCategoryFileOutEach
- self withWaitCursorDo:[
- self allClassesInCurrentCategoryDo:[:aClass |
- self busyLabel:'saving: ' with:aClass name.
- Class fileOutErrorSignal handle:[:ex |
- self warn:'cannot create: %1' with:ex parameter.
- ex return.
- ] do:[
- aClass fileOut
- ]
- ].
- self normalLabel.
- ]
-!
-
-classCategoryNewCategory
- |box|
-
- box := self enterBoxTitle:'name of new class category:' okText:'create'.
- box action:[:aString |
- |categories|
-
- currentClass notNil ifTrue:[
- categories := OrderedCollection new.
- currentClass withAllSuperclasses do:[:aClass |
- aClass methodArray do:[:aMethod |
- (categories includes:aMethod category) ifFalse:[
- categories add:aMethod category
- ]
- ]
- ].
- ].
- categories isNil ifTrue:[
- categories := classCategoryListView list.
- ].
- (categories includes:aString) ifFalse:[
- categories add:aString.
- categories sort.
- classCategoryListView setContents:categories.
- currentClassCategory := aString.
- classCategoryListView selectElement:aString.
- self switchToClass:nil.
- actualClass := acceptClass := nil.
- self classCategorySelectionChanged
- ]
- ].
- box showAtPointer
-!
-
-classCategoryFindClass
- |box|
-
- box := self enterBoxForCodeSelectionTitle:'class to find:' okText:'find'.
- box action:[:aString | self switchToClassNameMatching:aString].
- box showAtPointer
-!
-
-classCategoryRename
- "launch an enterBox to rename current class category"
-
- |box|
-
- self checkClassCategorySelected ifFalse:[^ self].
-
- box := self enterBoxTitle:'rename class category to:' okText:'rename'.
- box initialText:currentClassCategory.
- box action:[:aString | self renameCurrentClassCategoryTo:aString].
- box showAtPointer
-!
-
-classCategoryRemove
- "remove all classes in current category"
-
- |count t classesToRemove subclassesRemoved box|
-
- self checkClassCategorySelected ifFalse:[^ self].
-
- classesToRemove := OrderedCollection new.
- Smalltalk allBehaviorsDo:[:aClass |
- aClass category = currentClassCategory ifTrue:[
- classesToRemove add:aClass
- ]
- ].
- subclassesRemoved := OrderedCollection new.
- classesToRemove do:[:aClass |
- aClass allSubclassesDo:[:aSubclass |
- (classesToRemove includes:aSubclass) ifFalse:[
- (subclassesRemoved includes:aSubclass) ifFalse:[
- subclassesRemoved add:aSubclass
- ]
- ]
- ]
- ].
-
- count := classesToRemove size.
- t := resources string:'remove %1 ?' with:currentClassCategory.
- count ~~ 0 ifTrue:[
- t := t , (resources at:'\(with ') , count printString.
- count == 1 ifTrue:[
- t := t , (resources at:' class')
- ] ifFalse:[
- t := t , (resources at:' classes')
- ].
- t := (t , ')') withCRs
- ].
-
- count := subclassesRemoved size.
- count ~~ 0 ifTrue:[
- t := t , (resources at:'\(and ') , count printString.
- count == 1 ifTrue:[
- t := t , (resources at:' subclass ')
- ] ifFalse:[
- t := t , (resources at:' subclasses ')
- ].
- t := (t , ')') withCRs
- ].
-
- t := t withCRs.
-
- box := YesNoBox
- title:t
- yesText:(resources at:'remove')
- noText:(resources at:'abort').
- box confirm ifTrue:[
- "after querying user - do really remove classes in list1 and list2"
-
- subclassesRemoved do:[:aClass |
- (CheckForInstancesWhenRemovingClasses not
- or:[aClass hasInstances not
- or:[self confirm:(aClass name , ' has instances - remove anyway ?')]])
- ifTrue:[
- Smalltalk removeClass:aClass
- ]
- ].
- classesToRemove do:[:aClass |
- (CheckForInstancesWhenRemovingClasses not
- or:[aClass hasInstances not
- or:[self confirm:(aClass name , ' has instances - remove anyway ?')]])
- ifTrue:[
- Smalltalk removeClass:aClass
- ].
- ].
- currentClassCategory := nil.
- self switchToClass:nil.
- Smalltalk changed
- ]
-! !
-
-!SystemBrowser methodsFor:'method category list menu'!
-
-methodCategoryMenu
- |labels selectors i|
-
- currentClass isNil ifTrue:[
- methodCategoryListView flash.
- ^ nil
- ].
- currentMethodCategory isNil ifTrue:[
- labels := #(
- 'find method here ...'
- 'find method ...'
- '-'
- 'new category ...'
- 'create access methods'
- ).
- selectors := #(
- methodCategoryFindMethod
- methodCategoryFindAnyMethod
- nil
- methodCategoryNewCategory
- methodCategoryCreateAccessMethods
- ).
- ] ifFalse:[
- labels := #(
- 'fileOut'
- 'fileOut all'
- 'printOut'
- '-'
- 'SPAWN_METHODCATEGORY'
- 'spawn category'
- '-'
- 'find method here ...'
- 'find method ...'
- '-'
- 'new category ...'
- 'copy category ...'
- 'create access methods'
- 'rename ...'
- 'remove'
- ).
- selectors := #(
- methodCategoryFileOut
- methodCategoryFileOutAll
- methodCategoryPrintOut
- nil
- methodCategorySpawn
- methodCategorySpawnCategory
- nil
- methodCategoryFindMethod
- methodCategoryFindAnyMethod
- nil
- methodCategoryNewCategory
- methodCategoryCopyCategory
- methodCategoryCreateAccessMethods
- methodCategoryRename
- methodCategoryRemove
- ).
- ].
-
- showInstance ifFalse:[
- labels := labels copy.
- selectors := selectors copy.
- i := labels indexOf:'create access methods'.
- labels at:i put:'create documentation stubs'.
- selectors at:i put:#methodCategoryCreateDocumentationMethods
- ].
-
- ^ (PopUpMenu labels:(resources array:labels)
- selectors:selectors
- receiver:self)
-!
-
-methodCategoryFindAnyMethod
- |box|
-
- box := self enterBoxForSearchSelectorTitle:'method selector to search for:'.
- box action:[:aString | self switchToAnyMethodNamed:aString].
- box showAtPointer
-!
-
-methodCategoryFindMethod
- |box|
-
- box := self enterBoxForSearchSelectorTitle:'method selector to search for:'.
- box action:[:aString | self switchToMethodNamed:aString].
- box showAtPointer
-!
-
-methodCategoryPrintOut
- |printStream|
-
- self checkClassSelected ifFalse:[^ self].
- self whenMethodCategorySelected:[
- printStream := Printer new.
- actualClass printOutCategory:currentMethodCategory on:printStream.
- printStream close
- ]
-!
-
-methodCategoryFileOut
- "fileOut all methods in the selected methodcategory of
- the current class"
-
- self checkClassSelected ifFalse:[^ self].
- self whenMethodCategorySelected:[
- self busyLabel:'saving: %1' with:currentClass name , '-' , currentMethodCategory.
- Class fileOutErrorSignal handle:[:ex |
- self warn:'cannot create: %1' with:ex parameter.
- ex return.
- ] do:[
- actualClass fileOutCategory:currentMethodCategory.
- ].
- self normalLabel.
- ]
-!
-
-methodCategorySpawn
- "create a new SystemBrowser browsing current method category"
-
- currentMethodCategory notNil ifTrue:[
- self withWaitCursorDo:[
- self class browseClass:actualClass
- methodCategory:currentMethodCategory
- ]
- ]
-!
-
-methodCategoryFileOutAll
- "fileOut all methods in the selected methodcategory of
- the current class"
-
-
- self whenMethodCategorySelected:[
- |fileName outStream|
-
- fileName := currentMethodCategory , '.st'.
- fileName replaceAll:Character space by:$_.
- "
- this test allows a smalltalk to be built without Projects/ChangeSets
- "
- Project notNil ifTrue:[
- fileName := Project currentProjectDirectory , fileName.
- ].
- "
- if file exists, save original in a .sav file
- "
- fileName asFilename exists ifTrue:[
- fileName asFilename copyTo:(fileName , '.sav')
- ].
- outStream := FileStream newFileNamed:fileName.
- outStream isNil ifTrue:[
- ^ self warn:'cannot create: %1' with:fileName
- ].
-
- self busyLabel:'saving: ' with:currentMethodCategory.
- Class fileOutErrorSignal handle:[:ex |
- self warn:'cannot create: %1' with:ex parameter.
- ex return
- ] do:[
- Smalltalk allBehaviorsDo:[:class |
- |hasMethodsInThisCategory|
-
- hasMethodsInThisCategory := false.
- class methodArray do:[:method |
- method category = currentMethodCategory ifTrue:[
- hasMethodsInThisCategory := true
- ]
- ].
- hasMethodsInThisCategory ifTrue:[
- class fileOutCategory:currentMethodCategory on:outStream.
- outStream cr
- ].
- hasMethodsInThisCategory := false.
- class class methodArray do:[:method |
- method category = currentMethodCategory ifTrue:[
- hasMethodsInThisCategory := true
- ]
- ].
- hasMethodsInThisCategory ifTrue:[
- class class fileOutCategory:currentMethodCategory on:outStream.
- outStream cr
- ]
- ].
- ].
- outStream close.
- self normalLabel.
- ].
-!
-
-methodCategoryNewCategory
- "show the enter box to add a new method category.
- Offer existing superclass categories in box to help avoiding
- useless typing."
-
- |someCategories existingCategories box|
-
- actualClass notNil ifTrue:[
- someCategories := actualClass allCategories
- ] ifFalse:[
- "
- mhmh - offer some typical categories ...
- "
- showInstance ifTrue:[
- someCategories := #('accessing'
- 'initialization'
- 'private'
- 'printing & storing'
- 'queries'
- 'testing'
- )
- ] ifFalse:[
- someCategories := #(
- 'documentation'
- 'initialization'
- 'instance creation'
- ).
- ].
- ].
- someCategories sort.
-
- "
- remove existing categories
- "
- existingCategories := methodCategoryListView list.
- existingCategories notNil ifTrue:[
- someCategories := someCategories select:[:cat | (existingCategories includes:cat) not].
- ].
-
- box := self listBoxTitle:'name of new method category:'
- okText:'create'
- list:someCategories.
- box action:[:aString | self newMethodCategory:aString].
- box showAtPointer
-
-
-
-!
-
-methodCategorySpawnCategory
- "create a new SystemBrowser browsing all methods from all
- classes with same category as current method category"
-
- self askAndBrowseMethodCategory:'category to browse methods:'
- action:[:aString |
- self class browseMethodCategory:aString
- ]
-!
-
-methodCategoryCreateAccessMethods
- "create access methods for all instvars"
-
- self checkClassSelected ifFalse:[^ self].
-
- showInstance ifFalse:[
- self warn:'select instance - and try again'.
- ^ self.
- ].
-
- self withWaitCursorDo:[
- |nm names source|
-
- (variableListView notNil
- and:[(nm := variableListView selectionValue) notNil]) ifTrue:[
- names := Array with:nm
- ] ifFalse:[
- names := currentClass instVarNames
- ].
- names do:[:name |
- "check, if method is not already present"
- (currentClass implements:(name asSymbol)) ifFalse:[
- source := (name , '\ "return ' , name , '"\\ ^ ' , name) withCRs.
- Compiler compile:source forClass:currentClass inCategory:'accessing'.
- ] ifTrue:[
- Transcript showCr:'method ''', name , ''' already present'
- ].
- (currentClass implements:((name , ':') asSymbol)) ifFalse:[
- source := (name , ':something\ "set ' , name , '"\\ ' , name , ' := something.') withCRs.
- Compiler compile:source forClass:currentClass inCategory:'accessing'.
- ] ifTrue:[
- Transcript showCr:'method ''', name , ':'' already present'
- ].
- ].
- self updateMethodCategoryListWithScroll:false.
- self updateMethodListWithScroll:false
- ]
-!
-
-methodCategoryCreateDocumentationMethods
- "create empty documentation methods"
-
- |cls|
-
- self checkClassSelected ifFalse:[^ self].
-
- cls := currentClass class.
-
- self withWaitCursorDo:[
- |nm names source|
-
- (cls implements:#version) ifFalse:[
- Compiler compile:
-'version
-"
-$' , 'Header$
-"
-' forClass:cls inCategory:'documentation'.
- ].
- (cls implements:#documentation) ifFalse:[
- Compiler compile:
-'documentation
-"
- documentation to be added.
-"
-' forClass:cls inCategory:'documentation'.
- ].
- (cls implements:#examples) ifFalse:[
- Compiler compile:
-'examples
-"
- examples to be added.
-"
-' forClass:cls inCategory:'documentation'.
- ].
- self classProtocol.
- self switchToMethodNamed:#documentation
-"/ self updateMethodCategoryListWithScroll:false.
-"/ self updateMethodListWithScroll:false
- ]
-!
-
-methodCategoryCopyCategory
- "show the enter box to copy from an existing method category"
-
- |title box|
-
- showInstance ifTrue:[
- title := 'class to copy instance method category from:'
- ] ifFalse:[
- title := 'class to copy class method category from:'
- ].
-
- box := self listBoxTitle:title
- okText:'ok'
- list:(Smalltalk allClasses collect:[:cls | cls name]) asArray sort.
-
- box action:[:aString | self copyMethodsFromClass:aString].
- box showAtPointer
-!
-
-methodCategoryRename
- "launch an enterBox to rename current method category"
-
- |box|
-
- self checkMethodCategorySelected ifFalse:[^ self].
-
- box := self enterBoxTitle:(resources string:'rename method category %1 to:' with:currentMethodCategory)
- okText:(resources at:'rename').
- box initialText:currentMethodCategory.
- box action:[:aString |
- actualClass renameCategory:currentMethodCategory to:aString.
- currentMethodCategory := aString.
- currentMethod := currentSelector := nil.
- self updateMethodCategoryList.
- self updateMethodListWithScroll:false
- ].
- box showAtPointer
-!
-
-methodCategoryRemove
- "show number of methods to remove and query user"
-
- |count t box|
-
- currentMethodCategory notNil ifTrue:[
- count := 0.
- actualClass methodArray do:[:aMethod |
- (aMethod category = currentMethodCategory) ifTrue:[
- count := count + 1
- ]
- ].
- (count == 0) ifTrue:[
- currentMethodCategory := nil.
- currentMethod := currentSelector := nil.
- self updateMethodCategoryListWithScroll:false.
- self updateMethodList
- ] ifFalse:[
- (count == 1) ifTrue:[
- t := 'remove %1\(with 1 method) ?'
- ] ifFalse:[
- t := 'remove %1\(with %2 methods) ?'
- ].
- t := resources string:t with:currentMethodCategory with:count printString.
- t := t withCRs.
-
- box := YesNoBox
- title:t
- yesText:(resources at:'remove')
- noText:(resources at:'abort').
- box confirm ifTrue:[
- actualClass methodArray do:[:aMethod |
- (aMethod category = currentMethodCategory) ifTrue:[
- actualClass
- removeSelector:(actualClass selectorForMethod:aMethod)
- ]
- ].
- currentMethodCategory := nil.
- currentMethod := currentSelector := nil.
- self updateMethodCategoryList.
- self updateMethodList
- ]
- ]
- ]
-! !
-
-!SystemBrowser methodsFor:'method list menu'!
-
-methodMenu
- "return a popupmenu as appropriate for the methodList"
-
- |labels selectors
- newLabels newSelectors
- mthdLabels mthdSelectors
- brkLabels brkSelectors
- fileLabels fileSelectors
- searchLabels searchSelectors
- sepLocalLabels sepLocalSelectors
- localSearchLabels localSearchSelectors|
-
- sepLocalLabels := sepLocalSelectors := #().
-
- searchLabels := #(
- 'senders ...'
- 'implementors ...'
- 'globals ...'
- 'string search ...'
- 'apropos ...'
- ).
- searchSelectors := #(
- methodSenders
- methodImplementors
- methodGlobalReferends
- methodStringSearch
- methodAproposSearch
- ).
-
- currentClass notNil ifTrue:[
- localSearchLabels := #(
- '-'
- 'local senders ...'
- 'local implementors ...'
- 'local string search ...'
- 'local apropos ...'
- ).
- localSearchSelectors := #(
- nil
- methodLocalSenders
- methodLocalImplementors
- methodLocalStringSearch
- methodLocalAproposSearch
- ).
- ] ifFalse:[
- localSearchLabels := localSearchSelectors := #()
- ].
-
- currentMethodCategory notNil ifTrue:[
- sepLocalLabels := #('-'). sepLocalSelectors := #(nil).
-
- newLabels := #(
- 'new method'
- ).
-
- newSelectors := #(
- methodNewMethod
- ).
- ] ifFalse:[
- newLabels := newSelectors := #()
- ].
-
- currentMethod notNil ifTrue:[
- fileLabels := #(
- 'fileOut'
- 'printOut'
- '-'
- 'SPAWN_METHOD'
- '-'
- ).
-
- fileSelectors := #(
- methodFileOut
- methodPrintOut
- nil
- methodSpawn
- nil
- ).
-
- sepLocalLabels := #('-'). sepLocalSelectors := #(nil).
-
- mthdLabels := #(
- 'change category ...'
- 'remove'
- ).
-
- mthdSelectors := #(
- methodChangeCategory
- methodRemove
- ).
-
- currentMethod isWrapped ifTrue:[
- brkLabels := #(
- 'remove break/trace'
- '-'
- ).
-
- brkSelectors := #(
- methodRemoveBreakOrTrace
- nil
- )
- ] ifFalse:[
- brkLabels := #(
- 'breakpoint'
- 'trace'
- 'trace sender'
- '-'
- ).
-
- brkSelectors := #(
- methodBreakPoint
- methodTrace
- methodTraceSender
- nil
- )
- ]
- ] ifFalse:[
- fileLabels := fileSelectors := #().
- brkLabels := brkSelectors := #().
- mthdLabels := mthdSelectors := #().
- ].
-
-
-
- labels :=
- fileLabels ,
- searchLabels ,
- localSearchLabels ,
- sepLocalLabels ,
- brkLabels ,
- newLabels ,
- mthdLabels.
-
- selectors :=
- fileSelectors ,
- searchSelectors ,
- localSearchSelectors ,
- sepLocalSelectors ,
- brkSelectors ,
- newSelectors ,
- mthdSelectors.
-
-"
- labels := #(
- 'fileOut'
- 'printOut'
- '-'
- 'SPAWN_METHOD'
- '-'
- 'senders ...'
- 'implementors ...'
- 'globals ...'
- 'string search ...'
- 'apropos ...'
- '-'
- 'local senders ...'
- 'local implementors ...'
- 'local string search ...'
- 'local apropos ...'
- '-'
- 'breakpoint'
- 'trace'
- 'trace sender'
- '-'
- 'new method'
- 'change category ...'
- 'remove'
- ).
- selectors := #(
- methodFileOut
- methodPrintOut
- nil
- methodSpawn
- nil
- methodSenders
- methodImplementors
- methodGlobalReferends
- methodStringSearch
- methodAproposSearch
- nil
- methodLocalSenders
- methodLocalImplementors
- methodLocalStringSearch
- methodLocalAproposSearch
- nil
- methodBreakPoint
- methodTrace
- methodTraceSender
- nil
- methodNewMethod
- methodChangeCategory
- methodRemove
- )
-"
-
- ^ PopUpMenu
- labels:(resources array:labels)
- selectors:selectors
- receiver:self
- for:methodListView
-!
-
-methodImplementors
- "launch an enterBox for selector to search for"
-
- self askAndBrowseSelectorTitle:'selector to browse implementors of:'
- action:[:aString |
- self class browseImplementorsOf:aString
- ]
-!
-
-methodSenders
- "launch an enterBox for selector to search for"
-
- self askAndBrowseSelectorTitle:'selector to browse senders of:'
- action:[:aString |
- self class browseAllCallsOn:aString
- ]
-!
-
-methodRemove
- "remove the current method"
-
- self checkMethodSelected ifFalse:[^ self].
- actualClass removeSelector:(actualClass selectorForMethod:currentMethod).
- currentMethod := currentSelector := nil.
- self updateMethodListWithScroll:false
-!
-
-methodLocalSenders
- "launch an enterBox for selector to search for in current class & subclasses"
-
- self checkClassSelected ifFalse:[^ self].
- self askAndBrowseSelectorTitle:'selector to browse local senderss of:'
- action:[:aString |
- self class browseCallsOn:aString under:currentClass
- ]
-!
-
-methodPrintOut
- "print out the current method"
-
- |printStream|
-
- self checkMethodSelected ifFalse:[^ self].
-
- printStream := Printer new.
- actualClass printOutSource:(currentMethod source) on:printStream.
- printStream close
-!
-
-methodLocalImplementors
- "launch an enterBox for selector to search for"
-
- self checkClassSelected ifFalse:[^ self].
- self askAndBrowseSelectorTitle:'selector to browse local implementors of:'
- action:[:aString |
- self class browseImplementorsOf:aString under:currentClass
- ]
-!
-
-methodGlobalReferends
- "launch an enterBox for global symbol to search for"
-
- self enterBoxForBrowseTitle:'global variable to browse users of:'
- action:[:aString |
- self class browseReferendsOf:aString asSymbol
- ]
-!
-
-methodSpawn
- "create a new SystemBrowser browsing current method,
- or if the current selection is of the form 'class>>selector', spawan
- a browser on that method."
-
- |s sel selSymbol clsName clsSymbol cls isMeta w|
-
- classMethodListView notNil ifTrue:[
- s := classMethodListView selectionValue.
- clsName := self classFromClassMethodString:s.
- sel := self selectorFromClassMethodString:s.
- isMeta := false
- ].
-
- self extractClassAndSelectorFromSelectionInto:[:c :s :m |
- clsName := c.
- sel := s.
- isMeta := m
- ].
-
- (sel notNil and:[clsName notNil]) ifTrue:[
- (clsName knownAsSymbol and:[sel knownAsSymbol]) ifTrue:[
- clsSymbol := clsName asSymbol.
- (Smalltalk includesKey:clsSymbol) ifTrue:[
- cls := Smalltalk at:clsSymbol.
- isMeta ifTrue:[
- cls := cls class
- ].
- cls isBehavior ifFalse:[
- cls := cls class
- ].
- cls isBehavior ifTrue:[
- selSymbol := sel asSymbol.
- self withWaitCursorDo:[
- (cls implements:selSymbol) ifFalse:[
- cls := cls class.
- ].
- (cls implements:selSymbol) ifTrue:[
- self class browseClass:cls selector:selSymbol.
- ^ self
- ].
- w := ' does not implement #' , sel
- ]
- ] ifFalse:[
- w := ' is not a class'
- ]
- ] ifFalse:[
- w := ' is unknown'
- ]
- ] ifFalse:[
- w := ' and/or ' , sel , ' are unknown'
- ].
- self warn:(clsName , w).
- ^ self
- ].
-
- self checkMethodSelected ifFalse:[
- self warn:'select a method first'.
- ^ self
- ].
-
- self withWaitCursorDo:[
- w := currentMethod who.
- self class browseClass:(w at:1) selector:(w at:2)
- ]
-!
-
-methodFileOut
- "file out the current method"
-
- self checkMethodSelected ifFalse:[^ self].
-
- self busyLabel:'saving:' with:currentSelector.
- Class fileOutErrorSignal handle:[:ex |
- self warn:'cannot create: %1' with:ex parameter.
- ex return
- ] do:[
- actualClass fileOutMethod:currentMethod.
- ].
- self normalLabel.
-!
-
-methodChangeCategory
- "move the current method into another category -
- nothing done here, but a query for the new category.
- Remember the last category, to allow faster category change of a group of methods."
-
- |box txt|
-
- self checkMethodSelected ifFalse:[^ self].
-
- actualClass isNil ifTrue:[
- box := self enterBoxTitle:'' okText:'change'.
- ] ifFalse:[
- |someCategories|
-
- someCategories := actualClass categories sort.
- box := self listBoxTitle:'' okText:'change' list:someCategories.
- ].
- box title:('change category from ''' , currentMethod category , ''' to:').
- lastMethodCategory isNil ifTrue:[
- txt := currentMethod category.
- ] ifFalse:[
- txt := lastMethodCategory
- ].
- box initialText:txt.
- box action:[:aString |
- lastMethodCategory := aString.
-
- currentMethod category:aString asSymbol.
- currentClass changed.
- currentMethod changed:#category.
- currentClass addChangeRecordForMethodCategory:currentMethod category:aString.
- self updateMethodCategoryListWithScroll:false.
- self updateMethodListWithScroll:false
- ].
- box showAtPointer
-!
-
-methodStringSearch
- "launch an enterBox for string to search for"
-
- self askAndBrowseSelectorTitle:'string to search for in sources:'
- action:[:aString |
- self class browseForString:aString
- ]
-!
-
-methodLocalStringSearch
- "launch an enterBox for string to search for"
-
- self checkClassSelected ifFalse:[^ self].
- self askAndBrowseSelectorTitle:'string to search for in local methods:'
- action:[:aString |
- self class browseForString:aString in:(currentClass withAllSubclasses)
- ]
-!
-
-methodAproposSearch
- "launch an enterBox for a keyword search"
-
- self askAndBrowseSelectorTitle:'keyword to search for:'
- action:[:aString |
- self class aproposSearch:aString
- ]
-!
-
-methodLocalAproposSearch
- "launch an enterBox for a local keyword search"
-
- self askAndBrowseSelectorTitle:'keyword to search for:'
- action:[:aString |
- self class aproposSearch:aString in:(currentClass withAllSubclasses)
- ]
-!
-
-methodNewMethod
- "prepare for definition of a new method - put a template into
- code view and define accept-action to compile it"
-
- currentClass isNil ifTrue:[
- ^ self warn:'select/create a class first'.
- ].
- currentMethodCategory isNil ifTrue:[
- ^ self warn:'select/create a method category first'.
- ].
-
- currentMethod := currentSelector := nil.
-
- methodListView deselect.
- codeView contents:(self template).
- codeView modified:false.
-
- self setAcceptAndExplainActionsForMethod.
-!
-
-methodTrace
- "turn on tracing of the current method"
-
- |sel|
-
-currentClass notNil ifTrue:[
- currentSelector notNil ifTrue:[
- currentMethod := actualClass compiledMethodAt:currentSelector
- ]
-].
-
- (currentMethod notNil and:[currentMethod isWrapped not])
- ifTrue:[
- currentMethod := MessageTracer traceMethod:currentMethod.
- sel := methodListView selection.
- self updateMethodListWithScroll:false.
- methodListView selection:sel.
- currentClass changed:#methodDictionary with:currentSelector.
- ]
-!
-
-methodRemoveBreakOrTrace
- "turn off tracing of the current method"
-
- |sel|
-
- (currentMethod notNil and:[currentMethod isWrapped])
- ifTrue:[
- currentMethod := MessageTracer unwrapMethod:currentMethod.
- sel := methodListView selection.
- self updateMethodListWithScroll:false.
- methodListView selection:sel.
- currentClass changed:#methodDictionary with:currentSelector.
- ]
-!
-
-methodBreakPoint
- "set a breakpoint on the current method"
-
- |sel|
-
- currentSelector notNil ifTrue:[
- currentMethod := actualClass compiledMethodAt:currentSelector.
- currentMethod isWrapped ifFalse:[
- currentMethod := MessageTracer trapMethod:currentMethod.
- sel := methodListView selection.
- self updateMethodListWithScroll:false.
- methodListView selection:sel
- ].
- ]
-!
-
-methodTraceSender
- "turn on tracing of the current method"
-
- |sel|
-
- (currentMethod notNil and:[currentMethod isWrapped not])
- ifTrue:[
- currentMethod := MessageTracer traceMethodSender:currentMethod.
- sel := methodListView selection.
- self updateMethodListWithScroll:false.
- methodListView selection:sel.
- currentClass changed:#methodDictionary with:currentSelector.
- ]
-! !
-
-!SystemBrowser methodsFor:'variable list menu'!
-
-initializeVariableListMenu
- |varMenu|
-
- varMenu := (PopUpMenu labels:(resources array:#(
- 'instvar refs ...'
- 'classvar refs ...'
- 'all instvar refs ...'
- 'all classvar refs ...'
- '-'
- 'instvar mods ...'
- 'classvar mods ...'
- 'all instvar mods ...'
- 'all classvar mods ...'
- ))
- selectors:#(
- instVarRefs
- classVarRefs
- allInstVarRefs
- allClassVarRefs
- nil
- instVarMods
- classVarMods
- allInstVarMods
- allClassVarMods
- )
- receiver:self
- for:self).
-
- variableListView isNil ifTrue:[
- classListView notNil ifTrue:[
- |menu|
-
- menu := classListView middleButtonMenu.
- menu notNil ifTrue:[
- menu addLabel:(resources string:'variable search')
- selector:#variables
- before:#classRefs.
- menu subMenuAt:#variables put:varMenu.
- ]
- ]
- ] ifFalse:[
- variableListView middleButtonMenu:varMenu
- ]
-
-!
-
-variableSelection:lineNr
- "variable selection changed"
-
- |name idx|
-
- name := variableListView selectionValue.
- name isNil ifTrue:[
- self unhilightMethodCategories.
- self unhilightMethods.
- self autoSearch:nil.
- ^ self
- ].
-
- "
- first, check if the selected variable is really the one
- we get - reselect if its hidden (for example, a class variable
- with the same name could be defined in a subclass)
- "
- idx := variableListView list findLast:[:entry | entry = name].
- idx ~~ lineNr ifTrue:[
- "select it - user will see whats going on"
- variableListView selection:idx
- ].
-
- "search for methods in the current category, which access the selected
- variable, and highlight them"
-
- self hilightMethodsInMethodCategoryList:true inMethodList:true.
- self autoSearch:name.
-
-
-!
-
-enterBoxForVariableSearch:title
- |box sel|
-
- box := self enterBoxForCodeSelectionTitle:title okText:'browse'.
- variableListView notNil ifTrue:[
- codeView hasSelection ifFalse:[
- (sel := variableListView selectionValue) notNil ifTrue:[
- (sel startsWith:'---') ifFalse:[
- box initialText:sel
- ]
- ]
- ]
- ].
- ^ box
-!
-
-allClassOrInstVarRefsTitle:title access:access mods:modifications
- "show an enterbox for instVar to search for"
-
- self doClassMenu:[:currentClass |
- |box|
-
- box := self enterBoxForVariableSearch:title.
- box action:[:aVariableName |
- self withCursor:(Cursor questionMark) do:[
- |homeClass|
-
- homeClass := self findClassOfVariable:aVariableName
- accessWith:access.
- (self class) browseInstRefsTo:aVariableName
- under:homeClass
- modificationsOnly:modifications
- ]
- ].
- box showAtPointer
- ]
-!
-
-instVarRefsOrModsTitle:title mods:mods
- "show an enterbox for instvar to search for"
-
- self doClassMenu:[:currentClass |
- |box|
-
- box := self enterBoxForVariableSearch:title.
- box action:[:aString |
- self withCursor:(Cursor questionMark) do:[
- self class browseInstRefsTo:aString
- in:(Array with:currentClass)
- modificationsOnly:mods
- ]
- ].
- box showAtPointer
- ]
-!
-
-allClassVarMods
- "show an enterbox for classVar to search for"
-
- self allClassOrInstVarRefsTitle:'class variable to browse modifications of:'
- access:#classVarNames
- mods:true
-!
-
-instVarMods
- "show an enterbox for instVar to search for"
-
- self instVarRefsOrModsTitle:'instance variable to browse modifications of:'
- mods:true
-!
-
-instVarRefs
- "show an enterbox for instVar to search for"
-
- self instVarRefsOrModsTitle:'instance variable to browse references to:'
- mods:false
-!
-
-classVarRefsOrModsTitle:title mods:mods
- "show an enterbox for classVar to search for"
-
- self doClassMenu:[:currentClass |
- |box|
-
- box := self enterBoxForVariableSearch:title.
- box action:[:aString |
- self withCursor:(Cursor questionMark) do:[
- self class browseClassRefsTo:aString
- in:(Array with:currentClass)
- modificationsOnly:mods
- ]
- ].
- box showAtPointer
- ]
-!
-
-allInstVarRefs
- "show an enterbox for instVar to search for"
-
- self allClassOrInstVarRefsTitle:'instance variable to browse references to:'
- access:#instVarNames
- mods:false
-!
-
-classVarRefs
- "show an enterbox for classVar to search for"
-
- self classVarRefsOrModsTitle:'class variable to browse references to:'
- mods:false
-!
-
-classVarMods
- "show an enterbox for classVar to search for"
-
- self classVarRefsOrModsTitle:'class variable to browse modifications of:'
- mods:true
-!
-
-allInstVarMods
- "show an enterbox for instVar to search for"
-
- self allClassOrInstVarRefsTitle:'instance variable to browse modifications of:'
- access:#instVarNames
- mods:true
-!
-
-allClassVarRefs
- "show an enterbox for classVar to search for"
-
- self allClassOrInstVarRefsTitle:'class variable to browse references to:'
- access:#classVarNames
- mods:false
-! !
-
-!SystemBrowser methodsFor:'class-method list menu'!
-
-classMethodMenu
- |labels selectors|
-
- labels := #(
- 'fileOut'
- 'fileOut all'
- 'printOut'
- '-'
- 'spawn'
- 'spawn class'
- 'spawn full protocol'
- 'spawn hierarchy'
- '-'
- 'sender ...'
- 'implementors ...'
- 'globals ...'
-"/ '-'
-"/ 'breakpoint'
-"/ 'trace'
-"/ 'trace sender'
- ).
-
- selectors := #(
- methodFileOut
- classMethodFileOutAll
- methodPrintOut
- nil
- methodSpawn
- classSpawn
- classSpawnFullProtocol
- classSpawnHierarchy
- nil
- methodSenders
- methodImplementors
- methodGlobalReferends
-"/ nil
-"/ methodBreakPoint
-"/ methodTrace
-"/ methodTraceSender
- ).
-
- ^ (PopUpMenu labels:(resources array:labels)
- selectors:selectors
- receiver:self)
-!
-
-classMethodFileOutAll
- "fileout all methods into one source file"
-
- |list classString selectorString cls mth outStream fileName append
- fileBox|
-
- append := false.
- fileBox := FileSaveBox
- title:(resources string:'save methodss in:')
- okText:(resources string:'save')
- abortText:(resources string:'cancel')
- action:[:fName | fileName := fName].
- fileBox appendAction:[:fName | fileName := fName. append := true].
- fileBox initialText:'some_methods.st'.
- Project notNil ifTrue:[
- fileBox directory:Project currentProjectDirectory
- ].
- fileBox showAtPointer.
-
- fileName notNil ifTrue:[
- "
- if file exists, save original in a .sav file
- "
- fileName asFilename exists ifTrue:[
- fileName asFilename copyTo:(fileName , '.sav')
- ].
- append ifTrue:[
- outStream := FileStream appendingOldFileNamed:fileName
- ] ifFalse:[
- outStream := FileStream newFileNamed:fileName.
- ].
- outStream isNil ifTrue:[
- ^ self warn:'cannot create: %1' with:fileName
- ].
- self withWaitCursorDo:[
- list := classMethodListView list.
- list do:[:line |
- self busyLabel:'writing: ' with:line.
-
- classString := self classFromClassMethodString:line.
- selectorString := self selectorFromClassMethodString:line.
-
- ((classString ~= 'Metaclass') and:[classString endsWith:'class']) ifTrue:[
- classString := classString copyTo:(classString size - 5).
- cls := (Smalltalk at:classString asSymbol).
- cls := cls class
- ] ifFalse:[
- cls := (Smalltalk at:classString asSymbol).
- ].
-
- cls isNil ifTrue:[
- self warn:'oops class %1 is gone' with:classString
- ] ifFalse:[
- mth := cls compiledMethodAt:(selectorString asSymbol).
- Class fileOutErrorSignal handle:[:ex |
- |box|
- box := YesNoBox new.
- box yesText:'continue' noText:'abort'.
- (box confirm:('fileOut error: ' , ex errorString ,
- '\\continue anyway ?') withCRs) ifTrue:[
- ex proceed
- ].
- self normalLabel.
- ^ self
- ] do:[
- cls fileOutMethod:mth on:outStream.
- ]
- ]
- ].
- outStream close.
- self normalLabel.
- ]
- ]
-! !
-
SystemBrowser initialize!