"
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:#BrowserView
instanceVariableNames:'classCategoryListView classListView methodCategoryListView
methodListView classMethodListView codeView classToggle
instanceToggle currentNamespace currentClassCategory
currentClassHierarchy currentClass currentMethodCategory
currentMethod currentSelector showInstance actualClass fullClass
lastMethodCategory aspect variableListView fullProtocol
lockUpdates autoSearch myLabel acceptClass lastSourceLogMessage
lastCategory lastModule lastPackage lastMethodMoveClass
namespaceList allNamespaces gotClassList'
classVariableNames:'CheckForInstancesWhenRemovingClasses RememberAspect DefaultIcon
StopIcon TraceIcon'
poolDictionaries:''
category:'Interface-Browsers'
!
!BrowserView 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.
"
!
documentation
"
this class implements all kinds of class browsers.
Typically, it is started with 'SystemBrowser open', but there are many other
startup messages, to launch special browsers.
See the categories 'startup' and 'special search startup' in the classes
protocol.
Alse, see the extra document 'doc/misc/sbrowser.doc' or the HTML online doc
for how to use the browser.
written winter 89 by claus
Notice: SystemBrowser is currently being rewritten to be an instance
of ApplicationModel - this transition is not yet complete and you see
here intermediate versions of BrowserView/SystemBrowser.
All action is (currently) still done here in BrowserView, although the
SystemBrowsers class methods are used to startup a browser.
This will certainly change ...
[author:]
Claus Gittinger
"
! !
!BrowserView class methodsFor:'initialization'!
initialize
"Browser configuration;
(values can be changed from your private startup file)"
"
setting this to false, the removeClass function will remove
classes WITHOUT checking for instances. Otherwise,
it will check and let you confirm in case there are instances.
Checking for instances may be a bit time consuming, though.
The default is true - therefore, it will check
"
CheckForInstancesWhenRemovingClasses := true.
"
setting this to true makes the browser remember the aspect shown
in the classList and show this aspect when a new class is selected.
If false, it always switches to the classes definition
"
RememberAspect := true.
"
CheckForInstancesWhenRemovingClasses := true
CheckForInstancesWhenRemovingClasses := false
RememberAspect := true
RememberAspect := false
"
"Created: 23.11.1995 / 11:35:58 / cg"
"Modified: 23.11.1995 / 11:36:34 / cg"
! !
!BrowserView class methodsFor:'cleanup'!
lowSpaceCleanup
DefaultIcon := nil
"Created: 18.4.1996 / 16:46:40 / cg"
! !
!BrowserView class methodsFor:'defaults'!
defaultIcon
DefaultIcon isNil ifTrue:[
DefaultIcon := Image fromFile:'bitmaps/SBrowser.xbm' resolution:100
].
^ DefaultIcon
"Modified: 1.1.1970 / 14:04:42 / cg"
! !
!BrowserView methodsFor:'change & update'!
delayedUpdate:something with:someArgument from:changedObject
|list selector oldMethod|
(changedObject == Smalltalk) ifTrue:[
something == #methodInClassRemoved ifTrue:[
"/ ignored; I am dependent of individual class update messages
^ self
].
something == #methodInClass ifTrue:[
"/ ignored; I am dependent of individual class update messages
^ self
].
self updateNamespaceList.
something == #newClass ifTrue:[
(currentClass notNil
and:[someArgument name = currentClass name]) ifTrue:[
"
the current class has changed
"
(aspect == #definition
and:[codeView modified not]) ifTrue:[
self refetchClass.
self classSelectionChanged.
] ifFalse:[
self updateClassListWithScroll:false.
].
self warnLabel:'the selected class has changed'.
].
((someArgument category = currentClassCategory)
or:[currentClassCategory notNil
and:[currentClassCategory startsWith:'*']]) ifTrue:[
self updateClassListWithScroll:false.
].
someArgument category ~= currentClassCategory ifTrue:[
"
category new ?
"
(classCategoryListView notNil
and:[(list := classCategoryListView list) notNil
and:[(list includes:someArgument category) not]])
ifTrue:[
self updateClassCategoryListWithScroll:false.
]
].
^ self
].
something == #classRemove ifTrue:[
someArgument == currentClass ifTrue:[
self warnLabel:'the selected class was removed'.
^ self
].
" fall into general update "
].
"
any other (unknown) change
with the Smalltalk dictionary ...
"
self updateClassCategoryListWithScroll:false.
self updateClassListWithScroll:false.
^ self
].
changedObject isBehavior ifTrue:[
"/
"/ its a class, that has changed
"/
fullClass ifTrue:[
"/
"/ full-class browser ...
"/ (must check for both class and metaclass changes)
"/
(currentClass == changedObject
or:[currentClass class == changedObject]) ifTrue:[
self warnLabel:'class was changed - the code shown may be obsolete'.
].
^ self
].
(currentClass notNil
and:[changedObject name = currentClass name]) ifTrue:[
"/
"/ its the current class that has changed
"/
((something == #methodDictionary)
or:[something == #methodTrap
or:[something == #methodPrivacy]]) ifTrue:[
"/ new feature: changeArg may be an array consisting of
"/ the selector and the oldMethod
someArgument isArray ifTrue:[
oldMethod := someArgument at:2.
selector := someArgument at:1.
] ifFalse:[
selector := someArgument
].
(selector isSymbol) ifTrue:[
|changedMethod s1 s2 oldMethodSelection oldMethodCategorySelection|
"
the method with selector was changed or removed
"
methodListView notNil ifTrue:[
oldMethodSelection := methodListView selection.
].
(something ~~ #methodTrap
and:[something ~~ #methodPrivacy]) ifTrue:[
methodCategoryListView notNil ifTrue:[
oldMethodCategorySelection := methodCategoryListView selection.
self updateMethodCategoryListWithScroll:false.
methodCategoryListView selection:oldMethodCategorySelection.
].
].
self updateMethodListWithScroll:false.
methodListView notNil ifTrue:[
methodListView setSelection:oldMethodSelection.
].
classMethodListView notNil ifTrue:[
oldMethodSelection := classMethodListView selection.
self updateMethodCategoryListWithScroll:false.
classMethodListView selection:oldMethodSelection.
].
selector == currentSelector ifTrue:[
"
special care here: the currently shown method has been
changed somehow in another browser (or via fileIn)
"
changedMethod := currentClass compiledMethodAt:currentSelector.
changedMethod isNil ifTrue:[
self warnLabel:'the method shown was removed'.
^ self
].
"compare the source codes"
currentMethod notNil ifTrue:[
s1 := changedMethod source asString asCollectionOfLines copy.
[s1 last isEmpty] whileTrue:[s1 removeLast].
s2 := codeView contents asCollectionOfLines copy.
[s2 last isEmpty] whileTrue:[s2 removeLast].
s1 = s2 ifFalse:[
self warnLabel:'method has changed - the code shown may be obsolete'.
]
].
^ self
].
]
].
something == #comment ifTrue:[
"
the class has changed its comment; we dont care, except if
currently showing the comment
"
aspect == #comment ifTrue:[
codeView modified ifFalse:[
self refetchClass.
self updateCodeView
] ifTrue:[
self warnLabel:'the comment has changed - reselect to update'.
]
].
self refetchClass.
^ self
].
something == #definition ifTrue:[
"
the class has changed its definition.
Warn, except if showing a method.
"
aspect notNil ifTrue:[
codeView modified ifFalse:[
self refetchClass.
self updateCodeView
] ifTrue:[
self warnLabel:'the classes definition has changed - reselect to update'.
].
^ self
].
].
"/
"/ if I am not showing code update if unmodified,
"/ warn if modified
"/
aspect notNil ifTrue:[
codeView modified ifFalse:[
self refetchClass.
self updateCodeView
] ifTrue:[
self warnLabel:'the classes has changed - reselect to update'.
].
^ self
].
"
get the class again - in case of a changed class definition,
we are otherwise refering to the obsolete old class
"
self refetchClass.
self updateMethodCategoryListWithScroll:false.
"dont update codeView ...."
"self update"
self warnLabel:'the class has changed'.
^ self
].
"
any other class has changed (but not its organization, since
that is cought in the above case).
We are not interested in it - except, if showing fullProtocol
or hierarchy ...
"
currentClassHierarchy notNil ifTrue:[
fullProtocol ifTrue:[
(currentClass isSubclassOf:changedObject) ifTrue:[
self warnLabel:'some superclass has changed - reselect to update'.
]
] ifFalse:[
((currentClass isSubclassOf:changedObject)
or:[changedObject isSubclassOf:currentClass]) ifTrue:[
self warnLabel:'some superclass has changed - reselect to update'.
]
]
].
^ self
].
(changedObject isMethod) ifTrue:[
]
"Created: 4.1.1997 / 13:54:00 / cg"
"Modified: 7.3.1997 / 19:29:28 / cg"
!
refetchClass
"after a class definition change in another browser,
this is sent to update (otherwise, we'd still refer to the obsolete class)"
"/ currentClass := Smalltalk at:(currentClass name asSymbol).
self switchToClass:(Smalltalk at:(currentClass name asSymbol)).
"/ showInstance ifTrue:[
"/ actualClass := currentClass
"/ ] ifFalse:[
"/ actualClass := currentClass class
"/ ].
"Created: 8.2.1996 / 13:22:27 / cg"
"Modified: 8.2.1996 / 13:40:18 / cg"
!
update:something with:someArgument from:changedObject
|argList sensor|
(changedObject == ObjectMemory) ifTrue:[
(something == #earlyRestart
or:[something == #restarted
or:[something == #returnFromSnapshot]]) ifTrue:[
"/ those are to be ignored.
^ self
]
].
"/
"/ avoid update/warn after my own changes
"/
lockUpdates == true ifTrue:[
^ self
].
"/
"/ quick hack: delayed update fails, if I autoload
"/ LabelAndIcon in the update, and another browser
"/ gets a chance to do an update as well, trying to
"/ access the (temporarily nil) LabelAndIcon.
"/ To gat that beast out, do it synchronous for now.
LabelAndIcon isLoaded ifFalse:[
^ self delayedUpdate:something with:someArgument from:changedObject
].
(sensor := self sensor) isNil ifTrue:[
"/ mhmh - an update, but I am not yet visible
^ self delayedUpdate:something with:someArgument from:changedObject
].
"/
"/ if such an update is already in the queue, ignore it.
"/ Otherwise push it as an event, to be handled when I am back
"/
argList := Array with:something
with:someArgument
with:changedObject.
(self sensor
hasEvent:#delayedUpdate:with:from:
for:self
withArguments:argList) ifTrue:[
^ self
].
self sensor
pushUserEvent:#delayedUpdate:with:from:
for:self
withArguments:argList
"Modified: 9.1.1997 / 02:51:49 / cg"
! !
!BrowserView methodsFor:'class category list menu'!
classCategoryClone
"open a new SystemBrowser showing the same method as I do"
SystemBrowser openInClass:actualClass selector:currentSelector
"Created: 14.9.1995 / 10:55:20 / claus"
"Modified: 14.9.1995 / 10:59:31 / claus"
!
classCategoryFileOut
"create a file 'categoryName' consisting of all classes in current category"
|aStream fileName|
self checkClassCategorySelected ifFalse:[^ self].
(currentClassCategory startsWith:'*') ifTrue:[
self warn:(resources string:'try a real category').
^ self
].
fileName := currentClassCategory asString.
fileName replaceAll:Character space by:$_.
"
this test allows a smalltalk to be built without Projects/ChangeSets
"
Project notNil ifTrue:[
fileName := Project currentProjectDirectory , fileName.
].
self withWaitCursorDo:[
"
if file exists, save original in a .sav file
"
fileName asFilename exists ifTrue:[
self busyLabel:'saving existing %1' with:fileName.
fileName asFilename copyTo:(fileName , '.sav')
].
aStream := FileStream newFileNamed:fileName.
aStream isNil ifTrue:[
self warn:'cannot create: %1' with:fileName
] ifFalse:[
self busyLabel:'writing: %1' with:fileName.
self allClassesInCategory:currentClassCategory inOrderDo:[:aClass |
aClass isPrivate ifFalse:[
(self listOfNamespaces includesIdentical:aClass nameSpace)
ifTrue:[
self busyLabel:'writing: %1' with:fileName.
aClass fileOutOn:aStream.
]
]
].
aStream close.
]
].
self normalLabel.
"Modified: 16.1.1997 / 20:23:00 / cg"
!
classCategoryFileOutBinaryEach
"fileOut each class in the current category as binary bytecode."
|mode|
(currentClassCategory startsWith:'*') ifTrue:[
self warn:(resources string:'try a real category').
^ self
].
mode := Dialog choose:(resources string:'save including sources ?')
labels:(resources array:#('cancel' 'discard' 'by file reference' 'include source'))
values:#(nil #discard #reference #keep)
default:#keep.
mode isNil ifTrue:[^ self].
self withWaitCursorDo:[
self allClassesInCategory:currentClassCategory do:[:aClass |
aClass isPrivate ifFalse:[
(self listOfNamespaces includesIdentical:aClass nameSpace)
ifTrue:[
self busyLabel:'saving binary of: %1' with:aClass name.
Class fileOutErrorSignal handle:[:ex |
self warn:'cannot create: %1' with:ex parameter.
ex return.
] do:[
aClass binaryFileOutWithSourceMode:mode.
]
]
]
].
self normalLabel.
]
"Created: 25.1.1996 / 17:27:45 / cg"
"Modified: 16.1.1997 / 20:23:14 / cg"
!
classCategoryFileOutEach
(currentClassCategory startsWith:'*') ifTrue:[
self warn:(resources string:'try a real category').
^ self
].
self withWaitCursorDo:[
self allClassesInCategory:currentClassCategory do:[:aClass |
aClass isPrivate ifFalse:[
(self listOfNamespaces includesIdentical:aClass nameSpace)
ifTrue:[
self busyLabel:'saving: %1' with:aClass name.
Class fileOutErrorSignal handle:[:ex |
self warn:'cannot fileOut: %1\(%2)' with:aClass name with:ex errorString.
ex return.
] do:[
aClass fileOut
]
]
]
].
self normalLabel.
]
"Modified: 16.1.1997 / 20:23:33 / cg"
!
classCategoryFindClass
"find a class - and switch by default"
self classCategoryFindClassOpen:false
"Modified: 15.1.1997 / 22:55:20 / cg"
!
classCategoryFindClassOpen:doOpen
"common code for both opening a new browser on a class and
to search for a class in this browser"
|box openButton title open okText okText2|
open := doOpen.
open ifTrue:[
title := 'class to browse:'.
okText := 'open'.
okText2 := 'find here'.
] ifFalse:[
title := 'class to find:'.
okText := 'find'.
okText2 := 'open new'.
].
box := self enterBoxForCodeSelectionTitle:title okText:okText.
box label:(resources string:'browse or search class').
openButton := box addButton:(Button label:(resources string:okText2)) before:(box okButton).
openButton action:[
open := open not.
box doAccept.
box okPressed.
].
box entryCompletionBlock:[:contents |
|s what m|
s := contents withoutSpaces.
what := Smalltalk classnameCompletion:s.
box contents:what first.
(what at:2) size ~~ 1 ifTrue:[
self beep
]
].
box action:[:aString |
|brwsr|
open ifTrue:[
brwsr := SystemBrowser open
] ifFalse:[
brwsr := self
].
brwsr switchToClassNameMatching:aString
].
box showAtPointer
"Created: 1.6.1996 / 16:03:15 / cg"
"Modified: 15.1.1997 / 23:14:16 / cg"
!
classCategoryFindMethod
|box|
box := self
listBoxForCodeSelectionTitle:'selector to find:'
okText:'find'.
box label:(resources string:'find method').
box entryCompletionBlock:[:contents |
|s what m|
s := contents withoutSpaces.
box topView withWaitCursorDo:[
what := Smalltalk selectorCompletion:s.
box list:(what at:2).
box contents:what first.
(what at:2) size ~~ 1 ifTrue:[
self beep
]
]
].
box action:[:aString | self switchToAnyMethod:aString].
box showAtPointer
"Modified: 30.8.1995 / 22:49:49 / claus"
"Modified: 15.1.1997 / 23:19:08 / cg"
!
classCategoryMenu
<resource: #keyboard ( #Find #Cmdn) >
|specialMenu m labels selectors shorties|
currentClassCategory notNil ifTrue:[
labels := #(
'fileOut each binary ...'
'-'
'repository history ...'
'validate class revisions'
'-'
'checkin each ...'
).
selectors := #(
classCategoryFileOutBinaryEach
nil
classCategoryRepositoryHistory
classCategoryValidateClassRevisions
nil
classCategoryCheckinEach
).
] ifFalse:[
labels := #(
'repository history ...'
).
selectors := #(
classCategoryRepositoryHistory
).
].
specialMenu := PopUpMenu
labels:(resources array:labels)
selectors:selectors
receiver:self.
Smalltalk sourceCodeManager isNil ifTrue:[
specialMenu disableAll:#(classCategoryRepositoryHistory
classCategoryCheckinEach
classCategoryValidateClassRevisions).
].
device ctrlDown ifTrue:[
^ specialMenu
].
currentClassCategory isNil ifTrue:[
labels := #(
"/ 'namespace ...'
"/ '-'
'clone'
'open for class ...'
'spawn full class'
'-'
'update'
'find class ...'
'find method ...'
'-'
'new class category ...'
'='
'others'
).
selectors := #(
"/ namespaceDialog
"/ nil
classCategoryClone
classCategoryOpenInClass
classCategorySpawnFullClass
nil
classCategoryUpdate
classCategoryFindClass
classCategoryFindMethod
nil
classCategoryNewCategory
nil
otherMenu
).
shorties := #(
"/ nil
"/ nil
nil
nil
nil
nil
nil
Find
nil
nil
Cmdn
nil
#'Ctrl'
).
] ifFalse:[
labels := #(
'fileOut'
'fileOut each'
'printOut'
'printOut protocol'
'-'
"/ 'namespace ...'
"/ '-'
'clone'
'open for class ...'
'SPAWN_CATEGORY'
'spawn full class'
'-'
'update'
'find class ...'
'find method ...'
'-'
'new class category ...'
'rename ...'
'remove'
'='
'others'
).
selectors := #(
classCategoryFileOut
classCategoryFileOutEach
classCategoryPrintOut
classCategoryPrintOutProtocol
nil
"/ namespaceDialog
"/ nil
classCategoryClone
classCategoryOpenInClass
classCategorySpawn
classCategorySpawnFullClass
nil
classCategoryUpdate
classCategoryFindClass
classCategoryFindMethod
nil
classCategoryNewCategory
classCategoryRename
classCategoryRemove
nil
otherMenu
).
shorties := #(
nil
nil
nil
nil
nil
"/ nil
"/ nil
nil
nil
nil
nil
nil
nil
Find
nil
nil
Cmdn
nil
nil
nil
#'Ctrl'
).
].
m := PopUpMenu
labels:(resources array:labels)
selectors:selectors
accelerators:shorties.
m subMenuAt:#otherMenu put:specialMenu.
^ m
"Created: 14.9.1995 / 10:50:17 / claus"
"Modified: 11.1.1997 / 21:38:33 / cg"
!
classCategoryNewCategory
|box|
box := self
enterBoxTitle:'name of new class category:'
okText:'create'
label:'create category'.
box action:[:aString |
|categories|
categories := classCategoryListView list.
(categories includes:aString) ifFalse:[
categories add:aString.
categories sort.
classCategoryListView setContents:categories.
].
currentClassCategory := aString.
classCategoryListView setSelectElement:aString.
self switchToClass:nil.
actualClass := acceptClass := nil.
self classCategorySelectionChanged
].
box showAtPointer
"Modified: 19.8.1996 / 18:25:41 / stefan"
"Modified: 15.1.1997 / 23:06:46 / cg"
!
classCategoryOpenInClass
"find a class - and open a browser (by default)"
self classCategoryFindClassOpen:true
"Modified: 15.1.1997 / 22:55:32 / cg"
!
classCategoryPrintOut
|printStream|
self allClassesInCategory:currentClassCategory inOrderDo:[:aClass |
(self listOfNamespaces includesIdentical:aClass nameSpace)
ifTrue:[
printStream := Printer new.
aClass printOutOn:printStream.
printStream close
]
]
"Modified: 16.1.1997 / 20:22:23 / cg"
!
classCategoryPrintOutProtocol
|printStream|
Smalltalk allClassesInCategory:currentClassCategory inOrderDo:[:aClass |
(self listOfNamespaces includesIdentical:aClass nameSpace)
ifTrue:[
printStream := Printer new.
aClass printOutProtocolOn:printStream.
printStream close
]
]
"Modified: 16.1.1997 / 20:22:12 / cg"
!
classCategoryRemove
"remove all classes in current category"
|count overallCount t classesToRemove subclassesRemoved box t2|
self checkClassCategorySelected ifFalse:[^ self].
classesToRemove := IdentitySet new.
self allClassesInSelectedNamespacesDo:[:aClass |
aClass category = currentClassCategory ifTrue:[
classesToRemove add:aClass
]
].
subclassesRemoved := IdentitySet new.
classesToRemove do:[:aClass |
aClass allSubclassesDo:[:aSubclass |
(classesToRemove includes:aSubclass) ifFalse:[
(subclassesRemoved includes:aSubclass) ifFalse:[
subclassesRemoved add:aSubclass
]
]
]
].
count := overallCount := classesToRemove size.
t := resources string:'remove "%1" ?' with:currentClassCategory.
count ~~ 0 ifTrue:[
count == 1 ifTrue:[
t2 := '(with %1 class)'
] ifFalse:[
t2 := '(with %1 classes)'
].
t := t , '\' , (resources string:t2 with:count printString)
].
count := subclassesRemoved size.
overallCount := overallCount + count.
count ~~ 0 ifTrue:[
count == 1 ifTrue:[
t2 := '(and %1 subclass)'
] ifFalse:[
t2 := '(and %1 subclasses)'
].
t := t , '\' , (resources string:t2 with:count printString)
].
t := t withCRs.
box := YesNoBox
title:t
yesText:(resources at:'remove')
noText:(resources at:'abort').
box label:(resources at:'remove category').
overallCount ~~ 0 ifTrue:[
"/ should we disable the returnDefault here ?
].
box confirm ifTrue:[
"after querying user - do really remove classes in list1 and list2"
|keep idx|
keep := false.
(subclassesRemoved asOrderedCollection
, classesToRemove asOrderedCollection) do:[:aClassToRemove |
(CheckForInstancesWhenRemovingClasses not
or:[aClassToRemove hasInstances not
or:[self confirm:(resources string:'%1 has instances - remove anyway ?' with:aClassToRemove name)]]
) ifTrue:[
Smalltalk removeClass:aClassToRemove
] ifFalse:[
keep := true.
]
].
self updateClassCategoryList.
(classCategoryListView list includes:currentClassCategory) ifFalse:[
currentClassCategory := nil.
].
self classCategorySelectionChanged.
self switchToClass:nil.
"/ keep ifFalse:[
"/ idx := classCategoryListView list indexOf:currentClassCategory.
"/ currentClassCategory := nil.
"/ idx ~= 0 ifTrue:[
"/ classCategoryListView removeIndex:idx.
"/ ].
"/ ].
].
box destroy
"Modified: 19.8.1996 / 23:22:35 / stefan"
"Modified: 16.1.1997 / 20:21:05 / cg"
!
classCategoryRename
"launch an enterBox to rename current class category"
|box|
self checkClassCategorySelected ifFalse:[^ self].
box := self
enterBoxTitle:(resources string:'rename category ''%1'' to:' with:currentClassCategory)
okText:'rename'
label:'rename category'.
box initialText:currentClassCategory.
box action:[:aString | self renameCurrentClassCategoryTo:aString].
box showAtPointer
"Modified: 15.1.1997 / 23:10:12 / cg"
!
classCategorySpawn
"create a new SystemBrowser browsing current classCategory"
currentClassCategory notNil ifTrue:[
self withWaitCursorDo:[
SystemBrowser browseClassCategory:currentClassCategory
]
]
!
classCategorySpawnFullClass
"create a new SystemBrowser browsing full class"
|newBrowser|
self withWaitCursorDo:[
newBrowser := SystemBrowser browseFullClasses
" "
.
currentClass notNil ifTrue:[
newBrowser switchToClassNamed:(currentClass name)
]
" "
]
!
classCategoryUpdate
"update class category list and dependants"
|oldClassName oldMethodCategory|
classCategoryListView notNil ifTrue:[
self setListOfNamespaces.
currentClass notNil ifTrue:[
oldClassName := currentClass name.
(oldClassName endsWith:'-old') ifTrue:[
oldClassName := oldClassName copyWithoutLast:4 "copyTo:(oldClassName size - 4)"
]
].
oldMethodCategory := currentMethodCategory.
classCategoryListView setContents:(self listOfAllClassCategories).
currentClassCategory notNil ifTrue:[
classCategoryListView setSelectElement:currentClassCategory.
self classCategorySelectionChanged.
oldClassName notNil ifTrue:[
classListView setSelectElement:oldClassName.
self switchToClass:(Smalltalk at:oldClassName asSymbol).
self classSelectionChanged.
oldMethodCategory notNil ifTrue:[
methodCategoryListView setSelectElement:oldMethodCategory.
currentMethodCategory := oldMethodCategory.
self methodCategorySelectionChanged
]
]
].
self updateNamespaceList
]
"Modified: 8.1.1997 / 10:57:57 / cg"
! !
!BrowserView methodsFor:'class category source administration'!
classCategoryCheckinEach
(self checkSelectionChangeAllowedWithCompare:false) ifFalse:[^ self].
self withWaitCursorDo:[
|logMessage classes|
logMessage := self getLogMessageFor:'(any in classCategory ', currentClassCategory, ')'.
logMessage notNil ifTrue:[
(currentClassCategory = '* all *'
or:[currentClassCategory = '* hierarchy *']) ifTrue:[
classes := self allClasses
] ifFalse:[
classes := self allClassesInCategory:currentClassCategory.
].
"/ ignore private classes
classes := classes select:[:aClass | aClass owningClass isNil].
lastSourceLogMessage := logMessage.
classes do:[:aClass |
self busyLabel:'checking in %1' with:aClass name.
"/ ca does not want boxes to pop up all over ...
InformationSignal handle:[:ex |
Transcript showCR:ex errorString
] do:[
self classCheckin:aClass withLog:logMessage
"/ (aClass sourceCodeManager)
"/ checkinClass:aClass
"/ logMessage:logMessage.
].
self normalLabel.
]
].
self normalLabel.
]
"Created: 23.11.1995 / 11:41:38 / cg"
"Modified: 15.6.1996 / 00:25:58 / stefan"
"Modified: 26.2.1997 / 10:43:38 / cg"
!
classCategoryRepositoryHistory
(self checkSelectionChangeAllowedWithCompare:false) ifFalse:[^ self].
self withWaitCursorDo:[
|timeGoal aStream box y component timeGoalListPop|
box := Dialog new.
(box addTextLabel:(resources string:'repository change report')) adjust:#left.
box addVerticalSpace:20.
timeGoal := 'yesterday' asValue.
y := box yPosition.
component := box addTextLabel:(resources string:'list changes since (mm/dd):').
component width:0.5; adjust:#right; borderWidth:0.
box yPosition:y.
timeGoalListPop := box addComboBoxOn:timeGoal tabable:true.
timeGoalListPop width:0.5; left:0.5; immediateAccept:true; acceptOnLeave:false; cursorMovementWhenUpdating:#beginOfLine.
timeGoalListPop list:#('yesterday'
'a week ago'
'a month ago'
'a year ago'
'all'
).
box addAbortButton; addOkButton.
box open.
box accepted ifTrue:[
timeGoal := timeGoal value.
"/ timeGoal := Dialog
"/ request:'list changed repository containers since (mm/dd):
"/
"/You can also specify the date as
"/''yesterday'', ''a week ago'' or ''a month ago''
"/
"/'
"/ initialAnswer:'yesterday'
"/ onCancel:nil.
"/
"/ timeGoal notNil ifTrue:[
self busyLabel:'extracting history ...' with:nil.
aStream := WriteStream on:(String new:200).
Processor activeProcess withLowerPriorityDo:[
SourceCodeManager notNil ifTrue:[
SourceCodeManager
writeHistoryLogSince:timeGoal
to:aStream.
] ifFalse:[
aStream nextPutLine:'no history available (no SourceCodeManagement installed)'
].
].
codeView contents:(aStream contents).
codeView modified:false.
codeView acceptAction:nil.
codeView explainAction:nil.
methodListView notNil ifTrue:[
methodListView setSelection:nil
].
aspect := nil.
self normalLabel
].
]
"Created: 23.11.1995 / 11:41:38 / cg"
"Modified: 11.9.1996 / 14:02:49 / cg"
!
classCategoryValidateClassRevisions
"for all classes, ask the sourceCodeManager for the most recent version
and compare this to the actual version. Send mismatch info to the Transcript.
Use this, to find classes, which need to be reloaded from the repository."
self withWaitCursorDo:[
|logMessage classes repVersion clsVersion binVersion
count unloadedCount badCount cat|
cat := currentClassCategory.
(cat = '* hierarchy *') ifTrue:[
cat := '* all *'
].
classes := self listOfAllClassesInCategory:cat names:false.
classes isNil ifTrue:[
Transcript showCR:'no classes to validate'.
^ self
].
count := unloadedCount := badCount := 0.
Transcript cr.
Transcript showCR:'-------------------------------------------------'.
Transcript showCR:'checking class revisions vs. repository ...'.
Transcript cr.
classes do:[:aClass |
|clsName msg|
count := count + 1.
"/ ignore autoloaded and private classes here
clsName := aClass name.
aClass isLoaded ifFalse:[
unloadedCount := unloadedCount + 1.
(currentClassCategory ~= '* all *'
and:[currentClassCategory ~= '* hierarchy *']) ifTrue:[
msg := '?? ' , clsName , ' not loaded - skipped check'.
]
] ifTrue:[
((aClass isNamespace not or:[aClass == Smalltalk])
and:[aClass topOwningClass isNil]) ifTrue:[
"/ self busyLabel:'validating %1 ...' with:aClass name.
repVersion := aClass sourceCodeManager newestRevisionOf:aClass.
repVersion isNil ifTrue:[
msg := '-- ' , clsName
, ' not in repository'
] ifFalse:[
clsVersion := aClass revision.
binVersion := aClass binaryRevision.
clsName := aClass name.
msg := nil.
clsVersion ~= repVersion ifTrue:[
badCount := badCount + 1.
msg := '** ' , clsName
, ' is not up-to-date (this: '
, clsVersion printString
, ' repository: '
, repVersion printString
, ').'.
msg := msg asText allBold.
] ifFalse:[
clsVersion ~= binVersion ifTrue:[
binVersion notNil ifTrue:[
msg := clsName
, ' up-to-date (but should be stc-recompiled)'
]
] ifFalse:[
"/ msg := clsName , ' is up-to-date.'
]
].
].
].
].
msg notNil ifTrue:[
Transcript showCR:msg
].
].
Transcript cr.
Transcript showCR:('%1 classes / %2 unloaded / %3 need(s) to be updated from the repository.'
bindWith:count with:unloadedCount with:badCount).
Transcript showCR:'-------------------------------------------------'.
self normalLabel.
]
"Modified: 15.6.1996 / 00:25:58 / stefan"
"Created: 29.10.1996 / 13:21:08 / cg"
"Modified: 29.1.1997 / 18:48:30 / cg"
! !
!BrowserView methodsFor:'class category stuff'!
checkClassCategorySelected
currentClassCategory isNil ifTrue:[
self warn:'select a class category first'.
^ false
].
^ true
!
classCategorySelection:lineNr
"user clicked on a class category line - show classes.
If switching to hierarchy or all, keep current selections"
|newCategory oldClass oldName classIndex list|
newCategory := classCategoryListView selectionValue.
(newCategory startsWith:'*') ifTrue:[
"etiher all or hierarchy;
remember current selections and switch after showing class list"
oldClass := currentClass
].
currentClassCategory := newCategory.
oldClass isNil ifTrue:[
self classCategorySelectionChanged
] ifFalse:[
oldName := oldClass name.
self withWaitCursorDo:[
self updateClassList
].
"stupid - search for class name in (indented) list"
list := classListView list.
list notNil ifTrue:[
classIndex := list findFirst:[:elem | elem endsWith:oldName].
] ifFalse:[
classIndex := 0
].
classIndex ~~ 0 ifTrue:[
classListView setSelection:classIndex.
self switchToClass:(Smalltalk at:(oldName asSymbol))
] ifFalse:[
self normalLabel.
]
]
"Modified: 20.12.1996 / 16:40:15 / cg"
!
classCategorySelectionChanged
"class category has changed - update dependent views"
self withWaitCursorDo:[
self switchToClass:nil.
aspect := nil.
actualClass := acceptClass := nil.
currentMethodCategory := nil.
currentMethod := currentSelector := nil.
self updateClassList.
self updateMethodCategoryList.
self updateMethodList.
self updateCodeView.
codeView explainAction:nil.
codeView acceptAction:nil
]
"Modified: 8.2.1996 / 13:35:18 / cg"
!
listOfAllClassCategories
"return a list of all class categories"
|nameSpaceList newList cat allNameSpaces|
newList := Set new.
currentNamespace = '* all *' ifTrue:[
nameSpaceList := Array with:Smalltalk.
allNameSpaces := true.
] ifFalse:[
nameSpaceList := self listOfNamespaces.
allNameSpaces := false.
].
nameSpaceList do:[:aNamespace |
aNamespace allBehaviorsDo:[:aClass |
aClass isMeta ifFalse:[
(aClass isNamespace not
or:[aClass == Namespace
or:[aClass == Smalltalk]]) ifTrue:[
(allNameSpaces or:[aClass nameSpace == aNamespace]) ifTrue:[
cat := aClass category.
cat isNil ifTrue:[
cat := '* no category *'
].
cat ~= 'obsolete' ifTrue:[
newList add:cat
]
]
]
]
]
].
newList notEmpty ifTrue:[
newList add:'* all *'; add:'* hierarchy *'.
].
^ newList asOrderedCollection sort.
"Modified: 5.1.1997 / 17:12:01 / cg"
!
renameCurrentClassCategoryTo:aString
"helper - do the rename"
|any categories|
currentClassCategory notNil ifTrue:[
any := false.
self allClassesInSelectedNamespacesDo:[: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 setSelectElement:aString.
] ifTrue:[
currentClassCategory := aString.
self updateClassCategoryList.
self updateClassListWithScroll:false
]
]
"Modified: 16.1.1997 / 20:20:38 / cg"
!
switchToAnyMethod:aSelectorString
"find all implementors of aSelectorString, and present a list
to choose from. When an entry is selected, switch to that class/selector.
This allows for quickly moving around in the system."
|classes sel box theClassName|
classes := OrderedCollection new.
aSelectorString knownAsSymbol ifTrue:[
sel := aSelectorString asSymbol.
Smalltalk allClassesDo:[:aClass |
(aClass includesSelector:sel) ifTrue:[
classes add:aClass.
].
(aClass class includesSelector:sel) ifTrue:[
classes add:aClass class.
].
]
].
classes size == 0 ifTrue:[
SystemBrowser showNoneFound.
^ self
].
classes size > 1 ifTrue:[
box := ListSelectionBox
title:(resources string:'#%1\\in which class ?' with:aSelectorString) withCRs.
box label:'find method'.
box okText:(resources string:'show').
box list:(classes collect:[:aClass | aClass name]) asSortedCollection.
box action:[:aString | theClassName := aString].
box entryCompletionBlock:[:contents |
|s l what m|
s := contents withoutSpaces.
l := classes select:[:cls | cls name startsWith:s].
l size > 0 ifTrue:[
box list:(l collect:[:aClass | aClass name]) asSortedCollection.
box contents:l first name.
l size ~~ 1 ifTrue:[
self beep
]
]
].
box showAtPointer.
] ifFalse:[
theClassName := classes first name
].
theClassName notNil ifTrue:[
self switchToClassNamed:theClassName.
self updateMethodCategoryList.
self switchToMethodNamed:aSelectorString.
].
"Modified: 1.9.1995 / 01:39:58 / claus"
"Modified: 15.1.1997 / 23:20:51 / cg"
!
updateClassCategoryList
self updateClassCategoryListWithScroll:true.
"Modified: 8.1.1997 / 10:58:06 / cg"
!
updateClassCategoryListWithScroll:scroll
|oldClassCategory oldClass oldMethodCategory oldMethod
oldSelector newCategoryList|
classMethodListView notNil ifTrue:[ ^ self ].
oldClassCategory := currentClassCategory.
oldClass := currentClass.
oldMethodCategory := currentMethodCategory.
oldMethod := currentMethod.
oldMethod notNil ifTrue:[
oldSelector := currentSelector
].
classCategoryListView notNil ifTrue:[
newCategoryList := self listOfAllClassCategories.
newCategoryList = classCategoryListView list ifFalse:[
scroll ifTrue:[
classCategoryListView contents:newCategoryList
] ifFalse:[
classCategoryListView setContents:newCategoryList
]
]
].
oldClassCategory notNil ifTrue:[
classCategoryListView notNil ifTrue:[
classCategoryListView setSelectElement:oldClassCategory
]
].
classListView notNil ifTrue:[
oldClass notNil ifTrue:[
classListView setSelectElement:(oldClass name)
]
].
oldMethodCategory notNil ifTrue:[
methodCategoryListView notNil ifTrue:[
methodCategoryListView setSelectElement:oldMethodCategory
].
].
oldSelector notNil ifTrue:[
methodListView notNil ifTrue:[
methodListView setSelectElement:oldSelector
].
]
"Modified: 26.5.1996 / 15:04:25 / cg"
! !
!BrowserView methodsFor:'class list menu'!
classClassInstVars
"show class instance variables in codeView and setup accept-action
for a class-instvar-definition change"
self doClassMenu:[:currentClass |
|s|
s := WriteStream on:(String new).
currentClass fileOutClassInstVarDefinitionOn:s.
codeView contents:(s contents).
codeView modified:false.
codeView acceptAction:[:theCode |
codeView cursor:Cursor execute.
Object abortSignal catch:[
Class nameSpaceQuerySignal answer:Smalltalk
do:[
Compiler evaluate:theCode asString notifying:codeView compile:false.
].
codeView modified:false.
self normalLabel.
self updateClassList.
].
codeView cursor:Cursor normal.
].
codeView explainAction:nil.
methodListView notNil ifTrue:[
methodListView setSelection:nil
].
aspect := #classInstVars.
self normalLabel
]
"Modified: 16.1.1997 / 01:47:37 / cg"
!
classComment
"show the classes comment in the codeView.
Also, set accept action to change the comment."
self classShowFrom:#comment
set:#comment:
aspect:#comment
default:nil
!
classDefinition
"show class definition in codeView and setup accept-action for
a class-definition change.
Extract documentation either from a documentation method or
from the comment - not a biggy, but beginners will like
it when exploring the system."
self doClassMenu:[:currentClass |
|m s aStream isComment|
aStream := WriteStream on:(String new:200).
"/
"/ here, show it with a nameSpace pragma
"/ and prefer short names.
"/
currentClass
basicFileOutDefinitionOn:aStream
withNameSpace:true.
currentClass isLoaded ifTrue:[
"
add documentation as a comment, if there is any
"
m := currentClass class compiledMethodAt:#documentation.
m notNil ifTrue:[
s := m comment.
isComment := false.
] ifFalse:[
"try comment"
s := currentClass comment.
s notNil ifTrue:[
s isEmpty ifTrue:[
s := nil
] ifFalse:[
(s includes:$") ifTrue:[
s := s copy replaceAll:$" by:$'.
].
isComment := true
]
]
].
].
aStream cr; cr; cr; cr; cr.
s isNil ifTrue:[
aStream nextPut:$" ; cr; nextPutLine:' no comment or documentation found'.
] ifFalse:[
aStream nextPut:$" ; cr; nextPutLine:' Documentation:'.
aStream cr; nextPutLine:s; cr.
aStream nextPutLine:' Notice: '.
aStream nextPutAll:' the above string has been extracted from the classes '.
aStream nextPutLine:(isComment ifTrue:['comment.'] ifFalse:['documentation method.']).
aStream nextPutLine:' It will not be preserved when accepting a new class definition.'.
].
aStream nextPut:$".
codeView contents:(aStream contents).
codeView modified:false.
codeView acceptAction:[:theCode |
|ns|
currentClass notNil ifTrue:[
ns := currentClass nameSpace
] ifFalse:[
ns := nil
].
codeView cursor:Cursor execute.
Class nameSpaceQuerySignal handle:[:ex |
ns isNil ifTrue:[
ex reject
].
ex proceedWith:ns
] do:[
Object abortSignal catch:[
Class nameSpaceQuerySignal answer:Smalltalk
do:[
(Compiler evaluate:theCode asString notifying:codeView compile:false)
isBehavior ifTrue:[
codeView modified:false.
self classCategoryUpdate.
self updateClassListWithScroll:false.
]
]
].
].
codeView cursor:Cursor normal.
].
codeView explainAction:nil.
methodListView notNil ifTrue:[
methodListView setSelection:nil
].
aspect := #definition.
self normalLabel
]
"Modified: 16.1.1997 / 01:46:32 / cg"
!
classDocumentation
"show classes documentation (i.e. open doc-View on it)"
self doClassMenu:[:currentClass |
|v|
Autoload autoloadFailedSignal handle:[:ex |
self warn:'autoload failed.
Check your source directory and/or
the abbreviation file for the classes (correct) shortened name.'.
ex return.
] do:[
v := HTMLDocumentView
openFullOnText:(HTMLDocGenerator htmlDocOf:currentClass)
inDirectory:(Smalltalk getSystemFileName:'doc/online/english').
v nameSpaceForExecution:(currentClass nameSpace).
]
]
"Created: 18.5.1996 / 12:12:20 / cg"
"Modified: 3.1.1997 / 11:54:07 / cg"
!
classFileOut
"fileOut the current class.
Catch errors (sure, you like to know if it failed) and
warn if any)"
self doClassMenu:[:currentClass |
|msg|
currentClass isPrivate ifTrue:[
self warn:'You must fileOut the owning class: ' , currentClass owningClass name
] ifFalse:[
self busyLabel:'saving %1' with:currentClass name.
Class fileOutErrorSignal handle:[:ex |
self warn:'cannot fileOut: %1\(%2)' with:currentClass name with:ex errorString.
ex return.
] do:[
currentClass fileOut.
].
].
self normalLabel.
]
"Modified: 14.10.1996 / 20:12:24 / cg"
!
classFileOutBinary
"fileOut the current class as binary bytecode."
|mode|
mode := Dialog choose:(resources string:'save including sources ?')
labels:(resources array:#('cancel' 'discard' 'by file reference' 'include source'))
values:#(nil #discard #reference #keep)
default:#keep.
mode isNil ifTrue:[^ self]. "/ cancelled
self doClassMenu:[:currentClass |
|msg|
currentClass isPrivate ifTrue:[
self warn:'You must fileOut the owning class: ' , currentClass owningClass name
] ifFalse:[
self busyLabel:'saving binary of %1' with:currentClass name.
Class fileOutErrorSignal handle:[:ex |
self warn:'cannot create: %1\(%2)' with:ex parameter with:ex errorString.
ex return.
] do:[
currentClass binaryFileOutWithSourceMode:mode.
].
].
self normalLabel.
]
"Created: 24.1.1996 / 21:11:03 / cg"
"Modified: 14.10.1996 / 20:12:46 / cg"
!
classHierarchy
"show current classes hierarchy in codeView"
self doClassMenu:[:currentClass |
|aStream|
aStream := WriteStream on:(String new:200).
actualClass printHierarchyOn:aStream.
codeView contents:(aStream contents).
codeView modified:false.
codeView acceptAction:nil.
codeView explainAction:nil.
methodListView notNil ifTrue:[
methodListView setSelection:nil
].
aspect := #hierarchy.
self normalLabel
]
"Modified: 25.5.1996 / 13:02:37 / cg"
!
classInspect
"inspect the current class"
self checkClassSelected ifFalse:[^ self].
currentClass inspect.
!
classInstancesInspect
"inspect the current classes instances"
self checkClassSelected ifFalse:[^ self].
currentClass allInstances inspect.
"Created: 24.2.1996 / 16:12:14 / cg"
!
classLoad
"load an autoloaded class"
|nm nameShown|
self checkClassSelected ifFalse:[^ self].
nm := currentClass name.
nameShown := self displayedClassNameOf:currentClass.
Autoload autoloadFailedSignal handle:[:ex |
self warn:(resources string:'autoload of %1 failed.
Check your source directory for a file named %1.st and/or
the abbreviation file for its (correct) shortened name.') with:nm.
ex return.
] do:[
self withWaitCursorDo:[
lockUpdates := true.
[
currentClass autoload.
] valueNowOrOnUnwindDo:[
lockUpdates := false
].
currentClass := actualClass := nil.
"/ reselect the current class
showInstance ifFalse:[
nameShown := nameShown , ' class'
].
self switchToClassNamed:nameShown
]
]
"Modified: 23.1.1997 / 19:34:21 / cg"
!
classMenu
"sent by classListView to ask for the menu"
<resource: #keyboard ( #Cmdl #Cmdn #Cmdd) >
|specialMenu labels selectors shorties m newClassMenu spawnMenu idx|
currentClass isNil ifTrue:[
labels := #(
'fileIn new from repository ...'
).
selectors := #(
classLoadNewRevision
).
] ifFalse:[
labels := #(
'fileOut binary'
'-'
'inspect class'
'inspect instances'
'-'
'primitive definitions'
'primitive variables'
'primitive functions'
'-'
'source container ...'
'remove source container ...'
'-'
'revision log'
'compare with repository ...'
'-'
'check into source repository'
'fileIn from repository ...'
).
selectors := #(
classFileOutBinary
nil
classInspect
classInstancesInspect
nil
classPrimitiveDefinitions
classPrimitiveVariables
classPrimitiveFunctions
nil
classModifyContainer
classRemoveContainer
nil
classRevisionInfo
classCompareWithRepository
nil
classCheckin
classLoadRevision
).
].
specialMenu := PopUpMenu
labels:(resources array:labels)
selectors:selectors
receiver:self.
currentClass notNil ifTrue:[
currentClass sourceCodeManager isNil ifTrue:[
specialMenu disableAll:#(classModifyContainer classRemoveContainer
classRevisionInfo
classLoadRevision classCheckin
classCompareWithRepository).
].
currentClass isPrivate ifTrue:[
specialMenu disableAll:#(
classFileOutBinary
classModifyContainer
classRemoveContainer
classRevisionInfo
classLoadRevision classCheckin
classCompareWithRepository
classPrimitiveDefinitions
classPrimitiveVariables
classPrimitiveFunctions).
]
] ifFalse:[
SourceCodeManager isNil ifTrue:[
specialMenu disableAll:#(classLoadNewRevision)
]
].
(currentClass notNil
and:[currentClass isLoaded not]) ifTrue:[
specialMenu disableAll:#(
classInstancesInspect
classFileOutBinary
classModifyContainer
classRemoveContainer
classRevisionInfo
classLoadRevision
classCheckin
classCompareWithRepository
classPrimitiveDefinitions
classPrimitiveVariables
classPrimitiveFunctions).
].
device ctrlDown ifTrue:[
^ specialMenu
].
currentClass isNil ifTrue:[
labels := #(
'new class'
).
selectors := #(
classNewClass
).
] ifFalse:[
currentClass isLoaded ifFalse:[
labels := #(
'documentation'
'-'
'class refs'
'-'
'new class'
'-'
'load'
).
selectors := #(
classDocumentation
nil
classRefs
nil
classNewClass
nil
classLoad
).
] ifTrue:[
fullProtocol ifTrue:[
labels := #(
'hierarchy'
'definition'
'documentation'
'comment'
'class instvars'
).
selectors := #(
classHierarchy
classDefinition
classDocumentation
classComment
classClassInstVars
).
] ifFalse:[
labels := #(
'fileOut'
'printOut'
'printOut protocol'
" 'printOut full protocol' "
'-'
'spawn ...'
'-'
).
selectors := #(
classFileOut
classPrintOut
classPrintOutProtocol
" classPrintOutFullProtocol "
nil
spawnMenu
nil
).
spawnMenu := PopUpMenu
labels:(resources array:#('class' 'full protocol' 'hierarchy' 'subclasses'))
selectors:#(classSpawn classSpawnFullProtocol classSpawnHierarchy classSpawnSubclasses).
fullClass ifFalse:[
labels := labels , #(
'hierarchy'
'definition'
'documentation'
'comment'
'class instvars'
"/ 'protocols'
'-'
).
selectors := selectors , #(
classHierarchy
classDefinition
classDocumentation
classComment
classClassInstVars
"/ classProtocols
nil
).
].
labels := labels , #(
'class refs'
'-'
'new ...'
).
selectors := selectors , #(
classRefs
nil
newClassMenu
).
newClassMenu := PopUpMenu
labels:(resources array:#('class' 'subclass' 'private class'))
selectors:#(classNewClass classNewSubclass classNewPrivateClass).
labels := labels , #(
'rename ...'
'remove'
).
selectors := selectors , #(
classRename
classRemove
).
currentClass wasAutoloaded ifTrue:[
labels := labels , #(
'unload'
).
selectors := selectors , #(
classUnload
).
]
]
].
].
shorties := (Array new:labels size) , #(nil #'Ctrl').
(idx := selectors identityIndexOf:#classNewClass) ~~ 0 ifTrue:[
shorties at:idx put:#Cmdn
].
(idx := selectors identityIndexOf:#classLoad) ~~ 0 ifTrue:[
shorties at:idx put:#Cmdl
].
(idx := selectors identityIndexOf:#classDocumentation) ~~ 0 ifTrue:[
shorties at:idx put:#Cmdd
].
labels := labels , #(
'='
'others'
).
selectors := selectors , #(
nil
otherMenu
).
m := PopUpMenu
labels:(resources array:labels)
selectors:selectors
accelerators:shorties.
newClassMenu notNil ifTrue:[
m subMenuAt:#newClassMenu put:newClassMenu.
].
spawnMenu notNil ifTrue:[
m subMenuAt:#spawnMenu put:spawnMenu.
].
(currentClass notNil
and:[currentClass isPrivate]) ifTrue:[
m disableAll:#(
classFileOut
)
].
m subMenuAt:#otherMenu put:specialMenu.
^ m
"Modified: 11.1.1997 / 21:40:41 / cg"
!
classNewClass
"create a class-definition prototype in codeview"
|theClass cls|
theClass := Object.
currentClass notNil ifTrue:[
(cls := currentClass superclass) notNil ifTrue:[
theClass := cls
]
].
self
classClassDefinitionTemplateFor:theClass
in:currentClassCategory
namespace:false
private:false.
aspect := nil.
"Modified: 4.1.1997 / 14:52:16 / cg"
!
classNewPrivateClass
"create a class-definition prototype in codeview"
self
classClassDefinitionTemplateFor:Object
in:nil
namespace:false
private:true.
aspect := nil.
"Created: 11.10.1996 / 16:01:20 / cg"
"Modified: 4.1.1997 / 14:51:49 / cg"
!
classNewSubclass
"create a subclass-definition prototype in codeview"
self doClassMenu:[:currentClass |
self classClassDefinitionTemplateFor:currentClass
in:(currentClass category)
namespace:false
private:false.
aspect := nil
]
"Modified: 4.1.1997 / 14:51:44 / cg"
!
classPrimitiveDefinitions
"show the classes primitiveDefinition in the codeView.
Also, set accept action to change it."
self classShowFrom:#primitiveDefinitionsString
set:#primitiveDefinitions:
aspect:#primitiveDefinitions
default:'%{
/*
* includes, defines, structure definitions
* and typedefs come here.
*/
%}'
!
classPrimitiveFunctions
"show the classes primitiveFunctions in the codeView.
Also, set accept action to change it."
self classShowFrom:#primitiveFunctionsString
set:#primitiveFunctions:
aspect:#primitiveFunctions
default:'%{
/*
* any local C (helper) functions
* come here (please, define as static)
*/
%}'
!
classPrimitiveVariables
"show the classes primitiveVariables in the codeView.
Also, set accept action to change it."
self classShowFrom:#primitiveVariablesString
set:#primitiveVariables:
aspect:#primitiveVariables
default:'%{
/*
* any local C variables
* come here (please, define as static)
*/
%}'
!
classPrintOut
self classPrintOutWith:#printOutOn:
!
classPrintOutFullProtocol
self classPrintOutWith:#printOutFullProtocolOn:
!
classPrintOutProtocol
self classPrintOutWith:#printOutProtocolOn:
!
classPrintOutWith:aSelector
self doClassMenu:[:currentClass |
|printStream|
printStream := Printer new.
currentClass perform:aSelector with:printStream.
printStream close
]
!
classProtocols
^ self
!
classRefs
self doClassMenu:[:currentClass |
self withSearchCursorDo:[
SystemBrowser browseReferendsOf:currentClass name asSymbol
]
]
"Created: 23.11.1995 / 14:11:43 / cg"
!
classRemove
"user requested remove of current class and all subclasses -
count subclasses and let user confirm removal."
|count t box|
currentClass notNil ifTrue:[
count := currentClass allSubclasses size.
t := 'remove %1'.
count ~~ 0 ifTrue:[
t := t , '\(with %2 subclass'.
count ~~ 1 ifTrue:[
t := t , 'es'
].
t := (t , ')')
].
t := t , ' ?'.
t := (resources string:t with:currentClass name with:count) withCRs.
box := YesNoBox
title:t
yesText:(resources at:'remove')
noText:(resources at:'abort').
box label:(resources string:'remove class').
box confirm ifTrue:[
"after querying user - do really remove current class
and all subclasses
"
self doClassMenu:[:currentClass |
|didRemove|
didRemove := false.
"
query ?
"
currentClass allSubclassesDo:[:aSubClass |
(CheckForInstancesWhenRemovingClasses not
or:[aSubClass hasInstances not
or:[self confirm:(resources string:'''%1'' has instances - remove anyway ?' with:aSubClass name)]])
ifTrue:[
Smalltalk removeClass:aSubClass
]
].
(CheckForInstancesWhenRemovingClasses not
or:[currentClass hasInstances not
or:[self confirm:(resources string:'''%1'' has instances - remove anyway ?' with:currentClass name)]])
ifTrue:[
didRemove := true.
Smalltalk removeClass:currentClass.
].
didRemove ifTrue:[
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
]
]
].
box destroy.
]
"Modified: 15.1.1997 / 23:54:33 / cg"
!
classRename
"launch an enterBox for new name and query user"
|box|
self checkClassSelected ifFalse:[^ self].
box := self
enterBoxTitle:(resources string:'rename %1 to:' with:currentClass name)
okText:'rename'
label:'rename class'.
box initialText:(currentClass name).
box action:[:aString | self renameCurrentClassTo:aString].
box showAtPointer
"Modified: 15.1.1997 / 23:10:15 / cg"
!
classShowFrom:getSelector set:setSelector aspect:aspectSymbol default:default
"common helper for comment, primitive-stuff etc.
show the string returned from the classes getSelector-method,
Set acceptaction to change it via setSelector."
self doClassMenu:[:currentClass |
|text|
text := currentClass perform:getSelector.
text isNil ifTrue:[
text := default
].
codeView contents:text.
codeView modified:false.
codeView acceptAction:[:theCode |
Object abortSignal catch:[
lockUpdates := true.
currentClass perform:setSelector with:theCode asString.
codeView modified:false.
].
lockUpdates := false.
].
codeView explainAction:nil.
methodListView notNil ifTrue:[
methodListView setSelection:nil
].
aspect := aspectSymbol.
self normalLabel
]
"Modified: 25.5.1996 / 13:02:40 / cg"
!
classSpawn
"create a new SystemBrowser browsing current class,
or if there is a selection, spawn a browser on the selected class
even a class/selector pair can be specified."
self doClassMenuWithSelection:[:cls :sel |
|browser|
cls isMeta ifTrue:[
self listOfNamespaces do:[:aNamespace |
aNamespace allBehaviorsDo:[:aClass |
aClass class == cls ifTrue:[
browser := SystemBrowser browseClass:aClass.
browser instanceProtocol:false.
sel notNil ifTrue:[
browser switchToMethodNamed:sel
].
^ self
].
].
].
self warn:'oops, no class for this metaclass'.
^ self
].
browser := SystemBrowser browseClass:cls.
cls hasMethods ifFalse:[
browser instanceProtocol:false.
].
sel notNil ifTrue:[
browser switchToMethodNamed:sel
].
]
"
select 'Smalltalk allClassesDo:' and use spawn from the class menu
select 'Smalltalk' and use spawn from the class menu
"
"Modified: 20.12.1996 / 15:41:16 / cg"
!
classSpawnFullProtocol
"create a new browser, browsing current classes full protocol"
self doClassMenuWithSelection:[:cls :sel |
SystemBrowser browseFullClassProtocol:cls
]
!
classSpawnHierarchy
"create a new HierarchyBrowser browsing current class"
self doClassMenuWithSelection:[:cls :sel |
SystemBrowser browseClassHierarchy:cls
]
!
classSpawnSubclasses
"create a new browser browsing current class's subclasses"
self doClassMenuWithSelection:[:cls :sel |
|subs|
subs := OrderedCollection new.
self classHierarchyOf:cls withAutoloaded:false do:[:aClass :lvl |
subs add:(String new:lvl*2) , aClass name
].
"/ subs := cls allSubclasses.
(subs notNil and:[subs size ~~ 0]) ifTrue:[
SystemBrowser browseClasses:subs
title:('subclasses of ' , cls name)
sort:false
]
]
"Modified: 4.1.1997 / 13:35:55 / cg"
!
classUnload
"unload an autoloaded class"
|nm|
self checkClassSelected ifFalse:[^ self].
nm := currentClass name.
currentClass unload.
self switchToClassNamed:nm
!
classUses
"a powerful tool, when trying to learn more about where
a class is used. This one searches all uses of a class,
and shows a list of uses - try it and like it"
self doClassMenu:[:currentClass |
self withSearchCursorDo:[
SystemBrowser browseUsesOf:currentClass
]
]
"Created: 23.11.1995 / 14:11:47 / cg"
!
doClassMenuWithSelection:aBlock
"a helper - if there is a selection, which represents a classes name,
evaluate aBlock, passing that class and optional selector as arguments.
Otherwise, check if a class is selected and evaluate aBlock with the
current class."
|string words clsName cls sel isMeta|
string := codeView selection.
string notNil ifTrue:[
self extractClassAndSelectorFromSelectionInto:[:c :s :m |
clsName := c.
sel := s.
isMeta := m.
].
clsName isNil ifTrue:[
string := string asString withoutSeparators.
words := string asCollectionOfWords.
words notNil ifTrue:[
clsName := words first.
(clsName endsWith:' class') ifTrue:[
isMeta := true.
clsName := clsName copyWithoutLast:6 "copyTo:(clsName size - 5)"
] ifFalse:[
isMeta := false
].
sel := Parser selectorInExpression:string.
]
].
clsName notNil ifTrue:[
(cls := Smalltalk classNamed:clsName) notNil ifTrue:[
isMeta ifTrue:[
cls := cls class
].
self withWaitCursorDo:[
aBlock value:cls value:sel.
].
^ self
] ifFalse:[
self warn:'no class named: %1 - spawning current' with:clsName
]
].
].
classMethodListView notNil ifTrue:[
sel := classMethodListView selectionValue string.
sel notNil ifTrue:[
sel := self selectorFromClassMethodString:sel
]
].
self doClassMenu:[:currentClass | aBlock value:currentClass value:sel]
"Modified: 17.6.1996 / 16:51:49 / stefan"
"Modified: 22.10.1996 / 17:02:11 / cg"
! !
!BrowserView methodsFor:'class list source administration'!
classCheckin
"check a class into the source repository"
currentClass isLoaded ifFalse:[
self warn:'cannot checkin unloaded classes.'.
^ self.
].
self doClassMenu:[:currentClass |
self classCheckin:currentClass withLog:nil
].
"Created: 23.11.1995 / 11:41:38 / cg"
"Modified: 15.4.1996 / 17:07:07 / cg"
!
classCheckin:aClass withLog:aLogMessage
"check a class into the source repository"
|logMessage info mgr|
aClass isLoaded ifFalse:[
self information:'cannot checkin unloaded classes (' , aClass name , ').'.
^ self.
].
aLogMessage isNil ifTrue:[
logMessage := self getLogMessageFor:aClass name.
logMessage isNil ifTrue:[^ self].
] ifFalse:[
logMessage := aLogMessage
].
mgr := (aClass sourceCodeManager).
info := mgr sourceInfoOfClass:aClass.
(info isNil
or:[(info at:#fileName ifAbsent:nil) isNil
or:[(info at:#module ifAbsent:nil) isNil
or:[(info at:#directory ifAbsent:nil) isNil]]]) ifTrue:[
(self classCreateSourceContainerFor:aClass) ifFalse:[^ self].
^ self.
].
lastSourceLogMessage := logMessage.
self busyLabel:'checking in %1' with:aClass name.
Processor activeProcess withLowerPriorityDo:[
(mgr checkinClass:aClass logMessage:logMessage) ifFalse:[
self warn:'checkin failed'.
].
aspect == #revisionInfo ifTrue:[
self classListUpdate
].
].
self normalLabel.
"Created: 15.4.1996 / 17:06:39 / cg"
"Modified: 15.6.1996 / 00:22:49 / stefan"
"Modified: 21.12.1996 / 19:01:06 / cg"
!
classCompareWithRepository
"open a diff-textView comparing the current (in-image) version
with the some version found in the repository."
currentClass isLoaded ifFalse:[
self warn:'cannot compare unloaded classes.'.
^ self.
].
self doClassMenu:[:currentClass |
|aStream comparedSource currentSource v rev revString thisRevString mgr
nm msg|
nm := currentClass name.
rev := currentClass binaryRevision.
mgr := currentClass sourceCodeManager.
msg := resources string:'compare to revision: (empty for newest)'.
rev notNil ifTrue:[
msg := msg , '\\' , (resources string:'(%1 is based upon rev %2)'
with:nm with:rev)
].
rev := Dialog request:msg withCRs onCancel:nil.
rev notNil ifTrue:[
rev withoutSpaces isEmpty ifTrue:[
msg := 'extracting newest %1'.
aStream := mgr getMostRecentSourceStreamForClassNamed:nm.
revString := '(newest)'.
] ifFalse:[
msg := 'extracting previous %1'.
aStream := mgr getSourceStreamFor:currentClass revision:rev.
revString := rev
].
self busyLabel:msg with:nm.
aStream isNil ifTrue:[
self warn:'could not extract source from repository'.
^ self
].
comparedSource := aStream contents asString.
aStream close.
self busyLabel:'generating current source ...' with:nil.
aStream := '' writeStream.
Method flushSourceStreamCache.
currentClass fileOutOn:aStream withTimeStamp:false.
currentSource := aStream contents asString.
aStream close.
self busyLabel:'comparing ...' with:nil.
comparedSource = currentSource ifTrue:[
self information:'versions are identical'.
] ifFalse:[
thisRevString := currentClass revision.
thisRevString isNil ifTrue:[
thisRevString := 'no revision'
].
revString = '(newest)' ifTrue:[
(rev := mgr newestRevisionOf:currentClass) notNil ifTrue:[
revString := '(newest is' , rev , ')'
]
].
v := DiffTextView
openOn:currentSource label:'current: (based on: ' , thisRevString , ')'
and:comparedSource label:'repository: ' , revString.
v label:'comparing ' , nm.
].
self normalLabel.
]
]
"Created: 4.1.1997 / 15:48:20 / cg"
"Modified: 28.2.1997 / 11:44:15 / cg"
!
classCreateSourceContainerFor:aClass
"let user specify the source-repository values for aClass"
^ self
classDefineSourceContainerFor:aClass
title:(resources string:'Repository information for %1' with:aClass name)
text:(resources string:'CREATE_REPOSITORY' with:aClass name)
createDirectories:true
createContainer:true.
"Modified: 15.4.1996 / 17:07:57 / cg"
!
classDefineSourceContainerFor:aClass title:title text:boxText createDirectories:createDirs createContainer:createContainer
"let user specify the source-repository values for aClass"
|box className
moduleHolder packageHolder fileNameHolder
oldModule oldPackage oldFileName
module package fileName
y component info project nm mgr creatingNew msg|
aClass isLoaded ifFalse:[
self warn:'please load the class first'.
^ false.
].
className := aClass name.
"/
"/ defaults, if nothing at all is known
"/
(module := lastModule) isNil ifTrue:[
module := (OperatingSystem getLoginName).
].
(package := lastPackage) isNil ifTrue:[
package := 'private'.
].
"/
"/ try to extract some useful defaults from the current project
"/
(Project notNil and:[(project := Project current) notNil]) ifTrue:[
package isNil ifTrue:[
(nm := project repositoryDirectory) isNil ifTrue:[
nm := project name
].
package := nm.
].
module isNil ifTrue:[
(nm := project repositoryModule) notNil ifTrue:[
module := nm
]
].
].
"/
"/ ask the sourceCodeManager if it knows anything about that class
"/ if so, take that as a default.
"/
info := (mgr := aClass sourceCodeManager) sourceInfoOfClass:aClass.
info notNil ifTrue:[
(info includesKey:#module) ifTrue:[
module := (info at:#module).
].
(info includesKey:#directory) ifTrue:[
package := (info at:#directory).
].
fileName := mgr containerFromSourceInfo:info.
"/ (info includesKey:#fileName) ifTrue:[
"/ fileName := (info at:#fileName).
"/ ] ifFalse:[
"/ (info includesKey:#expectedFileName) ifTrue:[
"/ fileName := (info at:#expectedFileName).
"/ ] ifFalse:[
"/ (info includesKey:#classFileNameBase) ifTrue:[
"/ fileName := (info at:#classFileNameBase) , '.st'.
"/ ]
"/ ]
"/ ]
].
fileName isNil ifTrue:[
fileName := (Smalltalk fileNameForClass:aClass) , '.st'.
].
fileNameHolder := fileName asValue.
moduleHolder := module asValue.
packageHolder := package asValue.
"/
"/ should check for conflicts (i.e. if such a container already exists) ...
"/
(mgr checkForExistingContainerInModule:module
package:package
container:fileName) ifTrue:[
"/ for now - this needs more work.
"/ self information:(resources
"/ string:'%1 is already contained in the container:
"/
"/ %2 / %3 / %4'
"/ with:className
"/ with:module
"/ with:package
"/ with:fileName).
"/ ^ false.
"/
(Dialog confirm:(resources
string:'Notice: there already is a container for %1 in:
%2 / %3 / %4
To change it, press continue.'
with:className
with:module
with:package
with:fileName)
yesLabel:(resources string:'continue')
noLabel:(resources string:'cancel'))
ifFalse:[
^ false
].
oldModule := module.
oldPackage := package.
oldFileName := fileName
].
"/
"/ open a dialog for this
"/
box := DialogBox new.
box label:title.
component := box addTextLabel:boxText withCRs.
component adjust:#left; borderWidth:0.
box addVerticalSpace.
box addVerticalSpace.
y := box yPosition.
component := box addTextLabel:(resources string:'Module:').
component width:0.4; adjust:#right.
box yPosition:y.
component := box addInputFieldOn:moduleHolder tabable:true.
component width:0.6; left:0.4; immediateAccept:true; acceptOnLeave:false; cursorMovementWhenUpdating:#beginOfLine.
box addVerticalSpace.
y := box yPosition.
component := box addTextLabel:'Package:'.
component width:0.4; adjust:#right.
box yPosition:y.
component := box addInputFieldOn:packageHolder tabable:true.
component width:0.6; left:0.4; immediateAccept:true; acceptOnLeave:false; cursorMovementWhenUpdating:#beginOfLine.
box addVerticalSpace.
y := box yPosition.
component := box addTextLabel:'Filename:'.
component width:0.4; adjust:#right.
box yPosition:y.
component := box addInputFieldOn:fileNameHolder tabable:true.
component width:0.6; left:0.4; immediateAccept:true; acceptOnLeave:false; cursorMovementWhenUpdating:#beginOfLine.
box addVerticalSpace.
(mgr checkForExistingContainerInModule:module
package:package
container:fileName) ifFalse:[
component := box addTextLabel:'Notice: class seems to have no container yet.'.
component adjust:#left; borderWidth:0.
creatingNew := true.
] ifTrue:[
creatingNew := false.
].
box addVerticalSpace.
box addAbortButton; addOkButton.
box showAtPointer.
box accepted ifTrue:[
module := moduleHolder value withoutSpaces.
package := packageHolder value withoutSpaces.
fileName := fileNameHolder value withoutSpaces.
(fileName endsWith:',v') ifTrue:[
fileName := fileName copyWithoutLast:2
].
(fileName endsWith:'.st') ifFalse:[
fileName := fileName , '.st'
].
info := aClass revisionInfo.
info notNil ifTrue:[
(info includesKey:#repositoryPathName) ifFalse:[
info := nil
]
].
info isNil ifTrue:[
creatingNew ifFalse:[
(self confirm:(resources string:'The repository already contains a container named "%3" in "%1/%2" !!\\Checkin %4 anyway ? (DANGER - be careful)'
withArgs:(Array with:module with:package with:fileName with:className)) withCRs)
ifFalse:[
^ false
].
].
(self confirm:(resources string:'%1 does not have any (usable) revision info (#version method)\\Shall I create one ?' with:className) withCRs)
ifFalse:[
^ false
].
aClass updateVersionMethodFor:(mgr initialRevisionStringFor:aClass
inModule:module
package:package
container:fileName).
].
"/
"/ check for the module
"/
(mgr checkForExistingModule:module) ifFalse:[
(createDirs or:[creatingNew]) ifFalse:[
self warn:(resources string:'a module named %1 does not exist in the source code management' with:module).
^ false
].
(self confirm:(resources string:'%1 is a new module.\\create it ?' with:module) withCRs) ifFalse:[
^ false.
].
(mgr createModule:module) ifFalse:[
self warn:(resources string:'cannot create new module: %1' with:module).
^ false.
]
].
lastModule := module.
"/
"/ check for the package
"/
(mgr checkForExistingModule:module package:package) ifFalse:[
(createDirs or:[creatingNew]) ifFalse:[
self warn:(resources string:'a package named %1 does not exist module %2' with:module with:package).
^ false
].
(self confirm:(resources string:'%1 is a new package (in module %2).\\create it ?' with:package with:module) withCRs) ifFalse:[
^ false.
].
(mgr createModule:module package:package) ifFalse:[
self warn:(resources string:'cannot create new package: %1 (in module %2)' with:package with:module).
^ false.
]
].
lastPackage := package.
"/
"/ check for the container itself
"/
(mgr checkForExistingContainerInModule:module package:package container:fileName) ifTrue:[
creatingNew ifTrue:[
self warn:(resources string:'container for %1 already exists in %2/%3.' with:fileName with:module with:package) withCRs.
].
"/ (oldModule notNil
"/ and:[(oldModule ~= module)
"/ or:[oldPackage ~= package
"/ or:[oldFileName ~= fileName]]])
"/ ifFalse:[
"/ self warn:(resources string:'no change').
"/ ^ false.
"/ ].
(self confirm:(resources string:'check %1 into the existing container
%2 / %3 / %4 ?'
with:className
with:module
with:package
with:fileName) withCRs)
ifFalse:[
^ false.
].
aClass updateVersionMethodFor:'$' , 'Header' , '$'. "/ concatenated to avoid RCS-expansion
oldFileName notNil ifTrue:[
msg := ('forced checkin / source container change from ' , oldFileName).
] ifFalse:[
msg := 'defined source container'
].
(mgr
checkinClass:aClass
fileName:fileName
directory:package
module:module
logMessage:msg)
ifFalse:[
(self confirm:'no easy merge seems possible; force checkin (no merge) ?') ifFalse:[
self normalLabel.
^ false.
].
(mgr
checkinClass:aClass
fileName:fileName
directory:package
module:module
logMessage:msg
force:true)
ifFalse:[
self warn:(resources string:'failed to check into existing container.').
self normalLabel.
^ false.
].
].
self normalLabel.
^ true
] ifFalse:[
(createContainer or:[creatingNew]) ifFalse:[
(self confirm:(resources string:'no container exists for %1 in %2/%3\\create ?'
with:fileName with:module with:package) withCRs) ifFalse:[
^ false
]
]
].
(mgr
createContainerFor:aClass
inModule:module
package:package
container:fileName) ifFalse:[
self warn:(resources string:'failed to create container.').
self normalLabel.
^ false.
].
self normalLabel.
^ true
].
box destroy.
^ false
"Modified: 20.12.1996 / 13:18:42 / cg"
!
classLoadNewRevision
"let user specify a container and fileIn from there"
|box
moduleHolder packageHolder fileNameHolder
module package fileName aStream
y component mgr|
mgr := SourceCodeManager.
mgr isNil ifTrue:[^ false].
fileNameHolder := ValueHolder newString.
moduleHolder := (OperatingSystem getLoginName) asValue.
packageHolder := 'private' asValue.
"/
"/ open a dialog for the module/package/container
"/
box := DialogBox new.
box label:'container fileIn'.
component := box addTextLabel:(resources string:'container to fileIn') withCRs.
component adjust:#left; borderWidth:0.
box addVerticalSpace.
box addVerticalSpace.
y := box yPosition.
component := box addTextLabel:(resources string:'Module:').
component width:0.4; adjust:#right.
box yPosition:y.
component := box addInputFieldOn:moduleHolder tabable:true.
component width:0.6; left:0.4; immediateAccept:true; acceptOnLeave:false; cursorMovementWhenUpdating:#beginOfLine.
box addVerticalSpace.
y := box yPosition.
component := box addTextLabel:'Package:'.
component width:0.4; adjust:#right.
box yPosition:y.
component := box addInputFieldOn:packageHolder tabable:true.
component width:0.6; left:0.4; immediateAccept:true; acceptOnLeave:false; cursorMovementWhenUpdating:#beginOfLine.
box addVerticalSpace.
y := box yPosition.
component := box addTextLabel:'Filename:'.
component width:0.4; adjust:#right.
box yPosition:y.
component := box addInputFieldOn:fileNameHolder tabable:true.
component width:0.6; left:0.4; immediateAccept:true; acceptOnLeave:false; cursorMovementWhenUpdating:#beginOfLine.
box addVerticalSpace.
box addAbortButton; addOkButton.
box showAtPointer.
box destroy.
box accepted ifFalse:[
^ false
].
module := moduleHolder value withoutSpaces.
package := packageHolder value withoutSpaces.
fileName := fileNameHolder value withoutSpaces.
(fileName endsWith:',v') ifTrue:[
fileName := fileName copyWithoutLast:2
].
(fileName endsWith:'.st') ifFalse:[
fileName := fileName , '.st'
].
(mgr checkForExistingContainerInModule:module
package:package
container:fileName) ifFalse:[
self warn:'no such container'.
^ false
].
aStream := mgr
streamForClass:nil
fileName:fileName
revision:#newest
directory:package
module:module
cache:false.
aStream isNil ifTrue:[
self warn:'could not fileIn from repository'.
^ false.
].
self busyLabel:'loading from %1' with:(module , '/' , package , '/' , fileName).
Class withoutUpdatingChangesDo:[
[
aStream fileIn.
] valueNowOrOnUnwindDo:[
aStream close.
self normalLabel.
Smalltalk changed.
].
].
^ false
"Created: 13.9.1996 / 09:27:09 / cg"
"Modified: 16.1.1997 / 00:50:09 / cg"
!
classLoadRevision
"load a specific revision into the system - especially useful to
upgrade a class to the newest revision"
currentClass isLoaded ifFalse:[
self warn:'cannot load specific releases of autoloaded classes.'.
^ self.
].
self doClassMenu:[:currentClass |
|aStream comparedSource currentSource v rev revString what mgr keep className
newClass prevCategory ok|
rev := Dialog request:'load which revision: (empty for newest)' onCancel:nil.
rev notNil ifTrue:[
className := currentClass name.
(className includesString:'_rev_') ifTrue:[
self warn:'select the original class and try again.'.
^ self
].
mgr := currentClass sourceCodeManager.
ok := false.
rev withoutSpaces isEmpty ifTrue:[
what := className , '(newest)'.
self busyLabel:'extracting %1' with:what.
aStream := mgr getMostRecentSourceStreamForClassNamed:className.
revString := 'newest'.
keep := false.
] ifFalse:[
what := className , '(' , rev , ')'.
self busyLabel:'extracting %1' with:what.
aStream := mgr getSourceStreamFor:currentClass revision:rev.
revString := rev.
keep := true.
].
aStream isNil ifTrue:[
self warn:'cannot find classes source.'.
^ self.
].
self busyLabel:'loading %1' with:what .
[
Class withoutUpdatingChangesDo:[
|saveIt prevSkip|
saveIt := Dialog confirmWithCancel:'keep a save-copy of the existing class ?
(you have to care for subclasses if doing so)' default:false.
saveIt isNil ifTrue:[^ self].
saveIt ifTrue:[
"/ rename the current class - for backup
prevCategory := currentClass category.
currentClass category:'* obsolete *'.
Smalltalk renameClass:currentClass to:className , '_saved'.
].
prevSkip := ClassCategoryReader skipUnchangedMethods.
ClassCategoryReader skipUnchangedMethods:false.
[
aStream fileIn.
] valueNowOrOnUnwindDo:[
ClassCategoryReader skipUnchangedMethods:prevSkip
].
"/ did that work ?
newClass := Smalltalk at:className ifAbsent:nil.
newClass isNil ifTrue:[
saveIt ifTrue:[
self warn:'fileIn failed - undoing changes ...'.
Smalltalk renameClass:currentClass to:className.
currentClass category:prevCategory.
] ifFalse:[
self warn:'fileIn failed - cannot recover class'.
]
] ifFalse:[
"/
"/ if we loaded an old version, rename that one and fix the name of the
"/ current class
"/
keep ifTrue:[
saveIt ifTrue:[
Smalltalk renameClass:newClass to:(className , '_rev_' , rev).
newClass category:'* old versions *'.
Smalltalk renameClass:currentClass to:className.
currentClass category:prevCategory.
]
].
ok := true.
]
].
] valueNowOrOnUnwindDo:[
aStream close.
self normalLabel.
Smalltalk changed.
].
ok ifTrue:[
self switchToClassNamed:newClass name.
]
]
]
"Created: 14.11.1995 / 16:43:15 / cg"
"Modified: 14.2.1997 / 18:30:14 / cg"
!
classModifyContainer
"check a class into the source repository"
currentClass isLoaded ifFalse:[
self warn:'dont know anything about unloaded classes.'.
^ self.
].
self doClassMenu:[:currentClass |
self
classDefineSourceContainerFor:currentClass
title:(resources string:'Repository information for %1' with:currentClass name)
text:'defining/changing the source code container'
createDirectories:true createContainer:true.
]
"Created: 23.11.1995 / 11:41:38 / cg"
"Modified: 6.2.1996 / 16:58:58 / cg"
!
classRemoveContainer
"remove a container from the source repository"
currentClass isLoaded ifFalse:[
self warn:'please load the class first'.
^ self.
].
self doClassMenu:[:currentClass |
self
classRemoveSourceContainerFor:currentClass
]
"Created: 23.11.1995 / 11:41:38 / cg"
"Modified: 11.9.1996 / 12:55:42 / cg"
!
classRemoveSourceContainerFor:aClass
"show container & let user confirm twice."
|module package fileName info mgr|
aClass isLoaded ifFalse:[
self warn:'please load the class first'.
^ false.
].
"/
"/ ask the sourceCodeManager if it knows anything about that class
"/ if so, take that as a default.
"/
mgr := aClass sourceCodeManager.
mgr isNil ifTrue:[
self warn:'No sourceCodeManagement.'.
^ false
].
info := mgr sourceInfoOfClass:aClass.
info notNil ifTrue:[
(info includesKey:#module) ifTrue:[
module := (info at:#module).
].
(info includesKey:#directory) ifTrue:[
package := (info at:#directory).
].
fileName := mgr containerFromSourceInfo:info.
].
module isNil ifTrue:[
self warn:'classes module is unknown.\\It seems to not have a container.' withCRs.
^ false.
].
package isNil ifTrue:[
self warn:'classes package is unknown.\\It seems to not have a container.' withCRs.
^ false.
].
fileName isNil ifTrue:[
self warn:'classes container fileName is unknown.\\It seems to not have a container.' withCRs.
^ false.
].
(mgr checkForExistingContainerInModule:module
package:package
container:fileName) ifFalse:[
self warn:'Class has no source container.' withCRs.
^ false.
].
(Dialog
choose:(resources
string:'Please confirm removal of the container for %1:
container: %2 / %3 / %4
Really remove ?'
with:aClass name
with:module
with:package
with:fileName)
labels:(Array
with:(resources string:'no')
with:(resources string:'remove'))
values:#(false true)
default:false) ifFalse:[
^ self.
].
(mgr removeContainerFor:aClass
inModule:module
package:package
container:fileName) ifFalse:[
self warn:(resources string:'failed to remove container.').
self normalLabel.
^ true.
].
^ false
"Created: 11.9.1996 / 13:06:14 / cg"
"Modified: 13.9.1996 / 19:06:06 / cg"
!
classRevisionInfo
"show current classes revision info in codeView"
self doClassMenu:[:currentClass |
|aStream info info2 s rv mgr fn msg|
aStream := WriteStream on:(String new:200).
currentClass notNil ifTrue:[
Processor activeProcess withLowerPriorityDo:[
self busyLabel:'extracting revision info' with:nil.
info := currentClass revisionInfo.
rv := currentClass binaryRevision.
rv notNil ifTrue:[
aStream nextPutLine:'**** Loaded classes binary information ****'; cr.
aStream nextPutLine:' Binary based upon : ' , rv.
aStream cr.
].
info notNil ifTrue:[
(info includesKey:#revision) ifFalse:[
aStream nextPutLine:'WARNING:'; cr.
aStream nextPutLine:' The class seems not to be loaded from the repository.'.
aStream nextPutLine:' Check carefully before checking anything in.'.
aStream nextPutLine:' (i.e. compare with repository for renamed class(es), same-name but unrelated etc.)'.
aStream cr.
].
aStream nextPutLine:'**** Classes source information ****'; cr.
s := info at:#repositoryPath ifAbsent:nil.
s notNil ifTrue:[
aStream nextPutLine:' Source repository : ' , s
].
aStream nextPutLine:' Filename ........ : ' , (info at:#fileName ifAbsent:'?').
aStream nextPutLine:' Revision ........ : ' , (info at:#revision ifAbsent:'?').
aStream nextPutLine:' Checkin date .... : ' , (info at:#date ifAbsent:'?') , ' ' , (info at:#time ifAbsent:'?').
aStream nextPutLine:' Checkin user .... : ' , (info at:#user ifAbsent:'?').
(info2 := currentClass packageSourceCodeInfo) notNil ifTrue:[
aStream nextPutLine:' Repository: ..... : ' , (info2 at:#module ifAbsent:'?').
aStream nextPutLine:' Directory: ...... : ' , (info2 at:#directory ifAbsent:'?').
].
aStream nextPutLine:' Container ....... : ' , (info at:#repositoryPathName ifAbsent:'?').
aStream cr.
(mgr := currentClass sourceCodeManager) notNil ifTrue:[
aStream nextPutLine:'**** Repository information ****'; cr.
mgr writeRevisionLogOf:currentClass to:aStream.
]
] ifFalse:[
aStream nextPutLine:'No revision info found'.
currentClass isLoaded ifFalse:[
aStream cr; nextPutAll:'This is an autoloaded class - you may see more after its loaded.'
] ifTrue:[
fn := currentClass classFilename.
currentClass wasAutoloaded ifTrue:[
msg := 'This class was autoloaded.'.
fn notNil ifTrue:[
msg := msg , ' (from ''' , fn , ''')'.
].
] ifFalse:[
fn notNil ifTrue:[
msg := 'This class was loaded from ''' , fn , '''.'
].
].
msg notNil ifTrue:[
aStream cr; nextPutAll:msg.
]
]
]
]
].
codeView contents:(aStream contents).
codeView modified:false.
codeView acceptAction:nil.
codeView explainAction:nil.
methodListView notNil ifTrue:[
methodListView setSelection:nil
].
aspect := #revisionInfo.
self normalLabel
]
"Created: 14.11.1995 / 16:43:15 / cg"
"Modified: 11.11.1996 / 10:09:28 / cg"
!
getLogMessageFor:aString
"get a log message for when checking in a class.
Return the message or nil if aborted."
|dialog textView|
dialog := Dialog new.
(dialog addTextLabel:(resources string:'enter log message for: %1' with:aString)) adjust:#left.
textView := dialog addTextBoxOn:nil
class:EditTextView
withNumberOfLines:10
hScrollable:true
vScrollable:true.
dialog width:(textView preferredExtentForLines:10 cols:70) x.
textView contents:lastSourceLogMessage.
dialog addAbortButton; addOkButton.
dialog okButton isReturnButton:false.
dialog open.
dialog accepted ifTrue:[
^ textView contents
].
^ nil
"Created: 15.6.1996 / 00:20:46 / stefan"
"Modified: 28.2.1997 / 11:47:33 / cg"
! !
!BrowserView methodsFor:'class stuff'!
allClassesInCategory:aCategory
|classes|
currentNamespace = '* all *' ifTrue:[
^ Smalltalk allClassesInCategory:currentClassCategory
].
classes := Set new.
(self listOfNamespaces) do:[:aNamespace |
aNamespace allBehaviorsDo:[:aClass |
|actualNamespace nm|
aClass isMeta ifFalse:[
(aCategory = '* all *'
or:[aClass category = aCategory]) ifTrue:[
(aClass isNamespace not
or:[aClass == Smalltalk]) ifTrue:[
actualNamespace := aClass nameSpace.
(actualNamespace isNamespace not "/ a private class
or:[actualNamespace == aNamespace]) ifTrue:[
classes add:aClass
]
]
]
]
]
].
^ classes
"Created: 23.12.1996 / 10:26:28 / cg"
"Modified: 23.12.1996 / 11:33:13 / cg"
!
allClassesInCategory:aCategory do:aBlock
|classes|
classes := self allClassesInCategory:aCategory.
classes do:aBlock
"Modified: 23.12.1996 / 10:30:00 / cg"
!
allClassesInCategory:aCategory inOrderDo:aBlock
"evaluate the argument, aBlock for all classes in aCategory;
superclasses come first - then subclasses"
|classes|
classes := (self allClassesInCategory:aCategory) asOrderedCollection.
classes topologicalSort:[:a :b | b isSubclassOf:a].
classes do:aBlock
"Created: 23.12.1996 / 10:27:52 / cg"
"Modified: 19.3.1997 / 12:48:28 / cg"
!
allClassesInSelectedNamespacesDo:aBlock
|nameSpacesConsidered|
nameSpacesConsidered := self listOfNamespaces asIdentitySet.
Smalltalk allBehaviorsDo:[:aClass |
(nameSpacesConsidered includes:aClass nameSpace)
ifTrue:[
aBlock value:aClass
]
]
"Created: 16.1.1997 / 20:18:47 / cg"
"Modified: 16.1.1997 / 20:20:24 / cg"
!
checkClassSelected
"warn and return false, if no class is selected"
currentClass isNil ifTrue:[
self warn:'select a class first'.
^ false
].
^ true
!
classClassDefinitionTemplateFor:aClass in:cat namespace:isNameSpace private:isPrivate
"common helper for newClass and newSubclass
- show a template to define a subclass of aClass in category cat.
Also, set acceptaction to install the class."
|theSuperClass|
currentMethodCategory := nil.
currentMethod := currentSelector := nil.
classListView setSelection:nil.
fullClass ifFalse:[
methodCategoryListView contents:nil.
methodListView contents:nil
].
(aClass == Autoload
or:[aClass isNil or:[aClass isLoaded not]]) ifTrue:[
theSuperClass := Object
] ifFalse:[
theSuperClass := aClass
].
codeView contents:(self classTemplateFor:theSuperClass in:cat namespace:isNameSpace private:isPrivate).
codeView modified:false.
codeView acceptAction:[:theCode |
codeView cursor:Cursor execute.
Object abortSignal catch:[
|cls|
Object errorSignal handle:[:ex |
codeView error:ex errorString
position:1 to:nil from:nil.
] do:[
Class nameSpaceQuerySignal answer:Smalltalk
do:[
cls := (Compiler evaluate:theCode asString notifying:codeView compile:false).
cls isBehavior ifTrue:[
codeView modified:false.
self classCategoryUpdate.
self updateClassListWithScroll:false.
cls isNamespace ifFalse:[
self switchToClassNamed:(cls name).
]
]
]
]
].
codeView cursor:(Cursor normal).
].
codeView explainAction:nil.
self switchToClass:nil
"Created: 23.12.1996 / 12:45:43 / cg"
"Modified: 16.1.1997 / 01:46:39 / cg"
!
classListUpdate
RememberAspect ifTrue:[
aspect == #hierarchy ifTrue:[
^ self classHierarchy
].
aspect == #classInstVars ifTrue:[
^ self classClassInstVars
].
aspect == #comment ifTrue:[
^ self classComment
].
aspect == #primitiveDefinitions ifTrue:[
^ self classPrimitiveDefinitions
].
aspect == #primitiveFunctions ifTrue:[
^ self classPrimitiveFunctions
].
aspect == #primitiveVariables ifTrue:[
^ self classPrimitiveVariables
].
aspect == #revisionInfo ifTrue:[
^ self classRevisionInfo
].
].
self classDefinition
"Created: 23.11.1995 / 11:28:58 / cg"
"Modified: 23.11.1995 / 11:36:08 / cg"
!
classSelection:lineNr
"user clicked on a class line - show method categories"
|cls nm oldSelector sel classes key msg globlName|
(currentClassHierarchy notNil
and:[fullProtocol]) ifTrue:[
oldSelector := currentSelector.
self updateMethodCategoryListWithScroll:false.
self updateMethodListWithScroll:false.
fullProtocol ifFalse:[
self updateVariableList.
].
oldSelector notNil ifTrue:[
self switchToMethod:oldSelector.
currentMethod notNil ifTrue:[
self switchToMethodCategory:(currentMethod category).
]
].
^ self
].
(sel := classListView selectionValue) isNil ifTrue:[
self classCategorySelectionChanged.
aspect := nil.
currentClass := actualClass := nil.
self updateCodeView.
^ self
].
nm := sel withoutSpaces.
cls := self findClassNamed:nm.
cls notNil ifTrue:[
self switchToClass:cls.
self classSelectionChanged
] ifFalse:[
(self confirm:('oops - no class named: ' , nm , ' found in selected namespace(s)\\Try to reconnect ?') withCRs)
ifTrue:[
"/ search for all classes by that name ...
classes := IdentitySet new.
Class allSubInstancesDo:[:aClass |
aClass name = nm ifTrue:[
classes add:aClass
]
].
classes notEmpty ifTrue:[
classes size == 1 ifTrue:[
cls := classes first.
Smalltalk
keysAndValuesDo:[:key :aClass |
(Smalltalk at:key) == cls ifTrue:[
globlName := key
]
].
msg := 'found ' , cls name , ' in category ''' , cls category , '.\'.
globlName notNil ifTrue:[
msg := msg , '(known as ' , globlName , ')\'.
].
(self confirm:(msg , '\reconnect ?') withCRs)
ifTrue:[
Smalltalk at:cls name asSymbol put:cls
]
] ifFalse:[
self warn:('found multiple classes with a name of ' , nm , '.\\Select and rename as required') withCRs.
SystemBrowser browseClasses:classes asOrderedCollection
title:'choose and rename as required'
]
] ifFalse:[
self warn:'oops - could not find that class'
]
]
]
"Modified: 24.1.1997 / 18:49:47 / cg"
!
classSelectionChanged
|oldMethodCategory oldMethod oldSelector|
self withWaitCursorDo:[
aspect := #definition.
oldMethodCategory := currentMethodCategory.
oldMethod := currentMethod.
oldSelector := currentSelector.
showInstance ifTrue:[
actualClass := acceptClass := currentClass
] ifFalse:[
actualClass := acceptClass := currentClass class
].
currentMethodCategory := nil.
currentMethod := nil.
currentSelector := nil.
self updateMethodCategoryList.
oldMethodCategory notNil ifTrue:[
methodCategoryListView setSelectElement:oldMethodCategory.
methodCategoryListView hasSelection ifTrue:[
currentMethodCategory := oldMethodCategory.
self methodCategorySelectionChanged
]
].
self updateMethodList.
self updateCodeView.
self updateVariableList.
fullClass ifTrue:[
codeView acceptAction:[:theCode |
codeView cursor:Cursor execute.
Object abortSignal catch:[
self compileCode:theCode asString.
codeView modified:false.
].
codeView cursor:Cursor normal.
].
] ifFalse:[
"/ self classDefinition.
self classListUpdate.
codeView acceptAction:[:theCode |
|ns|
currentClass notNil ifTrue:[
ns := currentClass nameSpace
] ifFalse:[
ns := nil
].
codeView cursor:Cursor execute.
Class nameSpaceQuerySignal handle:[:ex |
ns isNil ifTrue:[
ex reject
].
ex proceedWith:ns
] do:[
Object abortSignal catch:[
UndefinedObject createMinimumProtocolInNewSubclassQuery
answer:true
do:[
(Compiler
evaluate:theCode asString
notifying:codeView
compile:false)
isBehavior ifTrue:[
self classCategoryUpdate.
self updateClassListWithScroll:false.
codeView modified:false.
].
]
].
].
codeView cursor:Cursor normal.
].
].
codeView explainAction:nil.
(classCategoryListView notNil and:[currentClass notNil]) ifTrue:[
(currentClassCategory = currentClass category) ifFalse:[
currentClassCategory := currentClass category.
classCategoryListView setSelectElement:currentClassCategory
]
].
self setDoitActionForClass
]
"Created: 23.11.1995 / 11:32:03 / cg"
"Modified: 14.1.1997 / 13:33:29 / cg"
!
classTemplateFor:aSuperClass in:categoryString namespace:isNameSpace private:isPrivate
"return a class definition template - be smart in what is offered initially"
|cat aString name nameProto namePrefix i existingNames withNameSpaceDirective
className ownerName|
isNameSpace ifTrue:[
^ 'Namespace name:''NewNameSpace''
"
Replace ''NewNameSpace'' by the desired name.
Create the namespace by ''accepting'',
either via the menu or the keyboard (usually CMD-A).
"
'
].
withNameSpaceDirective :=
currentNamespace notNil
and:[currentNamespace ~= '* all *'
and:[currentNamespace ~= Smalltalk]].
withNameSpaceDirective ifTrue:[
className := aSuperClass nameWithoutNameSpacePrefix
] ifFalse:[
className := aSuperClass name.
].
cat := categoryString.
(cat isNil or:[cat startsWith:'*']) ifTrue:[
cat := '* no category *'
].
nameProto := 'NewClass'.
i := 1.
isPrivate ifTrue:[
namePrefix := currentClass name , '::'.
existingNames := currentClass privateClasses.
existingNames notNil ifTrue:[
existingNames := existingNames collect:[:cls | cls name].
]
] ifFalse:[
namePrefix := ''.
existingNames := Smalltalk keys
].
name := 'NewClass' , i printString.
existingNames notNil ifTrue:[
nameProto := namePrefix , name.
[nameProto knownAsSymbol and:[existingNames includes:nameProto asSymbol]] whileTrue:[
i := i + 1.
name := 'NewClass' , i printString.
nameProto := namePrefix , name
].
].
isPrivate ifTrue:[
withNameSpaceDirective ifTrue:[
ownerName := currentClass nameWithoutNameSpacePrefix
] ifFalse:[
ownerName := currentClass name
].
aString := className , ' subclass:#' , name , '
' , ' instanceVariableNames: ''''
' , ' classVariableNames: ''''
' , ' poolDictionaries: ''''
' , ' privateIn:' , ownerName
] ifFalse:[
aString := className , ' subclass:#' , name , '
' , ' instanceVariableNames: ''''
' , ' classVariableNames: ''''
' , ' poolDictionaries: ''''
' , ' category: '''.
cat notNil ifTrue:[
aString := aString , cat
].
aString := aString , ''''
].
aString := aString , '
"
Replace ''' , className , ''', ''', name , ''' and
the empty string arguments by true values.
Install (or change) the class by ''accepting'',
either via the menu or the keyboard (usually CMD-A).
To be nice to others (and yourself later), do not forget to
add some documentation; preferably under the classes documentation
protocol.
(see the `create documentation stubs'' item in the methodList menu.)
"
'.
withNameSpaceDirective ifTrue:[
aString := '"{ Namespace: ''' , currentNamespace name , ''' }"
' , aString
].
^ aString
"Created: 23.12.1996 / 12:46:31 / cg"
"Modified: 5.1.1997 / 00:13:33 / cg"
!
doClassMenu:aBlock
"a helper - check if class is selected and evaluate aBlock
while showing waitCursor"
self checkClassSelected ifTrue:[
self withWaitCursorDo:[aBlock value:currentClass]
]
!
listOfAllClassNamesInCategory:aCategory
"return a list of the names of all classes in a given category"
^ self listOfAllClassesInCategory:aCategory names:true
"Modified: 10.1.1997 / 14:00:33 / cg"
!
listOfAllClassesInCategory:aCategory names:namesFlag
"return a list of (the names) of all classes in a given category
from the currently selected set of nameSpaces."
|nameSpaces listOfClassNames listOfClasses classesPresent namesPresent searchCategory
match anyCategory nm owner allNameSpaces|
allNameSpaces := (currentNamespace = '* all *').
"/ keep track of added names (care for obsolete classes)
namesPresent := Set new.
namesFlag ifTrue:[
(aCategory = '* hierarchy *') ifTrue:[
listOfClassNames := OrderedCollection new.
self classHierarchyOf:Object withAutoloaded:true do:[:aClass :lvl|
|indent|
(aClass isNamespace not
or:[aClass == Smalltalk]) ifTrue:[
nm := self displayedClassNameOf:aClass.
(namesPresent includes:nm) ifFalse:[
indent := String new:lvl*2.
"/ show classes from other nameSpaces in italic
(allNameSpaces not
and:[(self findClassNamedInNameSpace:nm) isNil]) ifTrue:[
nm := nm asText emphasizeAllWith:#italic.
].
nm := indent , nm.
namesPresent add:nm.
listOfClassNames add:nm
]
]
].
^ listOfClassNames
].
].
(aCategory = '* all *') ifTrue:[
anyCategory := true
] ifFalse:[
anyCategory := false.
(aCategory = '* no category *') ifTrue:[
searchCategory := nil
] ifFalse:[
searchCategory := aCategory
].
].
allNameSpaces ifTrue:[
nameSpaces := Array with:Smalltalk.
] ifFalse:[
nameSpaces := self listOfNamespaces.
].
listOfClasses := OrderedCollection new.
listOfClassNames := OrderedCollection new.
classesPresent := IdentitySet new.
nameSpaces do:[:aNamespace |
aNamespace allBehaviorsDo:[:aClass |
|thisCategory actualNamespace nm owner|
aClass isMeta ifFalse:[
(aClass isNamespace not
or:[aClass == Smalltalk]) ifTrue:[
(classesPresent includes:aClass) ifFalse:[
match := anyCategory.
match ifFalse:[
thisCategory := aClass category.
match := ((thisCategory = searchCategory)
or:[thisCategory = aCategory]).
].
match ifTrue:[
fullClass ifTrue:[
aClass owningClass notNil ifTrue:[
match := false
]
].
].
match ifTrue:[
nm := self displayedClassNameOf:aClass.
(namesPresent includes:nm) ifFalse:[
allNameSpaces ifFalse:[
(owner := aClass topOwningClass) notNil ifTrue:[
actualNamespace := owner nameSpace
] ifFalse:[
actualNamespace := aClass nameSpace.
].
match := actualNamespace isNamespace not "/ a private class
or:[actualNamespace == aNamespace].
].
match ifTrue:[
namesPresent add:nm.
classesPresent add:aClass.
listOfClasses add:aClass.
listOfClassNames add:nm.
]
]
]
]
]
]
]
].
fullClass ifFalse:[
"/
"/ mhm - must search through private classes of those
"/ in smalltalk (they are not visible in the nameSpace,
"/ but should also be displayed)
"/
Smalltalk allBehaviorsDo:[:aClass |
|actualNamespace owner|
aClass isMeta ifFalse:[
(classesPresent includes:aClass) ifFalse:[
(owner := aClass topOwningClass) notNil ifTrue:[
(classesPresent includes:owner) ifTrue:[
nm := self displayedClassNameOf:aClass.
(namesPresent includes:nm) ifFalse:[
namesPresent add:nm.
listOfClasses add:aClass.
listOfClassNames add:nm.
]
]
]
]
]
].
].
(listOfClasses size == 0) ifTrue:[^ nil].
"/ sort by name
listOfClassNames sortWith:listOfClasses.
namesFlag ifFalse:[
^ listOfClasses
].
"/ indent after sorting
1 to:listOfClassNames size do:[:index |
|nm cls owner s|
cls := listOfClasses at:index.
owner := cls.
(owner := owner owningClass) notNil ifTrue:[
nm := listOfClassNames at:index.
s := nm.
[owner notNil] whileTrue:[
s := ' ' , s.
owner := owner owningClass
].
listOfClassNames at:index put:s.
].
].
^ listOfClassNames
"Created: 10.1.1997 / 13:57:34 / cg"
"Modified: 10.1.1997 / 13:59:54 / cg"
!
listOfClassNameHierarchyOf:aClass
"return a hierarchy class-list"
|startClass classes thisOne|
showInstance ifTrue:[
startClass := aClass
] ifFalse:[
startClass := aClass class.
].
classes := startClass allSuperclasses.
thisOne := Array with:startClass.
classes notNil ifTrue:[
classes := classes reverse , thisOne.
] ifFalse:[
classes := thisOne
].
fullProtocol ifFalse:[
classes := classes , startClass allSubclassesInOrder
].
^ classes collect:[:c | c name]
"Modified: 20.12.1996 / 17:13:36 / cg"
"Created: 10.1.1997 / 14:01:06 / cg"
!
renameCurrentClassTo:aString
"helper - do the rename"
self doClassMenu:[:currentClass |
|oldSym cls|
"/ check if the target already exists - confirm if so.
(cls := Smalltalk classNamed:aString) notNil ifTrue:[
(self confirm:(resources string:'WARN_RENAME'
with:aString
with:cls category) withCRs)
ifFalse:[^ self]
].
oldSym := currentClass name asSymbol.
"/
"/ renaming is actually more complicated as one might
"/ think (care for classVariables, privateClasses etc.)
"/ Smalltalk knows all about that ...
Smalltalk renameClass:currentClass to:aString.
self updateClassList.
self updateMethodCategoryListWithScroll:false.
self updateMethodListWithScroll:false.
self withWaitCursorDo:[
Transcript showCR:('searching for users of ' , oldSym); endEntry.
SystemBrowser browseReferendsOf:oldSym warnIfNone:false
]
]
"Created: 25.11.1995 / 13:02:53 / cg"
"Modified: 25.1.1997 / 13:10:45 / cg"
!
switchToClass:newClass
"switch to some other class;
keep instance protocol as it was ..."
|cls meta|
"/ fullProtocol ifTrue:[^ self].
self releaseClass.
cls := newClass.
cls isMeta ifTrue:[
meta := cls.
cls := meta soleInstance
] ifFalse:[
meta := cls class
].
currentClass := cls.
showInstance ifTrue:[
actualClass := acceptClass := cls.
] ifFalse:[
actualClass := acceptClass := meta.
].
currentClass notNil ifTrue:[
cls addDependent:self.
meta addDependent:self.
].
self normalLabel.
"Modified: 1.9.1995 / 01:04:05 / claus"
"Modified: 13.12.1995 / 15:32:49 / cg"
!
switchToClassNameMatching:aMatchString
|classNames thisName box|
classNames := Set 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 first)
].
classNames := classNames asArray sort.
box := self listBoxTitle:'select class to switch to:'
okText:'ok'
list:classNames.
box action:[:aString | self switchToClassNamed:aString].
box showAtPointer
"Modified: 4.6.1996 / 11:34:22 / cg"
!
switchToClassNamed:aString
|meta str classSymbol theClass newCat element idx l|
meta := false.
str := aString.
(aString endsWith:' class') ifTrue:[
str := aString copyWithoutLast:6.
meta := true
].
theClass := self findClassNamed:str.
classCategoryListView notNil ifTrue:[
classCategoryListView list size == 0 ifTrue:[
classCategoryListView list:(self listOfAllClassCategories).
]
].
theClass == currentClass ifTrue:[^ self].
theClass isBehavior ifTrue:[
classCategoryListView notNil ifTrue:[
currentClassHierarchy isNil ifTrue:[
((newCat := theClass category) ~= currentClassCategory) ifTrue:[
currentClassCategory := newCat.
newCat isNil ifTrue:[
element := '* no category *'
] ifFalse:[
element := newCat.
].
classCategoryListView setSelectElement:element.
"/ classCategoryListView makeSelectionVisible.
]
]
].
self updateClassList.
self switchToClass:theClass.
"/ (currentNamespace = '* all *'
"/ or:[currentNamespace ~= theClass nameSpace]) ifTrue:[
"/ str := theClass name
"/ ] ifFalse:[
"/ str := theClass nameWithoutPrefix
"/ ].
l := classListView list.
l notNil ifTrue:[
idx := l findFirst:[:line | line withoutSpaces = str].
classListView selection:idx.
"/ classListView setSelectElement:str.
].
self instanceProtocol:meta not.
idx ~~ 0 ifTrue:[
self classSelectionChanged.
classCategoryListView notNil ifTrue:[
classCategoryListView setSelectElement:theClass category
]
]
]
"Modified: 1.9.1995 / 01:41:35 / claus"
"Modified: 17.6.1996 / 16:54:55 / stefan"
"Modified: 3.1.1997 / 11:45:46 / cg"
!
updateClassList
self updateClassListWithScroll:true
!
updateClassListWithScroll:scroll
|classes oldClassName|
gotClassList == true ifTrue:[^ self].
classListView notNil ifTrue:[
"
refetch in case we are not up to date
"
(currentClass notNil and:[fullProtocol not]) ifTrue:[
oldClassName := currentClass name.
currentClass := self findClassNamed:oldClassName.
].
currentClassCategory notNil ifTrue:[
classes := self listOfAllClassNamesInCategory:currentClassCategory
] ifFalse:[
currentClassHierarchy notNil ifTrue:[
classes := self listOfClassNameHierarchyOf:currentClassHierarchy
]
].
classListView list = classes ifFalse:[
scroll ifTrue:[
classListView contents:classes
] ifFalse:[
classListView setContents:classes
].
oldClassName notNil ifTrue:[
classListView setContents:classes.
classListView setSelectElement:oldClassName
] ifFalse:[
variableListView notNil ifTrue:[variableListView contents:nil]
].
scroll ifTrue:[
fullProtocol ifTrue:[
classListView scrollToBottom
]
]
].
]
"Modified: 10.1.1997 / 14:01:20 / cg"
! !
!BrowserView methodsFor:'class-method list menu'!
classMethodBrowse
SystemBrowser openInClass:actualClass selector:currentSelector
"Created: 13.12.1995 / 15:05:12 / cg"
"Modified: 13.12.1995 / 15:06:26 / cg"
!
classMethodFileOutAll
"fileout all methods into one source file"
|list classString selectorString cls mth outStream fileName append
fileBox|
append := false.
fileBox := FileSaveBox
title:(resources string:'save methods in:')
okText:(resources string:'save')
abortText:(resources string:'cancel')
action:[:fName | fileName := fName].
fileBox appendAction:[:fName | fileName := fName. append := true].
fileBox initialText:'some_methods.st'.
Project notNil ifTrue:[
fileBox directory:Project currentProjectDirectory
].
fileBox showAtPointer.
fileName notNil ifTrue:[
"
if file exists, save original in a .sav file
"
fileName asFilename exists ifTrue:[
fileName asFilename copyTo:(fileName , '.sav')
].
append ifTrue:[
outStream := FileStream appendingOldFileNamed:fileName
] ifFalse:[
outStream := FileStream newFileNamed:fileName.
].
outStream isNil ifTrue:[
^ self warn:'cannot create: %1' with:fileName
].
self withWaitCursorDo:[
list := classMethodListView list.
list do:[:line |
self busyLabel:'writing: ' with:line.
classString := self classNameFromClassMethodString:line.
selectorString := self selectorFromClassMethodString:line.
cls := self findClassNamed:classString.
cls isNil ifTrue:[
self warn:'oops class %1 is gone' with:classString
] ifFalse:[
mth := cls compiledMethodAt:(selectorString asSymbol).
Class fileOutErrorSignal handle:[:ex |
|box answer|
box := YesNoBox
title:('fileOut error: '
, ex errorString
, '\\continue anyway ?') withCRs
yesText:'continue'
noText:'abort'.
answer := box confirm.
box destroy.
answer ifTrue:[
ex proceed
].
self normalLabel.
^ self
] do:[
cls fileOutMethod:mth on:outStream.
]
]
].
outStream close.
self normalLabel.
]
]
"Modified: 17.6.1996 / 16:51:11 / stefan"
"Modified: 3.3.1997 / 15:11:20 / cg"
!
classMethodMenu
<resource: #keyboard ( #Cmds #Cmdi #Cmdg ) >
|labels selectors shorties m specialMenu|
(currentMethod notNil
and:[currentMethod isWrapped]) ifTrue:[
labels := #(
'inspect method'
'-'
'remove break/trace'
).
selectors := #(
methodInspect
nil
methodRemoveBreakOrTrace
).
] ifFalse:[
labels := #(
'inspect method'
'-'
'breakpoint'
'breakpoint in ...'
'-'
'trace'
'trace sender'
'trace full walkback'
'-'
'start timing'
'start counting'
'start mem usage'
).
selectors := #(
methodInspect
nil
methodBreakPoint
methodBreakPointInProcess
nil
methodTrace
methodTraceSender
methodTraceFull
nil
methodStartTiming
methodStartCounting
methodStartMemoryUsage
).
].
specialMenu := PopUpMenu
labels:(resources array:labels)
selectors:selectors.
device ctrlDown ifTrue:[
currentMethod isNil ifTrue:[
classMethodListView flash.
^ nil
].
^ specialMenu
].
labels := #(
'fileOut'
'fileOut all'
'printOut'
'-'
'browse'
'spawn'
'spawn class'
'spawn full protocol'
'spawn hierarchy'
'-'
'senders ...'
'implementors ...'
'globals ...'
"/ '-'
"/ 'breakpoint'
"/ 'trace'
"/ 'trace sender'
'-'
'remove'
'-'
'others'
).
shorties := #(
nil
nil
nil
nil
nil
nil
nil
nil
nil
nil
#Cmds
#Cmdi
#Cmdg
"/ nil
"/ nil
"/ nil
"/ nil
nil
nil
nil
#'Ctrl'
).
selectors := #(
methodFileOut
classMethodFileOutAll
methodPrintOut
nil
classMethodBrowse
methodSpawn
classSpawn
classSpawnFullProtocol
classSpawnHierarchy
nil
methodSenders
methodImplementors
methodGlobalReferends
"/ nil
"/ methodBreakPoint
"/ methodTrace
"/ methodTraceSender
nil
methodRemove
nil
othersMenu
).
m := PopUpMenu
labels:(resources array:labels)
selectors:selectors
accelerators:shorties.
m subMenuAt:#othersMenu put:specialMenu.
^ m
"Modified: 7.3.1997 / 19:33:14 / cg"
! !
!BrowserView methodsFor:'class-method stuff'!
classFromClassMethodString:aString
"helper for classMethod-list - extract class name from the string"
|classString|
classString := self classNameFromClassMethodString:aString.
^ self findClassNamed:classString.
"Created: 3.3.1997 / 15:12:59 / cg"
!
classMethodSelection:lineNr
"user clicked on a class/method line - show code"
|cls string classString selectorString meta sensor|
string := classMethodListView selectionValue string.
classString := self classNameFromClassMethodString:string.
selectorString := self selectorFromClassMethodString:string.
"/ reselected with control ?
((sensor := self sensor) notNil and:[sensor ctrlDown]) ifTrue:[
selectorString = currentSelector ifTrue:[
"/ if there is a trace/break, remove it.
(currentMethod notNil and:[currentMethod isWrapped]) ifTrue:[
self methodRemoveBreakOrTrace.
^ self
]
].
].
((classString ~= 'Metaclass') and:[classString endsWith:' class']) ifTrue:[
classString := classString copyWithoutLast:6 "copyTo:(classString size - 5)".
meta := true.
] ifFalse:[
meta := false.
].
self switchToClass:(self findClassNamed:classString).
meta ifTrue:[cls := currentClass class] ifFalse:[cls := currentClass].
actualClass := acceptClass := cls.
currentClass isNil ifTrue:[
self warn:'oops class is gone'
] ifFalse:[
currentClassCategory := currentClass category.
currentSelector := selectorString asSymbol.
currentMethod := actualClass compiledMethodAt:currentSelector.
currentMethod isNil ifTrue:[
self warn:'oops method is gone'
] ifFalse:[
currentMethodCategory := currentMethod category.
].
self methodSelectionChanged
].
self setDoitActionForClass
"Modified: 31.8.1995 / 11:56:02 / claus"
"Modified: 17.6.1996 / 16:51:28 / stefan"
"Modified: 7.3.1997 / 21:04:40 / cg"
!
classNameFromClassMethodString:aString
"helper for classMethod-list - extract class name from the string"
|pos s|
s := aString string withoutSpaces.
(s endsWith:' !!') ifTrue:[
s := s copyWithoutLast:2
].
(s endsWith:')') ifTrue:[
s := aString copyTo:(aString lastIndexOf:$()-1.
s := s withoutSpaces.
].
(s endsWith:' !!') ifTrue:[
s := s copyWithoutLast:2
].
pos := s lastIndexOf:(Character space).
^ s copyTo:(pos - 1)
"Modified: 17.6.1996 / 17:06:59 / stefan"
"Modified: 4.11.1996 / 23:56:52 / cg"
"Created: 3.3.1997 / 15:11:30 / cg"
!
selectorFromClassMethodString:aString
"helper for classMethod-list - extract selector from the string"
|pos s|
s := aString withoutSpaces.
(s endsWith:' !!') ifTrue:[
s := s copyWithoutLast:2
].
(s endsWith:')') ifTrue:[
s := aString copyTo:(aString lastIndexOf:$()-1.
s := s withoutSpaces.
].
(s endsWith:' !!') ifTrue:[
s := s copyWithoutLast:2
].
pos := s lastIndexOf:(Character space).
^ s copyFrom:(pos + 1)
"Modified: 17.6.1996 / 17:04:38 / stefan"
"Modified: 4.11.1996 / 23:57:00 / cg"
! !
!BrowserView methodsFor:'event handling'!
handlesKeyPress:key inView:view
"this method is reached via delegation: are we prepared to handle
a keyPress in some other view ?"
<resource: #keyboard (#Find #Cmdn #Cmdl #Cmdi #Cmds #Cmdg #Cmdt #Cmda)>
|untranslatedKey|
untranslatedKey := device keyboardMap keyAtValue:key ifAbsent:key.
view == classCategoryListView ifTrue:[
(key == #Find) ifTrue:[^ true].
(untranslatedKey == #Cmdn) ifTrue:[^ true].
].
view == classListView ifTrue:[
(untranslatedKey == #Cmdn) ifTrue:[^ true].
(untranslatedKey == #Cmdl) ifTrue:[^ true].
(untranslatedKey == #Cmdd) ifTrue:[^ true].
].
view == methodCategoryListView ifTrue:[
(untranslatedKey == #Cmdn) ifTrue:[^ true].
].
((view == methodListView)
or:[view == classMethodListView]) ifTrue:[
(untranslatedKey == #Cmdi) ifTrue:[^ true].
(untranslatedKey == #Cmds) ifTrue:[^ true].
(untranslatedKey == #Cmdg) ifTrue:[^ true].
(untranslatedKey == #Cmdt) ifTrue:[^ true].
(untranslatedKey == #Cmda) ifTrue:[^ true].
].
^ false
"Created: 2.3.1996 / 14:33:30 / cg"
"Modified: 11.1.1997 / 21:42:43 / cg"
!
keyPress:key x:x y:y view:view
"this method is reached via delegation from the classCategoryListView"
<resource: #keyboard (#Find #Cmdn #Cmdl #Cmdi #Cmds #Cmdg #Cmdt #Cmda)>
|untranslatedKey|
"/
"/ have to untranslate (since we get #Inspect / #Search
"/
untranslatedKey := device keyboardMap keyAtValue:key ifAbsent:key.
view == classCategoryListView ifTrue:[
(key == #Find) ifTrue:[^ self classCategoryFindClass].
(untranslatedKey == #Cmdn) ifTrue:[^ self classCategoryNewCategory].
].
view == classListView ifTrue:[
(untranslatedKey == #Cmdn) ifTrue:[^ self classNewClass].
(untranslatedKey == #Cmdl) ifTrue:[^ self classLoad].
(untranslatedKey == #Cmdd) ifTrue:[^ self classDocumentation].
].
view == methodCategoryListView ifTrue:[
(untranslatedKey == #Cmdn) ifTrue:[^ self methodCategoryNewCategory].
].
((view == methodListView)
or:[view == classMethodListView]) ifTrue:[
(untranslatedKey == #Cmdi) ifTrue:[^ self methodImplementors].
(untranslatedKey == #Cmds) ifTrue:[^ self methodSenders].
(untranslatedKey == #Cmdg) ifTrue:[^ self methodGlobalReferends].
(untranslatedKey == #Cmdt) ifTrue:[^ self methodStringSearch].
(untranslatedKey == #Cmda) ifTrue:[^ self methodAproposSearch].
].
view keyPress:key x:x y:y
"Created: 2.3.1996 / 14:37:52 / cg"
"Modified: 11.1.1997 / 21:42:54 / cg"
! !
!BrowserView methodsFor:'help'!
helpTextFor:aComponent
|s|
aComponent == classCategoryListView ifTrue:[
s := 'HELP_CCAT_LIST'
].
aComponent == classListView ifTrue:[
fullProtocol ifTrue:[
s := 'HELP_PCLASS_LIST'
] ifFalse:[
currentClassHierarchy notNil ifTrue:[
s := 'HELP_HCLASS_LIST'
] ifFalse:[
s := 'HELP_CLASS_LIST'
]
]
].
aComponent == methodCategoryListView ifTrue:[
s := 'HELP_MCAT_LIST'
].
aComponent == methodListView ifTrue:[
s := 'HELP_METHOD_LIST'
].
aComponent == variableListView ifTrue:[
s := 'HELP_VAR_LIST'
].
aComponent == codeView ifTrue:[
fullClass ifTrue:[
s := 'HELP_FULLCODE_VIEW'
] ifFalse:[
s := 'HELP_CODE_VIEW'
]
].
(aComponent == instanceToggle
or:[aComponent == classToggle]) ifTrue:[
s := 'HELP_INST_CLASS_TOGGLE'
].
aComponent == classMethodListView ifTrue:[
s := 'HELP_CLSMTHOD_LIST'
].
s notNil ifTrue:[
^ resources string:s
].
^ nil
"Modified: 31.8.1995 / 19:11:39 / claus"
! !
!BrowserView methodsFor:'initialize / release'!
autoSearch:aString
"used with class-method list browsing. If true,
selecting an entry from the list will automatically
search for the searchstring in the codeView"
self setSearchPattern:aString.
autoSearch := aString
!
destroy
"relese dependant - destroy popups"
Smalltalk removeDependent:self.
currentClass notNil ifTrue:[
self releaseClass.
"/
"/ just in case someone keeps a ref to myself around ...
"/ ... release refs to my class (not really needed)
"/
currentClass := actualClass := acceptClass := nil
].
super destroy
"Modified: 13.12.1995 / 15:33:03 / cg"
!
initialize
super initialize.
showInstance := true.
fullClass := false.
fullProtocol := false.
gotClassList := false.
aspect := nil.
currentNamespace := '* all *'.
"inform me, when Smalltalk changes"
Smalltalk addDependent:self
"Modified: 4.1.1997 / 19:58:52 / cg"
!
realize
|v checkBlock|
super realize.
checkBlock := [:lineNr | self checkSelectionChangeAllowed].
v := classCategoryListView.
v notNil ifTrue:[
v action:[:lineNr | self classCategorySelection:lineNr].
v selectConditionBlock:checkBlock.
v ignoreReselect:false.
v list size == 0 ifTrue:[
v list:(self listOfAllClassCategories).
].
"
tell classCategoryListView to ask for the menu
"
v menuHolder:self; menuPerformer:self; menuMessage:#classCategoryMenu.
].
v := classListView.
v notNil ifTrue:[
v action:[:lineNr | self classSelection:lineNr].
v selectConditionBlock:checkBlock.
v ignoreReselect:false.
"
tell classListView to ask for the menu
"
v menuHolder:self; menuPerformer:self; menuMessage:#classMenu.
].
v := methodCategoryListView.
v notNil ifTrue:[
v action:[:lineNr | self methodCategorySelection:lineNr].
v selectConditionBlock:checkBlock.
v ignoreReselect:false.
"
tell methodCategoryListView to ask for the menu
"
v menuHolder:self; menuPerformer:self; menuMessage:#methodCategoryMenu.
].
v := methodListView.
v notNil ifTrue:[
v action:[:lineNr | self methodSelection:lineNr].
v selectConditionBlock:checkBlock.
v ignoreReselect:false.
"
tell methodListView to ask for the menu
"
v menuHolder:self; menuPerformer:self; menuMessage:#methodMenu.
].
v := classMethodListView.
v notNil ifTrue:[
v action:[:lineNr | self classMethodSelection:lineNr].
v selectConditionBlock:checkBlock.
v ignoreReselect:false.
"
tell classMethodListView to ask for the menu
"
v menuHolder:self; menuPerformer:self; menuMessage:#classMethodMenu.
].
v := variableListView.
v notNil ifTrue:[
v action:[:lineNr | self variableSelection:lineNr].
v ignoreReselect:false.
v toggleSelect:true.
v menuHolder:self; menuPerformer:self; menuMessage:#variableListMenu.
].
"
normal browsers show the top/selection at first;
fullProtocol browsers better show the end initially
"
fullProtocol ifTrue:[
classListView scrollToBottom.
]
"Modified: 26.5.1996 / 15:59:13 / cg"
!
terminate
(self checkSelectionChangeAllowed) ifTrue:[
super terminate
]
!
title:someString
myLabel := someString.
self label:someString.
! !
!BrowserView methodsFor:'initialize subviews'!
createClassListViewIn:frame
"setup the classlist subview, with its toggles"
|v panel spc wScr wScrHalf|
self createTogglesIn:frame.
panel := VariableVerticalPanel
origin:(0.0 @ 0.0) corner:(1.0 @ 1.0)
in:frame.
styleSheet is3D ifTrue:[
spc := ViewSpacing.
] ifFalse:[
spc := 0
].
panel bottomInset:(instanceToggle height + spc + instanceToggle borderWidth).
v := HVScrollableView
for:SelectionInListView
miniScrollerH:true miniScrollerV:false
in:panel.
v origin:(0.0 @ 0.0) corner:(1.0 @ 0.7).
classListView := v scrolledView.
classListView delegate:self.
v := ScrollableView for:SelectionInListView in:panel.
v origin:(0.0 @ 0.7) corner:(1.0 @ 1.0).
variableListView := v scrolledView.
variableListView delegate:self.
wScr := v scrollBar preferredExtent x.
wScrHalf := wScr // 2.
"/ (styleSheet at:'scrollBarPosition' default:#right) == #right ifTrue:[
"/ classToggle rightInset:(classToggle rightInset + wScr).
"/ classToggle leftInset:(classToggle leftInset - wScrHalf).
"/ instanceToggle rightInset:(instanceToggle rightInset + wScrHalf)
"/ ].
"Modified: 19.3.1997 / 17:38:07 / cg"
!
createCodeViewIn:aView
"setup the code view"
^ self createCodeViewIn:aView atY:0.25
"Modified: 2.3.1996 / 16:08:46 / cg"
!
createCodeViewIn:aView atY:relY
"setup the code view"
|v|
v := HVScrollableView for:CodeView miniScrollerH:true miniScrollerV:false in:aView.
v origin:(0.0 @ relY) corner:(1.0 @ 1.0).
codeView := v scrolledView
"Created: 2.3.1996 / 16:09:03 / cg"
!
createMethodListViewIn:aView atX:relX
"setup the method list view"
|v|
v := HVScrollableView for:SelectionInListView miniScrollerH:true miniScrollerV:false in:aView.
v origin:(relX @ 0.0) corner:(1.0 @ 1.0).
methodListView := v scrolledView.
methodListView delegate:self.
^ v
"Created: 2.3.1996 / 16:07:10 / cg"
"Modified: 2.3.1996 / 16:11:42 / cg"
!
createTogglesIn:aFrame
"create and setup the class/instance toggles"
|h halfSpace classAction instanceAction|
classAction := [self instanceProtocol:false].
instanceAction := [self instanceProtocol:true].
halfSpace := ViewSpacing // 2.
instanceToggle := Toggle label:(resources at:'instance') in:aFrame.
h := instanceToggle heightIncludingBorder.
instanceToggle origin:(0.0 @ 1.0) corner:(0.5 @ 1.0).
instanceToggle topInset:h negated.
instanceToggle turnOn.
instanceToggle pressAction:instanceAction.
instanceToggle releaseAction:classAction.
classToggle := Toggle label:(resources at:'class') in:aFrame.
h := classToggle heightIncludingBorder.
classToggle origin:(0.5 @ 1.0) corner:(1.0 @ 1.0).
classToggle topInset:h negated.
classToggle turnOff.
classToggle pressAction:classAction.
classToggle releaseAction:instanceAction.
styleSheet is3D ifTrue:[
instanceToggle bottomInset:halfSpace.
classToggle bottomInset:halfSpace.
instanceToggle leftInset:halfSpace.
classToggle leftInset:halfSpace.
instanceToggle rightInset:ViewSpacing - halfSpace.
classToggle rightInset:ViewSpacing - halfSpace.
].
!
focusSequence
|s|
s := OrderedCollection new.
classCategoryListView notNil ifTrue:[
s add:classCategoryListView
].
classListView notNil ifTrue:[
s add:classListView
].
"/ variableListView notNil ifTrue:[
"/ s add:variableListView
"/ ].
instanceToggle notNil ifTrue:[
s add:instanceToggle.
].
methodCategoryListView notNil ifTrue:[
s add:methodCategoryListView
].
methodListView notNil ifTrue:[
s add:methodListView
].
classMethodListView notNil ifTrue:[
s add:classMethodListView
].
s add:codeView.
^ s
!
setupForAll
"create subviews for a full browser"
|vpanel hpanel frame v spc nsHolder|
styleSheet is3D ifTrue:[
spc := ViewSpacing.
] ifFalse:[
spc := 0
].
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 delegate:self.
frame := View origin:(0.25 @ 0.0) corner:(0.5 @ 1.0) in:hpanel.
self createClassListViewIn:frame.
v bottomInset:(instanceToggle height + spc + instanceToggle borderWidth).
nsHolder := currentNamespace asValue.
namespaceList := ComboListView origin:(0.0@1.0) corner:(0.25@1.0) in:hpanel.
namespaceList topInset:(v bottomInset negated) + (spc // 2).
namespaceList bottomInset:(spc // 2).
"/ styleSheet is3D ifTrue:[
"/ namespaceList leftInset:(classCategoryListView originRelativeTo:v) x.
"/ ].
"/ (v scrollBar originRelativeTo:v) > (classCategoryListView originRelativeTo:v)
"/ ifTrue:[
"/ namespaceList rightInset:((v scrollBar originRelativeTo:v)
"/ -
"/ (classCategoryListView originRelativeTo:v))
"/ ] ifFalse:[
"/ styleSheet is3D ifTrue:[
"/ namespaceList rightInset:(ViewSpacing // 2).
"/ ]
"/ ].
"/ styleSheet is3D ifTrue:[
"/ namespaceList rightInset:(ViewSpacing // 2).
"/ ].
self setListOfNamespaces.
namespaceList model:nsHolder.
namespaceList label menuHolder:self; menuMessage:#nameSpaceMenu.
nsHolder onChangeSend:#value
to:[
self changeNameSpaceTo:nsHolder value
].
v := HVScrollableView for:SelectionInListView miniScrollerH:true miniScrollerV:false in:hpanel.
v origin:(0.5 @ 0.0) corner:(0.75 @ 1.0).
methodCategoryListView := v scrolledView.
methodCategoryListView delegate:self.
self createMethodListViewIn:hpanel atX:0.75.
self createCodeViewIn:vpanel
"Modified: 9.1.1997 / 10:39:02 / cg"
!
setupForClass:aClass
"create subviews for browsing a single class"
|vpanel hpanel frame v|
vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
corner:(1.0 @ 1.0)
in:self.
hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
frame := View origin:(0.0 @ 0.0) corner:(0.5 @ 1.0)in:hpanel.
self createTogglesIn:frame.
v := ScrollableView for:SelectionInListView in:frame.
v origin:(0.0 @ 0.0)
extent:[frame width
@
(frame height
- ViewSpacing
- instanceToggle height
- instanceToggle borderWidth
+ v borderWidth)].
methodCategoryListView := v scrolledView.
methodCategoryListView delegate:self.
self createMethodListViewIn:hpanel atX:0.5.
self createCodeViewIn:vpanel.
self switchToClass:aClass.
actualClass := acceptClass := aClass.
self updateMethodCategoryList.
self updateMethodList.
self updateCodeView.
self classDefinition.
"Modified: 27.10.1996 / 14:17:06 / cg"
!
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 := self createMethodListViewIn:vpanel atX:0.0.
v corner:(1.0 @ 0.25).
self createCodeViewIn:vpanel.
currentClassCategory := aClass category.
self switchToClass:aClass.
actualClass := acceptClass := aClass.
currentMethodCategory := aMethodCategory.
self updateMethodList.
self updateCodeView.
"Modified: 2.3.1996 / 16:10:44 / cg"
!
setupForClass:aClass selector:selector
"setup subviews to browse a single method"
|v|
v := ScrollableView for:CodeView in:self.
v origin:(0.0 @ 0.0) corner:(1.0 @ 1.0).
codeView := v scrolledView.
currentClassCategory := aClass category.
self switchToClass:aClass.
actualClass := acceptClass := aClass.
currentSelector := selector.
currentMethod := actualClass compiledMethodAt:selector.
currentMethodCategory := currentMethod category.
self updateCodeView
"Modified: 13.12.1995 / 15:07:50 / cg"
!
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.
methodCategoryListView delegate:self.
self createMethodListViewIn:hpanel atX:0.66.
self createCodeViewIn:vpanel.
currentClassCategory := aClassCategory.
self updateClassList.
self updateMethodCategoryList.
self updateMethodList.
self updateCodeView
"Modified: 27.10.1996 / 14:17:24 / cg"
!
setupForClassHierarchy:aClass
"setup subviews to browse a class hierarchy"
|vpanel hpanel frame v cls|
vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
corner:(1.0 @ 1.0)
in:self.
"
notice: we use a different ratio here
"
hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.4) in:vpanel.
frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
self createClassListViewIn:frame.
v := ScrollableView for:SelectionInListView in:hpanel.
v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
methodCategoryListView := v scrolledView.
methodCategoryListView delegate:self.
self createMethodListViewIn:hpanel atX:0.66.
self createCodeViewIn:vpanel atY:0.4.
cls := aClass.
cls isMeta ifTrue:[
cls := cls soleInstance
].
currentClassHierarchy := currentClass := actualClass := cls.
self updateClassList.
classListView setSelectElement:aClass name; makeSelectionVisible.
self updateMethodCategoryList.
self updateMethodList.
self updateCodeView.
aClass isMeta ifTrue:[
self instanceProtocol:false
].
"Modified: 27.10.1996 / 14:17:30 / cg"
!
setupForClassList:aList
"setup subviews to browse classes from a list"
self setupForClassList:aList sort:true
"Modified: 28.5.1996 / 13:53:03 / cg"
!
setupForClassList:aList sort:doSort
"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.
methodCategoryListView delegate:self.
self createMethodListViewIn:hpanel atX:0.66.
self createCodeViewIn:vpanel.
l := (aList collect:[:entry |
entry isBehavior ifTrue:[
entry name
] ifFalse:[
entry
]]) asOrderedCollection.
doSort ifTrue:[
l sort.
].
classListView list:l.
gotClassList := true.
self updateMethodCategoryList.
self updateMethodList.
self updateCodeView
"Created: 28.5.1996 / 13:52:47 / cg"
"Modified: 4.1.1997 / 19:45:30 / cg"
!
setupForFullClass
"setup subviews to browse a class as full text"
|vpanel hpanel v|
vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
corner:(1.0 @ 1.0)
in:self.
hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.25) in:vpanel.
v := ScrollableView for:SelectionInListView in:hpanel.
v origin:(0.0 @ 0.0) corner:(0.5 @ 1.0).
classCategoryListView := v scrolledView.
classCategoryListView contents:(self listOfAllClassCategories).
v := ScrollableView for:SelectionInListView in:hpanel.
v origin:(0.5 @ 0.0) corner:(1.0 @ 1.0).
classListView := v scrolledView.
self createCodeViewIn:vpanel.
fullClass := true.
self updateCodeView
!
setupForFullClassProtocol:aClass
"setup subviews to browse a classes full protocol"
|vpanel hpanel frame v cls|
vpanel := VariableVerticalPanel origin:(0.0 @ 0.0)
corner:(1.0 @ 1.0)
in:self.
"
notice: we use a different ratio here
"
hpanel := View origin:(0.0 @ 0.0) corner:(1.0 @ 0.4) in:vpanel.
frame := View origin:(0.0 @ 0.0) corner:(0.33 @ 1.0) in:hpanel.
self createClassListViewIn:frame.
classListView multipleSelectOk:true.
classListView toggleSelect:true.
classListView strikeOut:true.
v := ScrollableView for:SelectionInListView in:hpanel.
v origin:(0.33 @ 0.0) corner:(0.66 @ 1.0).
methodCategoryListView := v scrolledView.
methodCategoryListView delegate:self.
self createMethodListViewIn:hpanel atX:0.66.
self createCodeViewIn:vpanel atY:0.4.
cls := aClass.
cls isMeta ifTrue:[
cls := cls soleInstance
].
currentClassHierarchy := actualClass := acceptClass := currentClass := cls.
fullProtocol := true.
self updateClassList.
self updateMethodCategoryList.
self updateMethodList.
self updateCodeView.
self updateVariableList.
aClass isMeta ifTrue:[
self instanceProtocol:false
].
"Modified: 27.10.1996 / 14:17:47 / cg"
!
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.
classMethodListView delegate:self.
classMethodListView doubleClickAction:[:lineNr | self classMethodBrowse].
self createCodeViewIn:vpanel.
aList size == 1 ifTrue:[
classMethodListView setSelection:1.
self classMethodSelection:1.
].
self updateCodeView.
"/ kludge - get trap icons
self updateClassMethodListWithScroll:false keepSelection:true
"Modified: 3.3.1997 / 15:26:48 / cg"
! !
!BrowserView methodsFor:'method category list menu'!
createAccessMethodsFor:aCollectionOfInstVarNames
"workhorse for creating access methods for instvars."
aCollectionOfInstVarNames do:[:name |
|source|
"check, if method is not already present"
(currentClass includesSelector:(name asSymbol)) ifFalse:[
source := (name , '\ "return the value of the instance variable ''' , name , ''' (automatically generated)"\\ ^ ' , name) withCRs.
Compiler compile:source forClass:currentClass inCategory:'accessing'.
] ifTrue:[
Transcript showCR:'method ''', name , ''' already present'
].
(currentClass includesSelector:((name , ':') asSymbol)) ifFalse:[
source := (name , ':something\ "set the value of the instance variable ''' , name , ''' (automatically generated)"\\ ' , name , ' := something.') withCRs.
Compiler compile:source forClass:currentClass inCategory:'accessing'.
] ifTrue:[
Transcript showCR:'method ''', name , ':'' already present'
].
]
"Created: 24.1.1997 / 11:04:46 / cg"
!
methodCategoryCopyCategory
"show the enter box to copy from an existing method category"
|title box|
showInstance ifTrue:[
title := 'class to copy instance method category from:'
] ifFalse:[
title := 'class to copy class method category from:'
].
box := self listBoxTitle:title
okText:'ok'
list:(Smalltalk allClasses collect:[:cls | cls name]) asArray sort.
box label:(resources string:'copy methods').
box action:[:aString | self copyMethodsFromClass:aString].
box showAtPointer
"Modified: 16.1.1997 / 00:01:20 / cg"
!
methodCategoryCreateAccessMethods
"create access methods for instvars.
If no variable is selected, for all instvars;
otherwise for that selected instvar."
self checkClassSelected ifFalse:[^ self].
showInstance ifFalse:[
self warn:'select instance - and try again'.
^ self.
].
self withWaitCursorDo:[
|nm names|
(variableListView notNil
and:[(nm := variableListView selectionValue) notNil]) ifTrue:[
names := Array with:nm
] ifFalse:[
names := currentClass instVarNames
].
lockUpdates := true.
[
self createAccessMethodsFor:names.
] valueOnUnwindDo:[
lockUpdates := false
].
self updateMethodCategoryListWithScroll:false.
self updateMethodListWithScroll:false
]
"Modified: 24.1.1997 / 11:11:02 / cg"
!
methodCategoryCreateDocumentationMethods
"create empty documentation methods"
|cls histStream|
self checkClassSelected ifFalse:[^ self].
cls := currentClass class.
self withWaitCursorDo:[
|nm names source|
"/ add version method containing RCS template
"/ but only if not already present.
(cls includesSelector:#version) ifFalse:[
Compiler compile:
'version
^ ''$' , 'Header$''
' forClass:cls
inCategory:'documentation'.
].
"/ add documentation method containing doc template
"/ but only if not already present.
(cls includesSelector:#documentation) ifFalse:[
Compiler compile:
'documentation
"
documentation to be added.
"
' forClass:cls
inCategory:'documentation'.
].
"/ add examples method containing examples template
"/ but only if not already present.
(cls includesSelector:#examples) ifFalse:[
Compiler compile:
'examples
"
examples to be added.
"
' forClass:cls
inCategory:'documentation'.
].
"/ add history method containing created-entry
"/ but only if not already present.
(cls includesSelector:#history) ifFalse:[
histStream := ReadWriteStream on: String new.
histStream nextPutLine: 'history'.
HistoryLine isBehavior ifTrue:[
histStream nextPutLine: (HistoryLine newCreated printString).
] ifFalse:[
histStream cr.
].
Compiler compile:(histStream contents)
forClass:cls
inCategory:'documentation'.
].
self instanceProtocol:false.
self switchToMethodNamed:#documentation
"/ self updateMethodCategoryListWithScroll:false.
"/ self updateMethodListWithScroll:false
]
"Modified: 8.11.1996 / 23:53:09 / cg"
!
methodCategoryFileOut
"fileOut all methods in the selected methodcategory of
the current class"
self checkClassSelected ifFalse:[^ self].
self whenMethodCategorySelected:[
self busyLabel:'saving: %1' with:currentClass name , '-' , currentMethodCategory.
Class fileOutErrorSignal handle:[:ex |
self warn:'cannot create: %1' with:ex parameter.
ex return.
] do:[
actualClass fileOutCategory:currentMethodCategory.
].
self normalLabel.
]
!
methodCategoryFileOutAll
"fileOut all methods in the selected methodcategory of
the current class"
self whenMethodCategorySelected:[
|fileName outStream|
fileName := currentMethodCategory , '.st'.
fileName replaceAll:Character space by:$_.
"
this test allows a smalltalk to be built without Projects/ChangeSets
"
Project notNil ifTrue:[
fileName := Project currentProjectDirectory , fileName.
].
"
if file exists, save original in a .sav file
"
fileName asFilename exists ifTrue:[
fileName asFilename copyTo:(fileName , '.sav')
].
outStream := FileStream newFileNamed:fileName.
outStream isNil ifTrue:[
^ self warn:'cannot create: %1' with:fileName
].
self busyLabel:'saving: ' with:currentMethodCategory.
Class fileOutErrorSignal handle:[:ex |
self warn:'cannot create: %1' with:ex parameter.
ex return
] do:[
Smalltalk allBehaviorsDo:[:class |
|hasMethodsInThisCategory|
hasMethodsInThisCategory := false.
class methodDictionary do:[:method |
method category = currentMethodCategory ifTrue:[
hasMethodsInThisCategory := true
]
].
hasMethodsInThisCategory ifTrue:[
class fileOutCategory:currentMethodCategory on:outStream.
outStream cr
].
hasMethodsInThisCategory := false.
class class methodDictionary do:[:method |
method category = currentMethodCategory ifTrue:[
hasMethodsInThisCategory := true
]
].
hasMethodsInThisCategory ifTrue:[
class class fileOutCategory:currentMethodCategory on:outStream.
outStream cr
]
].
].
outStream close.
self normalLabel.
].
"Modified: 7.6.1996 / 09:03:56 / stefan"
!
methodCategoryFindAnyMethod
|box|
box := self enterBoxForSearchSelectorTitle:'method selector to search for:'.
box label:(resources string:'find method').
box action:[:aString | self switchToAnyMethodNamed:aString].
box showAtPointer
"Modified: 15.1.1997 / 23:59:53 / cg"
!
methodCategoryFindMethod
|box|
box := self enterBoxForSearchSelectorTitle:'method selector to search for:'.
box label:(resources string:'find method').
box action:[:aString | self switchToMethodNamed:aString].
box showAtPointer
"Modified: 15.1.1997 / 23:59:27 / cg"
!
methodCategoryMenu
<resource: #keyboard (#Cmdn)>
|labels selectors shorties i m|
currentClass isNil ifTrue:[
methodCategoryListView flash.
^ nil
].
currentMethodCategory isNil ifTrue:[
labels := #(
'find method here ...'
'find method ...'
'-'
'new category ...'
'copy category ...'
'create access methods'
).
selectors := #(
methodCategoryFindMethod
methodCategoryFindAnyMethod
nil
methodCategoryNewCategory
methodCategoryCopyCategory
methodCategoryCreateAccessMethods
).
] ifFalse:[
labels := #(
'fileOut'
'fileOut all'
'printOut'
'-'
'SPAWN_METHODCATEGORY'
'spawn category'
'-'
'find method here ...'
'find method ...'
'-'
'new category ...'
'copy category ...'
'create access methods'
'-'
'rename ...'
'remove'
).
selectors := #(
methodCategoryFileOut
methodCategoryFileOutAll
methodCategoryPrintOut
nil
methodCategorySpawn
methodCategorySpawnCategory
nil
methodCategoryFindMethod
methodCategoryFindAnyMethod
nil
methodCategoryNewCategory
methodCategoryCopyCategory
methodCategoryCreateAccessMethods
nil
methodCategoryRename
methodCategoryRemove
).
].
showInstance ifFalse:[
labels := labels copy.
selectors := selectors copy.
i := labels indexOf:'create access methods'.
labels at:i put:'create documentation stubs'.
selectors at:i put:#methodCategoryCreateDocumentationMethods
].
shorties := Array new:(selectors size).
(selectors includes:#methodCategoryNewCategory) ifTrue:[
shorties at:(selectors indexOf:#methodCategoryNewCategory) put:#Cmdn
].
m := PopUpMenu
labels:(resources array:labels)
selectors:selectors
accelerators:shorties.
currentClass isLoaded ifFalse:[
m disableAll:#(
methodCategoryNewCategory
methodCategoryCopyCategory
methodCategoryCreateAccessMethods
)
].
^ m
"Modified: 24.1.1997 / 11:13:27 / cg"
!
methodCategoryNewCategory
"show the enter box to add a new method category.
Offer existing superclass categories in box to help avoiding
useless typing."
|someCategories existingCategories box|
actualClass notNil ifTrue:[
someCategories := actualClass allCategories
] ifFalse:[
"
mhmh - offer some typical categories ...
"
showInstance ifTrue:[
someCategories := #('accessing'
'initialization'
'private'
'printing & storing'
'queries'
'testing'
)
] ifFalse:[
someCategories := #(
'documentation'
'initialization'
'instance creation'
).
].
].
someCategories sort.
"
remove existing categories
"
existingCategories := methodCategoryListView list.
existingCategories notNil ifTrue:[
someCategories := someCategories select:[:cat | (existingCategories includes:cat) not].
].
someCategories := someCategories asSet asOrderedCollection sort.
box := self listBoxTitle:'name of new method category:'
okText:'create'
list:someCategories.
box label:(resources string:'create category').
box initialText:lastCategory.
box action:[:aString | self newMethodCategory:aString. lastCategory := aString].
box showAtPointer
"Modified: 15.1.1997 / 23:57:26 / cg"
!
methodCategoryPrintOut
|printStream|
self checkClassSelected ifFalse:[^ self].
self whenMethodCategorySelected:[
printStream := Printer new.
actualClass printOutCategory:currentMethodCategory on:printStream.
printStream close
]
!
methodCategoryRemove
"show number of methods to remove and query user"
|t box sels count answer|
currentMethodCategory notNil ifTrue:[
sels := OrderedCollection new.
actualClass methodDictionary keysAndValuesDo:[:selector :aMethod |
(aMethod category = currentMethodCategory) ifTrue:[
sels add:selector
]
].
count := sels size.
(count ~~ 0) ifTrue:[
(count == 1) ifTrue:[
t := 'remove %1\(with 1 method) ?'
] ifFalse:[
t := 'remove %1\(with %2 methods) ?'
].
t := resources string:t with:currentMethodCategory with:count printString.
t := t withCRs.
box := YesNoBox
title:t
yesText:(resources at:'remove')
noText:(resources at:'abort').
answer := box confirm.
box destroy.
answer ifFalse:[
^ self.
].
sels do:[:selector|
actualClass removeSelector:selector.
].
].
currentMethodCategory := nil.
currentMethod := currentSelector := nil.
self updateMethodCategoryListWithScroll:false.
self updateMethodList
]
"Modified: 7.6.1996 / 09:13:15 / stefan"
"Modified: 7.1.1997 / 23:03:20 / cg"
!
methodCategoryRename
"launch an enterBox to rename current method category"
|box|
self checkMethodCategorySelected ifFalse:[^ self].
box := self
enterBoxTitle:(resources string:'rename method category %1 to:' with:currentMethodCategory)
okText:(resources at:'rename')
label:'rename category'.
box initialText:currentMethodCategory.
box action:[:aString |
actualClass renameCategory:currentMethodCategory to:aString.
currentMethodCategory := aString.
currentMethod := currentSelector := nil.
self updateMethodCategoryList.
self updateMethodListWithScroll:false
].
box showAtPointer
"Modified: 15.1.1997 / 23:10:44 / cg"
!
methodCategorySpawn
"create a new SystemBrowser browsing current method category"
currentMethodCategory notNil ifTrue:[
self withWaitCursorDo:[
SystemBrowser browseClass:actualClass
methodCategory:currentMethodCategory
]
]
!
methodCategorySpawnCategory
"create a new SystemBrowser browsing all methods from all
classes with same category as current method category"
self askAndBrowseMethodCategory:'category to browse methods:'
action:[:aString |
SystemBrowser browseMethodCategory:aString
]
! !
!BrowserView methodsFor:'method category stuff'!
checkMethodCategorySelected
currentMethodCategory isNil ifTrue:[
self warn:'select a method category first'.
^ false
].
^ true
!
copyMethodsFromClass:aClassName
|class box list|
currentClass notNil ifTrue:[
class := Smalltalk classNamed:aClassName.
class isBehavior ifFalse:[
self warn:'no class named %1' with:aClassName.
^ self
].
showInstance ifFalse:[
class := class class
].
"show enterbox for category to copy from"
list := class categories asOrderedCollection sort.
list addFirst:'*'.
box := self
enterBoxTitle:'name of category to copy from (matchpattern allowed, * for all):'
okText:'copy'
label:(resources string:'copy methods from %1' with:aClassName)
list:list.
box open.
box accepted ifTrue:[
self
copyMethodsFromClass:class
category:(box aspectFor:#fieldValue) value
]
]
"Modified: 16.1.1997 / 20:15:51 / cg"
!
copyMethodsFromClass:class category:category
currentClass notNil ifTrue:[
Object abortSignal catch:[
class methodDictionary do:[:aMethod |
|source|
(category match:aMethod category) ifTrue:[
source := aMethod source.
codeView contents:source.
codeView modified:false.
actualClass compilerClass
compile:source
forClass:actualClass
inCategory:aMethod category
notifying:codeView.
self updateMethodCategoryListWithScroll:false.
self updateMethodListWithScroll:false.
]
]
]
]
"Modified: 7.6.1996 / 09:02:35 / stefan"
!
listOfAllMethodCategoriesInClass:aClass
"answer a list of all method categories of the argument, aClass"
|newList|
newList := Set new.
aClass methodDictionary do:[:aMethod |
|cat|
cat := aMethod category.
cat isNil ifTrue:[
cat := '* no category *'
].
newList add:cat
].
(newList size == 0) ifTrue:[^ nil].
newList add:'* all *'.
^ newList asOrderedCollection sort
"Modified: 7.6.1996 / 09:02:57 / stefan"
!
listOfAllMethodCategoriesInFullProtocolHierarchy:aClass
"answer a list of all method categories of the argument, aClass,
and all of its superclasses.
Used with fullProtocol browsing."
|newList|
newList := Set new.
self classesInFullProtocolHierarchy:aClass do:[:c |
|cat|
c methodDictionary do:[:aMethod |
cat := aMethod category.
cat isNil ifTrue:[
cat := '* no category *'
].
newList add:cat
]
].
(newList size == 0) ifTrue:[^ nil].
newList add:'* all *'.
^ newList asOrderedCollection sort
"Modified: 7.6.1996 / 09:03:11 / stefan"
!
methodCategorySelection:lineNr
"user clicked on a method category line - show selectors"
self switchToMethodCategory:(methodCategoryListView selectionValue string).
"Modified: 22.10.1996 / 17:27:13 / cg"
!
methodCategorySelectionChanged
"method category selection has changed - update dependent views"
self withWaitCursorDo:[
currentMethod := currentSelector := nil.
self updateMethodList.
self updateCodeView.
currentMethodCategory notNil ifTrue:[
methodCategoryListView setSelectElement:currentMethodCategory
].
aspect isNil ifTrue:[
self setAcceptAndExplainActionsForMethod.
].
"/ this is now done in
"/ #updateMethodList
"/
"/ (variableListView notNil
"/ and:[variableListView hasSelection]) ifTrue:[
"/ self hilightMethodsInMethodCategoryList:false inMethodList:true.
"/ ]
]
"Created: 23.11.1995 / 14:17:38 / cg"
"Modified: 20.12.1996 / 16:51:09 / cg"
!
newMethodCategory:aString
|categories|
currentClass isNil ifTrue:[
^ self warn:'select/create a class first'.
].
categories := methodCategoryListView list.
categories isNil ifTrue:[categories := OrderedCollection new].
(categories includes:aString) ifFalse:[
categories add:aString.
categories sort.
methodCategoryListView contents:categories
].
currentMethodCategory := aString.
aspect := nil.
self methodCategorySelectionChanged
"Modified: 10.2.1996 / 13:07:32 / cg"
!
switchToMethodCategory:aCategory
|oldSelector|
oldSelector := currentSelector.
aspect := nil.
(fullProtocol not and:[currentClass isNil]) ifTrue:[^ self].
currentMethodCategory := aCategory.
self methodCategorySelectionChanged.
"if there is only one method, show it right away"
methodListView list size == 1 ifTrue:[
methodListView setSelection:1.
self methodSelection:1
] ifFalse:[
oldSelector notNil ifTrue:[
methodListView setSelectElement:oldSelector.
methodListView hasSelection ifTrue:[
self methodSelection:methodListView selection.
]
]
]
"Modified: 26.5.1996 / 15:07:07 / cg"
"Created: 4.6.1996 / 23:03:50 / cg"
!
updateMethodCategoryList
self updateMethodCategoryListWithScroll:true
!
updateMethodCategoryListWithScroll:scroll
|categories|
methodCategoryListView notNil ifTrue:[
fullProtocol ifTrue:[
currentClassHierarchy notNil ifTrue:[
categories := self listOfAllMethodCategoriesInFullProtocolHierarchy:actualClass
]
] ifFalse:[
currentClass notNil ifTrue:[
categories := self listOfAllMethodCategoriesInClass:actualClass
]
].
methodCategoryListView list = categories ifFalse:[
scroll ifTrue:[
methodCategoryListView contents:categories
] ifFalse:[
methodCategoryListView setContents:categories
].
currentMethodCategory notNil ifTrue:[
methodCategoryListView setSelectElement:currentMethodCategory
]
]
]
"Modified: 26.5.1996 / 15:03:13 / cg"
!
whenMethodCategorySelected:aBlock
self checkMethodCategorySelected ifTrue:[
self withWaitCursorDo:aBlock
]
! !
!BrowserView methodsFor:'method list menu'!
commonTraceHelperWith:aSelector
"install a break/trace or countPoint for the current method"
"/ not for unbound methods (i.e. obsolete)
currentMethod isNil ifTrue:[^ self].
currentMethod who isNil ifTrue:[
self warn:'method is no longer valid'.
^ self
].
currentMethod := MessageTracer perform:aSelector with:currentMethod.
Class withoutUpdatingChangesDo:[
currentClass changed:#methodTrap with:currentSelector.
]
"Modified: 7.3.1997 / 19:17:33 / cg"
!
commonTraceHelperWith:aSelector with:argument
"install a break/trace or countPoint for the current method"
currentMethod := MessageTracer perform:aSelector with:currentMethod with:argument.
Class withoutUpdatingChangesDo:[
currentClass changed:#methodTrap with:currentSelector.
]
"Modified: 8.1.1997 / 22:34:21 / cg"
!
methodAproposSearch
"launch an enterBox for a keyword search"
self askForSearchTitle:'keyword to search for (in selector & comment):'
openWith:#aproposSearch:in:
isSelector:true
searchArea:#class
"Modified: 11.11.1996 / 12:43:54 / cg"
!
methodBreakPoint
"set a breakpoint on the current method"
self commonTraceHelperWith:#trapMethod:
"Modified: 15.12.1995 / 17:35:12 / cg"
!
methodBreakPointInProcess
"set a breakpoint on the current method, which only triggers if
executed by some particular process."
|processes processNames box|
processes := ProcessorScheduler knownProcesses asOrderedCollection.
processes := processes select:[:aProcess |
aProcess notNil
and:[aProcess id notNil]
].
processes := processes sort:[:a :b | a id < b id].
processNames := processes collect:[:aProcess |
aProcess id printString , ' -> ' , aProcess nameOrId
].
"/ let user specify which one ...
box := ListSelectionBox new.
box noEnterField.
box list:processNames.
box label:'process selection'.
box title:(resources string:('break if method is executed by process:\\(current = ' , Processor activeProcess id printString , ')') withCRs).
box action:[:selection |
self commonTraceHelperWith:#trapMethod:inProcess:
with:(processes at:box selectionIndex)
].
box showAtPointer.
box destroy
"Created: 14.10.1996 / 15:40:53 / cg"
"Modified: 15.10.1996 / 12:51:28 / cg"
!
methodChangeCategory
"move the current method into another category -
nothing done here, but a query for the new category.
Remember the last category, to allow faster category change of a group of methods."
|box txt|
self checkMethodSelected ifFalse:[^ self].
actualClass isNil ifTrue:[
box := self
enterBoxTitle:''
okText:'change'
label:'change category'.
] ifFalse:[
|someCategories|
someCategories := actualClass categories sort.
box := self
listBoxTitle:''
okText:'change'
list:someCategories.
].
box title:(resources string:'change category from ''%1'' to:' with:currentMethod category).
lastMethodCategory isNil ifTrue:[
txt := currentMethod category.
] ifFalse:[
txt := lastMethodCategory
].
box initialText:txt.
box action:[:aString |
|method|
lastMethodCategory := aString.
method := currentMethod.
method category:aString asSymbol.
actualClass changed:#organization with:currentSelector.
method changed:#category.
actualClass addChangeRecordForMethodCategory:method category:aString.
self updateMethodCategoryListWithScroll:false.
self updateMethodListWithScroll:false
].
box label:(resources string:'change category').
box showAtPointer
"Created: 29.10.1995 / 19:59:22 / cg"
"Modified: 16.1.1997 / 00:16:29 / cg"
!
methodCompareWithPreviousVersion
"compare with previous version"
|prev v|
self checkMethodSelected ifFalse:[^ self].
prev := currentMethod previousVersion.
prev isNil ifTrue:[
self warn:'oops - previous version is gone'.
^ self
].
v := DiffTextView
openOn:codeView contents
label:(resources string:'code here')
and:prev source
label:'previous version'.
v label:'comparing ' , currentMethod whoString.
"Modified: 7.11.1996 / 18:53:55 / cg"
!
methodDecompile
"decompile the current methods bytecodes.
The Decompiler is delivered as an extra, and not normally
avaliable with the system."
|s|
self checkMethodSelected ifFalse:[^ self].
self checkSelectionChangeAllowed ifFalse:[^ self].
s := '' writeStream.
(currentMethod decompileTo:s) ifFalse:[
self warn:'No decompiler available'.
].
codeView contents:s contents.
codeView modified:false.
codeView acceptAction:nil.
codeView explainAction:nil.
"Modified: 16.4.1996 / 20:35:05 / cg"
!
methodFileOut
"file out the current method"
self checkMethodSelected ifFalse:[^ self].
self busyLabel:'saving:' with:currentSelector.
Class fileOutErrorSignal handle:[:ex |
self warn:'cannot create: %1' with:ex parameter.
ex return
] do:[
actualClass fileOutMethod:currentMethod.
].
self normalLabel.
!
methodGlobalReferends
"launch an enterBox for global symbol to search for"
self askForSearchTitle:'global variable to search users of:'
openWith:#browseReferendsOf:in:
isSelector:false
"/ self enterBoxForBrowseTitle:'global variable to browse users of:'
"/ action:[:aString |
"/ SystemBrowser browseReferendsOf:aString asSymbol
"/ ]
"Modified: 10.7.1996 / 10:37:37 / cg"
!
methodImplementors
"launch an enterBox for selector to search for"
self askForSearchTitle:'selector to browse implementors of:'
openWith:#browseImplementorsOf:in:
isSelector:true
"Modified: 10.7.1996 / 12:40:07 / cg"
!
methodInspect
"inspect the current method"
self checkMethodSelected ifFalse:[^ self].
currentMethod inspect.
"/ (actualClass compiledMethodAt:currentSelector) inspect.
"Modified: 4.6.1996 / 22:47:27 / cg"
!
methodLocalSuperSends
"launch a browser showing super sends in current class & subclasses"
self checkClassSelected ifFalse:[^ self].
self withSearchCursorDo:[
SystemBrowser browseSuperCallsUnder:currentClass
]
"Created: 23.11.1995 / 12:03:57 / cg"
"Modified: 23.11.1995 / 14:12:15 / cg"
!
methodMakeIgnored
"make the current method be invisible.
EXPERIMENTAL"
self methodPrivacy:#ignored
"Created: 13.12.1995 / 13:59:59 / cg"
!
methodMakePrivate
"make the current method private.
EXPERIMENTAL"
self methodPrivacy:#private
!
methodMakeProtected
"make the current method protected.
EXPERIMENTAL"
self methodPrivacy:#protected
!
methodMakePublic
"make the current method public.
EXPERIMENTAL"
self methodPrivacy:#public
!
methodMenu
"return a popupmenu as appropriate for the methodList"
<resource: #keyboard ( #Cmds #Cmdi #Cmdg #Cmdt #Cmda) >
|specialMenu m labels selectors shorties
newLabels newSelectors
mthdLabels mthdSelectors
brkLabels brkSelectors
fileLabels fileSelectors
searchLabels searchSelectors searchShorties
sepLocalLabels sepLocalSelectors
localSearchLabels localSearchSelectors|
currentMethod notNil ifTrue:[
currentMethod isWrapped ifTrue:[
(MessageTracer isCountingMemoryUsage:currentMethod) ifTrue:[
brkLabels := #(
'-'
'stop mem usage'
).
brkSelectors := #(
nil
methodStopMemoryUsage
)
] ifFalse:[
(MessageTracer isCounting:currentMethod) ifTrue:[
brkLabels := #(
'-'
'stop counting'
).
brkSelectors := #(
nil
methodStopCounting
)
] ifFalse:[
(MessageTracer isTiming:currentMethod) ifTrue:[
brkLabels := #(
'-'
'stop timing'
).
brkSelectors := #(
nil
methodStopTiming
)
] ifFalse:[
brkLabels := #(
'-'
'remove break/trace'
).
brkSelectors := #(
nil
methodRemoveBreakOrTrace
)
]
]
]
] ifFalse:[
brkLabels := #(
'-'
'breakpoint'
'breakpoint in ...'
'-'
'trace'
'trace sender'
'trace full walkback'
'-'
'start timing'
'start counting'
'start mem usage'
).
brkSelectors := #(
nil
methodBreakPoint
methodBreakPointInProcess
nil
methodTrace
methodTraceSender
methodTraceFull
nil
methodStartTiming
methodStartCounting
methodStartMemoryUsage
)
].
Method methodPrivacySupported ifTrue:[
labels := #(
'inspect method'
'compile to machine code'
'decompile'
'-'
'make public'
'make private'
'make protected'
'make ignored'
).
selectors := #(
methodInspect
methodSTCCompile
methodDecompile
nil
methodMakePublic
methodMakePrivate
methodMakeProtected
methodMakeIgnored
)
] ifFalse:[
labels := #(
'inspect method'
'compile to machine code'
'decompile'
).
selectors := #(
methodInspect
methodSTCCompile
methodDecompile
)
].
labels := labels , brkLabels.
selectors := selectors , brkSelectors.
specialMenu := PopUpMenu
labels:(resources array:labels)
selectors:selectors.
currentMethod isPublic ifTrue:[
specialMenu disable:#methodMakePublic
].
currentMethod isPrivate ifTrue:[
specialMenu disable:#methodMakePrivate
].
currentMethod isProtected ifTrue:[
specialMenu disable:#methodMakeProtected
].
currentMethod isIgnored ifTrue:[
specialMenu disable:#methodMakeIgnored
].
].
device ctrlDown ifTrue:[
currentMethod isNil ifTrue:[
methodListView flash.
^ nil
].
^ specialMenu
].
sepLocalLabels := sepLocalSelectors := #().
searchLabels := #(
'senders ...'
'implementors ...'
'globals ...'
'string search ...'
'apropos ...'
).
searchSelectors := #(
methodSenders
methodImplementors
methodGlobalReferends
methodStringSearch
methodAproposSearch
).
searchShorties := #(
Cmds
Cmdi
Cmdg
Cmdt
Cmda
).
"/ currentClass notNil ifTrue:[
"/ localSearchLabels := #(
"/ '-'
"/ 'local senders ...'
"/ 'local implementors ...'
"/ 'local super sends ...'
"/ 'local string search ...'
"/ 'local apropos ...'
"/ ).
"/ localSearchSelectors := #(
"/ nil
"/ methodLocalSenders
"/ methodLocalImplementors
"/ methodLocalSuperSends
"/ methodLocalStringSearch
"/ methodLocalAproposSearch
"/ ).
"/ ] ifFalse:[
"/ localSearchLabels := localSearchSelectors := #()
"/ ].
currentMethodCategory notNil ifTrue:[
sepLocalLabels := #('-'). sepLocalSelectors := #(nil).
newLabels := #(
'new method'
).
newSelectors := #(
methodNewMethod
).
] ifFalse:[
newLabels := newSelectors := #()
].
currentMethod notNil ifTrue:[
fileLabels := #(
'fileOut'
'printOut'
'-'
'SPAWN_METHOD'
'-'
).
fileSelectors := #(
methodFileOut
methodPrintOut
nil
methodSpawn
nil
).
sepLocalLabels := #('-'). sepLocalSelectors := #(nil).
mthdLabels := #(
'change category ...'
'move ...'
'remove'
'-'
'compare with previous'
'back to previous'
).
mthdSelectors := #(
methodChangeCategory
methodMove
methodRemove
nil
methodCompareWithPreviousVersion
methodPreviousVersion
).
] ifFalse:[
fileLabels := fileSelectors := #().
mthdLabels := mthdSelectors := #().
].
labels :=
fileLabels ,
searchLabels ,
"/ localSearchLabels ,
sepLocalLabels ,
newLabels ,
mthdLabels.
selectors :=
fileSelectors ,
searchSelectors ,
"/ localSearchSelectors ,
sepLocalSelectors ,
newSelectors ,
mthdSelectors .
shorties := (Array new:(fileSelectors size))
, searchShorties
, (Array new:(localSearchSelectors size
+ sepLocalSelectors size
+ newSelectors size
+ mthdSelectors size)).
specialMenu notNil ifTrue:[
labels := labels , #(
'='
'others'
).
selectors := selectors , #(
nil
#otherMenu
).
shorties := shorties , #( nil #'Ctrl')
].
m := PopUpMenu
labels:(resources array:labels)
selectors:selectors
accelerators:shorties.
specialMenu notNil ifTrue:[
m subMenuAt:#otherMenu put:specialMenu.
].
currentMethod notNil ifTrue:[
currentMethod isPrivate ifTrue:[
m disable:#methodMakePrivate
].
currentMethod isProtected ifTrue:[
m disable:#methodMakeProtected
].
currentMethod isPublic ifTrue:[
m disable:#methodMakePublic
].
currentMethod isIgnored ifTrue:[
m disable:#methodMakeIgnored
].
(currentMethod code notNil
or:[Compiler canCreateMachineCode not]) ifTrue:[
m disable:#methodSTCCompile
].
currentMethod byteCode isNil ifTrue:[
m disable:#methodDecompile
].
currentMethod previousVersion isNil ifTrue:[
m disable:#methodPreviousVersion.
m disable:#methodCompareWithPreviousVersion
]
].
^ m
"Created: 23.11.1995 / 12:02:29 / cg"
"Modified: 18.12.1995 / 16:20:07 / stefan"
"Modified: 17.1.1997 / 20:32:35 / cg"
!
methodMove
"move the current method into another class; typically a superclass"
|newClass newClassName sup initial movedMethod|
self checkMethodSelected ifFalse:[^ self].
(initial := lastMethodMoveClass) isNil ifTrue:[
(sup := currentClass superclass) notNil ifTrue:[
initial := sup name
] ifFalse:[
initial := nil.
].
].
newClassName := Dialog
request:(resources string:'move current method to which class:')
initialAnswer:initial
okLabel:(resources string:'move')
title:(resources string:'move method')
onCancel:nil.
newClassName isNil ifTrue:[^ self].
newClass := Smalltalk classNamed:newClassName.
newClass isNil ifTrue:[
self warn:'no such class'.
^ self
].
lastMethodMoveClass := newClassName.
showInstance ifFalse:[
newClass isMeta ifFalse:[
newClass := newClass class
]
].
movedMethod := newClass
compile:(currentMethod source)
classified:currentMethodCategory.
(movedMethod isNil or:[movedMethod == #Error]) ifTrue:[
self warn:'not moved - compilation failed due to a compilation error'.
^ self
].
self methodRemove
"Created: 13.12.1995 / 10:56:42 / cg"
"Modified: 23.1.1997 / 02:39:40 / cg"
!
methodNewMethod
"prepare for definition of a new method - put a template into
code view and define accept-action to compile it"
currentClass isNil ifTrue:[
^ self warn:'select/create a class first'.
].
currentMethodCategory isNil ifTrue:[
^ self warn:'select/create a method category first'.
].
currentMethod := currentSelector := nil.
methodListView setSelection:nil.
codeView contents:(self methodTemplate).
codeView modified:false.
self setAcceptAndExplainActionsForMethod.
"Modified: 25.5.1996 / 13:02:44 / cg"
!
methodPreviousVersion
"switch back to the previous version
(undo last change)"
|cls sel prev|
self checkMethodSelected ifFalse:[^ self].
prev := currentMethod previousVersion.
prev isNil ifTrue:[
self warn:'oops - previous version is gone'.
^ self
].
cls := currentMethod containingClass.
cls notNil ifTrue:[
sel := actualClass selectorAtMethod:currentMethod.
sel isNil ifTrue:[
self warn:'oops - cannot find methods selector (gone)'
] ifFalse:[
cls basicAddSelector:sel withMethod:prev.
currentMethod := prev.
self updateCodeView
].
] ifFalse:[
self warn:'oops - cannot find containing class'
]
"Modified: 7.11.1996 / 18:51:09 / cg"
!
methodPrintOut
"print out the current method"
|printStream|
self checkMethodSelected ifFalse:[^ self].
printStream := Printer new.
actualClass printOutSource:(currentMethod source) on:printStream.
printStream close
!
methodPrivacy:how
"change the current methods privacy.
EXPERIMENTAL"
|cls m|
self checkMethodSelected ifFalse:[^ self].
m := currentMethod.
m isWrapped ifTrue:[
m := m originalMethod
].
(how == m privacy ) ifFalse:[
m privacy:how.
cls := currentMethod containingClass.
cls notNil ifTrue:[
cls addChangeRecordForMethodPrivacy:currentMethod.
] ifFalse:[
self warn:'cannot write change record (no class)'
].
Class withoutUpdatingChangesDo:[
currentClass changed:#methodPrivacy with:currentSelector.
]
]
"Created: 29.10.1995 / 20:00:00 / cg"
"Modified: 8.1.1997 / 22:37:02 / cg"
!
methodRemove
"remove the current method"
|cls sel w|
self checkMethodSelected ifFalse:[^ self].
w := currentMethod who.
w notNil ifTrue:[
cls := w methodClass.
sel := w methodSelector.
cls notNil ifTrue:[
cls ~~ actualClass ifTrue:[
^ self warn:'oops - obsolete class; please reselect class ...'
].
sel notNil ifTrue:[
actualClass removeSelector:sel.
currentMethod := currentSelector := nil.
self updateMethodListWithScroll:false.
^ self
]
].
].
self warn:'cannot remove method (no class)'
!
methodRemoveBreakOrTrace
"turn off tracing of the current method"
(currentMethod notNil and:[currentMethod isWrapped]) ifTrue:[
self commonTraceHelperWith:#unwrapMethod:
]
!
methodSTCCompile
"compile the current method to machine code.
This is not supported on all machines, and never supported in
the demo version."
|prev|
self checkMethodSelected ifFalse:[^ self].
prev := Compiler stcCompilation:#always.
[
codeView accept.
] valueNowOrOnUnwindDo:[
Compiler stcCompilation:prev
].
!
methodSenders
"launch an enterBox for selector to search for"
self askForSearchTitle:'selector to browse senders of:'
openWith:#browseAllCallsOn:in:
isSelector:true
"Modified: 10.7.1996 / 10:33:29 / cg"
!
methodSpawn
"create a new SystemBrowser browsing current method,
or if the current selection is of the form 'class>>selector', spawan
a browser on that method."
|s sel selSymbol clsName clsSymbol cls isMeta w|
classMethodListView notNil ifTrue:[
s := classMethodListView selectionValue string.
clsName := self classNameFromClassMethodString:s.
sel := self selectorFromClassMethodString:s.
isMeta := false
].
self extractClassAndSelectorFromSelectionInto:[:c :s :m |
clsName := c.
sel := s.
isMeta := m
].
(sel notNil and:[clsName notNil]) ifTrue:[
(clsName knownAsSymbol and:[sel knownAsSymbol]) ifTrue:[
clsSymbol := clsName asSymbol.
(Smalltalk includesKey:clsSymbol) ifTrue:[
cls := Smalltalk at:clsSymbol.
isMeta ifTrue:[
cls := cls class
].
cls isBehavior ifFalse:[
cls := cls class
].
cls isBehavior ifTrue:[
selSymbol := sel asSymbol.
self withWaitCursorDo:[
(cls includesSelector:selSymbol) ifFalse:[
cls := cls class.
].
(cls includesSelector:selSymbol) ifTrue:[
SystemBrowser browseClass:cls selector:selSymbol.
^ self
].
w := ' does not implement #' , sel
]
] ifFalse:[
w := ' is not a class'
]
] ifFalse:[
w := ' is unknown'
]
] ifFalse:[
w := ' and/or ' , sel , ' are unknown'
].
self warn:(clsName , w).
^ self
].
self checkMethodSelected ifFalse:[
self warn:'select a method first'.
^ self
].
self withWaitCursorDo:[
w := currentMethod who.
SystemBrowser browseClass:(w methodClass) selector:(w methodSelector)
]
"Modified: 3.3.1997 / 15:11:51 / cg"
!
methodStartCounting
"set a countpoint on the current method"
self commonTraceHelperWith:#countMethod:
"Modified: 15.12.1995 / 10:53:59 / cg"
"Created: 15.12.1995 / 11:00:44 / cg"
!
methodStartMemoryUsage
"set a countpoint for memory usage on the current method"
self commonTraceHelperWith:#countMemoryUsageOfMethod:
"Created: 18.12.1995 / 16:00:22 / stefan"
!
methodStartTiming
"set a timing on the current method"
self commonTraceHelperWith:#timeMethod:
"Modified: 15.12.1995 / 10:53:59 / cg"
"Created: 17.6.1996 / 17:12:06 / cg"
!
methodStopCounting
"show the number of invocations & remove a countpoint on the current method"
"/ self information:'called ' , (MessageTracer executionCountOfMethod:currentMethod) printString , ' times.'.
self commonTraceHelperWith:#stopCountingMethod:
"Created: 15.12.1995 / 11:03:22 / cg"
"Modified: 15.12.1995 / 17:13:05 / cg"
!
methodStopMemoryUsage
"stop counting of memory usage for this method"
"/ self information:'called ' , (MessageTracer executionCountOfMethod:currentMethod) printString , ' times.'.
self commonTraceHelperWith:#stopCountingMemoryUsageOfMethod:
"Created: 18.12.1995 / 16:02:02 / stefan"
!
methodStopTiming
"show the execution times on the current method"
"/ self information:'called ' , (MessageTracer executionCountOfMethod:currentMethod) printString , ' times.'.
self commonTraceHelperWith:#stopTimingMethod:
"Modified: 15.12.1995 / 17:13:05 / cg"
"Created: 17.6.1996 / 17:12:27 / cg"
!
methodStringSearch
"launch an enterBox for string to search for"
self
askForSearchTitle:'string to search for in sources:'
openWith:#browseForString:in:
isSelector:true
searchArea:#class
"Modified: 11.11.1996 / 12:44:13 / cg"
!
methodTrace
"turn on tracing of the current method"
self commonTraceHelperWith:#traceMethod:
"Modified: 15.12.1995 / 17:34:53 / cg"
!
methodTraceFull
"turn on tracing of the current method"
self commonTraceHelperWith:#traceMethodFull:
"Modified: 15.12.1995 / 10:52:58 / cg"
"Created: 15.12.1995 / 18:20:33 / cg"
!
methodTraceSender
"turn on tracing of the current method"
self commonTraceHelperWith:#traceMethodSender:
"Modified: 15.12.1995 / 17:34:58 / cg"
! !
!BrowserView methodsFor:'method stuff'!
checkMethodSelected
currentMethod isNil ifTrue:[
self warn:'select a method first'.
^ false
].
^ true
!
listEntryForMethod:aMethod selector:selector
"answer a method list entry
(gimmic: adding a little image to breakPointed methods)"
|s icn|
s := aMethod printStringForBrowserWithSelector:selector.
aMethod isWrapped ifTrue:[
(s endsWith:' !!') ifTrue:[
s := s copyWithoutLast:2
].
(MessageTracer isTrapped:aMethod) ifTrue:[
icn := self stopIcon
] ifFalse:[
icn := self traceIcon
].
^ LabelAndIcon icon:icn string:s
].
^ s
"Created: 22.10.1996 / 19:51:00 / cg"
"Modified: 9.11.1996 / 19:49:49 / cg"
!
listOfAllSelectorsInCategory:aCategory inFullProtocolHierarchyOfClass:aClass
"answer a list of all selectors in a given method category
of the argument, aClass and its superclasses.
Used with fullProtocol browsing."
|newList otherSelectors allCategories|
newList := Set new.
otherSelectors := IdentitySet new.
allCategories := (aCategory = '* all *').
self classesInFullProtocolHierarchy:aClass do:[:c |
|searchCategory|
(aCategory = '* no category *') ifTrue:[
searchCategory := nil
] ifFalse:[
searchCategory := aCategory
].
c methodDictionary keysAndValuesDo:[:selector :aMethod |
(allCategories
or:[aMethod category = searchCategory]) ifTrue:[
(otherSelectors includes:selector) ifFalse:[
newList add:(self listEntryForMethod:aMethod selector:selector)
].
] ifFalse:[
otherSelectors add:selector
]
].
].
(newList size == 0) ifTrue:[^ nil].
^ newList asOrderedCollection sort:[:a :b | a string < b string]
"Modified: 5.6.1996 / 11:40:25 / stefan"
"Modified: 22.10.1996 / 19:58:16 / cg"
!
listOfAllSelectorsInCategory:aCategory ofClass:aClass
"answer a list of all selectors in a given method category
of the argument, aClass"
|newList searchCategory all|
all := (aCategory = '* all *').
(aCategory = '* no category *') ifTrue:[
searchCategory := nil
] ifFalse:[
searchCategory := aCategory
].
newList := OrderedCollection new.
aClass methodDictionary keysAndValuesDo:[:selector :aMethod |
(all or:[aMethod category = searchCategory]) ifTrue:[
newList add:(self listEntryForMethod:aMethod selector:selector)
]
].
(newList size == 0) ifTrue:[^ nil].
^ newList sort:[:a :b | a string < b string]
"Modified: 28.8.1995 / 21:53:34 / claus"
"Modified: 5.6.1996 / 11:42:51 / stefan"
"Modified: 22.10.1996 / 19:59:47 / cg"
!
methodSelection:lineNr
"user clicked on a method line - show code"
|selection sensor|
selection := methodListView selectionValue string.
"/ reselected with control ?
((sensor := self sensor) notNil and:[sensor ctrlDown]) ifTrue:[
selection = currentSelector ifTrue:[
"/ if there is a trace/break, remove it.
(currentMethod notNil and:[currentMethod isWrapped]) ifTrue:[
self methodRemoveBreakOrTrace.
^ self
]
].
].
self switchToMethod:selection.
"Modified: 7.3.1997 / 21:04:47 / cg"
!
methodSelectionChanged
"method selection has changed - update dependent views"
self withWaitCursorDo:[
|index cls|
aspect := nil.
self updateCodeView.
(currentMethod notNil and:[MessageTracer isCounting:currentMethod]) ifTrue:[
self updateMethodListWithScroll:false.
].
self setAcceptAndExplainActionsForMethod.
"
if there is any autoSearch string, do the search
"
autoSearch notNil ifTrue:[
codeView searchFwd:autoSearch startingAtLine:1 col:0 ifAbsent:[]
].
fullProtocol ifTrue:[
"
remove any bold attribute from classList
"
1 to:classListView list size do:[:i |
classListView attributeAt:i remove:#bold.
].
"
boldify the class where this method is implemented
"
currentMethod notNil ifTrue:[
cls := currentMethod containingClass.
index := classListView list indexOf:(cls name).
(index == 0
and:[cls isMeta
and:[cls name endsWith:' class']]) ifTrue:[
index := classListView list indexOf:(cls name copyWithoutLast:6).
].
index ~~ 0 ifTrue:[
classListView attributeAt:index add:#bold.
].
currentClass := acceptClass := cls.
]
].
]
"Created: 23.11.1995 / 14:17:44 / cg"
"Modified: 17.6.1996 / 16:47:50 / stefan"
"Modified: 1.11.1996 / 16:33:17 / cg"
!
methodTemplate
"return a method definition template"
^
'message selector and argument names
"comment stating purpose of this message"
|temporaries|
statement.
statement.
"
optional: comment giving example use
"
"
change above template into real code.
Then `accept'' either via the menu
or via the keyboard (usually CMD-A).
You do not need this template; you can also
select any existing methods code, change it,
and finally `accept''.
Or clear this text, type in the method from scratch
and install it with `accept''.
"
'
"Modified: 8.2.1996 / 13:45:58 / cg"
"Created: 8.2.1996 / 18:21:53 / cg"
!
switchToAnyMethodNamed:matchString
"switch (in the current classes hierarchy) to a method named matchString.
If there are more than one matches, switch to the first."
|aSelector classToStartSearch classToSearch aClass nm idx|
actualClass isNil ifTrue:[
currentClassHierarchy notNil ifTrue:[
classToStartSearch := currentClassHierarchy
]
] ifFalse:[
classToStartSearch := actualClass
].
classToStartSearch notNil ifTrue:[
"/ showInstance ifFalse:[
"/ classToStartSearch := classToStartSearch class
"/ ].
((matchString ~= '*') and:[matchString includesMatchCharacters]) ifTrue:[
classToSearch := classToStartSearch.
aClass := nil.
[classToSearch notNil and:[aClass isNil]] whileTrue:[
aSelector := classToSearch methodDictionary findFirstKey:[:element | matchString match:element].
aSelector notNil ifTrue:[
aClass := classToSearch
] ifFalse:[
classToSearch := classToSearch superclass
]
]
] ifFalse:[
aSelector := matchString asSymbolIfInterned.
aSelector notNil ifTrue:[
aClass := classToStartSearch whichClassIncludesSelector:aSelector.
]
].
aClass notNil ifTrue:[
nm := aClass name.
"/ showInstance ifFalse:[
"/ ((nm ~= 'Metaclass') and:[nm endsWith:' class']) ifTrue:[
"/ nm := nm copyWithoutLast:6 "copyTo:(nm size - 5)"
"/ ]
"/ ].
aClass ~~ actualClass ifTrue:[
self switchToClassNamed:nm.
].
self switchToMethodNamed:aSelector "matchString".
^ self.
]
].
self beep
"Modified: 17.6.1996 / 16:52:36 / stefan"
"Modified: 8.10.1996 / 22:06:01 / cg"
!
switchToMethod:aString
"user clicked on a method line - show code"
|selectorString selectorSymbol|
(fullProtocol not and:[currentClass isNil]) ifTrue:[^ self].
"
kludge: extract real selector
"
selectorString := aString withoutSpaces upTo:(Character space).
selectorSymbol := selectorString asSymbolIfInterned.
selectorSymbol isNil ifTrue:[
self beep.
^ self
].
fullProtocol ifTrue:[
currentMethod := currentSelector := nil.
"
search which class implements the selector
"
self classesInFullProtocolHierarchy:actualClass do:[:c |
(currentMethod isNil
and:[c includesSelector:selectorSymbol]) ifTrue:[
currentSelector := selectorSymbol.
currentMethod := c compiledMethodAt:selectorSymbol.
acceptClass := c
]
]
] ifFalse:[
currentSelector := selectorSymbol.
currentMethod := actualClass compiledMethodAt:selectorSymbol.
].
methodCategoryListView notNil ifTrue:[
currentMethod notNil ifTrue:[
(currentMethodCategory = currentMethod category) ifFalse:[
currentMethodCategory := currentMethod category.
methodCategoryListView setSelectElement:currentMethodCategory
]
]
].
self methodSelectionChanged
"Created: 4.6.1996 / 23:00:12 / cg"
"Modified: 22.6.1996 / 16:46:18 / cg"
!
switchToMethodNamed:matchString
"switch (in the current class) to a method named matchString.
If there are more than one matches, switch to the first."
|aSelector method cat classToSearch dict m idx|
currentClass notNil ifTrue:[
classToSearch := actualClass.
dict := classToSearch methodDictionary.
((matchString ~= '*') and:[matchString includesMatchCharacters]) ifTrue:[
aSelector := dict findFirstKey:[:element | matchString match:element].
aSelector notNil ifTrue:[
method := dict at:aSelector.
]
] ifFalse:[
aSelector := matchString.
method := dict at:matchString ifAbsent:[]
].
method notNil ifTrue:[
cat := method category.
cat isNil ifTrue:[cat := '* all *'].
methodCategoryListView setSelectElement:cat.
currentMethodCategory := cat.
self updateMethodCategoryListWithScroll:false.
self methodCategorySelectionChanged.
currentMethod := method.
currentSelector := aSelector.
m := aSelector , '*(*)'.
idx := methodListView list findFirst:[:line |
line = aSelector
or:[m match:line]].
methodListView setSelection:idx. "/ setSelectElement:aSelector.
self methodSelectionChanged.
^ self
]
].
self beep.
"Modified: 28.6.1996 / 20:28:56 / stefan"
"Modified: 15.7.1996 / 11:44:11 / cg"
!
updateClassMethodListWithScroll:scroll keepSelection:keep
|newList selection|
newList := OrderedCollection new.
selection := classMethodListView selection.
"/ update the list, caring for traps.
classMethodListView list do:[:entry |
|cls sel mthd s icn|
cls := self classFromClassMethodString:entry string.
sel := self selectorFromClassMethodString:entry string.
(cls isNil or:[sel isNil]) ifTrue:[
"/ method is gone ?
newList add:(entry string , ' ???')
] ifFalse:[
mthd := cls compiledMethodAt:(sel asSymbol).
mthd isNil ifTrue:[
newList add:cls name , ' ' , sel , ' ???'
] ifFalse:[
s := cls name , ' ' , (mthd printStringForBrowserWithSelector:sel).
mthd isWrapped ifTrue:[
(s endsWith:' !!') ifTrue:[
s := s copyWithoutLast:2
].
(s endsWith:' !!') ifTrue:[
s := s copyWithoutLast:2
].
(MessageTracer isTrapped:mthd) ifTrue:[
icn := self stopIcon
] ifFalse:[
icn := self traceIcon
].
newList add:(LabelAndIcon icon:icn string:s)
] ifFalse:[
newList add:s
].
].
].
].
classMethodListView setList:newList.
classMethodListView setSelection:selection.
"Modified: 18.12.1995 / 22:54:04 / stefan"
"Created: 3.3.1997 / 15:10:15 / cg"
"Modified: 4.3.1997 / 19:06:22 / cg"
!
updateMethodList
self updateMethodListWithScroll:true keepSelection:false
!
updateMethodListWithScroll:scroll
self updateMethodListWithScroll:scroll keepSelection:false
!
updateMethodListWithScroll:scroll keepSelection:keep
|selectors scr first last selection|
methodListView notNil ifTrue:[
selection := methodListView selection.
currentMethodCategory notNil ifTrue:[
fullProtocol ifTrue:[
selectors := self listOfAllSelectorsInCategory:currentMethodCategory
inFullProtocolHierarchyOfClass:actualClass
] ifFalse:[
selectors := self listOfAllSelectorsInCategory:currentMethodCategory
ofClass:actualClass
]
].
scr := scroll.
first := methodListView firstLineShown.
first ~~ 1 ifTrue:[
last := methodListView lastLineShown.
selectors size <= (last - first + 1) ifTrue:[
scr := true
]
].
scr ifTrue:[
methodListView list: "contents:" selectors
] ifFalse:[
methodListView setList: "setContents:" selectors
].
(variableListView notNil
and:[variableListView hasSelection]) ifTrue:[
self hilightMethodsInMethodList.
].
keep ifTrue:[
methodListView setSelection:selection.
].
^ self
].
classMethodListView notNil ifTrue:[
self updateClassMethodListWithScroll:scroll keepSelection:keep
].
"Modified: 18.12.1995 / 22:54:04 / stefan"
"Modified: 3.3.1997 / 15:10:42 / cg"
! !
!BrowserView methodsFor:'misc'!
instanceProtocol:aBoolean
"switch between instance and class protocol"
|onToggle offToggle|
showInstance ~~ aBoolean ifTrue:[
self checkSelectionChangeAllowed ifTrue:[
instanceToggle notNil ifTrue:[
aBoolean ifTrue:[
offToggle := classToggle.
onToggle := instanceToggle.
] ifFalse:[
onToggle := classToggle.
offToggle := instanceToggle.
].
onToggle turnOn.
offToggle turnOff.
].
showInstance := aBoolean.
(variableListView notNil
and:[variableListView hasSelection]) ifTrue:[
self unhilightMethodCategories.
self unhilightMethods.
variableListView setSelection:nil
].
fullProtocol ifTrue:[
showInstance ifTrue:[
actualClass := currentClassHierarchy.
] ifFalse:[
actualClass := currentClassHierarchy class.
].
acceptClass := actualClass.
self updateClassList.
self updateMethodCategoryListWithScroll:false.
self updateMethodListWithScroll:false.
self updateVariableList.
^ self
].
currentClass notNil ifTrue:[
self classSelectionChanged
].
codeView modified:false.
] ifFalse:[
aBoolean ifTrue:[
onToggle := classToggle.
offToggle := instanceToggle
] ifFalse:[
offToggle := classToggle.
onToggle := instanceToggle.
].
onToggle turnOn.
offToggle turnOff.
]
]
"Modified: 25.5.1996 / 13:02:41 / cg"
!
processName
"the name of my process - for the processMonitor only"
^ 'System Browser'.
!
showActivity:someMessage
"some activityNotification to be forwarded to the user;
show it in the windows title area here."
self busyLabel:someMessage with:nil
"Created: 16.12.1995 / 18:41:37 / cg"
"Modified: 23.4.1996 / 21:39:24 / cg"
!
updateCodeView
|code|
aspect == #hierarchy ifTrue:[
^ self classHierarchy
].
aspect == #classInstVars ifTrue:[
^ self classClassInstVars
].
aspect == #comment ifTrue:[
^ self classComment
].
aspect == #primitiveDefinitions ifTrue:[
^ self classPrimitiveDefinitions
].
aspect == #primitiveFunctions ifTrue:[
^ self classPrimitiveFunctions
].
aspect == #primitiveVariables ifTrue:[
^ self classPrimitiveVariables
].
aspect == #revisionInfo ifTrue:[
^ self classRevisionInfo
].
fullClass ifTrue:[
currentClass notNil ifTrue:[
code := currentClass source.
]
] ifFalse:[
aspect == #definition ifTrue:[
^ self classDefinition
].
currentMethod notNil ifTrue:[
(codeView acceptAction isNil
and:[actualClass notNil
and:[currentMethodCategory notNil]]) ifTrue:[
self setAcceptAndExplainActionsForMethod.
].
code := currentMethod source.
]
].
codeView contents:code.
codeView modified:false.
self normalLabel.
"Created: 23.11.1995 / 14:16:43 / cg"
"Modified: 21.3.1996 / 21:23:26 / cg"
! !
!BrowserView methodsFor:'namespace menu'!
nameSpaceMenu
|labels selectors|
labels := #('new namespace').
selectors := #(nameSpaceNewNameSpace).
(currentNamespace notNil
and:[currentNamespace ~~ Smalltalk
and:[currentNamespace ~= '* all *']]) ifTrue:[
"/ is it all empty ?
currentNamespace allClasses isEmpty ifTrue:[
labels := #('new namespace' '-' 'remove').
selectors := #(nameSpaceNewNameSpace nil nameSpaceRemove).
]
].
^ PopUpMenu
labels:(resources array:labels)
selectors:selectors
receiver:self.
"Created: 4.1.1997 / 23:51:38 / cg"
"Modified: 16.1.1997 / 01:06:22 / cg"
!
nameSpaceNewNameSpace
"create a namespace-definition prototype in codeview"
self classClassDefinitionTemplateFor:nil in:nil namespace:true private:false.
aspect := nil.
"Modified: 23.12.1996 / 12:47:06 / cg"
"Created: 23.12.1996 / 13:11:48 / cg"
!
nameSpaceRemove
"remove that nameSpace - but only if its empty"
(currentNamespace ~~ Smalltalk
and:[currentNamespace allClasses isEmpty]) ifTrue:[
self withWaitCursorDo:[
Smalltalk removeClass:currentNamespace.
allNamespaces := nil.
self setListOfNamespaces.
self changeNameSpaceTo:'* all *'.
namespaceList contents:'* all *'
]
].
"Modified: 5.1.1997 / 00:10:05 / cg"
! !
!BrowserView methodsFor:'namespace stuff'!
changeNameSpaceTo:nsName
|n selectedClass str selectedCategory|
nsName = '* all *' ifTrue:[
currentNamespace := nsName.
] ifFalse:[
n := Smalltalk at:nsName asSymbol.
n isNamespace ifTrue:[
currentNamespace := n.
] ifFalse:[
^ self
]
].
selectedClass := actualClass.
currentClass := actualClass := nil.
selectedCategory := currentClassCategory.
self updateClassCategoryListWithScroll:true.
selectedCategory notNil ifTrue:[
self classCategorySelectionChanged.
].
selectedClass notNil ifTrue:[
str := self displayedClassNameOf:selectedClass.
self switchToClassNamed:str.
(classListView list isNil
or:[(classListView list includes:str) not]) ifTrue:[
currentClassCategory := nil.
currentClass := nil.
aspect := nil.
self updateMethodCategoryList.
self updateMethodList.
self updateCodeView.
].
(classCategoryListView notNil and:[currentClass notNil]) ifTrue:[
(currentClassCategory = currentClass category) ifFalse:[
currentClassCategory := currentClass category.
classCategoryListView setSelectElement:currentClassCategory
]
].
]
"Created: 3.1.1997 / 11:11:13 / cg"
"Modified: 29.1.1997 / 18:33:42 / cg"
!
displayedClassNameOf:aClass
"depending on the current nameSpace, either show a classes
fullname or its name without the namespace prefix (if its in the current)"
|owner nm ns|
"/ in which nameSpace is that class (or its owner) ?
owner := aClass topOwningClass.
owner notNil ifTrue:[
ns := owner nameSpace.
] ifFalse:[
ns := aClass nameSpace.
].
"/ this 'cannot' happen (should always be Smalltalk)
ns isNil ifTrue:[
^ aClass name
].
currentNamespace = '* all *' ifTrue:[
(ns == Smalltalk) ifTrue:[
nm := aClass nameWithoutNameSpacePrefix.
^ nm
].
nm := aClass nameWithoutNameSpacePrefix.
^ ns name , '::' , nm "/ full name
"/ ^ aClass name "/ full name
].
nm := aClass nameWithoutNameSpacePrefix.
"/ is it in one of the selected namespaces ?
(self findClassNamedInNameSpace:nm) isNil ifTrue:[
^ ns name , '::' , nm "/ full name
].
currentNamespace = ns ifFalse:[
^ ns name , '::' , nm "/ full name
].
^ nm.
"Created: 20.12.1996 / 17:46:41 / cg"
"Modified: 5.1.1997 / 18:30:29 / cg"
!
listOfAllNamespaces
"return a list of all namespaces"
allNamespaces isNil ifTrue:[
allNamespaces := Namespace allNamespaces.
].
^ allNamespaces
"Created: 20.12.1996 / 19:18:03 / cg"
"Modified: 2.1.1997 / 20:18:43 / cg"
!
listOfNamespaces
"return a list of considered namespaces"
currentNamespace isNil ifTrue:[
^ Array with:Smalltalk
].
currentNamespace = '* all *' ifTrue:[
^ self listOfAllNamespaces
].
^ Array with:currentNamespace
"Created: 26.10.1996 / 11:25:39 / cg"
"Modified: 20.12.1996 / 19:18:18 / cg"
!
setListOfNamespaces
|l hasSmalltalk|
namespaceList isNil ifTrue:[ ^ self ].
l := self listOfAllNamespaces collect:[:ns | ns name].
l := l asOrderedCollection.
hasSmalltalk := true.
l remove:'Smalltalk' ifAbsent:[hasSmalltalk := false].
l sort.
l addFirst:'-'.
hasSmalltalk ifTrue:[
l addFirst:'Smalltalk'
].
l addFirst:'* all *'.
namespaceList list:l
"Modified: 20.12.1996 / 19:18:29 / cg"
!
updateNamespaceList
allNamespaces := nil.
namespaceList notNil ifTrue:[
self setListOfNamespaces
].
"Created: 8.1.1997 / 10:54:03 / cg"
! !
!BrowserView methodsFor:'private'!
askAndBrowseMethodCategory:title action:aBlock
"convenient method: setup enterBox with initial being current method category"
|sel box|
box := self
enterBoxTitle:title
okText:'browse'
label:'browse category'.
sel := codeView selection.
sel isNil ifTrue:[
currentMethodCategory notNil ifTrue:[
sel := currentMethodCategory
]
].
sel notNil ifTrue:[
box initialText:(sel asString withoutSpaces)
].
box action:[:aString | self withWaitCursorDo:[aBlock value:aString]].
box showAtPointer
"Modified: 15.1.1997 / 23:10:05 / cg"
!
askForMethodCategory
|someCategories box txt retVal|
someCategories := actualClass categories sort.
box := self listBoxTitle:'accept in which method category ?' okText:'accept' list:someCategories.
lastMethodCategory isNil ifTrue:[
txt := 'new methods'
] ifFalse:[
txt := lastMethodCategory
].
box initialText:txt.
box action:[:aString | aString notEmpty ifTrue:[retVal := aString] ].
box showAtPointer.
^ retVal
"Modified: 27.3.1996 / 15:33:46 / cg"
!
askForSearchSelectorTitle:title openWith:aSelector
"convenient method: setup enterBox with text from codeView or selected
method for browsing based on a selector. Set action and launch box"
^ self
askForSearchTitle:title
openWith:aSelector
isSelector:true
"Modified: 11.11.1996 / 12:43:24 / cg"
!
askForSearchTitle:title openWith:aSelector isSelector:isSelector
"convenient method: setup enterBox with text from codeView or selected
method for browsing based on a selector. Set action and launch box"
^ self
askForSearchTitle:title
openWith:aSelector
isSelector:isSelector
searchArea:#everywhere
"Modified: 11.11.1996 / 12:42:46 / cg"
!
askForSearchTitle:title openWith:aSelector isSelector:isSelector searchArea:whereDefault
"convenient method: setup enterBox with text from codeView or selected
method for browsing based on a selector. Set action and launch box.
SearchArea may be one of #everywhere, #classCategory, #class or #classHierarchy"
|box grp panel selectorHolder where whereChannel b sel classes|
isSelector ifTrue:[
sel := self selectorToSearchFor.
] ifFalse:[
sel := self stringToSearchFor.
].
selectorHolder := sel asValue.
box := Dialog new.
(box addTextLabel:(resources string:title)) adjust:#left.
(box addInputFieldOn:(selectorHolder) tabable:true) selectAll.
(currentClassCategory notNil or:[currentClass notNil]) ifTrue:[
box addHorizontalLine.
box addVerticalSpace.
(box addTextLabel:(resources string:'search in:')) adjust:#left.
panel := VerticalPanelView "HorizontalPanelView" new.
panel horizontalLayout:#fitSpace.
grp := RadioButtonGroup new.
b := CheckBox "RadioButton" label:(resources string:'everywhere').
panel add:b. grp add:b.
box makeTabable:b.
currentClassCategory notNil ifTrue:[
b := CheckBox "RadioButton" label:(resources string:'class category').
panel add:b. grp add:b.
box makeTabable:b.
].
currentClass notNil ifTrue:[
b := CheckBox "RadioButton" label:(resources string:'class').
panel add:b.grp add:b.
box makeTabable:b.
b := CheckBox "RadioButton" label:(resources string:'class & subclasses').
panel add:b. grp add:b.
box makeTabable:b.
].
whereDefault notNil ifTrue:[
where := (#(everywhere classCategory class classHierarchy)
indexOf:whereDefault).
where == 0 ifTrue:[where := 1].
] ifFalse:[
where := 1.
].
grp value:where.
whereChannel := grp.
box addComponent:panel indent:0. "/ panel has its own idea of indenting
box addVerticalSpace.
box addHorizontalLine.
] ifFalse:[
whereChannel := 1 asValue.
].
box addAbortButton.
box addOkButtonLabelled:(resources string:'browse').
box label:(resources string:'search').
box open.
box accepted ifTrue:[
sel := selectorHolder value.
where := whereChannel value.
where == 1 ifTrue:[
classes := Smalltalk allClasses.
] ifFalse:[
where == 2 ifTrue:[
classes := Smalltalk allClassesInCategory:currentClassCategory
] ifFalse:[
where == 3 ifTrue:[
classes := Array with:currentClass
] ifFalse:[
classes := currentClass withAllSubclasses
]
]
].
self withSearchCursorDo:[
SystemBrowser perform:aSelector with:sel with:classes
]
]
"Created: 11.11.1996 / 12:42:14 / cg"
"Modified: 3.3.1997 / 14:47:16 / cg"
!
busyLabel:what with:someArgument
"set the title for some warning"
self label:('System Browser - ' , (resources string:what with:someArgument))
!
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"
|what m src1 src2 list1 list2 v|
codeView modified ifFalse:[
^ true
].
(currentMethod notNil and:[actualClass notNil]) ifTrue:[
self withWaitCursorDo:[
m := actualClass compiledMethodAt:currentSelector.
m notNil ifTrue:[
(src1 := m source) = (src2 := codeView contents) ifFalse:[
list1 := src1 asCollectionOfLines collect:[:line | line isNil ifTrue:['']
ifFalse:[
line
withoutTrailingSeparators
withTabsExpanded
]
].
list2 := src2 asCollectionOfLines collect:[:line | line isNil ifTrue:['']
ifFalse:[
line
withoutTrailingSeparators
withTabsExpanded
]
].
HistoryManager notNil ifTrue:[
list1 := HistoryManager withoutHistoryLines:list1 asStringCollection asString.
list2 := HistoryManager withoutHistoryLines:list2 asStringCollection asString.
].
list1 = list2 ifFalse:[
what := self checkSelectionChangeAllowedWithCompare:true.
what == #compare ifTrue:[
v := DiffTextView
openOn:src2
label:(resources string:'code here (to be accepted ?)')
and:src1
label:(resources string:'methods actual code').
v label:(resources string:'comparing method versions').
^ false
].
^ what
].
].
^ true
]
]
].
^ self checkSelectionChangeAllowedWithCompare:false
"Created: 24.11.1995 / 11:03:33 / cg"
"Modified: 18.1.1997 / 14:46:39 / cg"
!
checkSelectionChangeAllowedWithCompare:compareOffered
"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"
|action labels values|
codeView modified ifFalse:[
^ true
].
compareOffered ifTrue:[
labels := #('cancel' 'compare' 'accept' 'continue').
values := #(false #compare #accept true).
] ifFalse:[
labels := #('cancel' 'accept' 'continue').
values := #(false #accept true).
].
action := OptionBox
request:(resources at:'text has not been accepted.\\Your modifications will be lost when continuing.') withCRs
label:(resources string:'Attention')
form:(WarningBox iconBitmap)
buttonLabels:(resources array:labels)
values:values
default:true.
action ~~ #accept ifTrue:[
^ action
].
codeView accept.
^ true
"Created: 24.11.1995 / 10:54:46 / cg"
"Modified: 20.2.1996 / 20:47:51 / cg"
!
classHierarchyOf:aClass level:level do:aBlock using:subclassDictionary removeFrom:remainSet
"evaluate the 2-arg block for every subclass of aClass,
passing class and nesting level to the block."
|names subclasses|
remainSet remove:aClass ifAbsent:[].
aBlock value:aClass value:level.
subclasses := subclassDictionary 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:subclassDictionary
removeFrom:remainSet
]
]
"Created: 20.12.1996 / 17:05:06 / cg"
"Modified: 5.1.1997 / 18:45:41 / cg"
!
classHierarchyOf:topClass withAutoloaded:withAutoloaded do:aBlock
"evaluate the 2-arg block for every class,
starting at Object; passing class and nesting level to the block."
|classes s subclassDict l remaining allNameSpaces nameSpaceList|
classes := IdentitySet new.
"/ first, collect the list of classes to consider
"/ thats all classes which are in the selected NameSpaces,
"/ or private ones, owned by a class which is
"/ also all of its superclasses are added.
allNameSpaces := (currentNamespace = '* all *').
nameSpaceList := self listOfNamespaces.
Smalltalk allBehaviorsDo:[:aClass |
|actualNamespace match owner|
aClass isMeta ifFalse:[
(aClass isNamespace not
or:[aClass == Smalltalk]) ifTrue:[
match := allNameSpaces.
match ifFalse:[
(owner := aClass topOwningClass) notNil ifTrue:[
actualNamespace := owner nameSpace
] ifFalse:[
actualNamespace := aClass nameSpace.
].
match := nameSpaceList includesIdentical:actualNamespace.
].
match ifTrue:[
classes addAll:(aClass withAllSuperclasses).
]
]
]
].
"/ now, generate a dictionary, which associates a set of subclasses
"/ to each ...
subclassDict := IdentityDictionary new:classes size.
classes do:[:aClass |
s := aClass superclass.
s notNil ifTrue:[
l := subclassDict at:s ifAbsent:[nil].
l isNil ifTrue:[
l := OrderedCollection new:5.
subclassDict at:s put:l
].
l add:aClass
]
].
"/
"/ walk this ..
"/
remaining := classes.
self classHierarchyOf:topClass level:0 do:aBlock using:subclassDict removeFrom:remaining.
"/
"/ if autoloaded classes are wanted ...
"/
withAutoloaded ifTrue:[
(remaining includes:Autoload) ifTrue:[
self classHierarchyOf:Autoload level:0 do:aBlock using:subclassDict removeFrom:remaining.
].
(remaining asSortedCollection:[:a :b | a name < b name]) do:[:aNilSubclass |
aBlock value:aNilSubclass value:0
]
].
"Created: 28.5.1996 / 13:46:23 / cg"
"Modified: 5.1.1997 / 18:44:50 / cg"
!
classesInFullProtocolHierarchy:aClass do:aBlock
"evaluate aBlock for all non-striked out classes in
the hierarchy"
|index|
index := (classListView list size).
aClass withAllSuperclasses do:[:c |
(classListView isInSelection:index) ifFalse:[
aBlock value:c
].
index := index - 1
]
!
classesInHierarchy:aClass do:aBlock
|index|
index := (classListView list size).
aClass withAllSuperclasses do:[:c |
(classListView isInSelection:index) ifFalse:[
aBlock value:c
].
index := index - 1
]
!
compileCode:someCode
(ReadStream on:someCode) fileIn
!
enterBoxForCodeSelectionTitle:title okText:okText
"convenient method: setup enterBox with text from codeview"
|sel box|
box := self
enterBoxTitle:(resources string:title)
okText:(resources string:okText).
sel := codeView selection.
sel notNil ifTrue:[
box initialText:(sel asString withoutSeparators)
].
^ box
"Modified: 15.1.1997 / 23:09:11 / cg"
!
enterBoxForSearchSelectorTitle:title
"convenient method: setup enterBox with text from codeView or selected
method for browsing based on a selector"
|box|
box := self
enterBoxTitle:title
okText:'search'
label:'search selector'.
box initialText:(self selectorToSearchFor).
^ box
"Modified: 15.1.1997 / 23:10:26 / cg"
!
enterBoxTitle:title okText:okText
"convenient method: setup enterBox"
|box|
box := EnterBox new.
box title:(resources string:title) okText:(resources string:okText).
^ box
!
enterBoxTitle:title okText:okText label:label
"convenient method: setup enterBox"
|box|
box := EnterBox new.
box label:(resources string:label).
box title:(resources string:title)
okText:(resources string:okText).
^ box
"Created: 15.1.1997 / 23:01:04 / cg"
"Modified: 16.1.1997 / 00:26:31 / cg"
!
enterBoxTitle:title okText:okText label:label list:aList
"convenient method: setup enterBox"
|box fieldHolder|
fieldHolder := ValueHolder new.
box := DialogBox new.
box label:(resources string:label).
(box addTextLabel:(resources string:title)) adjust:#left.
box addVerticalSpace.
aList isNil ifTrue:[
box addInputFieldOn:fieldHolder.
] ifFalse:[
(box addComboBoxOn:fieldHolder) list:aList
].
box addVerticalSpace:15.
box addAbortButton;
addOkButtonLabelled:(resources string:okText).
box aspectAt:#fieldValue put:fieldHolder.
"/ box showAtPointer.
"/
"/ box := EnterBox new.
"/ box label:(resources string:label).
"/ box title:(resources string:title)
"/ okText:(resources string:okText).
^ box
"Created: 15.1.1997 / 23:01:04 / cg"
"Modified: 16.1.1997 / 20:13:28 / cg"
!
extractClassAndSelectorFromSelectionInto:aBlock
"given a string which can be either 'class>>sel' or
'class sel', extract className and selector, and call aBlock with
the result."
|sel clsName isMeta sep s|
sel := codeView selection.
sel notNil ifTrue:[
sel := sel asString withoutSeparators.
('*>>*' match:sel) ifTrue:[
sep := $>
] ifFalse:[
('* *' match:sel) ifTrue:[
sep := Character space
]
].
sep notNil ifTrue:[
"
extract class/sel from selection
"
s := ReadStream on:sel.
clsName := s upTo:sep.
[s peek == sep] whileTrue:[s next].
sel := s upToEnd.
(clsName endsWith:' class') ifTrue:[
isMeta := true.
clsName := clsName copyWithoutLast:6 "copyTo:(clsName size - 5)"
] ifFalse:[
isMeta := false
].
]
].
aBlock value:clsName value:sel value:isMeta
"Modified: 17.6.1996 / 16:52:14 / stefan"
!
findClassNamed:aClassName
"search through namespaces for aClassName."
|nm nameSym cls meta|
meta := false.
nm := aClassName.
(nm endsWith:' class') ifTrue:[
meta := true.
nm := nm copyWithoutLast:6.
].
nameSym := nm asSymbol.
currentNamespace = '* all *' ifTrue:[
(cls := Smalltalk at:nameSym) notNil ifTrue:[
meta ifTrue:[^ cls class].
^ cls
]
].
self listOfNamespaces do:[:aNamespace |
(cls := aNamespace at:nameSym) notNil ifTrue:[
meta ifTrue:[^ cls class].
^ cls
]
].
currentNamespace ~= '* all *' ifTrue:[
(cls := Smalltalk at:nameSym) notNil ifTrue:[
meta ifTrue:[^ cls class].
^ cls
]
].
(nm startsWith:'Smalltalk::') ifTrue:[
cls := Smalltalk classNamed:(nm copyFrom:'Smalltalk::' size + 1).
cls notNil ifTrue:[
meta ifTrue:[^ cls class].
^ cls
]
].
^ nil
"Created: 20.12.1996 / 15:39:38 / cg"
"Modified: 23.1.1997 / 14:21:00 / cg"
!
findClassNamedInNameSpace:aClassName
"search through current namespaces for aClassName.
Return the class or nil, if not found."
|cls owner|
self listOfNamespaces do:[:aNamespace |
(cls := aNamespace at:aClassName asSymbol) notNil ifTrue:[
(owner := cls topOwningClass) notNil ifTrue:[
owner nameSpace == aNamespace ifTrue:[
^ cls
]
] ifFalse:[
cls nameSpace == aNamespace ifTrue:[
^ cls
]
]
]
].
^ nil
"Created: 20.12.1996 / 17:41:54 / cg"
"Modified: 3.1.1997 / 19:30:53 / cg"
!
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
!
listBoxForCodeSelectionTitle:title okText:okText
"convenient method: setup listBox with text from codeview"
|sel box|
box := self listBoxTitle:title okText:okText list:nil.
sel := codeView selection.
sel notNil ifTrue:[
box initialText:(sel asString withoutSeparators)
].
^ box
!
listBoxTitle:title okText:okText list:aList
"convenient method: setup a listBox & return it"
|box|
box := ListSelectionBox
title:(resources string:title)
okText:(resources string:okText)
action:nil.
box list:aList.
^ box
!
normalLabel
"set the normal (inactive) window- and icon labels"
|l il|
myLabel notNil ifTrue:[
"if I have been given an explicit label,
and its not the default, take that one"
myLabel ~= 'System Browser' ifTrue:[
l := il := myLabel
]
].
l isNil ifTrue:[
l := resources string:'System Browser'.
currentClass notNil ifTrue:[
"/ l := l, ': ', currentClass name.
l := self displayedClassNameOf:currentClass.
classListView isNil ifTrue:[
currentSelector notNil ifTrue:[
l := l , ' ' , currentSelector
]
] ifFalse:[
currentClass isLoaded ifFalse:[
l := l , ' (unloaded)'
]
].
il := currentClass nameWithoutPrefix
] ifFalse:[
il := l.
]
].
self label:l.
self iconLabel:il.
"Modified: 4.1.1997 / 14:37:08 / cg"
!
releaseClass
|cls meta|
currentClass notNil ifTrue:[
cls := currentClass.
cls isMeta ifTrue:[
meta := cls.
cls := meta soleInstance
] ifFalse:[
meta := cls class
].
cls removeDependent:self.
meta removeDependent:self.
].
"Created: 13.12.1995 / 15:32:21 / cg"
!
selectorToSearchFor
"look in codeView and methodListView for a search-string when searching for selectors"
|sel t|
sel := codeView selection.
sel notNil ifTrue:[
sel := sel asString.
t := Parser selectorInExpression:sel.
t notNil ifTrue:[
sel := t
].
sel := sel withoutSpaces.
sel == #>> ifTrue:[
"oops - thats probably not what we want here ..."
self extractClassAndSelectorFromSelectionInto:[:c :s :m |
sel := s
]
]
] ifFalse:[
methodListView notNil ifTrue:[
methodListView selection notNil ifTrue:[
sel := methodListView selectionValue string
]
] ifFalse:[
classMethodListView notNil ifTrue:[
classMethodListView selection notNil ifTrue:[
sel := classMethodListView selectionValue string.
].
sel notNil ifTrue:[
sel := self selectorFromClassMethodString:sel
]
]
].
sel notNil ifTrue:[
sel := sel withoutSpaces upTo:(Character space)
] ifFalse:[
sel := ''
]
].
^ sel string
"Modified: 22.10.1996 / 17:29:53 / cg"
!
setAcceptAndExplainActionsForMethod
"tell the codeView what to do on accept and explain"
codeView acceptAction:[:theCode |
|cat cls rslt|
codeView cursor:Cursor execute.
(cat := currentMethodCategory) = '* all *' ifTrue:[
"must check from which category this code came from ...
... thanks to Arno for pointing this out"
cat := self askForMethodCategory.
].
(cat notNil and:[cat notEmpty]) ifTrue:[
fullProtocol ifTrue:[
cls := acceptClass
].
cls isNil ifTrue:[
cls := actualClass
].
Object abortSignal catch:[
lockUpdates := true.
rslt := actualClass compilerClass
compile:theCode asString
forClass:cls
inCategory:cat
notifying:codeView.
codeView modified:false.
currentMethod := actualClass compiledMethodAt:currentSelector.
self updateMethodListWithScroll:false keepSelection:(rslt == currentMethod).
self normalLabel.
].
lockUpdates := false.
].
codeView cursor:Cursor normal.
].
codeView explainAction:[:theCode :theSelection |
self showExplanation:(Explainer
explain:theSelection
in:theCode
forClass:actualClass)
].
"Modified: 16.1.1997 / 11:00:51 / cg"
!
setDoitActionForClass
"tell the codeView what to do on doIt"
"set self for doits. This allows accessing the current class
as self, and access to the class variables by name.
"
codeView doItAction:[:theCode |
|compiler ns|
currentClass notNil ifTrue:[
ns := currentClass nameSpace
] ifFalse:[
ns := nil
].
Class nameSpaceQuerySignal handle:[:ex |
ns isNil ifTrue:[
ex reject
].
ex proceedWith:ns
] do:[
currentClass isNil ifTrue:[
compiler := Compiler
] ifFalse:[
compiler := currentClass evaluatorClass
].
compiler
evaluate:theCode
in:nil
receiver:currentClass
notifying:codeView
logged:false
ifFail:nil
]
].
"Modified: 10.2.1997 / 14:17:15 / cg"
!
setSearchPattern:aString
codeView setSearchPattern:aString
!
showExplanation:someText
"show explanation from Parser"
self information:someText
!
stopIcon
"answer an icon to mark breakPointed methods"
|stopIcon|
StopIcon notNil ifTrue:[^ StopIcon].
stopIcon := Depth1Image
width:16
height:16
fromArray:#(
2r00000000 2r00000000
2r00000111 2r11100000
2r00001111 2r11110000
2r00011111 2r11111000
2r00111110 2r01111100
2r01111110 2r01111110
2r01111110 2r01111110
2r01111110 2r01111110
2r01111110 2r01111110
2r01111110 2r01111110
2r01111111 2r11111110
2r00111110 2r01111100
2r00011110 2r01111000
2r00001111 2r11110000
2r00000111 2r11100000
2r00000000 2r00000000
).
stopIcon mask:(Depth1Image
width:16
height:16
fromArray:#(
2r00000000 2r00000000
2r00000111 2r11100000
2r00001111 2r11110000
2r00011111 2r11111000
2r00111111 2r11111100
2r01111111 2r11111110
2r01111111 2r11111110
2r01111111 2r11111110
2r01111111 2r11111110
2r01111111 2r11111110
2r01111111 2r11111110
2r00111111 2r11111100
2r00011111 2r11111000
2r00001111 2r11110000
2r00000111 2r11100000
2r00000000 2r00000000
)).
stopIcon colorMap:(Array with:Color white with:Color red).
StopIcon := stopIcon.
^ stopIcon
"Created: 22.10.1996 / 18:03:38 / cg"
"Modified: 9.11.1996 / 19:47:51 / cg"
!
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
!
traceIcon
"answer an icon to mark traced methods"
|traceIcon|
TraceIcon notNil ifTrue:[^ TraceIcon].
traceIcon := Depth1Image
width:16
height:16
fromArray:#(
2r00000000 2r00000000
2r01111111 2r11111110
2r01111111 2r11111110
2r00110000 2r00001100
2r00110000 2r00001100
2r00011000 2r00011000
2r00011000 2r00011000
2r00001100 2r00110000
2r00001100 2r00110000
2r00000110 2r01100000
2r00000110 2r01100000
2r00000011 2r11000000
2r00000011 2r11000000
2r00000001 2r10000000
2r00000001 2r10000000
2r00000000 2r00000000
).
traceIcon mask:(Depth1Image
width:16
height:16
fromArray:#(
2r00000000 2r00000000
2r01111111 2r11111110
2r01111111 2r11111110
2r00111111 2r11111100
2r00111111 2r11111100
2r00011111 2r11111000
2r00011111 2r11111000
2r00001111 2r11110000
2r00001111 2r11110000
2r00000111 2r11100000
2r00000111 2r11100000
2r00000011 2r11000000
2r00000011 2r11000000
2r00000001 2r10000000
2r00000001 2r10000000
2r00000000 2r00000000
)).
traceIcon colorMap:(Array with:Color white with:Color red).
TraceIcon := traceIcon.
^ traceIcon
"Created: 22.10.1996 / 18:04:14 / cg"
"Modified: 9.11.1996 / 19:48:18 / cg"
!
warnLabel:what
"set the title for some warning"
self label:('System Browser WARNING: ' , what)
!
withSearchCursorDo:aBlock
^ self withCursor:(Cursor questionMark) do:aBlock
"Created: 23.11.1995 / 14:11:14 / cg"
! !
!BrowserView methodsFor:'unused'!
listOfAllMethodCategoriesInHierarchy:aClass
"answer a list of all method categories of the argument, aClass,
and all of its superclasses"
|newList cat|
newList := Set new.
self classesInHierarchy:aClass do:[:c |
c methodDictionary do:[:aMethod |
cat := aMethod category.
cat isNil ifTrue:[
cat := '* no category *'
].
newList add:cat
]
].
(newList size == 0) ifTrue:[^ nil].
newList add:'* all *'.
^ newList asOrderedCollection sort
"Modified: 7.6.1996 / 09:03:22 / stefan"
!
listOfAllSelectorsInCategory:aCategory inHierarchyOfClass:aClass
"answer a list of all selectors in a given method category
of the argument, aClass and its superclasses"
|newList|
newList := Set new.
self classesInHierarchy:aClass do:[:c |
|searchCategory|
(aCategory = '* all *') ifTrue:[
newList addAll:(c methodDictionary keys)
] ifFalse:[
(aCategory = '* no category *') ifTrue:[
searchCategory := nil
] ifFalse:[
searchCategory := aCategory
].
c methodDictionary keysAndValuesDo:[:selector :aMethod |
(aMethod category = searchCategory) ifTrue:[
newList add:selector
]
]
].
].
(newList size == 0) ifTrue:[^ nil].
^ newList asOrderedCollection sort
"Modified: 5.6.1996 / 11:42:12 / stefan"
! !
!BrowserView methodsFor:'variable list menu'!
allClassOrInstVarRefsTitle:title access:access mods:modifications
"show an enterbox for instVar to search for"
self doClassMenu:[:currentClass |
|box|
box := self enterBoxForVariableSearch:title.
box action:[:aVariableName |
|homeClass|
aVariableName isEmpty ifFalse:[
self withSearchCursorDo:[
homeClass := self findClassOfVariable:aVariableName accessWith:access.
access == #classVarNames ifTrue:[
SystemBrowser
browseClassRefsTo:aVariableName
under:homeClass
modificationsOnly:modifications
] ifFalse:[
SystemBrowser
browseInstRefsTo:aVariableName
under:homeClass
modificationsOnly:modifications
]
]
]
].
box showAtPointer
]
"Created: 23.11.1995 / 14:13:24 / cg"
!
allClassVarMods
"show an enterbox for classVar to search for"
self allClassOrInstVarRefsTitle:'class variable to browse modifications of:'
access:#classVarNames
mods:true
!
allClassVarRefs
"show an enterbox for classVar to search for"
self allClassOrInstVarRefsTitle:'class variable to browse references to:'
access:#classVarNames
mods:false
!
allInstVarMods
"show an enterbox for instVar to search for"
self allClassOrInstVarRefsTitle:'instance variable to browse modifications of:'
access:#instVarNames
mods:true
!
allInstVarRefs
"show an enterbox for instVar to search for"
self allClassOrInstVarRefsTitle:'instance variable to browse references to:'
access:#instVarNames
mods:false
!
classVarMods
"show an enterbox for classVar to search for"
self classVarRefsOrModsTitle:'class variable to browse modifications of:'
mods:true
!
classVarRefs
"show an enterbox for classVar to search for"
self classVarRefsOrModsTitle:'class variable to browse references to:'
mods:false
!
classVarRefsOrModsTitle:title mods:mods
"show an enterbox for classVar to search for"
self doClassMenu:[:currentClass |
|box|
box := self enterBoxForVariableSearch:title.
box action:[:aString |
aString notEmpty ifTrue:[
self withSearchCursorDo:[
SystemBrowser
browseClassRefsTo:aString
in:(Array with:currentClass)
modificationsOnly:mods
]
]
].
box showAtPointer
]
"Created: 23.11.1995 / 14:12:56 / cg"
!
enterBoxForVariableSearch:title
|box sel|
box := self enterBoxForCodeSelectionTitle:title okText:'browse'.
variableListView notNil ifTrue:[
codeView hasSelection ifFalse:[
(sel := variableListView selectionValue) notNil ifTrue:[
(sel startsWith:'---') ifFalse:[
box initialText:sel
]
]
]
].
^ box
!
instVarMods
"show an enterbox for instVar to search for"
self instVarRefsOrModsTitle:'instance variable to browse modifications of:'
mods:true
!
instVarRefs
"show an enterbox for instVar to search for"
self instVarRefsOrModsTitle:'instance variable to browse references to:'
mods:false
!
instVarRefsOrModsTitle:title mods:mods
"show an enterbox for instvar to search for"
self doClassMenu:[:currentClass |
|box|
box := self enterBoxForVariableSearch:title.
box action:[:aString |
aString notEmpty ifTrue:[
self withSearchCursorDo:[
SystemBrowser
browseInstRefsTo:aString
in:(Array with:currentClass)
modificationsOnly:mods
]
]
].
box showAtPointer
]
"Created: 23.11.1995 / 14:12:40 / cg"
!
varTypeInfo
"show typical usage of a variable"
|name idx classes values value msg cut names instCount subInstCount box
searchClass s|
name := variableListView selectionValue.
name isNil ifTrue:[^ self].
showInstance ifFalse:[
searchClass := currentClass whichClassDefinesClassVar:name.
value := searchClass classVarAt:(name asSymbol).
s := value displayString.
s size > 60 ifTrue:[
s := (s copyTo:60) , ' ...'
].
msg := name , ' is (currently):\\' , s.
s ~= value classNameWithArticle ifTrue:[
msg := msg , '\\(' , value class name , ')'
]
] ifTrue:[
searchClass := actualClass whichClassDefinesInstVar:name.
idx := searchClass instVarOffsetOf:name.
idx isNil ifTrue:[^ self].
classes := IdentitySet new.
values := IdentitySet new.
instCount := 0.
subInstCount := 0.
searchClass allSubInstancesDo:[:i |
|val|
val := i instVarAt:idx.
val notNil ifTrue:[values add:val].
classes add:val class.
(i isMemberOf:searchClass) ifTrue:[
instCount := instCount + 1.
] ifFalse:[
subInstCount := subInstCount + 1
]
].
(instCount == 0 and:[subInstCount == 0]) ifTrue:[
self warn:'there are currently no instances of ' , currentClass name.
^ self
].
instCount ~~ 0 ifTrue:[
msg := 'in (currently: ' , instCount printString,') instances '.
subInstCount ~~ 0 ifTrue:[
msg := msg , 'and '
]
] ifFalse:[
msg := 'in '.
].
subInstCount ~~ 0 ifTrue:[
msg := msg , '(currently: ' , subInstCount printString, ') derived instances '
].
msg := msg, 'of ' , searchClass name , ',\'.
msg := msg , name , ' '.
((values size == 1)
or:[classes size == 1 and:[classes first == UndefinedObject]]) ifTrue:[
values size == 1 ifTrue:[value := values first].
(value isNumber or:[value isString]) ifTrue:[
msg := msg , 'is always the same:\\ ' ,
value class name , ' (' , value storeString , ')'.
] ifFalse:[
(value isNil or:[value == true or:[value == false]]) ifTrue:[
msg := msg , 'is always:\\ ' ,
value printString.
] ifFalse:[
msg := msg , 'is always the same:\\'.
msg := msg , ' ' , value class name.
value isLiteral ifTrue:[
msg := msg , ' (' , value storeString , ')'
]
]
]
] ifFalse:[
classes size == 1 ifTrue:[
msg := msg , 'is always:\\'.
msg := msg , ' ' , classes first name , '\'.
] ifFalse:[
msg := msg , 'is one of:\\'.
classes := classes asOrderedCollection.
classes size > 20 ifTrue:[
classes := classes copyFrom:1 to:20.
cut := true
] ifFalse:[
cut := false.
].
names := classes collect:[:cls |
|nm|
cls == UndefinedObject ifTrue:[
'nil'
] ifFalse:[
cls == True ifTrue:[
'true'
] ifFalse:[
cls == False ifTrue:[
'false'
] ifFalse:[
cls name
]
]
].
].
names sort.
names do:[:nm |
msg := msg , ' ' , nm , '\'.
].
]
].
].
box := InfoBox title:msg withCRs.
box label:'variable type information'.
box showAtPointer
"Modified: 13.12.1995 / 12:59:03 / cg"
!
variableListMenu
|labels selectors m|
currentClass isNil ifTrue:[
variableListView flash.
^ nil
].
labels := #(
'instvar refs ...'
'classvar refs ...'
'all instvar refs ...'
'all classvar refs ...'
'-'
'instvar mods ...'
'classvar mods ...'
'all instvar mods ...'
'all classvar mods ...'
).
selectors := #(
instVarRefs
classVarRefs
allInstVarRefs
allClassVarRefs
nil
instVarMods
classVarMods
allInstVarMods
allClassVarMods
).
("showInstance and:[" variableListView hasSelection "]" ) ifTrue:[
labels := labels , #(
'-'
'type information'
).
selectors := selectors , #(
nil
varTypeInfo
).
].
m := PopUpMenu labels:(resources array:labels)
selectors:selectors.
currentClass isLoaded ifFalse:[
m disableAll
].
^ m
"Modified: 3.1.1997 / 11:57:27 / cg"
!
variableSelection:lineNr
"variable selection changed"
|name idx|
name := variableListView selectionValue.
name isNil ifTrue:[
self unhilightMethodCategories.
self unhilightMethods.
self autoSearch:nil.
^ self
].
"
first, check if the selected variable is really the one
we get - reselect if its hidden (for example, a class variable
with the same name could be defined in a subclass)
"
idx := variableListView list findLast:[:entry | entry = name].
idx ~~ lineNr ifTrue:[
"select it - user will see whats going on"
variableListView setSelection:idx
].
"search for methods in the current category, which access the selected
variable, and highlight them"
self hilightMethodsInMethodCategoryList:true inMethodList:true.
self autoSearch:name.
"Modified: 25.5.1996 / 12:26:07 / cg"
! !
!BrowserView methodsFor:'variable stuff'!
hilightEntryFor:entry
"helper; given a list itme, highlight it"
|e|
methodCategoryListView font bold ifTrue:[
"/ already bold; use different color then
methodCategoryListView foregroundColor brightness > 0.5 ifTrue:[
methodCategoryListView backgroundColor brightness < 0.25 ifTrue:[
e := #color->Color blue
] ifFalse:[
e := #color->Color black
]
] ifFalse:[
methodCategoryListView backgroundColor brightness > 0.75 ifTrue:[
e := #color->Color red darkened
] ifFalse:[
e := #color->Color white.
]
]
] ifFalse:[
e := #bold.
].
entry isString ifTrue:[
^ entry asText emphasizeAllWith:e.
].
^ entry copy string:(entry string asText emphasizeAllWith:e)
"Created: 22.10.1996 / 23:36:59 / cg"
"Modified: 22.10.1996 / 23:50:03 / cg"
!
hilightMethodsInMethodCategoryList
"search for methods which access the selected
variable, and highlight them"
self hilightMethodsInMethodCategoryList:true inMethodList:false
!
hilightMethodsInMethodCategoryList:inCat inMethodList:inMethods
"search for methods which access the selected
variable, and highlight them"
|name redefinedSelectors methodList methodCategoryList entry|
variableListView isNil ifTrue:[^ self].
inCat ifTrue:[self unhilightMethodCategories].
inMethods ifTrue:[self unhilightMethods].
actualClass isNil ifTrue:[^ self].
(methodCategoryListView isNil
and:[methodListView isNil]) ifTrue:[^ self].
name := variableListView selectionValue.
name isNil ifTrue:[^ self].
self withSearchCursorDo:[
|classes filter any supers|
classes := Array with:actualClass.
(currentClassHierarchy notNil and:[fullProtocol]) ifTrue:[
supers := actualClass allSuperclasses.
supers notNil ifTrue:[
classes := classes , supers.
].
redefinedSelectors := IdentitySet new.
].
filter := SystemBrowser filterToSearchRefsTo:name classVars:showInstance not modificationsOnly:false.
methodListView notNil ifTrue:[
methodList := methodListView list.
].
methodCategoryListView notNil ifTrue:[
methodCategoryList := methodCategoryListView list.
].
any := false.
"
highlight the method that ref this variable
"
classes do:[:someClass |
(fullProtocol
and:[classListView valueIsInSelection:(someClass name)]) ifFalse:[
someClass methodDictionary keysAndValuesDo:[:selector :method |
(inCat
or:[methodList notNil
and:[methodList includes:selector]])
ifTrue:[
(redefinedSelectors isNil
or:[(redefinedSelectors includes:selector) not])
ifTrue:[
(filter value:someClass value:method value:selector) ifTrue:[
|idx cat|
(inCat
and:[methodCategoryList notNil]) ifTrue:[
cat := method category.
"
highlight the methodCategory
"
idx := methodCategoryListView list indexOf:cat.
idx ~~ 0 ifTrue:[
entry := methodCategoryListView at:idx.
entry := self hilightEntryFor:entry.
methodCategoryListView at:idx put:entry
"/ methodCategoryListView attributeAt:idx put:#bold.
].
].
(inMethods
and:[methodList notNil]) ifTrue:[
"
highlight the method
"
idx := methodListView list
findFirst:[:item | item string = selector
or:[item string startsWith:(selector , ' ')]
].
idx ~~ 0 ifTrue:[
entry := methodListView at:idx.
entry := self hilightEntryFor:entry.
methodListView at:idx put:entry
"/ methodListView attributeAt:idx put:#bold.
].
any := true
].
].
redefinedSelectors notNil ifTrue:[
redefinedSelectors add:selector
]
]
]
]
]
].
any ifTrue:[
self setSearchPattern:name
]
]
"Created: 23.11.1995 / 14:12:08 / cg"
"Modified: 5.6.1996 / 11:38:19 / stefan"
"Modified: 22.10.1996 / 23:37:25 / cg"
!
hilightMethodsInMethodList
"search for methods which access the selected
variable, and highlight them"
self hilightMethodsInMethodCategoryList:false inMethodList:true
!
unhilightEntryFor:entry
"helper; given a list itme, unhighlight it"
entry isString ifTrue:[
^ entry string
].
^ entry copy string:(entry string)
"Created: 22.10.1996 / 23:38:21 / cg"
!
unhilightMethodCategories
"unhighlight items in method list"
|list entry sz "{ Class: SmallInteger }"|
variableListView isNil ifTrue:[^ self].
methodCategoryListView notNil ifTrue:[
list := methodCategoryListView list.
sz := list size.
1 to:sz do:[:idx |
entry := list at:idx.
entry := self unhilightEntryFor:entry.
methodCategoryListView at:idx put:entry.
"/ methodCategoryListView attributeAt:idx put:nil.
]
].
"Modified: 22.10.1996 / 23:40:52 / cg"
!
unhilightMethods
"unhighlight items in method list"
|list entry sz "{Class: SmallInteger }" |
variableListView isNil ifTrue:[^ self].
methodListView notNil ifTrue:[
list := methodListView list.
sz := list size.
1 to:sz do:[:idx |
entry := list at:idx.
entry := self unhilightEntryFor:entry.
methodListView at:idx put:entry.
"/ methodListView attributeAt:idx put:nil.
].
].
"Modified: 22.10.1996 / 23:39:18 / cg"
!
updateVariableList
|l subList last nameAccessSelector class oldSelection|
variableListView isNil ifTrue:[^ self].
oldSelection := variableListView selectionValue.
l := OrderedCollection new.
"
show classVars, if classProtocol is shown (instead of classInstance vars)
"
showInstance ifTrue:[
nameAccessSelector := #instVarNames
] ifFalse:[
nameAccessSelector := #classVarNames
].
"/ class := currentClass notNil ifTrue:[currentClass] ifFalse:[actualClass].
"/ class isNil ifTrue:[class := currentClassHierarchy].
class := currentClassHierarchy notNil ifTrue:[
currentClassHierarchy
] ifFalse:[
currentClass
].
class := currentClass.
fullProtocol ifTrue:[
class := currentClassHierarchy
].
class isNil ifTrue:[
variableListView list:nil.
^ self
].
class withAllSuperclasses do:[:aClass |
|ignore|
ignore := fullProtocol
and:[classListView valueIsInSelection:(aClass name asString)].
ignore ifFalse:[
subList := aClass perform:nameAccessSelector.
subList size ~~ 0 ifTrue:[
l := l , (subList asOrderedCollection reverse).
l := l , (OrderedCollection with:'---- ' , aClass name , ' ---------').
]
]
].
l reverse.
variableListView setAttributes:nil.
l ~= variableListView list ifTrue:[
variableListView list:l.
].
l keysAndValuesDo:[:index :entry |
(entry startsWith:'---') ifTrue:[
variableListView attributeAt:index put:#disabled.
last := index
]
].
last notNil ifTrue:[variableListView scrollToLine:last].
oldSelection notNil ifTrue:[
variableListView setSelectElement:oldSelection.
self hilightMethodsInMethodCategoryList:true inMethodList:true.
]
"Modified: 27.10.1996 / 15:48:02 / cg"
! !
!BrowserView class methodsFor:'documentation'!
version
^ '$Header: /cvs/stx/stx/libtool/BrowserView.st,v 1.282 1997-03-19 16:39:16 cg Exp $'
! !
BrowserView initialize!