--- a/ChangeSetBrowser.st Thu Nov 17 15:44:34 1994 +0100
+++ b/ChangeSetBrowser.st Thu Nov 17 15:47:59 1994 +0100
@@ -1,5 +1,3 @@
-"{ Package: 'Programming Tools' }"
-
"
COPYRIGHT (c) 1993 by Claus Gittinger
All Rights Reserved
@@ -23,7 +21,7 @@
COPYRIGHT (c) 1993 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libtool/ChangeSetBrowser.st,v 1.3 1994-10-10 03:15:18 claus Exp $
+$Header: /cvs/stx/stx/libtool/ChangeSetBrowser.st,v 1.4 1994-11-17 14:47:59 claus Exp $
'!
!ChangeSetBrowser class methodsFor:'documentation'!
@@ -44,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/ChangeSetBrowser.st,v 1.3 1994-10-10 03:15:18 claus Exp $
+$Header: /cvs/stx/stx/libtool/ChangeSetBrowser.st,v 1.4 1994-11-17 14:47:59 claus Exp $
"
!
--- a/ChgSetBrwsr.st Thu Nov 17 15:44:34 1994 +0100
+++ b/ChgSetBrwsr.st Thu Nov 17 15:47:59 1994 +0100
@@ -1,5 +1,3 @@
-"{ Package: 'Programming Tools' }"
-
"
COPYRIGHT (c) 1993 by Claus Gittinger
All Rights Reserved
@@ -23,7 +21,7 @@
COPYRIGHT (c) 1993 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libtool/Attic/ChgSetBrwsr.st,v 1.3 1994-10-10 03:15:18 claus Exp $
+$Header: /cvs/stx/stx/libtool/Attic/ChgSetBrwsr.st,v 1.4 1994-11-17 14:47:59 claus Exp $
'!
!ChangeSetBrowser class methodsFor:'documentation'!
@@ -44,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/Attic/ChgSetBrwsr.st,v 1.3 1994-10-10 03:15:18 claus Exp $
+$Header: /cvs/stx/stx/libtool/Attic/ChgSetBrwsr.st,v 1.4 1994-11-17 14:47:59 claus Exp $
"
!
--- a/DebugView.st Thu Nov 17 15:44:34 1994 +0100
+++ b/DebugView.st Thu Nov 17 15:47:59 1994 +0100
@@ -22,7 +22,7 @@
exclusive inspecting nChainShown
inspectedProcess updateProcess
monitorToggle'
- classVariableNames:'CachedDebugger CachedExclusive'
+ classVariableNames:'CachedDebugger CachedExclusive MoreDebuggingDetail'
poolDictionaries:''
category:'Interface-Debugger'
!
@@ -31,7 +31,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libtool/DebugView.st,v 1.16 1994-10-28 03:30:49 claus Exp $
+$Header: /cvs/stx/stx/libtool/DebugView.st,v 1.17 1994-11-17 14:46:40 claus Exp $
'!
!DebugView class methodsFor:'documentation'!
@@ -52,7 +52,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/DebugView.st,v 1.16 1994-10-28 03:30:49 claus Exp $
+$Header: /cvs/stx/stx/libtool/DebugView.st,v 1.17 1994-11-17 14:46:40 claus Exp $
"
!
@@ -182,12 +182,18 @@
"start a debugger on aProcess
(actually not more than a good-looking inspector)"
- |aDebugger label|
+ |aDebugger label nm|
aDebugger := super new.
aDebugger icon:(Form fromFile:'Debugger.xbm' resolution:100).
aProcess notNil ifTrue:[
- label := 'process Debugger (' , aProcess nameOrId , ')'.
+ nm := aProcess name.
+ nm notNil ifTrue:[
+ nm := (aProcess nameOrId contractTo:17) , '-' , aProcess id printString
+ ] ifFalse:[
+ nm := aProcess id printString
+ ].
+ label := 'Debugger [' , nm , ']'.
] ifFalse:[
label := 'no process'
].
@@ -225,6 +231,7 @@
action:[terminateButton turnOffWithoutRedraw. self doTerminate]
in:bpanel.
dummy := View extent:(20 @ 5) in:bpanel.
+ dummy borderWidth:0; level:0.
abortButton := Button
label:(resources at:'abort')
@@ -241,12 +248,14 @@
in:bpanel.
dummy := View extent:(20 @ 5) in:bpanel.
+ dummy borderWidth:0; level:0.
continueButton := Button
label:(resources at:'continue')
action:[continueButton turnOffWithoutRedraw. self doContinue]
in:bpanel.
dummy := View extent:(20 @ 5) in:bpanel.
+ dummy borderWidth:0; level:0.
stepButton := Button
label:(resources at:'step')
@@ -385,6 +394,10 @@
].
inspectedProcess notNil ifTrue:[
+ "
+ set prio somewhat higher (by 2, to allow walkBack-update process
+ to run between mine and the debugged processes prio)
+ "
Processor activeProcess
priority:(inspectedProcess priority + 2 min:16).
]
@@ -395,8 +408,13 @@
stepInterrupt
|where here s isWrap method lastWrappedConAddr wrappedMethod|
+ Processor activeProcess ~~ inspectedProcess ifTrue:[
+ 'stray step interrupt' errorPrintNL.
+ ^ self
+ ].
+
"
- kludge, check if we are in a wrapper methods hidden setup-sequence
+ kludge: check if we are in a wrapper methods hidden setup-sequence
"
here := thisContext. "stepInterrupt"
here := here sender. "the interrupted context"
@@ -549,7 +567,7 @@
busy := true.
inspecting := false.
- inspectedProcess := nil.
+ inspectedProcess := Processor activeProcess.
bigStep := false.
nChainShown := 50.
@@ -557,13 +575,8 @@
pointer, we must ungrab - otherwise X wont talk to
us here
"
- ActiveGrab notNil ifTrue:[
- grabber := ActiveGrab.
- ActiveGrab device ungrabPointer.
- ActiveGrab device synchronizeOutput.
- ActiveGrab := nil
- ] ifFalse:[
- grabber := nil
+ (grabber := device activePointerGrab) notNil ifTrue:[
+ device ungrabPointer
].
terminateButton enable.
@@ -575,7 +588,7 @@
abortButton turnOffWithoutRedraw.
stepButton turnOffWithoutRedraw.
sendButton turnOffWithoutRedraw.
- self rerealize
+"/ self rerealize
] ifFalse:[
exclusive ifFalse:[
windowGroup isNil ifTrue:[
@@ -583,15 +596,15 @@
windowGroup addTopView:self.
].
].
- self realize.
+"/ self realize.
self iconLabel:'Debugger'.
].
- "
- bring us to the top
- "
- self raise.
- Display synchronizeOutput.
+"/ "
+"/ bring us to the top
+"/ "
+"/ self raise.
+"/ Display synchronizeOutput.
"
get the walkback list
@@ -601,21 +614,39 @@
"
and find one to show
"
- steppedContextAddress isNil ifTrue:[
- "
- preselect a more interresting context, (where halt/raise was ...)
- "
- selection := self interrestingContextFrom:aContext.
+ exitAction == #step ifTrue:[
+ selection := 1.
+ steppedContextAddress notNil ifTrue:[
+ "
+ if we came here by a big-step, show the method where we are
+ "
+ steppedContextAddress notNil ifTrue:[
+ (ObjectMemory addressOf:aContext) == steppedContextAddress ifTrue:[
+ selection := 1
+ ] ifFalse:[
+ (ObjectMemory addressOf:aContext sender) == steppedContextAddress ifTrue:[
+ selection := 2
+ ]
+ ]
+ ]
+ ]
] ifFalse:[
- "
- if we came here by a big-step, show the method where we are
- "
- steppedContextAddress notNil ifTrue:[
- (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
+ "
+ steppedContextAddress notNil ifTrue:[
+ (ObjectMemory addressOf:aContext) == steppedContextAddress ifTrue:[
+ selection := 1
+ ] ifFalse:[
+ (ObjectMemory addressOf:aContext sender) == steppedContextAddress ifTrue:[
+ selection := 2
+ ]
]
]
]
@@ -645,10 +676,24 @@
]
].
+ drawableId notNil ifTrue:[
+ self rerealize
+ ] ifFalse:[
+ self realize.
+ ].
+
+ "
+ bring us to the top
+ "
+ self raise.
+ Display synchronizeOutput.
+
"
enter private event handling loop
"
canContinue := true.
+ exitAction := nil.
+
self controlLoop.
contextArray := nil.
@@ -743,8 +788,8 @@
selectedContext := nil.
grabber notNil ifTrue:[
- grabber device grabPointerIn:(grabber id).
- ActiveGrab := grabber
+ device grabPointerInView:grabber.
+ grabber := nil.
].
(exitAction == #step) ifTrue:[
@@ -766,9 +811,9 @@
openOn:aProcess
"enter the debugger on a process -
in this case, we are just inspecting the context chain of the process,
- not offering continue/abort/step and send functions.
- Also, we do not run on top of the debugger process, but as a separate
- one. (think of it as an inspector showing more detail)"
+ not running on top of the debugged process, but as a separate
+ one. (think of it as an inspector showing more detail, and offering
+ some more control operations)"
|bpanel updateButton stopButton dummy|
@@ -786,6 +831,7 @@
bpanel addSubView:stopButton after:continueButton.
dummy := View extent:(20 @ 5) in:bpanel.
+ dummy borderWidth:0; level:0.
"/ stepButton destroy.
"/ sendButton destroy.
@@ -825,6 +871,7 @@
self setContext:aProcess suspendedContext.
catchBlock := [
+ catchBlock := nil.
contextArray := nil.
selectedContext := nil.
(exitAction == #terminate) ifTrue:[
@@ -861,8 +908,8 @@
!
controlLoopCatchingErrors
- "setup a catch-block"
- catchBlock := [^ nil].
+ "setup a self removing catch-block"
+ catchBlock := [catchBlock := nil. ^ nil].
exclusive ifTrue:[
"if we do not have multiple processes or its a system process
@@ -880,13 +927,19 @@
active group.
"
SignalSet anySignal handle:[:ex |
- 'ignored error in debugger: ' errorPrint.
+"/ (self confirm:('error in debugger: ' , ex errorString , '\\debug again ?') withCRs)
+"/ ifTrue:[
+"/ Debugger enter:(ex suspendedContext).
+"/ ex return.
+"/ ].
+"/ 'ignored error in debugger: ' errorPrint.
ex errorString errorPrintNL.
ex return.
] do:[
windowGroup eventLoopWhile:[true]
- ]
- ]
+ ].
+ ].
+ catchBlock := nil.
! !
!DebugView methodsFor:'private'!
@@ -895,9 +948,13 @@
^ busy
!
+showError:message
+ codeView contents:(resources string:message).
+ codeView flash
+!
+
showTerminated
- codeView contents:(resources string:'** process has terminated **').
- codeView flash
+ self showError:'** the process has terminated **'
!
processAction:aBlock
@@ -927,9 +984,13 @@
interrestingContextFrom:aContext
"return an interresting contexts offset, or nil.
- Just to add a bit of comfort :-)"
+ This is the context initially shown in the walkback.
+ We move up the calling chain, skipping all intermediate Signal
+ and Exception contexts, to present the context in which the error
+ actually occured.
+ Just for your convenience :-)"
- |c found offset sel|
+ |c found offset sel prev|
"somewhere, at the bottom, there must be a raise ..."
@@ -937,40 +998,34 @@
1 to:5 do:[:i |
c isNil ifTrue:[^ 1 "^ nil"].
sel := c selector.
- ((sel == #raise)
- or:[(sel == #raiseRequestWith:)
- or:[(sel == #raiseRequestWith:errorString:)]])
- ifTrue:[
+ (sel == #raise) ifTrue:[
offset := i.
found := c
].
c := c sender.
].
- (c := found) isNil ifTrue:[^ 1 "nil"].
+ (c := found) isNil ifTrue:[^ 1].
"
- got it; move up, for the one that called the raise
+ got it; move up, skipping all intermediate Signal and
+ Exception contexts
"
- (c := c sender) isNil ifTrue:[^ offset].
- offset := offset + 1.
+ prev := nil.
+ [
+ ((c receiver isKindOf:Signal)
+ or:[(c receiver isKindOf:Exception)])
+ ] whileTrue:[
+ prev := c.
+ (c := c sender) isNil ifTrue:[^ offset].
+ offset := offset + 1.
+ ].
"
now, we are one above the raise
"
"
- if raise implementation reuses raise code ...
- "
- [
- #( raise raiseRequestWith: #raiseRequestWith:errorString: )
- includes:c selector
- ] whileTrue:[
- (c := c sender) isNil ifTrue:[^ offset].
- offset := offset + 1.
- ].
-
- "
if the sender of the raise is one of objects error methods ...
"
( #( halt halt:
@@ -988,6 +1043,13 @@
].
(c := c sender) isNil ifTrue:[^ offset].
offset := offset + 1.
+ ] ifFalse:[
+ "
+ ok, got the raise - if its a BreakPoint, look for the sender
+ "
+ prev receiver == MessageTracer breakpointSignal ifTrue:[
+ offset := offset + 1
+ ].
].
^ offset
@@ -1021,7 +1083,7 @@
"
[con notNil and:[contextArray size <= nChainShown]] whileTrue:[
contextArray add:con.
- (Smalltalk at:#SystemDebugging ifAbsent:[false]) ifTrue:[
+ (MoreDebuggingDetail == true) ifTrue:[
text add:(((ObjectMemory addressOf:con) printStringRadix:16) , ' ' , con printString).
] ifFalse:[
text add:con printString.
@@ -1135,7 +1197,7 @@
sel notNil ifTrue:[
implementorClass := homeContext searchClass whichClassImplements:sel.
implementorClass isNil ifTrue:[
- codeView contents:(resources string:'** no method - no source **')
+ self showError:'** no method - no source **'
] ifFalse:[
method := implementorClass compiledMethodAt:sel.
code := method source.
@@ -1143,9 +1205,10 @@
method sourceFilename notNil ifTrue:[
codeView contents:(resources
string:'** no sourcefile: %1 **'
- with:method sourceFilename)
+ with:method sourceFilename).
+ codeView flash
] ifFalse:[
- codeView contents:(resources string:'** no source **')
+ self showError:'** no source **'
]
]
].
@@ -1265,8 +1328,24 @@
"closing the debugger implies an abort or continue"
contextView middleButtonMenu hide.
+
+ "
+ we manually release all private data, since the Debugger
+ is cached for reuse - thus the memory would not be collectable
+ otherwise.
+ "
receiverInspector release.
contextInspector release.
+ inspectedProcess := nil.
+ exitAction := nil.
+ contextArray := nil.
+ selectedContext := nil.
+ catchBlock := nil.
+ grabber := nil.
+ self autoUpdateOff.
+
+ super destroy.
+
inspecting ifFalse:[
canAbort ifTrue:[
self doAbort.
@@ -1275,9 +1354,6 @@
self doContinue
]
].
- self autoUpdateOff.
- inspectedProcess := nil.
- super destroy
!
doExit
@@ -1291,6 +1367,10 @@
|implementorClass method|
+ selectedContext isNil ifTrue:[
+ ^ self showError:'** select a context first **'
+ ].
+
implementorClass := selectedContext searchClass
whichClassImplements:selectedContext selector.
implementorClass notNil ifTrue:[
@@ -1311,28 +1391,32 @@
doSenders
"open a browser on the senders"
- selectedContext notNil ifTrue:[
- SystemBrowser browseAllCallsOn:selectedContext selector.
- ]
+ selectedContext isNil ifTrue:[
+ ^ self showError:'** select a context first **'
+ ].
+ SystemBrowser browseAllCallsOn:selectedContext selector.
!
doImplementors
"open a browser on the implementors"
- selectedContext notNil ifTrue:[
- SystemBrowser browseImplementorsOf:selectedContext selector.
- ]
+ selectedContext isNil ifTrue:[
+ ^ self showError:'** select a context first **'
+ ].
+ SystemBrowser browseImplementorsOf:selectedContext selector.
!
doShowMore
"double number of contexts shown"
- |oldSelection|
+ |oldSelection con|
contextArray notNil ifTrue:[
oldSelection := contextView selection.
nChainShown := nChainShown * 2.
- self setContext:contextArray first.
+ con := contextArray at:1.
+ contextArray at:1 put:nil.
+ self setContext:con.
contextView selection:oldSelection.
]
!
@@ -1400,7 +1484,7 @@
^ self
].
(Object abortSignal isHandledIn:inspectedProcess suspendedContext) ifFalse:[
- codeView contents:(resources string:'** process no longer handles abort **')
+ self showError:'** the process does not handle the abort signal **'
] ifTrue:[
self interruptProcessWith:[Object abortSignal raise].
].
@@ -1423,12 +1507,12 @@
^ self.
"obsolete ..."
- Processor activeProcess id == 0 ifTrue:[
- "dont allow termination of main-thread"
- exitAction := #abort
- ] ifFalse:[
- exitAction := #terminate
- ]
+"/ Processor activeProcess id == 0 ifTrue:[
+"/ "dont allow termination of main-thread"
+"/ exitAction := #abort
+"/ ] ifFalse:[
+"/ exitAction := #terminate
+"/ ]
!
doTerminate
@@ -1479,6 +1563,9 @@
"return - the selected context will do a ^nil"
inspecting ifTrue:[
+ selectedContext isNil ifTrue:[
+ ^ self showError:'** select a context first **'
+ ].
self interruptProcessWith:[selectedContext return].
^ self
].
@@ -1499,6 +1586,9 @@
"restart - the selected context will be restarted"
inspecting ifTrue:[
+ selectedContext isNil ifTrue:[
+ ^ self showError:'** select a context first **'
+ ].
self interruptProcessWith:[selectedContext restart].
^ self
].
--- a/DictInspV.st Thu Nov 17 15:44:34 1994 +0100
+++ b/DictInspV.st Thu Nov 17 15:47:59 1994 +0100
@@ -1,8 +1,6 @@
-"{ Package: 'Programming Tools' }"
-
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -13,17 +11,17 @@
"
InspectorView subclass:#DictionaryInspectorView
- instanceVariableNames:'keys'
- classVariableNames:''
- poolDictionaries:''
- category:'Interface-Inspector'
+ instanceVariableNames:'keys'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Interface-Inspector'
!
-DictionaryInspectorView comment:'
+DictionaryInspectorView comment:'
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libtool/Attic/DictInspV.st,v 1.7 1994-10-10 03:15:31 claus Exp $
+$Header: /cvs/stx/stx/libtool/Attic/DictInspV.st,v 1.8 1994-11-17 14:46:44 claus Exp $
'!
!DictionaryInspectorView class methodsFor:'documentation'!
@@ -31,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -44,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/Attic/DictInspV.st,v 1.7 1994-10-10 03:15:31 claus Exp $
+$Header: /cvs/stx/stx/libtool/Attic/DictInspV.st,v 1.8 1994-11-17 14:46:44 claus Exp $
"
!
@@ -64,10 +62,10 @@
value := Compiler evaluate:theText receiver:inspectedObject notifying:workspace.
selectedLine notNil ifTrue:[
- selectedLine == 1 ifFalse:[
- inspectedObject at:(keys at:selectedLine - 1) put:value.
- inspectedObject changed
- ].
+ selectedLine == 1 ifFalse:[
+ inspectedObject at:(keys at:selectedLine - 1) put:value.
+ inspectedObject changed
+ ].
]
!
@@ -77,13 +75,23 @@
|k objectToInspect|
selectedLine notNil ifTrue:[
- selectedLine == 1 ifTrue:[
- objectToInspect := inspectedObject
- ] ifFalse:[
- k := (keys at:selectedLine - 1).
- objectToInspect := inspectedObject at:k.
- ].
- objectToInspect inspect
+ selectedLine == 1 ifTrue:[
+ objectToInspect := inspectedObject
+ ] ifFalse:[
+ k := (keys at:selectedLine - 1).
+ objectToInspect := inspectedObject at:k.
+ ].
+ objectToInspect inspect
+ ]
+!
+
+doInspectKey
+ "inspect selected items key"
+
+ selectedLine notNil ifTrue:[
+ selectedLine ~~ 1 ifTrue:[
+ (keys at:selectedLine - 1) inspect
+ ].
]
!
@@ -96,11 +104,11 @@
workspace contents:nil.
"
lineNr == 1 ifTrue:[
- "selecting self also does a re-set, this allows updating the list"
- self inspect:inspectedObject.
- val := inspectedObject
+ "selecting self also does a re-set, this allows updating the list"
+ self inspect:inspectedObject.
+ val := inspectedObject
] ifFalse:[
- val := inspectedObject at:(keys at:lineNr - 1)
+ val := inspectedObject at:(keys at:lineNr - 1)
].
string := val displayString.
workspace replace:string.
@@ -114,13 +122,13 @@
keyName := DialogView request:'key to add:' initialAnswer:''.
keyName notNil ifTrue:[
- key := keyName asSymbol.
- (inspectedObject includesKey:key) ifFalse:[
- inspectedObject at:key put:nil.
- selectedLine := nil.
- inspectedObject changed.
- self inspect:inspectedObject. "force list update"
- ]
+ key := keyName asSymbol.
+ (inspectedObject includesKey:key) ifFalse:[
+ inspectedObject at:key put:nil.
+ selectedLine := nil.
+ inspectedObject changed.
+ self inspect:inspectedObject. "force list update"
+ ]
]
!
@@ -130,16 +138,16 @@
|key|
selectedLine == 1 ifFalse:[
- key := (keys at:selectedLine - 1).
- (inspectedObject includesKey:key) ifTrue:[
- listView cursor:(Cursor wait).
- inspectedObject removeKey:key.
- keys := nil.
- selectedLine := nil.
- inspectedObject changed.
- listView cursor:(Cursor hand).
- self inspect:inspectedObject. "force list update"
- ].
+ key := (keys at:selectedLine - 1).
+ (inspectedObject includesKey:key) ifTrue:[
+ listView cursor:(Cursor wait).
+ inspectedObject removeKey:key.
+ keys := nil.
+ selectedLine := nil.
+ inspectedObject changed.
+ listView cursor:(Cursor hand).
+ self inspect:inspectedObject. "force list update"
+ ].
]
!
@@ -149,10 +157,10 @@
|k|
selectedLine notNil ifTrue:[
- selectedLine == 1 ifFalse:[
- k := (keys at:selectedLine - 1).
- SystemBrowser browseReferendsOf:k asSymbol
- ].
+ selectedLine == 1 ifFalse:[
+ k := (keys at:selectedLine - 1).
+ SystemBrowser browseReferendsOf:k asSymbol
+ ].
]
! !
@@ -164,9 +172,9 @@
|aList|
aList := OrderedCollection new.
- keys := inspectedObject keys asSortedCollection:[:a :b | a printString < b printString].
+ keys := inspectedObject keys asSortedCollection:[:a :b | a displayString < b displayString].
keys do:[:aKey |
- aList add:(aKey printString)
+ aList add:(aKey displayString)
].
aList addFirst:'self'.
^ aList
@@ -185,26 +193,28 @@
|labels selectors|
inspectedObject == Smalltalk ifTrue:[
- labels := resources array:#(
- 'inspect'
- 'references'
- '-'
- 'add key'
- 'remove key').
- selectors := #(doInspect doReferences nil doAddKey doRemoveKey).
+ labels := resources array:#(
+ 'inspect'
+ 'inspect key'
+ 'references'
+ '-'
+ 'add key'
+ 'remove key').
+ selectors := #(doInspect doInspectKey doReferences nil doAddKey doRemoveKey).
] ifFalse:[
- labels := resources array:#(
- 'inspect'
- '-'
- 'add key'
- 'remove key').
- selectors := #(doInspect nil doAddKey doRemoveKey).
+ labels := resources array:#(
+ 'inspect'
+ 'inspect key'
+ '-'
+ 'add key'
+ 'remove key').
+ selectors := #(doInspect doInspectKey nil doAddKey doRemoveKey).
].
menu1 := (PopUpMenu
- labels:(resources array:labels)
- selectors:selectors
- receiver:self
- for:listView).
- workspace acceptAction:[:theText | self doAccept:theText asString]
+ labels:(resources array:labels)
+ selectors:selectors
+ receiver:self
+ for:listView).
+
! !
--- a/DictionaryInspectorView.st Thu Nov 17 15:44:34 1994 +0100
+++ b/DictionaryInspectorView.st Thu Nov 17 15:47:59 1994 +0100
@@ -1,8 +1,6 @@
-"{ Package: 'Programming Tools' }"
-
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -13,17 +11,17 @@
"
InspectorView subclass:#DictionaryInspectorView
- instanceVariableNames:'keys'
- classVariableNames:''
- poolDictionaries:''
- category:'Interface-Inspector'
+ instanceVariableNames:'keys'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Interface-Inspector'
!
-DictionaryInspectorView comment:'
+DictionaryInspectorView comment:'
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libtool/DictionaryInspectorView.st,v 1.7 1994-10-10 03:15:31 claus Exp $
+$Header: /cvs/stx/stx/libtool/DictionaryInspectorView.st,v 1.8 1994-11-17 14:46:44 claus Exp $
'!
!DictionaryInspectorView class methodsFor:'documentation'!
@@ -31,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -44,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/DictionaryInspectorView.st,v 1.7 1994-10-10 03:15:31 claus Exp $
+$Header: /cvs/stx/stx/libtool/DictionaryInspectorView.st,v 1.8 1994-11-17 14:46:44 claus Exp $
"
!
@@ -64,10 +62,10 @@
value := Compiler evaluate:theText receiver:inspectedObject notifying:workspace.
selectedLine notNil ifTrue:[
- selectedLine == 1 ifFalse:[
- inspectedObject at:(keys at:selectedLine - 1) put:value.
- inspectedObject changed
- ].
+ selectedLine == 1 ifFalse:[
+ inspectedObject at:(keys at:selectedLine - 1) put:value.
+ inspectedObject changed
+ ].
]
!
@@ -77,13 +75,23 @@
|k objectToInspect|
selectedLine notNil ifTrue:[
- selectedLine == 1 ifTrue:[
- objectToInspect := inspectedObject
- ] ifFalse:[
- k := (keys at:selectedLine - 1).
- objectToInspect := inspectedObject at:k.
- ].
- objectToInspect inspect
+ selectedLine == 1 ifTrue:[
+ objectToInspect := inspectedObject
+ ] ifFalse:[
+ k := (keys at:selectedLine - 1).
+ objectToInspect := inspectedObject at:k.
+ ].
+ objectToInspect inspect
+ ]
+!
+
+doInspectKey
+ "inspect selected items key"
+
+ selectedLine notNil ifTrue:[
+ selectedLine ~~ 1 ifTrue:[
+ (keys at:selectedLine - 1) inspect
+ ].
]
!
@@ -96,11 +104,11 @@
workspace contents:nil.
"
lineNr == 1 ifTrue:[
- "selecting self also does a re-set, this allows updating the list"
- self inspect:inspectedObject.
- val := inspectedObject
+ "selecting self also does a re-set, this allows updating the list"
+ self inspect:inspectedObject.
+ val := inspectedObject
] ifFalse:[
- val := inspectedObject at:(keys at:lineNr - 1)
+ val := inspectedObject at:(keys at:lineNr - 1)
].
string := val displayString.
workspace replace:string.
@@ -114,13 +122,13 @@
keyName := DialogView request:'key to add:' initialAnswer:''.
keyName notNil ifTrue:[
- key := keyName asSymbol.
- (inspectedObject includesKey:key) ifFalse:[
- inspectedObject at:key put:nil.
- selectedLine := nil.
- inspectedObject changed.
- self inspect:inspectedObject. "force list update"
- ]
+ key := keyName asSymbol.
+ (inspectedObject includesKey:key) ifFalse:[
+ inspectedObject at:key put:nil.
+ selectedLine := nil.
+ inspectedObject changed.
+ self inspect:inspectedObject. "force list update"
+ ]
]
!
@@ -130,16 +138,16 @@
|key|
selectedLine == 1 ifFalse:[
- key := (keys at:selectedLine - 1).
- (inspectedObject includesKey:key) ifTrue:[
- listView cursor:(Cursor wait).
- inspectedObject removeKey:key.
- keys := nil.
- selectedLine := nil.
- inspectedObject changed.
- listView cursor:(Cursor hand).
- self inspect:inspectedObject. "force list update"
- ].
+ key := (keys at:selectedLine - 1).
+ (inspectedObject includesKey:key) ifTrue:[
+ listView cursor:(Cursor wait).
+ inspectedObject removeKey:key.
+ keys := nil.
+ selectedLine := nil.
+ inspectedObject changed.
+ listView cursor:(Cursor hand).
+ self inspect:inspectedObject. "force list update"
+ ].
]
!
@@ -149,10 +157,10 @@
|k|
selectedLine notNil ifTrue:[
- selectedLine == 1 ifFalse:[
- k := (keys at:selectedLine - 1).
- SystemBrowser browseReferendsOf:k asSymbol
- ].
+ selectedLine == 1 ifFalse:[
+ k := (keys at:selectedLine - 1).
+ SystemBrowser browseReferendsOf:k asSymbol
+ ].
]
! !
@@ -164,9 +172,9 @@
|aList|
aList := OrderedCollection new.
- keys := inspectedObject keys asSortedCollection:[:a :b | a printString < b printString].
+ keys := inspectedObject keys asSortedCollection:[:a :b | a displayString < b displayString].
keys do:[:aKey |
- aList add:(aKey printString)
+ aList add:(aKey displayString)
].
aList addFirst:'self'.
^ aList
@@ -185,26 +193,28 @@
|labels selectors|
inspectedObject == Smalltalk ifTrue:[
- labels := resources array:#(
- 'inspect'
- 'references'
- '-'
- 'add key'
- 'remove key').
- selectors := #(doInspect doReferences nil doAddKey doRemoveKey).
+ labels := resources array:#(
+ 'inspect'
+ 'inspect key'
+ 'references'
+ '-'
+ 'add key'
+ 'remove key').
+ selectors := #(doInspect doInspectKey doReferences nil doAddKey doRemoveKey).
] ifFalse:[
- labels := resources array:#(
- 'inspect'
- '-'
- 'add key'
- 'remove key').
- selectors := #(doInspect nil doAddKey doRemoveKey).
+ labels := resources array:#(
+ 'inspect'
+ 'inspect key'
+ '-'
+ 'add key'
+ 'remove key').
+ selectors := #(doInspect doInspectKey nil doAddKey doRemoveKey).
].
menu1 := (PopUpMenu
- labels:(resources array:labels)
- selectors:selectors
- receiver:self
- for:listView).
- workspace acceptAction:[:theText | self doAccept:theText asString]
+ labels:(resources array:labels)
+ selectors:selectors
+ receiver:self
+ for:listView).
+
! !
--- a/DiffTextView.st Thu Nov 17 15:44:34 1994 +0100
+++ b/DiffTextView.st Thu Nov 17 15:47:59 1994 +0100
@@ -1,5 +1,3 @@
-"{ Package: 'Programming Tools' }"
-
"
COPYRIGHT (c) 1994 by Claus Gittinger
All Rights Reserved
@@ -23,7 +21,7 @@
COPYRIGHT (c) 1994 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libtool/DiffTextView.st,v 1.3 1994-10-10 03:15:33 claus Exp $
+$Header: /cvs/stx/stx/libtool/DiffTextView.st,v 1.4 1994-11-17 14:46:45 claus Exp $
'!
!DiffTextView class methodsFor:'documentation'!
@@ -44,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/DiffTextView.st,v 1.3 1994-10-10 03:15:33 claus Exp $
+$Header: /cvs/stx/stx/libtool/DiffTextView.st,v 1.4 1994-11-17 14:46:45 claus Exp $
"
!
--- a/DiffTxtV.st Thu Nov 17 15:44:34 1994 +0100
+++ b/DiffTxtV.st Thu Nov 17 15:47:59 1994 +0100
@@ -1,5 +1,3 @@
-"{ Package: 'Programming Tools' }"
-
"
COPYRIGHT (c) 1994 by Claus Gittinger
All Rights Reserved
@@ -23,7 +21,7 @@
COPYRIGHT (c) 1994 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libtool/Attic/DiffTxtV.st,v 1.3 1994-10-10 03:15:33 claus Exp $
+$Header: /cvs/stx/stx/libtool/Attic/DiffTxtV.st,v 1.4 1994-11-17 14:46:45 claus Exp $
'!
!DiffTextView class methodsFor:'documentation'!
@@ -44,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/Attic/DiffTxtV.st,v 1.3 1994-10-10 03:15:33 claus Exp $
+$Header: /cvs/stx/stx/libtool/Attic/DiffTxtV.st,v 1.4 1994-11-17 14:46:45 claus Exp $
"
!
--- a/EvMonitor.st Thu Nov 17 15:44:34 1994 +0100
+++ b/EvMonitor.st Thu Nov 17 15:47:59 1994 +0100
@@ -1,3 +1,15 @@
+"
+ COPYRIGHT (c) 1991 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
'From Smalltalk/X, Version:1.4 on 19-Jul-91 at 18:34:01'!
StandardSystemView subclass:#EventMonitor
@@ -8,13 +20,42 @@
!
EventMonitor comment:'
-like xev - show events.
+COPYRIGHT (c) 1991 by Claus Gittinger
+ All Rights Reserved
+
+$Header: /cvs/stx/stx/libtool/Attic/EvMonitor.st,v 1.3 1994-11-17 14:46:46 claus Exp $
+'!
-start with: EventMonitor start
+!EventMonitor class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1991 by Claus Gittinger
+ All Rights Reserved
-%W% %E%
-written spring 91 by claus
-'!
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+!
+
+version
+"
+$Header: /cvs/stx/stx/libtool/Attic/EvMonitor.st,v 1.3 1994-11-17 14:46:46 claus Exp $
+"
+!
+
+documentation
+"
+ like xev - show events.
+ You can use this to check your keyboard mappings, for example.
+ start with:
+ EventMonitor open
+"
+! !
!EventMonitor class methodsFor:'defaults'!
@@ -26,6 +67,14 @@
^ 'Event Monitor'
! !
+!EventMonitor methodsFor:'initialization'!
+
+initialize
+ super initialize.
+
+ Label label:'see event trace\on standard output' withCRs in:self
+! !
+
!EventMonitor methodsFor:'events'!
keyPress:key x:x y:y
@@ -67,6 +116,15 @@
' button:' print. button printNL
!
+pointerEnter:state x:x y:y
+ 'pointerEnter x:' print. x print. ' y:' print. y print.
+ ' state:' print. state printNL
+!
+
+pointerLeave:state
+ 'pointerLeave state:' print. state printNL
+!
+
mapped
'mapped' printNL
!
@@ -86,5 +144,6 @@
self enableMotionEvents.
self enableButtonMotionEvents.
self enableKeyReleaseEvents.
+ self enableEnterLeaveEvents.
self enableEvent:#visibilityChange
! !
--- a/EventMonitor.st Thu Nov 17 15:44:34 1994 +0100
+++ b/EventMonitor.st Thu Nov 17 15:47:59 1994 +0100
@@ -1,3 +1,15 @@
+"
+ COPYRIGHT (c) 1991 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
'From Smalltalk/X, Version:1.4 on 19-Jul-91 at 18:34:01'!
StandardSystemView subclass:#EventMonitor
@@ -8,13 +20,42 @@
!
EventMonitor comment:'
-like xev - show events.
+COPYRIGHT (c) 1991 by Claus Gittinger
+ All Rights Reserved
+
+$Header: /cvs/stx/stx/libtool/EventMonitor.st,v 1.3 1994-11-17 14:46:46 claus Exp $
+'!
-start with: EventMonitor start
+!EventMonitor class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1991 by Claus Gittinger
+ All Rights Reserved
-%W% %E%
-written spring 91 by claus
-'!
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+!
+
+version
+"
+$Header: /cvs/stx/stx/libtool/EventMonitor.st,v 1.3 1994-11-17 14:46:46 claus Exp $
+"
+!
+
+documentation
+"
+ like xev - show events.
+ You can use this to check your keyboard mappings, for example.
+ start with:
+ EventMonitor open
+"
+! !
!EventMonitor class methodsFor:'defaults'!
@@ -26,6 +67,14 @@
^ 'Event Monitor'
! !
+!EventMonitor methodsFor:'initialization'!
+
+initialize
+ super initialize.
+
+ Label label:'see event trace\on standard output' withCRs in:self
+! !
+
!EventMonitor methodsFor:'events'!
keyPress:key x:x y:y
@@ -67,6 +116,15 @@
' button:' print. button printNL
!
+pointerEnter:state x:x y:y
+ 'pointerEnter x:' print. x print. ' y:' print. y print.
+ ' state:' print. state printNL
+!
+
+pointerLeave:state
+ 'pointerLeave state:' print. state printNL
+!
+
mapped
'mapped' printNL
!
@@ -86,5 +144,6 @@
self enableMotionEvents.
self enableButtonMotionEvents.
self enableKeyReleaseEvents.
+ self enableEnterLeaveEvents.
self enableEvent:#visibilityChange
! !
--- a/FBrowser.st Thu Nov 17 15:44:34 1994 +0100
+++ b/FBrowser.st Thu Nov 17 15:47:59 1994 +0100
@@ -16,8 +16,9 @@
fileList
checkBlock checkDelta timeOfLastCheck
showLongList showVeryLongList showDotFiles
- myName killButton compressTabs lockUpdate'
- classVariableNames:'DirectoryHistory HistorySize'
+ myName killButton compressTabs lockUpdate
+ previousDirectory currentFileName timeOfFileRead'
+ classVariableNames:'DirectoryHistory DirectoryHistoryWhere HistorySize'
poolDictionaries:''
category:'Interface-Browsers'
!
@@ -26,7 +27,7 @@
COPYRIGHT (c) 1991 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libtool/Attic/FBrowser.st,v 1.19 1994-10-28 03:29:30 claus Exp $
+$Header: /cvs/stx/stx/libtool/Attic/FBrowser.st,v 1.20 1994-11-17 14:46:47 claus Exp $
'!
!FileBrowser class methodsFor:'documentation'!
@@ -47,7 +48,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/Attic/FBrowser.st,v 1.19 1994-10-28 03:29:30 claus Exp $
+$Header: /cvs/stx/stx/libtool/Attic/FBrowser.st,v 1.20 1994-11-17 14:46:47 claus Exp $
"
!
@@ -57,9 +58,15 @@
but migrated into a quite nice tool, includes all kinds of
warning and information boxes, background processes for directory-
reading and internationalized strings. A good example for beginners,
- on how to do things ....
+ on how to do things .... (and maybe how not to do things ;-)
+
See additional information in 'doc/misc/fbrowser.doc'.
+ WARNING: files edited with FileBrowser will have leading spaces (multiple-8)
+ being replaced by tabs. If tabs are to be preserved at other
+ positions (for example, sendmail-config files) they will be
+ corrupt after being written.
+
instancevariables of interrest:
checkDelta <Integer> number of seconds of check interval
@@ -71,6 +78,9 @@
compressTabs <Boolean> if true, leading spaces will be
replaced by tabs when saving text
+
+ some of the defaults (long/short list etc.) can be set by the resource file;
+ see FileBrowser>>initialize for more details..
"
! !
@@ -81,7 +91,12 @@
^ (self new currentDirectory:aDirectoryPath) open
- "FileBrowser openOn:'aDirectoryPath'"
+ "
+ FileBrowser openOn:'aDirectoryPath'
+ FileBrowser openOn:'/etc'
+ FileBrowser openOn:'..'
+ FileBrowser openOn:'.'
+ "
! !
!FileBrowser methodsFor:'initialization'!
@@ -91,11 +106,32 @@
super initialize.
- compressTabs := true.
+ "if true, will replace leading spaces by tabs on
+ file write. If false, they will be written as spaces
+ "
+ compressTabs := resources at:'COMPRESS_TABS' default:true.
+
+ "
+ showing long or short by default
+ "
+ showLongList := resources at:'LONG_LIST' default:false.
+
+ "
+ show type of contents (somwehat slow) or not ?
+ "
+ showVeryLongList := resources at:'VERYLONG_LIST' default:true.
+
+ "
+ show hidden files or not ?
+ "
+ showDotFiles := resources at:'SHOW_DOT_FILES' default:false.
+
+
lockUpdate := false.
DirectoryHistory isNil ifTrue:[
DirectoryHistory := OrderedCollection new.
+ DirectoryHistoryWhere := OrderedCollection new.
HistorySize := 15.
].
@@ -107,6 +143,7 @@
labelFrame := View origin:(0.0 @ 0.0)
corner:(1.0 @ (font height * 2))
in:self.
+
StyleSheet name = #st80 ifTrue:[
labelFrame level:1
].
@@ -124,8 +161,6 @@
checkDelta := resources at:'CHECK_DELTA' default:10.
currentDirectory := FileDirectory directoryNamed:'.'.
- showLongList := resources at:'LONG_LIST' default:false.
- showDotFiles := resources at:'SHOW_DOT_FILES' default:false.
filterField := EditField in:labelFrame.
filterField origin:[((width // 4 * 3) + halfSpacing) @ halfSpacing]
@@ -214,14 +249,14 @@
!
initializeLabelMiddleButtonMenu
- |labels selectors args|
+ |labels selectors args menu|
labelView notNil ifTrue:[
labels := resources array:#(
'copy path'
'-'
'up'
-"/ 'back'
+ 'back'
'change to home-directory'
'change directory ...'
).
@@ -230,12 +265,12 @@
copyPath
nil
changeToParentDirectory
-"/ changeToPreviousDirectory
+ changeToPreviousDirectory
changeToHomeDirectory
changeCurrentDirectory
).
- args := Array new:5.
+ args := Array new:(labels size).
DirectoryHistory size > 0 ifTrue:[
labels := labels copyWith:'-'.
@@ -249,15 +284,14 @@
]
].
- labelView
- middleButtonMenu:(PopUpMenu
- labels:labels
- selectors:selectors
- args:args
- receiver:self
- for:labelView).
-
-
+ menu := (PopUpMenu
+ labels:labels
+ selectors:selectors
+ args:args
+ receiver:self
+ for:labelView).
+ menu disable:#changeToPreviousDirectory.
+ labelView middleButtonMenu:menu.
]
!
@@ -552,9 +586,14 @@
!
checkIfDirectoryHasChanged
- "every checkDelta secs, check if directoy has changed and update view if so"
+ "every checkDelta secs, check if directoy has changed and update the list if so.
+ Also, we check if the file shown has been touched in the meanwhile (for example,
+ from another browser) and say 'outdated' in the label if so.
+ This avoids confusion if the same file is being edited by two browsers. (or other editors).
+ If the text shown in the codeView has been edited, 'modified' is shown.
+ "
- |oldSelection nOld here|
+ |oldSelection nOld here newState|
shown ifTrue:[
currentDirectory notNil ifTrue:[
@@ -564,6 +603,10 @@
^ self
].
+ subView modified ifTrue:[
+ newState := ' (modified)'
+ ].
+
here := currentDirectory pathName.
(OperatingSystem isReadable:here) ifTrue:[
Processor removeTimedBlock:checkBlock.
@@ -580,10 +623,24 @@
] ifFalse:[
fileListView selectElementWithoutScroll:oldSelection
]
- ]
+ ].
] ifFalse:[
Processor addTimedBlock:checkBlock afterSeconds:checkDelta
- ]
+ ].
+
+ currentFileName notNil ifTrue:[
+ (currentDirectory exists:currentFileName) ifFalse:[
+ newState := ' (removed)'.
+ ] ifTrue:[
+ (currentDirectory timeOfLastChange:currentFileName) > timeOfFileRead ifTrue:[
+ newState := ' (outdated)'.
+ subView modified ifTrue:[
+ newState := ' (modified & outdated)'
+ ]
+ ].
+ ].
+ ].
+
] ifFalse:[
"
if the directory has been deleted, or is not readable ...
@@ -596,7 +653,15 @@
fileListView contents:nil.
self label:(myName , ': directory is gone !!').
"/ Processor addTimedBlock:checkBlock afterSeconds:checkDelta
- ]
+ ].
+
+ newState notNil ifTrue:[
+ currentFileName isNil ifTrue:[
+ self label:myName , newState
+ ] ifFalse:[
+ self label:myName , ': ' , currentFileName , newState
+ ]
+ ].
]
]
!
@@ -762,7 +827,11 @@
entry colAt:6 put:(self sizePrintString:(info at:#size)).
].
- entry colAt:7 put:(currentDirectory asFilename:aFileName) fileType.
+ showVeryLongList ifTrue:[
+ entry colAt:7 put:(currentDirectory asFilename:aFileName) fileType.
+ ] ifFalse:[
+ entry colAt:7 put:((currentDirectory asFilename:aFileName) info at:#type)
+ ].
text add:entry
].
@@ -802,56 +871,80 @@
"verify argument is name of a readable & executable directory
and if so, go there"
- |msg path|
+ |msg path idx|
self label:myName; iconLabel:myName.
fileName notNil ifTrue:[
(currentDirectory isDirectory:fileName) ifTrue:[
(currentDirectory isReadable:fileName) ifTrue:[
(currentDirectory isExecutable:fileName) ifTrue:[
-"/ this code updates when a directory is left
-"/
-"/ updateHistory ifTrue:[
-"/ (DirectoryHistory includes:(currentDirectory pathName)) ifFalse:[
-"/ DirectoryHistory addFirst:currentDirectory pathName.
-"/ DirectoryHistory size > HistorySize ifTrue:[
-"/ DirectoryHistory removeLast
-"/ ].
-"/ DirectoryHistory changed.
-"/ ]
-"/ ].
+
+ path := currentDirectory pathName.
+ previousDirectory := path.
+ (labelView notNil
+ and:[labelView middleButtonMenu notNil]) ifTrue:[
+ labelView middleButtonMenu enable:#changeToPreviousDirectory.
+ ].
+
+ "
+ remember where we are in the fileList
+ (in case we want to return)
+ "
+ idx := DirectoryHistory indexOf:path.
+ idx ~~ 0 ifTrue:[
+ DirectoryHistoryWhere at:idx put:fileListView firstLineShown
+ ].
self setCurrentDirectory:fileName.
-"/ its better to do it when directories are entered
-"/
+ path := currentDirectory pathName.
+
+ "
+ if we have already been there, look for the
+ position offset, and scroll the fileList
+ "
+ idx := DirectoryHistory indexOf:path.
+ idx ~~ 0 ifTrue:[
+ |pos|
+
+ pos := DirectoryHistoryWhere at:idx.
+ pos notNil ifTrue:[
+ fileListView scrollToLine:pos
+ ]
+ ].
+
updateHistory ifTrue:[
- path := currentDirectory pathName.
+ |pos|
+
(DirectoryHistory includes:path) ifFalse:[
- DirectoryHistory addFirst:path.
- DirectoryHistory size > HistorySize ifTrue:[
- DirectoryHistory removeLast
- ].
- DirectoryHistory changed.
+ DirectoryHistory size >= HistorySize ifTrue:[
+ DirectoryHistory removeLast.
+ DirectoryHistoryWhere removeLast
+ ]
] ifTrue:[
"already been there before; move the entry to
- the end, so it will fall out later."
+ the beginning, so it will fall out later."
- DirectoryHistory remove:path.
- DirectoryHistory addFirst:path.
- DirectoryHistory changed.
- ]
+ idx := DirectoryHistory indexOf:path.
+ DirectoryHistory removeIndex:idx.
+ pos := DirectoryHistoryWhere at:idx.
+ DirectoryHistoryWhere removeIndex:idx.
+ ].
+ DirectoryHistory addFirst:path.
+ DirectoryHistoryWhere addFirst:pos.
+ DirectoryHistory changed.
].
+
^ self
].
- msg := (resources string:'cannot change directory to ''%1'' !!' with:fileName)
+ msg := 'cannot change directory to ''%1'' !!'
] ifFalse:[
- msg := (resources string:'cannot read directory ''%1'' !!' with:fileName)
+ msg := 'cannot read directory ''%1'' !!'
]
] ifFalse:[
- msg := (resources string:'''%1'' is not a directory !!' with:fileName)
+ msg := '''%1'' is not a directory !!'
].
- self showAlert:msg with:nil
+ self showAlert:(resources string:msg with:fileName) with:nil
]
!
@@ -867,6 +960,19 @@
self doChangeCurrentDirectoryTo:(OperatingSystem getHomeDirectory) updateHistory:true
!
+changeToPreviousDirectory
+ "if text was modified show a queryBox,
+ otherwise change immediately to previous directory."
+
+ previousDirectory isNil ifTrue:[^ self].
+ self askIfModified:(resources at:'contents has not been saved.\\Modifications will be lost when directory is changed.') withCRs
+ yesButton:(resources at:'change')
+ action:[
+ self doChangeCurrentDirectoryTo:previousDirectory
+ updateHistory:false
+ ]
+!
+
setCurrentDirectory:aPathName
"setup for another directory"
@@ -878,6 +984,7 @@
newDirectory notNil ifTrue:[
currentDirectory := newDirectory.
fileListView contents:nil.
+ currentFileName := nil.
self updateCurrentDirectory.
info := self getInfoFile.
self showInfo:info.
@@ -918,7 +1025,10 @@
"for very big files, give ObjectMemory a hint, to preallocate more"
(sz := stream size) > 1000000 ifTrue:[
- ObjectMemory moreOldSpace:(sz + (sz // 5)) "/ add 20% for tab expansion
+ Processor activeProcess withLowerPriorityDo:[
+ ObjectMemory announceSpaceNeed:(sz + (sz // 5)) "/ add 20% for tab expansion
+ ].
+"/ ObjectMemory moreOldSpace:(sz + (sz // 5)) "/ add 20% for tab expansion
].
text := self readStream:stream lineDelimiter:aCharacter.
@@ -1084,10 +1194,6 @@
] ifTrue:[
subView insertSelectedStringAtCursor:text asString
].
-
- subView acceptAction:[:theCode |
- self writeFile:fileName text:theCode
- ]
!
show:something
@@ -1095,7 +1201,8 @@
subView contents:something.
subView acceptAction:nil.
- subView modified:false
+ subView modified:false.
+ currentFileName := nil
!
doFileGet
@@ -1111,7 +1218,16 @@
self label:myName.
self iconLabel:myName
] ifFalse:[
+ timeOfFileRead := currentDirectory timeOfLastChange:fileName.
self showFile:fileName insert:false.
+ currentFileName := fileName.
+
+ subView acceptAction:[:theCode |
+ self writeFile:fileName text:theCode.
+ timeOfFileRead := currentDirectory timeOfLastChange:fileName.
+ self label:myName , ': ' , currentFileName
+ ].
+
(currentDirectory isWritable:fileName) ifFalse:[
self label:(myName , ': ' , fileName , ' (readonly)')
] ifTrue:[
--- a/FileBrowser.st Thu Nov 17 15:44:34 1994 +0100
+++ b/FileBrowser.st Thu Nov 17 15:47:59 1994 +0100
@@ -16,8 +16,9 @@
fileList
checkBlock checkDelta timeOfLastCheck
showLongList showVeryLongList showDotFiles
- myName killButton compressTabs lockUpdate'
- classVariableNames:'DirectoryHistory HistorySize'
+ myName killButton compressTabs lockUpdate
+ previousDirectory currentFileName timeOfFileRead'
+ classVariableNames:'DirectoryHistory DirectoryHistoryWhere HistorySize'
poolDictionaries:''
category:'Interface-Browsers'
!
@@ -26,7 +27,7 @@
COPYRIGHT (c) 1991 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libtool/FileBrowser.st,v 1.19 1994-10-28 03:29:30 claus Exp $
+$Header: /cvs/stx/stx/libtool/FileBrowser.st,v 1.20 1994-11-17 14:46:47 claus Exp $
'!
!FileBrowser class methodsFor:'documentation'!
@@ -47,7 +48,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/FileBrowser.st,v 1.19 1994-10-28 03:29:30 claus Exp $
+$Header: /cvs/stx/stx/libtool/FileBrowser.st,v 1.20 1994-11-17 14:46:47 claus Exp $
"
!
@@ -57,9 +58,15 @@
but migrated into a quite nice tool, includes all kinds of
warning and information boxes, background processes for directory-
reading and internationalized strings. A good example for beginners,
- on how to do things ....
+ on how to do things .... (and maybe how not to do things ;-)
+
See additional information in 'doc/misc/fbrowser.doc'.
+ WARNING: files edited with FileBrowser will have leading spaces (multiple-8)
+ being replaced by tabs. If tabs are to be preserved at other
+ positions (for example, sendmail-config files) they will be
+ corrupt after being written.
+
instancevariables of interrest:
checkDelta <Integer> number of seconds of check interval
@@ -71,6 +78,9 @@
compressTabs <Boolean> if true, leading spaces will be
replaced by tabs when saving text
+
+ some of the defaults (long/short list etc.) can be set by the resource file;
+ see FileBrowser>>initialize for more details..
"
! !
@@ -81,7 +91,12 @@
^ (self new currentDirectory:aDirectoryPath) open
- "FileBrowser openOn:'aDirectoryPath'"
+ "
+ FileBrowser openOn:'aDirectoryPath'
+ FileBrowser openOn:'/etc'
+ FileBrowser openOn:'..'
+ FileBrowser openOn:'.'
+ "
! !
!FileBrowser methodsFor:'initialization'!
@@ -91,11 +106,32 @@
super initialize.
- compressTabs := true.
+ "if true, will replace leading spaces by tabs on
+ file write. If false, they will be written as spaces
+ "
+ compressTabs := resources at:'COMPRESS_TABS' default:true.
+
+ "
+ showing long or short by default
+ "
+ showLongList := resources at:'LONG_LIST' default:false.
+
+ "
+ show type of contents (somwehat slow) or not ?
+ "
+ showVeryLongList := resources at:'VERYLONG_LIST' default:true.
+
+ "
+ show hidden files or not ?
+ "
+ showDotFiles := resources at:'SHOW_DOT_FILES' default:false.
+
+
lockUpdate := false.
DirectoryHistory isNil ifTrue:[
DirectoryHistory := OrderedCollection new.
+ DirectoryHistoryWhere := OrderedCollection new.
HistorySize := 15.
].
@@ -107,6 +143,7 @@
labelFrame := View origin:(0.0 @ 0.0)
corner:(1.0 @ (font height * 2))
in:self.
+
StyleSheet name = #st80 ifTrue:[
labelFrame level:1
].
@@ -124,8 +161,6 @@
checkDelta := resources at:'CHECK_DELTA' default:10.
currentDirectory := FileDirectory directoryNamed:'.'.
- showLongList := resources at:'LONG_LIST' default:false.
- showDotFiles := resources at:'SHOW_DOT_FILES' default:false.
filterField := EditField in:labelFrame.
filterField origin:[((width // 4 * 3) + halfSpacing) @ halfSpacing]
@@ -214,14 +249,14 @@
!
initializeLabelMiddleButtonMenu
- |labels selectors args|
+ |labels selectors args menu|
labelView notNil ifTrue:[
labels := resources array:#(
'copy path'
'-'
'up'
-"/ 'back'
+ 'back'
'change to home-directory'
'change directory ...'
).
@@ -230,12 +265,12 @@
copyPath
nil
changeToParentDirectory
-"/ changeToPreviousDirectory
+ changeToPreviousDirectory
changeToHomeDirectory
changeCurrentDirectory
).
- args := Array new:5.
+ args := Array new:(labels size).
DirectoryHistory size > 0 ifTrue:[
labels := labels copyWith:'-'.
@@ -249,15 +284,14 @@
]
].
- labelView
- middleButtonMenu:(PopUpMenu
- labels:labels
- selectors:selectors
- args:args
- receiver:self
- for:labelView).
-
-
+ menu := (PopUpMenu
+ labels:labels
+ selectors:selectors
+ args:args
+ receiver:self
+ for:labelView).
+ menu disable:#changeToPreviousDirectory.
+ labelView middleButtonMenu:menu.
]
!
@@ -552,9 +586,14 @@
!
checkIfDirectoryHasChanged
- "every checkDelta secs, check if directoy has changed and update view if so"
+ "every checkDelta secs, check if directoy has changed and update the list if so.
+ Also, we check if the file shown has been touched in the meanwhile (for example,
+ from another browser) and say 'outdated' in the label if so.
+ This avoids confusion if the same file is being edited by two browsers. (or other editors).
+ If the text shown in the codeView has been edited, 'modified' is shown.
+ "
- |oldSelection nOld here|
+ |oldSelection nOld here newState|
shown ifTrue:[
currentDirectory notNil ifTrue:[
@@ -564,6 +603,10 @@
^ self
].
+ subView modified ifTrue:[
+ newState := ' (modified)'
+ ].
+
here := currentDirectory pathName.
(OperatingSystem isReadable:here) ifTrue:[
Processor removeTimedBlock:checkBlock.
@@ -580,10 +623,24 @@
] ifFalse:[
fileListView selectElementWithoutScroll:oldSelection
]
- ]
+ ].
] ifFalse:[
Processor addTimedBlock:checkBlock afterSeconds:checkDelta
- ]
+ ].
+
+ currentFileName notNil ifTrue:[
+ (currentDirectory exists:currentFileName) ifFalse:[
+ newState := ' (removed)'.
+ ] ifTrue:[
+ (currentDirectory timeOfLastChange:currentFileName) > timeOfFileRead ifTrue:[
+ newState := ' (outdated)'.
+ subView modified ifTrue:[
+ newState := ' (modified & outdated)'
+ ]
+ ].
+ ].
+ ].
+
] ifFalse:[
"
if the directory has been deleted, or is not readable ...
@@ -596,7 +653,15 @@
fileListView contents:nil.
self label:(myName , ': directory is gone !!').
"/ Processor addTimedBlock:checkBlock afterSeconds:checkDelta
- ]
+ ].
+
+ newState notNil ifTrue:[
+ currentFileName isNil ifTrue:[
+ self label:myName , newState
+ ] ifFalse:[
+ self label:myName , ': ' , currentFileName , newState
+ ]
+ ].
]
]
!
@@ -762,7 +827,11 @@
entry colAt:6 put:(self sizePrintString:(info at:#size)).
].
- entry colAt:7 put:(currentDirectory asFilename:aFileName) fileType.
+ showVeryLongList ifTrue:[
+ entry colAt:7 put:(currentDirectory asFilename:aFileName) fileType.
+ ] ifFalse:[
+ entry colAt:7 put:((currentDirectory asFilename:aFileName) info at:#type)
+ ].
text add:entry
].
@@ -802,56 +871,80 @@
"verify argument is name of a readable & executable directory
and if so, go there"
- |msg path|
+ |msg path idx|
self label:myName; iconLabel:myName.
fileName notNil ifTrue:[
(currentDirectory isDirectory:fileName) ifTrue:[
(currentDirectory isReadable:fileName) ifTrue:[
(currentDirectory isExecutable:fileName) ifTrue:[
-"/ this code updates when a directory is left
-"/
-"/ updateHistory ifTrue:[
-"/ (DirectoryHistory includes:(currentDirectory pathName)) ifFalse:[
-"/ DirectoryHistory addFirst:currentDirectory pathName.
-"/ DirectoryHistory size > HistorySize ifTrue:[
-"/ DirectoryHistory removeLast
-"/ ].
-"/ DirectoryHistory changed.
-"/ ]
-"/ ].
+
+ path := currentDirectory pathName.
+ previousDirectory := path.
+ (labelView notNil
+ and:[labelView middleButtonMenu notNil]) ifTrue:[
+ labelView middleButtonMenu enable:#changeToPreviousDirectory.
+ ].
+
+ "
+ remember where we are in the fileList
+ (in case we want to return)
+ "
+ idx := DirectoryHistory indexOf:path.
+ idx ~~ 0 ifTrue:[
+ DirectoryHistoryWhere at:idx put:fileListView firstLineShown
+ ].
self setCurrentDirectory:fileName.
-"/ its better to do it when directories are entered
-"/
+ path := currentDirectory pathName.
+
+ "
+ if we have already been there, look for the
+ position offset, and scroll the fileList
+ "
+ idx := DirectoryHistory indexOf:path.
+ idx ~~ 0 ifTrue:[
+ |pos|
+
+ pos := DirectoryHistoryWhere at:idx.
+ pos notNil ifTrue:[
+ fileListView scrollToLine:pos
+ ]
+ ].
+
updateHistory ifTrue:[
- path := currentDirectory pathName.
+ |pos|
+
(DirectoryHistory includes:path) ifFalse:[
- DirectoryHistory addFirst:path.
- DirectoryHistory size > HistorySize ifTrue:[
- DirectoryHistory removeLast
- ].
- DirectoryHistory changed.
+ DirectoryHistory size >= HistorySize ifTrue:[
+ DirectoryHistory removeLast.
+ DirectoryHistoryWhere removeLast
+ ]
] ifTrue:[
"already been there before; move the entry to
- the end, so it will fall out later."
+ the beginning, so it will fall out later."
- DirectoryHistory remove:path.
- DirectoryHistory addFirst:path.
- DirectoryHistory changed.
- ]
+ idx := DirectoryHistory indexOf:path.
+ DirectoryHistory removeIndex:idx.
+ pos := DirectoryHistoryWhere at:idx.
+ DirectoryHistoryWhere removeIndex:idx.
+ ].
+ DirectoryHistory addFirst:path.
+ DirectoryHistoryWhere addFirst:pos.
+ DirectoryHistory changed.
].
+
^ self
].
- msg := (resources string:'cannot change directory to ''%1'' !!' with:fileName)
+ msg := 'cannot change directory to ''%1'' !!'
] ifFalse:[
- msg := (resources string:'cannot read directory ''%1'' !!' with:fileName)
+ msg := 'cannot read directory ''%1'' !!'
]
] ifFalse:[
- msg := (resources string:'''%1'' is not a directory !!' with:fileName)
+ msg := '''%1'' is not a directory !!'
].
- self showAlert:msg with:nil
+ self showAlert:(resources string:msg with:fileName) with:nil
]
!
@@ -867,6 +960,19 @@
self doChangeCurrentDirectoryTo:(OperatingSystem getHomeDirectory) updateHistory:true
!
+changeToPreviousDirectory
+ "if text was modified show a queryBox,
+ otherwise change immediately to previous directory."
+
+ previousDirectory isNil ifTrue:[^ self].
+ self askIfModified:(resources at:'contents has not been saved.\\Modifications will be lost when directory is changed.') withCRs
+ yesButton:(resources at:'change')
+ action:[
+ self doChangeCurrentDirectoryTo:previousDirectory
+ updateHistory:false
+ ]
+!
+
setCurrentDirectory:aPathName
"setup for another directory"
@@ -878,6 +984,7 @@
newDirectory notNil ifTrue:[
currentDirectory := newDirectory.
fileListView contents:nil.
+ currentFileName := nil.
self updateCurrentDirectory.
info := self getInfoFile.
self showInfo:info.
@@ -918,7 +1025,10 @@
"for very big files, give ObjectMemory a hint, to preallocate more"
(sz := stream size) > 1000000 ifTrue:[
- ObjectMemory moreOldSpace:(sz + (sz // 5)) "/ add 20% for tab expansion
+ Processor activeProcess withLowerPriorityDo:[
+ ObjectMemory announceSpaceNeed:(sz + (sz // 5)) "/ add 20% for tab expansion
+ ].
+"/ ObjectMemory moreOldSpace:(sz + (sz // 5)) "/ add 20% for tab expansion
].
text := self readStream:stream lineDelimiter:aCharacter.
@@ -1084,10 +1194,6 @@
] ifTrue:[
subView insertSelectedStringAtCursor:text asString
].
-
- subView acceptAction:[:theCode |
- self writeFile:fileName text:theCode
- ]
!
show:something
@@ -1095,7 +1201,8 @@
subView contents:something.
subView acceptAction:nil.
- subView modified:false
+ subView modified:false.
+ currentFileName := nil
!
doFileGet
@@ -1111,7 +1218,16 @@
self label:myName.
self iconLabel:myName
] ifFalse:[
+ timeOfFileRead := currentDirectory timeOfLastChange:fileName.
self showFile:fileName insert:false.
+ currentFileName := fileName.
+
+ subView acceptAction:[:theCode |
+ self writeFile:fileName text:theCode.
+ timeOfFileRead := currentDirectory timeOfLastChange:fileName.
+ self label:myName , ': ' , currentFileName
+ ].
+
(currentDirectory isWritable:fileName) ifFalse:[
self label:(myName , ': ' , fileName , ' (readonly)')
] ifTrue:[
--- a/ImageInspectorView.st Thu Nov 17 15:44:34 1994 +0100
+++ b/ImageInspectorView.st Thu Nov 17 15:47:59 1994 +0100
@@ -1,5 +1,3 @@
-"{ Package: 'Programming Tools' }"
-
"
COPYRIGHT (c) 1993 by Claus Gittinger
All Rights Reserved
@@ -25,7 +23,7 @@
this class allows better inspection of images
-$Header: /cvs/stx/stx/libtool/ImageInspectorView.st,v 1.2 1994-10-10 03:15:45 claus Exp $
+$Header: /cvs/stx/stx/libtool/ImageInspectorView.st,v 1.3 1994-11-17 14:46:50 claus Exp $
'!
!ImageInspectorView methodsFor:'accessing'!
--- a/ImgInspV.st Thu Nov 17 15:44:34 1994 +0100
+++ b/ImgInspV.st Thu Nov 17 15:47:59 1994 +0100
@@ -1,5 +1,3 @@
-"{ Package: 'Programming Tools' }"
-
"
COPYRIGHT (c) 1993 by Claus Gittinger
All Rights Reserved
@@ -25,7 +23,7 @@
this class allows better inspection of images
-$Header: /cvs/stx/stx/libtool/Attic/ImgInspV.st,v 1.2 1994-10-10 03:15:45 claus Exp $
+$Header: /cvs/stx/stx/libtool/Attic/ImgInspV.st,v 1.3 1994-11-17 14:46:50 claus Exp $
'!
!ImageInspectorView methodsFor:'accessing'!
--- a/InspView.st Thu Nov 17 15:44:34 1994 +0100
+++ b/InspView.st Thu Nov 17 15:47:59 1994 +0100
@@ -1,5 +1,3 @@
-"{ Package: 'Programming Tools' }"
-
"
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
@@ -25,7 +23,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libtool/Attic/InspView.st,v 1.11 1994-10-28 03:30:29 claus Exp $
+$Header: /cvs/stx/stx/libtool/Attic/InspView.st,v 1.12 1994-11-17 14:46:51 claus Exp $
'!
!InspectorView class methodsFor:'documentation'!
@@ -46,7 +44,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/Attic/InspView.st,v 1.11 1994-10-28 03:30:29 claus Exp $
+$Header: /cvs/stx/stx/libtool/Attic/InspView.st,v 1.12 1994-11-17 14:46:51 claus Exp $
"
!
@@ -158,14 +156,25 @@
in:panel.
v origin:(0.3 @ 0.0) corner:(1.0 @ 1.0).
workspace := v scrolledView.
+
+ workspace acceptAction:[:theText | self doAccept:theText asString].
+
nShown := 100.
self initializeListViewMiddleButtonMenus
!
initializeListViewMiddleButtonMenus
menu1 := PopUpMenu
- labels:(resources array:#('inspect'))
- selectors:#doInspect
+ labels:(resources array:#(
+ 'inspect'
+"/ '-'
+"/ 'owners'
+ ))
+ selectors:#(
+ doInspect
+"/ nil
+"/ inspectOwners
+ )
receiver:self
for:listView.
menu2 := PopUpMenu
@@ -177,7 +186,6 @@
selectors:#(doInspect nil showMore)
receiver:self
for:listView.
- workspace acceptAction:[:theText | self doAccept:theText asString]
!
mapped
@@ -196,10 +204,13 @@
self inspect:o
! !
-!InspectorView methodsFor:'accessing'!
+!InspectorView methodsFor:'release'!
release
- "release inpected object"
+ "release inpected object. This is normally not needed,
+ since the garbage collector will find this memory alone.
+ However, if some applications keeps inspectors (for example,
+ the debugger does this), this would be freed very late."
"
inspectedObject notNil ifTrue:[
@@ -208,9 +219,12 @@
"
inspectedObject := nil.
inspectedValues := nil.
+ workspace doItAction:nil.
workspace contents:nil.
listView contents:nil
-!
+! !
+
+!InspectorView methodsFor:'private'!
listOfNames
"return a list of names to show in the selectionList"
@@ -254,6 +268,21 @@
self inspect:inspectedObject
!
+setDoItAction
+ workspace doItAction:[:theCode |
+ (inspectedObject class compiler)
+ evaluate:theCode
+ in:nil
+ receiver:inspectedObject
+ notifying:workspace
+ logged:true
+ ifFail:nil
+ ].
+
+! !
+
+!InspectorView methodsFor:'accessing'!
+
inspect:anObject
"define the object to be inspected"
@@ -280,15 +309,7 @@
].
workspace contents:nil.
- workspace doItAction:[:theCode |
- inspectedObject class compiler
- evaluate:theCode
- in:nil
- receiver:inspectedObject
- notifying:workspace
- logged:true
- ifFail:nil
- ].
+ self setDoItAction.
"
sameObject ifFalse:[
@@ -379,6 +400,13 @@
"
workspace contents:nil.
"
+ (lineNr == listView list size
+ and:[(listView listAt:lineNr) startsWith:' ...']) ifTrue:[
+ "clicked on the '...' entry"
+ self showMore.
+ listView selection:lineNr.
+ ].
+
inspectedValues isNil ifTrue:[
lineNr == 1 ifTrue:[
"selecting self also does a re-set, this allows updating the list"
@@ -466,4 +494,42 @@
].
objectToInspect inspect
]
+!
+
+inspectOwners
+ self withCursor:(Cursor questionMark) do:[
+ |owners dict|
+
+ owners := (ObjectMemory whoReferences:inspectedObject) asOrderedCollection.
+ owners size > 500 ifTrue:[
+ (self confirm:'there are ' , owners size printString , ' owners.\\Do you really want to see them all ?' withCRs)
+ ifFalse:[^ self]
+ ].
+ dict := IdentityDictionary new.
+ owners do:[:owner |
+ |set names oClass|
+
+ owner ~~ self ifTrue:[
+ set := Set new.
+ names := owner class allInstVarNames.
+ oClass := owner class.
+ 1 to:oClass instSize do:[:i |
+ (owner instVarAt:i) == inspectedObject ifTrue:[
+ set add:(names at:i).
+ ].
+ ].
+ oClass isVariable ifTrue:[
+ oClass isPointers ifTrue:[
+ 1 to:owner basicSize do:[:i |
+ (owner basicAt:i) == inspectedObject ifTrue:[
+ set add:i
+ ]
+ ]
+ ]
+ ].
+ dict at:owner put:set
+ ].
+ ].
+ dict inspect
+ ]
! !
--- a/InspectorView.st Thu Nov 17 15:44:34 1994 +0100
+++ b/InspectorView.st Thu Nov 17 15:47:59 1994 +0100
@@ -1,5 +1,3 @@
-"{ Package: 'Programming Tools' }"
-
"
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
@@ -25,7 +23,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libtool/InspectorView.st,v 1.11 1994-10-28 03:30:29 claus Exp $
+$Header: /cvs/stx/stx/libtool/InspectorView.st,v 1.12 1994-11-17 14:46:51 claus Exp $
'!
!InspectorView class methodsFor:'documentation'!
@@ -46,7 +44,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/InspectorView.st,v 1.11 1994-10-28 03:30:29 claus Exp $
+$Header: /cvs/stx/stx/libtool/InspectorView.st,v 1.12 1994-11-17 14:46:51 claus Exp $
"
!
@@ -158,14 +156,25 @@
in:panel.
v origin:(0.3 @ 0.0) corner:(1.0 @ 1.0).
workspace := v scrolledView.
+
+ workspace acceptAction:[:theText | self doAccept:theText asString].
+
nShown := 100.
self initializeListViewMiddleButtonMenus
!
initializeListViewMiddleButtonMenus
menu1 := PopUpMenu
- labels:(resources array:#('inspect'))
- selectors:#doInspect
+ labels:(resources array:#(
+ 'inspect'
+"/ '-'
+"/ 'owners'
+ ))
+ selectors:#(
+ doInspect
+"/ nil
+"/ inspectOwners
+ )
receiver:self
for:listView.
menu2 := PopUpMenu
@@ -177,7 +186,6 @@
selectors:#(doInspect nil showMore)
receiver:self
for:listView.
- workspace acceptAction:[:theText | self doAccept:theText asString]
!
mapped
@@ -196,10 +204,13 @@
self inspect:o
! !
-!InspectorView methodsFor:'accessing'!
+!InspectorView methodsFor:'release'!
release
- "release inpected object"
+ "release inpected object. This is normally not needed,
+ since the garbage collector will find this memory alone.
+ However, if some applications keeps inspectors (for example,
+ the debugger does this), this would be freed very late."
"
inspectedObject notNil ifTrue:[
@@ -208,9 +219,12 @@
"
inspectedObject := nil.
inspectedValues := nil.
+ workspace doItAction:nil.
workspace contents:nil.
listView contents:nil
-!
+! !
+
+!InspectorView methodsFor:'private'!
listOfNames
"return a list of names to show in the selectionList"
@@ -254,6 +268,21 @@
self inspect:inspectedObject
!
+setDoItAction
+ workspace doItAction:[:theCode |
+ (inspectedObject class compiler)
+ evaluate:theCode
+ in:nil
+ receiver:inspectedObject
+ notifying:workspace
+ logged:true
+ ifFail:nil
+ ].
+
+! !
+
+!InspectorView methodsFor:'accessing'!
+
inspect:anObject
"define the object to be inspected"
@@ -280,15 +309,7 @@
].
workspace contents:nil.
- workspace doItAction:[:theCode |
- inspectedObject class compiler
- evaluate:theCode
- in:nil
- receiver:inspectedObject
- notifying:workspace
- logged:true
- ifFail:nil
- ].
+ self setDoItAction.
"
sameObject ifFalse:[
@@ -379,6 +400,13 @@
"
workspace contents:nil.
"
+ (lineNr == listView list size
+ and:[(listView listAt:lineNr) startsWith:' ...']) ifTrue:[
+ "clicked on the '...' entry"
+ self showMore.
+ listView selection:lineNr.
+ ].
+
inspectedValues isNil ifTrue:[
lineNr == 1 ifTrue:[
"selecting self also does a re-set, this allows updating the list"
@@ -466,4 +494,42 @@
].
objectToInspect inspect
]
+!
+
+inspectOwners
+ self withCursor:(Cursor questionMark) do:[
+ |owners dict|
+
+ owners := (ObjectMemory whoReferences:inspectedObject) asOrderedCollection.
+ owners size > 500 ifTrue:[
+ (self confirm:'there are ' , owners size printString , ' owners.\\Do you really want to see them all ?' withCRs)
+ ifFalse:[^ self]
+ ].
+ dict := IdentityDictionary new.
+ owners do:[:owner |
+ |set names oClass|
+
+ owner ~~ self ifTrue:[
+ set := Set new.
+ names := owner class allInstVarNames.
+ oClass := owner class.
+ 1 to:oClass instSize do:[:i |
+ (owner instVarAt:i) == inspectedObject ifTrue:[
+ set add:(names at:i).
+ ].
+ ].
+ oClass isVariable ifTrue:[
+ oClass isPointers ifTrue:[
+ 1 to:owner basicSize do:[:i |
+ (owner basicAt:i) == inspectedObject ifTrue:[
+ set add:i
+ ]
+ ]
+ ]
+ ].
+ dict at:owner put:set
+ ].
+ ].
+ dict inspect
+ ]
! !
--- a/Make.proto Thu Nov 17 15:44:34 1994 +0100
+++ b/Make.proto Thu Nov 17 15:47:59 1994 +0100
@@ -88,7 +88,7 @@
I=$(INCLUDE)
OBJECT=$(I)/Object.H $(I)/stc.h $(I)/stcIntern.h
VIEW=$(I)/View.H $(OBJECT)
-STDSYSVIEW=$(I)/StdSysV.H $(OBJECT)
+STDSYSVIEW=$(I)/StdSysV.H $(VIEW)
InspView.$(O): InspView.st $(VIEW)
DictInspV.$(O): DictInspV.st $(I)/InspView.H $(VIEW)
--- a/MemMonitor.st Thu Nov 17 15:44:34 1994 +0100
+++ b/MemMonitor.st Thu Nov 17 15:47:59 1994 +0100
@@ -12,8 +12,9 @@
StandardSystemView subclass:#MemoryMonitor
instanceVariableNames:'updateInterval updateBlock myProcess oldData newData
- freeData updateIndex org maxTotal minTotal newColor dX
- freeColor oldColor prevTotal prevFree prevFree2 prevOld'
+ freeData updateIndex org maxTotal minTotal dX
+ newColor freeColor oldColor
+ prevTotal prevFree prevFree2 prevOld scale'
classVariableNames:''
poolDictionaries:''
category:'Interface-Tools'
@@ -23,7 +24,7 @@
COPYRIGHT (c) 1991 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libtool/Attic/MemMonitor.st,v 1.3 1994-10-28 03:30:33 claus Exp $
+$Header: /cvs/stx/stx/libtool/Attic/MemMonitor.st,v 1.4 1994-11-17 14:46:56 claus Exp $
'!
!MemoryMonitor class methodsFor:'documentation'!
@@ -44,7 +45,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/Attic/MemMonitor.st,v 1.3 1994-10-28 03:30:33 claus Exp $
+$Header: /cvs/stx/stx/libtool/Attic/MemMonitor.st,v 1.4 1994-11-17 14:46:56 claus Exp $
"
!
@@ -61,22 +62,30 @@
new current newSpace in use
- free the first number shows free space in (fragmented) free lists
- the second shows the compact free area above the used oldSpace
+ frl free space in (fragmented) free lists
+ fre compact free area above the used oldSpace
old current oldSpace in use
- max, extreme values of 'all' since the monitor started
- min
+ max, extreme values of 'tot' since the monitor started
+ min (can be reset by typing 'r' in the view)
t tenure threshold
I incremental GC state
+ % percentage of live objects in newSpace after last scavenge
+ (i.e. this is the garbage vs. living objects ratio of
+ newSpace objects after the last scavenge)
+
the graphic shows:
yellow newSpace used
green free memory in freeLists
white oldSpace used
+
+
+ the popupMenu offers GC functions; keyboard options are:
+ 'f' -> faster; 's' -> slower; 'r' -> reset min/max
"
! !
@@ -84,25 +93,18 @@
defaultExtent
^ (200 @ 200)
-! !
-
-!MemoryMonitor class methodsFor:'startup'!
+!
-open
- |m|
-
- m := self new.
+defaultLabel
+ ^ 'Memory Monitor'
+!
- m label:'Memory Monitor'.
- m icon:(Form fromFile:'Monitor.icon' resolution:100).
- m minExtent:(100 @ 100).
+defaultIcon
+ |i|
- m open.
- ^ m
-
- "
- MemoryMonitor open
- "
+ i := Image fromFile:'bitmaps/monitor.icon'.
+ i notNil ifTrue:[^ i].
+ ^ super defaultIcon
! !
!MemoryMonitor methodsFor:'drawing'!
@@ -117,26 +119,26 @@
redrawX:x y:y width:w height:h
"redraw data"
- |total oldSpaceUsed newSpaceUsed freeMem lx scale s startIdx endIdx|
+ |total oldSpaceUsed newSpaceUsed freeMem lx s startIdx endIdx
+ right|
shown ifFalse:[^ self].
- (x + w - 1) > org ifTrue:[
+ right := x + w - 1.
+ right >= org ifTrue:[
lx := x.
lx < org ifTrue:[
lx := org
].
- scale := height asFloat / (maxTotal + 100000).
-
total := ObjectMemory oldSpaceSize + ObjectMemory newSpaceSize.
- startIdx := (x-org+1).
+ startIdx := (lx-org+1).
startIdx < 1 ifTrue:[
startIdx := 1
].
- endIdx := (x + w - 1)-org+1.
+ endIdx := right-org+1.
endIdx >= updateIndex ifTrue:[
endIdx := updateIndex-1.
].
@@ -152,8 +154,7 @@
total:total
old:oldSpaceUsed
new:newSpaceUsed
- free:freeMem
- scale:scale.
+ free:freeMem.
].
lx := lx + 1
]
@@ -163,28 +164,16 @@
prevFree := prevFree2 := prevOld := prevTotal := nil.
self updateNumbers.
-
- self paint:White on:Black.
- s := 'max ' , ((maxTotal // 1024) printStringRightAdjustLen:5) , 'k '.
- self displayOpaqueString:s x:0 y:font ascent.
-
- s := 'min ' , ((minTotal // 1024) printStringRightAdjustLen:5) , 'k '.
- self displayOpaqueString:s x:0 y:(height - font descent).
-
]
!
-updateLineX:x total:total old:oldSpaceUsed new:newSpaceUsed free:freeMem scale:scale
+updateLineX:x total:total old:oldSpaceUsed new:newSpaceUsed free:freeMem
|hNew hOld hFree y1 y2|
hNew := (newSpaceUsed * scale) asInteger.
- hOld := (oldSpaceUsed * scale) asInteger // 2.
+ hOld := (oldSpaceUsed * scale) // 2.
hFree := (freeMem * scale) asInteger.
-"/ self paint:Black.
-"/ self displayLineFromX:x y:0 toX:x y:height-1.
-
-
y1 := height - 1.
y2 := y1 - hOld.
self paint:oldColor.
@@ -214,8 +203,7 @@
"
|oldSpaceSize newSpaceSize memUsed oldMemUsed newMemUsed freeMem free2
- x y
- half scaleChange s thisStringLen scale fontHeight total|
+ x y half s thisStringLen fontHeight total n|
oldMemUsed := ObjectMemory oldSpaceUsed.
newMemUsed := ObjectMemory newSpaceUsed.
@@ -227,13 +215,6 @@
total := oldSpaceSize + newSpaceSize.
free2 := oldSpaceSize - oldMemUsed.
- ((total - freeMem) < minTotal) ifTrue:[
- minTotal := total - freeMem.
- ].
- (total > maxTotal) ifTrue:[
- maxTotal := total.
- ].
-
self paint:White on:Black.
fontHeight := font height + font descent.
@@ -242,8 +223,22 @@
y := half - (fontHeight * 3).
total ~~ prevTotal ifTrue:[
+ ((total - freeMem) < minTotal) ifTrue:[
+ minTotal := total - freeMem.
+ ].
+ (total > maxTotal) ifTrue:[
+ maxTotal := total.
+ ].
+
+ s := 'max ' , ((maxTotal // 1024) printStringRightAdjustLen:5) , 'k '.
+ self displayOpaqueString:s x:0 y:font ascent.
+
+ s := 'min ' , ((minTotal // 1024) printStringRightAdjustLen:5) , 'k '.
+ self displayOpaqueString:s x:0 y:(height - font descent).
+
s := 'tot ' , ((total // 1024) printStringRightAdjustLen:5) , 'k '.
self displayOpaqueString:s x:0 y:y.
+
prevTotal := total.
].
@@ -259,7 +254,7 @@
y := y + fontHeight.
freeMem ~~ prevFree ifTrue:[
self paint:freeColor.
- s := 'free' , ((freeMem // 1024) printStringRightAdjustLen:5) , 'k '.
+ s := 'frl ' , ((freeMem // 1024) printStringRightAdjustLen:5) , 'k '.
self displayOpaqueString:s x:0 y:y.
prevFree := freeMem.
].
@@ -267,7 +262,7 @@
y := y + fontHeight.
free2 ~~ prevFree2 ifTrue:[
self paint:freeColor.
- s := ' ' , ((free2 // 1024) printStringRightAdjustLen:5) , 'k '.
+ s := 'fre ' , ((free2 // 1024) printStringRightAdjustLen:5) , 'k '.
self displayOpaqueString:s x:0 y:y.
prevFree2 := free2.
].
@@ -295,13 +290,18 @@
"/ self displayOpaqueString:'single' x:0 y:(half + (fontHeight*4)).
"/ ].
+ y := y + fontHeight.
+ n := ObjectMemory lastScavangeReclamation / ObjectMemory newSpaceSize * 100.0.
+ n := 100 - n asInteger.
+ s := (n printStringRightAdjustLen:2) , '%'.
+ self displayOpaqueString:s x:0 y:y.
!
updateDisplay
"update picture; trigger next update"
|total oldSpaceUsed newSpaceUsed freeMem
- gWidth shift scaleChange scale margin|
+ gWidth shift scaleChange margin mustWait|
shown ifTrue:[
oldSpaceUsed := ObjectMemory oldSpaceUsed.
@@ -310,7 +310,7 @@
total := oldSpaceUsed + newSpaceUsed.
scaleChange := false.
-
+
((total - freeMem) < minTotal) ifTrue:[
minTotal := total - freeMem.
scaleChange := true
@@ -326,12 +326,14 @@
updateIndex := updateIndex + 1.
scaleChange ifTrue:[
+ scale := height asFloat / (maxTotal + 100000).
self redraw
].
gWidth := width - org.
margin := 1.
+ mustWait := false.
((updateIndex-1) >= (gWidth - margin)) ifTrue:[
"on slow displays, use:"
"/ shift := gWidth // 4.
@@ -354,18 +356,19 @@
height:height.
self clearRectangleX:(width - margin - shift) y:0
width:shift height:height.
- self waitForExpose.
+ mustWait := true.
].
- scale := height asFloat / (maxTotal + 100000).
- self updateLineX:(updateIndex - 1 + org)
+ self updateLineX:(updateIndex - 1 + org - 1)
total:total
old:oldSpaceUsed
new:newSpaceUsed
- free:freeMem
- scale:scale.
+ free:freeMem.
self updateNumbers.
+ mustWait ifTrue:[
+ self waitForExpose.
+ ]
].
@@ -391,10 +394,18 @@
keyPress:key x:x y:y
key == $f ifTrue:[
+ "faster"
updateInterval := updateInterval / 2
].
key == $s ifTrue:[
+ "slower"
updateInterval := updateInterval * 2
+ ].
+ key == $r ifTrue:[
+ "reset max"
+ maxTotal := prevTotal.
+ scale := height asFloat / (maxTotal + 100000).
+ self redraw.
]
!
@@ -429,6 +440,8 @@
oldData := no.
freeData := nf.
+ scale := height asFloat / (maxTotal + 100000).
+ self clear.
self redraw
! !
@@ -469,7 +482,8 @@
freeData := Array new:1000.
updateIndex := 1.
- org := font widthOf:'used:9999k '.
+ org := font widthOf:'max 99999k'.
+ level := 0.
maxTotal := minTotal := ObjectMemory oldSpaceSize + ObjectMemory newSpaceSize.
@@ -490,5 +504,37 @@
"
MemoryMonitor open
"
+!
+
+initializeMiddleButtonMenu
+ self middleButtonMenu:
+ (PopUpMenu labels:(resources array:#(
+ 'collect Garbage'
+ 'collect Garbage & compress'
+ '-'
+ 'background collect'
+ ))
+ selectors:#(
+ garbageCollect
+ compressingGarbageCollect
+ nil
+ backgroundCollect
+ )
+ receiver:self
+ for:self)
! !
+!MemoryMonitor methodsFor:'menu functions'!
+
+garbageCollect
+ ObjectMemory markAndSweep
+!
+
+compressingGarbageCollect
+ ObjectMemory verboseGarbageCollect
+!
+
+backgroundCollect
+ [ObjectMemory incrementalGC] forkAt:4
+! !
+
--- a/MemUsageV.st Thu Nov 17 15:44:34 1994 +0100
+++ b/MemUsageV.st Thu Nov 17 15:47:59 1994 +0100
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/Attic/MemUsageV.st,v 1.3 1994-10-28 03:30:32 claus Exp $
+$Header: /cvs/stx/stx/libtool/Attic/MemUsageV.st,v 1.4 1994-11-17 14:46:57 claus Exp $
"
!
@@ -90,7 +90,88 @@
(className startsWith:'<') ifFalse:[
(className startsWith:'all') ifFalse:[
class := Smalltalk at:className asSymbol.
- class allInstances inspect
+ self withCursor:(Cursor questionMark) do:[
+ |insts|
+
+ insts := class allInstances.
+ insts size > 500 ifTrue:[
+ (self confirm:'there are ' , insts size printString , ' instances.\\Do you really want to see them all ?' withCRs)
+ ifFalse:[^ self]
+ ].
+ insts inspect
+ ]
+ ]
+ ]
+ ]
+!
+
+inspectOwners
+ |line className class|
+
+ line := list selectionValue.
+ (line notNil and:[line notEmpty]) ifTrue:[
+ className := line asCollectionOfWords first.
+ "
+ special kludge
+ "
+ (className startsWith:'<') ifFalse:[
+ (className startsWith:'all') ifFalse:[
+ class := Smalltalk at:className asSymbol.
+ self withCursor:(Cursor questionMark) do:[
+ |owners dict|
+
+ owners := (ObjectMemory whoReferencesInstancesOf:class).
+ owners isNil ifTrue:[
+ self information:'no owners found - next GC should remove it'.
+ ^ self
+ ].
+ owners := owners asOrderedCollection.
+ owners size > 500 ifTrue:[
+ (self confirm:'there are ' , owners size printString , ' owners.\\Do you really want to see them all ?' withCRs)
+ ifFalse:[^ self]
+ ].
+ dict := IdentityDictionary new.
+ owners do:[:owner |
+ |set names oClass s|
+
+ "
+ skip weakArrays ... (they dont count)
+ "
+ (owner isMemberOf:WeakArray) ifFalse:[
+ set := Set new.
+ names := owner class allInstVarNames.
+ oClass := owner class.
+ 1 to:oClass instSize do:[:i |
+ ((owner instVarAt:i) isMemberOf:class) ifTrue:[
+ set add:(names at:i).
+ ].
+ ].
+ oClass isVariable ifTrue:[
+ oClass isPointers ifTrue:[
+ 1 to:owner basicSize do:[:i |
+ ((owner basicAt:i) isMemberOf:class) ifTrue:[
+ set add:i
+ ]
+ ]
+ ]
+ ].
+ "
+ put a describing string into the dictionary
+ "
+ s := 'references in: '.
+ set do:[:name |
+ name isString ifTrue:[
+ s := s , name , ' '
+ ] ifFalse:[
+ s := s , '[' , name printString , '] '
+ ]
+ ].
+ dict at:owner put:s.
+"/ dict at:owner put:set
+ ]
+ ].
+ dict inspect
+ ]
]
]
]
@@ -114,14 +195,15 @@
updateDisplay
"update the displayed list"
- |classNames counts sumSizes percents avgSizes rawData l line allMemory overAllCount overAllAvgSize|
-
windowGroup withCursor:Cursor wait do:[
+ |classNames counts sumSizes percents avgSizes rawData
+ l line allMemory overAllCount overAllAvgSize|
rawData := info asSortedCollection:sortBlock.
"/ "this avoids getting a sorted collection in the collect: below"
"/ rawData := rawData asArray.
+"/ collect: has been fixed ...
classNames := rawData collect:[:i |
|cls|
@@ -141,11 +223,13 @@
counts := rawData collect:[:i | (i at:2) ].
sumSizes := rawData collect:[:i | (i at:3) ].
allMemory := ObjectMemory bytesUsed.
- percents := sumSizes collect:[:sz | (sz / allMemory * 100 * 10) rounded / 10.0].
+ percents := sumSizes collect:[:sz | (sz asFloat / allMemory * 1000) rounded / 10.0].
avgSizes := (1 to:sumSizes size) collect:[:i | (((sumSizes at:i) / (counts at:i)) * 10) rounded / 10.0].
l := OrderedCollection new.
1 to:classNames size do:[:i |
+ |line|
+
line := (classNames at:i) printStringPaddedTo:30 with:Character space.
line := line , ((counts at:i) printStringLeftPaddedTo:10).
line := line , ((avgSizes at:i) printStringLeftPaddedTo:10).
@@ -173,11 +257,8 @@
updateInfo
"scan all memory and collect the information"
- |myProcess myPriority|
-
windowGroup withCursor:Cursor questionMark do:[
-
- info := IdentityDictionary new:600.
+ |myProcess myPriority|
"find all objects, collect stuff in info"
@@ -188,6 +269,8 @@
myPriority := myProcess priority.
myProcess priority:(Processor userBackgroundPriority).
+ info := IdentityDictionary new:600.
+
[
ObjectMemory allObjectsDo:[:o |
|i class|
@@ -201,12 +284,11 @@
] ifFalse:[
class := o class.
].
- (info includesKey:class) ifFalse:[
- info at:class put:(Array with:class
- with:1
- with:(ObjectMemory sizeOf:o))
- ] ifTrue:[
- i := info at:class.
+ i := info at:class ifAbsent:[].
+ i isNil ifTrue:[
+ i := Array with:class with:1 with:(ObjectMemory sizeOf:o).
+ info at:class put:i.
+ ] ifFalse:[
i at:2 put:((i at:2) + 1).
i at:3 put:((i at:3) + (ObjectMemory sizeOf:o))
]
@@ -238,10 +320,13 @@
helpView := ScrollableView for:SelectionInListView in:self.
helpView origin:(0.0 @ l height) corner:1.0 @ 1.0.
- l origin:(helpView scrollBar width @ 0.0).
+ list := helpView scrolledView.
+
+ l origin:(list originRelativeTo:self) x @ 0.0.
- list := helpView scrolledView.
list font:(self font).
+ l font:(self font).
+
list middleButtonMenu:(PopUpMenu
labels:(
resources array:#(
@@ -250,6 +335,7 @@
'sort by memory usage'
'-'
'inspect instances'
+ 'owners'
'-'
'update'
))
@@ -259,12 +345,15 @@
sortByMemoryUsage
nil
inspectInstances
+ inspectOwners
nil
update
)
receiver:self
for:list).
- "MemoryUsageView start"
+ "
+ MemoryUsageView open
+ "
! !
--- a/MemoryMonitor.st Thu Nov 17 15:44:34 1994 +0100
+++ b/MemoryMonitor.st Thu Nov 17 15:47:59 1994 +0100
@@ -12,8 +12,9 @@
StandardSystemView subclass:#MemoryMonitor
instanceVariableNames:'updateInterval updateBlock myProcess oldData newData
- freeData updateIndex org maxTotal minTotal newColor dX
- freeColor oldColor prevTotal prevFree prevFree2 prevOld'
+ freeData updateIndex org maxTotal minTotal dX
+ newColor freeColor oldColor
+ prevTotal prevFree prevFree2 prevOld scale'
classVariableNames:''
poolDictionaries:''
category:'Interface-Tools'
@@ -23,7 +24,7 @@
COPYRIGHT (c) 1991 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libtool/MemoryMonitor.st,v 1.3 1994-10-28 03:30:33 claus Exp $
+$Header: /cvs/stx/stx/libtool/MemoryMonitor.st,v 1.4 1994-11-17 14:46:56 claus Exp $
'!
!MemoryMonitor class methodsFor:'documentation'!
@@ -44,7 +45,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/MemoryMonitor.st,v 1.3 1994-10-28 03:30:33 claus Exp $
+$Header: /cvs/stx/stx/libtool/MemoryMonitor.st,v 1.4 1994-11-17 14:46:56 claus Exp $
"
!
@@ -61,22 +62,30 @@
new current newSpace in use
- free the first number shows free space in (fragmented) free lists
- the second shows the compact free area above the used oldSpace
+ frl free space in (fragmented) free lists
+ fre compact free area above the used oldSpace
old current oldSpace in use
- max, extreme values of 'all' since the monitor started
- min
+ max, extreme values of 'tot' since the monitor started
+ min (can be reset by typing 'r' in the view)
t tenure threshold
I incremental GC state
+ % percentage of live objects in newSpace after last scavenge
+ (i.e. this is the garbage vs. living objects ratio of
+ newSpace objects after the last scavenge)
+
the graphic shows:
yellow newSpace used
green free memory in freeLists
white oldSpace used
+
+
+ the popupMenu offers GC functions; keyboard options are:
+ 'f' -> faster; 's' -> slower; 'r' -> reset min/max
"
! !
@@ -84,25 +93,18 @@
defaultExtent
^ (200 @ 200)
-! !
-
-!MemoryMonitor class methodsFor:'startup'!
+!
-open
- |m|
-
- m := self new.
+defaultLabel
+ ^ 'Memory Monitor'
+!
- m label:'Memory Monitor'.
- m icon:(Form fromFile:'Monitor.icon' resolution:100).
- m minExtent:(100 @ 100).
+defaultIcon
+ |i|
- m open.
- ^ m
-
- "
- MemoryMonitor open
- "
+ i := Image fromFile:'bitmaps/monitor.icon'.
+ i notNil ifTrue:[^ i].
+ ^ super defaultIcon
! !
!MemoryMonitor methodsFor:'drawing'!
@@ -117,26 +119,26 @@
redrawX:x y:y width:w height:h
"redraw data"
- |total oldSpaceUsed newSpaceUsed freeMem lx scale s startIdx endIdx|
+ |total oldSpaceUsed newSpaceUsed freeMem lx s startIdx endIdx
+ right|
shown ifFalse:[^ self].
- (x + w - 1) > org ifTrue:[
+ right := x + w - 1.
+ right >= org ifTrue:[
lx := x.
lx < org ifTrue:[
lx := org
].
- scale := height asFloat / (maxTotal + 100000).
-
total := ObjectMemory oldSpaceSize + ObjectMemory newSpaceSize.
- startIdx := (x-org+1).
+ startIdx := (lx-org+1).
startIdx < 1 ifTrue:[
startIdx := 1
].
- endIdx := (x + w - 1)-org+1.
+ endIdx := right-org+1.
endIdx >= updateIndex ifTrue:[
endIdx := updateIndex-1.
].
@@ -152,8 +154,7 @@
total:total
old:oldSpaceUsed
new:newSpaceUsed
- free:freeMem
- scale:scale.
+ free:freeMem.
].
lx := lx + 1
]
@@ -163,28 +164,16 @@
prevFree := prevFree2 := prevOld := prevTotal := nil.
self updateNumbers.
-
- self paint:White on:Black.
- s := 'max ' , ((maxTotal // 1024) printStringRightAdjustLen:5) , 'k '.
- self displayOpaqueString:s x:0 y:font ascent.
-
- s := 'min ' , ((minTotal // 1024) printStringRightAdjustLen:5) , 'k '.
- self displayOpaqueString:s x:0 y:(height - font descent).
-
]
!
-updateLineX:x total:total old:oldSpaceUsed new:newSpaceUsed free:freeMem scale:scale
+updateLineX:x total:total old:oldSpaceUsed new:newSpaceUsed free:freeMem
|hNew hOld hFree y1 y2|
hNew := (newSpaceUsed * scale) asInteger.
- hOld := (oldSpaceUsed * scale) asInteger // 2.
+ hOld := (oldSpaceUsed * scale) // 2.
hFree := (freeMem * scale) asInteger.
-"/ self paint:Black.
-"/ self displayLineFromX:x y:0 toX:x y:height-1.
-
-
y1 := height - 1.
y2 := y1 - hOld.
self paint:oldColor.
@@ -214,8 +203,7 @@
"
|oldSpaceSize newSpaceSize memUsed oldMemUsed newMemUsed freeMem free2
- x y
- half scaleChange s thisStringLen scale fontHeight total|
+ x y half s thisStringLen fontHeight total n|
oldMemUsed := ObjectMemory oldSpaceUsed.
newMemUsed := ObjectMemory newSpaceUsed.
@@ -227,13 +215,6 @@
total := oldSpaceSize + newSpaceSize.
free2 := oldSpaceSize - oldMemUsed.
- ((total - freeMem) < minTotal) ifTrue:[
- minTotal := total - freeMem.
- ].
- (total > maxTotal) ifTrue:[
- maxTotal := total.
- ].
-
self paint:White on:Black.
fontHeight := font height + font descent.
@@ -242,8 +223,22 @@
y := half - (fontHeight * 3).
total ~~ prevTotal ifTrue:[
+ ((total - freeMem) < minTotal) ifTrue:[
+ minTotal := total - freeMem.
+ ].
+ (total > maxTotal) ifTrue:[
+ maxTotal := total.
+ ].
+
+ s := 'max ' , ((maxTotal // 1024) printStringRightAdjustLen:5) , 'k '.
+ self displayOpaqueString:s x:0 y:font ascent.
+
+ s := 'min ' , ((minTotal // 1024) printStringRightAdjustLen:5) , 'k '.
+ self displayOpaqueString:s x:0 y:(height - font descent).
+
s := 'tot ' , ((total // 1024) printStringRightAdjustLen:5) , 'k '.
self displayOpaqueString:s x:0 y:y.
+
prevTotal := total.
].
@@ -259,7 +254,7 @@
y := y + fontHeight.
freeMem ~~ prevFree ifTrue:[
self paint:freeColor.
- s := 'free' , ((freeMem // 1024) printStringRightAdjustLen:5) , 'k '.
+ s := 'frl ' , ((freeMem // 1024) printStringRightAdjustLen:5) , 'k '.
self displayOpaqueString:s x:0 y:y.
prevFree := freeMem.
].
@@ -267,7 +262,7 @@
y := y + fontHeight.
free2 ~~ prevFree2 ifTrue:[
self paint:freeColor.
- s := ' ' , ((free2 // 1024) printStringRightAdjustLen:5) , 'k '.
+ s := 'fre ' , ((free2 // 1024) printStringRightAdjustLen:5) , 'k '.
self displayOpaqueString:s x:0 y:y.
prevFree2 := free2.
].
@@ -295,13 +290,18 @@
"/ self displayOpaqueString:'single' x:0 y:(half + (fontHeight*4)).
"/ ].
+ y := y + fontHeight.
+ n := ObjectMemory lastScavangeReclamation / ObjectMemory newSpaceSize * 100.0.
+ n := 100 - n asInteger.
+ s := (n printStringRightAdjustLen:2) , '%'.
+ self displayOpaqueString:s x:0 y:y.
!
updateDisplay
"update picture; trigger next update"
|total oldSpaceUsed newSpaceUsed freeMem
- gWidth shift scaleChange scale margin|
+ gWidth shift scaleChange margin mustWait|
shown ifTrue:[
oldSpaceUsed := ObjectMemory oldSpaceUsed.
@@ -310,7 +310,7 @@
total := oldSpaceUsed + newSpaceUsed.
scaleChange := false.
-
+
((total - freeMem) < minTotal) ifTrue:[
minTotal := total - freeMem.
scaleChange := true
@@ -326,12 +326,14 @@
updateIndex := updateIndex + 1.
scaleChange ifTrue:[
+ scale := height asFloat / (maxTotal + 100000).
self redraw
].
gWidth := width - org.
margin := 1.
+ mustWait := false.
((updateIndex-1) >= (gWidth - margin)) ifTrue:[
"on slow displays, use:"
"/ shift := gWidth // 4.
@@ -354,18 +356,19 @@
height:height.
self clearRectangleX:(width - margin - shift) y:0
width:shift height:height.
- self waitForExpose.
+ mustWait := true.
].
- scale := height asFloat / (maxTotal + 100000).
- self updateLineX:(updateIndex - 1 + org)
+ self updateLineX:(updateIndex - 1 + org - 1)
total:total
old:oldSpaceUsed
new:newSpaceUsed
- free:freeMem
- scale:scale.
+ free:freeMem.
self updateNumbers.
+ mustWait ifTrue:[
+ self waitForExpose.
+ ]
].
@@ -391,10 +394,18 @@
keyPress:key x:x y:y
key == $f ifTrue:[
+ "faster"
updateInterval := updateInterval / 2
].
key == $s ifTrue:[
+ "slower"
updateInterval := updateInterval * 2
+ ].
+ key == $r ifTrue:[
+ "reset max"
+ maxTotal := prevTotal.
+ scale := height asFloat / (maxTotal + 100000).
+ self redraw.
]
!
@@ -429,6 +440,8 @@
oldData := no.
freeData := nf.
+ scale := height asFloat / (maxTotal + 100000).
+ self clear.
self redraw
! !
@@ -469,7 +482,8 @@
freeData := Array new:1000.
updateIndex := 1.
- org := font widthOf:'used:9999k '.
+ org := font widthOf:'max 99999k'.
+ level := 0.
maxTotal := minTotal := ObjectMemory oldSpaceSize + ObjectMemory newSpaceSize.
@@ -490,5 +504,37 @@
"
MemoryMonitor open
"
+!
+
+initializeMiddleButtonMenu
+ self middleButtonMenu:
+ (PopUpMenu labels:(resources array:#(
+ 'collect Garbage'
+ 'collect Garbage & compress'
+ '-'
+ 'background collect'
+ ))
+ selectors:#(
+ garbageCollect
+ compressingGarbageCollect
+ nil
+ backgroundCollect
+ )
+ receiver:self
+ for:self)
! !
+!MemoryMonitor methodsFor:'menu functions'!
+
+garbageCollect
+ ObjectMemory markAndSweep
+!
+
+compressingGarbageCollect
+ ObjectMemory verboseGarbageCollect
+!
+
+backgroundCollect
+ [ObjectMemory incrementalGC] forkAt:4
+! !
+
--- a/MemoryUsageView.st Thu Nov 17 15:44:34 1994 +0100
+++ b/MemoryUsageView.st Thu Nov 17 15:47:59 1994 +0100
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libtool/MemoryUsageView.st,v 1.3 1994-10-28 03:30:32 claus Exp $
+$Header: /cvs/stx/stx/libtool/MemoryUsageView.st,v 1.4 1994-11-17 14:46:57 claus Exp $
"
!
@@ -90,7 +90,88 @@
(className startsWith:'<') ifFalse:[
(className startsWith:'all') ifFalse:[
class := Smalltalk at:className asSymbol.
- class allInstances inspect
+ self withCursor:(Cursor questionMark) do:[
+ |insts|
+
+ insts := class allInstances.
+ insts size > 500 ifTrue:[
+ (self confirm:'there are ' , insts size printString , ' instances.\\Do you really want to see them all ?' withCRs)
+ ifFalse:[^ self]
+ ].
+ insts inspect
+ ]
+ ]
+ ]
+ ]
+!
+
+inspectOwners
+ |line className class|
+
+ line := list selectionValue.
+ (line notNil and:[line notEmpty]) ifTrue:[
+ className := line asCollectionOfWords first.
+ "
+ special kludge
+ "
+ (className startsWith:'<') ifFalse:[
+ (className startsWith:'all') ifFalse:[
+ class := Smalltalk at:className asSymbol.
+ self withCursor:(Cursor questionMark) do:[
+ |owners dict|
+
+ owners := (ObjectMemory whoReferencesInstancesOf:class).
+ owners isNil ifTrue:[
+ self information:'no owners found - next GC should remove it'.
+ ^ self
+ ].
+ owners := owners asOrderedCollection.
+ owners size > 500 ifTrue:[
+ (self confirm:'there are ' , owners size printString , ' owners.\\Do you really want to see them all ?' withCRs)
+ ifFalse:[^ self]
+ ].
+ dict := IdentityDictionary new.
+ owners do:[:owner |
+ |set names oClass s|
+
+ "
+ skip weakArrays ... (they dont count)
+ "
+ (owner isMemberOf:WeakArray) ifFalse:[
+ set := Set new.
+ names := owner class allInstVarNames.
+ oClass := owner class.
+ 1 to:oClass instSize do:[:i |
+ ((owner instVarAt:i) isMemberOf:class) ifTrue:[
+ set add:(names at:i).
+ ].
+ ].
+ oClass isVariable ifTrue:[
+ oClass isPointers ifTrue:[
+ 1 to:owner basicSize do:[:i |
+ ((owner basicAt:i) isMemberOf:class) ifTrue:[
+ set add:i
+ ]
+ ]
+ ]
+ ].
+ "
+ put a describing string into the dictionary
+ "
+ s := 'references in: '.
+ set do:[:name |
+ name isString ifTrue:[
+ s := s , name , ' '
+ ] ifFalse:[
+ s := s , '[' , name printString , '] '
+ ]
+ ].
+ dict at:owner put:s.
+"/ dict at:owner put:set
+ ]
+ ].
+ dict inspect
+ ]
]
]
]
@@ -114,14 +195,15 @@
updateDisplay
"update the displayed list"
- |classNames counts sumSizes percents avgSizes rawData l line allMemory overAllCount overAllAvgSize|
-
windowGroup withCursor:Cursor wait do:[
+ |classNames counts sumSizes percents avgSizes rawData
+ l line allMemory overAllCount overAllAvgSize|
rawData := info asSortedCollection:sortBlock.
"/ "this avoids getting a sorted collection in the collect: below"
"/ rawData := rawData asArray.
+"/ collect: has been fixed ...
classNames := rawData collect:[:i |
|cls|
@@ -141,11 +223,13 @@
counts := rawData collect:[:i | (i at:2) ].
sumSizes := rawData collect:[:i | (i at:3) ].
allMemory := ObjectMemory bytesUsed.
- percents := sumSizes collect:[:sz | (sz / allMemory * 100 * 10) rounded / 10.0].
+ percents := sumSizes collect:[:sz | (sz asFloat / allMemory * 1000) rounded / 10.0].
avgSizes := (1 to:sumSizes size) collect:[:i | (((sumSizes at:i) / (counts at:i)) * 10) rounded / 10.0].
l := OrderedCollection new.
1 to:classNames size do:[:i |
+ |line|
+
line := (classNames at:i) printStringPaddedTo:30 with:Character space.
line := line , ((counts at:i) printStringLeftPaddedTo:10).
line := line , ((avgSizes at:i) printStringLeftPaddedTo:10).
@@ -173,11 +257,8 @@
updateInfo
"scan all memory and collect the information"
- |myProcess myPriority|
-
windowGroup withCursor:Cursor questionMark do:[
-
- info := IdentityDictionary new:600.
+ |myProcess myPriority|
"find all objects, collect stuff in info"
@@ -188,6 +269,8 @@
myPriority := myProcess priority.
myProcess priority:(Processor userBackgroundPriority).
+ info := IdentityDictionary new:600.
+
[
ObjectMemory allObjectsDo:[:o |
|i class|
@@ -201,12 +284,11 @@
] ifFalse:[
class := o class.
].
- (info includesKey:class) ifFalse:[
- info at:class put:(Array with:class
- with:1
- with:(ObjectMemory sizeOf:o))
- ] ifTrue:[
- i := info at:class.
+ i := info at:class ifAbsent:[].
+ i isNil ifTrue:[
+ i := Array with:class with:1 with:(ObjectMemory sizeOf:o).
+ info at:class put:i.
+ ] ifFalse:[
i at:2 put:((i at:2) + 1).
i at:3 put:((i at:3) + (ObjectMemory sizeOf:o))
]
@@ -238,10 +320,13 @@
helpView := ScrollableView for:SelectionInListView in:self.
helpView origin:(0.0 @ l height) corner:1.0 @ 1.0.
- l origin:(helpView scrollBar width @ 0.0).
+ list := helpView scrolledView.
+
+ l origin:(list originRelativeTo:self) x @ 0.0.
- list := helpView scrolledView.
list font:(self font).
+ l font:(self font).
+
list middleButtonMenu:(PopUpMenu
labels:(
resources array:#(
@@ -250,6 +335,7 @@
'sort by memory usage'
'-'
'inspect instances'
+ 'owners'
'-'
'update'
))
@@ -259,12 +345,15 @@
sortByMemoryUsage
nil
inspectInstances
+ inspectOwners
nil
update
)
receiver:self
for:list).
- "MemoryUsageView start"
+ "
+ MemoryUsageView open
+ "
! !
--- a/OCInspView.st Thu Nov 17 15:44:34 1994 +0100
+++ b/OCInspView.st Thu Nov 17 15:47:59 1994 +0100
@@ -1,8 +1,6 @@
-"{ Package: 'Programming Tools' }"
-
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -13,10 +11,10 @@
"
InspectorView subclass:#OrderedCollectionInspectorView
- instanceVariableNames:''
- classVariableNames:''
- poolDictionaries:''
- category:'Interface-Inspector'
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Interface-Inspector'
!
!OrderedCollectionInspectorView methodsFor:'user interaction'!
@@ -28,11 +26,11 @@
workspace contents:nil.
lineNr == 1 ifTrue:[
- "selecting self also does a re-set, this allows updating the list"
- self inspect:inspectedObject.
- val := inspectedObject
+ "selecting self also does a re-set, this allows updating the list"
+ self inspect:inspectedObject.
+ val := inspectedObject
] ifFalse:[
- val := inspectedObject at:(lineNr - 1)
+ val := inspectedObject at:(lineNr - 1)
].
string := val displayString.
workspace paste:string.
@@ -43,16 +41,16 @@
|value|
value := Compiler evaluate:theText
- receiver:inspectedObject
- notifying:workspace.
+ receiver:inspectedObject
+ notifying:workspace.
inspectedValues isNil ifTrue:[
- selectedLine notNil ifTrue:[
- selectedLine == 1 ifFalse:[
- inspectedObject at:selectedLine - 1 put:value.
- inspectedObject changed
- ]
- ]
+ selectedLine notNil ifTrue:[
+ selectedLine == 1 ifFalse:[
+ inspectedObject at:selectedLine - 1 put:value.
+ inspectedObject changed
+ ]
+ ]
].
!
@@ -60,13 +58,13 @@
"user selected inspect-menu entry"
selectedLine notNil ifTrue:[
- inspectedValues isNil ifTrue:[
- (selectedLine == 1) ifTrue:[
- inspectedObject inspect
- ] ifFalse:[
- (inspectedObject at:selectedLine - 1) inspect
- ]
- ].
+ inspectedValues isNil ifTrue:[
+ (selectedLine == 1) ifTrue:[
+ inspectedObject inspect
+ ] ifFalse:[
+ (inspectedObject at:selectedLine - 1) inspect
+ ]
+ ].
]
! !
@@ -81,18 +79,18 @@
aList add:'self'.
n := inspectedObject size.
(n > nShown) ifTrue:[
- n := nShown.
- cut := true.
- listView setMiddleButtonMenu:menu2.
+ n := nShown.
+ cut := true.
+ listView setMiddleButtonMenu:menu2.
] ifFalse:[
- cut := false.
- listView setMiddleButtonMenu:menu1.
+ cut := false.
+ listView setMiddleButtonMenu:menu1.
].
1 to:n do:[:index |
- aList add:(index printString)
+ aList add:(index printString)
].
cut ifTrue:[
- aList add:' ... '
+ aList add:' ... '
].
^ aList
! !
--- a/OldLauncher.st Thu Nov 17 15:44:34 1994 +0100
+++ b/OldLauncher.st Thu Nov 17 15:47:59 1994 +0100
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1991 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libtool/OldLauncher.st,v 1.16 1994-10-10 03:15:50 claus Exp $
+$Header: /cvs/stx/stx/libtool/OldLauncher.st,v 1.17 1994-11-17 14:46:53 claus Exp $
'!
!Launcher class methodsFor:'documentation'!
@@ -42,25 +42,36 @@
version
"
-$Header: /cvs/stx/stx/libtool/OldLauncher.st,v 1.16 1994-10-10 03:15:50 claus Exp $
+$Header: /cvs/stx/stx/libtool/OldLauncher.st,v 1.17 1994-11-17 14:46:53 claus Exp $
"
!
documentation
"
- Launcher allows startup of smalltalk applications
+ Launcher allows startup of smalltalk applications.
+
+ If you like this kind of permanent menu for your applications,
+ create a subclass of this, and redefine #initializeLogo and
+ #initializeMenu (thats why those two have been implemented as
+ separate methods).
+
+ If you like to add more entries to the menu (or a submenu),
+ add an entry to the menu (in #initializeMenu) and create a corresponding
+ action method, to be called from the menu.
+ Then start a new Launcher with:
+ Launcher open
+ start a new one, BEFORE you close the old one - otherwise you may be
+ left without any windows on the screen ...
+
+ If you want to change the launchers menu WITHOUT closing the active one,
+ use #addSelector... (see MenuView).
"
! !
-!Launcher class methodsFor:'instance creation'!
+!Launcher class methodsFor:'defaults '!
-new
- ^ super
- extent:(100 @ 100)
- label:'smallTalk'
- icon:(Form fromFile:'SmalltalkX.xbm' resolution:100)
-
- "Launcher start"
+defaultLabel
+ ^ 'smallTalk'
! !
!Launcher methodsFor:'initialize / release'!
@@ -71,6 +82,7 @@
self initializeMenu.
self initializeLogo.
+ myMenu level:0.
"/ myMenu borderWidth:0.
myMenu origin:(0.0 @ logoLabel height).
"/ myMenu font:(self font).
@@ -489,7 +501,7 @@
since if you close the last launcher, you might loose the possibility to
communicate with the system ..."
- (self confirm:(resources string:'close Launcher ?')) ifTrue:[
+ (self confirm:(resources string:'close ' , self class name , ' ?')) ifTrue:[
super destroy
]
!
@@ -556,6 +568,11 @@
!Launcher methodsFor:'events'!
saveAndTerminate
+ "
+ some windowManagers can send this, to shutDown an application
+ but let it save its state before, for restart. We are already
+ prepared for this ;-)"
+
ObjectMemory snapShotOn:name
! !
@@ -814,26 +831,7 @@
!
compressingGarbageCollect
- |nBytesBefore nReclaimed|
-
- nBytesBefore := ObjectMemory oldSpaceUsed.
- ObjectMemory garbageCollect.
- nReclaimed := nBytesBefore - ObjectMemory oldSpaceUsed.
- nReclaimed > 0 ifTrue:[
- Transcript show:'reclaimed '.
- nReclaimed > 1024 ifTrue:[
- nReclaimed > (1024 * 1024) ifTrue:[
- Transcript show:(nReclaimed // (1024 * 1024)) printString.
- Transcript showCr:' Mb.'
- ] ifFalse:[
- Transcript show:(nReclaimed // 1024) printString.
- Transcript showCr:' Kb.'
- ]
- ] ifFalse:[
- Transcript show:nReclaimed printString.
- Transcript showCr:' bytes.'
- ]
- ]
+ ObjectMemory verboseGarbageCollect
! !
!Launcher methodsFor:'project menu actions'!
--- a/OrderedCollectionInspectorView.st Thu Nov 17 15:44:34 1994 +0100
+++ b/OrderedCollectionInspectorView.st Thu Nov 17 15:47:59 1994 +0100
@@ -1,8 +1,6 @@
-"{ Package: 'Programming Tools' }"
-
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -13,10 +11,10 @@
"
InspectorView subclass:#OrderedCollectionInspectorView
- instanceVariableNames:''
- classVariableNames:''
- poolDictionaries:''
- category:'Interface-Inspector'
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Interface-Inspector'
!
!OrderedCollectionInspectorView methodsFor:'user interaction'!
@@ -28,11 +26,11 @@
workspace contents:nil.
lineNr == 1 ifTrue:[
- "selecting self also does a re-set, this allows updating the list"
- self inspect:inspectedObject.
- val := inspectedObject
+ "selecting self also does a re-set, this allows updating the list"
+ self inspect:inspectedObject.
+ val := inspectedObject
] ifFalse:[
- val := inspectedObject at:(lineNr - 1)
+ val := inspectedObject at:(lineNr - 1)
].
string := val displayString.
workspace paste:string.
@@ -43,16 +41,16 @@
|value|
value := Compiler evaluate:theText
- receiver:inspectedObject
- notifying:workspace.
+ receiver:inspectedObject
+ notifying:workspace.
inspectedValues isNil ifTrue:[
- selectedLine notNil ifTrue:[
- selectedLine == 1 ifFalse:[
- inspectedObject at:selectedLine - 1 put:value.
- inspectedObject changed
- ]
- ]
+ selectedLine notNil ifTrue:[
+ selectedLine == 1 ifFalse:[
+ inspectedObject at:selectedLine - 1 put:value.
+ inspectedObject changed
+ ]
+ ]
].
!
@@ -60,13 +58,13 @@
"user selected inspect-menu entry"
selectedLine notNil ifTrue:[
- inspectedValues isNil ifTrue:[
- (selectedLine == 1) ifTrue:[
- inspectedObject inspect
- ] ifFalse:[
- (inspectedObject at:selectedLine - 1) inspect
- ]
- ].
+ inspectedValues isNil ifTrue:[
+ (selectedLine == 1) ifTrue:[
+ inspectedObject inspect
+ ] ifFalse:[
+ (inspectedObject at:selectedLine - 1) inspect
+ ]
+ ].
]
! !
@@ -81,18 +79,18 @@
aList add:'self'.
n := inspectedObject size.
(n > nShown) ifTrue:[
- n := nShown.
- cut := true.
- listView setMiddleButtonMenu:menu2.
+ n := nShown.
+ cut := true.
+ listView setMiddleButtonMenu:menu2.
] ifFalse:[
- cut := false.
- listView setMiddleButtonMenu:menu1.
+ cut := false.
+ listView setMiddleButtonMenu:menu1.
].
1 to:n do:[:index |
- aList add:(index printString)
+ aList add:(index printString)
].
cut ifTrue:[
- aList add:' ... '
+ aList add:' ... '
].
^ aList
! !
--- a/ProcMonitor.st Thu Nov 17 15:44:34 1994 +0100
+++ b/ProcMonitor.st Thu Nov 17 15:47:59 1994 +0100
@@ -1,3 +1,15 @@
+"
+ COPYRIGHT (c) 1993 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
StandardSystemView subclass:#ProcessMonitor
instanceVariableNames:'listView processes listUpdateDelay updateDelay
updateBlock listUpdateBlock updateProcess hideDead
@@ -7,6 +19,54 @@
category:'Interface-Tools'
!
+!ProcessMonitor class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1993 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+!
+
+version
+"
+$Header: /cvs/stx/stx/libtool/Attic/ProcMonitor.st,v 1.4 1994-11-17 14:46:59 claus Exp $
+"
+!
+
+documentation
+"
+ This view shows smalltalks (light-weight) processes, and also offers
+ a popup menu for various useful operations on them.
+ Especially 'debug' is useful, to see what a process is currently
+ doing.
+ The information shown is:
+ id - the numeric id of the process
+ name - the name (if any) of the process
+ (the name has no semantic meaning; its for the processMonitor)
+ state - what is it doing;
+ wait - waiting on a semaphore
+ eventWait - waiting on a view-event semaphore
+ ioWait - waiting on an io-semaphore
+ timeWait - waiting for a time-semaphore
+ run - run, but currently not scheduled
+ active - really running
+ suspended - suspended; not waiting on a semaphore
+ light - not yet started (i.e. has no stack yet)
+
+ prio - the processes priority (1..30)
+ usedStack - the current stack use
+ totalStack - the stack currently allocated
+"
+! !
+
!ProcessMonitor class methodsFor:'startup'!
open
@@ -184,6 +244,8 @@
]
]
].
+ self updateStatus.
+ self updateList.
! !
!ProcessMonitor methodsFor:'menu actions'!
@@ -292,8 +354,8 @@
oldList := listView list.
processes notNil ifTrue:[
list := OrderedCollection new.
- list add:'id name state prio usedStack totalStack'.
- list add:'-------------------------------------------------------------------'.
+ list add:'id name state prio usedStack totalStack'.
+ list add:'------------------------------------------------------------------------'.
interrupted := Processor interruptedProcess.
@@ -310,10 +372,10 @@
] ifTrue:[
nm := ' '
].
- nm size >= 24 ifTrue:[
- nm := (nm copyTo:23) , ' '
+ nm size >= 29 ifTrue:[
+ nm := (nm contractTo:28) , ' '
] ifFalse:[
- nm := (nm printStringPaddedTo:24).
+ nm := (nm printStringPaddedTo:29).
].
line := line , nm.
st := aProcess state.
--- a/ProcessMonitor.st Thu Nov 17 15:44:34 1994 +0100
+++ b/ProcessMonitor.st Thu Nov 17 15:47:59 1994 +0100
@@ -1,3 +1,15 @@
+"
+ COPYRIGHT (c) 1993 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
StandardSystemView subclass:#ProcessMonitor
instanceVariableNames:'listView processes listUpdateDelay updateDelay
updateBlock listUpdateBlock updateProcess hideDead
@@ -7,6 +19,54 @@
category:'Interface-Tools'
!
+!ProcessMonitor class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1993 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+!
+
+version
+"
+$Header: /cvs/stx/stx/libtool/ProcessMonitor.st,v 1.4 1994-11-17 14:46:59 claus Exp $
+"
+!
+
+documentation
+"
+ This view shows smalltalks (light-weight) processes, and also offers
+ a popup menu for various useful operations on them.
+ Especially 'debug' is useful, to see what a process is currently
+ doing.
+ The information shown is:
+ id - the numeric id of the process
+ name - the name (if any) of the process
+ (the name has no semantic meaning; its for the processMonitor)
+ state - what is it doing;
+ wait - waiting on a semaphore
+ eventWait - waiting on a view-event semaphore
+ ioWait - waiting on an io-semaphore
+ timeWait - waiting for a time-semaphore
+ run - run, but currently not scheduled
+ active - really running
+ suspended - suspended; not waiting on a semaphore
+ light - not yet started (i.e. has no stack yet)
+
+ prio - the processes priority (1..30)
+ usedStack - the current stack use
+ totalStack - the stack currently allocated
+"
+! !
+
!ProcessMonitor class methodsFor:'startup'!
open
@@ -184,6 +244,8 @@
]
]
].
+ self updateStatus.
+ self updateList.
! !
!ProcessMonitor methodsFor:'menu actions'!
@@ -292,8 +354,8 @@
oldList := listView list.
processes notNil ifTrue:[
list := OrderedCollection new.
- list add:'id name state prio usedStack totalStack'.
- list add:'-------------------------------------------------------------------'.
+ list add:'id name state prio usedStack totalStack'.
+ list add:'------------------------------------------------------------------------'.
interrupted := Processor interruptedProcess.
@@ -310,10 +372,10 @@
] ifTrue:[
nm := ' '
].
- nm size >= 24 ifTrue:[
- nm := (nm copyTo:23) , ' '
+ nm size >= 29 ifTrue:[
+ nm := (nm contractTo:28) , ' '
] ifFalse:[
- nm := (nm printStringPaddedTo:24).
+ nm := (nm printStringPaddedTo:29).
].
line := line , nm.
st := aProcess state.
--- a/ProjectV.st Thu Nov 17 15:44:34 1994 +0100
+++ b/ProjectV.st Thu Nov 17 15:47:59 1994 +0100
@@ -1,5 +1,3 @@
-"{ Package: 'Programming Tools' }"
-
"
COPYRIGHT (c) 1993 by Claus Gittinger
All Rights Reserved
@@ -209,16 +207,18 @@
!
destroy
- |box|
+ (myProject views notNil
+ and:[myProject views notEmpty]) ifTrue:[
+ |box|
- box := YesNoBox new.
- box title:'Destroying a project will discard all changes made
+ box := YesNoBox new.
+ box title:'Destroying a project will discard all changes made
for that project and destroy all views opened for it.
Do you really want to do this ?'.
- box okText:'yes'.
- box yesAction:[
- self doDestroy
+ box okText:'yes'.
+ (box confirm) ifFalse:[^ self]
].
- box showAtPointer
+
+ self doDestroy
! !
--- a/ProjectView.st Thu Nov 17 15:44:34 1994 +0100
+++ b/ProjectView.st Thu Nov 17 15:47:59 1994 +0100
@@ -1,5 +1,3 @@
-"{ Package: 'Programming Tools' }"
-
"
COPYRIGHT (c) 1993 by Claus Gittinger
All Rights Reserved
@@ -209,16 +207,18 @@
!
destroy
- |box|
+ (myProject views notNil
+ and:[myProject views notEmpty]) ifTrue:[
+ |box|
- box := YesNoBox new.
- box title:'Destroying a project will discard all changes made
+ box := YesNoBox new.
+ box title:'Destroying a project will discard all changes made
for that project and destroy all views opened for it.
Do you really want to do this ?'.
- box okText:'yes'.
- box yesAction:[
- self doDestroy
+ box okText:'yes'.
+ (box confirm) ifFalse:[^ self]
].
- box showAtPointer
+
+ self doDestroy
! !
--- a/SBrowser.st Thu Nov 17 15:44:34 1994 +0100
+++ b/SBrowser.st Thu Nov 17 15:47:59 1994 +0100
@@ -1,5 +1,3 @@
-"{ Package: 'Programming Tools' }"
-
"
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
@@ -12,26 +10,25 @@
hereby transferred.
"
+'From Smalltalk/X, Version:2.10.4 on 7-nov-1994 at 14:56:27'!
+
StandardSystemView subclass:#SystemBrowser
- instanceVariableNames:'classCategoryListView classListView
- methodCategoryListView methodListView
- classMethodListView
- codeView classToggle instanceToggle
- currentClassCategory currentClassHierarchy
- currentClass
- currentMethodCategory currentMethod
- showInstance actualClass fullClass
- lastMethodCategory aspect variableListView'
- classVariableNames:''
- poolDictionaries:''
- category:'Interface-Browsers'
+ instanceVariableNames:'classCategoryListView classListView methodCategoryListView
+ methodListView classMethodListView codeView classToggle
+ instanceToggle currentClassCategory currentClassHierarchy
+ currentClass currentMethodCategory currentMethod currentSelector
+ showInstance actualClass fullClass lastMethodCategory aspect
+ variableListView fullProtocol lockUpdates autoSearch myLabel'
+ classVariableNames:'CheckForInstancesWhenRemovingClasses'
+ poolDictionaries:''
+ category:'Interface-Browsers'
!
SystemBrowser comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libtool/Attic/SBrowser.st,v 1.14 1994-10-28 03:29:32 claus Exp $
+$Header: /cvs/stx/stx/libtool/Attic/SBrowser.st,v 1.15 1994-11-17 14:47:02 claus Exp $
'!
!SystemBrowser class methodsFor:'documentation'!
@@ -52,115 +49,53 @@
version
"
-$Header: /cvs/stx/stx/libtool/Attic/SBrowser.st,v 1.14 1994-10-28 03:29:32 claus Exp $
+$Header: /cvs/stx/stx/libtool/Attic/SBrowser.st,v 1.15 1994-11-17 14:47:02 claus Exp $
"
!
documentation
"
this class implements all kinds of class browsers.
- Stypically, it is started with SystemBrowser open, but there are many other startup
- messages, to launch special browsers.
- See the extra document 'doc/misc/sbrowser.doc' for how to use this browser.
+ Typically, it is started with 'SystemBrowser open', but there are many other
+ startup messages, to launch special browsers.
+ See the categories 'startup' and 'special search startup' in the classes
+ protocol.
+
+ Alse, see the extra document 'doc/misc/sbrowser.doc' or the HTML online doc
+ for how to use the browser.
written winter 89 by claus
"
! !
-!SystemBrowser class methodsFor:'general startup'!
-
-open
- "launch a standard browser"
-
- ^ self openOnDisplay:Display
-
- "SystemBrowser open"
-!
-
-openOnDisplay:aDisplay
- "launch a standard browser on another display.
- Does not work currently - still being developped."
-
- ^ self newWithLabel:(self classResources string:'System Browser')
- setupBlock:[:browser | browser setupForAll]
- on:aDisplay
+!SystemBrowser class methodsFor:'initialization'!
+
+initialize
+ "SystemBrowser configuration;
+ (values can be changed from your private startup file)"
"
- SystemBrowser openOnDisplay:(XWorkstation new initializeFor:'porty:0')
+ setting this to false, the removeClass function will remove
+ classes WITHOUT checking for instances. Otherwise,
+ it will check and let you confirm in case there are instances.
+ Checking for instances may be a bit time consuming, though.
+ The default is true - therefore, it will check
+ "
+ CheckForInstancesWhenRemovingClasses := true
+
+ "
+ CheckForInstancesWhenRemovingClasses := true
+ CheckForInstancesWhenRemovingClasses := false
"
! !
!SystemBrowser class methodsFor:'startup'!
-browseFullClasses
- "launch a browser showing all methods at once"
-
- ^ self newWithLabel:'Full Class Browser'
- setupBlock:[:browser | browser setupForFullClass]
-
- "SystemBrowser browseFullClasses"
-!
-
-browseClassCategory:aClassCategory
- "launch a browser for all classes under aCategory"
-
- ^ self newWithLabel:aClassCategory
- setupBlock:[:browser | browser setupForClassCategory:aClassCategory]
-
- "SystemBrowser browseClassCategory:'Kernel-Objects'"
-!
-
-browseClass:aClass
- "launch a browser for aClass"
-
- ^ self newWithLabel:aClass name
- setupBlock:[:browser | browser setupForClass:aClass]
-
- "SystemBrowser browseClass:Object"
-!
-
-browseClassHierarchy:aClass
- "launch a browser for aClass and all its superclasses"
-
- ^ self newWithLabel:(aClass name , '-' , 'hierarchy')
- setupBlock:[:browser | browser setupForClassHierarchy:aClass]
-
- "SystemBrowser browseClassHierarchy:Number"
-!
-
-browseClasses:aList title:title
- "launch a browser for all classes in aList"
-
- ^ self newWithLabel:title
- setupBlock:[:browser | browser setupForClassList:aList]
-
- "
- SystemBrowser browseClasses:(Array with:Object
- with:Float)
- title:'two classes'
- "
-!
-
-browseClass:aClass methodCategory:aCategory
- "launch a browser for all methods under aCategory in aClass"
-
- ^ self newWithLabel:(aClass name , ' ' , aCategory)
- setupBlock:[:browser | browser setupForClass:aClass methodCategory:aCategory]
-
- "SystemBrowser browseClass:String methodCategory:'copying'"
-!
-
-browseClass:aClass selector:selector
- "launch a browser for the method at selector in aClass"
-
- ^ self newWithLabel:(aClass name , ' ' , selector)
- setupBlock:[:browser | browser setupForClass:aClass selector:selector]
-
- "SystemBrowser browseClass:Object selector:#printString"
-!
-
browseMethods:aList title:aString
- "launch a browser for an explicit list of class/selectors"
+ "launch a browser for an explicit list of class/selectors.
+ Each entry in the list must consist of the classes name and the selector,
+ separated by spaces. For class methods, the string 'class' must be
+ appended to the classname."
(aList size == 0) ifTrue:[
self showNoneFound:aString.
@@ -175,63 +110,12 @@
'Collection add:')
title:'some methods'
"
-!
-
-browseMethodCategory:aCategory
- "launch a browser for all methods where category = aCategory"
-
- |searchBlock|
-
- aCategory includesMatchCharacters ifTrue:[
- searchBlock := [:c :m :s | aCategory match:m category].
- ] ifFalse:[
- searchBlock := [:c :m :s | m category = aCategory]
- ].
-
- self browseMethodsWhere:searchBlock title:('all methods with category of ' , aCategory)
-
- "
- SystemBrowser browseMethodCategory:'printing & storing'
- SystemBrowser browseMethodCategory:'print*'
"
-!
-
-browseAllSelect:aBlock
- "launch a browser for all methods where aBlock returns true.
- The block is called with 3 arguments, class, method and seelctor."
-
- ^ self browseMethodsWhere:aBlock title:'selected messages'
-!
-
-browseMethodsWhere:aBlock title:title
- "launch a browser for all methods where aBlock returns true.
- The block is called with 3 arguments, class, method and seelctor."
-
- ^ self browseMethodsIn:(Smalltalk allClasses) where:aBlock title:title
-!
-
-browseMethodsOf:aClass where:aBlock title:title
- "launch a browser for all instance- and classmethods in aClass
- where aBlock evaluates to true.
- The block is called with 3 arguments, class, method and seelctor."
-
- ^ self browseMethodsIn:(Array with:aClass) where:aBlock title:title
-!
-
-browseMethodsFrom:aClass where:aBlock title:title
- "launch a browser for all instance- and classmethods in aClass
- and all its subclasses where aBlock evaluates to true.
- The block is called with 3 arguments, class, method and seelctor."
-
- ^ self browseMethodsIn:(aClass withAllSubclasses) where:aBlock title:title
-!
-
-browseMethodsIn:aCollectionOfClasses where:aBlock title:title
- "launch a browser for all instance- and classmethods from
- all classes in aCollectionOfClasses where aBlock evaluates to true.
- The block is called with 3 arguments, class, method and seelctor."
-
- ^ self browseMethodsIn:aCollectionOfClasses inst:true class:true where:aBlock title:title
+ SystemBrowser browseMethods:#('Behavior new:'
+ 'Setclass new:')
+ title:'some new: methods'
+ "
+
!
browseMethodsIn:aCollectionOfClasses inst:wantInst class:wantClass where:aBlock title:title
@@ -272,6 +156,10 @@
].
aCollectionOfClasses do:[:aClass |
+ "
+ output disabled - it slows down things too much (when searching for
+ implementors or senders)
+ "
"/ Transcript show:'searching '; show:aClass name; showCr:' ...'; endEntry.
wantInst ifTrue:[checkBlock value:aClass].
wantClass ifTrue:[checkBlock value:(aClass class)].
@@ -282,6 +170,152 @@
^ self browseMethods:list title:title
!
+browseMethodsIn:aCollectionOfClasses where:aBlock title:title
+ "launch a browser for all instance- and classmethods from
+ all classes in aCollectionOfClasses where aBlock evaluates to true.
+ The block is called with 3 arguments, class, method and seelctor."
+
+ ^ self browseMethodsIn:aCollectionOfClasses inst:true class:true where:aBlock title:title
+!
+
+browseClassCategory:aClassCategory
+ "launch a browser for all classes under aCategory"
+
+ ^ self newWithLabel:aClassCategory
+ setupBlock:[:browser | browser setupForClassCategory:aClassCategory]
+
+ "SystemBrowser browseClassCategory:'Kernel-Objects'"
+!
+
+browseFullClasses
+ "launch a browser showing all methods at once"
+
+ ^ self newWithLabel:'Full Class Browser'
+ setupBlock:[:browser | browser setupForFullClass]
+
+ "SystemBrowser browseFullClasses"
+!
+
+browseClass:aClass
+ "launch a browser for aClass"
+
+ ^ self newWithLabel:aClass name
+ setupBlock:[:browser | browser setupForClass:aClass]
+
+ "SystemBrowser browseClass:Object"
+!
+
+browseClass:aClass selector:selector
+ "launch a browser for the method at selector in aClass"
+
+ ^ self
+ newWithLabel:(aClass name , ' ' , selector , ' ' , selector)
+ setupBlock:[:browser | browser setupForClass:aClass selector:selector]
+
+ "
+ SystemBrowser browseClass:Object selector:#printString
+ "
+!
+
+browseClassHierarchy:aClass
+ "launch a browser for aClass and all its superclasses.
+ this is different from the fullProtocol browser."
+
+ ^ self newWithLabel:(aClass name , '-' , 'hierarchy')
+ setupBlock:[:browser | browser setupForClassHierarchy:aClass]
+
+ "
+ SystemBrowser browseClassHierarchy:Number
+ "
+!
+
+browseFullClassProtocol:aClass
+ "launch a browser for aClasses full protocol.
+ This is different from hierarchy browsing."
+
+ ^ self newWithLabel:(aClass name , '-' , 'full protocol')
+ setupBlock:[:browser | browser setupForFullClassProtocol:aClass]
+
+ "
+ SystemBrowser browseFullClassProtocol:Number
+ "
+!
+
+browseClasses:aList title:title
+ "launch a browser for all classes in aList"
+
+ ^ self newWithLabel:title
+ setupBlock:[:browser | browser setupForClassList:aList]
+
+ "
+ SystemBrowser browseClasses:(Array with:Object
+ with:Float)
+ title:'two classes'
+ "
+!
+
+browseClass:aClass methodCategory:aCategory
+ "launch a browser for all methods under aCategory in aClass"
+
+ ^ self newWithLabel:(aClass name , ' ' , aCategory)
+ setupBlock:[:browser | browser setupForClass:aClass methodCategory:aCategory]
+
+ "SystemBrowser browseClass:String methodCategory:'copying'"
+!
+
+browseMethodCategory:aCategory
+ "launch a browser for all methods where category = aCategory"
+
+ |searchBlock|
+
+ aCategory includesMatchCharacters ifTrue:[
+ searchBlock := [:c :m :s | aCategory match:m category].
+ ] ifFalse:[
+ searchBlock := [:c :m :s | m category = aCategory]
+ ].
+
+ self browseMethodsWhere:searchBlock title:('all methods with category of ' , aCategory)
+
+ "
+ SystemBrowser browseMethodCategory:'printing & storing'
+ SystemBrowser browseMethodCategory:'print*'
+ "
+!
+
+browseAllSelect:aBlock
+ "launch a browser for all methods where aBlock returns true.
+ The block is called with 3 arguments, class, method and seelctor."
+
+ ^ self browseMethodsWhere:aBlock title:'selected messages'
+
+ "
+ SystemBrowser browseAllSelect:[:aClass :aMethod :selector | selector numArgs == 3]
+ "
+!
+
+browseMethodsWhere:aBlock title:title
+ "launch a browser for all methods where aBlock returns true.
+ The block is called with 3 arguments, class, method and seelctor."
+
+ ^ self browseMethodsIn:(Smalltalk allClasses) where:aBlock title:title
+!
+
+browseMethodsOf:aClass where:aBlock title:title
+ "launch a browser for all instance- and classmethods in aClass
+ where aBlock evaluates to true.
+ The block is called with 3 arguments, class, method and seelctor."
+
+ ^ self browseMethodsIn:(Array with:aClass) where:aBlock title:title
+!
+
+browseMethodsFrom:aClass where:aBlock title:title
+ "launch a browser for all instance- and classmethods in aClass
+ and all its subclasses where aBlock evaluates to true.
+ The block is called with 3 arguments, class, method and seelctor."
+
+ ^ self browseMethodsIn:(aClass withAllSubclasses) where:aBlock title:title
+!
+
browseInstMethodsOf:aClass where:aBlock title:title
"launch a browser for all instance methods in aClass
where aBlock evaluates to true"
@@ -289,23 +323,102 @@
^ self browseMethodsIn:(Array with:aClass) inst:true class:false where:aBlock title:title
!
-browseInstMethodsFrom:aClass where:aBlock title:title
- "launch a browser for all instance methods in aClass and all subclasses
- where aBlock evaluates to true"
-
- ^ self browseMethodsIn:(aClass withAllSubclasses) inst:true class:false where:aBlock title:title
-!
-
browseInstMethodsIn:aCollectionOfClasses where:aBlock title:title
"launch a browser for all instance methods of all classes in
aCollectionOfClasses where aBlock evaluates to true"
^ self browseMethodsIn:aCollectionOfClasses inst:true class:false
where:aBlock title:title
+!
+
+browseInstMethodsFrom:aClass where:aBlock title:title
+ "launch a browser for all instance methods in aClass and all subclasses
+ where aBlock evaluates to true"
+
+ ^ self browseMethodsIn:(aClass withAllSubclasses) inst:true class:false where:aBlock title:title
+!
+
+browseFullClassHierarchy:aClass
+ "launch a browser for aClass and all its superclasses"
+
+ ^ self newWithLabel:(aClass name , '-' , 'full protocol')
+ setupBlock:[:browser | browser setupForFullClassHierarchy:aClass]
+
+ "
+ SystemBrowser browseFullClassHierarchy:Number
+ "
! !
!SystemBrowser class methodsFor:'special search startup'!
+browseAllCallsOn:aSelectorString in:aCollectionOfClasses title:title
+ "launch a browser for all senders of aSelector in aCollectionOfClasses"
+
+ |sel browser searchBlock|
+
+ ((aSelectorString ~= '*') and:[aSelectorString includesMatchCharacters]) ifTrue:[
+ "a matchString"
+ searchBlock := [:lits |
+ |found|
+
+ found := false.
+ lits notNil ifTrue:[
+ lits do:[:aLiteral |
+ found ifFalse:[
+ (aLiteral isMemberOf:Symbol) ifTrue:[
+ found := (aSelectorString match:aLiteral)
+ ]
+ ]
+ ]
+ ].
+ found
+ ].
+ browser := self browseMethodsIn:aCollectionOfClasses
+ where:[:class :method :s | searchBlock value:(method literals)]
+ title:title
+ ] ifFalse:[
+ aSelectorString knownAsSymbol ifFalse:[
+"
+ Transcript showCr:'none found.'.
+"
+ self showNoneFound:title.
+ ^ nil
+ ].
+
+ sel := aSelectorString asSymbol.
+ browser := self browseMethodsIn:aCollectionOfClasses
+ where:[:class :method :s | method sends:sel]
+ title:title
+ ].
+
+ browser notNil ifTrue:[
+ |s|
+
+ "
+ kludge for now, if its a multipart selector,
+ no easy search is (as yet) possible
+ "
+ s := aSelectorString.
+ (s includes:$:) ifTrue:[
+ s := s copyTo:(s indexOf:$:)
+ ].
+ browser autoSearch:s
+ ].
+ ^ browser
+!
+
+browseImplementorsOf:aSelectorString
+ "launch a browser for all implementors of aSelector"
+
+ ^ self browseImplementorsOf:aSelectorString
+ in:(Smalltalk allClasses)
+ title:('implementors of: ' , aSelectorString)
+
+ "
+ SystemBrowser browseImplementorsOf:#+
+ "
+!
+
browseImplementorsOf:aSelectorString in:aCollectionOfClasses title:title
"launch a browser for all implementors of aSelector in
the classes contained in aCollectionOfClasses and its metaclasses"
@@ -358,79 +471,6 @@
"
!
-browseImplementorsOf:aSelectorString
- "launch a browser for all implementors of aSelector"
-
- ^ self browseImplementorsOf:aSelectorString
- in:(Smalltalk allClasses)
- title:('implementors of: ' , aSelectorString)
-
- "
- SystemBrowser browseImplementorsOf:#+
- "
-!
-
-browseImplementorsOf:aSelectorString under:aClass
- "launch a browser for all implementors of aSelector in aClass
- and its subclasses"
-
- ^ self browseImplementorsOf:aSelectorString
- in:(aClass withAllSubclasses)
- title:('implementors of: ' ,
- aSelectorString ,
- ' (in or below ' , aClass name , ')')
-
- "
- SystemBrowser browseImplementorsOf:#+ under:Integer
- "
-!
-
-browseAllCallsOn:aSelectorString in:aCollectionOfClasses title:title
- "launch a browser for all senders of aSelector in aCollectionOfClasses"
-
- |sel browser searchBlock|
-
- ((aSelectorString ~= '*') and:[aSelectorString includesMatchCharacters]) ifTrue:[
- "a matchString"
- searchBlock := [:lits |
- |found|
-
- found := false.
- lits notNil ifTrue:[
- lits do:[:aLiteral |
- found ifFalse:[
- (aLiteral isMemberOf:Symbol) ifTrue:[
- found := (aSelectorString match:aLiteral)
- ]
- ]
- ]
- ].
- found
- ].
- browser := self browseMethodsIn:aCollectionOfClasses
- where:[:class :method :s | searchBlock value:(method literals)]
- title:title
- ] ifFalse:[
- aSelectorString knownAsSymbol ifFalse:[
-"
- Transcript showCr:'none found.'.
-"
- self showNoneFound:title.
- ^ nil
- ].
-
- sel := aSelectorString asSymbol.
- browser := self browseMethodsIn:aCollectionOfClasses
- where:[:class :method :s | method sends:sel]
- title:title
- ].
-
- browser notNil ifTrue:[
- browser setSearchPattern:aSelectorString
- ].
- ^ browser
-!
-
browseAllCallsOn:aSelectorString
"launch a browser for all senders of aSelector"
@@ -457,6 +497,21 @@
"
!
+browseImplementorsOf:aSelectorString under:aClass
+ "launch a browser for all implementors of aSelector in aClass
+ and its subclasses"
+
+ ^ self browseImplementorsOf:aSelectorString
+ in:(aClass withAllSubclasses)
+ title:('implementors of: ' ,
+ aSelectorString ,
+ ' (in or below ' , aClass name , ')')
+
+ "
+ SystemBrowser browseImplementorsOf:#+ under:Integer
+ "
+!
+
browseForSymbol:aSymbol title:title warnIfNone:doWarn
"launch a browser for all methods referencing aSymbol"
@@ -507,11 +562,61 @@
].
browser := self browseMethodsWhere:[:c :m :s | searchBlock value:(m literals)] title:title.
browser notNil ifTrue:[
- browser setSearchPattern:aSymbol
+ browser autoSearch:aSymbol
].
^ browser
!
+filterToSearchInstRefsTo:varName modificationsOnly:modsOnly
+ "return a block to search for instvar accesses"
+
+ |searchBlock|
+
+ searchBlock := [:c :m :s |
+ |src result parser instvars needMatch|
+
+ needMatch := varName includesMatchCharacters.
+
+ src := m source.
+ src isNil ifTrue:[
+ result := false
+ ] ifFalse:[
+ needMatch ifFalse:[
+ "
+ before doing a slow parse, quickly scan the
+ methods source for the variables name ...
+ "
+ result := (src findString:varName) ~~ 0.
+ ] ifTrue:[
+ result := true.
+ ].
+ result ifTrue:[
+ result := false.
+ parser := Parser parseMethod:src in:c.
+ parser notNil ifTrue:[
+ modsOnly ifTrue:[
+ instvars := parser modifiedInstVars
+ ] ifFalse:[
+ instvars := parser usedInstVars
+ ].
+ instvars notNil ifTrue:[
+ needMatch ifTrue:[
+ instvars do:[:iv |
+ (varName match:iv) ifTrue:[result := true]
+ ]
+ ] ifFalse:[
+ result := instvars includes:varName
+ ]
+ ]
+ ]
+ ].
+ ].
+ Processor yield.
+ result
+ ].
+ ^ searchBlock
+!
+
browseForSymbol:aSymbol
"launch a browser for all methods referencing aSymbol"
@@ -538,6 +643,117 @@
"
!
+browseUsesOf:aClass
+ |dict owners offsets
+ sz "{ Class: SmallInteger }"
+ n "{ Class: SmallInteger }"
+ removeSet newDict|
+
+ owners := ObjectMemory whoReferencesInstancesOf:aClass.
+
+ "
+ collect set of offsets in dict; key is class
+ "
+ dict := IdentityDictionary new.
+ owners do:[:someObject |
+ |cls create|
+
+ someObject isContext ifFalse:[
+ "
+ someObject refers to an instance of aClass;
+ find out, which instVar(s)
+ "
+ cls := someObject class.
+ cls ~~ Array ifTrue:[
+ n := cls instSize.
+ create := [|s| s := Set new. dict at:cls put:s. s].
+
+ 1 to:n do:[:i |
+ |ref|
+
+ ref := someObject instVarAt:i.
+ (ref isMemberOf:aClass) ifTrue:[
+ offsets := dict at:cls ifAbsent:create.
+ offsets add:i.
+ ]
+ ].
+ cls isVariable ifTrue:[
+ cls isPointers ifTrue:[
+ | idx "{ Class: SmallInteger }" |
+
+ sz := someObject basicSize.
+ idx := 1.
+ [idx <= sz] whileTrue:[
+ |ref|
+
+ ref := someObject basicAt:idx.
+ (ref isMemberOf:aClass) ifTrue:[
+ offsets := dict at:cls ifAbsent:create.
+ offsets add:0.
+ idx := sz
+ ].
+ idx := idx + 1
+ ]
+ ]
+ ]
+ ]
+ ]
+ ].
+
+ "
+ merge with superclass refs
+ "
+ dict keysAndValuesDo:[:cls :set |
+ cls allSuperclasses do:[:aSuperclass |
+ |superSet|
+
+ superSet := dict at:aSuperclass ifAbsent:[].
+ superSet notNil ifTrue:[
+ |removeSet|
+
+ superSet := dict at:aSuperclass.
+ removeSet := Set new.
+ set do:[:offset |
+ (superSet includes:offset) ifTrue:[
+ removeSet add:offset
+ ]
+ ].
+ set removeAll:removeSet
+ ]
+ ]
+ ].
+
+ "
+ remove empty ones
+ "
+ removeSet := Set new.
+ dict keysAndValuesDo:[:cls :set |
+ set isEmpty ifTrue:[
+ removeSet add:cls
+ ]
+ ].
+ removeSet do:[:cls |
+ dict removeKey:cls
+ ].
+
+ "
+ replace the indices by real names
+ "
+ newDict := IdentityDictionary new.
+ dict keysAndValuesDo:[:cls :set |
+ |newSet names|
+
+ names := cls allInstVarNames.
+ newSet := set collect:[:index |
+ index == 0 ifTrue:['*indexed*'] ifFalse:[names at:index].
+ ].
+ newDict at:cls put:newSet
+ ].
+
+ newDict inspect
+
+!
+
browseForString:aString in:aCollectionOfClasses
"launch a browser for all methods in aCollectionOfClasses
containing a string-constant"
@@ -585,7 +801,7 @@
title:title.
browser notNil ifTrue:[
- browser setSearchPattern:aString
+ browser autoSearch:aString
].
^ browser
@@ -600,6 +816,22 @@
^ self browseForString:aString in:(Smalltalk allClasses)
!
+browseInstRefsTo:varName in:aCollectionOfClasses modificationsOnly:modsOnly title:title
+ "launch a browser for all methods in aClass where the instVar named
+ varName is referenced; if modsOnly is true, browse only methods where the
+ instvar is modified"
+
+ |filter browser|
+
+ filter := self filterToSearchInstRefsTo:varName modificationsOnly:modsOnly.
+ browser := self browseInstMethodsIn:aCollectionOfClasses where:filter title:title.
+
+ browser notNil ifTrue:[
+ browser autoSearch:varName
+ ].
+ ^ browser
+!
+
aproposSearch:aString in:aCollectionOfClasses
"browse all methods, which have aString in their selector or
in the methods comment.
@@ -629,71 +861,6 @@
"SystemBrowser aproposSearch:'sort'"
!
-aproposSearch:aString
- "browse all methods, which have aString in their selector or
- in the methods comment.
- This is relatively slow, since all source must be processed."
-
- ^ self aproposSearch:aString in:(Smalltalk allClasses)
-!
-
-browseInstRefsTo:varName in:aCollectionOfClasses modificationsOnly:modsOnly title:title
- "launch a browser for all methods in aClass where the instVar named
- varName is referenced; if modsOnly is true, browse only methods where the
- instvar is modified"
-
- |searchBlock browser needMatch|
-
- needMatch := varName includesMatchCharacters.
-
- searchBlock := [:c :m :s |
- |src result parser instvars|
-
- src := m source.
- src isNil ifTrue:[
- result := false
- ] ifFalse:[
- needMatch ifFalse:[
- "
- before doing a slow parse, quickly scan the
- methods source for the variables name ...
- "
- result := (src findString:varName) ~~ 0.
- ] ifTrue:[
- result := true.
- ].
- result ifTrue:[
- result := false.
- parser := Parser parseMethod:src in:c.
- parser notNil ifTrue:[
- modsOnly ifTrue:[
- instvars := parser modifiedInstVars
- ] ifFalse:[
- instvars := parser usedInstVars
- ].
- instvars notNil ifTrue:[
- needMatch ifTrue:[
- instvars do:[:iv |
- (varName match:iv) ifTrue:[result := true]
- ]
- ] ifFalse:[
- result := instvars includes:varName
- ]
- ]
- ]
- ].
- ].
- Processor yield.
- result
- ].
- browser := self browseInstMethodsIn:aCollectionOfClasses where:searchBlock title:title.
-
- browser notNil ifTrue:[
- browser setSearchPattern:varName
- ].
- ^ browser
-!
-
browseInstRefsTo:aString in:aCollectionOfClasses modificationsOnly:modsOnly
"launch a browser for all methods in aClass where the instVar named
aString is referenced; if modsOnly is true, browse only methods where the
@@ -712,6 +879,14 @@
title:(title , aString)
!
+aproposSearch:aString
+ "browse all methods, which have aString in their selector or
+ in the methods comment.
+ This is relatively slow, since all source must be processed."
+
+ ^ self aproposSearch:aString in:(Smalltalk allClasses)
+!
+
browseInstRefsTo:aString under:aClass modificationsOnly:modsOnly
"launch a browser for all methods in aClass and subclasses
where the instVar named aString is referenced;
@@ -725,12 +900,49 @@
where the classVar named aString is referenced;
if modsOnly is true, browse only methods where the classvar is modified"
- |needMatch searchBlock browser|
-
- needMatch := varName includesMatchCharacters.
+ |searchBlock browser|
+
+ searchBlock := self filterToSearchClassRefsTo:varName modificationsOnly:modsOnly.
+ browser := self browseMethodsIn:aCollectionOfClasses where:searchBlock title:title.
+
+ browser notNil ifTrue:[
+ browser autoSearch:varName
+ ].
+ ^ browser
+!
+
+browseClassRefsTo:aString in:aCollectionOfClasses modificationsOnly:modsOnly
+ "launch a browser for all methods in aClass where the classVar named
+ aString is referenced; if modsOnly is true, browse only methods where the
+ classvar is modified"
+
+ |title|
+
+ modsOnly ifTrue:[
+ title := 'modifications of '
+ ] ifFalse:[
+ title := 'references to '
+ ].
+ ^ self browseClassRefsTo:aString in:aCollectionOfClasses modificationsOnly:modsOnly title:(title , aString)
+!
+
+browseClassRefsTo:aString under:aClass modificationsOnly:modsOnly
+ "launch a browser for all methods in aClass and subclasses
+ where the classVar named aString is referenced;
+ if modsOnly is true, browse only methods where the classvar is modified"
+
+ ^ self browseClassRefsTo:aString in:(aClass withAllSubclasses) modificationsOnly:modsOnly
+!
+
+filterToSearchClassRefsTo:varName modificationsOnly:modsOnly
+ "return a searchblock for class variable references"
+
+ |searchBlock|
searchBlock := [:c :m :s |
- |src result parser classvars|
+ |src result parser classvars needMatch|
+
+ needMatch := varName includesMatchCharacters.
src := m source.
src isNil ifTrue:[
@@ -769,55 +981,18 @@
Processor yield.
result
].
- browser := self browseMethodsIn:aCollectionOfClasses where:searchBlock title:title.
-
- browser notNil ifTrue:[
- browser setSearchPattern:varName
- ].
- ^ browser
-!
-
-browseClassRefsTo:aString in:aCollectionOfClasses modificationsOnly:modsOnly
- "launch a browser for all methods in aClass where the classVar named
- aString is referenced; if modsOnly is true, browse only methods where the
- classvar is modified"
-
- |title|
-
- modsOnly ifTrue:[
- title := 'modifications of '
- ] ifFalse:[
- title := 'references to '
- ].
- ^ self browseClassRefsTo:aString in:aCollectionOfClasses modificationsOnly:modsOnly title:(title , aString)
-!
-
-browseClassRefsTo:aString under:aClass modificationsOnly:modsOnly
- "launch a browser for all methods in aClass and subclasses
- where the classVar named aString is referenced;
- if modsOnly is true, browse only methods where the classvar is modified"
-
- ^ self browseClassRefsTo:aString in:(aClass withAllSubclasses) modificationsOnly:modsOnly
+ ^ searchBlock
! !
!SystemBrowser class methodsFor:'private'!
-showNoneFound:what
-"/ DialogView warn:(self classResources string:('no ' , what , ' found')).
- self showNoneFound
-!
-
-showNoneFound
- DialogView warn:(self classResources string:'None found').
-!
-
newWithLabel:aString setupBlock:aBlock on:aWorkstation
"common helper method for all creation methods"
|newBrowser|
newBrowser := self on:aWorkstation.
- newBrowser label:aString.
+ newBrowser title:aString.
aBlock value:newBrowser.
newBrowser open.
@@ -828,470 +1003,264 @@
"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 methodsFor:'initialize / release'!
-
-initialize
- super initialize.
-
- self icon:(Form fromFile:(resources at:'ICON_FILE' default:'SBrowser.xbm')
- resolution:100).
-
- showInstance := true.
- fullClass := false.
- aspect := nil.
-
- "inform me, when Smalltalk changes"
- Smalltalk addDependent:self
-!
-
-destroy
- "relese dependant - destroy popups"
-
- Smalltalk removeDependent:self.
- currentClass notNil ifTrue:[
- currentClass removeDependent:self.
- currentClass := nil
+!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
].
- super destroy
-!
-
-terminate
- (self checkSelectionChangeAllowed) ifTrue:[
- super terminate
- ]
-!
-
-createTogglesIn:aFrame
- "create and setup the class/instance toggles"
-
- |halfSpacing h|
-
- instanceToggle := Toggle label:(resources at:'instance') in:aFrame.
- h := instanceToggle height.
- instanceToggle origin:(0.0 @ 1.0) corner:(0.5 @ 1.0).
- instanceToggle topInset:(h negated).
-
- instanceToggle turnOn.
- instanceToggle pressAction:[self instanceProtocol].
- instanceToggle releaseAction:[self classProtocol].
-
- classToggle := Toggle label:(resources at:'class') in:aFrame.
- h := classToggle height.
- classToggle origin:(0.5 @ 1.0) corner:(1.0 @ 1.0).
- classToggle topInset:(h negated).
-
- classToggle turnOff.
- classToggle pressAction:[self classProtocol].
- classToggle releaseAction:[self instanceProtocol].
-
- StyleSheet is3D ifTrue:[
- instanceToggle leftInset:(ViewSpacing // 2).
- classToggle leftInset:(ViewSpacing // 2).
- instanceToggle rightInset:ViewSpacing - (ViewSpacing // 2).
- classToggle rightInset:ViewSpacing - (ViewSpacing // 2).
+
+"/ changedObject print. ' ' print. someArgument print. ' ' print.
+"/ something printNL.
+
+ (changedObject == Smalltalk) ifTrue:[
+ something == #newClass ifTrue:[
+ ((someArgument category = currentClassCategory)
+ or:[currentClassCategory notNil
+ and:[currentClassCategory startsWith:'*']]) ifTrue:[
+ self updateClassListWithScroll:false.
+ ].
+
+ someArgument category ~= currentClassCategory ifTrue:[
+ "
+ category new ?
+ "
+ (classCategoryListView notNil
+ and:[classCategoryListView list notNil
+ and:[(classCategoryListView list includes:someArgument category) not]])
+ ifTrue:[
+ self updateClassCategoryListWithScroll:false.
+ ]
+ ].
+ ^ self
+ ].
+
+ something == #classRemove ifTrue:[
+ someArgument = currentClass ifTrue:[
+ self warnLabel:'the selected class was removed'.
+ ^ self
+ ].
+ " fall into general update "
+ ].
+
+ "
+ any other (unknown) change
+ with the Smalltalk dictionary ...
+ "
+ self updateClassCategoryListWithScroll:false.
+ self updateClassListWithScroll:false.
+ ^ self
].
-!
-
-createClassListViewIn:frame
- "setup the classlist subview, with its toggles"
-
- |v panel oldStyle|
-
- self createTogglesIn:frame.
-
-"/ oldStyle := true.
-oldStyle := false.
- oldStyle ifTrue:[
- v := ScrollableView for:SelectionInListView in:frame.
- v origin:(0.0 @ 0.0)
- extent:[frame width
- @
- (frame height
- - (ViewSpacing // 2)
- - instanceToggle height
- - instanceToggle borderWidth
- + v borderWidth)].
-
- classListView := v scrolledView
- ] ifFalse:[
- panel := VariableVerticalPanel
- origin:(0.0 @ 0.0)
- corner:[frame width
- @
- (frame height
- - (ViewSpacing // 2)
- - instanceToggle height
- - instanceToggle borderWidth
- + v borderWidth)]
- in:frame.
-
- v := ScrollableView for:SelectionInListView in:panel.
- v origin:(0.0 @ 0.0) corner:(1.0 @ 0.5).
- classListView := v scrolledView.
-
-
- v := ScrollableView for:SelectionInListView in:panel.
- v origin:(0.0 @ 0.5)
- corner:(1.0 @ 1.0).
-
- variableListView := v scrolledView
- ]
-!
-
-createCodeViewIn:aView
- "setup the code view"
- |v|
-
- v := HVScrollableView for:CodeView miniScrollerH:true miniScrollerV:false in:aView.
- v origin:(0.0 @ 0.25) corner:(1.0 @ 1.0).
- codeView := v scrolledView
-!
-
-setupActions
-"/ |v|
-
-"/ v := classCategoryListView.
-"/ v notNil ifTrue:[
-"/ v action:[:lineNr | self classCategorySelection:lineNr].
-"/ v selectConditionBlock:[self checkSelectionChangeAllowed].
-"/ v ignoreReselect:false.
-"/ ].
-"/ v := classListView.
-"/ v notNil ifTrue:[
-"/ v action:[:lineNr | self classSelection:lineNr].
-"/ v selectConditionBlock:[self checkSelectionChangeAllowed].
-"/ v ignoreReselect:false.
-"/ ].
-"/ v := methodCategoryListView.
-"/ v notNil ifTrue:[
-"/ v action:[:lineNr | self methodCategorySelection:lineNr].
-"/ v selectConditionBlock:[self checkSelectionChangeAllowed].
-"/ v ignoreReselect:false.
-"/ ].
-"/ v := methodListView.
-"/ v notNil ifTrue:[
-"/ v action:[:lineNr | self methodSelection:lineNr].
-"/ v selectConditionBlock:[self checkSelectionChangeAllowed].
-"/ v ignoreReselect:false.
-"/ ].
-"/ v := classMethodListView.
-"/ v notNil ifTrue:[
-"/ v action:[:lineNr | self listSelection:lineNr].
-"/ v selectConditionBlock:[self checkSelectionChangeAllowed].
-"/ v ignoreReselect:false.
-"/ ]
-!
-
-setupForAll
- "create subviews for a full browser"
-
- |vpanel hpanel frame v|
-
- vpanel := VariableVerticalPanel origin:(0.0 @ 0.0) corner:(1.0 @ 1.0)
- in:self.
- hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
-
- v := HVScrollableView for:SelectionInListView
- miniScrollerH:true miniScrollerV:false
- in:hpanel.
- v origin:(0.0 @ 0.0) corner:(0.25 @ 1.0).
- classCategoryListView := v scrolledView.
-"/ classCategoryListView contents:(self listOfAllClassCategories).
-
- frame := View origin:(0.25 @ 0.0) corner:(0.5 @ 1.0) in:hpanel.
- self createClassListViewIn:frame.
-
- v := HVScrollableView for:SelectionInListView miniScrollerH:true miniScrollerV:false in:hpanel.
- v origin:(0.5 @ 0.0) corner:(0.75 @ 1.0).
- methodCategoryListView := v scrolledView.
-
- v := HVScrollableView for:SelectionInListView miniScrollerH:true miniScrollerV:false in:hpanel.
- v origin:(0.75 @ 0.0) corner:(1.0 @ 1.0).
- methodListView := v scrolledView.
-
-"/ self setupActions.
- self createCodeViewIn:vpanel
-!
-
-setupForFullClass
- "setup subviews to browse a class as full text"
-
- |vpanel hpanel v|
-
- vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
- corner:(1.0 @ 1.0)
- in:self.
-
- hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
-
- v := ScrollableView for:SelectionInListView in:hpanel.
- v origin:(0.0 @ 0.0) corner:(0.5 @ 1.0).
- classCategoryListView := v scrolledView.
- classCategoryListView contents:(self listOfAllClassCategories).
-
- v := ScrollableView for:SelectionInListView in:hpanel.
- v origin:(0.5 @ 0.0) corner:(1.0 @ 1.0).
- classListView := v scrolledView.
-
-"/ self setupActions.
- self createCodeViewIn:vpanel.
-
- fullClass := true.
- self updateCodeView
-!
-
-setupForClassCategory:aClassCategory
- "setup subviews to browse a class category"
-
- |vpanel hpanel frame v|
-
- vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
- corner:(1.0 @ 1.0)
- in:self.
-
- hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
- frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
-
- self createClassListViewIn:frame.
-
- v := ScrollableView for:SelectionInListView in:hpanel.
- v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
- methodCategoryListView := v scrolledView.
-
- v := ScrollableView for:SelectionInListView in:hpanel.
- v origin:(0.66 @ 0.0) corner:(1.0 @ 1.0).
- methodListView := v scrolledView.
-
-"/ self setupActions.
- self createCodeViewIn:vpanel.
-
- currentClassCategory := aClassCategory.
- self updateClassList.
- self updateMethodCategoryList.
- self updateMethodList.
- self updateCodeView
-!
-
-setupForClassList:aList
- "setup subviews to browse classes from a list"
-
- |vpanel hpanel frame l v|
-
- vpanel := VariableVerticalPanel
- origin:(0.0 @ 0.0) corner:(1.0 @ 1.0) in:self.
-
- hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
- frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
-
- self createClassListViewIn:frame.
-
- v := ScrollableView for:SelectionInListView in:hpanel.
- v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
- methodCategoryListView := v scrolledView.
-
- v := ScrollableView for:SelectionInListView in:hpanel.
- v origin:(0.66 @ 0.0) corner:(1.0 @ 1.0).
- methodListView := v scrolledView.
-
-"/ self setupActions.
- self createCodeViewIn:vpanel.
-
- l := aList collect:[:entry | entry name].
- classListView list:(l sort).
-
- self updateMethodCategoryList.
- self updateMethodList.
- self updateCodeView
-!
-
-setupForClassHierarchy:aClass
- "setup subviews to browse a class hierarchy"
-
- |vpanel hpanel frame v|
-
- vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
- corner:(1.0 @ 1.0)
- in:self.
-
- hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
- frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
-
- self createClassListViewIn:frame.
-
- v := ScrollableView for:SelectionInListView in:hpanel.
- v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
- methodCategoryListView := v scrolledView.
-
- v := ScrollableView for:SelectionInListView in:hpanel.
- v origin:(0.66 @ 0.0) corner:(1.0 @ 1.0).
- methodListView := v scrolledView.
-
-"/ self setupActions.
- self createCodeViewIn:vpanel.
-
- currentClassHierarchy := aClass.
- self updateClassList.
- self updateMethodCategoryList.
- self updateMethodList.
- self updateCodeView
-!
-
-setupForClass:aClass
- "create subviews for browsing a single class"
-
- |vpanel hpanel frame v|
-
- vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
- corner:(1.0 @ 1.0)
- in:self.
-
- hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
- frame := View origin:(0.0 @ 0.0) corner:(0.5 @ 1.0)in:hpanel.
-
- self createTogglesIn:frame.
-
- v := ScrollableView for:SelectionInListView in:frame.
- v origin:(0.0 @ 0.0)
- extent:[frame width
- @
- (frame height
- - (ViewSpacing // 2)
- - instanceToggle height
- - instanceToggle borderWidth
- + v borderWidth)].
- methodCategoryListView := v scrolledView.
-
- v := ScrollableView for:SelectionInListView in:hpanel.
- v origin:(0.5 @ 0.0) corner:(1.0 @ 1.0).
- methodListView := v scrolledView.
-
-"/ self setupActions.
- self createCodeViewIn:vpanel.
-
- self switchToClass:aClass.
- actualClass := aClass.
- self updateMethodCategoryList.
- self updateMethodList.
- self updateCodeView
-!
-
-setupForClass:aClass methodCategory:aMethodCategory
- "setup subviews to browse a method category"
-
- |vpanel v|
-
- vpanel := VariableVerticalPanel
- origin:(0.0 @ 0.0) corner:(1.0 @ 1.0)
- in:self.
-
- v := ScrollableView for:SelectionInListView in:vpanel.
- v origin:(0.0 @ 0.0) corner:(1.0 @ 0.25).
- methodListView := v scrolledView.
-
-"/ self setupActions.
- self createCodeViewIn:vpanel.
-
- currentClassCategory := aClass category.
- self switchToClass:aClass.
- actualClass := aClass.
- currentMethodCategory := aMethodCategory.
- self updateMethodList.
- self updateCodeView
-!
-
-setupForClass:aClass selector:selector
- "setup subviews to browse a single method"
-
- |v|
-
- v := ScrollableView for:CodeView in:self.
- v origin:(0.0 @ 0.0) corner:(1.0 @ 1.0).
- codeView := v scrolledView.
-
- currentClassCategory := aClass category.
- self switchToClass:aClass.
- actualClass := aClass.
- currentMethod := currentClass compiledMethodAt:selector.
- currentMethodCategory := currentMethod category.
- self updateCodeView
-!
-
-setupForList:aList
- "setup subviews to browse methods from a list"
-
- |vpanel v|
-
- vpanel := VariableVerticalPanel
- origin:(0.0 @ 0.0)
- corner:(1.0 @ 1.0)
- in:self.
-
- v := ScrollableView for:SelectionInListView in:vpanel.
- v origin:(0.0 @ 0.0) corner:(1.0 @ 0.25).
- classMethodListView := v scrolledView.
- classMethodListView contents:aList.
-
-"/ self setupActions.
- self createCodeViewIn:vpanel.
-
- self updateCodeView
-! !
-
-!SystemBrowser methodsFor:'realization'!
-
-realize
- |v checkBlock|
-
- super realize.
-
- checkBlock := [:lineNr | self checkSelectionChangeAllowed].
-
- v := classCategoryListView.
- v notNil ifTrue:[
- v action:[:lineNr | self classCategorySelection:lineNr].
- v selectConditionBlock:checkBlock.
- v ignoreReselect:false.
- v contents:(self listOfAllClassCategories).
- self initializeClassCategoryMenu
+
+ 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
].
- v := classListView.
- v notNil ifTrue:[
- v action:[:lineNr | self classSelection:lineNr].
- v selectConditionBlock:checkBlock.
- v ignoreReselect:false.
- self initializeClassMenu
- ].
-
- v := methodCategoryListView.
- v notNil ifTrue:[
- v action:[:lineNr | self methodCategorySelection:lineNr].
- v selectConditionBlock:checkBlock.
- v ignoreReselect:false.
- self initializeMethodCategoryMenu
- ].
-
- v := methodListView.
- v notNil ifTrue:[
- v action:[:lineNr | self methodSelection:lineNr].
- v selectConditionBlock:checkBlock.
- v ignoreReselect:false.
- self initializeMethodMenu
- ].
-
- v := classMethodListView.
- v notNil ifTrue:[
- v action:[:lineNr | self listSelection:lineNr].
- v selectConditionBlock:checkBlock.
- v ignoreReselect:false.
- self initializeClassMethodMenu
+ (changedObject isKindOf:Method) ifTrue:[
+
]
! !
!SystemBrowser methodsFor:'private'!
+normalLabel
+ "set the normal (inactive) window- and icon labels"
+
+ |l il sel|
+
+ myLabel notNil ifTrue:[
+ l := il := myLabel
+ ] ifFalse:[
+ l := resources string:'System Browser'.
+
+ currentClass notNil ifTrue:[
+ l := l, ': ', currentClass name.
+ classListView isNil ifTrue:[
+ currentSelector notNil ifTrue:[
+ l := l , ' ' , currentSelector
+ ]
+ ].
+ il := currentClass name
+ ] ifFalse:[
+ il := l.
+ ]
+ ].
+ self label:l.
+ self iconLabel:il.
+
+!
+
+setAcceptAndExplainActionsForMethod
+ "tell the codeView what to do on accept and explain"
+
+ codeView acceptAction:[:theCode |
+ |cat|
+
+ codeView cursor:Cursor execute.
+
+ (cat := currentMethodCategory) = '* all *' ifTrue:[
+ "must check from which category this code came from ...
+ ... thanks to Arno for pointing this out"
+
+ cat := self askForMethodCategory.
+ ].
+ (cat notNil and:[cat notEmpty]) ifTrue:[
+ Object abortSignal catch:[
+ lockUpdates := true.
+
+ actualClass compiler
+ compile:theCode asString
+ forClass:actualClass
+ inCategory:cat
+ notifying:codeView.
+
+ codeView modified:false.
+ self updateMethodListWithScroll:false.
+ ].
+ lockUpdates := false.
+ ].
+ codeView cursor:Cursor normal.
+ ].
+
+ codeView explainAction:[:theCode :theSelection |
+ self showExplanation:(Explainer
+ explain:theSelection
+ in:theCode
+ forClass:actualClass)
+ ].
+!
+
checkSelectionChangeAllowed
"return true, if selection change is ok;
its not ok, if code has been changed.
@@ -1302,6 +1271,7 @@
codeView modified ifFalse:[
^ true
].
+"/ fullProtocol ifTrue:[^ true].
box := YesNoBox
title:(resources at:'contents in codeview has not been accepted.\\Modifications will be lost when continuing.') withCRs
yesText:(resources at:'continue')
@@ -1309,39 +1279,6 @@
^ box confirm
!
-switchToClass:newClass
- currentClass notNil ifTrue:[
- currentClass removeDependent:self
- ].
- currentClass := newClass.
- currentClass notNil ifTrue:[
- currentClass addDependent:self.
- ].
- self normalLabel
-!
-
-showExplanation:someText
- "show explanation from Parser"
-
- self notify:someText
-!
-
-normalLabel
- "set the normal (inactive) window- and icon labels"
-
- currentClass notNil ifTrue:[
- self label:'System Browser: ', currentClass name.
- self iconLabel:currentClass name
- ] ifFalse:[
- self label:'System Browser'.
- self iconLabel:'System Browser'.
- ]
-!
-
-setSearchPattern:aString
- codeView setSearchPattern:aString
-!
-
selectorToSearchFor
"look in codeView and methodListView for a search-string when searching for selectors"
@@ -1354,7 +1291,13 @@
t notNil ifTrue:[
sel := t
].
- sel := sel withoutSpaces
+ 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
@@ -1375,6 +1318,50 @@
^ sel
!
+enterBoxTitle:title okText:okText
+ "convenient method: setup enterBox"
+
+ |box|
+
+ box := EnterBox new.
+ box title:(resources string:title) okText:(resources string:okText).
+ ^ box
+!
+
+askAndBrowseSelectorTitle:title action:aBlock
+ "convenient method: setup enterBox with text from codeView or selected
+ method for browsing based on a selector. Set action and launch box"
+
+ |box|
+
+ box := self enterBoxTitle:title okText:'browse'.
+ box initialText:(self selectorToSearchFor).
+ box action:[:aString | self withCursor:(Cursor questionMark) do:[aBlock value:aString]].
+ box showAtPointer
+!
+
+setSearchPattern:aString
+ codeView setSearchPattern:aString
+!
+
+listBoxTitle:title okText:okText list:aList
+ "convenient method: setup a listBox & return it"
+
+ |box|
+
+ box := ListSelectionBox new.
+ box okText:(resources string:okText).
+ box title:(resources string:title).
+ box list:aList.
+ ^ box
+!
+
+showExplanation:someText
+ "show explanation from Parser"
+
+ self notify:someText
+!
+
stringToSearchFor
"look in codeView and methodListView for a search-string when searching for classes/names"
@@ -1423,45 +1410,11 @@
"
homeClass := currentClass
] ifFalse:[
- Transcript showCr:'starting search in ' , homeClass name.
+"/ Transcript showCr:'starting search in ' , homeClass name.
].
^ homeClass
!
-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
-!
-
-enterBoxTitle:title okText:okText
- "convenient method: setup enterBox"
-
- |box|
-
- box := EnterBox new.
- box title:(resources string:title) okText:(resources string:okText).
- ^ box
-!
-
-askBoxTitle:title okText:okText initialText:initialText action:aBlock
- "convenient method: setup enterBox, and open it"
-
- |box|
-
- box := EnterBox new.
- box title:(resources string:title) okText:(resources string:okText).
- box initialText:initialText.
- box action:[:aString | self withWaitCursorDo:aBlock value:aString].
- box showAtPointer
-!
-
enterBoxForSearchSelectorTitle:title
"convenient method: setup enterBox with text from codeView or selected
method for browsing based on a selector"
@@ -1473,30 +1426,6 @@
^ 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
-!
-
-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
-!
-
enterBoxForCodeSelectionTitle:title okText:okText
"convenient method: setup enterBox with text from codeview"
@@ -1510,6 +1439,46 @@
^ box
!
+classesInFullProtocolHierarchy:aClass do:aBlock
+ "evaluate aBlock for all non-striked out classes in
+ the hierarchy"
+
+ |index|
+
+ index := (classListView list size).
+ aClass withAllSuperclasses do:[:c |
+ (classListView isInSelection:index) ifFalse:[
+ aBlock value:c
+ ].
+ index := index - 1
+ ]
+
+!
+
+enterBoxForBrowseTitle:title action:aBlock
+ "convenient method: setup enterBox with text from codeView or selected
+ method for method browsing based on className/variable"
+
+ |box|
+
+ box := self enterBoxTitle:title okText:'browse'.
+ box initialText:(self stringToSearchFor).
+ box action:[:aString | self withWaitCursorDo:[aBlock value:aString]].
+ box showAtPointer
+!
+
+askBoxTitle:title okText:okText initialText:initialText action:aBlock
+ "convenient method: setup enterBox, and open it"
+
+ |box|
+
+ box := EnterBox new.
+ box title:(resources string:title) okText:(resources string:okText).
+ box initialText:initialText.
+ box action:[:aString | self withWaitCursorDo:aBlock value:aString].
+ box showAtPointer
+!
+
askAndBrowseMethodCategory:title action:aBlock
"convenient method: setup enterBox with initial being current method category"
@@ -1529,42 +1498,1461 @@
box showAtPointer
!
-listOfAllClassCategories
- "return a list of all class categories"
+classHierarchyDo:aBlock
+ "eavluate the 2-arg block for every class,
+ starting at Object; passing class and nesting level to the block."
+
+ |classes s classDict l|
+
+ classes := Smalltalk allClasses.
+ classDict := IdentityDictionary new:classes size.
+ classes do:[:aClass |
+ s := aClass superclass.
+ s notNil ifTrue:[
+ l := classDict at:s ifAbsent:[nil].
+ l isNil ifTrue:[
+ l := OrderedCollection new:5.
+ classDict at:s put:l
+ ].
+ l add:aClass
+ ]
+ ].
+ self classHierarchyOf:Object level:0 do:aBlock using:classDict
+!
+
+classHierarchyOf:aClass level:level do:aBlock using:aDictionary
+ "evaluate the 2-arg block for every subclass of aClass,
+ passing class and nesting level to the block."
+
+ |names subclasses|
+
+ aBlock value:aClass value:level.
+ subclasses := aDictionary at:aClass ifAbsent:[nil].
+ (subclasses size == 0) ifFalse:[
+ names := subclasses collect:[:class | class name].
+ names sortWith:subclasses.
+ subclasses do:[:aSubClass |
+ self classHierarchyOf:aSubClass level:(level + 1) do:aBlock using:aDictionary
+ ]
+ ]
+!
+
+compileCode:someCode
+ (ReadStream on:someCode) fileIn
+!
+
+extractClassAndSelectorFromSelectionInto:aBlock
+ "given a string which can be either 'class>>sel' or
+ 'class sel', extract className and selector, and call aBlock with
+ the result."
+
+ |sel clsName isMeta sep s|
+
+ sel := codeView selection.
+ sel notNil ifTrue:[
+ sel := sel asString withoutSeparators.
+ ('*>>*' match:sel) ifTrue:[
+ sep := $>
+ ] ifFalse:[
+ ('* *' match:sel) ifTrue:[
+ sep := Character space
+ ]
+ ].
+ sep notNil ifTrue:[
+ "
+ extract class/sel from selection
+ "
+ s := ReadStream on:sel.
+ clsName := s upTo:sep.
+ [s peek == sep] whileTrue:[s next].
+ sel := s upToEnd.
+
+ (clsName endsWith:'class') ifTrue:[
+ isMeta := true.
+ clsName := clsName copyTo:(clsName size - 5)
+ ] ifFalse:[
+ isMeta := false
+ ].
+ ]
+ ].
+ aBlock value:clsName value:sel value:isMeta
+
+
+!
+
+classesInHierarchy:aClass do:aBlock
+ |index|
+
+ index := (classListView list size).
+ aClass withAllSuperclasses do:[:c |
+ (classListView isInSelection:index) ifFalse:[
+ aBlock value:c
+ ].
+ index := index - 1
+ ]
+
+!
+
+askForMethodCategory
+ |someCategories box txt|
+
+ someCategories := actualClass categories sort.
+ box := self listBoxTitle:'accept in which method category ?' okText:'accept' list:someCategories.
+
+ lastMethodCategory isNil ifTrue:[
+ txt := 'new methods'
+ ] ifFalse:[
+ txt := lastMethodCategory
+ ].
+ box initialText:txt.
+ box action:[:aString |
+ ^ aString
+ ].
+ box showAtPointer.
+ ^ nil
+!
+
+warnLabel:what
+ "set the title for some warning"
+
+ self label:('System Browser WARNING: ' , what)
+!
+
+busyLabel:what with:someArgument
+ "set the title for some warning"
+
+ self label:('System Browser:' , (resources string:what with:someArgument))
+
+! !
+
+!SystemBrowser methodsFor:'method stuff'!
+
+updateMethodListWithScroll:scroll
+ |selectors scr first last|
+
+ methodListView notNil ifTrue:[
+ currentMethodCategory notNil ifTrue:[
+ fullProtocol ifTrue:[
+ selectors := self listOfAllSelectorsInCategory:currentMethodCategory
+ inFullProtocolHierarchyOfClass:actualClass
+ ] ifFalse:[
+ selectors := self listOfAllSelectorsInCategory:currentMethodCategory
+ ofClass:actualClass
+ ]
+ ].
+ scr := scroll.
+ first := methodListView firstLineShown.
+ first ~~ 1 ifTrue:[
+ last := methodListView lastLineShown.
+ selectors size <= (last - first + 1) ifTrue:[
+ scr := true
+ ]
+ ].
+ methodListView list = selectors ifFalse:[
+ scr ifTrue:[
+ methodListView contents:selectors
+ ] ifFalse:[
+ methodListView setContents:selectors
+ ]
+ ].
+ ]
+!
+
+methodSelectionChanged
+ "method selection has changed - update dependent views"
+
+ self withWaitCursorDo:[
+ |index cls|
+
+ self updateCodeView.
+ self setAcceptAndExplainActionsForMethod.
+
+ "
+ if there is any autoSearch string, do the search
+ "
+ autoSearch notNil ifTrue:[
+ codeView searchFwd:autoSearch ifAbsent:[]
+ ].
+
+ fullProtocol ifTrue:[
+ "
+ remove any bold attribute from classList
+ "
+ 1 to:classListView list size do:[:i |
+ classListView attributeAt:i remove:#bold.
+ ].
+ "
+ boldify the class where this method is implemented
+ "
+ currentMethod notNil ifTrue:[
+ cls := currentMethod who at:1.
+ index := classListView list indexOf:(cls name).
+ index ~~ 0 ifTrue:[
+ classListView attributeAt:index add:#bold.
+ ].
+ currentClass := cls.
+
+ ]
+ ].
+ ]
+!
+
+updateMethodList
+ self updateMethodListWithScroll:true
+!
+
+methodSelection:lineNr
+ "user clicked on a method line - show code"
+
+ |selectorString selectorSymbol index|
+
+ (fullProtocol not and:[currentClass isNil]) ifTrue:[^ self].
+
+ selectorString := methodListView selectionValue.
+ "
+ kludge: check if its a wrapped one
+ "
+ (selectorString endsWith:' !!') ifTrue:[
+ selectorString := selectorString copyTo:(selectorString size - 2)
+ ].
+ selectorSymbol := selectorString asSymbol.
+ fullProtocol ifTrue:[
+ currentMethod := currentSelector := nil.
+ "
+ search which class implements the selector
+ "
+ self classesInFullProtocolHierarchy:actualClass do:[:c |
+ (currentMethod isNil
+ and:[c implements:selectorSymbol]) ifTrue:[
+ currentSelector := selectorSymbol.
+ currentMethod := c compiledMethodAt:selectorSymbol.
+ ]
+ ]
+ ] ifFalse:[
+ currentSelector := selectorSymbol.
+ currentMethod := actualClass compiledMethodAt:selectorSymbol.
+ ].
+
+ methodCategoryListView notNil ifTrue:[
+ currentMethod notNil ifTrue:[
+ (currentMethodCategory = currentMethod category) ifFalse:[
+ currentMethodCategory := currentMethod category.
+ methodCategoryListView selectElement:currentMethodCategory
+ ]
+ ]
+ ].
+
+ self methodSelectionChanged
+!
+
+listOfAllSelectorsInCategory:aCategory ofClass:aClass
+ "answer a list of all selectors in a given method category
+ of the argument, aClass"
+
+ |newList searchCategory selector|
+
+ (aCategory = '* all *') ifTrue:[
+ newList := aClass selectorArray asOrderedCollection
+ ] ifFalse:[
+ (aCategory = '* no category *') ifTrue:[
+ searchCategory := nil
+ ] ifFalse:[
+ searchCategory := aCategory
+ ].
+ newList := OrderedCollection new.
+ aClass methodArray with:aClass selectorArray do:[:aMethod :selector |
+ |sel|
+
+ (aMethod category = searchCategory) ifTrue:[
+ aMethod isWrapped ifTrue:[
+ sel := selector , ' !!'
+ ] ifFalse:[
+ sel := selector
+ ].
+
+ "mhmh - can this happen ?"
+"/ (newList includes:sel) ifFalse:[
+ newList add:sel
+"/ ]
+ ]
+ ]
+ ].
+ (newList size == 0) ifTrue:[^ nil].
+ ^ newList sort
+!
+
+template
+ "return a method definition template"
+
+ ^
+'message selector and argument names
+ "comment stating purpose of message"
+
+
+ |temporaries|
+ statements
+
+
+"
+ change above template into real code.
+ Then ''accept'' either via the menu
+ or via the keyboard (usually CMD-A).
+
+ You do not need this template; you can also
+ select any existing methods code, change it,
+ and finally ''accept''.
+"
+'
+!
+
+listOfAllSelectorsInCategory:aCategory inFullProtocolHierarchyOfClass:aClass
+ "answer a list of all selectors in a given method category
+ of the argument, aClass and its superclasses.
+ Used with fullProtocol browsing."
+
+ |newList thisList searchCategory selector|
+
+ newList := Set new.
+ self classesInFullProtocolHierarchy:aClass do:[:c |
+ (aCategory = '* all *') ifTrue:[
+ newList addAll:(c selectorArray)
+ ] ifFalse:[
+ (aCategory = '* no category *') ifTrue:[
+ searchCategory := nil
+ ] ifFalse:[
+ searchCategory := aCategory
+ ].
+ c methodArray with:c selectorArray do:[:aMethod :selector |
+ (aMethod category = searchCategory) ifTrue:[
+ newList add:selector
+ ]
+ ]
+ ].
+ ].
+ (newList size == 0) ifTrue:[^ nil].
+ ^ newList asOrderedCollection sort
+!
+
+checkMethodSelected
+ currentMethod isNil ifTrue:[
+ self warn:'select a method first'.
+ ^ false
+ ].
+ ^ true
+!
+
+switchToMethodNamed:matchString
+ |aSelector method cat index classToSearch selectors|
+
+ currentClass notNil ifTrue:[
+ showInstance ifTrue:[
+ classToSearch := currentClass
+ ] ifFalse:[
+ classToSearch := currentClass class
+ ].
+ selectors := classToSearch selectorArray.
+
+ ((matchString ~= '*') and:[matchString includesMatchCharacters]) ifTrue:[
+ index := selectors findFirst:[:element | matchString match:element]
+ ] ifFalse:[
+ index := selectors indexOf:matchString
+ ].
+
+ (index ~~ 0) ifTrue:[
+ aSelector := selectors at:index.
+ method := classToSearch methodArray at:index.
+ cat := method category.
+ cat isNil ifTrue:[cat := '* all *'].
+ methodCategoryListView selectElement:cat.
+ currentMethodCategory := cat.
+ self methodCategorySelectionChanged.
+
+ currentMethod := classToSearch compiledMethodAt:aSelector.
+ currentMethod notNil ifTrue:[
+ currentSelector := aSelector.
+ methodListView selectElement:aSelector.
+ ].
+ self methodSelectionChanged
+ ]
+ ]
+!
+
+switchToAnyMethodNamed:aString
+ |aSelector classToStartSearch aClass nm|
+
+ aSelector := aString asSymbol.
+ currentClass isNil ifTrue:[
+ currentClassHierarchy notNil ifTrue:[
+ classToStartSearch := currentClassHierarchy
+ ]
+ ] ifFalse:[
+ classToStartSearch := currentClass
+ ].
+ classToStartSearch notNil ifTrue:[
+ showInstance ifFalse:[
+ classToStartSearch := classToStartSearch class
+ ].
+ aClass := classToStartSearch whichClassImplements:aSelector.
+ aClass notNil ifTrue:[
+ nm := aClass name.
+ showInstance ifFalse:[
+ ((nm ~= 'Metaclass') and:[nm endsWith:'class']) ifTrue:[
+ nm := nm copyTo:(nm size - 5)
+ ]
+ ].
+ self switchToClassNamed:nm.
+ self switchToMethodNamed:aString
+ ]
+ ]
+! !
+
+!SystemBrowser methodsFor:'misc'!
+
+updateCodeView
+ |code aStream|
+
+ fullClass ifTrue:[
+ currentClass notNil ifTrue:[
+ code := currentClass source.
+ ]
+ ] ifFalse:[
+ currentMethod notNil ifTrue:[
+ (codeView acceptAction isNil
+ and:[actualClass notNil
+ and:[currentMethodCategory notNil]]) ifTrue:[
+ self setAcceptAndExplainActionsForMethod.
+ ].
+
+ code := currentMethod source.
+
+ ]
+ ].
+ codeView contents:code.
+ codeView modified:false.
+
+ self normalLabel.
+
+
+!
+
+instanceProtocol
+ "switch to instance protocol"
+
+ showInstance ifFalse:[
+ self checkSelectionChangeAllowed ifTrue:[
+ classToggle turnOff.
+ instanceToggle turnOn.
+ showInstance := true.
+
+ (variableListView notNil
+ and:[variableListView hasSelection]) ifTrue:[
+ self unhilightMethodCategories.
+ self unhilightMethods.
+ variableListView deselect
+ ].
+
+ fullProtocol ifTrue:[
+ actualClass := currentClass.
+ self updateClassList.
+ self updateMethodCategoryListWithScroll:false.
+ self updateMethodListWithScroll:false.
+ self updateVariableList.
+ ^ self
+ ].
+ currentClass notNil ifTrue:[
+ self classSelectionChanged
+ ].
+ codeView modified:false.
+ ] ifFalse:[
+ instanceToggle turnOff.
+ classToggle turnOn
+ ]
+ ]
+!
+
+classProtocol
+ "switch to class protocol"
+
+ showInstance ifTrue:[
+ self checkSelectionChangeAllowed ifTrue:[
+ instanceToggle turnOff.
+ classToggle turnOn.
+ showInstance := false.
+
+ (variableListView notNil
+ and:[variableListView hasSelection]) ifTrue:[
+ self unhilightMethodCategories.
+ self unhilightMethods.
+ variableListView deselect
+ ].
+
+ fullProtocol ifTrue:[
+ actualClass := currentClass class.
+ self updateClassList.
+ self updateMethodCategoryListWithScroll:false.
+ self updateMethodListWithScroll:false.
+ self updateVariableList.
+ ^ self
+ ].
+ currentClass notNil ifTrue:[
+ self classSelectionChanged
+ ].
+ codeView modified:false.
+ ] ifFalse:[
+ instanceToggle turnOn.
+ classToggle turnOff
+ ]
+ ]
+! !
+
+!SystemBrowser methodsFor:'method category stuff'!
+
+updateMethodCategoryListWithScroll:scroll
+ |categories|
+
+ methodCategoryListView notNil ifTrue:[
+ fullProtocol ifTrue:[
+ currentClassHierarchy notNil ifTrue:[
+ categories := self listOfAllMethodCategoriesInFullProtocolHierarchy:currentClassHierarchy
+ ]
+ ] ifFalse:[
+ currentClass notNil ifTrue:[
+ categories := self listOfAllMethodCategoriesInClass:actualClass
+ ]
+ ].
+ methodCategoryListView list = categories ifFalse:[
+ scroll ifTrue:[
+ methodCategoryListView contents:categories
+ ] ifFalse:[
+ methodCategoryListView setContents:categories
+ ].
+ currentMethodCategory notNil ifTrue:[
+ methodCategoryListView selectElement:currentMethodCategory
+ ]
+ ]
+ ]
+!
+
+listOfAllMethodCategoriesInClass:aClass
+ "answer a list of all method categories of the argument, aClass"
|newList cat|
- newList := Text with:'* all *' with:'* hierarchy *'.
- Smalltalk allBehaviorsDo:[:aClass |
- cat := aClass category.
+ newList := Text new.
+ aClass methodArray do:[:aMethod |
+ cat := aMethod category.
cat isNil ifTrue:[
cat := '* no category *'
].
- newList indexOf:cat ifAbsent:[newList add:cat]
+ (newList includes:cat) ifFalse:[newList add:cat]
+ ].
+ (newList size == 0) ifTrue:[^ nil].
+ newList add:'* all *'.
+ ^ newList sort
+!
+
+methodCategorySelection:lineNr
+ "user clicked on a method category line - show selectors"
+
+ |oldSelector|
+
+ oldSelector := currentSelector.
+
+ (fullProtocol not and:[currentClass isNil]) ifTrue:[^ self].
+
+ currentMethodCategory := methodCategoryListView selectionValue.
+ self methodCategorySelectionChanged.
+
+ "if there is only one method, show it right away"
+ methodListView list size == 1 ifTrue:[
+ methodListView selection:1.
+ self methodSelection:1
+ ] ifFalse:[
+ oldSelector notNil ifTrue:[
+ methodListView selectElement:oldSelector.
+ methodListView selection notNil ifTrue:[
+ self methodSelection:methodListView selection.
+ ]
+ ]
+ ]
+
+!
+
+updateMethodCategoryList
+ self updateMethodCategoryListWithScroll:true
+!
+
+methodCategorySelectionChanged
+ "method category selection has changed - update dependant views"
+
+ self withWaitCursorDo:[
+ currentMethod := currentSelector := nil.
+
+ self updateMethodList.
+ self updateCodeView.
+
+ currentMethodCategory notNil ifTrue:[
+ methodCategoryListView selectElement:currentMethodCategory
+ ].
+
+ self setAcceptAndExplainActionsForMethod.
+ self hilightMethodsInMethodCategoryList:false inMethodList:true.
+ ]
+!
+
+listOfAllMethodCategoriesInFullProtocolHierarchy:aClass
+ "answer a list of all method categories of the argument, aClass,
+ and all of its superclasses.
+ Used with fullProtocol browsing."
+
+ |newList cat|
+
+ newList := Text new.
+ self classesInFullProtocolHierarchy:aClass do:[:c |
+ c methodArray do:[:aMethod |
+ cat := aMethod category.
+ cat isNil ifTrue:[
+ cat := '* no category *'
+ ].
+ (newList includes:cat) ifFalse:[newList add:cat]
+ ]
+ ].
+ (newList size == 0) ifTrue:[^ nil].
+ newList add:'* all *'.
+ ^ newList sort
+
+!
+
+checkMethodCategorySelected
+ currentMethodCategory isNil ifTrue:[
+ self warn:'select a method category first'.
+ ^ false
+ ].
+ ^ true
+!
+
+whenMethodCategorySelected:aBlock
+ self checkMethodCategorySelected ifTrue:[
+ self withWaitCursorDo:aBlock
+ ]
+!
+
+copyMethodsFromClass:aClassName
+ |class box|
+
+ currentClass notNil ifTrue:[
+ Symbol hasInterned:aClassName ifTrue:[:sym |
+ (Smalltalk includesKey:sym) ifTrue:[
+ class := Smalltalk at:sym
+ ].
+ ].
+ class isBehavior ifFalse:[
+ self warn:'no class named %1' with:aClassName.
+ ^ self
+ ].
+
+ showInstance ifFalse:[
+ class := class class
+ ].
+
+ "show enterbox for category to copy from"
+
+ box := self enterBoxTitle:'name of category to copy from (matchpattern allowed, * for all):'
+ okText:'copy'.
+ box action:[:aString | self copyMethodsFromClass:class category:aString].
+ box showAtPointer.
+ ]
+!
+
+copyMethodsFromClass:class category:category
+ |source|
+
+ currentClass notNil ifTrue:[
+"/ codeView abortAction:[^ self].
+ Object abortSignal catch:[
+ class methodArray do:[:aMethod |
+ (category match:aMethod category) ifTrue:[
+ source := aMethod source.
+ codeView contents:source.
+ codeView modified:false.
+ actualClass compiler compile:source
+ forClass:actualClass
+ inCategory:aMethod category
+ notifying:codeView.
+ self updateMethodCategoryListWithScroll:false.
+ self updateMethodListWithScroll:false.
+ ]
+ ]
+ ]
+ ]
+!
+
+newMethodCategory:aString
+ |categories|
+
+ currentClass isNil ifTrue:[
+ ^ self warn:'select/create a class first'.
+ ].
+ categories := methodCategoryListView list.
+ categories isNil ifTrue:[categories := Text new].
+ (categories includes:aString) ifFalse:[
+ categories add:aString.
+ categories sort.
+ methodCategoryListView contents:categories
+ ].
+ currentMethodCategory := aString.
+ self methodCategorySelectionChanged
+! !
+
+!SystemBrowser methodsFor:'initialize / release'!
+
+initialize
+ super initialize.
+
+ self icon:(Form fromFile:(resources at:'ICON_FILE' default:'SBrowser.xbm')
+ resolution:100).
+
+ showInstance := true.
+ fullClass := false.
+ fullProtocol := false.
+ aspect := nil.
+
+ "inform me, when Smalltalk changes"
+ Smalltalk addDependent:self
+!
+
+realize
+ |v checkBlock|
+
+ super realize.
+
+ checkBlock := [:lineNr | self checkSelectionChangeAllowed].
+
+ v := classCategoryListView.
+ v notNil ifTrue:[
+ v action:[:lineNr | self classCategorySelection:lineNr].
+ v selectConditionBlock:checkBlock.
+ v ignoreReselect:false.
+ v contents:(self listOfAllClassCategories).
+ self initializeClassCategoryMenu
+ ].
+
+ v := classListView.
+ v notNil ifTrue:[
+ v action:[:lineNr | self classSelection:lineNr].
+ v selectConditionBlock:checkBlock.
+ v ignoreReselect:false.
+ self initializeClassMenu
+ ].
+
+ v := methodCategoryListView.
+ v notNil ifTrue:[
+ v action:[:lineNr | self methodCategorySelection:lineNr].
+ v selectConditionBlock:checkBlock.
+ v ignoreReselect:false.
+ self initializeMethodCategoryMenu
+ ].
+
+ v := methodListView.
+ v notNil ifTrue:[
+ v action:[:lineNr | self methodSelection:lineNr].
+ v selectConditionBlock:checkBlock.
+ v ignoreReselect:false.
+ self initializeMethodMenu
+ ].
+
+ v := classMethodListView.
+ v notNil ifTrue:[
+ v action:[:lineNr | self classMethodSelection:lineNr].
+ v selectConditionBlock:checkBlock.
+ v ignoreReselect:false.
+ self initializeClassMethodMenu
+ ].
+
+ v := variableListView.
+ v notNil ifTrue:[
+ v action:[:lineNr | self variableSelection:lineNr].
+ v ignoreReselect:false.
+ v toggleSelect:true
+ ]
+
+!
+
+terminate
+ (self checkSelectionChangeAllowed) ifTrue:[
+ super terminate
+ ]
+!
+
+destroy
+ "relese dependant - destroy popups"
+
+ Smalltalk removeDependent:self.
+ currentClass notNil ifTrue:[
+ currentClass removeDependent:self.
+ currentClass := nil
+ ].
+ super destroy
+!
+
+autoSearch:aString
+ "used with class-method list browsing. If true,
+ selecting an entry from the list will automatically
+ search for the searchstring in the codeView"
+
+ self setSearchPattern:aString.
+ autoSearch := aString
+!
+
+title:someString
+ myLabel := someString.
+ self label:someString.
+
+! !
+
+!SystemBrowser methodsFor:'initialize subviews'!
+
+createClassListViewIn:frame
+ "setup the classlist subview, with its toggles"
+
+ |v panel oldStyle|
+
+ self createTogglesIn:frame.
+
+"/ oldStyle := true.
+oldStyle := false.
+ oldStyle ifTrue:[
+ v := ScrollableView for:SelectionInListView in:frame.
+ v origin:(0.0 @ 0.0)
+ extent:[frame width
+ @
+ (frame height
+ - (ViewSpacing // 2)
+ - instanceToggle height
+ - instanceToggle borderWidth
+ + v borderWidth)].
+
+ classListView := v scrolledView
+ ] ifFalse:[
+ panel := VariableVerticalPanel
+ origin:(0.0 @ 0.0)
+ corner:[frame width
+ @
+ (frame height
+ - (ViewSpacing // 2)
+ - instanceToggle height
+ - instanceToggle borderWidth
+ + v borderWidth)]
+ in:frame.
+
+ v := ScrollableView for:SelectionInListView in:panel.
+ v origin:(0.0 @ 0.0) corner:(1.0 @ 0.7).
+ classListView := v scrolledView.
+
+
+ v := ScrollableView for:SelectionInListView in:panel.
+ v origin:(0.0 @ 0.7)
+ corner:(1.0 @ 1.0).
+
+ variableListView := v scrolledView
+ ]
+!
+
+createCodeViewIn:aView at:relY
+ "setup the code view"
+ |v|
+
+ v := HVScrollableView for:CodeView miniScrollerH:true miniScrollerV:false in:aView.
+ v origin:(0.0 @ relY) corner:(1.0 @ 1.0).
+ codeView := v scrolledView
+!
+
+createTogglesIn:aFrame
+ "create and setup the class/instance toggles"
+
+ |halfSpacing h classAction instanceAction|
+
+ classAction := [self classProtocol].
+ instanceAction := [self instanceProtocol].
+
+ instanceToggle := Toggle label:(resources at:'instance') in:aFrame.
+ h := instanceToggle height.
+ instanceToggle origin:(0.0 @ 1.0) corner:(0.5 @ 1.0).
+ instanceToggle topInset:(h negated).
+
+ instanceToggle turnOn.
+ instanceToggle pressAction:instanceAction.
+ instanceToggle releaseAction:classAction.
+
+ classToggle := Toggle label:(resources at:'class') in:aFrame.
+ h := classToggle height.
+ classToggle origin:(0.5 @ 1.0) corner:(1.0 @ 1.0).
+ classToggle topInset:(h negated).
+
+ classToggle turnOff.
+ classToggle pressAction:classAction.
+ classToggle releaseAction:instanceAction.
+
+ StyleSheet is3D ifTrue:[
+ instanceToggle leftInset:(ViewSpacing // 2).
+ classToggle leftInset:(ViewSpacing // 2).
+ instanceToggle rightInset:ViewSpacing - (ViewSpacing // 2).
+ classToggle rightInset:ViewSpacing - (ViewSpacing // 2).
].
- newList sort.
- ^ newList
-!
-
-listOfClassHierarchyOf:aClass
- "return a hierarchy class-list"
-
- ^ (aClass allSuperclasses reverse ,
- (Array with:aClass),
- aClass allSubclassesInOrder) collect:[:c | c name]
-
+!
+
+createCodeViewIn:aView
+ "setup the code view"
+
+ ^ self createCodeViewIn:aView at:0.25
+!
+
+setupForList:aList
+ "setup subviews to browse methods from a list"
+
+ |vpanel v|
+
+ vpanel := VariableVerticalPanel
+ origin:(0.0 @ 0.0)
+ corner:(1.0 @ 1.0)
+ in:self.
+
+ v := ScrollableView for:SelectionInListView in:vpanel.
+ v origin:(0.0 @ 0.0) corner:(1.0 @ 0.25).
+ classMethodListView := v scrolledView.
+ classMethodListView contents:aList.
+
+ self createCodeViewIn:vpanel.
+ self updateCodeView
+!
+
+setupForAll
+ "create subviews for a full browser"
+
+ |vpanel hpanel frame v|
+
+ vpanel := VariableVerticalPanel origin:(0.0 @ 0.0) corner:(1.0 @ 1.0)
+ in:self.
+ hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
+
+ v := HVScrollableView for:SelectionInListView
+ miniScrollerH:true miniScrollerV:false
+ in:hpanel.
+ v origin:(0.0 @ 0.0) corner:(0.25 @ 1.0).
+ classCategoryListView := v scrolledView.
+
+ frame := View origin:(0.25 @ 0.0) corner:(0.5 @ 1.0) in:hpanel.
+ self createClassListViewIn:frame.
+
+ v := HVScrollableView for:SelectionInListView miniScrollerH:true miniScrollerV:false in:hpanel.
+ v origin:(0.5 @ 0.0) corner:(0.75 @ 1.0).
+ methodCategoryListView := v scrolledView.
+
+ v := HVScrollableView for:SelectionInListView miniScrollerH:true miniScrollerV:false in:hpanel.
+ v origin:(0.75 @ 0.0) corner:(1.0 @ 1.0).
+ methodListView := v scrolledView.
+
+ self createCodeViewIn:vpanel
+!
+
+setupForClassHierarchy:aClass
+ "setup subviews to browse a class hierarchy"
+
+ |vpanel hpanel frame v|
+
+ vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
+ corner:(1.0 @ 1.0)
+ in:self.
+
+ "
+ notice: we use a different ratio here
+ "
+ hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.4) in:vpanel.
+ frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
+
+ self createClassListViewIn:frame.
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
+ methodCategoryListView := v scrolledView.
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.66 @ 0.0) corner:(1.0 @ 1.0).
+ methodListView := v scrolledView.
+
+ self createCodeViewIn:vpanel at:0.4.
+
+ currentClassHierarchy := aClass.
+ self updateClassList.
+ self updateMethodCategoryList.
+ self updateMethodList.
+ self updateCodeView
+!
+
+setupForFullClass
+ "setup subviews to browse a class as full text"
+
+ |vpanel hpanel v|
+
+ vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
+ corner:(1.0 @ 1.0)
+ in:self.
+
+ hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.0 @ 0.0) corner:(0.5 @ 1.0).
+ classCategoryListView := v scrolledView.
+ classCategoryListView contents:(self listOfAllClassCategories).
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.5 @ 0.0) corner:(1.0 @ 1.0).
+ classListView := v scrolledView.
+
+ self createCodeViewIn:vpanel.
+
+ fullClass := true.
+ self updateCodeView
+!
+
+setupForClass:aClass
+ "create subviews for browsing a single class"
+
+ |vpanel hpanel frame v|
+
+ vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
+ corner:(1.0 @ 1.0)
+ in:self.
+
+ hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
+ frame := View origin:(0.0 @ 0.0) corner:(0.5 @ 1.0)in:hpanel.
+
+ self createTogglesIn:frame.
+
+ v := ScrollableView for:SelectionInListView in:frame.
+ v origin:(0.0 @ 0.0)
+ extent:[frame width
+ @
+ (frame height
+ - (ViewSpacing // 2)
+ - instanceToggle height
+ - instanceToggle borderWidth
+ + v borderWidth)].
+ methodCategoryListView := v scrolledView.
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.5 @ 0.0) corner:(1.0 @ 1.0).
+ methodListView := v scrolledView.
+
+ self createCodeViewIn:vpanel.
+
+ self switchToClass:aClass.
+ actualClass := aClass.
+ self updateMethodCategoryList.
+ self updateMethodList.
+ self updateCodeView
+!
+
+setupForClassCategory:aClassCategory
+ "setup subviews to browse a class category"
+
+ |vpanel hpanel frame v|
+
+ vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
+ corner:(1.0 @ 1.0)
+ in:self.
+
+ hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
+ frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
+
+ self createClassListViewIn:frame.
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
+ methodCategoryListView := v scrolledView.
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.66 @ 0.0) corner:(1.0 @ 1.0).
+ methodListView := v scrolledView.
+
+ self createCodeViewIn:vpanel.
+
+ currentClassCategory := aClassCategory.
+ self updateClassList.
+ self updateMethodCategoryList.
+ self updateMethodList.
+ self updateCodeView
+!
+
+setupForClass:aClass selector:selector
+ "setup subviews to browse a single method"
+
+ |v|
+
+ v := ScrollableView for:CodeView in:self.
+ v origin:(0.0 @ 0.0) corner:(1.0 @ 1.0).
+ codeView := v scrolledView.
+
+ currentClassCategory := aClass category.
+ self switchToClass:aClass.
+ actualClass := aClass.
+ currentSelector := selector.
+ currentMethod := currentClass compiledMethodAt:selector.
+ currentMethodCategory := currentMethod category.
+ self updateCodeView
+!
+
+setupForClassList:aList
+ "setup subviews to browse classes from a list"
+
+ |vpanel hpanel frame l v|
+
+ vpanel := VariableVerticalPanel
+ origin:(0.0 @ 0.0) corner:(1.0 @ 1.0) in:self.
+
+ hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
+ frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
+
+ self createClassListViewIn:frame.
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
+ methodCategoryListView := v scrolledView.
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.66 @ 0.0) corner:(1.0 @ 1.0).
+ methodListView := v scrolledView.
+
+ self createCodeViewIn:vpanel.
+
+ l := aList collect:[:entry | entry name].
+ classListView list:(l sort).
+
+ self updateMethodCategoryList.
+ self updateMethodList.
+ self updateCodeView
+!
+
+setupForClass:aClass methodCategory:aMethodCategory
+ "setup subviews to browse a method category"
+
+ |vpanel v|
+
+ vpanel := VariableVerticalPanel
+ origin:(0.0 @ 0.0) corner:(1.0 @ 1.0)
+ in:self.
+
+ v := ScrollableView for:SelectionInListView in:vpanel.
+ v origin:(0.0 @ 0.0) corner:(1.0 @ 0.25).
+ methodListView := v scrolledView.
+
+ self createCodeViewIn:vpanel.
+
+ currentClassCategory := aClass category.
+ self switchToClass:aClass.
+ actualClass := aClass.
+ currentMethodCategory := aMethodCategory.
+ self updateMethodList.
+ self updateCodeView
+!
+
+setupForFullClassProtocol:aClass
+ "setup subviews to browse a classes full protocol"
+
+ |vpanel hpanel frame v|
+
+ vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
+ corner:(1.0 @ 1.0)
+ in:self.
+
+ "
+ notice: we use a different ratio here
+ "
+ hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.4) in:vpanel.
+ frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
+
+ self createClassListViewIn:frame.
+ classListView multipleSelectOk:true.
+ classListView toggleSelect:true.
+ classListView strikeOut:true.
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
+ methodCategoryListView := v scrolledView.
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.66 @ 0.0) corner:(1.0 @ 1.0).
+ methodListView := v scrolledView.
+
+ self createCodeViewIn:vpanel at:0.4.
+
+ currentClassHierarchy := actualClass := currentClass := aClass.
+ fullProtocol := true.
+
+ self updateClassList.
+ self updateMethodCategoryList.
+ self updateMethodList.
+ self updateCodeView.
+ self updateVariableList.
+
+!
+
+setupForFullClassHierarchy:aClass
+ "setup subviews to browse a class hierarchy"
+
+ |vpanel hpanel frame v|
+
+ vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
+ corner:(1.0 @ 1.0)
+ in:self.
+
+ hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.4) in:vpanel.
+ frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
+
+ self createClassListViewIn:frame.
+ classListView multipleSelectOk:true.
+ classListView toggleSelect:true.
+ classListView strikeOut:true.
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
+ methodCategoryListView := v scrolledView.
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.66 @ 0.0) corner:(1.0 @ 1.0).
+ methodListView := v scrolledView.
+
+"/ self setupActions.
+ self createCodeViewIn:vpanel at:0.4.
+
+ currentClassHierarchy := actualClass := aClass.
+ fullProtocol := true.
+
+ self updateClassList.
+ self updateMethodCategoryList.
+ self updateMethodList.
+ self updateCodeView.
+ self updateVariableList.
+
+! !
+
+!SystemBrowser methodsFor:'unused'!
+
+listOfAllSelectorsInCategory:aCategory inHierarchyOfClass:aClass
+ "answer a list of all selectors in a given method category
+ of the argument, aClass and its superclasses"
+
+ |newList thisList searchCategory selector|
+
+ newList := Set new.
+ self classesInHierarchy:aClass do:[:c |
+ (aCategory = '* all *') ifTrue:[
+ newList addAll:(c selectorArray)
+ ] ifFalse:[
+ (aCategory = '* no category *') ifTrue:[
+ searchCategory := nil
+ ] ifFalse:[
+ searchCategory := aCategory
+ ].
+ c methodArray with:c selectorArray do:[:aMethod :selector |
+ (aMethod category = searchCategory) ifTrue:[
+ newList add:selector
+ ]
+ ]
+ ].
+ ].
+ (newList size == 0) ifTrue:[^ nil].
+ ^ newList asOrderedCollection sort
+!
+
+listOfAllMethodCategoriesInHierarchy:aClass
+ "answer a list of all method categories of the argument, aClass,
+ and all of its superclasses"
+
+ |newList cat|
+
+ newList := Text new.
+ self classesInHierarchy:aClass do:[:c |
+ c methodArray do:[:aMethod |
+ cat := aMethod category.
+ cat isNil ifTrue:[
+ cat := '* no category *'
+ ].
+ (newList includes:cat) ifFalse:[newList add:cat]
+ ]
+ ].
+ (newList size == 0) ifTrue:[^ nil].
+ newList add:'* all *'.
+ ^ newList sort
+
+! !
+
+!SystemBrowser methodsFor:'class stuff'!
+
+switchToClass:newClass
+ fullProtocol ifTrue:[^ self].
+ currentClass notNil ifTrue:[
+ currentClass removeDependent:self
+ ].
+ currentClass := newClass.
+ currentClass notNil ifTrue:[
+ currentClass addDependent:self.
+ ].
+ self normalLabel
+!
+
+classSelectionChanged
+ |oldMethodCategory oldMethod oldSelector|
+
+ self withWaitCursorDo:[
+ oldMethodCategory := currentMethodCategory.
+ oldMethod := currentMethod.
+ oldSelector := currentSelector.
+
+ showInstance ifTrue:[
+ actualClass := currentClass
+ ] ifFalse:[
+ actualClass := currentClass class
+ ].
+ currentMethodCategory := nil.
+ currentMethod := nil.
+ currentSelector := nil.
+
+ self updateVariableList.
+ self updateMethodCategoryList.
+
+ oldMethodCategory notNil ifTrue:[
+ methodCategoryListView selectElement:oldMethodCategory.
+ methodCategoryListView selection notNil ifTrue:[
+ currentMethodCategory := oldMethodCategory.
+ self methodCategorySelectionChanged
+ ]
+ ].
+ self updateMethodList.
+ self updateCodeView.
+
+ fullClass ifTrue:[
+ codeView acceptAction:[:theCode |
+ codeView cursor:Cursor execute.
+ Object abortSignal catch:[
+ self compileCode:theCode asString.
+ codeView modified:false.
+ ].
+ codeView cursor:Cursor normal.
+ ].
+ ] ifFalse:[
+ self classDefinition.
+ codeView acceptAction:[:theCode |
+ codeView cursor:Cursor execute.
+ Object abortSignal catch:[
+ (Compiler evaluate:theCode asString notifying:codeView)
+ isBehavior ifTrue:[
+ self classCategoryUpdate.
+ self updateClassListWithScroll:false.
+ codeView modified:false.
+ ].
+ ].
+ codeView cursor:Cursor normal.
+ ].
+ ].
+ codeView explainAction:nil.
+
+ classCategoryListView notNil ifTrue:[
+ (currentClassCategory = currentClass category) ifFalse:[
+ currentClassCategory := currentClass category.
+ classCategoryListView selectElement:currentClassCategory
+ ]
+ ].
+
+ "set self for doits. This allows accessing the current class
+ as self, and access to the class variables by name.
+ "
+ codeView doItAction:[:theCode |
+ |compiler|
+
+ currentClass isNil ifTrue:[
+ compiler := Compiler
+ ] ifFalse:[
+ compiler := currentClass compiler
+ ].
+ compiler
+ evaluate:theCode
+ in:nil
+ receiver:currentClass
+ notifying:codeView
+ logged:false
+ ifFail:nil
+ ].
+ ]
+!
+
+updateClassListWithScroll:scroll
+ |classes oldClassName|
+
+ classListView notNil ifTrue:[
+ "
+ refetch in case we are not up to date
+ "
+ (currentClass notNil and:[fullProtocol not]) ifTrue:[
+ oldClassName := currentClass name.
+ currentClass := Smalltalk at:(oldClassName asSymbol).
+ ].
+
+ currentClassCategory notNil ifTrue:[
+ classes := self listOfAllClassesInCategory:currentClassCategory
+ ] ifFalse:[
+ currentClassHierarchy notNil ifTrue:[
+ classes := self listOfClassHierarchyOf:currentClassHierarchy
+ ]
+ ].
+
+ classListView list = classes ifFalse:[
+ scroll ifTrue:[
+ classListView contents:classes
+ ] ifFalse:[
+ classListView setContents:classes
+ ].
+ oldClassName notNil ifTrue:[
+ classListView setContents:classes.
+ classListView selectElement:oldClassName
+ ] ifFalse:[
+ variableListView notNil ifTrue:[variableListView contents:nil]
+ ]
+ ].
+ scroll ifTrue:[
+ fullProtocol ifTrue:[
+ classListView scrollToBottom
+ ]
+ ]
+ ]
+!
+
+classSelection:lineNr
+ "user clicked on a class line - show method categories"
+
+ |classSymbol cls oldSelector|
+
+ (currentClassHierarchy notNil
+ and:[fullProtocol]) ifTrue:[
+ oldSelector := currentSelector.
+
+ self updateMethodCategoryListWithScroll:false.
+ self updateMethodListWithScroll:false.
+ self updateVariableList.
+ ^ self
+ ].
+
+ cls := Smalltalk classNamed:classListView selectionValue withoutSpaces.
"
- |newList theClass|
-
- theClass := aClass.
- newList := Text with:theClass name.
- [theClass ~~ Object] whileTrue:[
- theClass := theClass superclass.
- newList add:theClass name
+ classSymbol := classListView selectionValue withoutSpaces asSymbol.
+ (Smalltalk includesKey:classSymbol) ifTrue:[
+ cls := Smalltalk at:classSymbol
].
- newList reverse.
- ^ newList
"
+ cls notNil ifTrue:[
+ self switchToClass:cls.
+ self classSelectionChanged
+ ]
!
listOfAllClassesInCategory:aCategory
@@ -1609,94 +2997,40 @@
^ newList sort
!
-classHierarchyDo:aBlock
- "eavluate the 2-arg block for every class,
- starting at Object; passing class and nesting level to the block."
-
- |classes s classDict l|
-
- classes := Smalltalk allClasses.
- classDict := IdentityDictionary new:classes size.
- classes do:[:aClass |
- s := aClass superclass.
- s notNil ifTrue:[
- l := classDict at:s ifAbsent:[nil].
- l isNil ifTrue:[
- l := OrderedCollection new:5.
- classDict at:s put:l
- ].
- l add:aClass
- ]
- ].
- self classHierarchyOf:Object level:0 do:aBlock using:classDict
-!
-
-classHierarchyOf:aClass level:level do:aBlock using:aDictionary
- "evaluate the 2-arg block for every subclass of aClass,
- passing class and nesting level to the block."
-
- |names subclasses|
-
- aBlock value:aClass value:level.
- subclasses := aDictionary at:aClass ifAbsent:[nil].
- (subclasses size == 0) ifFalse:[
- names := subclasses collect:[:class | class name].
- names sortWith:subclasses.
- subclasses do:[:aSubClass |
- self classHierarchyOf:aSubClass level:(level + 1) do:aBlock using:aDictionary
- ]
+doClassMenu:aBlock
+ "a helper - check if class is selected and evaluate aBlock
+ while showing waitCursor"
+
+ self checkClassSelected ifTrue:[
+ self withWaitCursorDo:aBlock
]
!
-listOfAllMethodCategoriesInClass:aClass
- "answer a list of all method categories of the argument, aClass"
-
- |newList cat|
-
- newList := Text new.
- aClass methodArray do:[:aMethod |
- cat := aMethod category.
- cat isNil ifTrue:[
- cat := '* no category *'
- ].
- (newList includes:cat) ifFalse:[newList add:cat]
+checkClassSelected
+ "warn and return false, if no class is selected"
+
+ currentClass isNil ifTrue:[
+ self warn:'select a class first'.
+ ^ false
].
- (newList size == 0) ifTrue:[^ nil].
- newList add:'* all *'.
- ^ newList sort
-!
-
-listOfAllSelectorsInCategory:aCategory ofClass:aClass
- "answer a list of all selectors in a given method category
- of the argument, aClass"
-
- |newList searchCategory selector|
-
- (aCategory = '* all *') ifTrue:[
- newList := aClass selectorArray asText
- ] ifFalse:[
- (aCategory = '* no category *') ifTrue:[
- searchCategory := nil
- ] ifFalse:[
- searchCategory := aCategory
- ].
- newList := Text new.
- aClass methodArray do:[:aMethod |
- (aMethod category = searchCategory) ifTrue:[
- selector := aClass selectorForMethod:aMethod.
- selector notNil ifTrue:[
- aMethod isWrapped ifTrue:[
- selector := selector , ' !!'
- ].
- (newList includes:selector) ifFalse:[
- newList add:selector
- ]
- ]
- ]
- ]
+ ^ true
+!
+
+updateClassList
+ self updateClassListWithScroll:true
+!
+
+listOfClassHierarchyOf:aClass
+ "return a hierarchy class-list"
+
+ |classes|
+
+ classes := aClass allSuperclasses reverse , (Array with:aClass).
+ fullProtocol ifFalse:[
+ classes := classes , aClass allSubclassesInOrder
].
- (newList size == 0) ifTrue:[^ nil].
- ^ newList sort
+ ^ classes collect:[:c | c name]
+
!
templateFor:className in:cat
@@ -1717,822 +3051,119 @@
poolDictionaries: ''''
category: '''.
- cat notNil ifTrue:[
- aString := aString , cat
- ].
- aString := aString , ''''.
- ^ aString
-!
-
-template
- "return a method definition template"
-
- ^
-'message selector and argument names
- "comment stating purpose of message"
-
-
- |temporaries|
- statements
-'
-!
-
-compileCode:someCode
- (ReadStream on:someCode) fileIn
-! !
-
-!SystemBrowser methodsFor:'user interaction'!
-
-instanceProtocol
- showInstance ifFalse:[
- self checkSelectionChangeAllowed ifTrue:[
- classToggle turnOff.
- instanceToggle turnOn.
- showInstance := true.
- currentClass notNil ifTrue:[
- self classSelectionChanged
- ].
- codeView modified:false.
- ] ifFalse:[
- instanceToggle turnOff.
- classToggle turnOn
- ]
- ]
-!
-
-classProtocol
- showInstance ifTrue:[
- self checkSelectionChangeAllowed ifTrue:[
- instanceToggle turnOff.
- classToggle turnOn.
- showInstance := false.
- currentClass notNil ifTrue:[
- self classSelectionChanged
- ].
- codeView modified:false.
- ] ifFalse:[
- instanceToggle turnOn.
- classToggle turnOff
- ]
- ]
-!
-
-updateClassCategoryListWithScroll:scroll
- |oldClassCategory oldClass oldMethodCategory oldMethod
- oldSelector newCategoryList|
-
- classMethodListView notNil ifTrue:[ ^ self ].
-
- oldClassCategory := currentClassCategory.
- oldClass := currentClass.
- oldMethodCategory := currentMethodCategory.
- oldMethod := currentMethod.
- oldMethod notNil ifTrue:[
- oldSelector := methodListView selectionValue
+ cat notNil ifTrue:[
+ aString := aString , cat
].
-
- 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)
- ]
+ 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
].
- oldMethodCategory notNil ifTrue:[
- methodCategoryListView notNil ifTrue:[
- methodCategoryListView selectElement:oldMethodCategory
- ].
- ].
- oldSelector notNil ifTrue:[
- methodListView notNil ifTrue:[
- methodListView selectElement:oldSelector
- ].
- ]
-!
-
-updateClassCategoryList
- self updateClassCategoryListWithScroll:true
-!
-
-updateClassListWithScroll:scroll
- |classes oldClassName|
-
- classListView notNil ifTrue:[
- currentClass notNil ifTrue:[
- oldClassName := currentClass name.
- currentClass := Smalltalk at:(oldClassName asSymbol).
- ].
-
- currentClassCategory notNil ifTrue:[
- classes := self listOfAllClassesInCategory:currentClassCategory
- ] ifFalse:[
- currentClassHierarchy notNil ifTrue:[
- classes := self listOfClassHierarchyOf:currentClassHierarchy
+
+ codeView contents:(self templateFor:name in:cat).
+ codeView modified:false.
+
+ codeView acceptAction:[:theCode |
+ codeView cursor:Cursor execute.
+ Object abortSignal catch:[
+ |cls|
+
+ cls := (Compiler evaluate:theCode asString notifying:codeView).
+ cls isBehavior ifTrue:[
+ codeView modified:false.
+ self classCategoryUpdate.
+ self updateClassListWithScroll:false.
+ self switchToClassNamed:(cls name).
]
].
-
- 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]
- ]
- ]
- ]
-!
-
-updateClassList
- self updateClassListWithScroll:true
-!
-
-updateVariableList
- |l subList flags last|
-
- variableListView isNil ifTrue:[^ self].
-
- l := OrderedCollection new.
- actualClass withAllSuperclasses do:[:aClass |
- subList := aClass instVarNames.
- subList size ~~ 0 ifTrue:[
- l := l , (subList asOrderedCollection reverse).
- l := l , (OrderedCollection with:'---- ' , aClass name , ' ---------').
- ]
- ].
- l reverse.
- variableListView attributes:nil.
- variableListView list:l.
- l keysAndValuesDo:[:index :entry |
- (entry startsWith:'---') ifTrue:[
- variableListView attributeAt:index put:#halfIntensity.
- last := index
- ]
+ codeView cursor:(Cursor normal).
].
- last notNil ifTrue:[variableListView scrollToLine:last]
-!
-
-updateMethodCategoryListWithScroll:scroll
- |categories|
-
- methodCategoryListView notNil ifTrue:[
- currentClass notNil ifTrue:[
- categories := self listOfAllMethodCategoriesInClass:actualClass
- ].
- methodCategoryListView list = categories ifFalse:[
- scroll ifTrue:[
- methodCategoryListView contents:categories
- ] ifFalse:[
- methodCategoryListView setContents:categories
- ].
- currentMethodCategory notNil ifTrue:[
- methodCategoryListView selectElement:currentMethodCategory
- ]
- ]
- ]
-!
-
-updateMethodCategoryList
- self updateMethodCategoryListWithScroll:true
-!
-
-updateMethodListWithScroll:scroll
- |selectors scr first last|
-
- methodListView notNil ifTrue:[
- currentMethodCategory notNil ifTrue:[
- selectors := self listOfAllSelectorsInCategory:currentMethodCategory
- ofClass:actualClass
- ].
- scr := scroll.
- first := methodListView firstLineShown.
- first ~~ 1 ifTrue:[
- last := methodListView lastLineShown.
- selectors size <= (last - first + 1) ifTrue:[
- scr := true
- ]
- ].
- methodListView list = selectors ifFalse:[
- scr ifTrue:[
- methodListView contents:selectors
- ] ifFalse:[
- methodListView setContents:selectors
- ]
- ].
- ]
-!
-
-updateMethodList
- self updateMethodListWithScroll:true
-!
-
-updateCodeView
- |code aStream|
-
- fullClass ifTrue:[
- currentClass notNil ifTrue:[
-" this is too slow for big classes ...
- code := String new:1000.
- aStream := WriteStream on:code.
- currentClass fileOutOn:aStream
+ codeView explainAction:nil.
+ self switchToClass:nil
+!
+
+renameCurrentClassTo:aString
+ "helper - do the rename"
+
+ self doClassMenu:[
+ |oldName oldSym newSym|
+
+ oldName := currentClass name.
+ oldSym := oldName asSymbol.
"
- aStream := FileStream newFileNamed:'__temp'.
- aStream isNil ifTrue:[
- self notify:'cannot create temporary file.'.
- codeView contents:nil.
- codeView modified:false.
- ^ self
- ].
- currentClass fileOutOn:aStream.
- aStream close.
- aStream := FileStream oldFileNamed:'__temp'.
- aStream isNil ifTrue:[
- self notify:'oops - cannot reopen temp file'.
- codeView contents:nil.
- codeView modified:false.
- ^ self
- ].
- code := aStream contents.
- aStream close.
- OperatingSystem removeFile:'__temp'
- ]
- ] ifFalse:[
- currentMethod notNil ifTrue:[
- code := currentMethod source
- ]
- ].
- codeView contents:code.
- codeView modified:false
-!
-
-classSelectionChanged
- |oldMethodCategory oldMethod|
-
- self withWaitCursorDo:[
- oldMethodCategory := currentMethodCategory.
- oldMethod := currentMethod.
-
- showInstance ifTrue:[
- actualClass := currentClass
- ] ifFalse:[
- actualClass := currentClass class
- ].
- currentMethodCategory := nil.
- currentMethod := nil.
-
- self updateVariableList.
- self updateMethodCategoryList.
- oldMethodCategory notNil ifTrue:[
- methodCategoryListView selectElement:oldMethodCategory.
- methodCategoryListView selection notNil ifTrue:[
- currentMethodCategory := oldMethodCategory.
- self methodCategorySelectionChanged
- ]
- ].
- self updateMethodList.
- self updateCodeView.
-
- fullClass ifTrue:[
- codeView acceptAction:[:theCode |
- codeView cursor:Cursor execute.
- Object abortSignal catch:[
- self compileCode:theCode asString.
- codeView modified:false.
- ].
- codeView cursor:Cursor normal.
- ].
- codeView explainAction:nil
- ] ifFalse:[
- self classDefinition.
- codeView acceptAction:[:theCode |
- codeView cursor:Cursor execute.
- Object abortSignal catch:[
- (Compiler evaluate:theCode asString notifying:codeView)
- isBehavior ifTrue:[
- self classCategoryUpdate.
- self updateClassListWithScroll:false.
- codeView modified:false.
- ].
- ].
- codeView cursor:Cursor normal.
- ].
- codeView explainAction:nil
- ].
- classCategoryListView notNil ifTrue:[
- (currentClassCategory = currentClass category) ifFalse:[
- currentClassCategory := currentClass category.
- classCategoryListView selectElement:currentClassCategory
- ]
- ].
-
- "set self for doits. This allows accessing the current class
- as self, and access to the class variables by name."
-
- codeView doItAction:[:theCode |
- |compiler|
-
- currentClass isNil ifTrue:[
- compiler := Compiler
- ] ifFalse:[
- compiler := currentClass compiler
- ].
- compiler
- evaluate:theCode
- in:nil
- receiver:currentClass
- notifying:codeView
- logged:false
- ifFail:nil
- ]
- ]
-!
-
-classCategorySelectionChanged
- "class category has changed - update dependant views"
-
- self withWaitCursorDo:[
- self switchToClass:nil.
- actualClass := nil.
- currentMethodCategory := nil.
- currentMethod := nil.
+ 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 updateMethodCategoryList.
- self updateMethodList.
- self updateCodeView.
-
- codeView explainAction:nil.
- codeView acceptAction:nil
- ]
-!
-
-classCategorySelection:lineNr
- "user clicked on a class category line - show classes.
- If switching to hierarchy or all, keep current selections"
-
- |newCategory oldClass classIndex index|
-
- newCategory := classCategoryListView selectionValue.
- (newCategory startsWith:'*') ifTrue:[
- "etiher all or hierarchy;
- remember current selections and switch after showing class list"
- oldClass := currentClass
- ].
- currentClassCategory := newCategory.
- oldClass isNil ifTrue:[
- self classCategorySelectionChanged
- ] ifFalse:[
+ self updateMethodCategoryListWithScroll:false.
+ self updateMethodListWithScroll:false.
self withWaitCursorDo:[
- self updateClassList
- ].
- "stupid - search for class name in (indented) list"
- index := 1.
- classListView list do:[:elem |
- (elem endsWith:(oldClass name)) ifTrue:[
- classIndex := index
- ].
- index := index + 1
- ].
- classIndex notNil ifTrue:[
- classListView selection:classIndex.
- self switchToClass:(Smalltalk at:(oldClass name asSymbol))
- ] ifFalse:[
- self normalLabel.
- ]
- ]
-!
-
-classSelection:lineNr
- "user clicked on a class line - show method categories"
-
- |classSymbol cls|
-
- classSymbol := classListView selectionValue withoutSpaces asSymbol.
- (Smalltalk includesKey:classSymbol) ifTrue:[
- cls := Smalltalk at:classSymbol
- ].
- cls notNil ifTrue:[
- self switchToClass:cls.
- self classSelectionChanged
- ]
-!
-
-methodCategorySelectionChanged
- "method category selection has changed - update dependant views"
-
- self withWaitCursorDo:[
- currentMethod := nil.
-
- self updateMethodList.
- self updateCodeView.
-
- currentMethodCategory notNil ifTrue:[
- methodCategoryListView selectElement:currentMethodCategory
- ].
-
- codeView acceptAction:[:theCode |
- codeView cursor:Cursor execute.
- Object abortSignal catch:[
- actualClass compiler compile:theCode asString
- forClass:actualClass
- inCategory:currentMethodCategory
- notifying:codeView.
- codeView modified:false.
- self updateMethodListWithScroll:false.
- ].
- codeView cursor:Cursor normal.
- ].
- codeView explainAction:[:theCode :theSelection |
- self showExplanation:(Explainer explain:theSelection
- in:theCode
- forClass:actualClass)
- ]
- ]
-!
-
-methodCategorySelection:lineNr
- "user clicked on a method category line - show selectors"
-
- currentClass isNil ifTrue:[^ self].
-
- currentMethodCategory := methodCategoryListView selectionValue.
- self methodCategorySelectionChanged
-!
-
-methodSelectionChanged
- "method selection has changed - update dependant views"
-
- self withWaitCursorDo:[
- self updateCodeView.
- codeView acceptAction:[:theCode |
- codeView cursor:Cursor execute.
- Object abortSignal catch:[
- actualClass compiler compile:theCode asString
- forClass:actualClass
- inCategory:currentMethodCategory
- notifying:codeView.
- codeView modified:false.
- self updateMethodListWithScroll:false.
- ].
- codeView cursor:Cursor normal.
- ].
- codeView explainAction:[:theCode :theSelection |
- self showExplanation:(Explainer explain:theSelection
- in:theCode
- forClass:actualClass)
- ].
- methodListView notNil ifTrue:[
- (currentMethod notNil and:[currentMethod isWrapped]) ifTrue:[
- self initializeMethodMenu2
- ] ifFalse:[
- self initializeMethodMenu
- ]
+ Transcript showCr:('searching for users of ' , oldSym); endEntry.
+ self class browseReferendsOf:oldSym warnIfNone:false
]
]
!
-methodSelection:lineNr
- "user clicked on a method line - show code"
-
- |selectorString selectorSymbol|
-
- currentClass isNil ifTrue:[^ self].
-
- selectorString := methodListView selectionValue.
- "
- kludge: check if its a wrapped one
- "
- (selectorString endsWith:' !!') ifTrue:[
- selectorString := selectorString copyTo:(selectorString size - 2)
- ].
- selectorSymbol := selectorString asSymbol.
- currentMethod := actualClass compiledMethodAt:selectorSymbol.
-
- methodCategoryListView notNil ifTrue:[
- currentMethod notNil ifTrue:[
- (currentMethodCategory = currentMethod category) ifFalse:[
- currentMethodCategory := currentMethod category.
- methodCategoryListView selectElement:currentMethodCategory
- ]
- ]
- ].
-
- self methodSelectionChanged
-!
-
-classFromClassMethodString:aString
- "helper for classMethod-list - extract class name from the string"
-
- |pos|
-
- pos := aString indexOf:(Character space).
- ^ aString copyTo:(pos - 1)
-!
-
-selectorFromClassMethodString:aString
- "helper for classMethod-list - extract selector from the string"
-
- |pos|
-
- pos := aString indexOf:(Character space).
- ^ aString copyFrom:(pos + 1)
-!
-
-listSelection:lineNr
- "user clicked on a class/method line - show code"
-
- |string classString selectorString|
-
- string := classMethodListView selectionValue.
- classString := self classFromClassMethodString:string.
- selectorString := self selectorFromClassMethodString:string.
- ((classString ~= 'Metaclass') and:[classString endsWith:'class']) ifTrue:[
- classString := classString copyTo:(classString size - 5).
- self switchToClass:(Smalltalk at:classString asSymbol).
- actualClass := currentClass class
- ] ifFalse:[
- self switchToClass:(Smalltalk at:classString asSymbol).
- actualClass := currentClass
- ].
- currentClass isNil ifTrue:[
- self warn:'oops class is gone'
- ] ifFalse:[
- currentClassCategory := currentClass category.
- currentMethod := actualClass compiledMethodAt:(selectorString asSymbol).
- currentMethodCategory := currentMethod category.
-
- self methodSelectionChanged
- ]
-! !
-
-!SystemBrowser methodsFor:'class category menu'!
-
-initializeClassCategoryMenu
- |labels|
-
- labels := resources array:#(
- 'fileOut'
- 'fileOut each'
-"
- 'fileOut binary'
-"
- 'printOut'
- 'printOut protocol'
- '-'
- 'SPAWN_CATEGORY'
- 'spawn full class'
- '-'
- 'update'
- 'find class ...'
- '-'
- 'new class category ...'
- 'rename ...'
- 'remove').
-
- classCategoryListView
- middleButtonMenu:(PopUpMenu
- labels:labels
- selectors:#(classCategoryFileOut
- classCategoryFileOutEach
- classCategoryPrintOut
- classCategoryPrintOutProtocol
- nil
- classCategorySpawn
- classCategorySpawnFullClass
- nil
- classCategoryUpdate
- classCategoryFindClass
- nil
- classCategoryNewCategory
- classCategoryRename
- classCategoryRemove)
- receiver:self
- for:classCategoryListView)
-!
-
-allClassesInCurrentCategoryInOrderDo:aBlock
- "evaluate aBlock for all classes in the current class category;
- superclasses come first - then subclasses"
-
- |classes|
-
- currentClassCategory notNil ifTrue:[
- classes := OrderedCollection new.
- Smalltalk allClassesDo:[:aClass |
- aClass isMeta ifFalse:[
- (aClass category = currentClassCategory) ifTrue:[
- classes add:aClass
- ]
- ]
- ].
- classes topologicalSort:[:a :b | b isSubclassOf:a].
- classes do:aBlock
- ]
-!
-
-allClassesInCurrentCategoryDo:aBlock
- "evaluate aBlock for all classes in the current class category;
- superclasses come first - then subclasses"
-
- currentClassCategory notNil ifTrue:[
- Smalltalk allClassesDo:[:aClass |
- aClass isMeta ifFalse:[
- (aClass category = currentClassCategory) ifTrue:[
- aBlock value:aClass
- ]
- ]
- ].
- ]
-!
-
-classCategoryUpdate
- "update class category list and dependants"
-
- |oldClassName oldMethodCategory|
-
- classCategoryListView notNil ifTrue:[
- currentClass notNil ifTrue:[
- oldClassName := currentClass name.
- (oldClassName endsWith:'-old') ifTrue:[
- oldClassName := oldClassName copyTo:(oldClassName size - 4)
- ]
- ].
- oldMethodCategory := currentMethodCategory.
-
- classCategoryListView setContents:(self listOfAllClassCategories).
- currentClassCategory notNil ifTrue:[
- classCategoryListView selectElement:currentClassCategory.
- self classCategorySelectionChanged.
- oldClassName notNil ifTrue:[
- classListView selectElement:oldClassName.
- self switchToClass:(Smalltalk at:oldClassName asSymbol).
- self classSelectionChanged.
- oldMethodCategory notNil ifTrue:[
- methodCategoryListView selectElement:oldMethodCategory.
- currentMethodCategory := oldMethodCategory.
- self methodCategorySelectionChanged
- ]
- ]
- ]
- ]
-!
-
-classCategoryPrintOutProtocol
- |printStream|
-
- self allClassesInCurrentCategoryInOrderDo:[:aClass |
- printStream := Printer new.
- aClass printOutProtocolOn:printStream.
- printStream close
- ]
-!
-
-classCategoryPrintOut
- |printStream|
-
- self allClassesInCurrentCategoryDo:[:aClass |
- printStream := Printer new.
- aClass printOutOn:printStream.
- printStream close
- ]
-!
-
-classCategoryFileOut
- "create a file 'categoryName' consisting of all classes in current category"
-
- |aStream fileName|
-
- 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 label:('System Browser writing: ' , fileName).
- self allClassesInCurrentCategoryInOrderDo:[:aClass |
- aClass fileOutOn:aStream.
- ].
- aStream close.
- self normalLabel.
- ]
-!
-
-classCategoryFileOutEach
- self withWaitCursorDo:[
- self allClassesInCurrentCategoryDo:[:aClass |
- self label:('System Browser saving: ' , aClass name).
- Class fileOutErrorSignal handle:[:ex |
- self warn:'cannot create: %1' with:ex parameter.
- ex return.
- ] do:[
- aClass fileOut
- ]
- ].
- self normalLabel.
- ]
-!
-
-classCategorySpawn
- "create a new SystemBrowser browsing current classCategory"
-
- currentClassCategory notNil ifTrue:[
- self withWaitCursorDo:[
- self class browseClassCategory:currentClassCategory
- ]
- ]
-!
-
-classCategorySpawnFullClass
- "create a new SystemBrowser browsing full class"
-
- |newBrowser|
-
- self withWaitCursorDo:[
- newBrowser := self class browseFullClasses
-"
- .
- currentClass notNil ifTrue:[
- newBrowser switchToClassNamed:(currentClass name)
- ]
-"
- ]
-!
-
-classCategoryNewCategory
- |box|
-
- box := self enterBoxTitle:'name of new class category:' okText:'create'.
- box action:[:aString |
- |categories|
-
- categories := classCategoryListView list.
- (categories includes:aString) ifFalse:[
- categories add:aString.
- categories sort.
- classCategoryListView setContents:categories.
- currentClassCategory := aString.
- classCategoryListView selectElement:aString.
- self switchToClass:nil.
- actualClass := nil.
- self classCategorySelectionChanged
- ]
- ].
- box showAtPointer
-!
-
switchToClassNamed:aString
- |classSymbol theClass|
+ |classSymbol theClass newCat|
+
+ aString knownAsSymbol ifFalse:[^ self].
classSymbol := aString asSymbol.
theClass := Smalltalk at:classSymbol.
theClass isBehavior ifTrue:[
classCategoryListView notNil ifTrue:[
currentClassHierarchy isNil ifTrue:[
- (theClass category ~~ currentClassCategory) ifTrue:[
- currentClassCategory := theClass category.
- currentClassCategory isNil ifTrue:[
+ ((newCat := theClass category) ~= currentClassCategory) ifTrue:[
+ currentClassCategory := newCat.
+ newCat isNil ifTrue:[
classCategoryListView selectElement:'* no category *'
] ifFalse:[
- classCategoryListView selectElement:currentClassCategory
+ classCategoryListView selectElement:newCat.
].
- self classCategorySelectionChanged
+ "/ classCategoryListView makeSelectionVisible.
]
]
].
+ self updateClassList.
self switchToClass:theClass.
classListView selectElement:aString.
self classSelectionChanged
@@ -2559,130 +3190,274 @@
list:classNames sort.
box action:[:aString | self switchToClassNamed:aString].
box showAtPointer
-!
-
-classCategoryFindClass
- |box|
-
- box := self enterBoxForCodeSelectionTitle:'class to find:' okText:'find'.
- box action:[:aString | self switchToClassNameMatching:aString].
- box showAtPointer
-!
-
-renameCurrentClassCategoryTo:aString
- "helper - do the rename"
-
- |any categories|
-
- currentClassCategory notNil ifTrue:[
- any := false.
- Smalltalk allBehaviorsDo:[:aClass |
- aClass category = currentClassCategory ifTrue:[
- aClass category:aString.
- any := true
- ]
- ].
- any ifFalse:[
- categories := classCategoryListView list.
- categories remove:currentClassCategory.
- categories add:aString.
- categories sort.
- classCategoryListView setContents:categories.
- currentClassCategory := aString.
- classCategoryListView selectElement:aString.
- ] ifTrue:[
- currentClassCategory := aString.
- self updateClassCategoryList.
- self updateClassListWithScroll:false
- ]
- ]
-!
-
-classCategoryRename
- "launch an enterBox to rename current class category"
-
- |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
- ]
+! !
+
+!SystemBrowser methodsFor:'variable stuff'!
+
+updateVariableList
+ |l subList flags last nameAccessSelector class oldSelection|
+
+ variableListView isNil ifTrue:[^ self].
+
+ oldSelection := variableListView selectionValue.
+
+ l := OrderedCollection new.
+ "
+ show classVars, if classProtocol is shown (instead of classInstance vars)
+ "
+ showInstance ifTrue:[
+ nameAccessSelector := #instVarNames
+ ] ifFalse:[
+ nameAccessSelector := #classVarNames
].
- subclassesRemoved := OrderedCollection new.
- classesToRemove do:[:aClass |
- aClass allSubclassesDo:[:aSubclass |
- (classesToRemove includes:aSubclass) ifFalse:[
- (subclassesRemoved includes:aSubclass) ifFalse:[
- subclassesRemoved add:aSubclass
- ]
+
+ class := currentClass notNil ifTrue:[currentClass] ifFalse:[actualClass].
+ class isNil ifTrue:[class := currentClassHierarchy].
+ class withAllSuperclasses do:[:aClass |
+ |ignore|
+
+ ignore := fullProtocol
+ and:[classListView valueIsInSelection:(aClass name asString)].
+ ignore ifFalse:[
+ subList := aClass perform:nameAccessSelector.
+ subList size ~~ 0 ifTrue:[
+ l := l , (subList asOrderedCollection reverse).
+ l := l , (OrderedCollection with:'---- ' , aClass name , ' ---------').
]
]
].
-
- 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
+ l reverse.
+ variableListView setAttributes:nil.
+ variableListView list:l.
+ l keysAndValuesDo:[:index :entry |
+ (entry startsWith:'---') ifTrue:[
+ variableListView attributeAt:index put:#disabled.
+ last := index
+ ]
].
-
- 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
+ last notNil ifTrue:[variableListView scrollToLine:last].
+
+ oldSelection notNil ifTrue:[
+ variableListView selectElement:oldSelection
+ ]
+!
+
+unhilightMethods
+ "unhighlight items in method list"
+
+ variableListView isNil ifTrue:[^ self].
+
+ methodListView notNil ifTrue:[
+ 1 to:methodListView list size do:[:entry |
+ methodListView attributeAt:entry put:nil.
+ ].
].
- 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 |
- Smalltalk removeClass:aClass
+
+!
+
+hilightMethodsInMethodCategoryList:inCat inMethodList:inMethods
+ "search for methods which access the selected
+ variable, and highlight them"
+
+ |name idx redefinedSelectors|
+
+ variableListView isNil ifTrue:[^ self].
+
+ inCat ifTrue:[self unhilightMethodCategories].
+ inMethods ifTrue:[self unhilightMethods].
+
+ actualClass isNil ifTrue:[^ self].
+ (methodCategoryListView isNil
+ and:[methodListView isNil]) ifTrue:[^ self].
+
+ name := variableListView selectionValue.
+ name isNil ifTrue:[^ self].
+
+ self withCursor:(Cursor questionMark) do:[
+ |classes filter any|
+
+ classes := Array with:currentClass.
+ currentClassHierarchy notNil ifTrue:[
+ fullProtocol ifTrue:[
+ ].
+ classes := classes , currentClass allSuperclasses.
+ redefinedSelectors := IdentitySet new.
+ ].
+ showInstance ifTrue:[
+ filter := self class filterToSearchInstRefsTo:name modificationsOnly:false
+ ] ifFalse:[
+ filter := self class filterToSearchClassRefsTo:name modificationsOnly:false
+ ].
+
+ any := false.
+ "
+ highlight the method that ref this variable
+ "
+ classes do:[:someClass |
+ someClass methodArray with:someClass selectorArray
+ do:[:method :selector |
+
+ (inCat
+ or:[methodListView list notNil
+ and:[methodListView list includes:selector]])
+ ifTrue:[
+ (redefinedSelectors isNil
+ or:[(redefinedSelectors includes:selector) not])
+ ifTrue:[
+ (filter value:someClass value:method value:selector) ifTrue:[
+ |idx cat|
+
+ (inCat
+ and:[methodCategoryListView notNil
+ and:[methodCategoryListView list notNil]]) ifTrue:[
+ cat := method category.
+ "
+ highlight the methodCategory
+ "
+ idx := methodCategoryListView list indexOf:cat.
+ idx ~~ 0 ifTrue:[
+ methodCategoryListView attributeAt:idx put:#bold.
+ ].
+ ].
+
+ (inMethods
+ and:[methodListView notNil
+ and:[methodListView list notNil]]) ifTrue:[
+ "
+ highlight the method
+ "
+ idx := methodListView list indexOf:selector.
+ idx ~~ 0 ifTrue:[
+ methodListView attributeAt:idx put:#bold.
+ ].
+ any := true
+ ].
+ ].
+ redefinedSelectors notNil ifTrue:[
+ redefinedSelectors add:selector
+ ]
+ ]
+ ]
+ ]
].
- classesToRemove do:[:aClass |
- Smalltalk removeClass:aClass
+ any ifTrue:[
+ self setSearchPattern:name
+ ]
+ ]
+
+
+!
+
+hilightMethodsInMethodCategoryList
+ "search for methods which access the selected
+ variable, and highlight them"
+
+ self hilightMethodsInMethodCategoryList:true inMethodList:false
+
+
+
+!
+
+unhilightMethodCategories
+ "unhighlight items in method list"
+
+ variableListView isNil ifTrue:[^ self].
+
+ methodCategoryListView notNil ifTrue:[
+ 1 to:methodCategoryListView list size do:[:entry |
+ methodCategoryListView attributeAt:entry put:nil.
+ ]
+ ].
+
+
+!
+
+hilightMethodsInMethodList
+ "search for methods which access the selected
+ variable, and highlight them"
+
+ self hilightMethodsInMethodCategoryList:false inMethodList:true
+
+
+
+! !
+
+!SystemBrowser methodsFor:'class list menu'!
+
+classDefinition
+ "show class definition in codeView and setup accept-action for
+ a class-definition change.
+ Extract documentation either from a documentation method or
+ from the comment - not a biggy, but beginners will like
+ it when exploring the system."
+
+ self doClassMenu:[
+ |m s aStream isComment|
+
+ aStream := WriteStream on:(String new:200).
+ currentClass fileOutDefinitionOn:aStream.
+
+ currentClass isLoaded ifTrue:[
+ "
+ add documentation as a comment, if there is any
+ "
+ m := currentClass class compiledMethodAt:#documentation.
+ m notNil ifTrue:[
+ s := m comment.
+ isComment := false.
+ ] ifFalse:[
+ "try comment"
+ s := currentClass comment.
+ s notNil ifTrue:[
+ isComment := true
+ ]
+ ].
].
- currentClassCategory := nil.
- self switchToClass:nil.
- Smalltalk changed
+ s notNil ifTrue:[
+ aStream cr.
+ aStream cr.
+ aStream cr.
+ aStream cr.
+ aStream cr.
+ aStream nextPut:$" ; cr; nextPutAll:' Documentation:'; cr.
+ aStream cr.
+ aStream nextPutAll:s.
+ aStream cr; cr.
+ aStream nextPutAll:' Notice: '; cr.
+ aStream nextPutAll:' the above string has been extracted from the classes '.
+ aStream nextPutAll:(isComment ifTrue:['comment.'] ifFalse:['documentation method.']).
+ aStream cr.
+ aStream nextPutAll:' It will not preserved when accepting a new class definition.'; cr.
+ aStream nextPut:$".
+ ].
+
+ codeView contents:(aStream contents).
+ codeView modified:false.
+ codeView acceptAction:[:theCode |
+ codeView cursor:Cursor execute.
+ Object abortSignal catch:[
+ (Compiler evaluate:theCode asString notifying:codeView)
+ isBehavior ifTrue:[
+ codeView modified:false.
+ self classCategoryUpdate.
+ self updateClassListWithScroll:false.
+ ]
+ ].
+ codeView cursor:Cursor normal.
+ ].
+ codeView explainAction:nil.
+
+ methodListView notNil ifTrue:[
+ methodListView deselect
+ ].
+ aspect := #definition.
+ self normalLabel
]
-! !
-
-!SystemBrowser methodsFor:'class menu'!
+!
initializeClassMenu
- |labels menu varMenu|
+ |labels menu|
labels := resources array:#(
'fileOut'
@@ -2691,6 +3466,7 @@
" 'printOut full protocol' "
'-'
'SPAWN_CLASS'
+ 'spawn full protocol'
'spawn hierarchy'
'spawn subclasses'
'-'
@@ -2715,6 +3491,7 @@
" classPrintOutFullProtocol "
nil
classSpawn
+ classSpawnFullProtocol
classSpawnHierarchy
classSpawnSubclasses
nil
@@ -2734,90 +3511,31 @@
receiver:self
for:classListView.
- classListView middleButtonMenu:menu.
-
- 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:#(
- classInstVarRefs
- classClassVarRefs
- classAllInstVarRefs
- classAllClassVarRefs
- nil
- classInstVarMods
- classClassVarMods
- classAllInstVarMods
- classAllClassVarMods
- )
- receiver:self
- for:self).
-
- variableListView isNil ifTrue:[
- menu addLabel:(resources string:'variable search')
- selector:#variables
- before:#classRefs.
- menu subMenuAt:#variables put:varMenu.
- ] ifFalse:[
- variableListView middleButtonMenu:varMenu
- ].
-!
-
-checkClassCategorySelected
- currentClassCategory isNil ifTrue:[
- self warn:'select a class category first'.
- ^ false
+ fullProtocol ifFalse:[
+ classListView middleButtonMenu:menu.
].
- ^ true
-!
-
-checkClassSelected
- currentClass isNil ifTrue:[
- self warn:'select a class first'.
- ^ false
- ].
- ^ true
-!
-
-checkMethodCategorySelected
- currentMethodCategory isNil ifTrue:[
- self warn:'select a method category first'.
- ^ false
- ].
- ^ true
-!
-
-whenMethodCategorySelected:aBlock
- self checkMethodCategorySelected ifTrue:[
- self withWaitCursorDo:aBlock
+
+ self initializeVariableListMenu.
+
+!
+
+classFileOut
+ "fileOut the current class.
+ Catch errors (sure, you like to know if it failed) and
+ warn if any)"
+
+ self doClassMenu:[
+ self busyLabel:'saving %1' with:currentClass name.
+ Class fileOutErrorSignal handle:[:ex |
+ self warn:'cannot create: %1' with:ex parameter.
+ ex return.
+ ] do:[
+ currentClass fileOut.
+ ].
+ self normalLabel.
]
!
-checkMethodSelected
- currentMethod isNil ifTrue:[
- self warn:'select a method first'.
- ^ false
- ].
- ^ true
-!
-
-doClassMenu:aBlock
- "a helper - check if class is selected and evaluate aBlock
- while showing waitCursor"
-
- self checkClassSelected ifTrue:[
- self withWaitCursorDo:aBlock
- ]
-!
-
doClassMenuWithSelection:aBlock
"a helper - if there is a selection, which represents a classes name,
evaluate aBlock, passing that class and optional selector as arguments.
@@ -2828,18 +3546,27 @@
string := codeView selection.
string notNil 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
- ].
+ 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:[
- sel := Parser selectorInExpression:string.
isMeta ifTrue:[
cls := cls class
].
@@ -2853,7 +3580,13 @@
].
].
- self doClassMenu:[aBlock value:currentClass value:nil]
+ classMethodListView notNil ifTrue:[
+ sel := classMethodListView selectionValue.
+ sel notNil ifTrue:[
+ sel := self selectorFromClassMethodString:sel
+ ]
+ ].
+ self doClassMenu:[aBlock value:currentClass value:sel]
!
classSpawn
@@ -2865,7 +3598,7 @@
self doClassMenuWithSelection:[:cls :sel |
cls isMeta ifTrue:[
- Smalltalk allClassesDo:[:aClass |
+ Smalltalk allBehaviorsDo:[:aClass |
aClass class == cls ifTrue:[
browser := self class browseClass:aClass.
browser classProtocol.
@@ -2944,19 +3677,6 @@
]
!
-classFileOut
- self doClassMenu:[
- self label:('System Browser saving: ' , currentClass name).
- Class fileOutErrorSignal handle:[:ex |
- self warn:'cannot create: %1' with:ex parameter.
- ex return.
- ] do:[
- currentClass fileOut.
- ].
- self normalLabel.
- ]
-!
-
classHierarchy
"show current classes hierarchy in codeView"
@@ -2972,44 +3692,28 @@
methodListView notNil ifTrue:[
methodListView deselect
].
- aspect := #hierarchy
+ aspect := #hierarchy.
+ self normalLabel
]
!
-classDefinition
- "show class definition in codeView and setup accept-action for
- class-definition change"
-
- |aStream|
-
- self doClassMenu:[
- aStream := WriteStream on:(String new:200).
- currentClass fileOutDefinitionOn:aStream.
- codeView contents:(aStream contents).
- codeView modified:false.
- codeView acceptAction:[:theCode |
- codeView cursor:Cursor execute.
- Object abortSignal catch:[
- (Compiler evaluate:theCode asString notifying:codeView)
- isBehavior ifTrue:[
- codeView modified:false.
- self classCategoryUpdate.
- self updateClassListWithScroll:false.
- ]
- ].
- codeView cursor:Cursor normal.
- ].
- codeView explainAction:nil.
- methodListView notNil ifTrue:[
- methodListView deselect
- ].
- aspect := #definition
- ]
+classNewClass
+ "create a class-definition prototype in codeview"
+
+ |nm|
+
+ currentClass notNil ifTrue:[
+ nm := currentClass superclass name
+ ] ifFalse:[
+ nm := 'Object'
+ ].
+ self classClassDefinitionTemplateFor:nm in:currentClassCategory.
+ aspect := nil.
!
classClassInstVars
"show class instance variables in codeView and setup accept-action
- for class-instvar-definition change"
+ for a class-instvar-definition change"
|s|
@@ -3030,7 +3734,17 @@
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
]
!
@@ -3038,136 +3752,6 @@
^ self
!
-classComment
- "show the classes comment in the codeView"
-
- self doClassMenu:[
- codeView contents:(currentClass comment).
- codeView modified:false.
- codeView acceptAction:[:theCode |
- Object abortSignal catch:[
- currentClass comment:theCode asString.
- codeView modified:false.
- ]
- ].
- codeView explainAction:nil.
- methodListView notNil ifTrue:[
- methodListView deselect
- ].
- aspect := #comment
- ]
-!
-
-classRefs
- self doClassMenu:[
- self withCursor:(Cursor questionMark) do:[
- self class browseReferendsOf:currentClass name asSymbol
- ]
- ]
-!
-
-classClassDefinitionTemplateFor:name in:cat
- "common helper for newClass and newSubclass
- - show a template to define class name in category cat"
-
- currentMethodCategory := nil.
- currentMethod := nil.
-
- classListView deselect.
-
- fullClass ifFalse:[
- methodCategoryListView contents:nil.
- methodListView contents:nil
- ].
-
- codeView contents:(self templateFor:name in:cat).
- codeView modified:false.
-
- codeView acceptAction:[:theCode |
- codeView cursor:Cursor execute.
- Object abortSignal catch:[
- |cl|
-
- cl := (Compiler evaluate:theCode asString notifying:codeView).
- cl isBehavior ifTrue:[
- codeView modified:false.
- self classCategoryUpdate.
- self updateClassListWithScroll:false.
- self switchToClassNamed:(cl name)
- ]
- ].
- codeView cursor:(Cursor normal).
- ].
- codeView explainAction:nil.
- self switchToClass:nil
-!
-
-classNewClass
- "create a class-definition prototype in codeview"
-
- |nm|
-
- currentClass notNil ifTrue:[
- nm := currentClass superclass name
- ] ifFalse:[
- nm := 'Object'
- ].
- self classClassDefinitionTemplateFor:nm in:currentClassCategory.
- aspect := nil
-!
-
-classNewSubclass
- "create a subclass-definition prototype in codeview"
-
- self doClassMenu:[
- self classClassDefinitionTemplateFor:(currentClass name)
- in:(currentClass category).
- aspect := nil
- ]
-!
-
-renameCurrentClassTo:aString
- "helper - do the rename"
-
- self doClassMenu:[
- |oldName oldSym newSym|
-
- oldName := currentClass name.
- oldSym := oldName asSymbol.
-"
- currentClass setName:aString.
- newSym := aString asSymbol.
- Smalltalk at:oldSym put:nil.
- Smalltalk removeKey:oldSym.
- Smalltalk at:newSym put:currentClass.
-"
-"
- currentClass renameTo:aString.
-"
- Smalltalk renameClass:currentClass to:aString.
-
- self updateClassList.
- self updateMethodCategoryListWithScroll:false.
- self updateMethodListWithScroll:false.
- self withWaitCursorDo:[
- Transcript showCr:('searching for users of ' , oldSym); endEntry.
- self class browseReferendsOf:oldSym warnIfNone:false
- ]
- ]
-!
-
-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
-!
-
classRemove
"user requested remove of current class and all subclasses -
count subclasses and let user confirm removal."
@@ -3193,10 +3777,23 @@
and all subclasses
"
self doClassMenu:[
+ "
+ query ?
+ "
currentClass allSubclassesDo:[:aSubClass |
- Smalltalk removeClass:aSubClass
+ (CheckForInstancesWhenRemovingClasses not
+ or:[aSubClass hasInstances not
+ or:[self confirm:(aSubClass name , ' has instances - remove anyway ?')]])
+ ifTrue:[
+ Smalltalk removeClass:aSubClass
+ ]
].
- Smalltalk removeClass:currentClass.
+ (CheckForInstancesWhenRemovingClasses not
+ or:[currentClass hasInstances not
+ or:[self confirm:(currentClass name , ' has instances - remove anyway ?')]])
+ ifTrue:[
+ Smalltalk removeClass:currentClass.
+ ].
self switchToClass:nil.
Smalltalk changed.
@@ -3215,145 +3812,636 @@
]
]
]
+!
+
+classComment
+ "show the classes comment in the codeView.
+ Also, set acceptaction to change the comment."
+
+ self doClassMenu:[
+ codeView contents:(currentClass comment).
+ codeView modified:false.
+ codeView acceptAction:[:theCode |
+ Object abortSignal catch:[
+ lockUpdates := true.
+ currentClass comment:theCode asString.
+ codeView modified:false.
+ ].
+ lockUpdates := false.
+ ].
+ codeView explainAction:nil.
+
+ methodListView notNil ifTrue:[
+ methodListView deselect
+ ].
+ aspect := #comment.
+ self normalLabel
+ ]
+!
+
+classRefs
+ self doClassMenu:[
+ self withCursor:(Cursor questionMark) do:[
+ self class browseReferendsOf:currentClass name asSymbol
+ ]
+ ]
+!
+
+classNewSubclass
+ "create a subclass-definition prototype in codeview"
+
+ self doClassMenu:[
+ self classClassDefinitionTemplateFor:(currentClass name)
+ in:(currentClass category).
+ aspect := nil
+ ]
+!
+
+classUses
+ "a powerful tool, when trying to learn more about where
+ a class is used. This one searches all uses of a class,
+ and shows a list of uses - try it and like it"
+
+ self doClassMenu:[
+ self withCursor:(Cursor questionMark) do:[
+ self class browseUsesOf:currentClass
+ ]
+ ]
+!
+
+classRename
+ "launch an enterBox for new name and query user"
+
+ |box|
+
+ self checkClassSelected ifFalse:[^ self].
+ box := self enterBoxTitle:(resources string:'rename %1 to:' with:currentClass name) okText:'rename'.
+ box initialText:(currentClass name).
+ box action:[:aString | self renameCurrentClassTo:aString].
+ box showAtPointer
+!
+
+classSpawnFullHierarchy
+ "create a new HierarchyBrowser browsing current class"
+
+ self doClassMenuWithSelection:[:cls :sel |
+ self class browseFullClassHierarchy:cls
+ ]
! !
-!SystemBrowser methodsFor:'variables menu'!
-
-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
+!SystemBrowser methodsFor:'class category stuff'!
+
+checkClassCategorySelected
+ currentClassCategory isNil ifTrue:[
+ self warn:'select a class category first'.
+ ^ false
+ ].
+ ^ true
+!
+
+listOfAllClassCategories
+ "return a list of all class categories"
+
+ |newList cat|
+
+ newList := Text with:'* all *' with:'* hierarchy *'.
+ Smalltalk allBehaviorsDo:[:aClass |
+ cat := aClass category.
+ cat isNil ifTrue:[
+ cat := '* no category *'
+ ].
+ newList indexOf:cat ifAbsent:[newList add:cat]
+ ].
+ newList sort.
+ ^ newList
+!
+
+classCategorySelectionChanged
+ "class category has changed - update dependent views"
+
+ self withWaitCursorDo:[
+ self switchToClass:nil.
+ actualClass := nil.
+ currentMethodCategory := nil.
+ currentMethod := currentSelector := nil.
+
+ self updateClassList.
+ self updateMethodCategoryList.
+ self updateMethodList.
+ self updateCodeView.
+
+ codeView explainAction:nil.
+ codeView acceptAction:nil
+ ]
+!
+
+classCategorySelection:lineNr
+ "user clicked on a class category line - show classes.
+ If switching to hierarchy or all, keep current selections"
+
+ |newCategory oldClass classIndex index|
+
+ newCategory := classCategoryListView selectionValue.
+ (newCategory startsWith:'*') ifTrue:[
+ "etiher all or hierarchy;
+ remember current selections and switch after showing class list"
+ oldClass := currentClass
+ ].
+ currentClassCategory := newCategory.
+ oldClass isNil ifTrue:[
+ self classCategorySelectionChanged
+ ] ifFalse:[
+ self withWaitCursorDo:[
+ self updateClassList
+ ].
+ "stupid - search for class name in (indented) list"
+ index := 1.
+ classListView list do:[:elem |
+ (elem endsWith:(oldClass name)) ifTrue:[
+ classIndex := index
+ ].
+ index := index + 1
+ ].
+ classIndex notNil ifTrue:[
+ classListView selection:classIndex.
+ self switchToClass:(Smalltalk at:(oldClass name asSymbol))
+ ] ifFalse:[
+ self normalLabel.
+ ]
+ ]
+!
+
+updateClassCategoryListWithScroll:scroll
+ |oldClassCategory oldClass oldMethodCategory oldMethod
+ oldSelector newCategoryList|
+
+ classMethodListView notNil ifTrue:[ ^ self ].
+
+ oldClassCategory := currentClassCategory.
+ oldClass := currentClass.
+ oldMethodCategory := currentMethodCategory.
+ oldMethod := currentMethod.
+ oldMethod notNil ifTrue:[
+ oldSelector := currentSelector
+ ].
+
+ classCategoryListView notNil ifTrue:[
+ newCategoryList := self listOfAllClassCategories.
+ newCategoryList = classCategoryListView list ifFalse:[
+ scroll ifTrue:[
+ classCategoryListView contents:newCategoryList
+ ] ifFalse:[
+ classCategoryListView setContents:newCategoryList
+ ]
+ ]
+ ].
+
+ oldClassCategory notNil ifTrue:[
+ classCategoryListView notNil ifTrue:[
+ classCategoryListView selectElement:oldClassCategory
+ ]
+ ].
+ classListView notNil ifTrue:[
+ oldClass notNil ifTrue:[
+ classListView selectElement:(oldClass name)
+ ]
+ ].
+ oldMethodCategory notNil ifTrue:[
+ methodCategoryListView notNil ifTrue:[
+ methodCategoryListView selectElement:oldMethodCategory
+ ].
+ ].
+ oldSelector notNil ifTrue:[
+ methodListView notNil ifTrue:[
+ methodListView selectElement:oldSelector
+ ].
+ ]
+!
+
+updateClassCategoryList
+ self updateClassCategoryListWithScroll:true
+!
+
+allClassesInCurrentCategoryInOrderDo:aBlock
+ "evaluate aBlock for all classes in the current class category;
+ superclasses come first - then subclasses"
+
+ |classes|
+
+ currentClassCategory notNil ifTrue:[
+ classes := OrderedCollection new.
+ Smalltalk allBehaviorsDo:[:aClass |
+ aClass isMeta ifFalse:[
+ (aClass category = currentClassCategory) ifTrue:[
+ classes add:aClass
+ ]
+ ]
+ ].
+ classes topologicalSort:[:a :b | b isSubclassOf:a].
+ classes do:aBlock
+ ]
+!
+
+allClassesInCurrentCategoryDo:aBlock
+ "evaluate aBlock for all classes in the current class category;
+ superclasses come first - then subclasses"
+
+ currentClassCategory notNil ifTrue:[
+ Smalltalk allBehaviorsDo:[:aClass |
+ aClass isMeta ifFalse:[
+ (aClass category = currentClassCategory) ifTrue:[
+ aBlock value:aClass
+ ]
+ ]
+ ].
+ ]
+!
+
+renameCurrentClassCategoryTo:aString
+ "helper - do the rename"
+
+ |any categories|
+
+ currentClassCategory notNil ifTrue:[
+ any := false.
+ Smalltalk allBehaviorsDo:[:aClass |
+ aClass category = currentClassCategory ifTrue:[
+ aClass category:aString.
+ any := true
+ ]
+ ].
+ any ifFalse:[
+ categories := classCategoryListView list.
+ categories remove:currentClassCategory.
+ categories add:aString.
+ categories sort.
+ classCategoryListView setContents:categories.
+ currentClassCategory := aString.
+ classCategoryListView selectElement:aString.
+ ] ifTrue:[
+ currentClassCategory := aString.
+ self updateClassCategoryList.
+ self updateClassListWithScroll:false
+ ]
+ ]
+! !
+
+!SystemBrowser methodsFor:'class-method stuff'!
+
+classFromClassMethodString:aString
+ "helper for classMethod-list - extract class name from the string"
+
+ |pos|
+
+ pos := aString indexOf:(Character space).
+ ^ aString copyTo:(pos - 1)
+!
+
+selectorFromClassMethodString:aString
+ "helper for classMethod-list - extract selector from the string"
+
+ |pos|
+
+ pos := aString indexOf:(Character space).
+ ^ aString copyFrom:(pos + 1)
+!
+
+classMethodSelection:lineNr
+ "user clicked on a class/method line - show code"
+
+ |string classString selectorString|
+
+ string := classMethodListView selectionValue.
+ classString := self classFromClassMethodString:string.
+ selectorString := self selectorFromClassMethodString:string.
+ ((classString ~= 'Metaclass') and:[classString endsWith:'class']) ifTrue:[
+ classString := classString copyTo:(classString size - 5).
+ self switchToClass:(Smalltalk at:classString asSymbol).
+ actualClass := currentClass class
+ ] ifFalse:[
+ self switchToClass:(Smalltalk at:classString asSymbol).
+ actualClass := currentClass
+ ].
+ currentClass isNil ifTrue:[
+ self warn:'oops class is gone'
+ ] ifFalse:[
+ currentClassCategory := currentClass category.
+ currentSelector := selectorString asSymbol.
+ currentMethod := actualClass compiledMethodAt:currentSelector.
+ currentMethodCategory := currentMethod category.
+
+ self methodSelectionChanged
+ ]
+! !
+
+!SystemBrowser methodsFor:'class category list menu'!
+
+initializeClassCategoryMenu
+ |labels|
+
+ labels := resources array:#(
+ 'fileOut'
+ 'fileOut each'
+"
+ 'fileOut binary'
+"
+ 'printOut'
+ 'printOut protocol'
+ '-'
+ 'SPAWN_CATEGORY'
+ 'spawn full class'
+ '-'
+ 'update'
+ 'find class ...'
+ '-'
+ 'new class category ...'
+ 'rename ...'
+ 'remove').
+
+ classCategoryListView
+ middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:#(classCategoryFileOut
+ classCategoryFileOutEach
+ classCategoryPrintOut
+ classCategoryPrintOutProtocol
+ nil
+ classCategorySpawn
+ classCategorySpawnFullClass
+ nil
+ classCategoryUpdate
+ classCategoryFindClass
+ nil
+ classCategoryNewCategory
+ classCategoryRename
+ classCategoryRemove)
+ receiver:self
+ for:classCategoryListView)
+!
+
+classCategoryUpdate
+ "update class category list and dependants"
+
+ |oldClassName oldMethodCategory|
+
+ classCategoryListView notNil ifTrue:[
+ currentClass notNil ifTrue:[
+ oldClassName := currentClass name.
+ (oldClassName endsWith:'-old') ifTrue:[
+ oldClassName := oldClassName copyTo:(oldClassName size - 4)
+ ]
+ ].
+ oldMethodCategory := currentMethodCategory.
+
+ classCategoryListView setContents:(self listOfAllClassCategories).
+ currentClassCategory notNil ifTrue:[
+ classCategoryListView selectElement:currentClassCategory.
+ self classCategorySelectionChanged.
+ oldClassName notNil ifTrue:[
+ classListView selectElement:oldClassName.
+ self switchToClass:(Smalltalk at:oldClassName asSymbol).
+ self classSelectionChanged.
+ oldMethodCategory notNil ifTrue:[
+ methodCategoryListView selectElement:oldMethodCategory.
+ currentMethodCategory := oldMethodCategory.
+ self methodCategorySelectionChanged
+ ]
+ ]
+ ]
+ ]
+!
+
+classCategoryPrintOutProtocol
+ |printStream|
+
+ self allClassesInCurrentCategoryInOrderDo:[:aClass |
+ printStream := Printer new.
+ aClass printOutProtocolOn:printStream.
+ printStream close
+ ]
+!
+
+classCategoryPrintOut
+ |printStream|
+
+ self allClassesInCurrentCategoryDo:[:aClass |
+ printStream := Printer new.
+ aClass printOutOn:printStream.
+ printStream close
+ ]
+!
+
+classCategorySpawn
+ "create a new SystemBrowser browsing current classCategory"
+
+ currentClassCategory notNil ifTrue:[
+ self withWaitCursorDo:[
+ self class browseClassCategory:currentClassCategory
+ ]
+ ]
+!
+
+classCategoryFileOut
+ "create a file 'categoryName' consisting of all classes in current category"
+
+ |aStream fileName|
+
+ self checkClassCategorySelected ifFalse:[^ self].
+
+ fileName := currentClassCategory asString.
+ fileName replaceAll:Character space by:$_.
+ "
+ this test allows a smalltalk to be built without Projects/ChangeSets
+ "
+ Project notNil ifTrue:[
+ fileName := Project currentProjectDirectory , fileName.
+ ].
+
+ "
+ if file exists, save original in a .sav file
+ "
+ fileName asFilename exists ifTrue:[
+ fileName asFilename copyTo:(fileName , '.sav')
+ ].
+ aStream := FileStream newFileNamed:fileName.
+ aStream isNil ifTrue:[
+ ^ self warn:'cannot create: %1' with:fileName
+ ].
+ self withWaitCursorDo:[
+ self busyLabel:'writing: %1' with:fileName.
+ self allClassesInCurrentCategoryInOrderDo:[:aClass |
+ aClass fileOutOn:aStream.
+ ].
+ aStream close.
+ self normalLabel.
+ ]
+!
+
+classCategorySpawnFullClass
+ "create a new SystemBrowser browsing full class"
+
+ |newBrowser|
+
+ self withWaitCursorDo:[
+ newBrowser := self class browseFullClasses
+" "
+ .
+ currentClass notNil ifTrue:[
+ newBrowser switchToClassNamed:(currentClass name)
+ ]
+" "
+ ]
+!
+
+classCategoryFileOutEach
+ self withWaitCursorDo:[
+ self allClassesInCurrentCategoryDo:[:aClass |
+ self busyLabel:'saving: ' with:aClass name.
+ Class fileOutErrorSignal handle:[:ex |
+ self warn:'cannot create: %1' with:ex parameter.
+ ex return.
+ ] do:[
+ aClass fileOut
+ ]
+ ].
+ self normalLabel.
+ ]
+!
+
+classCategoryNewCategory
+ |box|
+
+ box := self enterBoxTitle:'name of new class category:' okText:'create'.
+ box action:[:aString |
+ |categories|
+
+ currentClass notNil ifTrue:[
+ categories := OrderedCollection new.
+ currentClass withAllSuperclasses do:[:aClass |
+ aClass methodArray do:[:aMethod |
+ (categories includes:aMethod category) ifFalse:[
+ categories add:aMethod category
+ ]
+ ]
+ ].
+ ].
+ categories isNil ifTrue:[
+ categories := classCategoryListView list.
+ ].
+ (categories includes:aString) ifFalse:[
+ categories add:aString.
+ categories sort.
+ classCategoryListView setContents:categories.
+ currentClassCategory := aString.
+ classCategoryListView selectElement:aString.
+ self switchToClass:nil.
+ actualClass := nil.
+ self classCategorySelectionChanged
+ ]
+ ].
+ box showAtPointer
+!
+
+classCategoryFindClass
+ |box|
+
+ box := self enterBoxForCodeSelectionTitle:'class to find:' okText:'find'.
+ box action:[:aString | self switchToClassNameMatching:aString].
+ box showAtPointer
+!
+
+classCategoryRename
+ "launch an enterBox to rename current class category"
+
+ |box|
+
+ self checkClassCategorySelected ifFalse:[^ self].
+
+ box := self enterBoxTitle:'rename class category to:' okText:'rename'.
+ box initialText:currentClassCategory.
+ box action:[:aString | self renameCurrentClassCategoryTo:aString].
+ box showAtPointer
+!
+
+classCategoryRemove
+ "remove all classes in current category"
+
+ |count t classesToRemove subclassesRemoved box|
+
+ self checkClassCategorySelected ifFalse:[^ self].
+
+ classesToRemove := OrderedCollection new.
+ Smalltalk allBehaviorsDo:[:aClass |
+ aClass category = currentClassCategory ifTrue:[
+ classesToRemove add:aClass
+ ]
+ ].
+ subclassesRemoved := OrderedCollection new.
+ classesToRemove do:[:aClass |
+ aClass allSubclassesDo:[:aSubclass |
+ (classesToRemove includes:aSubclass) ifFalse:[
+ (subclassesRemoved includes:aSubclass) ifFalse:[
+ subclassesRemoved add:aSubclass
]
]
]
].
- ^ box
-!
-
-classInstVarRefsOrModsTitle:title mods:mods
- "show an enterbox for instvar to search for"
-
- self doClassMenu:[
- |box|
-
- box := self enterBoxForVariableSearch:title.
- box action:[:aString |
- self withCursor:(Cursor questionMark) do:[
- self class browseInstRefsTo:aString
- in:(Array with:currentClass)
- modificationsOnly:mods
- ]
- ].
- box showAtPointer
- ]
-!
-
-classInstVarRefs
- "show an enterbox for instVar to search for"
-
- self classInstVarRefsOrModsTitle:'instance variable to browse references to:'
- mods:false
-!
-
-classInstVarMods
- "show an enterbox for instVar to search for"
-
- self classInstVarRefsOrModsTitle:'instance variable to browse modifications of:'
- mods:true
-!
-
-classClassVarRefsOrModsTitle:title mods:mods
- "show an enterbox for classVar to search for"
-
- self doClassMenu:[
- |box|
-
- box := self enterBoxForVariableSearch:title.
- box action:[:aString |
- self withCursor:(Cursor questionMark) do:[
- self class browseClassRefsTo:aString
- in:(Array with:currentClass)
- modificationsOnly:mods
+
+ 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
]
].
- box showAtPointer
- ]
-!
-
-classClassVarMods
- "show an enterbox for classVar to search for"
-
- self classClassVarRefsOrModsTitle:'class variable to browse modifications of:'
- mods:true
-!
-
-classClassVarRefs
- "show an enterbox for classVar to search for"
-
- self classClassVarRefsOrModsTitle:'class variable to browse references to:'
- mods:false
-!
-
-classAllClassOrInstVarRefsTitle:title access:access mods:modifications
- "show an enterbox for instVar to search for"
-
- self doClassMenu:[
- |box|
-
- box := self enterBoxForVariableSearch:title.
- box action:[:aVariableName |
- self withCursor:(Cursor questionMark) do:[
- |homeClass|
-
- homeClass := self findClassOfVariable:aVariableName
- accessWith:access.
- (self class) browseInstRefsTo:aVariableName
- under:homeClass
- modificationsOnly:modifications
- ]
+ classesToRemove do:[:aClass |
+ (CheckForInstancesWhenRemovingClasses not
+ or:[aClass hasInstances not
+ or:[self confirm:(aClass name , ' has instances - remove anyway ?')]])
+ ifTrue:[
+ Smalltalk removeClass:aClass
+ ].
].
- box showAtPointer
+ currentClassCategory := nil.
+ self switchToClass:nil.
+ Smalltalk changed
]
-!
-
-classAllInstVarRefs
- "show an enterbox for instVar to search for"
-
- self classAllClassOrInstVarRefsTitle:'instance variable to browse references to:'
- access:#instVarNames
- mods:false
-!
-
-classAllClassVarRefs
- "show an enterbox for classVar to search for"
-
- self classAllClassOrInstVarRefsTitle:'class variable to browse references to:'
- access:#classVarNames
- mods:false
-!
-
-classAllInstVarMods
- "show an enterbox for instVar to search for"
-
- self classAllClassOrInstVarRefsTitle:'instance variable to browse modifications of:'
- access:#instVarNames
- mods:true
-!
-
-classAllClassVarMods
- "show an enterbox for classVar to search for"
-
- self classAllClassOrInstVarRefsTitle:'class variable to browse modifications of:'
- access:#classVarNames
- mods:true
! !
-!SystemBrowser methodsFor:'method category menu'!
+!SystemBrowser methodsFor:'method category list menu'!
initializeMethodCategoryMenu
|labels|
@@ -3398,116 +4486,12 @@
for:methodCategoryListView)
!
-switchToMethodNamed:matchString
- |aSelector method cat index classToSearch selectors|
-
- currentClass notNil ifTrue:[
- showInstance ifTrue:[
- classToSearch := currentClass
- ] ifFalse:[
- classToSearch := currentClass class
- ].
- selectors := classToSearch selectorArray.
-
- ((matchString ~= '*') and:[matchString includesMatchCharacters]) ifTrue:[
- index := selectors findFirst:[:element | matchString match:element]
- ] ifFalse:[
- index := selectors indexOf:matchString
- ].
-
- (index ~~ 0) ifTrue:[
- aSelector := selectors at:index.
- method := classToSearch methodArray at:index.
- cat := method category.
- cat isNil ifTrue:[cat := '* all *'].
- methodCategoryListView selectElement:cat.
- currentMethodCategory := cat.
- self methodCategorySelectionChanged.
-
- currentMethod := classToSearch compiledMethodAt:aSelector.
- methodListView selectElement:aSelector.
- self methodSelectionChanged
- ]
- ]
-!
-
-switchToAnyMethodNamed:aString
- |aSelector classToStartSearch aClass nm|
-
- aSelector := aString asSymbol.
- currentClass isNil ifTrue:[
- currentClassHierarchy notNil ifTrue:[
- classToStartSearch := currentClassHierarchy
- ]
- ] ifFalse:[
- classToStartSearch := currentClass
- ].
- classToStartSearch notNil ifTrue:[
- showInstance ifFalse:[
- classToStartSearch := classToStartSearch class
- ].
- aClass := classToStartSearch whichClassImplements:aSelector.
- aClass notNil ifTrue:[
- nm := aClass name.
- showInstance ifFalse:[
- ((nm ~= 'Metaclass') and:[nm endsWith:'class']) ifTrue:[
- nm := nm copyTo:(nm size - 5)
- ]
- ].
- self switchToClassNamed:nm.
- self switchToMethodNamed:aString
- ]
- ]
-!
-
-copyMethodsFromClass:aClassName
- |class box|
-
- currentClass notNil ifTrue:[
- Symbol hasInterned:aClassName ifTrue:[:sym |
- (Smalltalk includesKey:sym) ifTrue:[
- class := Smalltalk at:sym
- ].
- ].
- class isBehavior ifFalse:[
- self warn:'no class named %1' with:aClassName.
- ^ self
- ].
-
- showInstance ifFalse:[
- class := class class
- ].
-
- "show enterbox for category to copy from"
-
- box := self enterBoxTitle:'name of category to copy from (matchpattern allowed, * for all):'
- okText:'copy'.
- box action:[:aString | self copyMethodsFromClass:class category:aString].
- box showAtPointer.
- ]
-!
-
-copyMethodsFromClass:class category:category
- |source|
-
- currentClass notNil ifTrue:[
-"/ codeView abortAction:[^ self].
- Object abortSignal catch:[
- class methodArray do:[:aMethod |
- (category match:aMethod category) ifTrue:[
- source := aMethod source.
- codeView contents:source.
- codeView modified:false.
- actualClass compiler compile:source
- forClass:actualClass
- inCategory:aMethod category
- notifying:codeView.
- self updateMethodCategoryListWithScroll:false.
- self updateMethodListWithScroll:false.
- ]
- ]
- ]
- ]
+methodCategoryFindAnyMethod
+ |box|
+
+ box := self enterBoxForSearchSelectorTitle:'method selector to search for:'.
+ box action:[:aString | self switchToAnyMethodNamed:aString].
+ box showAtPointer
!
methodCategoryFindMethod
@@ -3518,14 +4502,6 @@
box showAtPointer
!
-methodCategoryFindAnyMethod
- |box|
-
- box := self enterBoxForSearchSelectorTitle:'method selector to search for:'.
- box action:[:aString | self switchToAnyMethodNamed:aString].
- box showAtPointer
-!
-
methodCategoryPrintOut
|printStream|
@@ -3543,7 +4519,7 @@
self checkClassSelected ifFalse:[^ self].
self whenMethodCategorySelected:[
- self label:('System Browser saving: ' , currentClass name , '-' , currentMethodCategory).
+ self busyLabel:'saving: %1' with:currentClass name , '-' , currentMethodCategory.
Class fileOutErrorSignal handle:[:ex |
self warn:'cannot create: %1' with:ex parameter.
ex return.
@@ -3554,6 +4530,17 @@
]
!
+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"
@@ -3581,12 +4568,12 @@
^ self warn:'cannot create: %1' with:fileName
].
- self label:('System Browser saving: ' , currentMethodCategory).
+ self busyLabel:'saving: ' with:currentMethodCategory.
Class fileOutErrorSignal handle:[:ex |
self warn:'cannot create: %1' with:ex parameter.
ex return
] do:[
- Smalltalk allClassesDo:[:class |
+ Smalltalk allBehaviorsDo:[:class |
|hasMethodsInThisCategory|
hasMethodsInThisCategory := false.
@@ -3616,15 +4603,53 @@
].
!
-methodCategorySpawn
- "create a new SystemBrowser browsing current method category"
-
- currentMethodCategory notNil ifTrue:[
- self withWaitCursorDo:[
- self class browseClass:actualClass
- methodCategory:currentMethodCategory
- ]
- ]
+methodCategoryNewCategory
+ "show the enter box to add a new method category.
+ Offer existing superclass categories in box to help avoiding
+ useless typing."
+
+ |someCategories existingCategories box|
+
+ actualClass notNil ifTrue:[
+ someCategories := actualClass allCategories
+ ] ifFalse:[
+ "
+ mhmh - offer some typical categories ...
+ "
+ showInstance ifTrue:[
+ someCategories := #('accessing'
+ 'initialization'
+ 'private'
+ 'printing & storing'
+ 'queries'
+ 'testing'
+ )
+ ] ifFalse:[
+ someCategories := #(
+ 'documentation'
+ 'initialization'
+ 'instance creation'
+ ).
+ ].
+ ].
+ someCategories sort.
+
+ "
+ remove existing categories
+ "
+ existingCategories := methodCategoryListView list.
+ existingCategories notNil ifTrue:[
+ someCategories := someCategories select:[:cat | (existingCategories includes:cat) not].
+ ].
+
+ box := self listBoxTitle:'name of new method category:'
+ okText:'create'
+ list:someCategories.
+ box action:[:aString | self newMethodCategory:aString].
+ box showAtPointer
+
+
+
!
methodCategorySpawnCategory
@@ -3637,61 +4662,9 @@
]
!
-newMethodCategory:aString
- |categories|
-
- currentClass isNil ifTrue:[
- ^ self warn:'select/create a class first'.
- ].
- categories := methodCategoryListView list.
- categories isNil ifTrue:[categories := Text new].
- (categories includes:aString) ifFalse:[
- categories add:aString.
- categories sort.
- methodCategoryListView contents:categories
- ].
- currentMethodCategory := aString.
- self methodCategorySelectionChanged
-!
-
-methodCategoryNewCategory
- "show the enter box to add a new method category"
-
- |someCategories existingCategories box|
-
- "a tiny little goody here ..."
- showInstance ifTrue:[
- someCategories := #('accessing'
- 'initialization'
- 'private'
- 'printing & storing'
- 'queries'
- 'testing'
- )
- ] ifFalse:[
- someCategories := #(
- 'documentation'
- 'initialization'
- 'instance creation'
- ).
- ].
- existingCategories := methodCategoryListView list.
- existingCategories notNil ifTrue:[
- someCategories := someCategories select:[:cat | (existingCategories includes:cat) not].
- ].
-
- box := self listBoxTitle:'name of new method category:'
- okText:'create'
- list:someCategories.
- box action:[:aString | self newMethodCategory:aString].
- box showAtPointer
-!
-
methodCategoryCreateAccessMethods
"create access methods for all instvars"
- |source|
-
self checkClassSelected ifFalse:[^ self].
showInstance ifFalse:[
@@ -3700,7 +4673,15 @@
].
self withWaitCursorDo:[
- currentClass instVarNames do:[:name |
+ |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.
@@ -3752,7 +4733,7 @@
box action:[:aString |
actualClass renameCategory:currentMethodCategory to:aString.
currentMethodCategory := aString.
- currentMethod := nil.
+ currentMethod := currentSelector := nil.
self updateMethodCategoryList.
self updateMethodListWithScroll:false
].
@@ -3773,7 +4754,7 @@
].
(count == 0) ifTrue:[
currentMethodCategory := nil.
- currentMethod := nil.
+ currentMethod := currentSelector := nil.
self updateMethodCategoryListWithScroll:false.
self updateMethodList
] ifFalse:[
@@ -3797,7 +4778,7 @@
]
].
currentMethodCategory := nil.
- currentMethod := nil.
+ currentMethod := currentSelector := nil.
self updateMethodCategoryList.
self updateMethodList
]
@@ -3805,11 +4786,140 @@
]
! !
-!SystemBrowser methodsFor:'method menu'!
+!SystemBrowser methodsFor:'method list menu'!
+
+methodMenu
+ "return a popupmenu as appropriate for the methodList"
+
+ |labels selectors|
+
+ (currentMethod notNil and:[currentMethod isWrapped]) ifTrue:[
+ labels := #(
+ 'fileOut'
+ 'printOut'
+ '-'
+ 'SPAWN_METHOD'
+ '-'
+ 'senders ...'
+ 'implementors ...'
+ 'globals ...'
+"
+ 'strings ...'
+ 'apropos ...'
+"
+ '-'
+ 'local senders ...'
+ 'local implementors ...'
+"
+ 'local strings ...'
+"
+ '-'
+ 'remove break/trace'
+ '-'
+ 'new method'
+ 'change category ...'
+ 'remove'
+ ).
+
+ selectors := #(
+ methodFileOut
+ methodPrintOut
+ nil
+ methodSpawn
+ nil
+ methodSenders
+ methodImplementors
+ methodGlobalReferends
+"
+ methodStringSearch
+ methodAproposSearch
+"
+ nil
+ methodLocalSenders
+ methodLocalImplementors
+"
+ methodLocalStringSearch
+"
+ nil
+ methodRemoveBreakOrTrace
+ nil
+ methodNewMethod
+ methodChangeCategory
+ methodRemove
+ )
+ ] ifFalse:[
+ labels := #(
+ 'fileOut'
+ 'printOut'
+ '-'
+ 'SPAWN_METHOD'
+ '-'
+ 'senders ...'
+ 'implementors ...'
+ 'globals ...'
+"
+ 'strings ...'
+ 'apropos ...'
+"
+ '-'
+ 'local senders ...'
+ 'local implementors ...'
+"
+ 'local strings ...'
+"
+ '-'
+ 'breakpoint'
+ 'trace'
+ 'trace sender'
+ '-'
+ 'new method'
+ 'change category ...'
+ 'remove'
+ ).
+ selectors := #(
+ methodFileOut
+ methodPrintOut
+ nil
+ methodSpawn
+ nil
+ methodSenders
+ methodImplementors
+ methodGlobalReferends
+"
+ methodStringSearch
+ methodAproposSearch
+"
+ nil
+ methodLocalSenders
+ methodLocalImplementors
+"
+ methodLocalStringSearch
+"
+ nil
+ methodBreakPoint
+ methodTrace
+ methodTraceSender
+ nil
+ methodNewMethod
+ methodChangeCategory
+ methodRemove
+ )
+ ].
+
+ ^ PopUpMenu
+ labels:(resources array:labels)
+ selectors:selectors
+ receiver:self
+ for:methodListView
+!
initializeMethodMenu
|labels|
+methodListView model:self.
+methodListView menu:#methodMenu.
+^ self.
+
labels := resources array:#(
'fileOut'
'printOut'
@@ -3871,10 +4981,38 @@
for:methodListView)
!
+methodImplementors
+ "launch an enterBox for selector to search for"
+
+ self askAndBrowseSelectorTitle:'selector to browse implementors of:'
+ action:[:aString |
+ self class browseImplementorsOf:aString
+ ]
+!
+
+methodSenders
+ "launch an enterBox for selector to search for"
+
+ self askAndBrowseSelectorTitle:'selector to browse senders of:'
+ action:[:aString |
+ self class browseAllCallsOn:aString
+ ]
+!
+
+methodRemove
+ "remove the current method"
+
+ self checkMethodSelected ifFalse:[^ self].
+ actualClass removeSelector:(actualClass selectorForMethod:currentMethod).
+ currentMethod := currentSelector := nil.
+ self updateMethodListWithScroll:false
+!
+
initializeMethodMenu2
|labels|
methodListView isNil ifTrue:[^ self].
+^self.
labels := resources array:#(
'fileOut'
'printOut'
@@ -3932,6 +5070,16 @@
for:methodListView)
!
+methodLocalSenders
+ "launch an enterBox for selector to search for in current class & subclasses"
+
+ self checkClassSelected ifFalse:[^ self].
+ self askAndBrowseSelectorTitle:'selector to browse local senderss of:'
+ action:[:aString |
+ self class browseCallsOn:aString under:currentClass
+ ]
+!
+
methodPrintOut
"print out the current method"
@@ -3940,34 +5088,10 @@
self checkMethodSelected ifFalse:[^ self].
printStream := Printer new.
- actualClass printOutSource:currentMethod source on:printStream.
+ actualClass printOutSource:(currentMethod source) on:printStream.
printStream close
!
-methodFileOut
- "file out the current method"
-
- self checkMethodSelected ifFalse:[^ self].
-
- self label:'System Browser saving'.
- Class fileOutErrorSignal handle:[:ex |
- self warn:'cannot create: %1' with:ex parameter.
- ex return
- ] do:[
- actualClass fileOutMethod:currentMethod.
- ].
- self normalLabel.
-!
-
-methodImplementors
- "launch an enterBox for selector to search for"
-
- self askAndBrowseSelectorTitle:'selector to browse implementors of:'
- action:[:aString |
- self class browseImplementorsOf:aString
- ]
-!
-
methodLocalImplementors
"launch an enterBox for selector to search for"
@@ -3978,25 +5102,6 @@
]
!
-methodSenders
- "launch an enterBox for selector to search for"
-
- self askAndBrowseSelectorTitle:'selector to browse senders of:'
- action:[:aString |
- self class browseAllCallsOn:aString
- ]
-!
-
-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
- ]
-!
-
methodGlobalReferends
"launch an enterBox for global symbol to search for"
@@ -4006,6 +5111,125 @@
]
!
+methodSpawn
+ "create a new SystemBrowser browsing current method,
+ or if the current selection is of the form 'class>>selector', spawan
+ a browser on that method."
+
+ |s sel selSymbol clsName clsSymbol cls meta isMeta w sep|
+
+ classMethodListView notNil ifTrue:[
+ s := classMethodListView selectionValue.
+ clsName := self classFromClassMethodString:s.
+ sel := self selectorFromClassMethodString:s.
+ isMeta := false
+ ].
+
+ self extractClassAndSelectorFromSelectionInto:[:c :s :m |
+ clsName := c.
+ sel := s.
+ isMeta := m
+ ].
+
+ (sel notNil and:[clsName notNil]) ifTrue:[
+ (clsName knownAsSymbol and:[sel knownAsSymbol]) ifTrue:[
+ clsSymbol := clsName asSymbol.
+ (Smalltalk includesKey:clsSymbol) ifTrue:[
+ cls := Smalltalk at:clsSymbol.
+ isMeta ifTrue:[
+ cls := cls class
+ ].
+ cls isBehavior ifFalse:[
+ cls := cls class
+ ].
+ cls isBehavior ifTrue:[
+ selSymbol := sel asSymbol.
+ self withWaitCursorDo:[
+ (cls implements:selSymbol) ifFalse:[
+ cls := cls class.
+ ].
+ (cls implements:selSymbol) ifTrue:[
+ self class browseClass:cls selector:selSymbol.
+ ^ self
+ ].
+ w := ' does not implement #' , sel
+ ]
+ ] ifFalse:[
+ w := ' is not a class'
+ ]
+ ] ifFalse:[
+ w := ' is unknown'
+ ]
+ ] ifFalse:[
+ w := ' and/or ' , sel , ' are unknown'
+ ].
+ self warn:(clsName , w).
+ ^ self
+ ].
+
+ self checkMethodSelected ifFalse:[
+ self warn:'select a method first'.
+ ^ self
+ ].
+
+ self withWaitCursorDo:[
+ w := currentMethod who.
+ self class browseClass:(w at:1) selector:(w at:2)
+ ]
+!
+
+methodFileOut
+ "file out the current method"
+
+ self checkMethodSelected ifFalse:[^ self].
+
+ self busyLabel:'saving:' with:currentSelector.
+ Class fileOutErrorSignal handle:[:ex |
+ self warn:'cannot create: %1' with:ex parameter.
+ ex return
+ ] do:[
+ actualClass fileOutMethod:currentMethod.
+ ].
+ self normalLabel.
+!
+
+methodChangeCategory
+ "move the current method into another category -
+ nothing done here, but a query for the new category.
+ Remember the last category, to allow faster category change of a group of methods."
+
+ |box txt|
+
+ self checkMethodSelected ifFalse:[^ self].
+
+ actualClass isNil ifTrue:[
+ box := self enterBoxTitle:'' okText:'change'.
+ ] ifFalse:[
+ |someCategories|
+
+ someCategories := actualClass categories sort.
+ box := self listBoxTitle:'' okText:'change' list:someCategories.
+ ].
+ box title:('change category from ''' , currentMethod category , ''' to:').
+ lastMethodCategory isNil ifTrue:[
+ txt := currentMethod category.
+ ] ifFalse:[
+ txt := lastMethodCategory
+ ].
+ box initialText:txt.
+ box action:[:aString |
+ lastMethodCategory := aString.
+
+ currentMethod category:aString asSymbol.
+ currentClass changed.
+ currentMethod changed:#category.
+ currentClass addChangeRecordForMethodCategory:currentMethod category:aString.
+ self updateMethodCategoryListWithScroll:false.
+ self updateMethodListWithScroll:false
+ ].
+ box showAtPointer
+!
+
methodStringSearch
"launch an enterBox for (sub)-string to search for"
@@ -4034,84 +5258,6 @@
]
!
-methodSpawn
- "create a new SystemBrowser browsing current method,
- or if the current selection is of the form 'class>>selector', spwan
- a browser on that method."
-
- |s sel selSymbol clsName clsSymbol cls meta browseMeta w sep|
-
- sel := codeView selection.
- sel notNil ifTrue:[
- sel := sel asString withoutSeparators.
- ('*>>*' match:sel) ifTrue:[
- sep := $>
- ] ifFalse:[
- ('* *' match:sel) ifTrue:[
- sep := Character space
- ]
- ].
- sep notNil ifTrue:[
- "
- 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:[
- browseMeta := true.
- clsName := clsName copyTo:(clsName size - 5)
- ] ifFalse:[
- browseMeta := false
- ].
- (clsName knownAsSymbol and:[sel knownAsSymbol]) ifTrue:[
- clsSymbol := clsName asSymbol.
- (Smalltalk includesKey:clsSymbol) ifTrue:[
- cls := Smalltalk at:clsSymbol.
- browseMeta ifTrue:[
- cls := cls class
- ].
- cls isBehavior ifFalse:[
- cls := cls class
- ].
- cls isBehavior ifTrue:[
- selSymbol := sel asSymbol.
- self withWaitCursorDo:[
- (cls implements:selSymbol) ifTrue:[
- self class browseClass:cls selector:selSymbol.
- ^ self
- ] ifFalse:[
- meta := cls class.
- (meta implements:selSymbol) ifTrue:[
- self class browseClass:meta selector:selSymbol.
- ^ self
- ].
- w := ' does not implement #' , sel
- ]
- ]
- ] ifFalse:[
- w := ' is not a class'
- ]
- ] ifFalse:[
- w := ' is unknown'
- ]
- ] ifFalse:[
- w := ' and/or ' , sel , ' is unknown'
- ].
- self warn:(clsName , w).
- ^ self
- ].
- ].
-
- self checkMethodSelected ifFalse:[^ self].
- self withWaitCursorDo:[
- self class browseClass:actualClass
- selector:(actualClass selectorForMethod:currentMethod)
- ]
-!
-
methodNewMethod
"prepare for definition of a new method - put a template into
code view and define accept-action to compile it"
@@ -4123,80 +5269,48 @@
^ self warn:'select/create a method category first'.
].
- currentMethod := nil.
+ currentMethod := currentSelector := nil.
methodListView deselect.
codeView contents:(self template).
codeView modified:false.
- codeView acceptAction:[:theCode |
- codeView cursor:Cursor execute.
- Object abortSignal catch:[
- actualClass compiler compile:theCode asString
- forClass:actualClass
- inCategory:currentMethodCategory
- notifying:codeView.
- codeView modified:false.
- self updateMethodListWithScroll:false.
- ].
- codeView cursor:Cursor normal.
- ].
- codeView explainAction:[:theCode :theSelection |
- self showExplanation:(Explainer explain:theSelection
- in:theCode
- forClass:actualClass)
+ 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.
]
!
-methodRemove
- "remove the current method"
-
- self checkMethodSelected ifFalse:[^ self].
- actualClass removeSelector:(actualClass selectorForMethod:currentMethod).
- self updateMethodListWithScroll:false
-!
-
-methodChangeCategory
- "move the current method into another category -
- nothing done here, but a query for the new category.
- Remember the last category, to allow faster category change of a group of methods."
-
- |box txt|
-
- self checkMethodSelected ifFalse:[^ self].
-
- box := self enterBoxTitle:('change category from ' , currentMethod category , ' to:')
- okText:'change'.
- lastMethodCategory isNil ifTrue:[
- txt := currentMethod category.
- ] ifFalse:[
- txt := lastMethodCategory
- ].
- box initialText:txt.
- box action:[:aString |
- lastMethodCategory := aString.
-
- currentMethod category:aString asSymbol.
- currentClass changed.
- self updateMethodCategoryListWithScroll:false.
- self updateMethodListWithScroll:false
- ].
- box showAtPointer
-!
-
methodRemoveBreakOrTrace
"turn off tracing of the current method"
|sel|
- currentMethod notNil ifTrue:[
- currentMethod isWrapped ifTrue:[
- currentMethod := MessageTracer unwrapMethod:currentMethod.
- sel := methodListView selection.
- self updateMethodListWithScroll:false.
- methodListView selection:sel.
- self initializeMethodMenu
- ].
+ (currentMethod notNil and:[currentMethod isWrapped])
+ ifTrue:[
+ currentMethod := MessageTracer unwrapMethod:currentMethod.
+ sel := methodListView selection.
+ self updateMethodListWithScroll:false.
+ methodListView selection:sel.
+ currentClass changed:#methodDictionary with:currentSelector.
]
!
@@ -4216,39 +5330,294 @@
]
!
-methodTrace
- "turn on tracing of the current method"
-
- |sel|
-
- currentMethod notNil ifTrue:[
- currentMethod isWrapped ifFalse:[
- currentMethod := MessageTracer traceMethod:currentMethod.
- self initializeMethodMenu2.
- sel := methodListView selection.
- self updateMethodListWithScroll:false.
- methodListView selection:sel
- ].
- ]
-!
-
methodTraceSender
"turn on tracing of the current method"
|sel|
- currentMethod notNil ifTrue:[
- currentMethod isWrapped ifFalse:[
- currentMethod := MessageTracer traceMethodSender:currentMethod.
- self initializeMethodMenu2.
- sel := methodListView selection.
- self updateMethodListWithScroll:false.
- methodListView selection:sel
+ (currentMethod notNil and:[currentMethod isWrapped not])
+ ifTrue:[
+ currentMethod := MessageTracer traceMethodSender:currentMethod.
+ sel := methodListView selection.
+ self updateMethodListWithScroll:false.
+ methodListView selection:sel.
+ currentClass changed:#methodDictionary with:currentSelector.
+ ]
+!
+
+methodMenuForWrappedMethod
+ |labels|
+
+ labels := resources array:#(
+ 'fileOut'
+ 'printOut'
+ '-'
+ 'SPAWN_METHOD'
+ '-'
+ 'senders ...'
+ 'implementors ...'
+ 'globals ...'
+"
+ 'strings ...'
+ 'apropos ...'
+"
+ '-'
+ 'local senders ...'
+ 'local implementors ...'
+"
+ 'local strings ...'
+"
+ '-'
+ 'remove break/trace'
+ '-'
+ 'new method'
+ 'change category ...'
+ 'remove').
+
+ ^ PopUpMenu
+ labels:labels
+ selectors:#(methodFileOut
+ methodPrintOut
+ nil
+ methodSpawn
+ nil
+ methodSenders
+ methodImplementors
+ methodGlobalReferends
+"
+ methodStringSearch
+ methodAproposSearch
+"
+ nil
+ methodLocalSenders
+ methodLocalImplementors
+"
+ methodLocalStringSearch
+"
+ nil
+ methodRemoveBreakOrTrace
+ nil
+ methodNewMethod
+ methodChangeCategory
+ methodRemove)
+ receiver:self
+ for:methodListView
+! !
+
+!SystemBrowser methodsFor:'variable list menu'!
+
+initializeVariableListMenu
+ |varMenu|
+
+ varMenu := (PopUpMenu labels:(resources array:#(
+ 'instvar refs ...'
+ 'classvar refs ...'
+ 'all instvar refs ...'
+ 'all classvar refs ...'
+ '-'
+ 'instvar mods ...'
+ 'classvar mods ...'
+ 'all instvar mods ...'
+ 'all classvar mods ...'
+ ))
+ selectors:#(
+ instVarRefs
+ classVarRefs
+ allInstVarRefs
+ allClassVarRefs
+ nil
+ instVarMods
+ classVarMods
+ allInstVarMods
+ allClassVarMods
+ )
+ receiver:self
+ for:self).
+
+ variableListView isNil ifTrue:[
+ classListView notNil ifTrue:[
+ |menu|
+
+ menu := classListView middleButtonMenu.
+ menu addLabel:(resources string:'variable search')
+ selector:#variables
+ before:#classRefs.
+ menu subMenuAt:#variables put:varMenu.
+ ]
+ ] ifFalse:[
+ variableListView middleButtonMenu:varMenu
+ ]
+
+!
+
+variableSelection:lineNr
+ "variable selection changed"
+
+ |name idx|
+
+ name := variableListView selectionValue.
+ name isNil ifTrue:[
+ self unhilightMethodCategories.
+ self unhilightMethods.
+ self autoSearch:nil.
+ ^ self
+ ].
+
+ "
+ first, check if the selected variable is really the one
+ we get - reselect if its hidden (for example, a class variable
+ with the same name could be defined in a subclass)
+ "
+ idx := variableListView list findLast:[:entry | entry = name].
+ idx ~~ lineNr ifTrue:[
+ "select it - user will see whats going on"
+ variableListView selection:idx
+ ].
+
+ "search for methods in the current category, which access the selected
+ variable, and highlight them"
+
+ self hilightMethodsInMethodCategoryList:true inMethodList:true.
+ self autoSearch:name.
+
+
+!
+
+enterBoxForVariableSearch:title
+ |box sel|
+
+ box := self enterBoxForCodeSelectionTitle:title okText:'browse'.
+ variableListView notNil ifTrue:[
+ codeView hasSelection ifFalse:[
+ (sel := variableListView selectionValue) notNil ifTrue:[
+ (sel startsWith:'---') ifFalse:[
+ box initialText:sel
+ ]
+ ]
+ ]
+ ].
+ ^ box
+!
+
+allClassOrInstVarRefsTitle:title access:access mods:modifications
+ "show an enterbox for instVar to search for"
+
+ self doClassMenu:[
+ |box|
+
+ box := self enterBoxForVariableSearch:title.
+ box action:[:aVariableName |
+ self withCursor:(Cursor questionMark) do:[
+ |homeClass|
+
+ homeClass := self findClassOfVariable:aVariableName
+ accessWith:access.
+ (self class) browseInstRefsTo:aVariableName
+ under:homeClass
+ modificationsOnly:modifications
+ ]
].
+ box showAtPointer
]
+!
+
+instVarRefsOrModsTitle:title mods:mods
+ "show an enterbox for instvar to search for"
+
+ self doClassMenu:[
+ |box|
+
+ box := self enterBoxForVariableSearch:title.
+ box action:[:aString |
+ self withCursor:(Cursor questionMark) do:[
+ self class browseInstRefsTo:aString
+ in:(Array with:currentClass)
+ modificationsOnly:mods
+ ]
+ ].
+ box showAtPointer
+ ]
+!
+
+allClassVarMods
+ "show an enterbox for classVar to search for"
+
+ self allClassOrInstVarRefsTitle:'class variable to browse modifications of:'
+ access:#classVarNames
+ mods:true
+!
+
+instVarMods
+ "show an enterbox for instVar to search for"
+
+ self instVarRefsOrModsTitle:'instance variable to browse modifications of:'
+ mods:true
+!
+
+instVarRefs
+ "show an enterbox for instVar to search for"
+
+ self instVarRefsOrModsTitle:'instance variable to browse references to:'
+ mods:false
+!
+
+classVarRefsOrModsTitle:title mods:mods
+ "show an enterbox for classVar to search for"
+
+ self doClassMenu:[
+ |box|
+
+ box := self enterBoxForVariableSearch:title.
+ box action:[:aString |
+ self withCursor:(Cursor questionMark) do:[
+ self class browseClassRefsTo:aString
+ in:(Array with:currentClass)
+ modificationsOnly:mods
+ ]
+ ].
+ box showAtPointer
+ ]
+!
+
+allInstVarRefs
+ "show an enterbox for instVar to search for"
+
+ self allClassOrInstVarRefsTitle:'instance variable to browse references to:'
+ access:#instVarNames
+ mods:false
+!
+
+classVarRefs
+ "show an enterbox for classVar to search for"
+
+ self classVarRefsOrModsTitle:'class variable to browse references to:'
+ mods:false
+!
+
+classVarMods
+ "show an enterbox for classVar to search for"
+
+ self classVarRefsOrModsTitle:'class variable to browse modifications of:'
+ mods:true
+!
+
+allInstVarMods
+ "show an enterbox for instVar to search for"
+
+ self allClassOrInstVarRefsTitle:'instance variable to browse modifications of:'
+ access:#instVarNames
+ mods:true
+!
+
+allClassVarRefs
+ "show an enterbox for classVar to search for"
+
+ self allClassOrInstVarRefsTitle:'class variable to browse references to:'
+ access:#classVarNames
+ mods:false
! !
-!SystemBrowser methodsFor:'class-method menu'!
+!SystemBrowser methodsFor:'class-method list menu'!
initializeClassMethodMenu
|labels|
@@ -4329,7 +5698,7 @@
self withWaitCursorDo:[
list := classMethodListView list.
list do:[:line |
- self label:('System Browser writing: ' , line).
+ self busyLabel:'writing: ' with:line.
classString := self classFromClassMethodString:line.
selectorString := self selectorFromClassMethodString:line.
@@ -4354,7 +5723,7 @@
'\\continue anyway ?') withCRs) ifTrue:[
ex proceed
].
- self label:'System Browser'.
+ self normalLabel.
^ self
] do:[
cls fileOutMethod:mth on:outStream.
@@ -4367,90 +5736,4 @@
]
! !
-!SystemBrowser methodsFor:'dependencies'!
-
-update
- "handle changes from other browsers"
-
- |oldClassCategory oldClassName oldMethodCategory oldMethod oldSelector|
-
-self updateClassCategoryListWithScroll:false.
-"
-self updateClassListWithScroll:false.
-"
-^ self.
-
- oldClassCategory := currentClassCategory.
- currentClass notNil ifTrue:[
- oldClassName := currentClass name
- ].
- oldMethodCategory := currentMethodCategory.
- oldMethod := currentMethod.
- methodListView notNil ifTrue:[
- oldMethod notNil ifTrue:[
- oldSelector := methodListView selectionValue
- ]
- ].
-
- classCategoryListView notNil ifTrue:[
- classCategoryListView setContents:(self listOfAllClassCategories).
- oldClassCategory notNil ifTrue:[
- classCategoryListView selectElement:oldClassCategory
- ].
- classCategoryListView selection isNil ifTrue:[
- currentClassCategory := nil.
- self switchToClass:nil.
- oldClassName := nil
- ]
- ].
- classListView notNil ifTrue:[
- self updateClassListWithScroll:false.
- oldClassName notNil ifTrue:[
- classListView selectElement:oldClassName
- ].
- classListView selection isNil ifTrue:[
- self switchToClass:nil.
- currentMethodCategory := nil.
- oldMethodCategory := nil
- ]
- ].
- methodCategoryListView notNil ifTrue:[
- self updateMethodCategoryListWithScroll:false.
- oldMethodCategory notNil ifTrue:[
- methodCategoryListView selectElement:oldMethodCategory
- ].
- methodCategoryListView selection isNil ifTrue:[
- currentMethodCategory := nil.
- currentMethod := nil.
- oldSelector := nil
- ]
- ].
- methodListView notNil ifTrue:[
- self updateMethodListWithScroll:false.
- oldSelector notNil ifTrue:[
- methodListView selectElement:oldSelector
- ].
- methodListView selection isNil ifTrue:[
- currentMethod := nil
- ]
- ].
- self updateCodeView
-!
-
-update:something with:someArgument from:changedObject
- (changedObject == Smalltalk) ifTrue:[self update. ^ self].
- changedObject isBehavior ifTrue:[
- (currentClass notNil and:[changedObject name = currentClass name]) ifTrue:[
- currentClass := Smalltalk at:(currentClass name asSymbol).
- showInstance ifTrue:[
- actualClass := currentClass
- ] ifFalse:[
- actualClass := currentClass class
- ].
- self updateMethodCategoryListWithScroll:false.
- "dont update codeView ...."
- "self update"
- ^ self
- ]
- ]
-! !
+SystemBrowser initialize!
--- a/SystemBrowser.st Thu Nov 17 15:44:34 1994 +0100
+++ b/SystemBrowser.st Thu Nov 17 15:47:59 1994 +0100
@@ -1,5 +1,3 @@
-"{ Package: 'Programming Tools' }"
-
"
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
@@ -12,26 +10,25 @@
hereby transferred.
"
+'From Smalltalk/X, Version:2.10.4 on 7-nov-1994 at 14:56:27'!
+
StandardSystemView subclass:#SystemBrowser
- instanceVariableNames:'classCategoryListView classListView
- methodCategoryListView methodListView
- classMethodListView
- codeView classToggle instanceToggle
- currentClassCategory currentClassHierarchy
- currentClass
- currentMethodCategory currentMethod
- showInstance actualClass fullClass
- lastMethodCategory aspect variableListView'
- classVariableNames:''
- poolDictionaries:''
- category:'Interface-Browsers'
+ instanceVariableNames:'classCategoryListView classListView methodCategoryListView
+ methodListView classMethodListView codeView classToggle
+ instanceToggle currentClassCategory currentClassHierarchy
+ currentClass currentMethodCategory currentMethod currentSelector
+ showInstance actualClass fullClass lastMethodCategory aspect
+ variableListView fullProtocol lockUpdates autoSearch myLabel'
+ classVariableNames:'CheckForInstancesWhenRemovingClasses'
+ poolDictionaries:''
+ category:'Interface-Browsers'
!
SystemBrowser comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libtool/SystemBrowser.st,v 1.14 1994-10-28 03:29:32 claus Exp $
+$Header: /cvs/stx/stx/libtool/SystemBrowser.st,v 1.15 1994-11-17 14:47:02 claus Exp $
'!
!SystemBrowser class methodsFor:'documentation'!
@@ -52,115 +49,53 @@
version
"
-$Header: /cvs/stx/stx/libtool/SystemBrowser.st,v 1.14 1994-10-28 03:29:32 claus Exp $
+$Header: /cvs/stx/stx/libtool/SystemBrowser.st,v 1.15 1994-11-17 14:47:02 claus Exp $
"
!
documentation
"
this class implements all kinds of class browsers.
- Stypically, it is started with SystemBrowser open, but there are many other startup
- messages, to launch special browsers.
- See the extra document 'doc/misc/sbrowser.doc' for how to use this browser.
+ Typically, it is started with 'SystemBrowser open', but there are many other
+ startup messages, to launch special browsers.
+ See the categories 'startup' and 'special search startup' in the classes
+ protocol.
+
+ Alse, see the extra document 'doc/misc/sbrowser.doc' or the HTML online doc
+ for how to use the browser.
written winter 89 by claus
"
! !
-!SystemBrowser class methodsFor:'general startup'!
-
-open
- "launch a standard browser"
-
- ^ self openOnDisplay:Display
-
- "SystemBrowser open"
-!
-
-openOnDisplay:aDisplay
- "launch a standard browser on another display.
- Does not work currently - still being developped."
-
- ^ self newWithLabel:(self classResources string:'System Browser')
- setupBlock:[:browser | browser setupForAll]
- on:aDisplay
+!SystemBrowser class methodsFor:'initialization'!
+
+initialize
+ "SystemBrowser configuration;
+ (values can be changed from your private startup file)"
"
- SystemBrowser openOnDisplay:(XWorkstation new initializeFor:'porty:0')
+ setting this to false, the removeClass function will remove
+ classes WITHOUT checking for instances. Otherwise,
+ it will check and let you confirm in case there are instances.
+ Checking for instances may be a bit time consuming, though.
+ The default is true - therefore, it will check
+ "
+ CheckForInstancesWhenRemovingClasses := true
+
+ "
+ CheckForInstancesWhenRemovingClasses := true
+ CheckForInstancesWhenRemovingClasses := false
"
! !
!SystemBrowser class methodsFor:'startup'!
-browseFullClasses
- "launch a browser showing all methods at once"
-
- ^ self newWithLabel:'Full Class Browser'
- setupBlock:[:browser | browser setupForFullClass]
-
- "SystemBrowser browseFullClasses"
-!
-
-browseClassCategory:aClassCategory
- "launch a browser for all classes under aCategory"
-
- ^ self newWithLabel:aClassCategory
- setupBlock:[:browser | browser setupForClassCategory:aClassCategory]
-
- "SystemBrowser browseClassCategory:'Kernel-Objects'"
-!
-
-browseClass:aClass
- "launch a browser for aClass"
-
- ^ self newWithLabel:aClass name
- setupBlock:[:browser | browser setupForClass:aClass]
-
- "SystemBrowser browseClass:Object"
-!
-
-browseClassHierarchy:aClass
- "launch a browser for aClass and all its superclasses"
-
- ^ self newWithLabel:(aClass name , '-' , 'hierarchy')
- setupBlock:[:browser | browser setupForClassHierarchy:aClass]
-
- "SystemBrowser browseClassHierarchy:Number"
-!
-
-browseClasses:aList title:title
- "launch a browser for all classes in aList"
-
- ^ self newWithLabel:title
- setupBlock:[:browser | browser setupForClassList:aList]
-
- "
- SystemBrowser browseClasses:(Array with:Object
- with:Float)
- title:'two classes'
- "
-!
-
-browseClass:aClass methodCategory:aCategory
- "launch a browser for all methods under aCategory in aClass"
-
- ^ self newWithLabel:(aClass name , ' ' , aCategory)
- setupBlock:[:browser | browser setupForClass:aClass methodCategory:aCategory]
-
- "SystemBrowser browseClass:String methodCategory:'copying'"
-!
-
-browseClass:aClass selector:selector
- "launch a browser for the method at selector in aClass"
-
- ^ self newWithLabel:(aClass name , ' ' , selector)
- setupBlock:[:browser | browser setupForClass:aClass selector:selector]
-
- "SystemBrowser browseClass:Object selector:#printString"
-!
-
browseMethods:aList title:aString
- "launch a browser for an explicit list of class/selectors"
+ "launch a browser for an explicit list of class/selectors.
+ Each entry in the list must consist of the classes name and the selector,
+ separated by spaces. For class methods, the string 'class' must be
+ appended to the classname."
(aList size == 0) ifTrue:[
self showNoneFound:aString.
@@ -175,63 +110,12 @@
'Collection add:')
title:'some methods'
"
-!
-
-browseMethodCategory:aCategory
- "launch a browser for all methods where category = aCategory"
-
- |searchBlock|
-
- aCategory includesMatchCharacters ifTrue:[
- searchBlock := [:c :m :s | aCategory match:m category].
- ] ifFalse:[
- searchBlock := [:c :m :s | m category = aCategory]
- ].
-
- self browseMethodsWhere:searchBlock title:('all methods with category of ' , aCategory)
-
- "
- SystemBrowser browseMethodCategory:'printing & storing'
- SystemBrowser browseMethodCategory:'print*'
"
-!
-
-browseAllSelect:aBlock
- "launch a browser for all methods where aBlock returns true.
- The block is called with 3 arguments, class, method and seelctor."
-
- ^ self browseMethodsWhere:aBlock title:'selected messages'
-!
-
-browseMethodsWhere:aBlock title:title
- "launch a browser for all methods where aBlock returns true.
- The block is called with 3 arguments, class, method and seelctor."
-
- ^ self browseMethodsIn:(Smalltalk allClasses) where:aBlock title:title
-!
-
-browseMethodsOf:aClass where:aBlock title:title
- "launch a browser for all instance- and classmethods in aClass
- where aBlock evaluates to true.
- The block is called with 3 arguments, class, method and seelctor."
-
- ^ self browseMethodsIn:(Array with:aClass) where:aBlock title:title
-!
-
-browseMethodsFrom:aClass where:aBlock title:title
- "launch a browser for all instance- and classmethods in aClass
- and all its subclasses where aBlock evaluates to true.
- The block is called with 3 arguments, class, method and seelctor."
-
- ^ self browseMethodsIn:(aClass withAllSubclasses) where:aBlock title:title
-!
-
-browseMethodsIn:aCollectionOfClasses where:aBlock title:title
- "launch a browser for all instance- and classmethods from
- all classes in aCollectionOfClasses where aBlock evaluates to true.
- The block is called with 3 arguments, class, method and seelctor."
-
- ^ self browseMethodsIn:aCollectionOfClasses inst:true class:true where:aBlock title:title
+ SystemBrowser browseMethods:#('Behavior new:'
+ 'Setclass new:')
+ title:'some new: methods'
+ "
+
!
browseMethodsIn:aCollectionOfClasses inst:wantInst class:wantClass where:aBlock title:title
@@ -272,6 +156,10 @@
].
aCollectionOfClasses do:[:aClass |
+ "
+ output disabled - it slows down things too much (when searching for
+ implementors or senders)
+ "
"/ Transcript show:'searching '; show:aClass name; showCr:' ...'; endEntry.
wantInst ifTrue:[checkBlock value:aClass].
wantClass ifTrue:[checkBlock value:(aClass class)].
@@ -282,6 +170,152 @@
^ self browseMethods:list title:title
!
+browseMethodsIn:aCollectionOfClasses where:aBlock title:title
+ "launch a browser for all instance- and classmethods from
+ all classes in aCollectionOfClasses where aBlock evaluates to true.
+ The block is called with 3 arguments, class, method and seelctor."
+
+ ^ self browseMethodsIn:aCollectionOfClasses inst:true class:true where:aBlock title:title
+!
+
+browseClassCategory:aClassCategory
+ "launch a browser for all classes under aCategory"
+
+ ^ self newWithLabel:aClassCategory
+ setupBlock:[:browser | browser setupForClassCategory:aClassCategory]
+
+ "SystemBrowser browseClassCategory:'Kernel-Objects'"
+!
+
+browseFullClasses
+ "launch a browser showing all methods at once"
+
+ ^ self newWithLabel:'Full Class Browser'
+ setupBlock:[:browser | browser setupForFullClass]
+
+ "SystemBrowser browseFullClasses"
+!
+
+browseClass:aClass
+ "launch a browser for aClass"
+
+ ^ self newWithLabel:aClass name
+ setupBlock:[:browser | browser setupForClass:aClass]
+
+ "SystemBrowser browseClass:Object"
+!
+
+browseClass:aClass selector:selector
+ "launch a browser for the method at selector in aClass"
+
+ ^ self
+ newWithLabel:(aClass name , ' ' , selector , ' ' , selector)
+ setupBlock:[:browser | browser setupForClass:aClass selector:selector]
+
+ "
+ SystemBrowser browseClass:Object selector:#printString
+ "
+!
+
+browseClassHierarchy:aClass
+ "launch a browser for aClass and all its superclasses.
+ this is different from the fullProtocol browser."
+
+ ^ self newWithLabel:(aClass name , '-' , 'hierarchy')
+ setupBlock:[:browser | browser setupForClassHierarchy:aClass]
+
+ "
+ SystemBrowser browseClassHierarchy:Number
+ "
+!
+
+browseFullClassProtocol:aClass
+ "launch a browser for aClasses full protocol.
+ This is different from hierarchy browsing."
+
+ ^ self newWithLabel:(aClass name , '-' , 'full protocol')
+ setupBlock:[:browser | browser setupForFullClassProtocol:aClass]
+
+ "
+ SystemBrowser browseFullClassProtocol:Number
+ "
+!
+
+browseClasses:aList title:title
+ "launch a browser for all classes in aList"
+
+ ^ self newWithLabel:title
+ setupBlock:[:browser | browser setupForClassList:aList]
+
+ "
+ SystemBrowser browseClasses:(Array with:Object
+ with:Float)
+ title:'two classes'
+ "
+!
+
+browseClass:aClass methodCategory:aCategory
+ "launch a browser for all methods under aCategory in aClass"
+
+ ^ self newWithLabel:(aClass name , ' ' , aCategory)
+ setupBlock:[:browser | browser setupForClass:aClass methodCategory:aCategory]
+
+ "SystemBrowser browseClass:String methodCategory:'copying'"
+!
+
+browseMethodCategory:aCategory
+ "launch a browser for all methods where category = aCategory"
+
+ |searchBlock|
+
+ aCategory includesMatchCharacters ifTrue:[
+ searchBlock := [:c :m :s | aCategory match:m category].
+ ] ifFalse:[
+ searchBlock := [:c :m :s | m category = aCategory]
+ ].
+
+ self browseMethodsWhere:searchBlock title:('all methods with category of ' , aCategory)
+
+ "
+ SystemBrowser browseMethodCategory:'printing & storing'
+ SystemBrowser browseMethodCategory:'print*'
+ "
+!
+
+browseAllSelect:aBlock
+ "launch a browser for all methods where aBlock returns true.
+ The block is called with 3 arguments, class, method and seelctor."
+
+ ^ self browseMethodsWhere:aBlock title:'selected messages'
+
+ "
+ SystemBrowser browseAllSelect:[:aClass :aMethod :selector | selector numArgs == 3]
+ "
+!
+
+browseMethodsWhere:aBlock title:title
+ "launch a browser for all methods where aBlock returns true.
+ The block is called with 3 arguments, class, method and seelctor."
+
+ ^ self browseMethodsIn:(Smalltalk allClasses) where:aBlock title:title
+!
+
+browseMethodsOf:aClass where:aBlock title:title
+ "launch a browser for all instance- and classmethods in aClass
+ where aBlock evaluates to true.
+ The block is called with 3 arguments, class, method and seelctor."
+
+ ^ self browseMethodsIn:(Array with:aClass) where:aBlock title:title
+!
+
+browseMethodsFrom:aClass where:aBlock title:title
+ "launch a browser for all instance- and classmethods in aClass
+ and all its subclasses where aBlock evaluates to true.
+ The block is called with 3 arguments, class, method and seelctor."
+
+ ^ self browseMethodsIn:(aClass withAllSubclasses) where:aBlock title:title
+!
+
browseInstMethodsOf:aClass where:aBlock title:title
"launch a browser for all instance methods in aClass
where aBlock evaluates to true"
@@ -289,23 +323,102 @@
^ self browseMethodsIn:(Array with:aClass) inst:true class:false where:aBlock title:title
!
-browseInstMethodsFrom:aClass where:aBlock title:title
- "launch a browser for all instance methods in aClass and all subclasses
- where aBlock evaluates to true"
-
- ^ self browseMethodsIn:(aClass withAllSubclasses) inst:true class:false where:aBlock title:title
-!
-
browseInstMethodsIn:aCollectionOfClasses where:aBlock title:title
"launch a browser for all instance methods of all classes in
aCollectionOfClasses where aBlock evaluates to true"
^ self browseMethodsIn:aCollectionOfClasses inst:true class:false
where:aBlock title:title
+!
+
+browseInstMethodsFrom:aClass where:aBlock title:title
+ "launch a browser for all instance methods in aClass and all subclasses
+ where aBlock evaluates to true"
+
+ ^ self browseMethodsIn:(aClass withAllSubclasses) inst:true class:false where:aBlock title:title
+!
+
+browseFullClassHierarchy:aClass
+ "launch a browser for aClass and all its superclasses"
+
+ ^ self newWithLabel:(aClass name , '-' , 'full protocol')
+ setupBlock:[:browser | browser setupForFullClassHierarchy:aClass]
+
+ "
+ SystemBrowser browseFullClassHierarchy:Number
+ "
! !
!SystemBrowser class methodsFor:'special search startup'!
+browseAllCallsOn:aSelectorString in:aCollectionOfClasses title:title
+ "launch a browser for all senders of aSelector in aCollectionOfClasses"
+
+ |sel browser searchBlock|
+
+ ((aSelectorString ~= '*') and:[aSelectorString includesMatchCharacters]) ifTrue:[
+ "a matchString"
+ searchBlock := [:lits |
+ |found|
+
+ found := false.
+ lits notNil ifTrue:[
+ lits do:[:aLiteral |
+ found ifFalse:[
+ (aLiteral isMemberOf:Symbol) ifTrue:[
+ found := (aSelectorString match:aLiteral)
+ ]
+ ]
+ ]
+ ].
+ found
+ ].
+ browser := self browseMethodsIn:aCollectionOfClasses
+ where:[:class :method :s | searchBlock value:(method literals)]
+ title:title
+ ] ifFalse:[
+ aSelectorString knownAsSymbol ifFalse:[
+"
+ Transcript showCr:'none found.'.
+"
+ self showNoneFound:title.
+ ^ nil
+ ].
+
+ sel := aSelectorString asSymbol.
+ browser := self browseMethodsIn:aCollectionOfClasses
+ where:[:class :method :s | method sends:sel]
+ title:title
+ ].
+
+ browser notNil ifTrue:[
+ |s|
+
+ "
+ kludge for now, if its a multipart selector,
+ no easy search is (as yet) possible
+ "
+ s := aSelectorString.
+ (s includes:$:) ifTrue:[
+ s := s copyTo:(s indexOf:$:)
+ ].
+ browser autoSearch:s
+ ].
+ ^ browser
+!
+
+browseImplementorsOf:aSelectorString
+ "launch a browser for all implementors of aSelector"
+
+ ^ self browseImplementorsOf:aSelectorString
+ in:(Smalltalk allClasses)
+ title:('implementors of: ' , aSelectorString)
+
+ "
+ SystemBrowser browseImplementorsOf:#+
+ "
+!
+
browseImplementorsOf:aSelectorString in:aCollectionOfClasses title:title
"launch a browser for all implementors of aSelector in
the classes contained in aCollectionOfClasses and its metaclasses"
@@ -358,79 +471,6 @@
"
!
-browseImplementorsOf:aSelectorString
- "launch a browser for all implementors of aSelector"
-
- ^ self browseImplementorsOf:aSelectorString
- in:(Smalltalk allClasses)
- title:('implementors of: ' , aSelectorString)
-
- "
- SystemBrowser browseImplementorsOf:#+
- "
-!
-
-browseImplementorsOf:aSelectorString under:aClass
- "launch a browser for all implementors of aSelector in aClass
- and its subclasses"
-
- ^ self browseImplementorsOf:aSelectorString
- in:(aClass withAllSubclasses)
- title:('implementors of: ' ,
- aSelectorString ,
- ' (in or below ' , aClass name , ')')
-
- "
- SystemBrowser browseImplementorsOf:#+ under:Integer
- "
-!
-
-browseAllCallsOn:aSelectorString in:aCollectionOfClasses title:title
- "launch a browser for all senders of aSelector in aCollectionOfClasses"
-
- |sel browser searchBlock|
-
- ((aSelectorString ~= '*') and:[aSelectorString includesMatchCharacters]) ifTrue:[
- "a matchString"
- searchBlock := [:lits |
- |found|
-
- found := false.
- lits notNil ifTrue:[
- lits do:[:aLiteral |
- found ifFalse:[
- (aLiteral isMemberOf:Symbol) ifTrue:[
- found := (aSelectorString match:aLiteral)
- ]
- ]
- ]
- ].
- found
- ].
- browser := self browseMethodsIn:aCollectionOfClasses
- where:[:class :method :s | searchBlock value:(method literals)]
- title:title
- ] ifFalse:[
- aSelectorString knownAsSymbol ifFalse:[
-"
- Transcript showCr:'none found.'.
-"
- self showNoneFound:title.
- ^ nil
- ].
-
- sel := aSelectorString asSymbol.
- browser := self browseMethodsIn:aCollectionOfClasses
- where:[:class :method :s | method sends:sel]
- title:title
- ].
-
- browser notNil ifTrue:[
- browser setSearchPattern:aSelectorString
- ].
- ^ browser
-!
-
browseAllCallsOn:aSelectorString
"launch a browser for all senders of aSelector"
@@ -457,6 +497,21 @@
"
!
+browseImplementorsOf:aSelectorString under:aClass
+ "launch a browser for all implementors of aSelector in aClass
+ and its subclasses"
+
+ ^ self browseImplementorsOf:aSelectorString
+ in:(aClass withAllSubclasses)
+ title:('implementors of: ' ,
+ aSelectorString ,
+ ' (in or below ' , aClass name , ')')
+
+ "
+ SystemBrowser browseImplementorsOf:#+ under:Integer
+ "
+!
+
browseForSymbol:aSymbol title:title warnIfNone:doWarn
"launch a browser for all methods referencing aSymbol"
@@ -507,11 +562,61 @@
].
browser := self browseMethodsWhere:[:c :m :s | searchBlock value:(m literals)] title:title.
browser notNil ifTrue:[
- browser setSearchPattern:aSymbol
+ browser autoSearch:aSymbol
].
^ browser
!
+filterToSearchInstRefsTo:varName modificationsOnly:modsOnly
+ "return a block to search for instvar accesses"
+
+ |searchBlock|
+
+ searchBlock := [:c :m :s |
+ |src result parser instvars needMatch|
+
+ needMatch := varName includesMatchCharacters.
+
+ src := m source.
+ src isNil ifTrue:[
+ result := false
+ ] ifFalse:[
+ needMatch ifFalse:[
+ "
+ before doing a slow parse, quickly scan the
+ methods source for the variables name ...
+ "
+ result := (src findString:varName) ~~ 0.
+ ] ifTrue:[
+ result := true.
+ ].
+ result ifTrue:[
+ result := false.
+ parser := Parser parseMethod:src in:c.
+ parser notNil ifTrue:[
+ modsOnly ifTrue:[
+ instvars := parser modifiedInstVars
+ ] ifFalse:[
+ instvars := parser usedInstVars
+ ].
+ instvars notNil ifTrue:[
+ needMatch ifTrue:[
+ instvars do:[:iv |
+ (varName match:iv) ifTrue:[result := true]
+ ]
+ ] ifFalse:[
+ result := instvars includes:varName
+ ]
+ ]
+ ]
+ ].
+ ].
+ Processor yield.
+ result
+ ].
+ ^ searchBlock
+!
+
browseForSymbol:aSymbol
"launch a browser for all methods referencing aSymbol"
@@ -538,6 +643,117 @@
"
!
+browseUsesOf:aClass
+ |dict owners offsets
+ sz "{ Class: SmallInteger }"
+ n "{ Class: SmallInteger }"
+ removeSet newDict|
+
+ owners := ObjectMemory whoReferencesInstancesOf:aClass.
+
+ "
+ collect set of offsets in dict; key is class
+ "
+ dict := IdentityDictionary new.
+ owners do:[:someObject |
+ |cls create|
+
+ someObject isContext ifFalse:[
+ "
+ someObject refers to an instance of aClass;
+ find out, which instVar(s)
+ "
+ cls := someObject class.
+ cls ~~ Array ifTrue:[
+ n := cls instSize.
+ create := [|s| s := Set new. dict at:cls put:s. s].
+
+ 1 to:n do:[:i |
+ |ref|
+
+ ref := someObject instVarAt:i.
+ (ref isMemberOf:aClass) ifTrue:[
+ offsets := dict at:cls ifAbsent:create.
+ offsets add:i.
+ ]
+ ].
+ cls isVariable ifTrue:[
+ cls isPointers ifTrue:[
+ | idx "{ Class: SmallInteger }" |
+
+ sz := someObject basicSize.
+ idx := 1.
+ [idx <= sz] whileTrue:[
+ |ref|
+
+ ref := someObject basicAt:idx.
+ (ref isMemberOf:aClass) ifTrue:[
+ offsets := dict at:cls ifAbsent:create.
+ offsets add:0.
+ idx := sz
+ ].
+ idx := idx + 1
+ ]
+ ]
+ ]
+ ]
+ ]
+ ].
+
+ "
+ merge with superclass refs
+ "
+ dict keysAndValuesDo:[:cls :set |
+ cls allSuperclasses do:[:aSuperclass |
+ |superSet|
+
+ superSet := dict at:aSuperclass ifAbsent:[].
+ superSet notNil ifTrue:[
+ |removeSet|
+
+ superSet := dict at:aSuperclass.
+ removeSet := Set new.
+ set do:[:offset |
+ (superSet includes:offset) ifTrue:[
+ removeSet add:offset
+ ]
+ ].
+ set removeAll:removeSet
+ ]
+ ]
+ ].
+
+ "
+ remove empty ones
+ "
+ removeSet := Set new.
+ dict keysAndValuesDo:[:cls :set |
+ set isEmpty ifTrue:[
+ removeSet add:cls
+ ]
+ ].
+ removeSet do:[:cls |
+ dict removeKey:cls
+ ].
+
+ "
+ replace the indices by real names
+ "
+ newDict := IdentityDictionary new.
+ dict keysAndValuesDo:[:cls :set |
+ |newSet names|
+
+ names := cls allInstVarNames.
+ newSet := set collect:[:index |
+ index == 0 ifTrue:['*indexed*'] ifFalse:[names at:index].
+ ].
+ newDict at:cls put:newSet
+ ].
+
+ newDict inspect
+
+!
+
browseForString:aString in:aCollectionOfClasses
"launch a browser for all methods in aCollectionOfClasses
containing a string-constant"
@@ -585,7 +801,7 @@
title:title.
browser notNil ifTrue:[
- browser setSearchPattern:aString
+ browser autoSearch:aString
].
^ browser
@@ -600,6 +816,22 @@
^ self browseForString:aString in:(Smalltalk allClasses)
!
+browseInstRefsTo:varName in:aCollectionOfClasses modificationsOnly:modsOnly title:title
+ "launch a browser for all methods in aClass where the instVar named
+ varName is referenced; if modsOnly is true, browse only methods where the
+ instvar is modified"
+
+ |filter browser|
+
+ filter := self filterToSearchInstRefsTo:varName modificationsOnly:modsOnly.
+ browser := self browseInstMethodsIn:aCollectionOfClasses where:filter title:title.
+
+ browser notNil ifTrue:[
+ browser autoSearch:varName
+ ].
+ ^ browser
+!
+
aproposSearch:aString in:aCollectionOfClasses
"browse all methods, which have aString in their selector or
in the methods comment.
@@ -629,71 +861,6 @@
"SystemBrowser aproposSearch:'sort'"
!
-aproposSearch:aString
- "browse all methods, which have aString in their selector or
- in the methods comment.
- This is relatively slow, since all source must be processed."
-
- ^ self aproposSearch:aString in:(Smalltalk allClasses)
-!
-
-browseInstRefsTo:varName in:aCollectionOfClasses modificationsOnly:modsOnly title:title
- "launch a browser for all methods in aClass where the instVar named
- varName is referenced; if modsOnly is true, browse only methods where the
- instvar is modified"
-
- |searchBlock browser needMatch|
-
- needMatch := varName includesMatchCharacters.
-
- searchBlock := [:c :m :s |
- |src result parser instvars|
-
- src := m source.
- src isNil ifTrue:[
- result := false
- ] ifFalse:[
- needMatch ifFalse:[
- "
- before doing a slow parse, quickly scan the
- methods source for the variables name ...
- "
- result := (src findString:varName) ~~ 0.
- ] ifTrue:[
- result := true.
- ].
- result ifTrue:[
- result := false.
- parser := Parser parseMethod:src in:c.
- parser notNil ifTrue:[
- modsOnly ifTrue:[
- instvars := parser modifiedInstVars
- ] ifFalse:[
- instvars := parser usedInstVars
- ].
- instvars notNil ifTrue:[
- needMatch ifTrue:[
- instvars do:[:iv |
- (varName match:iv) ifTrue:[result := true]
- ]
- ] ifFalse:[
- result := instvars includes:varName
- ]
- ]
- ]
- ].
- ].
- Processor yield.
- result
- ].
- browser := self browseInstMethodsIn:aCollectionOfClasses where:searchBlock title:title.
-
- browser notNil ifTrue:[
- browser setSearchPattern:varName
- ].
- ^ browser
-!
-
browseInstRefsTo:aString in:aCollectionOfClasses modificationsOnly:modsOnly
"launch a browser for all methods in aClass where the instVar named
aString is referenced; if modsOnly is true, browse only methods where the
@@ -712,6 +879,14 @@
title:(title , aString)
!
+aproposSearch:aString
+ "browse all methods, which have aString in their selector or
+ in the methods comment.
+ This is relatively slow, since all source must be processed."
+
+ ^ self aproposSearch:aString in:(Smalltalk allClasses)
+!
+
browseInstRefsTo:aString under:aClass modificationsOnly:modsOnly
"launch a browser for all methods in aClass and subclasses
where the instVar named aString is referenced;
@@ -725,12 +900,49 @@
where the classVar named aString is referenced;
if modsOnly is true, browse only methods where the classvar is modified"
- |needMatch searchBlock browser|
-
- needMatch := varName includesMatchCharacters.
+ |searchBlock browser|
+
+ searchBlock := self filterToSearchClassRefsTo:varName modificationsOnly:modsOnly.
+ browser := self browseMethodsIn:aCollectionOfClasses where:searchBlock title:title.
+
+ browser notNil ifTrue:[
+ browser autoSearch:varName
+ ].
+ ^ browser
+!
+
+browseClassRefsTo:aString in:aCollectionOfClasses modificationsOnly:modsOnly
+ "launch a browser for all methods in aClass where the classVar named
+ aString is referenced; if modsOnly is true, browse only methods where the
+ classvar is modified"
+
+ |title|
+
+ modsOnly ifTrue:[
+ title := 'modifications of '
+ ] ifFalse:[
+ title := 'references to '
+ ].
+ ^ self browseClassRefsTo:aString in:aCollectionOfClasses modificationsOnly:modsOnly title:(title , aString)
+!
+
+browseClassRefsTo:aString under:aClass modificationsOnly:modsOnly
+ "launch a browser for all methods in aClass and subclasses
+ where the classVar named aString is referenced;
+ if modsOnly is true, browse only methods where the classvar is modified"
+
+ ^ self browseClassRefsTo:aString in:(aClass withAllSubclasses) modificationsOnly:modsOnly
+!
+
+filterToSearchClassRefsTo:varName modificationsOnly:modsOnly
+ "return a searchblock for class variable references"
+
+ |searchBlock|
searchBlock := [:c :m :s |
- |src result parser classvars|
+ |src result parser classvars needMatch|
+
+ needMatch := varName includesMatchCharacters.
src := m source.
src isNil ifTrue:[
@@ -769,55 +981,18 @@
Processor yield.
result
].
- browser := self browseMethodsIn:aCollectionOfClasses where:searchBlock title:title.
-
- browser notNil ifTrue:[
- browser setSearchPattern:varName
- ].
- ^ browser
-!
-
-browseClassRefsTo:aString in:aCollectionOfClasses modificationsOnly:modsOnly
- "launch a browser for all methods in aClass where the classVar named
- aString is referenced; if modsOnly is true, browse only methods where the
- classvar is modified"
-
- |title|
-
- modsOnly ifTrue:[
- title := 'modifications of '
- ] ifFalse:[
- title := 'references to '
- ].
- ^ self browseClassRefsTo:aString in:aCollectionOfClasses modificationsOnly:modsOnly title:(title , aString)
-!
-
-browseClassRefsTo:aString under:aClass modificationsOnly:modsOnly
- "launch a browser for all methods in aClass and subclasses
- where the classVar named aString is referenced;
- if modsOnly is true, browse only methods where the classvar is modified"
-
- ^ self browseClassRefsTo:aString in:(aClass withAllSubclasses) modificationsOnly:modsOnly
+ ^ searchBlock
! !
!SystemBrowser class methodsFor:'private'!
-showNoneFound:what
-"/ DialogView warn:(self classResources string:('no ' , what , ' found')).
- self showNoneFound
-!
-
-showNoneFound
- DialogView warn:(self classResources string:'None found').
-!
-
newWithLabel:aString setupBlock:aBlock on:aWorkstation
"common helper method for all creation methods"
|newBrowser|
newBrowser := self on:aWorkstation.
- newBrowser label:aString.
+ newBrowser title:aString.
aBlock value:newBrowser.
newBrowser open.
@@ -828,470 +1003,264 @@
"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 methodsFor:'initialize / release'!
-
-initialize
- super initialize.
-
- self icon:(Form fromFile:(resources at:'ICON_FILE' default:'SBrowser.xbm')
- resolution:100).
-
- showInstance := true.
- fullClass := false.
- aspect := nil.
-
- "inform me, when Smalltalk changes"
- Smalltalk addDependent:self
-!
-
-destroy
- "relese dependant - destroy popups"
-
- Smalltalk removeDependent:self.
- currentClass notNil ifTrue:[
- currentClass removeDependent:self.
- currentClass := nil
+!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
].
- super destroy
-!
-
-terminate
- (self checkSelectionChangeAllowed) ifTrue:[
- super terminate
- ]
-!
-
-createTogglesIn:aFrame
- "create and setup the class/instance toggles"
-
- |halfSpacing h|
-
- instanceToggle := Toggle label:(resources at:'instance') in:aFrame.
- h := instanceToggle height.
- instanceToggle origin:(0.0 @ 1.0) corner:(0.5 @ 1.0).
- instanceToggle topInset:(h negated).
-
- instanceToggle turnOn.
- instanceToggle pressAction:[self instanceProtocol].
- instanceToggle releaseAction:[self classProtocol].
-
- classToggle := Toggle label:(resources at:'class') in:aFrame.
- h := classToggle height.
- classToggle origin:(0.5 @ 1.0) corner:(1.0 @ 1.0).
- classToggle topInset:(h negated).
-
- classToggle turnOff.
- classToggle pressAction:[self classProtocol].
- classToggle releaseAction:[self instanceProtocol].
-
- StyleSheet is3D ifTrue:[
- instanceToggle leftInset:(ViewSpacing // 2).
- classToggle leftInset:(ViewSpacing // 2).
- instanceToggle rightInset:ViewSpacing - (ViewSpacing // 2).
- classToggle rightInset:ViewSpacing - (ViewSpacing // 2).
+
+"/ changedObject print. ' ' print. someArgument print. ' ' print.
+"/ something printNL.
+
+ (changedObject == Smalltalk) ifTrue:[
+ something == #newClass ifTrue:[
+ ((someArgument category = currentClassCategory)
+ or:[currentClassCategory notNil
+ and:[currentClassCategory startsWith:'*']]) ifTrue:[
+ self updateClassListWithScroll:false.
+ ].
+
+ someArgument category ~= currentClassCategory ifTrue:[
+ "
+ category new ?
+ "
+ (classCategoryListView notNil
+ and:[classCategoryListView list notNil
+ and:[(classCategoryListView list includes:someArgument category) not]])
+ ifTrue:[
+ self updateClassCategoryListWithScroll:false.
+ ]
+ ].
+ ^ self
+ ].
+
+ something == #classRemove ifTrue:[
+ someArgument = currentClass ifTrue:[
+ self warnLabel:'the selected class was removed'.
+ ^ self
+ ].
+ " fall into general update "
+ ].
+
+ "
+ any other (unknown) change
+ with the Smalltalk dictionary ...
+ "
+ self updateClassCategoryListWithScroll:false.
+ self updateClassListWithScroll:false.
+ ^ self
].
-!
-
-createClassListViewIn:frame
- "setup the classlist subview, with its toggles"
-
- |v panel oldStyle|
-
- self createTogglesIn:frame.
-
-"/ oldStyle := true.
-oldStyle := false.
- oldStyle ifTrue:[
- v := ScrollableView for:SelectionInListView in:frame.
- v origin:(0.0 @ 0.0)
- extent:[frame width
- @
- (frame height
- - (ViewSpacing // 2)
- - instanceToggle height
- - instanceToggle borderWidth
- + v borderWidth)].
-
- classListView := v scrolledView
- ] ifFalse:[
- panel := VariableVerticalPanel
- origin:(0.0 @ 0.0)
- corner:[frame width
- @
- (frame height
- - (ViewSpacing // 2)
- - instanceToggle height
- - instanceToggle borderWidth
- + v borderWidth)]
- in:frame.
-
- v := ScrollableView for:SelectionInListView in:panel.
- v origin:(0.0 @ 0.0) corner:(1.0 @ 0.5).
- classListView := v scrolledView.
-
-
- v := ScrollableView for:SelectionInListView in:panel.
- v origin:(0.0 @ 0.5)
- corner:(1.0 @ 1.0).
-
- variableListView := v scrolledView
- ]
-!
-
-createCodeViewIn:aView
- "setup the code view"
- |v|
-
- v := HVScrollableView for:CodeView miniScrollerH:true miniScrollerV:false in:aView.
- v origin:(0.0 @ 0.25) corner:(1.0 @ 1.0).
- codeView := v scrolledView
-!
-
-setupActions
-"/ |v|
-
-"/ v := classCategoryListView.
-"/ v notNil ifTrue:[
-"/ v action:[:lineNr | self classCategorySelection:lineNr].
-"/ v selectConditionBlock:[self checkSelectionChangeAllowed].
-"/ v ignoreReselect:false.
-"/ ].
-"/ v := classListView.
-"/ v notNil ifTrue:[
-"/ v action:[:lineNr | self classSelection:lineNr].
-"/ v selectConditionBlock:[self checkSelectionChangeAllowed].
-"/ v ignoreReselect:false.
-"/ ].
-"/ v := methodCategoryListView.
-"/ v notNil ifTrue:[
-"/ v action:[:lineNr | self methodCategorySelection:lineNr].
-"/ v selectConditionBlock:[self checkSelectionChangeAllowed].
-"/ v ignoreReselect:false.
-"/ ].
-"/ v := methodListView.
-"/ v notNil ifTrue:[
-"/ v action:[:lineNr | self methodSelection:lineNr].
-"/ v selectConditionBlock:[self checkSelectionChangeAllowed].
-"/ v ignoreReselect:false.
-"/ ].
-"/ v := classMethodListView.
-"/ v notNil ifTrue:[
-"/ v action:[:lineNr | self listSelection:lineNr].
-"/ v selectConditionBlock:[self checkSelectionChangeAllowed].
-"/ v ignoreReselect:false.
-"/ ]
-!
-
-setupForAll
- "create subviews for a full browser"
-
- |vpanel hpanel frame v|
-
- vpanel := VariableVerticalPanel origin:(0.0 @ 0.0) corner:(1.0 @ 1.0)
- in:self.
- hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
-
- v := HVScrollableView for:SelectionInListView
- miniScrollerH:true miniScrollerV:false
- in:hpanel.
- v origin:(0.0 @ 0.0) corner:(0.25 @ 1.0).
- classCategoryListView := v scrolledView.
-"/ classCategoryListView contents:(self listOfAllClassCategories).
-
- frame := View origin:(0.25 @ 0.0) corner:(0.5 @ 1.0) in:hpanel.
- self createClassListViewIn:frame.
-
- v := HVScrollableView for:SelectionInListView miniScrollerH:true miniScrollerV:false in:hpanel.
- v origin:(0.5 @ 0.0) corner:(0.75 @ 1.0).
- methodCategoryListView := v scrolledView.
-
- v := HVScrollableView for:SelectionInListView miniScrollerH:true miniScrollerV:false in:hpanel.
- v origin:(0.75 @ 0.0) corner:(1.0 @ 1.0).
- methodListView := v scrolledView.
-
-"/ self setupActions.
- self createCodeViewIn:vpanel
-!
-
-setupForFullClass
- "setup subviews to browse a class as full text"
-
- |vpanel hpanel v|
-
- vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
- corner:(1.0 @ 1.0)
- in:self.
-
- hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
-
- v := ScrollableView for:SelectionInListView in:hpanel.
- v origin:(0.0 @ 0.0) corner:(0.5 @ 1.0).
- classCategoryListView := v scrolledView.
- classCategoryListView contents:(self listOfAllClassCategories).
-
- v := ScrollableView for:SelectionInListView in:hpanel.
- v origin:(0.5 @ 0.0) corner:(1.0 @ 1.0).
- classListView := v scrolledView.
-
-"/ self setupActions.
- self createCodeViewIn:vpanel.
-
- fullClass := true.
- self updateCodeView
-!
-
-setupForClassCategory:aClassCategory
- "setup subviews to browse a class category"
-
- |vpanel hpanel frame v|
-
- vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
- corner:(1.0 @ 1.0)
- in:self.
-
- hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
- frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
-
- self createClassListViewIn:frame.
-
- v := ScrollableView for:SelectionInListView in:hpanel.
- v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
- methodCategoryListView := v scrolledView.
-
- v := ScrollableView for:SelectionInListView in:hpanel.
- v origin:(0.66 @ 0.0) corner:(1.0 @ 1.0).
- methodListView := v scrolledView.
-
-"/ self setupActions.
- self createCodeViewIn:vpanel.
-
- currentClassCategory := aClassCategory.
- self updateClassList.
- self updateMethodCategoryList.
- self updateMethodList.
- self updateCodeView
-!
-
-setupForClassList:aList
- "setup subviews to browse classes from a list"
-
- |vpanel hpanel frame l v|
-
- vpanel := VariableVerticalPanel
- origin:(0.0 @ 0.0) corner:(1.0 @ 1.0) in:self.
-
- hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
- frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
-
- self createClassListViewIn:frame.
-
- v := ScrollableView for:SelectionInListView in:hpanel.
- v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
- methodCategoryListView := v scrolledView.
-
- v := ScrollableView for:SelectionInListView in:hpanel.
- v origin:(0.66 @ 0.0) corner:(1.0 @ 1.0).
- methodListView := v scrolledView.
-
-"/ self setupActions.
- self createCodeViewIn:vpanel.
-
- l := aList collect:[:entry | entry name].
- classListView list:(l sort).
-
- self updateMethodCategoryList.
- self updateMethodList.
- self updateCodeView
-!
-
-setupForClassHierarchy:aClass
- "setup subviews to browse a class hierarchy"
-
- |vpanel hpanel frame v|
-
- vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
- corner:(1.0 @ 1.0)
- in:self.
-
- hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
- frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
-
- self createClassListViewIn:frame.
-
- v := ScrollableView for:SelectionInListView in:hpanel.
- v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
- methodCategoryListView := v scrolledView.
-
- v := ScrollableView for:SelectionInListView in:hpanel.
- v origin:(0.66 @ 0.0) corner:(1.0 @ 1.0).
- methodListView := v scrolledView.
-
-"/ self setupActions.
- self createCodeViewIn:vpanel.
-
- currentClassHierarchy := aClass.
- self updateClassList.
- self updateMethodCategoryList.
- self updateMethodList.
- self updateCodeView
-!
-
-setupForClass:aClass
- "create subviews for browsing a single class"
-
- |vpanel hpanel frame v|
-
- vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
- corner:(1.0 @ 1.0)
- in:self.
-
- hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
- frame := View origin:(0.0 @ 0.0) corner:(0.5 @ 1.0)in:hpanel.
-
- self createTogglesIn:frame.
-
- v := ScrollableView for:SelectionInListView in:frame.
- v origin:(0.0 @ 0.0)
- extent:[frame width
- @
- (frame height
- - (ViewSpacing // 2)
- - instanceToggle height
- - instanceToggle borderWidth
- + v borderWidth)].
- methodCategoryListView := v scrolledView.
-
- v := ScrollableView for:SelectionInListView in:hpanel.
- v origin:(0.5 @ 0.0) corner:(1.0 @ 1.0).
- methodListView := v scrolledView.
-
-"/ self setupActions.
- self createCodeViewIn:vpanel.
-
- self switchToClass:aClass.
- actualClass := aClass.
- self updateMethodCategoryList.
- self updateMethodList.
- self updateCodeView
-!
-
-setupForClass:aClass methodCategory:aMethodCategory
- "setup subviews to browse a method category"
-
- |vpanel v|
-
- vpanel := VariableVerticalPanel
- origin:(0.0 @ 0.0) corner:(1.0 @ 1.0)
- in:self.
-
- v := ScrollableView for:SelectionInListView in:vpanel.
- v origin:(0.0 @ 0.0) corner:(1.0 @ 0.25).
- methodListView := v scrolledView.
-
-"/ self setupActions.
- self createCodeViewIn:vpanel.
-
- currentClassCategory := aClass category.
- self switchToClass:aClass.
- actualClass := aClass.
- currentMethodCategory := aMethodCategory.
- self updateMethodList.
- self updateCodeView
-!
-
-setupForClass:aClass selector:selector
- "setup subviews to browse a single method"
-
- |v|
-
- v := ScrollableView for:CodeView in:self.
- v origin:(0.0 @ 0.0) corner:(1.0 @ 1.0).
- codeView := v scrolledView.
-
- currentClassCategory := aClass category.
- self switchToClass:aClass.
- actualClass := aClass.
- currentMethod := currentClass compiledMethodAt:selector.
- currentMethodCategory := currentMethod category.
- self updateCodeView
-!
-
-setupForList:aList
- "setup subviews to browse methods from a list"
-
- |vpanel v|
-
- vpanel := VariableVerticalPanel
- origin:(0.0 @ 0.0)
- corner:(1.0 @ 1.0)
- in:self.
-
- v := ScrollableView for:SelectionInListView in:vpanel.
- v origin:(0.0 @ 0.0) corner:(1.0 @ 0.25).
- classMethodListView := v scrolledView.
- classMethodListView contents:aList.
-
-"/ self setupActions.
- self createCodeViewIn:vpanel.
-
- self updateCodeView
-! !
-
-!SystemBrowser methodsFor:'realization'!
-
-realize
- |v checkBlock|
-
- super realize.
-
- checkBlock := [:lineNr | self checkSelectionChangeAllowed].
-
- v := classCategoryListView.
- v notNil ifTrue:[
- v action:[:lineNr | self classCategorySelection:lineNr].
- v selectConditionBlock:checkBlock.
- v ignoreReselect:false.
- v contents:(self listOfAllClassCategories).
- self initializeClassCategoryMenu
+
+ 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
].
- v := classListView.
- v notNil ifTrue:[
- v action:[:lineNr | self classSelection:lineNr].
- v selectConditionBlock:checkBlock.
- v ignoreReselect:false.
- self initializeClassMenu
- ].
-
- v := methodCategoryListView.
- v notNil ifTrue:[
- v action:[:lineNr | self methodCategorySelection:lineNr].
- v selectConditionBlock:checkBlock.
- v ignoreReselect:false.
- self initializeMethodCategoryMenu
- ].
-
- v := methodListView.
- v notNil ifTrue:[
- v action:[:lineNr | self methodSelection:lineNr].
- v selectConditionBlock:checkBlock.
- v ignoreReselect:false.
- self initializeMethodMenu
- ].
-
- v := classMethodListView.
- v notNil ifTrue:[
- v action:[:lineNr | self listSelection:lineNr].
- v selectConditionBlock:checkBlock.
- v ignoreReselect:false.
- self initializeClassMethodMenu
+ (changedObject isKindOf:Method) ifTrue:[
+
]
! !
!SystemBrowser methodsFor:'private'!
+normalLabel
+ "set the normal (inactive) window- and icon labels"
+
+ |l il sel|
+
+ myLabel notNil ifTrue:[
+ l := il := myLabel
+ ] ifFalse:[
+ l := resources string:'System Browser'.
+
+ currentClass notNil ifTrue:[
+ l := l, ': ', currentClass name.
+ classListView isNil ifTrue:[
+ currentSelector notNil ifTrue:[
+ l := l , ' ' , currentSelector
+ ]
+ ].
+ il := currentClass name
+ ] ifFalse:[
+ il := l.
+ ]
+ ].
+ self label:l.
+ self iconLabel:il.
+
+!
+
+setAcceptAndExplainActionsForMethod
+ "tell the codeView what to do on accept and explain"
+
+ codeView acceptAction:[:theCode |
+ |cat|
+
+ codeView cursor:Cursor execute.
+
+ (cat := currentMethodCategory) = '* all *' ifTrue:[
+ "must check from which category this code came from ...
+ ... thanks to Arno for pointing this out"
+
+ cat := self askForMethodCategory.
+ ].
+ (cat notNil and:[cat notEmpty]) ifTrue:[
+ Object abortSignal catch:[
+ lockUpdates := true.
+
+ actualClass compiler
+ compile:theCode asString
+ forClass:actualClass
+ inCategory:cat
+ notifying:codeView.
+
+ codeView modified:false.
+ self updateMethodListWithScroll:false.
+ ].
+ lockUpdates := false.
+ ].
+ codeView cursor:Cursor normal.
+ ].
+
+ codeView explainAction:[:theCode :theSelection |
+ self showExplanation:(Explainer
+ explain:theSelection
+ in:theCode
+ forClass:actualClass)
+ ].
+!
+
checkSelectionChangeAllowed
"return true, if selection change is ok;
its not ok, if code has been changed.
@@ -1302,6 +1271,7 @@
codeView modified ifFalse:[
^ true
].
+"/ fullProtocol ifTrue:[^ true].
box := YesNoBox
title:(resources at:'contents in codeview has not been accepted.\\Modifications will be lost when continuing.') withCRs
yesText:(resources at:'continue')
@@ -1309,39 +1279,6 @@
^ box confirm
!
-switchToClass:newClass
- currentClass notNil ifTrue:[
- currentClass removeDependent:self
- ].
- currentClass := newClass.
- currentClass notNil ifTrue:[
- currentClass addDependent:self.
- ].
- self normalLabel
-!
-
-showExplanation:someText
- "show explanation from Parser"
-
- self notify:someText
-!
-
-normalLabel
- "set the normal (inactive) window- and icon labels"
-
- currentClass notNil ifTrue:[
- self label:'System Browser: ', currentClass name.
- self iconLabel:currentClass name
- ] ifFalse:[
- self label:'System Browser'.
- self iconLabel:'System Browser'.
- ]
-!
-
-setSearchPattern:aString
- codeView setSearchPattern:aString
-!
-
selectorToSearchFor
"look in codeView and methodListView for a search-string when searching for selectors"
@@ -1354,7 +1291,13 @@
t notNil ifTrue:[
sel := t
].
- sel := sel withoutSpaces
+ 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
@@ -1375,6 +1318,50 @@
^ sel
!
+enterBoxTitle:title okText:okText
+ "convenient method: setup enterBox"
+
+ |box|
+
+ box := EnterBox new.
+ box title:(resources string:title) okText:(resources string:okText).
+ ^ box
+!
+
+askAndBrowseSelectorTitle:title action:aBlock
+ "convenient method: setup enterBox with text from codeView or selected
+ method for browsing based on a selector. Set action and launch box"
+
+ |box|
+
+ box := self enterBoxTitle:title okText:'browse'.
+ box initialText:(self selectorToSearchFor).
+ box action:[:aString | self withCursor:(Cursor questionMark) do:[aBlock value:aString]].
+ box showAtPointer
+!
+
+setSearchPattern:aString
+ codeView setSearchPattern:aString
+!
+
+listBoxTitle:title okText:okText list:aList
+ "convenient method: setup a listBox & return it"
+
+ |box|
+
+ box := ListSelectionBox new.
+ box okText:(resources string:okText).
+ box title:(resources string:title).
+ box list:aList.
+ ^ box
+!
+
+showExplanation:someText
+ "show explanation from Parser"
+
+ self notify:someText
+!
+
stringToSearchFor
"look in codeView and methodListView for a search-string when searching for classes/names"
@@ -1423,45 +1410,11 @@
"
homeClass := currentClass
] ifFalse:[
- Transcript showCr:'starting search in ' , homeClass name.
+"/ Transcript showCr:'starting search in ' , homeClass name.
].
^ homeClass
!
-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
-!
-
-enterBoxTitle:title okText:okText
- "convenient method: setup enterBox"
-
- |box|
-
- box := EnterBox new.
- box title:(resources string:title) okText:(resources string:okText).
- ^ box
-!
-
-askBoxTitle:title okText:okText initialText:initialText action:aBlock
- "convenient method: setup enterBox, and open it"
-
- |box|
-
- box := EnterBox new.
- box title:(resources string:title) okText:(resources string:okText).
- box initialText:initialText.
- box action:[:aString | self withWaitCursorDo:aBlock value:aString].
- box showAtPointer
-!
-
enterBoxForSearchSelectorTitle:title
"convenient method: setup enterBox with text from codeView or selected
method for browsing based on a selector"
@@ -1473,30 +1426,6 @@
^ 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
-!
-
-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
-!
-
enterBoxForCodeSelectionTitle:title okText:okText
"convenient method: setup enterBox with text from codeview"
@@ -1510,6 +1439,46 @@
^ box
!
+classesInFullProtocolHierarchy:aClass do:aBlock
+ "evaluate aBlock for all non-striked out classes in
+ the hierarchy"
+
+ |index|
+
+ index := (classListView list size).
+ aClass withAllSuperclasses do:[:c |
+ (classListView isInSelection:index) ifFalse:[
+ aBlock value:c
+ ].
+ index := index - 1
+ ]
+
+!
+
+enterBoxForBrowseTitle:title action:aBlock
+ "convenient method: setup enterBox with text from codeView or selected
+ method for method browsing based on className/variable"
+
+ |box|
+
+ box := self enterBoxTitle:title okText:'browse'.
+ box initialText:(self stringToSearchFor).
+ box action:[:aString | self withWaitCursorDo:[aBlock value:aString]].
+ box showAtPointer
+!
+
+askBoxTitle:title okText:okText initialText:initialText action:aBlock
+ "convenient method: setup enterBox, and open it"
+
+ |box|
+
+ box := EnterBox new.
+ box title:(resources string:title) okText:(resources string:okText).
+ box initialText:initialText.
+ box action:[:aString | self withWaitCursorDo:aBlock value:aString].
+ box showAtPointer
+!
+
askAndBrowseMethodCategory:title action:aBlock
"convenient method: setup enterBox with initial being current method category"
@@ -1529,42 +1498,1461 @@
box showAtPointer
!
-listOfAllClassCategories
- "return a list of all class categories"
+classHierarchyDo:aBlock
+ "eavluate the 2-arg block for every class,
+ starting at Object; passing class and nesting level to the block."
+
+ |classes s classDict l|
+
+ classes := Smalltalk allClasses.
+ classDict := IdentityDictionary new:classes size.
+ classes do:[:aClass |
+ s := aClass superclass.
+ s notNil ifTrue:[
+ l := classDict at:s ifAbsent:[nil].
+ l isNil ifTrue:[
+ l := OrderedCollection new:5.
+ classDict at:s put:l
+ ].
+ l add:aClass
+ ]
+ ].
+ self classHierarchyOf:Object level:0 do:aBlock using:classDict
+!
+
+classHierarchyOf:aClass level:level do:aBlock using:aDictionary
+ "evaluate the 2-arg block for every subclass of aClass,
+ passing class and nesting level to the block."
+
+ |names subclasses|
+
+ aBlock value:aClass value:level.
+ subclasses := aDictionary at:aClass ifAbsent:[nil].
+ (subclasses size == 0) ifFalse:[
+ names := subclasses collect:[:class | class name].
+ names sortWith:subclasses.
+ subclasses do:[:aSubClass |
+ self classHierarchyOf:aSubClass level:(level + 1) do:aBlock using:aDictionary
+ ]
+ ]
+!
+
+compileCode:someCode
+ (ReadStream on:someCode) fileIn
+!
+
+extractClassAndSelectorFromSelectionInto:aBlock
+ "given a string which can be either 'class>>sel' or
+ 'class sel', extract className and selector, and call aBlock with
+ the result."
+
+ |sel clsName isMeta sep s|
+
+ sel := codeView selection.
+ sel notNil ifTrue:[
+ sel := sel asString withoutSeparators.
+ ('*>>*' match:sel) ifTrue:[
+ sep := $>
+ ] ifFalse:[
+ ('* *' match:sel) ifTrue:[
+ sep := Character space
+ ]
+ ].
+ sep notNil ifTrue:[
+ "
+ extract class/sel from selection
+ "
+ s := ReadStream on:sel.
+ clsName := s upTo:sep.
+ [s peek == sep] whileTrue:[s next].
+ sel := s upToEnd.
+
+ (clsName endsWith:'class') ifTrue:[
+ isMeta := true.
+ clsName := clsName copyTo:(clsName size - 5)
+ ] ifFalse:[
+ isMeta := false
+ ].
+ ]
+ ].
+ aBlock value:clsName value:sel value:isMeta
+
+
+!
+
+classesInHierarchy:aClass do:aBlock
+ |index|
+
+ index := (classListView list size).
+ aClass withAllSuperclasses do:[:c |
+ (classListView isInSelection:index) ifFalse:[
+ aBlock value:c
+ ].
+ index := index - 1
+ ]
+
+!
+
+askForMethodCategory
+ |someCategories box txt|
+
+ someCategories := actualClass categories sort.
+ box := self listBoxTitle:'accept in which method category ?' okText:'accept' list:someCategories.
+
+ lastMethodCategory isNil ifTrue:[
+ txt := 'new methods'
+ ] ifFalse:[
+ txt := lastMethodCategory
+ ].
+ box initialText:txt.
+ box action:[:aString |
+ ^ aString
+ ].
+ box showAtPointer.
+ ^ nil
+!
+
+warnLabel:what
+ "set the title for some warning"
+
+ self label:('System Browser WARNING: ' , what)
+!
+
+busyLabel:what with:someArgument
+ "set the title for some warning"
+
+ self label:('System Browser:' , (resources string:what with:someArgument))
+
+! !
+
+!SystemBrowser methodsFor:'method stuff'!
+
+updateMethodListWithScroll:scroll
+ |selectors scr first last|
+
+ methodListView notNil ifTrue:[
+ currentMethodCategory notNil ifTrue:[
+ fullProtocol ifTrue:[
+ selectors := self listOfAllSelectorsInCategory:currentMethodCategory
+ inFullProtocolHierarchyOfClass:actualClass
+ ] ifFalse:[
+ selectors := self listOfAllSelectorsInCategory:currentMethodCategory
+ ofClass:actualClass
+ ]
+ ].
+ scr := scroll.
+ first := methodListView firstLineShown.
+ first ~~ 1 ifTrue:[
+ last := methodListView lastLineShown.
+ selectors size <= (last - first + 1) ifTrue:[
+ scr := true
+ ]
+ ].
+ methodListView list = selectors ifFalse:[
+ scr ifTrue:[
+ methodListView contents:selectors
+ ] ifFalse:[
+ methodListView setContents:selectors
+ ]
+ ].
+ ]
+!
+
+methodSelectionChanged
+ "method selection has changed - update dependent views"
+
+ self withWaitCursorDo:[
+ |index cls|
+
+ self updateCodeView.
+ self setAcceptAndExplainActionsForMethod.
+
+ "
+ if there is any autoSearch string, do the search
+ "
+ autoSearch notNil ifTrue:[
+ codeView searchFwd:autoSearch ifAbsent:[]
+ ].
+
+ fullProtocol ifTrue:[
+ "
+ remove any bold attribute from classList
+ "
+ 1 to:classListView list size do:[:i |
+ classListView attributeAt:i remove:#bold.
+ ].
+ "
+ boldify the class where this method is implemented
+ "
+ currentMethod notNil ifTrue:[
+ cls := currentMethod who at:1.
+ index := classListView list indexOf:(cls name).
+ index ~~ 0 ifTrue:[
+ classListView attributeAt:index add:#bold.
+ ].
+ currentClass := cls.
+
+ ]
+ ].
+ ]
+!
+
+updateMethodList
+ self updateMethodListWithScroll:true
+!
+
+methodSelection:lineNr
+ "user clicked on a method line - show code"
+
+ |selectorString selectorSymbol index|
+
+ (fullProtocol not and:[currentClass isNil]) ifTrue:[^ self].
+
+ selectorString := methodListView selectionValue.
+ "
+ kludge: check if its a wrapped one
+ "
+ (selectorString endsWith:' !!') ifTrue:[
+ selectorString := selectorString copyTo:(selectorString size - 2)
+ ].
+ selectorSymbol := selectorString asSymbol.
+ fullProtocol ifTrue:[
+ currentMethod := currentSelector := nil.
+ "
+ search which class implements the selector
+ "
+ self classesInFullProtocolHierarchy:actualClass do:[:c |
+ (currentMethod isNil
+ and:[c implements:selectorSymbol]) ifTrue:[
+ currentSelector := selectorSymbol.
+ currentMethod := c compiledMethodAt:selectorSymbol.
+ ]
+ ]
+ ] ifFalse:[
+ currentSelector := selectorSymbol.
+ currentMethod := actualClass compiledMethodAt:selectorSymbol.
+ ].
+
+ methodCategoryListView notNil ifTrue:[
+ currentMethod notNil ifTrue:[
+ (currentMethodCategory = currentMethod category) ifFalse:[
+ currentMethodCategory := currentMethod category.
+ methodCategoryListView selectElement:currentMethodCategory
+ ]
+ ]
+ ].
+
+ self methodSelectionChanged
+!
+
+listOfAllSelectorsInCategory:aCategory ofClass:aClass
+ "answer a list of all selectors in a given method category
+ of the argument, aClass"
+
+ |newList searchCategory selector|
+
+ (aCategory = '* all *') ifTrue:[
+ newList := aClass selectorArray asOrderedCollection
+ ] ifFalse:[
+ (aCategory = '* no category *') ifTrue:[
+ searchCategory := nil
+ ] ifFalse:[
+ searchCategory := aCategory
+ ].
+ newList := OrderedCollection new.
+ aClass methodArray with:aClass selectorArray do:[:aMethod :selector |
+ |sel|
+
+ (aMethod category = searchCategory) ifTrue:[
+ aMethod isWrapped ifTrue:[
+ sel := selector , ' !!'
+ ] ifFalse:[
+ sel := selector
+ ].
+
+ "mhmh - can this happen ?"
+"/ (newList includes:sel) ifFalse:[
+ newList add:sel
+"/ ]
+ ]
+ ]
+ ].
+ (newList size == 0) ifTrue:[^ nil].
+ ^ newList sort
+!
+
+template
+ "return a method definition template"
+
+ ^
+'message selector and argument names
+ "comment stating purpose of message"
+
+
+ |temporaries|
+ statements
+
+
+"
+ change above template into real code.
+ Then ''accept'' either via the menu
+ or via the keyboard (usually CMD-A).
+
+ You do not need this template; you can also
+ select any existing methods code, change it,
+ and finally ''accept''.
+"
+'
+!
+
+listOfAllSelectorsInCategory:aCategory inFullProtocolHierarchyOfClass:aClass
+ "answer a list of all selectors in a given method category
+ of the argument, aClass and its superclasses.
+ Used with fullProtocol browsing."
+
+ |newList thisList searchCategory selector|
+
+ newList := Set new.
+ self classesInFullProtocolHierarchy:aClass do:[:c |
+ (aCategory = '* all *') ifTrue:[
+ newList addAll:(c selectorArray)
+ ] ifFalse:[
+ (aCategory = '* no category *') ifTrue:[
+ searchCategory := nil
+ ] ifFalse:[
+ searchCategory := aCategory
+ ].
+ c methodArray with:c selectorArray do:[:aMethod :selector |
+ (aMethod category = searchCategory) ifTrue:[
+ newList add:selector
+ ]
+ ]
+ ].
+ ].
+ (newList size == 0) ifTrue:[^ nil].
+ ^ newList asOrderedCollection sort
+!
+
+checkMethodSelected
+ currentMethod isNil ifTrue:[
+ self warn:'select a method first'.
+ ^ false
+ ].
+ ^ true
+!
+
+switchToMethodNamed:matchString
+ |aSelector method cat index classToSearch selectors|
+
+ currentClass notNil ifTrue:[
+ showInstance ifTrue:[
+ classToSearch := currentClass
+ ] ifFalse:[
+ classToSearch := currentClass class
+ ].
+ selectors := classToSearch selectorArray.
+
+ ((matchString ~= '*') and:[matchString includesMatchCharacters]) ifTrue:[
+ index := selectors findFirst:[:element | matchString match:element]
+ ] ifFalse:[
+ index := selectors indexOf:matchString
+ ].
+
+ (index ~~ 0) ifTrue:[
+ aSelector := selectors at:index.
+ method := classToSearch methodArray at:index.
+ cat := method category.
+ cat isNil ifTrue:[cat := '* all *'].
+ methodCategoryListView selectElement:cat.
+ currentMethodCategory := cat.
+ self methodCategorySelectionChanged.
+
+ currentMethod := classToSearch compiledMethodAt:aSelector.
+ currentMethod notNil ifTrue:[
+ currentSelector := aSelector.
+ methodListView selectElement:aSelector.
+ ].
+ self methodSelectionChanged
+ ]
+ ]
+!
+
+switchToAnyMethodNamed:aString
+ |aSelector classToStartSearch aClass nm|
+
+ aSelector := aString asSymbol.
+ currentClass isNil ifTrue:[
+ currentClassHierarchy notNil ifTrue:[
+ classToStartSearch := currentClassHierarchy
+ ]
+ ] ifFalse:[
+ classToStartSearch := currentClass
+ ].
+ classToStartSearch notNil ifTrue:[
+ showInstance ifFalse:[
+ classToStartSearch := classToStartSearch class
+ ].
+ aClass := classToStartSearch whichClassImplements:aSelector.
+ aClass notNil ifTrue:[
+ nm := aClass name.
+ showInstance ifFalse:[
+ ((nm ~= 'Metaclass') and:[nm endsWith:'class']) ifTrue:[
+ nm := nm copyTo:(nm size - 5)
+ ]
+ ].
+ self switchToClassNamed:nm.
+ self switchToMethodNamed:aString
+ ]
+ ]
+! !
+
+!SystemBrowser methodsFor:'misc'!
+
+updateCodeView
+ |code aStream|
+
+ fullClass ifTrue:[
+ currentClass notNil ifTrue:[
+ code := currentClass source.
+ ]
+ ] ifFalse:[
+ currentMethod notNil ifTrue:[
+ (codeView acceptAction isNil
+ and:[actualClass notNil
+ and:[currentMethodCategory notNil]]) ifTrue:[
+ self setAcceptAndExplainActionsForMethod.
+ ].
+
+ code := currentMethod source.
+
+ ]
+ ].
+ codeView contents:code.
+ codeView modified:false.
+
+ self normalLabel.
+
+
+!
+
+instanceProtocol
+ "switch to instance protocol"
+
+ showInstance ifFalse:[
+ self checkSelectionChangeAllowed ifTrue:[
+ classToggle turnOff.
+ instanceToggle turnOn.
+ showInstance := true.
+
+ (variableListView notNil
+ and:[variableListView hasSelection]) ifTrue:[
+ self unhilightMethodCategories.
+ self unhilightMethods.
+ variableListView deselect
+ ].
+
+ fullProtocol ifTrue:[
+ actualClass := currentClass.
+ self updateClassList.
+ self updateMethodCategoryListWithScroll:false.
+ self updateMethodListWithScroll:false.
+ self updateVariableList.
+ ^ self
+ ].
+ currentClass notNil ifTrue:[
+ self classSelectionChanged
+ ].
+ codeView modified:false.
+ ] ifFalse:[
+ instanceToggle turnOff.
+ classToggle turnOn
+ ]
+ ]
+!
+
+classProtocol
+ "switch to class protocol"
+
+ showInstance ifTrue:[
+ self checkSelectionChangeAllowed ifTrue:[
+ instanceToggle turnOff.
+ classToggle turnOn.
+ showInstance := false.
+
+ (variableListView notNil
+ and:[variableListView hasSelection]) ifTrue:[
+ self unhilightMethodCategories.
+ self unhilightMethods.
+ variableListView deselect
+ ].
+
+ fullProtocol ifTrue:[
+ actualClass := currentClass class.
+ self updateClassList.
+ self updateMethodCategoryListWithScroll:false.
+ self updateMethodListWithScroll:false.
+ self updateVariableList.
+ ^ self
+ ].
+ currentClass notNil ifTrue:[
+ self classSelectionChanged
+ ].
+ codeView modified:false.
+ ] ifFalse:[
+ instanceToggle turnOn.
+ classToggle turnOff
+ ]
+ ]
+! !
+
+!SystemBrowser methodsFor:'method category stuff'!
+
+updateMethodCategoryListWithScroll:scroll
+ |categories|
+
+ methodCategoryListView notNil ifTrue:[
+ fullProtocol ifTrue:[
+ currentClassHierarchy notNil ifTrue:[
+ categories := self listOfAllMethodCategoriesInFullProtocolHierarchy:currentClassHierarchy
+ ]
+ ] ifFalse:[
+ currentClass notNil ifTrue:[
+ categories := self listOfAllMethodCategoriesInClass:actualClass
+ ]
+ ].
+ methodCategoryListView list = categories ifFalse:[
+ scroll ifTrue:[
+ methodCategoryListView contents:categories
+ ] ifFalse:[
+ methodCategoryListView setContents:categories
+ ].
+ currentMethodCategory notNil ifTrue:[
+ methodCategoryListView selectElement:currentMethodCategory
+ ]
+ ]
+ ]
+!
+
+listOfAllMethodCategoriesInClass:aClass
+ "answer a list of all method categories of the argument, aClass"
|newList cat|
- newList := Text with:'* all *' with:'* hierarchy *'.
- Smalltalk allBehaviorsDo:[:aClass |
- cat := aClass category.
+ newList := Text new.
+ aClass methodArray do:[:aMethod |
+ cat := aMethod category.
cat isNil ifTrue:[
cat := '* no category *'
].
- newList indexOf:cat ifAbsent:[newList add:cat]
+ (newList includes:cat) ifFalse:[newList add:cat]
+ ].
+ (newList size == 0) ifTrue:[^ nil].
+ newList add:'* all *'.
+ ^ newList sort
+!
+
+methodCategorySelection:lineNr
+ "user clicked on a method category line - show selectors"
+
+ |oldSelector|
+
+ oldSelector := currentSelector.
+
+ (fullProtocol not and:[currentClass isNil]) ifTrue:[^ self].
+
+ currentMethodCategory := methodCategoryListView selectionValue.
+ self methodCategorySelectionChanged.
+
+ "if there is only one method, show it right away"
+ methodListView list size == 1 ifTrue:[
+ methodListView selection:1.
+ self methodSelection:1
+ ] ifFalse:[
+ oldSelector notNil ifTrue:[
+ methodListView selectElement:oldSelector.
+ methodListView selection notNil ifTrue:[
+ self methodSelection:methodListView selection.
+ ]
+ ]
+ ]
+
+!
+
+updateMethodCategoryList
+ self updateMethodCategoryListWithScroll:true
+!
+
+methodCategorySelectionChanged
+ "method category selection has changed - update dependant views"
+
+ self withWaitCursorDo:[
+ currentMethod := currentSelector := nil.
+
+ self updateMethodList.
+ self updateCodeView.
+
+ currentMethodCategory notNil ifTrue:[
+ methodCategoryListView selectElement:currentMethodCategory
+ ].
+
+ self setAcceptAndExplainActionsForMethod.
+ self hilightMethodsInMethodCategoryList:false inMethodList:true.
+ ]
+!
+
+listOfAllMethodCategoriesInFullProtocolHierarchy:aClass
+ "answer a list of all method categories of the argument, aClass,
+ and all of its superclasses.
+ Used with fullProtocol browsing."
+
+ |newList cat|
+
+ newList := Text new.
+ self classesInFullProtocolHierarchy:aClass do:[:c |
+ c methodArray do:[:aMethod |
+ cat := aMethod category.
+ cat isNil ifTrue:[
+ cat := '* no category *'
+ ].
+ (newList includes:cat) ifFalse:[newList add:cat]
+ ]
+ ].
+ (newList size == 0) ifTrue:[^ nil].
+ newList add:'* all *'.
+ ^ newList sort
+
+!
+
+checkMethodCategorySelected
+ currentMethodCategory isNil ifTrue:[
+ self warn:'select a method category first'.
+ ^ false
+ ].
+ ^ true
+!
+
+whenMethodCategorySelected:aBlock
+ self checkMethodCategorySelected ifTrue:[
+ self withWaitCursorDo:aBlock
+ ]
+!
+
+copyMethodsFromClass:aClassName
+ |class box|
+
+ currentClass notNil ifTrue:[
+ Symbol hasInterned:aClassName ifTrue:[:sym |
+ (Smalltalk includesKey:sym) ifTrue:[
+ class := Smalltalk at:sym
+ ].
+ ].
+ class isBehavior ifFalse:[
+ self warn:'no class named %1' with:aClassName.
+ ^ self
+ ].
+
+ showInstance ifFalse:[
+ class := class class
+ ].
+
+ "show enterbox for category to copy from"
+
+ box := self enterBoxTitle:'name of category to copy from (matchpattern allowed, * for all):'
+ okText:'copy'.
+ box action:[:aString | self copyMethodsFromClass:class category:aString].
+ box showAtPointer.
+ ]
+!
+
+copyMethodsFromClass:class category:category
+ |source|
+
+ currentClass notNil ifTrue:[
+"/ codeView abortAction:[^ self].
+ Object abortSignal catch:[
+ class methodArray do:[:aMethod |
+ (category match:aMethod category) ifTrue:[
+ source := aMethod source.
+ codeView contents:source.
+ codeView modified:false.
+ actualClass compiler compile:source
+ forClass:actualClass
+ inCategory:aMethod category
+ notifying:codeView.
+ self updateMethodCategoryListWithScroll:false.
+ self updateMethodListWithScroll:false.
+ ]
+ ]
+ ]
+ ]
+!
+
+newMethodCategory:aString
+ |categories|
+
+ currentClass isNil ifTrue:[
+ ^ self warn:'select/create a class first'.
+ ].
+ categories := methodCategoryListView list.
+ categories isNil ifTrue:[categories := Text new].
+ (categories includes:aString) ifFalse:[
+ categories add:aString.
+ categories sort.
+ methodCategoryListView contents:categories
+ ].
+ currentMethodCategory := aString.
+ self methodCategorySelectionChanged
+! !
+
+!SystemBrowser methodsFor:'initialize / release'!
+
+initialize
+ super initialize.
+
+ self icon:(Form fromFile:(resources at:'ICON_FILE' default:'SBrowser.xbm')
+ resolution:100).
+
+ showInstance := true.
+ fullClass := false.
+ fullProtocol := false.
+ aspect := nil.
+
+ "inform me, when Smalltalk changes"
+ Smalltalk addDependent:self
+!
+
+realize
+ |v checkBlock|
+
+ super realize.
+
+ checkBlock := [:lineNr | self checkSelectionChangeAllowed].
+
+ v := classCategoryListView.
+ v notNil ifTrue:[
+ v action:[:lineNr | self classCategorySelection:lineNr].
+ v selectConditionBlock:checkBlock.
+ v ignoreReselect:false.
+ v contents:(self listOfAllClassCategories).
+ self initializeClassCategoryMenu
+ ].
+
+ v := classListView.
+ v notNil ifTrue:[
+ v action:[:lineNr | self classSelection:lineNr].
+ v selectConditionBlock:checkBlock.
+ v ignoreReselect:false.
+ self initializeClassMenu
+ ].
+
+ v := methodCategoryListView.
+ v notNil ifTrue:[
+ v action:[:lineNr | self methodCategorySelection:lineNr].
+ v selectConditionBlock:checkBlock.
+ v ignoreReselect:false.
+ self initializeMethodCategoryMenu
+ ].
+
+ v := methodListView.
+ v notNil ifTrue:[
+ v action:[:lineNr | self methodSelection:lineNr].
+ v selectConditionBlock:checkBlock.
+ v ignoreReselect:false.
+ self initializeMethodMenu
+ ].
+
+ v := classMethodListView.
+ v notNil ifTrue:[
+ v action:[:lineNr | self classMethodSelection:lineNr].
+ v selectConditionBlock:checkBlock.
+ v ignoreReselect:false.
+ self initializeClassMethodMenu
+ ].
+
+ v := variableListView.
+ v notNil ifTrue:[
+ v action:[:lineNr | self variableSelection:lineNr].
+ v ignoreReselect:false.
+ v toggleSelect:true
+ ]
+
+!
+
+terminate
+ (self checkSelectionChangeAllowed) ifTrue:[
+ super terminate
+ ]
+!
+
+destroy
+ "relese dependant - destroy popups"
+
+ Smalltalk removeDependent:self.
+ currentClass notNil ifTrue:[
+ currentClass removeDependent:self.
+ currentClass := nil
+ ].
+ super destroy
+!
+
+autoSearch:aString
+ "used with class-method list browsing. If true,
+ selecting an entry from the list will automatically
+ search for the searchstring in the codeView"
+
+ self setSearchPattern:aString.
+ autoSearch := aString
+!
+
+title:someString
+ myLabel := someString.
+ self label:someString.
+
+! !
+
+!SystemBrowser methodsFor:'initialize subviews'!
+
+createClassListViewIn:frame
+ "setup the classlist subview, with its toggles"
+
+ |v panel oldStyle|
+
+ self createTogglesIn:frame.
+
+"/ oldStyle := true.
+oldStyle := false.
+ oldStyle ifTrue:[
+ v := ScrollableView for:SelectionInListView in:frame.
+ v origin:(0.0 @ 0.0)
+ extent:[frame width
+ @
+ (frame height
+ - (ViewSpacing // 2)
+ - instanceToggle height
+ - instanceToggle borderWidth
+ + v borderWidth)].
+
+ classListView := v scrolledView
+ ] ifFalse:[
+ panel := VariableVerticalPanel
+ origin:(0.0 @ 0.0)
+ corner:[frame width
+ @
+ (frame height
+ - (ViewSpacing // 2)
+ - instanceToggle height
+ - instanceToggle borderWidth
+ + v borderWidth)]
+ in:frame.
+
+ v := ScrollableView for:SelectionInListView in:panel.
+ v origin:(0.0 @ 0.0) corner:(1.0 @ 0.7).
+ classListView := v scrolledView.
+
+
+ v := ScrollableView for:SelectionInListView in:panel.
+ v origin:(0.0 @ 0.7)
+ corner:(1.0 @ 1.0).
+
+ variableListView := v scrolledView
+ ]
+!
+
+createCodeViewIn:aView at:relY
+ "setup the code view"
+ |v|
+
+ v := HVScrollableView for:CodeView miniScrollerH:true miniScrollerV:false in:aView.
+ v origin:(0.0 @ relY) corner:(1.0 @ 1.0).
+ codeView := v scrolledView
+!
+
+createTogglesIn:aFrame
+ "create and setup the class/instance toggles"
+
+ |halfSpacing h classAction instanceAction|
+
+ classAction := [self classProtocol].
+ instanceAction := [self instanceProtocol].
+
+ instanceToggle := Toggle label:(resources at:'instance') in:aFrame.
+ h := instanceToggle height.
+ instanceToggle origin:(0.0 @ 1.0) corner:(0.5 @ 1.0).
+ instanceToggle topInset:(h negated).
+
+ instanceToggle turnOn.
+ instanceToggle pressAction:instanceAction.
+ instanceToggle releaseAction:classAction.
+
+ classToggle := Toggle label:(resources at:'class') in:aFrame.
+ h := classToggle height.
+ classToggle origin:(0.5 @ 1.0) corner:(1.0 @ 1.0).
+ classToggle topInset:(h negated).
+
+ classToggle turnOff.
+ classToggle pressAction:classAction.
+ classToggle releaseAction:instanceAction.
+
+ StyleSheet is3D ifTrue:[
+ instanceToggle leftInset:(ViewSpacing // 2).
+ classToggle leftInset:(ViewSpacing // 2).
+ instanceToggle rightInset:ViewSpacing - (ViewSpacing // 2).
+ classToggle rightInset:ViewSpacing - (ViewSpacing // 2).
].
- newList sort.
- ^ newList
-!
-
-listOfClassHierarchyOf:aClass
- "return a hierarchy class-list"
-
- ^ (aClass allSuperclasses reverse ,
- (Array with:aClass),
- aClass allSubclassesInOrder) collect:[:c | c name]
-
+!
+
+createCodeViewIn:aView
+ "setup the code view"
+
+ ^ self createCodeViewIn:aView at:0.25
+!
+
+setupForList:aList
+ "setup subviews to browse methods from a list"
+
+ |vpanel v|
+
+ vpanel := VariableVerticalPanel
+ origin:(0.0 @ 0.0)
+ corner:(1.0 @ 1.0)
+ in:self.
+
+ v := ScrollableView for:SelectionInListView in:vpanel.
+ v origin:(0.0 @ 0.0) corner:(1.0 @ 0.25).
+ classMethodListView := v scrolledView.
+ classMethodListView contents:aList.
+
+ self createCodeViewIn:vpanel.
+ self updateCodeView
+!
+
+setupForAll
+ "create subviews for a full browser"
+
+ |vpanel hpanel frame v|
+
+ vpanel := VariableVerticalPanel origin:(0.0 @ 0.0) corner:(1.0 @ 1.0)
+ in:self.
+ hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
+
+ v := HVScrollableView for:SelectionInListView
+ miniScrollerH:true miniScrollerV:false
+ in:hpanel.
+ v origin:(0.0 @ 0.0) corner:(0.25 @ 1.0).
+ classCategoryListView := v scrolledView.
+
+ frame := View origin:(0.25 @ 0.0) corner:(0.5 @ 1.0) in:hpanel.
+ self createClassListViewIn:frame.
+
+ v := HVScrollableView for:SelectionInListView miniScrollerH:true miniScrollerV:false in:hpanel.
+ v origin:(0.5 @ 0.0) corner:(0.75 @ 1.0).
+ methodCategoryListView := v scrolledView.
+
+ v := HVScrollableView for:SelectionInListView miniScrollerH:true miniScrollerV:false in:hpanel.
+ v origin:(0.75 @ 0.0) corner:(1.0 @ 1.0).
+ methodListView := v scrolledView.
+
+ self createCodeViewIn:vpanel
+!
+
+setupForClassHierarchy:aClass
+ "setup subviews to browse a class hierarchy"
+
+ |vpanel hpanel frame v|
+
+ vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
+ corner:(1.0 @ 1.0)
+ in:self.
+
+ "
+ notice: we use a different ratio here
+ "
+ hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.4) in:vpanel.
+ frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
+
+ self createClassListViewIn:frame.
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
+ methodCategoryListView := v scrolledView.
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.66 @ 0.0) corner:(1.0 @ 1.0).
+ methodListView := v scrolledView.
+
+ self createCodeViewIn:vpanel at:0.4.
+
+ currentClassHierarchy := aClass.
+ self updateClassList.
+ self updateMethodCategoryList.
+ self updateMethodList.
+ self updateCodeView
+!
+
+setupForFullClass
+ "setup subviews to browse a class as full text"
+
+ |vpanel hpanel v|
+
+ vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
+ corner:(1.0 @ 1.0)
+ in:self.
+
+ hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.0 @ 0.0) corner:(0.5 @ 1.0).
+ classCategoryListView := v scrolledView.
+ classCategoryListView contents:(self listOfAllClassCategories).
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.5 @ 0.0) corner:(1.0 @ 1.0).
+ classListView := v scrolledView.
+
+ self createCodeViewIn:vpanel.
+
+ fullClass := true.
+ self updateCodeView
+!
+
+setupForClass:aClass
+ "create subviews for browsing a single class"
+
+ |vpanel hpanel frame v|
+
+ vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
+ corner:(1.0 @ 1.0)
+ in:self.
+
+ hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
+ frame := View origin:(0.0 @ 0.0) corner:(0.5 @ 1.0)in:hpanel.
+
+ self createTogglesIn:frame.
+
+ v := ScrollableView for:SelectionInListView in:frame.
+ v origin:(0.0 @ 0.0)
+ extent:[frame width
+ @
+ (frame height
+ - (ViewSpacing // 2)
+ - instanceToggle height
+ - instanceToggle borderWidth
+ + v borderWidth)].
+ methodCategoryListView := v scrolledView.
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.5 @ 0.0) corner:(1.0 @ 1.0).
+ methodListView := v scrolledView.
+
+ self createCodeViewIn:vpanel.
+
+ self switchToClass:aClass.
+ actualClass := aClass.
+ self updateMethodCategoryList.
+ self updateMethodList.
+ self updateCodeView
+!
+
+setupForClassCategory:aClassCategory
+ "setup subviews to browse a class category"
+
+ |vpanel hpanel frame v|
+
+ vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
+ corner:(1.0 @ 1.0)
+ in:self.
+
+ hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
+ frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
+
+ self createClassListViewIn:frame.
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
+ methodCategoryListView := v scrolledView.
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.66 @ 0.0) corner:(1.0 @ 1.0).
+ methodListView := v scrolledView.
+
+ self createCodeViewIn:vpanel.
+
+ currentClassCategory := aClassCategory.
+ self updateClassList.
+ self updateMethodCategoryList.
+ self updateMethodList.
+ self updateCodeView
+!
+
+setupForClass:aClass selector:selector
+ "setup subviews to browse a single method"
+
+ |v|
+
+ v := ScrollableView for:CodeView in:self.
+ v origin:(0.0 @ 0.0) corner:(1.0 @ 1.0).
+ codeView := v scrolledView.
+
+ currentClassCategory := aClass category.
+ self switchToClass:aClass.
+ actualClass := aClass.
+ currentSelector := selector.
+ currentMethod := currentClass compiledMethodAt:selector.
+ currentMethodCategory := currentMethod category.
+ self updateCodeView
+!
+
+setupForClassList:aList
+ "setup subviews to browse classes from a list"
+
+ |vpanel hpanel frame l v|
+
+ vpanel := VariableVerticalPanel
+ origin:(0.0 @ 0.0) corner:(1.0 @ 1.0) in:self.
+
+ hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
+ frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
+
+ self createClassListViewIn:frame.
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
+ methodCategoryListView := v scrolledView.
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.66 @ 0.0) corner:(1.0 @ 1.0).
+ methodListView := v scrolledView.
+
+ self createCodeViewIn:vpanel.
+
+ l := aList collect:[:entry | entry name].
+ classListView list:(l sort).
+
+ self updateMethodCategoryList.
+ self updateMethodList.
+ self updateCodeView
+!
+
+setupForClass:aClass methodCategory:aMethodCategory
+ "setup subviews to browse a method category"
+
+ |vpanel v|
+
+ vpanel := VariableVerticalPanel
+ origin:(0.0 @ 0.0) corner:(1.0 @ 1.0)
+ in:self.
+
+ v := ScrollableView for:SelectionInListView in:vpanel.
+ v origin:(0.0 @ 0.0) corner:(1.0 @ 0.25).
+ methodListView := v scrolledView.
+
+ self createCodeViewIn:vpanel.
+
+ currentClassCategory := aClass category.
+ self switchToClass:aClass.
+ actualClass := aClass.
+ currentMethodCategory := aMethodCategory.
+ self updateMethodList.
+ self updateCodeView
+!
+
+setupForFullClassProtocol:aClass
+ "setup subviews to browse a classes full protocol"
+
+ |vpanel hpanel frame v|
+
+ vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
+ corner:(1.0 @ 1.0)
+ in:self.
+
+ "
+ notice: we use a different ratio here
+ "
+ hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.4) in:vpanel.
+ frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
+
+ self createClassListViewIn:frame.
+ classListView multipleSelectOk:true.
+ classListView toggleSelect:true.
+ classListView strikeOut:true.
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
+ methodCategoryListView := v scrolledView.
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.66 @ 0.0) corner:(1.0 @ 1.0).
+ methodListView := v scrolledView.
+
+ self createCodeViewIn:vpanel at:0.4.
+
+ currentClassHierarchy := actualClass := currentClass := aClass.
+ fullProtocol := true.
+
+ self updateClassList.
+ self updateMethodCategoryList.
+ self updateMethodList.
+ self updateCodeView.
+ self updateVariableList.
+
+!
+
+setupForFullClassHierarchy:aClass
+ "setup subviews to browse a class hierarchy"
+
+ |vpanel hpanel frame v|
+
+ vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
+ corner:(1.0 @ 1.0)
+ in:self.
+
+ hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.4) in:vpanel.
+ frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
+
+ self createClassListViewIn:frame.
+ classListView multipleSelectOk:true.
+ classListView toggleSelect:true.
+ classListView strikeOut:true.
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
+ methodCategoryListView := v scrolledView.
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.66 @ 0.0) corner:(1.0 @ 1.0).
+ methodListView := v scrolledView.
+
+"/ self setupActions.
+ self createCodeViewIn:vpanel at:0.4.
+
+ currentClassHierarchy := actualClass := aClass.
+ fullProtocol := true.
+
+ self updateClassList.
+ self updateMethodCategoryList.
+ self updateMethodList.
+ self updateCodeView.
+ self updateVariableList.
+
+! !
+
+!SystemBrowser methodsFor:'unused'!
+
+listOfAllSelectorsInCategory:aCategory inHierarchyOfClass:aClass
+ "answer a list of all selectors in a given method category
+ of the argument, aClass and its superclasses"
+
+ |newList thisList searchCategory selector|
+
+ newList := Set new.
+ self classesInHierarchy:aClass do:[:c |
+ (aCategory = '* all *') ifTrue:[
+ newList addAll:(c selectorArray)
+ ] ifFalse:[
+ (aCategory = '* no category *') ifTrue:[
+ searchCategory := nil
+ ] ifFalse:[
+ searchCategory := aCategory
+ ].
+ c methodArray with:c selectorArray do:[:aMethod :selector |
+ (aMethod category = searchCategory) ifTrue:[
+ newList add:selector
+ ]
+ ]
+ ].
+ ].
+ (newList size == 0) ifTrue:[^ nil].
+ ^ newList asOrderedCollection sort
+!
+
+listOfAllMethodCategoriesInHierarchy:aClass
+ "answer a list of all method categories of the argument, aClass,
+ and all of its superclasses"
+
+ |newList cat|
+
+ newList := Text new.
+ self classesInHierarchy:aClass do:[:c |
+ c methodArray do:[:aMethod |
+ cat := aMethod category.
+ cat isNil ifTrue:[
+ cat := '* no category *'
+ ].
+ (newList includes:cat) ifFalse:[newList add:cat]
+ ]
+ ].
+ (newList size == 0) ifTrue:[^ nil].
+ newList add:'* all *'.
+ ^ newList sort
+
+! !
+
+!SystemBrowser methodsFor:'class stuff'!
+
+switchToClass:newClass
+ fullProtocol ifTrue:[^ self].
+ currentClass notNil ifTrue:[
+ currentClass removeDependent:self
+ ].
+ currentClass := newClass.
+ currentClass notNil ifTrue:[
+ currentClass addDependent:self.
+ ].
+ self normalLabel
+!
+
+classSelectionChanged
+ |oldMethodCategory oldMethod oldSelector|
+
+ self withWaitCursorDo:[
+ oldMethodCategory := currentMethodCategory.
+ oldMethod := currentMethod.
+ oldSelector := currentSelector.
+
+ showInstance ifTrue:[
+ actualClass := currentClass
+ ] ifFalse:[
+ actualClass := currentClass class
+ ].
+ currentMethodCategory := nil.
+ currentMethod := nil.
+ currentSelector := nil.
+
+ self updateVariableList.
+ self updateMethodCategoryList.
+
+ oldMethodCategory notNil ifTrue:[
+ methodCategoryListView selectElement:oldMethodCategory.
+ methodCategoryListView selection notNil ifTrue:[
+ currentMethodCategory := oldMethodCategory.
+ self methodCategorySelectionChanged
+ ]
+ ].
+ self updateMethodList.
+ self updateCodeView.
+
+ fullClass ifTrue:[
+ codeView acceptAction:[:theCode |
+ codeView cursor:Cursor execute.
+ Object abortSignal catch:[
+ self compileCode:theCode asString.
+ codeView modified:false.
+ ].
+ codeView cursor:Cursor normal.
+ ].
+ ] ifFalse:[
+ self classDefinition.
+ codeView acceptAction:[:theCode |
+ codeView cursor:Cursor execute.
+ Object abortSignal catch:[
+ (Compiler evaluate:theCode asString notifying:codeView)
+ isBehavior ifTrue:[
+ self classCategoryUpdate.
+ self updateClassListWithScroll:false.
+ codeView modified:false.
+ ].
+ ].
+ codeView cursor:Cursor normal.
+ ].
+ ].
+ codeView explainAction:nil.
+
+ classCategoryListView notNil ifTrue:[
+ (currentClassCategory = currentClass category) ifFalse:[
+ currentClassCategory := currentClass category.
+ classCategoryListView selectElement:currentClassCategory
+ ]
+ ].
+
+ "set self for doits. This allows accessing the current class
+ as self, and access to the class variables by name.
+ "
+ codeView doItAction:[:theCode |
+ |compiler|
+
+ currentClass isNil ifTrue:[
+ compiler := Compiler
+ ] ifFalse:[
+ compiler := currentClass compiler
+ ].
+ compiler
+ evaluate:theCode
+ in:nil
+ receiver:currentClass
+ notifying:codeView
+ logged:false
+ ifFail:nil
+ ].
+ ]
+!
+
+updateClassListWithScroll:scroll
+ |classes oldClassName|
+
+ classListView notNil ifTrue:[
+ "
+ refetch in case we are not up to date
+ "
+ (currentClass notNil and:[fullProtocol not]) ifTrue:[
+ oldClassName := currentClass name.
+ currentClass := Smalltalk at:(oldClassName asSymbol).
+ ].
+
+ currentClassCategory notNil ifTrue:[
+ classes := self listOfAllClassesInCategory:currentClassCategory
+ ] ifFalse:[
+ currentClassHierarchy notNil ifTrue:[
+ classes := self listOfClassHierarchyOf:currentClassHierarchy
+ ]
+ ].
+
+ classListView list = classes ifFalse:[
+ scroll ifTrue:[
+ classListView contents:classes
+ ] ifFalse:[
+ classListView setContents:classes
+ ].
+ oldClassName notNil ifTrue:[
+ classListView setContents:classes.
+ classListView selectElement:oldClassName
+ ] ifFalse:[
+ variableListView notNil ifTrue:[variableListView contents:nil]
+ ]
+ ].
+ scroll ifTrue:[
+ fullProtocol ifTrue:[
+ classListView scrollToBottom
+ ]
+ ]
+ ]
+!
+
+classSelection:lineNr
+ "user clicked on a class line - show method categories"
+
+ |classSymbol cls oldSelector|
+
+ (currentClassHierarchy notNil
+ and:[fullProtocol]) ifTrue:[
+ oldSelector := currentSelector.
+
+ self updateMethodCategoryListWithScroll:false.
+ self updateMethodListWithScroll:false.
+ self updateVariableList.
+ ^ self
+ ].
+
+ cls := Smalltalk classNamed:classListView selectionValue withoutSpaces.
"
- |newList theClass|
-
- theClass := aClass.
- newList := Text with:theClass name.
- [theClass ~~ Object] whileTrue:[
- theClass := theClass superclass.
- newList add:theClass name
+ classSymbol := classListView selectionValue withoutSpaces asSymbol.
+ (Smalltalk includesKey:classSymbol) ifTrue:[
+ cls := Smalltalk at:classSymbol
].
- newList reverse.
- ^ newList
"
+ cls notNil ifTrue:[
+ self switchToClass:cls.
+ self classSelectionChanged
+ ]
!
listOfAllClassesInCategory:aCategory
@@ -1609,94 +2997,40 @@
^ newList sort
!
-classHierarchyDo:aBlock
- "eavluate the 2-arg block for every class,
- starting at Object; passing class and nesting level to the block."
-
- |classes s classDict l|
-
- classes := Smalltalk allClasses.
- classDict := IdentityDictionary new:classes size.
- classes do:[:aClass |
- s := aClass superclass.
- s notNil ifTrue:[
- l := classDict at:s ifAbsent:[nil].
- l isNil ifTrue:[
- l := OrderedCollection new:5.
- classDict at:s put:l
- ].
- l add:aClass
- ]
- ].
- self classHierarchyOf:Object level:0 do:aBlock using:classDict
-!
-
-classHierarchyOf:aClass level:level do:aBlock using:aDictionary
- "evaluate the 2-arg block for every subclass of aClass,
- passing class and nesting level to the block."
-
- |names subclasses|
-
- aBlock value:aClass value:level.
- subclasses := aDictionary at:aClass ifAbsent:[nil].
- (subclasses size == 0) ifFalse:[
- names := subclasses collect:[:class | class name].
- names sortWith:subclasses.
- subclasses do:[:aSubClass |
- self classHierarchyOf:aSubClass level:(level + 1) do:aBlock using:aDictionary
- ]
+doClassMenu:aBlock
+ "a helper - check if class is selected and evaluate aBlock
+ while showing waitCursor"
+
+ self checkClassSelected ifTrue:[
+ self withWaitCursorDo:aBlock
]
!
-listOfAllMethodCategoriesInClass:aClass
- "answer a list of all method categories of the argument, aClass"
-
- |newList cat|
-
- newList := Text new.
- aClass methodArray do:[:aMethod |
- cat := aMethod category.
- cat isNil ifTrue:[
- cat := '* no category *'
- ].
- (newList includes:cat) ifFalse:[newList add:cat]
+checkClassSelected
+ "warn and return false, if no class is selected"
+
+ currentClass isNil ifTrue:[
+ self warn:'select a class first'.
+ ^ false
].
- (newList size == 0) ifTrue:[^ nil].
- newList add:'* all *'.
- ^ newList sort
-!
-
-listOfAllSelectorsInCategory:aCategory ofClass:aClass
- "answer a list of all selectors in a given method category
- of the argument, aClass"
-
- |newList searchCategory selector|
-
- (aCategory = '* all *') ifTrue:[
- newList := aClass selectorArray asText
- ] ifFalse:[
- (aCategory = '* no category *') ifTrue:[
- searchCategory := nil
- ] ifFalse:[
- searchCategory := aCategory
- ].
- newList := Text new.
- aClass methodArray do:[:aMethod |
- (aMethod category = searchCategory) ifTrue:[
- selector := aClass selectorForMethod:aMethod.
- selector notNil ifTrue:[
- aMethod isWrapped ifTrue:[
- selector := selector , ' !!'
- ].
- (newList includes:selector) ifFalse:[
- newList add:selector
- ]
- ]
- ]
- ]
+ ^ true
+!
+
+updateClassList
+ self updateClassListWithScroll:true
+!
+
+listOfClassHierarchyOf:aClass
+ "return a hierarchy class-list"
+
+ |classes|
+
+ classes := aClass allSuperclasses reverse , (Array with:aClass).
+ fullProtocol ifFalse:[
+ classes := classes , aClass allSubclassesInOrder
].
- (newList size == 0) ifTrue:[^ nil].
- ^ newList sort
+ ^ classes collect:[:c | c name]
+
!
templateFor:className in:cat
@@ -1717,822 +3051,119 @@
poolDictionaries: ''''
category: '''.
- cat notNil ifTrue:[
- aString := aString , cat
- ].
- aString := aString , ''''.
- ^ aString
-!
-
-template
- "return a method definition template"
-
- ^
-'message selector and argument names
- "comment stating purpose of message"
-
-
- |temporaries|
- statements
-'
-!
-
-compileCode:someCode
- (ReadStream on:someCode) fileIn
-! !
-
-!SystemBrowser methodsFor:'user interaction'!
-
-instanceProtocol
- showInstance ifFalse:[
- self checkSelectionChangeAllowed ifTrue:[
- classToggle turnOff.
- instanceToggle turnOn.
- showInstance := true.
- currentClass notNil ifTrue:[
- self classSelectionChanged
- ].
- codeView modified:false.
- ] ifFalse:[
- instanceToggle turnOff.
- classToggle turnOn
- ]
- ]
-!
-
-classProtocol
- showInstance ifTrue:[
- self checkSelectionChangeAllowed ifTrue:[
- instanceToggle turnOff.
- classToggle turnOn.
- showInstance := false.
- currentClass notNil ifTrue:[
- self classSelectionChanged
- ].
- codeView modified:false.
- ] ifFalse:[
- instanceToggle turnOn.
- classToggle turnOff
- ]
- ]
-!
-
-updateClassCategoryListWithScroll:scroll
- |oldClassCategory oldClass oldMethodCategory oldMethod
- oldSelector newCategoryList|
-
- classMethodListView notNil ifTrue:[ ^ self ].
-
- oldClassCategory := currentClassCategory.
- oldClass := currentClass.
- oldMethodCategory := currentMethodCategory.
- oldMethod := currentMethod.
- oldMethod notNil ifTrue:[
- oldSelector := methodListView selectionValue
+ cat notNil ifTrue:[
+ aString := aString , cat
].
-
- 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)
- ]
+ 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
].
- oldMethodCategory notNil ifTrue:[
- methodCategoryListView notNil ifTrue:[
- methodCategoryListView selectElement:oldMethodCategory
- ].
- ].
- oldSelector notNil ifTrue:[
- methodListView notNil ifTrue:[
- methodListView selectElement:oldSelector
- ].
- ]
-!
-
-updateClassCategoryList
- self updateClassCategoryListWithScroll:true
-!
-
-updateClassListWithScroll:scroll
- |classes oldClassName|
-
- classListView notNil ifTrue:[
- currentClass notNil ifTrue:[
- oldClassName := currentClass name.
- currentClass := Smalltalk at:(oldClassName asSymbol).
- ].
-
- currentClassCategory notNil ifTrue:[
- classes := self listOfAllClassesInCategory:currentClassCategory
- ] ifFalse:[
- currentClassHierarchy notNil ifTrue:[
- classes := self listOfClassHierarchyOf:currentClassHierarchy
+
+ codeView contents:(self templateFor:name in:cat).
+ codeView modified:false.
+
+ codeView acceptAction:[:theCode |
+ codeView cursor:Cursor execute.
+ Object abortSignal catch:[
+ |cls|
+
+ cls := (Compiler evaluate:theCode asString notifying:codeView).
+ cls isBehavior ifTrue:[
+ codeView modified:false.
+ self classCategoryUpdate.
+ self updateClassListWithScroll:false.
+ self switchToClassNamed:(cls name).
]
].
-
- 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]
- ]
- ]
- ]
-!
-
-updateClassList
- self updateClassListWithScroll:true
-!
-
-updateVariableList
- |l subList flags last|
-
- variableListView isNil ifTrue:[^ self].
-
- l := OrderedCollection new.
- actualClass withAllSuperclasses do:[:aClass |
- subList := aClass instVarNames.
- subList size ~~ 0 ifTrue:[
- l := l , (subList asOrderedCollection reverse).
- l := l , (OrderedCollection with:'---- ' , aClass name , ' ---------').
- ]
- ].
- l reverse.
- variableListView attributes:nil.
- variableListView list:l.
- l keysAndValuesDo:[:index :entry |
- (entry startsWith:'---') ifTrue:[
- variableListView attributeAt:index put:#halfIntensity.
- last := index
- ]
+ codeView cursor:(Cursor normal).
].
- last notNil ifTrue:[variableListView scrollToLine:last]
-!
-
-updateMethodCategoryListWithScroll:scroll
- |categories|
-
- methodCategoryListView notNil ifTrue:[
- currentClass notNil ifTrue:[
- categories := self listOfAllMethodCategoriesInClass:actualClass
- ].
- methodCategoryListView list = categories ifFalse:[
- scroll ifTrue:[
- methodCategoryListView contents:categories
- ] ifFalse:[
- methodCategoryListView setContents:categories
- ].
- currentMethodCategory notNil ifTrue:[
- methodCategoryListView selectElement:currentMethodCategory
- ]
- ]
- ]
-!
-
-updateMethodCategoryList
- self updateMethodCategoryListWithScroll:true
-!
-
-updateMethodListWithScroll:scroll
- |selectors scr first last|
-
- methodListView notNil ifTrue:[
- currentMethodCategory notNil ifTrue:[
- selectors := self listOfAllSelectorsInCategory:currentMethodCategory
- ofClass:actualClass
- ].
- scr := scroll.
- first := methodListView firstLineShown.
- first ~~ 1 ifTrue:[
- last := methodListView lastLineShown.
- selectors size <= (last - first + 1) ifTrue:[
- scr := true
- ]
- ].
- methodListView list = selectors ifFalse:[
- scr ifTrue:[
- methodListView contents:selectors
- ] ifFalse:[
- methodListView setContents:selectors
- ]
- ].
- ]
-!
-
-updateMethodList
- self updateMethodListWithScroll:true
-!
-
-updateCodeView
- |code aStream|
-
- fullClass ifTrue:[
- currentClass notNil ifTrue:[
-" this is too slow for big classes ...
- code := String new:1000.
- aStream := WriteStream on:code.
- currentClass fileOutOn:aStream
+ codeView explainAction:nil.
+ self switchToClass:nil
+!
+
+renameCurrentClassTo:aString
+ "helper - do the rename"
+
+ self doClassMenu:[
+ |oldName oldSym newSym|
+
+ oldName := currentClass name.
+ oldSym := oldName asSymbol.
"
- aStream := FileStream newFileNamed:'__temp'.
- aStream isNil ifTrue:[
- self notify:'cannot create temporary file.'.
- codeView contents:nil.
- codeView modified:false.
- ^ self
- ].
- currentClass fileOutOn:aStream.
- aStream close.
- aStream := FileStream oldFileNamed:'__temp'.
- aStream isNil ifTrue:[
- self notify:'oops - cannot reopen temp file'.
- codeView contents:nil.
- codeView modified:false.
- ^ self
- ].
- code := aStream contents.
- aStream close.
- OperatingSystem removeFile:'__temp'
- ]
- ] ifFalse:[
- currentMethod notNil ifTrue:[
- code := currentMethod source
- ]
- ].
- codeView contents:code.
- codeView modified:false
-!
-
-classSelectionChanged
- |oldMethodCategory oldMethod|
-
- self withWaitCursorDo:[
- oldMethodCategory := currentMethodCategory.
- oldMethod := currentMethod.
-
- showInstance ifTrue:[
- actualClass := currentClass
- ] ifFalse:[
- actualClass := currentClass class
- ].
- currentMethodCategory := nil.
- currentMethod := nil.
-
- self updateVariableList.
- self updateMethodCategoryList.
- oldMethodCategory notNil ifTrue:[
- methodCategoryListView selectElement:oldMethodCategory.
- methodCategoryListView selection notNil ifTrue:[
- currentMethodCategory := oldMethodCategory.
- self methodCategorySelectionChanged
- ]
- ].
- self updateMethodList.
- self updateCodeView.
-
- fullClass ifTrue:[
- codeView acceptAction:[:theCode |
- codeView cursor:Cursor execute.
- Object abortSignal catch:[
- self compileCode:theCode asString.
- codeView modified:false.
- ].
- codeView cursor:Cursor normal.
- ].
- codeView explainAction:nil
- ] ifFalse:[
- self classDefinition.
- codeView acceptAction:[:theCode |
- codeView cursor:Cursor execute.
- Object abortSignal catch:[
- (Compiler evaluate:theCode asString notifying:codeView)
- isBehavior ifTrue:[
- self classCategoryUpdate.
- self updateClassListWithScroll:false.
- codeView modified:false.
- ].
- ].
- codeView cursor:Cursor normal.
- ].
- codeView explainAction:nil
- ].
- classCategoryListView notNil ifTrue:[
- (currentClassCategory = currentClass category) ifFalse:[
- currentClassCategory := currentClass category.
- classCategoryListView selectElement:currentClassCategory
- ]
- ].
-
- "set self for doits. This allows accessing the current class
- as self, and access to the class variables by name."
-
- codeView doItAction:[:theCode |
- |compiler|
-
- currentClass isNil ifTrue:[
- compiler := Compiler
- ] ifFalse:[
- compiler := currentClass compiler
- ].
- compiler
- evaluate:theCode
- in:nil
- receiver:currentClass
- notifying:codeView
- logged:false
- ifFail:nil
- ]
- ]
-!
-
-classCategorySelectionChanged
- "class category has changed - update dependant views"
-
- self withWaitCursorDo:[
- self switchToClass:nil.
- actualClass := nil.
- currentMethodCategory := nil.
- currentMethod := nil.
+ 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 updateMethodCategoryList.
- self updateMethodList.
- self updateCodeView.
-
- codeView explainAction:nil.
- codeView acceptAction:nil
- ]
-!
-
-classCategorySelection:lineNr
- "user clicked on a class category line - show classes.
- If switching to hierarchy or all, keep current selections"
-
- |newCategory oldClass classIndex index|
-
- newCategory := classCategoryListView selectionValue.
- (newCategory startsWith:'*') ifTrue:[
- "etiher all or hierarchy;
- remember current selections and switch after showing class list"
- oldClass := currentClass
- ].
- currentClassCategory := newCategory.
- oldClass isNil ifTrue:[
- self classCategorySelectionChanged
- ] ifFalse:[
+ self updateMethodCategoryListWithScroll:false.
+ self updateMethodListWithScroll:false.
self withWaitCursorDo:[
- self updateClassList
- ].
- "stupid - search for class name in (indented) list"
- index := 1.
- classListView list do:[:elem |
- (elem endsWith:(oldClass name)) ifTrue:[
- classIndex := index
- ].
- index := index + 1
- ].
- classIndex notNil ifTrue:[
- classListView selection:classIndex.
- self switchToClass:(Smalltalk at:(oldClass name asSymbol))
- ] ifFalse:[
- self normalLabel.
- ]
- ]
-!
-
-classSelection:lineNr
- "user clicked on a class line - show method categories"
-
- |classSymbol cls|
-
- classSymbol := classListView selectionValue withoutSpaces asSymbol.
- (Smalltalk includesKey:classSymbol) ifTrue:[
- cls := Smalltalk at:classSymbol
- ].
- cls notNil ifTrue:[
- self switchToClass:cls.
- self classSelectionChanged
- ]
-!
-
-methodCategorySelectionChanged
- "method category selection has changed - update dependant views"
-
- self withWaitCursorDo:[
- currentMethod := nil.
-
- self updateMethodList.
- self updateCodeView.
-
- currentMethodCategory notNil ifTrue:[
- methodCategoryListView selectElement:currentMethodCategory
- ].
-
- codeView acceptAction:[:theCode |
- codeView cursor:Cursor execute.
- Object abortSignal catch:[
- actualClass compiler compile:theCode asString
- forClass:actualClass
- inCategory:currentMethodCategory
- notifying:codeView.
- codeView modified:false.
- self updateMethodListWithScroll:false.
- ].
- codeView cursor:Cursor normal.
- ].
- codeView explainAction:[:theCode :theSelection |
- self showExplanation:(Explainer explain:theSelection
- in:theCode
- forClass:actualClass)
- ]
- ]
-!
-
-methodCategorySelection:lineNr
- "user clicked on a method category line - show selectors"
-
- currentClass isNil ifTrue:[^ self].
-
- currentMethodCategory := methodCategoryListView selectionValue.
- self methodCategorySelectionChanged
-!
-
-methodSelectionChanged
- "method selection has changed - update dependant views"
-
- self withWaitCursorDo:[
- self updateCodeView.
- codeView acceptAction:[:theCode |
- codeView cursor:Cursor execute.
- Object abortSignal catch:[
- actualClass compiler compile:theCode asString
- forClass:actualClass
- inCategory:currentMethodCategory
- notifying:codeView.
- codeView modified:false.
- self updateMethodListWithScroll:false.
- ].
- codeView cursor:Cursor normal.
- ].
- codeView explainAction:[:theCode :theSelection |
- self showExplanation:(Explainer explain:theSelection
- in:theCode
- forClass:actualClass)
- ].
- methodListView notNil ifTrue:[
- (currentMethod notNil and:[currentMethod isWrapped]) ifTrue:[
- self initializeMethodMenu2
- ] ifFalse:[
- self initializeMethodMenu
- ]
+ Transcript showCr:('searching for users of ' , oldSym); endEntry.
+ self class browseReferendsOf:oldSym warnIfNone:false
]
]
!
-methodSelection:lineNr
- "user clicked on a method line - show code"
-
- |selectorString selectorSymbol|
-
- currentClass isNil ifTrue:[^ self].
-
- selectorString := methodListView selectionValue.
- "
- kludge: check if its a wrapped one
- "
- (selectorString endsWith:' !!') ifTrue:[
- selectorString := selectorString copyTo:(selectorString size - 2)
- ].
- selectorSymbol := selectorString asSymbol.
- currentMethod := actualClass compiledMethodAt:selectorSymbol.
-
- methodCategoryListView notNil ifTrue:[
- currentMethod notNil ifTrue:[
- (currentMethodCategory = currentMethod category) ifFalse:[
- currentMethodCategory := currentMethod category.
- methodCategoryListView selectElement:currentMethodCategory
- ]
- ]
- ].
-
- self methodSelectionChanged
-!
-
-classFromClassMethodString:aString
- "helper for classMethod-list - extract class name from the string"
-
- |pos|
-
- pos := aString indexOf:(Character space).
- ^ aString copyTo:(pos - 1)
-!
-
-selectorFromClassMethodString:aString
- "helper for classMethod-list - extract selector from the string"
-
- |pos|
-
- pos := aString indexOf:(Character space).
- ^ aString copyFrom:(pos + 1)
-!
-
-listSelection:lineNr
- "user clicked on a class/method line - show code"
-
- |string classString selectorString|
-
- string := classMethodListView selectionValue.
- classString := self classFromClassMethodString:string.
- selectorString := self selectorFromClassMethodString:string.
- ((classString ~= 'Metaclass') and:[classString endsWith:'class']) ifTrue:[
- classString := classString copyTo:(classString size - 5).
- self switchToClass:(Smalltalk at:classString asSymbol).
- actualClass := currentClass class
- ] ifFalse:[
- self switchToClass:(Smalltalk at:classString asSymbol).
- actualClass := currentClass
- ].
- currentClass isNil ifTrue:[
- self warn:'oops class is gone'
- ] ifFalse:[
- currentClassCategory := currentClass category.
- currentMethod := actualClass compiledMethodAt:(selectorString asSymbol).
- currentMethodCategory := currentMethod category.
-
- self methodSelectionChanged
- ]
-! !
-
-!SystemBrowser methodsFor:'class category menu'!
-
-initializeClassCategoryMenu
- |labels|
-
- labels := resources array:#(
- 'fileOut'
- 'fileOut each'
-"
- 'fileOut binary'
-"
- 'printOut'
- 'printOut protocol'
- '-'
- 'SPAWN_CATEGORY'
- 'spawn full class'
- '-'
- 'update'
- 'find class ...'
- '-'
- 'new class category ...'
- 'rename ...'
- 'remove').
-
- classCategoryListView
- middleButtonMenu:(PopUpMenu
- labels:labels
- selectors:#(classCategoryFileOut
- classCategoryFileOutEach
- classCategoryPrintOut
- classCategoryPrintOutProtocol
- nil
- classCategorySpawn
- classCategorySpawnFullClass
- nil
- classCategoryUpdate
- classCategoryFindClass
- nil
- classCategoryNewCategory
- classCategoryRename
- classCategoryRemove)
- receiver:self
- for:classCategoryListView)
-!
-
-allClassesInCurrentCategoryInOrderDo:aBlock
- "evaluate aBlock for all classes in the current class category;
- superclasses come first - then subclasses"
-
- |classes|
-
- currentClassCategory notNil ifTrue:[
- classes := OrderedCollection new.
- Smalltalk allClassesDo:[:aClass |
- aClass isMeta ifFalse:[
- (aClass category = currentClassCategory) ifTrue:[
- classes add:aClass
- ]
- ]
- ].
- classes topologicalSort:[:a :b | b isSubclassOf:a].
- classes do:aBlock
- ]
-!
-
-allClassesInCurrentCategoryDo:aBlock
- "evaluate aBlock for all classes in the current class category;
- superclasses come first - then subclasses"
-
- currentClassCategory notNil ifTrue:[
- Smalltalk allClassesDo:[:aClass |
- aClass isMeta ifFalse:[
- (aClass category = currentClassCategory) ifTrue:[
- aBlock value:aClass
- ]
- ]
- ].
- ]
-!
-
-classCategoryUpdate
- "update class category list and dependants"
-
- |oldClassName oldMethodCategory|
-
- classCategoryListView notNil ifTrue:[
- currentClass notNil ifTrue:[
- oldClassName := currentClass name.
- (oldClassName endsWith:'-old') ifTrue:[
- oldClassName := oldClassName copyTo:(oldClassName size - 4)
- ]
- ].
- oldMethodCategory := currentMethodCategory.
-
- classCategoryListView setContents:(self listOfAllClassCategories).
- currentClassCategory notNil ifTrue:[
- classCategoryListView selectElement:currentClassCategory.
- self classCategorySelectionChanged.
- oldClassName notNil ifTrue:[
- classListView selectElement:oldClassName.
- self switchToClass:(Smalltalk at:oldClassName asSymbol).
- self classSelectionChanged.
- oldMethodCategory notNil ifTrue:[
- methodCategoryListView selectElement:oldMethodCategory.
- currentMethodCategory := oldMethodCategory.
- self methodCategorySelectionChanged
- ]
- ]
- ]
- ]
-!
-
-classCategoryPrintOutProtocol
- |printStream|
-
- self allClassesInCurrentCategoryInOrderDo:[:aClass |
- printStream := Printer new.
- aClass printOutProtocolOn:printStream.
- printStream close
- ]
-!
-
-classCategoryPrintOut
- |printStream|
-
- self allClassesInCurrentCategoryDo:[:aClass |
- printStream := Printer new.
- aClass printOutOn:printStream.
- printStream close
- ]
-!
-
-classCategoryFileOut
- "create a file 'categoryName' consisting of all classes in current category"
-
- |aStream fileName|
-
- 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 label:('System Browser writing: ' , fileName).
- self allClassesInCurrentCategoryInOrderDo:[:aClass |
- aClass fileOutOn:aStream.
- ].
- aStream close.
- self normalLabel.
- ]
-!
-
-classCategoryFileOutEach
- self withWaitCursorDo:[
- self allClassesInCurrentCategoryDo:[:aClass |
- self label:('System Browser saving: ' , aClass name).
- Class fileOutErrorSignal handle:[:ex |
- self warn:'cannot create: %1' with:ex parameter.
- ex return.
- ] do:[
- aClass fileOut
- ]
- ].
- self normalLabel.
- ]
-!
-
-classCategorySpawn
- "create a new SystemBrowser browsing current classCategory"
-
- currentClassCategory notNil ifTrue:[
- self withWaitCursorDo:[
- self class browseClassCategory:currentClassCategory
- ]
- ]
-!
-
-classCategorySpawnFullClass
- "create a new SystemBrowser browsing full class"
-
- |newBrowser|
-
- self withWaitCursorDo:[
- newBrowser := self class browseFullClasses
-"
- .
- currentClass notNil ifTrue:[
- newBrowser switchToClassNamed:(currentClass name)
- ]
-"
- ]
-!
-
-classCategoryNewCategory
- |box|
-
- box := self enterBoxTitle:'name of new class category:' okText:'create'.
- box action:[:aString |
- |categories|
-
- categories := classCategoryListView list.
- (categories includes:aString) ifFalse:[
- categories add:aString.
- categories sort.
- classCategoryListView setContents:categories.
- currentClassCategory := aString.
- classCategoryListView selectElement:aString.
- self switchToClass:nil.
- actualClass := nil.
- self classCategorySelectionChanged
- ]
- ].
- box showAtPointer
-!
-
switchToClassNamed:aString
- |classSymbol theClass|
+ |classSymbol theClass newCat|
+
+ aString knownAsSymbol ifFalse:[^ self].
classSymbol := aString asSymbol.
theClass := Smalltalk at:classSymbol.
theClass isBehavior ifTrue:[
classCategoryListView notNil ifTrue:[
currentClassHierarchy isNil ifTrue:[
- (theClass category ~~ currentClassCategory) ifTrue:[
- currentClassCategory := theClass category.
- currentClassCategory isNil ifTrue:[
+ ((newCat := theClass category) ~= currentClassCategory) ifTrue:[
+ currentClassCategory := newCat.
+ newCat isNil ifTrue:[
classCategoryListView selectElement:'* no category *'
] ifFalse:[
- classCategoryListView selectElement:currentClassCategory
+ classCategoryListView selectElement:newCat.
].
- self classCategorySelectionChanged
+ "/ classCategoryListView makeSelectionVisible.
]
]
].
+ self updateClassList.
self switchToClass:theClass.
classListView selectElement:aString.
self classSelectionChanged
@@ -2559,130 +3190,274 @@
list:classNames sort.
box action:[:aString | self switchToClassNamed:aString].
box showAtPointer
-!
-
-classCategoryFindClass
- |box|
-
- box := self enterBoxForCodeSelectionTitle:'class to find:' okText:'find'.
- box action:[:aString | self switchToClassNameMatching:aString].
- box showAtPointer
-!
-
-renameCurrentClassCategoryTo:aString
- "helper - do the rename"
-
- |any categories|
-
- currentClassCategory notNil ifTrue:[
- any := false.
- Smalltalk allBehaviorsDo:[:aClass |
- aClass category = currentClassCategory ifTrue:[
- aClass category:aString.
- any := true
- ]
- ].
- any ifFalse:[
- categories := classCategoryListView list.
- categories remove:currentClassCategory.
- categories add:aString.
- categories sort.
- classCategoryListView setContents:categories.
- currentClassCategory := aString.
- classCategoryListView selectElement:aString.
- ] ifTrue:[
- currentClassCategory := aString.
- self updateClassCategoryList.
- self updateClassListWithScroll:false
- ]
- ]
-!
-
-classCategoryRename
- "launch an enterBox to rename current class category"
-
- |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
- ]
+! !
+
+!SystemBrowser methodsFor:'variable stuff'!
+
+updateVariableList
+ |l subList flags last nameAccessSelector class oldSelection|
+
+ variableListView isNil ifTrue:[^ self].
+
+ oldSelection := variableListView selectionValue.
+
+ l := OrderedCollection new.
+ "
+ show classVars, if classProtocol is shown (instead of classInstance vars)
+ "
+ showInstance ifTrue:[
+ nameAccessSelector := #instVarNames
+ ] ifFalse:[
+ nameAccessSelector := #classVarNames
].
- subclassesRemoved := OrderedCollection new.
- classesToRemove do:[:aClass |
- aClass allSubclassesDo:[:aSubclass |
- (classesToRemove includes:aSubclass) ifFalse:[
- (subclassesRemoved includes:aSubclass) ifFalse:[
- subclassesRemoved add:aSubclass
- ]
+
+ class := currentClass notNil ifTrue:[currentClass] ifFalse:[actualClass].
+ class isNil ifTrue:[class := currentClassHierarchy].
+ class withAllSuperclasses do:[:aClass |
+ |ignore|
+
+ ignore := fullProtocol
+ and:[classListView valueIsInSelection:(aClass name asString)].
+ ignore ifFalse:[
+ subList := aClass perform:nameAccessSelector.
+ subList size ~~ 0 ifTrue:[
+ l := l , (subList asOrderedCollection reverse).
+ l := l , (OrderedCollection with:'---- ' , aClass name , ' ---------').
]
]
].
-
- 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
+ l reverse.
+ variableListView setAttributes:nil.
+ variableListView list:l.
+ l keysAndValuesDo:[:index :entry |
+ (entry startsWith:'---') ifTrue:[
+ variableListView attributeAt:index put:#disabled.
+ last := index
+ ]
].
-
- 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
+ last notNil ifTrue:[variableListView scrollToLine:last].
+
+ oldSelection notNil ifTrue:[
+ variableListView selectElement:oldSelection
+ ]
+!
+
+unhilightMethods
+ "unhighlight items in method list"
+
+ variableListView isNil ifTrue:[^ self].
+
+ methodListView notNil ifTrue:[
+ 1 to:methodListView list size do:[:entry |
+ methodListView attributeAt:entry put:nil.
+ ].
].
- 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 |
- Smalltalk removeClass:aClass
+
+!
+
+hilightMethodsInMethodCategoryList:inCat inMethodList:inMethods
+ "search for methods which access the selected
+ variable, and highlight them"
+
+ |name idx redefinedSelectors|
+
+ variableListView isNil ifTrue:[^ self].
+
+ inCat ifTrue:[self unhilightMethodCategories].
+ inMethods ifTrue:[self unhilightMethods].
+
+ actualClass isNil ifTrue:[^ self].
+ (methodCategoryListView isNil
+ and:[methodListView isNil]) ifTrue:[^ self].
+
+ name := variableListView selectionValue.
+ name isNil ifTrue:[^ self].
+
+ self withCursor:(Cursor questionMark) do:[
+ |classes filter any|
+
+ classes := Array with:currentClass.
+ currentClassHierarchy notNil ifTrue:[
+ fullProtocol ifTrue:[
+ ].
+ classes := classes , currentClass allSuperclasses.
+ redefinedSelectors := IdentitySet new.
+ ].
+ showInstance ifTrue:[
+ filter := self class filterToSearchInstRefsTo:name modificationsOnly:false
+ ] ifFalse:[
+ filter := self class filterToSearchClassRefsTo:name modificationsOnly:false
+ ].
+
+ any := false.
+ "
+ highlight the method that ref this variable
+ "
+ classes do:[:someClass |
+ someClass methodArray with:someClass selectorArray
+ do:[:method :selector |
+
+ (inCat
+ or:[methodListView list notNil
+ and:[methodListView list includes:selector]])
+ ifTrue:[
+ (redefinedSelectors isNil
+ or:[(redefinedSelectors includes:selector) not])
+ ifTrue:[
+ (filter value:someClass value:method value:selector) ifTrue:[
+ |idx cat|
+
+ (inCat
+ and:[methodCategoryListView notNil
+ and:[methodCategoryListView list notNil]]) ifTrue:[
+ cat := method category.
+ "
+ highlight the methodCategory
+ "
+ idx := methodCategoryListView list indexOf:cat.
+ idx ~~ 0 ifTrue:[
+ methodCategoryListView attributeAt:idx put:#bold.
+ ].
+ ].
+
+ (inMethods
+ and:[methodListView notNil
+ and:[methodListView list notNil]]) ifTrue:[
+ "
+ highlight the method
+ "
+ idx := methodListView list indexOf:selector.
+ idx ~~ 0 ifTrue:[
+ methodListView attributeAt:idx put:#bold.
+ ].
+ any := true
+ ].
+ ].
+ redefinedSelectors notNil ifTrue:[
+ redefinedSelectors add:selector
+ ]
+ ]
+ ]
+ ]
].
- classesToRemove do:[:aClass |
- Smalltalk removeClass:aClass
+ any ifTrue:[
+ self setSearchPattern:name
+ ]
+ ]
+
+
+!
+
+hilightMethodsInMethodCategoryList
+ "search for methods which access the selected
+ variable, and highlight them"
+
+ self hilightMethodsInMethodCategoryList:true inMethodList:false
+
+
+
+!
+
+unhilightMethodCategories
+ "unhighlight items in method list"
+
+ variableListView isNil ifTrue:[^ self].
+
+ methodCategoryListView notNil ifTrue:[
+ 1 to:methodCategoryListView list size do:[:entry |
+ methodCategoryListView attributeAt:entry put:nil.
+ ]
+ ].
+
+
+!
+
+hilightMethodsInMethodList
+ "search for methods which access the selected
+ variable, and highlight them"
+
+ self hilightMethodsInMethodCategoryList:false inMethodList:true
+
+
+
+! !
+
+!SystemBrowser methodsFor:'class list menu'!
+
+classDefinition
+ "show class definition in codeView and setup accept-action for
+ a class-definition change.
+ Extract documentation either from a documentation method or
+ from the comment - not a biggy, but beginners will like
+ it when exploring the system."
+
+ self doClassMenu:[
+ |m s aStream isComment|
+
+ aStream := WriteStream on:(String new:200).
+ currentClass fileOutDefinitionOn:aStream.
+
+ currentClass isLoaded ifTrue:[
+ "
+ add documentation as a comment, if there is any
+ "
+ m := currentClass class compiledMethodAt:#documentation.
+ m notNil ifTrue:[
+ s := m comment.
+ isComment := false.
+ ] ifFalse:[
+ "try comment"
+ s := currentClass comment.
+ s notNil ifTrue:[
+ isComment := true
+ ]
+ ].
].
- currentClassCategory := nil.
- self switchToClass:nil.
- Smalltalk changed
+ s notNil ifTrue:[
+ aStream cr.
+ aStream cr.
+ aStream cr.
+ aStream cr.
+ aStream cr.
+ aStream nextPut:$" ; cr; nextPutAll:' Documentation:'; cr.
+ aStream cr.
+ aStream nextPutAll:s.
+ aStream cr; cr.
+ aStream nextPutAll:' Notice: '; cr.
+ aStream nextPutAll:' the above string has been extracted from the classes '.
+ aStream nextPutAll:(isComment ifTrue:['comment.'] ifFalse:['documentation method.']).
+ aStream cr.
+ aStream nextPutAll:' It will not preserved when accepting a new class definition.'; cr.
+ aStream nextPut:$".
+ ].
+
+ codeView contents:(aStream contents).
+ codeView modified:false.
+ codeView acceptAction:[:theCode |
+ codeView cursor:Cursor execute.
+ Object abortSignal catch:[
+ (Compiler evaluate:theCode asString notifying:codeView)
+ isBehavior ifTrue:[
+ codeView modified:false.
+ self classCategoryUpdate.
+ self updateClassListWithScroll:false.
+ ]
+ ].
+ codeView cursor:Cursor normal.
+ ].
+ codeView explainAction:nil.
+
+ methodListView notNil ifTrue:[
+ methodListView deselect
+ ].
+ aspect := #definition.
+ self normalLabel
]
-! !
-
-!SystemBrowser methodsFor:'class menu'!
+!
initializeClassMenu
- |labels menu varMenu|
+ |labels menu|
labels := resources array:#(
'fileOut'
@@ -2691,6 +3466,7 @@
" 'printOut full protocol' "
'-'
'SPAWN_CLASS'
+ 'spawn full protocol'
'spawn hierarchy'
'spawn subclasses'
'-'
@@ -2715,6 +3491,7 @@
" classPrintOutFullProtocol "
nil
classSpawn
+ classSpawnFullProtocol
classSpawnHierarchy
classSpawnSubclasses
nil
@@ -2734,90 +3511,31 @@
receiver:self
for:classListView.
- classListView middleButtonMenu:menu.
-
- 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:#(
- classInstVarRefs
- classClassVarRefs
- classAllInstVarRefs
- classAllClassVarRefs
- nil
- classInstVarMods
- classClassVarMods
- classAllInstVarMods
- classAllClassVarMods
- )
- receiver:self
- for:self).
-
- variableListView isNil ifTrue:[
- menu addLabel:(resources string:'variable search')
- selector:#variables
- before:#classRefs.
- menu subMenuAt:#variables put:varMenu.
- ] ifFalse:[
- variableListView middleButtonMenu:varMenu
- ].
-!
-
-checkClassCategorySelected
- currentClassCategory isNil ifTrue:[
- self warn:'select a class category first'.
- ^ false
+ fullProtocol ifFalse:[
+ classListView middleButtonMenu:menu.
].
- ^ true
-!
-
-checkClassSelected
- currentClass isNil ifTrue:[
- self warn:'select a class first'.
- ^ false
- ].
- ^ true
-!
-
-checkMethodCategorySelected
- currentMethodCategory isNil ifTrue:[
- self warn:'select a method category first'.
- ^ false
- ].
- ^ true
-!
-
-whenMethodCategorySelected:aBlock
- self checkMethodCategorySelected ifTrue:[
- self withWaitCursorDo:aBlock
+
+ self initializeVariableListMenu.
+
+!
+
+classFileOut
+ "fileOut the current class.
+ Catch errors (sure, you like to know if it failed) and
+ warn if any)"
+
+ self doClassMenu:[
+ self busyLabel:'saving %1' with:currentClass name.
+ Class fileOutErrorSignal handle:[:ex |
+ self warn:'cannot create: %1' with:ex parameter.
+ ex return.
+ ] do:[
+ currentClass fileOut.
+ ].
+ self normalLabel.
]
!
-checkMethodSelected
- currentMethod isNil ifTrue:[
- self warn:'select a method first'.
- ^ false
- ].
- ^ true
-!
-
-doClassMenu:aBlock
- "a helper - check if class is selected and evaluate aBlock
- while showing waitCursor"
-
- self checkClassSelected ifTrue:[
- self withWaitCursorDo:aBlock
- ]
-!
-
doClassMenuWithSelection:aBlock
"a helper - if there is a selection, which represents a classes name,
evaluate aBlock, passing that class and optional selector as arguments.
@@ -2828,18 +3546,27 @@
string := codeView selection.
string notNil 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
- ].
+ 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:[
- sel := Parser selectorInExpression:string.
isMeta ifTrue:[
cls := cls class
].
@@ -2853,7 +3580,13 @@
].
].
- self doClassMenu:[aBlock value:currentClass value:nil]
+ classMethodListView notNil ifTrue:[
+ sel := classMethodListView selectionValue.
+ sel notNil ifTrue:[
+ sel := self selectorFromClassMethodString:sel
+ ]
+ ].
+ self doClassMenu:[aBlock value:currentClass value:sel]
!
classSpawn
@@ -2865,7 +3598,7 @@
self doClassMenuWithSelection:[:cls :sel |
cls isMeta ifTrue:[
- Smalltalk allClassesDo:[:aClass |
+ Smalltalk allBehaviorsDo:[:aClass |
aClass class == cls ifTrue:[
browser := self class browseClass:aClass.
browser classProtocol.
@@ -2944,19 +3677,6 @@
]
!
-classFileOut
- self doClassMenu:[
- self label:('System Browser saving: ' , currentClass name).
- Class fileOutErrorSignal handle:[:ex |
- self warn:'cannot create: %1' with:ex parameter.
- ex return.
- ] do:[
- currentClass fileOut.
- ].
- self normalLabel.
- ]
-!
-
classHierarchy
"show current classes hierarchy in codeView"
@@ -2972,44 +3692,28 @@
methodListView notNil ifTrue:[
methodListView deselect
].
- aspect := #hierarchy
+ aspect := #hierarchy.
+ self normalLabel
]
!
-classDefinition
- "show class definition in codeView and setup accept-action for
- class-definition change"
-
- |aStream|
-
- self doClassMenu:[
- aStream := WriteStream on:(String new:200).
- currentClass fileOutDefinitionOn:aStream.
- codeView contents:(aStream contents).
- codeView modified:false.
- codeView acceptAction:[:theCode |
- codeView cursor:Cursor execute.
- Object abortSignal catch:[
- (Compiler evaluate:theCode asString notifying:codeView)
- isBehavior ifTrue:[
- codeView modified:false.
- self classCategoryUpdate.
- self updateClassListWithScroll:false.
- ]
- ].
- codeView cursor:Cursor normal.
- ].
- codeView explainAction:nil.
- methodListView notNil ifTrue:[
- methodListView deselect
- ].
- aspect := #definition
- ]
+classNewClass
+ "create a class-definition prototype in codeview"
+
+ |nm|
+
+ currentClass notNil ifTrue:[
+ nm := currentClass superclass name
+ ] ifFalse:[
+ nm := 'Object'
+ ].
+ self classClassDefinitionTemplateFor:nm in:currentClassCategory.
+ aspect := nil.
!
classClassInstVars
"show class instance variables in codeView and setup accept-action
- for class-instvar-definition change"
+ for a class-instvar-definition change"
|s|
@@ -3030,7 +3734,17 @@
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
]
!
@@ -3038,136 +3752,6 @@
^ self
!
-classComment
- "show the classes comment in the codeView"
-
- self doClassMenu:[
- codeView contents:(currentClass comment).
- codeView modified:false.
- codeView acceptAction:[:theCode |
- Object abortSignal catch:[
- currentClass comment:theCode asString.
- codeView modified:false.
- ]
- ].
- codeView explainAction:nil.
- methodListView notNil ifTrue:[
- methodListView deselect
- ].
- aspect := #comment
- ]
-!
-
-classRefs
- self doClassMenu:[
- self withCursor:(Cursor questionMark) do:[
- self class browseReferendsOf:currentClass name asSymbol
- ]
- ]
-!
-
-classClassDefinitionTemplateFor:name in:cat
- "common helper for newClass and newSubclass
- - show a template to define class name in category cat"
-
- currentMethodCategory := nil.
- currentMethod := nil.
-
- classListView deselect.
-
- fullClass ifFalse:[
- methodCategoryListView contents:nil.
- methodListView contents:nil
- ].
-
- codeView contents:(self templateFor:name in:cat).
- codeView modified:false.
-
- codeView acceptAction:[:theCode |
- codeView cursor:Cursor execute.
- Object abortSignal catch:[
- |cl|
-
- cl := (Compiler evaluate:theCode asString notifying:codeView).
- cl isBehavior ifTrue:[
- codeView modified:false.
- self classCategoryUpdate.
- self updateClassListWithScroll:false.
- self switchToClassNamed:(cl name)
- ]
- ].
- codeView cursor:(Cursor normal).
- ].
- codeView explainAction:nil.
- self switchToClass:nil
-!
-
-classNewClass
- "create a class-definition prototype in codeview"
-
- |nm|
-
- currentClass notNil ifTrue:[
- nm := currentClass superclass name
- ] ifFalse:[
- nm := 'Object'
- ].
- self classClassDefinitionTemplateFor:nm in:currentClassCategory.
- aspect := nil
-!
-
-classNewSubclass
- "create a subclass-definition prototype in codeview"
-
- self doClassMenu:[
- self classClassDefinitionTemplateFor:(currentClass name)
- in:(currentClass category).
- aspect := nil
- ]
-!
-
-renameCurrentClassTo:aString
- "helper - do the rename"
-
- self doClassMenu:[
- |oldName oldSym newSym|
-
- oldName := currentClass name.
- oldSym := oldName asSymbol.
-"
- currentClass setName:aString.
- newSym := aString asSymbol.
- Smalltalk at:oldSym put:nil.
- Smalltalk removeKey:oldSym.
- Smalltalk at:newSym put:currentClass.
-"
-"
- currentClass renameTo:aString.
-"
- Smalltalk renameClass:currentClass to:aString.
-
- self updateClassList.
- self updateMethodCategoryListWithScroll:false.
- self updateMethodListWithScroll:false.
- self withWaitCursorDo:[
- Transcript showCr:('searching for users of ' , oldSym); endEntry.
- self class browseReferendsOf:oldSym warnIfNone:false
- ]
- ]
-!
-
-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
-!
-
classRemove
"user requested remove of current class and all subclasses -
count subclasses and let user confirm removal."
@@ -3193,10 +3777,23 @@
and all subclasses
"
self doClassMenu:[
+ "
+ query ?
+ "
currentClass allSubclassesDo:[:aSubClass |
- Smalltalk removeClass:aSubClass
+ (CheckForInstancesWhenRemovingClasses not
+ or:[aSubClass hasInstances not
+ or:[self confirm:(aSubClass name , ' has instances - remove anyway ?')]])
+ ifTrue:[
+ Smalltalk removeClass:aSubClass
+ ]
].
- Smalltalk removeClass:currentClass.
+ (CheckForInstancesWhenRemovingClasses not
+ or:[currentClass hasInstances not
+ or:[self confirm:(currentClass name , ' has instances - remove anyway ?')]])
+ ifTrue:[
+ Smalltalk removeClass:currentClass.
+ ].
self switchToClass:nil.
Smalltalk changed.
@@ -3215,145 +3812,636 @@
]
]
]
+!
+
+classComment
+ "show the classes comment in the codeView.
+ Also, set acceptaction to change the comment."
+
+ self doClassMenu:[
+ codeView contents:(currentClass comment).
+ codeView modified:false.
+ codeView acceptAction:[:theCode |
+ Object abortSignal catch:[
+ lockUpdates := true.
+ currentClass comment:theCode asString.
+ codeView modified:false.
+ ].
+ lockUpdates := false.
+ ].
+ codeView explainAction:nil.
+
+ methodListView notNil ifTrue:[
+ methodListView deselect
+ ].
+ aspect := #comment.
+ self normalLabel
+ ]
+!
+
+classRefs
+ self doClassMenu:[
+ self withCursor:(Cursor questionMark) do:[
+ self class browseReferendsOf:currentClass name asSymbol
+ ]
+ ]
+!
+
+classNewSubclass
+ "create a subclass-definition prototype in codeview"
+
+ self doClassMenu:[
+ self classClassDefinitionTemplateFor:(currentClass name)
+ in:(currentClass category).
+ aspect := nil
+ ]
+!
+
+classUses
+ "a powerful tool, when trying to learn more about where
+ a class is used. This one searches all uses of a class,
+ and shows a list of uses - try it and like it"
+
+ self doClassMenu:[
+ self withCursor:(Cursor questionMark) do:[
+ self class browseUsesOf:currentClass
+ ]
+ ]
+!
+
+classRename
+ "launch an enterBox for new name and query user"
+
+ |box|
+
+ self checkClassSelected ifFalse:[^ self].
+ box := self enterBoxTitle:(resources string:'rename %1 to:' with:currentClass name) okText:'rename'.
+ box initialText:(currentClass name).
+ box action:[:aString | self renameCurrentClassTo:aString].
+ box showAtPointer
+!
+
+classSpawnFullHierarchy
+ "create a new HierarchyBrowser browsing current class"
+
+ self doClassMenuWithSelection:[:cls :sel |
+ self class browseFullClassHierarchy:cls
+ ]
! !
-!SystemBrowser methodsFor:'variables menu'!
-
-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
+!SystemBrowser methodsFor:'class category stuff'!
+
+checkClassCategorySelected
+ currentClassCategory isNil ifTrue:[
+ self warn:'select a class category first'.
+ ^ false
+ ].
+ ^ true
+!
+
+listOfAllClassCategories
+ "return a list of all class categories"
+
+ |newList cat|
+
+ newList := Text with:'* all *' with:'* hierarchy *'.
+ Smalltalk allBehaviorsDo:[:aClass |
+ cat := aClass category.
+ cat isNil ifTrue:[
+ cat := '* no category *'
+ ].
+ newList indexOf:cat ifAbsent:[newList add:cat]
+ ].
+ newList sort.
+ ^ newList
+!
+
+classCategorySelectionChanged
+ "class category has changed - update dependent views"
+
+ self withWaitCursorDo:[
+ self switchToClass:nil.
+ actualClass := nil.
+ currentMethodCategory := nil.
+ currentMethod := currentSelector := nil.
+
+ self updateClassList.
+ self updateMethodCategoryList.
+ self updateMethodList.
+ self updateCodeView.
+
+ codeView explainAction:nil.
+ codeView acceptAction:nil
+ ]
+!
+
+classCategorySelection:lineNr
+ "user clicked on a class category line - show classes.
+ If switching to hierarchy or all, keep current selections"
+
+ |newCategory oldClass classIndex index|
+
+ newCategory := classCategoryListView selectionValue.
+ (newCategory startsWith:'*') ifTrue:[
+ "etiher all or hierarchy;
+ remember current selections and switch after showing class list"
+ oldClass := currentClass
+ ].
+ currentClassCategory := newCategory.
+ oldClass isNil ifTrue:[
+ self classCategorySelectionChanged
+ ] ifFalse:[
+ self withWaitCursorDo:[
+ self updateClassList
+ ].
+ "stupid - search for class name in (indented) list"
+ index := 1.
+ classListView list do:[:elem |
+ (elem endsWith:(oldClass name)) ifTrue:[
+ classIndex := index
+ ].
+ index := index + 1
+ ].
+ classIndex notNil ifTrue:[
+ classListView selection:classIndex.
+ self switchToClass:(Smalltalk at:(oldClass name asSymbol))
+ ] ifFalse:[
+ self normalLabel.
+ ]
+ ]
+!
+
+updateClassCategoryListWithScroll:scroll
+ |oldClassCategory oldClass oldMethodCategory oldMethod
+ oldSelector newCategoryList|
+
+ classMethodListView notNil ifTrue:[ ^ self ].
+
+ oldClassCategory := currentClassCategory.
+ oldClass := currentClass.
+ oldMethodCategory := currentMethodCategory.
+ oldMethod := currentMethod.
+ oldMethod notNil ifTrue:[
+ oldSelector := currentSelector
+ ].
+
+ classCategoryListView notNil ifTrue:[
+ newCategoryList := self listOfAllClassCategories.
+ newCategoryList = classCategoryListView list ifFalse:[
+ scroll ifTrue:[
+ classCategoryListView contents:newCategoryList
+ ] ifFalse:[
+ classCategoryListView setContents:newCategoryList
+ ]
+ ]
+ ].
+
+ oldClassCategory notNil ifTrue:[
+ classCategoryListView notNil ifTrue:[
+ classCategoryListView selectElement:oldClassCategory
+ ]
+ ].
+ classListView notNil ifTrue:[
+ oldClass notNil ifTrue:[
+ classListView selectElement:(oldClass name)
+ ]
+ ].
+ oldMethodCategory notNil ifTrue:[
+ methodCategoryListView notNil ifTrue:[
+ methodCategoryListView selectElement:oldMethodCategory
+ ].
+ ].
+ oldSelector notNil ifTrue:[
+ methodListView notNil ifTrue:[
+ methodListView selectElement:oldSelector
+ ].
+ ]
+!
+
+updateClassCategoryList
+ self updateClassCategoryListWithScroll:true
+!
+
+allClassesInCurrentCategoryInOrderDo:aBlock
+ "evaluate aBlock for all classes in the current class category;
+ superclasses come first - then subclasses"
+
+ |classes|
+
+ currentClassCategory notNil ifTrue:[
+ classes := OrderedCollection new.
+ Smalltalk allBehaviorsDo:[:aClass |
+ aClass isMeta ifFalse:[
+ (aClass category = currentClassCategory) ifTrue:[
+ classes add:aClass
+ ]
+ ]
+ ].
+ classes topologicalSort:[:a :b | b isSubclassOf:a].
+ classes do:aBlock
+ ]
+!
+
+allClassesInCurrentCategoryDo:aBlock
+ "evaluate aBlock for all classes in the current class category;
+ superclasses come first - then subclasses"
+
+ currentClassCategory notNil ifTrue:[
+ Smalltalk allBehaviorsDo:[:aClass |
+ aClass isMeta ifFalse:[
+ (aClass category = currentClassCategory) ifTrue:[
+ aBlock value:aClass
+ ]
+ ]
+ ].
+ ]
+!
+
+renameCurrentClassCategoryTo:aString
+ "helper - do the rename"
+
+ |any categories|
+
+ currentClassCategory notNil ifTrue:[
+ any := false.
+ Smalltalk allBehaviorsDo:[:aClass |
+ aClass category = currentClassCategory ifTrue:[
+ aClass category:aString.
+ any := true
+ ]
+ ].
+ any ifFalse:[
+ categories := classCategoryListView list.
+ categories remove:currentClassCategory.
+ categories add:aString.
+ categories sort.
+ classCategoryListView setContents:categories.
+ currentClassCategory := aString.
+ classCategoryListView selectElement:aString.
+ ] ifTrue:[
+ currentClassCategory := aString.
+ self updateClassCategoryList.
+ self updateClassListWithScroll:false
+ ]
+ ]
+! !
+
+!SystemBrowser methodsFor:'class-method stuff'!
+
+classFromClassMethodString:aString
+ "helper for classMethod-list - extract class name from the string"
+
+ |pos|
+
+ pos := aString indexOf:(Character space).
+ ^ aString copyTo:(pos - 1)
+!
+
+selectorFromClassMethodString:aString
+ "helper for classMethod-list - extract selector from the string"
+
+ |pos|
+
+ pos := aString indexOf:(Character space).
+ ^ aString copyFrom:(pos + 1)
+!
+
+classMethodSelection:lineNr
+ "user clicked on a class/method line - show code"
+
+ |string classString selectorString|
+
+ string := classMethodListView selectionValue.
+ classString := self classFromClassMethodString:string.
+ selectorString := self selectorFromClassMethodString:string.
+ ((classString ~= 'Metaclass') and:[classString endsWith:'class']) ifTrue:[
+ classString := classString copyTo:(classString size - 5).
+ self switchToClass:(Smalltalk at:classString asSymbol).
+ actualClass := currentClass class
+ ] ifFalse:[
+ self switchToClass:(Smalltalk at:classString asSymbol).
+ actualClass := currentClass
+ ].
+ currentClass isNil ifTrue:[
+ self warn:'oops class is gone'
+ ] ifFalse:[
+ currentClassCategory := currentClass category.
+ currentSelector := selectorString asSymbol.
+ currentMethod := actualClass compiledMethodAt:currentSelector.
+ currentMethodCategory := currentMethod category.
+
+ self methodSelectionChanged
+ ]
+! !
+
+!SystemBrowser methodsFor:'class category list menu'!
+
+initializeClassCategoryMenu
+ |labels|
+
+ labels := resources array:#(
+ 'fileOut'
+ 'fileOut each'
+"
+ 'fileOut binary'
+"
+ 'printOut'
+ 'printOut protocol'
+ '-'
+ 'SPAWN_CATEGORY'
+ 'spawn full class'
+ '-'
+ 'update'
+ 'find class ...'
+ '-'
+ 'new class category ...'
+ 'rename ...'
+ 'remove').
+
+ classCategoryListView
+ middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:#(classCategoryFileOut
+ classCategoryFileOutEach
+ classCategoryPrintOut
+ classCategoryPrintOutProtocol
+ nil
+ classCategorySpawn
+ classCategorySpawnFullClass
+ nil
+ classCategoryUpdate
+ classCategoryFindClass
+ nil
+ classCategoryNewCategory
+ classCategoryRename
+ classCategoryRemove)
+ receiver:self
+ for:classCategoryListView)
+!
+
+classCategoryUpdate
+ "update class category list and dependants"
+
+ |oldClassName oldMethodCategory|
+
+ classCategoryListView notNil ifTrue:[
+ currentClass notNil ifTrue:[
+ oldClassName := currentClass name.
+ (oldClassName endsWith:'-old') ifTrue:[
+ oldClassName := oldClassName copyTo:(oldClassName size - 4)
+ ]
+ ].
+ oldMethodCategory := currentMethodCategory.
+
+ classCategoryListView setContents:(self listOfAllClassCategories).
+ currentClassCategory notNil ifTrue:[
+ classCategoryListView selectElement:currentClassCategory.
+ self classCategorySelectionChanged.
+ oldClassName notNil ifTrue:[
+ classListView selectElement:oldClassName.
+ self switchToClass:(Smalltalk at:oldClassName asSymbol).
+ self classSelectionChanged.
+ oldMethodCategory notNil ifTrue:[
+ methodCategoryListView selectElement:oldMethodCategory.
+ currentMethodCategory := oldMethodCategory.
+ self methodCategorySelectionChanged
+ ]
+ ]
+ ]
+ ]
+!
+
+classCategoryPrintOutProtocol
+ |printStream|
+
+ self allClassesInCurrentCategoryInOrderDo:[:aClass |
+ printStream := Printer new.
+ aClass printOutProtocolOn:printStream.
+ printStream close
+ ]
+!
+
+classCategoryPrintOut
+ |printStream|
+
+ self allClassesInCurrentCategoryDo:[:aClass |
+ printStream := Printer new.
+ aClass printOutOn:printStream.
+ printStream close
+ ]
+!
+
+classCategorySpawn
+ "create a new SystemBrowser browsing current classCategory"
+
+ currentClassCategory notNil ifTrue:[
+ self withWaitCursorDo:[
+ self class browseClassCategory:currentClassCategory
+ ]
+ ]
+!
+
+classCategoryFileOut
+ "create a file 'categoryName' consisting of all classes in current category"
+
+ |aStream fileName|
+
+ self checkClassCategorySelected ifFalse:[^ self].
+
+ fileName := currentClassCategory asString.
+ fileName replaceAll:Character space by:$_.
+ "
+ this test allows a smalltalk to be built without Projects/ChangeSets
+ "
+ Project notNil ifTrue:[
+ fileName := Project currentProjectDirectory , fileName.
+ ].
+
+ "
+ if file exists, save original in a .sav file
+ "
+ fileName asFilename exists ifTrue:[
+ fileName asFilename copyTo:(fileName , '.sav')
+ ].
+ aStream := FileStream newFileNamed:fileName.
+ aStream isNil ifTrue:[
+ ^ self warn:'cannot create: %1' with:fileName
+ ].
+ self withWaitCursorDo:[
+ self busyLabel:'writing: %1' with:fileName.
+ self allClassesInCurrentCategoryInOrderDo:[:aClass |
+ aClass fileOutOn:aStream.
+ ].
+ aStream close.
+ self normalLabel.
+ ]
+!
+
+classCategorySpawnFullClass
+ "create a new SystemBrowser browsing full class"
+
+ |newBrowser|
+
+ self withWaitCursorDo:[
+ newBrowser := self class browseFullClasses
+" "
+ .
+ currentClass notNil ifTrue:[
+ newBrowser switchToClassNamed:(currentClass name)
+ ]
+" "
+ ]
+!
+
+classCategoryFileOutEach
+ self withWaitCursorDo:[
+ self allClassesInCurrentCategoryDo:[:aClass |
+ self busyLabel:'saving: ' with:aClass name.
+ Class fileOutErrorSignal handle:[:ex |
+ self warn:'cannot create: %1' with:ex parameter.
+ ex return.
+ ] do:[
+ aClass fileOut
+ ]
+ ].
+ self normalLabel.
+ ]
+!
+
+classCategoryNewCategory
+ |box|
+
+ box := self enterBoxTitle:'name of new class category:' okText:'create'.
+ box action:[:aString |
+ |categories|
+
+ currentClass notNil ifTrue:[
+ categories := OrderedCollection new.
+ currentClass withAllSuperclasses do:[:aClass |
+ aClass methodArray do:[:aMethod |
+ (categories includes:aMethod category) ifFalse:[
+ categories add:aMethod category
+ ]
+ ]
+ ].
+ ].
+ categories isNil ifTrue:[
+ categories := classCategoryListView list.
+ ].
+ (categories includes:aString) ifFalse:[
+ categories add:aString.
+ categories sort.
+ classCategoryListView setContents:categories.
+ currentClassCategory := aString.
+ classCategoryListView selectElement:aString.
+ self switchToClass:nil.
+ actualClass := nil.
+ self classCategorySelectionChanged
+ ]
+ ].
+ box showAtPointer
+!
+
+classCategoryFindClass
+ |box|
+
+ box := self enterBoxForCodeSelectionTitle:'class to find:' okText:'find'.
+ box action:[:aString | self switchToClassNameMatching:aString].
+ box showAtPointer
+!
+
+classCategoryRename
+ "launch an enterBox to rename current class category"
+
+ |box|
+
+ self checkClassCategorySelected ifFalse:[^ self].
+
+ box := self enterBoxTitle:'rename class category to:' okText:'rename'.
+ box initialText:currentClassCategory.
+ box action:[:aString | self renameCurrentClassCategoryTo:aString].
+ box showAtPointer
+!
+
+classCategoryRemove
+ "remove all classes in current category"
+
+ |count t classesToRemove subclassesRemoved box|
+
+ self checkClassCategorySelected ifFalse:[^ self].
+
+ classesToRemove := OrderedCollection new.
+ Smalltalk allBehaviorsDo:[:aClass |
+ aClass category = currentClassCategory ifTrue:[
+ classesToRemove add:aClass
+ ]
+ ].
+ subclassesRemoved := OrderedCollection new.
+ classesToRemove do:[:aClass |
+ aClass allSubclassesDo:[:aSubclass |
+ (classesToRemove includes:aSubclass) ifFalse:[
+ (subclassesRemoved includes:aSubclass) ifFalse:[
+ subclassesRemoved add:aSubclass
]
]
]
].
- ^ box
-!
-
-classInstVarRefsOrModsTitle:title mods:mods
- "show an enterbox for instvar to search for"
-
- self doClassMenu:[
- |box|
-
- box := self enterBoxForVariableSearch:title.
- box action:[:aString |
- self withCursor:(Cursor questionMark) do:[
- self class browseInstRefsTo:aString
- in:(Array with:currentClass)
- modificationsOnly:mods
- ]
- ].
- box showAtPointer
- ]
-!
-
-classInstVarRefs
- "show an enterbox for instVar to search for"
-
- self classInstVarRefsOrModsTitle:'instance variable to browse references to:'
- mods:false
-!
-
-classInstVarMods
- "show an enterbox for instVar to search for"
-
- self classInstVarRefsOrModsTitle:'instance variable to browse modifications of:'
- mods:true
-!
-
-classClassVarRefsOrModsTitle:title mods:mods
- "show an enterbox for classVar to search for"
-
- self doClassMenu:[
- |box|
-
- box := self enterBoxForVariableSearch:title.
- box action:[:aString |
- self withCursor:(Cursor questionMark) do:[
- self class browseClassRefsTo:aString
- in:(Array with:currentClass)
- modificationsOnly:mods
+
+ 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
]
].
- box showAtPointer
- ]
-!
-
-classClassVarMods
- "show an enterbox for classVar to search for"
-
- self classClassVarRefsOrModsTitle:'class variable to browse modifications of:'
- mods:true
-!
-
-classClassVarRefs
- "show an enterbox for classVar to search for"
-
- self classClassVarRefsOrModsTitle:'class variable to browse references to:'
- mods:false
-!
-
-classAllClassOrInstVarRefsTitle:title access:access mods:modifications
- "show an enterbox for instVar to search for"
-
- self doClassMenu:[
- |box|
-
- box := self enterBoxForVariableSearch:title.
- box action:[:aVariableName |
- self withCursor:(Cursor questionMark) do:[
- |homeClass|
-
- homeClass := self findClassOfVariable:aVariableName
- accessWith:access.
- (self class) browseInstRefsTo:aVariableName
- under:homeClass
- modificationsOnly:modifications
- ]
+ classesToRemove do:[:aClass |
+ (CheckForInstancesWhenRemovingClasses not
+ or:[aClass hasInstances not
+ or:[self confirm:(aClass name , ' has instances - remove anyway ?')]])
+ ifTrue:[
+ Smalltalk removeClass:aClass
+ ].
].
- box showAtPointer
+ currentClassCategory := nil.
+ self switchToClass:nil.
+ Smalltalk changed
]
-!
-
-classAllInstVarRefs
- "show an enterbox for instVar to search for"
-
- self classAllClassOrInstVarRefsTitle:'instance variable to browse references to:'
- access:#instVarNames
- mods:false
-!
-
-classAllClassVarRefs
- "show an enterbox for classVar to search for"
-
- self classAllClassOrInstVarRefsTitle:'class variable to browse references to:'
- access:#classVarNames
- mods:false
-!
-
-classAllInstVarMods
- "show an enterbox for instVar to search for"
-
- self classAllClassOrInstVarRefsTitle:'instance variable to browse modifications of:'
- access:#instVarNames
- mods:true
-!
-
-classAllClassVarMods
- "show an enterbox for classVar to search for"
-
- self classAllClassOrInstVarRefsTitle:'class variable to browse modifications of:'
- access:#classVarNames
- mods:true
! !
-!SystemBrowser methodsFor:'method category menu'!
+!SystemBrowser methodsFor:'method category list menu'!
initializeMethodCategoryMenu
|labels|
@@ -3398,116 +4486,12 @@
for:methodCategoryListView)
!
-switchToMethodNamed:matchString
- |aSelector method cat index classToSearch selectors|
-
- currentClass notNil ifTrue:[
- showInstance ifTrue:[
- classToSearch := currentClass
- ] ifFalse:[
- classToSearch := currentClass class
- ].
- selectors := classToSearch selectorArray.
-
- ((matchString ~= '*') and:[matchString includesMatchCharacters]) ifTrue:[
- index := selectors findFirst:[:element | matchString match:element]
- ] ifFalse:[
- index := selectors indexOf:matchString
- ].
-
- (index ~~ 0) ifTrue:[
- aSelector := selectors at:index.
- method := classToSearch methodArray at:index.
- cat := method category.
- cat isNil ifTrue:[cat := '* all *'].
- methodCategoryListView selectElement:cat.
- currentMethodCategory := cat.
- self methodCategorySelectionChanged.
-
- currentMethod := classToSearch compiledMethodAt:aSelector.
- methodListView selectElement:aSelector.
- self methodSelectionChanged
- ]
- ]
-!
-
-switchToAnyMethodNamed:aString
- |aSelector classToStartSearch aClass nm|
-
- aSelector := aString asSymbol.
- currentClass isNil ifTrue:[
- currentClassHierarchy notNil ifTrue:[
- classToStartSearch := currentClassHierarchy
- ]
- ] ifFalse:[
- classToStartSearch := currentClass
- ].
- classToStartSearch notNil ifTrue:[
- showInstance ifFalse:[
- classToStartSearch := classToStartSearch class
- ].
- aClass := classToStartSearch whichClassImplements:aSelector.
- aClass notNil ifTrue:[
- nm := aClass name.
- showInstance ifFalse:[
- ((nm ~= 'Metaclass') and:[nm endsWith:'class']) ifTrue:[
- nm := nm copyTo:(nm size - 5)
- ]
- ].
- self switchToClassNamed:nm.
- self switchToMethodNamed:aString
- ]
- ]
-!
-
-copyMethodsFromClass:aClassName
- |class box|
-
- currentClass notNil ifTrue:[
- Symbol hasInterned:aClassName ifTrue:[:sym |
- (Smalltalk includesKey:sym) ifTrue:[
- class := Smalltalk at:sym
- ].
- ].
- class isBehavior ifFalse:[
- self warn:'no class named %1' with:aClassName.
- ^ self
- ].
-
- showInstance ifFalse:[
- class := class class
- ].
-
- "show enterbox for category to copy from"
-
- box := self enterBoxTitle:'name of category to copy from (matchpattern allowed, * for all):'
- okText:'copy'.
- box action:[:aString | self copyMethodsFromClass:class category:aString].
- box showAtPointer.
- ]
-!
-
-copyMethodsFromClass:class category:category
- |source|
-
- currentClass notNil ifTrue:[
-"/ codeView abortAction:[^ self].
- Object abortSignal catch:[
- class methodArray do:[:aMethod |
- (category match:aMethod category) ifTrue:[
- source := aMethod source.
- codeView contents:source.
- codeView modified:false.
- actualClass compiler compile:source
- forClass:actualClass
- inCategory:aMethod category
- notifying:codeView.
- self updateMethodCategoryListWithScroll:false.
- self updateMethodListWithScroll:false.
- ]
- ]
- ]
- ]
+methodCategoryFindAnyMethod
+ |box|
+
+ box := self enterBoxForSearchSelectorTitle:'method selector to search for:'.
+ box action:[:aString | self switchToAnyMethodNamed:aString].
+ box showAtPointer
!
methodCategoryFindMethod
@@ -3518,14 +4502,6 @@
box showAtPointer
!
-methodCategoryFindAnyMethod
- |box|
-
- box := self enterBoxForSearchSelectorTitle:'method selector to search for:'.
- box action:[:aString | self switchToAnyMethodNamed:aString].
- box showAtPointer
-!
-
methodCategoryPrintOut
|printStream|
@@ -3543,7 +4519,7 @@
self checkClassSelected ifFalse:[^ self].
self whenMethodCategorySelected:[
- self label:('System Browser saving: ' , currentClass name , '-' , currentMethodCategory).
+ self busyLabel:'saving: %1' with:currentClass name , '-' , currentMethodCategory.
Class fileOutErrorSignal handle:[:ex |
self warn:'cannot create: %1' with:ex parameter.
ex return.
@@ -3554,6 +4530,17 @@
]
!
+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"
@@ -3581,12 +4568,12 @@
^ self warn:'cannot create: %1' with:fileName
].
- self label:('System Browser saving: ' , currentMethodCategory).
+ self busyLabel:'saving: ' with:currentMethodCategory.
Class fileOutErrorSignal handle:[:ex |
self warn:'cannot create: %1' with:ex parameter.
ex return
] do:[
- Smalltalk allClassesDo:[:class |
+ Smalltalk allBehaviorsDo:[:class |
|hasMethodsInThisCategory|
hasMethodsInThisCategory := false.
@@ -3616,15 +4603,53 @@
].
!
-methodCategorySpawn
- "create a new SystemBrowser browsing current method category"
-
- currentMethodCategory notNil ifTrue:[
- self withWaitCursorDo:[
- self class browseClass:actualClass
- methodCategory:currentMethodCategory
- ]
- ]
+methodCategoryNewCategory
+ "show the enter box to add a new method category.
+ Offer existing superclass categories in box to help avoiding
+ useless typing."
+
+ |someCategories existingCategories box|
+
+ actualClass notNil ifTrue:[
+ someCategories := actualClass allCategories
+ ] ifFalse:[
+ "
+ mhmh - offer some typical categories ...
+ "
+ showInstance ifTrue:[
+ someCategories := #('accessing'
+ 'initialization'
+ 'private'
+ 'printing & storing'
+ 'queries'
+ 'testing'
+ )
+ ] ifFalse:[
+ someCategories := #(
+ 'documentation'
+ 'initialization'
+ 'instance creation'
+ ).
+ ].
+ ].
+ someCategories sort.
+
+ "
+ remove existing categories
+ "
+ existingCategories := methodCategoryListView list.
+ existingCategories notNil ifTrue:[
+ someCategories := someCategories select:[:cat | (existingCategories includes:cat) not].
+ ].
+
+ box := self listBoxTitle:'name of new method category:'
+ okText:'create'
+ list:someCategories.
+ box action:[:aString | self newMethodCategory:aString].
+ box showAtPointer
+
+
+
!
methodCategorySpawnCategory
@@ -3637,61 +4662,9 @@
]
!
-newMethodCategory:aString
- |categories|
-
- currentClass isNil ifTrue:[
- ^ self warn:'select/create a class first'.
- ].
- categories := methodCategoryListView list.
- categories isNil ifTrue:[categories := Text new].
- (categories includes:aString) ifFalse:[
- categories add:aString.
- categories sort.
- methodCategoryListView contents:categories
- ].
- currentMethodCategory := aString.
- self methodCategorySelectionChanged
-!
-
-methodCategoryNewCategory
- "show the enter box to add a new method category"
-
- |someCategories existingCategories box|
-
- "a tiny little goody here ..."
- showInstance ifTrue:[
- someCategories := #('accessing'
- 'initialization'
- 'private'
- 'printing & storing'
- 'queries'
- 'testing'
- )
- ] ifFalse:[
- someCategories := #(
- 'documentation'
- 'initialization'
- 'instance creation'
- ).
- ].
- existingCategories := methodCategoryListView list.
- existingCategories notNil ifTrue:[
- someCategories := someCategories select:[:cat | (existingCategories includes:cat) not].
- ].
-
- box := self listBoxTitle:'name of new method category:'
- okText:'create'
- list:someCategories.
- box action:[:aString | self newMethodCategory:aString].
- box showAtPointer
-!
-
methodCategoryCreateAccessMethods
"create access methods for all instvars"
- |source|
-
self checkClassSelected ifFalse:[^ self].
showInstance ifFalse:[
@@ -3700,7 +4673,15 @@
].
self withWaitCursorDo:[
- currentClass instVarNames do:[:name |
+ |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.
@@ -3752,7 +4733,7 @@
box action:[:aString |
actualClass renameCategory:currentMethodCategory to:aString.
currentMethodCategory := aString.
- currentMethod := nil.
+ currentMethod := currentSelector := nil.
self updateMethodCategoryList.
self updateMethodListWithScroll:false
].
@@ -3773,7 +4754,7 @@
].
(count == 0) ifTrue:[
currentMethodCategory := nil.
- currentMethod := nil.
+ currentMethod := currentSelector := nil.
self updateMethodCategoryListWithScroll:false.
self updateMethodList
] ifFalse:[
@@ -3797,7 +4778,7 @@
]
].
currentMethodCategory := nil.
- currentMethod := nil.
+ currentMethod := currentSelector := nil.
self updateMethodCategoryList.
self updateMethodList
]
@@ -3805,11 +4786,140 @@
]
! !
-!SystemBrowser methodsFor:'method menu'!
+!SystemBrowser methodsFor:'method list menu'!
+
+methodMenu
+ "return a popupmenu as appropriate for the methodList"
+
+ |labels selectors|
+
+ (currentMethod notNil and:[currentMethod isWrapped]) ifTrue:[
+ labels := #(
+ 'fileOut'
+ 'printOut'
+ '-'
+ 'SPAWN_METHOD'
+ '-'
+ 'senders ...'
+ 'implementors ...'
+ 'globals ...'
+"
+ 'strings ...'
+ 'apropos ...'
+"
+ '-'
+ 'local senders ...'
+ 'local implementors ...'
+"
+ 'local strings ...'
+"
+ '-'
+ 'remove break/trace'
+ '-'
+ 'new method'
+ 'change category ...'
+ 'remove'
+ ).
+
+ selectors := #(
+ methodFileOut
+ methodPrintOut
+ nil
+ methodSpawn
+ nil
+ methodSenders
+ methodImplementors
+ methodGlobalReferends
+"
+ methodStringSearch
+ methodAproposSearch
+"
+ nil
+ methodLocalSenders
+ methodLocalImplementors
+"
+ methodLocalStringSearch
+"
+ nil
+ methodRemoveBreakOrTrace
+ nil
+ methodNewMethod
+ methodChangeCategory
+ methodRemove
+ )
+ ] ifFalse:[
+ labels := #(
+ 'fileOut'
+ 'printOut'
+ '-'
+ 'SPAWN_METHOD'
+ '-'
+ 'senders ...'
+ 'implementors ...'
+ 'globals ...'
+"
+ 'strings ...'
+ 'apropos ...'
+"
+ '-'
+ 'local senders ...'
+ 'local implementors ...'
+"
+ 'local strings ...'
+"
+ '-'
+ 'breakpoint'
+ 'trace'
+ 'trace sender'
+ '-'
+ 'new method'
+ 'change category ...'
+ 'remove'
+ ).
+ selectors := #(
+ methodFileOut
+ methodPrintOut
+ nil
+ methodSpawn
+ nil
+ methodSenders
+ methodImplementors
+ methodGlobalReferends
+"
+ methodStringSearch
+ methodAproposSearch
+"
+ nil
+ methodLocalSenders
+ methodLocalImplementors
+"
+ methodLocalStringSearch
+"
+ nil
+ methodBreakPoint
+ methodTrace
+ methodTraceSender
+ nil
+ methodNewMethod
+ methodChangeCategory
+ methodRemove
+ )
+ ].
+
+ ^ PopUpMenu
+ labels:(resources array:labels)
+ selectors:selectors
+ receiver:self
+ for:methodListView
+!
initializeMethodMenu
|labels|
+methodListView model:self.
+methodListView menu:#methodMenu.
+^ self.
+
labels := resources array:#(
'fileOut'
'printOut'
@@ -3871,10 +4981,38 @@
for:methodListView)
!
+methodImplementors
+ "launch an enterBox for selector to search for"
+
+ self askAndBrowseSelectorTitle:'selector to browse implementors of:'
+ action:[:aString |
+ self class browseImplementorsOf:aString
+ ]
+!
+
+methodSenders
+ "launch an enterBox for selector to search for"
+
+ self askAndBrowseSelectorTitle:'selector to browse senders of:'
+ action:[:aString |
+ self class browseAllCallsOn:aString
+ ]
+!
+
+methodRemove
+ "remove the current method"
+
+ self checkMethodSelected ifFalse:[^ self].
+ actualClass removeSelector:(actualClass selectorForMethod:currentMethod).
+ currentMethod := currentSelector := nil.
+ self updateMethodListWithScroll:false
+!
+
initializeMethodMenu2
|labels|
methodListView isNil ifTrue:[^ self].
+^self.
labels := resources array:#(
'fileOut'
'printOut'
@@ -3932,6 +5070,16 @@
for:methodListView)
!
+methodLocalSenders
+ "launch an enterBox for selector to search for in current class & subclasses"
+
+ self checkClassSelected ifFalse:[^ self].
+ self askAndBrowseSelectorTitle:'selector to browse local senderss of:'
+ action:[:aString |
+ self class browseCallsOn:aString under:currentClass
+ ]
+!
+
methodPrintOut
"print out the current method"
@@ -3940,34 +5088,10 @@
self checkMethodSelected ifFalse:[^ self].
printStream := Printer new.
- actualClass printOutSource:currentMethod source on:printStream.
+ actualClass printOutSource:(currentMethod source) on:printStream.
printStream close
!
-methodFileOut
- "file out the current method"
-
- self checkMethodSelected ifFalse:[^ self].
-
- self label:'System Browser saving'.
- Class fileOutErrorSignal handle:[:ex |
- self warn:'cannot create: %1' with:ex parameter.
- ex return
- ] do:[
- actualClass fileOutMethod:currentMethod.
- ].
- self normalLabel.
-!
-
-methodImplementors
- "launch an enterBox for selector to search for"
-
- self askAndBrowseSelectorTitle:'selector to browse implementors of:'
- action:[:aString |
- self class browseImplementorsOf:aString
- ]
-!
-
methodLocalImplementors
"launch an enterBox for selector to search for"
@@ -3978,25 +5102,6 @@
]
!
-methodSenders
- "launch an enterBox for selector to search for"
-
- self askAndBrowseSelectorTitle:'selector to browse senders of:'
- action:[:aString |
- self class browseAllCallsOn:aString
- ]
-!
-
-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
- ]
-!
-
methodGlobalReferends
"launch an enterBox for global symbol to search for"
@@ -4006,6 +5111,125 @@
]
!
+methodSpawn
+ "create a new SystemBrowser browsing current method,
+ or if the current selection is of the form 'class>>selector', spawan
+ a browser on that method."
+
+ |s sel selSymbol clsName clsSymbol cls meta isMeta w sep|
+
+ classMethodListView notNil ifTrue:[
+ s := classMethodListView selectionValue.
+ clsName := self classFromClassMethodString:s.
+ sel := self selectorFromClassMethodString:s.
+ isMeta := false
+ ].
+
+ self extractClassAndSelectorFromSelectionInto:[:c :s :m |
+ clsName := c.
+ sel := s.
+ isMeta := m
+ ].
+
+ (sel notNil and:[clsName notNil]) ifTrue:[
+ (clsName knownAsSymbol and:[sel knownAsSymbol]) ifTrue:[
+ clsSymbol := clsName asSymbol.
+ (Smalltalk includesKey:clsSymbol) ifTrue:[
+ cls := Smalltalk at:clsSymbol.
+ isMeta ifTrue:[
+ cls := cls class
+ ].
+ cls isBehavior ifFalse:[
+ cls := cls class
+ ].
+ cls isBehavior ifTrue:[
+ selSymbol := sel asSymbol.
+ self withWaitCursorDo:[
+ (cls implements:selSymbol) ifFalse:[
+ cls := cls class.
+ ].
+ (cls implements:selSymbol) ifTrue:[
+ self class browseClass:cls selector:selSymbol.
+ ^ self
+ ].
+ w := ' does not implement #' , sel
+ ]
+ ] ifFalse:[
+ w := ' is not a class'
+ ]
+ ] ifFalse:[
+ w := ' is unknown'
+ ]
+ ] ifFalse:[
+ w := ' and/or ' , sel , ' are unknown'
+ ].
+ self warn:(clsName , w).
+ ^ self
+ ].
+
+ self checkMethodSelected ifFalse:[
+ self warn:'select a method first'.
+ ^ self
+ ].
+
+ self withWaitCursorDo:[
+ w := currentMethod who.
+ self class browseClass:(w at:1) selector:(w at:2)
+ ]
+!
+
+methodFileOut
+ "file out the current method"
+
+ self checkMethodSelected ifFalse:[^ self].
+
+ self busyLabel:'saving:' with:currentSelector.
+ Class fileOutErrorSignal handle:[:ex |
+ self warn:'cannot create: %1' with:ex parameter.
+ ex return
+ ] do:[
+ actualClass fileOutMethod:currentMethod.
+ ].
+ self normalLabel.
+!
+
+methodChangeCategory
+ "move the current method into another category -
+ nothing done here, but a query for the new category.
+ Remember the last category, to allow faster category change of a group of methods."
+
+ |box txt|
+
+ self checkMethodSelected ifFalse:[^ self].
+
+ actualClass isNil ifTrue:[
+ box := self enterBoxTitle:'' okText:'change'.
+ ] ifFalse:[
+ |someCategories|
+
+ someCategories := actualClass categories sort.
+ box := self listBoxTitle:'' okText:'change' list:someCategories.
+ ].
+ box title:('change category from ''' , currentMethod category , ''' to:').
+ lastMethodCategory isNil ifTrue:[
+ txt := currentMethod category.
+ ] ifFalse:[
+ txt := lastMethodCategory
+ ].
+ box initialText:txt.
+ box action:[:aString |
+ lastMethodCategory := aString.
+
+ currentMethod category:aString asSymbol.
+ currentClass changed.
+ currentMethod changed:#category.
+ currentClass addChangeRecordForMethodCategory:currentMethod category:aString.
+ self updateMethodCategoryListWithScroll:false.
+ self updateMethodListWithScroll:false
+ ].
+ box showAtPointer
+!
+
methodStringSearch
"launch an enterBox for (sub)-string to search for"
@@ -4034,84 +5258,6 @@
]
!
-methodSpawn
- "create a new SystemBrowser browsing current method,
- or if the current selection is of the form 'class>>selector', spwan
- a browser on that method."
-
- |s sel selSymbol clsName clsSymbol cls meta browseMeta w sep|
-
- sel := codeView selection.
- sel notNil ifTrue:[
- sel := sel asString withoutSeparators.
- ('*>>*' match:sel) ifTrue:[
- sep := $>
- ] ifFalse:[
- ('* *' match:sel) ifTrue:[
- sep := Character space
- ]
- ].
- sep notNil ifTrue:[
- "
- 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:[
- browseMeta := true.
- clsName := clsName copyTo:(clsName size - 5)
- ] ifFalse:[
- browseMeta := false
- ].
- (clsName knownAsSymbol and:[sel knownAsSymbol]) ifTrue:[
- clsSymbol := clsName asSymbol.
- (Smalltalk includesKey:clsSymbol) ifTrue:[
- cls := Smalltalk at:clsSymbol.
- browseMeta ifTrue:[
- cls := cls class
- ].
- cls isBehavior ifFalse:[
- cls := cls class
- ].
- cls isBehavior ifTrue:[
- selSymbol := sel asSymbol.
- self withWaitCursorDo:[
- (cls implements:selSymbol) ifTrue:[
- self class browseClass:cls selector:selSymbol.
- ^ self
- ] ifFalse:[
- meta := cls class.
- (meta implements:selSymbol) ifTrue:[
- self class browseClass:meta selector:selSymbol.
- ^ self
- ].
- w := ' does not implement #' , sel
- ]
- ]
- ] ifFalse:[
- w := ' is not a class'
- ]
- ] ifFalse:[
- w := ' is unknown'
- ]
- ] ifFalse:[
- w := ' and/or ' , sel , ' is unknown'
- ].
- self warn:(clsName , w).
- ^ self
- ].
- ].
-
- self checkMethodSelected ifFalse:[^ self].
- self withWaitCursorDo:[
- self class browseClass:actualClass
- selector:(actualClass selectorForMethod:currentMethod)
- ]
-!
-
methodNewMethod
"prepare for definition of a new method - put a template into
code view and define accept-action to compile it"
@@ -4123,80 +5269,48 @@
^ self warn:'select/create a method category first'.
].
- currentMethod := nil.
+ currentMethod := currentSelector := nil.
methodListView deselect.
codeView contents:(self template).
codeView modified:false.
- codeView acceptAction:[:theCode |
- codeView cursor:Cursor execute.
- Object abortSignal catch:[
- actualClass compiler compile:theCode asString
- forClass:actualClass
- inCategory:currentMethodCategory
- notifying:codeView.
- codeView modified:false.
- self updateMethodListWithScroll:false.
- ].
- codeView cursor:Cursor normal.
- ].
- codeView explainAction:[:theCode :theSelection |
- self showExplanation:(Explainer explain:theSelection
- in:theCode
- forClass:actualClass)
+ 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.
]
!
-methodRemove
- "remove the current method"
-
- self checkMethodSelected ifFalse:[^ self].
- actualClass removeSelector:(actualClass selectorForMethod:currentMethod).
- self updateMethodListWithScroll:false
-!
-
-methodChangeCategory
- "move the current method into another category -
- nothing done here, but a query for the new category.
- Remember the last category, to allow faster category change of a group of methods."
-
- |box txt|
-
- self checkMethodSelected ifFalse:[^ self].
-
- box := self enterBoxTitle:('change category from ' , currentMethod category , ' to:')
- okText:'change'.
- lastMethodCategory isNil ifTrue:[
- txt := currentMethod category.
- ] ifFalse:[
- txt := lastMethodCategory
- ].
- box initialText:txt.
- box action:[:aString |
- lastMethodCategory := aString.
-
- currentMethod category:aString asSymbol.
- currentClass changed.
- self updateMethodCategoryListWithScroll:false.
- self updateMethodListWithScroll:false
- ].
- box showAtPointer
-!
-
methodRemoveBreakOrTrace
"turn off tracing of the current method"
|sel|
- currentMethod notNil ifTrue:[
- currentMethod isWrapped ifTrue:[
- currentMethod := MessageTracer unwrapMethod:currentMethod.
- sel := methodListView selection.
- self updateMethodListWithScroll:false.
- methodListView selection:sel.
- self initializeMethodMenu
- ].
+ (currentMethod notNil and:[currentMethod isWrapped])
+ ifTrue:[
+ currentMethod := MessageTracer unwrapMethod:currentMethod.
+ sel := methodListView selection.
+ self updateMethodListWithScroll:false.
+ methodListView selection:sel.
+ currentClass changed:#methodDictionary with:currentSelector.
]
!
@@ -4216,39 +5330,294 @@
]
!
-methodTrace
- "turn on tracing of the current method"
-
- |sel|
-
- currentMethod notNil ifTrue:[
- currentMethod isWrapped ifFalse:[
- currentMethod := MessageTracer traceMethod:currentMethod.
- self initializeMethodMenu2.
- sel := methodListView selection.
- self updateMethodListWithScroll:false.
- methodListView selection:sel
- ].
- ]
-!
-
methodTraceSender
"turn on tracing of the current method"
|sel|
- currentMethod notNil ifTrue:[
- currentMethod isWrapped ifFalse:[
- currentMethod := MessageTracer traceMethodSender:currentMethod.
- self initializeMethodMenu2.
- sel := methodListView selection.
- self updateMethodListWithScroll:false.
- methodListView selection:sel
+ (currentMethod notNil and:[currentMethod isWrapped not])
+ ifTrue:[
+ currentMethod := MessageTracer traceMethodSender:currentMethod.
+ sel := methodListView selection.
+ self updateMethodListWithScroll:false.
+ methodListView selection:sel.
+ currentClass changed:#methodDictionary with:currentSelector.
+ ]
+!
+
+methodMenuForWrappedMethod
+ |labels|
+
+ labels := resources array:#(
+ 'fileOut'
+ 'printOut'
+ '-'
+ 'SPAWN_METHOD'
+ '-'
+ 'senders ...'
+ 'implementors ...'
+ 'globals ...'
+"
+ 'strings ...'
+ 'apropos ...'
+"
+ '-'
+ 'local senders ...'
+ 'local implementors ...'
+"
+ 'local strings ...'
+"
+ '-'
+ 'remove break/trace'
+ '-'
+ 'new method'
+ 'change category ...'
+ 'remove').
+
+ ^ PopUpMenu
+ labels:labels
+ selectors:#(methodFileOut
+ methodPrintOut
+ nil
+ methodSpawn
+ nil
+ methodSenders
+ methodImplementors
+ methodGlobalReferends
+"
+ methodStringSearch
+ methodAproposSearch
+"
+ nil
+ methodLocalSenders
+ methodLocalImplementors
+"
+ methodLocalStringSearch
+"
+ nil
+ methodRemoveBreakOrTrace
+ nil
+ methodNewMethod
+ methodChangeCategory
+ methodRemove)
+ receiver:self
+ for:methodListView
+! !
+
+!SystemBrowser methodsFor:'variable list menu'!
+
+initializeVariableListMenu
+ |varMenu|
+
+ varMenu := (PopUpMenu labels:(resources array:#(
+ 'instvar refs ...'
+ 'classvar refs ...'
+ 'all instvar refs ...'
+ 'all classvar refs ...'
+ '-'
+ 'instvar mods ...'
+ 'classvar mods ...'
+ 'all instvar mods ...'
+ 'all classvar mods ...'
+ ))
+ selectors:#(
+ instVarRefs
+ classVarRefs
+ allInstVarRefs
+ allClassVarRefs
+ nil
+ instVarMods
+ classVarMods
+ allInstVarMods
+ allClassVarMods
+ )
+ receiver:self
+ for:self).
+
+ variableListView isNil ifTrue:[
+ classListView notNil ifTrue:[
+ |menu|
+
+ menu := classListView middleButtonMenu.
+ menu addLabel:(resources string:'variable search')
+ selector:#variables
+ before:#classRefs.
+ menu subMenuAt:#variables put:varMenu.
+ ]
+ ] ifFalse:[
+ variableListView middleButtonMenu:varMenu
+ ]
+
+!
+
+variableSelection:lineNr
+ "variable selection changed"
+
+ |name idx|
+
+ name := variableListView selectionValue.
+ name isNil ifTrue:[
+ self unhilightMethodCategories.
+ self unhilightMethods.
+ self autoSearch:nil.
+ ^ self
+ ].
+
+ "
+ first, check if the selected variable is really the one
+ we get - reselect if its hidden (for example, a class variable
+ with the same name could be defined in a subclass)
+ "
+ idx := variableListView list findLast:[:entry | entry = name].
+ idx ~~ lineNr ifTrue:[
+ "select it - user will see whats going on"
+ variableListView selection:idx
+ ].
+
+ "search for methods in the current category, which access the selected
+ variable, and highlight them"
+
+ self hilightMethodsInMethodCategoryList:true inMethodList:true.
+ self autoSearch:name.
+
+
+!
+
+enterBoxForVariableSearch:title
+ |box sel|
+
+ box := self enterBoxForCodeSelectionTitle:title okText:'browse'.
+ variableListView notNil ifTrue:[
+ codeView hasSelection ifFalse:[
+ (sel := variableListView selectionValue) notNil ifTrue:[
+ (sel startsWith:'---') ifFalse:[
+ box initialText:sel
+ ]
+ ]
+ ]
+ ].
+ ^ box
+!
+
+allClassOrInstVarRefsTitle:title access:access mods:modifications
+ "show an enterbox for instVar to search for"
+
+ self doClassMenu:[
+ |box|
+
+ box := self enterBoxForVariableSearch:title.
+ box action:[:aVariableName |
+ self withCursor:(Cursor questionMark) do:[
+ |homeClass|
+
+ homeClass := self findClassOfVariable:aVariableName
+ accessWith:access.
+ (self class) browseInstRefsTo:aVariableName
+ under:homeClass
+ modificationsOnly:modifications
+ ]
].
+ box showAtPointer
]
+!
+
+instVarRefsOrModsTitle:title mods:mods
+ "show an enterbox for instvar to search for"
+
+ self doClassMenu:[
+ |box|
+
+ box := self enterBoxForVariableSearch:title.
+ box action:[:aString |
+ self withCursor:(Cursor questionMark) do:[
+ self class browseInstRefsTo:aString
+ in:(Array with:currentClass)
+ modificationsOnly:mods
+ ]
+ ].
+ box showAtPointer
+ ]
+!
+
+allClassVarMods
+ "show an enterbox for classVar to search for"
+
+ self allClassOrInstVarRefsTitle:'class variable to browse modifications of:'
+ access:#classVarNames
+ mods:true
+!
+
+instVarMods
+ "show an enterbox for instVar to search for"
+
+ self instVarRefsOrModsTitle:'instance variable to browse modifications of:'
+ mods:true
+!
+
+instVarRefs
+ "show an enterbox for instVar to search for"
+
+ self instVarRefsOrModsTitle:'instance variable to browse references to:'
+ mods:false
+!
+
+classVarRefsOrModsTitle:title mods:mods
+ "show an enterbox for classVar to search for"
+
+ self doClassMenu:[
+ |box|
+
+ box := self enterBoxForVariableSearch:title.
+ box action:[:aString |
+ self withCursor:(Cursor questionMark) do:[
+ self class browseClassRefsTo:aString
+ in:(Array with:currentClass)
+ modificationsOnly:mods
+ ]
+ ].
+ box showAtPointer
+ ]
+!
+
+allInstVarRefs
+ "show an enterbox for instVar to search for"
+
+ self allClassOrInstVarRefsTitle:'instance variable to browse references to:'
+ access:#instVarNames
+ mods:false
+!
+
+classVarRefs
+ "show an enterbox for classVar to search for"
+
+ self classVarRefsOrModsTitle:'class variable to browse references to:'
+ mods:false
+!
+
+classVarMods
+ "show an enterbox for classVar to search for"
+
+ self classVarRefsOrModsTitle:'class variable to browse modifications of:'
+ mods:true
+!
+
+allInstVarMods
+ "show an enterbox for instVar to search for"
+
+ self allClassOrInstVarRefsTitle:'instance variable to browse modifications of:'
+ access:#instVarNames
+ mods:true
+!
+
+allClassVarRefs
+ "show an enterbox for classVar to search for"
+
+ self allClassOrInstVarRefsTitle:'class variable to browse references to:'
+ access:#classVarNames
+ mods:false
! !
-!SystemBrowser methodsFor:'class-method menu'!
+!SystemBrowser methodsFor:'class-method list menu'!
initializeClassMethodMenu
|labels|
@@ -4329,7 +5698,7 @@
self withWaitCursorDo:[
list := classMethodListView list.
list do:[:line |
- self label:('System Browser writing: ' , line).
+ self busyLabel:'writing: ' with:line.
classString := self classFromClassMethodString:line.
selectorString := self selectorFromClassMethodString:line.
@@ -4354,7 +5723,7 @@
'\\continue anyway ?') withCRs) ifTrue:[
ex proceed
].
- self label:'System Browser'.
+ self normalLabel.
^ self
] do:[
cls fileOutMethod:mth on:outStream.
@@ -4367,90 +5736,4 @@
]
! !
-!SystemBrowser methodsFor:'dependencies'!
-
-update
- "handle changes from other browsers"
-
- |oldClassCategory oldClassName oldMethodCategory oldMethod oldSelector|
-
-self updateClassCategoryListWithScroll:false.
-"
-self updateClassListWithScroll:false.
-"
-^ self.
-
- oldClassCategory := currentClassCategory.
- currentClass notNil ifTrue:[
- oldClassName := currentClass name
- ].
- oldMethodCategory := currentMethodCategory.
- oldMethod := currentMethod.
- methodListView notNil ifTrue:[
- oldMethod notNil ifTrue:[
- oldSelector := methodListView selectionValue
- ]
- ].
-
- classCategoryListView notNil ifTrue:[
- classCategoryListView setContents:(self listOfAllClassCategories).
- oldClassCategory notNil ifTrue:[
- classCategoryListView selectElement:oldClassCategory
- ].
- classCategoryListView selection isNil ifTrue:[
- currentClassCategory := nil.
- self switchToClass:nil.
- oldClassName := nil
- ]
- ].
- classListView notNil ifTrue:[
- self updateClassListWithScroll:false.
- oldClassName notNil ifTrue:[
- classListView selectElement:oldClassName
- ].
- classListView selection isNil ifTrue:[
- self switchToClass:nil.
- currentMethodCategory := nil.
- oldMethodCategory := nil
- ]
- ].
- methodCategoryListView notNil ifTrue:[
- self updateMethodCategoryListWithScroll:false.
- oldMethodCategory notNil ifTrue:[
- methodCategoryListView selectElement:oldMethodCategory
- ].
- methodCategoryListView selection isNil ifTrue:[
- currentMethodCategory := nil.
- currentMethod := nil.
- oldSelector := nil
- ]
- ].
- methodListView notNil ifTrue:[
- self updateMethodListWithScroll:false.
- oldSelector notNil ifTrue:[
- methodListView selectElement:oldSelector
- ].
- methodListView selection isNil ifTrue:[
- currentMethod := nil
- ]
- ].
- self updateCodeView
-!
-
-update:something with:someArgument from:changedObject
- (changedObject == Smalltalk) ifTrue:[self update. ^ self].
- changedObject isBehavior ifTrue:[
- (currentClass notNil and:[changedObject name = currentClass name]) ifTrue:[
- currentClass := Smalltalk at:(currentClass name asSymbol).
- showInstance ifTrue:[
- actualClass := currentClass
- ] ifFalse:[
- actualClass := currentClass class
- ].
- self updateMethodCategoryListWithScroll:false.
- "dont update codeView ...."
- "self update"
- ^ self
- ]
- ]
-! !
+SystemBrowser initialize!