--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/DictInspV.st Sat Aug 13 20:40:49 1994 +0200
@@ -0,0 +1,185 @@
+"{ Package: 'Programming Tools' }"
+
+"
+ 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.
+"
+
+InspectorView subclass:#DictionaryInspectorView
+ instanceVariableNames:'keys'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Interface-Inspector'
+!
+
+DictionaryInspectorView comment:'
+COPYRIGHT (c) 1993 by Claus Gittinger
+ All Rights Reserved
+
+$Header: /cvs/stx/stx/libtool/Attic/DictInspV.st,v 1.6 1994-08-13 18:40:01 claus Exp $
+'!
+
+!DictionaryInspectorView 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/DictInspV.st,v 1.6 1994-08-13 18:40:01 claus Exp $
+"
+!
+
+documentation
+"
+ a modified Inspector for Dictionaries
+"
+! !
+
+!DictionaryInspectorView methodsFor:'user interaction'!
+
+doAccept:theText
+ "accept value for selected item"
+
+ |value|
+
+ value := Compiler evaluate:theText receiver:inspectedObject notifying:workspace.
+
+ selectedLine notNil ifTrue:[
+ selectedLine == 1 ifFalse:[
+ inspectedObject at:(keys at:selectedLine - 1) put:value.
+ inspectedObject changed
+ ].
+ ]
+!
+
+doInspect
+ "inspect selected item"
+
+ |k objectToInspect|
+
+ selectedLine notNil ifTrue:[
+ selectedLine == 1 ifTrue:[
+ objectToInspect := inspectedObject
+ ] ifFalse:[
+ k := (keys at:selectedLine - 1).
+ objectToInspect := inspectedObject at:k.
+ ].
+ objectToInspect inspect
+ ]
+!
+
+showSelection:lineNr
+ "user clicked on an instvar - show value in workspace"
+
+ |val string|
+
+"
+ workspace contents:nil.
+"
+ lineNr == 1 ifTrue:[
+ "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)
+ ].
+ string := val displayString.
+ workspace replace:string.
+ selectedLine := lineNr
+!
+
+doAddKey
+ "add a key"
+
+ |keyName key|
+
+ 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"
+ ]
+ ]
+!
+
+doRemoveKey
+ "remove selected item from keys"
+
+ |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"
+ ].
+ ]
+! !
+
+!DictionaryInspectorView methodsFor:'accessing'!
+
+listOfNames
+ "return a list of names for the selectionlist"
+
+ |aList|
+
+ aList := OrderedCollection new.
+ keys := inspectedObject keys asSortedCollection:[:a :b | a printString < b printString].
+ keys do:[:aKey |
+ aList add:(aKey printString)
+ ].
+ aList addFirst:'self'.
+ ^ aList
+!
+
+release
+ "release inspected object"
+
+ keys := nil.
+ super release
+! !
+
+!DictionaryInspectorView methodsFor:'initialization'!
+
+initializeListViewMiddleButtonMenu
+ |labels|
+
+ labels := resources array:#(
+ 'inspect'
+ '-'
+ 'add key'
+ 'remove key').
+ listView middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:#(doInspect nil doAddKey doRemoveKey)
+ receiver:self
+ for:listView).
+ workspace acceptAction:[:theText | self doAccept:theText asString]
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/DictionaryInspectorView.st Sat Aug 13 20:40:49 1994 +0200
@@ -0,0 +1,185 @@
+"{ Package: 'Programming Tools' }"
+
+"
+ 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.
+"
+
+InspectorView subclass:#DictionaryInspectorView
+ instanceVariableNames:'keys'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Interface-Inspector'
+!
+
+DictionaryInspectorView comment:'
+COPYRIGHT (c) 1993 by Claus Gittinger
+ All Rights Reserved
+
+$Header: /cvs/stx/stx/libtool/DictionaryInspectorView.st,v 1.6 1994-08-13 18:40:01 claus Exp $
+'!
+
+!DictionaryInspectorView 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/DictionaryInspectorView.st,v 1.6 1994-08-13 18:40:01 claus Exp $
+"
+!
+
+documentation
+"
+ a modified Inspector for Dictionaries
+"
+! !
+
+!DictionaryInspectorView methodsFor:'user interaction'!
+
+doAccept:theText
+ "accept value for selected item"
+
+ |value|
+
+ value := Compiler evaluate:theText receiver:inspectedObject notifying:workspace.
+
+ selectedLine notNil ifTrue:[
+ selectedLine == 1 ifFalse:[
+ inspectedObject at:(keys at:selectedLine - 1) put:value.
+ inspectedObject changed
+ ].
+ ]
+!
+
+doInspect
+ "inspect selected item"
+
+ |k objectToInspect|
+
+ selectedLine notNil ifTrue:[
+ selectedLine == 1 ifTrue:[
+ objectToInspect := inspectedObject
+ ] ifFalse:[
+ k := (keys at:selectedLine - 1).
+ objectToInspect := inspectedObject at:k.
+ ].
+ objectToInspect inspect
+ ]
+!
+
+showSelection:lineNr
+ "user clicked on an instvar - show value in workspace"
+
+ |val string|
+
+"
+ workspace contents:nil.
+"
+ lineNr == 1 ifTrue:[
+ "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)
+ ].
+ string := val displayString.
+ workspace replace:string.
+ selectedLine := lineNr
+!
+
+doAddKey
+ "add a key"
+
+ |keyName key|
+
+ 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"
+ ]
+ ]
+!
+
+doRemoveKey
+ "remove selected item from keys"
+
+ |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"
+ ].
+ ]
+! !
+
+!DictionaryInspectorView methodsFor:'accessing'!
+
+listOfNames
+ "return a list of names for the selectionlist"
+
+ |aList|
+
+ aList := OrderedCollection new.
+ keys := inspectedObject keys asSortedCollection:[:a :b | a printString < b printString].
+ keys do:[:aKey |
+ aList add:(aKey printString)
+ ].
+ aList addFirst:'self'.
+ ^ aList
+!
+
+release
+ "release inspected object"
+
+ keys := nil.
+ super release
+! !
+
+!DictionaryInspectorView methodsFor:'initialization'!
+
+initializeListViewMiddleButtonMenu
+ |labels|
+
+ labels := resources array:#(
+ 'inspect'
+ '-'
+ 'add key'
+ 'remove key').
+ listView middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:#(doInspect nil doAddKey doRemoveKey)
+ receiver:self
+ for:listView).
+ workspace acceptAction:[:theText | self doAccept:theText asString]
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/DiffTextView.st Sat Aug 13 20:40:49 1994 +0200
@@ -0,0 +1,301 @@
+"{ Package: 'Programming Tools' }"
+
+"
+ COPYRIGHT (c) 1994 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.
+"
+
+TwoColumnTextView subclass:#DiffTextView
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Text'
+!
+
+DiffTextView comment:'
+COPYRIGHT (c) 1994 by Claus Gittinger
+ All Rights Reserved
+
+$Header: /cvs/stx/stx/libtool/DiffTextView.st,v 1.2 1994-08-13 18:40:49 claus Exp $
+'!
+
+!DiffTextView class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1994 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/DiffTextView.st,v 1.2 1994-08-13 18:40:49 claus Exp $
+"
+!
+
+documentation
+"
+ a view showing diff output in a user-friendly form.
+ The view is created and opened with:
+
+ d := DiffTextView openOn:text1 and:text2.
+
+ and it will show the differences side-by-side
+"
+! !
+
+!DiffTextView methodsFor:'private'!
+
+updateListsFrom:text1 and:text2 diffs:diffList
+ |idx1 idx2 dIdx dEnd state s nr1 nr2 nr3 op entry c l1 l2 any delta|
+
+ l1 := OrderedCollection new.
+ l2 := OrderedCollection new.
+
+ idx1 := 1.
+ idx2 := 1.
+
+ dIdx := 1.
+ dEnd := diffList size + 1.
+ state := #initial.
+ [dIdx <= dEnd] whileTrue:[
+ dIdx == dEnd ifTrue:[
+ "dummy cleanup entry"
+ entry := nil.
+ state := #initial.
+ ] ifFalse:[
+ entry := diffList at:dIdx.
+ ].
+
+ state == #initial ifTrue:[
+ "entry is of the form <nr> <op> <offs> [<offs2>]"
+
+ "
+ fill up to size difference from previous change
+ "
+ delta := l1 size - l2 size.
+ delta > 0 ifTrue:[
+ delta timesRepeat:[l2 add:nil]
+ ] ifFalse:[
+ delta < 0 ifTrue:[
+ delta negated timesRepeat:[l1 add:nil]
+ ]
+ ].
+
+ "
+ except for the first chunk, add a separating line
+ "
+ l1 size ~~ 0 ifTrue:[
+ l1 add:'--------'.
+ l2 add:'--------'.
+ ].
+
+ "
+ in cleanup ?
+ "
+ entry isNil ifTrue:[
+ nr1 := text1 size + 1.
+ nr2 := text2 size + 1.
+ state := #finish.
+ ] ifFalse:[
+ s := ReadStream on:entry.
+ nr1 := Integer readFrom:s.
+ s peek == $, ifTrue:[
+ s next.
+ Integer readFrom:s
+ ].
+ op := s next.
+ nr2 := Integer readFrom:s.
+ s peek == $, ifTrue:[
+ s next.
+ nr3 := Integer readFrom:s
+ ] ifFalse:[
+ nr3 := nil
+ ].
+
+ op == $c ifTrue:[
+ state := #changed.
+ ] ifFalse:[
+ op == $a ifTrue:[
+ state := #added.
+ l1 add:(text1 at:idx1).
+ idx1 := idx1 + 1.
+ ] ifFalse:[
+ op == $d ifTrue:[
+ state := #deleted
+ ]
+ ]
+ ].
+
+ ].
+
+ "
+ copy over unchanged lines
+ "
+ any := false.
+ [idx1 < nr1] whileTrue:[
+ l1 add:(text1 at:idx1).
+ idx1 := idx1 + 1.
+ any := true.
+ ].
+ [idx2 < nr2] whileTrue:[
+ l2 add:(text2 at:idx2).
+ idx2 := idx2 + 1.
+ any := true.
+ ].
+
+ "
+ add a separating line, except at end
+ "
+ any ifTrue:[
+ state ~~ #finish ifTrue:[
+ l1 add:'--------'.
+ l2 add:'--------'.
+ ]
+ ].
+
+ ] ifFalse:[
+ state == #changed ifTrue:[
+ (entry at:1) == $< ifTrue:[
+ l1 add:(text1 at:idx1).
+ idx1 := idx1 + 1
+ ] ifFalse:[
+ (entry at:1) == $> ifTrue:[
+ l2 add:(text2 at:idx2).
+ idx2 := idx2 + 1
+ ] ifFalse:[
+ (entry at:1) == $- ifTrue:[
+ ] ifFalse:[
+ state := #initial.
+ dIdx := dIdx - 1
+ ]
+ ]
+ ]
+ ] ifFalse:[
+ state == #added ifTrue:[
+ (entry at:1) == $> ifTrue:[
+ l2 add:(text2 at:idx2).
+ idx2 := idx2 + 1.
+ l1 add:nil
+ ] ifFalse:[
+ state := #initial.
+ dIdx := dIdx - 1
+ ]
+ ] ifFalse:[
+ state == #deleted ifTrue:[
+ (entry at:1) == $< ifTrue:[
+ l1 add:(text1 at:idx1).
+ idx1 := idx1 + 1.
+ l2 add:nil
+ ] ifFalse:[
+ state := #initial.
+ dIdx := dIdx - 1
+ ]
+ ]
+ "must be in finish otherwise"
+ ]
+ ]
+ ].
+ dIdx := dIdx + 1
+ ].
+ [l1 size < l2 size] whileTrue:[
+ l1 add:''.
+ ].
+ [l2 size < l1 size] whileTrue:[
+ l2 add:''.
+ ].
+ textView1 list:l1.
+ textView2 list:l2
+! !
+
+!DiffTextView methodsFor:'accessing'!
+
+text1:t1 text2:t2
+ |tmpName1 tmpName2 stream line text1 text2 diffList|
+
+ text1 := t1 asText.
+ text2 := t2 asText.
+
+ "
+ save them texts in two temporary files ...
+ "
+ tmpName1 := '/tmp/sta_' , OperatingSystem getProcessId printString , '.tmp'.
+ tmpName2 := '/tmp/stb_' , OperatingSystem getProcessId printString , '.tmp'.
+
+ stream := tmpName1 asFilename writeStream.
+ text1 do:[:line |
+ stream nextPutAll:line; cr
+ ].
+ stream close.
+
+ stream := tmpName2 asFilename writeStream.
+ text2 do:[:line |
+ stream nextPutAll:line; cr
+ ].
+ stream close.
+
+ "
+ start diff on it ...
+ "
+ stream := PipeStream readingFrom:'diff ' , tmpName1 , ' ' , tmpName2.
+ stream isNil ifTrue:[
+ self error:'cannot execute diff'.
+ text1 := text2 := nil.
+ ^ nil
+ ].
+ diffList := OrderedCollection new.
+ [stream atEnd] whileFalse:[
+ line := stream nextLine.
+ line notNil ifTrue:[diffList add:line]
+ ].
+ stream close.
+
+ self updateListsFrom:text1 and:text2 diffs:diffList
+
+ "
+ |v|
+
+ v := HVScrollableView for:DiffTextView.
+ v scrolledView text1:('../libview/Color.st' asFilename readStream contents)
+ text2:('../libview/Color.st.old' asFilename readStream contents).
+ v open
+ "
+
+ "
+ |v t1 t2|
+
+ t1 := '
+one
+two
+three
+four
+'.
+ t2 := '
+one
+two-a
+two-b
+three
+three-b
+four
+'.
+
+ v := DiffTextView new.
+ v text1:t1 text2:t2.
+ v
+ "
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/DiffTxtV.st Sat Aug 13 20:40:49 1994 +0200
@@ -0,0 +1,301 @@
+"{ Package: 'Programming Tools' }"
+
+"
+ COPYRIGHT (c) 1994 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.
+"
+
+TwoColumnTextView subclass:#DiffTextView
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Text'
+!
+
+DiffTextView comment:'
+COPYRIGHT (c) 1994 by Claus Gittinger
+ All Rights Reserved
+
+$Header: /cvs/stx/stx/libtool/Attic/DiffTxtV.st,v 1.2 1994-08-13 18:40:49 claus Exp $
+'!
+
+!DiffTextView class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1994 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/DiffTxtV.st,v 1.2 1994-08-13 18:40:49 claus Exp $
+"
+!
+
+documentation
+"
+ a view showing diff output in a user-friendly form.
+ The view is created and opened with:
+
+ d := DiffTextView openOn:text1 and:text2.
+
+ and it will show the differences side-by-side
+"
+! !
+
+!DiffTextView methodsFor:'private'!
+
+updateListsFrom:text1 and:text2 diffs:diffList
+ |idx1 idx2 dIdx dEnd state s nr1 nr2 nr3 op entry c l1 l2 any delta|
+
+ l1 := OrderedCollection new.
+ l2 := OrderedCollection new.
+
+ idx1 := 1.
+ idx2 := 1.
+
+ dIdx := 1.
+ dEnd := diffList size + 1.
+ state := #initial.
+ [dIdx <= dEnd] whileTrue:[
+ dIdx == dEnd ifTrue:[
+ "dummy cleanup entry"
+ entry := nil.
+ state := #initial.
+ ] ifFalse:[
+ entry := diffList at:dIdx.
+ ].
+
+ state == #initial ifTrue:[
+ "entry is of the form <nr> <op> <offs> [<offs2>]"
+
+ "
+ fill up to size difference from previous change
+ "
+ delta := l1 size - l2 size.
+ delta > 0 ifTrue:[
+ delta timesRepeat:[l2 add:nil]
+ ] ifFalse:[
+ delta < 0 ifTrue:[
+ delta negated timesRepeat:[l1 add:nil]
+ ]
+ ].
+
+ "
+ except for the first chunk, add a separating line
+ "
+ l1 size ~~ 0 ifTrue:[
+ l1 add:'--------'.
+ l2 add:'--------'.
+ ].
+
+ "
+ in cleanup ?
+ "
+ entry isNil ifTrue:[
+ nr1 := text1 size + 1.
+ nr2 := text2 size + 1.
+ state := #finish.
+ ] ifFalse:[
+ s := ReadStream on:entry.
+ nr1 := Integer readFrom:s.
+ s peek == $, ifTrue:[
+ s next.
+ Integer readFrom:s
+ ].
+ op := s next.
+ nr2 := Integer readFrom:s.
+ s peek == $, ifTrue:[
+ s next.
+ nr3 := Integer readFrom:s
+ ] ifFalse:[
+ nr3 := nil
+ ].
+
+ op == $c ifTrue:[
+ state := #changed.
+ ] ifFalse:[
+ op == $a ifTrue:[
+ state := #added.
+ l1 add:(text1 at:idx1).
+ idx1 := idx1 + 1.
+ ] ifFalse:[
+ op == $d ifTrue:[
+ state := #deleted
+ ]
+ ]
+ ].
+
+ ].
+
+ "
+ copy over unchanged lines
+ "
+ any := false.
+ [idx1 < nr1] whileTrue:[
+ l1 add:(text1 at:idx1).
+ idx1 := idx1 + 1.
+ any := true.
+ ].
+ [idx2 < nr2] whileTrue:[
+ l2 add:(text2 at:idx2).
+ idx2 := idx2 + 1.
+ any := true.
+ ].
+
+ "
+ add a separating line, except at end
+ "
+ any ifTrue:[
+ state ~~ #finish ifTrue:[
+ l1 add:'--------'.
+ l2 add:'--------'.
+ ]
+ ].
+
+ ] ifFalse:[
+ state == #changed ifTrue:[
+ (entry at:1) == $< ifTrue:[
+ l1 add:(text1 at:idx1).
+ idx1 := idx1 + 1
+ ] ifFalse:[
+ (entry at:1) == $> ifTrue:[
+ l2 add:(text2 at:idx2).
+ idx2 := idx2 + 1
+ ] ifFalse:[
+ (entry at:1) == $- ifTrue:[
+ ] ifFalse:[
+ state := #initial.
+ dIdx := dIdx - 1
+ ]
+ ]
+ ]
+ ] ifFalse:[
+ state == #added ifTrue:[
+ (entry at:1) == $> ifTrue:[
+ l2 add:(text2 at:idx2).
+ idx2 := idx2 + 1.
+ l1 add:nil
+ ] ifFalse:[
+ state := #initial.
+ dIdx := dIdx - 1
+ ]
+ ] ifFalse:[
+ state == #deleted ifTrue:[
+ (entry at:1) == $< ifTrue:[
+ l1 add:(text1 at:idx1).
+ idx1 := idx1 + 1.
+ l2 add:nil
+ ] ifFalse:[
+ state := #initial.
+ dIdx := dIdx - 1
+ ]
+ ]
+ "must be in finish otherwise"
+ ]
+ ]
+ ].
+ dIdx := dIdx + 1
+ ].
+ [l1 size < l2 size] whileTrue:[
+ l1 add:''.
+ ].
+ [l2 size < l1 size] whileTrue:[
+ l2 add:''.
+ ].
+ textView1 list:l1.
+ textView2 list:l2
+! !
+
+!DiffTextView methodsFor:'accessing'!
+
+text1:t1 text2:t2
+ |tmpName1 tmpName2 stream line text1 text2 diffList|
+
+ text1 := t1 asText.
+ text2 := t2 asText.
+
+ "
+ save them texts in two temporary files ...
+ "
+ tmpName1 := '/tmp/sta_' , OperatingSystem getProcessId printString , '.tmp'.
+ tmpName2 := '/tmp/stb_' , OperatingSystem getProcessId printString , '.tmp'.
+
+ stream := tmpName1 asFilename writeStream.
+ text1 do:[:line |
+ stream nextPutAll:line; cr
+ ].
+ stream close.
+
+ stream := tmpName2 asFilename writeStream.
+ text2 do:[:line |
+ stream nextPutAll:line; cr
+ ].
+ stream close.
+
+ "
+ start diff on it ...
+ "
+ stream := PipeStream readingFrom:'diff ' , tmpName1 , ' ' , tmpName2.
+ stream isNil ifTrue:[
+ self error:'cannot execute diff'.
+ text1 := text2 := nil.
+ ^ nil
+ ].
+ diffList := OrderedCollection new.
+ [stream atEnd] whileFalse:[
+ line := stream nextLine.
+ line notNil ifTrue:[diffList add:line]
+ ].
+ stream close.
+
+ self updateListsFrom:text1 and:text2 diffs:diffList
+
+ "
+ |v|
+
+ v := HVScrollableView for:DiffTextView.
+ v scrolledView text1:('../libview/Color.st' asFilename readStream contents)
+ text2:('../libview/Color.st.old' asFilename readStream contents).
+ v open
+ "
+
+ "
+ |v t1 t2|
+
+ t1 := '
+one
+two
+three
+four
+'.
+ t2 := '
+one
+two-a
+two-b
+three
+three-b
+four
+'.
+
+ v := DiffTextView new.
+ v text1:t1 text2:t2.
+ v
+ "
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/FBrowser.st Sat Aug 13 20:40:49 1994 +0200
@@ -0,0 +1,1633 @@
+"
+ 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.
+"
+
+StandardSystemView subclass:#FileBrowser
+ instanceVariableNames:'labelView filterField fileListView subView
+ currentDirectory
+ queryBox yesNoBox
+ topFrame fileList
+ checkBlock checkDelta timeOfLastCheck
+ showLongList showVeryLongList showDotFiles
+ myName killButton'
+ classVariableNames:'DirectoryHistory HistorySize'
+ poolDictionaries:''
+ category:'Interface-Browsers'
+!
+
+FileBrowser comment:'
+COPYRIGHT (c) 1991 by Claus Gittinger
+ All Rights Reserved
+
+$Header: /cvs/stx/stx/libtool/Attic/FBrowser.st,v 1.15 1994-08-13 18:40:28 claus Exp $
+'!
+
+!FileBrowser class methodsFor:'documentation'!
+
+copyright
+"
+ 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.
+"
+!
+
+version
+"
+$Header: /cvs/stx/stx/libtool/Attic/FBrowser.st,v 1.15 1994-08-13 18:40:28 claus Exp $
+"
+!
+
+documentation
+"
+ this used to be a very simple demo application,
+ 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 ....
+ See additional information in 'doc/misc/fbrowser.doc'.
+"
+! !
+
+!FileBrowser class methodsFor:'instance creation'!
+
+openOn:aDirectoryPath
+ "start a new FileBrowser in a pathname"
+
+ ^ (self new currentDirectory:aDirectoryPath) open
+
+ "FileBrowser openOn:'aDirectoryPath'"
+! !
+
+!FileBrowser methodsFor:'initialization'!
+
+initialize
+ |frame spacing halfSpacing v|
+
+ super initialize.
+
+ DirectoryHistory isNil ifTrue:[
+ DirectoryHistory := OrderedCollection new.
+ HistorySize := 15.
+ ].
+
+ myName := (resources string:self class name).
+ self label:myName.
+ self icon:(Form fromFile:(resources at:'ICON_FILE' default:'FBrowser.xbm')
+ resolution:100).
+
+ spacing := ViewSpacing.
+ halfSpacing := spacing // 2.
+
+ checkBlock := [self checkIfDirectoryHasChanged].
+ checkDelta := 5.
+
+ currentDirectory := FileDirectory directoryNamed:'.'.
+ showLongList := resources at:'LONG_LIST' default:false.
+ showDotFiles := resources at:'SHOW_DOT_FILES' default:false.
+
+ filterField := EditField in:self.
+ filterField origin:[((width // 4 * 3) + halfSpacing) @ halfSpacing]
+ extent:[((width // 4) - borderWidth
+ - (filterField margin)
+ - halfSpacing
+ - filterField borderWidth)
+ @
+ (filterField heightIncludingBorder "i.e. take its default height"
+ "font height + font descent + (filterField margin * 2)"
+ )
+ ].
+ self initializeFilterPattern.
+ filterField leaveAction:[:key | fileListView scrollToTop. self updateCurrentDirectory].
+
+ labelView := Label in:self.
+ labelView origin:(halfSpacing @ halfSpacing)
+ extent:[((width // 4 * 3) - spacing - borderWidth)
+ @
+ (filterField heightIncludingBorder)
+ "(font height + font descent)"
+ ].
+ labelView adjust:#right.
+ labelView borderWidth:0.
+ self initializeLabelMiddleButtonMenu.
+
+ killButton := Button label:(resources string:'kill') in:self.
+ killButton origin:(halfSpacing @ halfSpacing)
+ extent:[(killButton width)
+ @
+ (filterField heightIncludingBorder)
+ ].
+ killButton hidden:true.
+
+ frame := VariableVerticalPanel
+ origin:[frame borderWidth negated
+ @
+ (labelView height + labelView origin y + spacing)
+ ]
+ extent:[width
+ @
+ (height - spacing - labelView height - borderWidth)
+ ]
+ in:self.
+
+ topFrame := ScrollableView for:SelectionInListView in:frame.
+ topFrame origin:(0.0 @ 0.0) corner:(1.0 @ 0.3).
+
+ fileListView := topFrame scrolledView.
+ fileListView action:[:lineNr | self fileSelect:lineNr].
+ fileListView doubleClickAction:[:lineNr | self fileSelect:lineNr.
+ self fileGet].
+ fileListView multipleSelectOk:true.
+
+ v := self initializeSubViewIn:frame.
+ v origin:(0.0 @ 0.3) corner:(1.0 @ 1.0).
+ subView := v scrolledView.
+ (subView respondsTo:#directoryForFileDialog:) ifTrue:[
+ subView directoryForFileDialog:currentDirectory
+ ].
+
+ ObjectMemory addDependent:self.
+!
+
+initializeFilterPattern
+ "set an initial matchpattern - can be redefined in subclasses"
+
+ filterField contents:'*'
+!
+
+initializeSubViewIn:frame
+ "set up the contents view - can be redefined in subclasses for
+ different view types (SoundFileBrowser/ImageBrowsers etc.)"
+
+ ^ HVScrollableView for:CodeView miniScrollerH:true miniScrollerV:false in:frame.
+!
+
+currentDirectory:aDirectoryPath
+ "set the directory to be browsed"
+
+ currentDirectory := FileDirectory directoryNamed:aDirectoryPath.
+ (subView respondsTo:#directoryForFileDialog:) ifTrue:[
+ subView directoryForFileDialog:currentDirectory
+ ]
+!
+
+realize
+ self initializeFileListMiddleButtonMenu.
+ super realize.
+"/ self updateCurrentDirectory
+!
+
+mapped
+ super mapped.
+ self updateCurrentDirectory
+!
+
+initializeLabelMiddleButtonMenu
+ |labels selectors args|
+
+ labelView notNil ifTrue:[
+ labels := resources array:#(
+ 'copy path'
+ '-'
+ 'up'
+ 'change to home-directory'
+ 'change directory ...'
+ ).
+
+ selectors := #(
+ copyPath
+ nil
+ changeToParentDirectory
+ changeToHomeDirectory
+ changeCurrentDirectory
+ ).
+
+ args := Array new:5.
+
+ DirectoryHistory size > 0 ifTrue:[
+ labels := labels copyWith:'-'.
+ selectors := selectors copyWith:nil.
+ args := args copyWith:nil.
+
+ DirectoryHistory do:[:dirName |
+ labels := labels copyWith:dirName.
+ selectors := selectors copyWith:#changeDirectoryTo:.
+ args := args copyWith:dirName
+ ]
+ ].
+
+ labelView
+ middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:selectors
+ args:args
+ receiver:self
+ for:labelView).
+
+
+ ]
+!
+
+initializeFileListMiddleButtonMenu
+ |labels|
+
+ fileListView notNil ifTrue:[
+ labels := resources array:#(
+ 'spawn'
+ 'get contents'
+ 'show info'
+ 'show full info'
+ 'fileIn'
+ '-'
+ 'update'
+ '-'
+ 'execute unix command ...'
+ '-'
+ 'remove'
+ 'rename ...'
+ '-'
+ 'display long list'
+ 'show all files'
+ '-'
+ 'create directory ...'
+ 'create file ...').
+
+ fileListView
+ middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:#(fileSpawn
+ fileGet
+ fileGetInfo
+ fileGetLongInfo
+ fileFileIn
+ nil
+ updateCurrentDirectory
+ nil
+ fileExecute
+ nil
+ fileRemove
+ fileRename
+ nil
+ changeDisplayMode
+ changeDotFileVisibility
+ nil
+ newDirectory
+ newFile)
+ receiver:self
+ for:fileListView)
+ ]
+! !
+
+!FileBrowser methodsFor:'private'!
+
+showAlert:aString with:anErrorString
+ "show an alertbox, displaying the last Unix-error"
+
+ anErrorString isNil ifTrue:[
+ self warn:aString withCRs
+ ] ifFalse:[
+ self warn:(aString , '\\(' , anErrorString , ')' ) withCRs
+ ]
+!
+
+ask:question yesButton:yesButtonText action:aBlock
+ "common method to ask a yes/no question"
+
+ self ask:question yesButton:yesButtonText noButton:'abort' action:aBlock
+!
+
+ask:question yesButton:yesButtonText noButton:noButtonText action:aBlock
+ "common method to ask a yes/no question"
+
+ "cache the box"
+ yesNoBox isNil ifTrue:[
+ yesNoBox := YesNoBox new
+ ].
+ yesNoBox title:question withCRs.
+ yesNoBox okText:(resources at:yesButtonText).
+ yesNoBox noText:(resources at:noButtonText).
+ yesNoBox okAction:aBlock.
+ yesNoBox showAtPointer
+!
+
+askIfModified:question yesButton:yesButtonText action:aBlock
+ "tell user, that code has been modified - let her confirm"
+
+ (subView modified not or:[subView contentsWasSaved]) ifTrue:[
+ aBlock value.
+ ^ self
+ ].
+ self ask:question yesButton:yesButtonText action:aBlock
+!
+
+withoutHiddenFiles:aCollection
+ "remove hidden files (i.e. those that start with '.') from
+ the list in aCollection"
+
+ |newCollection|
+
+ newCollection := aCollection species new.
+ aCollection do:[:fname |
+ ((fname startsWith:'.') and:[(fname = '..') not]) ifTrue:[
+ showDotFiles ifTrue:[
+ newCollection add:fname
+ ]
+ ] ifFalse:[
+ newCollection add:fname
+ ]
+ ].
+ ^ newCollection
+!
+
+getInfoFile
+ "get filename of a description-file (.dir.info);
+ uncomment stuff below if you want this to also
+ automatically show contents of README files."
+
+ #( '.dir.info'
+"you can add these if you like ..."
+"
+ 'README'
+ 'ReadMe'
+ 'Readme'
+ 'readme'
+"
+ ) do:[:f |
+ (currentDirectory isReadable:f) ifTrue:[^ f].
+ ].
+ ^ nil
+!
+
+showInfo:info
+ "show directory info when dir has changed"
+
+ info notNil ifTrue:[
+ self show:(self readFile:info)
+ ] ifFalse:[
+ self show:nil.
+ ]
+!
+
+getSelectedFileName
+ "returns the currently selected file; shows an error if
+ multiple files are selected"
+
+ |sel|
+
+ sel := fileListView selection.
+ (sel isKindOf:Collection) ifTrue:[
+ self onlyOneSelection
+ ] ifFalse:[
+ sel notNil ifTrue:[
+ ^ fileList at:sel
+ ]
+ ].
+ ^ nil
+!
+
+getFileInfoString:longInfo
+ "get stat info on selected file - return a string which can be
+ shown in a box"
+
+ |fileName fullPath text info stream fileOutput type modeBits modeString s|
+
+ fileName := self getSelectedFileName.
+ fileName isNil ifTrue:[^ nil].
+
+ info := currentDirectory infoOf:fileName.
+ info isNil ifTrue:[
+ self showAlert:(resources string:'cannot get info of ''%1'' !!' with:fileName)
+ with:(OperatingSystem lastErrorString).
+ ^ nil
+ ].
+
+ text := Text new.
+ type := info at:#type.
+ (longInfo and:[type == #regular]) ifTrue:[
+ fullPath := currentDirectory pathName , '/' , fileName.
+ stream := PipeStream readingFrom:('file ' , fullPath).
+ stream notNil ifTrue:[
+ fileOutput := stream contents asString.
+ stream close.
+ fileOutput := fileOutput copyFrom:(fileOutput indexOf:$:) + 1.
+ fileOutput := fileOutput withoutSeparators
+ ]
+ ].
+
+ s := (resources at:'type: ').
+ fileOutput isNil ifTrue:[
+ s := s , type asString
+ ] ifFalse:[
+ s := s , 'regular (' , fileOutput , ')'
+ ].
+ text add:s.
+ text add:(resources at:'size: ') , (info at:#size) printString.
+
+ modeBits := (info at:#mode).
+ modeString := self getModeString:modeBits.
+ longInfo ifTrue:[
+ text add:((resources at:'access: ')
+ , modeString
+ , ' (' , (modeBits printStringRadix:8), ')' )
+ ] ifFalse:[
+ text add:(resources at:'access: ') , modeString
+ ].
+ text add:(resources at:'owner: ')
+ , (OperatingSystem getUserNameFromID:(info at:#uid)).
+ longInfo ifTrue:[
+ text add:(resources at:'group: ')
+ , (OperatingSystem getGroupNameFromID:(info at:#gid)).
+ text add:(resources at:'last access: ')
+ , (info at:#accessTime) asTime printString
+ , ' '
+ , (info at:#accessTime) asDate printString.
+ text add:(resources at:'last modification: ')
+ , (info at:#modificationTime) asTime printString
+ , ' '
+ , (info at:#modificationTime) asDate printString.
+
+ ].
+ ^ text asString
+!
+
+getModeString:modeBits
+ "convert file-mode bits into a more user-friendly string.
+ This is wrong here - should be moved into OperatingSystem."
+
+ |bits modeString|
+
+ bits := modeBits bitAnd:8r777.
+ modeString := ''.
+
+ #( nil 8r400 8r200 8r100 nil 8r040 8r020 8r010 nil 8r004 8r002 8r001 )
+ with: #( 'owner:' $r $w $x ' group:' $r $w $x ' others:' $r $w $x ) do:[:bitMask :access |
+ bitMask isNil ifTrue:[
+ modeString := modeString , (resources string:access)
+ ] ifFalse:[
+ (bits bitAnd:bitMask) == 0 ifTrue:[
+ modeString := modeString copyWith:$-
+ ] ifFalse:[
+ modeString := modeString copyWith:access
+ ]
+ ]
+ ].
+ ^ modeString
+!
+
+checkIfDirectoryHasChanged
+ "every checkDelta secs, check if directoy has changed and update view if so"
+
+ |oldSelection nOld here|
+
+ shown ifTrue:[
+ currentDirectory notNil ifTrue:[
+ here := currentDirectory pathName.
+ (OperatingSystem isReadable:here) ifTrue:[
+ Processor removeTimedBlock:checkBlock.
+
+ (currentDirectory timeOfLastChange > timeOfLastCheck) ifTrue:[
+ nOld := fileListView numberOfSelections.
+ oldSelection := fileListView selectionValue.
+ self updateCurrentDirectory.
+ nOld ~~ 0 ifTrue:[
+ nOld > 1 ifTrue:[
+ oldSelection do:[:element |
+ fileListView addElementToSelection:element
+ ]
+ ] ifFalse:[
+ fileListView selectElement:oldSelection
+ ]
+ ]
+ ] ifFalse:[
+ Processor addTimedBlock:checkBlock afterSeconds:checkDelta
+ ]
+ ] ifFalse:[
+ "
+ if the directory has been deleted, or is not readable ...
+ "
+ (OperatingSystem isValidPath:here) ifFalse:[
+ self warn:(resources string:'FileBrowser:\\directory %1 is gone ?!!?' with:here) withCRs
+ ] ifTrue:[
+ self warn:(resources string:'FileBrowser:\\directory %1 is no longer readable ?!!?' with:here) withCRs
+ ].
+ fileListView contents:nil.
+ self label:(myName , ': directory is gone !!').
+ "/ Processor addTimedBlock:checkBlock afterSeconds:checkDelta
+ ]
+ ]
+ ]
+!
+
+sizePrintString:size
+ "helper for update-directory to return a string with a files size.
+ This one gives the size in byte, Kb or Mb depending on size.
+ If you dont like this, just uncomment the first statement below."
+
+ |unitString sizeString|
+
+"
+ ^ size printString.
+"
+ unitString := ''.
+ size < (500 * 1024) ifTrue:[
+ size < (1024) ifTrue:[
+ sizeString := size printString
+ ] ifFalse:[
+ sizeString := (size * 10 // 1024 / 10.0) printString.
+ unitString := 'Kb'
+ ]
+ ] ifFalse:[
+ sizeString := (size * 10 // 1024 // 1024 / 10.0) printString.
+ unitString := 'Mb'
+ ].
+ (sizeString includes:$.) ifFalse:[
+ sizeString := sizeString , ' '
+ ].
+ ^ (sizeString printStringLeftPaddedTo:5) , unitString.
+!
+
+updateCurrentDirectory
+ "update listView with directory contents"
+
+ |files text len line info modeString typ
+ prevUid prevGid nameString groupString matchPattern
+ myProcess myPriority|
+
+ self withCursor:(Cursor read) do:[
+ Processor removeTimedBlock:checkBlock.
+
+ labelView label:(currentDirectory pathName).
+ timeOfLastCheck := Time now.
+
+ files := currentDirectory asOrderedCollection.
+
+ matchPattern := filterField contents.
+ (matchPattern notNil and:[
+ matchPattern isEmpty not and:[
+ matchPattern ~= '*']]) ifTrue:[
+ files := files select:[:aName |
+ ((currentDirectory typeOf:aName) == #directory)
+ or:[matchPattern match:aName]
+ ].
+ ].
+ files sort.
+
+ files size == 0 ifTrue:[
+ self notify:('directory ', currentDirectory pathName, ' vanished').
+ ^ self
+ ].
+ files := self withoutHiddenFiles:files.
+
+ "
+ this is a time consuming operation (especially, if reading an
+ NFS-mounted directory); therefore lower my priority while getting
+ the files info ...
+ "
+ myProcess := Processor activeProcess.
+ myPriority := myProcess priority.
+ myProcess priority:(Processor userBackgroundPriority).
+ [
+ fileList := files.
+ showLongList ifTrue:[
+ text := OrderedCollection new.
+ files do:[:aFileName |
+ "
+ if multiple FileBrowsers are reading, let others
+ make some progress too
+ "
+ Processor yield.
+
+ len := aFileName size.
+ (len < 20) ifTrue:[
+ line := aFileName , (String new:(22 - len))
+ ] ifFalse:[
+ "can happen on BSD only"
+ line := (aFileName copyTo:20) , ' '
+ ].
+ info := currentDirectory infoOf:aFileName.
+ info isNil ifTrue:[
+ "not accessable - usually a symlink,
+ which is not there/not readable
+ "
+ text add:line , '? bad symbolic link'
+ ] ifFalse:[
+ typ := (info at:#type) at:1.
+ (typ == $r) ifFalse:[
+ line := line , typ asString , ' '
+ ] ifTrue:[
+ line := line , ' '
+ ].
+
+ modeString := self getModeString:(info at:#mode).
+ line := line , modeString , ' '.
+
+ ((info at:#uid) ~~ prevUid) ifTrue:[
+ prevUid := (info at:#uid).
+ nameString := OperatingSystem getUserNameFromID:prevUid.
+ nameString := nameString , (String new:(10 - nameString size))
+ ].
+ line := line , nameString.
+ ((info at:#gid) ~~ prevGid) ifTrue:[
+ prevGid := (info at:#gid).
+ groupString := OperatingSystem getGroupNameFromID:prevGid.
+ groupString := groupString , (String new:(10 - groupString size))
+ ].
+ line := line , groupString.
+
+ (typ == $r) ifTrue:[
+ line := line , (self sizePrintString:(info at:#size))
+ ].
+ text add:line
+ ].
+ ].
+ ] ifFalse:[
+ text := files collect:[:aName |
+ "
+ if multiple FileBrowsers are reading, let others
+ make some progress too
+ "
+ Processor yield.
+ (((currentDirectory typeOf:aName) == #directory) and:[
+ (aName ~= '..') and:[aName ~= '.']]) ifTrue:[
+ aName , ' ...'
+ ] ifFalse:[
+ aName
+ ]
+ ].
+ ].
+ fileListView setContents:text
+ ] valueNowOrOnUnwindDo:[
+ myProcess priority:myPriority.
+ ].
+
+ "
+ install a new check after some time
+ "
+ Processor addTimedBlock:checkBlock afterSeconds:checkDelta
+ ]
+!
+
+doChangeCurrentDirectoryTo:fileName updateHistory:updateHistory
+ "verify argument is name of a readable & executable directory
+ and if so, go there"
+
+ |msg|
+
+ self label:myName.
+ fileName notNil ifTrue:[
+ (currentDirectory isDirectory:fileName) ifTrue:[
+ (currentDirectory isReadable:fileName) ifTrue:[
+ (currentDirectory isExecutable:fileName) ifTrue:[
+ updateHistory ifTrue:[
+ (DirectoryHistory includes:(currentDirectory pathName)) ifFalse:[
+ DirectoryHistory addFirst:currentDirectory pathName.
+ DirectoryHistory size > HistorySize ifTrue:[
+ DirectoryHistory removeLast
+ ].
+ self initializeLabelMiddleButtonMenu
+ ]
+ ].
+
+ ^ self setCurrentDirectory:fileName
+ ].
+ msg := (resources string:'cannot change directory to ''%1'' !!' with:fileName)
+ ] ifFalse:[
+ msg := (resources string:'cannot read directory ''%1'' !!' with:fileName)
+ ]
+ ] ifFalse:[
+ msg := (resources string:'''%1'' is not a directory !!' with:fileName)
+ ].
+ self showAlert:msg with:nil
+ ]
+!
+
+doChangeToParentDirectory
+ "go to home directory"
+
+ self doChangeCurrentDirectoryTo:'..' updateHistory:true
+!
+
+doChangeToHomeDirectory
+ "go to home directory"
+
+ self doChangeCurrentDirectoryTo:(OperatingSystem getHomeDirectory) updateHistory:true
+!
+
+setCurrentDirectory:aPathName
+ "setup for another directory"
+
+ |newDirectory info|
+
+ aPathName isEmpty ifTrue:[^ self].
+ (currentDirectory isDirectory:aPathName) ifTrue:[
+ newDirectory := FileDirectory directoryNamed:aPathName in:currentDirectory.
+ newDirectory notNil ifTrue:[
+ currentDirectory := newDirectory.
+ fileListView contents:nil.
+ self updateCurrentDirectory.
+ info := self getInfoFile.
+ self showInfo:info.
+ "
+ tell my subview (whatever that is) to start its file-dialog
+ (i.e. save-as etc.) in that directory
+ "
+ (subView respondsTo:#directoryForFileDialog:) ifTrue:[
+ subView directoryForFileDialog:currentDirectory
+ ]
+ ]
+ ]
+!
+
+readFile:fileName
+ "read in the file, answer its contents as Text"
+
+ ^ self readFile:fileName lineDelimiter:Character cr
+!
+
+readStream:aStream
+ "read in from aStream, answer its contents as Text"
+
+ ^ self readStream:aStream lineDelimiter:Character cr
+!
+
+readFile:fileName lineDelimiter:aCharacter
+ "read in the file, answer its contents as Text. The files lines are delimited by aCharacter."
+
+ |stream text msg line sz|
+
+ stream := FileStream readonlyFileNamed:fileName in:currentDirectory.
+ stream isNil ifTrue:[
+ msg := (resources string:'cannot read file ''%1'' !!' with:fileName).
+ self showAlert:msg with:(FileStream lastErrorString).
+ ^ nil
+ ].
+
+ "for very big files, give ObjectMemory a hint, to preallocate more"
+ (sz := stream size) > 1000000 ifTrue:[
+ ObjectMemory moreOldSpace:sz
+ ].
+
+ text := self readStream:stream lineDelimiter:aCharacter.
+ stream close.
+ ^ text
+!
+
+readStream:aStream lineDelimiter:aCharacter
+ "read from aStream, answer its contents as Text. The files lines are delimited by aCharacter."
+
+ |text msg line|
+
+ aCharacter == Character cr ifTrue:[
+ text := aStream contents
+ ] ifFalse:[
+ text := Text new.
+ [aStream atEnd] whileFalse:[
+ line := aStream upTo:aCharacter.
+ text add:line
+ ].
+ ].
+ ^ text
+!
+
+writeFile:fileName text:someText
+ |stream msg startNr nLines string|
+
+ self withCursor:(Cursor write) do:[
+ stream := FileStream newFileNamed:fileName in:currentDirectory.
+ stream isNil ifTrue:[
+ msg := (resources string:'cannot write file ''%1'' !!' with:fileName).
+ self showAlert:msg with:(FileStream lastErrorString)
+ ] ifFalse:[
+ someText isString ifTrue:[
+ stream nextPutAll:someText.
+ ] ifFalse:[
+ "on some systems, writing linewise is very slow (via NFS)
+ therefore we convert to a string and write it in chunks
+ to avoid creating huge strings, we do it in blocks of 1000 lines
+ "
+ startNr := 1.
+ nLines := someText size.
+ [startNr <= nLines] whileTrue:[
+ string := someText asStringFrom:startNr to:((startNr + 1000) min:nLines).
+ stream nextPutAll:string.
+ startNr := startNr + 1000 + 1.
+ ].
+"/ someText do:[:line |
+"/ line notNil ifTrue:[
+"/ stream nextPutAll:line.
+"/ ].
+"/ stream cr.
+"/ ]
+ ].
+ stream close.
+ subView modified:false
+ ]
+ ]
+!
+
+doCreateDirectory:newName
+ (currentDirectory includes:newName) ifTrue:[
+ self warn:(resources string:'%1 already exists.' with:newName) withCRs.
+ ^ self
+ ].
+
+ (currentDirectory createDirectory:newName) ifTrue:[
+ self updateCurrentDirectory
+ ] ifFalse:[
+ self showAlert:(resources string:'cannot create directory ''%1'' !!' with:newName)
+ with:(OperatingSystem lastErrorString)
+ ]
+!
+
+doCreateFile:newName
+ |aStream box|
+
+ (currentDirectory includes:newName) ifTrue:[
+ box := YesNoBox new.
+ box title:(resources string:'%1 already exists\\truncate ?' with:newName) withCRs.
+ box okText:(resources string:'truncate').
+ box noText:(resources string:'cancel').
+ box noAction:[^ self].
+ box showAtPointer
+ ].
+
+ aStream := FileStream newFileNamed:newName in:currentDirectory.
+ aStream notNil ifTrue:[
+ aStream close.
+ self updateCurrentDirectory
+ ] ifFalse:[
+ self showAlert:(resources string:'cannot create file ''%1'' !!' with:newName)
+ with:(FileStream lastErrorString)
+ ]
+!
+
+showFile:fileName
+ "show contents of fileName in subView"
+
+ |buffer s n i ok convert|
+
+ ((currentDirectory typeOf:fileName) == #regular) ifFalse:[
+ "clicked on something else - ignore it ..."
+ self show:(resources string:'''%1'' is not a regular file' with:fileName).
+ ^ self
+ ].
+ "
+ check if file is a text file
+ "
+ s := FileStream readonlyFileNamed:fileName in:currentDirectory.
+ s isNil ifTrue:[
+ self showAlert:(resources string:'cannot read file ''%1'' !!' with:fileName)
+ with:(FileStream lastErrorString).
+ ^ nil
+ ].
+
+ buffer := String new:300.
+ n := s nextBytes:300 into:buffer.
+ s close.
+
+ ok := true.
+ 1 to:n do:[:i |
+ (buffer at:i) isPrintable ifFalse:[ok := false].
+ ].
+ ok ifFalse:[
+ (self confirm:(resources string:'''%1'' seems to be a binary file - continue anyway ?' with:fileName))
+ ifFalse:[^ self]
+ ].
+
+ convert := false.
+ ok ifTrue:[
+ "
+ check if line delimiter is a cr
+ "
+ i := buffer indexOf:Character cr.
+ i == 0 ifTrue:[
+ "
+ no newline found - try cr
+ "
+ i := buffer indexOf:(Character value:13).
+ i ~~ 0 ifTrue:[
+ convert := self confirm:(resources string:'''%1'' seems to have CR as line delimiter - convert to NL ?' with:fileName).
+ ]
+ ]
+ ].
+
+ "release old text first - we might need the memory in case of huge files
+ (helps if you have a 4Mb file in the view, and click on another biggy)"
+ subView contents:nil.
+
+ convert ifTrue:[
+ self show:(self readFile:fileName lineDelimiter:(Character value:13))
+ ] ifFalse:[
+ self show:(self readFile:fileName).
+ ].
+ subView acceptAction:[:theCode |
+ self writeFile:fileName text:theCode
+ ]
+!
+
+show:something
+ "show something in subview and undef acceptAction"
+
+ subView contents:something.
+ subView acceptAction:nil.
+ subView modified:false
+!
+
+doFileGet
+ "get selected file - show contents in subView"
+
+ |fileName|
+
+ self withCursor:(Cursor read) do:[
+ fileName := self getSelectedFileName.
+ fileName notNil ifTrue:[
+ (currentDirectory isDirectory:fileName) ifTrue:[
+ self doChangeCurrentDirectoryTo:fileName updateHistory:true.
+ self label:myName
+ ] ifFalse:[
+ self showFile:fileName.
+ (currentDirectory isWritable:fileName) ifFalse:[
+ self label:(myName , ': ' , fileName , ' (readonly)')
+ ] ifTrue:[
+ self label:(myName , ': ' , fileName)
+ ]
+ ]
+ ]
+ ]
+!
+
+doExecuteCommand:command replace:replace
+ "execute a unix command inserting the output of the command.
+ If replace is true, all text is replaced by the commands output;
+ otherwise, its inserted as selected text at the cursor position."
+
+ |stream line lnr myProcess myPriority startLine startCol stopSignal
+ access|
+
+ access := Semaphore forMutualExclusion.
+ stopSignal := Signal new.
+
+ "
+ must take killButton out of my group
+ "
+ windowGroup removeView:killButton.
+ "
+ bring it to front, and turn hidden-mode off
+ "
+ killButton raise.
+ killButton hidden:false.
+ "
+ it will make me raise stopSignal when pressed
+ "
+ killButton action:[
+ stream notNil ifTrue:[
+ access critical:[
+ myProcess interruptWith:[stopSignal raise].
+ ]
+ ]
+ ].
+ "
+ start it up under its own windowgroup
+ "
+ killButton openAutonomous.
+
+ "
+ go fork a pipe and read it
+ "
+ self label:(myName , ': executing ' , (command copyTo:(20 min:command size)) , ' ...').
+ [
+ self withCursor:(Cursor wait) do:[
+ stopSignal catch:[
+ startLine := subView cursorLine.
+ startCol := subView cursorCol.
+
+ stream := PipeStream readingFrom:('cd '
+ , currentDirectory pathName
+ , '; '
+ , command).
+ stream notNil ifTrue:[
+ "
+ this can be a time consuming operation; therefore lower my priority
+ "
+ myProcess := Processor activeProcess.
+ myPriority := myProcess priority.
+ myProcess priority:(Processor userBackgroundPriority).
+
+ [
+ replace ifTrue:[
+ subView list:nil.
+ lnr := 1.
+ ].
+
+ [stream atEnd] whileFalse:[
+ stream readWait.
+ line := stream nextLine.
+
+ "
+ need this critical section; otherwise,
+ we could get the signal while waiting for
+ an expose event ...
+ "
+ access critical:[
+ line notNil ifTrue:[
+ replace ifTrue:[
+ subView at:lnr put:line.
+ lnr := lnr + 1.
+ ] ifFalse:[
+ subView insertStringAtCursor:line.
+ subView insertCharAtCursor:(Character cr).
+ ]
+ ].
+
+ windowGroup processExposeEvents.
+ ].
+ "/
+ "/ give others running at same prio a chance too
+ "/
+ Processor yield
+ ].
+ ] valueNowOrOnUnwindDo:[
+ stream close. stream := nil.
+ ].
+ self updateCurrentDirectory
+ ].
+ replace ifTrue:[
+ subView modified:false.
+ ].
+ ]
+ ]
+ ] valueNowOrOnUnwindDo:[
+ |wg|
+
+ self label:myName.
+ myProcess priority:myPriority.
+
+ "
+ remove the killButton from its group
+ (otherwise, it will be destroyed when we shut down the group)
+ "
+ wg := killButton windowGroup.
+ killButton windowGroup:nil.
+ "
+ shut down the windowgroup
+ "
+ wg process terminate.
+ "
+ hide the button, and make sure it will stay
+ hidden when we are realized again
+ "
+ killButton unrealize.
+ killButton hidden:true.
+ "
+ clear its action (actually not needed, but
+ releases reference to thisContext earlier)
+ "
+ killButton action:nil.
+ ]
+!
+
+initialCommandFor:fileName into:aBox
+ "set a useful initial command for execute box.
+
+ XXX should be changed to take stuff from a config file
+ XXX or from resources."
+
+ ((currentDirectory typeOf:fileName) == #regular) ifTrue:[
+
+ (currentDirectory isExecutable:fileName) ifTrue:[
+ aBox initialText:(fileName , '<arguments>').
+ ^ self
+ ].
+
+ "some heuristics - my personal preferences ...
+ (actually this should come from a configfile)"
+
+ (fileName endsWith:'akefile') ifTrue:[
+ aBox initialText:'make target' selectFrom:6 to:11.
+ ^ self
+ ].
+ (fileName endsWith:'.tar.Z') ifTrue:[
+ aBox initialText:'zcat ' , fileName , ' | tar tvf -'.
+ ^ self
+ ].
+ (fileName endsWith:'.taz') ifTrue:[
+ aBox initialText:'zcat ' , fileName , ' | tar tvf -'.
+ ^ self
+ ].
+ (fileName endsWith:'.tar') ifTrue:[
+ aBox initialText:'tar tvf ' , fileName selectFrom:1 to:7.
+ ^ self
+ ].
+ (fileName endsWith:'.zoo') ifTrue:[
+ aBox initialText:'zoo -list ' , fileName selectFrom:1 to:9.
+ ^ self
+ ].
+ (fileName endsWith:'.zip') ifTrue:[
+ aBox initialText:'unzip -l ' , fileName selectFrom:1 to:8.
+ ^ self
+ ].
+ (fileName endsWith:'.Z') ifTrue:[
+ aBox initialText:'uncompress ' , fileName selectFrom:1 to:10.
+ ^ self
+ ].
+ (fileName endsWith:'tar.gz') ifTrue:[
+ aBox initialText:('gunzip <' , fileName , ' | tar tvf -' ).
+ ^ self
+ ].
+ (fileName endsWith:'.gz') ifTrue:[
+ aBox initialText:('gunzip <' , fileName , ' >' , (fileName copyTo:(fileName size - 3))).
+ ^ self
+ ].
+ (fileName endsWith:'.uue') ifTrue:[
+ aBox initialText:'uudecode ' , fileName selectFrom:1 to:8.
+ ^ self
+ ].
+ (fileName endsWith:'.c') ifTrue:[
+ aBox initialText:'cc -c ' , fileName selectFrom:1 to:5.
+ ^ self
+ ].
+ (fileName endsWith:'.cc') ifTrue:[
+ aBox initialText:'g++ -c ' , fileName selectFrom:1 to:6.
+ ^ self
+ ].
+ (fileName endsWith:'.C') ifTrue:[
+ aBox initialText:'g++ -c ' , fileName selectFrom:1 to:6.
+ ^ self
+ ].
+ (fileName endsWith:'.xbm') ifTrue:[
+ aBox initialText:'bitmap ' , fileName selectFrom:1 to:6.
+ ^ self
+ ].
+ ((fileName endsWith:'.ps') or:[fileName endsWith:'.PS']) ifTrue:[
+ aBox initialText:'ghostview ' , fileName selectFrom:1 to:9.
+ ^ self
+ ].
+ ((fileName endsWith:'.1')
+ or:[fileName endsWith:'.man']) ifTrue:[
+ aBox initialText:'nroff -man ' , fileName selectFrom:1 to:10.
+ ^ self
+ ].
+ aBox initialText:'<cmd> ' , fileName selectFrom:1 to:5
+ ]
+!
+
+askForCommandThenDo:aBlock
+ "setup and launch a querybox to ask for unix command.
+ Then evaluate aBlock passing the command-string as argument."
+
+ |fileName sel box|
+
+ box :=EnterBox new.
+ box initialText:''.
+
+ sel := fileListView selection.
+ (sel isKindOf:Collection) ifFalse:[
+ sel notNil ifTrue:[
+ fileName := fileList at:sel
+ ]
+ ].
+ fileName notNil ifTrue:[
+ self initialCommandFor:fileName into:box.
+ ].
+ box title:(resources at:'execute unix command:').
+ box okText:(resources at:'execute').
+ box action:aBlock.
+ box showAtPointer
+!
+
+selectedFilesDo:aBlock
+ |sel files|
+
+ sel := fileListView selection.
+ sel notNil ifTrue:[
+ (sel isKindOf:Collection) ifTrue:[
+ files := sel collect:[:index | fileList at:index].
+ files do:[:aFile |
+ aBlock value:aFile
+ ]
+ ] ifFalse:[
+ aBlock value:(fileList at:sel)
+ ]
+ ]
+
+!
+
+doRename:oldName to:newName
+ (oldName notNil and:[newName notNil]) ifTrue:[
+ (oldName isBlank or:[newName isBlank]) ifFalse:[
+ currentDirectory renameFile:oldName newName:newName.
+ self updateCurrentDirectory.
+"
+ self checkIfDirectoryHasChanged
+"
+ ]
+ ]
+!
+
+doRemove
+ "remove the selected file(s) - no questions asked"
+
+ |ok msg dir|
+
+ self withCursor:(Cursor execute) do:[
+ self selectedFilesDo:[:fileName |
+ (currentDirectory isDirectory:fileName) ifTrue:[
+ dir := FileDirectory directoryNamed:fileName in:currentDirectory.
+ dir isEmpty ifFalse:[
+ self ask:(resources string:'directory ''%1'' is not empty\remove anyway ?' with:fileName)
+ yesButton:'remove'
+ action:[currentDirectory removeDirectory:fileName]
+ ] ifTrue:[
+ currentDirectory removeDirectory:fileName
+ ].
+ ] ifFalse:[
+ ok := currentDirectory remove:fileName.
+ ok ifFalse:[
+ "was not able to remove it"
+ msg := (resources string:'cannot remove ''%1'' !!' with:fileName).
+ self showAlert:msg with:(OperatingSystem lastErrorString)
+ ] ifTrue:[
+"
+ self show:nil
+"
+ ]
+ ]
+ ].
+ self updateCurrentDirectory.
+ ]
+!
+
+onlyOneSelection
+ "show a warning, that only one file must be selected for
+ this operation"
+
+ self warn:(resources at:'exactly one file must be selected !!')
+! !
+
+!FileBrowser methodsFor:'user interaction'!
+
+fileSpawn
+ "start another FileBrowser on the selected directory or
+ on the same directory if none is selected."
+
+ |any|
+
+ any := false.
+ self selectedFilesDo:[:fileName |
+ (currentDirectory isDirectory:fileName) ifTrue:[
+ self class openOn:(currentDirectory pathName , '/' , fileName).
+ any := true
+ ]
+ ].
+ any ifFalse:[
+ self class openOn:currentDirectory pathName
+ ]
+!
+
+copyPath
+ "copy current path into cut & paste buffer"
+
+ Smalltalk at:#CopyBuffer put:(currentDirectory pathName)
+!
+
+fileExecute
+ "if text was modified show a queryBox,
+ otherwise pop up execute box immediately"
+
+ |action|
+
+"/ action := [:command| self doExecuteCommand:command replace:true].
+"/
+"/ self askIfModified:(resources at:'contents has not been saved.\\Modifications will be lost when command is executed.') withCRs
+"/ yesButton:(resources at:'execute')
+"/ action:[self askForCommandThenDo:action]
+
+ action := [:command| self doExecuteCommand:command replace:false].
+ self askForCommandThenDo:action
+!
+
+fileSelect:lineNr
+ "selected a file - do nothing here"
+ ^ self
+!
+
+fileGet
+ "if text was modified show an queryBox,
+ otherwise get it immediately"
+
+ |fileName msg label|
+
+ (subView modified not or:[subView contentsWasSaved]) ifTrue:[^ self doFileGet].
+ fileName := self getSelectedFileName.
+ fileName notNil ifTrue:[
+ (currentDirectory isDirectory:fileName) ifTrue:[
+ msg := (resources at:'contents has not been saved.\\Modifications will be lost when directory is changed.').
+ label := 'change'.
+ ] ifFalse:[
+ msg := (resources at:'contents has not been saved.\\Modifications will be lost when new file is read.').
+ label := 'get'.
+ ].
+ self ask:msg yesButton:label action:[self doFileGet]
+ ]
+!
+
+filePrint
+ |fileName inStream printStream line|
+
+ self withCursor:(Cursor execute) do:[
+ fileName := self getSelectedFileName.
+ fileName notNil ifTrue:[
+ ((currentDirectory typeOf:fileName) == #regular) ifTrue:[
+ inStream := FileStream readonlyFileNamed:fileName
+ in:currentDirectory.
+ inStream isNil ifFalse:[
+ printStream := PrinterStream new.
+ printStream notNil ifTrue:[
+ [inStream atEnd] whileFalse:[
+ line := inStream nextLine.
+ printStream nextPutAll:line.
+ printStream cr
+ ].
+ printStream close
+ ].
+ inStream close
+ ]
+ ]
+ ].
+ 0 "compiler hint"
+ ]
+!
+
+fileFileIn
+ "fileIn the selected file(s)"
+
+ |aStream upd|
+
+ self withCursor:(Cursor wait) do:[
+ self selectedFilesDo:[:fileName |
+ ((currentDirectory typeOf:fileName) == #regular) ifTrue:[
+ ((fileName endsWith:'.o')
+ or:[(fileName endsWith:'.so')
+ or:[fileName endsWith:'.obj']]) ifTrue:[
+ Object abortSignal catch:[
+ ObjectFileLoader loadObjectFile:(currentDirectory pathName , '/' ,fileName)
+ ]
+ ] ifFalse:[
+ aStream := FileStream readonlyFileNamed:fileName in:currentDirectory.
+ aStream isNil ifFalse:[
+ upd := Class updateChanges:false.
+ [
+ Smalltalk systemPath addFirst:(currentDirectory pathName).
+ aStream fileIn.
+ Smalltalk systemPath removeFirst
+ ] valueNowOrOnUnwindDo:[
+ Class updateChanges:upd.
+ aStream close
+ ]
+ ]
+ ]
+ ]
+ ]
+ ]
+!
+
+fileRemove
+ "remove the selected file(s).
+ Query if user really wants to remove the file.
+ - should be enhanced, to look for a ~/.trash directory
+ and move files there if it exists (without asking in this case)."
+
+ |sel q|
+
+ sel := fileListView selection.
+ sel notNil ifTrue:[
+ (sel isKindOf:Collection) ifTrue:[
+ q := resources string:'remove selected files ?'
+ ] ifFalse:[
+ q := resources string:'remove ''%1'' ?' with:(fileList at:sel)
+ ].
+ self ask:q yesButton:'remove' action:[self doRemove]
+ ]
+!
+
+newDirectory
+ "ask for and create a new directory"
+
+ queryBox isNil ifTrue:[
+ queryBox := FilenameEnterBox new
+ ].
+ queryBox initialText:''.
+ queryBox title:(resources at:'create new directory:') withCRs.
+ queryBox okText:(resources at:'create').
+ "queryBox abortText:(resources at:'abort')."
+ queryBox action:[:newName | self doCreateDirectory:newName].
+ queryBox showAtPointer
+!
+
+newFile
+ "ask for and create a new file"
+
+ | sel |
+
+ queryBox isNil ifTrue:[
+ queryBox := FilenameEnterBox new
+ ].
+ sel := subView selection.
+ sel notNil ifTrue:[
+ queryBox initialText:(sel asString)
+ ] ifFalse:[
+ queryBox initialText:''
+ ].
+ queryBox title:(resources at:'create new file:') withCRs.
+ queryBox okText:(resources at:'create').
+ "queryBox abortText:(resources at:'abort')."
+ queryBox action:[:newName | self doCreateFile:newName].
+ queryBox showAtPointer
+!
+
+fileRename
+ "rename the selected file(s)"
+
+ queryBox isNil ifTrue:[
+ queryBox := FilenameEnterBox new
+ ].
+ queryBox okText:(resources at:'rename').
+ "queryBox abortText:(resources at:'abort')."
+ self selectedFilesDo:[:oldName |
+ queryBox title:(resources string:'rename ''%1'' to:' with:oldName).
+ queryBox initialText:oldName.
+ queryBox action:[:newName | self doRename:oldName to:newName].
+ queryBox showAtPointer
+ ]
+!
+
+terminate
+ "exit FileBrowser"
+
+ self askIfModified:(resources at:'contents has not been saved.\\Modifications will be lost when FileBrowser is closed.') withCRs
+ yesButton:(resources at:'close')
+ action:[self destroy]
+!
+
+destroy
+ "destroy view and boxes"
+
+ ObjectMemory removeDependent:self.
+ Processor removeTimedBlock:checkBlock.
+ checkBlock := nil.
+ yesNoBox notNil ifTrue:[yesNoBox destroy. yesNoBox := nil].
+ queryBox notNil ifTrue:[queryBox destroy. queryBox := nil].
+ super destroy
+!
+
+update:what
+ (what == #aboutToExit) ifTrue:[
+ "system wants to shut down this
+ - if text was modified, pop up, and ask user and save if requested."
+
+ (subView modified and:[subView contentsWasSaved not]) ifTrue:[
+ shown ifFalse:[
+ self unrealize.
+ self realize
+ ].
+ self raise.
+ "
+ mhmh: I dont like this - need some way to tell windowGroup to handle
+ all pending exposures ...
+ "
+ self withAllSubViewsDo:[:view | view redraw].
+
+ self ask:(resources at:'FileBrowser:\\contents has not been saved.\\Save before exiting ?') withCRs
+ yesButton:'save'
+ noButton:'don''t save'
+ action:[
+ subView acceptAction notNil ifTrue:[
+ subView accept
+ ] ifFalse:[
+ subView save
+ ]
+ ]
+ ].
+ ^ self
+ ].
+ super update:what
+
+!
+
+changeDirectoryTo:aDirectoryName
+ "sent from label menu to change back to a previous directory"
+
+ self doChangeCurrentDirectoryTo:aDirectoryName updateHistory:false
+!
+
+changeCurrentDirectory
+ "if text was modified show a queryBox,
+ otherwise change immediately to directory"
+
+ self askIfModified:(resources at:'contents has not been saved.\\Modifications will be lost when directory is changed.') withCRs
+ yesButton:(resources at:'change')
+ action:[self queryForDirectoryToChange]
+!
+
+changeToParentDirectory
+ "if text was modified show a queryBox,
+ otherwise change immediately to directory"
+
+ self askIfModified:(resources at:'contents has not been saved.\\Modifications will be lost when directory is changed.') withCRs
+ yesButton:(resources at:'change')
+ action:[self doChangeToParentDirectory]
+!
+
+changeToHomeDirectory
+ "if text was modified show a queryBox,
+ otherwise change immediately to directory"
+
+ self askIfModified:(resources at:'contents has not been saved.\\Modifications will be lost when directory is changed.') withCRs
+ yesButton:(resources at:'change')
+ action:[self doChangeToHomeDirectory]
+!
+
+queryForDirectoryToChange
+ "query for new directory"
+
+ queryBox isNil ifTrue:[
+ queryBox := FilenameEnterBox new
+ ].
+ queryBox initialText:''.
+ queryBox title:(resources at:'change directory to:') withCRs.
+ queryBox okText:(resources at:'change').
+ "queryBox abortText:(resources at:'abort')."
+ queryBox action:[:newName | self doChangeCurrentDirectoryTo:newName updateHistory:true].
+ queryBox showAtPointer
+!
+
+fileGetInfo:longInfo
+ "get info on selected file - show it in a box"
+
+ |string|
+
+ string := self getFileInfoString:longInfo.
+ string notNil ifTrue:[
+ self information:string
+ ]
+!
+
+fileGetLongInfo
+ "triggered by menu: show long stat-info"
+
+ self fileGetInfo:true
+!
+
+fileGetInfo
+ "triggered by menu: show short stat-info"
+
+ self fileGetInfo:false
+!
+
+changeDisplayMode
+ "toggle from long to short listing (and vice-versa)"
+
+ |long short|
+
+ long := (resources at:'display long list').
+ short := (resources at:'display short list').
+
+ showLongList := showLongList not.
+ showLongList ifFalse:[
+ fileListView middleButtonMenu labelAt:short put:long
+ ] ifTrue:[
+ fileListView middleButtonMenu labelAt:long put:short
+ ].
+ self updateCurrentDirectory
+!
+
+changeDotFileVisibility
+ "turn on/off visibility of files whose name starts with '.'"
+
+ |show dontShow|
+
+ show := (resources at:'show all files').
+ dontShow := (resources at:'hide hidden files').
+
+ showDotFiles := showDotFiles not.
+ showDotFiles ifFalse:[
+ fileListView middleButtonMenu labelAt:dontShow put:show
+ ] ifTrue:[
+ fileListView middleButtonMenu labelAt:show put:dontShow
+ ].
+ self updateCurrentDirectory
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/FileBrowser.st Sat Aug 13 20:40:49 1994 +0200
@@ -0,0 +1,1633 @@
+"
+ 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.
+"
+
+StandardSystemView subclass:#FileBrowser
+ instanceVariableNames:'labelView filterField fileListView subView
+ currentDirectory
+ queryBox yesNoBox
+ topFrame fileList
+ checkBlock checkDelta timeOfLastCheck
+ showLongList showVeryLongList showDotFiles
+ myName killButton'
+ classVariableNames:'DirectoryHistory HistorySize'
+ poolDictionaries:''
+ category:'Interface-Browsers'
+!
+
+FileBrowser comment:'
+COPYRIGHT (c) 1991 by Claus Gittinger
+ All Rights Reserved
+
+$Header: /cvs/stx/stx/libtool/FileBrowser.st,v 1.15 1994-08-13 18:40:28 claus Exp $
+'!
+
+!FileBrowser class methodsFor:'documentation'!
+
+copyright
+"
+ 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.
+"
+!
+
+version
+"
+$Header: /cvs/stx/stx/libtool/FileBrowser.st,v 1.15 1994-08-13 18:40:28 claus Exp $
+"
+!
+
+documentation
+"
+ this used to be a very simple demo application,
+ 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 ....
+ See additional information in 'doc/misc/fbrowser.doc'.
+"
+! !
+
+!FileBrowser class methodsFor:'instance creation'!
+
+openOn:aDirectoryPath
+ "start a new FileBrowser in a pathname"
+
+ ^ (self new currentDirectory:aDirectoryPath) open
+
+ "FileBrowser openOn:'aDirectoryPath'"
+! !
+
+!FileBrowser methodsFor:'initialization'!
+
+initialize
+ |frame spacing halfSpacing v|
+
+ super initialize.
+
+ DirectoryHistory isNil ifTrue:[
+ DirectoryHistory := OrderedCollection new.
+ HistorySize := 15.
+ ].
+
+ myName := (resources string:self class name).
+ self label:myName.
+ self icon:(Form fromFile:(resources at:'ICON_FILE' default:'FBrowser.xbm')
+ resolution:100).
+
+ spacing := ViewSpacing.
+ halfSpacing := spacing // 2.
+
+ checkBlock := [self checkIfDirectoryHasChanged].
+ checkDelta := 5.
+
+ currentDirectory := FileDirectory directoryNamed:'.'.
+ showLongList := resources at:'LONG_LIST' default:false.
+ showDotFiles := resources at:'SHOW_DOT_FILES' default:false.
+
+ filterField := EditField in:self.
+ filterField origin:[((width // 4 * 3) + halfSpacing) @ halfSpacing]
+ extent:[((width // 4) - borderWidth
+ - (filterField margin)
+ - halfSpacing
+ - filterField borderWidth)
+ @
+ (filterField heightIncludingBorder "i.e. take its default height"
+ "font height + font descent + (filterField margin * 2)"
+ )
+ ].
+ self initializeFilterPattern.
+ filterField leaveAction:[:key | fileListView scrollToTop. self updateCurrentDirectory].
+
+ labelView := Label in:self.
+ labelView origin:(halfSpacing @ halfSpacing)
+ extent:[((width // 4 * 3) - spacing - borderWidth)
+ @
+ (filterField heightIncludingBorder)
+ "(font height + font descent)"
+ ].
+ labelView adjust:#right.
+ labelView borderWidth:0.
+ self initializeLabelMiddleButtonMenu.
+
+ killButton := Button label:(resources string:'kill') in:self.
+ killButton origin:(halfSpacing @ halfSpacing)
+ extent:[(killButton width)
+ @
+ (filterField heightIncludingBorder)
+ ].
+ killButton hidden:true.
+
+ frame := VariableVerticalPanel
+ origin:[frame borderWidth negated
+ @
+ (labelView height + labelView origin y + spacing)
+ ]
+ extent:[width
+ @
+ (height - spacing - labelView height - borderWidth)
+ ]
+ in:self.
+
+ topFrame := ScrollableView for:SelectionInListView in:frame.
+ topFrame origin:(0.0 @ 0.0) corner:(1.0 @ 0.3).
+
+ fileListView := topFrame scrolledView.
+ fileListView action:[:lineNr | self fileSelect:lineNr].
+ fileListView doubleClickAction:[:lineNr | self fileSelect:lineNr.
+ self fileGet].
+ fileListView multipleSelectOk:true.
+
+ v := self initializeSubViewIn:frame.
+ v origin:(0.0 @ 0.3) corner:(1.0 @ 1.0).
+ subView := v scrolledView.
+ (subView respondsTo:#directoryForFileDialog:) ifTrue:[
+ subView directoryForFileDialog:currentDirectory
+ ].
+
+ ObjectMemory addDependent:self.
+!
+
+initializeFilterPattern
+ "set an initial matchpattern - can be redefined in subclasses"
+
+ filterField contents:'*'
+!
+
+initializeSubViewIn:frame
+ "set up the contents view - can be redefined in subclasses for
+ different view types (SoundFileBrowser/ImageBrowsers etc.)"
+
+ ^ HVScrollableView for:CodeView miniScrollerH:true miniScrollerV:false in:frame.
+!
+
+currentDirectory:aDirectoryPath
+ "set the directory to be browsed"
+
+ currentDirectory := FileDirectory directoryNamed:aDirectoryPath.
+ (subView respondsTo:#directoryForFileDialog:) ifTrue:[
+ subView directoryForFileDialog:currentDirectory
+ ]
+!
+
+realize
+ self initializeFileListMiddleButtonMenu.
+ super realize.
+"/ self updateCurrentDirectory
+!
+
+mapped
+ super mapped.
+ self updateCurrentDirectory
+!
+
+initializeLabelMiddleButtonMenu
+ |labels selectors args|
+
+ labelView notNil ifTrue:[
+ labels := resources array:#(
+ 'copy path'
+ '-'
+ 'up'
+ 'change to home-directory'
+ 'change directory ...'
+ ).
+
+ selectors := #(
+ copyPath
+ nil
+ changeToParentDirectory
+ changeToHomeDirectory
+ changeCurrentDirectory
+ ).
+
+ args := Array new:5.
+
+ DirectoryHistory size > 0 ifTrue:[
+ labels := labels copyWith:'-'.
+ selectors := selectors copyWith:nil.
+ args := args copyWith:nil.
+
+ DirectoryHistory do:[:dirName |
+ labels := labels copyWith:dirName.
+ selectors := selectors copyWith:#changeDirectoryTo:.
+ args := args copyWith:dirName
+ ]
+ ].
+
+ labelView
+ middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:selectors
+ args:args
+ receiver:self
+ for:labelView).
+
+
+ ]
+!
+
+initializeFileListMiddleButtonMenu
+ |labels|
+
+ fileListView notNil ifTrue:[
+ labels := resources array:#(
+ 'spawn'
+ 'get contents'
+ 'show info'
+ 'show full info'
+ 'fileIn'
+ '-'
+ 'update'
+ '-'
+ 'execute unix command ...'
+ '-'
+ 'remove'
+ 'rename ...'
+ '-'
+ 'display long list'
+ 'show all files'
+ '-'
+ 'create directory ...'
+ 'create file ...').
+
+ fileListView
+ middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:#(fileSpawn
+ fileGet
+ fileGetInfo
+ fileGetLongInfo
+ fileFileIn
+ nil
+ updateCurrentDirectory
+ nil
+ fileExecute
+ nil
+ fileRemove
+ fileRename
+ nil
+ changeDisplayMode
+ changeDotFileVisibility
+ nil
+ newDirectory
+ newFile)
+ receiver:self
+ for:fileListView)
+ ]
+! !
+
+!FileBrowser methodsFor:'private'!
+
+showAlert:aString with:anErrorString
+ "show an alertbox, displaying the last Unix-error"
+
+ anErrorString isNil ifTrue:[
+ self warn:aString withCRs
+ ] ifFalse:[
+ self warn:(aString , '\\(' , anErrorString , ')' ) withCRs
+ ]
+!
+
+ask:question yesButton:yesButtonText action:aBlock
+ "common method to ask a yes/no question"
+
+ self ask:question yesButton:yesButtonText noButton:'abort' action:aBlock
+!
+
+ask:question yesButton:yesButtonText noButton:noButtonText action:aBlock
+ "common method to ask a yes/no question"
+
+ "cache the box"
+ yesNoBox isNil ifTrue:[
+ yesNoBox := YesNoBox new
+ ].
+ yesNoBox title:question withCRs.
+ yesNoBox okText:(resources at:yesButtonText).
+ yesNoBox noText:(resources at:noButtonText).
+ yesNoBox okAction:aBlock.
+ yesNoBox showAtPointer
+!
+
+askIfModified:question yesButton:yesButtonText action:aBlock
+ "tell user, that code has been modified - let her confirm"
+
+ (subView modified not or:[subView contentsWasSaved]) ifTrue:[
+ aBlock value.
+ ^ self
+ ].
+ self ask:question yesButton:yesButtonText action:aBlock
+!
+
+withoutHiddenFiles:aCollection
+ "remove hidden files (i.e. those that start with '.') from
+ the list in aCollection"
+
+ |newCollection|
+
+ newCollection := aCollection species new.
+ aCollection do:[:fname |
+ ((fname startsWith:'.') and:[(fname = '..') not]) ifTrue:[
+ showDotFiles ifTrue:[
+ newCollection add:fname
+ ]
+ ] ifFalse:[
+ newCollection add:fname
+ ]
+ ].
+ ^ newCollection
+!
+
+getInfoFile
+ "get filename of a description-file (.dir.info);
+ uncomment stuff below if you want this to also
+ automatically show contents of README files."
+
+ #( '.dir.info'
+"you can add these if you like ..."
+"
+ 'README'
+ 'ReadMe'
+ 'Readme'
+ 'readme'
+"
+ ) do:[:f |
+ (currentDirectory isReadable:f) ifTrue:[^ f].
+ ].
+ ^ nil
+!
+
+showInfo:info
+ "show directory info when dir has changed"
+
+ info notNil ifTrue:[
+ self show:(self readFile:info)
+ ] ifFalse:[
+ self show:nil.
+ ]
+!
+
+getSelectedFileName
+ "returns the currently selected file; shows an error if
+ multiple files are selected"
+
+ |sel|
+
+ sel := fileListView selection.
+ (sel isKindOf:Collection) ifTrue:[
+ self onlyOneSelection
+ ] ifFalse:[
+ sel notNil ifTrue:[
+ ^ fileList at:sel
+ ]
+ ].
+ ^ nil
+!
+
+getFileInfoString:longInfo
+ "get stat info on selected file - return a string which can be
+ shown in a box"
+
+ |fileName fullPath text info stream fileOutput type modeBits modeString s|
+
+ fileName := self getSelectedFileName.
+ fileName isNil ifTrue:[^ nil].
+
+ info := currentDirectory infoOf:fileName.
+ info isNil ifTrue:[
+ self showAlert:(resources string:'cannot get info of ''%1'' !!' with:fileName)
+ with:(OperatingSystem lastErrorString).
+ ^ nil
+ ].
+
+ text := Text new.
+ type := info at:#type.
+ (longInfo and:[type == #regular]) ifTrue:[
+ fullPath := currentDirectory pathName , '/' , fileName.
+ stream := PipeStream readingFrom:('file ' , fullPath).
+ stream notNil ifTrue:[
+ fileOutput := stream contents asString.
+ stream close.
+ fileOutput := fileOutput copyFrom:(fileOutput indexOf:$:) + 1.
+ fileOutput := fileOutput withoutSeparators
+ ]
+ ].
+
+ s := (resources at:'type: ').
+ fileOutput isNil ifTrue:[
+ s := s , type asString
+ ] ifFalse:[
+ s := s , 'regular (' , fileOutput , ')'
+ ].
+ text add:s.
+ text add:(resources at:'size: ') , (info at:#size) printString.
+
+ modeBits := (info at:#mode).
+ modeString := self getModeString:modeBits.
+ longInfo ifTrue:[
+ text add:((resources at:'access: ')
+ , modeString
+ , ' (' , (modeBits printStringRadix:8), ')' )
+ ] ifFalse:[
+ text add:(resources at:'access: ') , modeString
+ ].
+ text add:(resources at:'owner: ')
+ , (OperatingSystem getUserNameFromID:(info at:#uid)).
+ longInfo ifTrue:[
+ text add:(resources at:'group: ')
+ , (OperatingSystem getGroupNameFromID:(info at:#gid)).
+ text add:(resources at:'last access: ')
+ , (info at:#accessTime) asTime printString
+ , ' '
+ , (info at:#accessTime) asDate printString.
+ text add:(resources at:'last modification: ')
+ , (info at:#modificationTime) asTime printString
+ , ' '
+ , (info at:#modificationTime) asDate printString.
+
+ ].
+ ^ text asString
+!
+
+getModeString:modeBits
+ "convert file-mode bits into a more user-friendly string.
+ This is wrong here - should be moved into OperatingSystem."
+
+ |bits modeString|
+
+ bits := modeBits bitAnd:8r777.
+ modeString := ''.
+
+ #( nil 8r400 8r200 8r100 nil 8r040 8r020 8r010 nil 8r004 8r002 8r001 )
+ with: #( 'owner:' $r $w $x ' group:' $r $w $x ' others:' $r $w $x ) do:[:bitMask :access |
+ bitMask isNil ifTrue:[
+ modeString := modeString , (resources string:access)
+ ] ifFalse:[
+ (bits bitAnd:bitMask) == 0 ifTrue:[
+ modeString := modeString copyWith:$-
+ ] ifFalse:[
+ modeString := modeString copyWith:access
+ ]
+ ]
+ ].
+ ^ modeString
+!
+
+checkIfDirectoryHasChanged
+ "every checkDelta secs, check if directoy has changed and update view if so"
+
+ |oldSelection nOld here|
+
+ shown ifTrue:[
+ currentDirectory notNil ifTrue:[
+ here := currentDirectory pathName.
+ (OperatingSystem isReadable:here) ifTrue:[
+ Processor removeTimedBlock:checkBlock.
+
+ (currentDirectory timeOfLastChange > timeOfLastCheck) ifTrue:[
+ nOld := fileListView numberOfSelections.
+ oldSelection := fileListView selectionValue.
+ self updateCurrentDirectory.
+ nOld ~~ 0 ifTrue:[
+ nOld > 1 ifTrue:[
+ oldSelection do:[:element |
+ fileListView addElementToSelection:element
+ ]
+ ] ifFalse:[
+ fileListView selectElement:oldSelection
+ ]
+ ]
+ ] ifFalse:[
+ Processor addTimedBlock:checkBlock afterSeconds:checkDelta
+ ]
+ ] ifFalse:[
+ "
+ if the directory has been deleted, or is not readable ...
+ "
+ (OperatingSystem isValidPath:here) ifFalse:[
+ self warn:(resources string:'FileBrowser:\\directory %1 is gone ?!!?' with:here) withCRs
+ ] ifTrue:[
+ self warn:(resources string:'FileBrowser:\\directory %1 is no longer readable ?!!?' with:here) withCRs
+ ].
+ fileListView contents:nil.
+ self label:(myName , ': directory is gone !!').
+ "/ Processor addTimedBlock:checkBlock afterSeconds:checkDelta
+ ]
+ ]
+ ]
+!
+
+sizePrintString:size
+ "helper for update-directory to return a string with a files size.
+ This one gives the size in byte, Kb or Mb depending on size.
+ If you dont like this, just uncomment the first statement below."
+
+ |unitString sizeString|
+
+"
+ ^ size printString.
+"
+ unitString := ''.
+ size < (500 * 1024) ifTrue:[
+ size < (1024) ifTrue:[
+ sizeString := size printString
+ ] ifFalse:[
+ sizeString := (size * 10 // 1024 / 10.0) printString.
+ unitString := 'Kb'
+ ]
+ ] ifFalse:[
+ sizeString := (size * 10 // 1024 // 1024 / 10.0) printString.
+ unitString := 'Mb'
+ ].
+ (sizeString includes:$.) ifFalse:[
+ sizeString := sizeString , ' '
+ ].
+ ^ (sizeString printStringLeftPaddedTo:5) , unitString.
+!
+
+updateCurrentDirectory
+ "update listView with directory contents"
+
+ |files text len line info modeString typ
+ prevUid prevGid nameString groupString matchPattern
+ myProcess myPriority|
+
+ self withCursor:(Cursor read) do:[
+ Processor removeTimedBlock:checkBlock.
+
+ labelView label:(currentDirectory pathName).
+ timeOfLastCheck := Time now.
+
+ files := currentDirectory asOrderedCollection.
+
+ matchPattern := filterField contents.
+ (matchPattern notNil and:[
+ matchPattern isEmpty not and:[
+ matchPattern ~= '*']]) ifTrue:[
+ files := files select:[:aName |
+ ((currentDirectory typeOf:aName) == #directory)
+ or:[matchPattern match:aName]
+ ].
+ ].
+ files sort.
+
+ files size == 0 ifTrue:[
+ self notify:('directory ', currentDirectory pathName, ' vanished').
+ ^ self
+ ].
+ files := self withoutHiddenFiles:files.
+
+ "
+ this is a time consuming operation (especially, if reading an
+ NFS-mounted directory); therefore lower my priority while getting
+ the files info ...
+ "
+ myProcess := Processor activeProcess.
+ myPriority := myProcess priority.
+ myProcess priority:(Processor userBackgroundPriority).
+ [
+ fileList := files.
+ showLongList ifTrue:[
+ text := OrderedCollection new.
+ files do:[:aFileName |
+ "
+ if multiple FileBrowsers are reading, let others
+ make some progress too
+ "
+ Processor yield.
+
+ len := aFileName size.
+ (len < 20) ifTrue:[
+ line := aFileName , (String new:(22 - len))
+ ] ifFalse:[
+ "can happen on BSD only"
+ line := (aFileName copyTo:20) , ' '
+ ].
+ info := currentDirectory infoOf:aFileName.
+ info isNil ifTrue:[
+ "not accessable - usually a symlink,
+ which is not there/not readable
+ "
+ text add:line , '? bad symbolic link'
+ ] ifFalse:[
+ typ := (info at:#type) at:1.
+ (typ == $r) ifFalse:[
+ line := line , typ asString , ' '
+ ] ifTrue:[
+ line := line , ' '
+ ].
+
+ modeString := self getModeString:(info at:#mode).
+ line := line , modeString , ' '.
+
+ ((info at:#uid) ~~ prevUid) ifTrue:[
+ prevUid := (info at:#uid).
+ nameString := OperatingSystem getUserNameFromID:prevUid.
+ nameString := nameString , (String new:(10 - nameString size))
+ ].
+ line := line , nameString.
+ ((info at:#gid) ~~ prevGid) ifTrue:[
+ prevGid := (info at:#gid).
+ groupString := OperatingSystem getGroupNameFromID:prevGid.
+ groupString := groupString , (String new:(10 - groupString size))
+ ].
+ line := line , groupString.
+
+ (typ == $r) ifTrue:[
+ line := line , (self sizePrintString:(info at:#size))
+ ].
+ text add:line
+ ].
+ ].
+ ] ifFalse:[
+ text := files collect:[:aName |
+ "
+ if multiple FileBrowsers are reading, let others
+ make some progress too
+ "
+ Processor yield.
+ (((currentDirectory typeOf:aName) == #directory) and:[
+ (aName ~= '..') and:[aName ~= '.']]) ifTrue:[
+ aName , ' ...'
+ ] ifFalse:[
+ aName
+ ]
+ ].
+ ].
+ fileListView setContents:text
+ ] valueNowOrOnUnwindDo:[
+ myProcess priority:myPriority.
+ ].
+
+ "
+ install a new check after some time
+ "
+ Processor addTimedBlock:checkBlock afterSeconds:checkDelta
+ ]
+!
+
+doChangeCurrentDirectoryTo:fileName updateHistory:updateHistory
+ "verify argument is name of a readable & executable directory
+ and if so, go there"
+
+ |msg|
+
+ self label:myName.
+ fileName notNil ifTrue:[
+ (currentDirectory isDirectory:fileName) ifTrue:[
+ (currentDirectory isReadable:fileName) ifTrue:[
+ (currentDirectory isExecutable:fileName) ifTrue:[
+ updateHistory ifTrue:[
+ (DirectoryHistory includes:(currentDirectory pathName)) ifFalse:[
+ DirectoryHistory addFirst:currentDirectory pathName.
+ DirectoryHistory size > HistorySize ifTrue:[
+ DirectoryHistory removeLast
+ ].
+ self initializeLabelMiddleButtonMenu
+ ]
+ ].
+
+ ^ self setCurrentDirectory:fileName
+ ].
+ msg := (resources string:'cannot change directory to ''%1'' !!' with:fileName)
+ ] ifFalse:[
+ msg := (resources string:'cannot read directory ''%1'' !!' with:fileName)
+ ]
+ ] ifFalse:[
+ msg := (resources string:'''%1'' is not a directory !!' with:fileName)
+ ].
+ self showAlert:msg with:nil
+ ]
+!
+
+doChangeToParentDirectory
+ "go to home directory"
+
+ self doChangeCurrentDirectoryTo:'..' updateHistory:true
+!
+
+doChangeToHomeDirectory
+ "go to home directory"
+
+ self doChangeCurrentDirectoryTo:(OperatingSystem getHomeDirectory) updateHistory:true
+!
+
+setCurrentDirectory:aPathName
+ "setup for another directory"
+
+ |newDirectory info|
+
+ aPathName isEmpty ifTrue:[^ self].
+ (currentDirectory isDirectory:aPathName) ifTrue:[
+ newDirectory := FileDirectory directoryNamed:aPathName in:currentDirectory.
+ newDirectory notNil ifTrue:[
+ currentDirectory := newDirectory.
+ fileListView contents:nil.
+ self updateCurrentDirectory.
+ info := self getInfoFile.
+ self showInfo:info.
+ "
+ tell my subview (whatever that is) to start its file-dialog
+ (i.e. save-as etc.) in that directory
+ "
+ (subView respondsTo:#directoryForFileDialog:) ifTrue:[
+ subView directoryForFileDialog:currentDirectory
+ ]
+ ]
+ ]
+!
+
+readFile:fileName
+ "read in the file, answer its contents as Text"
+
+ ^ self readFile:fileName lineDelimiter:Character cr
+!
+
+readStream:aStream
+ "read in from aStream, answer its contents as Text"
+
+ ^ self readStream:aStream lineDelimiter:Character cr
+!
+
+readFile:fileName lineDelimiter:aCharacter
+ "read in the file, answer its contents as Text. The files lines are delimited by aCharacter."
+
+ |stream text msg line sz|
+
+ stream := FileStream readonlyFileNamed:fileName in:currentDirectory.
+ stream isNil ifTrue:[
+ msg := (resources string:'cannot read file ''%1'' !!' with:fileName).
+ self showAlert:msg with:(FileStream lastErrorString).
+ ^ nil
+ ].
+
+ "for very big files, give ObjectMemory a hint, to preallocate more"
+ (sz := stream size) > 1000000 ifTrue:[
+ ObjectMemory moreOldSpace:sz
+ ].
+
+ text := self readStream:stream lineDelimiter:aCharacter.
+ stream close.
+ ^ text
+!
+
+readStream:aStream lineDelimiter:aCharacter
+ "read from aStream, answer its contents as Text. The files lines are delimited by aCharacter."
+
+ |text msg line|
+
+ aCharacter == Character cr ifTrue:[
+ text := aStream contents
+ ] ifFalse:[
+ text := Text new.
+ [aStream atEnd] whileFalse:[
+ line := aStream upTo:aCharacter.
+ text add:line
+ ].
+ ].
+ ^ text
+!
+
+writeFile:fileName text:someText
+ |stream msg startNr nLines string|
+
+ self withCursor:(Cursor write) do:[
+ stream := FileStream newFileNamed:fileName in:currentDirectory.
+ stream isNil ifTrue:[
+ msg := (resources string:'cannot write file ''%1'' !!' with:fileName).
+ self showAlert:msg with:(FileStream lastErrorString)
+ ] ifFalse:[
+ someText isString ifTrue:[
+ stream nextPutAll:someText.
+ ] ifFalse:[
+ "on some systems, writing linewise is very slow (via NFS)
+ therefore we convert to a string and write it in chunks
+ to avoid creating huge strings, we do it in blocks of 1000 lines
+ "
+ startNr := 1.
+ nLines := someText size.
+ [startNr <= nLines] whileTrue:[
+ string := someText asStringFrom:startNr to:((startNr + 1000) min:nLines).
+ stream nextPutAll:string.
+ startNr := startNr + 1000 + 1.
+ ].
+"/ someText do:[:line |
+"/ line notNil ifTrue:[
+"/ stream nextPutAll:line.
+"/ ].
+"/ stream cr.
+"/ ]
+ ].
+ stream close.
+ subView modified:false
+ ]
+ ]
+!
+
+doCreateDirectory:newName
+ (currentDirectory includes:newName) ifTrue:[
+ self warn:(resources string:'%1 already exists.' with:newName) withCRs.
+ ^ self
+ ].
+
+ (currentDirectory createDirectory:newName) ifTrue:[
+ self updateCurrentDirectory
+ ] ifFalse:[
+ self showAlert:(resources string:'cannot create directory ''%1'' !!' with:newName)
+ with:(OperatingSystem lastErrorString)
+ ]
+!
+
+doCreateFile:newName
+ |aStream box|
+
+ (currentDirectory includes:newName) ifTrue:[
+ box := YesNoBox new.
+ box title:(resources string:'%1 already exists\\truncate ?' with:newName) withCRs.
+ box okText:(resources string:'truncate').
+ box noText:(resources string:'cancel').
+ box noAction:[^ self].
+ box showAtPointer
+ ].
+
+ aStream := FileStream newFileNamed:newName in:currentDirectory.
+ aStream notNil ifTrue:[
+ aStream close.
+ self updateCurrentDirectory
+ ] ifFalse:[
+ self showAlert:(resources string:'cannot create file ''%1'' !!' with:newName)
+ with:(FileStream lastErrorString)
+ ]
+!
+
+showFile:fileName
+ "show contents of fileName in subView"
+
+ |buffer s n i ok convert|
+
+ ((currentDirectory typeOf:fileName) == #regular) ifFalse:[
+ "clicked on something else - ignore it ..."
+ self show:(resources string:'''%1'' is not a regular file' with:fileName).
+ ^ self
+ ].
+ "
+ check if file is a text file
+ "
+ s := FileStream readonlyFileNamed:fileName in:currentDirectory.
+ s isNil ifTrue:[
+ self showAlert:(resources string:'cannot read file ''%1'' !!' with:fileName)
+ with:(FileStream lastErrorString).
+ ^ nil
+ ].
+
+ buffer := String new:300.
+ n := s nextBytes:300 into:buffer.
+ s close.
+
+ ok := true.
+ 1 to:n do:[:i |
+ (buffer at:i) isPrintable ifFalse:[ok := false].
+ ].
+ ok ifFalse:[
+ (self confirm:(resources string:'''%1'' seems to be a binary file - continue anyway ?' with:fileName))
+ ifFalse:[^ self]
+ ].
+
+ convert := false.
+ ok ifTrue:[
+ "
+ check if line delimiter is a cr
+ "
+ i := buffer indexOf:Character cr.
+ i == 0 ifTrue:[
+ "
+ no newline found - try cr
+ "
+ i := buffer indexOf:(Character value:13).
+ i ~~ 0 ifTrue:[
+ convert := self confirm:(resources string:'''%1'' seems to have CR as line delimiter - convert to NL ?' with:fileName).
+ ]
+ ]
+ ].
+
+ "release old text first - we might need the memory in case of huge files
+ (helps if you have a 4Mb file in the view, and click on another biggy)"
+ subView contents:nil.
+
+ convert ifTrue:[
+ self show:(self readFile:fileName lineDelimiter:(Character value:13))
+ ] ifFalse:[
+ self show:(self readFile:fileName).
+ ].
+ subView acceptAction:[:theCode |
+ self writeFile:fileName text:theCode
+ ]
+!
+
+show:something
+ "show something in subview and undef acceptAction"
+
+ subView contents:something.
+ subView acceptAction:nil.
+ subView modified:false
+!
+
+doFileGet
+ "get selected file - show contents in subView"
+
+ |fileName|
+
+ self withCursor:(Cursor read) do:[
+ fileName := self getSelectedFileName.
+ fileName notNil ifTrue:[
+ (currentDirectory isDirectory:fileName) ifTrue:[
+ self doChangeCurrentDirectoryTo:fileName updateHistory:true.
+ self label:myName
+ ] ifFalse:[
+ self showFile:fileName.
+ (currentDirectory isWritable:fileName) ifFalse:[
+ self label:(myName , ': ' , fileName , ' (readonly)')
+ ] ifTrue:[
+ self label:(myName , ': ' , fileName)
+ ]
+ ]
+ ]
+ ]
+!
+
+doExecuteCommand:command replace:replace
+ "execute a unix command inserting the output of the command.
+ If replace is true, all text is replaced by the commands output;
+ otherwise, its inserted as selected text at the cursor position."
+
+ |stream line lnr myProcess myPriority startLine startCol stopSignal
+ access|
+
+ access := Semaphore forMutualExclusion.
+ stopSignal := Signal new.
+
+ "
+ must take killButton out of my group
+ "
+ windowGroup removeView:killButton.
+ "
+ bring it to front, and turn hidden-mode off
+ "
+ killButton raise.
+ killButton hidden:false.
+ "
+ it will make me raise stopSignal when pressed
+ "
+ killButton action:[
+ stream notNil ifTrue:[
+ access critical:[
+ myProcess interruptWith:[stopSignal raise].
+ ]
+ ]
+ ].
+ "
+ start it up under its own windowgroup
+ "
+ killButton openAutonomous.
+
+ "
+ go fork a pipe and read it
+ "
+ self label:(myName , ': executing ' , (command copyTo:(20 min:command size)) , ' ...').
+ [
+ self withCursor:(Cursor wait) do:[
+ stopSignal catch:[
+ startLine := subView cursorLine.
+ startCol := subView cursorCol.
+
+ stream := PipeStream readingFrom:('cd '
+ , currentDirectory pathName
+ , '; '
+ , command).
+ stream notNil ifTrue:[
+ "
+ this can be a time consuming operation; therefore lower my priority
+ "
+ myProcess := Processor activeProcess.
+ myPriority := myProcess priority.
+ myProcess priority:(Processor userBackgroundPriority).
+
+ [
+ replace ifTrue:[
+ subView list:nil.
+ lnr := 1.
+ ].
+
+ [stream atEnd] whileFalse:[
+ stream readWait.
+ line := stream nextLine.
+
+ "
+ need this critical section; otherwise,
+ we could get the signal while waiting for
+ an expose event ...
+ "
+ access critical:[
+ line notNil ifTrue:[
+ replace ifTrue:[
+ subView at:lnr put:line.
+ lnr := lnr + 1.
+ ] ifFalse:[
+ subView insertStringAtCursor:line.
+ subView insertCharAtCursor:(Character cr).
+ ]
+ ].
+
+ windowGroup processExposeEvents.
+ ].
+ "/
+ "/ give others running at same prio a chance too
+ "/
+ Processor yield
+ ].
+ ] valueNowOrOnUnwindDo:[
+ stream close. stream := nil.
+ ].
+ self updateCurrentDirectory
+ ].
+ replace ifTrue:[
+ subView modified:false.
+ ].
+ ]
+ ]
+ ] valueNowOrOnUnwindDo:[
+ |wg|
+
+ self label:myName.
+ myProcess priority:myPriority.
+
+ "
+ remove the killButton from its group
+ (otherwise, it will be destroyed when we shut down the group)
+ "
+ wg := killButton windowGroup.
+ killButton windowGroup:nil.
+ "
+ shut down the windowgroup
+ "
+ wg process terminate.
+ "
+ hide the button, and make sure it will stay
+ hidden when we are realized again
+ "
+ killButton unrealize.
+ killButton hidden:true.
+ "
+ clear its action (actually not needed, but
+ releases reference to thisContext earlier)
+ "
+ killButton action:nil.
+ ]
+!
+
+initialCommandFor:fileName into:aBox
+ "set a useful initial command for execute box.
+
+ XXX should be changed to take stuff from a config file
+ XXX or from resources."
+
+ ((currentDirectory typeOf:fileName) == #regular) ifTrue:[
+
+ (currentDirectory isExecutable:fileName) ifTrue:[
+ aBox initialText:(fileName , '<arguments>').
+ ^ self
+ ].
+
+ "some heuristics - my personal preferences ...
+ (actually this should come from a configfile)"
+
+ (fileName endsWith:'akefile') ifTrue:[
+ aBox initialText:'make target' selectFrom:6 to:11.
+ ^ self
+ ].
+ (fileName endsWith:'.tar.Z') ifTrue:[
+ aBox initialText:'zcat ' , fileName , ' | tar tvf -'.
+ ^ self
+ ].
+ (fileName endsWith:'.taz') ifTrue:[
+ aBox initialText:'zcat ' , fileName , ' | tar tvf -'.
+ ^ self
+ ].
+ (fileName endsWith:'.tar') ifTrue:[
+ aBox initialText:'tar tvf ' , fileName selectFrom:1 to:7.
+ ^ self
+ ].
+ (fileName endsWith:'.zoo') ifTrue:[
+ aBox initialText:'zoo -list ' , fileName selectFrom:1 to:9.
+ ^ self
+ ].
+ (fileName endsWith:'.zip') ifTrue:[
+ aBox initialText:'unzip -l ' , fileName selectFrom:1 to:8.
+ ^ self
+ ].
+ (fileName endsWith:'.Z') ifTrue:[
+ aBox initialText:'uncompress ' , fileName selectFrom:1 to:10.
+ ^ self
+ ].
+ (fileName endsWith:'tar.gz') ifTrue:[
+ aBox initialText:('gunzip <' , fileName , ' | tar tvf -' ).
+ ^ self
+ ].
+ (fileName endsWith:'.gz') ifTrue:[
+ aBox initialText:('gunzip <' , fileName , ' >' , (fileName copyTo:(fileName size - 3))).
+ ^ self
+ ].
+ (fileName endsWith:'.uue') ifTrue:[
+ aBox initialText:'uudecode ' , fileName selectFrom:1 to:8.
+ ^ self
+ ].
+ (fileName endsWith:'.c') ifTrue:[
+ aBox initialText:'cc -c ' , fileName selectFrom:1 to:5.
+ ^ self
+ ].
+ (fileName endsWith:'.cc') ifTrue:[
+ aBox initialText:'g++ -c ' , fileName selectFrom:1 to:6.
+ ^ self
+ ].
+ (fileName endsWith:'.C') ifTrue:[
+ aBox initialText:'g++ -c ' , fileName selectFrom:1 to:6.
+ ^ self
+ ].
+ (fileName endsWith:'.xbm') ifTrue:[
+ aBox initialText:'bitmap ' , fileName selectFrom:1 to:6.
+ ^ self
+ ].
+ ((fileName endsWith:'.ps') or:[fileName endsWith:'.PS']) ifTrue:[
+ aBox initialText:'ghostview ' , fileName selectFrom:1 to:9.
+ ^ self
+ ].
+ ((fileName endsWith:'.1')
+ or:[fileName endsWith:'.man']) ifTrue:[
+ aBox initialText:'nroff -man ' , fileName selectFrom:1 to:10.
+ ^ self
+ ].
+ aBox initialText:'<cmd> ' , fileName selectFrom:1 to:5
+ ]
+!
+
+askForCommandThenDo:aBlock
+ "setup and launch a querybox to ask for unix command.
+ Then evaluate aBlock passing the command-string as argument."
+
+ |fileName sel box|
+
+ box :=EnterBox new.
+ box initialText:''.
+
+ sel := fileListView selection.
+ (sel isKindOf:Collection) ifFalse:[
+ sel notNil ifTrue:[
+ fileName := fileList at:sel
+ ]
+ ].
+ fileName notNil ifTrue:[
+ self initialCommandFor:fileName into:box.
+ ].
+ box title:(resources at:'execute unix command:').
+ box okText:(resources at:'execute').
+ box action:aBlock.
+ box showAtPointer
+!
+
+selectedFilesDo:aBlock
+ |sel files|
+
+ sel := fileListView selection.
+ sel notNil ifTrue:[
+ (sel isKindOf:Collection) ifTrue:[
+ files := sel collect:[:index | fileList at:index].
+ files do:[:aFile |
+ aBlock value:aFile
+ ]
+ ] ifFalse:[
+ aBlock value:(fileList at:sel)
+ ]
+ ]
+
+!
+
+doRename:oldName to:newName
+ (oldName notNil and:[newName notNil]) ifTrue:[
+ (oldName isBlank or:[newName isBlank]) ifFalse:[
+ currentDirectory renameFile:oldName newName:newName.
+ self updateCurrentDirectory.
+"
+ self checkIfDirectoryHasChanged
+"
+ ]
+ ]
+!
+
+doRemove
+ "remove the selected file(s) - no questions asked"
+
+ |ok msg dir|
+
+ self withCursor:(Cursor execute) do:[
+ self selectedFilesDo:[:fileName |
+ (currentDirectory isDirectory:fileName) ifTrue:[
+ dir := FileDirectory directoryNamed:fileName in:currentDirectory.
+ dir isEmpty ifFalse:[
+ self ask:(resources string:'directory ''%1'' is not empty\remove anyway ?' with:fileName)
+ yesButton:'remove'
+ action:[currentDirectory removeDirectory:fileName]
+ ] ifTrue:[
+ currentDirectory removeDirectory:fileName
+ ].
+ ] ifFalse:[
+ ok := currentDirectory remove:fileName.
+ ok ifFalse:[
+ "was not able to remove it"
+ msg := (resources string:'cannot remove ''%1'' !!' with:fileName).
+ self showAlert:msg with:(OperatingSystem lastErrorString)
+ ] ifTrue:[
+"
+ self show:nil
+"
+ ]
+ ]
+ ].
+ self updateCurrentDirectory.
+ ]
+!
+
+onlyOneSelection
+ "show a warning, that only one file must be selected for
+ this operation"
+
+ self warn:(resources at:'exactly one file must be selected !!')
+! !
+
+!FileBrowser methodsFor:'user interaction'!
+
+fileSpawn
+ "start another FileBrowser on the selected directory or
+ on the same directory if none is selected."
+
+ |any|
+
+ any := false.
+ self selectedFilesDo:[:fileName |
+ (currentDirectory isDirectory:fileName) ifTrue:[
+ self class openOn:(currentDirectory pathName , '/' , fileName).
+ any := true
+ ]
+ ].
+ any ifFalse:[
+ self class openOn:currentDirectory pathName
+ ]
+!
+
+copyPath
+ "copy current path into cut & paste buffer"
+
+ Smalltalk at:#CopyBuffer put:(currentDirectory pathName)
+!
+
+fileExecute
+ "if text was modified show a queryBox,
+ otherwise pop up execute box immediately"
+
+ |action|
+
+"/ action := [:command| self doExecuteCommand:command replace:true].
+"/
+"/ self askIfModified:(resources at:'contents has not been saved.\\Modifications will be lost when command is executed.') withCRs
+"/ yesButton:(resources at:'execute')
+"/ action:[self askForCommandThenDo:action]
+
+ action := [:command| self doExecuteCommand:command replace:false].
+ self askForCommandThenDo:action
+!
+
+fileSelect:lineNr
+ "selected a file - do nothing here"
+ ^ self
+!
+
+fileGet
+ "if text was modified show an queryBox,
+ otherwise get it immediately"
+
+ |fileName msg label|
+
+ (subView modified not or:[subView contentsWasSaved]) ifTrue:[^ self doFileGet].
+ fileName := self getSelectedFileName.
+ fileName notNil ifTrue:[
+ (currentDirectory isDirectory:fileName) ifTrue:[
+ msg := (resources at:'contents has not been saved.\\Modifications will be lost when directory is changed.').
+ label := 'change'.
+ ] ifFalse:[
+ msg := (resources at:'contents has not been saved.\\Modifications will be lost when new file is read.').
+ label := 'get'.
+ ].
+ self ask:msg yesButton:label action:[self doFileGet]
+ ]
+!
+
+filePrint
+ |fileName inStream printStream line|
+
+ self withCursor:(Cursor execute) do:[
+ fileName := self getSelectedFileName.
+ fileName notNil ifTrue:[
+ ((currentDirectory typeOf:fileName) == #regular) ifTrue:[
+ inStream := FileStream readonlyFileNamed:fileName
+ in:currentDirectory.
+ inStream isNil ifFalse:[
+ printStream := PrinterStream new.
+ printStream notNil ifTrue:[
+ [inStream atEnd] whileFalse:[
+ line := inStream nextLine.
+ printStream nextPutAll:line.
+ printStream cr
+ ].
+ printStream close
+ ].
+ inStream close
+ ]
+ ]
+ ].
+ 0 "compiler hint"
+ ]
+!
+
+fileFileIn
+ "fileIn the selected file(s)"
+
+ |aStream upd|
+
+ self withCursor:(Cursor wait) do:[
+ self selectedFilesDo:[:fileName |
+ ((currentDirectory typeOf:fileName) == #regular) ifTrue:[
+ ((fileName endsWith:'.o')
+ or:[(fileName endsWith:'.so')
+ or:[fileName endsWith:'.obj']]) ifTrue:[
+ Object abortSignal catch:[
+ ObjectFileLoader loadObjectFile:(currentDirectory pathName , '/' ,fileName)
+ ]
+ ] ifFalse:[
+ aStream := FileStream readonlyFileNamed:fileName in:currentDirectory.
+ aStream isNil ifFalse:[
+ upd := Class updateChanges:false.
+ [
+ Smalltalk systemPath addFirst:(currentDirectory pathName).
+ aStream fileIn.
+ Smalltalk systemPath removeFirst
+ ] valueNowOrOnUnwindDo:[
+ Class updateChanges:upd.
+ aStream close
+ ]
+ ]
+ ]
+ ]
+ ]
+ ]
+!
+
+fileRemove
+ "remove the selected file(s).
+ Query if user really wants to remove the file.
+ - should be enhanced, to look for a ~/.trash directory
+ and move files there if it exists (without asking in this case)."
+
+ |sel q|
+
+ sel := fileListView selection.
+ sel notNil ifTrue:[
+ (sel isKindOf:Collection) ifTrue:[
+ q := resources string:'remove selected files ?'
+ ] ifFalse:[
+ q := resources string:'remove ''%1'' ?' with:(fileList at:sel)
+ ].
+ self ask:q yesButton:'remove' action:[self doRemove]
+ ]
+!
+
+newDirectory
+ "ask for and create a new directory"
+
+ queryBox isNil ifTrue:[
+ queryBox := FilenameEnterBox new
+ ].
+ queryBox initialText:''.
+ queryBox title:(resources at:'create new directory:') withCRs.
+ queryBox okText:(resources at:'create').
+ "queryBox abortText:(resources at:'abort')."
+ queryBox action:[:newName | self doCreateDirectory:newName].
+ queryBox showAtPointer
+!
+
+newFile
+ "ask for and create a new file"
+
+ | sel |
+
+ queryBox isNil ifTrue:[
+ queryBox := FilenameEnterBox new
+ ].
+ sel := subView selection.
+ sel notNil ifTrue:[
+ queryBox initialText:(sel asString)
+ ] ifFalse:[
+ queryBox initialText:''
+ ].
+ queryBox title:(resources at:'create new file:') withCRs.
+ queryBox okText:(resources at:'create').
+ "queryBox abortText:(resources at:'abort')."
+ queryBox action:[:newName | self doCreateFile:newName].
+ queryBox showAtPointer
+!
+
+fileRename
+ "rename the selected file(s)"
+
+ queryBox isNil ifTrue:[
+ queryBox := FilenameEnterBox new
+ ].
+ queryBox okText:(resources at:'rename').
+ "queryBox abortText:(resources at:'abort')."
+ self selectedFilesDo:[:oldName |
+ queryBox title:(resources string:'rename ''%1'' to:' with:oldName).
+ queryBox initialText:oldName.
+ queryBox action:[:newName | self doRename:oldName to:newName].
+ queryBox showAtPointer
+ ]
+!
+
+terminate
+ "exit FileBrowser"
+
+ self askIfModified:(resources at:'contents has not been saved.\\Modifications will be lost when FileBrowser is closed.') withCRs
+ yesButton:(resources at:'close')
+ action:[self destroy]
+!
+
+destroy
+ "destroy view and boxes"
+
+ ObjectMemory removeDependent:self.
+ Processor removeTimedBlock:checkBlock.
+ checkBlock := nil.
+ yesNoBox notNil ifTrue:[yesNoBox destroy. yesNoBox := nil].
+ queryBox notNil ifTrue:[queryBox destroy. queryBox := nil].
+ super destroy
+!
+
+update:what
+ (what == #aboutToExit) ifTrue:[
+ "system wants to shut down this
+ - if text was modified, pop up, and ask user and save if requested."
+
+ (subView modified and:[subView contentsWasSaved not]) ifTrue:[
+ shown ifFalse:[
+ self unrealize.
+ self realize
+ ].
+ self raise.
+ "
+ mhmh: I dont like this - need some way to tell windowGroup to handle
+ all pending exposures ...
+ "
+ self withAllSubViewsDo:[:view | view redraw].
+
+ self ask:(resources at:'FileBrowser:\\contents has not been saved.\\Save before exiting ?') withCRs
+ yesButton:'save'
+ noButton:'don''t save'
+ action:[
+ subView acceptAction notNil ifTrue:[
+ subView accept
+ ] ifFalse:[
+ subView save
+ ]
+ ]
+ ].
+ ^ self
+ ].
+ super update:what
+
+!
+
+changeDirectoryTo:aDirectoryName
+ "sent from label menu to change back to a previous directory"
+
+ self doChangeCurrentDirectoryTo:aDirectoryName updateHistory:false
+!
+
+changeCurrentDirectory
+ "if text was modified show a queryBox,
+ otherwise change immediately to directory"
+
+ self askIfModified:(resources at:'contents has not been saved.\\Modifications will be lost when directory is changed.') withCRs
+ yesButton:(resources at:'change')
+ action:[self queryForDirectoryToChange]
+!
+
+changeToParentDirectory
+ "if text was modified show a queryBox,
+ otherwise change immediately to directory"
+
+ self askIfModified:(resources at:'contents has not been saved.\\Modifications will be lost when directory is changed.') withCRs
+ yesButton:(resources at:'change')
+ action:[self doChangeToParentDirectory]
+!
+
+changeToHomeDirectory
+ "if text was modified show a queryBox,
+ otherwise change immediately to directory"
+
+ self askIfModified:(resources at:'contents has not been saved.\\Modifications will be lost when directory is changed.') withCRs
+ yesButton:(resources at:'change')
+ action:[self doChangeToHomeDirectory]
+!
+
+queryForDirectoryToChange
+ "query for new directory"
+
+ queryBox isNil ifTrue:[
+ queryBox := FilenameEnterBox new
+ ].
+ queryBox initialText:''.
+ queryBox title:(resources at:'change directory to:') withCRs.
+ queryBox okText:(resources at:'change').
+ "queryBox abortText:(resources at:'abort')."
+ queryBox action:[:newName | self doChangeCurrentDirectoryTo:newName updateHistory:true].
+ queryBox showAtPointer
+!
+
+fileGetInfo:longInfo
+ "get info on selected file - show it in a box"
+
+ |string|
+
+ string := self getFileInfoString:longInfo.
+ string notNil ifTrue:[
+ self information:string
+ ]
+!
+
+fileGetLongInfo
+ "triggered by menu: show long stat-info"
+
+ self fileGetInfo:true
+!
+
+fileGetInfo
+ "triggered by menu: show short stat-info"
+
+ self fileGetInfo:false
+!
+
+changeDisplayMode
+ "toggle from long to short listing (and vice-versa)"
+
+ |long short|
+
+ long := (resources at:'display long list').
+ short := (resources at:'display short list').
+
+ showLongList := showLongList not.
+ showLongList ifFalse:[
+ fileListView middleButtonMenu labelAt:short put:long
+ ] ifTrue:[
+ fileListView middleButtonMenu labelAt:long put:short
+ ].
+ self updateCurrentDirectory
+!
+
+changeDotFileVisibility
+ "turn on/off visibility of files whose name starts with '.'"
+
+ |show dontShow|
+
+ show := (resources at:'show all files').
+ dontShow := (resources at:'hide hidden files').
+
+ showDotFiles := showDotFiles not.
+ showDotFiles ifFalse:[
+ fileListView middleButtonMenu labelAt:dontShow put:show
+ ] ifTrue:[
+ fileListView middleButtonMenu labelAt:show put:dontShow
+ ].
+ self updateCurrentDirectory
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/SBrowser.st Sat Aug 13 20:40:49 1994 +0200
@@ -0,0 +1,4245 @@
+"{ Package: 'Programming Tools' }"
+
+"
+ COPYRIGHT (c) 1989 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+StandardSystemView subclass:#SystemBrowser
+ instanceVariableNames:'classCategoryListView classListView
+ methodCategoryListView methodListView
+ classMethodListView
+ codeView classToggle instanceToggle
+ currentClassCategory currentClassHierarchy
+ currentClass
+ currentMethodCategory currentMethod
+ showInstance actualClass fullClass
+ enterBox questBox
+ selectBox lastMethodCategory'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Interface-Browsers'
+!
+
+SystemBrowser comment:'
+COPYRIGHT (c) 1989 by Claus Gittinger
+ All Rights Reserved
+
+$Header: /cvs/stx/stx/libtool/Attic/SBrowser.st,v 1.10 1994-08-13 18:39:07 claus Exp $
+'!
+
+!SystemBrowser class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1989 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+!
+
+version
+"
+$Header: /cvs/stx/stx/libtool/Attic/SBrowser.st,v 1.10 1994-08-13 18:39:07 claus Exp $
+"
+!
+
+documentation
+"
+ this class implements all kinds of class browsers.
+ Stypically, it is started with SystemBrowser open, but there are many other startup
+ messages, to launch special browsers.
+ See the extra document 'doc/misc/sbrowser.doc' for how to use this browser.
+
+ written winter 89 by claus
+"
+! !
+
+!SystemBrowser class methodsFor:'general startup'!
+
+open
+ "launch a standard browser"
+
+ ^ self openOnDisplay:Display
+
+ "SystemBrowser open"
+!
+
+openOnDisplay:aDisplay
+ "launch a standard browser on another display.
+ Does not work currently - still being developped."
+
+ ^ self newWithLabel:(self classResources string:'System Browser')
+ setupBlock:[:browser | browser setupForAll]
+ on:aDisplay
+
+ "
+ SystemBrowser openOnDisplay:(XWorkstation new initializeFor:'porty:0')
+ "
+! !
+
+!SystemBrowser class methodsFor:'startup'!
+
+browseFullClasses
+ "launch a browser showing all methods at once"
+
+ ^ self newWithLabel:'Full Class Browser'
+ setupBlock:[:browser | browser setupForFullClass]
+
+ "SystemBrowser browseFullClasses"
+!
+
+browseClassCategory:aClassCategory
+ "launch a browser for all classes under aCategory"
+
+ ^ self newWithLabel:aClassCategory
+ setupBlock:[:browser | browser setupForClassCategory:aClassCategory]
+
+ "SystemBrowser browseClassCategory:'Kernel-Objects'"
+!
+
+browseClass:aClass
+ "launch a browser for aClass"
+
+ ^ self newWithLabel:aClass name
+ setupBlock:[:browser | browser setupForClass:aClass]
+
+ "SystemBrowser browseClass:Object"
+!
+
+browseClassHierarchy:aClass
+ "launch a browser for aClass and all its superclasses"
+
+ ^ self newWithLabel:(aClass name , '-' , 'hierarchy')
+ setupBlock:[:browser | browser setupForClassHierarchy:aClass]
+
+ "SystemBrowser browseClassHierarchy:Number"
+!
+
+browseClasses:aList title:title
+ "launch a browser for all classes in aList"
+
+ ^ self newWithLabel:title
+ setupBlock:[:browser | browser setupForClassList:aList]
+
+ "
+ SystemBrowser browseClasses:(Array with:Object
+ with:Float)
+ title:'two classes'
+ "
+!
+
+browseClass:aClass methodCategory:aCategory
+ "launch a browser for all methods under aCategory in aClass"
+
+ ^ self newWithLabel:(aClass name , ' ' , aCategory)
+ setupBlock:[:browser | browser setupForClass:aClass methodCategory:aCategory]
+
+ "SystemBrowser browseClass:String methodCategory:'copying'"
+!
+
+browseClass:aClass selector:selector
+ "launch a browser for the method at selector in aClass"
+
+ ^ self newWithLabel:(aClass name , ' ' , selector)
+ setupBlock:[:browser | browser setupForClass:aClass selector:selector]
+
+ "SystemBrowser browseClass:Object selector:#printString"
+!
+
+browseMethods:aList title:aString
+ "launch a browser for an explicit list of class/selectors"
+
+ (aList size == 0) ifTrue:[
+ self showNoneFound:aString.
+ ^ nil
+ ].
+ aList sort.
+ ^ self newWithLabel:aString
+ setupBlock:[:browser | browser setupForList:aList]
+
+ "
+ SystemBrowser browseMethods:#('Object printOn:'
+ 'Collection add:')
+ title:'some methods'
+ "
+!
+
+browseMethodCategory:aCategory
+ "launch a browser for all methods where category = aCategory"
+
+ |searchBlock|
+
+ aCategory includesMatchCharacters ifTrue:[
+ searchBlock := [:c :m :s | aCategory match:m category].
+ ] ifFalse:[
+ searchBlock := [:c :m :s | m category = aCategory]
+ ].
+
+ self browseMethodsWhere:searchBlock title:('all methods with category of ' , aCategory)
+
+ "
+ SystemBrowser browseMethodCategory:'printing & storing'
+ SystemBrowser browseMethodCategory:'print*'
+ "
+!
+
+browseAllSelect:aBlock
+ "launch a browser for all methods where aBlock returns true.
+ The block is called with 3 arguments, class, method and seelctor."
+
+ ^ self browseMethodsWhere:aBlock title:'selected messages'
+!
+
+browseMethodsWhere:aBlock title:title
+ "launch a browser for all methods where aBlock returns true.
+ The block is called with 3 arguments, class, method and seelctor."
+
+ ^ self browseMethodsIn:(Smalltalk allClasses) where:aBlock title:title
+!
+
+browseMethodsOf:aClass where:aBlock title:title
+ "launch a browser for all instance- and classmethods in aClass
+ where aBlock evaluates to true.
+ The block is called with 3 arguments, class, method and seelctor."
+
+ ^ self browseMethodsIn:(Array with:aClass) where:aBlock title:title
+!
+
+browseMethodsFrom:aClass where:aBlock title:title
+ "launch a browser for all instance- and classmethods in aClass
+ and all its subclasses where aBlock evaluates to true.
+ The block is called with 3 arguments, class, method and seelctor."
+
+ ^ self browseMethodsIn:(aClass withAllSubclasses) where:aBlock title:title
+!
+
+browseMethodsIn:aCollectionOfClasses where:aBlock title:title
+ "launch a browser for all instance- and classmethods from
+ all classes in aCollectionOfClasses where aBlock evaluates to true.
+ The block is called with 3 arguments, class, method and seelctor."
+
+ ^ self browseMethodsIn:aCollectionOfClasses inst:true class:true where:aBlock title:title
+!
+
+browseMethodsIn:aCollectionOfClasses inst:wantInst class:wantClass where:aBlock title:title
+ "launch a browser for all instance- (if wantInst is true) and/or
+ classmethods (if wantClass is true) from classes in aCollectionOfClasses,
+ where aBlock evaluates to true.
+ The block is called with 3 arguments, class, method and seelctor."
+
+ |list prio checkedClasses checkBlock|
+
+ "
+ since this may take a long time, lower my priority ...
+ "
+ prio := Processor activeProcess priority.
+ Processor activeProcess priority:(prio - 1).
+
+ checkBlock := [:cls |
+ |methodArray selectorArray|
+
+ (checkedClasses includes:cls) ifFalse:[
+ methodArray := cls methodArray.
+ selectorArray := cls selectorArray.
+
+ 1 to:methodArray size do:[:index |
+ |method sel|
+
+ method := methodArray at:index.
+ sel := selectorArray at:index.
+ (aBlock value:cls value:method value:sel) ifTrue:[
+ list add:(cls name , ' ' , sel)
+ ]
+ ].
+ checkedClasses add:cls.
+ ]
+ ].
+
+ [
+ checkedClasses := IdentitySet new.
+ list := OrderedCollection new.
+ aCollectionOfClasses do:[:aClass |
+ wantInst ifTrue:[checkBlock value:aClass].
+ wantClass ifTrue:[checkBlock value:(aClass class)]
+ ]
+ ] valueNowOrOnUnwindDo:[
+ Processor activeProcess priority:prio.
+ ].
+
+ ^ self browseMethods:list title:title
+!
+
+browseInstMethodsOf:aClass where:aBlock title:title
+ "launch a browser for all instance methods in aClass
+ where aBlock evaluates to true"
+
+ ^ self browseMethodsIn:(Array with:aClass) inst:true class:false where:aBlock title:title
+!
+
+browseInstMethodsFrom:aClass where:aBlock title:title
+ "launch a browser for all instance methods in aClass and all subclasses
+ where aBlock evaluates to true"
+
+ ^ self browseMethodsIn:(aClass withAllSubclasses) inst:true class:false where:aBlock title:title
+!
+
+browseInstMethodsIn:aCollectionOfClasses where:aBlock title:title
+ "launch a browser for all instance methods of all classes in
+ aCollectionOfClasses where aBlock evaluates to true"
+
+ ^ self browseMethodsIn:aCollectionOfClasses inst:true class:false
+ where:aBlock title:title
+! !
+
+!SystemBrowser class methodsFor:'special search startup'!
+
+browseImplementorsOf:aSelectorString in:aCollectionOfClasses title:title
+ "launch a browser for all implementors of aSelector in
+ the classes contained in aCollectionOfClasses and its metaclasses"
+
+ |list sel|
+
+ list := OrderedCollection new.
+
+ ((aSelectorString ~= '*') and:[aSelectorString includesMatchCharacters]) ifTrue:[
+ "a matchString"
+
+ aCollectionOfClasses do:[:aClass |
+ aClass selectorArray do:[:aSelector |
+ (aSelectorString match:aSelector) ifTrue:[
+ list add:(aClass name , ' ' , aSelector)
+ ]
+ ].
+ aClass class selectorArray do:[:aSelector |
+ (aSelectorString match:aSelector) ifTrue:[
+ list add:(aClass name , 'class ' , aSelector)
+ ]
+ ]
+ ]
+ ] ifFalse:[
+ "can do a faster search"
+
+ aSelectorString knownAsSymbol ifFalse:[
+ self showNoneFound:title.
+ ^ nil
+ ].
+
+ sel := aSelectorString asSymbol.
+ aCollectionOfClasses do:[:aClass |
+ (aClass implements:sel) ifTrue:[
+ list add:(aClass name , ' ' , aSelectorString)
+ ].
+ (aClass class implements:sel) ifTrue:[
+ list add:(aClass name , 'class ' , aSelectorString)
+ ]
+ ]
+ ].
+ ^ self browseMethods:list title:title
+
+ "
+ SystemBrowser browseImplementorsOf:#+
+ in:(Array with:Number
+ with:Float
+ with:SmallInteger)
+ title:'some implementors of +'
+ "
+!
+
+browseImplementorsOf:aSelectorString
+ "launch a browser for all implementors of aSelector"
+
+ ^ self browseImplementorsOf:aSelectorString
+ in:(Smalltalk allClasses)
+ title:('implementors of: ' , aSelectorString)
+
+ "
+ SystemBrowser browseImplementorsOf:#+
+ "
+!
+
+browseImplementorsOf:aSelectorString under:aClass
+ "launch a browser for all implementors of aSelector in aClass
+ and its subclasses"
+
+ ^ self browseImplementorsOf:aSelectorString
+ in:(aClass withAllSubclasses)
+ title:('implementors of: ' ,
+ aSelectorString ,
+ ' (in or below ' , aClass name , ')')
+
+ "
+ SystemBrowser browseImplementorsOf:#+ under:Integer
+ "
+!
+
+browseAllCallsOn:aSelectorString in:aCollectionOfClasses title:title
+ "launch a browser for all senders of aSelector in aCollectionOfClasses"
+
+ |sel browser searchBlock|
+
+ ((aSelectorString ~= '*') and:[aSelectorString includesMatchCharacters]) ifTrue:[
+ "a matchString"
+ searchBlock := [:lits |
+ |found|
+
+ found := false.
+ lits notNil ifTrue:[
+ lits do:[:aLiteral |
+ found ifFalse:[
+ (aLiteral isMemberOf:Symbol) ifTrue:[
+ found := (aSelectorString match:aLiteral)
+ ]
+ ]
+ ]
+ ].
+ found
+ ].
+ browser := self browseMethodsIn:aCollectionOfClasses
+ where:[:class :method :s | searchBlock value:(method literals)]
+ title:title
+ ] ifFalse:[
+ aSelectorString knownAsSymbol ifFalse:[
+"
+ Transcript showCr:'none found.'.
+"
+ self showNoneFound:title.
+ ^ nil
+ ].
+
+ sel := aSelectorString asSymbol.
+ browser := self browseMethodsIn:aCollectionOfClasses
+ where:[:class :method :s | method sends:sel]
+ title:title
+ ].
+
+ browser notNil ifTrue:[
+ browser setSearchPattern:aSelectorString
+ ].
+ ^ browser
+!
+
+browseAllCallsOn:aSelectorString
+ "launch a browser for all senders of aSelector"
+
+ ^ self browseAllCallsOn:aSelectorString
+ in:(Smalltalk allClasses)
+ title:('senders of ' , aSelectorString)
+
+ "
+ SystemBrowser browseAllCallsOn:#+
+ "
+!
+
+browseCallsOn:aSelectorString under:aClass
+ "launch a browser for all senders of aSelector in aClass and subclasses"
+
+ ^ self browseAllCallsOn:aSelectorString
+ in:(aClass withAllSubclasses)
+ title:('senders of: ' ,
+ aSelectorString ,
+ ' (in or below ' , aClass name , ')')
+
+ "
+ SystemBrowser browseAllCallsOn:#+ under:Number
+ "
+!
+
+browseForSymbol:aSymbol title:title warnIfNone:doWarn
+ "launch a browser for all methods referencing aSymbol"
+
+ |browser searchBlock sym|
+
+ (aSymbol includesMatchCharacters) ifTrue:[
+ "a matchString"
+ searchBlock := [:lits |
+ |found|
+
+ found := false.
+ lits notNil ifTrue:[
+ lits do:[:aLiteral |
+ found ifFalse:[
+ (aLiteral isMemberOf:Symbol) ifTrue:[
+ found := (aSymbol match:aLiteral)
+ ]
+ ]
+ ]
+ ].
+ found
+ ].
+ ] ifFalse:[
+ "
+ can do a faster search
+ "
+ aSymbol knownAsSymbol ifFalse:[
+ self showNoneFound:title.
+ ^ nil
+ ].
+
+ sym := aSymbol asSymbol.
+ searchBlock := [:lits |
+ |found|
+
+ found := false.
+ lits notNil ifTrue:[
+ lits do:[:aLiteral |
+ found ifFalse:[
+ (aLiteral isMemberOf:Symbol) ifTrue:[
+ found := (sym == aLiteral)
+ ]
+ ]
+ ]
+ ].
+ found
+ ].
+ ].
+ browser := self browseMethodsWhere:[:c :m :s | searchBlock value:(m literals)] title:title.
+ browser notNil ifTrue:[
+ browser setSearchPattern:aSymbol
+ ].
+ ^ browser
+!
+
+browseForSymbol:aSymbol
+ "launch a browser for all methods referencing aSymbol"
+
+ ^ self browseForSymbol:aSymbol title:('users of ' , aSymbol) warnIfNone:true
+!
+
+browseReferendsOf:aGlobalName warnIfNone:doWarn
+ "launch a browser for all methods referencing a global
+ named aGlobalName.
+ "
+
+ ^ self browseForSymbol:aGlobalName title:('users of: ' , aGlobalName) warnIfNone:doWarn
+!
+
+browseReferendsOf:aGlobalName
+ "launch a browser for all methods referencing a global
+ named aGlobalName.
+ "
+
+ ^ self browseReferendsOf:aGlobalName warnIfNone:true
+
+ "
+ Browser browseReferendsOf:#Transcript
+ "
+!
+
+browseForString:aString in:aCollectionOfClasses
+ "launch a browser for all methods in aCollectionOfClasses containing a string"
+
+ |browser searchBlock title|
+
+ title := 'methods containing: ' , aString displayString.
+
+ (aString includesMatchCharacters) ifTrue:[
+ "a matchString"
+ searchBlock := [:lits |
+ |found|
+
+ found := false.
+ lits notNil ifTrue:[
+ lits do:[:aLiteral |
+ found ifFalse:[
+ (aLiteral isMemberOf:String) ifTrue:[
+ found := (aString match:aLiteral)
+ ]
+ ]
+ ]
+ ].
+ found
+ ].
+ ] ifFalse:[
+ searchBlock := [:lits |
+ |found|
+
+ found := false.
+ lits notNil ifTrue:[
+ lits do:[:aLiteral |
+ found ifFalse:[
+ (aLiteral isMemberOf:String) ifTrue:[
+ found := (aLiteral = aString)
+ ]
+ ]
+ ]
+ ].
+ found
+ ].
+ ].
+ browser := self browseMethodsIn:aCollectionOfClasses
+ where:[:c :m :s | searchBlock value:(m literals)]
+ title:title.
+
+ browser notNil ifTrue:[
+ browser setSearchPattern:aString
+ ].
+ ^ browser
+
+ "SystemBrowser browseForString:'*all*'"
+ "SystemBrowser browseForString:'*should*'"
+ "SystemBrowser browseForString:'*[eE]rror*'"
+!
+
+browseForString:aString
+ "launch a browser for all methods containing a string"
+
+ ^ self browseForString:aString in:(Smalltalk allClasses)
+!
+
+aproposSearch:aString in:aCollectionOfClasses
+ "browse all methods, which have aString in their selector or
+ in the methods comment.
+ This is relatively slow, since all source must be processed."
+
+ |matchString list|
+
+ matchString := '*' , aString , '*'.
+
+ list := OrderedCollection new.
+
+ ^ self browseMethodsIn:aCollectionOfClasses
+ where:[:class :method :sel |
+ (matchString match:sel) ifTrue:[
+ list add:(class name , '>>' , sel)
+ ] ifFalse:[
+ (matchString match:(method comment)) ifTrue:[
+ list add:(class name , '>>' , sel)
+ ]
+ ]
+ ]
+ title:('apropos: ' , aString)
+
+ "SystemBrowser aproposSearch:'append'"
+ "SystemBrowser aproposSearch:'add'"
+ "SystemBrowser aproposSearch:'sort'"
+!
+
+aproposSearch:aString
+ "browse all methods, which have aString in their selector or
+ in the methods comment.
+ This is relatively slow, since all source must be processed."
+
+ ^ self aproposSearch:aString in:(Smalltalk allClasses)
+!
+
+browseInstRefsTo:aString in:aCollectionOfClasses modificationsOnly:modsOnly title:title
+ "launch a browser for all methods in aClass where the instVar named
+ aString is referenced; if modsOnly is true, browse only methods where the
+ instvar is modified"
+
+ |parser result instvars searchBlock browser|
+
+ searchBlock := [:c :m :s |
+ result := false.
+ parser := Parser parseMethod:(m source) in:c.
+ parser notNil ifTrue:[
+ modsOnly ifTrue:[
+ instvars := parser modifiedInstVars
+ ] ifFalse:[
+ instvars := parser usedInstVars
+ ].
+ instvars notNil ifTrue:[
+ aString includesMatchCharacters ifTrue:[
+ instvars do:[:iv |
+ (aString match:iv) ifTrue:[result := true]
+ ]
+ ] ifFalse:[
+ result := instvars includes:aString
+ ]
+ ]
+ ].
+ result
+ ].
+ browser := self browseInstMethodsIn:aCollectionOfClasses where:searchBlock title:title.
+
+ browser notNil ifTrue:[
+ browser setSearchPattern:aString
+ ].
+ ^ browser
+!
+
+browseInstRefsTo:aString in:aCollectionOfClasses modificationsOnly:modsOnly
+ "launch a browser for all methods in aClass where the instVar named
+ aString is referenced; if modsOnly is true, browse only methods where the
+ instvar is modified"
+
+ |title|
+
+ modsOnly ifTrue:[
+ title := 'modifications of '
+ ] ifFalse:[
+ title := 'references to '
+ ].
+ ^ self browseInstRefsTo:aString
+ in:aCollectionOfClasses
+ modificationsOnly:modsOnly
+ title:(title , aString)
+!
+
+browseInstRefsTo:aString under:aClass modificationsOnly:modsOnly
+ "launch a browser for all methods in aClass and subclasses
+ where the instVar named aString is referenced;
+ if modsOnly is true, browse only methods where the instvar is modified"
+
+ ^ self browseInstRefsTo:aString in:(aClass withAllSubclasses) modificationsOnly:modsOnly
+!
+
+browseClassRefsTo:aString in:aCollectionOfClasses modificationsOnly:modsOnly title:title
+ "launch a browser for all methods in aCollectionOfClasses,
+ where the classVar named aString is referenced;
+ if modsOnly is true, browse only methods where the classvar is modified"
+
+ |parser result classvars searchBlock browser|
+
+ searchBlock := [:c :m :s |
+ result := false.
+ parser := Parser parseMethod:(m source) in:c.
+ parser notNil ifTrue:[
+ modsOnly ifTrue:[
+ classvars := parser modifiedClassVars
+ ] ifFalse:[
+ classvars := parser usedClassVars
+ ].
+ classvars notNil ifTrue:[
+ aString includesMatchCharacters ifTrue:[
+ classvars do:[:cv |
+ (aString match:cv) ifTrue:[result := true]
+ ]
+ ] ifFalse:[
+ result := classvars includes:aString
+ ]
+ ]
+ ].
+ result
+ ].
+ browser := self browseMethodsIn:aCollectionOfClasses where:searchBlock title:title.
+
+ browser notNil ifTrue:[
+ browser setSearchPattern:aString
+ ].
+ ^ browser
+!
+
+browseClassRefsTo:aString in:aCollectionOfClasses modificationsOnly:modsOnly
+ "launch a browser for all methods in aClass where the classVar named
+ aString is referenced; if modsOnly is true, browse only methods where the
+ classvar is modified"
+
+ |title|
+
+ modsOnly ifTrue:[
+ title := 'modifications of '
+ ] ifFalse:[
+ title := 'references to '
+ ].
+ ^ self browseClassRefsTo:aString in:aCollectionOfClasses modificationsOnly:modsOnly title:(title , aString)
+!
+
+browseClassRefsTo:aString under:aClass modificationsOnly:modsOnly
+ "launch a browser for all methods in aClass and subclasses
+ where the classVar named aString is referenced;
+ if modsOnly is true, browse only methods where the classvar is modified"
+
+ ^ self browseClassRefsTo:aString in:(aClass withAllSubclasses) modificationsOnly:modsOnly
+! !
+
+!SystemBrowser class methodsFor:'private'!
+
+showNoneFound:what
+"/ DialogView warn:(self classResources string:('no ' , what , ' found')).
+ self showNoneFound
+!
+
+showNoneFound
+ DialogView warn:(self classResources string:'None found').
+!
+
+newWithLabel:aString setupBlock:aBlock on:aWorkstation
+ "common helper method for all creation methods"
+
+ |newBrowser|
+
+ newBrowser := self on:aWorkstation.
+ newBrowser label:aString.
+ aBlock value:newBrowser.
+
+ newBrowser open.
+ ^ newBrowser
+!
+
+newWithLabel:aString setupBlock:aBlock
+ "common helper method for all creation methods"
+
+ ^ self newWithLabel:aString setupBlock:aBlock on:Display
+! !
+
+!SystemBrowser methodsFor:'initialize / release'!
+
+initialize
+ super initialize.
+
+ self icon:(Form fromFile:(resources at:'ICON_FILE' default:'SBrowser.xbm')
+ resolution:100).
+
+ showInstance := true.
+ fullClass := false.
+
+ "inform me, when Smalltalk changes"
+ Smalltalk addDependent:self
+!
+
+destroy
+ "relese dependant - destroy popups"
+
+ Smalltalk removeDependent:self.
+ currentClass notNil ifTrue:[
+ currentClass removeDependent:self.
+ currentClass := nil
+ ].
+ enterBox notNil ifTrue:[enterBox destroy. enterBox := nil].
+ questBox notNil ifTrue:[questBox destroy. questBox := nil].
+ selectBox notNil ifTrue:[selectBox destroy. selectBox := nil].
+ super destroy
+!
+
+terminate
+ (self checkSelectionChangeAllowed) ifTrue:[
+ super terminate
+ ]
+!
+
+createTogglesIn:aFrame
+ "create and setup the class/instance toggles"
+
+ |bw halfSpacing|
+
+ instanceToggle := Toggle label:(resources at:'instance') in:aFrame.
+ bw := instanceToggle borderWidth.
+ halfSpacing := [
+ (self is3D and:[style ~~ #st80]) ifTrue:[
+ ViewSpacing // 2
+ ] ifFalse:[
+ 0
+ ]
+ ].
+ instanceToggle extent:[(aFrame width // 2 - halfSpacing value) @ instanceToggle height].
+ instanceToggle origin:[bw negated + halfSpacing value
+ @
+ (aFrame height - instanceToggle heightIncludingBorder + bw)].
+
+ instanceToggle turnOn.
+ instanceToggle pressAction:[self instanceProtocol].
+ instanceToggle releaseAction:[self classProtocol].
+
+ classToggle := Toggle label:(resources at:'class') in:aFrame.
+ classToggle extent:[(aFrame width - (aFrame width // 2) - halfSpacing value) @ classToggle height].
+ classToggle origin:[(aFrame width // 2 + halfSpacing value)
+ @
+ (aFrame height - classToggle heightIncludingBorder + bw)].
+
+ classToggle turnOff.
+ classToggle pressAction:[self classProtocol].
+ classToggle releaseAction:[self instanceProtocol]
+!
+
+createClassListViewIn:frame
+ "setup the classlist subview, with its toggles"
+
+ |v|
+
+ self createTogglesIn:frame.
+
+ v := ScrollableView for:SelectionInListView in:frame.
+ v origin:(0.0 @ 0.0)
+ extent:[frame width
+ @
+ (frame height
+ - instanceToggle height
+ - instanceToggle borderWidth)].
+
+ classListView := v scrolledView
+!
+
+createCodeViewIn:aView
+ "setup the code view"
+ |v|
+
+ v := HVScrollableView for:CodeView miniScrollerH:true miniScrollerV:false in:aView.
+ v origin:(0.0 @ 0.25) corner:(1.0 @ 1.0).
+ codeView := v scrolledView
+!
+
+setupActions
+"/ |v|
+
+"/ v := classCategoryListView.
+"/ v notNil ifTrue:[
+"/ v action:[:lineNr | self classCategorySelection:lineNr].
+"/ v selectConditionBlock:[self checkSelectionChangeAllowed].
+"/ v ignoreReselect:false.
+"/ ].
+"/ v := classListView.
+"/ v notNil ifTrue:[
+"/ v action:[:lineNr | self classSelection:lineNr].
+"/ v selectConditionBlock:[self checkSelectionChangeAllowed].
+"/ v ignoreReselect:false.
+"/ ].
+"/ v := methodCategoryListView.
+"/ v notNil ifTrue:[
+"/ v action:[:lineNr | self methodCategorySelection:lineNr].
+"/ v selectConditionBlock:[self checkSelectionChangeAllowed].
+"/ v ignoreReselect:false.
+"/ ].
+"/ v := methodListView.
+"/ v notNil ifTrue:[
+"/ v action:[:lineNr | self methodSelection:lineNr].
+"/ v selectConditionBlock:[self checkSelectionChangeAllowed].
+"/ v ignoreReselect:false.
+"/ ].
+"/ v := classMethodListView.
+"/ v notNil ifTrue:[
+"/ v action:[:lineNr | self listSelection:lineNr].
+"/ v selectConditionBlock:[self checkSelectionChangeAllowed].
+"/ v ignoreReselect:false.
+"/ ]
+!
+
+setupForAll
+ "create subviews for a full browser"
+
+ |vpanel hpanel frame v|
+
+ vpanel := VariableVerticalPanel origin:(0.0 @ 0.0) corner:(1.0 @ 1.0)
+ in:self.
+ hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
+
+ v := HVScrollableView for:SelectionInListView
+ miniScrollerH:true miniScrollerV:false
+ in:hpanel.
+ v origin:(0.0 @ 0.0) corner:(0.25 @ 1.0).
+ classCategoryListView := v scrolledView.
+"/ classCategoryListView contents:(self listOfAllClassCategories).
+
+ frame := View origin:(0.25 @ 0.0) corner:(0.5 @ 1.0) in:hpanel.
+ self createClassListViewIn:frame.
+
+ v := HVScrollableView for:SelectionInListView miniScrollerH:true miniScrollerV:false in:hpanel.
+ v origin:(0.5 @ 0.0) corner:(0.75 @ 1.0).
+ methodCategoryListView := v scrolledView.
+
+ v := HVScrollableView for:SelectionInListView miniScrollerH:true miniScrollerV:false in:hpanel.
+ v origin:(0.75 @ 0.0) corner:(1.0 @ 1.0).
+ methodListView := v scrolledView.
+
+"/ self setupActions.
+ self createCodeViewIn:vpanel
+!
+
+setupForFullClass
+ "setup subviews to browse a class as full text"
+
+ |vpanel hpanel v|
+
+ vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
+ corner:(1.0 @ 1.0)
+ in:self.
+
+ hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.0 @ 0.0) corner:(0.5 @ 1.0).
+ classCategoryListView := v scrolledView.
+ classCategoryListView contents:(self listOfAllClassCategories).
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.5 @ 0.0) corner:(1.0 @ 1.0).
+ classListView := v scrolledView.
+
+"/ self setupActions.
+ self createCodeViewIn:vpanel.
+
+ fullClass := true.
+ self updateCodeView
+!
+
+setupForClassCategory:aClassCategory
+ "setup subviews to browse a class category"
+
+ |vpanel hpanel frame v|
+
+ vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
+ corner:(1.0 @ 1.0)
+ in:self.
+
+ hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
+ frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
+
+ self createClassListViewIn:frame.
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
+ methodCategoryListView := v scrolledView.
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.66 @ 0.0) corner:(1.0 @ 1.0).
+ methodListView := v scrolledView.
+
+"/ self setupActions.
+ self createCodeViewIn:vpanel.
+
+ currentClassCategory := aClassCategory.
+ self updateClassList.
+ self updateMethodCategoryList.
+ self updateMethodList.
+ self updateCodeView
+!
+
+setupForClassList:aList
+ "setup subviews to browse classes from a list"
+
+ |vpanel hpanel frame l v|
+
+ vpanel := VariableVerticalPanel
+ origin:(0.0 @ 0.0) corner:(1.0 @ 1.0) in:self.
+
+ hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
+ frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
+
+ self createClassListViewIn:frame.
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
+ methodCategoryListView := v scrolledView.
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.66 @ 0.0) corner:(1.0 @ 1.0).
+ methodListView := v scrolledView.
+
+"/ self setupActions.
+ self createCodeViewIn:vpanel.
+
+ l := aList collect:[:entry | entry name].
+ classListView list:(l sort).
+
+ self updateMethodCategoryList.
+ self updateMethodList.
+ self updateCodeView
+!
+
+setupForClassHierarchy:aClass
+ "setup subviews to browse a class hierarchy"
+
+ |vpanel hpanel frame v|
+
+ vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
+ corner:(1.0 @ 1.0)
+ in:self.
+
+ hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
+ frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
+
+ self createClassListViewIn:frame.
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
+ methodCategoryListView := v scrolledView.
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.66 @ 0.0) corner:(1.0 @ 1.0).
+ methodListView := v scrolledView.
+
+"/ self setupActions.
+ self createCodeViewIn:vpanel.
+
+ currentClassHierarchy := aClass.
+ self updateClassList.
+ self updateMethodCategoryList.
+ self updateMethodList.
+ self updateCodeView
+!
+
+setupForClass:aClass
+ "create subviews for browsing a single class"
+
+ |vpanel hpanel frame v|
+
+ vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
+ corner:(1.0 @ 1.0)
+ in:self.
+
+ hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
+ frame := View origin:(0.0 @ 0.0) corner:(0.5 @ 1.0)in:hpanel.
+
+ self createTogglesIn:frame.
+
+ v := ScrollableView for:SelectionInListView in:frame.
+ v origin:(0.0 @ 0.0)
+ extent:[frame width
+ @
+ (frame height - instanceToggle heightIncludingBorder)].
+ methodCategoryListView := v scrolledView.
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.5 @ 0.0) corner:(1.0 @ 1.0).
+ methodListView := v scrolledView.
+
+"/ self setupActions.
+ self createCodeViewIn:vpanel.
+
+ self switchToClass:aClass.
+ actualClass := aClass.
+ self updateMethodCategoryList.
+ self updateMethodList.
+ self updateCodeView
+!
+
+setupForClass:aClass methodCategory:aMethodCategory
+ "setup subviews to browse a method category"
+
+ |vpanel v|
+
+ vpanel := VariableVerticalPanel
+ origin:(0.0 @ 0.0) corner:(1.0 @ 1.0)
+ in:self.
+
+ v := ScrollableView for:SelectionInListView in:vpanel.
+ v origin:(0.0 @ 0.0) corner:(1.0 @ 0.25).
+ methodListView := v scrolledView.
+
+"/ self setupActions.
+ self createCodeViewIn:vpanel.
+
+ currentClassCategory := aClass category.
+ self switchToClass:aClass.
+ actualClass := aClass.
+ currentMethodCategory := aMethodCategory.
+ self updateMethodList.
+ self updateCodeView
+!
+
+setupForClass:aClass selector:selector
+ "setup subviews to browse a single method"
+
+ |v|
+
+ v := ScrollableView for:CodeView in:self.
+ v origin:(0.0 @ 0.0) corner:(1.0 @ 1.0).
+ codeView := v scrolledView.
+
+ currentClassCategory := aClass category.
+ self switchToClass:aClass.
+ actualClass := aClass.
+ currentMethod := currentClass compiledMethodAt:selector.
+ currentMethodCategory := currentMethod category.
+ self updateCodeView
+!
+
+setupForList:aList
+ "setup subviews to browse methods from a list"
+
+ |vpanel v|
+
+ vpanel := VariableVerticalPanel
+ origin:(0.0 @ 0.0)
+ corner:(1.0 @ 1.0)
+ in:self.
+
+ v := ScrollableView for:SelectionInListView in:vpanel.
+ v origin:(0.0 @ 0.0) corner:(1.0 @ 0.25).
+ classMethodListView := v scrolledView.
+ classMethodListView contents:aList.
+
+"/ self setupActions.
+ self createCodeViewIn:vpanel.
+
+ self updateCodeView
+! !
+
+!SystemBrowser methodsFor:'realization'!
+
+realize
+ |v|
+
+ super realize.
+
+ v := classCategoryListView.
+ v notNil ifTrue:[
+ v action:[:lineNr | self classCategorySelection:lineNr].
+ v selectConditionBlock:[self checkSelectionChangeAllowed].
+ v ignoreReselect:false.
+ v contents:(self listOfAllClassCategories).
+ self initializeClassCategoryMenu
+ ].
+
+ v := classListView.
+ v notNil ifTrue:[
+ v action:[:lineNr | self classSelection:lineNr].
+ v selectConditionBlock:[self checkSelectionChangeAllowed].
+ v ignoreReselect:false.
+ self initializeClassMenu
+ ].
+
+ v := methodCategoryListView.
+ v notNil ifTrue:[
+ v action:[:lineNr | self methodCategorySelection:lineNr].
+ v selectConditionBlock:[self checkSelectionChangeAllowed].
+ v ignoreReselect:false.
+ self initializeMethodCategoryMenu
+ ].
+
+ v := methodListView.
+ v notNil ifTrue:[
+ v action:[:lineNr | self methodSelection:lineNr].
+ v selectConditionBlock:[self checkSelectionChangeAllowed].
+ v ignoreReselect:false.
+ self initializeMethodMenu
+ ].
+
+ v := classMethodListView.
+ v notNil ifTrue:[
+ v action:[:lineNr | self listSelection:lineNr].
+ v selectConditionBlock:[self checkSelectionChangeAllowed].
+ v ignoreReselect:false.
+ self initializeClassMethodMenu
+ ]
+! !
+
+!SystemBrowser methodsFor:'private'!
+
+checkSelectionChangeAllowed
+ "return true, if selection change is ok;
+ its not ok, if code has been changed.
+ in this case, return the result of a user query"
+
+ |box|
+
+ codeView modified ifFalse:[
+ ^ true
+ ].
+ box := questBox.
+ box isNil ifTrue:[
+ box := questBox := YesNoBox title:''
+ ].
+
+ box title:(resources at:'contents in codeview has not been accepted.\\Modifications will be lost when continuing.') withCRs.
+ box okText:(resources at:'continue').
+ box noText:(resources at:'abort').
+ box yesAction:[^ true] noAction:[^ false].
+ box showAtPointer
+!
+
+switchToClass:newClass
+ currentClass notNil ifTrue:[
+ currentClass removeDependent:self
+ ].
+ currentClass := newClass.
+ currentClass notNil ifTrue:[
+ currentClass addDependent:self
+ ]
+!
+
+showExplanation:someText
+ "show explanation from Parser"
+
+ self notify:someText
+!
+
+setSearchPattern:aString
+ codeView setSearchPattern:aString
+!
+
+selectorToSearchFor
+ "look in codeView and methodListView for a search-string when searching for selectors"
+
+ |sel t|
+
+ sel := codeView selection.
+ sel notNil ifTrue:[
+ sel := sel asString.
+ t := Parser selectorInExpression:sel.
+ t notNil ifTrue:[
+ sel := t
+ ].
+ sel := sel withoutSpaces
+ ] ifFalse:[
+ methodListView notNil ifTrue:[
+ sel := methodListView selectionValue
+ ] ifFalse:[
+ classMethodListView notNil ifTrue:[
+ sel := classMethodListView selectionValue.
+ sel notNil ifTrue:[
+ sel := self selectorFromClassMethodString:sel
+ ]
+ ]
+ ].
+ sel notNil ifTrue:[
+ sel := sel withoutSpaces
+ ] ifFalse:[
+ sel := ''
+ ]
+ ].
+ ^ sel
+!
+
+stringToSearchFor
+ "look in codeView and methodListView for a search-string when searching for classes/names"
+
+ |sel|
+
+ sel := codeView selection.
+ sel notNil ifTrue:[
+ sel := sel asString withoutSpaces
+ ] ifFalse:[
+ sel isNil ifTrue:[
+ currentClass notNil ifTrue:[
+ sel := currentClass name
+ ]
+ ].
+ sel notNil ifTrue:[
+ sel := sel withoutSpaces
+ ] ifFalse:[
+ sel := ''
+ ]
+ ].
+ ^ sel
+!
+
+findClassOfVariable:aVariableName accessWith:aSelector
+ "this method returns the class, in which a variable
+ is defined;
+ needs either #instVarNames or #classVarNames as aSelector."
+
+ |cls homeClass|
+
+ "
+ first, find the class, where the variable is declared
+ "
+ cls := currentClass.
+ [cls notNil] whileTrue:[
+ ((cls perform:aSelector) includes:aVariableName) ifTrue:[
+ homeClass := cls.
+ cls := nil.
+ ] ifFalse:[
+ cls := cls superclass
+ ]
+ ].
+ homeClass isNil ifTrue:[
+ "nope, must be one below ... (could optimize a bit, by searching down
+ for the declaring class ...
+ "
+ homeClass := currentClass
+ ] ifFalse:[
+ Transcript showCr:'starting search in ' , homeClass name.
+ ].
+ ^ homeClass
+!
+
+listBoxTitle:title okText:okText list:aList
+ "convenient method: setup a listBox"
+
+ |box|
+
+ box := selectBox.
+ box isNil ifTrue:[
+ box := selectBox := ListSelectionBox
+ title:''
+ okText:(resources string:'ok')
+ abortText:(resources string:'abort')
+ action:[:aString | ]
+ ].
+ box title:(resources string:title).
+ box list:aList.
+!
+
+enterBoxTitle:title okText:okText
+ "convenient method: setup enterBox"
+
+ |box|
+
+ box := enterBox.
+ box isNil ifTrue:[
+ box := enterBox := EnterBox new
+ ].
+ box title:(resources string:title) okText:(resources string:okText).
+ box initialText:''
+!
+
+enterBoxForSearchSelectorTitle:title
+ "convenient method: setup enterBox with text from codeView or selected
+ method for browsing based on a selector"
+
+ self enterBoxTitle:title okText:'search'.
+ enterBox initialText:(self selectorToSearchFor)
+!
+
+enterBoxForBrowseSelectorTitle:title
+ "convenient method: setup enterBox with text from codeView or selected
+ method for browsing based on a selector"
+
+ self enterBoxTitle:title okText:'browse'.
+ enterBox initialText:(self selectorToSearchFor)
+!
+
+enterBoxForBrowseTitle:title
+ "convenient method: setup enterBox with text from codeView or selected
+ method for method browsing based on className/variable"
+
+ self enterBoxTitle:title okText:'browse'.
+ enterBox initialText:(self stringToSearchFor)
+!
+
+enterBoxForCodeSelectionTitle:title okText:okText
+ "convenient method: setup enterBox with text from codeview"
+
+ |sel|
+
+ self enterBoxTitle:(resources string:title) okText:(resources string:okText).
+ sel := codeView selection.
+ sel notNil ifTrue:[
+ enterBox initialText:(sel asString withoutSeparators)
+ ] ifFalse:[
+ enterBox initialText:nil
+ ]
+!
+
+enterBoxForMethodCategory:title
+ "convenient method: setup enterBox with initial being current method category"
+
+ |sel|
+
+ self enterBoxTitle:title okText:'browse'.
+ sel := codeView selection.
+ sel isNil ifTrue:[
+ currentMethodCategory notNil ifTrue:[
+ sel := currentMethodCategory
+ ]
+ ].
+ sel notNil ifTrue:[
+ enterBox initialText:(sel asString withoutSpaces)
+ ]
+!
+
+newClassCategory:aString
+ |categories|
+
+ categories := classCategoryListView list.
+ (categories includes:aString) ifFalse:[
+ categories add:aString.
+ categories sort.
+ classCategoryListView setContents:categories.
+ currentClassCategory := aString.
+ classCategoryListView selectElement:aString.
+ self switchToClass:nil.
+ actualClass := nil.
+ self classCategorySelectionChanged
+ ]
+!
+
+listOfAllClassCategories
+ "return a list of all class categories"
+
+ |newList cat|
+
+ newList := Text with:'* all *' with:'* hierarchy *'.
+ Smalltalk allBehaviorsDo:[:aClass |
+ cat := aClass category.
+ cat isNil ifTrue:[
+ cat := '* no category *'
+ ].
+ newList indexOf:cat ifAbsent:[newList add:cat]
+ ].
+ newList sort.
+ ^ newList
+!
+
+listOfClassHierarchyOf:aClass
+ "return a hierarchy class-list"
+
+ ^ (aClass allSuperclasses reverse ,
+ (Array with:aClass),
+ aClass allSubclassesInOrder) collect:[:c | c name]
+
+"
+ |newList theClass|
+
+ theClass := aClass.
+ newList := Text with:theClass name.
+ [theClass ~~ Object] whileTrue:[
+ theClass := theClass superclass.
+ newList add:theClass name
+ ].
+ newList reverse.
+ ^ newList
+"
+!
+
+listOfAllClassesInCategory:aCategory
+ "return a list of all classes in a given category"
+
+ |newList classList searchCategory string|
+
+ newList := Text new.
+ (aCategory = '* all *') ifTrue:[
+ Smalltalk allBehaviorsDo:[:aClass |
+ string := aClass name.
+ newList indexOf:string ifAbsent:[newList add:string]
+ ]
+ ] ifFalse:[
+ (aCategory = '* hierarchy *') ifTrue:[
+ classList := Text new.
+ self classHierarchyDo:[:aClass :lvl|
+ string := aClass name.
+ classList indexOf:string ifAbsent:[
+ classList add:string.
+ newList add:(String new:lvl) , string
+ ]
+ ].
+ ^ newList
+ ] ifFalse:[
+ (aCategory = '* no category *') ifTrue:[
+ searchCategory := nil
+ ] ifFalse:[
+ searchCategory := aCategory
+ ].
+ Smalltalk allBehaviorsDo:[:aClass |
+ aClass isMeta ifFalse:[
+ (aClass category = searchCategory) ifTrue:[
+ string := aClass name.
+ newList indexOf:string ifAbsent:[newList add:string]
+ ]
+ ]
+ ]
+ ]
+ ].
+ (newList size == 0) ifTrue:[^ nil].
+ ^ newList sort
+!
+
+classHierarchyDo:aBlock
+ "eavluate the 2-arg block for every class,
+ starting at Object; passing class and nesting level to the block."
+
+ |classes s classDict l|
+
+ classes := Smalltalk allClasses.
+ classDict := IdentityDictionary new:classes size.
+ classes do:[:aClass |
+ s := aClass superclass.
+ s notNil ifTrue:[
+ l := classDict at:s ifAbsent:[nil].
+ l isNil ifTrue:[
+ l := OrderedCollection new:5.
+ classDict at:s put:l
+ ].
+ l add:aClass
+ ]
+ ].
+ self classHierarchyOf:Object level:0 do:aBlock using:classDict
+!
+
+classHierarchyOf:aClass level:level do:aBlock using:aDictionary
+ "evaluate the 2-arg block for every subclass of aClass,
+ passing class and nesting level to the block."
+
+ |names subclasses|
+
+ aBlock value:aClass value:level.
+ subclasses := aDictionary at:aClass ifAbsent:[nil].
+ (subclasses size == 0) ifFalse:[
+ names := subclasses collect:[:class | class name].
+ names sortWith:subclasses.
+ subclasses do:[:aSubClass |
+ self classHierarchyOf:aSubClass level:(level + 1) do:aBlock using:aDictionary
+ ]
+ ]
+!
+
+listOfAllMethodCategoriesInClass:aClass
+ "answer a list of all method categories of the argument, aClass"
+
+ |newList cat|
+
+ newList := Text new.
+ aClass methodArray do:[:aMethod |
+ cat := aMethod category.
+ cat isNil ifTrue:[
+ cat := '* no category *'
+ ].
+ (newList includes:cat) ifFalse:[newList add:cat]
+ ].
+ (newList size == 0) ifTrue:[^ nil].
+ newList add:'* all *'.
+ ^ newList sort
+!
+
+listOfAllSelectorsInCategory:aCategory ofClass:aClass
+ "answer a list of all selectors in a given method category
+ of the argument, aClass"
+
+ |newList searchCategory selector|
+
+ (aCategory = '* all *') ifTrue:[
+ newList := aClass selectorArray asText
+ ] ifFalse:[
+ (aCategory = '* no category *') ifTrue:[
+ searchCategory := nil
+ ] ifFalse:[
+ searchCategory := aCategory
+ ].
+ newList := Text new.
+ aClass methodArray do:[:aMethod |
+ (aMethod category = searchCategory) ifTrue:[
+ selector := aClass selectorForMethod:aMethod.
+ selector notNil ifTrue:[
+ aMethod isWrapped ifTrue:[
+ selector := selector , ' !!'
+ ].
+ (newList includes:selector) ifFalse:[
+ newList add:selector
+ ]
+ ]
+ ]
+ ]
+ ].
+ (newList size == 0) ifTrue:[^ nil].
+ ^ newList sort
+!
+
+templateFor:className in:cat
+ "return a class definition template - be smart in what is offered initially"
+
+ |aString name i|
+
+ name := 'NewClass'.
+ i := 1.
+ [name knownAsSymbol and:[Smalltalk includesKey:name asSymbol]] whileTrue:[
+ i := i + 1.
+ name := 'NewClass' , i printString
+ ].
+
+ aString := className , ' subclass:#' , name , '
+ instanceVariableNames: ''''
+ classVariableNames: ''''
+ poolDictionaries: ''''
+ category: '''.
+
+ cat notNil ifTrue:[
+ aString := aString , cat
+ ].
+ aString := aString , ''''.
+ ^ aString
+!
+
+template
+ "return a method definition template"
+
+ ^
+'message selector and argument names
+ "comment stating purpose of message"
+
+
+ |temporaries|
+ statements
+'
+!
+
+compileCode:someCode
+ (ReadStream on:someCode) fileIn
+! !
+
+!SystemBrowser methodsFor:'user interaction'!
+
+instanceProtocol
+ showInstance ifFalse:[
+ self checkSelectionChangeAllowed ifTrue:[
+ classToggle turnOff.
+ instanceToggle turnOn.
+ showInstance := true.
+ currentClass notNil ifTrue:[
+ self classSelectionChanged
+ ].
+ codeView modified:false.
+ ] ifFalse:[
+ instanceToggle turnOff.
+ classToggle turnOn
+ ]
+ ]
+!
+
+classProtocol
+ showInstance ifTrue:[
+ self checkSelectionChangeAllowed ifTrue:[
+ instanceToggle turnOff.
+ classToggle turnOn.
+ showInstance := false.
+ currentClass notNil ifTrue:[
+ self classSelectionChanged
+ ].
+ codeView modified:false.
+ ] ifFalse:[
+ instanceToggle turnOn.
+ classToggle turnOff
+ ]
+ ]
+!
+
+updateClassCategoryListWithScroll:scroll
+ |oldClassCategory oldClass oldMethodCategory oldMethod
+ oldSelector newCategoryList|
+
+ classMethodListView notNil ifTrue:[ ^ self ].
+
+ oldClassCategory := currentClassCategory.
+ oldClass := currentClass.
+ oldMethodCategory := currentMethodCategory.
+ oldMethod := currentMethod.
+ oldMethod notNil ifTrue:[
+ oldSelector := methodListView selectionValue
+ ].
+
+ classCategoryListView notNil ifTrue:[
+ newCategoryList := self listOfAllClassCategories.
+ newCategoryList = classCategoryListView list ifFalse:[
+ scroll ifTrue:[
+ classCategoryListView contents:newCategoryList
+ ] ifFalse:[
+ classCategoryListView setContents:newCategoryList
+ ]
+ ]
+ ].
+
+ oldClassCategory notNil ifTrue:[
+ classCategoryListView notNil ifTrue:[
+ classCategoryListView selectElement:oldClassCategory
+ ]
+ ].
+ classListView notNil ifTrue:[
+ oldClass notNil ifTrue:[
+ classListView selectElement:(oldClass name)
+ ]
+ ].
+ oldMethodCategory notNil ifTrue:[
+ methodCategoryListView notNil ifTrue:[
+ methodCategoryListView selectElement:oldMethodCategory
+ ].
+ ].
+ oldSelector notNil ifTrue:[
+ methodListView notNil ifTrue:[
+ methodListView selectElement:oldSelector
+ ].
+ ]
+!
+
+updateClassCategoryList
+ self updateClassCategoryListWithScroll:true
+!
+
+updateClassListWithScroll:scroll
+ |classes oldClassName|
+
+ classListView notNil ifTrue:[
+ currentClass notNil ifTrue:[
+ oldClassName := currentClass name.
+ currentClass := Smalltalk at:(oldClassName asSymbol).
+ ].
+
+ currentClassCategory notNil ifTrue:[
+ classes := self listOfAllClassesInCategory:currentClassCategory
+ ] ifFalse:[
+ currentClassHierarchy notNil ifTrue:[
+ classes := self listOfClassHierarchyOf:currentClassHierarchy
+ ]
+ ].
+
+ classListView list = classes ifFalse:[
+ scroll ifTrue:[
+ classListView contents:classes
+ ] ifFalse:[
+ classListView setContents:classes
+ ].
+ oldClassName notNil ifTrue:[
+ classListView setContents:classes.
+ classListView selectElement:oldClassName
+ ].
+ ]
+ ]
+!
+
+updateClassList
+ self updateClassListWithScroll:true
+!
+
+updateMethodCategoryListWithScroll:scroll
+ |categories|
+
+ methodCategoryListView notNil ifTrue:[
+ currentClass notNil ifTrue:[
+ categories := self listOfAllMethodCategoriesInClass:actualClass
+ ].
+ methodCategoryListView list = categories ifFalse:[
+ scroll ifTrue:[
+ methodCategoryListView contents:categories
+ ] ifFalse:[
+ methodCategoryListView setContents:categories
+ ].
+ currentMethodCategory notNil ifTrue:[
+ methodCategoryListView selectElement:currentMethodCategory
+ ]
+ ]
+ ]
+!
+
+updateMethodCategoryList
+ self updateMethodCategoryListWithScroll:true
+!
+
+updateMethodListWithScroll:scroll
+ |selectors scr first last|
+
+ methodListView notNil ifTrue:[
+ currentMethodCategory notNil ifTrue:[
+ selectors := self listOfAllSelectorsInCategory:currentMethodCategory
+ ofClass:actualClass
+ ].
+ scr := scroll.
+ first := methodListView firstLineShown.
+ first ~~ 1 ifTrue:[
+ last := methodListView lastLineShown.
+ selectors size <= (last - first + 1) ifTrue:[
+ scr := true
+ ]
+ ].
+ methodListView list = selectors ifFalse:[
+ scr ifTrue:[
+ methodListView contents:selectors
+ ] ifFalse:[
+ methodListView setContents:selectors
+ ]
+ ].
+ ]
+!
+
+updateMethodList
+ self updateMethodListWithScroll:true
+!
+
+updateCodeView
+ |code aStream|
+
+ fullClass ifTrue:[
+ currentClass notNil ifTrue:[
+" this is too slow for big classes ...
+ code := String new:1000.
+ aStream := WriteStream on:code.
+ currentClass fileOutOn:aStream
+"
+ aStream := FileStream newFileNamed:'__temp'.
+ aStream isNil ifTrue:[
+ self notify:'cannot create temporary file.'.
+ codeView contents:nil.
+ codeView modified:false.
+ ^ self
+ ].
+ currentClass fileOutOn:aStream.
+ aStream close.
+ aStream := FileStream oldFileNamed:'__temp'.
+ aStream isNil ifTrue:[
+ self notify:'oops - cannot reopen temp file'.
+ codeView contents:nil.
+ codeView modified:false.
+ ^ self
+ ].
+ code := aStream contents.
+ aStream close.
+ OperatingSystem removeFile:'__temp'
+ ]
+ ] ifFalse:[
+ currentMethod notNil ifTrue:[
+ code := currentMethod source
+ ]
+ ].
+ codeView contents:code.
+ codeView modified:false
+!
+
+classSelectionChanged
+ |oldMethodCategory oldMethod|
+
+ self withWaitCursorDo:[
+ oldMethodCategory := currentMethodCategory.
+ oldMethod := currentMethod.
+
+ showInstance ifTrue:[
+ actualClass := currentClass
+ ] ifFalse:[
+ actualClass := currentClass class
+ ].
+ currentMethodCategory := nil.
+ currentMethod := nil.
+
+ self updateMethodCategoryList.
+ oldMethodCategory notNil ifTrue:[
+ methodCategoryListView selectElement:oldMethodCategory.
+ methodCategoryListView selection notNil ifTrue:[
+ currentMethodCategory := oldMethodCategory.
+ self methodCategorySelectionChanged
+ ]
+ ].
+ self updateMethodList.
+ self updateCodeView.
+
+ fullClass ifTrue:[
+ codeView acceptAction:[:theCode |
+ codeView cursor:Cursor execute.
+ Object abortSignal catch:[
+ self compileCode:theCode asString.
+ codeView modified:false.
+ ].
+ codeView cursor:Cursor normal.
+ ].
+ codeView explainAction:nil
+ ] ifFalse:[
+ self classDefinition.
+ codeView acceptAction:[:theCode |
+ codeView cursor:Cursor execute.
+ Object abortSignal catch:[
+ (Compiler evaluate:theCode asString notifying:codeView)
+ isBehavior ifTrue:[
+ self classCategoryUpdate.
+ self updateClassListWithScroll:false.
+ codeView modified:false.
+ ].
+ ].
+ codeView cursor:Cursor normal.
+ ].
+ codeView explainAction:nil
+ ].
+ classCategoryListView notNil ifTrue:[
+ (currentClassCategory = currentClass category) ifFalse:[
+ currentClassCategory := currentClass category.
+ classCategoryListView selectElement:currentClassCategory
+ ]
+ ].
+
+ "set self for doits. This allows accessing the current class
+ as self, and access to the class variables by name."
+
+ codeView doItAction:[:theCode |
+ |compiler|
+
+ currentClass isNil ifTrue:[
+ compiler := Compiler
+ ] ifFalse:[
+ compiler := currentClass compiler
+ ].
+ compiler
+ evaluate:theCode
+ in:nil
+ receiver:currentClass
+ notifying:codeView
+ logged:false
+ ifFail:nil
+ ]
+ ]
+!
+
+classCategorySelectionChanged
+ "class category has changed - update dependant views"
+
+ self withWaitCursorDo:[
+ self switchToClass:nil.
+ actualClass := nil.
+ currentMethodCategory := nil.
+ currentMethod := nil.
+
+ self updateClassList.
+ self updateMethodCategoryList.
+ self updateMethodList.
+ self updateCodeView.
+
+ codeView explainAction:nil.
+ codeView acceptAction:nil
+ ]
+!
+
+classCategorySelection:lineNr
+ "user clicked on a class category line - show classes.
+ If switching to hierarchy or all, keep current selections"
+
+ |newCategory oldClass classIndex index|
+
+ newCategory := classCategoryListView selectionValue.
+ (newCategory startsWith:'*') ifTrue:[
+ "etiher all or hierarchy;
+ remember current selections and switch after showing class list"
+ oldClass := currentClass
+ ].
+ currentClassCategory := newCategory.
+ oldClass isNil ifTrue:[
+ self classCategorySelectionChanged
+ ] ifFalse:[
+ self withWaitCursorDo:[
+ self updateClassList
+ ].
+ "stupid - search for class name in (indented) list"
+ index := 1.
+ classListView list do:[:elem |
+ (elem endsWith:(oldClass name)) ifTrue:[
+ classIndex := index
+ ].
+ index := index + 1
+ ].
+ classIndex notNil ifTrue:[
+ classListView selection:classIndex.
+ self switchToClass:(Smalltalk at:(oldClass name asSymbol))
+ ]
+ ]
+!
+
+classSelection:lineNr
+ "user clicked on a class line - show method categories"
+
+ |classSymbol cls|
+
+ classSymbol := classListView selectionValue withoutSpaces asSymbol.
+ (Smalltalk includesKey:classSymbol) ifTrue:[
+ cls := Smalltalk at:classSymbol
+ ].
+ cls notNil ifTrue:[
+ self switchToClass:cls.
+ self classSelectionChanged
+ ]
+!
+
+methodCategorySelectionChanged
+ "method category selection has changed - update dependant views"
+
+ self withWaitCursorDo:[
+ currentMethod := nil.
+
+ self updateMethodList.
+ self updateCodeView.
+
+ currentMethodCategory notNil ifTrue:[
+ methodCategoryListView selectElement:currentMethodCategory
+ ].
+
+ codeView acceptAction:[:theCode |
+ codeView cursor:Cursor execute.
+ Object abortSignal catch:[
+ actualClass compiler compile:theCode asString
+ forClass:actualClass
+ inCategory:currentMethodCategory
+ notifying:codeView.
+ codeView modified:false.
+ self updateMethodListWithScroll:false.
+ ].
+ codeView cursor:Cursor normal.
+ ].
+ codeView explainAction:[:theCode :theSelection |
+ self showExplanation:(Explainer explain:theSelection
+ in:theCode
+ forClass:actualClass)
+ ]
+ ]
+!
+
+methodCategorySelection:lineNr
+ "user clicked on a method category line - show selectors"
+
+ currentClass isNil ifTrue:[^ self].
+
+ currentMethodCategory := methodCategoryListView selectionValue.
+ self methodCategorySelectionChanged
+!
+
+methodSelectionChanged
+ "method selection has changed - update dependant views"
+
+ self withWaitCursorDo:[
+ self updateCodeView.
+ codeView acceptAction:[:theCode |
+ codeView cursor:Cursor execute.
+ Object abortSignal catch:[
+ actualClass compiler compile:theCode asString
+ forClass:actualClass
+ inCategory:currentMethodCategory
+ notifying:codeView.
+ codeView modified:false.
+ self updateMethodListWithScroll:false.
+ ].
+ codeView cursor:Cursor normal.
+ ].
+ codeView explainAction:[:theCode :theSelection |
+ self showExplanation:(Explainer explain:theSelection
+ in:theCode
+ forClass:actualClass)
+ ].
+ methodListView notNil ifTrue:[
+ (currentMethod notNil and:[currentMethod isWrapped]) ifTrue:[
+ self initializeMethodMenu2
+ ] ifFalse:[
+ self initializeMethodMenu
+ ]
+ ]
+ ]
+!
+
+methodSelection:lineNr
+ "user clicked on a method line - show code"
+
+ |selectorString selectorSymbol|
+
+ currentClass isNil ifTrue:[^ self].
+
+ selectorString := methodListView selectionValue.
+ "
+ kludge: check if its a wrapped one
+ "
+ (selectorString endsWith:' !!') ifTrue:[
+ selectorString := selectorString copyTo:(selectorString size - 2)
+ ].
+ selectorSymbol := selectorString asSymbol.
+ currentMethod := actualClass compiledMethodAt:selectorSymbol.
+
+ methodCategoryListView notNil ifTrue:[
+ currentMethod notNil ifTrue:[
+ (currentMethodCategory = currentMethod category) ifFalse:[
+ currentMethodCategory := currentMethod category.
+ methodCategoryListView selectElement:currentMethodCategory
+ ]
+ ]
+ ].
+
+ self methodSelectionChanged
+!
+
+classFromClassMethodString:aString
+ "helper for classMethod-list - extract class name from the string"
+
+ |pos|
+
+ pos := aString indexOf:(Character space).
+ ^ aString copyTo:(pos - 1)
+!
+
+selectorFromClassMethodString:aString
+ "helper for classMethod-list - extract selector from the string"
+
+ |pos|
+
+ pos := aString indexOf:(Character space).
+ ^ aString copyFrom:(pos + 1)
+!
+
+listSelection:lineNr
+ "user clicked on a class/method line - show code"
+
+ |string classString selectorString|
+
+ string := classMethodListView selectionValue.
+ classString := self classFromClassMethodString:string.
+ selectorString := self selectorFromClassMethodString:string.
+ ((classString ~= 'Metaclass') and:[classString endsWith:'class']) ifTrue:[
+ classString := classString copyTo:(classString size - 5).
+ self switchToClass:(Smalltalk at:classString asSymbol).
+ actualClass := currentClass class
+ ] ifFalse:[
+ self switchToClass:(Smalltalk at:classString asSymbol).
+ actualClass := currentClass
+ ].
+ currentClass isNil ifTrue:[
+ self warn:'oops class is gone'
+ ] ifFalse:[
+ currentClassCategory := currentClass category.
+ currentMethod := actualClass compiledMethodAt:(selectorString asSymbol).
+ currentMethodCategory := currentMethod category.
+
+ self methodSelectionChanged
+ ]
+! !
+
+!SystemBrowser methodsFor:'class category menu'!
+
+initializeClassCategoryMenu
+ |labels|
+
+ labels := resources array:#(
+ 'fileOut'
+ 'fileOut each'
+"
+ 'fileOut binary'
+"
+ 'printOut'
+ 'printOut protocol'
+ '-'
+ 'spawn'
+ 'spawn class'
+ '-'
+ 'update'
+ 'find class ...'
+ '-'
+ 'new class category ...'
+ 'rename ...'
+ 'remove').
+
+ classCategoryListView
+ middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:#(classCategoryFileOut
+ classCategoryFileOutEach
+"
+ classCategoryBinaryFileOut
+"
+ classCategoryPrintOut
+ classCategoryPrintOutProtocol
+ nil
+ classCategorySpawn
+ classCategorySpawnFullClass
+ nil
+ classCategoryUpdate
+ classCategoryFindClass
+ nil
+ classCategoryNewCategory
+ classCategoryRename
+ classCategoryRemove)
+ receiver:self
+ for:classCategoryListView)
+!
+
+allClassesInCurrentCategoryInOrderDo:aBlock
+ "evaluate aBlock for all classes in the current class category;
+ superclasses come first - then subclasses"
+
+ |classes|
+
+ currentClassCategory notNil ifTrue:[
+ classes := OrderedCollection new.
+ Smalltalk allClassesDo:[:aClass |
+ aClass isMeta ifFalse:[
+ (aClass category = currentClassCategory) ifTrue:[
+ classes add:aClass
+ ]
+ ]
+ ].
+ classes topologicalSort:[:a :b | b isSubclassOf:a].
+ classes do:aBlock
+ ]
+!
+
+allClassesInCurrentCategoryDo:aBlock
+ "evaluate aBlock for all classes in the current class category;
+ superclasses come first - then subclasses"
+
+ currentClassCategory notNil ifTrue:[
+ Smalltalk allClassesDo:[:aClass |
+ aClass isMeta ifFalse:[
+ (aClass category = currentClassCategory) ifTrue:[
+ aBlock value:aClass
+ ]
+ ]
+ ].
+ ]
+!
+
+classCategoryUpdate
+ "update class category list and dependants"
+
+ |oldClassName oldMethodCategory|
+
+ classCategoryListView notNil ifTrue:[
+ currentClass notNil ifTrue:[
+ oldClassName := currentClass name.
+ (oldClassName endsWith:'-old') ifTrue:[
+ oldClassName := oldClassName copyTo:(oldClassName size - 4)
+ ]
+ ].
+ oldMethodCategory := currentMethodCategory.
+
+ classCategoryListView setContents:(self listOfAllClassCategories).
+ currentClassCategory notNil ifTrue:[
+ classCategoryListView selectElement:currentClassCategory.
+ self classCategorySelectionChanged.
+ oldClassName notNil ifTrue:[
+ classListView selectElement:oldClassName.
+ self switchToClass:(Smalltalk at:oldClassName asSymbol).
+ self classSelectionChanged.
+ oldMethodCategory notNil ifTrue:[
+ methodCategoryListView selectElement:oldMethodCategory.
+ currentMethodCategory := oldMethodCategory.
+ self methodCategorySelectionChanged
+ ]
+ ]
+ ]
+ ]
+!
+
+classCategoryPrintOutProtocol
+ |printStream|
+
+ self allClassesInCurrentCategoryInOrderDo:[:aClass |
+ printStream := Printer new.
+ aClass printOutProtocolOn:printStream.
+ printStream close
+ ]
+!
+
+classCategoryPrintOut
+ |printStream|
+
+ self allClassesInCurrentCategoryDo:[:aClass |
+ printStream := Printer new.
+ aClass printOutOn:printStream.
+ printStream close
+ ]
+!
+
+classCategoryFileOut
+ "create a file 'categoryName' consisting of all classes in current category"
+
+ |aStream fileName project|
+
+ currentClassCategory isNil ifTrue:[
+ ^ self warn:'select a class category first'.
+ ].
+
+ fileName := currentClassCategory asString.
+ fileName replaceAll:Character space by:$_.
+ Project notNil ifTrue:[
+ project := Project current.
+ project notNil ifTrue:[
+ fileName := project directory , Filename separator asString , fileName.
+ ].
+ ].
+
+ aStream := FileStream newFileNamed:fileName.
+ aStream isNil ifTrue:[
+ ^ self warn:(resources string:'cannot create: %1' with:fileName)
+ ].
+ self withWaitCursorDo:[
+ self label:('System Browser writing: ' , fileName).
+ self allClassesInCurrentCategoryInOrderDo:[:aClass |
+ aClass fileOutOn:aStream.
+ ].
+ aStream close.
+ self label:'System Browser'.
+ ]
+!
+
+classCategoryFileOutEach
+ self withWaitCursorDo:[
+ self allClassesInCurrentCategoryDo:[:aClass |
+ self label:('System Browser saving: ' , aClass name).
+ aClass fileOut
+ ].
+ self label:'System Browser'.
+ ]
+!
+
+classCategoryBinaryFileOut
+ self withWaitCursorDo:[
+ self allClassesInCurrentCategoryInOrderDo:[:aClass |
+ aClass binaryFileOut
+ ]
+ ]
+!
+
+classCategorySpawn
+ "create a new SystemBrowser browsing current classCategory"
+
+ currentClassCategory notNil ifTrue:[
+ self withWaitCursorDo:[
+ self class browseClassCategory:currentClassCategory
+ ]
+ ]
+!
+
+classCategorySpawnFullClass
+ "create a new SystemBrowser browsing full class"
+
+ |newBrowser|
+
+ self withWaitCursorDo:[
+ newBrowser := self class browseFullClasses
+"
+ .
+ currentClass notNil ifTrue:[
+ newBrowser switchToClassNamed:(currentClass name)
+ ]
+"
+ ]
+!
+
+classCategoryNewCategory
+ self enterBoxTitle:'name of new class category:' okText:'create'.
+ enterBox action:[:aString | self newClassCategory:aString].
+ enterBox showAtPointer
+!
+
+switchToClassNamed:aString
+ |classSymbol theClass|
+
+ classSymbol := aString asSymbol.
+ theClass := Smalltalk at:classSymbol.
+ theClass isBehavior ifTrue:[
+ classCategoryListView notNil ifTrue:[
+ currentClassHierarchy isNil ifTrue:[
+ (theClass category ~~ currentClassCategory) ifTrue:[
+ currentClassCategory := theClass category.
+ currentClassCategory isNil ifTrue:[
+ classCategoryListView selectElement:'* no category *'
+ ] ifFalse:[
+ classCategoryListView selectElement:currentClassCategory
+ ].
+ self classCategorySelectionChanged
+ ]
+ ]
+ ].
+ self switchToClass:theClass.
+ classListView selectElement:aString.
+ self classSelectionChanged
+ ]
+!
+
+switchToClassNameMatching:aMatchString
+ |classNames thisName|
+
+ classNames := OrderedCollection new.
+ Smalltalk allBehaviorsDo:[:aClass |
+ thisName := aClass name.
+ (aMatchString match:thisName) ifTrue:[
+ classNames add:thisName
+ ]
+ ].
+ (classNames size == 0) ifTrue:[^ nil].
+ (classNames size == 1) ifTrue:[
+ ^ self switchToClassNamed:(classNames at:1)
+ ].
+ self listBoxTitle:'select class to switch to:'
+ okText:'ok'
+ list:classNames sort.
+ selectBox action:[:aString | self switchToClassNamed:aString].
+ selectBox showAtPointer
+!
+
+classCategoryFindClass
+ self enterBoxForCodeSelectionTitle:'class to find:' okText:'find'.
+ enterBox action:[:aString | self switchToClassNameMatching:aString].
+ enterBox showAtPointer
+!
+
+renameCurrentClassCategoryTo:aString
+ "helper - do the rename"
+
+ |any categories|
+
+ currentClassCategory notNil ifTrue:[
+ any := false.
+ Smalltalk allBehaviorsDo:[:aClass |
+ aClass category = currentClassCategory ifTrue:[
+ aClass category:aString.
+ any := true
+ ]
+ ].
+ any ifFalse:[
+ categories := classCategoryListView list.
+ categories remove:currentClassCategory.
+ categories add:aString.
+ categories sort.
+ classCategoryListView setContents:categories.
+ currentClassCategory := aString.
+ classCategoryListView selectElement:aString.
+ ] ifTrue:[
+ currentClassCategory := aString.
+ self updateClassCategoryList.
+ self updateClassListWithScroll:false
+ ]
+ ]
+!
+
+classCategoryRename
+ "launch an enterBox to rename current class category"
+
+ currentClassCategory isNil ifTrue:[
+ ^ self warn:'select a class category first'.
+ ].
+ self enterBoxTitle:'rename class category to:' okText:'rename'.
+ enterBox initialText:currentClassCategory.
+ enterBox action:[:aString | self renameCurrentClassCategoryTo:aString].
+ enterBox showAtPointer
+!
+
+classCategoryRemove
+ "remove all classes in current category"
+
+ |count t classesToRemove subclassesRemoved|
+
+ currentClassCategory isNil ifTrue:[
+ ^ self warn:'select a class category first'.
+ ].
+
+ classesToRemove := OrderedCollection new.
+ Smalltalk allBehaviorsDo:[:aClass |
+ aClass category = currentClassCategory ifTrue:[
+ classesToRemove add:aClass
+ ]
+ ].
+ subclassesRemoved := OrderedCollection new.
+ classesToRemove do:[:aClass |
+ aClass allSubclassesDo:[:aSubclass |
+ (classesToRemove includes:aSubclass) ifFalse:[
+ (subclassesRemoved includes:aSubclass) ifFalse:[
+ subclassesRemoved add:aSubclass
+ ]
+ ]
+ ]
+ ].
+
+ count := classesToRemove size.
+ t := resources string:'remove %1 ?' with:currentClassCategory.
+ count ~~ 0 ifTrue:[
+ t := t , (resources at:'\(with ') , count printString.
+ count == 1 ifTrue:[
+ t := t , (resources at:' class')
+ ] ifFalse:[
+ t := t , (resources at:' classes')
+ ].
+ t := (t , ')') withCRs
+ ].
+
+ count := subclassesRemoved size.
+ count ~~ 0 ifTrue:[
+ t := t , (resources at:'\(and ') , count printString.
+ count == 1 ifTrue:[
+ t := t , (resources at:' subclass ')
+ ] ifFalse:[
+ t := t , (resources at:' subclasses ')
+ ].
+ t := (t , ')') withCRs
+ ].
+
+ t := t withCRs.
+
+ questBox isNil ifTrue:[questBox := YesNoBox title:''].
+ questBox title:t.
+ questBox yesAction:[self doRemoveClasses:classesToRemove and:subclassesRemoved].
+ questBox okText:(resources at:'remove').
+ questBox noText:(resources at:'abort').
+ questBox showAtPointer
+!
+
+doRemoveClasses:classList and:subclassList
+ "after querying user - do really remove classes in list1 and list2"
+
+ subclassList do:[:aClass |
+ Smalltalk removeClass:aClass
+ ].
+ classList do:[:aClass |
+ Smalltalk removeClass:aClass
+ ].
+ currentClassCategory := nil.
+ self switchToClass:nil.
+ Smalltalk changed
+! !
+
+!SystemBrowser methodsFor:'class menu'!
+
+initializeClassMenu
+ |labels menu|
+
+ labels := resources array:#(
+ 'fileOut'
+"
+ 'fileOut binary'
+"
+ 'printOut'
+ 'printOut protocol'
+ " 'printOut full protocol' "
+ '-'
+ 'spawn'
+ 'spawn hierarchy'
+ 'spawn subclasses'
+ '-'
+ 'hierarchy'
+ 'definition'
+ 'comment'
+ 'class instvars'
+ " 'protocols' "
+ '-'
+ 'variable search'
+ '-'
+ 'new class'
+ 'new subclass'
+ 'rename ...'
+ 'remove').
+
+ menu := PopUpMenu labels:labels
+ selectors:#(classFileOut
+"
+ classBinaryFileOut
+"
+ classPrintOut
+ classPrintOutProtocol
+ " classPrintOutFullProtocol "
+ nil
+ classSpawn
+ classSpawnHierarchy
+ classSpawnSubclasses
+ nil
+ classHierarchy
+ classDefinition
+ classComment
+ classClassInstVars
+ " classProtocols "
+ nil
+"
+ classInstVarRefs
+ classClassVarRefs
+ classAllInstVarRefs
+ classAllClassVarRefs
+ nil
+ classInstVarMods
+ classClassVarMods
+ classAllInstVarMods
+ classAllClassVarMods
+"
+ variables
+ nil
+ classNewClass
+ classNewSubclass
+ classRename
+ classRemove)
+ receiver:self
+ for:classListView.
+
+ classListView middleButtonMenu:menu.
+
+ menu subMenuAt:#variables
+ put:(PopUpMenu labels:(resources array:#(
+ 'instvar refs ...'
+ 'classvar refs ...'
+ 'all instvar refs ...'
+ 'all classvar refs ...'
+ '-'
+ 'instvar mods ...'
+ 'classvar mods ...'
+ 'all instvar mods ...'
+ 'all classvar mods ...'
+ ))
+ selectors:#(
+ classInstVarRefs
+ classClassVarRefs
+ classAllInstVarRefs
+ classAllClassVarRefs
+ nil
+ classInstVarMods
+ classClassVarMods
+ classAllInstVarMods
+ classAllClassVarMods
+ )
+ receiver:self
+ for:self
+
+ ).
+!
+
+doClassMenu:aBlock
+ "a helper - check if class is selected and evaluate aBlock
+ while showing waitCursor"
+
+ currentClass isNil ifTrue:[
+ ^ self warn:'select a class first'.
+ ].
+ self withWaitCursorDo:aBlock
+!
+
+doClassMenuWithSelection:aBlock
+ "a helper - if there is a selection, which represents a classes name,
+ evaluate aBlock, passing that class as argument.
+ Otherwise, check if a class is selected and evaluate aBlock with the
+ current class. Otherwise report an error."
+
+ |clsName cls isMeta w|
+
+ clsName := codeView selection.
+ clsName notNil ifTrue:[
+ clsName := clsName asString withoutSeparators.
+ (clsName endsWith:'class') ifTrue:[
+ isMeta := true.
+ clsName := clsName copyTo:(clsName size - 5)
+ ] ifFalse:[
+ isMeta := false
+ ].
+ clsName knownAsSymbol ifTrue:[
+ (Smalltalk includesKey:clsName asSymbol) ifTrue:[
+ cls := Smalltalk at:clsName asSymbol.
+ cls isBehavior ifTrue:[
+ isMeta ifTrue:[
+ cls := cls class
+ ].
+ self withWaitCursorDo:[
+ aBlock value:cls.
+ ].
+ ^ self
+ ] ifFalse:[
+ w := clsName , ' is not a class'
+ ]
+ ] ifFalse:[
+ w := clsName , ' is unknown'
+ ].
+ self warn:w.
+ ^ self
+ ].
+ ].
+
+ currentClass isNil ifTrue:[
+ ^ self warn:'select a class first'.
+ ].
+ self withWaitCursorDo:[aBlock value:currentClass]
+!
+
+classSpawn
+ "create a new SystemBrowser browsing current class,
+ or if there is a selection, spawn a browser on the selected name."
+
+ |browser|
+
+ self doClassMenuWithSelection:[:cls |
+ cls isMeta ifTrue:[
+ Smalltalk allClassesDo:[:aClass |
+ aClass class == cls ifTrue:[
+ browser := self class browseClass:aClass.
+ browser classProtocol.
+ ^ self
+ ].
+ ].
+ self warn:'oops, no class for this metaclass'.
+ ^ self
+ ].
+ self class browseClass:cls
+ ]
+!
+
+classSpawnHierarchy
+ "create a new HierarchyBrowser browsing current class"
+
+ self doClassMenuWithSelection:[:cls |
+ self class browseClassHierarchy:cls
+ ]
+!
+
+classSpawnSubclasses
+ "create a new browser browsing current class's subclasses"
+
+ |subs|
+
+ self doClassMenuWithSelection:[:cls |
+ subs := cls allSubclasses.
+ (subs notNil and:[subs size ~~ 0]) ifTrue:[
+ self class browseClasses:subs title:('subclasses of ' , cls name)
+ ]
+ ]
+!
+
+classPrintOutFullProtocol
+ |printStream|
+
+ self doClassMenu:[
+ printStream := Printer new.
+ currentClass printOutFullProtocolOn:printStream.
+ printStream close
+ ]
+!
+
+classPrintOutProtocol
+ |printStream|
+
+ self doClassMenu:[
+ printStream := Printer new.
+ currentClass printOutProtocolOn:printStream.
+ printStream close
+ ]
+!
+
+classPrintOut
+ |printStream|
+
+ self doClassMenu:[
+ printStream := Printer new.
+ currentClass printOutOn:printStream.
+ printStream close
+ ]
+!
+
+classBinaryFileOut
+ self doClassMenu:[
+ currentClass binaryFileOut
+ ]
+!
+
+classFileOut
+ self doClassMenu:[
+ self label:('System Browser saving: ' , currentClass name).
+ currentClass fileOut.
+ self label:'System Browser'
+ ]
+!
+
+classHierarchy
+ "show current classes hierarchy in codeView"
+
+ |aStream|
+
+ self doClassMenu:[
+ aStream := WriteStream on:(String new:200).
+ actualClass printHierarchyOn:aStream.
+ codeView contents:(aStream contents).
+ codeView modified:false.
+ codeView acceptAction:nil.
+ codeView explainAction:nil.
+ methodListView notNil ifTrue:[
+ methodListView deselect
+ ]
+ ]
+!
+
+classDefinition
+ "show class definition in codeView and setup accept-action for
+ class-definition change"
+
+ |aStream|
+
+ self doClassMenu:[
+ aStream := WriteStream on:(String new:200).
+ currentClass fileOutDefinitionOn:aStream.
+ codeView contents:(aStream contents).
+ codeView modified:false.
+ codeView acceptAction:[:theCode |
+ codeView cursor:Cursor execute.
+ Object abortSignal catch:[
+ (Compiler evaluate:theCode asString notifying:codeView)
+ isBehavior ifTrue:[
+ codeView modified:false.
+ self classCategoryUpdate.
+ self updateClassListWithScroll:false.
+ ]
+ ].
+ codeView cursor:Cursor normal.
+ ].
+ codeView explainAction:nil.
+ methodListView notNil ifTrue:[
+ methodListView deselect
+ ]
+ ]
+!
+
+classClassInstVars
+ "show class instance variables in codeView and setup accept-action
+ for class-instvar-definition change"
+
+ |s|
+
+ self doClassMenu:[
+ s := WriteStream on:(String new).
+ currentClass fileOutClassInstVarDefinitionOn:s.
+ codeView contents:(s contents).
+ codeView modified:false.
+ codeView acceptAction:[:theCode |
+ codeView cursor:Cursor execute.
+ Object abortSignal catch:[
+ Compiler evaluate:theCode asString notifying:codeView.
+ codeView modified:false.
+ self updateClassList.
+ ].
+ codeView cursor:Cursor normal.
+ ].
+ codeView explainAction:nil.
+ methodListView notNil ifTrue:[
+ methodListView deselect
+ ]
+ ]
+!
+
+classProtocols
+ ^ self
+!
+
+classComment
+ "show the classes comment in the codeView"
+
+ self doClassMenu:[
+ codeView contents:(currentClass comment).
+ codeView modified:false.
+ codeView acceptAction:[:theCode |
+ Object abortSignal catch:[
+ currentClass comment:theCode asString.
+ codeView modified:false.
+ ]
+ ].
+ codeView explainAction:nil.
+ methodListView notNil ifTrue:[
+ methodListView deselect
+ ]
+ ]
+!
+
+classInstVarRefsOrModsTitle:title mods:mods
+ "show an enterbox for instvar to search for"
+
+ self doClassMenu:[
+ self enterBoxForCodeSelectionTitle:title okText:'browse'.
+ enterBox action:[:aString |
+ self withWaitCursorDo:[
+ self class browseInstRefsTo:aString
+ in:(Array with:currentClass)
+ modificationsOnly:mods
+ ]
+ ].
+ enterBox showAtPointer
+ ]
+!
+
+classInstVarRefs
+ "show an enterbox for instVar to search for"
+
+ self classInstVarRefsOrModsTitle:'instance variable to browse references to:'
+ mods:false
+!
+
+classInstVarMods
+ "show an enterbox for instVar to search for"
+
+ self classInstVarRefsOrModsTitle:'instance variable to browse modifications of:'
+ mods:true
+!
+
+classClassVarRefsOrModsTitle:title mods:mods
+ "show an enterbox for classVar to search for"
+
+ self doClassMenu:[
+ self enterBoxForCodeSelectionTitle:title okText:'browse'.
+ enterBox action:[:aString |
+ self withWaitCursorDo:[
+ self class browseClassRefsTo:aString
+ in:(Array with:currentClass)
+ modificationsOnly:mods
+ ]
+ ].
+ enterBox showAtPointer
+ ]
+!
+
+classClassVarMods
+ "show an enterbox for classVar to search for"
+
+ self classClassVarRefsOrModsTitle:'class variable to browse modifications of:'
+ mods:true
+!
+
+classClassVarRefs
+ "show an enterbox for classVar to search for"
+
+ self classClassVarRefsOrModsTitle:'class variable to browse references to:'
+ mods:false
+!
+
+classAllClassOrInstVarRefsTitle:title access:access
+ "show an enterbox for instVar to search for"
+
+ self doClassMenu:[
+ self enterBoxForCodeSelectionTitle:title okText:'browse'.
+ enterBox action:[:aVariableName |
+ self withWaitCursorDo:[
+ |homeClass|
+
+ homeClass := self findClassOfVariable:aVariableName
+ accessWith:access.
+ (self class) browseInstRefsTo:aVariableName
+ under:homeClass
+ modificationsOnly:false
+ ]
+ ].
+ enterBox showAtPointer
+ ]
+!
+
+classAllInstVarRefs
+ "show an enterbox for instVar to search for"
+
+ self classAllClassOrInstVarRefsTitle:'instance variable to browse references to:'
+ access:#instVarNames
+!
+
+classAllClassVarRefs
+ "show an enterbox for classVar to search for"
+
+ self classAllClassOrInstVarRefsTitle:'class variable to browse references to:'
+ access:#classVarNames
+!
+
+classAllInstOrClassVarModsTitle:title access:access
+ "show an enterbox for instVar to search for"
+
+ self doClassMenu:[
+ self enterBoxForCodeSelectionTitle:title okText:'browse'.
+ enterBox action:[:aVariableName |
+ self withWaitCursorDo:[
+ |homeClass|
+
+ homeClass := self findClassOfVariable:aVariableName
+ accessWith:access.
+ (self class) browseInstRefsTo:aVariableName
+ under:homeClass
+ modificationsOnly:true
+ ]
+ ].
+ enterBox showAtPointer
+ ]
+!
+
+classAllInstVarMods
+ "show an enterbox for instVar to search for"
+
+ self classAllInstOrClassVarModsTitle:'instance variable to browse modifications of:'
+ access:#instVarNames.
+!
+
+classAllClassVarMods
+ "show an enterbox for classVar to search for"
+
+ self classAllInstOrClassVarModsTitle:'class variable to browse modifications of:'
+ access:#classVarNames.
+!
+
+classClassDefinitionTemplateFor:name in:cat
+ "common helper for newClass and newSubclass
+ - show a template to define class name in category cat"
+
+ currentMethodCategory := nil.
+ currentMethod := nil.
+
+ classListView deselect.
+
+ fullClass ifFalse:[
+ methodCategoryListView contents:nil.
+ methodListView contents:nil
+ ].
+
+ codeView contents:(self templateFor:name in:cat).
+ codeView modified:false.
+
+ codeView acceptAction:[:theCode |
+ codeView cursor:Cursor execute.
+ Object abortSignal catch:[
+ |cl|
+
+ cl := (Compiler evaluate:theCode asString notifying:codeView).
+ cl isBehavior ifTrue:[
+ codeView modified:false.
+ self classCategoryUpdate.
+ self updateClassListWithScroll:false.
+ self switchToClassNamed:(cl name)
+ ]
+ ].
+ codeView cursor:(Cursor normal).
+ ].
+ codeView explainAction:nil.
+ self switchToClass:nil
+!
+
+classNewClass
+ "create a class-definition prototype in codeview"
+
+ |nm|
+
+ currentClass notNil ifTrue:[
+ nm := currentClass superclass name
+ ] ifFalse:[
+ nm := 'Object'
+ ].
+ self classClassDefinitionTemplateFor:nm in:currentClassCategory
+!
+
+classNewSubclass
+ "create a subclass-definition prototype in codeview"
+
+ currentClass isNil ifTrue:[
+ ^ self warn:'select a class first'.
+ ].
+ self classClassDefinitionTemplateFor:(currentClass name)
+ in:(currentClass category)
+!
+
+renameCurrentClassTo:aString
+ "helper - do the rename"
+
+ self doClassMenu:[
+ |oldName oldSym newSym|
+
+ oldName := currentClass name.
+ oldSym := oldName asSymbol.
+"
+ currentClass setName:aString.
+ newSym := aString asSymbol.
+ Smalltalk at:oldSym put:nil.
+ Smalltalk removeKey:oldSym.
+ Smalltalk at:newSym put:currentClass.
+"
+"
+ currentClass renameTo:aString.
+"
+ Smalltalk renameClass:currentClass to:aString.
+
+ self updateClassList.
+ self updateMethodCategoryListWithScroll:false.
+ self updateMethodListWithScroll:false.
+ self withWaitCursorDo:[
+ Transcript showCr:('searching for users of ' , oldSym); endEntry.
+ self class browseReferendsOf:oldSym warnIfNone:false
+ ]
+ ]
+!
+
+classRename
+ "launch an enterBox for new name and query user"
+
+ currentClass isNil ifTrue:[
+ ^ self warn:'select a class first'.
+ ].
+ self enterBoxTitle:(resources string:'rename %1 to:' with:currentClass name) okText:'rename'.
+ enterBox initialText:(currentClass name).
+ enterBox action:[:aString | self renameCurrentClassTo:aString].
+ enterBox showAtPointer
+!
+
+doRemoveCurrentClass
+ "after querying user - do really remove current class
+ and all subclasses"
+
+ self doClassMenu:[
+ currentClass allSubclassesDo:[:aSubClass |
+ Smalltalk removeClass:aSubClass
+ ].
+ Smalltalk removeClass:currentClass.
+
+ self switchToClass:nil.
+ Smalltalk changed.
+ self updateClassList.
+
+ "if it was the last in its category, update class category list"
+"
+ classListView numberOfLines == 0 ifTrue:[
+ self updateClassCategoryListWithScroll:false
+ ].
+"
+ methodCategoryListView notNil ifTrue:[methodCategoryListView contents:nil].
+ methodListView notNil ifTrue:[methodListView contents:nil].
+ codeView contents:nil.
+ codeView modified:false
+ ]
+!
+
+classRemove
+ "user requested remove of current class and all subclasses -
+ count subclasses and let user confirm removal."
+
+ |count t|
+
+ currentClass notNil ifTrue:[
+ count := 0.
+ currentClass allSubclassesDo:[:aSubClass |
+ count := count + 1
+ ].
+ t := 'remove ' , currentClass name.
+ count ~~ 0 ifTrue:[
+ t := t , '\(with ' , count printString.
+ count == 1 ifTrue:[
+ t := t , ' subclass'
+ ] ifFalse:[
+ t := t , ' subclasses'
+ ].
+ t := (t , ')') withCRs
+ ].
+ questBox isNil ifTrue:[questBox := YesNoBox title:''].
+ questBox title:t.
+ questBox yesAction:[self doRemoveCurrentClass].
+ questBox okText:(resources at:'remove').
+ questBox noText:(resources at:'abort').
+ questBox showAtPointer
+ ]
+! !
+
+!SystemBrowser methodsFor:'method category menu'!
+
+initializeMethodCategoryMenu
+ |labels|
+
+ labels := resources array:#(
+ 'fileOut'
+ 'fileOut all'
+ 'printOut'
+ '-'
+ 'spawn'
+ 'spawn category'
+ '-'
+ 'find method here ...'
+ 'find method ...'
+ '-'
+ 'new category ...'
+ 'copy category ...'
+ 'create access methods'
+ 'rename ...'
+ 'remove').
+
+ methodCategoryListView
+ middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:#(
+ methodCategoryFileOut
+ methodCategoryFileOutAll
+ methodCategoryPrintOut
+ nil
+ methodCategorySpawn
+ methodCategorySpawnCategory
+ nil
+ methodCategoryFindMethod
+ methodCategoryFindAnyMethod
+ nil
+ methodCategoryNewCategory
+ methodCategoryCopyCategory
+ methodCategoryCreateAccessMethods
+ methodCategoryRename
+ methodCategoryRemove)
+ receiver:self
+ for:methodCategoryListView)
+!
+
+switchToMethodNamed:matchString
+ |aSelector method cat index classToSearch selectors|
+
+ currentClass notNil ifTrue:[
+ showInstance ifTrue:[
+ classToSearch := currentClass
+ ] ifFalse:[
+ classToSearch := currentClass class
+ ].
+ selectors := classToSearch selectorArray.
+
+ ((matchString ~= '*') and:[matchString includesMatchCharacters]) ifTrue:[
+ index := selectors findFirst:[:element | matchString match:element]
+ ] ifFalse:[
+ index := selectors indexOf:matchString
+ ].
+
+ (index ~~ 0) ifTrue:[
+ aSelector := selectors at:index.
+ method := classToSearch methodArray at:index.
+ cat := method category.
+ cat isNil ifTrue:[cat := '* all *'].
+ methodCategoryListView selectElement:cat.
+ currentMethodCategory := cat.
+ self methodCategorySelectionChanged.
+
+ currentMethod := classToSearch compiledMethodAt:aSelector.
+ methodListView selectElement:aSelector.
+ self methodSelectionChanged
+ ]
+ ]
+!
+
+switchToAnyMethodNamed:aString
+ |aSelector classToStartSearch aClass nm|
+
+ aSelector := aString asSymbol.
+ currentClass isNil ifTrue:[
+ currentClassHierarchy notNil ifTrue:[
+ classToStartSearch := currentClassHierarchy
+ ]
+ ] ifFalse:[
+ classToStartSearch := currentClass
+ ].
+ classToStartSearch notNil ifTrue:[
+ showInstance ifFalse:[
+ classToStartSearch := classToStartSearch class
+ ].
+ aClass := classToStartSearch whichClassImplements:aSelector.
+ aClass notNil ifTrue:[
+ nm := aClass name.
+ showInstance ifFalse:[
+ ((nm ~= 'Metaclass') and:[nm endsWith:'class']) ifTrue:[
+ nm := nm copyTo:(nm size - 5)
+ ]
+ ].
+ self switchToClassNamed:nm.
+ self switchToMethodNamed:aString
+ ]
+ ]
+!
+
+copyMethodsFromClass:aClassName
+ |class|
+
+ currentClass notNil ifTrue:[
+ Symbol hasInterned:aClassName ifTrue:[:sym |
+ (Smalltalk includesKey:sym) ifTrue:[
+ class := Smalltalk at:sym
+ ].
+ ].
+ class isBehavior ifFalse:[
+ self warn:(resources string:'no class named %1' with:aClassName).
+ ^ self
+ ].
+
+ showInstance ifFalse:[
+ class := class class
+ ].
+
+ "show enterbox for category to copy from"
+
+ self enterBoxTitle:'name of category to copy from (matchpattern allowed, * for all):'
+ okText:'copy'.
+ enterBox action:[:aString | self copyMethodsFromClass:class category:aString].
+ enterBox showAtPointer
+ ]
+!
+
+copyMethodsFromClass:class category:category
+ |source|
+
+ currentClass notNil ifTrue:[
+ codeView abortAction:[^ self].
+ class methodArray do:[:aMethod |
+ (category match:aMethod category) ifTrue:[
+ source := aMethod source.
+ codeView contents:source.
+ codeView modified:false.
+ actualClass compiler compile:source
+ forClass:actualClass
+ inCategory:aMethod category
+ notifying:codeView.
+ self updateMethodCategoryListWithScroll:false.
+ self updateMethodListWithScroll:false.
+ ]
+ ]
+ ]
+!
+
+methodCategoryFindMethod
+ self enterBoxForSearchSelectorTitle:'method selector to search for:'.
+ enterBox action:[:aString | self switchToMethodNamed:aString].
+ enterBox showAtPointer
+!
+
+methodCategoryFindAnyMethod
+ self enterBoxForSearchSelectorTitle:'method selector to search for:'.
+ enterBox action:[:aString | self switchToAnyMethodNamed:aString].
+ enterBox showAtPointer
+!
+
+methodCategoryPrintOut
+ |printStream|
+
+ currentClass isNil ifTrue:[
+ ^ self warn:'select a class first'.
+ ].
+ currentMethodCategory isNil ifTrue:[
+ ^ self warn:'select a method category first'.
+ ].
+ currentMethodCategory notNil ifTrue:[
+ self withWaitCursorDo:[
+ printStream := Printer new.
+ actualClass printOutCategory:currentMethodCategory on:printStream.
+ printStream close
+ ]
+ ]
+!
+
+methodCategoryFileOut
+ "fileOut all methods in the selected methodcategory of
+ the current class"
+
+ currentClass isNil ifTrue:[
+ ^ self warn:'select a class first'.
+ ].
+ currentMethodCategory isNil ifTrue:[
+ ^ self warn:'select a method category first'.
+ ].
+ currentMethodCategory notNil ifTrue:[
+ self withWaitCursorDo:[
+ self label:('System Browser saving: ' , currentClass name , '-' , currentMethodCategory).
+ actualClass fileOutCategory:currentMethodCategory.
+ self label:'System Browser'.
+ ]
+ ]
+!
+
+methodCategoryFileOutAll
+ "fileOut all methods in the selected methodcategory of
+ the current class"
+
+ |fileName project outStream hasMethodsInThisCategory|
+
+ currentMethodCategory isNil ifTrue:[
+ ^ self warn:'select a method category first'.
+ ].
+ fileName := currentMethodCategory , '.st'.
+ fileName replaceAll:Character space by:$_.
+ Project notNil ifTrue:[
+ project := Project current.
+ project notNil ifTrue:[
+ fileName := project directory , Filename separator asString , fileName.
+ ].
+ ].
+ outStream := FileStream newFileNamed:fileName.
+ outStream isNil ifTrue:[
+ ^ self warn:(resources string:'cannot create: %1' with:fileName)
+ ].
+ self withWaitCursorDo:[
+ self label:('System Browser saving: ' , currentMethodCategory).
+ Smalltalk allClassesDo:[:class |
+ hasMethodsInThisCategory := false.
+ class methodArray do:[:method |
+ method category = currentMethodCategory ifTrue:[
+ hasMethodsInThisCategory := true
+ ]
+ ].
+ hasMethodsInThisCategory ifTrue:[
+ class fileOutCategory:currentMethodCategory on:outStream.
+ outStream cr
+ ].
+ hasMethodsInThisCategory := false.
+ class class methodArray do:[:method |
+ method category = currentMethodCategory ifTrue:[
+ hasMethodsInThisCategory := true
+ ]
+ ].
+ hasMethodsInThisCategory ifTrue:[
+ class class fileOutCategory:currentMethodCategory on:outStream.
+ outStream cr
+ ]
+ ].
+ outStream close.
+ self label:'System Browser'.
+ ].
+!
+
+methodCategorySpawn
+ "create a new SystemBrowser browsing current method category"
+
+ currentMethodCategory notNil ifTrue:[
+ self withWaitCursorDo:[
+ self class browseClass:actualClass
+ methodCategory:currentMethodCategory
+ ]
+ ]
+!
+
+methodCategorySpawnCategory
+ "create a new SystemBrowser browsing all methods from all
+ classes with same category as current method category"
+
+ self enterBoxForMethodCategory:'category to browse methods:'.
+ enterBox action:[:aString | self withWaitCursorDo:[
+ self class browseMethodCategory:aString
+ ]
+ ].
+ enterBox showAtPointer
+!
+
+newMethodCategory:aString
+ |categories|
+
+ currentClass isNil ifTrue:[
+ ^ self warn:'select/create a class first'.
+ ].
+ categories := methodCategoryListView list.
+ categories isNil ifTrue:[categories := Text new].
+ (categories includes:aString) ifFalse:[
+ categories add:aString.
+ categories sort.
+ methodCategoryListView contents:categories
+ ].
+ currentMethodCategory := aString.
+ self methodCategorySelectionChanged
+!
+
+methodCategoryNewCategory
+ "show the enter box to add a new method category"
+
+ |someCategories existingCategories|
+
+ "a tiny little goody here ..."
+ showInstance ifTrue:[
+ someCategories := #('accessing'
+ 'initialization'
+ 'private'
+ 'printing & storing'
+ 'queries'
+ 'testing'
+ )
+ ] ifFalse:[
+ someCategories := #(
+ 'documentation'
+ 'initialization'
+ 'instance creation'
+ ).
+ ].
+ existingCategories := methodCategoryListView list.
+ existingCategories notNil ifTrue:[
+ someCategories := someCategories select:[:cat | (existingCategories includes:cat) not].
+ ].
+
+ self listBoxTitle:(resources at:'name of new method category:')
+ okText:(resources at:'create')
+ list:someCategories.
+ selectBox action:[:aString | self newMethodCategory:aString].
+ selectBox showAtPointer
+!
+
+methodCategoryCreateAccessMethods
+ "create access methods for all instvars"
+
+ |source|
+
+ currentClass isNil ifTrue:[^ self].
+ showInstance ifFalse:[
+ self warn:(resources string:'select instance - and try again').
+ ^ self.
+ ].
+ self withWaitCursorDo:[
+ currentClass instVarNames do:[:name |
+ "check, if method is not already present"
+ (currentClass implements:(name asSymbol)) ifFalse:[
+ source := (name , '\ "return ' , name , '"\\ ^ ' , name) withCRs.
+ Compiler compile:source forClass:currentClass inCategory:'accessing'.
+ ] ifTrue:[
+ Transcript showCr:'method ''', name , ''' already present'
+ ].
+ (currentClass implements:((name , ':') asSymbol)) ifFalse:[
+ source := (name , ':something\ "set ' , name , '"\\ ' , name , ' := something.') withCRs.
+ Compiler compile:source forClass:currentClass inCategory:'accessing'.
+ ] ifTrue:[
+ Transcript showCr:'method ''', name , ':'' already present'
+ ].
+ ].
+ self updateMethodCategoryListWithScroll:false.
+ self updateMethodListWithScroll:false
+ ]
+!
+
+methodCategoryCopyCategory
+ "show the enter box to copy from an existing method category"
+
+ |title|
+
+ showInstance ifTrue:[
+ title := 'class to copy instance method category from:'
+ ] ifFalse:[
+ title := 'class to copy class method category from:'
+ ].
+
+ self listBoxTitle:title
+ okText:'ok'
+ list:(Smalltalk allClasses collect:[:cls | cls name]) asArray sort.
+
+ selectBox action:[:aString | self copyMethodsFromClass:aString].
+ selectBox showAtPointer
+!
+
+renameCurrentMethodCategoryTo:aString
+ "helper - do the rename"
+
+ currentMethodCategory notNil ifTrue:[
+ actualClass renameCategory:currentMethodCategory to:aString.
+
+"/ actualClass methodArray do:[:aMethod |
+"/ aMethod category = currentMethodCategory ifTrue:[
+"/ aMethod category:aString
+"/ ]
+"/ ].
+ currentMethodCategory := aString.
+ currentMethod := nil.
+ self updateMethodCategoryList.
+ self updateMethodListWithScroll:false
+ ]
+!
+
+methodCategoryRename
+ "launch an enterBox to rename current method category"
+
+ currentMethodCategory isNil ifTrue:[
+ ^ self warn:'select a method category first'.
+ ].
+
+ self enterBoxTitle:(resources string:'rename method category %1 to:' with:currentMethodCategory)
+ okText:(resources at:'rename').
+ enterBox initialText:currentMethodCategory.
+ enterBox action:[:aString | self renameCurrentMethodCategoryTo:aString].
+ enterBox showAtPointer
+!
+
+doMethodCategoryRemove
+ "actually remove all methods from current method category"
+
+ currentMethodCategory notNil ifTrue:[
+ actualClass methodArray do:[:aMethod |
+ (aMethod category = currentMethodCategory) ifTrue:[
+ actualClass
+ removeSelector:(actualClass selectorForMethod:aMethod)
+ ]
+ ].
+ currentMethodCategory := nil.
+ currentMethod := nil.
+ self updateMethodCategoryList.
+ self updateMethodList
+ ]
+!
+
+methodCategoryRemove
+ "show number of methods to remove and query user"
+
+ |count t|
+
+ currentMethodCategory notNil ifTrue:[
+ count := 0.
+ actualClass methodArray do:[:aMethod |
+ (aMethod category = currentMethodCategory) ifTrue:[
+ count := count + 1
+ ]
+ ].
+ (count == 0) ifTrue:[
+ currentMethodCategory := nil.
+ currentMethod := nil.
+ self updateMethodCategoryListWithScroll:false.
+ self updateMethodList
+ ] ifFalse:[
+ (count == 1) ifTrue:[
+ t := resources string:'remove %1 ?\(with 1 method)' with:currentMethodCategory
+ ] ifFalse:[
+ t := resources string:'remove %1 ?\(with %2 methods)' with:currentMethodCategory
+ with:count printString.
+ ].
+ t := t withCRs.
+
+ questBox isNil ifTrue:[questBox := YesNoBox title:''].
+ questBox title:t.
+ questBox yesAction:[self doMethodCategoryRemove].
+ questBox okText:(resources at:'remove').
+ questBox noText:(resources at:'abort').
+ questBox showAtPointer
+ ]
+ ]
+! !
+
+!SystemBrowser methodsFor:'method menu'!
+
+initializeMethodMenu
+ |labels|
+
+ labels := resources array:#(
+ 'fileOut'
+ 'printOut'
+ '-'
+ 'spawn'
+ '-'
+ 'senders ...'
+ 'implementors ...'
+ 'globals ...'
+"
+ 'strings ...'
+ 'apropos ...'
+"
+ '-'
+ 'local senders ...'
+ 'local implementors ...'
+"
+ 'local strings ...'
+"
+ '-'
+ 'breakpoint'
+ 'trace'
+ 'trace sender'
+ '-'
+ 'new method'
+ 'change category ...'
+ 'remove').
+
+ methodListView
+ middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:#(methodFileOut
+ methodPrintOut
+ nil
+ methodSpawn
+ nil
+ methodSenders
+ methodImplementors
+ methodGlobalReferends
+"
+ methodStringSearch
+ methodAproposSearch
+"
+ nil
+ methodLocalSenders
+ methodLocalImplementors
+"
+ methodLocalStringSearch
+"
+ nil
+ methodBreakPoint
+ methodTrace
+ methodTraceSender
+ nil
+ methodNewMethod
+ methodChangeCategory
+ methodRemove)
+ receiver:self
+ for:methodListView)
+!
+
+initializeMethodMenu2
+ |labels|
+
+ methodListView isNil ifTrue:[^ self].
+ labels := resources array:#(
+ 'fileOut'
+ 'printOut'
+ '-'
+ 'spawn'
+ '-'
+ 'senders ...'
+ 'implementors ...'
+ 'globals ...'
+"
+ 'strings ...'
+ 'apropos ...'
+"
+ '-'
+ 'local senders ...'
+ 'local implementors ...'
+"
+ 'local strings ...'
+"
+ '-'
+ 'remove break/trace'
+ '-'
+ 'new method'
+ 'change category ...'
+ 'remove').
+
+ methodListView
+ middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:#(methodFileOut
+ methodPrintOut
+ nil
+ methodSpawn
+ nil
+ methodSenders
+ methodImplementors
+ methodGlobalReferends
+"
+ methodStringSearch
+ methodAproposSearch
+"
+ nil
+ methodLocalSenders
+ methodLocalImplementors
+"
+ methodLocalStringSearch
+"
+ nil
+ methodRemoveBreakOrTrace
+ nil
+ methodNewMethod
+ methodChangeCategory
+ methodRemove)
+ receiver:self
+ for:methodListView)
+!
+
+methodPrintOut
+ "print out the current method"
+
+ |printStream|
+
+ currentMethod isNil ifTrue:[
+ ^ self warn:'select a method first'.
+ ].
+ printStream := Printer new.
+ actualClass printOutSource:currentMethod source on:printStream.
+ printStream close
+!
+
+methodFileOut
+ "file out the current method"
+
+ currentMethod isNil ifTrue:[
+ ^ self warn:'select a method first'.
+ ].
+ self label:'System Browser saving'.
+ actualClass fileOutMethod:currentMethod.
+ self label:'System Browser'.
+!
+
+methodImplementors
+ "launch an enterBox for selector to search for"
+
+ self enterBoxForBrowseSelectorTitle:'selector to browse implementors of:'.
+ enterBox action:[:aString | self withWaitCursorDo:[
+ self class browseImplementorsOf:aString
+ ]
+ ].
+ enterBox showAtPointer
+!
+
+methodLocalImplementors
+ "launch an enterBox for selector to search for"
+
+ currentClass isNil ifTrue:[
+ ^ self warn:'select a class first'.
+ ].
+
+ self enterBoxForBrowseSelectorTitle:'selector to browse local implementors of:'.
+ enterBox action:[:aString | self withWaitCursorDo:[
+ self class browseImplementorsOf:aString under:currentClass
+ ]
+ ].
+ enterBox showAtPointer
+!
+
+methodSenders
+ "launch an enterBox for selector to search for"
+
+ self enterBoxForBrowseSelectorTitle:'selector to browse senders of:'.
+ enterBox action:[:aString | self withWaitCursorDo:[
+ self class browseAllCallsOn:aString
+ ]
+ ].
+ enterBox showAtPointer
+!
+
+methodLocalSenders
+ "launch an enterBox for selector to search for in current class & subclasses"
+
+ currentClass isNil ifTrue:[
+ ^ self warn:'select a class first'.
+ ].
+ self enterBoxForBrowseSelectorTitle:'selector to browse local senderss of:'.
+ enterBox action:[:aString | self withWaitCursorDo:[
+ self class browseCallsOn:aString under:currentClass
+ ]
+ ].
+ enterBox showAtPointer
+!
+
+methodGlobalReferends
+ "launch an enterBox for global symbol to search for"
+
+ self enterBoxForBrowseTitle:'global variable to browse users of:'.
+ enterBox action:[:aString | self withWaitCursorDo:[
+ self class browseReferendsOf:aString asSymbol
+ ]
+ ].
+ enterBox showAtPointer
+!
+
+methodStringSearch
+ "launch an enterBox for (sub)-string to search for"
+
+ self enterBoxForBrowseSelectorTitle:'string / matchString to search for:'.
+ enterBox action:[:aString | self withWaitCursorDo:[
+ self class browseForString:aString
+ ]
+ ].
+ enterBox showAtPointer
+!
+
+methodLocalStringSearch
+ "launch an enterBox for (sub)-string to search for"
+
+ currentClass isNil ifTrue:[
+ ^ self warn:'select a class first'.
+ ].
+ self enterBoxForBrowseSelectorTitle:'string / matchString to search for locally:'.
+ enterBox action:[:aString | self withWaitCursorDo:[
+ self class browseForString:aString in:(currentClass withAllSubclasses)
+ ]
+ ].
+ enterBox showAtPointer
+!
+
+methodAproposSearch
+ "launch an enterBox for a keyword search"
+
+ self enterBoxForBrowseSelectorTitle:'keyword to search for:'.
+ enterBox action:[:aString | self withWaitCursorDo:[
+ self class aproposSearch:aString
+ ]
+ ].
+ enterBox showAtPointer
+!
+
+methodSpawn
+ "create a new SystemBrowser browsing current method,
+ or if the current selection is of the form 'class>>selector', spwan
+ a browser on that method."
+
+ |s sel clsName cls browseMeta w sep|
+
+ sel := codeView selection.
+ sel notNil ifTrue:[
+ sel := sel asString withoutSeparators.
+ ('*>>*' match:sel) ifTrue:[
+ sep := $>
+ ] ifFalse:[
+ ('* *' match:sel) ifTrue:[
+ sep := Character space
+ ]
+ ].
+ sep notNil ifTrue:[
+ s := ReadStream on:sel.
+ clsName := s upTo:sep.
+ [s peek == sep] whileTrue:[s next].
+ sel := s upToEnd.
+ (clsName endsWith:'class') ifTrue:[
+ browseMeta := true.
+ clsName := clsName copyTo:(clsName size - 5)
+ ] ifFalse:[
+ browseMeta := false
+ ].
+ (clsName knownAsSymbol and:[sel knownAsSymbol]) ifTrue:[
+ (Smalltalk includesKey:clsName asSymbol) ifTrue:[
+ cls := Smalltalk at:clsName asSymbol.
+ browseMeta ifTrue:[
+ cls := cls class
+ ].
+ cls isBehavior ifFalse:[
+ cls := cls class
+ ].
+ cls isBehavior ifTrue:[
+ (cls implements:sel asSymbol) ifTrue:[
+ self withWaitCursorDo:[
+ self class browseClass:cls selector:sel asSymbol
+ ].
+ ^ self
+ ] ifFalse:[
+ (cls class implements:sel asSymbol) ifTrue:[
+ self withWaitCursorDo:[
+ self class browseClass:cls class selector:sel asSymbol
+ ].
+ ^ self
+ ] ifFalse:[
+ w := clsName , ' does not implement #' , sel
+ ]
+ ]
+ ] ifFalse:[
+ w := clsName , ' is not a class'
+ ]
+ ] ifFalse:[
+ w := clsName , ' is unknown'
+ ]
+ ] ifFalse:[
+ w := clsName , ' and/or ' , sel , ' is unknown'
+ ].
+ self warn:w.
+ ^ self
+ ].
+ ].
+
+ currentMethod isNil ifTrue:[
+ ^ self warn:'select a method first'.
+ ].
+ self withWaitCursorDo:[
+ self class browseClass:actualClass
+ selector:(actualClass selectorForMethod:currentMethod)
+ ]
+!
+
+methodNewMethod
+ "prepare for definition of a new method - put a template into
+ code view and define accept-action to compile it"
+
+ currentClass isNil ifTrue:[
+ ^ self warn:'select/create a class first'.
+ ].
+ currentMethodCategory isNil ifTrue:[
+ ^ self warn:'select/create a method category first'.
+ ].
+
+ currentMethod := nil.
+
+ methodListView deselect.
+ codeView contents:(self template).
+ codeView modified:false.
+
+ codeView acceptAction:[:theCode |
+ codeView cursor:Cursor execute.
+ Object abortSignal catch:[
+ actualClass compiler compile:theCode asString
+ forClass:actualClass
+ inCategory:currentMethodCategory
+ notifying:codeView.
+ codeView modified:false.
+ self updateMethodListWithScroll:false.
+ ].
+ codeView cursor:Cursor normal.
+ ].
+ codeView explainAction:[:theCode :theSelection |
+ self showExplanation:(Explainer explain:theSelection
+ in:theCode
+ forClass:actualClass)
+ ]
+!
+
+methodRemove
+ "remove the current method"
+
+ currentMethod isNil ifTrue:[
+ ^ self warn:'select a method first'.
+ ].
+ actualClass
+ removeSelector:(actualClass selectorForMethod:currentMethod).
+ self updateMethodListWithScroll:false
+!
+
+doChangeCategoryOfCurrentMethodTo:aString
+ "after querying user - do really change current methods category"
+
+ currentMethod isNil ifTrue:[
+ ^ self warn:'select a method first'.
+ ].
+ currentMethod category:aString asSymbol.
+ currentClass changed.
+ self updateMethodCategoryListWithScroll:false.
+ self updateMethodListWithScroll:false
+!
+
+methodChangeCategory
+ "move the current method into another category -
+ nothing done here, but a query for the new category.
+ Remember the last category, to allow faster category change of a group of methods."
+
+ currentMethod isNil ifTrue:[
+ ^ self warn:'select a method first'.
+ ].
+ self enterBoxTitle:('change category from ' , currentMethod category , ' to:')
+ okText:'change'.
+ lastMethodCategory isNil ifTrue:[
+ enterBox initialText:(currentMethod category).
+ ] ifFalse:[
+ enterBox initialText:lastMethodCategory
+ ].
+ enterBox action:[:aString | lastMethodCategory := aString.
+ self doChangeCategoryOfCurrentMethodTo:aString
+ ].
+ enterBox showAtPointer
+!
+
+methodRemoveBreakOrTrace
+ "turn off tracing of the current method"
+
+ |sel|
+
+ currentMethod notNil ifTrue:[
+ currentMethod isWrapped ifTrue:[
+ currentMethod := MessageTracer unwrapMethod:currentMethod.
+ sel := methodListView selection.
+ self updateMethodListWithScroll:false.
+ methodListView selection:sel.
+ self initializeMethodMenu
+ ].
+ ]
+!
+
+methodBreakPoint
+ "set a breakpoint on the current method"
+
+ |sel|
+
+ currentMethod notNil ifTrue:[
+ currentMethod isWrapped ifFalse:[
+ currentMethod := MessageTracer trapMethod:currentMethod.
+ self initializeMethodMenu2.
+ sel := methodListView selection.
+ self updateMethodListWithScroll:false.
+ methodListView selection:sel
+ ].
+ ]
+!
+
+methodTrace
+ "turn on tracing of the current method"
+
+ |sel|
+
+ currentMethod notNil ifTrue:[
+ currentMethod isWrapped ifFalse:[
+ currentMethod := MessageTracer traceMethod:currentMethod.
+ self initializeMethodMenu2.
+ sel := methodListView selection.
+ self updateMethodListWithScroll:false.
+ methodListView selection:sel
+ ].
+ ]
+!
+
+methodTraceSender
+ "turn on tracing of the current method"
+
+ |sel|
+
+ currentMethod notNil ifTrue:[
+ currentMethod isWrapped ifFalse:[
+ currentMethod := MessageTracer traceMethodSender:currentMethod.
+ self initializeMethodMenu2.
+ sel := methodListView selection.
+ self updateMethodListWithScroll:false.
+ methodListView selection:sel
+ ].
+ ]
+! !
+
+!SystemBrowser methodsFor:'class-method menu'!
+
+initializeClassMethodMenu
+ |labels|
+
+ labels := resources array:#(
+ 'fileOut'
+ 'printOut'
+ '-'
+ 'spawn'
+ '-'
+ 'sender ...'
+ 'implementors ...'
+ 'globals ...'
+"/ '-'
+"/ 'breakpoint'
+"/ 'trace'
+"/ 'trace sender'
+ ).
+
+ classMethodListView
+ middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:#(methodFileOut
+ methodPrintOut
+ nil
+ methodSpawn
+ nil
+ methodSenders
+ methodImplementors
+ methodGlobalReferends
+"/ nil
+"/ methodBreakPoint
+"/ methodTrace
+"/ methodTraceSender
+ )
+ receiver:self
+ for:classMethodListView)
+! !
+
+!SystemBrowser methodsFor:'dependencies'!
+
+update
+ "handle changes from other browsers"
+
+ |oldClassCategory oldClassName oldMethodCategory oldMethod oldSelector|
+
+self updateClassCategoryListWithScroll:false.
+"
+self updateClassListWithScroll:false.
+"
+^ self.
+
+ oldClassCategory := currentClassCategory.
+ currentClass notNil ifTrue:[
+ oldClassName := currentClass name
+ ].
+ oldMethodCategory := currentMethodCategory.
+ oldMethod := currentMethod.
+ methodListView notNil ifTrue:[
+ oldMethod notNil ifTrue:[
+ oldSelector := methodListView selectionValue
+ ]
+ ].
+
+ classCategoryListView notNil ifTrue:[
+ classCategoryListView setContents:(self listOfAllClassCategories).
+ oldClassCategory notNil ifTrue:[
+ classCategoryListView selectElement:oldClassCategory
+ ].
+ classCategoryListView selection isNil ifTrue:[
+ currentClassCategory := nil.
+ self switchToClass:nil.
+ oldClassName := nil
+ ]
+ ].
+ classListView notNil ifTrue:[
+ self updateClassListWithScroll:false.
+ oldClassName notNil ifTrue:[
+ classListView selectElement:oldClassName
+ ].
+ classListView selection isNil ifTrue:[
+ self switchToClass:nil.
+ currentMethodCategory := nil.
+ oldMethodCategory := nil
+ ]
+ ].
+ methodCategoryListView notNil ifTrue:[
+ self updateMethodCategoryListWithScroll:false.
+ oldMethodCategory notNil ifTrue:[
+ methodCategoryListView selectElement:oldMethodCategory
+ ].
+ methodCategoryListView selection isNil ifTrue:[
+ currentMethodCategory := nil.
+ currentMethod := nil.
+ oldSelector := nil
+ ]
+ ].
+ methodListView notNil ifTrue:[
+ self updateMethodListWithScroll:false.
+ oldSelector notNil ifTrue:[
+ methodListView selectElement:oldSelector
+ ].
+ methodListView selection isNil ifTrue:[
+ currentMethod := nil
+ ]
+ ].
+ self updateCodeView
+!
+
+update:someObject
+ (someObject == Smalltalk) ifTrue:[self update. ^ self].
+ someObject isBehavior ifTrue:[
+ currentClass notNil ifTrue:[
+ someObject name = currentClass name ifTrue:[
+ currentClass := someObject.
+ showInstance ifTrue:[
+ actualClass := currentClass
+ ] ifFalse:[
+ actualClass := currentClass class
+ ].
+ self updateMethodCategoryListWithScroll:false.
+ "dont update codeView ...."
+ "self update"
+ ^ self
+ ]
+ ]
+ ]
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/SystemBrowser.st Sat Aug 13 20:40:49 1994 +0200
@@ -0,0 +1,4245 @@
+"{ Package: 'Programming Tools' }"
+
+"
+ COPYRIGHT (c) 1989 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+StandardSystemView subclass:#SystemBrowser
+ instanceVariableNames:'classCategoryListView classListView
+ methodCategoryListView methodListView
+ classMethodListView
+ codeView classToggle instanceToggle
+ currentClassCategory currentClassHierarchy
+ currentClass
+ currentMethodCategory currentMethod
+ showInstance actualClass fullClass
+ enterBox questBox
+ selectBox lastMethodCategory'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Interface-Browsers'
+!
+
+SystemBrowser comment:'
+COPYRIGHT (c) 1989 by Claus Gittinger
+ All Rights Reserved
+
+$Header: /cvs/stx/stx/libtool/SystemBrowser.st,v 1.10 1994-08-13 18:39:07 claus Exp $
+'!
+
+!SystemBrowser class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1989 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+!
+
+version
+"
+$Header: /cvs/stx/stx/libtool/SystemBrowser.st,v 1.10 1994-08-13 18:39:07 claus Exp $
+"
+!
+
+documentation
+"
+ this class implements all kinds of class browsers.
+ Stypically, it is started with SystemBrowser open, but there are many other startup
+ messages, to launch special browsers.
+ See the extra document 'doc/misc/sbrowser.doc' for how to use this browser.
+
+ written winter 89 by claus
+"
+! !
+
+!SystemBrowser class methodsFor:'general startup'!
+
+open
+ "launch a standard browser"
+
+ ^ self openOnDisplay:Display
+
+ "SystemBrowser open"
+!
+
+openOnDisplay:aDisplay
+ "launch a standard browser on another display.
+ Does not work currently - still being developped."
+
+ ^ self newWithLabel:(self classResources string:'System Browser')
+ setupBlock:[:browser | browser setupForAll]
+ on:aDisplay
+
+ "
+ SystemBrowser openOnDisplay:(XWorkstation new initializeFor:'porty:0')
+ "
+! !
+
+!SystemBrowser class methodsFor:'startup'!
+
+browseFullClasses
+ "launch a browser showing all methods at once"
+
+ ^ self newWithLabel:'Full Class Browser'
+ setupBlock:[:browser | browser setupForFullClass]
+
+ "SystemBrowser browseFullClasses"
+!
+
+browseClassCategory:aClassCategory
+ "launch a browser for all classes under aCategory"
+
+ ^ self newWithLabel:aClassCategory
+ setupBlock:[:browser | browser setupForClassCategory:aClassCategory]
+
+ "SystemBrowser browseClassCategory:'Kernel-Objects'"
+!
+
+browseClass:aClass
+ "launch a browser for aClass"
+
+ ^ self newWithLabel:aClass name
+ setupBlock:[:browser | browser setupForClass:aClass]
+
+ "SystemBrowser browseClass:Object"
+!
+
+browseClassHierarchy:aClass
+ "launch a browser for aClass and all its superclasses"
+
+ ^ self newWithLabel:(aClass name , '-' , 'hierarchy')
+ setupBlock:[:browser | browser setupForClassHierarchy:aClass]
+
+ "SystemBrowser browseClassHierarchy:Number"
+!
+
+browseClasses:aList title:title
+ "launch a browser for all classes in aList"
+
+ ^ self newWithLabel:title
+ setupBlock:[:browser | browser setupForClassList:aList]
+
+ "
+ SystemBrowser browseClasses:(Array with:Object
+ with:Float)
+ title:'two classes'
+ "
+!
+
+browseClass:aClass methodCategory:aCategory
+ "launch a browser for all methods under aCategory in aClass"
+
+ ^ self newWithLabel:(aClass name , ' ' , aCategory)
+ setupBlock:[:browser | browser setupForClass:aClass methodCategory:aCategory]
+
+ "SystemBrowser browseClass:String methodCategory:'copying'"
+!
+
+browseClass:aClass selector:selector
+ "launch a browser for the method at selector in aClass"
+
+ ^ self newWithLabel:(aClass name , ' ' , selector)
+ setupBlock:[:browser | browser setupForClass:aClass selector:selector]
+
+ "SystemBrowser browseClass:Object selector:#printString"
+!
+
+browseMethods:aList title:aString
+ "launch a browser for an explicit list of class/selectors"
+
+ (aList size == 0) ifTrue:[
+ self showNoneFound:aString.
+ ^ nil
+ ].
+ aList sort.
+ ^ self newWithLabel:aString
+ setupBlock:[:browser | browser setupForList:aList]
+
+ "
+ SystemBrowser browseMethods:#('Object printOn:'
+ 'Collection add:')
+ title:'some methods'
+ "
+!
+
+browseMethodCategory:aCategory
+ "launch a browser for all methods where category = aCategory"
+
+ |searchBlock|
+
+ aCategory includesMatchCharacters ifTrue:[
+ searchBlock := [:c :m :s | aCategory match:m category].
+ ] ifFalse:[
+ searchBlock := [:c :m :s | m category = aCategory]
+ ].
+
+ self browseMethodsWhere:searchBlock title:('all methods with category of ' , aCategory)
+
+ "
+ SystemBrowser browseMethodCategory:'printing & storing'
+ SystemBrowser browseMethodCategory:'print*'
+ "
+!
+
+browseAllSelect:aBlock
+ "launch a browser for all methods where aBlock returns true.
+ The block is called with 3 arguments, class, method and seelctor."
+
+ ^ self browseMethodsWhere:aBlock title:'selected messages'
+!
+
+browseMethodsWhere:aBlock title:title
+ "launch a browser for all methods where aBlock returns true.
+ The block is called with 3 arguments, class, method and seelctor."
+
+ ^ self browseMethodsIn:(Smalltalk allClasses) where:aBlock title:title
+!
+
+browseMethodsOf:aClass where:aBlock title:title
+ "launch a browser for all instance- and classmethods in aClass
+ where aBlock evaluates to true.
+ The block is called with 3 arguments, class, method and seelctor."
+
+ ^ self browseMethodsIn:(Array with:aClass) where:aBlock title:title
+!
+
+browseMethodsFrom:aClass where:aBlock title:title
+ "launch a browser for all instance- and classmethods in aClass
+ and all its subclasses where aBlock evaluates to true.
+ The block is called with 3 arguments, class, method and seelctor."
+
+ ^ self browseMethodsIn:(aClass withAllSubclasses) where:aBlock title:title
+!
+
+browseMethodsIn:aCollectionOfClasses where:aBlock title:title
+ "launch a browser for all instance- and classmethods from
+ all classes in aCollectionOfClasses where aBlock evaluates to true.
+ The block is called with 3 arguments, class, method and seelctor."
+
+ ^ self browseMethodsIn:aCollectionOfClasses inst:true class:true where:aBlock title:title
+!
+
+browseMethodsIn:aCollectionOfClasses inst:wantInst class:wantClass where:aBlock title:title
+ "launch a browser for all instance- (if wantInst is true) and/or
+ classmethods (if wantClass is true) from classes in aCollectionOfClasses,
+ where aBlock evaluates to true.
+ The block is called with 3 arguments, class, method and seelctor."
+
+ |list prio checkedClasses checkBlock|
+
+ "
+ since this may take a long time, lower my priority ...
+ "
+ prio := Processor activeProcess priority.
+ Processor activeProcess priority:(prio - 1).
+
+ checkBlock := [:cls |
+ |methodArray selectorArray|
+
+ (checkedClasses includes:cls) ifFalse:[
+ methodArray := cls methodArray.
+ selectorArray := cls selectorArray.
+
+ 1 to:methodArray size do:[:index |
+ |method sel|
+
+ method := methodArray at:index.
+ sel := selectorArray at:index.
+ (aBlock value:cls value:method value:sel) ifTrue:[
+ list add:(cls name , ' ' , sel)
+ ]
+ ].
+ checkedClasses add:cls.
+ ]
+ ].
+
+ [
+ checkedClasses := IdentitySet new.
+ list := OrderedCollection new.
+ aCollectionOfClasses do:[:aClass |
+ wantInst ifTrue:[checkBlock value:aClass].
+ wantClass ifTrue:[checkBlock value:(aClass class)]
+ ]
+ ] valueNowOrOnUnwindDo:[
+ Processor activeProcess priority:prio.
+ ].
+
+ ^ self browseMethods:list title:title
+!
+
+browseInstMethodsOf:aClass where:aBlock title:title
+ "launch a browser for all instance methods in aClass
+ where aBlock evaluates to true"
+
+ ^ self browseMethodsIn:(Array with:aClass) inst:true class:false where:aBlock title:title
+!
+
+browseInstMethodsFrom:aClass where:aBlock title:title
+ "launch a browser for all instance methods in aClass and all subclasses
+ where aBlock evaluates to true"
+
+ ^ self browseMethodsIn:(aClass withAllSubclasses) inst:true class:false where:aBlock title:title
+!
+
+browseInstMethodsIn:aCollectionOfClasses where:aBlock title:title
+ "launch a browser for all instance methods of all classes in
+ aCollectionOfClasses where aBlock evaluates to true"
+
+ ^ self browseMethodsIn:aCollectionOfClasses inst:true class:false
+ where:aBlock title:title
+! !
+
+!SystemBrowser class methodsFor:'special search startup'!
+
+browseImplementorsOf:aSelectorString in:aCollectionOfClasses title:title
+ "launch a browser for all implementors of aSelector in
+ the classes contained in aCollectionOfClasses and its metaclasses"
+
+ |list sel|
+
+ list := OrderedCollection new.
+
+ ((aSelectorString ~= '*') and:[aSelectorString includesMatchCharacters]) ifTrue:[
+ "a matchString"
+
+ aCollectionOfClasses do:[:aClass |
+ aClass selectorArray do:[:aSelector |
+ (aSelectorString match:aSelector) ifTrue:[
+ list add:(aClass name , ' ' , aSelector)
+ ]
+ ].
+ aClass class selectorArray do:[:aSelector |
+ (aSelectorString match:aSelector) ifTrue:[
+ list add:(aClass name , 'class ' , aSelector)
+ ]
+ ]
+ ]
+ ] ifFalse:[
+ "can do a faster search"
+
+ aSelectorString knownAsSymbol ifFalse:[
+ self showNoneFound:title.
+ ^ nil
+ ].
+
+ sel := aSelectorString asSymbol.
+ aCollectionOfClasses do:[:aClass |
+ (aClass implements:sel) ifTrue:[
+ list add:(aClass name , ' ' , aSelectorString)
+ ].
+ (aClass class implements:sel) ifTrue:[
+ list add:(aClass name , 'class ' , aSelectorString)
+ ]
+ ]
+ ].
+ ^ self browseMethods:list title:title
+
+ "
+ SystemBrowser browseImplementorsOf:#+
+ in:(Array with:Number
+ with:Float
+ with:SmallInteger)
+ title:'some implementors of +'
+ "
+!
+
+browseImplementorsOf:aSelectorString
+ "launch a browser for all implementors of aSelector"
+
+ ^ self browseImplementorsOf:aSelectorString
+ in:(Smalltalk allClasses)
+ title:('implementors of: ' , aSelectorString)
+
+ "
+ SystemBrowser browseImplementorsOf:#+
+ "
+!
+
+browseImplementorsOf:aSelectorString under:aClass
+ "launch a browser for all implementors of aSelector in aClass
+ and its subclasses"
+
+ ^ self browseImplementorsOf:aSelectorString
+ in:(aClass withAllSubclasses)
+ title:('implementors of: ' ,
+ aSelectorString ,
+ ' (in or below ' , aClass name , ')')
+
+ "
+ SystemBrowser browseImplementorsOf:#+ under:Integer
+ "
+!
+
+browseAllCallsOn:aSelectorString in:aCollectionOfClasses title:title
+ "launch a browser for all senders of aSelector in aCollectionOfClasses"
+
+ |sel browser searchBlock|
+
+ ((aSelectorString ~= '*') and:[aSelectorString includesMatchCharacters]) ifTrue:[
+ "a matchString"
+ searchBlock := [:lits |
+ |found|
+
+ found := false.
+ lits notNil ifTrue:[
+ lits do:[:aLiteral |
+ found ifFalse:[
+ (aLiteral isMemberOf:Symbol) ifTrue:[
+ found := (aSelectorString match:aLiteral)
+ ]
+ ]
+ ]
+ ].
+ found
+ ].
+ browser := self browseMethodsIn:aCollectionOfClasses
+ where:[:class :method :s | searchBlock value:(method literals)]
+ title:title
+ ] ifFalse:[
+ aSelectorString knownAsSymbol ifFalse:[
+"
+ Transcript showCr:'none found.'.
+"
+ self showNoneFound:title.
+ ^ nil
+ ].
+
+ sel := aSelectorString asSymbol.
+ browser := self browseMethodsIn:aCollectionOfClasses
+ where:[:class :method :s | method sends:sel]
+ title:title
+ ].
+
+ browser notNil ifTrue:[
+ browser setSearchPattern:aSelectorString
+ ].
+ ^ browser
+!
+
+browseAllCallsOn:aSelectorString
+ "launch a browser for all senders of aSelector"
+
+ ^ self browseAllCallsOn:aSelectorString
+ in:(Smalltalk allClasses)
+ title:('senders of ' , aSelectorString)
+
+ "
+ SystemBrowser browseAllCallsOn:#+
+ "
+!
+
+browseCallsOn:aSelectorString under:aClass
+ "launch a browser for all senders of aSelector in aClass and subclasses"
+
+ ^ self browseAllCallsOn:aSelectorString
+ in:(aClass withAllSubclasses)
+ title:('senders of: ' ,
+ aSelectorString ,
+ ' (in or below ' , aClass name , ')')
+
+ "
+ SystemBrowser browseAllCallsOn:#+ under:Number
+ "
+!
+
+browseForSymbol:aSymbol title:title warnIfNone:doWarn
+ "launch a browser for all methods referencing aSymbol"
+
+ |browser searchBlock sym|
+
+ (aSymbol includesMatchCharacters) ifTrue:[
+ "a matchString"
+ searchBlock := [:lits |
+ |found|
+
+ found := false.
+ lits notNil ifTrue:[
+ lits do:[:aLiteral |
+ found ifFalse:[
+ (aLiteral isMemberOf:Symbol) ifTrue:[
+ found := (aSymbol match:aLiteral)
+ ]
+ ]
+ ]
+ ].
+ found
+ ].
+ ] ifFalse:[
+ "
+ can do a faster search
+ "
+ aSymbol knownAsSymbol ifFalse:[
+ self showNoneFound:title.
+ ^ nil
+ ].
+
+ sym := aSymbol asSymbol.
+ searchBlock := [:lits |
+ |found|
+
+ found := false.
+ lits notNil ifTrue:[
+ lits do:[:aLiteral |
+ found ifFalse:[
+ (aLiteral isMemberOf:Symbol) ifTrue:[
+ found := (sym == aLiteral)
+ ]
+ ]
+ ]
+ ].
+ found
+ ].
+ ].
+ browser := self browseMethodsWhere:[:c :m :s | searchBlock value:(m literals)] title:title.
+ browser notNil ifTrue:[
+ browser setSearchPattern:aSymbol
+ ].
+ ^ browser
+!
+
+browseForSymbol:aSymbol
+ "launch a browser for all methods referencing aSymbol"
+
+ ^ self browseForSymbol:aSymbol title:('users of ' , aSymbol) warnIfNone:true
+!
+
+browseReferendsOf:aGlobalName warnIfNone:doWarn
+ "launch a browser for all methods referencing a global
+ named aGlobalName.
+ "
+
+ ^ self browseForSymbol:aGlobalName title:('users of: ' , aGlobalName) warnIfNone:doWarn
+!
+
+browseReferendsOf:aGlobalName
+ "launch a browser for all methods referencing a global
+ named aGlobalName.
+ "
+
+ ^ self browseReferendsOf:aGlobalName warnIfNone:true
+
+ "
+ Browser browseReferendsOf:#Transcript
+ "
+!
+
+browseForString:aString in:aCollectionOfClasses
+ "launch a browser for all methods in aCollectionOfClasses containing a string"
+
+ |browser searchBlock title|
+
+ title := 'methods containing: ' , aString displayString.
+
+ (aString includesMatchCharacters) ifTrue:[
+ "a matchString"
+ searchBlock := [:lits |
+ |found|
+
+ found := false.
+ lits notNil ifTrue:[
+ lits do:[:aLiteral |
+ found ifFalse:[
+ (aLiteral isMemberOf:String) ifTrue:[
+ found := (aString match:aLiteral)
+ ]
+ ]
+ ]
+ ].
+ found
+ ].
+ ] ifFalse:[
+ searchBlock := [:lits |
+ |found|
+
+ found := false.
+ lits notNil ifTrue:[
+ lits do:[:aLiteral |
+ found ifFalse:[
+ (aLiteral isMemberOf:String) ifTrue:[
+ found := (aLiteral = aString)
+ ]
+ ]
+ ]
+ ].
+ found
+ ].
+ ].
+ browser := self browseMethodsIn:aCollectionOfClasses
+ where:[:c :m :s | searchBlock value:(m literals)]
+ title:title.
+
+ browser notNil ifTrue:[
+ browser setSearchPattern:aString
+ ].
+ ^ browser
+
+ "SystemBrowser browseForString:'*all*'"
+ "SystemBrowser browseForString:'*should*'"
+ "SystemBrowser browseForString:'*[eE]rror*'"
+!
+
+browseForString:aString
+ "launch a browser for all methods containing a string"
+
+ ^ self browseForString:aString in:(Smalltalk allClasses)
+!
+
+aproposSearch:aString in:aCollectionOfClasses
+ "browse all methods, which have aString in their selector or
+ in the methods comment.
+ This is relatively slow, since all source must be processed."
+
+ |matchString list|
+
+ matchString := '*' , aString , '*'.
+
+ list := OrderedCollection new.
+
+ ^ self browseMethodsIn:aCollectionOfClasses
+ where:[:class :method :sel |
+ (matchString match:sel) ifTrue:[
+ list add:(class name , '>>' , sel)
+ ] ifFalse:[
+ (matchString match:(method comment)) ifTrue:[
+ list add:(class name , '>>' , sel)
+ ]
+ ]
+ ]
+ title:('apropos: ' , aString)
+
+ "SystemBrowser aproposSearch:'append'"
+ "SystemBrowser aproposSearch:'add'"
+ "SystemBrowser aproposSearch:'sort'"
+!
+
+aproposSearch:aString
+ "browse all methods, which have aString in their selector or
+ in the methods comment.
+ This is relatively slow, since all source must be processed."
+
+ ^ self aproposSearch:aString in:(Smalltalk allClasses)
+!
+
+browseInstRefsTo:aString in:aCollectionOfClasses modificationsOnly:modsOnly title:title
+ "launch a browser for all methods in aClass where the instVar named
+ aString is referenced; if modsOnly is true, browse only methods where the
+ instvar is modified"
+
+ |parser result instvars searchBlock browser|
+
+ searchBlock := [:c :m :s |
+ result := false.
+ parser := Parser parseMethod:(m source) in:c.
+ parser notNil ifTrue:[
+ modsOnly ifTrue:[
+ instvars := parser modifiedInstVars
+ ] ifFalse:[
+ instvars := parser usedInstVars
+ ].
+ instvars notNil ifTrue:[
+ aString includesMatchCharacters ifTrue:[
+ instvars do:[:iv |
+ (aString match:iv) ifTrue:[result := true]
+ ]
+ ] ifFalse:[
+ result := instvars includes:aString
+ ]
+ ]
+ ].
+ result
+ ].
+ browser := self browseInstMethodsIn:aCollectionOfClasses where:searchBlock title:title.
+
+ browser notNil ifTrue:[
+ browser setSearchPattern:aString
+ ].
+ ^ browser
+!
+
+browseInstRefsTo:aString in:aCollectionOfClasses modificationsOnly:modsOnly
+ "launch a browser for all methods in aClass where the instVar named
+ aString is referenced; if modsOnly is true, browse only methods where the
+ instvar is modified"
+
+ |title|
+
+ modsOnly ifTrue:[
+ title := 'modifications of '
+ ] ifFalse:[
+ title := 'references to '
+ ].
+ ^ self browseInstRefsTo:aString
+ in:aCollectionOfClasses
+ modificationsOnly:modsOnly
+ title:(title , aString)
+!
+
+browseInstRefsTo:aString under:aClass modificationsOnly:modsOnly
+ "launch a browser for all methods in aClass and subclasses
+ where the instVar named aString is referenced;
+ if modsOnly is true, browse only methods where the instvar is modified"
+
+ ^ self browseInstRefsTo:aString in:(aClass withAllSubclasses) modificationsOnly:modsOnly
+!
+
+browseClassRefsTo:aString in:aCollectionOfClasses modificationsOnly:modsOnly title:title
+ "launch a browser for all methods in aCollectionOfClasses,
+ where the classVar named aString is referenced;
+ if modsOnly is true, browse only methods where the classvar is modified"
+
+ |parser result classvars searchBlock browser|
+
+ searchBlock := [:c :m :s |
+ result := false.
+ parser := Parser parseMethod:(m source) in:c.
+ parser notNil ifTrue:[
+ modsOnly ifTrue:[
+ classvars := parser modifiedClassVars
+ ] ifFalse:[
+ classvars := parser usedClassVars
+ ].
+ classvars notNil ifTrue:[
+ aString includesMatchCharacters ifTrue:[
+ classvars do:[:cv |
+ (aString match:cv) ifTrue:[result := true]
+ ]
+ ] ifFalse:[
+ result := classvars includes:aString
+ ]
+ ]
+ ].
+ result
+ ].
+ browser := self browseMethodsIn:aCollectionOfClasses where:searchBlock title:title.
+
+ browser notNil ifTrue:[
+ browser setSearchPattern:aString
+ ].
+ ^ browser
+!
+
+browseClassRefsTo:aString in:aCollectionOfClasses modificationsOnly:modsOnly
+ "launch a browser for all methods in aClass where the classVar named
+ aString is referenced; if modsOnly is true, browse only methods where the
+ classvar is modified"
+
+ |title|
+
+ modsOnly ifTrue:[
+ title := 'modifications of '
+ ] ifFalse:[
+ title := 'references to '
+ ].
+ ^ self browseClassRefsTo:aString in:aCollectionOfClasses modificationsOnly:modsOnly title:(title , aString)
+!
+
+browseClassRefsTo:aString under:aClass modificationsOnly:modsOnly
+ "launch a browser for all methods in aClass and subclasses
+ where the classVar named aString is referenced;
+ if modsOnly is true, browse only methods where the classvar is modified"
+
+ ^ self browseClassRefsTo:aString in:(aClass withAllSubclasses) modificationsOnly:modsOnly
+! !
+
+!SystemBrowser class methodsFor:'private'!
+
+showNoneFound:what
+"/ DialogView warn:(self classResources string:('no ' , what , ' found')).
+ self showNoneFound
+!
+
+showNoneFound
+ DialogView warn:(self classResources string:'None found').
+!
+
+newWithLabel:aString setupBlock:aBlock on:aWorkstation
+ "common helper method for all creation methods"
+
+ |newBrowser|
+
+ newBrowser := self on:aWorkstation.
+ newBrowser label:aString.
+ aBlock value:newBrowser.
+
+ newBrowser open.
+ ^ newBrowser
+!
+
+newWithLabel:aString setupBlock:aBlock
+ "common helper method for all creation methods"
+
+ ^ self newWithLabel:aString setupBlock:aBlock on:Display
+! !
+
+!SystemBrowser methodsFor:'initialize / release'!
+
+initialize
+ super initialize.
+
+ self icon:(Form fromFile:(resources at:'ICON_FILE' default:'SBrowser.xbm')
+ resolution:100).
+
+ showInstance := true.
+ fullClass := false.
+
+ "inform me, when Smalltalk changes"
+ Smalltalk addDependent:self
+!
+
+destroy
+ "relese dependant - destroy popups"
+
+ Smalltalk removeDependent:self.
+ currentClass notNil ifTrue:[
+ currentClass removeDependent:self.
+ currentClass := nil
+ ].
+ enterBox notNil ifTrue:[enterBox destroy. enterBox := nil].
+ questBox notNil ifTrue:[questBox destroy. questBox := nil].
+ selectBox notNil ifTrue:[selectBox destroy. selectBox := nil].
+ super destroy
+!
+
+terminate
+ (self checkSelectionChangeAllowed) ifTrue:[
+ super terminate
+ ]
+!
+
+createTogglesIn:aFrame
+ "create and setup the class/instance toggles"
+
+ |bw halfSpacing|
+
+ instanceToggle := Toggle label:(resources at:'instance') in:aFrame.
+ bw := instanceToggle borderWidth.
+ halfSpacing := [
+ (self is3D and:[style ~~ #st80]) ifTrue:[
+ ViewSpacing // 2
+ ] ifFalse:[
+ 0
+ ]
+ ].
+ instanceToggle extent:[(aFrame width // 2 - halfSpacing value) @ instanceToggle height].
+ instanceToggle origin:[bw negated + halfSpacing value
+ @
+ (aFrame height - instanceToggle heightIncludingBorder + bw)].
+
+ instanceToggle turnOn.
+ instanceToggle pressAction:[self instanceProtocol].
+ instanceToggle releaseAction:[self classProtocol].
+
+ classToggle := Toggle label:(resources at:'class') in:aFrame.
+ classToggle extent:[(aFrame width - (aFrame width // 2) - halfSpacing value) @ classToggle height].
+ classToggle origin:[(aFrame width // 2 + halfSpacing value)
+ @
+ (aFrame height - classToggle heightIncludingBorder + bw)].
+
+ classToggle turnOff.
+ classToggle pressAction:[self classProtocol].
+ classToggle releaseAction:[self instanceProtocol]
+!
+
+createClassListViewIn:frame
+ "setup the classlist subview, with its toggles"
+
+ |v|
+
+ self createTogglesIn:frame.
+
+ v := ScrollableView for:SelectionInListView in:frame.
+ v origin:(0.0 @ 0.0)
+ extent:[frame width
+ @
+ (frame height
+ - instanceToggle height
+ - instanceToggle borderWidth)].
+
+ classListView := v scrolledView
+!
+
+createCodeViewIn:aView
+ "setup the code view"
+ |v|
+
+ v := HVScrollableView for:CodeView miniScrollerH:true miniScrollerV:false in:aView.
+ v origin:(0.0 @ 0.25) corner:(1.0 @ 1.0).
+ codeView := v scrolledView
+!
+
+setupActions
+"/ |v|
+
+"/ v := classCategoryListView.
+"/ v notNil ifTrue:[
+"/ v action:[:lineNr | self classCategorySelection:lineNr].
+"/ v selectConditionBlock:[self checkSelectionChangeAllowed].
+"/ v ignoreReselect:false.
+"/ ].
+"/ v := classListView.
+"/ v notNil ifTrue:[
+"/ v action:[:lineNr | self classSelection:lineNr].
+"/ v selectConditionBlock:[self checkSelectionChangeAllowed].
+"/ v ignoreReselect:false.
+"/ ].
+"/ v := methodCategoryListView.
+"/ v notNil ifTrue:[
+"/ v action:[:lineNr | self methodCategorySelection:lineNr].
+"/ v selectConditionBlock:[self checkSelectionChangeAllowed].
+"/ v ignoreReselect:false.
+"/ ].
+"/ v := methodListView.
+"/ v notNil ifTrue:[
+"/ v action:[:lineNr | self methodSelection:lineNr].
+"/ v selectConditionBlock:[self checkSelectionChangeAllowed].
+"/ v ignoreReselect:false.
+"/ ].
+"/ v := classMethodListView.
+"/ v notNil ifTrue:[
+"/ v action:[:lineNr | self listSelection:lineNr].
+"/ v selectConditionBlock:[self checkSelectionChangeAllowed].
+"/ v ignoreReselect:false.
+"/ ]
+!
+
+setupForAll
+ "create subviews for a full browser"
+
+ |vpanel hpanel frame v|
+
+ vpanel := VariableVerticalPanel origin:(0.0 @ 0.0) corner:(1.0 @ 1.0)
+ in:self.
+ hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
+
+ v := HVScrollableView for:SelectionInListView
+ miniScrollerH:true miniScrollerV:false
+ in:hpanel.
+ v origin:(0.0 @ 0.0) corner:(0.25 @ 1.0).
+ classCategoryListView := v scrolledView.
+"/ classCategoryListView contents:(self listOfAllClassCategories).
+
+ frame := View origin:(0.25 @ 0.0) corner:(0.5 @ 1.0) in:hpanel.
+ self createClassListViewIn:frame.
+
+ v := HVScrollableView for:SelectionInListView miniScrollerH:true miniScrollerV:false in:hpanel.
+ v origin:(0.5 @ 0.0) corner:(0.75 @ 1.0).
+ methodCategoryListView := v scrolledView.
+
+ v := HVScrollableView for:SelectionInListView miniScrollerH:true miniScrollerV:false in:hpanel.
+ v origin:(0.75 @ 0.0) corner:(1.0 @ 1.0).
+ methodListView := v scrolledView.
+
+"/ self setupActions.
+ self createCodeViewIn:vpanel
+!
+
+setupForFullClass
+ "setup subviews to browse a class as full text"
+
+ |vpanel hpanel v|
+
+ vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
+ corner:(1.0 @ 1.0)
+ in:self.
+
+ hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.0 @ 0.0) corner:(0.5 @ 1.0).
+ classCategoryListView := v scrolledView.
+ classCategoryListView contents:(self listOfAllClassCategories).
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.5 @ 0.0) corner:(1.0 @ 1.0).
+ classListView := v scrolledView.
+
+"/ self setupActions.
+ self createCodeViewIn:vpanel.
+
+ fullClass := true.
+ self updateCodeView
+!
+
+setupForClassCategory:aClassCategory
+ "setup subviews to browse a class category"
+
+ |vpanel hpanel frame v|
+
+ vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
+ corner:(1.0 @ 1.0)
+ in:self.
+
+ hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
+ frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
+
+ self createClassListViewIn:frame.
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
+ methodCategoryListView := v scrolledView.
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.66 @ 0.0) corner:(1.0 @ 1.0).
+ methodListView := v scrolledView.
+
+"/ self setupActions.
+ self createCodeViewIn:vpanel.
+
+ currentClassCategory := aClassCategory.
+ self updateClassList.
+ self updateMethodCategoryList.
+ self updateMethodList.
+ self updateCodeView
+!
+
+setupForClassList:aList
+ "setup subviews to browse classes from a list"
+
+ |vpanel hpanel frame l v|
+
+ vpanel := VariableVerticalPanel
+ origin:(0.0 @ 0.0) corner:(1.0 @ 1.0) in:self.
+
+ hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
+ frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
+
+ self createClassListViewIn:frame.
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
+ methodCategoryListView := v scrolledView.
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.66 @ 0.0) corner:(1.0 @ 1.0).
+ methodListView := v scrolledView.
+
+"/ self setupActions.
+ self createCodeViewIn:vpanel.
+
+ l := aList collect:[:entry | entry name].
+ classListView list:(l sort).
+
+ self updateMethodCategoryList.
+ self updateMethodList.
+ self updateCodeView
+!
+
+setupForClassHierarchy:aClass
+ "setup subviews to browse a class hierarchy"
+
+ |vpanel hpanel frame v|
+
+ vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
+ corner:(1.0 @ 1.0)
+ in:self.
+
+ hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
+ frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
+
+ self createClassListViewIn:frame.
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
+ methodCategoryListView := v scrolledView.
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.66 @ 0.0) corner:(1.0 @ 1.0).
+ methodListView := v scrolledView.
+
+"/ self setupActions.
+ self createCodeViewIn:vpanel.
+
+ currentClassHierarchy := aClass.
+ self updateClassList.
+ self updateMethodCategoryList.
+ self updateMethodList.
+ self updateCodeView
+!
+
+setupForClass:aClass
+ "create subviews for browsing a single class"
+
+ |vpanel hpanel frame v|
+
+ vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
+ corner:(1.0 @ 1.0)
+ in:self.
+
+ hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
+ frame := View origin:(0.0 @ 0.0) corner:(0.5 @ 1.0)in:hpanel.
+
+ self createTogglesIn:frame.
+
+ v := ScrollableView for:SelectionInListView in:frame.
+ v origin:(0.0 @ 0.0)
+ extent:[frame width
+ @
+ (frame height - instanceToggle heightIncludingBorder)].
+ methodCategoryListView := v scrolledView.
+
+ v := ScrollableView for:SelectionInListView in:hpanel.
+ v origin:(0.5 @ 0.0) corner:(1.0 @ 1.0).
+ methodListView := v scrolledView.
+
+"/ self setupActions.
+ self createCodeViewIn:vpanel.
+
+ self switchToClass:aClass.
+ actualClass := aClass.
+ self updateMethodCategoryList.
+ self updateMethodList.
+ self updateCodeView
+!
+
+setupForClass:aClass methodCategory:aMethodCategory
+ "setup subviews to browse a method category"
+
+ |vpanel v|
+
+ vpanel := VariableVerticalPanel
+ origin:(0.0 @ 0.0) corner:(1.0 @ 1.0)
+ in:self.
+
+ v := ScrollableView for:SelectionInListView in:vpanel.
+ v origin:(0.0 @ 0.0) corner:(1.0 @ 0.25).
+ methodListView := v scrolledView.
+
+"/ self setupActions.
+ self createCodeViewIn:vpanel.
+
+ currentClassCategory := aClass category.
+ self switchToClass:aClass.
+ actualClass := aClass.
+ currentMethodCategory := aMethodCategory.
+ self updateMethodList.
+ self updateCodeView
+!
+
+setupForClass:aClass selector:selector
+ "setup subviews to browse a single method"
+
+ |v|
+
+ v := ScrollableView for:CodeView in:self.
+ v origin:(0.0 @ 0.0) corner:(1.0 @ 1.0).
+ codeView := v scrolledView.
+
+ currentClassCategory := aClass category.
+ self switchToClass:aClass.
+ actualClass := aClass.
+ currentMethod := currentClass compiledMethodAt:selector.
+ currentMethodCategory := currentMethod category.
+ self updateCodeView
+!
+
+setupForList:aList
+ "setup subviews to browse methods from a list"
+
+ |vpanel v|
+
+ vpanel := VariableVerticalPanel
+ origin:(0.0 @ 0.0)
+ corner:(1.0 @ 1.0)
+ in:self.
+
+ v := ScrollableView for:SelectionInListView in:vpanel.
+ v origin:(0.0 @ 0.0) corner:(1.0 @ 0.25).
+ classMethodListView := v scrolledView.
+ classMethodListView contents:aList.
+
+"/ self setupActions.
+ self createCodeViewIn:vpanel.
+
+ self updateCodeView
+! !
+
+!SystemBrowser methodsFor:'realization'!
+
+realize
+ |v|
+
+ super realize.
+
+ v := classCategoryListView.
+ v notNil ifTrue:[
+ v action:[:lineNr | self classCategorySelection:lineNr].
+ v selectConditionBlock:[self checkSelectionChangeAllowed].
+ v ignoreReselect:false.
+ v contents:(self listOfAllClassCategories).
+ self initializeClassCategoryMenu
+ ].
+
+ v := classListView.
+ v notNil ifTrue:[
+ v action:[:lineNr | self classSelection:lineNr].
+ v selectConditionBlock:[self checkSelectionChangeAllowed].
+ v ignoreReselect:false.
+ self initializeClassMenu
+ ].
+
+ v := methodCategoryListView.
+ v notNil ifTrue:[
+ v action:[:lineNr | self methodCategorySelection:lineNr].
+ v selectConditionBlock:[self checkSelectionChangeAllowed].
+ v ignoreReselect:false.
+ self initializeMethodCategoryMenu
+ ].
+
+ v := methodListView.
+ v notNil ifTrue:[
+ v action:[:lineNr | self methodSelection:lineNr].
+ v selectConditionBlock:[self checkSelectionChangeAllowed].
+ v ignoreReselect:false.
+ self initializeMethodMenu
+ ].
+
+ v := classMethodListView.
+ v notNil ifTrue:[
+ v action:[:lineNr | self listSelection:lineNr].
+ v selectConditionBlock:[self checkSelectionChangeAllowed].
+ v ignoreReselect:false.
+ self initializeClassMethodMenu
+ ]
+! !
+
+!SystemBrowser methodsFor:'private'!
+
+checkSelectionChangeAllowed
+ "return true, if selection change is ok;
+ its not ok, if code has been changed.
+ in this case, return the result of a user query"
+
+ |box|
+
+ codeView modified ifFalse:[
+ ^ true
+ ].
+ box := questBox.
+ box isNil ifTrue:[
+ box := questBox := YesNoBox title:''
+ ].
+
+ box title:(resources at:'contents in codeview has not been accepted.\\Modifications will be lost when continuing.') withCRs.
+ box okText:(resources at:'continue').
+ box noText:(resources at:'abort').
+ box yesAction:[^ true] noAction:[^ false].
+ box showAtPointer
+!
+
+switchToClass:newClass
+ currentClass notNil ifTrue:[
+ currentClass removeDependent:self
+ ].
+ currentClass := newClass.
+ currentClass notNil ifTrue:[
+ currentClass addDependent:self
+ ]
+!
+
+showExplanation:someText
+ "show explanation from Parser"
+
+ self notify:someText
+!
+
+setSearchPattern:aString
+ codeView setSearchPattern:aString
+!
+
+selectorToSearchFor
+ "look in codeView and methodListView for a search-string when searching for selectors"
+
+ |sel t|
+
+ sel := codeView selection.
+ sel notNil ifTrue:[
+ sel := sel asString.
+ t := Parser selectorInExpression:sel.
+ t notNil ifTrue:[
+ sel := t
+ ].
+ sel := sel withoutSpaces
+ ] ifFalse:[
+ methodListView notNil ifTrue:[
+ sel := methodListView selectionValue
+ ] ifFalse:[
+ classMethodListView notNil ifTrue:[
+ sel := classMethodListView selectionValue.
+ sel notNil ifTrue:[
+ sel := self selectorFromClassMethodString:sel
+ ]
+ ]
+ ].
+ sel notNil ifTrue:[
+ sel := sel withoutSpaces
+ ] ifFalse:[
+ sel := ''
+ ]
+ ].
+ ^ sel
+!
+
+stringToSearchFor
+ "look in codeView and methodListView for a search-string when searching for classes/names"
+
+ |sel|
+
+ sel := codeView selection.
+ sel notNil ifTrue:[
+ sel := sel asString withoutSpaces
+ ] ifFalse:[
+ sel isNil ifTrue:[
+ currentClass notNil ifTrue:[
+ sel := currentClass name
+ ]
+ ].
+ sel notNil ifTrue:[
+ sel := sel withoutSpaces
+ ] ifFalse:[
+ sel := ''
+ ]
+ ].
+ ^ sel
+!
+
+findClassOfVariable:aVariableName accessWith:aSelector
+ "this method returns the class, in which a variable
+ is defined;
+ needs either #instVarNames or #classVarNames as aSelector."
+
+ |cls homeClass|
+
+ "
+ first, find the class, where the variable is declared
+ "
+ cls := currentClass.
+ [cls notNil] whileTrue:[
+ ((cls perform:aSelector) includes:aVariableName) ifTrue:[
+ homeClass := cls.
+ cls := nil.
+ ] ifFalse:[
+ cls := cls superclass
+ ]
+ ].
+ homeClass isNil ifTrue:[
+ "nope, must be one below ... (could optimize a bit, by searching down
+ for the declaring class ...
+ "
+ homeClass := currentClass
+ ] ifFalse:[
+ Transcript showCr:'starting search in ' , homeClass name.
+ ].
+ ^ homeClass
+!
+
+listBoxTitle:title okText:okText list:aList
+ "convenient method: setup a listBox"
+
+ |box|
+
+ box := selectBox.
+ box isNil ifTrue:[
+ box := selectBox := ListSelectionBox
+ title:''
+ okText:(resources string:'ok')
+ abortText:(resources string:'abort')
+ action:[:aString | ]
+ ].
+ box title:(resources string:title).
+ box list:aList.
+!
+
+enterBoxTitle:title okText:okText
+ "convenient method: setup enterBox"
+
+ |box|
+
+ box := enterBox.
+ box isNil ifTrue:[
+ box := enterBox := EnterBox new
+ ].
+ box title:(resources string:title) okText:(resources string:okText).
+ box initialText:''
+!
+
+enterBoxForSearchSelectorTitle:title
+ "convenient method: setup enterBox with text from codeView or selected
+ method for browsing based on a selector"
+
+ self enterBoxTitle:title okText:'search'.
+ enterBox initialText:(self selectorToSearchFor)
+!
+
+enterBoxForBrowseSelectorTitle:title
+ "convenient method: setup enterBox with text from codeView or selected
+ method for browsing based on a selector"
+
+ self enterBoxTitle:title okText:'browse'.
+ enterBox initialText:(self selectorToSearchFor)
+!
+
+enterBoxForBrowseTitle:title
+ "convenient method: setup enterBox with text from codeView or selected
+ method for method browsing based on className/variable"
+
+ self enterBoxTitle:title okText:'browse'.
+ enterBox initialText:(self stringToSearchFor)
+!
+
+enterBoxForCodeSelectionTitle:title okText:okText
+ "convenient method: setup enterBox with text from codeview"
+
+ |sel|
+
+ self enterBoxTitle:(resources string:title) okText:(resources string:okText).
+ sel := codeView selection.
+ sel notNil ifTrue:[
+ enterBox initialText:(sel asString withoutSeparators)
+ ] ifFalse:[
+ enterBox initialText:nil
+ ]
+!
+
+enterBoxForMethodCategory:title
+ "convenient method: setup enterBox with initial being current method category"
+
+ |sel|
+
+ self enterBoxTitle:title okText:'browse'.
+ sel := codeView selection.
+ sel isNil ifTrue:[
+ currentMethodCategory notNil ifTrue:[
+ sel := currentMethodCategory
+ ]
+ ].
+ sel notNil ifTrue:[
+ enterBox initialText:(sel asString withoutSpaces)
+ ]
+!
+
+newClassCategory:aString
+ |categories|
+
+ categories := classCategoryListView list.
+ (categories includes:aString) ifFalse:[
+ categories add:aString.
+ categories sort.
+ classCategoryListView setContents:categories.
+ currentClassCategory := aString.
+ classCategoryListView selectElement:aString.
+ self switchToClass:nil.
+ actualClass := nil.
+ self classCategorySelectionChanged
+ ]
+!
+
+listOfAllClassCategories
+ "return a list of all class categories"
+
+ |newList cat|
+
+ newList := Text with:'* all *' with:'* hierarchy *'.
+ Smalltalk allBehaviorsDo:[:aClass |
+ cat := aClass category.
+ cat isNil ifTrue:[
+ cat := '* no category *'
+ ].
+ newList indexOf:cat ifAbsent:[newList add:cat]
+ ].
+ newList sort.
+ ^ newList
+!
+
+listOfClassHierarchyOf:aClass
+ "return a hierarchy class-list"
+
+ ^ (aClass allSuperclasses reverse ,
+ (Array with:aClass),
+ aClass allSubclassesInOrder) collect:[:c | c name]
+
+"
+ |newList theClass|
+
+ theClass := aClass.
+ newList := Text with:theClass name.
+ [theClass ~~ Object] whileTrue:[
+ theClass := theClass superclass.
+ newList add:theClass name
+ ].
+ newList reverse.
+ ^ newList
+"
+!
+
+listOfAllClassesInCategory:aCategory
+ "return a list of all classes in a given category"
+
+ |newList classList searchCategory string|
+
+ newList := Text new.
+ (aCategory = '* all *') ifTrue:[
+ Smalltalk allBehaviorsDo:[:aClass |
+ string := aClass name.
+ newList indexOf:string ifAbsent:[newList add:string]
+ ]
+ ] ifFalse:[
+ (aCategory = '* hierarchy *') ifTrue:[
+ classList := Text new.
+ self classHierarchyDo:[:aClass :lvl|
+ string := aClass name.
+ classList indexOf:string ifAbsent:[
+ classList add:string.
+ newList add:(String new:lvl) , string
+ ]
+ ].
+ ^ newList
+ ] ifFalse:[
+ (aCategory = '* no category *') ifTrue:[
+ searchCategory := nil
+ ] ifFalse:[
+ searchCategory := aCategory
+ ].
+ Smalltalk allBehaviorsDo:[:aClass |
+ aClass isMeta ifFalse:[
+ (aClass category = searchCategory) ifTrue:[
+ string := aClass name.
+ newList indexOf:string ifAbsent:[newList add:string]
+ ]
+ ]
+ ]
+ ]
+ ].
+ (newList size == 0) ifTrue:[^ nil].
+ ^ newList sort
+!
+
+classHierarchyDo:aBlock
+ "eavluate the 2-arg block for every class,
+ starting at Object; passing class and nesting level to the block."
+
+ |classes s classDict l|
+
+ classes := Smalltalk allClasses.
+ classDict := IdentityDictionary new:classes size.
+ classes do:[:aClass |
+ s := aClass superclass.
+ s notNil ifTrue:[
+ l := classDict at:s ifAbsent:[nil].
+ l isNil ifTrue:[
+ l := OrderedCollection new:5.
+ classDict at:s put:l
+ ].
+ l add:aClass
+ ]
+ ].
+ self classHierarchyOf:Object level:0 do:aBlock using:classDict
+!
+
+classHierarchyOf:aClass level:level do:aBlock using:aDictionary
+ "evaluate the 2-arg block for every subclass of aClass,
+ passing class and nesting level to the block."
+
+ |names subclasses|
+
+ aBlock value:aClass value:level.
+ subclasses := aDictionary at:aClass ifAbsent:[nil].
+ (subclasses size == 0) ifFalse:[
+ names := subclasses collect:[:class | class name].
+ names sortWith:subclasses.
+ subclasses do:[:aSubClass |
+ self classHierarchyOf:aSubClass level:(level + 1) do:aBlock using:aDictionary
+ ]
+ ]
+!
+
+listOfAllMethodCategoriesInClass:aClass
+ "answer a list of all method categories of the argument, aClass"
+
+ |newList cat|
+
+ newList := Text new.
+ aClass methodArray do:[:aMethod |
+ cat := aMethod category.
+ cat isNil ifTrue:[
+ cat := '* no category *'
+ ].
+ (newList includes:cat) ifFalse:[newList add:cat]
+ ].
+ (newList size == 0) ifTrue:[^ nil].
+ newList add:'* all *'.
+ ^ newList sort
+!
+
+listOfAllSelectorsInCategory:aCategory ofClass:aClass
+ "answer a list of all selectors in a given method category
+ of the argument, aClass"
+
+ |newList searchCategory selector|
+
+ (aCategory = '* all *') ifTrue:[
+ newList := aClass selectorArray asText
+ ] ifFalse:[
+ (aCategory = '* no category *') ifTrue:[
+ searchCategory := nil
+ ] ifFalse:[
+ searchCategory := aCategory
+ ].
+ newList := Text new.
+ aClass methodArray do:[:aMethod |
+ (aMethod category = searchCategory) ifTrue:[
+ selector := aClass selectorForMethod:aMethod.
+ selector notNil ifTrue:[
+ aMethod isWrapped ifTrue:[
+ selector := selector , ' !!'
+ ].
+ (newList includes:selector) ifFalse:[
+ newList add:selector
+ ]
+ ]
+ ]
+ ]
+ ].
+ (newList size == 0) ifTrue:[^ nil].
+ ^ newList sort
+!
+
+templateFor:className in:cat
+ "return a class definition template - be smart in what is offered initially"
+
+ |aString name i|
+
+ name := 'NewClass'.
+ i := 1.
+ [name knownAsSymbol and:[Smalltalk includesKey:name asSymbol]] whileTrue:[
+ i := i + 1.
+ name := 'NewClass' , i printString
+ ].
+
+ aString := className , ' subclass:#' , name , '
+ instanceVariableNames: ''''
+ classVariableNames: ''''
+ poolDictionaries: ''''
+ category: '''.
+
+ cat notNil ifTrue:[
+ aString := aString , cat
+ ].
+ aString := aString , ''''.
+ ^ aString
+!
+
+template
+ "return a method definition template"
+
+ ^
+'message selector and argument names
+ "comment stating purpose of message"
+
+
+ |temporaries|
+ statements
+'
+!
+
+compileCode:someCode
+ (ReadStream on:someCode) fileIn
+! !
+
+!SystemBrowser methodsFor:'user interaction'!
+
+instanceProtocol
+ showInstance ifFalse:[
+ self checkSelectionChangeAllowed ifTrue:[
+ classToggle turnOff.
+ instanceToggle turnOn.
+ showInstance := true.
+ currentClass notNil ifTrue:[
+ self classSelectionChanged
+ ].
+ codeView modified:false.
+ ] ifFalse:[
+ instanceToggle turnOff.
+ classToggle turnOn
+ ]
+ ]
+!
+
+classProtocol
+ showInstance ifTrue:[
+ self checkSelectionChangeAllowed ifTrue:[
+ instanceToggle turnOff.
+ classToggle turnOn.
+ showInstance := false.
+ currentClass notNil ifTrue:[
+ self classSelectionChanged
+ ].
+ codeView modified:false.
+ ] ifFalse:[
+ instanceToggle turnOn.
+ classToggle turnOff
+ ]
+ ]
+!
+
+updateClassCategoryListWithScroll:scroll
+ |oldClassCategory oldClass oldMethodCategory oldMethod
+ oldSelector newCategoryList|
+
+ classMethodListView notNil ifTrue:[ ^ self ].
+
+ oldClassCategory := currentClassCategory.
+ oldClass := currentClass.
+ oldMethodCategory := currentMethodCategory.
+ oldMethod := currentMethod.
+ oldMethod notNil ifTrue:[
+ oldSelector := methodListView selectionValue
+ ].
+
+ classCategoryListView notNil ifTrue:[
+ newCategoryList := self listOfAllClassCategories.
+ newCategoryList = classCategoryListView list ifFalse:[
+ scroll ifTrue:[
+ classCategoryListView contents:newCategoryList
+ ] ifFalse:[
+ classCategoryListView setContents:newCategoryList
+ ]
+ ]
+ ].
+
+ oldClassCategory notNil ifTrue:[
+ classCategoryListView notNil ifTrue:[
+ classCategoryListView selectElement:oldClassCategory
+ ]
+ ].
+ classListView notNil ifTrue:[
+ oldClass notNil ifTrue:[
+ classListView selectElement:(oldClass name)
+ ]
+ ].
+ oldMethodCategory notNil ifTrue:[
+ methodCategoryListView notNil ifTrue:[
+ methodCategoryListView selectElement:oldMethodCategory
+ ].
+ ].
+ oldSelector notNil ifTrue:[
+ methodListView notNil ifTrue:[
+ methodListView selectElement:oldSelector
+ ].
+ ]
+!
+
+updateClassCategoryList
+ self updateClassCategoryListWithScroll:true
+!
+
+updateClassListWithScroll:scroll
+ |classes oldClassName|
+
+ classListView notNil ifTrue:[
+ currentClass notNil ifTrue:[
+ oldClassName := currentClass name.
+ currentClass := Smalltalk at:(oldClassName asSymbol).
+ ].
+
+ currentClassCategory notNil ifTrue:[
+ classes := self listOfAllClassesInCategory:currentClassCategory
+ ] ifFalse:[
+ currentClassHierarchy notNil ifTrue:[
+ classes := self listOfClassHierarchyOf:currentClassHierarchy
+ ]
+ ].
+
+ classListView list = classes ifFalse:[
+ scroll ifTrue:[
+ classListView contents:classes
+ ] ifFalse:[
+ classListView setContents:classes
+ ].
+ oldClassName notNil ifTrue:[
+ classListView setContents:classes.
+ classListView selectElement:oldClassName
+ ].
+ ]
+ ]
+!
+
+updateClassList
+ self updateClassListWithScroll:true
+!
+
+updateMethodCategoryListWithScroll:scroll
+ |categories|
+
+ methodCategoryListView notNil ifTrue:[
+ currentClass notNil ifTrue:[
+ categories := self listOfAllMethodCategoriesInClass:actualClass
+ ].
+ methodCategoryListView list = categories ifFalse:[
+ scroll ifTrue:[
+ methodCategoryListView contents:categories
+ ] ifFalse:[
+ methodCategoryListView setContents:categories
+ ].
+ currentMethodCategory notNil ifTrue:[
+ methodCategoryListView selectElement:currentMethodCategory
+ ]
+ ]
+ ]
+!
+
+updateMethodCategoryList
+ self updateMethodCategoryListWithScroll:true
+!
+
+updateMethodListWithScroll:scroll
+ |selectors scr first last|
+
+ methodListView notNil ifTrue:[
+ currentMethodCategory notNil ifTrue:[
+ selectors := self listOfAllSelectorsInCategory:currentMethodCategory
+ ofClass:actualClass
+ ].
+ scr := scroll.
+ first := methodListView firstLineShown.
+ first ~~ 1 ifTrue:[
+ last := methodListView lastLineShown.
+ selectors size <= (last - first + 1) ifTrue:[
+ scr := true
+ ]
+ ].
+ methodListView list = selectors ifFalse:[
+ scr ifTrue:[
+ methodListView contents:selectors
+ ] ifFalse:[
+ methodListView setContents:selectors
+ ]
+ ].
+ ]
+!
+
+updateMethodList
+ self updateMethodListWithScroll:true
+!
+
+updateCodeView
+ |code aStream|
+
+ fullClass ifTrue:[
+ currentClass notNil ifTrue:[
+" this is too slow for big classes ...
+ code := String new:1000.
+ aStream := WriteStream on:code.
+ currentClass fileOutOn:aStream
+"
+ aStream := FileStream newFileNamed:'__temp'.
+ aStream isNil ifTrue:[
+ self notify:'cannot create temporary file.'.
+ codeView contents:nil.
+ codeView modified:false.
+ ^ self
+ ].
+ currentClass fileOutOn:aStream.
+ aStream close.
+ aStream := FileStream oldFileNamed:'__temp'.
+ aStream isNil ifTrue:[
+ self notify:'oops - cannot reopen temp file'.
+ codeView contents:nil.
+ codeView modified:false.
+ ^ self
+ ].
+ code := aStream contents.
+ aStream close.
+ OperatingSystem removeFile:'__temp'
+ ]
+ ] ifFalse:[
+ currentMethod notNil ifTrue:[
+ code := currentMethod source
+ ]
+ ].
+ codeView contents:code.
+ codeView modified:false
+!
+
+classSelectionChanged
+ |oldMethodCategory oldMethod|
+
+ self withWaitCursorDo:[
+ oldMethodCategory := currentMethodCategory.
+ oldMethod := currentMethod.
+
+ showInstance ifTrue:[
+ actualClass := currentClass
+ ] ifFalse:[
+ actualClass := currentClass class
+ ].
+ currentMethodCategory := nil.
+ currentMethod := nil.
+
+ self updateMethodCategoryList.
+ oldMethodCategory notNil ifTrue:[
+ methodCategoryListView selectElement:oldMethodCategory.
+ methodCategoryListView selection notNil ifTrue:[
+ currentMethodCategory := oldMethodCategory.
+ self methodCategorySelectionChanged
+ ]
+ ].
+ self updateMethodList.
+ self updateCodeView.
+
+ fullClass ifTrue:[
+ codeView acceptAction:[:theCode |
+ codeView cursor:Cursor execute.
+ Object abortSignal catch:[
+ self compileCode:theCode asString.
+ codeView modified:false.
+ ].
+ codeView cursor:Cursor normal.
+ ].
+ codeView explainAction:nil
+ ] ifFalse:[
+ self classDefinition.
+ codeView acceptAction:[:theCode |
+ codeView cursor:Cursor execute.
+ Object abortSignal catch:[
+ (Compiler evaluate:theCode asString notifying:codeView)
+ isBehavior ifTrue:[
+ self classCategoryUpdate.
+ self updateClassListWithScroll:false.
+ codeView modified:false.
+ ].
+ ].
+ codeView cursor:Cursor normal.
+ ].
+ codeView explainAction:nil
+ ].
+ classCategoryListView notNil ifTrue:[
+ (currentClassCategory = currentClass category) ifFalse:[
+ currentClassCategory := currentClass category.
+ classCategoryListView selectElement:currentClassCategory
+ ]
+ ].
+
+ "set self for doits. This allows accessing the current class
+ as self, and access to the class variables by name."
+
+ codeView doItAction:[:theCode |
+ |compiler|
+
+ currentClass isNil ifTrue:[
+ compiler := Compiler
+ ] ifFalse:[
+ compiler := currentClass compiler
+ ].
+ compiler
+ evaluate:theCode
+ in:nil
+ receiver:currentClass
+ notifying:codeView
+ logged:false
+ ifFail:nil
+ ]
+ ]
+!
+
+classCategorySelectionChanged
+ "class category has changed - update dependant views"
+
+ self withWaitCursorDo:[
+ self switchToClass:nil.
+ actualClass := nil.
+ currentMethodCategory := nil.
+ currentMethod := nil.
+
+ self updateClassList.
+ self updateMethodCategoryList.
+ self updateMethodList.
+ self updateCodeView.
+
+ codeView explainAction:nil.
+ codeView acceptAction:nil
+ ]
+!
+
+classCategorySelection:lineNr
+ "user clicked on a class category line - show classes.
+ If switching to hierarchy or all, keep current selections"
+
+ |newCategory oldClass classIndex index|
+
+ newCategory := classCategoryListView selectionValue.
+ (newCategory startsWith:'*') ifTrue:[
+ "etiher all or hierarchy;
+ remember current selections and switch after showing class list"
+ oldClass := currentClass
+ ].
+ currentClassCategory := newCategory.
+ oldClass isNil ifTrue:[
+ self classCategorySelectionChanged
+ ] ifFalse:[
+ self withWaitCursorDo:[
+ self updateClassList
+ ].
+ "stupid - search for class name in (indented) list"
+ index := 1.
+ classListView list do:[:elem |
+ (elem endsWith:(oldClass name)) ifTrue:[
+ classIndex := index
+ ].
+ index := index + 1
+ ].
+ classIndex notNil ifTrue:[
+ classListView selection:classIndex.
+ self switchToClass:(Smalltalk at:(oldClass name asSymbol))
+ ]
+ ]
+!
+
+classSelection:lineNr
+ "user clicked on a class line - show method categories"
+
+ |classSymbol cls|
+
+ classSymbol := classListView selectionValue withoutSpaces asSymbol.
+ (Smalltalk includesKey:classSymbol) ifTrue:[
+ cls := Smalltalk at:classSymbol
+ ].
+ cls notNil ifTrue:[
+ self switchToClass:cls.
+ self classSelectionChanged
+ ]
+!
+
+methodCategorySelectionChanged
+ "method category selection has changed - update dependant views"
+
+ self withWaitCursorDo:[
+ currentMethod := nil.
+
+ self updateMethodList.
+ self updateCodeView.
+
+ currentMethodCategory notNil ifTrue:[
+ methodCategoryListView selectElement:currentMethodCategory
+ ].
+
+ codeView acceptAction:[:theCode |
+ codeView cursor:Cursor execute.
+ Object abortSignal catch:[
+ actualClass compiler compile:theCode asString
+ forClass:actualClass
+ inCategory:currentMethodCategory
+ notifying:codeView.
+ codeView modified:false.
+ self updateMethodListWithScroll:false.
+ ].
+ codeView cursor:Cursor normal.
+ ].
+ codeView explainAction:[:theCode :theSelection |
+ self showExplanation:(Explainer explain:theSelection
+ in:theCode
+ forClass:actualClass)
+ ]
+ ]
+!
+
+methodCategorySelection:lineNr
+ "user clicked on a method category line - show selectors"
+
+ currentClass isNil ifTrue:[^ self].
+
+ currentMethodCategory := methodCategoryListView selectionValue.
+ self methodCategorySelectionChanged
+!
+
+methodSelectionChanged
+ "method selection has changed - update dependant views"
+
+ self withWaitCursorDo:[
+ self updateCodeView.
+ codeView acceptAction:[:theCode |
+ codeView cursor:Cursor execute.
+ Object abortSignal catch:[
+ actualClass compiler compile:theCode asString
+ forClass:actualClass
+ inCategory:currentMethodCategory
+ notifying:codeView.
+ codeView modified:false.
+ self updateMethodListWithScroll:false.
+ ].
+ codeView cursor:Cursor normal.
+ ].
+ codeView explainAction:[:theCode :theSelection |
+ self showExplanation:(Explainer explain:theSelection
+ in:theCode
+ forClass:actualClass)
+ ].
+ methodListView notNil ifTrue:[
+ (currentMethod notNil and:[currentMethod isWrapped]) ifTrue:[
+ self initializeMethodMenu2
+ ] ifFalse:[
+ self initializeMethodMenu
+ ]
+ ]
+ ]
+!
+
+methodSelection:lineNr
+ "user clicked on a method line - show code"
+
+ |selectorString selectorSymbol|
+
+ currentClass isNil ifTrue:[^ self].
+
+ selectorString := methodListView selectionValue.
+ "
+ kludge: check if its a wrapped one
+ "
+ (selectorString endsWith:' !!') ifTrue:[
+ selectorString := selectorString copyTo:(selectorString size - 2)
+ ].
+ selectorSymbol := selectorString asSymbol.
+ currentMethod := actualClass compiledMethodAt:selectorSymbol.
+
+ methodCategoryListView notNil ifTrue:[
+ currentMethod notNil ifTrue:[
+ (currentMethodCategory = currentMethod category) ifFalse:[
+ currentMethodCategory := currentMethod category.
+ methodCategoryListView selectElement:currentMethodCategory
+ ]
+ ]
+ ].
+
+ self methodSelectionChanged
+!
+
+classFromClassMethodString:aString
+ "helper for classMethod-list - extract class name from the string"
+
+ |pos|
+
+ pos := aString indexOf:(Character space).
+ ^ aString copyTo:(pos - 1)
+!
+
+selectorFromClassMethodString:aString
+ "helper for classMethod-list - extract selector from the string"
+
+ |pos|
+
+ pos := aString indexOf:(Character space).
+ ^ aString copyFrom:(pos + 1)
+!
+
+listSelection:lineNr
+ "user clicked on a class/method line - show code"
+
+ |string classString selectorString|
+
+ string := classMethodListView selectionValue.
+ classString := self classFromClassMethodString:string.
+ selectorString := self selectorFromClassMethodString:string.
+ ((classString ~= 'Metaclass') and:[classString endsWith:'class']) ifTrue:[
+ classString := classString copyTo:(classString size - 5).
+ self switchToClass:(Smalltalk at:classString asSymbol).
+ actualClass := currentClass class
+ ] ifFalse:[
+ self switchToClass:(Smalltalk at:classString asSymbol).
+ actualClass := currentClass
+ ].
+ currentClass isNil ifTrue:[
+ self warn:'oops class is gone'
+ ] ifFalse:[
+ currentClassCategory := currentClass category.
+ currentMethod := actualClass compiledMethodAt:(selectorString asSymbol).
+ currentMethodCategory := currentMethod category.
+
+ self methodSelectionChanged
+ ]
+! !
+
+!SystemBrowser methodsFor:'class category menu'!
+
+initializeClassCategoryMenu
+ |labels|
+
+ labels := resources array:#(
+ 'fileOut'
+ 'fileOut each'
+"
+ 'fileOut binary'
+"
+ 'printOut'
+ 'printOut protocol'
+ '-'
+ 'spawn'
+ 'spawn class'
+ '-'
+ 'update'
+ 'find class ...'
+ '-'
+ 'new class category ...'
+ 'rename ...'
+ 'remove').
+
+ classCategoryListView
+ middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:#(classCategoryFileOut
+ classCategoryFileOutEach
+"
+ classCategoryBinaryFileOut
+"
+ classCategoryPrintOut
+ classCategoryPrintOutProtocol
+ nil
+ classCategorySpawn
+ classCategorySpawnFullClass
+ nil
+ classCategoryUpdate
+ classCategoryFindClass
+ nil
+ classCategoryNewCategory
+ classCategoryRename
+ classCategoryRemove)
+ receiver:self
+ for:classCategoryListView)
+!
+
+allClassesInCurrentCategoryInOrderDo:aBlock
+ "evaluate aBlock for all classes in the current class category;
+ superclasses come first - then subclasses"
+
+ |classes|
+
+ currentClassCategory notNil ifTrue:[
+ classes := OrderedCollection new.
+ Smalltalk allClassesDo:[:aClass |
+ aClass isMeta ifFalse:[
+ (aClass category = currentClassCategory) ifTrue:[
+ classes add:aClass
+ ]
+ ]
+ ].
+ classes topologicalSort:[:a :b | b isSubclassOf:a].
+ classes do:aBlock
+ ]
+!
+
+allClassesInCurrentCategoryDo:aBlock
+ "evaluate aBlock for all classes in the current class category;
+ superclasses come first - then subclasses"
+
+ currentClassCategory notNil ifTrue:[
+ Smalltalk allClassesDo:[:aClass |
+ aClass isMeta ifFalse:[
+ (aClass category = currentClassCategory) ifTrue:[
+ aBlock value:aClass
+ ]
+ ]
+ ].
+ ]
+!
+
+classCategoryUpdate
+ "update class category list and dependants"
+
+ |oldClassName oldMethodCategory|
+
+ classCategoryListView notNil ifTrue:[
+ currentClass notNil ifTrue:[
+ oldClassName := currentClass name.
+ (oldClassName endsWith:'-old') ifTrue:[
+ oldClassName := oldClassName copyTo:(oldClassName size - 4)
+ ]
+ ].
+ oldMethodCategory := currentMethodCategory.
+
+ classCategoryListView setContents:(self listOfAllClassCategories).
+ currentClassCategory notNil ifTrue:[
+ classCategoryListView selectElement:currentClassCategory.
+ self classCategorySelectionChanged.
+ oldClassName notNil ifTrue:[
+ classListView selectElement:oldClassName.
+ self switchToClass:(Smalltalk at:oldClassName asSymbol).
+ self classSelectionChanged.
+ oldMethodCategory notNil ifTrue:[
+ methodCategoryListView selectElement:oldMethodCategory.
+ currentMethodCategory := oldMethodCategory.
+ self methodCategorySelectionChanged
+ ]
+ ]
+ ]
+ ]
+!
+
+classCategoryPrintOutProtocol
+ |printStream|
+
+ self allClassesInCurrentCategoryInOrderDo:[:aClass |
+ printStream := Printer new.
+ aClass printOutProtocolOn:printStream.
+ printStream close
+ ]
+!
+
+classCategoryPrintOut
+ |printStream|
+
+ self allClassesInCurrentCategoryDo:[:aClass |
+ printStream := Printer new.
+ aClass printOutOn:printStream.
+ printStream close
+ ]
+!
+
+classCategoryFileOut
+ "create a file 'categoryName' consisting of all classes in current category"
+
+ |aStream fileName project|
+
+ currentClassCategory isNil ifTrue:[
+ ^ self warn:'select a class category first'.
+ ].
+
+ fileName := currentClassCategory asString.
+ fileName replaceAll:Character space by:$_.
+ Project notNil ifTrue:[
+ project := Project current.
+ project notNil ifTrue:[
+ fileName := project directory , Filename separator asString , fileName.
+ ].
+ ].
+
+ aStream := FileStream newFileNamed:fileName.
+ aStream isNil ifTrue:[
+ ^ self warn:(resources string:'cannot create: %1' with:fileName)
+ ].
+ self withWaitCursorDo:[
+ self label:('System Browser writing: ' , fileName).
+ self allClassesInCurrentCategoryInOrderDo:[:aClass |
+ aClass fileOutOn:aStream.
+ ].
+ aStream close.
+ self label:'System Browser'.
+ ]
+!
+
+classCategoryFileOutEach
+ self withWaitCursorDo:[
+ self allClassesInCurrentCategoryDo:[:aClass |
+ self label:('System Browser saving: ' , aClass name).
+ aClass fileOut
+ ].
+ self label:'System Browser'.
+ ]
+!
+
+classCategoryBinaryFileOut
+ self withWaitCursorDo:[
+ self allClassesInCurrentCategoryInOrderDo:[:aClass |
+ aClass binaryFileOut
+ ]
+ ]
+!
+
+classCategorySpawn
+ "create a new SystemBrowser browsing current classCategory"
+
+ currentClassCategory notNil ifTrue:[
+ self withWaitCursorDo:[
+ self class browseClassCategory:currentClassCategory
+ ]
+ ]
+!
+
+classCategorySpawnFullClass
+ "create a new SystemBrowser browsing full class"
+
+ |newBrowser|
+
+ self withWaitCursorDo:[
+ newBrowser := self class browseFullClasses
+"
+ .
+ currentClass notNil ifTrue:[
+ newBrowser switchToClassNamed:(currentClass name)
+ ]
+"
+ ]
+!
+
+classCategoryNewCategory
+ self enterBoxTitle:'name of new class category:' okText:'create'.
+ enterBox action:[:aString | self newClassCategory:aString].
+ enterBox showAtPointer
+!
+
+switchToClassNamed:aString
+ |classSymbol theClass|
+
+ classSymbol := aString asSymbol.
+ theClass := Smalltalk at:classSymbol.
+ theClass isBehavior ifTrue:[
+ classCategoryListView notNil ifTrue:[
+ currentClassHierarchy isNil ifTrue:[
+ (theClass category ~~ currentClassCategory) ifTrue:[
+ currentClassCategory := theClass category.
+ currentClassCategory isNil ifTrue:[
+ classCategoryListView selectElement:'* no category *'
+ ] ifFalse:[
+ classCategoryListView selectElement:currentClassCategory
+ ].
+ self classCategorySelectionChanged
+ ]
+ ]
+ ].
+ self switchToClass:theClass.
+ classListView selectElement:aString.
+ self classSelectionChanged
+ ]
+!
+
+switchToClassNameMatching:aMatchString
+ |classNames thisName|
+
+ classNames := OrderedCollection new.
+ Smalltalk allBehaviorsDo:[:aClass |
+ thisName := aClass name.
+ (aMatchString match:thisName) ifTrue:[
+ classNames add:thisName
+ ]
+ ].
+ (classNames size == 0) ifTrue:[^ nil].
+ (classNames size == 1) ifTrue:[
+ ^ self switchToClassNamed:(classNames at:1)
+ ].
+ self listBoxTitle:'select class to switch to:'
+ okText:'ok'
+ list:classNames sort.
+ selectBox action:[:aString | self switchToClassNamed:aString].
+ selectBox showAtPointer
+!
+
+classCategoryFindClass
+ self enterBoxForCodeSelectionTitle:'class to find:' okText:'find'.
+ enterBox action:[:aString | self switchToClassNameMatching:aString].
+ enterBox showAtPointer
+!
+
+renameCurrentClassCategoryTo:aString
+ "helper - do the rename"
+
+ |any categories|
+
+ currentClassCategory notNil ifTrue:[
+ any := false.
+ Smalltalk allBehaviorsDo:[:aClass |
+ aClass category = currentClassCategory ifTrue:[
+ aClass category:aString.
+ any := true
+ ]
+ ].
+ any ifFalse:[
+ categories := classCategoryListView list.
+ categories remove:currentClassCategory.
+ categories add:aString.
+ categories sort.
+ classCategoryListView setContents:categories.
+ currentClassCategory := aString.
+ classCategoryListView selectElement:aString.
+ ] ifTrue:[
+ currentClassCategory := aString.
+ self updateClassCategoryList.
+ self updateClassListWithScroll:false
+ ]
+ ]
+!
+
+classCategoryRename
+ "launch an enterBox to rename current class category"
+
+ currentClassCategory isNil ifTrue:[
+ ^ self warn:'select a class category first'.
+ ].
+ self enterBoxTitle:'rename class category to:' okText:'rename'.
+ enterBox initialText:currentClassCategory.
+ enterBox action:[:aString | self renameCurrentClassCategoryTo:aString].
+ enterBox showAtPointer
+!
+
+classCategoryRemove
+ "remove all classes in current category"
+
+ |count t classesToRemove subclassesRemoved|
+
+ currentClassCategory isNil ifTrue:[
+ ^ self warn:'select a class category first'.
+ ].
+
+ classesToRemove := OrderedCollection new.
+ Smalltalk allBehaviorsDo:[:aClass |
+ aClass category = currentClassCategory ifTrue:[
+ classesToRemove add:aClass
+ ]
+ ].
+ subclassesRemoved := OrderedCollection new.
+ classesToRemove do:[:aClass |
+ aClass allSubclassesDo:[:aSubclass |
+ (classesToRemove includes:aSubclass) ifFalse:[
+ (subclassesRemoved includes:aSubclass) ifFalse:[
+ subclassesRemoved add:aSubclass
+ ]
+ ]
+ ]
+ ].
+
+ count := classesToRemove size.
+ t := resources string:'remove %1 ?' with:currentClassCategory.
+ count ~~ 0 ifTrue:[
+ t := t , (resources at:'\(with ') , count printString.
+ count == 1 ifTrue:[
+ t := t , (resources at:' class')
+ ] ifFalse:[
+ t := t , (resources at:' classes')
+ ].
+ t := (t , ')') withCRs
+ ].
+
+ count := subclassesRemoved size.
+ count ~~ 0 ifTrue:[
+ t := t , (resources at:'\(and ') , count printString.
+ count == 1 ifTrue:[
+ t := t , (resources at:' subclass ')
+ ] ifFalse:[
+ t := t , (resources at:' subclasses ')
+ ].
+ t := (t , ')') withCRs
+ ].
+
+ t := t withCRs.
+
+ questBox isNil ifTrue:[questBox := YesNoBox title:''].
+ questBox title:t.
+ questBox yesAction:[self doRemoveClasses:classesToRemove and:subclassesRemoved].
+ questBox okText:(resources at:'remove').
+ questBox noText:(resources at:'abort').
+ questBox showAtPointer
+!
+
+doRemoveClasses:classList and:subclassList
+ "after querying user - do really remove classes in list1 and list2"
+
+ subclassList do:[:aClass |
+ Smalltalk removeClass:aClass
+ ].
+ classList do:[:aClass |
+ Smalltalk removeClass:aClass
+ ].
+ currentClassCategory := nil.
+ self switchToClass:nil.
+ Smalltalk changed
+! !
+
+!SystemBrowser methodsFor:'class menu'!
+
+initializeClassMenu
+ |labels menu|
+
+ labels := resources array:#(
+ 'fileOut'
+"
+ 'fileOut binary'
+"
+ 'printOut'
+ 'printOut protocol'
+ " 'printOut full protocol' "
+ '-'
+ 'spawn'
+ 'spawn hierarchy'
+ 'spawn subclasses'
+ '-'
+ 'hierarchy'
+ 'definition'
+ 'comment'
+ 'class instvars'
+ " 'protocols' "
+ '-'
+ 'variable search'
+ '-'
+ 'new class'
+ 'new subclass'
+ 'rename ...'
+ 'remove').
+
+ menu := PopUpMenu labels:labels
+ selectors:#(classFileOut
+"
+ classBinaryFileOut
+"
+ classPrintOut
+ classPrintOutProtocol
+ " classPrintOutFullProtocol "
+ nil
+ classSpawn
+ classSpawnHierarchy
+ classSpawnSubclasses
+ nil
+ classHierarchy
+ classDefinition
+ classComment
+ classClassInstVars
+ " classProtocols "
+ nil
+"
+ classInstVarRefs
+ classClassVarRefs
+ classAllInstVarRefs
+ classAllClassVarRefs
+ nil
+ classInstVarMods
+ classClassVarMods
+ classAllInstVarMods
+ classAllClassVarMods
+"
+ variables
+ nil
+ classNewClass
+ classNewSubclass
+ classRename
+ classRemove)
+ receiver:self
+ for:classListView.
+
+ classListView middleButtonMenu:menu.
+
+ menu subMenuAt:#variables
+ put:(PopUpMenu labels:(resources array:#(
+ 'instvar refs ...'
+ 'classvar refs ...'
+ 'all instvar refs ...'
+ 'all classvar refs ...'
+ '-'
+ 'instvar mods ...'
+ 'classvar mods ...'
+ 'all instvar mods ...'
+ 'all classvar mods ...'
+ ))
+ selectors:#(
+ classInstVarRefs
+ classClassVarRefs
+ classAllInstVarRefs
+ classAllClassVarRefs
+ nil
+ classInstVarMods
+ classClassVarMods
+ classAllInstVarMods
+ classAllClassVarMods
+ )
+ receiver:self
+ for:self
+
+ ).
+!
+
+doClassMenu:aBlock
+ "a helper - check if class is selected and evaluate aBlock
+ while showing waitCursor"
+
+ currentClass isNil ifTrue:[
+ ^ self warn:'select a class first'.
+ ].
+ self withWaitCursorDo:aBlock
+!
+
+doClassMenuWithSelection:aBlock
+ "a helper - if there is a selection, which represents a classes name,
+ evaluate aBlock, passing that class as argument.
+ Otherwise, check if a class is selected and evaluate aBlock with the
+ current class. Otherwise report an error."
+
+ |clsName cls isMeta w|
+
+ clsName := codeView selection.
+ clsName notNil ifTrue:[
+ clsName := clsName asString withoutSeparators.
+ (clsName endsWith:'class') ifTrue:[
+ isMeta := true.
+ clsName := clsName copyTo:(clsName size - 5)
+ ] ifFalse:[
+ isMeta := false
+ ].
+ clsName knownAsSymbol ifTrue:[
+ (Smalltalk includesKey:clsName asSymbol) ifTrue:[
+ cls := Smalltalk at:clsName asSymbol.
+ cls isBehavior ifTrue:[
+ isMeta ifTrue:[
+ cls := cls class
+ ].
+ self withWaitCursorDo:[
+ aBlock value:cls.
+ ].
+ ^ self
+ ] ifFalse:[
+ w := clsName , ' is not a class'
+ ]
+ ] ifFalse:[
+ w := clsName , ' is unknown'
+ ].
+ self warn:w.
+ ^ self
+ ].
+ ].
+
+ currentClass isNil ifTrue:[
+ ^ self warn:'select a class first'.
+ ].
+ self withWaitCursorDo:[aBlock value:currentClass]
+!
+
+classSpawn
+ "create a new SystemBrowser browsing current class,
+ or if there is a selection, spawn a browser on the selected name."
+
+ |browser|
+
+ self doClassMenuWithSelection:[:cls |
+ cls isMeta ifTrue:[
+ Smalltalk allClassesDo:[:aClass |
+ aClass class == cls ifTrue:[
+ browser := self class browseClass:aClass.
+ browser classProtocol.
+ ^ self
+ ].
+ ].
+ self warn:'oops, no class for this metaclass'.
+ ^ self
+ ].
+ self class browseClass:cls
+ ]
+!
+
+classSpawnHierarchy
+ "create a new HierarchyBrowser browsing current class"
+
+ self doClassMenuWithSelection:[:cls |
+ self class browseClassHierarchy:cls
+ ]
+!
+
+classSpawnSubclasses
+ "create a new browser browsing current class's subclasses"
+
+ |subs|
+
+ self doClassMenuWithSelection:[:cls |
+ subs := cls allSubclasses.
+ (subs notNil and:[subs size ~~ 0]) ifTrue:[
+ self class browseClasses:subs title:('subclasses of ' , cls name)
+ ]
+ ]
+!
+
+classPrintOutFullProtocol
+ |printStream|
+
+ self doClassMenu:[
+ printStream := Printer new.
+ currentClass printOutFullProtocolOn:printStream.
+ printStream close
+ ]
+!
+
+classPrintOutProtocol
+ |printStream|
+
+ self doClassMenu:[
+ printStream := Printer new.
+ currentClass printOutProtocolOn:printStream.
+ printStream close
+ ]
+!
+
+classPrintOut
+ |printStream|
+
+ self doClassMenu:[
+ printStream := Printer new.
+ currentClass printOutOn:printStream.
+ printStream close
+ ]
+!
+
+classBinaryFileOut
+ self doClassMenu:[
+ currentClass binaryFileOut
+ ]
+!
+
+classFileOut
+ self doClassMenu:[
+ self label:('System Browser saving: ' , currentClass name).
+ currentClass fileOut.
+ self label:'System Browser'
+ ]
+!
+
+classHierarchy
+ "show current classes hierarchy in codeView"
+
+ |aStream|
+
+ self doClassMenu:[
+ aStream := WriteStream on:(String new:200).
+ actualClass printHierarchyOn:aStream.
+ codeView contents:(aStream contents).
+ codeView modified:false.
+ codeView acceptAction:nil.
+ codeView explainAction:nil.
+ methodListView notNil ifTrue:[
+ methodListView deselect
+ ]
+ ]
+!
+
+classDefinition
+ "show class definition in codeView and setup accept-action for
+ class-definition change"
+
+ |aStream|
+
+ self doClassMenu:[
+ aStream := WriteStream on:(String new:200).
+ currentClass fileOutDefinitionOn:aStream.
+ codeView contents:(aStream contents).
+ codeView modified:false.
+ codeView acceptAction:[:theCode |
+ codeView cursor:Cursor execute.
+ Object abortSignal catch:[
+ (Compiler evaluate:theCode asString notifying:codeView)
+ isBehavior ifTrue:[
+ codeView modified:false.
+ self classCategoryUpdate.
+ self updateClassListWithScroll:false.
+ ]
+ ].
+ codeView cursor:Cursor normal.
+ ].
+ codeView explainAction:nil.
+ methodListView notNil ifTrue:[
+ methodListView deselect
+ ]
+ ]
+!
+
+classClassInstVars
+ "show class instance variables in codeView and setup accept-action
+ for class-instvar-definition change"
+
+ |s|
+
+ self doClassMenu:[
+ s := WriteStream on:(String new).
+ currentClass fileOutClassInstVarDefinitionOn:s.
+ codeView contents:(s contents).
+ codeView modified:false.
+ codeView acceptAction:[:theCode |
+ codeView cursor:Cursor execute.
+ Object abortSignal catch:[
+ Compiler evaluate:theCode asString notifying:codeView.
+ codeView modified:false.
+ self updateClassList.
+ ].
+ codeView cursor:Cursor normal.
+ ].
+ codeView explainAction:nil.
+ methodListView notNil ifTrue:[
+ methodListView deselect
+ ]
+ ]
+!
+
+classProtocols
+ ^ self
+!
+
+classComment
+ "show the classes comment in the codeView"
+
+ self doClassMenu:[
+ codeView contents:(currentClass comment).
+ codeView modified:false.
+ codeView acceptAction:[:theCode |
+ Object abortSignal catch:[
+ currentClass comment:theCode asString.
+ codeView modified:false.
+ ]
+ ].
+ codeView explainAction:nil.
+ methodListView notNil ifTrue:[
+ methodListView deselect
+ ]
+ ]
+!
+
+classInstVarRefsOrModsTitle:title mods:mods
+ "show an enterbox for instvar to search for"
+
+ self doClassMenu:[
+ self enterBoxForCodeSelectionTitle:title okText:'browse'.
+ enterBox action:[:aString |
+ self withWaitCursorDo:[
+ self class browseInstRefsTo:aString
+ in:(Array with:currentClass)
+ modificationsOnly:mods
+ ]
+ ].
+ enterBox showAtPointer
+ ]
+!
+
+classInstVarRefs
+ "show an enterbox for instVar to search for"
+
+ self classInstVarRefsOrModsTitle:'instance variable to browse references to:'
+ mods:false
+!
+
+classInstVarMods
+ "show an enterbox for instVar to search for"
+
+ self classInstVarRefsOrModsTitle:'instance variable to browse modifications of:'
+ mods:true
+!
+
+classClassVarRefsOrModsTitle:title mods:mods
+ "show an enterbox for classVar to search for"
+
+ self doClassMenu:[
+ self enterBoxForCodeSelectionTitle:title okText:'browse'.
+ enterBox action:[:aString |
+ self withWaitCursorDo:[
+ self class browseClassRefsTo:aString
+ in:(Array with:currentClass)
+ modificationsOnly:mods
+ ]
+ ].
+ enterBox showAtPointer
+ ]
+!
+
+classClassVarMods
+ "show an enterbox for classVar to search for"
+
+ self classClassVarRefsOrModsTitle:'class variable to browse modifications of:'
+ mods:true
+!
+
+classClassVarRefs
+ "show an enterbox for classVar to search for"
+
+ self classClassVarRefsOrModsTitle:'class variable to browse references to:'
+ mods:false
+!
+
+classAllClassOrInstVarRefsTitle:title access:access
+ "show an enterbox for instVar to search for"
+
+ self doClassMenu:[
+ self enterBoxForCodeSelectionTitle:title okText:'browse'.
+ enterBox action:[:aVariableName |
+ self withWaitCursorDo:[
+ |homeClass|
+
+ homeClass := self findClassOfVariable:aVariableName
+ accessWith:access.
+ (self class) browseInstRefsTo:aVariableName
+ under:homeClass
+ modificationsOnly:false
+ ]
+ ].
+ enterBox showAtPointer
+ ]
+!
+
+classAllInstVarRefs
+ "show an enterbox for instVar to search for"
+
+ self classAllClassOrInstVarRefsTitle:'instance variable to browse references to:'
+ access:#instVarNames
+!
+
+classAllClassVarRefs
+ "show an enterbox for classVar to search for"
+
+ self classAllClassOrInstVarRefsTitle:'class variable to browse references to:'
+ access:#classVarNames
+!
+
+classAllInstOrClassVarModsTitle:title access:access
+ "show an enterbox for instVar to search for"
+
+ self doClassMenu:[
+ self enterBoxForCodeSelectionTitle:title okText:'browse'.
+ enterBox action:[:aVariableName |
+ self withWaitCursorDo:[
+ |homeClass|
+
+ homeClass := self findClassOfVariable:aVariableName
+ accessWith:access.
+ (self class) browseInstRefsTo:aVariableName
+ under:homeClass
+ modificationsOnly:true
+ ]
+ ].
+ enterBox showAtPointer
+ ]
+!
+
+classAllInstVarMods
+ "show an enterbox for instVar to search for"
+
+ self classAllInstOrClassVarModsTitle:'instance variable to browse modifications of:'
+ access:#instVarNames.
+!
+
+classAllClassVarMods
+ "show an enterbox for classVar to search for"
+
+ self classAllInstOrClassVarModsTitle:'class variable to browse modifications of:'
+ access:#classVarNames.
+!
+
+classClassDefinitionTemplateFor:name in:cat
+ "common helper for newClass and newSubclass
+ - show a template to define class name in category cat"
+
+ currentMethodCategory := nil.
+ currentMethod := nil.
+
+ classListView deselect.
+
+ fullClass ifFalse:[
+ methodCategoryListView contents:nil.
+ methodListView contents:nil
+ ].
+
+ codeView contents:(self templateFor:name in:cat).
+ codeView modified:false.
+
+ codeView acceptAction:[:theCode |
+ codeView cursor:Cursor execute.
+ Object abortSignal catch:[
+ |cl|
+
+ cl := (Compiler evaluate:theCode asString notifying:codeView).
+ cl isBehavior ifTrue:[
+ codeView modified:false.
+ self classCategoryUpdate.
+ self updateClassListWithScroll:false.
+ self switchToClassNamed:(cl name)
+ ]
+ ].
+ codeView cursor:(Cursor normal).
+ ].
+ codeView explainAction:nil.
+ self switchToClass:nil
+!
+
+classNewClass
+ "create a class-definition prototype in codeview"
+
+ |nm|
+
+ currentClass notNil ifTrue:[
+ nm := currentClass superclass name
+ ] ifFalse:[
+ nm := 'Object'
+ ].
+ self classClassDefinitionTemplateFor:nm in:currentClassCategory
+!
+
+classNewSubclass
+ "create a subclass-definition prototype in codeview"
+
+ currentClass isNil ifTrue:[
+ ^ self warn:'select a class first'.
+ ].
+ self classClassDefinitionTemplateFor:(currentClass name)
+ in:(currentClass category)
+!
+
+renameCurrentClassTo:aString
+ "helper - do the rename"
+
+ self doClassMenu:[
+ |oldName oldSym newSym|
+
+ oldName := currentClass name.
+ oldSym := oldName asSymbol.
+"
+ currentClass setName:aString.
+ newSym := aString asSymbol.
+ Smalltalk at:oldSym put:nil.
+ Smalltalk removeKey:oldSym.
+ Smalltalk at:newSym put:currentClass.
+"
+"
+ currentClass renameTo:aString.
+"
+ Smalltalk renameClass:currentClass to:aString.
+
+ self updateClassList.
+ self updateMethodCategoryListWithScroll:false.
+ self updateMethodListWithScroll:false.
+ self withWaitCursorDo:[
+ Transcript showCr:('searching for users of ' , oldSym); endEntry.
+ self class browseReferendsOf:oldSym warnIfNone:false
+ ]
+ ]
+!
+
+classRename
+ "launch an enterBox for new name and query user"
+
+ currentClass isNil ifTrue:[
+ ^ self warn:'select a class first'.
+ ].
+ self enterBoxTitle:(resources string:'rename %1 to:' with:currentClass name) okText:'rename'.
+ enterBox initialText:(currentClass name).
+ enterBox action:[:aString | self renameCurrentClassTo:aString].
+ enterBox showAtPointer
+!
+
+doRemoveCurrentClass
+ "after querying user - do really remove current class
+ and all subclasses"
+
+ self doClassMenu:[
+ currentClass allSubclassesDo:[:aSubClass |
+ Smalltalk removeClass:aSubClass
+ ].
+ Smalltalk removeClass:currentClass.
+
+ self switchToClass:nil.
+ Smalltalk changed.
+ self updateClassList.
+
+ "if it was the last in its category, update class category list"
+"
+ classListView numberOfLines == 0 ifTrue:[
+ self updateClassCategoryListWithScroll:false
+ ].
+"
+ methodCategoryListView notNil ifTrue:[methodCategoryListView contents:nil].
+ methodListView notNil ifTrue:[methodListView contents:nil].
+ codeView contents:nil.
+ codeView modified:false
+ ]
+!
+
+classRemove
+ "user requested remove of current class and all subclasses -
+ count subclasses and let user confirm removal."
+
+ |count t|
+
+ currentClass notNil ifTrue:[
+ count := 0.
+ currentClass allSubclassesDo:[:aSubClass |
+ count := count + 1
+ ].
+ t := 'remove ' , currentClass name.
+ count ~~ 0 ifTrue:[
+ t := t , '\(with ' , count printString.
+ count == 1 ifTrue:[
+ t := t , ' subclass'
+ ] ifFalse:[
+ t := t , ' subclasses'
+ ].
+ t := (t , ')') withCRs
+ ].
+ questBox isNil ifTrue:[questBox := YesNoBox title:''].
+ questBox title:t.
+ questBox yesAction:[self doRemoveCurrentClass].
+ questBox okText:(resources at:'remove').
+ questBox noText:(resources at:'abort').
+ questBox showAtPointer
+ ]
+! !
+
+!SystemBrowser methodsFor:'method category menu'!
+
+initializeMethodCategoryMenu
+ |labels|
+
+ labels := resources array:#(
+ 'fileOut'
+ 'fileOut all'
+ 'printOut'
+ '-'
+ 'spawn'
+ 'spawn category'
+ '-'
+ 'find method here ...'
+ 'find method ...'
+ '-'
+ 'new category ...'
+ 'copy category ...'
+ 'create access methods'
+ 'rename ...'
+ 'remove').
+
+ methodCategoryListView
+ middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:#(
+ methodCategoryFileOut
+ methodCategoryFileOutAll
+ methodCategoryPrintOut
+ nil
+ methodCategorySpawn
+ methodCategorySpawnCategory
+ nil
+ methodCategoryFindMethod
+ methodCategoryFindAnyMethod
+ nil
+ methodCategoryNewCategory
+ methodCategoryCopyCategory
+ methodCategoryCreateAccessMethods
+ methodCategoryRename
+ methodCategoryRemove)
+ receiver:self
+ for:methodCategoryListView)
+!
+
+switchToMethodNamed:matchString
+ |aSelector method cat index classToSearch selectors|
+
+ currentClass notNil ifTrue:[
+ showInstance ifTrue:[
+ classToSearch := currentClass
+ ] ifFalse:[
+ classToSearch := currentClass class
+ ].
+ selectors := classToSearch selectorArray.
+
+ ((matchString ~= '*') and:[matchString includesMatchCharacters]) ifTrue:[
+ index := selectors findFirst:[:element | matchString match:element]
+ ] ifFalse:[
+ index := selectors indexOf:matchString
+ ].
+
+ (index ~~ 0) ifTrue:[
+ aSelector := selectors at:index.
+ method := classToSearch methodArray at:index.
+ cat := method category.
+ cat isNil ifTrue:[cat := '* all *'].
+ methodCategoryListView selectElement:cat.
+ currentMethodCategory := cat.
+ self methodCategorySelectionChanged.
+
+ currentMethod := classToSearch compiledMethodAt:aSelector.
+ methodListView selectElement:aSelector.
+ self methodSelectionChanged
+ ]
+ ]
+!
+
+switchToAnyMethodNamed:aString
+ |aSelector classToStartSearch aClass nm|
+
+ aSelector := aString asSymbol.
+ currentClass isNil ifTrue:[
+ currentClassHierarchy notNil ifTrue:[
+ classToStartSearch := currentClassHierarchy
+ ]
+ ] ifFalse:[
+ classToStartSearch := currentClass
+ ].
+ classToStartSearch notNil ifTrue:[
+ showInstance ifFalse:[
+ classToStartSearch := classToStartSearch class
+ ].
+ aClass := classToStartSearch whichClassImplements:aSelector.
+ aClass notNil ifTrue:[
+ nm := aClass name.
+ showInstance ifFalse:[
+ ((nm ~= 'Metaclass') and:[nm endsWith:'class']) ifTrue:[
+ nm := nm copyTo:(nm size - 5)
+ ]
+ ].
+ self switchToClassNamed:nm.
+ self switchToMethodNamed:aString
+ ]
+ ]
+!
+
+copyMethodsFromClass:aClassName
+ |class|
+
+ currentClass notNil ifTrue:[
+ Symbol hasInterned:aClassName ifTrue:[:sym |
+ (Smalltalk includesKey:sym) ifTrue:[
+ class := Smalltalk at:sym
+ ].
+ ].
+ class isBehavior ifFalse:[
+ self warn:(resources string:'no class named %1' with:aClassName).
+ ^ self
+ ].
+
+ showInstance ifFalse:[
+ class := class class
+ ].
+
+ "show enterbox for category to copy from"
+
+ self enterBoxTitle:'name of category to copy from (matchpattern allowed, * for all):'
+ okText:'copy'.
+ enterBox action:[:aString | self copyMethodsFromClass:class category:aString].
+ enterBox showAtPointer
+ ]
+!
+
+copyMethodsFromClass:class category:category
+ |source|
+
+ currentClass notNil ifTrue:[
+ codeView abortAction:[^ self].
+ class methodArray do:[:aMethod |
+ (category match:aMethod category) ifTrue:[
+ source := aMethod source.
+ codeView contents:source.
+ codeView modified:false.
+ actualClass compiler compile:source
+ forClass:actualClass
+ inCategory:aMethod category
+ notifying:codeView.
+ self updateMethodCategoryListWithScroll:false.
+ self updateMethodListWithScroll:false.
+ ]
+ ]
+ ]
+!
+
+methodCategoryFindMethod
+ self enterBoxForSearchSelectorTitle:'method selector to search for:'.
+ enterBox action:[:aString | self switchToMethodNamed:aString].
+ enterBox showAtPointer
+!
+
+methodCategoryFindAnyMethod
+ self enterBoxForSearchSelectorTitle:'method selector to search for:'.
+ enterBox action:[:aString | self switchToAnyMethodNamed:aString].
+ enterBox showAtPointer
+!
+
+methodCategoryPrintOut
+ |printStream|
+
+ currentClass isNil ifTrue:[
+ ^ self warn:'select a class first'.
+ ].
+ currentMethodCategory isNil ifTrue:[
+ ^ self warn:'select a method category first'.
+ ].
+ currentMethodCategory notNil ifTrue:[
+ self withWaitCursorDo:[
+ printStream := Printer new.
+ actualClass printOutCategory:currentMethodCategory on:printStream.
+ printStream close
+ ]
+ ]
+!
+
+methodCategoryFileOut
+ "fileOut all methods in the selected methodcategory of
+ the current class"
+
+ currentClass isNil ifTrue:[
+ ^ self warn:'select a class first'.
+ ].
+ currentMethodCategory isNil ifTrue:[
+ ^ self warn:'select a method category first'.
+ ].
+ currentMethodCategory notNil ifTrue:[
+ self withWaitCursorDo:[
+ self label:('System Browser saving: ' , currentClass name , '-' , currentMethodCategory).
+ actualClass fileOutCategory:currentMethodCategory.
+ self label:'System Browser'.
+ ]
+ ]
+!
+
+methodCategoryFileOutAll
+ "fileOut all methods in the selected methodcategory of
+ the current class"
+
+ |fileName project outStream hasMethodsInThisCategory|
+
+ currentMethodCategory isNil ifTrue:[
+ ^ self warn:'select a method category first'.
+ ].
+ fileName := currentMethodCategory , '.st'.
+ fileName replaceAll:Character space by:$_.
+ Project notNil ifTrue:[
+ project := Project current.
+ project notNil ifTrue:[
+ fileName := project directory , Filename separator asString , fileName.
+ ].
+ ].
+ outStream := FileStream newFileNamed:fileName.
+ outStream isNil ifTrue:[
+ ^ self warn:(resources string:'cannot create: %1' with:fileName)
+ ].
+ self withWaitCursorDo:[
+ self label:('System Browser saving: ' , currentMethodCategory).
+ Smalltalk allClassesDo:[:class |
+ hasMethodsInThisCategory := false.
+ class methodArray do:[:method |
+ method category = currentMethodCategory ifTrue:[
+ hasMethodsInThisCategory := true
+ ]
+ ].
+ hasMethodsInThisCategory ifTrue:[
+ class fileOutCategory:currentMethodCategory on:outStream.
+ outStream cr
+ ].
+ hasMethodsInThisCategory := false.
+ class class methodArray do:[:method |
+ method category = currentMethodCategory ifTrue:[
+ hasMethodsInThisCategory := true
+ ]
+ ].
+ hasMethodsInThisCategory ifTrue:[
+ class class fileOutCategory:currentMethodCategory on:outStream.
+ outStream cr
+ ]
+ ].
+ outStream close.
+ self label:'System Browser'.
+ ].
+!
+
+methodCategorySpawn
+ "create a new SystemBrowser browsing current method category"
+
+ currentMethodCategory notNil ifTrue:[
+ self withWaitCursorDo:[
+ self class browseClass:actualClass
+ methodCategory:currentMethodCategory
+ ]
+ ]
+!
+
+methodCategorySpawnCategory
+ "create a new SystemBrowser browsing all methods from all
+ classes with same category as current method category"
+
+ self enterBoxForMethodCategory:'category to browse methods:'.
+ enterBox action:[:aString | self withWaitCursorDo:[
+ self class browseMethodCategory:aString
+ ]
+ ].
+ enterBox showAtPointer
+!
+
+newMethodCategory:aString
+ |categories|
+
+ currentClass isNil ifTrue:[
+ ^ self warn:'select/create a class first'.
+ ].
+ categories := methodCategoryListView list.
+ categories isNil ifTrue:[categories := Text new].
+ (categories includes:aString) ifFalse:[
+ categories add:aString.
+ categories sort.
+ methodCategoryListView contents:categories
+ ].
+ currentMethodCategory := aString.
+ self methodCategorySelectionChanged
+!
+
+methodCategoryNewCategory
+ "show the enter box to add a new method category"
+
+ |someCategories existingCategories|
+
+ "a tiny little goody here ..."
+ showInstance ifTrue:[
+ someCategories := #('accessing'
+ 'initialization'
+ 'private'
+ 'printing & storing'
+ 'queries'
+ 'testing'
+ )
+ ] ifFalse:[
+ someCategories := #(
+ 'documentation'
+ 'initialization'
+ 'instance creation'
+ ).
+ ].
+ existingCategories := methodCategoryListView list.
+ existingCategories notNil ifTrue:[
+ someCategories := someCategories select:[:cat | (existingCategories includes:cat) not].
+ ].
+
+ self listBoxTitle:(resources at:'name of new method category:')
+ okText:(resources at:'create')
+ list:someCategories.
+ selectBox action:[:aString | self newMethodCategory:aString].
+ selectBox showAtPointer
+!
+
+methodCategoryCreateAccessMethods
+ "create access methods for all instvars"
+
+ |source|
+
+ currentClass isNil ifTrue:[^ self].
+ showInstance ifFalse:[
+ self warn:(resources string:'select instance - and try again').
+ ^ self.
+ ].
+ self withWaitCursorDo:[
+ currentClass instVarNames do:[:name |
+ "check, if method is not already present"
+ (currentClass implements:(name asSymbol)) ifFalse:[
+ source := (name , '\ "return ' , name , '"\\ ^ ' , name) withCRs.
+ Compiler compile:source forClass:currentClass inCategory:'accessing'.
+ ] ifTrue:[
+ Transcript showCr:'method ''', name , ''' already present'
+ ].
+ (currentClass implements:((name , ':') asSymbol)) ifFalse:[
+ source := (name , ':something\ "set ' , name , '"\\ ' , name , ' := something.') withCRs.
+ Compiler compile:source forClass:currentClass inCategory:'accessing'.
+ ] ifTrue:[
+ Transcript showCr:'method ''', name , ':'' already present'
+ ].
+ ].
+ self updateMethodCategoryListWithScroll:false.
+ self updateMethodListWithScroll:false
+ ]
+!
+
+methodCategoryCopyCategory
+ "show the enter box to copy from an existing method category"
+
+ |title|
+
+ showInstance ifTrue:[
+ title := 'class to copy instance method category from:'
+ ] ifFalse:[
+ title := 'class to copy class method category from:'
+ ].
+
+ self listBoxTitle:title
+ okText:'ok'
+ list:(Smalltalk allClasses collect:[:cls | cls name]) asArray sort.
+
+ selectBox action:[:aString | self copyMethodsFromClass:aString].
+ selectBox showAtPointer
+!
+
+renameCurrentMethodCategoryTo:aString
+ "helper - do the rename"
+
+ currentMethodCategory notNil ifTrue:[
+ actualClass renameCategory:currentMethodCategory to:aString.
+
+"/ actualClass methodArray do:[:aMethod |
+"/ aMethod category = currentMethodCategory ifTrue:[
+"/ aMethod category:aString
+"/ ]
+"/ ].
+ currentMethodCategory := aString.
+ currentMethod := nil.
+ self updateMethodCategoryList.
+ self updateMethodListWithScroll:false
+ ]
+!
+
+methodCategoryRename
+ "launch an enterBox to rename current method category"
+
+ currentMethodCategory isNil ifTrue:[
+ ^ self warn:'select a method category first'.
+ ].
+
+ self enterBoxTitle:(resources string:'rename method category %1 to:' with:currentMethodCategory)
+ okText:(resources at:'rename').
+ enterBox initialText:currentMethodCategory.
+ enterBox action:[:aString | self renameCurrentMethodCategoryTo:aString].
+ enterBox showAtPointer
+!
+
+doMethodCategoryRemove
+ "actually remove all methods from current method category"
+
+ currentMethodCategory notNil ifTrue:[
+ actualClass methodArray do:[:aMethod |
+ (aMethod category = currentMethodCategory) ifTrue:[
+ actualClass
+ removeSelector:(actualClass selectorForMethod:aMethod)
+ ]
+ ].
+ currentMethodCategory := nil.
+ currentMethod := nil.
+ self updateMethodCategoryList.
+ self updateMethodList
+ ]
+!
+
+methodCategoryRemove
+ "show number of methods to remove and query user"
+
+ |count t|
+
+ currentMethodCategory notNil ifTrue:[
+ count := 0.
+ actualClass methodArray do:[:aMethod |
+ (aMethod category = currentMethodCategory) ifTrue:[
+ count := count + 1
+ ]
+ ].
+ (count == 0) ifTrue:[
+ currentMethodCategory := nil.
+ currentMethod := nil.
+ self updateMethodCategoryListWithScroll:false.
+ self updateMethodList
+ ] ifFalse:[
+ (count == 1) ifTrue:[
+ t := resources string:'remove %1 ?\(with 1 method)' with:currentMethodCategory
+ ] ifFalse:[
+ t := resources string:'remove %1 ?\(with %2 methods)' with:currentMethodCategory
+ with:count printString.
+ ].
+ t := t withCRs.
+
+ questBox isNil ifTrue:[questBox := YesNoBox title:''].
+ questBox title:t.
+ questBox yesAction:[self doMethodCategoryRemove].
+ questBox okText:(resources at:'remove').
+ questBox noText:(resources at:'abort').
+ questBox showAtPointer
+ ]
+ ]
+! !
+
+!SystemBrowser methodsFor:'method menu'!
+
+initializeMethodMenu
+ |labels|
+
+ labels := resources array:#(
+ 'fileOut'
+ 'printOut'
+ '-'
+ 'spawn'
+ '-'
+ 'senders ...'
+ 'implementors ...'
+ 'globals ...'
+"
+ 'strings ...'
+ 'apropos ...'
+"
+ '-'
+ 'local senders ...'
+ 'local implementors ...'
+"
+ 'local strings ...'
+"
+ '-'
+ 'breakpoint'
+ 'trace'
+ 'trace sender'
+ '-'
+ 'new method'
+ 'change category ...'
+ 'remove').
+
+ methodListView
+ middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:#(methodFileOut
+ methodPrintOut
+ nil
+ methodSpawn
+ nil
+ methodSenders
+ methodImplementors
+ methodGlobalReferends
+"
+ methodStringSearch
+ methodAproposSearch
+"
+ nil
+ methodLocalSenders
+ methodLocalImplementors
+"
+ methodLocalStringSearch
+"
+ nil
+ methodBreakPoint
+ methodTrace
+ methodTraceSender
+ nil
+ methodNewMethod
+ methodChangeCategory
+ methodRemove)
+ receiver:self
+ for:methodListView)
+!
+
+initializeMethodMenu2
+ |labels|
+
+ methodListView isNil ifTrue:[^ self].
+ labels := resources array:#(
+ 'fileOut'
+ 'printOut'
+ '-'
+ 'spawn'
+ '-'
+ 'senders ...'
+ 'implementors ...'
+ 'globals ...'
+"
+ 'strings ...'
+ 'apropos ...'
+"
+ '-'
+ 'local senders ...'
+ 'local implementors ...'
+"
+ 'local strings ...'
+"
+ '-'
+ 'remove break/trace'
+ '-'
+ 'new method'
+ 'change category ...'
+ 'remove').
+
+ methodListView
+ middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:#(methodFileOut
+ methodPrintOut
+ nil
+ methodSpawn
+ nil
+ methodSenders
+ methodImplementors
+ methodGlobalReferends
+"
+ methodStringSearch
+ methodAproposSearch
+"
+ nil
+ methodLocalSenders
+ methodLocalImplementors
+"
+ methodLocalStringSearch
+"
+ nil
+ methodRemoveBreakOrTrace
+ nil
+ methodNewMethod
+ methodChangeCategory
+ methodRemove)
+ receiver:self
+ for:methodListView)
+!
+
+methodPrintOut
+ "print out the current method"
+
+ |printStream|
+
+ currentMethod isNil ifTrue:[
+ ^ self warn:'select a method first'.
+ ].
+ printStream := Printer new.
+ actualClass printOutSource:currentMethod source on:printStream.
+ printStream close
+!
+
+methodFileOut
+ "file out the current method"
+
+ currentMethod isNil ifTrue:[
+ ^ self warn:'select a method first'.
+ ].
+ self label:'System Browser saving'.
+ actualClass fileOutMethod:currentMethod.
+ self label:'System Browser'.
+!
+
+methodImplementors
+ "launch an enterBox for selector to search for"
+
+ self enterBoxForBrowseSelectorTitle:'selector to browse implementors of:'.
+ enterBox action:[:aString | self withWaitCursorDo:[
+ self class browseImplementorsOf:aString
+ ]
+ ].
+ enterBox showAtPointer
+!
+
+methodLocalImplementors
+ "launch an enterBox for selector to search for"
+
+ currentClass isNil ifTrue:[
+ ^ self warn:'select a class first'.
+ ].
+
+ self enterBoxForBrowseSelectorTitle:'selector to browse local implementors of:'.
+ enterBox action:[:aString | self withWaitCursorDo:[
+ self class browseImplementorsOf:aString under:currentClass
+ ]
+ ].
+ enterBox showAtPointer
+!
+
+methodSenders
+ "launch an enterBox for selector to search for"
+
+ self enterBoxForBrowseSelectorTitle:'selector to browse senders of:'.
+ enterBox action:[:aString | self withWaitCursorDo:[
+ self class browseAllCallsOn:aString
+ ]
+ ].
+ enterBox showAtPointer
+!
+
+methodLocalSenders
+ "launch an enterBox for selector to search for in current class & subclasses"
+
+ currentClass isNil ifTrue:[
+ ^ self warn:'select a class first'.
+ ].
+ self enterBoxForBrowseSelectorTitle:'selector to browse local senderss of:'.
+ enterBox action:[:aString | self withWaitCursorDo:[
+ self class browseCallsOn:aString under:currentClass
+ ]
+ ].
+ enterBox showAtPointer
+!
+
+methodGlobalReferends
+ "launch an enterBox for global symbol to search for"
+
+ self enterBoxForBrowseTitle:'global variable to browse users of:'.
+ enterBox action:[:aString | self withWaitCursorDo:[
+ self class browseReferendsOf:aString asSymbol
+ ]
+ ].
+ enterBox showAtPointer
+!
+
+methodStringSearch
+ "launch an enterBox for (sub)-string to search for"
+
+ self enterBoxForBrowseSelectorTitle:'string / matchString to search for:'.
+ enterBox action:[:aString | self withWaitCursorDo:[
+ self class browseForString:aString
+ ]
+ ].
+ enterBox showAtPointer
+!
+
+methodLocalStringSearch
+ "launch an enterBox for (sub)-string to search for"
+
+ currentClass isNil ifTrue:[
+ ^ self warn:'select a class first'.
+ ].
+ self enterBoxForBrowseSelectorTitle:'string / matchString to search for locally:'.
+ enterBox action:[:aString | self withWaitCursorDo:[
+ self class browseForString:aString in:(currentClass withAllSubclasses)
+ ]
+ ].
+ enterBox showAtPointer
+!
+
+methodAproposSearch
+ "launch an enterBox for a keyword search"
+
+ self enterBoxForBrowseSelectorTitle:'keyword to search for:'.
+ enterBox action:[:aString | self withWaitCursorDo:[
+ self class aproposSearch:aString
+ ]
+ ].
+ enterBox showAtPointer
+!
+
+methodSpawn
+ "create a new SystemBrowser browsing current method,
+ or if the current selection is of the form 'class>>selector', spwan
+ a browser on that method."
+
+ |s sel clsName cls browseMeta w sep|
+
+ sel := codeView selection.
+ sel notNil ifTrue:[
+ sel := sel asString withoutSeparators.
+ ('*>>*' match:sel) ifTrue:[
+ sep := $>
+ ] ifFalse:[
+ ('* *' match:sel) ifTrue:[
+ sep := Character space
+ ]
+ ].
+ sep notNil ifTrue:[
+ s := ReadStream on:sel.
+ clsName := s upTo:sep.
+ [s peek == sep] whileTrue:[s next].
+ sel := s upToEnd.
+ (clsName endsWith:'class') ifTrue:[
+ browseMeta := true.
+ clsName := clsName copyTo:(clsName size - 5)
+ ] ifFalse:[
+ browseMeta := false
+ ].
+ (clsName knownAsSymbol and:[sel knownAsSymbol]) ifTrue:[
+ (Smalltalk includesKey:clsName asSymbol) ifTrue:[
+ cls := Smalltalk at:clsName asSymbol.
+ browseMeta ifTrue:[
+ cls := cls class
+ ].
+ cls isBehavior ifFalse:[
+ cls := cls class
+ ].
+ cls isBehavior ifTrue:[
+ (cls implements:sel asSymbol) ifTrue:[
+ self withWaitCursorDo:[
+ self class browseClass:cls selector:sel asSymbol
+ ].
+ ^ self
+ ] ifFalse:[
+ (cls class implements:sel asSymbol) ifTrue:[
+ self withWaitCursorDo:[
+ self class browseClass:cls class selector:sel asSymbol
+ ].
+ ^ self
+ ] ifFalse:[
+ w := clsName , ' does not implement #' , sel
+ ]
+ ]
+ ] ifFalse:[
+ w := clsName , ' is not a class'
+ ]
+ ] ifFalse:[
+ w := clsName , ' is unknown'
+ ]
+ ] ifFalse:[
+ w := clsName , ' and/or ' , sel , ' is unknown'
+ ].
+ self warn:w.
+ ^ self
+ ].
+ ].
+
+ currentMethod isNil ifTrue:[
+ ^ self warn:'select a method first'.
+ ].
+ self withWaitCursorDo:[
+ self class browseClass:actualClass
+ selector:(actualClass selectorForMethod:currentMethod)
+ ]
+!
+
+methodNewMethod
+ "prepare for definition of a new method - put a template into
+ code view and define accept-action to compile it"
+
+ currentClass isNil ifTrue:[
+ ^ self warn:'select/create a class first'.
+ ].
+ currentMethodCategory isNil ifTrue:[
+ ^ self warn:'select/create a method category first'.
+ ].
+
+ currentMethod := nil.
+
+ methodListView deselect.
+ codeView contents:(self template).
+ codeView modified:false.
+
+ codeView acceptAction:[:theCode |
+ codeView cursor:Cursor execute.
+ Object abortSignal catch:[
+ actualClass compiler compile:theCode asString
+ forClass:actualClass
+ inCategory:currentMethodCategory
+ notifying:codeView.
+ codeView modified:false.
+ self updateMethodListWithScroll:false.
+ ].
+ codeView cursor:Cursor normal.
+ ].
+ codeView explainAction:[:theCode :theSelection |
+ self showExplanation:(Explainer explain:theSelection
+ in:theCode
+ forClass:actualClass)
+ ]
+!
+
+methodRemove
+ "remove the current method"
+
+ currentMethod isNil ifTrue:[
+ ^ self warn:'select a method first'.
+ ].
+ actualClass
+ removeSelector:(actualClass selectorForMethod:currentMethod).
+ self updateMethodListWithScroll:false
+!
+
+doChangeCategoryOfCurrentMethodTo:aString
+ "after querying user - do really change current methods category"
+
+ currentMethod isNil ifTrue:[
+ ^ self warn:'select a method first'.
+ ].
+ currentMethod category:aString asSymbol.
+ currentClass changed.
+ self updateMethodCategoryListWithScroll:false.
+ self updateMethodListWithScroll:false
+!
+
+methodChangeCategory
+ "move the current method into another category -
+ nothing done here, but a query for the new category.
+ Remember the last category, to allow faster category change of a group of methods."
+
+ currentMethod isNil ifTrue:[
+ ^ self warn:'select a method first'.
+ ].
+ self enterBoxTitle:('change category from ' , currentMethod category , ' to:')
+ okText:'change'.
+ lastMethodCategory isNil ifTrue:[
+ enterBox initialText:(currentMethod category).
+ ] ifFalse:[
+ enterBox initialText:lastMethodCategory
+ ].
+ enterBox action:[:aString | lastMethodCategory := aString.
+ self doChangeCategoryOfCurrentMethodTo:aString
+ ].
+ enterBox showAtPointer
+!
+
+methodRemoveBreakOrTrace
+ "turn off tracing of the current method"
+
+ |sel|
+
+ currentMethod notNil ifTrue:[
+ currentMethod isWrapped ifTrue:[
+ currentMethod := MessageTracer unwrapMethod:currentMethod.
+ sel := methodListView selection.
+ self updateMethodListWithScroll:false.
+ methodListView selection:sel.
+ self initializeMethodMenu
+ ].
+ ]
+!
+
+methodBreakPoint
+ "set a breakpoint on the current method"
+
+ |sel|
+
+ currentMethod notNil ifTrue:[
+ currentMethod isWrapped ifFalse:[
+ currentMethod := MessageTracer trapMethod:currentMethod.
+ self initializeMethodMenu2.
+ sel := methodListView selection.
+ self updateMethodListWithScroll:false.
+ methodListView selection:sel
+ ].
+ ]
+!
+
+methodTrace
+ "turn on tracing of the current method"
+
+ |sel|
+
+ currentMethod notNil ifTrue:[
+ currentMethod isWrapped ifFalse:[
+ currentMethod := MessageTracer traceMethod:currentMethod.
+ self initializeMethodMenu2.
+ sel := methodListView selection.
+ self updateMethodListWithScroll:false.
+ methodListView selection:sel
+ ].
+ ]
+!
+
+methodTraceSender
+ "turn on tracing of the current method"
+
+ |sel|
+
+ currentMethod notNil ifTrue:[
+ currentMethod isWrapped ifFalse:[
+ currentMethod := MessageTracer traceMethodSender:currentMethod.
+ self initializeMethodMenu2.
+ sel := methodListView selection.
+ self updateMethodListWithScroll:false.
+ methodListView selection:sel
+ ].
+ ]
+! !
+
+!SystemBrowser methodsFor:'class-method menu'!
+
+initializeClassMethodMenu
+ |labels|
+
+ labels := resources array:#(
+ 'fileOut'
+ 'printOut'
+ '-'
+ 'spawn'
+ '-'
+ 'sender ...'
+ 'implementors ...'
+ 'globals ...'
+"/ '-'
+"/ 'breakpoint'
+"/ 'trace'
+"/ 'trace sender'
+ ).
+
+ classMethodListView
+ middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:#(methodFileOut
+ methodPrintOut
+ nil
+ methodSpawn
+ nil
+ methodSenders
+ methodImplementors
+ methodGlobalReferends
+"/ nil
+"/ methodBreakPoint
+"/ methodTrace
+"/ methodTraceSender
+ )
+ receiver:self
+ for:classMethodListView)
+! !
+
+!SystemBrowser methodsFor:'dependencies'!
+
+update
+ "handle changes from other browsers"
+
+ |oldClassCategory oldClassName oldMethodCategory oldMethod oldSelector|
+
+self updateClassCategoryListWithScroll:false.
+"
+self updateClassListWithScroll:false.
+"
+^ self.
+
+ oldClassCategory := currentClassCategory.
+ currentClass notNil ifTrue:[
+ oldClassName := currentClass name
+ ].
+ oldMethodCategory := currentMethodCategory.
+ oldMethod := currentMethod.
+ methodListView notNil ifTrue:[
+ oldMethod notNil ifTrue:[
+ oldSelector := methodListView selectionValue
+ ]
+ ].
+
+ classCategoryListView notNil ifTrue:[
+ classCategoryListView setContents:(self listOfAllClassCategories).
+ oldClassCategory notNil ifTrue:[
+ classCategoryListView selectElement:oldClassCategory
+ ].
+ classCategoryListView selection isNil ifTrue:[
+ currentClassCategory := nil.
+ self switchToClass:nil.
+ oldClassName := nil
+ ]
+ ].
+ classListView notNil ifTrue:[
+ self updateClassListWithScroll:false.
+ oldClassName notNil ifTrue:[
+ classListView selectElement:oldClassName
+ ].
+ classListView selection isNil ifTrue:[
+ self switchToClass:nil.
+ currentMethodCategory := nil.
+ oldMethodCategory := nil
+ ]
+ ].
+ methodCategoryListView notNil ifTrue:[
+ self updateMethodCategoryListWithScroll:false.
+ oldMethodCategory notNil ifTrue:[
+ methodCategoryListView selectElement:oldMethodCategory
+ ].
+ methodCategoryListView selection isNil ifTrue:[
+ currentMethodCategory := nil.
+ currentMethod := nil.
+ oldSelector := nil
+ ]
+ ].
+ methodListView notNil ifTrue:[
+ self updateMethodListWithScroll:false.
+ oldSelector notNil ifTrue:[
+ methodListView selectElement:oldSelector
+ ].
+ methodListView selection isNil ifTrue:[
+ currentMethod := nil
+ ]
+ ].
+ self updateCodeView
+!
+
+update:someObject
+ (someObject == Smalltalk) ifTrue:[self update. ^ self].
+ someObject isBehavior ifTrue:[
+ currentClass notNil ifTrue:[
+ someObject name = currentClass name ifTrue:[
+ currentClass := someObject.
+ showInstance ifTrue:[
+ actualClass := currentClass
+ ] ifFalse:[
+ actualClass := currentClass class
+ ].
+ self updateMethodCategoryListWithScroll:false.
+ "dont update codeView ...."
+ "self update"
+ ^ self
+ ]
+ ]
+ ]
+! !