[Pkg] The Inbox: Tools-ul.134.mcz
commits at source.squeak.org
commits at source.squeak.org
Fri Oct 9 02:48:57 UTC 2009
A new version of Tools was added to project The Inbox:
http://source.squeak.org/inbox/Tools-ul.134.mcz
==================== Summary ====================
Name: Tools-ul.134
Author: ul
Time: 9 October 2009, 1:01:52 am
UUID: dcfa44c0-cf09-ce46-ac34-8348c991b9d1
Ancestors: Tools-ar.133
- added BlockClosure >> #timeProfile which opens a TimeProfileBrowser on the block
==================== Snapshot ====================
SystemOrganization addCategory: #'Tools-ArchiveViewer'!
SystemOrganization addCategory: #'Tools-Base'!
SystemOrganization addCategory: #'Tools-Browser'!
SystemOrganization addCategory: #'Tools-Browser-Tests'!
SystemOrganization addCategory: #'Tools-Changes'!
SystemOrganization addCategory: #'Tools-Debugger'!
SystemOrganization addCategory: #'Tools-Debugger-Tests'!
SystemOrganization addCategory: #'Tools-Explorer'!
SystemOrganization addCategory: #'Tools-File Contents Browser'!
SystemOrganization addCategory: #'Tools-FileList'!
SystemOrganization addCategory: #'Tools-FileList-Tests'!
SystemOrganization addCategory: #'Tools-Inspector'!
SystemOrganization addCategory: #'Tools-Process Browser'!
SystemOrganization addCategory: #'Tools-Protocols'!
----- Method: Utilities class>>browseRecentSubmissions (in category '*Tools') -----
browseRecentSubmissions
"Open up a browser on the most recent methods submitted in the image. 5/96 sw."
"Utilities browseRecentSubmissions"
| recentMessages |
self recentMethodSubmissions size == 0 ifTrue:
[^ self inform: 'There are no recent submissions'].
recentMessages := RecentSubmissions copy reversed.
RecentMessageSet
openMessageList: recentMessages
name: 'Recent submissions -- youngest first '
autoSelect: nil!
----- Method: Utilities class>>closeAllDebuggers (in category '*Tools') -----
closeAllDebuggers
"Utilities closeAllDebuggers"
Smalltalk isMorphic
ifTrue:
[(SystemWindow allSubInstances select: [:w | w model isKindOf: Debugger])
do: [:w | w delete]]
ifFalse:
[(StandardSystemController allInstances select: [:w | w model isKindOf: Debugger])
do: [:w | w closeAndUnscheduleNoTerminate]]!
----- Method: Utilities class>>openRecentSubmissionsBrowser (in category '*Tools') -----
openRecentSubmissionsBrowser
"Open up a browser on the most recent methods submitted in the image; reuse any existing one found in the world."
self currentWorld openRecentSubmissionsBrowser: nil!
----- Method: Utilities class>>recentSubmissionsWindow (in category '*Tools') -----
recentSubmissionsWindow
"Answer a SystemWindow holding recent submissions"
| recentMessages messageSet |
recentMessages := RecentSubmissions copy reversed.
messageSet := RecentMessageSet messageList: recentMessages.
messageSet autoSelectString: nil.
^ ToolBuilder build: messageSet
"Utilities recentSubmissionsWindow openInHand"
!
Object subclass: #ChangesOrganizer
instanceVariableNames: ''
classVariableNames: 'ChangeSetCategories ChangeSetNamesInRelease RecentUpdateMarker'
poolDictionaries: ''
category: 'Tools-Changes'!
!ChangesOrganizer commentStamp: 'pk 10/17/2006 09:25' prior: 0!
Changes organizer!
----- Method: ChangesOrganizer class>>allChangeSetNames (in category 'enumerating') -----
allChangeSetNames
^ self allChangeSets collect: [:c | c name]!
----- Method: ChangesOrganizer class>>allChangeSets (in category 'enumerating') -----
allChangeSets
"Return the list of all current ChangeSets"
^ChangeSet allChangeSets!
----- Method: ChangesOrganizer class>>allChangeSetsWithClass:selector: (in category 'enumerating') -----
allChangeSetsWithClass: class selector: selector
class ifNil: [^ #()].
^ self allChangeSets select:
[:cs | (cs atSelector: selector class: class) ~~ #none]!
----- Method: ChangesOrganizer class>>assuredChangeSetNamed: (in category 'services') -----
assuredChangeSetNamed: aName
"Answer a change set of the given name. If one already exists, answer that, else create a new one and answer it."
| existing |
^ (existing := self changeSetNamed: aName)
ifNotNil:
[existing]
ifNil:
[self basicNewChangeSet: aName]!
----- Method: ChangesOrganizer class>>basicNewChangeSet: (in category 'adding') -----
basicNewChangeSet: newName
^ChangeSet basicNewChangeSet: newName!
----- Method: ChangesOrganizer class>>belongsInAdditions: (in category 'class initialization') -----
belongsInAdditions: aChangeSet
"Answer whether a change set belongs in the Additions category, which is fed by all change sets that are neither numbered nor in the initial release"
^ (((self belongsInProjectsInRelease: aChangeSet) or:
[self belongsInNumbered: aChangeSet])) not!
----- Method: ChangesOrganizer class>>belongsInAll: (in category 'class initialization') -----
belongsInAll: aChangeSet
"Answer whether a change set belongs in the All category"
^ true !
----- Method: ChangesOrganizer class>>belongsInMyInitials: (in category 'class initialization') -----
belongsInMyInitials: aChangeSet
"Answer whether a change set belongs in the MyInitials category. "
^ aChangeSet name endsWith: ('-', Utilities authorInitials)!
----- Method: ChangesOrganizer class>>belongsInNumbered: (in category 'class initialization') -----
belongsInNumbered: aChangeSet
"Answer whether a change set belongs in the Numbered category. "
^ aChangeSet name startsWithDigit!
----- Method: ChangesOrganizer class>>belongsInProjectChangeSets: (in category 'class initialization') -----
belongsInProjectChangeSets: aChangeSet
"Answer whether a change set belongs in the MyInitials category. "
^ aChangeSet belongsToAProject!
----- Method: ChangesOrganizer class>>belongsInProjectsInRelease: (in category 'class initialization') -----
belongsInProjectsInRelease: aChangeSet
"Answer whether a change set belongs in the ProjectsInRelease category. You can hand-tweak this to suit your working style. This just covers the space of project names in the 2.9, 3.0, and 3.1a systems"
| aString |
^ ((aString := aChangeSet name) beginsWith: 'Play With Me') or: [self changeSetNamesInReleaseImage includes: aString]!
----- Method: ChangesOrganizer class>>belongsInRecentUpdates: (in category 'class initialization') -----
belongsInRecentUpdates: aChangeSet
"Answer whether a change set belongs in the RecentUpdates category."
^ aChangeSet name startsWithDigit and:
[aChangeSet name asInteger >= self recentUpdateMarker]!
----- Method: ChangesOrganizer class>>buildAggregateChangeSet (in category 'services') -----
buildAggregateChangeSet
"Establish a change-set named Aggregate which bears the union of all the changes in all the existing change-sets in the system (other than any pre-existing Aggregate). This can be useful when wishing to discover potential conflicts between a disk-resident change-set and an image. Formerly very useful, now some of its unique contributions have been overtaken by new features"
| aggregateChangeSet |
aggregateChangeSet := self existingOrNewChangeSetNamed: 'Aggregate'.
aggregateChangeSet clear.
self allChangeSets do:
[:aChangeSet | aChangeSet == aggregateChangeSet ifFalse:
[aggregateChangeSet assimilateAllChangesFoundIn: aChangeSet]]
"ChangeSorter buildAggregateChangeSet"
!
----- Method: ChangesOrganizer class>>changeSet:containsClass: (in category 'enumerating') -----
changeSet: aChangeSet containsClass: aClass
| theClass |
theClass := Smalltalk classNamed: aClass.
theClass ifNil: [^ false].
^ aChangeSet containsClass: theClass!
----- Method: ChangesOrganizer class>>changeSetCategoryNamed: (in category 'class initialization') -----
changeSetCategoryNamed: aName
"Answer the changeSetCategory of the given name, or nil if none"
^ ChangeSetCategories elementAt: aName asSymbol !
----- Method: ChangesOrganizer class>>changeSetNamed: (in category 'enumerating') -----
changeSetNamed: aName
"Return the change set of the given name, or nil if none found. 1/22/96 sw"
^ChangeSet named: aName!
----- Method: ChangesOrganizer class>>changeSetNamesInReleaseImage (in category 'class initialization') -----
changeSetNamesInReleaseImage
"Answer a list of names of project change sets that come pre-shipped in the latest sytem release. On the brink of shipping a new release, call 'ChangeSorter noteChangeSetsInRelease' "
^ ChangeSetNamesInRelease ifNil:
[ChangeSetNamesInRelease := self changeSetNamesInThreeOh]!
----- Method: ChangesOrganizer class>>changeSetNamesInThreeOh (in category 'class initialization') -----
changeSetNamesInThreeOh
"Hard-coded: answer a list of names of project change sets that came pre-shipped in Squeak 3.0"
^ #('The Worlds of Squeak' 'Fun with Morphic' 'Games' 'Fun With Music' 'Building with Squeak' 'Squeak and the Internet' 'Squeak in 3D' 'More About Sound' ) !
----- Method: ChangesOrganizer class>>changeSetsNamedSuchThat: (in category 'enumerating') -----
changeSetsNamedSuchThat: nameBlock
^ChangeSet changeSetsNamedSuchThat: nameBlock!
----- Method: ChangesOrganizer class>>countOfChangeSetsWithClass:andSelector: (in category 'services') -----
countOfChangeSetsWithClass: aClass andSelector: aSelector
"Answer how many change sets record a change for the given class and selector"
^ (self allChangeSetsWithClass: aClass selector: aSelector) size!
----- Method: ChangesOrganizer class>>deleteChangeSetsNumberedLowerThan: (in category 'removing') -----
deleteChangeSetsNumberedLowerThan: anInteger
"Delete all changes sets whose names start with integers smaller than anInteger"
self removeChangeSetsNamedSuchThat:
[:aName | aName first isDigit and: [aName initialIntegerOrNil < anInteger]].
"ChangesOrganizer deleteChangeSetsNumberedLowerThan: (ChangeSorter highestNumberedChangeSet name initialIntegerOrNil - 500)"
!
----- Method: ChangesOrganizer class>>doesAnyChangeSetHaveClass:andSelector: (in category 'services') -----
doesAnyChangeSetHaveClass: aClass andSelector: aSelector
"Answer whether any known change set bears a change for the given class and selector"
^ (self countOfChangeSetsWithClass: aClass andSelector: aSelector) > 0!
----- Method: ChangesOrganizer class>>existingOrNewChangeSetNamed: (in category 'enumerating') -----
existingOrNewChangeSetNamed: aName
^ChangeSet existingOrNewChangeSetNamed: aName!
----- Method: ChangesOrganizer class>>fileOutChangeSetsNamed: (in category 'utilities') -----
fileOutChangeSetsNamed: nameList
"File out the list of change sets whose names are provided"
"ChangeSorter fileOutChangeSetsNamed: #('New Changes' 'miscTidies-sw')"
| notFound aChangeSet infoString empty |
notFound := OrderedCollection new.
empty := OrderedCollection new.
nameList do:
[:aName | (aChangeSet := self changeSetNamed: aName)
ifNotNil:
[aChangeSet isEmpty
ifTrue:
[empty add: aName]
ifFalse:
[aChangeSet fileOut]]
ifNil:
[notFound add: aName]].
infoString := (nameList size - notFound size) printString, ' change set(s) filed out'.
notFound size > 0 ifTrue:
[infoString := infoString, '
', notFound size printString, ' change set(s) not found:'.
notFound do:
[:aName | infoString := infoString, '
', aName]].
empty size > 0 ifTrue:
[infoString := infoString, '
', empty size printString, ' change set(s) were empty:'.
empty do:
[:aName | infoString := infoString, '
', aName]].
self inform: infoString!
----- Method: ChangesOrganizer class>>gatherChangeSets (in category 'enumerating') -----
gatherChangeSets "ChangeSorter gatherChangeSets"
^ChangeSet gatherChangeSets!
----- Method: ChangesOrganizer class>>highestNumberedChangeSet (in category 'enumerating') -----
highestNumberedChangeSet
"ChangeSorter highestNumberedChangeSet"
| aList |
aList := (ChangeSet allChangeSetNames select: [:aString | aString startsWithDigit] thenCollect:
[:aString | aString initialIntegerOrNil]).
^ (aList size > 0)
ifTrue:
[aList max]
ifFalse:
[nil]
!
----- Method: ChangesOrganizer class>>initialize (in category 'class initialization') -----
initialize
"Initialize the class variables"
ChangeSetCategories ifNil:
[self initializeChangeSetCategories].
RecentUpdateMarker := 0.
!
----- Method: ChangesOrganizer class>>initializeChangeSetCategories (in category 'class initialization') -----
initializeChangeSetCategories
"Initialize the set of change-set categories"
"ChangeSorter initializeChangeSetCategories"
| aCategory |
ChangeSetCategories := ElementCategory new categoryName: #ChangeSetCategories.
aCategory := ChangeSetCategory new categoryName: #All.
aCategory membershipSelector: #belongsInAll:.
aCategory documentation: 'All change sets known to the system'.
ChangeSetCategories addCategoryItem: aCategory.
aCategory := ChangeSetCategory new categoryName: #Additions.
aCategory membershipSelector: #belongsInAdditions:.
aCategory documentation: 'All unnumbered change sets except those representing projects in the system as initially released.'.
ChangeSetCategories addCategoryItem: aCategory.
aCategory := ChangeSetCategory new categoryName: #MyInitials.
aCategory membershipSelector: #belongsInMyInitials:.
aCategory documentation: 'All change sets whose names end with the current author''s initials.'.
ChangeSetCategories addCategoryItem: aCategory.
aCategory := ChangeSetCategory new categoryName: #Numbered.
aCategory membershipSelector: #belongsInNumbered:.
aCategory documentation: 'All change sets whose names start with a digit -- normally these will be the official updates to the system.'.
ChangeSetCategories addCategoryItem: aCategory.
aCategory := ChangeSetCategory new categoryName: #ProjectChangeSets.
aCategory membershipSelector: #belongsInProjectChangeSets:.
aCategory documentation: 'All change sets that are currently associated with projects present in the system right now.'.
ChangeSetCategories addCategoryItem: aCategory.
aCategory := ChangeSetCategory new categoryName: #ProjectsInRelease.
aCategory membershipSelector: #belongsInProjectsInRelease:.
aCategory documentation: 'All change sets belonging to projects that were shipped in the initial release of this version of Squeak'.
ChangeSetCategories addCategoryItem: aCategory.
aCategory := ChangeSetCategory new categoryName: #RecentUpdates.
aCategory membershipSelector: #belongsInRecentUpdates:.
aCategory documentation: 'Updates whose numbers are at or beyond the number I have designated as the earliest one to qualify as Recent'.
ChangeSetCategories addCategoryItem: aCategory.
ChangeSetCategories elementsInOrder do: [:anElem | anElem reconstituteList] !
----- Method: ChangesOrganizer class>>mostRecentChangeSetWithChangeForClass:selector: (in category 'enumerating') -----
mostRecentChangeSetWithChangeForClass: class selector: selector
| hits |
hits := self allChangeSets select:
[:cs | (cs atSelector: selector class: class) ~~ #none].
hits isEmpty ifTrue: [^ 'not in any change set'].
^ 'recent cs: ', hits last name!
----- Method: ChangesOrganizer class>>newChangeSet (in category 'adding') -----
newChangeSet
"Prompt the user for a name, and establish a new change set of
that name (if ok), making it the current changeset. Return nil
of not ok, else return the actual changeset."
| newName newSet |
newName := UIManager default
request: 'Please name the new change set:'
initialAnswer: ChangeSet defaultName.
newName isEmptyOrNil ifTrue:
[^ nil].
newSet := self basicNewChangeSet: newName.
newSet ifNotNil:
[ChangeSet newChanges: newSet].
^ newSet!
----- Method: ChangesOrganizer class>>newChangeSet: (in category 'adding') -----
newChangeSet: aName
"Makes a new change set called aName, add author initials to try to
ensure a unique change set name."
| newName |
newName := aName , FileDirectory dot , Utilities authorInitials.
^ self basicNewChangeSet: newName!
----- Method: ChangesOrganizer class>>newChangesFromStream:named: (in category 'adding') -----
newChangesFromStream: aStream named: aName
^ChangeSet newChangesFromStream: aStream named: aName
!
----- Method: ChangesOrganizer class>>noteChangeSetsInRelease (in category 'class initialization') -----
noteChangeSetsInRelease
"Freshly compute what the change sets in the release are; to be called manually just before a release"
ChangeSetNamesInRelease := (Project allProjects collect: [:p | p name]) asSet asOrderedCollection.
"ChangeSorter noteChangeSetsInRelease"!
----- Method: ChangesOrganizer class>>promoteToTop: (in category 'enumerating') -----
promoteToTop: aChangeSet
"Make aChangeSet the first in the list from now on"
^ChangeSet promoteToTop: aChangeSet!
----- Method: ChangesOrganizer class>>recentUpdateMarker (in category 'services') -----
recentUpdateMarker
"Answer the number representing the threshold of what counts as 'recent' for an update number. This allow you to use the RecentUpdates category in a ChangeSorter to advantage"
^ RecentUpdateMarker ifNil: [RecentUpdateMarker := 0]!
----- Method: ChangesOrganizer class>>recentUpdateMarker: (in category 'services') -----
recentUpdateMarker: aNumber
"Set the recent update marker as indicated"
^ RecentUpdateMarker := aNumber!
----- Method: ChangesOrganizer class>>removeChangeSet: (in category 'removing') -----
removeChangeSet: aChangeSet
"Remove the given changeSet. Caller must assure that it's cool to do this"
^ChangeSet removeChangeSet: aChangeSet!
----- Method: ChangesOrganizer class>>removeChangeSetsNamedSuchThat: (in category 'removing') -----
removeChangeSetsNamedSuchThat: nameBlock
(self changeSetsNamedSuchThat: nameBlock)
do: [:cs | self removeChangeSet: cs]!
----- Method: ChangesOrganizer class>>removeEmptyUnnamedChangeSets (in category 'removing') -----
removeEmptyUnnamedChangeSets
"Remove all change sets that are empty, whose names start with Unnamed,
and which are not nailed down by belonging to a Project."
"ChangeSorter removeEmptyUnnamedChangeSets"
| toGo |
(toGo := (self changeSetsNamedSuchThat: [:csName | csName beginsWith: 'Unnamed'])
select: [:cs | cs isEmpty and: [cs okayToRemoveInforming: false]])
do: [:cs | self removeChangeSet: cs].
self inform: toGo size printString, ' change set(s) removed.'!
----- Method: ChangesOrganizer class>>reorderChangeSets (in category 'services') -----
reorderChangeSets
"Change the order of the change sets to something more convenient:
First come the project changesets that come with the release. These are mostly empty.
Next come all numbered updates.
Next come all remaining changesets
In a ChangeSorter, they will appear in the reversed order."
"ChangeSorter reorderChangeSets"
| newHead newMid newTail |
newHead := OrderedCollection new.
newMid := OrderedCollection new.
newTail := OrderedCollection new.
ChangeSet allChangeSets do:
[:aChangeSet |
(self belongsInProjectsInRelease: aChangeSet)
ifTrue:
[newHead add: aChangeSet]
ifFalse:
[(self belongsInNumbered: aChangeSet)
ifTrue:
[newMid add: aChangeSet]
ifFalse:
[newTail add: aChangeSet]]].
ChangeSet allChangeSets: newHead, newMid, newTail.
Smalltalk isMorphic ifTrue: [SystemWindow wakeUpTopWindowUponStartup]!
----- Method: ChangesOrganizer class>>secondaryChangeSet (in category 'services') -----
secondaryChangeSet
^ChangeSet secondaryChangeSet!
----- Method: ChangesOrganizer class>>unload (in category 'class initialization') -----
unload
"Unload the receiver from global registries"
self environment at: #FileList ifPresent: [:cl |
cl unregisterFileReader: self].
self environment at: #Flaps ifPresent: [:cl |
cl unregisterQuadsWithReceiver: self] !
Object subclass: #DebuggerMethodMap
instanceVariableNames: 'timestamp methodReference methodNode abstractSourceRanges sortedSourceMap'
classVariableNames: 'MapCache MapCacheEntries'
poolDictionaries: ''
category: 'Tools-Debugger'!
!DebuggerMethodMap commentStamp: '<historical>' prior: 0!
I am a place-holder for information needed by the Debugger to inspect method activations. I insulate the debugger from details of code generation such as exact bytecode offsets and temporary variable locations. I have two concreate subclasses, one for methods compiled using BlueBook blocks and one for methods compiled using Closures. These classes deal with temporary variable access. My function is to abstract the source map away from actual bytecode pcs to abstract bytecode pcs.
To reduce compilation time I try and defer as much computation to access time as possible as instances of me will be created after each compilation.
I maintain a WeakIdentityDictionary of method to DebuggerMethodMap to cache maps. I refer to my method through a WeakArray to keep the map cache functional. If the reference from a DebuggerMethodMap to its method were strong then the method would never be dropped from the cache because the reference from its map would keep it alive.!
----- Method: DebuggerMethodMap class>>cacheDebugMap:forMethod: (in category 'debugger support') -----
cacheDebugMap: aDebuggerMethodMap forMethod: aCompiledMethod
MapCache finalizeValues.
[MapCache size >= MapCacheEntries] whileTrue:
[| mapsByAge |
mapsByAge := MapCache keys asSortedCollection:
[:m1 :m2|
(MapCache at: m1) timestamp
< (MapCache at: m2) timestamp].
mapsByAge notEmpty ifTrue: "There be race conditions and reentrancy issues here"
[MapCache removeKey: mapsByAge last]].
^MapCache
at: aCompiledMethod
put: aDebuggerMethodMap!
----- Method: DebuggerMethodMap class>>forMethod: (in category 'instance creation') -----
forMethod: aMethod "<CompiledMethod>"
"Answer a DebuggerMethodMap suitable for debugging activations of aMethod.
Answer an existing instance from the cache if it exists, cacheing a new one if required."
^MapCache
at: aMethod
ifAbsent: [self
cacheDebugMap:
(self
forMethod: aMethod
methodNode: aMethod methodNode)
forMethod: aMethod]!
----- Method: DebuggerMethodMap class>>forMethod:methodNode: (in category 'instance creation') -----
forMethod: aMethod "<CompiledMethod>" methodNode: methodNode "<MethodNode>"
"Uncached instance creation method for private use or for tests.
Please consider using forMethod: instead."
^(aMethod isBlueBookCompiled
ifTrue: [DebuggerMethodMapForBlueBookMethods]
ifFalse: [DebuggerMethodMapForClosureCompiledMethods]) new
forMethod: aMethod
methodNode: methodNode!
----- Method: DebuggerMethodMap class>>initialize (in category 'class initialization') -----
initialize
"DebuggerMethodMap initialize"
self voidMapCache!
----- Method: DebuggerMethodMap class>>voidMapCache (in category 'class initialization') -----
voidMapCache
MapCache := WeakIdentityKeyDictionary new.
MapCacheEntries := 16!
----- Method: DebuggerMethodMap>>abstractSourceMap (in category 'source mapping') -----
abstractSourceMap
"Answer with a Dictionary of abstractPC <Integer> to sourceRange <Interval>."
| theMethodToScan rawSourceRanges concreteSourceRanges abstractPC scanner client |
abstractSourceRanges ifNotNil:
[^abstractSourceRanges].
"If the methodNode hasn't had a method generated it doesn't have pcs set in its
nodes so we must generate a new method and might as well use it for scanning."
methodNode rawSourceRangesAndMethodDo:
[:ranges :method|
rawSourceRanges := ranges.
theMethodToScan := method].
concreteSourceRanges := Dictionary new.
rawSourceRanges keysAndValuesDo:
[:node :range|
node pc ~= 0 ifTrue:
[concreteSourceRanges at: node pc put: range]].
abstractPC := 1.
abstractSourceRanges := Dictionary new.
scanner := InstructionStream on: theMethodToScan.
client := InstructionClient new.
[(concreteSourceRanges includesKey: scanner pc) ifTrue:
[abstractSourceRanges at: abstractPC put: (concreteSourceRanges at: scanner pc)].
abstractPC := abstractPC + 1.
scanner interpretNextInstructionFor: client.
scanner atEnd] whileFalse.
^abstractSourceRanges!
----- Method: DebuggerMethodMap>>forMethod:methodNode: (in category 'initialize-release') -----
forMethod: aMethod "<CompiledMethod>" methodNode: theMethodNode "<MethodNode>"
methodReference := WeakArray with: aMethod.
methodNode := theMethodNode.
self markRecentlyUsed!
----- Method: DebuggerMethodMap>>markRecentlyUsed (in category 'accessing') -----
markRecentlyUsed
timestamp := Time totalSeconds!
----- Method: DebuggerMethodMap>>method (in category 'accessing') -----
method
^methodReference at: 1!
----- Method: DebuggerMethodMap>>namedTempAt:in: (in category 'accessing') -----
namedTempAt: index in: aContext
"Answer the value of the temp at index in aContext where index is relative
to the array of temp names answered by tempNamesForContext:"
self subclassResponsibility!
----- Method: DebuggerMethodMap>>namedTempAt:put:in: (in category 'accessing') -----
namedTempAt: index put: aValue in: aContext
"Assign the value of the temp at index in aContext where index is relative
to the array of temp names answered by tempNamesForContext:"
self subclassResponsibility!
----- Method: DebuggerMethodMap>>rangeForPC:contextIsActiveContext: (in category 'source mapping') -----
rangeForPC: contextsConcretePC contextIsActiveContext: contextIsActiveContext
"Answer the indices in the source code for the supplied pc.
If the context is the actve context (is at the hot end of the stack)
then its pc is the current pc. But if the context isn't, because it is
suspended sending a message, then its current pc is the previous pc."
| pc i end |
pc := self method abstractPCForConcretePC: (contextIsActiveContext
ifTrue: [contextsConcretePC]
ifFalse: [(self method pcPreviousTo: contextsConcretePC)
ifNotNil: [:prevpc| prevpc]
ifNil: [contextsConcretePC]]).
(self abstractSourceMap includesKey: pc) ifTrue:
[^self abstractSourceMap at: pc].
sortedSourceMap ifNil:
[sortedSourceMap := self abstractSourceMap.
sortedSourceMap := (sortedSourceMap keys collect:
[:key| key -> (sortedSourceMap at: key)]) asSortedCollection].
(sortedSourceMap isNil or: [sortedSourceMap isEmpty]) ifTrue: [^1 to: 0].
i := sortedSourceMap indexForInserting: (pc -> nil).
i < 1 ifTrue: [^1 to: 0].
i > sortedSourceMap size ifTrue:
[end := sortedSourceMap inject: 0 into:
[:prev :this | prev max: this value last].
^end+1 to: end].
^(sortedSourceMap at: i) value
"| method source scanner map |
method := DebuggerMethodMap compiledMethodAt: #rangeForPC:contextIsActiveContext:.
source := method getSourceFromFile asString.
scanner := InstructionStream on: method.
map := method debuggerMap.
Array streamContents:
[:ranges|
[scanner atEnd] whileFalse:
[| range |
range := map rangeForPC: scanner pc contextIsActiveContext: true.
((map abstractSourceMap includesKey: scanner abstractPC)
and: [range first ~= 0]) ifTrue:
[ranges nextPut: (source copyFrom: range first to: range last)].
scanner interpretNextInstructionFor: InstructionClient new]]"!
----- Method: DebuggerMethodMap>>sourceText (in category 'source mapping') -----
sourceText
self method ifNotNil:
[:method|
method holdsTempNames ifTrue:
[^method
getSourceFor: (method selector ifNil: [method defaultSelector])
in: method methodClass]].
^methodNode sourceText!
----- Method: DebuggerMethodMap>>tempNamesForContext: (in category 'accessing') -----
tempNamesForContext: aContext
"Answer an Array of all the temp names in scope in aContext starting with
the home's first local (the first argument or first temporary if no arguments)."
self subclassResponsibility!
----- Method: DebuggerMethodMap>>tempsAndValuesForContext: (in category 'accessing') -----
tempsAndValuesForContext: aContext
"Return a string of the temporary variabls and their current values"
| aStream |
aStream := WriteStream on: (String new: 100).
(self tempNamesForContext: aContext) doWithIndex:
[:title :index |
aStream nextPutAll: title; nextPut: $:; space; tab.
aContext print: (self namedTempAt: index in: aContext) on: aStream.
aStream cr].
^aStream contents!
----- Method: DebuggerMethodMap>>timestamp (in category 'accessing') -----
timestamp
^timestamp!
DebuggerMethodMap subclass: #DebuggerMethodMapForBlueBookMethods
instanceVariableNames: 'tempNames'
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Debugger'!
!DebuggerMethodMapForBlueBookMethods commentStamp: '<historical>' prior: 0!
I am a place-holder for information needed by the Debugger to inspect method activations. See my superclass's comment. I map methods compiled using Closures.!
----- Method: DebuggerMethodMapForBlueBookMethods>>forMethod:methodNode: (in category 'initialize-release') -----
forMethod: aMethod "<CompiledMethod>" methodNode: aMethodNode "<MethodNode>"
super forMethod: aMethod methodNode: aMethodNode.
tempNames := methodNode encoder tempNames!
----- Method: DebuggerMethodMapForBlueBookMethods>>namedTempAt:in: (in category 'accessing') -----
namedTempAt: index in: aContext
"Answer the value of the temp at index in aContext where index is relative
to the array of temp names answered by tempNamesForContext:"
^aContext tempAt: index!
----- Method: DebuggerMethodMapForBlueBookMethods>>namedTempAt:put:in: (in category 'accessing') -----
namedTempAt: index put: aValue in: aContext
"Assign the value of the temp at index in aContext where index is relative
to the array of temp names answered by tempNamesForContext:"
^aContext tempAt: index put: aValue!
----- Method: DebuggerMethodMapForBlueBookMethods>>tempNamesForContext: (in category 'accessing') -----
tempNamesForContext: aContext
"Answer an Array of all the temp names in scope in aContext starting with
the home's first local (the first argument or first temporary if no arguments)."
^tempNames!
DebuggerMethodMap subclass: #DebuggerMethodMapForClosureCompiledMethods
instanceVariableNames: 'blockExtentsToTempRefs startpcsToTempRefs'
classVariableNames: 'FirstTime'
poolDictionaries: ''
category: 'Tools-Debugger'!
!DebuggerMethodMapForClosureCompiledMethods commentStamp: '<historical>' prior: 0!
I am a place-holder for information needed by the Debugger to inspect method activations. See my superclass's comment. I map methods compiled using BlueBook blocks.
Instance variables
blockExtentsToTempsRefs <Dictionary of: Interval -> Array of: (Array with: String with: (Integer | (Array with: Integer with: Integer)))>
maps a block extent to an Array of temp references for that block/method.
Each reference is a pair of temp name and index, where the index can itself be a pair for a remote temp.
startpcsToTempRefs <Dictionary of: Integer -> Array of: (Array with: String with: temp reference)> where
temp reference ::= Integer
| (Array with: Integer with: Integer)
| (Array with: #outer with: temp reference)!
----- Method: DebuggerMethodMapForClosureCompiledMethods>>ensureExtentsMapsInitialized (in category 'private') -----
ensureExtentsMapsInitialized
| encoderTempRefs "<Dictionary of: Interval -> <Array of: <String | <Array of: String>>>>" |
blockExtentsToTempRefs ifNotNil: [^self].
blockExtentsToTempRefs := Dictionary new.
startpcsToTempRefs := Dictionary new.
encoderTempRefs := methodNode blockExtentsToTempRefs.
encoderTempRefs keysAndValuesDo:
[:blockExtent :tempVector|
blockExtentsToTempRefs
at: blockExtent
put: (Array streamContents:
[:stream|
tempVector withIndexDo:
[:nameOrSequence :index|
nameOrSequence isString
ifTrue:
[stream nextPut: {nameOrSequence. index}]
ifFalse:
[nameOrSequence withIndexDo:
[:name :indirectIndex|
stream nextPut: { name. { index. indirectIndex }}]]]])]!
----- Method: DebuggerMethodMapForClosureCompiledMethods>>namedTempAt:in: (in category 'accessing') -----
namedTempAt: index in: aContext
"Answer the value of the temp at index in aContext where index is relative
to the array of temp names answered by tempNamesForContext:"
^self
privateTempAt: index
in: aContext
startpcsToBlockExtents: aContext method startpcsToBlockExtents!
----- Method: DebuggerMethodMapForClosureCompiledMethods>>namedTempAt:put:in: (in category 'accessing') -----
namedTempAt: index put: aValue in: aContext
"Assign the value of the temp at index in aContext where index is relative
to the array of temp names answered by tempNamesForContext:.
If the value is a copied value we also need to set it along the lexical chain."
^self
privateTempAt: index
in: aContext
put: aValue
startpcsToBlockExtents: aContext method startpcsToBlockExtents!
----- Method: DebuggerMethodMapForClosureCompiledMethods>>privateDereference:in: (in category 'private') -----
privateDereference: tempReference in: aContext
"Fetch the temporary with reference tempReference in aContext.
tempReference can be
integer - direct temp reference
#( indirectionVectorIndex tempIndex ) - remote temp in indirectionVector at index
#( outer. temp reference ) - a temp reference in an outer context."
^tempReference isInteger
ifTrue: [aContext tempAt: tempReference]
ifFalse:
[tempReference first == #outer
ifTrue: [self privateDereference: tempReference last
in: aContext outerContext]
ifFalse: [(aContext tempAt: tempReference first)
at: tempReference second]]!
----- Method: DebuggerMethodMapForClosureCompiledMethods>>privateDereference:in:put: (in category 'private') -----
privateDereference: tempReference in: aContext put: aValue
"Assign the temporary with reference tempReference in aContext.
tempReference can be
integer - direct temp reference
#( indirectionVectorIndex tempIndex ) - remote temp in indirectionVector at index
#( outer. temp reference ) - a temp reference in an outer context."
^tempReference isInteger
ifTrue: [aContext tempAt: tempReference put: aValue]
ifFalse:
[tempReference first == #outer
ifTrue: [self privateDereference: tempReference last
in: aContext outerContext
put: aValue]
ifFalse: [(aContext tempAt: tempReference first)
at: tempReference second
put: aValue]]!
----- Method: DebuggerMethodMapForClosureCompiledMethods>>privateTempAt:in:put:startpcsToBlockExtents: (in category 'private') -----
privateTempAt: index in: aContext put: aValue startpcsToBlockExtents: theContextsStartpcsToBlockExtents
| nameRefPair |
nameRefPair := (self privateTempRefsForContext: aContext
startpcsToBlockExtents: theContextsStartpcsToBlockExtents)
at: index
ifAbsent: [aContext errorSubscriptBounds: index].
^self privateDereference: nameRefPair last in: aContext put: aValue!
----- Method: DebuggerMethodMapForClosureCompiledMethods>>privateTempAt:in:startpcsToBlockExtents: (in category 'private') -----
privateTempAt: index in: aContext startpcsToBlockExtents: theContextsStartpcsToBlockExtents
| nameRefPair |
nameRefPair := (self privateTempRefsForContext: aContext
startpcsToBlockExtents: theContextsStartpcsToBlockExtents)
at: index
ifAbsent: [aContext errorSubscriptBounds: index].
^self privateDereference: nameRefPair last in: aContext!
----- Method: DebuggerMethodMapForClosureCompiledMethods>>privateTempRefsForContext:startpcsToBlockExtents: (in category 'private') -----
privateTempRefsForContext: aContext startpcsToBlockExtents: theContextsStartpcsToBlockExtents
"Answer the sequence of temps in scope in aContext in the natural order,
outermost arguments and temporaries first, innermost last. Each temp is
a pair of the temp's name followed by a reference. The reference can be
integer - index of temp in aContext
#( indirectionVectorIndex tempIndex ) - remote temp in indirectionVector at index in aContext
#( outer. temp reference ) - a temp reference in an outer context."
blockExtentsToTempRefs ifNil:
[blockExtentsToTempRefs := (aContext method holdsTempNames
ifTrue: [aContext method]
ifFalse: [methodNode]) blockExtentsToTempsMap.
startpcsToTempRefs := Dictionary new].
^startpcsToTempRefs
at: aContext startpc
ifAbsentPut:
[| localRefs |
localRefs := blockExtentsToTempRefs at: (theContextsStartpcsToBlockExtents at: aContext startpc).
aContext outerContext
ifNil: [localRefs]
ifNotNil:
[:outer| | outerTemps |
"Present temps in the order outermost to innermost left-to-right, but replace
copied outermost temps with their innermost copies"
outerTemps := (self
privateTempRefsForContext: outer
startpcsToBlockExtents: theContextsStartpcsToBlockExtents) collect:
[:outerPair|
localRefs
detect: [:localPair| outerPair first = localPair first]
ifNone: [{ outerPair first. { #outer. outerPair last } }]].
outerTemps,
(localRefs reject: [:localPair| outerTemps anySatisfy: [:outerPair| localPair first = outerPair first]])]]!
----- Method: DebuggerMethodMapForClosureCompiledMethods>>tempNamesForContext: (in category 'accessing') -----
tempNamesForContext: aContext
"Answer an Array of all the temp names in scope in aContext starting with
the home's first local (the first argument or first temporary if no arguments)."
^(self
privateTempRefsForContext: aContext
startpcsToBlockExtents: aContext method startpcsToBlockExtents) collect:
[:pair| pair first]!
Object subclass: #DummyToolWorkingWithFileList
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-FileList-Tests'!
!DummyToolWorkingWithFileList commentStamp: '<historical>' prior: 0!
I'm a dummy class for testing that the registration of the tool to the FileList of actually happens.
In the future the tests should cover that the class register when loaded in memory and unregister when unloaded.!
----- Method: DummyToolWorkingWithFileList class>>fileReaderServicesForFile:suffix: (in category 'class initialization') -----
fileReaderServicesForFile: fullName suffix: suffix
^ (suffix = 'kkk')
ifTrue: [ self services]
ifFalse: [#()] !
----- Method: DummyToolWorkingWithFileList class>>initialize (in category 'class initialization') -----
initialize
"self initialize"
FileList registerFileReader: self
!
----- Method: DummyToolWorkingWithFileList class>>loadAFileForTheDummyTool: (in category 'class initialization') -----
loadAFileForTheDummyTool: aFileListOrAPath
"attention. if the file list selects a file the argument will be a fullpath of the selected file else it will pass the filelist itself"!
----- Method: DummyToolWorkingWithFileList class>>serviceLoadAFilForDummyTool (in category 'class initialization') -----
serviceLoadAFilForDummyTool
"Answer a service for opening the Dummy tool"
^ SimpleServiceEntry
provider: self
label: 'menu label'
selector: #loadAFileForTheDummyTool:
description: 'Menu label for dummy tool'
buttonLabel: 'test'!
----- Method: DummyToolWorkingWithFileList class>>services (in category 'class initialization') -----
services
^ Array with: self serviceLoadAFilForDummyTool
!
----- Method: DummyToolWorkingWithFileList class>>unload (in category 'class initialization') -----
unload
FileList unregisterFileReader: self !
----- Method: DummyToolWorkingWithFileList class>>unregister (in category 'class initialization') -----
unregister
FileList unregisterFileReader: self.
!
----- Method: Object>>browse (in category '*tools-browser') -----
browse
self systemNavigation browseClass: self class!
----- Method: Object>>browseHierarchy (in category '*tools-browser') -----
browseHierarchy
self systemNavigation browseHierarchy: self class!
----- Method: Object>>exploreAndYourself (in category '*Tools-Explorer') -----
exploreAndYourself
"i.e. explore; yourself. Thisway i can peek w/o typing all the parentheses"
self explore.
^self!
----- Method: Object>>exploreWithLabel: (in category '*Tools-Explorer') -----
exploreWithLabel: label
^ ObjectExplorer new openExplorerFor: self withLabel:
label!
Object subclass: #StandardToolSet
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Base'!
!StandardToolSet commentStamp: '<historical>' prior: 0!
Main comment stating the purpose of this class and relevant relationship to other classes.
Possible useful expressions for doIt or printIt.
Structure:
instVar1 type -- comment about the purpose of instVar1
instVar2 type -- comment about the purpose of instVar2
Any further useful comments about the general approach of this implementation.!
----- Method: StandardToolSet class>>basicInspect: (in category 'inspecting') -----
basicInspect: anObject
"Open an inspector on the given object. The tool set must know which inspector type to use for which object - the object cannot possibly know what kind of inspectors the toolset provides."
^BasicInspector openOn: anObject!
----- Method: StandardToolSet class>>browse:selector: (in category 'browsing') -----
browse: aClass selector: aSelector
"Open a browser"
^SystemBrowser default fullOnClass: aClass selector: aSelector!
----- Method: StandardToolSet class>>browseChangeSetsWithClass:selector: (in category 'browsing') -----
browseChangeSetsWithClass: aClass selector: aSelector
"Browse all the change sets with the given class/selector"
^ChangeSorter browseChangeSetsWithClass: aClass selector: aSelector!
----- Method: StandardToolSet class>>browseHierarchy:selector: (in category 'browsing') -----
browseHierarchy: aClass selector: aSelector
"Open a browser"
| newBrowser |
(aClass == nil) ifTrue: [^ self].
(newBrowser := SystemBrowser default new) setClass: aClass selector: aSelector.
newBrowser spawnHierarchy.!
----- Method: StandardToolSet class>>browseMessageNames: (in category 'browsing') -----
browseMessageNames: aString
^(MessageNames methodBrowserSearchingFor: aString) openInWorld!
----- Method: StandardToolSet class>>browseMessageSet:name:autoSelect: (in category 'browsing') -----
browseMessageSet: messageList name: title autoSelect: autoSelectString
"Open a message set browser"
^MessageSet
openMessageList: messageList
name: title
autoSelect: autoSelectString!
----- Method: StandardToolSet class>>browseVersionsOf:selector: (in category 'browsing') -----
browseVersionsOf: aClass selector: aSelector
"Open a browser"
VersionsBrowser
browseVersionsOf: (aClass compiledMethodAt: aSelector)
class: aClass theNonMetaClass
meta: aClass isMeta
category: (aClass organization categoryOfElement: aSelector)
selector: aSelector!
----- Method: StandardToolSet class>>debug:context:label:contents:fullView: (in category 'debugging') -----
debug: aProcess context: aContext label: aString contents: contents fullView: aBool
"Open a debugger on the given process and context."
^Debugger openOn: aProcess context: aContext label: aString contents: contents fullView: aBool!
----- Method: StandardToolSet class>>debugContext:label:contents: (in category 'debugging') -----
debugContext: aContext label: aString contents: contents
"Open a debugger on the given process and context."
^Debugger openContext: aContext label: aString contents: contents!
----- Method: StandardToolSet class>>debugError: (in category 'debugging') -----
debugError: anError
"Handle an otherwise unhandled error"
^Processor activeProcess
debug: anError signalerContext
title: anError description!
----- Method: StandardToolSet class>>debugSyntaxError: (in category 'debugging') -----
debugSyntaxError: anError
"Handle a syntax error"
| notifier |
notifier := SyntaxError new
setClass: anError errorClass
code: anError errorCode
debugger: (Debugger context: anError signalerContext)
doitFlag: anError doitFlag.
notifier category: anError category.
SyntaxError open: notifier.!
----- Method: StandardToolSet class>>explore: (in category 'inspecting') -----
explore: anObject
"Open an explorer on the given object."
^ObjectExplorer new openExplorerFor: anObject!
----- Method: StandardToolSet class>>initialize (in category 'class initialization') -----
initialize
ToolSet register: self.
Preferences installMissingWindowColors.!
----- Method: StandardToolSet class>>inspect: (in category 'inspecting') -----
inspect: anObject
"Open an inspector on the given object. The tool set must know which inspector type to use for which object - the object cannot possibly know what kind of inspectors the toolset provides."
^(self inspectorClassOf: anObject) openOn: anObject!
----- Method: StandardToolSet class>>inspect:label: (in category 'inspecting') -----
inspect: anObject label: aString
"Open an inspector on the given object. The tool set must know which inspector type to use for which object - the object cannot possibly know what kind of inspectors the toolset provides."
^(self inspectorClassOf: anObject) openOn: anObject withEvalPane: true withLabel: aString!
----- Method: StandardToolSet class>>inspectorClassOf: (in category 'inspecting') -----
inspectorClassOf: anObject
"Answer the inspector class for the given object. The tool set must know which inspector type to use for which object - the object cannot possibly know what kind of inspectors the toolset provides."
| map |
map := Dictionary new.
#(
(CompiledMethod CompiledMethodInspector)
(CompositeEvent OrderedCollectionInspector)
(Dictionary DictionaryInspector)
(ExternalStructure ExternalStructureInspector)
(FloatArray OrderedCollectionInspector)
(OrderedCollection OrderedCollectionInspector)
(Set SetInspector)
(WeakSet WeakSetInspector)
) do:[:spec|
map at: spec first put: spec last.
].
anObject class withAllSuperclassesDo:[:cls|
map at: cls name ifPresent:[:inspectorName| ^Smalltalk classNamed: inspectorName].
].
^Inspector!
----- Method: StandardToolSet class>>interrupt:label: (in category 'debugging') -----
interrupt: aProcess label: aString
"Open a debugger on the given process and context."
Debugger
openInterrupt: aString
onProcess: aProcess!
----- Method: StandardToolSet class>>menuItems (in category 'menu') -----
menuItems
"Answer the menu items available for this tool set"
^#(
('class browser' #openClassBrowser)
('workspace' #openWorkspace)
('file list' #openFileList)
('package pane browser' #openPackagePaneBrowser)
('process browser' #openProcessBrowser)
-
('method finder' #openSelectorBrowser)
('message names' #openMessageNames)
-
('simple change sorter' #openChangeSorter)
('dual change sorter' #openDualChangeSorter)
)
!
----- Method: StandardToolSet class>>openChangeSorter (in category 'menu') -----
openChangeSorter
ToolBuilder open: ChangeSorter new!
----- Method: StandardToolSet class>>openChangedMessageSet: (in category 'browsing') -----
openChangedMessageSet: aChangeSet
"Open a ChangedMessageSet for aChangeSet"
ChangedMessageSet openFor: aChangeSet!
----- Method: StandardToolSet class>>openClassBrowser (in category 'menu') -----
openClassBrowser
SystemBrowser default open!
----- Method: StandardToolSet class>>openClassListBrowser:title: (in category 'browsing') -----
openClassListBrowser: anArray title: aString
"Open a class list browser"
^ClassListBrowser new initForClassesNamed: anArray title: aString
!
----- Method: StandardToolSet class>>openDualChangeSorter (in category 'menu') -----
openDualChangeSorter
ToolBuilder open: DualChangeSorter new!
----- Method: StandardToolSet class>>openFileList (in category 'menu') -----
openFileList
FileList open!
----- Method: StandardToolSet class>>openMessageNames (in category 'menu') -----
openMessageNames
"Bring a MessageNames tool to the front"
MessageNames openMessageNames!
----- Method: StandardToolSet class>>openPackagePaneBrowser (in category 'menu') -----
openPackagePaneBrowser
PackagePaneBrowser openBrowser.!
----- Method: StandardToolSet class>>openProcessBrowser (in category 'menu') -----
openProcessBrowser
ProcessBrowser open!
----- Method: StandardToolSet class>>openSelectorBrowser (in category 'menu') -----
openSelectorBrowser
ToolBuilder open: SelectorBrowser new!
----- Method: StandardToolSet class>>openWorkspace (in category 'menu') -----
openWorkspace
Workspace open!
----- Method: StandardToolSet class>>unload (in category 'class initialization') -----
unload
ToolSet unregister: self.!
----- Method: WeakSet>>inspectorClass (in category '*Tools-Inspector') -----
inspectorClass
^ WeakSetInspector!
SystemWindow subclass: #ArchiveViewer
instanceVariableNames: 'archive fileName memberIndex viewAllContents'
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-ArchiveViewer'!
!ArchiveViewer commentStamp: '<historical>' prior: 0!
This is a viewer window that allows editing and viewing of Zip archives.!
----- Method: ArchiveViewer class>>addFileToNewZip: (in category 'instance creation') -----
addFileToNewZip: fullName
"Add the currently selected file to a new zip"
| zip |
zip := (ZipArchive new)
addFile: fullName
as: (FileDirectory localNameFor: fullName); yourself.
(self open) archive: zip
!
----- Method: ArchiveViewer class>>deleteTemporaryDirectory (in category 'class initialization') -----
deleteTemporaryDirectory
"
ArchiveViewer deleteTemporaryDirectory
"
| dir |
(dir := self temporaryDirectory) exists ifTrue: [ dir recursiveDelete ].!
----- Method: ArchiveViewer class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
^ self partName: 'Zip Tool'
categories: #(Tools)
documentation: 'A viewer and editor for Zip archive files'
!
----- Method: ArchiveViewer class>>extractAllFrom: (in category 'file list services') -----
extractAllFrom: aFileName
(self new) fileName: aFileName; extractAll!
----- Method: ArchiveViewer class>>fileReaderServicesForFile:suffix: (in category 'fileIn/Out') -----
fileReaderServicesForFile: fullName suffix: suffix
| services |
services := OrderedCollection new.
services add: self serviceAddToNewZip.
({'zip'.'sar'.'pr'. 'mcz'. '*'} includes: suffix)
ifTrue: [services add: self serviceOpenInZipViewer.
services add: self serviceExtractAll].
^ services!
----- Method: ArchiveViewer class>>initialize (in category 'class initialization') -----
initialize
"ArchiveViewer initialize"
FileList registerFileReader: self.
Smalltalk addToShutDownList: self.!
----- Method: ArchiveViewer class>>open (in category 'instance creation') -----
open
^(self new) createWindow; openInWorld.!
----- Method: ArchiveViewer class>>openOn: (in category 'instance creation') -----
openOn: aFileName
| newMe |
newMe := self new.
newMe createWindow; fileName: aFileName; openInWorld.
^newMe!
----- Method: ArchiveViewer class>>serviceAddToNewZip (in category 'file list services') -----
serviceAddToNewZip
"Answer a service for adding the file to a new zip"
^ FileModifyingSimpleServiceEntry
provider: self
label: 'add file to new zip'
selector: #addFileToNewZip:
description: 'add file to new zip'
buttonLabel: 'to new zip'!
----- Method: ArchiveViewer class>>serviceExtractAll (in category 'file list services') -----
serviceExtractAll
"Answer a service for opening in a zip viewer"
^ FileModifyingSimpleServiceEntry
provider: self
label: 'extract all to...'
selector: #extractAllFrom:
description: 'extract all files to a user-specified directory'
buttonLabel: 'extract all'!
----- Method: ArchiveViewer class>>serviceOpenInZipViewer (in category 'class initialization') -----
serviceOpenInZipViewer
"Answer a service for opening in a zip viewer"
^ SimpleServiceEntry
provider: self
label: 'open in zip viewer'
selector: #openOn:
description: 'open in zip viewer'
buttonLabel: 'open zip'!
----- Method: ArchiveViewer class>>services (in category 'fileIn/Out') -----
services
^ Array
with: self serviceAddToNewZip
with: self serviceOpenInZipViewer
!
----- Method: ArchiveViewer class>>shutDown: (in category 'class initialization') -----
shutDown: quitting
quitting ifTrue: [ self deleteTemporaryDirectory ].!
----- Method: ArchiveViewer class>>temporaryDirectory (in category 'fileIn/Out') -----
temporaryDirectory
"Answer a directory to use for unpacking files for the file list services."
^FileDirectory default directoryNamed: '.archiveViewerTemp'!
----- Method: ArchiveViewer class>>unload (in category 'initialize-release') -----
unload
FileList unregisterFileReader: self !
----- Method: ArchiveViewer>>addDirectory (in category 'member operations') -----
addDirectory
| directory |
self canAddMember ifFalse: [ ^self ].
directory := FileList2 modalFolderSelector.
directory
ifNil: [^ self].
archive addTree: directory removingFirstCharacters: directory pathName size + 1.
self memberIndex: 0.
self changed: #memberList.!
----- Method: ArchiveViewer>>addMember (in category 'member operations') -----
addMember
| result local full |
self canAddMember ifFalse: [ ^self ].
result := FileList2 modalFileSelector .
result ifNil: [ ^self ].
local := result directory localNameFor: result name.
full := result directory fullNameFor: result name.
(archive addFile: full as: local)
desiredCompressionMethod: ZipArchive compressionDeflated.
self memberIndex: self members size.
self changed: #memberList.!
----- Method: ArchiveViewer>>addMemberFromClipboard (in category 'member operations') -----
addMemberFromClipboard
| string newName |
self canAddMember ifFalse: [ ^self ].
string := Clipboard clipboardText asString.
newName := FillInTheBlankMorph
request: 'New name for member:'
initialAnswer: 'clipboardText'.
newName notEmpty ifTrue: [
(archive addString: string as: newName) desiredCompressionMethod: ZipArchive compressionDeflated.
self memberIndex: self members size.
self changed: #memberList.
]
!
----- Method: ArchiveViewer>>archive (in category 'accessing') -----
archive
^archive!
----- Method: ArchiveViewer>>archive: (in category 'initialization') -----
archive: aZipArchive
archive := aZipArchive.
self model: aZipArchive.
self setLabel: 'New Zip Archive'.
self memberIndex: 0.
self changed: #memberList!
----- Method: ArchiveViewer>>briefContents (in category 'initialization') -----
briefContents
"Trim to 5000 characters. If the member is longer, then point out that it is trimmed.
Also warn if the member has a corrupt CRC-32."
| stream subContents errorMessage |
self selectedMember ifNil: [^ ''].
errorMessage := ''.
stream := WriteStream on: (String new: (self selectedMember uncompressedSize min: 5500)).
[ self selectedMember uncompressedSize > 5000
ifTrue: [ | lastLineEndingIndex tempIndex |
subContents := self selectedMember contentsFrom: 1 to: 5000.
lastLineEndingIndex := subContents lastIndexOf: Character cr.
tempIndex := subContents lastIndexOf: Character lf.
tempIndex > lastLineEndingIndex ifTrue: [lastLineEndingIndex := tempIndex].
lastLineEndingIndex = 0
ifFalse: [subContents := subContents copyFrom: 1 to: lastLineEndingIndex]]
ifFalse: [ subContents := self selectedMember contents ]]
on: CRCError do: [ :ex |
errorMessage := String streamContents: [ :s |
s nextPutAll: '[ ';
nextPutAll: (ex messageText copyUpToLast: $( );
nextPutAll: ' ]' ].
ex proceed ].
(errorMessage isEmpty not or: [ self selectedMember isCorrupt ]) ifTrue: [
stream nextPutAll: '********** WARNING!! Member is corrupt!! ';
nextPutAll: errorMessage;
nextPutAll: ' **********'; cr ].
self selectedMember uncompressedSize > 5000
ifTrue: [
stream nextPutAll: 'File ';
print: self selectedMember fileName;
nextPutAll: ' is ';
print: self selectedMember uncompressedSize;
nextPutAll: ' bytes long.'; cr;
nextPutAll: 'Click the ''View All Contents'' button above to see the entire file.'; cr; cr;
nextPutAll: 'Here are the first ';
print: subContents size;
nextPutAll: ' characters...'; cr;
next: 40 put: $-; cr;
nextPutAll: subContents;
next: 40 put: $-; cr;
nextPutAll: '... end of the first ';
print: subContents size;
nextPutAll: ' characters.' ]
ifFalse: [ stream nextPutAll: self selectedMember contents ].
^stream contents
!
----- Method: ArchiveViewer>>buildWindowMenu (in category 'menu') -----
buildWindowMenu
| menu |
menu := super buildWindowMenu.
menu addLine.
menu add: 'inspect archive' target: archive action: #inspect.
menu add: 'write prepending file...' target: self action: #writePrependingFile.
^menu.!
----- Method: ArchiveViewer>>buttonColor (in category 'initialization') -----
buttonColor
^self defaultBackgroundColor darker!
----- Method: ArchiveViewer>>buttonOffColor (in category 'initialization') -----
buttonOffColor
^self defaultBackgroundColor darker!
----- Method: ArchiveViewer>>buttonOnColor (in category 'initialization') -----
buttonOnColor
^self defaultBackgroundColor!
----- Method: ArchiveViewer>>canAddMember (in category 'member operations') -----
canAddMember
^archive notNil!
----- Method: ArchiveViewer>>canCreateNewArchive (in category 'archive operations') -----
canCreateNewArchive
^true!
----- Method: ArchiveViewer>>canDeleteMember (in category 'member operations') -----
canDeleteMember
^memberIndex > 0!
----- Method: ArchiveViewer>>canExtractAll (in category 'archive operations') -----
canExtractAll
^self members notEmpty!
----- Method: ArchiveViewer>>canExtractMember (in category 'member operations') -----
canExtractMember
^memberIndex > 0!
----- Method: ArchiveViewer>>canOpenNewArchive (in category 'archive operations') -----
canOpenNewArchive
^true!
----- Method: ArchiveViewer>>canRenameMember (in category 'member operations') -----
canRenameMember
^memberIndex > 0!
----- Method: ArchiveViewer>>canSaveArchive (in category 'archive operations') -----
canSaveArchive
^archive notNil!
----- Method: ArchiveViewer>>canViewAllContents (in category 'member operations') -----
canViewAllContents
^memberIndex > 0 and: [ viewAllContents not ]!
----- Method: ArchiveViewer>>changeViewAllContents (in category 'member operations') -----
changeViewAllContents
(viewAllContents not and: [ self selectedMember notNil and: [ self selectedMember uncompressedSize > 50000 ]])
ifTrue: [ (self confirm: 'This member''s size is ',
(self selectedMember uncompressedSize asString),
'; do you really want to see all that data?')
ifFalse: [ ^self ]
].
viewAllContents := viewAllContents not.
self changed: #contents!
----- Method: ArchiveViewer>>commentArchive (in category 'archive operations') -----
commentArchive
| newName |
archive ifNil: [ ^self ].
newName := FillInTheBlankMorph
request: 'New comment for archive:'
initialAnswer: archive zipFileComment
centerAt: Sensor cursorPoint
inWorld: self world
onCancelReturn: archive zipFileComment
acceptOnCR: true.
archive zipFileComment: newName.!
----- Method: ArchiveViewer>>commentMember (in category 'member operations') -----
commentMember
| newName |
newName := FillInTheBlankMorph
request: 'New comment for member:'
initialAnswer: self selectedMember fileComment
centerAt: Sensor cursorPoint
inWorld: self world
onCancelReturn: self selectedMember fileComment
acceptOnCR: true.
self selectedMember fileComment: newName.!
----- Method: ArchiveViewer>>contents (in category 'initialization') -----
contents
| contents errorMessage |
self selectedMember ifNil: [^ ''].
viewAllContents ifFalse: [^ self briefContents].
[ contents := self selectedMember contents ]
on: CRCError
do: [ :ex | errorMessage := String streamContents: [ :stream |
stream nextPutAll: '********** WARNING!! Member is corrupt!! [ ';
nextPutAll: (ex messageText copyUpToLast: $( );
nextPutAll: '] **********'; cr ].
ex proceed ].
^self selectedMember isCorrupt
ifFalse: [ contents ]
ifTrue: [ errorMessage, contents ]!
----- Method: ArchiveViewer>>contents: (in category 'initialization') -----
contents: aText
self shouldNotImplement.!
----- Method: ArchiveViewer>>createButtonBar (in category 'initialization') -----
createButtonBar
| bar button narrowFont registeredFonts |
registeredFonts := OrderedCollection new.
TextStyle knownTextStylesWithoutDefault do:
[:st | (TextStyle named: st) fonts do: [:f | registeredFonts addLast: f]].
narrowFont := registeredFonts detectMin:
[:ea | ea widthOfString: 'Contents' from: 1 to: 8].
bar := AlignmentMorph newRow.
bar
color: self defaultBackgroundColor;
rubberBandCells: false;
vResizing: #shrinkWrap;
cellInset: 6 @ 0.
#(#('New\Archive' #canCreateNewArchive #createNewArchive 'Create a new, empty archive and discard this one') #('Load\Archive' #canOpenNewArchive #openNewArchive 'Open another archive and discard this one') #('Save\Archive As' #canSaveArchive #saveArchive 'Save this archive under a new name') #('Extract\All' #canExtractAll #extractAll 'Extract all this archive''s members into a directory') #('Add\File' #canAddMember #addMember 'Add a file to this archive') #('Add from\Clipboard' #canAddMember #addMemberFromClipboard 'Add the contents of the clipboard as a new file') #('Add\Directory' #canAddMember #addDirectory 'Add the entire contents of a directory, with all of its subdirectories') #('Extract\Member As' #canExtractMember #extractMember 'Extract the selected member to a file') #('Delete\Member' #canDeleteMember #deleteMember 'Remove the selected member from this archive') #('Rename\Member' #canRenameMember #renameMember 'Rename the selected member') #('View All\Contents' #canViewAllContents #changeViewAllContents 'Toggle the view of all the selected member''s contents'))
do:
[:arr |
| buttonLabel |
buttonLabel := (TextMorph new)
string: arr first withCRs
fontName: narrowFont familyName
size: narrowFont pointSize
wrap: false;
hResizing: #shrinkWrap;
lock;
yourself.
(button := PluggableButtonMorph
on: self
getState: arr second
action: arr third)
vResizing: #shrinkWrap;
hResizing: #spaceFill;
onColor: self buttonOnColor offColor: self buttonOffColor;
label: buttonLabel;
setBalloonText: arr fourth.
bar addMorphBack: button.
buttonLabel composeToBounds].
^bar!
----- Method: ArchiveViewer>>createListHeadingUsingFont: (in category 'initialization') -----
createListHeadingUsingFont: font
| sm |
sm := StringMorph contents: ' order uncomp comp CRC-32 date time file name'.
font ifNotNil: [ sm font: font ].
^(AlignmentMorph newColumn)
color: self defaultBackgroundColor;
addMorph: sm;
yourself.!
----- Method: ArchiveViewer>>createNewArchive (in category 'archive operations') -----
createNewArchive
self setLabel: '(new archive)'.
archive := ZipArchive new.
self memberIndex: 0.
self changed: #memberList.!
----- Method: ArchiveViewer>>createWindow (in category 'initialization') -----
createWindow
| list heading font text buttonBar |
font := (TextStyle named: #DefaultFixedTextStyle)
ifNotNilDo: [ :ts | ts fontArray first].
buttonBar := self createButtonBar.
self addMorph: buttonBar
fullFrame: (LayoutFrame fractions: (0 at 0 corner: 1.0 at 0.0) offsets: (0 at 0 corner: 0 at 44)).
self minimumExtent: (buttonBar fullBounds width + 20) @ 230.
self extent: self minimumExtent.
heading := self createListHeadingUsingFont: font.
self addMorph: heading
fullFrame: (LayoutFrame fractions: (0 at 0 corner: 1.0 at 0.0) offsets: (0 at 44 corner: 0 at 60)).
(list := PluggableListMorph new)
on: self list: #memberList
selected: #memberIndex changeSelected: #memberIndex:
menu: #memberMenu:shifted: keystroke: nil.
list color: self defaultBackgroundColor.
font ifNotNil: [list font: font].
self addMorph: list
fullFrame: (LayoutFrame fractions: (0 at 0 corner: 1.0 at 0.8) offsets: (0 at 60 corner: 0 at 0)).
text := PluggableTextMorph on: self
text: #contents accept: nil
readSelection: nil menu: nil.
self addMorph: text
frame: (0 at 0.8 corner: 1.0 at 1.0).
text lock.
self setLabel: 'Ned''s Zip Viewer'!
----- Method: ArchiveViewer>>deleteMember (in category 'member operations') -----
deleteMember
self canDeleteMember ifFalse: [ ^self ].
archive removeMember: self selectedMember.
self memberIndex: 0.
self changed: #memberList.
!
----- Method: ArchiveViewer>>directory (in category 'accessing') -----
directory
"For compatibility with file list."
^self error: 'should use readOnlyStream instead!!'!
----- Method: ArchiveViewer>>displayLineFor: (in category 'member list') -----
displayLineFor: aMember
| stream dateTime index |
index := self archive members indexOf: aMember.
stream := WriteStream on: (String new: 60).
dateTime := Time dateAndTimeFromSeconds: aMember lastModTime.
stream
nextPutAll: (index printString padded: #left to: 4 with: $ );
space;
nextPutAll: (aMember uncompressedSize printString padded: #left to: 8 with: $ );
space; space;
nextPutAll: (aMember compressedSize printString padded: #left to: 8 with: $ );
space; space;
nextPutAll: (aMember crc32String );
space; space.
dateTime first printOn: stream format: #(3 2 1 $- 2 1 2).
stream space; space.
dateTime second print24: true showSeconds: false on: stream.
stream space; space;
nextPutAll: (aMember fileName ).
^stream contents!
----- Method: ArchiveViewer>>downMember (in category 'member order') -----
downMember
| temp |
temp := (self archive members) at: memberIndex.
self archive members at: memberIndex put: (self archive members at: memberIndex + 1).
self archive members at: (memberIndex +1) put: temp.
self memberIndex: 0.
self changed: #memberList.!
----- Method: ArchiveViewer>>extractAll (in category 'archive operations') -----
extractAll
| directory |
self canExtractAll ifFalse: [^ self].
directory := FileList2 modalFolderSelector ifNil: [^ self].
archive extractAllTo: directory.!
----- Method: ArchiveViewer>>extractAllPossibleInDirectory: (in category 'archive operations') -----
extractAllPossibleInDirectory: directory
"Answer true if I can extract all the files in the given directory safely.
Inform the user as to problems."
| conflicts |
self canExtractAll ifFalse: [ ^false ].
conflicts := Set new.
self members do: [ :ea | | fullName |
fullName := directory fullNameFor: ea localFileName.
(ea usesFileNamed: fullName) ifTrue: [ conflicts add: fullName ].
].
conflicts notEmpty ifTrue: [ | str |
str := WriteStream on: (String new: 200).
str nextPutAll: 'The following file(s) are needed by archive members and cannot be overwritten:';
cr.
conflicts do: [ :ea | str nextPutAll: ea ] separatedBy: [ str cr ].
self inform: str contents.
^false.
].
conflicts := Set new.
self members do: [ :ea | | fullName |
fullName := directory relativeNameFor: ea localFileName.
(directory fileExists: fullName)
ifTrue: [ conflicts add: fullName ].
].
conflicts notEmpty ifTrue: [ | str |
str := WriteStream on: (String new: 200).
str nextPutAll: 'The following file(s) will be overwritten:'; cr.
conflicts do: [ :ea | str nextPutAll: ea ] separatedBy: [ str cr ].
str cr; nextPutAll: 'Is this OK?'.
^self confirm: str contents.
].
^true.
!
----- Method: ArchiveViewer>>extractDirectoriesIntoDirectory: (in category 'archive operations') -----
extractDirectoriesIntoDirectory: directory
(self members select: [:ea | ea isDirectory])
do: [:ea | ea extractInDirectory: directory]!
----- Method: ArchiveViewer>>extractFilesIntoDirectory: (in category 'archive operations') -----
extractFilesIntoDirectory: directory
(self members reject: [:ea | ea isDirectory])
do: [:ea | ea extractInDirectory: directory]!
----- Method: ArchiveViewer>>extractMember (in category 'member operations') -----
extractMember
"Extract the member after prompting for a filename.
Answer the filename, or nil if error."
| result name |
self canExtractMember ifFalse: [ ^nil ].
result := StandardFileMenu newFile.
result ifNil: [ ^nil ].
name := (result directory fullNameFor: result name).
(archive canWriteToFileNamed: name)
ifFalse: [ self inform: name, ' is used by one or more members
in your archive, and cannot be overwritten.
Try extracting to another file name'.
^nil ].
self selectedMember extractToFileNamed: name.
^name!
----- Method: ArchiveViewer>>fileName (in category 'accessing') -----
fileName
^fileName!
----- Method: ArchiveViewer>>fileName: (in category 'initialization') -----
fileName: aString
archive := ZipArchive new readFrom: aString.
self setLabel: aString.
self memberIndex: 0.
self changed: #memberList!
----- Method: ArchiveViewer>>fullName (in category 'accessing') -----
fullName
"For compatibility with FileList services.
If this is called, it means that a service that requires a real filename has been requested.
So extract the selected member to a temporary file and return that name."
| fullName dir |
self canExtractMember ifFalse: [ ^nil ].
dir := FileDirectory default directoryNamed: '.archiveViewerTemp'.
fullName := dir fullNameFor: self selectedMember localFileName.
self selectedMember extractInDirectory: dir.
^fullName!
----- Method: ArchiveViewer>>highlightMemberList:with: (in category 'member list') -----
highlightMemberList: list with: morphList
(morphList at: self memberIndex) color: Color red!
----- Method: ArchiveViewer>>initialize (in category 'initialization') -----
initialize
super initialize.
memberIndex := 0.
viewAllContents := false.
!
----- Method: ArchiveViewer>>initializeToStandAlone (in category 'parts bin') -----
initializeToStandAlone
self initialize createWindow.!
----- Method: ArchiveViewer>>inspectMember (in category 'member operations') -----
inspectMember
self selectedMember inspect!
----- Method: ArchiveViewer>>memberIndex (in category 'member list') -----
memberIndex
^memberIndex!
----- Method: ArchiveViewer>>memberIndex: (in category 'member list') -----
memberIndex: n
memberIndex := n.
viewAllContents := false.
self changed: #memberIndex.
self changed: #contents.!
----- Method: ArchiveViewer>>memberList (in category 'member list') -----
memberList
^ self members collect: [ :ea | self displayLineFor: ea ]!
----- Method: ArchiveViewer>>memberMenu:shifted: (in category 'member list') -----
memberMenu: menu shifted: shifted
| services |
menu
add: 'Comment archive' target: self selector: #commentArchive;
balloonTextForLastItem: 'Add a comment for the entire archive'.
self selectedMember ifNotNilDo: [ :member |
menu
addLine;
add: 'Inspect member' target: self selector: #inspectMember;
balloonTextForLastItem: 'Inspect the selected member';
add: 'Comment member' target: self selector: #commentMember;
balloonTextForLastItem: 'Add a comment for the selected member';
addLine;
add: 'member go up in order ' target: self selector: #upMember;
add: 'member go down in order ' target: self selector: #downMember;
add: 'select member order ' target: self selector: #toIndexPlace;
addLine.
services := FileList itemsForFile: member fileName.
menu addServices2: services for: self extraLines: #().
].
^menu!
----- Method: ArchiveViewer>>members (in category 'accessing') -----
members
^archive ifNil: [ #() asOrderedCollection ]
ifNotNil: [ archive members asOrderedCollection ]!
----- Method: ArchiveViewer>>openNewArchive (in category 'archive operations') -----
openNewArchive
| result |
result := FileList2 modalFileSelector .
result ifNil: [ ^self ].
self fileName: (result directory fullNameFor: result name).
!
----- Method: ArchiveViewer>>perform:orSendTo: (in category 'message handling') -----
perform: selector orSendTo: otherTarget
^ self perform: selector!
----- Method: ArchiveViewer>>readOnlyStream (in category 'accessing') -----
readOnlyStream
"Answer a read-only stream on the selected member.
For the various stream-reading services."
^self selectedMember ifNotNilDo: [ :mem | mem contentStream ascii ]!
----- Method: ArchiveViewer>>renameMember (in category 'member operations') -----
renameMember
| newName |
self canRenameMember ifFalse: [ ^self ].
newName := FillInTheBlankMorph
request: 'New name for member:'
initialAnswer: self selectedMember fileName.
newName notEmpty ifTrue: [
self selectedMember fileName: newName.
self changed: #memberList
]!
----- Method: ArchiveViewer>>saveArchive (in category 'archive operations') -----
saveArchive
| result name |
name := FileDirectory localNameFor: labelString .
self canSaveArchive ifFalse: [ ^self ].
result := UIManager default
request: 'Name this zip '
initialAnswer: name.
result ifNil: [ ^self ].
(archive canWriteToFileNamed: result)
ifFalse: [ self inform: name, ' is used by one or more members
in your archive, and cannot be overwritten.
Try writing to another file name'.
^self ].
[ archive writeToFileNamed: result ] on: Error do: [ :ex | self inform: ex description. ].
self setLabel: name asString.
self changed: #memberList "in case CRC's and compressed sizes got set"!
----- Method: ArchiveViewer>>selectedMember (in category 'accessing') -----
selectedMember
^memberIndex
ifNil: [ nil ]
ifNotNil: [ self members at: memberIndex ifAbsent: [ ] ]!
----- Method: ArchiveViewer>>stream: (in category 'initialization') -----
stream: aStream
archive := ZipArchive new readFrom: aStream.
self setLabel: aStream fullName.
self memberIndex: 0.
self changed: #memberList!
----- Method: ArchiveViewer>>toIndexPlace (in category 'member order') -----
toIndexPlace
| index max temp |
max := self archive members size.
index :=0.
[index := (UIManager default
request: 'To which index '
initialAnswer: '1') asInteger.
index between: 1 and: max] whileFalse.
temp := (self archive members) at: memberIndex.
self archive members at: memberIndex put: (self archive members at: index).
self archive members at: index put: temp.
self memberIndex: 0.
self changed: #memberList.!
----- Method: ArchiveViewer>>upMember (in category 'member order') -----
upMember
| temp |
temp := (self archive members) at: memberIndex.
self archive members at: memberIndex put: (self archive members at: memberIndex -1).
self archive members at: (memberIndex -1) put: temp.
self memberIndex: 0.
self changed: #memberList.!
----- Method: ArchiveViewer>>windowIsClosing (in category 'initialization') -----
windowIsClosing
archive ifNotNil: [ archive close ].!
----- Method: ArchiveViewer>>writePrependingFile (in category 'archive operations') -----
writePrependingFile
| result name prependedName |
self canSaveArchive ifFalse: [ ^self ].
result := (StandardFileMenu newFileMenu: FileDirectory default)
startUpWithCaption: 'Destination Zip File Name:'.
result ifNil: [ ^self ].
name := result directory fullNameFor: result name.
(archive canWriteToFileNamed: name)
ifFalse: [ self inform: name, ' is used by one or more members
in your archive, and cannot be overwritten.
Try writing to another file name'.
^self ].
result := (StandardFileMenu oldFileMenu: FileDirectory default)
startUpWithCaption: 'Prepended File:'.
result ifNil: [ ^self ].
prependedName := result directory fullNameFor: result name.
[ archive writeToFileNamed: name prependingFileNamed: prependedName ]
on: Error
do: [ :ex | self inform: ex description. ].
self changed: #memberList "in case CRC's and compressed sizes got set"!
StandardSystemController subclass: #DeferredActionStandardSystemController
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Process Browser'!
!DeferredActionStandardSystemController commentStamp: 'dtl 9/20/2009 18:39' prior: 0!
Deprecated (Sept 2009) - The DeferredActionStandardSystemController has been merged into Controller. This class remains as a stub to guard ensure that any external packages that depend on it remain functional.
This is a StandardSystemController that can queue up objects to be evaluated before its control loop.!
----- Method: ComponentLayout>>inspectModelInMorphic (in category '*Tools') -----
inspectModelInMorphic
| insp |
insp := InspectorBrowser openOn: self model.
self world addMorph: insp; startStepping: insp!
TestCase subclass: #BrowseTest
instanceVariableNames: 'originalBrowserClass originalHierarchyBrowserClass'
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Browser-Tests'!
----- Method: BrowseTest>>currentBrowsers (in category 'private') -----
currentBrowsers
^ (ActiveWorld submorphs
select: [:each | (each isKindOf: SystemWindow)
and: [each model isKindOf: Browser]]) asSet!
----- Method: BrowseTest>>currentHierarchyBrowsers (in category 'private') -----
currentHierarchyBrowsers
^ (ActiveWorld submorphs
select: [:each | (each isKindOf: SystemWindow)
and: [each model isKindOf: HierarchyBrowser]]) asSet!
----- Method: BrowseTest>>ensureMorphic (in category 'private') -----
ensureMorphic
self isMorphic ifFalse: [self error: 'This test should be run in Morphic'].!
----- Method: BrowseTest>>isMorphic (in category 'private') -----
isMorphic
^Smalltalk isMorphic!
----- Method: BrowseTest>>setUp (in category 'running') -----
setUp
| systemNavigation |
systemNavigation := SystemNavigation default.
originalBrowserClass := systemNavigation browserClass.
originalHierarchyBrowserClass := systemNavigation hierarchyBrowserClass.
systemNavigation browserClass: nil.
systemNavigation hierarchyBrowserClass: nil.
!
----- Method: BrowseTest>>tearDown (in category 'running') -----
tearDown
| systemNavigation |
systemNavigation := SystemNavigation default.
systemNavigation browserClass: originalBrowserClass.
systemNavigation hierarchyBrowserClass: originalHierarchyBrowserClass.!
----- Method: BrowseTest>>testBrowseClass (in category 'testing') -----
testBrowseClass
"self debug: #testBrowseClass"
| browsersBefore browsersAfter opened |
self ensureMorphic.
browsersBefore := self currentBrowsers.
1 class browse.
browsersAfter := self currentBrowsers.
self assert: (browsersAfter size = (browsersBefore size + 1)).
opened := browsersAfter removeAll: browsersBefore; yourself.
self assert: (opened size = 1).
opened := opened asArray first.
self assert: (opened model selectedClass == SmallInteger).
opened delete
!
----- Method: BrowseTest>>testBrowseHierarchyClass (in category 'testing') -----
testBrowseHierarchyClass
"self debug: #testBrowseHierarchyClass"
| browsersBefore browsersAfter opened |
self ensureMorphic.
browsersBefore := self currentHierarchyBrowsers.
1 class browseHierarchy.
browsersAfter := self currentHierarchyBrowsers.
self assert: (browsersAfter size = (browsersBefore size + 1)).
opened := browsersAfter removeAll: browsersBefore; yourself.
self assert: (opened size = 1).
opened := opened asArray first.
self assert: (opened model selectedClass == SmallInteger).
opened delete
!
----- Method: BrowseTest>>testBrowseHierarchyInstance (in category 'testing') -----
testBrowseHierarchyInstance
"self debug: #testBrowseHierarchyInstance"
| browsersBefore browsersAfter opened |
self ensureMorphic.
browsersBefore := self currentHierarchyBrowsers.
1 browseHierarchy.
browsersAfter := self currentHierarchyBrowsers.
self assert: (browsersAfter size = (browsersBefore size + 1)).
opened := browsersAfter removeAll: browsersBefore; yourself.
self assert: (opened size = 1).
opened := opened asArray first.
self assert: (opened model selectedClass == SmallInteger).
opened delete
!
----- Method: BrowseTest>>testBrowseHierarchyMataclass (in category 'testing') -----
testBrowseHierarchyMataclass
"self debug: #testBrowseHierarchyMataclass"
| browsersBefore browsersAfter opened |
self ensureMorphic.
browsersBefore := self currentHierarchyBrowsers.
1 class class browseHierarchy.
browsersAfter := self currentHierarchyBrowsers.
self assert: (browsersAfter size = (browsersBefore size + 1)).
opened := browsersAfter removeAll: browsersBefore; yourself.
self assert: (opened size = 1).
opened := opened asArray first.
self assert: (opened model selectedClass == Metaclass).
opened delete
!
----- Method: BrowseTest>>testBrowseInstance (in category 'testing') -----
testBrowseInstance
"self debug: #testBrowseInstance"
| browsersBefore browsersAfter opened |
self ensureMorphic.
browsersBefore := self currentBrowsers.
1 browse.
browsersAfter := self currentBrowsers.
self assert: (browsersAfter size = (browsersBefore size + 1)).
opened := browsersAfter removeAll: browsersBefore; yourself.
self assert: (opened size = 1).
opened := opened asArray first.
self assert: (opened model selectedClass == SmallInteger).
opened delete
!
----- Method: BrowseTest>>testBrowseMetaclass (in category 'testing') -----
testBrowseMetaclass
"self debug: #testBrowseMetaclass"
| browsersBefore browsersAfter opened |
self ensureMorphic.
browsersBefore := self currentBrowsers.
1 class class browse.
browsersAfter := self currentBrowsers.
self assert: (browsersAfter size = (browsersBefore size + 1)).
opened := browsersAfter removeAll: browsersBefore; yourself.
self assert: (opened size = 1).
opened := opened asArray first.
self assert: (opened model selectedClass == Metaclass).
opened delete
!
TestCase subclass: #BrowserHierarchicalListTest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Browser-Tests'!
!BrowserHierarchicalListTest commentStamp: 'rkrk 8/24/2009 05:11' prior: 0!
Tests the optional hierarchical class ordering of Browser.!
----- Method: BrowserHierarchicalListTest>>assertCorrectOrderOf:followedBy:in: (in category 'assertion') -----
assertCorrectOrderOf: classB followedBy: classA in: classCollection
"classB comes before classA. Assert that classB is a superclass of classB or that
a common superclass is in front of both"
| commonSuperclasses commonSuperclass classAIndex classBIndex superIndex |
classA == classB ifTrue: [^ self].
(classA inheritsFrom: classB) ifTrue: [^ self].
commonSuperclasses := classA withAllSuperclasses intersection: classB withAllSuperclasses.
commonSuperclass := commonSuperclasses first.
(classCollection includes: commonSuperclass) ifFalse: [^ self].
classAIndex := classCollection indexOf: classA.
classBIndex := classCollection indexOf: classB.
superIndex := classCollection indexOf: commonSuperclass.
(superIndex < classAIndex and: [superIndex < classBIndex]) ifTrue: [^self].
self fail.!
----- Method: BrowserHierarchicalListTest>>hierarchicalClassListForCategory: (in category 'helper') -----
hierarchicalClassListForCategory: category
| b index |
b := Browser new.
index := b systemCategoryList indexOf: category.
b systemCategoryListIndex: index.
^ b hierarchicalClassList.
!
----- Method: BrowserHierarchicalListTest>>nameToClass: (in category 'helper') -----
nameToClass: classNameWithIndent
^ Smalltalk classNamed: classNameWithIndent withoutLeadingBlanks asSymbol!
----- Method: BrowserHierarchicalListTest>>testListClassesHierarchically1 (in category 'tests') -----
testListClassesHierarchically1
| result classes category |
category := 'Collections-Abstract'.
result := self hierarchicalClassListForCategory: category.
self assert: (SystemOrganization listAtCategoryNamed: category) size equals: result size.
classes := result collect: [:ea | self nameToClass: ea].
classes withIndexDo: [:ea : i |
classes
from: 1 to: i
do: [:other | self assertCorrectOrderOf: other followedBy: ea in: classes]].!
----- Method: BrowserHierarchicalListTest>>testListClassesHierarchically2 (in category 'tests') -----
testListClassesHierarchically2
| result classes category |
category := 'Tools-Browser'.
result := self hierarchicalClassListForCategory: category.
self assert: (SystemOrganization listAtCategoryNamed: category) size equals: result size.
classes := result collect: [:ea | self nameToClass: ea].
classes withIndexDo: [:ea : i |
classes
from: 1 to: i
do: [:other | self assertCorrectOrderOf: other followedBy: ea in: classes]].!
----- Method: BrowserHierarchicalListTest>>testListClassesHierarchicallyIndent (in category 'tests') -----
testListClassesHierarchicallyIndent
| result dict indent |
result := self hierarchicalClassListForCategory: 'Tools-Browser'.
"Create class->indent mapping"
dict := result inject: Dictionary new into: [:classIndentMapping :className |
indent := className count: [:char | char = Character space or: [char = Character tab]].
classIndentMapping at: (self nameToClass: className) put: indent.
classIndentMapping].
"assert that indent of class is larger than indent of superclass"
dict keysAndValuesDo: [:class :myIndent |
dict at: class superclass ifPresent: [:superIndent |
self assert: myIndent > superIndent]].!
TestCase subclass: #DebuggerUnwindBug
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Debugger-Tests'!
----- Method: DebuggerUnwindBug>>testUnwindBlock (in category 'as yet unclassified') -----
testUnwindBlock
"test if unwind blocks work properly"
| sema process |
sema := Semaphore forMutualExclusion.
self assert: sema isSignaled.
"deadlock on the semaphore"
process := [sema critical:[sema wait]] forkAt: Processor userInterruptPriority.
self deny: sema isSignaled.
"terminate process"
process terminate.
self assert: sema isSignaled.
!
----- Method: DebuggerUnwindBug>>testUnwindDebugger (in category 'as yet unclassified') -----
testUnwindDebugger
"test if unwind blocks work properly when a debugger is closed"
| sema process debugger top |
sema := Semaphore forMutualExclusion.
self assert: sema isSignaled.
process := [sema critical:[sema wait]] forkAt: Processor userInterruptPriority.
self deny: sema isSignaled.
"everything set up here - open a debug notifier"
debugger := Debugger openInterrupt: 'test' onProcess: process.
"get into the debugger"
debugger debug.
top := debugger topView.
"set top context"
debugger toggleContextStackIndex: 1.
"close debugger"
top delete.
"and see if unwind protection worked"
self assert: sema isSignaled.!
----- Method: DebuggerUnwindBug>>testUnwindDebuggerWithStep (in category 'as yet unclassified') -----
testUnwindDebuggerWithStep
"test if unwind blocks work properly when a debugger is closed"
| sema process debugger top |
sema := Semaphore forMutualExclusion.
self assert: sema isSignaled.
process := [sema critical:[sema wait]] forkAt: Processor userInterruptPriority.
self deny: sema isSignaled.
"everything set up here - open a debug notifier"
debugger := Debugger openInterrupt: 'test' onProcess: process.
"get into the debugger"
debugger debug.
top := debugger topView.
"set top context"
debugger toggleContextStackIndex: 1.
"do single step"
debugger doStep.
"close debugger"
top delete.
"and see if unwind protection worked"
self assert: sema isSignaled.!
TestCase subclass: #FileList2ModalDialogsTest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-FileList-Tests'!
!FileList2ModalDialogsTest commentStamp: '<historical>' prior: 0!
TestRunner open!
----- Method: FileList2ModalDialogsTest>>testModalFileSelector (in category 'running') -----
testModalFileSelector
| window fileList2 |
window := FileList2 morphicViewFileSelector.
window openCenteredInWorld.
fileList2 := window valueOfProperty: #fileListModel.
fileList2 fileListIndex: 1.
window delete.
self assert: fileList2 getSelectedFile isNil.
fileList2 okHit.
self deny: fileList2 getSelectedFile isNil
!
----- Method: FileList2ModalDialogsTest>>testModalFileSelectorForSuffixes (in category 'running') -----
testModalFileSelectorForSuffixes
| window fileList2 |
window := FileList2 morphicViewFileSelectorForSuffixes: nil.
window openCenteredInWorld.
fileList2 := window valueOfProperty: #fileListModel.
fileList2 fileListIndex: 1.
window delete.
self assert: fileList2 getSelectedFile isNil.
fileList2 okHit.
self deny: fileList2 getSelectedFile isNil
!
----- Method: FileList2ModalDialogsTest>>testModalFolderSelector (in category 'running') -----
testModalFolderSelector
| window fileList2 |
window := FileList2 morphicViewFolderSelector.
fileList2 := window model.
window openInWorld: self currentWorld extent: 300 at 400.
fileList2 fileListIndex: 1.
window delete.
self assert: fileList2 getSelectedDirectory withoutListWrapper isNil.
fileList2 okHit.
self deny: fileList2 getSelectedDirectory withoutListWrapper isNil
!
----- Method: FileList2ModalDialogsTest>>testModalFolderSelectorForProjectLoad (in category 'running') -----
testModalFolderSelectorForProjectLoad
| window fileList2 w |
window := FileList2
morphicViewProjectLoader2InWorld: self currentWorld
reallyLoad: false.
fileList2 := window valueOfProperty: #FileList.
w := self currentWorld.
window position: w topLeft + (w extent - window extent // 2).
window openInWorld: w.
window delete.
self assert: fileList2 getSelectedDirectory withoutListWrapper isNil.
fileList2 okHit.
self deny: fileList2 getSelectedDirectory withoutListWrapper isNil
!
FileList2 subclass: #FileChooser
instanceVariableNames: 'view caption captionMorph captionBox cancelButton okButton buttonPane captionPane directoryPane filePane showShortFileNames'
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-FileList'!
!FileChooser commentStamp: 'miki 8/15/2005 12:07' prior: 0!
This class provides a simple "modal" dialog box to choose a file, with a directory tree, a file list, and open and cancel buttons. It is meant to be an improvement of FileList2 modalFileSelector.
An applictaion can customize the user interface in a straightforward way. Creation of the file choser is done in several steps by calling various helper methods..
The order of the method calls when creating a customized file chooser are important. The UI must be created before methods that change the attributes of the UI can be called. You can either start by creating the default UI, and them modify the morphs in the file chooser (there are methods to access the buttons and the panes).
You can also build a completely custom UI, by writing your own methods for creating the layout etc. One way to do this is to subclass FileChooser and override the methods you want to change, andother way is to supply your own morphic view to the file chooser. This must be an instance of MorphicModel or a subclass of it, because the file chooser uses the model functionality.
There are two varieties of the UI, one that is supposed to be like a dialog box (uses colors from the menu preferences in class Preference), and one is using a system window. The way a system window works turns out to be somehat different from how a plain Morphic Model works, and this is why there are separate methods for creating the dialog box UI and the system window UI.
On the class side, there are examples that shows differents ways to use this class.
On the to do list is adding support for a file save dialog box, with a directory tree and a text input field for typing a file name.
(Mikael Kindborg, 050815)
!
----- Method: FileChooser class>>example1 (in category 'examples') -----
example1
"Open file chooser with the standard dialog box UI."
"FileChooser example1"
| fc stream |
fc := FileChooser new.
fc initalizeAsDialogBox.
stream := fc open.
stream inspect.!
----- Method: FileChooser class>>example2 (in category 'examples') -----
example2
"Open file chooser with a system window UI."
"FileChooser example2"
| fc stream |
fc := FileChooser new.
fc initalizeAsSystemWindow.
stream := fc open.
stream inspect.!
----- Method: FileChooser class>>example3 (in category 'examples') -----
example3
"Open file chooser with a system window UI that has a caption pane and shows only picture files."
"FileChooser example3"
| fc stream |
fc := FileChooser new.
fc initalizeAsSystemWindowWithCaptionPane.
fc setCaption: 'Select a picture file' translated.
fc setSuffixes: {'png' . 'gif' . 'bmp' . 'jpg' . 'jpeg' }.
stream := fc open.
stream ifNotNil: [(Form fromBinaryStream: stream) asMorph openInHand].!
----- Method: FileChooser class>>example4 (in category 'examples') -----
example4
"Open file chooser with a customized dialog box UI. The order of the messages is important. In general, call the initialize method first, then modify things, and finally call open."
"FileChooser example4"
| fc stream |
fc := FileChooser new.
fc initalizeAsDialogBox.
fc setDirectory: FileDirectory root.
fc setSuffixes: {'png' . 'gif' . 'bmp' . 'jpg' . 'jpeg' }.
fc setCaption: 'Select a picture file' translated.
fc morphicView
borderColor: Color black;
borderWidth: 2;
color: Color white.
fc setPaneColor: Color gray muchLighter.
fc captionPane color: Color orange muchLighter.
fc okButton color: Color green muchLighter.
fc cancelButton color: Color blue muchLighter.
fc morphicView position: 20 at 20.
stream := fc open.
stream ifNotNil: [(Form fromBinaryStream: stream) asMorph openInHand].!
----- Method: FileChooser>>addFullPanesTo:from: (in category 'ui creation') -----
addFullPanesTo: aMorph from: aCollection
| frame |
aCollection do: [ :each |
frame := LayoutFrame
fractions: each second
offsets: each third.
aMorph addMorph: each first fullFrame: frame.
]!
----- Method: FileChooser>>buttonPane (in category 'accessing') -----
buttonPane
^buttonPane!
----- Method: FileChooser>>cancelButton (in category 'accessing') -----
cancelButton
^cancelButton!
----- Method: FileChooser>>caption (in category 'accessing') -----
caption
^caption!
----- Method: FileChooser>>captionPane (in category 'accessing') -----
captionPane
^captionPane!
----- Method: FileChooser>>centerMorphicView (in category 'ui creation') -----
centerMorphicView
self morphicView
fullBounds;
position: Display extent - self morphicView extent // 2.
!
----- Method: FileChooser>>createCancelButton (in category 'ui creation') -----
createCancelButton
cancelButton := SimpleButtonMorph new.
cancelButton
label: 'Cancel' translated;
color: Color transparent;
borderColor: Color black;
borderWidth: 1.
cancelButton
on: #mouseUp
send: #cancelHit
to: self.
^cancelButton
!
----- Method: FileChooser>>createDialogBoxButtonPane (in category 'ui creation') -----
createDialogBoxButtonPane
"Create buttons suitable for a MorphicModel file chooser."
buttonPane := AlignmentMorph new.
buttonPane
layoutPolicy: ProportionalLayout new;
color: Color transparent;
borderWidth: 0.
self createOkButton.
self createCancelButton.
buttonPane addMorph: self cancelButton
fullFrame: (LayoutFrame fractions: (0 @ 0 corner: 0.49 @ 1.0)
offsets: (0 @ 0 corner: 0 @ 0)).
buttonPane addMorph: self okButton
fullFrame: (LayoutFrame fractions: (0.51 @ 0 corner: 1.0 @ 1.0)
offsets: (0 @ 0 corner: 0 @ 0)).
^buttonPane!
----- Method: FileChooser>>createDialogBoxCaptionPane (in category 'ui creation') -----
createDialogBoxCaptionPane
"Create a morph to hold the caption string. The caption is created in setCaption:"
| icon frame |
captionPane := AlignmentMorph new.
captionPane
color: Color transparent;
layoutPolicy: ProportionalLayout new.
"You can change the caption later by calling setCaption:"
self setCaption: 'Please select a file' translated.
self setCaptionFont: Preferences windowTitleFont.
icon := SketchMorph new.
icon form: MenuIcons openIcon.
captionPane addMorph: icon.
frame := LayoutFrame new.
frame
leftFraction: 0;
topFraction: 0.5;
leftOffset: icon form width // 2;
topOffset: (icon form width // 2) negated.
icon layoutFrame: frame.
^captionPane!
----- Method: FileChooser>>createDialogBoxLayout (in category 'ui creation') -----
createDialogBoxLayout
"Create a layout suitable for a MorphicModel file chooser."
| inset insetNeg captionTop captionBottom buttonsBottom buttonsTop contentTop contentBottom |
inset := 6.
insetNeg := inset negated.
captionTop := 0.
captionBottom := 33.
contentTop := captionBottom + inset.
contentBottom := -30 - inset - inset.
buttonsTop := contentBottom + inset.
buttonsBottom := insetNeg.
self addFullPanesTo: self morphicView
from: {
{
(self captionPane).
(0 @ 0 corner: 1 @ 0).
(0 @ captionTop corner: 0 @ captionBottom)
}.
{
(self buttonPane).
(0 @ 1 corner: 1 @ 1).
(inset @ buttonsTop corner: insetNeg @ buttonsBottom)
}.
{
(self directoryPane).
(0 @ 0 corner: 0.5 @ 1).
(inset @ contentTop corner: insetNeg @ contentBottom)
}.
{
(self filePane).
(0.5 @ 0 corner: 1 @ 1).
(inset @ contentTop corner: insetNeg @ contentBottom)
}
}!
----- Method: FileChooser>>createDialogBoxMorphicView (in category 'ui creation') -----
createDialogBoxMorphicView
| m |
m := MorphicModel new
layoutPolicy: ProportionalLayout new;
color: Preferences menuColor;
borderColor: Preferences menuBorderColor;
borderWidth: Preferences menuBorderWidth;
layoutInset: 0;
extent: 600 at 400.
self setMorphicView: m.
^m!
----- Method: FileChooser>>createDialogBoxUI (in category 'ui creation') -----
createDialogBoxUI
"This method creates UI components and a layout that are suitable for a MorphicModel. Also centers the morphic view in the world. Note that the order of the method calls are important if you modify this."
self
createDialogBoxMorphicView;
createDialogBoxCaptionPane;
createDialogBoxButtonPane;
createDirectoryPane;
createFilePane;
createDialogBoxLayout;
centerMorphicView.
^self morphicView!
----- Method: FileChooser>>createDirectoryPane (in category 'ui creation') -----
createDirectoryPane
directoryPane := self morphicDirectoryTreePane.
directoryPane borderWidth: 0.
^directoryPane!
----- Method: FileChooser>>createFilePane (in category 'ui creation') -----
createFilePane
filePane := self morphicFileListPane.
filePane borderWidth: 0.
^filePane!
----- Method: FileChooser>>createOkButton (in category 'ui creation') -----
createOkButton
okButton := SimpleButtonMorph new.
okButton
label: 'Open' translated;
color: Color transparent;
borderColor: Color black;
borderWidth: 1.
okButton
on: #mouseUp
send: #okHit
to: self.
^okButton!
----- Method: FileChooser>>createSystemWindowButtonPane (in category 'ui creation') -----
createSystemWindowButtonPane
"Create buttons suitable for a SystemWindow file chooser."
self optionalButtonSpecs: self okayAndCancelServices.
buttonPane := self optionalButtonRow.
okButton := buttonPane firstSubmorph.
cancelButton := buttonPane firstSubmorph.
^buttonPane!
----- Method: FileChooser>>createSystemWindowCaptionPane (in category 'ui creation') -----
createSystemWindowCaptionPane
"Create a morph to hold the caption string. The caption is created in setCaption:"
captionPane := AlignmentMorph new.
captionPane
color: Color transparent;
layoutPolicy: ProportionalLayout new.
"You can change the caption later by calling setCaption:"
self setCaption: 'Please select a file' translated.
^captionPane!
----- Method: FileChooser>>createSystemWindowLayout (in category 'ui creation') -----
createSystemWindowLayout
"Create a layout suitable for a SystemWindow file chooser."
| buttonsHeight |
buttonsHeight := 33.
self addFullPanesTo: self morphicView
from: {
{
(self buttonPane).
(0 @ 0 corner: 1 @ 0).
(0 @ 0 corner: 0 @ buttonsHeight)
}.
{
(self directoryPane).
(0 @ 0 corner: 0.5 @ 1).
(0 @ buttonsHeight corner: 0 @ 0)
}.
{
(self filePane).
(0.5 @ 0 corner: 1 @ 1).
(0 @ buttonsHeight corner: 0 @ 0)
}
}!
----- Method: FileChooser>>createSystemWindowLayoutWithCaptionPane (in category 'ui creation') -----
createSystemWindowLayoutWithCaptionPane
| buttonsHeight captionHeight |
buttonsHeight := 33.
captionHeight := 28.
self addFullPanesTo: self morphicView
from: {
{
(self captionPane).
(0 @ 0 corner: 1 @ 0).
(0 @ 0 corner: 0 @ captionHeight)
}.
{
(self buttonPane).
(0 @ 0 corner: 1 @ 0).
(0 @ captionHeight corner: 0 @ (captionHeight + buttonsHeight))
}.
{
(self directoryPane).
(0 @ 0 corner: 0.5 @ 1).
(0 @ (captionHeight + buttonsHeight) corner: 0 @ 0)
}.
{
(self filePane).
(0.5 @ 0 corner: 1 @ 1).
(0 @ (captionHeight + buttonsHeight) corner: 0 @ 0)
}
}!
----- Method: FileChooser>>createSystemWindowMorphicView (in category 'ui creation') -----
createSystemWindowMorphicView
| m |
m := SystemWindow labelled: 'Please select a file' translated. "self directory pathName."
"m deleteCloseBox."
self setMorphicView: m.!
----- Method: FileChooser>>createSystemWindowUI (in category 'ui creation') -----
createSystemWindowUI
"This method creates UI components and a layout that are suitable for a SystemWindow. Note that the order of the method calls are important."
self
createSystemWindowMorphicView;
createSystemWindowButtonPane;
createDirectoryPane;
createFilePane;
createSystemWindowLayout.
^self morphicView!
----- Method: FileChooser>>createSystemWindowUIWithCaptionPane (in category 'ui creation') -----
createSystemWindowUIWithCaptionPane
self
createSystemWindowMorphicView;
createSystemWindowCaptionPane;
createSystemWindowButtonPane;
createDirectoryPane;
createFilePane;
createSystemWindowLayoutWithCaptionPane.
^self morphicView!
----- Method: FileChooser>>directory (in category 'accessing') -----
directory
^super directory!
----- Method: FileChooser>>directoryPane (in category 'accessing') -----
directoryPane
^directoryPane!
----- Method: FileChooser>>fileNameFormattedFrom:sizePad: (in category 'updating') -----
fileNameFormattedFrom: entry sizePad: sizePad
"entry is a 5-element array of the form:
(name creationTime modificationTime dirFlag fileSize)"
"If the short file list flag is false, we send this on to the superclass."
| nameStr |
showShortFileNames
ifFalse: [^super fileNameFormattedFrom: entry sizePad: sizePad].
"Otherwise, just show the name of the file in the file list."
nameStr := (entry at: 4)
ifTrue: [entry first , self folderString]
ifFalse: [entry first].
^nameStr!
----- Method: FileChooser>>filePane (in category 'accessing') -----
filePane
^filePane!
----- Method: FileChooser>>initalizeAsDialogBox (in category 'initialization') -----
initalizeAsDialogBox
self initalizeBasicParameters.
self createDialogBoxUI.
self morphicView
useRoundedCorners;
color: Preferences menuColor;
adoptPaneColor: Preferences menuLineColor.
self
setCaptionColor: Preferences menuTitleColor;
setButtonColor: Preferences menuColor.!
----- Method: FileChooser>>initalizeAsSystemWindow (in category 'initialization') -----
initalizeAsSystemWindow
self initalizeBasicParameters.
self createSystemWindowUI.!
----- Method: FileChooser>>initalizeAsSystemWindowWithCaptionPane (in category 'initialization') -----
initalizeAsSystemWindowWithCaptionPane
self initalizeBasicParameters.
self createSystemWindowUIWithCaptionPane.!
----- Method: FileChooser>>initalizeBasicParameters (in category 'initialization') -----
initalizeBasicParameters
self showShortFileNames: true.
self setDirectory: FileDirectory default.!
----- Method: FileChooser>>morphicView (in category 'accessing') -----
morphicView
^view!
----- Method: FileChooser>>okButton (in category 'accessing') -----
okButton
^okButton!
----- Method: FileChooser>>open (in category 'open') -----
open
| model |
self postOpen. "Funny name in this context, should be renamed, but whatever..."
self morphicView openInWorld.
model := self morphicView model.
FileChooser modalLoopOn: self morphicView.
^ model getSelectedFile.
!
----- Method: FileChooser>>setButtonColor: (in category 'ui creation') -----
setButtonColor: aColor
self okButton color: aColor.
self cancelButton color: aColor.
!
----- Method: FileChooser>>setCaption: (in category 'ui creation') -----
setCaption: aString
| frame |
caption ifNil:
[caption := StringMorph new.
self captionPane addMorph: caption].
caption contents: aString.
frame := LayoutFrame new.
frame
leftFraction: 0.5;
topFraction: 0.5;
leftOffset: caption width negated // 2;
topOffset: caption height negated // 2.
caption layoutFrame: frame!
----- Method: FileChooser>>setCaptionColor: (in category 'ui creation') -----
setCaptionColor: aColor
self captionPane color: aColor!
----- Method: FileChooser>>setCaptionFont: (in category 'ui creation') -----
setCaptionFont: aFont
self caption font: aFont.
self setCaption: self caption contents asString.
!
----- Method: FileChooser>>setDirectory: (in category 'initialization') -----
setDirectory: aDir
^super directory: aDir!
----- Method: FileChooser>>setMorphicView: (in category 'initialization') -----
setMorphicView: aMorphicModel
view := aMorphicModel.
self modalView: view.
view model: self.!
----- Method: FileChooser>>setPaneColor: (in category 'ui creation') -----
setPaneColor: aColor
self morphicView
color: aColor;
adoptPaneColor: aColor.
!
----- Method: FileChooser>>setSuffixes: (in category 'initialization') -----
setSuffixes: aList
self fileSelectionBlock: [:entry :myPattern |
entry isDirectory
ifTrue:
[false]
ifFalse:
[aList includes: (FileDirectory extensionFor: entry name asLowercase)]] fixTemps!
----- Method: FileChooser>>showShortFileNames: (in category 'initialization') -----
showShortFileNames: aBoolean
showShortFileNames := aBoolean!
----- Method: FileChooser>>updateButtonRow (in category 'updating') -----
updateButtonRow
"Prevent updating of the the button row."!
PluggableTextMorph subclass: #BrowserCommentTextMorph
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Browser'!
!BrowserCommentTextMorph commentStamp: '<historical>' prior: 0!
I am a PluggableTextMorph that knows enough to make myself invisible when necessary.!
----- Method: BrowserCommentTextMorph>>hideOrShowPane (in category 'displaying') -----
hideOrShowPane
(self model editSelection == #editClass)
ifTrue: [ self showPane ]
ifFalse: [ self hidePane ]!
----- Method: BrowserCommentTextMorph>>hidePane (in category 'displaying') -----
hidePane
| win |
self window ifNotNilDo: [:window | window removePaneSplitters].
self lowerPane ifNotNilDo:
[ :lp |
lp layoutFrame bottomFraction: self layoutFrame bottomFraction.
lp layoutFrame bottomOffset: SystemWindow borderWidth negated].
win := self window ifNil: [ ^self ].
self delete.
win updatePanesFromSubmorphs.
win addPaneSplitters!
----- Method: BrowserCommentTextMorph>>lowerPane (in category 'accessing') -----
lowerPane
"Answer the AlignmentMorph that I live beneath"
^self valueOfProperty: #browserLowerPane!
----- Method: BrowserCommentTextMorph>>noteNewOwner: (in category 'updating') -----
noteNewOwner: win
super noteNewOwner: win.
self setProperty: #browserWindow toValue: win.
win ifNil: [ ^self ].
win setProperty: #browserClassCommentPane toValue: self.
self setProperty: #browserLowerPane
toValue: (win submorphThat: [ :m |
m isAlignmentMorph
and: [ m layoutFrame bottomFraction notNil]
and: [ m layoutFrame bottomFraction >= self layoutFrame topFraction ]]
ifNone: [])!
----- Method: BrowserCommentTextMorph>>showPane (in category 'displaying') -----
showPane
owner ifNil: [
| win |
win := self window ifNil: [ ^self ].
win addMorph: self fullFrame: self layoutFrame.
win updatePanesFromSubmorphs ].
self lowerPane ifNotNilDo: [ :lp | lp layoutFrame bottomFraction: self layoutFrame topFraction ].
self window ifNotNilDo: [:win | win addPaneSplitters]!
----- Method: BrowserCommentTextMorph>>update: (in category 'updating') -----
update: anAspect
super update: anAspect.
anAspect == #editSelection ifFalse: [ ^self ].
self hideOrShowPane!
----- Method: BrowserCommentTextMorph>>window (in category 'accessing') -----
window
^self owner ifNil: [ self valueOfProperty: #browserWindow ].!
----- Method: ParagraphEditor>>browseChangeSetsWithSelector (in category '*Tools') -----
browseChangeSetsWithSelector
"Determine which, if any, change sets have at least one change for the selected selector, independent of class"
| aSelector |
self lineSelectAndEmptyCheck: [^ self].
(aSelector := self selectedSelector) == nil ifTrue: [^ view flash].
self terminateAndInitializeAround: [ChangeSorter browseChangeSetsWithSelector: aSelector]!
----- Method: ParagraphEditor>>browseItHere (in category '*Tools') -----
browseItHere
"Retarget the receiver's window to look at the selected class, if appropriate. 3/1/96 sw"
| aSymbol foundClass b |
(((b := model) isKindOf: Browser) and: [b couldBrowseAnyClass])
ifFalse: [^ view flash].
model okToChange ifFalse: [^ view flash].
self selectionInterval isEmpty ifTrue: [self selectWord].
(aSymbol := self selectedSymbol) isNil ifTrue: [^ view flash].
self terminateAndInitializeAround:
[foundClass := (Smalltalk at: aSymbol ifAbsent: [nil]).
foundClass isNil ifTrue: [^ view flash].
(foundClass isKindOf: Class)
ifTrue:
[model systemCategoryListIndex:
(model systemCategoryList indexOf: foundClass category).
model classListIndex: (model classList indexOf: foundClass name)]]!
----- Method: ParagraphEditor>>debug:receiver:in: (in category '*Tools') -----
debug: aCompiledMethod receiver: anObject in: evalContext
| selector guineaPig debugger context |
selector := evalContext isNil ifTrue: [#DoIt] ifFalse: [#DoItIn:].
anObject class addSelectorSilently: selector withMethod: aCompiledMethod.
guineaPig := evalContext isNil
ifTrue: [[anObject DoIt] newProcess]
ifFalse: [[anObject DoItIn: evalContext] newProcess].
context := guineaPig suspendedContext.
debugger := Debugger new
process: guineaPig
controller: ((Smalltalk isMorphic not and: [ScheduledControllers inActiveControllerProcess])
ifTrue: [ScheduledControllers activeController]
ifFalse: [nil])
context: context
isolationHead: nil.
debugger openFullNoSuspendLabel: 'Debug it'.
[debugger interruptedContext method == aCompiledMethod]
whileFalse: [debugger send].
anObject class basicRemoveSelector: selector!
----- Method: ParagraphEditor>>debugIt (in category '*Tools') -----
debugIt
| method receiver context |
(model respondsTo: #doItReceiver)
ifTrue:
[FakeClassPool adopt: model selectedClass.
receiver := model doItReceiver.
context := model doItContext]
ifFalse:
[receiver := context := nil].
self lineSelectAndEmptyCheck: [^self].
method := self compileSelectionFor: receiver in: context.
method notNil ifTrue:
[self debug: method receiver: receiver in: context].
FakeClassPool adopt: nil!
AbstractHierarchicalList subclass: #ObjectExplorer
instanceVariableNames: 'rootObject inspector monitorList'
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Explorer'!
!ObjectExplorer commentStamp: '<historical>' prior: 0!
ObjectExplorer provides a hierarchical alternative to #inspect. Simply evaluate an expression like:
World explore
and enjoy.!
----- Method: ObjectExplorer class>>about (in category 'as yet unclassified') -----
about
StringHolder new textContents: self comment; openLabel: 'about ',self asString!
----- Method: ObjectExplorer>>chasePointers (in category 'menus') -----
chasePointers
"Open a PointerFinder on the selected item"
| path sel savedRoot saved |
path := OrderedCollection new.
sel := currentSelection.
[ sel isNil ] whileFalse: [ path addFirst: sel asString. sel := sel parent ].
path addFirst: #openPath.
path := path asArray.
savedRoot := rootObject.
saved := self object.
[ rootObject := nil.
self changed: #getList.
(Smalltalk includesKey: #PointerFinder)
ifTrue: [PointerFinder on: saved]
ifFalse: [self objectReferencesToSelection ]]
ensure: [ rootObject := savedRoot.
self changed: #getList.
self changed: path.
]!
----- Method: ObjectExplorer>>codePaneMenu:shifted: (in category 'menus') -----
codePaneMenu: aMenu shifted: shifted
"Note that unless we override perform:orSendTo:, PluggableTextController will respond to all menu items"
^ StringHolder basicNew codePaneMenu: aMenu shifted: shifted
!
----- Method: ObjectExplorer>>contentsSelection (in category 'accessing') -----
contentsSelection
"Return the interval of text in the code pane to select when I set the pane's contents"
^ 1 to: 0 "null selection"!
----- Method: ObjectExplorer>>defsOfSelection (in category 'menus') -----
defsOfSelection
"Open a browser on all defining references to the selected instance variable, if that's what's currently selected."
| aClass sel |
(aClass := self parentObject class) isVariable ifTrue: [^ self changed: #flash].
sel := self selector.
self systemNavigation browseAllStoresInto: sel from: aClass!
----- Method: ObjectExplorer>>doItContext (in category 'accessing') -----
doItContext
"Answer the context in which a text selection can be evaluated."
^nil!
----- Method: ObjectExplorer>>doItReceiver (in category 'accessing') -----
doItReceiver
"Answer the object that should be informed of the result of evaluating a
text selection."
currentSelection ifNil: [^rootObject].
^currentSelection withoutListWrapper
!
----- Method: ObjectExplorer>>doesNotUnderstand: (in category 'error handling') -----
doesNotUnderstand: aMessage
inspector ifNotNil: [ (inspector respondsTo: aMessage selector) ifTrue: [ ^inspector perform: aMessage selector withArguments: aMessage arguments ]].
^super doesNotUnderstand: aMessage!
----- Method: ObjectExplorer>>exploreSelection (in category 'menus') -----
exploreSelection
"Open an ObjectExplorer on the current selection"
self object explore!
----- Method: ObjectExplorer>>explorerFor: (in category 'accessing') -----
explorerFor: anObject
| window listMorph |
rootObject := anObject.
window := (SystemWindow labelled: self label) model: self.
window addMorph: (listMorph := SimpleHierarchicalListMorph
on: self
list: #getList
selected: #getCurrentSelection
changeSelected: #noteNewSelection:
menu: #genericMenu:
keystroke: #explorerKey:from:)
frame: (0 at 0 corner: 1 at 0.8).
window addMorph: ((PluggableTextMorph on: self text: #trash accept: #trash:
readSelection: #contentsSelection menu: #codePaneMenu:shifted:)
askBeforeDiscardingEdits: false)
frame: (0 at 0.8 corner: 1 at 1).
listMorph
autoDeselect: false.
^ window!
----- Method: ObjectExplorer>>explorerFor:withLabel: (in category 'user interface') -----
explorerFor: anObject withLabel: label
| window listMorph |
rootObject := anObject.
window := (SystemWindow labelled: label)
model: self.
window
addMorph: (listMorph := SimpleHierarchicalListMorph
on: self
list: #getList
selected: #getCurrentSelection
changeSelected: #noteNewSelection:
menu: #genericMenu:
keystroke: nil)
frame: (0 @ 0 corner: 1 @ 0.8).
window
addMorph: ((PluggableTextMorph
on: self
text: #trash
accept: #trash:
readSelection: #contentsSelection
menu: #codePaneMenu:shifted:)
askBeforeDiscardingEdits: false)
frame: (0 @ 0.8 corner: 1 @ 1).
listMorph autoDeselect: false.
^ window!
----- Method: ObjectExplorer>>explorerKey:from: (in category 'menus') -----
explorerKey: aChar from: view
"Similar to #genericMenu:..."
| insideObject parentObject |
currentSelection ifNotNil: [
insideObject := self object.
parentObject := self parentObject.
inspector ifNil: [inspector := Inspector new].
inspector
inspect: parentObject;
object: insideObject.
aChar == $i ifTrue: [^ self inspectSelection].
aChar == $I ifTrue: [^ self exploreSelection].
aChar == $b ifTrue: [^ inspector browseMethodFull].
aChar == $h ifTrue: [^ inspector classHierarchy].
aChar == $c ifTrue: [^ inspector copyName].
aChar == $p ifTrue: [^ inspector browseFullProtocol].
aChar == $N ifTrue: [^ inspector browseClassRefs].
aChar == $t ifTrue: [^ inspector tearOffTile].
aChar == $v ifTrue: [^ inspector viewerForValue]].
^ self arrowKey: aChar from: view!
----- Method: ObjectExplorer>>genericMenu: (in category 'menus') -----
genericMenu: aMenu
"Borrow a menu from my inspector"
| insideObject menu parentObject |
currentSelection
ifNil: [menu := aMenu.
menu
add: '*nothing selected*'
target: self
selector: #yourself]
ifNotNil: [insideObject := self object.
parentObject := self parentObject.
inspector
ifNil: [inspector := Inspector new].
inspector inspect: parentObject;
object: insideObject.
aMenu defaultTarget: inspector.
inspector fieldListMenu: aMenu.
aMenu items
do: [:i | (#(#inspectSelection #exploreSelection #referencesToSelection #defsOfSelection #objectReferencesToSelection #chasePointers ) includes: i selector)
ifTrue: [i target: self]].
aMenu addLine;
add: 'monitor changes'
target: self
selector: #monitor:
argument: currentSelection].
monitorList isEmptyOrNil
ifFalse: [aMenu addLine;
add: 'stop monitoring all'
target: self
selector: #stopMonitoring].
^ aMenu!
----- Method: ObjectExplorer>>getList (in category 'accessing') -----
getList
^Array with: (ObjectExplorerWrapper with: rootObject name: 'root' model: self parent: nil)
!
----- Method: ObjectExplorer>>initialExtent (in category 'user interface') -----
initialExtent
^300 at 500!
----- Method: ObjectExplorer>>inspectSelection (in category 'menus') -----
inspectSelection
"Open an Inspector on the current selection"
self object inspect!
----- Method: ObjectExplorer>>label (in category 'accessing') -----
label
^ rootObject printStringLimitedTo: 32!
----- Method: ObjectExplorer>>monitor: (in category 'monitoring') -----
monitor: anObjectExplorerWrapper
"Start stepping and watching the given wrapper for changes."
anObjectExplorerWrapper ifNil: [ ^self ].
self world ifNil: [ ^self ].
self monitorList at: anObjectExplorerWrapper put: anObjectExplorerWrapper asString.
self world startStepping: self at: Time millisecondClockValue selector: #step arguments: #() stepTime: 200.!
----- Method: ObjectExplorer>>monitorList (in category 'monitoring') -----
monitorList
^monitorList ifNil: [ monitorList := WeakIdentityKeyDictionary new ].!
----- Method: ObjectExplorer>>object (in category 'accessing') -----
object
^currentSelection ifNotNilDo: [ :cs | cs withoutListWrapper ]!
----- Method: ObjectExplorer>>objectReferencesToSelection (in category 'menus') -----
objectReferencesToSelection
"Open a browser on all references to the selected instance variable, if that's what currently selected. "
self systemNavigation
browseAllObjectReferencesTo: self object
except: (Array with: self parentObject with: currentSelection with: inspector)
ifNone: [:obj | self changed: #flash].
!
----- Method: ObjectExplorer>>openBrowser: (in category 'user interface') -----
openBrowser: aClass
ToolSet browse: aClass selector: nil!
----- Method: ObjectExplorer>>openExplorerFor: (in category 'user interface') -----
openExplorerFor: anObject
"
ObjectExplorer new openExplorerFor: Smalltalk
"
| win |
win := (self explorerFor: anObject) openInWorld.
Cursor wait showWhile:
[win submorphs do:
[:sm|
(sm respondsTo: #expandRoots) ifTrue:
[sm expandRoots]]].
^self
!
----- Method: ObjectExplorer>>openExplorerFor:withLabel: (in category 'user interface') -----
openExplorerFor: anObject withLabel: label
"ObjectExplorer new openExplorerFor: Smalltalk withLabel: 'Smalltalk'"
(self explorerFor: anObject withLabel: label)
openInWorld!
----- Method: ObjectExplorer>>parentObject (in category 'accessing') -----
parentObject
currentSelection ifNil: [ ^nil ].
currentSelection parent ifNil: [ ^rootObject ].
^currentSelection parent withoutListWrapper!
----- Method: ObjectExplorer>>referencesToSelection (in category 'menus') -----
referencesToSelection
"Open a browser on all references to the selected instance variable, if that's what's currently selected."
| aClass sel |
(aClass := self parentObject class) isVariable ifTrue: [^ self changed: #flash].
sel := self selector.
self systemNavigation browseAllAccessesTo: sel from: aClass!
----- Method: ObjectExplorer>>release (in category 'monitoring') -----
release
self world ifNotNil: [ self world stopStepping: self selector: #step ].
super release.!
----- Method: ObjectExplorer>>selectedClass (in category 'menus') -----
selectedClass
"Answer the class of the receiver's current selection"
^self doItReceiver class
!
----- Method: ObjectExplorer>>selector (in category 'accessing') -----
selector
^currentSelection ifNotNilDo: [ :cs | cs selector ]!
----- Method: ObjectExplorer>>shouldGetStepsFrom: (in category 'monitoring') -----
shouldGetStepsFrom: aWorld
^self monitorList notEmpty!
----- Method: ObjectExplorer>>step (in category 'monitoring') -----
step
"If there's anything in my monitor list, see if the strings have changed."
| string changes |
changes := false.
self monitorList keysAndValuesDo: [ :k :v |
k ifNotNil: [
k refresh.
(string := k asString) ~= v ifTrue: [ self monitorList at: k put: string. changes := true ].
]
].
changes ifTrue: [ | sel |
sel := currentSelection.
self changed: #getList.
self noteNewSelection: sel.
].
self monitorList isEmpty ifTrue: [ ActiveWorld stopStepping: self selector: #step ].!
----- Method: ObjectExplorer>>stopMonitoring (in category 'monitoring') -----
stopMonitoring
monitorList := nil.
self world stopStepping: self selector: #step!
----- Method: ObjectExplorer>>trash (in category 'menus') -----
trash
"What goes in the bottom pane"
^ ''!
----- Method: ObjectExplorer>>trash: (in category 'menus') -----
trash: newText
"Don't save it"
^ true!
----- Method: ObjectExplorer>>world (in category 'monitoring') -----
world
^ActiveWorld!
ObjectExplorer subclass: #PointerExplorer
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Explorer'!
!PointerExplorer commentStamp: 'avi 8/21/2004 20:01' prior: 0!
A variant on the ObjectExlorer that works "backwards": like the ObjectExplorer, it shows a tree of objects, but expanding a node won't show the objects which that node references, but rather the objects that reference that node. Its main use is to track down memory leaks: if you want to know why a particular object is still alive, open a PointerExplorer on it and drill down until you find the root object that's referencing it. For example, find all the references to the symbol #zot with:
PointerExplorer new openExplorerFor: #zot
For the "name" of the object, the PointerExplorer shows each object's identityHash, to allow the user to identify when two similar objects are identical and notice cycles.!
----- Method: PointerExplorer>>getList (in category 'accessing') -----
getList
^Array with: (PointerExplorerWrapper with: rootObject name: rootObject identityHash asString model: self)
!
----- Method: Dictionary>>inspectorClass (in category '*Tools-Inspector') -----
inspectorClass
"Answer the class of the inspector to be used on the receiver. Called by inspect;
use basicInspect to get a normal (less useful) type of inspector."
^ DictionaryInspector!
StringMorph subclass: #IndentingListItemMorph
instanceVariableNames: 'indentLevel isExpanded complexContents firstChild container nextSibling icon'
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Explorer'!
!IndentingListItemMorph commentStamp: '<historical>' prior: 0!
An IndentingListItemMorph is a StringMorph that draws itself with an optional toggle at its left, as part of the display of the SimpleHierarchicalListMorph.
It will also display lines around the toggle if the #showLinesInHierarchyViews Preference is set.
Instance variables:
indentLevel <SmallInteger> the indent level, from 0 at the root and increasing by 1 at each level of the hierarchy.
isExpanded <Boolean> true if this item is expanded (showing its children)
complexContents <ListItemWrapper> an adapter wrapping my represented item that can answer its children, etc.
firstChild <IndentingListItemMorph|nil> my first child, or nil if none
container <SimpleHierarchicalListMorph> my container
nextSibling <IndentingListItemMorph|nil> the next item in the linked list of siblings, or nil if none.
Contributed by Bob Arning as part of the ObjectExplorer package.
Don't blame him if it's not perfect. We wanted to get it out for people to play with.!
----- Method: IndentingListItemMorph>>acceptDroppingMorph:event: (in category 'drag and drop') -----
acceptDroppingMorph: toDrop event: evt
complexContents acceptDroppingObject: toDrop complexContents.
toDrop delete.
self highlightForDrop: false.!
----- Method: IndentingListItemMorph>>addChildrenForList:addingTo:withExpandedItems: (in category 'private-container protocol') -----
addChildrenForList: hostList addingTo: morphList withExpandedItems: expandedItems
firstChild ifNotNil: [
firstChild withSiblingsDo: [ :aNode | aNode delete].
].
firstChild := nil.
complexContents hasContents ifFalse: [^self].
firstChild := hostList
addMorphsTo: morphList
from: complexContents contents
allowSorting: true
withExpandedItems: expandedItems
atLevel: indentLevel + 1.
!
----- Method: IndentingListItemMorph>>balloonText (in category 'accessing') -----
balloonText
^complexContents balloonText ifNil: [super balloonText]!
----- Method: IndentingListItemMorph>>boundsForBalloon (in category 'halos and balloon help') -----
boundsForBalloon
"some morphs have bounds that are way too big"
container ifNil: [^super boundsForBalloon].
^self boundsInWorld intersect: container boundsInWorld!
----- Method: IndentingListItemMorph>>canExpand (in category 'accessing') -----
canExpand
^complexContents hasContents!
----- Method: IndentingListItemMorph>>children (in category 'accessing') -----
children
| children |
children := OrderedCollection new.
self childrenDo: [:each | children add: each].
^children!
----- Method: IndentingListItemMorph>>childrenDo: (in category 'enumeration') -----
childrenDo: aBlock
firstChild ifNotNil: [
firstChild withSiblingsDo: [ :aNode | aBlock value: aNode].
]!
----- Method: IndentingListItemMorph>>complexContents (in category 'private-container protocol') -----
complexContents
^complexContents!
----- Method: IndentingListItemMorph>>drawLineToggleToTextOn:lineColor:hasToggle: (in category 'drawing') -----
drawLineToggleToTextOn: aCanvas lineColor: lineColor hasToggle: hasToggle
"If I am not the only item in my container, draw the line between:
- my toggle (if any) or my left edge (if no toggle)
- and my text left edge"
| myBounds myCenter hLineY hLineLeft |
self isSoleItem ifTrue: [ ^self ].
myBounds := self toggleBounds.
myCenter := myBounds center.
hLineY := myCenter y.
hLineLeft := myCenter x - 1.
"Draw line from toggle to text"
aCanvas
line: hLineLeft @ hLineY
to: myBounds right + 0 @ hLineY
width: 1
color: lineColor!
----- Method: IndentingListItemMorph>>drawLinesOn:lineColor: (in category 'drawing') -----
drawLinesOn: aCanvas lineColor: lineColor
| hasToggle |
hasToggle := self hasToggle.
"Draw line from toggle to text"
self drawLineToggleToTextOn: aCanvas lineColor: lineColor hasToggle: hasToggle.
"Draw the line from my toggle to the nextSibling's toggle"
self nextSibling ifNotNil: [ self drawLinesToNextSiblingOn: aCanvas lineColor: lineColor hasToggle: hasToggle ].
"If I have children and am expanded, draw a line to my first child"
(self firstChild notNil and: [ self isExpanded ])
ifTrue: [ self drawLinesToFirstChildOn: aCanvas lineColor: lineColor]!
----- Method: IndentingListItemMorph>>drawLinesToFirstChildOn:lineColor: (in category 'drawing') -----
drawLinesToFirstChildOn: aCanvas lineColor: lineColor
"Draw line from me to next sibling"
| vLineX vLineTop vLineBottom childBounds childCenter |
childBounds := self firstChild toggleBounds.
childCenter := childBounds center.
vLineX := childCenter x - 1.
vLineTop := bounds bottom.
self firstChild hasToggle
ifTrue: [vLineBottom := childCenter y - 7]
ifFalse: [vLineBottom := childCenter y].
aCanvas
line: vLineX @ vLineTop
to: vLineX @ vLineBottom
width: 1
color: lineColor!
----- Method: IndentingListItemMorph>>drawLinesToNextSiblingOn:lineColor:hasToggle: (in category 'drawing') -----
drawLinesToNextSiblingOn: aCanvas lineColor: lineColor hasToggle: hasToggle
| myBounds nextSibBounds vLineX myCenter vLineTop vLineBottom |
myBounds := self toggleBounds.
nextSibBounds := self nextSibling toggleBounds.
myCenter := myBounds center.
vLineX := myCenter x - 1.
vLineTop := myCenter y.
vLineBottom := nextSibBounds center y.
"Draw line from me to next sibling"
aCanvas
line: vLineX @ vLineTop
to: vLineX @ vLineBottom
width: 1
color: lineColor!
----- Method: IndentingListItemMorph>>drawOn: (in category 'drawing') -----
drawOn: aCanvas
| tRect sRect columnRect columnScanner columnData columnLeft |
tRect := self toggleRectangle.
sRect := bounds withLeft: tRect right + 4.
self drawToggleOn: aCanvas in: tRect.
icon isNil ifFalse:[
aCanvas
translucentImage: icon
at: sRect left @ (self top + (self height - icon height // 2)).
sRect := sRect left: sRect left + icon width + 2.
].
(container columns isNil or: [(contents asString indexOf: Character tab) = 0]) ifTrue: [
sRect := sRect top: sRect top + sRect bottom - self fontToUse height // 2.
aCanvas drawString: contents asString in: sRect font: self fontToUse color: color.
] ifFalse: [
columnLeft := sRect left.
columnScanner := ReadStream on: contents asString.
container columns do: [ :width |
columnRect := columnLeft @ sRect top extent: width @ sRect height.
columnData := columnScanner upTo: Character tab.
columnData isEmpty ifFalse: [
aCanvas drawString: columnData in: columnRect font: self fontToUse color: color
.
].
columnLeft := columnRect right + 5.
].
]
!
----- Method: IndentingListItemMorph>>drawToggleOn:in: (in category 'drawing') -----
drawToggleOn: aCanvas in: aRectangle
| aForm centeringOffset |
complexContents hasContents ifFalse: [^self].
aForm := isExpanded
ifTrue: [container expandedForm]
ifFalse: [container notExpandedForm].
centeringOffset := ((aRectangle height - aForm extent y) / 2.0) rounded.
^aCanvas
paintImage: aForm
at: (aRectangle topLeft translateBy: 0 @ centeringOffset).
!
----- Method: IndentingListItemMorph>>firstChild (in category 'accessing') -----
firstChild
^firstChild!
----- Method: IndentingListItemMorph>>hasIcon (in category 'accessing') -----
hasIcon
"Answer whether the receiver has an icon."
^ icon notNil!
----- Method: IndentingListItemMorph>>hasToggle (in category 'private') -----
hasToggle
^ complexContents hasContents!
----- Method: IndentingListItemMorph>>highlight (in category 'private-container protocol') -----
highlight
complexContents highlightingColor ifNotNil: [self color: complexContents highlightingColor].
self changed.
!
----- Method: IndentingListItemMorph>>icon (in category 'accessing') -----
icon
"answer the receiver's icon"
^ icon!
----- Method: IndentingListItemMorph>>inToggleArea: (in category 'mouse events') -----
inToggleArea: aPoint
^self toggleRectangle containsPoint: aPoint!
----- Method: IndentingListItemMorph>>indentLevel (in category 'accessing') -----
indentLevel
^indentLevel!
----- Method: IndentingListItemMorph>>initWithContents:prior:forList:indentLevel: (in category 'initialization') -----
initWithContents: anObject prior: priorMorph forList: hostList indentLevel: newLevel
container := hostList.
complexContents := anObject.
self initWithContents: anObject asString font: Preferences standardListFont emphasis: nil.
indentLevel := 0.
isExpanded := false.
nextSibling := firstChild := nil.
priorMorph ifNotNil: [
priorMorph nextSibling: self.
].
indentLevel := newLevel.
icon := anObject icon.
self extent: self minWidth @ self minHeight!
----- Method: IndentingListItemMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
indentLevel := 0.
isExpanded := false!
----- Method: IndentingListItemMorph>>isExpanded (in category 'accessing') -----
isExpanded
^isExpanded!
----- Method: IndentingListItemMorph>>isExpanded: (in category 'accessing') -----
isExpanded: aBoolean
isExpanded := aBoolean!
----- Method: IndentingListItemMorph>>isFirstItem (in category 'accessing') -----
isFirstItem
^owner submorphs first == self!
----- Method: IndentingListItemMorph>>isSoleItem (in category 'accessing') -----
isSoleItem
^self isFirstItem and: [ owner submorphs size = 1 ]!
----- Method: IndentingListItemMorph>>minHeight (in category 'layout') -----
minHeight
| iconHeight |
iconHeight := self hasIcon
ifTrue: [self icon height + 2]
ifFalse: [0].
^ self fontToUse height max: iconHeight !
----- Method: IndentingListItemMorph>>minWidth (in category 'layout') -----
minWidth
| iconWidth |
iconWidth := self hasIcon
ifTrue: [self icon width + 2]
ifFalse: [0].
^ (self fontToUse widthOfString: contents)
+ iconWidth !
----- Method: IndentingListItemMorph>>nextSibling (in category 'accessing') -----
nextSibling
^nextSibling!
----- Method: IndentingListItemMorph>>nextSibling: (in category 'accessing') -----
nextSibling: anotherMorph
nextSibling := anotherMorph!
----- Method: IndentingListItemMorph>>openPath: (in category 'private-container protocol') -----
openPath: anArray
| found |
anArray isEmpty
ifTrue: [^ container setSelectedMorph: nil].
found := nil.
self
withSiblingsDo: [:each | found
ifNil: [(each complexContents asString = anArray first
or: [anArray first isNil])
ifTrue: [found := each]]].
found
ifNil: ["try again with no case sensitivity"
self
withSiblingsDo: [:each | found
ifNil: [(each complexContents asString sameAs: anArray first)
ifTrue: [found := each]]]].
found
ifNotNil: [found isExpanded
ifFalse: [found toggleExpandedState.
container adjustSubmorphPositions].
found changed.
anArray size = 1
ifTrue: [^ container setSelectedMorph: found].
^ found firstChild
ifNil: [container setSelectedMorph: nil]
ifNotNil: [found firstChild openPath: anArray allButFirst]].
^ container setSelectedMorph: nil!
----- Method: IndentingListItemMorph>>recursiveAddTo: (in category 'private-container protocol') -----
recursiveAddTo: aCollection
firstChild ifNotNil: [
firstChild withSiblingsDo: [ :aNode | aNode recursiveAddTo: aCollection].
].
aCollection add: self
!
----- Method: IndentingListItemMorph>>recursiveDelete (in category 'private-container protocol') -----
recursiveDelete
firstChild ifNotNil: [
firstChild withSiblingsDo: [ :aNode | aNode recursiveDelete].
].
self delete
!
----- Method: IndentingListItemMorph>>toggleBounds (in category 'private') -----
toggleBounds
^self toggleRectangle!
----- Method: IndentingListItemMorph>>toggleExpandedState (in category 'private-container protocol') -----
toggleExpandedState
| newChildren toDelete c |
isExpanded := isExpanded not.
toDelete := OrderedCollection new.
firstChild ifNotNil: [
firstChild withSiblingsDo: [ :aNode | aNode recursiveAddTo: toDelete].
].
container noteRemovalOfAll: toDelete.
(isExpanded and: [complexContents hasContents]) ifFalse: [
^self changed
].
(c := complexContents contents) isEmpty ifTrue: [^self changed].
newChildren := container
addSubmorphsAfter: self
fromCollection: c
allowSorting: true.
firstChild := newChildren first.
!
----- Method: IndentingListItemMorph>>toggleRectangle (in category 'private') -----
toggleRectangle
| h |
h := bounds height.
^(bounds left + (12 * indentLevel)) @ bounds top extent: 12 at h!
----- Method: IndentingListItemMorph>>unhighlight (in category 'drawing') -----
unhighlight
complexContents highlightingColor ifNotNil: [self color: Color black].
self changed.
!
----- Method: IndentingListItemMorph>>userString (in category 'accessing') -----
userString
"Add leading tabs to my userString"
^ (String new: indentLevel withAll: Character tab), super userString
!
----- Method: IndentingListItemMorph>>withSiblingsDo: (in category 'private') -----
withSiblingsDo: aBlock
| node |
node := self.
[node isNil] whileFalse: [
aBlock value: node.
node := node nextSibling
].!
----- Method: IndentingListItemMorph>>withoutListWrapper (in category 'converting') -----
withoutListWrapper
^complexContents withoutListWrapper!
----- Method: StringMorph>>balloonTextForClassAndMethodString (in category '*Tools') -----
balloonTextForClassAndMethodString
"Answer suitable balloon text for the receiver thought of as an encoding of the form
<className> [ class ] <selector>"
| aComment |
Preferences balloonHelpInMessageLists
ifFalse: [^ nil].
MessageSet parse: self contents asString toClassAndSelector:
[:aClass :aSelector |
(aClass notNil and: [aSelector notNil]) ifTrue:
[aComment := aClass precodeCommentOrInheritedCommentFor: aSelector]].
^ aComment
!
----- Method: StringMorph>>balloonTextForLexiconString (in category '*Tools') -----
balloonTextForLexiconString
"Answer suitable balloon text for the receiver thought of as an encoding (used in Lexicons) of the form
<selector> <spaces> (<className>>)"
| aComment contentsString aSelector aClassName |
Preferences balloonHelpInMessageLists
ifFalse: [^ nil].
contentsString := self contents asString.
aSelector := contentsString upTo: $ .
aClassName := contentsString copyFrom: ((contentsString indexOf: $() + 1) to: ((contentsString indexOf: $)) - 1).
MessageSet parse: (aClassName, ' dummy') toClassAndSelector:
[:cl :sel | cl ifNotNil:
[aComment := cl precodeCommentOrInheritedCommentFor: aSelector]].
^ aComment
!
----- Method: StringMorph>>balloonTextForMethodString (in category '*Tools') -----
balloonTextForMethodString
"Answer suitable balloon text for the receiver thought of as a method belonging to the currently-selected class of a browser tool."
| aWindow aCodeHolder aClass |
Preferences balloonHelpInMessageLists
ifFalse: [^ nil].
aWindow := self ownerThatIsA: SystemWindow.
(aWindow isNil or: [((aCodeHolder := aWindow model) isKindOf: CodeHolder) not])
ifTrue: [^ nil].
((aClass := aCodeHolder selectedClassOrMetaClass) isNil or:
[(aClass includesSelector: contents asSymbol) not])
ifTrue: [^ nil].
^ aClass precodeCommentOrInheritedCommentFor: contents asSymbol
!
----- Method: PasteUpMorph>>defaultDesktopCommandKeyTriplets (in category '*Tools') -----
defaultDesktopCommandKeyTriplets
"Answer a list of triplets of the form
<key> <receiver> <selector> [+ optional fourth element, a <description> for use in desktop-command-key-help]
that will provide the default desktop command key handlers. If the selector takes an argument, that argument will be the command-key event"
| noviceKeys expertKeys |
noviceKeys := {
{ $o. ActiveWorld. #activateObjectsTool. 'Activate the "Objects Tool"'}.
{ $r. ActiveWorld. #restoreMorphicDisplay. 'Redraw the screen'}.
{ $z. self. #undoOrRedoCommand. 'Undo or redo the last undoable command'}.
{ $F. Project current. #toggleFlapsSuppressed. 'Toggle the display of flaps'}.
{ $N. self. #toggleClassicNavigatorIfAppropriate. 'Show/Hide the classic Navigator, if appropriate'}.
{ $M. self. #toggleShowWorldMainDockingBar. 'Show/Hide the Main Docking Bar'}.
}.
Preferences noviceMode
ifTrue:[^ noviceKeys].
expertKeys := {
{ $b. SystemBrowser. #defaultOpenBrowser. 'Open a new System Browser'}.
{ $k. StringHolder. #open. 'Open a new, blank Workspace'}.
{ $m. self. #putUpNewMorphMenu. 'Put up the "New Morph" menu'}.
{ $t. self. #findATranscript:. 'Make a System Transcript visible'}.
{ $w. SystemWindow. #closeTopWindow. 'Close the topmost window'}.
{ $C. self. #findAChangeSorter:. 'Make a Change Sorter visible'}.
{ $L. self. #findAFileList:. 'Make a File List visible'}.
{ $P. self. #findAPreferencesPanel:. 'Activate the Preferences tool'}.
{ $R. self. #openRecentSubmissionsBrowser:. 'Make a Recent Submissions browser visible'}.
{ $W. self. #findAMessageNamesWindow:. 'Make a MessageNames tool visible'}.
{ $Z. ChangeList. #browseRecentLog. 'Browse recently-logged changes'}.
{ $\. SystemWindow. #sendTopWindowToBack. 'Send the top window to the back'}.
}.
^ noviceKeys, expertKeys
!
----- Method: SystemNavigation>>browserClass (in category '*tools-browser') -----
browserClass
browserClass ifNil: [browserClass := self defaultBrowserClass].
^browserClass!
----- Method: SystemNavigation>>browserClass: (in category '*tools-browser') -----
browserClass: aBrowserClass
browserClass := aBrowserClass!
----- Method: SystemNavigation>>defaultBrowserClass (in category '*tools-browser') -----
defaultBrowserClass
^SystemBrowser default!
----- Method: SystemNavigation>>defaultHierarchyBrowserClass (in category '*tools-browser') -----
defaultHierarchyBrowserClass
^self class environment at: #HierarchyBrowser ifAbsent:[]!
----- Method: SystemNavigation>>hierarchyBrowserClass (in category '*tools-browser') -----
hierarchyBrowserClass
hierarchyBrowserClass ifNil: [hierarchyBrowserClass := self defaultHierarchyBrowserClass].
^hierarchyBrowserClass!
----- Method: SystemNavigation>>hierarchyBrowserClass: (in category '*tools-browser') -----
hierarchyBrowserClass: aBrowserClass
hierarchyBrowserClass := aBrowserClass!
----- Method: TraitBehavior>>browse (in category '*tools-browser') -----
browse
self systemNavigation browseClass: self!
StringHolder subclass: #CodeHolder
instanceVariableNames: 'currentCompiledMethod contentsSymbol'
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Base'!
!CodeHolder commentStamp: '<historical>' prior: 0!
An ancestor class for all models which can show code. Eventually, much of the code that currently resides in StringHolder which only applies to code-holding StringHolders might get moved down here.!
CodeHolder subclass: #Browser
instanceVariableNames: 'systemOrganizer classOrganizer metaClassOrganizer systemCategoryListIndex classListIndex messageCategoryListIndex messageListIndex editSelection metaClassIndicated'
classVariableNames: 'ListClassesHierarchically RecentClasses'
poolDictionaries: ''
category: 'Tools-Browser'!
!Browser commentStamp: '<historical>' prior: 0!
I represent a query path into the class descriptions, the software of the system.!
----- Method: Browser class>>fullOnClass: (in category 'instance creation') -----
fullOnClass: aClass
"Open a new full browser set to class."
| brow |
brow := self new.
brow setClass: aClass selector: nil.
^ self
openBrowserView: (brow openEditString: nil)
label: 'System Browser'!
----- Method: Browser class>>fullOnClass:selector: (in category 'instance creation') -----
fullOnClass: aClass selector: aSelector
"Open a new full browser set to class."
| brow classToUse |
classToUse := SystemBrowser default.
brow := classToUse new.
brow setClass: aClass selector: aSelector.
^ classToUse
openBrowserView: (brow openEditString: nil)
label: brow labelString!
----- Method: Browser class>>initialize (in category 'class initialization') -----
initialize
"Browser initialize"
RecentClasses := OrderedCollection new.
self
registerInFlapsRegistry;
registerInAppRegistry !
----- Method: Browser class>>listClassesHierarchically (in category 'preferences') -----
listClassesHierarchically
<preference: 'List classes hierarchically'
category: 'browsing'
description: 'When enabled, the class list in the browser is arranged and indented with regard to the class hierarchy.'
type: #Boolean>
^ListClassesHierarchically ifNil: [false]
!
----- Method: Browser class>>listClassesHierarchically: (in category 'preferences') -----
listClassesHierarchically: aBool
ListClassesHierarchically := aBool!
----- Method: Browser class>>new (in category 'instance creation') -----
new
^super new systemOrganizer: SystemOrganization!
----- Method: Browser class>>newOnCategory: (in category 'instance creation') -----
newOnCategory: aCategory
"Browse the system category of the given name. 7/13/96 sw"
"Browser newOnCategory: 'Interface-Browser'"
| newBrowser catList |
newBrowser := self new.
catList := newBrowser systemCategoryList.
newBrowser systemCategoryListIndex:
(catList indexOf: aCategory asSymbol ifAbsent: [^ self inform: 'No such category']).
^ self
openBrowserView: (newBrowser openSystemCatEditString: nil)
label: 'Classes in category ', aCategory
!
----- Method: Browser class>>newOnClass: (in category 'instance creation') -----
newOnClass: aClass
"Open a new class browser on this class."
^ self newOnClass: aClass label: 'Class Browser: ', aClass name!
----- Method: Browser class>>newOnClass:label: (in category 'instance creation') -----
newOnClass: aClass label: aLabel
"Open a new class browser on this class."
| newBrowser |
newBrowser := self new.
newBrowser setClass: aClass selector: nil.
^ self
openBrowserView: (newBrowser openOnClassWithEditString: nil)
label: aLabel
!
----- Method: Browser class>>newOnClass:selector: (in category 'instance creation') -----
newOnClass: aClass selector: aSymbol
"Open a new class browser on this class."
| newBrowser |
newBrowser := self new.
newBrowser setClass: aClass selector: aSymbol.
^ self
openBrowserView: (newBrowser openOnClassWithEditString: nil)
label: 'Class Browser: ', aClass name
!
----- Method: Browser class>>open (in category 'instance creation') -----
open
^self openBrowser
!
----- Method: Browser class>>openBrowser (in category 'instance creation') -----
openBrowser
"Create and schedule a BrowserView with default browser label. The
view consists of five subviews, starting with the list view of system
categories of SystemOrganization. The initial text view part is empty."
| br |
br := self new.
^ self
openBrowserView: (br openEditString: nil)
label: br defaultBrowserTitle.
!
----- Method: Browser class>>openBrowserView:label: (in category 'instance creation') -----
openBrowserView: aBrowserView label: aString
"Schedule aBrowserView, labelling the view aString."
(aBrowserView isKindOf: ToolBuilderSpec) ifTrue:[
ToolBuilder open: aBrowserView label: aString.
] ifFalse:[
aBrowserView isMorph
ifTrue: [(aBrowserView setLabel: aString) openInWorld]
ifFalse: [aBrowserView label: aString.
aBrowserView minimumSize: 300 @ 200.
aBrowserView subViews do: [:each | each controller].
aBrowserView controller open].
].
^ aBrowserView model
!
----- Method: Browser class>>prototypicalToolWindow (in category 'instance creation') -----
prototypicalToolWindow
"Answer an example of myself seen in a tool window, for the benefit of parts-launching tools"
| aWindow |
aWindow := self new openEditString: nil.
^ ToolBuilder build: aWindow!
----- Method: Browser class>>registerInAppRegistry (in category 'class initialization') -----
registerInAppRegistry
"Register the receiver in the SystemBrowser AppRegistry"
SystemBrowser register: self.!
----- Method: Browser class>>registerInFlapsRegistry (in category 'class initialization') -----
registerInFlapsRegistry
"Register the receiver in the system's flaps registry"
self environment
at: #Flaps
ifPresent: [:cl | cl registerQuad: #(#Browser #prototypicalToolWindow 'Browser' 'A Browser is a tool that allows you to view all the code of all the classes in the system' )
forFlapNamed: 'Tools']!
----- Method: Browser class>>systemOrganizer: (in category 'instance creation') -----
systemOrganizer: anOrganizer
^(super new)
systemOrganizer: anOrganizer;
yourself!
----- Method: Browser class>>unload (in category 'class initialization') -----
unload
"Unload the receiver from global registries"
self environment at: #Flaps ifPresent: [:cl |
cl unregisterQuadsWithReceiver: self].
SystemBrowser unregister: self.!
----- Method: Browser class>>windowColorSpecification (in category 'window color') -----
windowColorSpecification
"Answer a WindowColorSpec object that declares my preference"
^ WindowColorSpec classSymbol: self name wording: 'Browser' brightColor: #lightGreen pastelColor: #paleGreen helpMessage: 'The standard "system browser" tool that allows you to browse through all the code in the system'!
----- Method: Browser>>aboutToStyle: (in category 'code pane') -----
aboutToStyle: aStyler
"This is a notification that aStyler is about to re-style its text.
Set the classOrMetaClass in aStyler, so that identifiers
will be resolved correctly.
Answer true to allow styling to proceed, or false to veto the styling"
| type |
self isModeStyleable ifFalse: [^false].
type := self editSelection.
(#(newMessage editMessage editClass newClass) includes: type) ifFalse:[^false].
aStyler classOrMetaClass: (type = #editClass ifFalse:[self selectedClassOrMetaClass]).
^true!
----- Method: Browser>>addAllMethodsToCurrentChangeSet (in category 'class functions') -----
addAllMethodsToCurrentChangeSet
"Add all the methods in the selected class or metaclass to the current change set. You ought to know what you're doing before you invoke this!!"
| aClass |
(aClass := self selectedClassOrMetaClass) ifNotNil:
[aClass selectors do:
[:sel |
ChangeSet current adoptSelector: sel forClass: aClass].
self changed: #annotation]
!
----- Method: Browser>>addCategory (in category 'message category functions') -----
addCategory
"Present a choice of categories or prompt for a new category name and add it before the current selection, or at the end if no current selection"
| labels reject lines cats menuIndex oldIndex newName |
self okToChange ifFalse: [^ self].
classListIndex = 0 ifTrue: [^ self].
labels := OrderedCollection with: 'new...'.
reject := Set new.
reject
addAll: self selectedClassOrMetaClass organization categories;
add: ClassOrganizer nullCategory;
add: ClassOrganizer default.
lines := OrderedCollection new.
self selectedClassOrMetaClass allSuperclasses do: [:cls |
cls = Object ifFalse: [
cats := cls organization categories reject:
[:cat | reject includes: cat].
cats isEmpty ifFalse: [
lines add: labels size.
labels addAll: cats asSortedCollection.
reject addAll: cats]]].
newName := (labels size = 1 or: [
menuIndex := (UIManager default chooseFrom: labels lines: lines title: 'Add Category').
menuIndex = 0 ifTrue: [^ self].
menuIndex = 1])
ifTrue: [
self request: 'Please type new category name'
initialAnswer: 'category name']
ifFalse: [
labels at: menuIndex].
oldIndex := messageCategoryListIndex.
newName isEmpty
ifTrue: [^ self]
ifFalse: [newName := newName asSymbol].
self classOrMetaClassOrganizer
addCategory: newName
before: (messageCategoryListIndex = 0
ifTrue: [nil]
ifFalse: [self selectedMessageCategoryName]).
self changed: #messageCategoryList.
self messageCategoryListIndex:
(oldIndex = 0
ifTrue: [self classOrMetaClassOrganizer categories size + 1]
ifFalse: [oldIndex]).
self changed: #messageCategoryList.
!
----- Method: Browser>>addClassAndSwitchesTo:at:with: (in category 'toolbuilder') -----
addClassAndSwitchesTo: windowSpec at: frame with: builder
| listSpec panelSpec |
listSpec := self buildClassListWith: builder.
listSpec frame: (frame origin corner: frame right @ (frame bottom - 0.08)).
windowSpec children add: listSpec.
panelSpec := self buildSwitchesWith: builder.
panelSpec frame: (frame left@(frame bottom - 0.08) corner: frame corner).
windowSpec children addLast: panelSpec.!
----- Method: Browser>>addExtraShiftedItemsTo: (in category 'message functions') -----
addExtraShiftedItemsTo: aMenu
"The shifted selector-list menu is being built; some menu items are appropriate only for certain kinds of browsers, and this gives a hook for them to be added as approrpiate. If any is added here, a line should be added first -- browse reimplementors of this message for examples."
!
----- Method: Browser>>addModelItemsToWindowMenu: (in category 'user interface') -----
addModelItemsToWindowMenu: aMenu
"Add model-related items to the window menu"
super addModelItemsToWindowMenu: aMenu.
SystemBrowser addRegistryMenuItemsTo: aMenu inAccountOf: self.!
----- Method: Browser>>addSpecialMenu: (in category 'traits') -----
addSpecialMenu: aMenu
aMenu addList: #(
-
('new class' newClass)
('new trait' newTrait)
-).
self selectedClass notNil ifTrue: [
aMenu addList: #(
('add trait' addTrait)
-) ].
aMenu addList: #(-).
^ aMenu!
----- Method: Browser>>addSystemCategory (in category 'system category functions') -----
addSystemCategory
"Prompt for a new category name and add it before the
current selection, or at the end if no current selection"
| oldIndex newName |
self okToChange ifFalse: [^ self].
oldIndex := systemCategoryListIndex.
newName := self
request: 'Please type new category name'
initialAnswer: 'Category-Name'.
newName isEmpty
ifTrue: [^ self]
ifFalse: [newName := newName asSymbol].
systemOrganizer
addCategory: newName
before: (systemCategoryListIndex = 0
ifTrue: [nil]
ifFalse: [self selectedSystemCategoryName]).
self systemCategoryListIndex:
(oldIndex = 0
ifTrue: [self systemCategoryList size]
ifFalse: [oldIndex]).
self changed: #systemCategoryList.!
----- Method: Browser>>addTrait (in category 'traits') -----
addTrait
| input trait |
input := UIManager default request: 'add trait'.
input isEmptyOrNil ifFalse: [
trait := Smalltalk classNamed: input.
(trait isNil or: [trait isTrait not]) ifTrue: [
^self inform: 'Input invalid. ' , input , ' does not exist or is not a trait'].
self selectedClass addToComposition: trait.
self contentsChanged].
!
----- Method: Browser>>alphabetizeMessageCategories (in category 'message category functions') -----
alphabetizeMessageCategories
classListIndex = 0 ifTrue: [^ false].
self okToChange ifFalse: [^ false].
self classOrMetaClassOrganizer sortCategories.
self clearUserEditFlag.
self editClass.
self classListIndex: classListIndex.
^ true!
----- Method: Browser>>alphabetizeSystemCategories (in category 'system category functions') -----
alphabetizeSystemCategories
self okToChange ifFalse: [^ false].
systemOrganizer sortCategories.
self systemCategoryListIndex: 0.
self changed: #systemCategoryList.
!
----- Method: Browser>>annotation (in category 'annotation') -----
annotation
"Provide a line of content for an annotation pane, representing information about the method associated with the selected class and selector in the receiver."
| aSelector aClass |
(aClass := self selectedClassOrMetaClass) == nil ifTrue: [^ ''].
self editSelection == #editComment ifTrue:
[^ self annotationForSelector: #Comment ofClass: aClass].
self editSelection == #editClass ifTrue:
[^ self annotationForSelector: #Definition ofClass: aClass].
(aSelector := self selectedMessageName) ifNil: [^ ''].
^ self annotationForSelector: aSelector ofClass: aClass!
----- Method: Browser>>annotationForClassDefinitionFor: (in category 'class comment pane') -----
annotationForClassDefinitionFor: aClass
"Provide a line of content for an annotation pane, given that the receiver is pointing at the class definition of the given class."
^self classCommentText!
----- Method: Browser>>browseAllClasses (in category 'system category functions') -----
browseAllClasses
"Create and schedule a new browser on all classes alphabetically."
| newBrowser |
newBrowser := HierarchyBrowser new initAlphabeticListing.
self class openBrowserView: (newBrowser openSystemCatEditString: nil)
label: 'All Classes Alphabetically'!
----- Method: Browser>>buildClassListSingletonWith: (in category 'toolbuilder') -----
buildClassListSingletonWith: builder
| listSpec |
listSpec := builder pluggableListSpec new.
listSpec
model: self;
list: #classListSingleton;
getIndex: #indexIsOne;
setIndex: #indexIsOne:;
menu: #classListMenu:;
keyPress: #classListKey:from:.
^listSpec
!
----- Method: Browser>>buildClassListWith: (in category 'toolbuilder') -----
buildClassListWith: builder
| listSpec |
listSpec := builder pluggableListSpec new.
listSpec
model: self;
list: #classList;
getIndex: #classListIndex;
setIndex: #classListIndex:;
menu: #classListMenu:;
keyPress: #classListKey:from:.
Preferences browseWithDragNDrop
ifTrue:[listSpec dragItem: #dragFromClassList:].
^listSpec
!
----- Method: Browser>>buildMessageCategoryBrowser (in category 'message category functions') -----
buildMessageCategoryBrowser
"Create and schedule a message category browser for the currently
selected message category."
self buildMessageCategoryBrowserEditString: nil!
----- Method: Browser>>buildMessageCategoryBrowserEditString: (in category 'message category functions') -----
buildMessageCategoryBrowserEditString: aString
"Create and schedule a message category browser for the currently
selected message category. The initial text view contains the characters
in aString."
"wod 6/24/1998: set newBrowser classListIndex so that it works whether the
receiver is a standard or a Hierarchy Browser."
| newBrowser |
messageCategoryListIndex ~= 0
ifTrue:
[newBrowser := Browser new.
newBrowser systemCategoryListIndex: systemCategoryListIndex.
newBrowser classListIndex: (newBrowser classList indexOf: self selectedClassName).
newBrowser metaClassIndicated: metaClassIndicated.
newBrowser messageCategoryListIndex: messageCategoryListIndex.
newBrowser messageListIndex: messageListIndex.
self class openBrowserView: (newBrowser openMessageCatEditString: aString)
label: 'Message Category Browser (' ,
newBrowser selectedClassOrMetaClassName , ')']!
----- Method: Browser>>buildMessageCategoryListWith: (in category 'toolbuilder') -----
buildMessageCategoryListWith: builder
| listSpec |
listSpec := builder pluggableListSpec new.
listSpec
model: self;
list: #messageCategoryList;
getIndex: #messageCategoryListIndex;
setIndex: #messageCategoryListIndex:;
menu: #messageCategoryMenu:;
keyPress: #arrowKey:from:.
Preferences browseWithDragNDrop ifTrue:[
listSpec
dropAccept: #wantsMessageCategoriesDrop:;
dropItem: #dropOnMessageCategories:at:].
^listSpec
!
----- Method: Browser>>buildMessageListCatSingletonWith: (in category 'toolbuilder') -----
buildMessageListCatSingletonWith: builder
| listSpec |
listSpec := builder pluggableListSpec new.
listSpec
model: self;
list: #messageCatListSingleton;
getIndex: #indexIsOne;
setIndex: #indexIsOne:;
menu: #messageCategoryMenu:.
^listSpec
!
----- Method: Browser>>buildMessageListWith: (in category 'toolbuilder') -----
buildMessageListWith: builder
| listSpec |
listSpec := builder pluggableListSpec new.
listSpec
model: self;
list: #messageList;
getIndex: #messageListIndex;
setIndex: #messageListIndex:;
menu: #messageListMenu:shifted:;
keyPress: #messageListKey:from:.
Preferences browseWithDragNDrop
ifTrue:[listSpec dragItem: #dragFromMessageList:].
^listSpec
!
----- Method: Browser>>buildSwitchesWith: (in category 'toolbuilder') -----
buildSwitchesWith: builder
"Build the instance/comment/class switch"
| panelSpec buttonSpec |
panelSpec := builder pluggablePanelSpec new.
panelSpec children: OrderedCollection new.
buttonSpec := builder pluggableButtonSpec new.
buttonSpec
model: self;
label: 'instance';
state: #instanceMessagesIndicated;
action: #indicateInstanceMessages;
frame: (0 at 0 corner: 0.39 at 1).
panelSpec children addLast: buttonSpec.
buttonSpec := builder pluggableButtonSpec new.
buttonSpec
model: self;
label: '?';
state: #classCommentIndicated;
action: #plusButtonHit;
frame: (0.41 at 0 corner: 0.59 at 1).
panelSpec children addLast: buttonSpec.
buttonSpec := builder pluggableButtonSpec new.
buttonSpec
model: self;
label: 'class';
state: #classMessagesIndicated;
action: #indicateClassMessages;
frame: (0.61 at 0 corner: 1 at 1).
panelSpec children addLast: buttonSpec.
^panelSpec!
----- Method: Browser>>buildSystemCatListSingletonWith: (in category 'toolbuilder') -----
buildSystemCatListSingletonWith: builder
| listSpec |
listSpec := builder pluggableListSpec new.
listSpec
model: self;
list: #systemCategorySingleton;
getIndex: #indexIsOne;
setIndex: #indexIsOne:;
menu: #systemCategoryMenu:;
keyPress: #systemCatSingletonKey:from:.
^listSpec!
----- Method: Browser>>buildSystemCategoryBrowser (in category 'system category functions') -----
buildSystemCategoryBrowser
"Create and schedule a new system category browser."
self buildSystemCategoryBrowserEditString: nil!
----- Method: Browser>>buildSystemCategoryBrowserEditString: (in category 'system category functions') -----
buildSystemCategoryBrowserEditString: aString
"Create and schedule a new system category browser with initial textual
contents set to aString."
| newBrowser |
systemCategoryListIndex > 0
ifTrue:
[newBrowser := self class new.
newBrowser systemCategoryListIndex: systemCategoryListIndex.
newBrowser setClass: self selectedClassOrMetaClass selector: self selectedMessageName.
self class openBrowserView: (newBrowser openSystemCatEditString: aString)
label: 'Classes in category ', newBrowser selectedSystemCategoryName]!
----- Method: Browser>>buildSystemCategoryListWith: (in category 'toolbuilder') -----
buildSystemCategoryListWith: builder
| listSpec |
listSpec := builder pluggableListSpec new.
listSpec
model: self;
list: #systemCategoryList;
getIndex: #systemCategoryListIndex;
setIndex: #systemCategoryListIndex:;
menu: #systemCategoryMenu:;
keyPress: #systemCatListKey:from:.
Preferences browseWithDragNDrop ifTrue:[
listSpec
dropAccept: #wantsSystemCategoriesDrop:;
dropItem: #dropOnSystemCategories:at:].
^listSpec!
----- Method: Browser>>buildWith: (in category 'toolbuilder') -----
buildWith: builder
"Create the ui for the browser"
| windowSpec max |
max := self wantsOptionalButtons ifTrue:[0.42] ifFalse:[0.5].
windowSpec := self buildWindowWith: builder specs: {
(0 at 0 corner: 0.25 at max) -> [self buildSystemCategoryListWith: builder].
(0.25 at 0 corner: 0.5@(max-0.08)) -> [self buildClassListWith: builder].
(0.25@(max-0.08) corner: 0.5 at max) -> [self buildSwitchesWith: builder].
(0.5 at 0 corner: 0.75 at max) -> [self buildMessageCategoryListWith: builder].
(0.75 at 0 corner: 1 at max) -> [self buildMessageListWith: builder].
(0 at max corner: 1 at 1) -> [self buildCodePaneWith: builder].
}.
^builder build: windowSpec!
----- Method: Browser>>canShowMultipleMessageCategories (in category 'message category functions') -----
canShowMultipleMessageCategories
"Answer whether the receiver is capable of showing multiple message categories"
^ true!
----- Method: Browser>>categorizeAllUncategorizedMethods (in category 'message category list') -----
categorizeAllUncategorizedMethods
"Categorize methods by looking in parent classes for a method category."
| organizer organizers |
organizer := self classOrMetaClassOrganizer.
organizers := self selectedClassOrMetaClass withAllSuperclasses collect: [:ea | ea organization].
(organizer listAtCategoryNamed: ClassOrganizer default) do: [:sel | | found |
found := (organizers collect: [ :org | org categoryOfElement: sel])
detect: [:ea | ea ~= ClassOrganizer default and: [ ea ~= nil]]
ifNone: [].
found ifNotNil: [organizer classify: sel under: found]].
self changed: #messageCategoryList!
----- Method: Browser>>categoryOfCurrentMethod (in category 'message category functions') -----
categoryOfCurrentMethod
"Determine the method category associated with the receiver at the current moment, or nil if none"
| aCategory |
^ super categoryOfCurrentMethod ifNil:
[(aCategory := self messageCategoryListSelection) == ClassOrganizer allCategory
ifTrue:
[nil]
ifFalse:
[aCategory]]!
----- Method: Browser>>changeMessageCategories: (in category 'message category functions') -----
changeMessageCategories: aString
"The characters in aString represent an edited version of the the message
categories for the selected class. Update this information in the system
and inform any dependents that the categories have been changed. This
message is invoked because the user had issued the categories command
and edited the message categories. Then the user issued the accept
command."
self classOrMetaClassOrganizer changeFromString: aString.
self clearUserEditFlag.
self editClass.
self classListIndex: classListIndex.
^ true!
----- Method: Browser>>changeSystemCategories: (in category 'system category functions') -----
changeSystemCategories: aString
"Update the class categories by parsing the argument aString."
systemOrganizer changeFromString: aString.
self changed: #systemCategoryList.
^ true!
----- Method: Browser>>classComment:notifying: (in category 'class comment pane') -----
classComment: aText notifying: aPluggableTextMorph
"The user has just entered aText.
It may be all red (a side-effect of replacing the default comment), so remove the color if it is."
| theClass cleanedText redRange |
theClass := self selectedClassOrMetaClass.
theClass
ifNotNil: [cleanedText := aText asText.
redRange := cleanedText rangeOf: TextColor red startingAt: 1.
redRange size = cleanedText size
ifTrue: [cleanedText
removeAttribute: TextColor red
from: 1
to: redRange last ].
theClass comment: aText stamp: Utilities changeStamp].
self changed: #classCommentText.
^ true!
----- Method: Browser>>classCommentIndicated (in category 'metaclass') -----
classCommentIndicated
"Answer true iff we're viewing the class comment."
^ editSelection == #editComment
!
----- Method: Browser>>classCommentText (in category 'class functions') -----
classCommentText
"return the text to display for the comment of the currently selected class"
| theClass |
theClass := self selectedClassOrMetaClass.
theClass ifNil: [ ^''].
^ theClass hasComment
ifTrue: [ theClass comment ]
ifFalse: [ self noCommentNagString ]!
----- Method: Browser>>classDefinitionText (in category 'class functions') -----
classDefinitionText
"return the text to display for the definition of the currently selected class"
| theClass |
^(theClass := self selectedClassOrMetaClass) ifNil: [''] ifNotNil: [theClass definition]!
----- Method: Browser>>classList (in category 'class list') -----
classList
^ self class listClassesHierarchically
ifTrue: [self hierarchicalClassList]
ifFalse: [self defaultClassList].!
----- Method: Browser>>classListIndex (in category 'class list') -----
classListIndex
"Answer the index of the current class selection."
^classListIndex!
----- Method: Browser>>classListIndex: (in category 'class list') -----
classListIndex: anInteger
"Set anInteger to be the index of the current class selection."
| className |
classListIndex := anInteger.
self setClassOrganizer.
messageCategoryListIndex := 0.
messageListIndex := 0.
self classCommentIndicated
ifTrue: []
ifFalse: [self editSelection: (anInteger = 0
ifTrue: [metaClassIndicated | (systemCategoryListIndex == 0)
ifTrue: [#none]
ifFalse: [#newClass]]
ifFalse: [#editClass])].
contents := nil.
self selectedClass isNil
ifFalse: [className := self selectedClass name.
(RecentClasses includes: className)
ifTrue: [RecentClasses remove: className].
RecentClasses addFirst: className.
RecentClasses size > 16
ifTrue: [RecentClasses removeLast]].
self changed: #classSelectionChanged.
self changed: #classCommentText.
self changed: #classListIndex. "update my selection"
self changed: #messageCategoryList.
self changed: #messageList.
self changed: #relabel.
self contentsChanged!
----- Method: Browser>>classListIndexOf: (in category 'class list') -----
classListIndexOf: className
| classList |
classList := self classList.
self class listClassesHierarchically
ifTrue: [classList := classList collect: [:ea | ea withoutLeadingBlanks asSymbol]].
^ classList indexOf: className.!
----- Method: Browser>>classListMenu: (in category 'class functions') -----
classListMenu: aMenu
"For backward compatibility with old browers stored in image segments"
^ self classListMenu: aMenu shifted: false!
----- Method: Browser>>classListMenu:shifted: (in category 'class functions') -----
classListMenu: aMenu shifted: shifted
"Set up the menu to apply to the receiver's class list, honoring the #shifted boolean"
ServiceGui browser: self classMenu: aMenu.
ServiceGui onlyServices ifTrue: [^aMenu].
shifted
ifTrue:
[^ self shiftedClassListMenu: aMenu].
aMenu addList: #(
-
('browse full (b)' browseMethodFull)
('browse hierarchy (h)' spawnHierarchy)
('browse protocol (p)' browseFullProtocol)
-
('printOut' printOutClass)
('fileOut' fileOutClass)
-
('show hierarchy' hierarchy)
('show definition' editClass)
('show comment' editComment)
-
('inst var refs...' browseInstVarRefs)
('inst var defs...' browseInstVarDefs)
-
('class var refs...' browseClassVarRefs)
('class vars' browseClassVariables)
('class refs (N)' browseClassRefs)
-
('rename class ...' renameClass)
('copy class' copyClass)
('remove class (x)' removeClass)
-
('find method...' findMethod)
('find method wildcard...' findMethodWithWildcard)
-
('more...' offerShiftedClassListMenu)).
^ aMenu
!
----- Method: Browser>>classListSingleton (in category 'class list') -----
classListSingleton
| name |
name := self selectedClassName.
^ name ifNil: [Array new]
ifNotNil: [Array with: name]!
----- Method: Browser>>classMessagesIndicated (in category 'metaclass') -----
classMessagesIndicated
"Answer whether the messages to be presented should come from the
metaclass."
^ self metaClassIndicated and: [self classCommentIndicated not]!
----- Method: Browser>>classNotFound (in category 'system category functions') -----
classNotFound
self changed: #flash.!
----- Method: Browser>>classOrMetaClassOrganizer (in category 'metaclass') -----
classOrMetaClassOrganizer
"Answer the class organizer for the metaclass or class, depending on
which (instance or class) is indicated."
self metaClassIndicated
ifTrue: [^metaClassOrganizer]
ifFalse: [^classOrganizer]!
----- Method: Browser>>codePaneMenu:shifted: (in category 'code pane') -----
codePaneMenu: aMenu shifted: shifted
ServiceGui browser: self codePaneMenu: aMenu.
ServiceGui onlyServices ifTrue: [^ aMenu].
super codePaneMenu: aMenu shifted: shifted.
^ aMenu!
----- Method: Browser>>codeTextMorph (in category 'drag and drop') -----
codeTextMorph
^ self dependents
detect: [:dep | (dep isKindOf: PluggableTextMorph)
and: [dep getTextSelector == #contents]]
ifNone: []!
----- Method: Browser>>compileMessage:notifying: (in category 'code pane') -----
compileMessage: aText notifying: aController
"Compile the code that was accepted by the user, placing the compiled method into an appropriate message category. Return true if the compilation succeeded, else false."
| fallBackCategoryIndex fallBackMethodIndex originalSelectorName result |
self selectedMessageCategoryName ifNil:
[ self selectOriginalCategoryForCurrentMethod
ifFalse:["Select the '--all--' category"
self messageCategoryListIndex: 1]].
self selectedMessageCategoryName asSymbol = ClassOrganizer allCategory
ifTrue:
[ "User tried to save a method while the ALL category was selected"
fallBackCategoryIndex := messageCategoryListIndex.
fallBackMethodIndex := messageListIndex.
editSelection == #newMessage
ifTrue:
[ "Select the 'as yet unclassified' category"
messageCategoryListIndex := 0.
(result := self defineMessageFrom: aText notifying: aController)
ifNil:
["Compilation failure: reselect the original category & method"
messageCategoryListIndex := fallBackCategoryIndex.
messageListIndex := fallBackMethodIndex]
ifNotNil:
[self setSelector: result]]
ifFalse:
[originalSelectorName := self selectedMessageName.
self setOriginalCategoryIndexForCurrentMethod.
messageListIndex := fallBackMethodIndex := self messageList indexOf: originalSelectorName.
(result := self defineMessageFrom: aText notifying: aController)
ifNotNil:
[self setSelector: result]
ifNil:
[ "Compilation failure: reselect the original category & method"
messageCategoryListIndex := fallBackCategoryIndex.
messageListIndex := fallBackMethodIndex.
^ result notNil]].
self changed: #messageCategoryList.
^ result notNil]
ifFalse:
[ "User tried to save a method while the ALL category was NOT selected"
^ (self defineMessageFrom: aText notifying: aController) notNil]!
----- Method: Browser>>contents (in category 'accessing') -----
contents
"Depending on the current selection, different information is retrieved.
Answer a string description of that information. This information is the
method of the currently selected class and message."
| comment theClass latestCompiledMethod |
latestCompiledMethod := currentCompiledMethod.
currentCompiledMethod := nil.
editSelection == #newTrait
ifTrue: [^Trait newTemplateIn: self selectedSystemCategoryName].
editSelection == #none ifTrue: [^ ''].
editSelection == #editSystemCategories
ifTrue: [^ systemOrganizer printString].
editSelection == #newClass
ifTrue: [^ (theClass := self selectedClass)
ifNil:
[Class template: self selectedSystemCategoryName]
ifNotNil:
[Class templateForSubclassOf: theClass category: self selectedSystemCategoryName]].
editSelection == #editClass
ifTrue: [^self classDefinitionText].
editSelection == #editComment
ifTrue:
[(theClass := self selectedClass) ifNil: [^ ''].
comment := theClass comment.
currentCompiledMethod := theClass organization commentRemoteStr.
^ comment size = 0
ifTrue: ['This class has not yet been commented.']
ifFalse: [comment]].
editSelection == #hierarchy
ifTrue: [
self selectedClassOrMetaClass isTrait
ifTrue: [^'']
ifFalse: [^self selectedClassOrMetaClass printHierarchy]].
editSelection == #editMessageCategories
ifTrue: [^ self classOrMetaClassOrganizer printString].
editSelection == #newMessage
ifTrue:
[^ (theClass := self selectedClassOrMetaClass)
ifNil: ['']
ifNotNil: [theClass sourceCodeTemplate]].
editSelection == #editMessage
ifTrue:
[self showingByteCodes ifTrue: [^ self selectedBytecodes].
currentCompiledMethod := latestCompiledMethod.
^ self selectedMessage].
self error: 'Browser internal error: unknown edit selection.'!
----- Method: Browser>>contents:notifying: (in category 'accessing') -----
contents: input notifying: aController
"The retrieved information has changed and its source must now be
updated. The information can be a variety of things, depending on
the list selections (such as templates for class or message definition,
methods) or the user menu commands (such as definition, comment,
hierarchy). Answer the result of updating the source."
| aString aText theClass |
self changed: #annotation.
aString := input asString.
aText := input asText.
editSelection == #newTrait ifTrue: [^self defineTrait: input asString notifying: aController].
editSelection == #editSystemCategories ifTrue: [^ self changeSystemCategories: aString].
editSelection == #editClass | (editSelection == #newClass) ifTrue: [^ self defineClass: aString notifying: aController].
editSelection == #editComment
ifTrue:
[theClass := self selectedClass.
theClass
ifNil:
[self inform: 'You must select a class
before giving it a comment.'.
^ false].
theClass comment: aText stamp: Utilities changeStamp.
self changed: #classCommentText.
^ true].
editSelection == #hierarchy ifTrue: [^ true].
editSelection == #editMessageCategories ifTrue: [^ self changeMessageCategories: aString].
editSelection == #editMessage | (editSelection == #newMessage)
ifTrue:
[^ self okayToAccept
ifFalse:
[false]
ifTrue:
[self compileMessage: aText notifying: aController]].
editSelection == #none
ifTrue:
[self inform: 'This text cannot be accepted
in this part of the browser.'.
^ false].
self error: 'unacceptable accept'!
----- Method: Browser>>contentsSelection (in category 'accessing') -----
contentsSelection
"Return the interval of text in the code pane to select when I set the pane's contents"
messageCategoryListIndex > 0 & (messageListIndex = 0)
ifTrue: [^ 1 to: 500] "entire empty method template"
ifFalse: [^ 1 to: 0] "null selection"!
----- Method: Browser>>copyClass (in category 'class functions') -----
copyClass
| originalName copysName class oldDefinition newDefinition |
classListIndex = 0 ifTrue: [^ self].
self okToChange ifFalse: [^ self].
originalName := self selectedClass name.
copysName := self request: 'Please type new class name' initialAnswer: originalName.
copysName = '' ifTrue: [^ self]. " Cancel returns '' "
copysName := copysName asSymbol.
copysName = originalName ifTrue: [^ self].
(Smalltalk includesKey: copysName)
ifTrue: [^ self error: copysName , ' already exists'].
oldDefinition := self selectedClass definition.
newDefinition := oldDefinition copyReplaceAll: '#' , originalName asString with: '#' , copysName asString.
Cursor wait
showWhile: [class := Compiler evaluate: newDefinition logged: true.
class copyAllCategoriesFrom: (Smalltalk at: originalName).
class class copyAllCategoriesFrom: (Smalltalk at: originalName) class].
self classListIndex: 0.
self changed: #classList!
----- Method: Browser>>couldBrowseAnyClass (in category 'accessing') -----
couldBrowseAnyClass
"Answer whether the receiver is equipped to browse any class. This is in support of the system-brower feature that allows the browser to be redirected at the selected class name. This implementation is clearly ugly, but the feature it enables is handsome enough. 3/1/96 sw"
self dependents
detect: [:d |
((d isKindOf: PluggableListView) or: [d isKindOf: PluggableListMorph]) and:
[d getListSelector == #systemCategoryList]]
ifNone: [^ false].
^ true
!
----- Method: Browser>>createHierarchyTreeOf: (in category 'class list') -----
createHierarchyTreeOf: col
"Create a tree from a flat collection of classes"
| childs transformed val indexes |
transformed := col collect: [:ea |
childs := col select: [:class | class isTrait not and: [class superclass = ea]].
indexes := childs collect: [:child | col indexOf: child].
ea -> indexes].
transformed copy do: [:ea |
ea value: (ea value collect: [:idx |
val := transformed at: idx.
transformed at: idx put: nil.
val])].
^ transformed select: [:ea | ea notNil].
!
----- Method: Browser>>createInstVarAccessors (in category 'class functions') -----
createInstVarAccessors
"Create getters and setters for all inst vars defined at the level of the current class selection, except do NOT clobber or override any selectors already understood by the instances of the selected class"
| aClass newMessage setter |
(aClass := self selectedClassOrMetaClass) ifNotNil:
[aClass instVarNames do:
[:aName |
(aClass canUnderstand: aName asSymbol)
ifFalse:
[newMessage := aName, '
"Answer the value of ', aName, '"
^ ', aName.
aClass compile: newMessage classified: 'accessing' notifying: nil].
(aClass canUnderstand: (setter := aName, ':') asSymbol)
ifFalse:
[newMessage := setter, ' anObject
"Set the value of ', aName, '"
', aName, ' := anObject'.
aClass compile: newMessage classified: 'accessing' notifying: nil]]]!
----- Method: Browser>>defaultBrowserTitle (in category 'initialize-release') -----
defaultBrowserTitle
^ 'System Browser'!
----- Method: Browser>>defaultClassList (in category 'class list') -----
defaultClassList
"Answer an array of the class names of the selected category. Answer an
empty array if no selection exists."
^ systemCategoryListIndex = 0
ifTrue: [Array new]
ifFalse: [systemOrganizer listAtCategoryNumber: systemCategoryListIndex]!
----- Method: Browser>>defineClass:notifying: (in category 'class functions') -----
defineClass: defString notifying: aController
"The receiver's textual content is a request to define a new class. The
source code is defString. If any errors occur in compilation, notify
aController."
| oldClass class newClassName defTokens keywdIx envt |
oldClass := self selectedClassOrMetaClass.
defTokens := defString findTokens: Character separators.
((defTokens first = 'Trait' and: [defTokens second = 'named:'])
or: [defTokens second = 'classTrait'])
ifTrue: [^self defineTrait: defString notifying: aController].
keywdIx := defTokens findFirst: [:x | x beginsWith: 'category'].
envt := Smalltalk.
keywdIx := defTokens findFirst: [:x | '*subclass*' match: x].
newClassName := (defTokens at: keywdIx+1) copyWithoutAll: '#()'.
((oldClass isNil or: [oldClass theNonMetaClass name asString ~= newClassName])
and: [envt includesKey: newClassName asSymbol]) ifTrue:
["Attempting to define new class over existing one when
not looking at the original one in this browser..."
(self confirm: ((newClassName , ' is an existing class in this system.
Redefining it might cause serious problems.
Is this really what you want to do?') asText makeBoldFrom: 1 to: newClassName size))
ifFalse: [^ false]].
"ar 8/29/1999: Use oldClass superclass for defining oldClass
since oldClass superclass knows the definerClass of oldClass."
oldClass ifNotNil:[oldClass := oldClass superclass].
class := oldClass subclassDefinerClass
evaluate: defString
notifying: aController
logged: true.
(class isKindOf: Behavior)
ifTrue: [self changed: #systemCategoryList.
self changed: #classList.
self clearUserEditFlag.
self setClass: class selector: nil.
"self clearUserEditFlag; editClass."
^ true]
ifFalse: [^ false]!
----- Method: Browser>>defineMessage:notifying: (in category 'message functions') -----
defineMessage: aString notifying: aController
"Compile the expressions in aString. Notify aController if a syntax error
occurs. Install the compiled method in the selected class classified under
the currently selected message category name. Answer true if
compilation succeeds, false otherwise."
| selectedMessageName selector category oldMessageList |
selectedMessageName := self selectedMessageName.
oldMessageList := self messageList.
contents := nil.
selector := self selectedClassOrMetaClass
compile: aString
classified: (category := self selectedMessageCategoryName)
notifying: aController.
selector == nil ifTrue: [^ false].
contents := aString copy.
selector ~~ selectedMessageName
ifTrue:
[category = ClassOrganizer nullCategory
ifTrue: [self changed: #classSelectionChanged.
self changed: #classList.
self messageCategoryListIndex: 1].
self setClassOrganizer. "In case organization not cached"
(oldMessageList includes: selector)
ifFalse: [self changed: #messageList].
self messageListIndex: (self messageList indexOf: selector)].
^ true!
----- Method: Browser>>defineMessageFrom:notifying: (in category 'message functions') -----
defineMessageFrom: aString notifying: aController
"Compile the expressions in aString. Notify aController if a syntax error occurs. Install the compiled method in the selected class classified under the currently selected message category name. Answer the selector obtained if compilation succeeds, nil otherwise."
| selectedMessageName selector category oldMessageList |
selectedMessageName := self selectedMessageName.
oldMessageList := self messageList.
contents := nil.
selector := (self selectedClassOrMetaClass parserClass new parseSelector: aString).
(self metaClassIndicated
and: [(self selectedClassOrMetaClass includesSelector: selector) not
and: [Metaclass isScarySelector: selector]])
ifTrue: ["A frist-time definition overlaps the protocol of Metaclasses"
(self confirm: ((selector , ' is used in the existing class system.
Overriding it could cause serious problems.
Is this really what you want to do?') asText makeBoldFrom: 1 to: selector size))
ifFalse: [^nil]].
selector := self selectedClassOrMetaClass
compile: aString
classified: (category := self selectedMessageCategoryName)
notifying: aController.
selector == nil ifTrue: [^ nil].
contents := aString copy.
selector ~~ selectedMessageName
ifTrue:
[category = ClassOrganizer nullCategory
ifTrue: [self changed: #classSelectionChanged.
self changed: #classList.
self messageCategoryListIndex: 1].
self setClassOrganizer. "In case organization not cached"
(oldMessageList includes: selector)
ifFalse: [self changed: #messageList].
self messageListIndex: (self messageList indexOf: selector)].
^ selector!
----- Method: Browser>>defineTrait:notifying: (in category 'traits') -----
defineTrait: defString notifying: aController
| defTokens keywdIx envt oldTrait newTraitName trait |
oldTrait := self selectedClassOrMetaClass.
defTokens := defString findTokens: Character separators.
keywdIx := defTokens findFirst: [:x | x = 'category'].
envt := self selectedEnvironment.
keywdIx := defTokens findFirst: [:x | x = 'named:'].
newTraitName := (defTokens at: keywdIx+1) copyWithoutAll: '#()'.
((oldTrait isNil or: [oldTrait baseTrait name asString ~= newTraitName])
and: [envt includesKey: newTraitName asSymbol]) ifTrue:
["Attempting to define new class/trait over existing one when
not looking at the original one in this browser..."
(self confirm: ((newTraitName , ' is an existing class/trait in this system.
Redefining it might cause serious problems.
Is this really what you want to do?') asText makeBoldFrom: 1 to: newTraitName size))
ifFalse: [^ false]].
trait := Compiler evaluate: defString notifying: aController logged: true.
^(trait isKindOf: TraitBehavior)
ifTrue: [
self changed: #classList.
self classListIndex: (self classListIndexOf: trait baseTrait name).
self clearUserEditFlag; editClass.
true]
ifFalse: [ false ]
!
----- Method: Browser>>doItReceiver (in category 'accessing') -----
doItReceiver
"This class's classPool has been jimmied to be the classPool of the class
being browsed. A doIt in the code pane will let the user see the value of
the class variables."
^ self selectedClass ifNil: [FakeClassPool new]!
----- Method: Browser>>dragFromClassList: (in category 'drag and drop') -----
dragFromClassList: index
"Drag a class from the browser"
| name envt |
(name := self classList at: index) ifNil: [^ nil].
(envt := self selectedEnvironment) ifNil: [^ nil].
^ envt at: name ifAbsent:[nil]!
----- Method: Browser>>dragFromMessageList: (in category 'drag and drop') -----
dragFromMessageList: index
"Drag a method from the browser"
^self selectedClassOrMetaClass compiledMethodAt: (self messageList at: index) ifAbsent:[nil]!
----- Method: Browser>>dropOnMessageCategories:at: (in category 'drag and drop') -----
dropOnMessageCategories: method at: index
| dstClass category |
(method isKindOf: CompiledMethod)
ifFalse:[^self inform: 'Can only drop methods'].
dstClass := self selectedClassOrMetaClass.
(dstClass == method methodClass) ifTrue:[
category := self messageCategoryList at: index.
dstClass organization classify: method selector under: category.
^true].
^self inform: 'Cannot move methods between unrelated classes'
!
----- Method: Browser>>dropOnSystemCategories:at: (in category 'drag and drop') -----
dropOnSystemCategories: aClass at: index
| category |
(aClass isBehavior) ifFalse:[^self inform: 'Can only drop classes'].
category := self systemCategoryList at: index.
self selectedEnvironment organization classify: aClass instanceSide name under: category.
^true!
----- Method: Browser>>editClass (in category 'class functions') -----
editClass
"Retrieve the description of the class definition."
classListIndex = 0 ifTrue: [^ self].
self okToChange ifFalse: [^ self].
self messageCategoryListIndex: 0.
self editSelection: #editClass.
self changed: #contents.
self changed: #classCommentText.
!
----- Method: Browser>>editComment (in category 'class functions') -----
editComment
"Retrieve the description of the class comment."
classListIndex = 0 ifTrue: [^ self].
self okToChange ifFalse: [^ self].
self messageCategoryListIndex: 0.
metaClassIndicated := false.
self editSelection: #editComment.
self changed: #classSelectionChanged.
self changed: #messageCategoryList.
self changed: #messageList.
self decorateButtons.
self contentsChanged
!
----- Method: Browser>>editMessageCategories (in category 'message category functions') -----
editMessageCategories
"Indicate to the receiver and its dependents that the message categories of
the selected class have been changed."
self okToChange ifFalse: [^ self].
classListIndex ~= 0
ifTrue:
[self messageCategoryListIndex: 0.
self editSelection: #editMessageCategories.
self changed: #editMessageCategories.
self contentsChanged]!
----- Method: Browser>>editSelection (in category 'accessing') -----
editSelection
^editSelection!
----- Method: Browser>>editSelection: (in category 'accessing') -----
editSelection: aSelection
"Set the editSelection as requested."
editSelection := aSelection.
self changed: #editSelection.!
----- Method: Browser>>editSystemCategories (in category 'system category functions') -----
editSystemCategories
"Retrieve the description of the class categories of the system organizer."
self okToChange ifFalse: [^ self].
self systemCategoryListIndex: 0.
self editSelection: #editSystemCategories.
self changed: #editSystemCategories.
self contentsChanged!
----- Method: Browser>>explainSpecial: (in category 'class functions') -----
explainSpecial: string
"Answer a string explaining the code pane selection if it is displaying
one of the special edit functions."
| classes whole lits reply |
(editSelection == #editClass or: [editSelection == #newClass])
ifTrue:
["Selector parts in class definition"
string last == $: ifFalse: [^nil].
lits := Array with:
#subclass:instanceVariableNames:classVariableNames:poolDictionaries:category:.
(whole := lits detect: [:each | (each keywords
detect: [:frag | frag = string] ifNone: []) ~~ nil]
ifNone: []) ~~ nil
ifTrue: [reply := '"' , string , ' is one part of the message selector ' , whole , '.']
ifFalse: [^nil].
classes := self systemNavigation allClassesImplementing: whole.
classes := 'these classes ' , classes printString.
^reply , ' It is defined in ' , classes , '."
Smalltalk browseAllImplementorsOf: #' , whole].
editSelection == #hierarchy
ifTrue:
["Instance variables in subclasses"
classes := self selectedClassOrMetaClass allSubclasses.
classes := classes detect: [:each | (each instVarNames
detect: [:name | name = string] ifNone: []) ~~ nil]
ifNone: [^nil].
classes := classes printString.
^'"is an instance variable in class ' , classes , '."
' , classes , ' browseAllAccessesTo: ''' , string , '''.'].
editSelection == #editSystemCategories ifTrue: [^nil].
editSelection == #editMessageCategories ifTrue: [^nil].
^nil!
----- Method: Browser>>fileOutClass (in category 'class functions') -----
fileOutClass
"Print a description of the selected class onto a file whose name is the
category name followed by .st."
Cursor write showWhile:
[classListIndex ~= 0 ifTrue: [self selectedClass fileOut]]!
----- Method: Browser>>fileOutMessageCategories (in category 'message category functions') -----
fileOutMessageCategories
"Print a description of the selected message category of the selected class
onto an external file."
Cursor write showWhile:
[messageCategoryListIndex ~= 0
ifTrue:
[self selectedClassOrMetaClass fileOutCategory: self selectedMessageCategoryName]]!
----- Method: Browser>>fileOutSystemCategory (in category 'system category functions') -----
fileOutSystemCategory
"Print a description of each class in the selected category onto a file
whose name is the category name followed by .st."
systemCategoryListIndex ~= 0
ifTrue: [systemOrganizer fileOutCategory: self selectedSystemCategoryName]!
----- Method: Browser>>findClass (in category 'system category functions') -----
findClass
"Search for a class by name."
| pattern foundClassOrTrait |
self okToChange ifFalse: [^ self classNotFound].
pattern := UIManager default request: 'Class name or fragment?'.
pattern isEmpty ifTrue: [^ self classNotFound].
foundClassOrTrait := Utilities classFromPattern: pattern withCaption: ''.
foundClassOrTrait ifNil: [^ self classNotFound].
self selectCategoryForClass: foundClassOrTrait.
self selectClass: foundClassOrTrait.
!
----- Method: Browser>>findMethod (in category 'class functions') -----
findMethod
"Pop up a list of the current class's methods, and select the one chosen by the user"
| aClass selectors reply cat messageCatIndex messageIndex |
self classListIndex = 0 ifTrue: [^ self].
self okToChange ifFalse: [^ self].
aClass := self selectedClassOrMetaClass.
selectors := aClass selectors asSortedArray.
selectors isEmpty ifTrue: [self inform: aClass name, ' has no methods.'. ^ self].
reply := UIManager default
chooseFrom: (Array with: 'Enter Wildcard'), selectors
values: (Array with: 'Enter Wildcard'), selectors
lines: #(1).
reply == nil ifTrue: [^ self].
reply = 'EnterWildcard'
ifTrue: [
reply := UIManager default request: 'Enter partial method name:'.
(reply isNil or: [reply isEmpty])
ifTrue: [^self].
(reply includes: $*)
ifFalse: [reply := '*', reply, '*'].
selectors := selectors select: [:each | reply match: each].
selectors isEmpty ifTrue: [self inform: aClass name, ' has no matching methods.'. ^ self].
reply := selectors size = 1
ifTrue: [selectors first]
ifFalse: [
UIManager default
chooseFrom: selectors
values selectors].
reply == nil ifTrue: [^ self]].
cat := aClass whichCategoryIncludesSelector: reply.
messageCatIndex := self messageCategoryList indexOf: cat.
self messageCategoryListIndex: messageCatIndex.
messageIndex := (self messageList indexOf: reply).
self messageListIndex: messageIndex!
----- Method: Browser>>findMethodWithWildcard (in category 'class functions') -----
findMethodWithWildcard
"Pop up a list of the current class's methods, and select the one chosen by the user"
| aClass selectors reply cat messageCatIndex messageIndex |
self classListIndex = 0 ifTrue: [^ self].
self okToChange ifFalse: [^ self].
aClass := self selectedClassOrMetaClass.
selectors := aClass selectors asSortedArray.
selectors isEmpty ifTrue: [self inform: aClass name, ' has no methods.'. ^ self].
reply := UIManager default request: 'Enter partial method name:'.
(reply isNil or: [reply isEmpty])
ifTrue: [^self].
(reply includes: $*)
ifFalse: [reply := '*', reply, '*'].
selectors := selectors select: [:each | reply match: each].
selectors isEmpty ifTrue: [self inform: aClass name, ' has no matching methods.'. ^ self].
reply := selectors size = 1
ifTrue: [selectors first]
ifFalse: [
UIManager default
chooseFrom: selectors
values: selectors].
reply == nil ifTrue: [^ self].
cat := aClass whichCategoryIncludesSelector: reply.
messageCatIndex := self messageCategoryList indexOf: cat.
self messageCategoryListIndex: messageCatIndex.
messageIndex := (self messageList indexOf: reply).
self messageListIndex: messageIndex!
----- Method: Browser>>flattenHierarchyTree:on:indent: (in category 'class list') -----
flattenHierarchyTree: classHierarchy on: col indent: indent
| class childs plusIndent |
plusIndent := String space.
classHierarchy do: [:assoc |
class := assoc key.
col add: indent , class name.
childs := assoc value.
self
flattenHierarchyTree: childs
on: col
indent: indent , plusIndent].
^ col!
----- Method: Browser>>hierarchicalClassList (in category 'class list') -----
hierarchicalClassList
"classNames are an arbitrary collection of classNames of the system.
Reorder those class names so that they are sorted and indended by inheritance"
| classes |
classes := self defaultClassList collect: [:sym | Smalltalk classNamed: sym].
^ self
flattenHierarchyTree: (self createHierarchyTreeOf: classes)
on: OrderedCollection new
indent: ''.!
----- Method: Browser>>hierarchy (in category 'class functions') -----
hierarchy
"Display the inheritance hierarchy of the receiver's selected class."
classListIndex = 0 ifTrue: [^ self].
self okToChange ifFalse: [^ self].
self messageCategoryListIndex: 0.
self editSelection: #hierarchy.
self changed: #editComment.
self contentsChanged.
^ self!
----- Method: Browser>>highlightMessageList:with: (in category 'message category functions') -----
highlightMessageList: list with: morphList
"Changed by emm to add emphasis in case of breakpoint"
morphList do:[:each |
| classOrNil methodOrNil |
classOrNil := self selectedClassOrMetaClass.
methodOrNil := classOrNil isNil
ifTrue:[nil]
ifFalse:[classOrNil methodDictionary at: each contents ifAbsent:[]].
(methodOrNil notNil and:[methodOrNil hasBreakpoint])
ifTrue:[each contents: ((each contents ,' [break]') asText allBold)]]!
----- Method: Browser>>indexIsOne (in category 'system category list') -----
indexIsOne
"When used as a singleton list, index is always one"
^ 1!
----- Method: Browser>>indexIsOne: (in category 'system category list') -----
indexIsOne: value
"When used as a singleton list, can't change it"
^ self!
----- Method: Browser>>indicateClassMessages (in category 'metaclass') -----
indicateClassMessages
"Indicate that the message selection should come from the metaclass
messages."
self metaClassIndicated: true!
----- Method: Browser>>indicateInstanceMessages (in category 'metaclass') -----
indicateInstanceMessages
"Indicate that the message selection should come from the class (instance)
messages."
self metaClassIndicated: false!
----- Method: Browser>>inspectInstances (in category 'message functions') -----
inspectInstances
"Inspect all instances of the selected class. 1/26/96 sw"
| myClass |
((myClass := self selectedClassOrMetaClass) isNil or: [myClass isTrait])
ifFalse: [myClass theNonMetaClass inspectAllInstances]
!
----- Method: Browser>>inspectSubInstances (in category 'message functions') -----
inspectSubInstances
"Inspect all instances of the selected class and all its subclasses 1/26/96 sw"
| aClass |
((aClass := self selectedClassOrMetaClass) isNil or: [aClass isTrait])
ifFalse: [
aClass := aClass theNonMetaClass.
aClass inspectSubInstances].
!
----- Method: Browser>>instanceMessagesIndicated (in category 'metaclass') -----
instanceMessagesIndicated
"Answer whether the messages to be presented should come from the
class."
^metaClassIndicated not and: [self classCommentIndicated not]!
----- Method: Browser>>labelString (in category 'initialize-release') -----
labelString
^self selectedClass ifNil: [ self defaultBrowserTitle ]
ifNotNil: [ self defaultBrowserTitle, ': ', self selectedClass printString ].
!
----- Method: Browser>>makeNewSubclass (in category 'class functions') -----
makeNewSubclass
self selectedClassOrMetaClass ifNil: [^ self].
self okToChange ifFalse: [^ self].
self editSelection: #newClass.
self contentsChanged!
----- Method: Browser>>messageCatListSingleton (in category 'message category list') -----
messageCatListSingleton
| name |
name := self selectedMessageCategoryName.
^ name ifNil: [Array new]
ifNotNil: [Array with: name]!
----- Method: Browser>>messageCategoryList (in category 'message category list') -----
messageCategoryList
"Answer the selected category of messages."
classListIndex = 0
ifTrue: [^ Array new]
ifFalse: [^ (Array with: ClassOrganizer allCategory), self classOrMetaClassOrganizer categories]!
----- Method: Browser>>messageCategoryListIndex (in category 'message category list') -----
messageCategoryListIndex
"Answer the index of the selected message category."
^messageCategoryListIndex!
----- Method: Browser>>messageCategoryListIndex: (in category 'message category list') -----
messageCategoryListIndex: anInteger
"Set the selected message category to be the one indexed by anInteger."
messageCategoryListIndex := anInteger.
messageListIndex := 0.
self changed: #messageCategorySelectionChanged.
self changed: #messageCategoryListIndex. "update my selection"
self changed: #messageList.
self editSelection: (anInteger > 0
ifTrue: [#newMessage]
ifFalse: [self classListIndex > 0
ifTrue: [#editClass]
ifFalse: [#newClass]]).
contents := nil.
self contentsChanged.!
----- Method: Browser>>messageCategoryListSelection (in category 'message category list') -----
messageCategoryListSelection
"Return the selected category name or nil."
^ ((self messageCategoryList size = 0
or: [self messageCategoryListIndex = 0])
or: [self messageCategoryList size < self messageCategoryListIndex])
ifTrue: [nil]
ifFalse: [self messageCategoryList at: (self messageCategoryListIndex max: 1)]!
----- Method: Browser>>messageCategoryMenu: (in category 'message category functions') -----
messageCategoryMenu: aMenu
ServiceGui browser: self messageCategoryMenu: aMenu.
ServiceGui onlyServices ifTrue: [^aMenu].
^ aMenu labels:
'browse
printOut
fileOut
reorganize
alphabetize
remove empty categories
categorize all uncategorized
new category...
rename...
remove'
lines: #(3 8)
selections:
#(buildMessageCategoryBrowser printOutMessageCategories fileOutMessageCategories
editMessageCategories alphabetizeMessageCategories removeEmptyCategories
categorizeAllUncategorizedMethods addCategory renameCategory removeMessageCategory)
!
----- Method: Browser>>messageList (in category 'message list') -----
messageList
"Answer an Array of the message selectors of the currently selected message category, provided that the messageCategoryListIndex is in proper range. Otherwise, answer an empty Array If messageCategoryListIndex is found to be larger than the number of categories (it happens!!), it is reset to zero."
| sel |
(sel := self messageCategoryListSelection) ifNil:
[
^ self classOrMetaClassOrganizer
ifNil: [Array new]
ifNotNil: [self classOrMetaClassOrganizer allMethodSelectors]
"^ Array new"
].
^ sel = ClassOrganizer allCategory
ifTrue:
[self classOrMetaClassOrganizer
ifNil: [Array new]
ifNotNil: [self classOrMetaClassOrganizer allMethodSelectors]]
ifFalse:
[(self classOrMetaClassOrganizer listAtCategoryNumber: messageCategoryListIndex - 1)
ifNil: [messageCategoryListIndex := 0. Array new]]!
----- Method: Browser>>messageListIndex (in category 'message list') -----
messageListIndex
"Answer the index of the selected message selector into the currently
selected message category."
^messageListIndex!
----- Method: Browser>>messageListIndex: (in category 'message list') -----
messageListIndex: anInteger
"Set the selected message selector to be the one indexed by anInteger."
messageListIndex := anInteger.
self editSelection: (anInteger > 0
ifTrue: [#editMessage]
ifFalse: [self messageCategoryListIndex > 0
ifTrue: [#newMessage]
ifFalse: [self classListIndex > 0
ifTrue: [#editClass]
ifFalse: [#newClass]]]).
contents := nil.
self changed: #messageListIndex. "update my selection"
self contentsChanged.
self decorateButtons.!
----- Method: Browser>>messageListMenu:shifted: (in category 'message functions') -----
messageListMenu: aMenu shifted: shifted
"Answer the message-list menu"
ServiceGui browser: self messageListMenu: aMenu.
ServiceGui onlyServices ifTrue: [^ aMenu].
shifted
ifTrue: [^ self shiftedMessageListMenu: aMenu].
aMenu addList: #(
('what to show...' offerWhatToShowMenu)
('toggle break on entry' toggleBreakOnEntry)
-
('browse full (b)' browseMethodFull)
('browse hierarchy (h)' classHierarchy)
('browse method (O)' openSingleMessageBrowser)
('browse protocol (p)' browseFullProtocol)
-
('fileOut' fileOutMessage)
('printOut' printOutMessage)
-
('senders of... (n)' browseSendersOfMessages)
('implementors of... (m)' browseMessages)
('inheritance (i)' methodHierarchy)
('tile scriptor' openSyntaxView)
('versions (v)' browseVersions)
-
('inst var refs...' browseInstVarRefs)
('inst var defs...' browseInstVarDefs)
('class var refs...' browseClassVarRefs)
('class variables' browseClassVariables)
('class refs (N)' browseClassRefs)
-
('remove method (x)' removeMessage)
-
('more...' shiftedYellowButtonActivity)).
^ aMenu!
----- Method: Browser>>messageListSingleton (in category 'message list') -----
messageListSingleton
| name |
name := self selectedMessageName.
^ name ifNil: [Array new]
ifNotNil: [Array with: name]!
----- Method: Browser>>metaClassIndicated (in category 'metaclass') -----
metaClassIndicated
"Answer the boolean flag that indicates which of the method dictionaries,
class or metaclass."
^ metaClassIndicated!
----- Method: Browser>>metaClassIndicated: (in category 'metaclass') -----
metaClassIndicated: trueOrFalse
"Indicate whether browsing instance or class messages."
metaClassIndicated := trueOrFalse.
self setClassOrganizer.
systemCategoryListIndex > 0 ifTrue:
[self editSelection: (classListIndex = 0
ifTrue: [metaClassIndicated
ifTrue: [#none]
ifFalse: [#newClass]]
ifFalse: [#editClass])].
messageCategoryListIndex := 0.
messageListIndex := 0.
contents := nil.
self changed: #classSelectionChanged.
self changed: #messageCategoryList.
self changed: #messageList.
self changed: #contents.
self changed: #annotation.
self decorateButtons
!
----- Method: Browser>>methodCategoryChanged (in category 'initialize-release') -----
methodCategoryChanged
self changed: #messageCategoryList.
self changed: #messageList.
self changed: #annotation.
self messageListIndex: 0!
----- Method: Browser>>newClass (in category 'traits') -----
newClass
(self selectedClassOrMetaClass notNil and:
[self selectedClassOrMetaClass isTrait]) ifTrue: [self classListIndex: 0].
self editClass.
editSelection := #newClass.
self contentsChanged!
----- Method: Browser>>newTrait (in category 'traits') -----
newTrait
self classListIndex: 0.
self editClass.
editSelection := #newTrait.
self contentsChanged!
----- Method: Browser>>noCommentNagString (in category 'class comment pane') -----
noCommentNagString
^ Text string: 'THIS CLASS HAS NO COMMENT!!' translated attribute: TextColor red.
!
----- Method: Browser>>noteSelectionIndex:for: (in category 'accessing') -----
noteSelectionIndex: anInteger for: aSymbol
aSymbol == #systemCategoryList
ifTrue:
[systemCategoryListIndex := anInteger].
aSymbol == #classList
ifTrue:
[classListIndex := anInteger].
aSymbol == #messageCategoryList
ifTrue:
[messageCategoryListIndex := anInteger].
aSymbol == #messageList
ifTrue:
[messageListIndex := anInteger].!
----- Method: Browser>>openEditString: (in category 'initialize-release') -----
openEditString: aString
"Create a pluggable version of all the views for a Browser, including views and controllers."
"Example:
Browser fullOnClass: Browser.
"
| builder max |
builder := ToolBuilder default.
max := self wantsOptionalButtons ifTrue:[0.42] ifFalse:[0.5].
^self buildWindowWith: builder specs: {
(0 at 0 corner: 0.25 at max) -> [self buildSystemCategoryListWith: builder].
(0.25 at 0 corner: 0.5@(max-0.08)) -> [self buildClassListWith: builder].
(0.25@(max-0.08) corner: 0.5 at max) -> [self buildSwitchesWith: builder].
(0.5 at 0 corner: 0.75 at max) -> [self buildMessageCategoryListWith: builder].
(0.75 at 0 corner: 1 at max) -> [self buildMessageListWith: builder].
"(0 at max corner: 1 at 0.5) -> [self buildOptionalButtonsWith: builder]."
(0 at max corner: 1 at 1) -> [self buildCodePaneWith: builder].
}!
----- Method: Browser>>openMessageCatEditString: (in category 'initialize-release') -----
openMessageCatEditString: aString
"Create a pluggable version of the views for a Browser that just shows one message category."
"Example:
Preferences browseThemes.
"
| builder max |
builder := ToolBuilder default.
max := self wantsOptionalButtons ifTrue:[0.32] ifFalse:[0.4].
^self buildWindowWith: builder specs: {
(0 at 0 corner: 1.0 at 0.08) -> [self buildMessageListCatSingletonWith: builder].
(0.0 at 0.08 corner: 1.0 at max) -> [self buildMessageListWith: builder].
(0 at max corner: 1 at 1) -> [self buildCodePaneWith: builder].
}.!
----- Method: Browser>>openOnClassWithEditString: (in category 'initialize-release') -----
openOnClassWithEditString: aString
"Create a pluggable version of all the views for a Browser, including views and controllers."
"Example:
Browser newOnClass: Browser.
"
| builder max |
builder := ToolBuilder default.
max := self wantsOptionalButtons ifTrue:[0.32] ifFalse:[0.4].
^self buildWindowWith: builder specs: {
(0.0 at 0.0 corner: 0.5 at 0.08) -> [self buildClassListSingletonWith: builder].
(0.5 at 0.0 corner: 1.0 at 0.08) -> [self buildSwitchesWith: builder].
(0.0 at 0.08 corner: 0.5 at max) -> [self buildMessageCategoryListWith: builder].
(0.5 at 0.08 corner: 1 at max) -> [self buildMessageListWith: builder].
(0 at max corner: 1 at 1) -> [self buildCodePaneWith: builder].
}
!
----- Method: Browser>>openSystemCatEditString: (in category 'initialize-release') -----
openSystemCatEditString: aString
"Create a pluggable version of all the views for a Browser, including views and controllers. The top list view is of the currently selected system class category--a single item list."
"Example:
Browser new browseAllClasses.
"
| builder max |
builder := ToolBuilder default.
max := self wantsOptionalButtons ifTrue:[0.32] ifFalse:[0.4].
^self buildWindowWith: builder specs: {
(0 at 0 corner: 1.0 at 0.08) -> [self buildSystemCatListSingletonWith: builder].
(0.0 at 0.08 corner: 0.333@(max-0.1)) -> [self buildClassListWith: builder].
(0.0@(max-0.1) corner: 0.333 at max) -> [self buildSwitchesWith: builder].
(0.333 at 0.08 corner: 0.666 at max) -> [self buildMessageCategoryListWith: builder].
(0.666 at 0.08 corner: 1 at max) -> [self buildMessageListWith: builder].
(0 at max corner: 1 at 1) -> [self buildCodePaneWith: builder].
}!
----- Method: Browser>>optionalAnnotationHeight (in category 'initialize-release') -----
optionalAnnotationHeight
^ 10!
----- Method: Browser>>optionalButtonHeight (in category 'initialize-release') -----
optionalButtonHeight
^ 10!
----- Method: Browser>>plusButtonHit (in category 'class functions') -----
plusButtonHit
"Cycle among definition, comment, and hierachy"
editSelection == #editComment
ifTrue: [self hierarchy. ^ self].
editSelection == #hierarchy
ifTrue: [self editSelection: #editClass.
classListIndex = 0 ifTrue: [^ self].
self okToChange ifFalse: [^ self].
self changed: #editComment.
self contentsChanged.
^ self].
self editComment!
----- Method: Browser>>potentialClassNames (in category 'system category functions') -----
potentialClassNames
"Answer the names of all the classes that could be viewed in this browser. This hook is provided so that HierarchyBrowsers can indicate their restricted subset. For generic Browsers, the entire list of classes known to Smalltalk is provided, though of course that really only is accurate in the case of full system browsers."
^ Smalltalk classNames!
----- Method: Browser>>printOutClass (in category 'class functions') -----
printOutClass
"Print a description of the selected class onto a file whose name is the
category name followed by .html."
Cursor write showWhile:
[classListIndex ~= 0 ifTrue: [self selectedClass fileOutAsHtml: true]]!
----- Method: Browser>>printOutMessageCategories (in category 'message category functions') -----
printOutMessageCategories
"Print a description of the selected message category of the selected class
onto an external file in Html format."
Cursor write showWhile:
[messageCategoryListIndex ~= 0
ifTrue:
[self selectedClassOrMetaClass fileOutCategory: self selectedMessageCategoryName
asHtml: true]]!
----- Method: Browser>>printOutSystemCategory (in category 'system category functions') -----
printOutSystemCategory
"Print a description of each class in the selected category as Html."
Cursor write showWhile:
[systemCategoryListIndex ~= 0
ifTrue: [systemOrganizer fileOutCategory: self selectedSystemCategoryName
asHtml: true ]]
!
----- Method: Browser>>rawMessageCategoryList (in category 'message category list') -----
rawMessageCategoryList
^ classListIndex = 0
ifTrue: [Array new]
ifFalse: [self classOrMetaClassOrganizer categories]!
----- Method: Browser>>recategorizeMethodSelector: (in category 'message category list') -----
recategorizeMethodSelector: sel
"Categorize method named sel by looking in parent classes for a
method category.
Answer true if recategorized."
| thisCat |
self selectedClassOrMetaClass allSuperclasses
do: [:ea |
thisCat := ea organization categoryOfElement: sel.
(thisCat ~= ClassOrganizer default
and: [thisCat notNil])
ifTrue: [self classOrMetaClassOrganizer classify: sel under: thisCat.
self changed: #messageCategoryList.
^ true]].
^ false!
----- Method: Browser>>recent (in category 'class list') -----
recent
"Let the user select from a list of recently visited classes. 11/96 stp.
12/96 di: use class name, not classes themselves.
: dont fall into debugger in empty case"
| className class recentList |
recentList := RecentClasses select: [:n | Smalltalk includesKey: n].
recentList size == 0 ifTrue: [^ Beeper beep].
className := UIManager default chooseFrom: recentList values: recentList.
className == nil ifTrue: [^ self].
class := Smalltalk at: className.
self selectCategoryForClass: class.
self classListIndex: (self classListIndexOf: class name)!
----- Method: Browser>>reformulateList (in category 'message list') -----
reformulateList
"If the receiver has a way of reformulating its message list, here is a chance for it to do so"
super reformulateList.
self messageListIndex: 0!
----- Method: Browser>>removeClass (in category 'class functions') -----
removeClass
"If the user confirms the wish to delete the class, do so"
super removeClass ifTrue:
[self classListIndex: 0]!
----- Method: Browser>>removeEmptyCategories (in category 'message category functions') -----
removeEmptyCategories
self okToChange ifFalse: [^ self].
self selectedClassOrMetaClass organization removeEmptyCategories.
self changed: #messageCategoryList
!
----- Method: Browser>>removeMessage (in category 'message functions') -----
removeMessage
"If a message is selected, create a Confirmer so the user can verify that
the currently selected message should be removed from the system. If
so,
remove it. If the Preference 'confirmMethodRemoves' is set to false, the
confirmer is bypassed."
| messageName confirmation |
messageListIndex = 0
ifTrue: [^ self].
self okToChange
ifFalse: [^ self].
messageName := self selectedMessageName.
confirmation := self systemNavigation confirmRemovalOf: messageName on: self selectedClassOrMetaClass.
confirmation == 3
ifTrue: [^ self].
(self selectedClassOrMetaClass includesLocalSelector: messageName)
ifTrue: [self selectedClassOrMetaClass removeSelector: messageName]
ifFalse: [self removeNonLocalSelector: messageName].
self messageListIndex: 0.
self changed: #messageList.
self setClassOrganizer.
"In case organization not cached"
confirmation == 2
ifTrue: [self systemNavigation browseAllCallsOn: messageName]!
----- Method: Browser>>removeMessageCategory (in category 'message category functions') -----
removeMessageCategory
"If a message category is selected, create a Confirmer so the user can
verify that the currently selected message category should be removed
from the system. If so, remove it."
| messageCategoryName |
messageCategoryListIndex = 0 ifTrue: [^ self].
self okToChange ifFalse: [^ self].
messageCategoryName := self selectedMessageCategoryName.
(self messageList size = 0
or: [self confirm: 'Are you sure you want to
remove this method category
and all its methods?'])
ifTrue:
[self selectedClassOrMetaClass removeCategory: messageCategoryName.
self messageCategoryListIndex: 0.
self changed: #classSelectionChanged].
self changed: #messageCategoryList.
!
----- Method: Browser>>removeMessageFromBrowser (in category 'message functions') -----
removeMessageFromBrowser
"Our list speaks the truth and can't have arbitrary things removed"
^ self changed: #flash!
----- Method: Browser>>removeNonLocalSelector: (in category 'traits') -----
removeNonLocalSelector: aSymbol
| traits isAlias |
traits := self selectedClassOrMetaClass traitsProvidingSelector: aSymbol.
isAlias := self selectedClassOrMetaClass isLocalAliasSelector: aSymbol.
isAlias
ifTrue: [
self assert: traits size = 1.
self selectedClassOrMetaClass removeAlias: aSymbol of: traits first]
ifFalse: [
traits do: [:each |
self selectedClassOrMetaClass addExclusionOf: aSymbol to: each ]]
!
----- Method: Browser>>removeSystemCategory (in category 'system category functions') -----
removeSystemCategory
"If a class category is selected, create a Confirmer so the user can
verify that the currently selected class category and all of its classes
should be removed from the system. If so, remove it."
systemCategoryListIndex = 0 ifTrue: [^ self].
self okToChange ifFalse: [^ self].
(self classList size = 0
or: [self confirm: 'Are you sure you want to
remove this system category
and all its classes?'])
ifTrue:
[systemOrganizer removeSystemCategory: self selectedSystemCategoryName.
self systemCategoryListIndex: 0.
self changed: #systemCategoryList]!
----- Method: Browser>>renameCategory (in category 'message category functions') -----
renameCategory
"Prompt for a new category name and add it before the
current selection, or at the end if no current selection"
| oldIndex oldName newName |
classListIndex = 0 ifTrue: [^ self].
self okToChange ifFalse: [^ self].
(oldIndex := messageCategoryListIndex) = 0 ifTrue: [^ self].
oldName := self selectedMessageCategoryName.
newName := self
request: 'Please type new category name'
initialAnswer: oldName.
newName isEmpty
ifTrue: [^ self]
ifFalse: [newName := newName asSymbol].
newName = oldName ifTrue: [^ self].
self classOrMetaClassOrganizer
renameCategory: oldName
toBe: newName.
self classListIndex: classListIndex.
self messageCategoryListIndex: oldIndex.
self changed: #messageCategoryList.
!
----- Method: Browser>>renameClass (in category 'class functions') -----
renameClass
| oldName newName obs |
classListIndex = 0
ifTrue: [^ self].
self okToChange
ifFalse: [^ self].
oldName := self selectedClass name.
newName := self request: 'Please type new class name' initialAnswer: oldName.
newName = ''
ifTrue: [^ self].
"Cancel returns ''"
newName := newName asSymbol.
newName = oldName
ifTrue: [^ self].
(Smalltalk includesKey: newName)
ifTrue: [^ self error: newName , ' already exists'].
self selectedClass rename: newName.
self changed: #classList.
self classListIndex: (self classListIndexOf: newName).
obs := self systemNavigation
allCallsOn: (Smalltalk associationAt: newName).
obs isEmpty
ifFalse: [self systemNavigation
browseMessageList: obs
name: 'Obsolete References to ' , oldName
autoSelect: oldName]!
----- Method: Browser>>renameSystemCategory (in category 'system category functions') -----
renameSystemCategory
"Prompt for a new category name and add it before the
current selection, or at the end if no current selection"
| oldIndex oldName newName |
(oldIndex := systemCategoryListIndex) = 0
ifTrue: [^ self]. "no selection"
self okToChange ifFalse: [^ self].
oldName := self selectedSystemCategoryName.
newName := self
request: 'Please type new category name'
initialAnswer: oldName.
newName isEmpty
ifTrue: [^ self]
ifFalse: [newName := newName asSymbol].
oldName = newName ifTrue: [^ self].
systemOrganizer
renameCategory: oldName
toBe: newName.
self systemCategoryListIndex: oldIndex.
self changed: #systemCategoryList.!
----- Method: Browser>>request:initialAnswer: (in category 'accessing') -----
request: prompt initialAnswer: initialAnswer
^ UIManager default
request: prompt
initialAnswer: initialAnswer
!
----- Method: Browser>>selectCategoryForClass: (in category 'system category list') -----
selectCategoryForClass: theClass
self systemCategoryListIndex: (self systemCategoryList indexOf: theClass category)
!
----- Method: Browser>>selectClass: (in category 'class list') -----
selectClass: classNotMeta
self classListIndex: (self classListIndexOf: classNotMeta name)!
----- Method: Browser>>selectMessageCategoryNamed: (in category 'message category list') -----
selectMessageCategoryNamed: aSymbol
"Given aSymbol, select the category with that name. Do nothing if
aSymbol doesn't exist."
self messageCategoryListIndex: (self messageCategoryList indexOf: aSymbol ifAbsent: [ 1])!
----- Method: Browser>>selectOriginalCategoryForCurrentMethod (in category 'message category list') -----
selectOriginalCategoryForCurrentMethod
"private - Select the message category for the current method.
Note: This should only be called when somebody tries to save
a method that they are modifying while ALL is selected.
Returns: true on success, false on failure."
| aSymbol selectorName |
aSymbol := self categoryOfCurrentMethod.
selectorName := self selectedMessageName.
(aSymbol notNil and: [aSymbol ~= ClassOrganizer allCategory])
ifTrue:
[messageCategoryListIndex := (self messageCategoryList indexOf: aSymbol).
messageListIndex := (self messageList indexOf: selectorName).
self changed: #messageCategorySelectionChanged.
self changed: #messageCategoryListIndex. "update my selection"
self changed: #messageList.
self changed: #messageListIndex.
^ true].
^ false!
----- Method: Browser>>selectedClass (in category 'class list') -----
selectedClass
"Answer the class that is currently selected. Answer nil if no selection
exists."
| name envt |
(name := self selectedClassName) ifNil: [^ nil].
(envt := self selectedEnvironment) ifNil: [^ nil].
^ envt at: name!
----- Method: Browser>>selectedClassName (in category 'class list') -----
selectedClassName
| className |
className := self classList
at: classListIndex
ifAbsent: [^ nil].
self class listClassesHierarchically ifTrue: [
className := className withoutLeadingBlanks asSymbol].
^ className.!
----- Method: Browser>>selectedClassOrMetaClass (in category 'metaclass') -----
selectedClassOrMetaClass
"Answer the selected class/trait or metaclass/classTrait."
| cls |
^self metaClassIndicated
ifTrue: [(cls := self selectedClass) ifNil: [nil] ifNotNil: [cls classSide]]
ifFalse: [self selectedClass]!
----- Method: Browser>>selectedClassOrMetaClassName (in category 'metaclass') -----
selectedClassOrMetaClassName
"Answer the selected class name or metaclass name."
^self selectedClassOrMetaClass name!
----- Method: Browser>>selectedEnvironment (in category 'system category list') -----
selectedEnvironment
"Answer the name of the selected system category or nil."
systemCategoryListIndex = 0 ifTrue: [^nil].
^ Smalltalk!
----- Method: Browser>>selectedMessage (in category 'message list') -----
selectedMessage
"Answer a copy of the source code for the selected message."
| class selector method |
contents == nil ifFalse: [^ contents copy].
self showingDecompile ifTrue:
[^ self decompiledSourceIntoContents].
class := self selectedClassOrMetaClass.
selector := self selectedMessageName.
method := class compiledMethodAt: selector ifAbsent: [^ '']. "method deleted while in another project"
currentCompiledMethod := method.
^ contents := (self showingDocumentation
ifFalse: [ self sourceStringPrettifiedAndDiffed ]
ifTrue: [ self commentContents ])
copy asText makeSelectorBoldIn: class!
----- Method: Browser>>selectedMessageCategoryName (in category 'message category list') -----
selectedMessageCategoryName
"Answer the name of the selected message category, if any. Answer nil
otherwise."
messageCategoryListIndex = 0 ifTrue: [^nil].
^self messageCategoryList at: messageCategoryListIndex!
----- Method: Browser>>selectedMessageName (in category 'message list') -----
selectedMessageName
"Answer the message selector of the currently selected message, if any.
Answer nil otherwise."
| aList |
messageListIndex = 0 ifTrue: [^ nil].
^ (aList := self messageList) size >= messageListIndex
ifTrue:
[aList at: messageListIndex]
ifFalse:
[nil]!
----- Method: Browser>>selectedMessageName: (in category 'message list') -----
selectedMessageName: aSelector
"Make the given selector be the selected message name"
| anIndex |
anIndex := self messageList indexOf: aSelector.
anIndex > 0 ifTrue:
[self messageListIndex: anIndex]!
----- Method: Browser>>selectedSystemCategoryName (in category 'system category list') -----
selectedSystemCategoryName
"Answer the name of the selected system category or nil."
systemCategoryListIndex = 0 ifTrue: [^nil].
^self systemCategoryList at: systemCategoryListIndex!
----- Method: Browser>>setClass:selector: (in category 'initialize-release') -----
setClass: aBehavior selector: aSymbol
"Set the state of a new, uninitialized Browser."
| isMeta aClass messageCatIndex |
aBehavior ifNil: [^ self].
(aBehavior isKindOf: Metaclass)
ifTrue: [
isMeta := true.
aClass := aBehavior soleInstance]
ifFalse: [
isMeta := false.
aClass := aBehavior].
self selectCategoryForClass: aClass.
self classListIndex: (self classListIndexOf: aClass name).
self metaClassIndicated: isMeta.
aSymbol ifNil: [^ self].
messageCatIndex := aBehavior organization numberOfCategoryOfElement: aSymbol.
self messageCategoryListIndex: (messageCatIndex > 0
ifTrue: [messageCatIndex + 1]
ifFalse: [0]).
messageCatIndex = 0 ifTrue: [^ self].
self messageListIndex: (
(aBehavior organization listAtCategoryNumber: messageCatIndex)
indexOf: aSymbol).!
----- Method: Browser>>setClassOrganizer (in category 'metaclass') -----
setClassOrganizer
"Install whatever organization is appropriate"
| theClass |
classOrganizer := nil.
metaClassOrganizer := nil.
classListIndex = 0 ifTrue: [^ self].
theClass := self selectedClass ifNil: [ ^self ].
classOrganizer := theClass organization.
metaClassOrganizer := theClass classSide organization.!
----- Method: Browser>>setOriginalCategoryIndexForCurrentMethod (in category 'message category list') -----
setOriginalCategoryIndexForCurrentMethod
"private - Set the message category index for the currently selected method.
Note: This should only be called when somebody tries to save
a method that they are modifying while ALL is selected."
messageCategoryListIndex := self messageCategoryList indexOf: self categoryOfCurrentMethod
!
----- Method: Browser>>setSelector: (in category 'initialize-release') -----
setSelector: aSymbol
"Make the receiver point at the given selector, in the currently chosen class"
| aClass messageCatIndex |
aSymbol ifNil: [^ self].
(aClass := self selectedClassOrMetaClass) ifNil: [^ self].
messageCatIndex := aClass organization numberOfCategoryOfElement: aSymbol.
self messageCategoryListIndex: messageCatIndex + 1.
messageCatIndex = 0 ifTrue: [^ self].
self messageListIndex:
((aClass organization listAtCategoryNumber: messageCatIndex)
indexOf: aSymbol)!
----- Method: Browser>>shiftedClassListMenu: (in category 'class functions') -----
shiftedClassListMenu: aMenu
"Set up the menu to apply to the receiver's class list when the shift key is down"
^ aMenu addList: #(
-
('unsent methods' browseUnusedMethods 'browse all methods defined by this class that have no senders')
('unreferenced inst vars' showUnreferencedInstVars 'show a list of all instance variables that are not referenced in methods')
('unreferenced class vars' showUnreferencedClassVars 'show a list of all class variables that are not referenced in methods')
('subclass template' makeNewSubclass 'put a template into the code pane for defining of a subclass of this class')
-
('sample instance' makeSampleInstance 'give me a sample instance of this class, if possible')
('inspect instances' inspectInstances 'open an inspector on all the extant instances of this class')
('inspect subinstances' inspectSubInstances 'open an inspector on all the extant instances of this class and of all of its subclasses')
-
('add all meths to current chgs' addAllMethodsToCurrentChangeSet
'place all the methods defined by this class into the current change set')
('create inst var accessors' createInstVarAccessors 'compile instance-variable access methods for any instance variables that do not yet have them')
-
('more...' offerUnshiftedClassListMenu 'return to the standard class-list menu'))!
----- Method: Browser>>shiftedMessageListMenu: (in category 'message functions') -----
shiftedMessageListMenu: aMenu
"Fill aMenu with the items appropriate when the shift key is held down"
Smalltalk isMorphic ifTrue: [aMenu addStayUpItem].
aMenu addList: #(
('method pane' makeIsolatedCodePane)
('tile scriptor' openSyntaxView)
('toggle diffing (D)' toggleDiffing)
('implementors of sent messages' browseAllMessages)
-
('local senders of...' browseLocalSendersOfMessages)
('local implementors of...' browseLocalImplementors)
-
('spawn sub-protocol' spawnProtocol)
('spawn full protocol' spawnFullProtocol)
-
('sample instance' makeSampleInstance)
('inspect instances' inspectInstances)
('inspect subinstances' inspectSubInstances)).
self addExtraShiftedItemsTo: aMenu.
aMenu addList: #(
-
('change category...' changeCategory)).
self canShowMultipleMessageCategories ifTrue: [aMenu addList:
#(('show category (C)' showHomeCategory))].
aMenu addList: #(
-
('change sets with this method' findMethodInChangeSets)
('revert to previous version' revertToPreviousVersion)
('remove from current change set' removeFromCurrentChanges)
('revert & remove from changes' revertAndForget)
('add to current change set' adoptMessageInCurrentChangeset)
('copy up or copy down...' copyUpOrCopyDown)
-
('more...' unshiftedYellowButtonActivity)).
^ aMenu
!
----- Method: Browser>>showBytecodes (in category 'code pane') -----
showBytecodes
"Show or hide the bytecodes of the selected method -- an older protocol now mostly not relevant."
self toggleShowingByteCodes!
----- Method: Browser>>showHomeCategory (in category 'message category functions') -----
showHomeCategory
"Show the home category of the selected method. This is only really useful if one is in a tool that supports the showing of categories. Thus, it's good in browsers and hierarchy browsers but not in message-list browsers"
| aSelector |
self okToChange ifTrue:
[(aSelector := self selectedMessageName) ifNotNil:
[self selectOriginalCategoryForCurrentMethod.
self selectedMessageName: aSelector]]!
----- Method: Browser>>spawn: (in category 'accessing') -----
spawn: aString
"Create and schedule a fresh browser and place aString in its code pane. This method is called when the user issues the #spawn command (cmd-o) in any code pane. Whatever text was in the original code pane comes in to this method as the aString argument; the changes in the original code pane have already been cancelled by the time this method is called, so aString is the only copy of what the user had in his code pane."
self selectedClassOrMetaClass ifNotNil: [^ super spawn: aString].
systemCategoryListIndex ~= 0
ifTrue:
["This choice is slightly useless but is the historical implementation"
^ self buildSystemCategoryBrowserEditString: aString].
^ super spawn: aString
"This bail-out at least saves the text being spawned, which would otherwise be lost"!
----- Method: Browser>>suggestCategoryToSpawnedBrowser: (in category 'accessing') -----
suggestCategoryToSpawnedBrowser: aBrowser
"aBrowser is a message-category browser being spawned from the receiver. Tell it what it needs to know to get its category info properly set up."
(self isMemberOf: Browser) "yecch, but I didn't invent the browser hierarchy"
ifTrue:
[aBrowser messageCategoryListIndex: (self messageCategoryList indexOf: self categoryOfCurrentMethod ifAbsent: [2])]
ifFalse:
[aBrowser setOriginalCategoryIndexForCurrentMethod]!
----- Method: Browser>>systemCatSingletonKey:from: (in category 'initialize-release') -----
systemCatSingletonKey: aChar from: aView
^ self messageListKey: aChar from: aView!
----- Method: Browser>>systemCatSingletonMenu: (in category 'system category functions') -----
systemCatSingletonMenu: aMenu
^ aMenu labels:
'browse all
browse
printOut
fileOut
update
rename...
remove'
lines: #(2 4)
selections:
#(browseAllClasses buildSystemCategoryBrowser
printOutSystemCategory fileOutSystemCategory updateSystemCategories
renameSystemCategory removeSystemCategory)
!
----- Method: Browser>>systemCategoryList (in category 'system category list') -----
systemCategoryList
"Answer the class categories modelled by the receiver."
^systemOrganizer categories!
----- Method: Browser>>systemCategoryListIndex (in category 'system category list') -----
systemCategoryListIndex
"Answer the index of the selected class category."
^systemCategoryListIndex!
----- Method: Browser>>systemCategoryListIndex: (in category 'system category list') -----
systemCategoryListIndex: anInteger
"Set the selected system category index to be anInteger. Update all other
selections to be deselected."
systemCategoryListIndex := anInteger.
classListIndex := 0.
messageCategoryListIndex := 0.
messageListIndex := 0.
self editSelection: ( anInteger = 0 ifTrue: [#none] ifFalse: [#newClass]).
metaClassIndicated := false.
self setClassOrganizer.
contents := nil.
self changed: #systemCategorySelectionChanged.
self changed: #systemCategoryListIndex. "update my selection"
self changed: #classList.
self changed: #messageCategoryList.
self changed: #messageList.
self changed: #relabel.
self contentsChanged!
----- Method: Browser>>systemCategoryMenu: (in category 'system category functions') -----
systemCategoryMenu: aMenu
ServiceGui browser: self classCategoryMenu: aMenu.
ServiceGui onlyServices ifTrue: [^aMenu].
^ aMenu labels:
'find class... (f)
recent classes... (r)
browse all
browse
printOut
fileOut
reorganize
alphabetize
update
add item...
rename...
remove'
lines: #(2 4 6 8)
selections:
#(findClass recent browseAllClasses buildSystemCategoryBrowser
printOutSystemCategory fileOutSystemCategory
editSystemCategories alphabetizeSystemCategories updateSystemCategories
addSystemCategory renameSystemCategory removeSystemCategory )!
----- Method: Browser>>systemCategorySingleton (in category 'system category list') -----
systemCategorySingleton
| cat |
cat := self selectedSystemCategoryName.
^ cat ifNil: [Array new]
ifNotNil: [Array with: cat]!
----- Method: Browser>>systemOrganizer: (in category 'initialize-release') -----
systemOrganizer: aSystemOrganizer
"Initialize the receiver as a perspective on the system organizer,
aSystemOrganizer. Typically there is only one--the system variable
SystemOrganization."
contents := nil.
systemOrganizer := aSystemOrganizer.
systemCategoryListIndex := 0.
classListIndex := 0.
messageCategoryListIndex := 0.
messageListIndex := 0.
metaClassIndicated := false.
self setClassOrganizer.
self editSelection: #none.!
----- Method: Browser>>toggleBreakOnEntry (in category 'breakpoints') -----
toggleBreakOnEntry
"Install or uninstall a halt-on-entry breakpoint"
| selectedMethod |
self selectedClassOrMetaClass isNil ifTrue:[^self].
selectedMethod := self selectedClassOrMetaClass >> self selectedMessageName.
selectedMethod hasBreakpoint
ifTrue:
[BreakpointManager unInstall: selectedMethod]
ifFalse:
[BreakpointManager
installInClass: self selectedClassOrMetaClass
selector: self selectedMessageName].
self changed: #messageList
!
----- Method: Browser>>toggleClassListIndex: (in category 'class list') -----
toggleClassListIndex: anInteger
"If anInteger is the current class index, deselect it. Else make it the
current class selection."
self classListIndex:
(classListIndex = anInteger
ifTrue: [0]
ifFalse: [anInteger])!
----- Method: Browser>>toggleMessageCategoryListIndex: (in category 'message category list') -----
toggleMessageCategoryListIndex: anInteger
"If the currently selected message category index is anInteger, deselect
the category. Otherwise select the category whose index is anInteger."
self messageCategoryListIndex:
(messageCategoryListIndex = anInteger
ifTrue: [0]
ifFalse: [anInteger])!
----- Method: Browser>>toggleMessageListIndex: (in category 'message list') -----
toggleMessageListIndex: anInteger
"If the currently selected message index is anInteger, deselect the message
selector. Otherwise select the message selector whose index is anInteger."
self messageListIndex:
(messageListIndex = anInteger
ifTrue: [0]
ifFalse: [anInteger])!
----- Method: Browser>>toggleSystemCategoryListIndex: (in category 'system category list') -----
toggleSystemCategoryListIndex: anInteger
"If anInteger is the current system category index, deselect it. Else make
it the current system category selection."
self systemCategoryListIndex:
(systemCategoryListIndex = anInteger
ifTrue: [0]
ifFalse: [anInteger])!
----- Method: Browser>>updateSystemCategories (in category 'system category functions') -----
updateSystemCategories
"The class categories were changed in another browser. The receiver must
reorganize its lists based on these changes."
self okToChange ifFalse: [^ self].
self changed: #systemCategoryList!
----- Method: Browser>>veryDeepInner: (in category 'copying') -----
veryDeepInner: deepCopier
"Copy all of my instance variables. Some need to be not copied at all, but shared. See DeepCopier class comment."
super veryDeepInner: deepCopier.
"systemOrganizer := systemOrganizer. clone has the old value. we share it"
"classOrganizer := classOrganizer clone has the old value. we share it"
"metaClassOrganizer := metaClassOrganizer clone has the old value. we share it"
systemCategoryListIndex := systemCategoryListIndex veryDeepCopyWith: deepCopier.
classListIndex := classListIndex veryDeepCopyWith: deepCopier.
messageCategoryListIndex := messageCategoryListIndex veryDeepCopyWith: deepCopier.
messageListIndex := messageListIndex veryDeepCopyWith: deepCopier.
editSelection := editSelection veryDeepCopyWith: deepCopier.
metaClassIndicated := metaClassIndicated veryDeepCopyWith: deepCopier.
!
----- Method: Browser>>wantsMessageCategoriesDrop: (in category 'drag and drop') -----
wantsMessageCategoriesDrop: anObject
"Only accept drops of compiled methods on system categories"
^anObject isKindOf: CompiledMethod!
----- Method: Browser>>wantsSystemCategoriesDrop: (in category 'drag and drop') -----
wantsSystemCategoriesDrop: anObject
"Only accept drops of behaviors on system categories"
^anObject isBehavior!
Browser subclass: #FileContentsBrowser
instanceVariableNames: 'packages infoString'
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-File Contents Browser'!
!FileContentsBrowser commentStamp: '<historical>' prior: 0!
I am a class browser view on a fileout (either a source file (.st) or change set (.cs)). I do not actually load the code into to the system, nor do I alter the classes in the image. Use me to vet code in a comfortable way before loading it into your image.
>From a FileList, I can be invoked by selecting a source file and selecting the "browse code" menu item from the yellow button menu.
I use PseudoClass, PseudoClassOrganizers, and PseudoMetaclass to model the class structure of the source file.!
----- Method: FileContentsBrowser class>>browseCompressedCodeStream: (in category 'instance creation') -----
browseCompressedCodeStream: aStandardFileStream
"Browse the selected file in fileIn format."
| zipped unzipped |
[zipped := GZipReadStream on: aStandardFileStream.
unzipped := MultiByteBinaryOrTextStream with: zipped contents asString]
ensure: [aStandardFileStream close].
unzipped reset.
self browseStream: unzipped named: aStandardFileStream name!
----- Method: FileContentsBrowser class>>browseFile: (in category 'instance creation') -----
browseFile: aFilename
"Open a file contents browser on a file of the given name"
aFilename ifNil: [^ Beeper beep].
self browseFiles: (Array with: aFilename)!
----- Method: FileContentsBrowser class>>browseFiles: (in category 'instance creation') -----
browseFiles: fileList
| package organizer packageDict browser |
Cursor wait showWhile: [
packageDict := Dictionary new.
organizer := SystemOrganizer defaultList: Array new.
fileList do: [:fileName |
package := FilePackage fromFileNamed: fileName.
packageDict
at: package packageName
put: package.
organizer
classifyAll: package classes keys
under: package packageName].
(browser := self systemOrganizer: organizer)
packages: packageDict].
self
openBrowserView: browser createViews
label: 'File Contents Browser'.
!
----- Method: FileContentsBrowser class>>browseStream: (in category 'instance creation') -----
browseStream: aStream
aStream setConverterForCode.
self browseStream: aStream named: aStream name!
----- Method: FileContentsBrowser class>>browseStream:named: (in category 'instance creation') -----
browseStream: aStream named: aString
| package organizer packageDict browser |
Cursor wait showWhile: [
packageDict := Dictionary new.
browser := self new.
organizer := SystemOrganizer defaultList: Array new.
package := (FilePackage new fullName: aString; fileInFrom: aStream).
packageDict
at: package packageName
put: package.
organizer
classifyAll: package classes keys
under: package packageName.
(browser := self systemOrganizer: organizer)
packages: packageDict].
self
openBrowserView: browser createViews
label: 'File Contents Browser'.
!
----- Method: FileContentsBrowser class>>fileReaderServicesForDirectory: (in category 'file list services') -----
fileReaderServicesForDirectory: aDirectory
^{ self serviceBrowseCodeFiles }!
----- Method: FileContentsBrowser class>>fileReaderServicesForFile:suffix: (in category 'file list services') -----
fileReaderServicesForFile: fullName suffix: suffix
((FileStream isSourceFileSuffix: suffix) or: [ suffix = '*' ])
ifTrue: [ ^Array with: self serviceBrowseCode].
^(fullName endsWith: 'cs.gz')
ifTrue: [ Array with: self serviceBrowseCompressedCode ]
ifFalse: [#()]
!
----- Method: FileContentsBrowser class>>initialize (in category 'class initialization') -----
initialize
FileList registerFileReader: self!
----- Method: FileContentsBrowser class>>selectAndBrowseFile: (in category 'file list services') -----
selectAndBrowseFile: aFileList
"When no file are selected you can ask to browse several of them"
| selectionPattern files |
selectionPattern := UIManager default request:'What files?' initialAnswer: '*.cs;*.st'.
files := (aFileList directory fileNamesMatching: selectionPattern)
collect: [:each | aFileList directory fullNameFor: each].
self browseFiles: files.
!
----- Method: FileContentsBrowser class>>serviceBrowseCode (in category 'file list services') -----
serviceBrowseCode
"Answer the service of opening a file-contents browser"
^ (SimpleServiceEntry
provider: self
label: 'code-file browser'
selector: #browseStream:
description: 'open a "file-contents browser" on this file, allowing you to view and selectively load its code'
buttonLabel: 'code')
argumentGetter: [ :fileList | fileList readOnlyStream ]!
----- Method: FileContentsBrowser class>>serviceBrowseCodeFiles (in category 'file list services') -----
serviceBrowseCodeFiles
^ (SimpleServiceEntry
provider: self
label: 'browse code files'
selector: #selectAndBrowseFile:)
argumentGetter: [ :fileList | fileList ];
yourself!
----- Method: FileContentsBrowser class>>serviceBrowseCompressedCode (in category 'file list services') -----
serviceBrowseCompressedCode
"Answer a service for opening a changelist browser on a file"
^ (SimpleServiceEntry
provider: self
label: 'code-file browser'
selector: #browseCompressedCodeStream:
description: 'open a "file-contents browser" on this file, allowing you to view and selectively load its code'
buttonLabel: 'code')
argumentGetter: [ :fileList | fileList readOnlyStream ]!
----- Method: FileContentsBrowser class>>services (in category 'file list services') -----
services
"Answer potential file services associated with this class"
^ {self serviceBrowseCode}.!
----- Method: FileContentsBrowser class>>unload (in category 'class initialization') -----
unload
FileList unregisterFileReader: self !
----- Method: FileContentsBrowser class>>windowColorSpecification (in category 'window color') -----
windowColorSpecification
"Answer a WindowColorSpec object that declares my preference"
^ WindowColorSpec classSymbol: self name wording: 'File Contents Browser' brightColor: #tan pastelColor: #paleTan helpMessage: 'Lets you view the contents of a file as code, in a browser-like tool.'!
----- Method: FileContentsBrowser>>aboutToStyle: (in category 'edit pane') -----
aboutToStyle: aStyler
"This is a notification that aStyler is about to re-style its text.
Set the classOrMetaClass in aStyler, so that identifiers
will be resolved correctly.
Answer true to allow styling to proceed, or false to veto the styling"
self isModeStyleable ifFalse: [^false].
aStyler classOrMetaClass: self selectedClassOrMetaClass.
^true!
----- Method: FileContentsBrowser>>browseMethodFull (in category 'class list') -----
browseMethodFull
| myClass |
(myClass := self selectedClassOrMetaClass) ifNotNil:
[ToolSet browse: myClass realClass selector: self selectedMessageName]!
----- Method: FileContentsBrowser>>browseSenders (in category 'other') -----
browseSenders
"Create and schedule a message set browser on all senders of the
currently selected message selector. Do nothing if no message is selected."
messageListIndex ~= 0
ifTrue: [self systemNavigation browseAllCallsOn: self selectedMessageName]!
----- Method: FileContentsBrowser>>browseVersions (in category 'other') -----
browseVersions
"Create and schedule a message set browser on all versions of the
currently selected message selector."
| class selector |
(selector := self selectedMessageName) ifNotNil:
[class := self selectedClassOrMetaClass.
(class exists and: [class realClass includesSelector: selector]) ifTrue:
[VersionsBrowser
browseVersionsOf: (class realClass compiledMethodAt: selector)
class: class realClass theNonMetaClass
meta: class realClass isMeta
category: self selectedMessageCategoryName
selector: selector]]!
----- Method: FileContentsBrowser>>buildInfoViewWith: (in category 'toolbuilder') -----
buildInfoViewWith: builder
| textSpec |
textSpec := builder pluggableTextSpec new.
textSpec
model: self;
getText: #infoViewContents.
^textSpec!
----- Method: FileContentsBrowser>>buildSystemCatListSingletonWith: (in category 'toolbuilder') -----
buildSystemCatListSingletonWith: builder
| listSpec |
listSpec := builder pluggableListSpec new.
listSpec
model: self;
list: #systemCategorySingleton;
getIndex: #indexIsOne;
setIndex: #indexIsOne:;
menu: #packageListMenu:;
keyPress: #packageListKey:from:.
^listSpec!
----- Method: FileContentsBrowser>>buildSystemCategoryListWith: (in category 'toolbuilder') -----
buildSystemCategoryListWith: builder
| listSpec |
listSpec := builder pluggableListSpec new.
listSpec
model: self;
list: #systemCategoryList;
getIndex: #systemCategoryListIndex;
setIndex: #systemCategoryListIndex:;
menu: #packageListMenu:;
keyPress: #packageListKey:from:.
^listSpec!
----- Method: FileContentsBrowser>>buildWith: (in category 'toolbuilder') -----
buildWith: builder
"Create a pluggable version of all the views for a Browser, including views and controllers."
| windowSpec |
self packages size = 1 ifTrue:[
self systemCategoryListIndex: 1.
windowSpec := self buildWindowWith: builder specs: {
(0 at 0 corner: 1.0 at 0.06) -> [self buildSystemCatListSingletonWith: builder].
(0 at 0.06 corner: 0.34 at 0.24) -> [self buildClassListWith: builder].
(0 at 0.24 corner: 0.34 at 0.34) -> [self buildSwitchesWith: builder].
(0.34 at 0.06 corner: 0.67 at 0.34) -> [self buildMessageCategoryListWith: builder].
(0.67 at 0.06 corner: 1.0 at 0.34) -> [self buildMessageListWith: builder].
(0.0 at 0.34 corner: 1.0 at 0.9) -> [self buildCodePaneWith: builder].
(0.0 at 0.9 corner: 1.0 at 1.0) -> [self buildInfoViewWith: builder].
}
] ifFalse:[
windowSpec := self buildWindowWith: builder specs: {
(0 at 0 corner: 0.25 at 0.4) -> [self buildSystemCategoryListWith: builder].
(0.25 at 0 corner: 0.5 at 0.3) -> [self buildClassListWith: builder].
(0.25 at 0.3 corner: 0.5 at 0.4) -> [self buildSwitchesWith: builder].
(0.5 at 0 corner: 0.75 at 0.4) -> [self buildMessageCategoryListWith: builder].
(0.75 at 0 corner: 1.0 at 0.4) -> [self buildMessageListWith: builder].
(0.0 at 0.4 corner: 1.0 at 0.9) -> [self buildCodePaneWith: builder].
(0.0 at 0.9 corner: 1.0 at 1.0) -> [self buildInfoViewWith: builder].
}
].
^ windowSpec
!
----- Method: FileContentsBrowser>>changeMessageCategories: (in category 'other') -----
changeMessageCategories: aString
"The characters in aString represent an edited version of the the message
categories for the selected class. Update this information in the system
and inform any dependents that the categories have been changed. This
message is invoked because the user had issued the categories command
and edited the message categories. Then the user issued the accept
command."
self classOrMetaClassOrganizer changeFromString: aString.
self unlock.
self editClass.
self classListIndex: classListIndex.
^ true!
----- Method: FileContentsBrowser>>classList (in category 'class list') -----
classList
"Answer an array of the class names of the selected category. Answer an
empty array if no selection exists."
(systemCategoryListIndex = 0 or:[self selectedPackage isNil])
ifTrue: [^Array new]
ifFalse: [^self selectedPackage classes keys asSortedCollection].!
----- Method: FileContentsBrowser>>classListKey:from: (in category 'keys') -----
classListKey: aChar from: view
aChar == $b ifTrue: [^ self browseMethodFull].
aChar == $N ifTrue: [^ self browseClassRefs].
self packageListKey: aChar from: view!
----- Method: FileContentsBrowser>>classListMenu: (in category 'menus') -----
classListMenu: aMenu
^ aMenu
labels:
'definition
comment
browse full (b)
class refs (N)
fileIn
fileOut
rename...
remove
remove existing'
lines: #(2 4 6 8)
selections: #(editClass editComment browseMethodFull browseClassRefs fileInClass fileOutClass renameClass removeClass removeUnmodifiedCategories)
!
----- Method: FileContentsBrowser>>classListMenu:shifted: (in category 'menus') -----
classListMenu: aMenu shifted: ignored
"Answer the class list menu, ignoring the state of the shift key in this case"
^ self classListMenu: aMenu!
----- Method: FileContentsBrowser>>contents (in category 'accessing') -----
contents
self updateInfoView.
(editSelection == #newClass and:[self selectedPackage notNil])
ifTrue: [^self selectedPackage packageInfo].
editSelection == #editClass
ifTrue:[^self modifiedClassDefinition].
^super contents!
----- Method: FileContentsBrowser>>contents:notifying: (in category 'accessing') -----
contents: input notifying: aController
"The retrieved information has changed and its source must now be
updated. The information can be a variety of things, depending on the
list selections (such as templates for class or message definition, methods)
or the user menu commands (such as definition, comment, hierarchy).
Answer the result of updating the source."
| aString aText theClass |
aString := input asString.
aText := input asText.
editSelection == #editComment
ifTrue: [theClass := self selectedClass.
theClass ifNil: [self inform: 'You must select a class
before giving it a comment.'.
^ false].
theClass comment: aText. ^ true].
editSelection == #editMessageCategories
ifTrue: [^ self changeMessageCategories: aString].
self inform:'You cannot change the current selection'.
^false
!
----- Method: FileContentsBrowser>>contentsSymbolQuints (in category 'menus') -----
contentsSymbolQuints
"Answer a list of quintuplets representing information on the alternative views available in the code pane. For the file-contents browser, the choices are restricted to source and the two diffing options"
^ self sourceAndDiffsQuintsOnly!
----- Method: FileContentsBrowser>>createViews (in category 'creation') -----
createViews
"Create a pluggable version of all the views for a Browser, including views and controllers."
contentsSymbol := self defaultDiffsSymbol. "#showDiffs or #prettyDiffs"
^self buildWith: ToolBuilder default!
----- Method: FileContentsBrowser>>defaultBrowserTitle (in category 'initialize-release') -----
defaultBrowserTitle
^ 'File Contents Browser'!
----- Method: FileContentsBrowser>>didCodeChangeElsewhere (in category 'other') -----
didCodeChangeElsewhere
"Determine whether the code for the currently selected method and class has been changed somewhere else."
| aClass |
(aClass := self selectedClassOrMetaClass) ifNil: [^ false].
(aClass isKindOf: PseudoClass) ifTrue: [^ false]. "class not installed"
^super didCodeChangeElsewhere!
----- Method: FileContentsBrowser>>extraInfo (in category 'infoView') -----
extraInfo
^ (self
methodDiffFor: (self selectedClassOrMetaClass sourceCodeAt: self selectedMessageName)
class: self selectedClass
selector: self selectedMessageName
meta: self metaClassIndicated) unembellished
ifTrue: [' - identical']
ifFalse: [' - modified']!
----- Method: FileContentsBrowser>>fileInClass (in category 'fileIn/fileOut') -----
fileInClass
Cursor read showWhile:[
self selectedClass fileIn.
].!
----- Method: FileContentsBrowser>>fileInMessage (in category 'fileIn/fileOut') -----
fileInMessage
self selectedMessageName ifNil: [^self].
Cursor read showWhile: [
self selectedClassOrMetaClass fileInMethod: self selectedMessageName.
].!
----- Method: FileContentsBrowser>>fileInMessageCategories (in category 'fileIn/fileOut') -----
fileInMessageCategories
Cursor read showWhile:[
self selectedClassOrMetaClass fileInCategory: self selectedMessageCategoryName.
].!
----- Method: FileContentsBrowser>>fileInPackage (in category 'fileIn/fileOut') -----
fileInPackage
Cursor read showWhile:[
self selectedPackage fileIn.
].!
----- Method: FileContentsBrowser>>fileIntoNewChangeSet (in category 'fileIn/fileOut') -----
fileIntoNewChangeSet
| p ff |
(p := self selectedPackage) ifNil: [^ Beeper beep].
ff := FileStream readOnlyFileNamed: p fullPackageName.
ChangeSet newChangesFromStream: ff named: p packageName!
----- Method: FileContentsBrowser>>fileOutClass (in category 'fileIn/fileOut') -----
fileOutClass
Cursor write showWhile:[
self selectedClass fileOut.
].!
----- Method: FileContentsBrowser>>fileOutMessage (in category 'fileIn/fileOut') -----
fileOutMessage
self selectedMessageName ifNil: [^self].
Cursor write showWhile: [
self selectedClassOrMetaClass fileOutMethod: self selectedMessageName].!
----- Method: FileContentsBrowser>>fileOutMessageCategories (in category 'fileIn/fileOut') -----
fileOutMessageCategories
Cursor write showWhile:[
self selectedClassOrMetaClass fileOutCategory: self selectedMessageCategoryName.
].!
----- Method: FileContentsBrowser>>fileOutPackage (in category 'fileIn/fileOut') -----
fileOutPackage
Cursor write showWhile:[
self selectedPackage fileOut.
].!
----- Method: FileContentsBrowser>>findClass (in category 'class list') -----
findClass
| pattern foundClass classNames index foundPackage |
self okToChange ifFalse: [^ self classNotFound].
pattern := (UIManager default request: 'Class Name?') asLowercase.
pattern isEmpty ifTrue: [^ self].
classNames := Set new.
self packages do:[:p| classNames addAll: p classes keys].
classNames := classNames asArray select:
[:n | (n asLowercase indexOfSubCollection: pattern startingAt: 1) > 0].
classNames isEmpty ifTrue: [^ self].
index := classNames size == 1
ifTrue: [1]
ifFalse: [(UIManager default chooseFrom: classNames lines: #())].
index = 0 ifTrue: [^ self].
foundPackage := nil.
foundClass := nil.
self packages do:[:p|
(p classes includesKey: (classNames at: index)) ifTrue:[
foundClass := p classes at: (classNames at: index).
foundPackage := p]].
foundClass isNil ifTrue:[^self].
self systemCategoryListIndex: (self systemCategoryList indexOf: foundPackage packageName asSymbol).
self classListIndex: (self classList indexOf: foundClass name). !
----- Method: FileContentsBrowser>>infoString (in category 'infoView') -----
infoString
^infoString isNil
ifTrue:[infoString := StringHolder new]
ifFalse:[infoString]!
----- Method: FileContentsBrowser>>infoViewContents (in category 'infoView') -----
infoViewContents
"Answer the string to show in the info view"
| theClass stamp exists |
editSelection == #newClass ifTrue: [^ self packageInfo: self selectedPackage].
self selectedClass isNil ifTrue: [^ ''].
theClass := Smalltalk at: self selectedClass name asSymbol ifAbsent: [].
editSelection == #editClass ifTrue:
[^ theClass notNil
ifTrue: ['Class exists already in the system' translated]
ifFalse: ['New class' translated]].
editSelection == #editMessage ifFalse: [^ ''].
(theClass notNil and: [self metaClassIndicated])
ifTrue: [theClass := theClass class].
stamp := self selectedClassOrMetaClass stampAt: self selectedMessageName.
exists := theClass notNil and: [theClass includesSelector: self selectedMessageName].
^ stamp = 'methodWasRemoved'
ifTrue:
[exists
ifTrue:
['Existing method removed by this change-set' translated]
ifFalse:
['Removal request for a method that is not present in this image' translated]]
ifFalse:
[stamp, ' · ',
(exists
ifTrue: ['Method already exists' translated , self extraInfo]
ifFalse: ['New method' translated])]!
----- Method: FileContentsBrowser>>labelString (in category 'other') -----
labelString
"Answer the string for the window title"
^ 'File Contents Browser ', (self selectedSystemCategoryName ifNil: [''])!
----- Method: FileContentsBrowser>>messageCategoryMenu: (in category 'menus') -----
messageCategoryMenu: aMenu
^ aMenu
labels:
'fileIn
fileOut
reorganize
add item...
rename...
remove
remove existing'
lines: #(2 3 6)
selections: #(fileInMessageCategories fileOutMessageCategories editMessageCategories addCategory renameCategory removeMessageCategory removeUnmodifiedMethods)!
----- Method: FileContentsBrowser>>messageListKey:from: (in category 'keys') -----
messageListKey: aChar from: view
aChar == $b ifTrue: [^ self browseMethodFull].
super messageListKey: aChar from: view!
----- Method: FileContentsBrowser>>messageListMenu:shifted: (in category 'menus') -----
messageListMenu: aMenu shifted: aBool
^ aMenu
labels:
'fileIn
fileOut
senders (n)
implementors (m)
method inheritance (h)
versions (v)
remove'
lines: #(2 6)
selections: #(fileInMessage fileOutMessage
browseSenders browseImplementors methodHierarchy browseVersions
removeMessage).
!
----- Method: FileContentsBrowser>>methodDiffFor:class:selector:meta: (in category 'diffs') -----
methodDiffFor: aString class: aPseudoClass selector: selector meta: meta
"Answer the diff between the current copy of the given class/selector/meta for the string provided"
| theClass source |
theClass := Smalltalk
at: aPseudoClass name
ifAbsent: [^ aString copy].
meta
ifTrue: [theClass := theClass class].
(theClass includesSelector: selector)
ifFalse: [^ aString copy].
source := theClass sourceCodeAt: selector.
^ Cursor wait
showWhile: [TextDiffBuilder buildDisplayPatchFrom: source to: aString inClass: theClass prettyDiffs: self showingPrettyDiffs]!
----- Method: FileContentsBrowser>>methodHierarchy (in category 'other') -----
methodHierarchy
(self selectedClassOrMetaClass isNil or:
[self selectedClassOrMetaClass hasDefinition])
ifFalse: [super methodHierarchy]!
----- Method: FileContentsBrowser>>modifiedClassDefinition (in category 'diffs') -----
modifiedClassDefinition
| pClass rClass old new diff |
pClass := self selectedClassOrMetaClass.
pClass hasDefinition ifFalse:[^pClass definition].
rClass := Smalltalk at: self selectedClass name asSymbol ifAbsent:[nil].
rClass isNil ifTrue:[^pClass definition].
self metaClassIndicated ifTrue:[ rClass := rClass class].
old := rClass definition.
new := pClass definition.
Cursor wait showWhile:[
diff := ClassDiffBuilder buildDisplayPatchFrom: old to: new
].
^diff!
----- Method: FileContentsBrowser>>packageInfo: (in category 'infoView') -----
packageInfo: p
| nClasses newClasses oldClasses |
p isNil ifTrue:[^''].
nClasses := newClasses := oldClasses := 0.
p classes do:[:cls|
nClasses := nClasses + 1.
(Smalltalk includesKey: (cls name asSymbol))
ifTrue:[oldClasses := oldClasses + 1]
ifFalse:[newClasses := newClasses + 1]].
^nClasses printString,' classes (', newClasses printString, ' new / ', oldClasses printString, ' modified)'!
----- Method: FileContentsBrowser>>packageListKey:from: (in category 'keys') -----
packageListKey: aChar from: view
aChar == $f ifTrue: [^ self findClass].
self arrowKey: aChar from: view!
----- Method: FileContentsBrowser>>packageListMenu: (in category 'menus') -----
packageListMenu: aMenu
^ aMenu
labels:
'find class... (f)
fileIn
file into new changeset
fileOut
remove
remove existing'
lines: #(1 4 5)
selections: #(findClass fileInPackage fileIntoNewChangeSet fileOutPackage removePackage removeUnmodifiedClasses)!
----- Method: FileContentsBrowser>>packages (in category 'accessing') -----
packages
^packages!
----- Method: FileContentsBrowser>>packages: (in category 'accessing') -----
packages: aDictionary
packages := aDictionary.!
----- Method: FileContentsBrowser>>removeClass (in category 'removing') -----
removeClass
| class |
classListIndex = 0 ifTrue: [^ self].
class := self selectedClass.
(self confirm:'Are you certain that you
want to delete the class ', class name, '?') ifFalse:[^self].
self selectedPackage removeClass: class.
self classListIndex: 0.
self changed: #classList.!
----- Method: FileContentsBrowser>>removeMessage (in category 'removing') -----
removeMessage
| messageName |
messageListIndex = 0
ifTrue: [^ self].
self okToChange
ifFalse: [^ self].
messageName := self selectedMessageName.
(self selectedClass confirmRemovalOf: messageName)
ifFalse: [^ false].
self selectedClassOrMetaClass removeMethod: self selectedMessageName.
self messageListIndex: 0.
self setClassOrganizer.
"In case organization not cached"
self changed: #messageList!
----- Method: FileContentsBrowser>>removeMessageCategory (in category 'removing') -----
removeMessageCategory
"If a message category is selected, create a Confirmer so the user can
verify that the currently selected message category should be removed
from the system. If so, remove it."
| messageCategoryName |
messageCategoryListIndex = 0 ifTrue: [^ self].
self okToChange ifFalse: [^ self].
messageCategoryName := self selectedMessageCategoryName.
(self messageList size = 0
or: [self confirm: 'Are you sure you want to
remove this method category
and all its methods?']) ifFalse: [^ self].
self selectedClassOrMetaClass removeCategory: messageCategoryName.
self messageCategoryListIndex: 0.
self changed: #messageCategoryList.!
----- Method: FileContentsBrowser>>removePackage (in category 'removing') -----
removePackage
systemCategoryListIndex = 0 ifTrue: [^ self].
self okToChange ifFalse: [^ self].
(self confirm: 'Are you sure you want to
remove this package
and all its classes?') ifFalse:[^self].
(systemOrganizer listAtCategoryNamed: self selectedSystemCategoryName) do:[:el|
systemOrganizer removeElement: el].
self packages removeKey: self selectedPackage packageName.
systemOrganizer removeCategory: self selectedSystemCategoryName.
self systemCategoryListIndex: 0.
self changed: #systemCategoryList!
----- Method: FileContentsBrowser>>removeUnmodifiedCategories (in category 'removing') -----
removeUnmodifiedCategories
| theClass |
self okToChange ifFalse: [^self].
theClass := self selectedClass.
theClass isNil ifTrue: [^self].
Cursor wait showWhile:
[theClass removeUnmodifiedMethods: theClass selectors.
theClass metaClass removeUnmodifiedMethods: theClass metaClass selectors].
self messageCategoryListIndex: 0.
self changed: #messageCategoryList.!
----- Method: FileContentsBrowser>>removeUnmodifiedClasses (in category 'removing') -----
removeUnmodifiedClasses
| packageList |
self okToChange ifFalse:[^self].
packageList := self selectedPackage isNil
ifTrue:[self packages]
ifFalse:[Array with: self selectedPackage].
packageList do:[:package|
package classes copy do:[:theClass|
Cursor wait showWhile:[
theClass removeAllUnmodified.
].
theClass hasChanges ifFalse:[
package removeClass: theClass.
].
]].
self classListIndex: 0.
self changed: #classList.!
----- Method: FileContentsBrowser>>removeUnmodifiedMethods (in category 'removing') -----
removeUnmodifiedMethods
| theClass cat |
self okToChange ifFalse:[^self].
theClass := self selectedClassOrMetaClass.
theClass isNil ifTrue:[^self].
cat := self selectedMessageCategoryName.
cat isNil ifTrue:[^self].
Cursor wait showWhile:[
theClass removeUnmodifiedMethods: (theClass organization listAtCategoryNamed: cat).
].
self messageListIndex: 0.
self changed: #messageList.!
----- Method: FileContentsBrowser>>renameClass (in category 'class list') -----
renameClass
| oldName newName |
classListIndex = 0 ifTrue: [^ self].
self okToChange ifFalse: [^ self].
oldName := self selectedClass name.
newName := (self request: 'Please type new class name'
initialAnswer: oldName) asSymbol.
(newName isEmpty or:[newName = oldName]) ifTrue: [^ self].
(self selectedPackage classes includesKey: newName)
ifTrue: [^ self error: newName , ' already exists in the package'].
systemOrganizer classify: newName under: self selectedSystemCategoryName.
systemOrganizer removeElement: oldName.
self selectedPackage renameClass: self selectedClass to: newName.
self changed: #classList.
self classListIndex: ((systemOrganizer listAtCategoryNamed: self selectedSystemCategoryName) indexOf: newName).
!
----- Method: FileContentsBrowser>>selectedBytecodes (in category 'edit pane') -----
selectedBytecodes
"Compile the source code for the selected message selector and extract and return
the bytecode listing."
| class selector |
class := self selectedClassOrMetaClass.
selector := self selectedMessageName.
contents := class sourceCodeAt: selector.
contents := Compiler new
parse: contents
in: class
notifying: nil.
contents := contents generate.
^ contents symbolic asText!
----- Method: FileContentsBrowser>>selectedClass (in category 'class list') -----
selectedClass
"Answer the class that is currently selected. Answer nil if no selection
exists."
self selectedClassName == nil ifTrue: [^nil].
^self selectedPackage classAt: self selectedClassName!
----- Method: FileContentsBrowser>>selectedClassOrMetaClass (in category 'metaclass') -----
selectedClassOrMetaClass
"Answer the selected class or metaclass."
| cls |
self metaClassIndicated
ifTrue: [^ (cls := self selectedClass) ifNotNil: [cls metaClass]]
ifFalse: [^ self selectedClass]!
----- Method: FileContentsBrowser>>selectedMessage (in category 'edit pane') -----
selectedMessage
"Answer a copy of the source code for the selected message selector."
| class selector |
class := self selectedClassOrMetaClass.
selector := self selectedMessageName.
contents := class sourceCodeAt: selector.
Preferences browseWithPrettyPrint
ifTrue:
[contents := class prettyPrinterClass
format: contents
in: class
notifying: nil
decorated: false].
self showingAnyKindOfDiffs
ifTrue:
[contents := self
methodDiffFor: contents
class: self selectedClass
selector: self selectedMessageName
meta: self metaClassIndicated].
^contents asText makeSelectorBoldIn: class!
----- Method: FileContentsBrowser>>selectedPackage (in category 'accessing') -----
selectedPackage
| cat |
cat := self selectedSystemCategoryName.
cat isNil ifTrue:[^nil].
^self packages at: cat asString ifAbsent:[nil]!
----- Method: FileContentsBrowser>>setClassOrganizer (in category 'metaclass') -----
setClassOrganizer
"Install whatever organization is appropriate"
| theClass |
classOrganizer := nil.
metaClassOrganizer := nil.
classListIndex = 0 ifTrue: [^ self].
classOrganizer := (theClass := self selectedClass) organization.
metaClassOrganizer := theClass metaClass organization.
!
----- Method: FileContentsBrowser>>updateInfoView (in category 'infoView') -----
updateInfoView
Smalltalk isMorphic
ifTrue: [self changed: #infoViewContents]
ifFalse: [
self infoString contents: self infoViewContents.
self infoString changed].!
----- Method: FileContentsBrowser>>wantsAnnotationPane (in category 'toolbuilder') -----
wantsAnnotationPane
"Never. FCB has its info pane already which serves the same purpose."
^false
!
Browser subclass: #HierarchyBrowser
instanceVariableNames: 'classList centralClass'
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Browser'!
HierarchyBrowser subclass: #ClassListBrowser
instanceVariableNames: 'defaultTitle'
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Browser'!
!ClassListBrowser commentStamp: '<historical>' prior: 0!
A ClassListBrowser displays the code for an arbitrary list of classes.
ClassListBrowser example1. "all classes that have the string 'Pluggable' in their names"
ClassListBrowser example2. "all classes whose names start with the letter S"
ClassListBrowser example3. "all variable classes"
ClassListBrowser example4. "all classes with more than 100 methods"
ClassListBrowser example5. "all classes that lack class comments"
ClassListBrowser example6. "all classes that have class instance variables"
ClassListBrowser new initForClassesNamed: #(Browser Boolean) title: 'Browser and Boolean!!'.
!
----- Method: ClassListBrowser class>>browseClassesSatisfying:title: (in category 'instance creation') -----
browseClassesSatisfying: classBlock title: aTitle
"Put up a ClassListBrowser showing all classes that satisfy the classBlock."
self new
initForClassesNamed:
(self systemNavigation allClasses select:
[:c | (classBlock value: c) == true]
thenCollect:
[:c | c name])
title:
aTitle!
----- Method: ClassListBrowser class>>example1 (in category 'examples') -----
example1
"Put up a ClassListBrowser that shows all classes that have the string 'Pluggable' in their names"
self browseClassesSatisfying: [:cl | cl name includesSubString: 'Pluggable'] title: 'Pluggables'
"ClassListBrowser example1"
!
----- Method: ClassListBrowser class>>example2 (in category 'examples') -----
example2
"Put up a ClassListBrowser that shows all classes whose names start with
the letter S"
self new
initForClassesNamed: (self systemNavigation allClasses
collect: [:c | c name]
thenSelect: [:aName | aName first == $S])
title: 'All classes starting with S'
"ClassListBrowser example2"!
----- Method: ClassListBrowser class>>example3 (in category 'examples') -----
example3
"Put up a ClassListBrowser that shows all Variable classes"
self browseClassesSatisfying: [:c | c isVariable] title: 'All Variable classes'
"ClassListBrowser example3"
!
----- Method: ClassListBrowser class>>example4 (in category 'examples') -----
example4
"Put up a ClassListBrowser that shows all classes implementing more than 100 methods"
self browseClassesSatisfying:
[:c | (c selectors size + c class selectors size) > 100] title: 'Classes with more than 100 methods'
"ClassListBrowser example4"
!
----- Method: ClassListBrowser class>>example5 (in category 'examples') -----
example5
"Put up a ClassListBrowser that shows all classes that lack class comments"
self
browseClassesSatisfying:
[:c | c organization classComment isEmptyOrNil]
title: 'Classes lacking class comments'
"ClassListBrowser example5"
!
----- Method: ClassListBrowser class>>example6 (in category 'examples') -----
example6
"Put up a ClassListBrowser that shows all classes that have class instance variables"
self
browseClassesSatisfying:
[:c | c class instVarNames size > 0]
title:
'Classes that define class-side instance variables'
"ClassListBrowser example6"!
----- Method: ClassListBrowser>>defaultTitle: (in category 'title') -----
defaultTitle: aTitle
"Set the browser's default title"
defaultTitle := aTitle!
----- Method: ClassListBrowser>>initForClassesNamed:title: (in category 'initialization') -----
initForClassesNamed: nameList title: aTitle
"Initialize the receiver for the class-name-list and title provided"
self systemOrganizer: SystemOrganization.
metaClassIndicated := false.
defaultTitle := aTitle.
classList := nameList copy.
self class openBrowserView: (self openSystemCatEditString: nil)
label: aTitle
"ClassListBrowser new initForClassesNamed: #(Browser CategoryViewer) title: 'Frogs'"!
----- Method: ClassListBrowser>>labelString (in category 'title') -----
labelString
"Answer the label strilng to use on the browser"
^ defaultTitle ifNil: [super labelString]!
----- Method: HierarchyBrowser class>>newFor: (in category 'instance creation') -----
newFor: aClass
"Open a new HierarchyBrowser on the given class"
| newBrowser |
newBrowser := HierarchyBrowser new initHierarchyForClass: aClass.
Browser openBrowserView: (newBrowser openSystemCatEditString: nil)
label: newBrowser labelString
"HierarchyBrowser newFor: Boolean"!
----- Method: HierarchyBrowser class>>newFor:labeled: (in category 'instance creation') -----
newFor: aClass labeled: aLabel
"Open a new HierarchyBrowser on the given class, using aLabel as the window title."
| newBrowser |
newBrowser := HierarchyBrowser new initHierarchyForClass: aClass.
Browser openBrowserView: (newBrowser openSystemCatEditString: nil)
label: aLabel
"HierarchyBrowser newFor: Boolean labeled: 'Testing'"!
----- Method: HierarchyBrowser>>assureSelectionsShow (in category 'class list') -----
assureSelectionsShow
"This is a workaround for the fact that a hierarchy browser, when launched, often does not show the selected class"
| saveCatIndex saveMsgIndex |
saveCatIndex := messageCategoryListIndex.
saveMsgIndex := messageListIndex.
self classListIndex: classListIndex.
self messageCategoryListIndex: saveCatIndex.
self messageListIndex: saveMsgIndex!
----- Method: HierarchyBrowser>>buildClassBrowserEditString: (in category 'menu messages') -----
buildClassBrowserEditString: aString
"Create and schedule a new class browser for the current selection, if one
exists, with initial textual contents set to aString."
self spawnHierarchy!
----- Method: HierarchyBrowser>>buildWith: (in category 'toolbuilder') -----
buildWith: builder
^builder build: (self openSystemCatEditString: '')!
----- Method: HierarchyBrowser>>changed: (in category 'initialization') -----
changed: sym
sym == #classList ifTrue: [self updateAfterClassChange].
super changed: sym!
----- Method: HierarchyBrowser>>classList (in category 'class list') -----
classList
classList := classList select: [:each | Smalltalk includesKey: each withBlanksTrimmed asSymbol].
^ classList!
----- Method: HierarchyBrowser>>classListIndex: (in category 'initialization') -----
classListIndex: newIndex
"Cause system organization to reflect appropriate category"
| newClassName ind |
newIndex ~= 0 ifTrue:
[newClassName := (classList at: newIndex) copyWithout: $ .
systemCategoryListIndex :=
systemOrganizer numberOfCategoryOfElement: newClassName].
ind := super classListIndex: newIndex.
self changed: #systemCategorySingleton.
^ ind!
----- Method: HierarchyBrowser>>defaultBrowserTitle (in category 'initialization') -----
defaultBrowserTitle
^ 'Hierarchy Browser'!
----- Method: HierarchyBrowser>>initAlphabeticListing (in category 'initialization') -----
initAlphabeticListing
| tab stab index |
self systemOrganizer: SystemOrganization.
metaClassIndicated := false.
classList := Smalltalk classNames.!
----- Method: HierarchyBrowser>>initHierarchyForClass: (in category 'initialization') -----
initHierarchyForClass: aClassOrMetaClass
| tab stab index nonMetaClass |
centralClass := aClassOrMetaClass.
nonMetaClass := aClassOrMetaClass theNonMetaClass.
self systemOrganizer: SystemOrganization.
metaClassIndicated := aClassOrMetaClass isMeta.
classList := OrderedCollection new.
tab := ''.
nonMetaClass allSuperclasses reverseDo:
[:aClass |
classList add: tab , aClass name.
tab := tab , ' '].
index := classList size + 1.
nonMetaClass allSubclassesWithLevelDo:
[:aClass :level |
stab := ''. 1 to: level do: [:i | stab := stab , ' '].
classList add: tab , stab , aClass name]
startingLevel: 0.
self classListIndex: index!
----- Method: HierarchyBrowser>>openEditString: (in category 'initialization') -----
openEditString: aString
"Create a pluggable version of all the views for a HierarchyBrowser, including views and controllers. The top list view is of the currently selected system class category--a single item list."
^ self openSystemCatEditString: aString!
----- Method: HierarchyBrowser>>potentialClassNames (in category 'initialization') -----
potentialClassNames
"Answer the names of all the classes that could be viewed in this browser"
^ self classList collect:
[:aName | aName copyWithout: $ ]!
----- Method: HierarchyBrowser>>removeSystemCategory (in category 'menu messages') -----
removeSystemCategory
"If a class category is selected, create a Confirmer so the user can
verify that the currently selected class category and all of its classes
should be removed from the system. If so, remove it."
self inform: 'Use a normal Browser, in which you can see
the entire category you are trying to remove.'!
----- Method: HierarchyBrowser>>selectClass: (in category 'initialization') -----
selectClass: classNotMeta
| name |
name := classNotMeta name.
self classListIndex: (self classList findFirst:
[:each | (each endsWith: name)
and: [each size = name size
or: [(each at: each size - name size) isSeparator]]])!
----- Method: HierarchyBrowser>>selectedClassName (in category 'initialization') -----
selectedClassName
"Answer the name of the class currently selected. di
bug fix for the case where name cannot be found -- return nil rather than halt"
| aName |
aName := self classList at: classListIndex ifAbsent: [^ nil].
^ (aName copyWithout: Character space) asSymbol!
----- Method: HierarchyBrowser>>systemCatSingletonKey:from: (in category 'menu messages') -----
systemCatSingletonKey: aChar from: aView
^ self systemCatListKey: aChar from: aView!
----- Method: HierarchyBrowser>>systemCatSingletonMenu: (in category 'menu messages') -----
systemCatSingletonMenu: aMenu
^ aMenu labels:
'find class... (f)
browse
printOut
fileOut
update
rename...
remove'
lines: #(1 4)
selections:
#(findClass buildSystemCategoryBrowser
printOutSystemCategory fileOutSystemCategory updateSystemCategories
renameSystemCategory removeSystemCategory )
!
----- Method: HierarchyBrowser>>systemCategorySingleton (in category 'initialization') -----
systemCategorySingleton
| cls |
cls := self selectedClass.
^ cls ifNil: [Array new]
ifNotNil: [Array with: cls category]!
----- Method: HierarchyBrowser>>updateAfterClassChange (in category 'initialization') -----
updateAfterClassChange
"It is possible that some the classes comprising the hierarchy have changed, so reinitialize the entire browser."
(centralClass notNil and: [centralClass isObsolete not])
ifTrue: [self initHierarchyForClass: centralClass]!
Browser subclass: #MessageSet
instanceVariableNames: 'messageList autoSelectString growable'
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Browser'!
!MessageSet commentStamp: '<historical>' prior: 0!
I represent a query path of the retrieval result of making a query about methods in the system. The result is a set of methods, denoted by a message selector and the class in which the method was found. As a StringHolder, the string I represent is the source code of the currently selected method. I am typically viewed in a Message Set Browser consisting of a MessageListView and a BrowserCodeView.!
MessageSet subclass: #ChangedMessageSet
instanceVariableNames: 'changeSet'
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Browser'!
!ChangedMessageSet commentStamp: '<historical>' prior: 0!
A ChangedMessageSet is a message set associated with a change-set; it bears an entry for every method added or changed in the change set, as well as for every class-comment of which the change-set bears a note.!
----- Method: ChangedMessageSet class>>openFor: (in category 'as yet unclassified') -----
openFor: aChangeSet
"Open up a ChangedMessageSet browser on the given change set; this is a conventional message-list browser whose message-list consists of all the methods in aChangeSet. After any method submission, the message list is refigured, making it plausibly dynamic"
| messageSet |
messageSet := aChangeSet changedMessageListAugmented select: [ :each | each isValid].
self
openMessageList: messageSet
name: 'Methods in Change Set ', aChangeSet name
autoSelect: nil
changeSet: aChangeSet!
----- Method: ChangedMessageSet class>>openMessageList:name:autoSelect:changeSet: (in category 'as yet unclassified') -----
openMessageList: messageList name: labelString autoSelect: autoSelectString changeSet: aChangeSet
| messageSet |
messageSet := self messageList: messageList.
messageSet changeSet: aChangeSet.
messageSet autoSelectString: autoSelectString.
ToolBuilder open: messageSet label: labelString.!
----- Method: ChangedMessageSet>>changeSet: (in category 'initialization') -----
changeSet: aChangeSet
changeSet := aChangeSet!
----- Method: ChangedMessageSet>>contents:notifying: (in category 'acceptance') -----
contents: aString notifying: aController
"Accept the string as new source for the current method, and make certain the annotation pane gets invalidated"
| existingSelector existingClass superResult newSelector |
existingSelector := self selectedMessageName.
existingClass := self selectedClassOrMetaClass.
superResult := super contents: aString notifying: aController.
superResult ifTrue: "succeeded"
[newSelector := existingClass parserClass new parseSelector: aString.
newSelector ~= existingSelector
ifTrue: "Selector changed -- maybe an addition"
[self reformulateList.
self changed: #messageList.
self messageList doWithIndex:
[:aMethodReference :anIndex |
(aMethodReference actualClass == existingClass and:
[aMethodReference methodSymbol == newSelector])
ifTrue:
[self messageListIndex: anIndex]]]].
^ superResult!
----- Method: ChangedMessageSet>>growable (in category 'message list') -----
growable
"Answer whether the receiver can be changed by manual additions & deletions"
^ false!
----- Method: ChangedMessageSet>>reformulateList (in category 'reformulation') -----
reformulateList
"Reformulate the message list of the receiver"
self initializeMessageList: (changeSet changedMessageListAugmented select:
[:each | each isValid])
!
MessageSet subclass: #MessageNames
instanceVariableNames: 'searchString selectorList selectorListIndex searchPane'
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Browser'!
----- Method: MessageNames class>>methodBrowserSearchingFor: (in category 'instance creation') -----
methodBrowserSearchingFor: searchString
"Answer an method-browser window whose search-string is initially as indicated"
| aWindow |
aWindow := self new searchString: searchString.
^ToolBuilder default build: aWindow!
----- Method: MessageNames class>>openMessageNames (in category 'instance creation') -----
openMessageNames
"Open a new instance of the receiver in the active world"
^ToolBuilder open: self new label: 'Message Names'
"MessageNames openMessageNames"
!
----- Method: MessageNames class>>prototypicalToolWindow (in category 'instance creation') -----
prototypicalToolWindow
"Answer an example of myself seen in a tool window, for the benefit of parts-launching tools"
^ self methodBrowserSearchingFor: nil!
----- Method: MessageNames class>>windowColorSpecification (in category 'window color') -----
windowColorSpecification
"Answer a WindowColorSpec object that declares my preference"
^ WindowColorSpec classSymbol: self name wording: 'Message Names' brightColor: #(0.645 1.0 0.452) pastelColor: #(0.843 0.976 0.843) helpMessage: 'A tool finding, viewing, and editing all methods whose names contiane a given character sequence.'!
----- Method: MessageNames>>buildSearchPaneWith: (in category 'toolbuilder') -----
buildSearchPaneWith: builder
| textSpec |
textSpec := builder pluggableInputFieldSpec new.
textSpec
model: self;
name: #search;
getText: #searchString;
setText: #searchString:notifying:.
^textSpec!
----- Method: MessageNames>>buildSelectorListWith: (in category 'toolbuilder') -----
buildSelectorListWith: builder
| listSpec |
listSpec := builder pluggableListSpec new.
listSpec
model: self;
list: #selectorList;
getIndex: #selectorListIndex;
setIndex: #selectorListIndex:;
menu: #selectorListMenu:;
keyPress: #selectorListKey:from:.
^listSpec
!
----- Method: MessageNames>>buildWith: (in category 'toolbuilder') -----
buildWith: builder
"ToolBuilder open: MessageNames new"
| windowSpec max buttonSpec result |
max := self wantsOptionalButtons ifTrue:[0.42] ifFalse:[0.5].
windowSpec := self buildWindowWith: builder specs: {
(0.15 at 0 corner: 0.5 at 0.08) -> [self buildSearchPaneWith: builder].
(0 at 0.08 corner: 0.5 at max) -> [self buildSelectorListWith: builder].
(0.5 at 0.0 corner: 1.0 at max) -> [self buildMessageListWith: builder].
(0 at max corner: 1 at 1) -> [self buildCodePaneWith: builder].
}.
buttonSpec := builder pluggableActionButtonSpec new.
buttonSpec
model: self;
label: 'Search';
action: [self doSearchFrom: searchPane];
frame: (0.0 at 0 corner: 0.15 at 0.08).
windowSpec children add: buttonSpec.
result := builder build: windowSpec.
searchPane := builder widgetAt: #search.
^result!
----- Method: MessageNames>>computeSelectorListFromSearchString (in category 'search') -----
computeSelectorListFromSearchString
"Compute selector list from search string"
| raw sorted |
searchString := searchString asString copyWithout: $ .
selectorList := Cursor wait
showWhile: [raw := Symbol selectorsContaining: searchString.
sorted := raw as: SortedCollection.
sorted
sortBlock: [:x :y | x asLowercase <= y asLowercase].
sorted asArray].
selectorList size > 19
ifFalse: ["else the following filtering is considered too expensive. This 19
should be a system-maintained Parameter, someday"
selectorList := self systemNavigation allSelectorsWithAnyImplementorsIn: selectorList].
^ selectorList!
----- Method: MessageNames>>copyName (in category 'message list menu') -----
copyName
"Copy the current selector to the clipboard"
| selector |
(selector := self selectorList at: selectorListIndex ifAbsent: [nil]) ifNotNil:
[Clipboard clipboardText: selector asString asText]!
----- Method: MessageNames>>doSearchFrom: (in category 'search') -----
doSearchFrom: aPane
"The user hit the Search button -- treat it as a synonym for the user having hit the Return or Enter (or cmd-s) in the type-in pane"
aPane accept.
aPane selectAll!
----- Method: MessageNames>>messageList (in category 'selector list') -----
messageList
"Answer the receiver's message list, computing it if necessary. The way
to force a recomputation is to set the messageList to nil"
messageList
ifNil: [messageList := selectorListIndex == 0
ifTrue: [#()]
ifFalse: [self systemNavigation
allImplementorsOf: (selectorList at: selectorListIndex)].
self
messageListIndex: (messageList size > 0
ifTrue: [1]
ifFalse: [0])].
^ messageList!
----- Method: MessageNames>>searchString (in category 'search') -----
searchString
"Answer the current searchString, initializing it if need be"
| pane |
searchString isEmptyOrNil ifTrue:
[searchString := 'type here, then hit Search'.
pane := self containingWindow findDeepSubmorphThat:
[:m | m knownName = 'Search'] ifAbsent: ["this happens during window creation" ^ searchString].
pane setText: searchString.
pane setTextMorphToSelectAllOnMouseEnter.
pane selectAll].
^ searchString!
----- Method: MessageNames>>searchString: (in category 'search') -----
searchString: aString
"Set the current searchString"
self searchString: aString notifying: nil!
----- Method: MessageNames>>searchString:notifying: (in category 'search') -----
searchString: aString notifying: aController
"Take what the user typed and find all selectors containing it"
searchString := aString asString copyWithout: $ .
self containingWindow ifNotNil:[:w| w setLabel: 'Message names containing "', searchString asLowercase, '"'].
selectorList := nil.
self changed: #selectorList.
self changed: #messageList.
^ true!
----- Method: MessageNames>>selection (in category 'selection') -----
selection
"Answer the item in the list that is currently selected, or nil if no selection is present"
^ self messageList at: messageListIndex ifAbsent: [nil]!
----- Method: MessageNames>>selectorList (in category 'selector list') -----
selectorList
"Answer the selectorList"
selectorList ifNil:
[self computeSelectorListFromSearchString.
selectorListIndex := selectorList size > 0
ifTrue: [1]
ifFalse: [0].
messageList := nil].
^ selectorList!
----- Method: MessageNames>>selectorListIndex (in category 'selector list') -----
selectorListIndex
"Answer the selectorListIndex"
^ selectorListIndex!
----- Method: MessageNames>>selectorListIndex: (in category 'selector list') -----
selectorListIndex: anInteger
"Set the selectorListIndex as specified, and propagate consequences"
selectorListIndex := anInteger.
selectorListIndex = 0
ifTrue: [^ self].
messageList := nil.
self changed: #selectorListIndex.
self changed: #messageList!
----- Method: MessageNames>>selectorListKey:from: (in category 'initialization') -----
selectorListKey: aChar from: view
"Respond to a Command key in the message-list pane."
aChar == $n ifTrue: [^ self browseSenders].
aChar == $c ifTrue: [^ self copyName].
aChar == $b ifTrue: [^ self browseMethodFull].
!
----- Method: MessageNames>>selectorListMenu: (in category 'selector list') -----
selectorListMenu: aMenu
"Answer the menu associated with the selectorList"
aMenu addList: #(
('senders (n)' browseSenders 'browse senders of the chosen selector')
('copy selector to clipboard' copyName 'copy the chosen selector to the clipboard, for subsequent pasting elsewhere')
-
('show only implemented selectors' showOnlyImplementedSelectors 'remove from the selector-list all symbols that do not represent implemented methods')).
^ aMenu!
----- Method: MessageNames>>selectorListMenuTitle (in category 'selector list') -----
selectorListMenuTitle
"Answer the title to supply for the menu belonging to the selector-list pane"
^ 'Click on any item in the list
to see all implementors of it'!
----- Method: MessageNames>>showOnlyImplementedSelectors (in category 'search') -----
showOnlyImplementedSelectors
"Caution -- can be slow!! Filter my selector list down such that it only
shows selectors that are actually implemented somewhere in the system."
self okToChange
ifTrue: [Cursor wait
showWhile: [selectorList := self systemNavigation allSelectorsWithAnyImplementorsIn: selectorList.
self changed: #selectorList.
self changed: #messageList]]!
----- Method: MessageSet class>>extantMethodsIn: (in category 'utilities') -----
extantMethodsIn: aListOfMethodRefs
"Answer the subset of the incoming list consisting only of those message markers that refer to methods actually in the current image"
self flag: #mref. "may be removed in second round"
^ aListOfMethodRefs select: [:aToken |
self
parse: aToken
toClassAndSelector: [ :aClass :aSelector |
aClass notNil and: [aClass includesSelector: aSelector]
]
]!
----- Method: MessageSet class>>isPseudoSelector: (in category 'utilities') -----
isPseudoSelector: aSelector
"Answer whether the given selector is a special marker"
^ #(Comment Definition Hierarchy) includes: aSelector!
----- Method: MessageSet class>>messageList: (in category 'instance creation') -----
messageList: anArray
"Answer an instance of me with message list anArray."
^self new initializeMessageList: anArray!
----- Method: MessageSet class>>open:name: (in category 'instance creation') -----
open: aMessageSet name: aString
"Create a standard system view for the messageSet, aMessageSet, whose label is aString."
^ToolBuilder open: aMessageSet label: aString!
----- Method: MessageSet class>>openMessageList:name: (in category 'instance creation') -----
openMessageList: anArray name: aString
"Create a standard system view for the message set on the list, anArray.
The label of the view is aString."
self open: (self messageList: anArray) name: aString!
----- Method: MessageSet class>>openMessageList:name:autoSelect: (in category 'instance creation') -----
openMessageList: messageList name: labelString autoSelect: autoSelectString
"Open a system view for a MessageSet on messageList.
1/24/96 sw: the there-are-no msg now supplied by my sender"
| messageSet |
messageSet := self messageList: messageList.
messageSet autoSelectString: autoSelectString.
^ToolBuilder open: messageSet label: labelString!
----- Method: MessageSet class>>parse:toClassAndSelector: (in category 'utilities') -----
parse: methodRef toClassAndSelector: csBlock
"Decode strings of the form <className> [class] <selectorName>."
| tuple cl |
self flag: #mref. "compatibility with pre-MethodReference lists"
methodRef ifNil: [^ csBlock value: nil value: nil].
(methodRef isKindOf: MethodReference) ifTrue: [
^methodRef setClassAndSelectorIn: csBlock
].
methodRef isEmpty ifTrue: [^ csBlock value: nil value: nil].
tuple := methodRef asString findTokens: ' .'.
cl := Smalltalk at: tuple first asSymbol ifAbsent: [^ csBlock value: nil value: nil].
(tuple size = 2 or: [tuple size > 2 and: [(tuple at: 2) ~= 'class']])
ifTrue: [^ csBlock value: cl value: (tuple at: 2) asSymbol]
ifFalse: [^ csBlock value: cl class value: (tuple at: 3) asSymbol]!
----- Method: MessageSet class>>windowColorSpecification (in category 'window color') -----
windowColorSpecification
"Answer a WindowColorSpec object that declares my preference"
^ WindowColorSpec classSymbol: self name wording: 'Message List' brightColor: #lightBlue pastelColor: #paleBlue helpMessage: 'A list of messages (e.g. senders, implementors)'!
----- Method: MessageSet>>aboutToStyle: (in category 'contents') -----
aboutToStyle: aStyler
"This is a notification that aStyler is about to re-style its text.
Set the classOrMetaClass in aStyler, so that identifiers
will be resolved correctly.
Answer true to allow styling to proceed, or false to veto the styling"
self isModeStyleable ifFalse: [^false].
aStyler classOrMetaClass: self selectedClassOrMetaClass.
^true!
----- Method: MessageSet>>addExtraShiftedItemsTo: (in category 'message list') -----
addExtraShiftedItemsTo: aMenu
"The shifted selector-list menu is being built. Add items specific to MessageSet"
self growable ifTrue:
[aMenu addList: #(
-
('remove from this browser' removeMessageFromBrowser)
('filter message list...' filterMessageList)
('add to message list...' augmentMessageList))].
aMenu add: 'sort by date' action: #sortByDate!
----- Method: MessageSet>>addItem: (in category 'message list') -----
addItem: classAndMethod
"Append a classAndMethod string to the list. Select the new item."
"Do some checks on the input?"
self okToChange ifFalse: [^ self].
messageList add: classAndMethod.
self changed: #messageList.
self messageListIndex: messageList size.!
----- Method: MessageSet>>adjustWindowTitleAfterFiltering (in category 'private') -----
adjustWindowTitleAfterFiltering
"Set the title of the receiver's window, if any, to reflect the just-completed filtering"
| aWindow existingLabel newLabel |
(aWindow := self containingWindow) ifNil: [^ self].
(existingLabel := aWindow label) isEmptyOrNil ifTrue: [^ self].
(((existingLabel size < 3) or: [existingLabel last ~~ $]]) or: [(existingLabel at: (existingLabel size - 1)) isDigit not]) ifTrue: [^ self].
existingLabel size to: 1 by: -1 do:
[:anIndex | ((existingLabel at: anIndex) == $[) ifTrue:
[newLabel := (existingLabel copyFrom: 1 to: anIndex),
'Filtered: ',
messageList size printString,
']'.
^ aWindow setLabel: newLabel]]
!
----- Method: MessageSet>>augmentMessageList (in category 'filtering') -----
augmentMessageList
"Allow the user to add to the list of messages."
self notYetImplemented
!
----- Method: MessageSet>>autoSelectString (in category 'private') -----
autoSelectString
"Return the string to be highlighted when making new selections"
^ autoSelectString!
----- Method: MessageSet>>autoSelectString: (in category 'private') -----
autoSelectString: aString
"Set the string to be highlighted when making new selections"
autoSelectString := aString!
----- Method: MessageSet>>buildWith: (in category 'toolbuilder') -----
buildWith: builder
| windowSpec max result |
self wantsOptionalButtons ifTrue:[max := 0.3] ifFalse:[max := 0.3].
windowSpec := self buildWindowWith: builder specs: {
(0 at 0 corner: 1 at max) -> [self buildMessageListWith: builder].
(0 at max corner: 1 at 1) -> [self buildCodePaneWith: builder].
}.
result := builder build: windowSpec.
autoSelectString ifNotNil:[self changed: #autoSelect].
^result!
----- Method: MessageSet>>canShowMultipleMessageCategories (in category 'message category functions') -----
canShowMultipleMessageCategories
"Answer whether the receiver is capable of showing multiple message categories"
^ false!
----- Method: MessageSet>>classCommentIndicated (in category 'metaclass') -----
classCommentIndicated
"Answer true iff we're viewing the class comment."
^ editSelection == #editComment or: [ self selectedMessageName == #Comment ]!
----- Method: MessageSet>>contents (in category 'contents') -----
contents
"Answer the contents of the receiver"
^ contents == nil
ifTrue: [currentCompiledMethod := nil. '']
ifFalse: [messageListIndex = 0
ifTrue: [currentCompiledMethod := nil. contents]
ifFalse: [self showingByteCodes
ifTrue: [self selectedBytecodes]
ifFalse: [self selectedMessage]]]!
----- Method: MessageSet>>contents:notifying: (in category 'private') -----
contents: aString notifying: aController
"Compile the code in aString. Notify aController of any syntax errors.
Answer false if the compilation fails. Otherwise, if the compilation
created a new method, deselect the current selection. Then answer true."
| category selector class oldSelector |
self okayToAccept ifFalse: [^ false].
self setClassAndSelectorIn: [:c :os | class := c. oldSelector := os].
class ifNil: [^ false].
(oldSelector ~~ nil and: [oldSelector first isUppercase]) ifTrue:
[oldSelector = #Comment ifTrue:
[class comment: aString stamp: Utilities changeStamp.
self changed: #annotation.
self clearUserEditFlag.
^ false].
oldSelector = #Definition ifTrue:
["self defineClass: aString notifying: aController."
class subclassDefinerClass
evaluate: aString
notifying: aController
logged: true.
self clearUserEditFlag.
^ false].
oldSelector = #Hierarchy ifTrue:
[self inform: 'To change the hierarchy, edit the class definitions'.
^ false]].
"Normal method accept"
category := class organization categoryOfElement: oldSelector.
selector := class compile: aString
classified: category
notifying: aController.
selector == nil ifTrue: [^ false].
self noteAcceptanceOfCodeFor: selector.
selector == oldSelector ifFalse:
[self reformulateListNoting: selector].
contents := aString copy.
self changed: #annotation.
^ true!
----- Method: MessageSet>>deleteFromMessageList: (in category 'message functions') -----
deleteFromMessageList: aMessage
"Delete the given message from the receiver's message list"
messageList := messageList copyWithout: aMessage!
----- Method: MessageSet>>dragPassengerFor:inMorph: (in category 'drag and drop') -----
dragPassengerFor: item inMorph: dragSource
| transferType |
transferType := self dragTransferTypeForMorph: dragSource.
transferType == #messageList
ifTrue: [^self selectedClassOrMetaClass->(item contents findTokens: ' ') second asSymbol].
transferType == #classList
ifTrue: [^self selectedClass].
^nil!
----- Method: MessageSet>>filterFrom: (in category 'filtering') -----
filterFrom: aBlock
"Filter the receiver's list down to only those items that satisfy aBlock, which takes a class an a selector as its arguments."
| newList |
newList := messageList select:
[:anElement |
self class parse: anElement toClassAndSelector: [ :cls :sel |
(self class isPseudoSelector: sel) not and: [ aBlock value: cls value: sel ]]].
self setFilteredList: newList!
----- Method: MessageSet>>filterMessageList (in category 'filtering') -----
filterMessageList
"Allow the user to refine the list of messages."
| aMenu evt |
Smalltalk isMorphic ifFalse: [^ self inform: 'sorry, morphic only at this time.'].
messageList size <= 1 ifTrue: [^ self inform: 'this is not a propitious filtering situation'].
"would like to get the evt coming in but thwarted by the setInvokingView: circumlocution"
evt := self currentWorld activeHand lastEvent.
aMenu := MenuMorph new defaultTarget: self.
aMenu addTitle: 'Filter by only showing...'.
aMenu addStayUpItem.
aMenu addList: #(
('unsent messages' filterToUnsentMessages 'filter to show only messages that have no senders')
-
('messages that send...' filterToSendersOf 'filter to show only messages that send a selector I specify')
('messages that do not send...' filterToNotSendersOf 'filter to show only messages that do not send a selector I specify')
-
('messages whose selector is...' filterToImplementorsOf 'filter to show only messages with a given selector I specify')
('messages whose selector is NOT...' filterToNotImplementorsOf 'filter to show only messages whose selector is NOT a seletor I specify')
-
('messages in current change set' filterToCurrentChangeSet 'filter to show only messages that are in the current change set')
('messages not in current change set' filterToNotCurrentChangeSet 'filter to show only messages that are not in the current change set')
-
('messages in any change set' filterToAnyChangeSet 'filter to show only messages that occur in at least one change set')
('messages not in any change set' filterToNotAnyChangeSet 'filter to show only messages that do not occur in any change set in the system')
-
('messages authored by me' filterToCurrentAuthor 'filter to show only messages whose authoring stamp has my initials')
('messages not authored by me' filterToNotCurrentAuthor 'filter to show only messages whose authoring stamp does not have my initials')
-
('messages logged in .changes file' filterToMessagesInChangesFile 'filter to show only messages whose latest source code is logged in the .changes file')
('messages only in .sources file' filterToMessagesInSourcesFile 'filter to show only messages whose latest source code is logged in the .sources file')
-
('messages with prior versions' filterToMessagesWithPriorVersions 'filter to show only messages that have at least one prior version')
('messages without prior versions' filterToMessagesWithoutPriorVersions 'filter to show only messages that have no prior versions')
-
('uncommented messages' filterToUncommentedMethods 'filter to show only messages that do not have comments at the beginning')
('commented messages' filterToCommentedMethods 'fileter to show only messages that have comments at the beginning')
-
('messages in hardened classes' filterToMessagesWithHardenedClasses 'filter to show only messages of established classes (as opposed to Uniclasses such as Player23)')
-
('messages that...' filterToMessagesThat 'let me type in a block taking a class and a selector, which will specify yea or nay concerning which elements should remain in the list')
).
aMenu popUpEvent: evt hand lastEvent in: evt hand world.!
----- Method: MessageSet>>filterToAnyChangeSet (in category 'filtering') -----
filterToAnyChangeSet
"Filter down only to messages present in ANY change set"
self filterFrom:
[:aClass :aSelector |
ChangesOrganizer doesAnyChangeSetHaveClass: aClass andSelector: aSelector]
!
----- Method: MessageSet>>filterToCommentedMethods (in category 'filtering') -----
filterToCommentedMethods
"Filter the receiver's list down to only those items which have comments"
self filterFrom:
[:aClass :aSelector |
(aClass selectors includes: aSelector) and:
[(aClass firstPrecodeCommentFor: aSelector) isEmptyOrNil not]]!
----- Method: MessageSet>>filterToCurrentAuthor (in category 'filtering') -----
filterToCurrentAuthor
"Filter down only to messages with my initials as most recent author"
| myInitials aMethod aTimeStamp |
(myInitials := Utilities authorInitialsPerSe) ifNil: [^ self inform: 'No author initials set in this image'].
self filterFrom:
[:aClass :aSelector |
(aClass notNil and: [aSelector notNil]) and:
[aMethod := aClass compiledMethodAt: aSelector ifAbsent: [nil].
aMethod notNil and:
[(aTimeStamp := Utilities timeStampForMethod: aMethod) notNil and:
[aTimeStamp beginsWith: myInitials]]]]!
----- Method: MessageSet>>filterToCurrentChangeSet (in category 'filtering') -----
filterToCurrentChangeSet
"Filter the receiver's list down to only those items in the current change set"
self filterFrom:
[:aClass :aSelector |
(aClass notNil and: [aSelector notNil]) and:
[(ChangeSet current atSelector: aSelector class: aClass) ~~ #none]]!
----- Method: MessageSet>>filterToImplementorsOf (in category 'filtering') -----
filterToImplementorsOf
"Filter the receiver's list down to only those items with a given selector"
| aFragment inputWithBlanksTrimmed |
aFragment := UIManager default request: 'type selector:' initialAnswer: ''.
aFragment isEmptyOrNil ifTrue: [^ self].
inputWithBlanksTrimmed := aFragment withBlanksTrimmed.
Symbol hasInterned: inputWithBlanksTrimmed ifTrue:
[:aSymbol |
self filterFrom:
[:aClass :aSelector |
aSelector == aSymbol]]!
----- Method: MessageSet>>filterToMessagesInChangesFile (in category 'filtering') -----
filterToMessagesInChangesFile
"Filter down only to messages whose source code risides in the Changes file. This allows one to ignore long-standing methods that live in the .sources file."
| cm |
self filterFrom:
[:aClass :aSelector |
aClass notNil and: [aSelector notNil and:
[(self class isPseudoSelector: aSelector) not and:
[(cm := aClass compiledMethodAt: aSelector ifAbsent: [nil]) notNil and:
[cm fileIndex ~~ 1]]]]]!
----- Method: MessageSet>>filterToMessagesInSourcesFile (in category 'filtering') -----
filterToMessagesInSourcesFile
"Filter down only to messages whose source code resides in the .sources file."
| cm |
self filterFrom: [:aClass :aSelector |
(aClass notNil and: [aSelector notNil]) and:
[(self class isPseudoSelector: aSelector) not and:
[(cm := aClass compiledMethodAt: aSelector ifAbsent: [nil]) notNil and:
[cm fileIndex == 1]]]]!
----- Method: MessageSet>>filterToMessagesThat (in category 'filtering') -----
filterToMessagesThat
"Allow the user to type in a block which will be"
| reply |
reply := UIManager default
multiLineRequest: 'Type your block here'
centerAt: Sensor cursorPoint
initialAnswer: '[:aClass :aSelector |
]'
answerHeight: 200.
reply isEmptyOrNil ifTrue: [^ self].
self filterFrom: (Compiler evaluate: reply)
!
----- Method: MessageSet>>filterToMessagesWithHardenedClasses (in category 'filtering') -----
filterToMessagesWithHardenedClasses
"Filter the receiver's list down to only those items representing methods of hardened classes, as opposed to uniclasses"
self filterFrom:
[:aClass :aSelector |
(aClass notNil and: [aSelector notNil]) and:
[aClass isUniClass not]]!
----- Method: MessageSet>>filterToMessagesWithPriorVersions (in category 'filtering') -----
filterToMessagesWithPriorVersions
"Filter down only to messages which have at least one prior version"
self filterFrom:
[:aClass :aSelector |
(aClass notNil and: [aSelector notNil]) and:
[(self class isPseudoSelector: aSelector) not and:
[(VersionsBrowser versionCountForSelector: aSelector class: aClass) > 1]]]!
----- Method: MessageSet>>filterToMessagesWithoutPriorVersions (in category 'filtering') -----
filterToMessagesWithoutPriorVersions
"Filter down only to messages which have no prior version stored"
self filterFrom:
[:aClass :aSelector |
(aClass notNil and: [aSelector notNil]) and:
[(self class isPseudoSelector: aSelector) not and:
[(VersionsBrowser versionCountForSelector: aSelector class: aClass) <= 1]]]!
----- Method: MessageSet>>filterToNotAnyChangeSet (in category 'filtering') -----
filterToNotAnyChangeSet
"Filter down only to messages present in NO change set"
self filterFrom:
[:aClass :aSelector |
(ChangesOrganizer doesAnyChangeSetHaveClass: aClass andSelector: aSelector) not]
!
----- Method: MessageSet>>filterToNotCurrentAuthor (in category 'filtering') -----
filterToNotCurrentAuthor
"Filter down only to messages not stamped with my initials"
| myInitials aMethod aTimeStamp |
(myInitials := Utilities authorInitialsPerSe) ifNil: [^ self inform: 'No author initials set in this image'].
self filterFrom:
[:aClass :aSelector |
(aClass notNil and: [aSelector notNil]) and:
[aMethod := aClass compiledMethodAt: aSelector ifAbsent: [nil].
aMethod notNil and:
[(aTimeStamp := Utilities timeStampForMethod: aMethod) isNil or:
[(aTimeStamp beginsWith: myInitials) not]]]]!
----- Method: MessageSet>>filterToNotCurrentChangeSet (in category 'filtering') -----
filterToNotCurrentChangeSet
"Filter the receiver's list down to only those items not in the current change set"
self filterFrom:
[:aClass :aSelector |
(aClass notNil and: [aSelector notNil]) and:
[(ChangeSet current atSelector: aSelector class: aClass) == #none]]!
----- Method: MessageSet>>filterToNotImplementorsOf (in category 'filtering') -----
filterToNotImplementorsOf
"Filter the receiver's list down to only those items whose selector is NOT one solicited from the user."
| aFragment inputWithBlanksTrimmed |
aFragment := UIManager default request: 'type selector: ' initialAnswer: ''.
aFragment isEmptyOrNil ifTrue: [^ self].
inputWithBlanksTrimmed := aFragment withBlanksTrimmed.
Symbol hasInterned: inputWithBlanksTrimmed ifTrue:
[:aSymbol |
self filterFrom:
[:aClass :aSelector |
aSelector ~~ aSymbol]]!
----- Method: MessageSet>>filterToNotSendersOf (in category 'filtering') -----
filterToNotSendersOf
"Filter the receiver's list down to only those items which do not send a given selector"
| aFragment inputWithBlanksTrimmed aMethod |
aFragment := UIManager default request: 'type selector:' initialAnswer: ''.
aFragment isEmptyOrNil ifTrue: [^ self].
inputWithBlanksTrimmed := aFragment withBlanksTrimmed.
Symbol hasInterned: inputWithBlanksTrimmed ifTrue:
[:aSymbol |
self filterFrom:
[:aClass :aSelector |
(aMethod := aClass compiledMethodAt: aSelector) isNil or:
[(aMethod hasLiteralThorough: aSymbol) not]]]!
----- Method: MessageSet>>filterToSendersOf (in category 'filtering') -----
filterToSendersOf
"Filter the receiver's list down to only those items which send a given selector"
| aFragment inputWithBlanksTrimmed aMethod |
aFragment := UIManager default request: 'type selector:' initialAnswer: ''.
aFragment isEmptyOrNil ifTrue: [^ self].
inputWithBlanksTrimmed := aFragment withBlanksTrimmed.
Symbol hasInterned: inputWithBlanksTrimmed ifTrue:
[:aSymbol |
self filterFrom:
[:aClass :aSelector |
(aMethod := aClass compiledMethodAt: aSelector) notNil and:
[aMethod hasLiteralThorough: aSymbol]]]
!
----- Method: MessageSet>>filterToUncommentedMethods (in category 'filtering') -----
filterToUncommentedMethods
"Filter the receiver's list down to only those items which lack comments"
self filterFrom:
[:aClass :aSelector |
(aClass selectors includes: aSelector) and:
[(aClass firstPrecodeCommentFor: aSelector) isEmptyOrNil]]!
----- Method: MessageSet>>filterToUnsentMessages (in category 'filtering') -----
filterToUnsentMessages
"Filter the receiver's list down to only those items which have no
senders"
self
filterFrom: [:aClass :aSelector | (self systemNavigation allCallsOn: aSelector) isEmpty]!
----- Method: MessageSet>>growable (in category 'message list') -----
growable
"Answer whether the receiver is capable of growing/shrinking dynamically"
^ growable ~~ false!
----- Method: MessageSet>>growable: (in category 'message list') -----
growable: aBoolean
"Give or take away the growable trait; when a message set is growable, methods submitted within it will be added to its message list"
growable := aBoolean!
----- Method: MessageSet>>initializeMessageList: (in category 'private') -----
initializeMessageList: anArray
"Initialize my messageList from the given list of MethodReference or string objects. NB: special handling for uniclasses."
| s |
messageList := OrderedCollection new.
anArray do: [ :each |
MessageSet
parse: each
toClassAndSelector: [ :class :sel |
class ifNotNil:
[class isUniClass
ifTrue:
[s := class typicalInstanceName, ' ', sel]
ifFalse:
[s := class name , ' ' , sel , ' {' ,
((class organization categoryOfElement: sel) ifNil: ['']) , '}'].
messageList add: (
MethodReference new
setClass: class
methodSymbol: sel
stringVersion: s)]]].
messageListIndex := messageList isEmpty ifTrue: [0] ifFalse: [1].
contents := ''!
----- Method: MessageSet>>messageList (in category 'message list') -----
messageList
"Answer the current list of messages."
^messageList!
----- Method: MessageSet>>messageListIndex: (in category 'message list') -----
messageListIndex: anInteger
"Set the index of the selected item to be anInteger."
messageListIndex := anInteger.
contents :=
messageListIndex ~= 0
ifTrue: [self selectedMessage]
ifFalse: [''].
self changed: #messageListIndex. "update my selection"
self editSelection: #editMessage.
self contentsChanged.
(messageListIndex ~= 0 and: [autoSelectString notNil])
ifTrue: [self changed: #autoSelect].
self decorateButtons
!
----- Method: MessageSet>>metaClassIndicated (in category 'class list') -----
metaClassIndicated
"Answer the boolean flag that indicates whether
this is a class method."
^ self selectedClassOrMetaClass isMeta!
----- Method: MessageSet>>methodCategoryChanged (in category 'message functions') -----
methodCategoryChanged
self changed: #annotation!
----- Method: MessageSet>>optionalButtonHeight (in category 'message list') -----
optionalButtonHeight
^ 15!
----- Method: MessageSet>>reformulateList (in category 'message functions') -----
reformulateList
"The receiver's messageList has been changed; rebuild it"
super reformulateList.
self initializeMessageList: messageList.
self changed: #messageList.
self changed: #messageListIndex.
self contentsChanged
!
----- Method: MessageSet>>removeMessage (in category 'message functions') -----
removeMessage
"Remove the selected message from the system. 1/15/96 sw"
| messageName confirmation |
messageListIndex = 0
ifTrue: [^ self].
self okToChange
ifFalse: [^ self].
messageName := self selectedMessageName.
confirmation := self systemNavigation confirmRemovalOf: messageName on: self selectedClassOrMetaClass.
confirmation == 3
ifTrue: [^ self].
self selectedClassOrMetaClass removeSelector: messageName.
self deleteFromMessageList: self selection.
self reformulateList.
confirmation == 2
ifTrue: [self systemNavigation browseAllCallsOn: messageName]!
----- Method: MessageSet>>removeMessageFromBrowser (in category 'message functions') -----
removeMessageFromBrowser
"Remove the selected message from the browser."
messageListIndex = 0 ifTrue: [^ self].
self deleteFromMessageList: self selection.
self reformulateList.
self adjustWindowTitleAfterFiltering
!
----- Method: MessageSet>>selectedClass (in category 'class list') -----
selectedClass
"Return the base class for the current selection. 1/17/96 sw fixed up so that it doesn't fall into a debugger in a msg browser that has no message selected"
| aClass |
^ (aClass := self selectedClassOrMetaClass) == nil
ifTrue:
[nil]
ifFalse:
[aClass theNonMetaClass]!
----- Method: MessageSet>>selectedClassName (in category 'class list') -----
selectedClassName
"Answer the name of class of the currently selected message. Answer nil if no selection
exists."
| cls |
(cls := self selectedClass) ifNil: [^ nil].
^ cls name!
----- Method: MessageSet>>selectedClassOrMetaClass (in category 'class list') -----
selectedClassOrMetaClass
"Answer the currently selected class (or metaclass)."
messageListIndex = 0 ifTrue: [^nil].
self setClassAndSelectorIn: [:c :s | ^c]!
----- Method: MessageSet>>selectedMessage (in category 'contents') -----
selectedMessage
"Answer the source method for the currently selected message."
| source |
self setClassAndSelectorIn: [:class :selector |
class ifNil: [^ 'Class vanished'].
selector first isUppercase ifTrue:
[selector == #Comment ifTrue:
[currentCompiledMethod := class organization commentRemoteStr.
^ class comment].
selector == #Definition ifTrue:
[^ class definitionST80].
selector == #Hierarchy ifTrue: [^ class printHierarchy]].
source := class sourceMethodAt: selector ifAbsent:
[currentCompiledMethod := nil.
^ 'Missing'].
self showingDecompile ifTrue: [^ self decompiledSourceIntoContents].
currentCompiledMethod := class compiledMethodAt: selector ifAbsent: [nil].
self showingDocumentation ifTrue: [^ self commentContents].
source := self sourceStringPrettifiedAndDiffed.
^ source asText makeSelectorBoldIn: class]!
----- Method: MessageSet>>selectedMessageCategoryName (in category 'class list') -----
selectedMessageCategoryName
"Answer the name of the selected message category or nil."
messageListIndex = 0 ifTrue: [^ nil].
^ self selectedClassOrMetaClass organization categoryOfElement: self selectedMessageName!
----- Method: MessageSet>>selectedMessageName (in category 'message list') -----
selectedMessageName
"Answer the name of the currently selected message."
"wod 6/16/1998: answer nil if none are selected."
messageListIndex = 0 ifTrue: [^ nil].
^ self setClassAndSelectorIn: [:class :selector | ^ selector]!
----- Method: MessageSet>>selection (in category 'private') -----
selection
"Answer the item in the list that is currently selected, or nil if no selection is present"
^ messageList at: messageListIndex ifAbsent: [nil]!
----- Method: MessageSet>>setClassAndSelectorIn: (in category 'private') -----
setClassAndSelectorIn: csBlock
| sel |
"Decode strings of the form <className> [class] <selectorName>."
self flag: #mref. "compatibility with pre-MethodReference lists"
sel := self selection.
^(sel isKindOf: MethodReference) ifTrue: [
sel setClassAndSelectorIn: csBlock
] ifFalse: [
MessageSet parse: sel toClassAndSelector: csBlock
]!
----- Method: MessageSet>>setContentsToForceRefetch (in category 'contents') -----
setContentsToForceRefetch
"Set the receiver's contents such that on the next update the contents will be formulated afresh. This is a critical and obscure difference between Browsers on the one hand and MessageSets on the other, and has over the years been the source of much confusion and much difficulty. By centralizing the different handling here, we don't need so many idiosyncratic overrides in MessageSet any more"
contents := ''!
----- Method: MessageSet>>setFilteredList: (in category 'private') -----
setFilteredList: newList
"Establish newList as the new list if appropriate, and adjust the window title accordingly; if the new list is of the same size as the old, warn and do nothing"
newList size == 0
ifTrue:
[^ self inform: 'Nothing would be left in the list if you did that'].
newList size == messageList size
ifTrue:
[^ self inform: 'That leaves the list unchanged'].
self initializeMessageList: newList.
self adjustWindowTitleAfterFiltering!
----- Method: MessageSet>>sortByDate (in category 'message list') -----
sortByDate
"Sort the message-list by date of time-stamp"
| assocs aCompiledMethod aDate inOrder |
assocs := messageList collect:
[:aRef |
aDate := aRef methodSymbol == #Comment
ifTrue:
[aRef actualClass organization dateCommentLastSubmitted]
ifFalse:
[aCompiledMethod := aRef actualClass compiledMethodAt: aRef methodSymbol ifAbsent: [nil].
aCompiledMethod ifNotNil: [aCompiledMethod dateMethodLastSubmitted]].
aRef -> (aDate ifNil: [Date fromString: '01/01/1996'])]. "The dawn of Squeak history"
inOrder := assocs asSortedCollection:
[:a :b | a value < b value].
messageList := inOrder asArray collect: [:assoc | assoc key].
self changed: #messageList!
MessageSet subclass: #ProtocolBrowser
instanceVariableNames: 'selectedClass selectedSelector'
classVariableNames: 'TextMenu'
poolDictionaries: ''
category: 'Tools-Browser'!
!ProtocolBrowser commentStamp: '<historical>' prior: 0!
An instance of ProtocolBrowser shows the methods a class understands--inherited or implemented at this level--as a "flattened" list.!
ProtocolBrowser subclass: #Lexicon
instanceVariableNames: 'currentVocabulary categoryList categoryListIndex targetClass limitClass currentQuery currentQueryParameter selectorsVisited'
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Protocols'!
!Lexicon commentStamp: '<historical>' prior: 0!
An instance of Lexicon shows the a list of all the method categories known to an object or any of its superclasses, as a "flattened" list, and, within any selected category, shows all methods understood by the class's instances which are associated with that category, again as a "flattened" list. A variant with a search pane rather than a category list is also implemented.
categoryList the list of categories
categoryListIndex index of currently-selected category
targetObject optional -- an instance being viewed
targetClass the class being viewed
lastSearchString the last string searched for
lastSendersSearchSelector the last senders search selector
limitClass optional -- the limit class to search for
selectorsVisited list of selectors visited
selectorsActive not presently in use, subsumed by selectorsVisited
currentVocabulary the vocabulary currently installed
currentQuery what the query category relates to:
#senders #selectorName #currentChangeSet!
Lexicon subclass: #InstanceBrowser
instanceVariableNames: 'objectViewed'
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Protocols'!
----- Method: InstanceBrowser class>>windowColorSpecification (in category 'window color') -----
windowColorSpecification
"Answer a WindowColorSpec object that declares my preference"
^ WindowColorSpec classSymbol: self name wording: 'Instance Browser' brightColor: #(0.806 1.0 1.0) pastelColor: #(0.925 1.000 1.0) helpMessage: 'A tool for browsing the full protocol of an instance.'!
----- Method: InstanceBrowser>>inspectViewee (in category 'menu commands') -----
inspectViewee
"Open an Inspector on the object I view"
objectViewed inspect!
----- Method: InstanceBrowser>>offerMenu (in category 'menu commands') -----
offerMenu
"Offer a menu to the user, in response to the hitting of the menu button on the tool pane"
| aMenu |
aMenu := MenuMorph new defaultTarget: self.
aMenu title: 'Messages of ', objectViewed nameForViewer.
aMenu addStayUpItem.
aMenu addList: #(
('vocabulary...' chooseVocabulary)
('what to show...' offerWhatToShowMenu)
-
('inst var refs (here)' setLocalInstVarRefs)
('inst var defs (here)' setLocalInstVarDefs)
('class var refs (here)' setLocalClassVarRefs)
-
('navigate to a sender...' navigateToASender)
('recent...' navigateToRecentMethod)
('show methods in current change set'
showMethodsInCurrentChangeSet)
('show methods with initials...'
showMethodsWithInitials)
-
"('toggle search pane' toggleSearch)"
-
-
('browse full (b)' browseMethodFull)
('browse hierarchy (h)' classHierarchy)
('browse method (O)' openSingleMessageBrowser)
('browse protocol (p)' browseFullProtocol)
-
('fileOut' fileOutMessage)
('printOut' printOutMessage)
-
('senders of... (n)' browseSendersOfMessages)
('implementors of... (m)' browseMessages)
('versions (v)' browseVersions)
('inheritance (i)' methodHierarchy)
-
('inst var refs' browseInstVarRefs)
('inst var defs' browseInstVarDefs)
('class var refs' browseClassVarRefs)
-
('viewer on me' viewViewee)
('inspector on me' inspectViewee)
-
('more...' shiftedYellowButtonActivity)).
aMenu popUpInWorld: ActiveWorld!
----- Method: InstanceBrowser>>openOnObject:inWorld:showingSelector: (in category 'initialization') -----
openOnObject: anObject inWorld: ignored showingSelector: aSelector
"Create and open a SystemWindow to house the receiver, showing the categories pane."
^self openOnObject: anObject showingSelector: aSelector!
----- Method: InstanceBrowser>>openOnObject:showingSelector: (in category 'initialization') -----
openOnObject: anObject showingSelector: aSelector
"Create and open a SystemWindow to house the receiver, showing the categories pane."
objectViewed := anObject.
self openOnClass: anObject class showingSelector: aSelector!
----- Method: InstanceBrowser>>startingWindowTitle (in category 'window title') -----
startingWindowTitle
"Answer the initial window title to apply"
^ 'Vocabulary of ', objectViewed nameForViewer!
----- Method: InstanceBrowser>>targetObject (in category 'target-object access') -----
targetObject
"Answer the object to which this tool is bound"
^ objectViewed!
----- Method: InstanceBrowser>>viewViewee (in category 'menu commands') -----
viewViewee
"Open a viewer on the object I view"
objectViewed beViewed!
----- Method: Lexicon class>>activeCategoryName (in category 'visible category names') -----
activeCategoryName
"Answer the name to be used for the active-methods category"
true ifTrue: [^ #'-- current working set --'].
'-- current working set --' asSymbol "Placed here so a message-strings-containing-it query will find this method"
!
----- Method: Lexicon class>>allCategoryName (in category 'visible category names') -----
allCategoryName
"Answer the name to be used for the all category"
true ifTrue: [^ #'-- all --'].
'-- all --' asSymbol "Placed here so a message-strings-containing-it query will find this method"
!
----- Method: Lexicon class>>queryCategoryName (in category 'visible category names') -----
queryCategoryName
"Answer the name to be used for the query-results category"
true ifTrue: [^ #'-- query results --'].
^ '-- query results --' asSymbol "Placed here so a message-strings-containing-it query will find this method"!
----- Method: Lexicon class>>sendersCategoryName (in category 'visible category names') -----
sendersCategoryName
"Answer the name to be used for the senders-results category"
true ifTrue: [^ #'-- "senders" results --'].
^ '-- "senders" results --'. "so methods-strings-containing will find this"!
----- Method: Lexicon class>>viewedCategoryName (in category 'visible category names') -----
viewedCategoryName
"Answer the name to be used for the previously-viewed-methods category"
true ifTrue: [^ #'-- active --'].
^ '-- active --' asSymbol "For benefit of method-strings-containing-it search"
!
----- Method: Lexicon class>>windowColorSpecification (in category 'window color') -----
windowColorSpecification
"Answer a WindowColorSpec object that declares my preference"
^ WindowColorSpec classSymbol: self name wording: 'Lexicon' brightColor: #(0.878 1.000 0.878) pastelColor: #(0.925 1.000 0.925) helpMessage: 'A tool for browsing the full protocol of a class.'!
----- Method: Lexicon>>addModelItemsToWindowMenu: (in category 'window title') -----
addModelItemsToWindowMenu: aMenu
"Add model-related item to the window menu"
super addModelItemsToWindowMenu: aMenu.
aMenu add: 'choose vocabulary...' target: self action: #chooseVocabulary!
----- Method: Lexicon>>addSpecialButtonsTo:with: (in category 'toolbuilder') -----
addSpecialButtonsTo: buttonPanelSpec with: builder
| homeCatBtnSpec menuBtnSpec mostGenericBtnSpec |
homeCatBtnSpec := builder pluggableButtonSpec new
model: self;
action: #showHomeCategory;
label: (ScriptingSystem formAtKey: #Cat) asMorph;
help: 'show this method''s home category';
yourself.
menuBtnSpec := builder pluggableButtonSpec new
model: self;
action: #offerMenu;
label: (ScriptingSystem formAtKey: #TinyMenu) asMorph;
help: 'click here to get a menu with further options';
yourself.
mostGenericBtnSpec :=builder pluggableButtonSpec new
model: self;
action: #chooseLimitClass;
label: #limitClassString;
help: 'Governs which classes'' methods should be shown. If this is the same as the viewed class, then only methods implemented in that class will be shown. If it is ProtoObject, then methods of all classes in the vocabulary will be shown.'.
buttonPanelSpec children
add: homeCatBtnSpec;
addFirst: mostGenericBtnSpec;
addFirst: menuBtnSpec.!
----- Method: Lexicon>>adjustWindowTitle (in category 'window title') -----
adjustWindowTitle
"Set the title of the receiver's window, if any, to reflect the current choices"
| aWindow aLabel catName |
(catName := self selectedCategoryName) ifNil: [^ self].
(aWindow := self containingWindow) ifNil: [^ self].
aLabel := nil.
#( (viewedCategoryName 'Messages already viewed - ')
(allCategoryName 'All messages - ')) do:
[:aPair | catName = (self categoryWithNameSpecifiedBy: aPair first) ifTrue: [aLabel := aPair second]].
aLabel ifNil:
[aLabel := catName = self class queryCategoryName
ifTrue:
[self queryCharacterization, ' - ']
ifFalse:
['Vocabulary of ']].
aWindow setLabel: aLabel, (self targetObject ifNil: [targetClass]) nameForViewer!
----- Method: Lexicon>>annotation (in category 'basic operation') -----
annotation
"Provide a line of annotation material for a middle pane."
| aCategoryName |
self selectedMessageName ifNotNil: [^ super annotation].
(aCategoryName := self selectedCategoryName) ifNil:
[^ self hasSearchPane
ifTrue:
['type a message name or fragment in the top pane and hit RETURN or ENTER']
ifFalse:
['' "currentVocabulary documentation"]].
(aCategoryName = self class queryCategoryName) ifTrue:
[^ self queryCharacterization].
#(
(allCategoryName 'Shows all methods, whatever other category they belong to')
(viewedCategoryName 'Methods visited recently. Use "-" button to remove a method from this category.')
(queryCategoryName 'Query results'))
do:
[:pair | (self categoryWithNameSpecifiedBy: pair first) = aCategoryName ifTrue: [^ pair second]].
^ currentVocabulary categoryCommentFor: aCategoryName!
----- Method: Lexicon>>browseClassVarRefs (in category 'new-window queries') -----
browseClassVarRefs
"Let the search pertain to the target class regardless of selection"
self systemNavigation browseClassVarRefs: targetClass theNonMetaClass !
----- Method: Lexicon>>browseInstVarDefs (in category 'new-window queries') -----
browseInstVarDefs
"Let the search pertain to the target class regardless of selection"
self systemNavigation browseInstVarDefs: targetClass!
----- Method: Lexicon>>browseInstVarRefs (in category 'new-window queries') -----
browseInstVarRefs
"Let the search pertain to the target class regardless of selection"
self systemNavigation browseInstVarRefs: targetClass!
----- Method: Lexicon>>buildCategoryListWith: (in category 'toolbuilder') -----
buildCategoryListWith: builder
| listSpec |
listSpec := builder pluggableListSpec new.
listSpec
model: self;
list: #categoryList;
getIndex: #categoryListIndex;
setIndex: #categoryListIndex:;
menu: #categoryListMenu:shifted:;
keyPress: #categoryListKey:from:.
^listSpec!
----- Method: Lexicon>>buildCodePaneWith: (in category 'toolbuilder') -----
buildCodePaneWith: builder
| spec standardButtonPanel codePane customPanelSpec |
spec := super buildCodePaneWith: builder.
standardButtonPanel := spec children
detect: [:ea | ea isKindOf: PluggablePanelSpec]
ifNone: [^ spec]. "do nothing if optionalButtons not enabled"
customPanelSpec := self buildCustomButtonsWith: builder.
customPanelSpec frame: (0 at 0.12 corner: 1 at 0.24).
spec children add: customPanelSpec after: standardButtonPanel.
"resize code pane so that new panel fits in"
codePane := spec children detect: [:ea | ea isKindOf: PluggableCodePaneSpec].
codePane frame: (codePane frame withTop: 0.24).
^ spec.!
----- Method: Lexicon>>buildCustomButtonsWith: (in category 'toolbuilder') -----
buildCustomButtonsWith: builder
"This method if very similar to StringHolder>>buildOptionalButtonsWith:.
Refactor and pass in button specs?"
| panelSpec buttonSpec |
panelSpec := builder pluggablePanelSpec new.
panelSpec children: OrderedCollection new.
self customButtonSpecs do: [:spec |
buttonSpec := builder pluggableActionButtonSpec new.
buttonSpec model: self.
buttonSpec label: spec first.
buttonSpec action: spec second.
spec size > 2 ifTrue: [buttonSpec help: spec third].
panelSpec children add: buttonSpec.
].
panelSpec layout: #horizontal. "buttons"
self addSpecialButtonsTo: panelSpec with: builder.
^panelSpec!
----- Method: Lexicon>>buildWith: (in category 'toolbuilder') -----
buildWith: builder
"Create the ui for the browser"
| windowSpec max |
max := self wantsOptionalButtons ifTrue:[0.32] ifFalse:[0.4].
windowSpec := self buildWindowWith: builder specs: {
(0 at 0 corner: 0.5 at max) -> [self buildCategoryListWith: builder].
(0.5 at 0 corner: 1 at max) -> [self buildMessageListWith: builder].
(0 at max corner: 1 at 1) -> [self buildCodePaneWith: builder].
}.
^builder build: windowSpec!
----- Method: Lexicon>>canShowMultipleMessageCategories (in category 'message category functions') -----
canShowMultipleMessageCategories
"Answer whether the receiver is capable of showing multiple message categories"
^ true!
----- Method: Lexicon>>categoriesPane (in category 'category list') -----
categoriesPane
"If there is a pane defined by #categoryList in my containing window, answer it, else answer nil"
^ self listPaneWithSelector: #categoryList!
----- Method: Lexicon>>categoryDefiningSelector: (in category 'category list') -----
categoryDefiningSelector: aSelector
"Answer a category in which aSelector occurs"
| categoryNames |
categoryNames := categoryList copyWithoutAll: #('-- all --').
^ currentVocabulary categoryWithNameIn: categoryNames thatIncludesSelector: aSelector forInstance: self targetObject ofClass: targetClass!
----- Method: Lexicon>>categoryList (in category 'category list') -----
categoryList
"Answer the category list for the protcol, creating it if necessary, and prepending the -- all -- category, and appending the other special categories for search results, etc."
| specialCategoryNames |
categoryList ifNil:
[specialCategoryNames := #(queryCategoryName viewedCategoryName "searchCategoryName sendersCategoryName changedCategoryName activeCategoryName") collect:
[:sym | self class perform: sym].
categoryList :=
(currentVocabulary categoryListForInstance: self targetObject ofClass: targetClass limitClass: limitClass),
specialCategoryNames,
(Array with: self class allCategoryName)].
^ categoryList!
----- Method: Lexicon>>categoryListIndex (in category 'category list') -----
categoryListIndex
"Answer the index of the currently-selected item in in the category list"
^ categoryListIndex ifNil: [categoryListIndex := 1]!
----- Method: Lexicon>>categoryListIndex: (in category 'category list') -----
categoryListIndex: anIndex
"Set the category list index as indicated"
| categoryName aList found existingSelector |
existingSelector := self selectedMessageName.
categoryListIndex := anIndex.
anIndex > 0
ifTrue:
[categoryName := categoryList at: anIndex]
ifFalse:
[contents := nil].
self changed: #categoryListIndex.
found := false.
#( (viewedCategoryName selectorsVisited)
(queryCategoryName selectorsRetrieved)) do:
[:pair |
categoryName = (self class perform: pair first)
ifTrue:
[aList := self perform: pair second.
found := true]].
found ifFalse:
[aList := currentVocabulary allMethodsInCategory: categoryName forInstance: self targetObject ofClass: targetClass].
categoryName = self class queryCategoryName ifFalse: [autoSelectString := nil].
self initListFrom: aList highlighting: targetClass.
messageListIndex := 0.
self changed: #messageList.
contents := nil.
self contentsChanged.
self selectWithinCurrentCategoryIfPossible: existingSelector.
self adjustWindowTitle!
----- Method: Lexicon>>categoryListKey:from: (in category 'category list') -----
categoryListKey: aChar from: aView
"The user hit a command-key while in the category-list. Do something"
(aChar == $f and: [self hasSearchPane not]) ifTrue:
[^ self obtainNewSearchString].!
----- Method: Lexicon>>categoryListMenu:shifted: (in category 'category list') -----
categoryListMenu: aMenu shifted: aBoolean
"Answer the menu for the category list"
^ aMenu labels: 'find...(f)' lines: #() selections: #(obtainNewSearchString)!
----- Method: Lexicon>>categoryListMenuTitle (in category 'category list') -----
categoryListMenuTitle
"Answer the menu title for the category list menu"
^ 'categories'!
----- Method: Lexicon>>categoryOfSelector: (in category 'selection') -----
categoryOfSelector: aSelector
"Answer the name of the defining category for aSelector, or nil if none"
| classDefiningSelector |
classDefiningSelector := targetClass whichClassIncludesSelector: aSelector.
classDefiningSelector
ifNil: [^ nil].
"can happen for example if one issues this from a change-sorter for a
message that is recorded as having been removed"
^ classDefiningSelector whichCategoryIncludesSelector: aSelector!
----- Method: Lexicon>>categoryWithNameSpecifiedBy: (in category 'category list') -----
categoryWithNameSpecifiedBy: aSelector
"Answer the category name obtained by sending aSelector to my class. This provides a way to avoid hard-coding the wording of conventions such as '-- all --'"
^ self class perform: aSelector!
----- Method: Lexicon>>chooseCategory: (in category 'category list') -----
chooseCategory: aCategory
"Choose the category of the given name, if there is one"
self categoryListIndex: (categoryList indexOf: aCategory ifAbsent: [^ Beeper beep])!
----- Method: Lexicon>>chooseLimitClass (in category 'limit class') -----
chooseLimitClass
"Put up a menu allowing the user to choose the most generic class to show"
| aMenu |
aMenu := MenuMorph new defaultTarget: self.
targetClass withAllSuperclasses do:
[:aClass |
aClass == ProtoObject
ifTrue:
[aMenu addLine].
aMenu add: aClass name selector: #setLimitClass: argument: aClass.
aClass == limitClass ifTrue:
[aMenu lastItem color: Color red].
aClass == targetClass ifTrue: [aMenu addLine]].
aMenu addTitle: 'Show only methods
implemented at or above...'. "heh heh -- somebody please find nice wording here!!"
aMenu popUpInWorld: self currentWorld!
----- Method: Lexicon>>chooseVocabulary (in category 'vocabulary') -----
chooseVocabulary
"Put up a dialog affording the user a chance to choose a different vocabulary to be installed in the receiver"
| aMenu |
aMenu := MenuMorph new defaultTarget: self.
aMenu addTitle: 'Choose a vocabulary
blue = current
red = imperfect' translated.
aMenu addStayUpItem.
Vocabulary allStandardVocabularies do:
[:aVocabulary |
(targetClass implementsVocabulary: aVocabulary)
ifTrue:
[aMenu add: aVocabulary vocabularyName selector: #switchToVocabulary: argument: aVocabulary.
(targetClass fullyImplementsVocabulary: aVocabulary) ifFalse:
[aMenu lastItem color: Color red].
aVocabulary == currentVocabulary ifTrue:
[aMenu lastItem color: Color blue].
aMenu balloonTextForLastItem: aVocabulary documentation]].
aMenu popUpInWorld: self currentWorld!
----- Method: Lexicon>>contents (in category 'contents') -----
contents
"We have a class, allow new messages to be defined"
editSelection == #newMessage ifTrue: [^ targetClass sourceCodeTemplate].
^ super contents!
----- Method: Lexicon>>currentQueryParameter (in category 'within-tool queries') -----
currentQueryParameter
"Answer the current query parameter"
^ currentQueryParameter ifNil: [currentQueryParameter := 'contents']!
----- Method: Lexicon>>customButtonSpecs (in category 'control buttons') -----
customButtonSpecs
"Answer a triplet defining buttons, in the format:
button label
selector to send
help message"
| aa |
aa := contentsSymbol == #tiles ifTrue: [{ "Consult Ted Kaehler regarding this bit"
{'tiles'. #tilesMenu. 'tiles for assignment and constants'. true}.
{'vars'. #varTilesMenu. 'tiles for instance variables and a new temporary'. true}
}] ifFalse: [#()]. "true in 4th place means act on mouseDown"
^ aa, #(
('follow' seeAlso 'view a method I implement that is called by this method')
('find' obtainNewSearchString 'find methods by name search')
('sent...' setSendersSearch 'view the methods I implement that send a given message')
('<' navigateToPreviousMethod 'view the previous active method')
('>' navigateToNextMethod 'view the next active method')
('-' removeFromSelectorsVisited 'remove this method from my active list'))!
----- Method: Lexicon>>displaySelector: (in category 'basic operation') -----
displaySelector: aSelector
"Set aSelector to be the one whose source shows in the browser. If there is a category list, make it highlight a suitable category"
| detectedItem messageIndex |
self chooseCategory: (self categoryDefiningSelector: aSelector).
detectedItem := messageList detect:
[:anItem | (anItem asString upTo: $ ) asSymbol == aSelector] ifNone: [^ Beeper beep].
messageIndex := messageList indexOf: detectedItem.
self messageListIndex: messageIndex!
----- Method: Lexicon>>doItReceiver (in category 'model glue') -----
doItReceiver
"This class's classPool has been jimmied to be the classPool of the class being browsed. A doIt in the code pane will let the user see the value of the class variables. Here, if the receiver is affiliated with a specific instance, we give give that primacy"
^ self targetObject ifNil: [self selectedClass ifNil: [FakeClassPool new]]!
----- Method: Lexicon>>hasSearchPane (in category 'search') -----
hasSearchPane
"Answer whether receiver has a search pane"
^ self searchPane notNil!
----- Method: Lexicon>>initListFrom:highlighting: (in category 'initialization') -----
initListFrom: selectorCollection highlighting: aClass
"Make up the messageList with items from aClass in boldface. Provide a final filtering in that only selectors whose implementations fall within my limitClass will be shown."
| defClass item |
messageList := OrderedCollection new.
selectorCollection do:
[:selector | defClass := aClass whichClassIncludesSelector: selector.
(defClass notNil and: [defClass includesBehavior: self limitClass]) ifTrue:
[item := selector, ' (' , defClass name , ')'.
item := item asText.
defClass == aClass ifTrue: [item allBold].
"(self isThereAnOverrideOf: selector) ifTrue: [item addAttribute: TextEmphasis struckOut]."
"The above has a germ of a good idea but could be very slow"
messageList add: item]]!
----- Method: Lexicon>>initialLimitClass (in category 'limit class') -----
initialLimitClass
"Choose a plausible initial vlaue for the limit class, and answer it"
| oneTooFar |
limitClass := targetClass.
(#('ProtoObject' 'Object' 'Behavior' 'ClassDescription' 'Class' 'ProtoObject class' 'Object class') includes: targetClass name asString) ifTrue: [^ targetClass].
oneTooFar := (targetClass isKindOf: Metaclass)
ifTrue:
["use the fifth back from the superclass chain for Metaclasses, which is the immediate subclass of ProtoObject class. Print <ProtoObject class allSuperclasses> to count them yourself."
targetClass allSuperclasses at: (targetClass allSuperclasses size - 5)]
ifFalse:
[targetClass allSuperclasses at: targetClass allSuperclasses size].
[limitClass superclass ~~ oneTooFar]
whileTrue: [limitClass := limitClass superclass].
^ limitClass!
----- Method: Lexicon>>lastSearchString (in category 'search') -----
lastSearchString
"Answer the last search string, initializing it to an empty string if it has not been initialized yet"
^ currentQueryParameter ifNil: [currentQueryParameter := 'contents']!
----- Method: Lexicon>>lastSearchString: (in category 'search') -----
lastSearchString: aString
"Make a note of the last string searched for in the receiver"
currentQueryParameter := aString asString.
currentQuery := #selectorName.
autoSelectString := aString.
self setMethodListFromSearchString.
^ true!
----- Method: Lexicon>>lastSendersSearchSelector (in category 'search') -----
lastSendersSearchSelector
"Answer the last senders search selector, initializing it to a default value if it does not already have a value"
^ currentQueryParameter ifNil: [currentQueryParameter := #flag:]!
----- Method: Lexicon>>limitClass (in category 'limit class') -----
limitClass
"Answer the most generic class to show in the browser. By default, we go all the way up to ProtoObject"
^ limitClass ifNil: [self initialLimitClass]!
----- Method: Lexicon>>limitClass: (in category 'limit class') -----
limitClass: aClass
"Set the most generic class to show as indicated"
limitClass := aClass!
----- Method: Lexicon>>limitClassString (in category 'limit class') -----
limitClassString
"Answer a string representing the current choice of most-generic-class-to-show"
| most |
(most := self limitClass) == ProtoObject
ifTrue: [^ 'All'].
most == targetClass
ifTrue: [^ most name].
^ 'Only through ', most name!
----- Method: Lexicon>>maybeReselectClass:selector: (in category 'transition') -----
maybeReselectClass: aClass selector: aSelector
"The protocol or limitClass may have changed, so that there is a different categoryList. Formerly, the given class and selector were selected; if it is possible to do so, reselect them now"
aClass ifNil: [^ self].
(currentVocabulary includesSelector: aSelector forInstance: self targetObject ofClass: targetClass limitClass: limitClass)
ifTrue:
[self selectSelectorItsNaturalCategory: aSelector]!
----- Method: Lexicon>>messageListIndex: (in category 'basic operation') -----
messageListIndex: anIndex
"Set the message list index as indicated, and update the history list if appropriate"
| newSelector current |
current := self selectedMessageName.
super messageListIndex: anIndex.
anIndex = 0 ifTrue: [
self editSelection: #newMessage.
self contentsChanged].
(newSelector := self selectedMessageName) ifNotNil:
[self updateSelectorsVisitedfrom: current to: newSelector]!
----- Method: Lexicon>>messageListKey:from: (in category 'message list menu') -----
messageListKey: aChar from: view
"Respond to a Command key"
aChar == $f ifTrue: [^ self obtainNewSearchString].
^ super messageListKey: aChar from: view!
----- Method: Lexicon>>methodListFromSearchString: (in category 'search') -----
methodListFromSearchString: fragment
"Answer a method list of methods whose selectors match the given fragment"
| aList searchFor |
currentQueryParameter := fragment.
currentQuery := #selectorName.
autoSelectString := fragment.
searchFor := fragment asString asLowercase withBlanksTrimmed.
aList := targetClass allSelectors select:
[:aSelector | currentVocabulary includesSelector: aSelector forInstance: self targetObject ofClass: targetClass limitClass: limitClass].
searchFor size > 0 ifTrue:
[aList := aList select:
[:aSelector | aSelector includesSubstring: searchFor caseSensitive: false]].
^ aList asSortedArray
!
----- Method: Lexicon>>methodsWithInitials (in category 'within-tool queries') -----
methodsWithInitials
"Answer the list of method selectors within the scope of this tool whose time stamps begin with the initials designated by my currentQueryParameter"
^ self methodsWithInitials: currentQueryParameter!
----- Method: Lexicon>>methodsWithInitials: (in category 'within-tool queries') -----
methodsWithInitials: initials
"Return a list of selectors representing methods whose timestamps have the given initials and which are in the protocol of this object and within the range dictated by my limitClass."
| classToUse |
classToUse := self targetObject ifNotNil: [self targetObject class] ifNil: [targetClass]. "In support of lightweight uniclasses"
^ targetClass allSelectors select:
[:aSelector | (currentVocabulary includesSelector: aSelector forInstance: self targetObject ofClass: classToUse limitClass: limitClass) and:
[Utilities doesMethod: aSelector forClass: classToUse bearInitials: initials]].
!
----- Method: Lexicon>>navigateToASender (in category 'senders') -----
navigateToASender
"Present the user with a list of senders of the currently-selected
message, and navigate to the chosen one"
| selectorSet chosen aSelector |
aSelector := self selectedMessageName.
selectorSet := Set new.
(self systemNavigation allCallsOn: aSelector)
do: [:anItem | selectorSet add: anItem methodSymbol].
selectorSet := selectorSet
select: [:sel | currentVocabulary
includesSelector: sel
forInstance: self targetObject
ofClass: targetClass
limitClass: limitClass].
selectorSet size == 0
ifTrue: [^ Beeper beep].
self okToChange
ifFalse: [^ self].
chosen := UIManager default chooseFrom: selectorSet asSortedArray values: selectorSet asSortedArray.
chosen isEmptyOrNil
ifFalse: [self displaySelector: chosen]!
----- Method: Lexicon>>navigateToNextMethod (in category 'history') -----
navigateToNextMethod
"Navigate to the 'next' method in the current viewing sequence"
| anIndex aSelector |
self selectorsVisited size == 0 ifTrue: [^ self].
anIndex := (aSelector := self selectedMessageName) notNil ifTrue: [selectorsVisited indexOf: aSelector ifAbsent: [selectorsVisited size]] ifFalse: [1].
self selectedCategoryName == self class viewedCategoryName
ifTrue:
[self selectWithinCurrentCategory: (selectorsVisited atWrap: (anIndex + 1))]
ifFalse:
[self displaySelector: (selectorsVisited atWrap: (anIndex + 1))]!
----- Method: Lexicon>>navigateToPreviousMethod (in category 'history') -----
navigateToPreviousMethod
"Navigate to the 'previous' method in the current viewing sequence"
| anIndex aSelector |
self selectorsVisited size == 0 ifTrue: [^ self].
anIndex := (aSelector := self selectedMessageName) notNil
ifTrue: [selectorsVisited indexOf: aSelector ifAbsent: [selectorsVisited size]]
ifFalse: [selectorsVisited size].
self selectedCategoryName == self class viewedCategoryName
ifTrue:
[self selectWithinCurrentCategory: (selectorsVisited atWrap: (anIndex - 1))]
ifFalse:
[self displaySelector: (selectorsVisited atWrap: (anIndex - 1))]!
----- Method: Lexicon>>navigateToRecentMethod (in category 'history') -----
navigateToRecentMethod
"Put up a menu of recent selectors visited and navigate to the one chosen"
| visited aSelector |
(visited := self selectorsVisited) size > 1 ifTrue:
[visited := visited copyFrom: 1 to: (visited size min: 20).
aSelector := UIManager default chooseFrom: visited values: visited
title: 'Recent methods visited in this browser'.
aSelector isEmptyOrNil ifFalse: [self displaySelector: aSelector]]!
----- Method: Lexicon>>newCategoryPane (in category 'category list') -----
newCategoryPane
"Formulate a category pane for insertion into the receiver's pane list"
| aListMorph |
aListMorph := PluggableListMorph on: self list: #categoryList
selected: #categoryListIndex changeSelected: #categoryListIndex:
menu: #categoryListMenu:shifted:
keystroke: #categoryListKey:from:.
aListMorph setNameTo: 'categoryList'.
aListMorph menuTitleSelector: #categoryListMenuTitle.
^ aListMorph!
----- Method: Lexicon>>noteAcceptanceOfCodeFor: (in category 'transition') -----
noteAcceptanceOfCodeFor: newSelector
"The user has submitted new code for the given selector; take a note of it. NB that the selectors-changed list gets added to here, but is not currently used in the system."
(self selectorsVisited includes: newSelector) ifFalse: [selectorsVisited add: newSelector].!
----- Method: Lexicon>>obtainNewSearchString (in category 'search') -----
obtainNewSearchString
"Put up a box allowing the user to enter a fresh search string"
| fragment |
fragment := UIManager default request: 'type method name or fragment: ' initialAnswer: self currentQueryParameter.
fragment ifNil: [^ self].
(fragment := fragment copyWithout: $ ) size == 0 ifTrue: [^ self].
currentQueryParameter := fragment.
fragment := fragment asLowercase.
currentQuery := #selectorName.
self showQueryResultsCategory.
self messageListIndex: 0!
----- Method: Lexicon>>offerMenu (in category 'menu commands') -----
offerMenu
"Offer a menu to the user, in response to the hitting of the menu button on the tool pane"
| aMenu |
aMenu := MenuMorph new defaultTarget: self.
aMenu addTitle: 'Lexicon'.
aMenu addStayUpItem.
aMenu addList: #(
('vocabulary...' chooseVocabulary)
('what to show...' offerWhatToShowMenu)
-
('inst var refs (here)' setLocalInstVarRefs)
('inst var defs (here)' setLocalInstVarDefs)
('class var refs (here)' setLocalClassVarRefs)
-
('navigate to a sender...' navigateToASender)
('recent...' navigateToRecentMethod)
('show methods in current change set'
showMethodsInCurrentChangeSet)
('show methods with initials...'
showMethodsWithInitials)
-
"('toggle search pane' toggleSearch)"
-
('browse full (b)' browseMethodFull)
('browse hierarchy (h)' classHierarchy)
('browse method (O)' openSingleMessageBrowser)
('browse protocol (p)' browseFullProtocol)
-
('fileOut' fileOutMessage)
('printOut' printOutMessage)
-
('senders of... (n)' browseSendersOfMessages)
('implementors of... (m)' browseMessages)
('versions (v)' browseVersions)
('inheritance (i)' methodHierarchy)
-
('inst var refs' browseInstVarRefs)
('inst var defs' browseInstVarDefs)
('class var refs' browseClassVarRefs)
-
('more...' shiftedYellowButtonActivity)).
aMenu popUpInWorld: ActiveWorld!
----- Method: Lexicon>>okayToAccept (in category 'model glue') -----
okayToAccept
"Answer whether it is okay to accept the receiver's input"
| ok aClass reply |
(ok := super okayToAccept) ifTrue:
[((aClass := self selectedClassOrMetaClass) ~~ targetClass) ifTrue:
[reply := UIManager default chooseFrom:
{'okay, no problem'.
'cancel - let me reconsider'.
'compile into ', targetClass name, ' instead'.
'compile into a new uniclass'} title:
'Caution!! This would be
accepted into class ', aClass name, '.
Is that okay?' .
reply = 1 ifTrue: [^ true].
reply ~~ 2 ifTrue:
[self notYetImplemented].
^ false]].
^ ok!
----- Method: Lexicon>>openOnClass:inWorld:showingSelector: (in category 'toolbuilder') -----
openOnClass: aTargetClass inWorld: ignored showingSelector: aSelector
^self openOnClass: aTargetClass showingSelector: aSelector!
----- Method: Lexicon>>openOnClass:showingSelector: (in category 'toolbuilder') -----
openOnClass: aTargetClass showingSelector: aSelector
currentVocabulary ifNil: [currentVocabulary := Vocabulary fullVocabulary].
targetClass := aTargetClass.
self initialLimitClass.
self reformulateCategoryList.
ToolBuilder open: self.
self adjustWindowTitle.!
----- Method: Lexicon>>preserveSelectorIfPossibleSurrounding: (in category 'transition') -----
preserveSelectorIfPossibleSurrounding: aBlock
"Make a note of the currently-selected method; perform aBlock and then attempt to reestablish that same method as the selected one in the new circumstances"
| aClass aSelector |
aClass := self selectedClassOrMetaClass.
aSelector := self selectedMessageName.
aBlock value.
self hasSearchPane
ifTrue:
[self setMethodListFromSearchString]
ifFalse:
[self maybeReselectClass: aClass selector: aSelector]!
----- Method: Lexicon>>queryCharacterization (in category 'within-tool queries') -----
queryCharacterization
"Answer a characterization of the most recent query"
currentQuery == #selectorName
ifTrue: [^ 'My methods whose names include "', self lastSearchString, '"'].
currentQuery == #methodsWithInitials
ifTrue: [^ 'My methods stamped with initials ', currentQueryParameter].
currentQuery == #senders
ifTrue: [^ 'My methods that send #', self lastSendersSearchSelector].
currentQuery == #currentChangeSet
ifTrue: [^ 'My methods in the current change set'].
currentQuery == #instVarRefs
ifTrue: [^ 'My methods that refer to instance variable "', currentQueryParameter, '"'].
currentQuery == #instVarDefs
ifTrue: [^ 'My methods that store into instance variable "', currentQueryParameter, '"'].
currentQuery == #classVarRefs
ifTrue: [^ 'My methods that refer to class variable "', currentQueryParameter, '"'].
^ 'Results of queries will show up here'!
----- Method: Lexicon>>reformulateCategoryList (in category 'category list') -----
reformulateCategoryList
"Reformulate the category list"
categoryList := nil.
self categoryListIndex: 0.
self changed: #categoryList.
self contentsChanged!
----- Method: Lexicon>>reformulateList (in category 'transition') -----
reformulateList
"Make the category list afresh, and reselect the current selector if appropriate"
self preserveSelectorIfPossibleSurrounding:
[super reformulateList.
self categoryListIndex: categoryListIndex]!
----- Method: Lexicon>>reformulateListNoting: (in category 'transition') -----
reformulateListNoting: newSelector
"A method has possibly been submitted for the receiver with newSelector as its selector; If the receiver has a way of reformulating its message list, here is a chance for it to do so"
super reformulateListNoting: newSelector.
newSelector ifNotNil:
[self displaySelector: newSelector]!
----- Method: Lexicon>>removeFromSelectorsVisited (in category 'history') -----
removeFromSelectorsVisited
"Remove the currently-selected method from the active set"
| aSelector |
(aSelector := self selectedMessageName) ifNil: [^ self].
self removeFromSelectorsVisited: aSelector.
self chooseCategory: self class viewedCategoryName!
----- Method: Lexicon>>removeFromSelectorsVisited: (in category 'history') -----
removeFromSelectorsVisited: aSelector
"remove aSelector from my history list"
self selectorsVisited remove: aSelector ifAbsent: []!
----- Method: Lexicon>>removeMessage (in category 'menu commands') -----
removeMessage
"Remove the selected message from the system."
messageListIndex = 0 ifTrue: [^ self].
self okToChange ifFalse: [^ self].
super removeMessage.
"my #reformulateList method, called from the super #removeMethod method, will however try to preserve the selection, so we take pains to clobber it by the below..."
messageListIndex := 0.
self changed: #messageList.
self changed: #messageListIndex.
contents := nil.
self contentsChanged!
----- Method: Lexicon>>retainMethodSelectionWhileSwitchingToCategory: (in category 'transition') -----
retainMethodSelectionWhileSwitchingToCategory: aCategoryName
"retain method selection while switching the category-pane selection to show the category of the given name"
| aSelectedName |
aSelectedName := self selectedMessageName.
self categoryListIndex: (categoryList indexOf: aCategoryName ifAbsent: [^ self]).
aSelectedName ifNotNil: [self selectWithinCurrentCategory: aSelectedName]
!
----- Method: Lexicon>>seeAlso (in category 'within-tool queries') -----
seeAlso
"Present a menu offering the selector of the currently selected message, as well as of all messages sent by it. If the chosen selector is showable in the current browser, show it here, minding unsubmitted edits however"
self selectImplementedMessageAndEvaluate:
[:aSelector |
((currentVocabulary includesSelector: aSelector forInstance: self targetObject ofClass: targetClass limitClass: limitClass) "i.e., is this aSelector available in this browser"
and: [self okToChange])
ifTrue:
[self displaySelector: aSelector]
ifFalse:
[Beeper beep. "SysttemNavigation new browseAllImplementorsOf: aSelector"]].
"Initially I tried making this open an external implementors browser in this case, but later decided that the user model for this was unstable"!
----- Method: Lexicon>>seeAlso: (in category 'within-tool queries') -----
seeAlso: aSelector
"If the requested selector is showable in the current browser, show it here, minding unsubmitted edits however"
((currentVocabulary includesSelector: aSelector forInstance: self targetObject ofClass: targetClass limitClass: limitClass) "i.e., is aSelector available in this browser"
and: [self okToChange])
ifTrue:
[self displaySelector: aSelector]
ifFalse:
[Beeper beep]!
----- Method: Lexicon>>selectImplementedMessageAndEvaluate: (in category 'selection') -----
selectImplementedMessageAndEvaluate: aBlock
"Allow the user to choose one selector, chosen from the currently selected message's selector, as well as those of all messages sent by it, and evaluate aBlock on behalf of chosen selector. If there is only one possible choice, simply make it; if there are multiple choices, put up a menu, and evaluate aBlock on behalf of the the chosen selector, doing nothing if the user declines to choose any. In this variant, only selectors "
| selector method messages |
(selector := self selectedMessageName) ifNil: [^ self].
method := (self selectedClassOrMetaClass ifNil: [^ self])
compiledMethodAt: selector
ifAbsent: [].
(method isNil or: [(messages := method messages) size == 0])
ifTrue: [^ aBlock value: selector].
(messages size == 1 and: [messages includes: selector])
ifTrue:
[^ aBlock value: selector]. "If only one item, there is no choice"
messages := messages select: [:aSelector | currentVocabulary includesSelector: aSelector forInstance: self targetObject ofClass: targetClass limitClass: limitClass].
self systemNavigation
showMenuOf: messages
withFirstItem: selector
ifChosenDo: [:sel | aBlock value: sel]!
----- Method: Lexicon>>selectSelectorItsNaturalCategory: (in category 'selection') -----
selectSelectorItsNaturalCategory: aSelector
"Make aSelector be the current selection of the receiver, with the category being its home category."
| cat catIndex detectedItem |
cat := self categoryOfSelector: aSelector.
catIndex := categoryList indexOf: cat ifAbsent:
["The method's own category is not seen in this browser; the method probably occurs in some other category not known directly to the class, but for now, we'll just use the all category"
1].
self categoryListIndex: catIndex.
detectedItem := messageList detect:
[:anItem | (anItem asString upTo: $ ) asSymbol == aSelector] ifNone: [^ self].
self messageListIndex: (messageList indexOf: detectedItem ifAbsent: [^ self])!
----- Method: Lexicon>>selectWithinCurrentCategory: (in category 'selection') -----
selectWithinCurrentCategory: aSelector
"If aSelector is one of the selectors seen in the current category, select it"
| detectedItem |
detectedItem := self messageList detect:
[:anItem | (anItem asString upTo: $ ) asSymbol == aSelector] ifNone: [^ self].
self messageListIndex: (messageList indexOf: detectedItem ifAbsent: [^ self])!
----- Method: Lexicon>>selectWithinCurrentCategoryIfPossible: (in category 'category list') -----
selectWithinCurrentCategoryIfPossible: aSelector
"If the receiver's message list contains aSelector, navigate right to it without changing categories"
| detectedItem messageIndex |
aSelector ifNil: [^ self].
detectedItem := messageList detect:
[:anItem | (anItem asString upTo: $ ) asSymbol == aSelector] ifNone: [^ self].
messageIndex := messageList indexOf: detectedItem.
self messageListIndex: messageIndex
!
----- Method: Lexicon>>selectedCategoryName (in category 'category list') -----
selectedCategoryName
"Answer the selected category name"
^ categoryList ifNotNil:
[categoryList at: categoryListIndex ifAbsent: [nil]]!
----- Method: Lexicon>>selectedClassOrMetaClass (in category 'selection') -----
selectedClassOrMetaClass
"Answer the currently selected class (or metaclass)."
self setClassAndSelectorIn: [:c :s | ^c]!
----- Method: Lexicon>>selectedMessage (in category 'selection') -----
selectedMessage
"Answer the source method for the currently selected message."
(categoryList notNil and: [(categoryListIndex isNil or: [categoryListIndex == 0])])
ifTrue:
[^ '---'].
self setClassAndSelectorIn: [:class :selector |
class ifNil: [^ 'here would go the documentation for the protocol category, if any.'].
self showingDecompile ifTrue: [^ self decompiledSourceIntoContents].
self showingDocumentation ifTrue: [^ self commentContents].
currentCompiledMethod := class compiledMethodAt: selector ifAbsent: [nil].
^ self sourceStringPrettifiedAndDiffed asText makeSelectorBoldIn: class]!
----- Method: Lexicon>>selectorsChanged (in category 'within-tool queries') -----
selectorsChanged
"Return a list of methods in the current change set (or satisfying some
other such criterion) that are in the protocol of this object"
| aList aClass targetedClass |
targetedClass := self targetObject
ifNil: [targetClass]
ifNotNil: [self targetObject class].
aList := OrderedCollection new.
ChangeSet current methodChanges
associationsDo: [:classChgAssoc | classChgAssoc value
associationsDo: [:methodChgAssoc | (methodChgAssoc value == #change
or: [methodChgAssoc value == #add])
ifTrue: [(aClass := targetedClass whichClassIncludesSelector: methodChgAssoc key)
ifNotNil: [aClass name = classChgAssoc key
ifTrue: [aList add: methodChgAssoc key]]]]].
^ aList!
----- Method: Lexicon>>selectorsDefiningInstVar (in category 'within-tool queries') -----
selectorsDefiningInstVar
"Return a list of methods that define a given inst var that are in the protocol of this object"
| aList |
aList := OrderedCollection new.
targetClass withAllSuperclassesDo:
[:aClass |
(aClass whichSelectorsStoreInto: currentQueryParameter asString) do:
[:sel | sel isDoIt ifFalse: [aList add: sel]
]
].
^ aList!
----- Method: Lexicon>>selectorsMatching (in category 'search') -----
selectorsMatching
"Anwer a list of selectors in the receiver that match the current search string"
| fragment aList |
fragment := self lastSearchString asLowercase.
aList := targetClass allSelectors select:
[:aSelector | (aSelector includesSubstring: fragment caseSensitive: false) and:
[currentVocabulary includesSelector: aSelector forInstance: self targetObject ofClass: targetClass limitClass: limitClass]].
^ aList asSortedArray!
----- Method: Lexicon>>selectorsReferringToClassVar (in category 'category list') -----
selectorsReferringToClassVar
"Return a list of methods that refer to given class var that are in the
protocol of this object"
| aList aClass nonMeta poolAssoc |
nonMeta := targetClass theNonMetaClass.
aClass := nonMeta classThatDefinesClassVariable: currentQueryParameter.
aList := OrderedCollection new.
poolAssoc := aClass classPool associationAt: currentQueryParameter asSymbol.
(self systemNavigation allCallsOn: poolAssoc)
do: [:elem | (nonMeta isKindOf: elem actualClass)
ifTrue: [aList add: elem methodSymbol]].
^ aList!
----- Method: Lexicon>>selectorsReferringToInstVar (in category 'within-tool queries') -----
selectorsReferringToInstVar
"Return a list of methods that refer to a given inst var that are in the protocol of this object"
| aList |
aList := OrderedCollection new.
targetClass withAllSuperclassesDo: [:aClass |
(aClass whichSelectorsAccess: currentQueryParameter asString) do: [:sel |
sel isDoIt ifFalse: [aList add: sel]
]
].
^ aList!
----- Method: Lexicon>>selectorsRetrieved (in category 'within-tool queries') -----
selectorsRetrieved
"Anwer a list of selectors in the receiver that have been retrieved for the query category. This protocol is used when reformulating a list after, say, a limitClass change"
currentQuery == #classVarRefs ifTrue: [^ self selectorsReferringToClassVar].
currentQuery == #currentChangeSet ifTrue: [^ self selectorsChanged].
currentQuery == #instVarDefs ifTrue: [^ self selectorsDefiningInstVar].
currentQuery == #instVarRefs ifTrue: [^ self selectorsReferringToInstVar].
currentQuery == #methodsWithInitials ifTrue: [^ self methodsWithInitials].
currentQuery == #selectorName ifTrue: [^ self selectorsMatching].
currentQuery == #senders ifTrue: [^ self selectorsSendingSelectedSelector].
^ #()!
----- Method: Lexicon>>selectorsSendingSelectedSelector (in category 'senders') -----
selectorsSendingSelectedSelector
"Assumes lastSendersSearchSelector is already set"
| selectorSet sel cl |
autoSelectString := (self lastSendersSearchSelector upTo: $:) asString.
selectorSet := Set new.
(self systemNavigation allCallsOn: self lastSendersSearchSelector)
do: [:anItem |
sel := anItem methodSymbol.
cl := anItem actualClass.
((currentVocabulary
includesSelector: sel
forInstance: self targetObject
ofClass: targetClass
limitClass: limitClass)
and: [targetClass includesBehavior: cl])
ifTrue: [selectorSet add: sel]].
^ selectorSet asSortedArray!
----- Method: Lexicon>>selectorsVisited (in category 'history') -----
selectorsVisited
"Answer the list of selectors visited in this tool"
^ selectorsVisited ifNil: [selectorsVisited := OrderedCollection new]!
----- Method: Lexicon>>setClassAndSelectorIn: (in category 'selection') -----
setClassAndSelectorIn: csBlock
"Decode strings of the form <selectorName> (<className> [class])"
self selection ifNil: [^ csBlock value: targetClass value: nil].
^ super setClassAndSelectorIn: csBlock!
----- Method: Lexicon>>setLimitClass: (in category 'limit class') -----
setLimitClass: aClass
"Set aClass as the limit class for this browser"
| currentClass currentSelector |
currentClass := self selectedClassOrMetaClass.
currentSelector := self selectedMessageName.
self limitClass: aClass.
categoryList := nil.
self categoryListIndex: 0.
self changed: #categoryList.
self changed: #methodList.
self changed: #contents.
self changed: #limitClassString.
self adjustWindowTitle.
self hasSearchPane
ifTrue:
[self setMethodListFromSearchString].
self maybeReselectClass: currentClass selector: currentSelector
!
----- Method: Lexicon>>setLocalClassVarRefs (in category 'within-tool queries') -----
setLocalClassVarRefs
"Put up a list of the class variables in the viewed object, and when the user selects one, let the query results category show all the references to that class variable."
| aName |
(aName := targetClass theNonMetaClass chooseClassVarName) ifNil: [^ self].
currentQuery := #classVarRefs.
currentQueryParameter := aName.
self showQueryResultsCategory!
----- Method: Lexicon>>setLocalInstVarDefs (in category 'within-tool queries') -----
setLocalInstVarDefs
"Put up a list of the instance variables in the viewed object, and when the user seletcts one, let the query results category show all the references to that instance variable."
| instVarToProbe |
targetClass chooseInstVarThenDo:
[:aName | instVarToProbe := aName].
instVarToProbe isEmptyOrNil ifTrue: [^ self].
currentQuery := #instVarDefs.
currentQueryParameter := instVarToProbe.
self showQueryResultsCategory!
----- Method: Lexicon>>setLocalInstVarRefs (in category 'within-tool queries') -----
setLocalInstVarRefs
"Put up a list of the instance variables in the viewed object, and when the user seletcts one, let the query results category show all the references to that instance variable."
| instVarToProbe |
targetClass chooseInstVarThenDo:
[:aName | instVarToProbe := aName].
instVarToProbe isEmptyOrNil ifTrue: [^ self].
currentQuery := #instVarRefs.
currentQueryParameter := instVarToProbe.
self showQueryResultsCategory!
----- Method: Lexicon>>setMethodListFromSearchString (in category 'search') -----
setMethodListFromSearchString
"Set the method list of the receiver based on matches from the search string"
| fragment aList |
self okToChange ifFalse: [^ self].
fragment := currentQueryParameter.
fragment := fragment asString asLowercase withBlanksTrimmed.
aList := targetClass allSelectors select:
[:aSelector | currentVocabulary includesSelector: aSelector forInstance: self targetObject ofClass: targetClass limitClass: limitClass].
fragment size > 0 ifTrue:
[aList := aList select:
[:aSelector | aSelector includesSubstring: fragment caseSensitive: false]].
aList size == 0 ifTrue:
[^ Beeper beep].
self initListFrom: aList asSortedArray highlighting: targetClass.
messageListIndex := messageListIndex min: messageList size.
self changed: #messageList
!
----- Method: Lexicon>>setSendersSearch (in category 'senders') -----
setSendersSearch
"Put up a list of messages sent in the current message, find all methods
of the browsee which send the one the user chooses, and show that list
in the message-list pane, with the 'query results' item selected in the
category-list pane"
| selectorSet aSelector aString |
self selectedMessageName
ifNil: [aString := UIManager default request: 'Type selector to search for' initialAnswer: 'flag:'.
aString isEmptyOrNil
ifTrue: [^ self].
Symbol
hasInterned: aString
ifTrue: [:sel | aSelector := sel]]
ifNotNil: [self
selectMessageAndEvaluate: [:sel | aSelector := sel]].
aSelector
ifNil: [^ self].
selectorSet := Set new.
(self systemNavigation allCallsOn: aSelector)
do: [:anItem | selectorSet add: anItem methodSymbol].
selectorSet := selectorSet
select: [:sel | currentVocabulary
includesSelector: sel
forInstance: self targetObject
ofClass: targetClass
limitClass: limitClass].
selectorSet size > 0
ifTrue: [currentQuery := #senders.
currentQueryParameter := aSelector.
self
categoryListIndex: (categoryList indexOf: self class queryCategoryName).
self messageListIndex: 0]!
----- Method: Lexicon>>setToShowSelector: (in category 'selection') -----
setToShowSelector: aSelector
"Set up the receiver so that it will show the given selector"
| catName catIndex detectedItem messageIndex aList |
catName := (aList := currentVocabulary categoriesContaining: aSelector forClass: targetClass) size > 0
ifTrue:
[aList first]
ifFalse:
[self class allCategoryName].
catIndex := categoryList indexOf: catName ifAbsent: [1].
self categoryListIndex: catIndex.
detectedItem := messageList detect:
[:anItem | (anItem upTo: $ ) asString asSymbol == aSelector] ifNone: [^ self].
messageIndex := messageList indexOf: detectedItem.
self messageListIndex: messageIndex
!
----- Method: Lexicon>>showCategoriesPane (in category 'category list') -----
showCategoriesPane
"Show the categories pane instead of the search pane"
| aPane |
(aPane := self searchPane) ifNil: [^ Beeper beep].
self containingWindow replacePane: aPane with: self newCategoryPane.
categoryList := nil.
self changed: #categoryList.
self changed: #messageList!
----- Method: Lexicon>>showCategory (in category 'menu commands') -----
showCategory
"A revectoring blamable on history. Not sent in the image, but grandfathered buttons may still send this."
^ self showHomeCategory!
----- Method: Lexicon>>showHomeCategory (in category 'menu commands') -----
showHomeCategory
"Continue to show the current selector, but show it within the context of its primary category"
| aSelector |
(aSelector := self selectedMessageName) ifNotNil:
[self preserveSelectorIfPossibleSurrounding:
[self setToShowSelector: aSelector]]!
----- Method: Lexicon>>showMainCategory (in category 'menu commands') -----
showMainCategory
"Continue to show the current selector, but show it within the context of its primary category. Preserved for backward compatibility with pre-existing buttons."
^ self showHomeCategory!
----- Method: Lexicon>>showMethodsInCurrentChangeSet (in category 'within-tool queries') -----
showMethodsInCurrentChangeSet
"Set the current query to be for methods in the current change set"
currentQuery := #currentChangeSet.
autoSelectString := nil.
self categoryListIndex: (categoryList indexOf: self class queryCategoryName).!
----- Method: Lexicon>>showMethodsWithInitials (in category 'within-tool queries') -----
showMethodsWithInitials
"Prompt the user for initials to scan for; then show, in the query-results category, all methods with those initials in their time stamps"
| initials |
initials := UIManager default request: 'whose initials? ' initialAnswer: Utilities authorInitials.
initials isEmptyOrNil ifTrue: [^ self].
self showMethodsWithInitials: initials
!
----- Method: Lexicon>>showMethodsWithInitials: (in category 'within-tool queries') -----
showMethodsWithInitials: initials
"Make the current query be for methods stamped with the given initials"
currentQuery := #methodsWithInitials.
currentQueryParameter := initials.
self showQueryResultsCategory.
autoSelectString := nil.
self changed: #messageList.
self adjustWindowTitle
!
----- Method: Lexicon>>showQueryResultsCategory (in category 'within-tool queries') -----
showQueryResultsCategory
"Point the receiver at the query-results category and set the search string accordingly"
autoSelectString := self currentQueryParameter.
self categoryListIndex: (categoryList indexOf: self class queryCategoryName).
self messageListIndex: 0!
----- Method: Lexicon>>showSearchPane (in category 'search') -----
showSearchPane
"Given that the receiver is showing the categories pane, replace that with a search pane. Though there is a residual UI for obtaining this variant, it is obscure and the integrity of the protocol-category-browser when there is no categories pane is not necessarily assured at the moment."
| aPane |
(aPane := self categoriesPane) ifNil: [^ Beeper beep].
self containingWindow replacePane: aPane with: self newSearchPane.
categoryList := nil.
self changed: #categoryList.
self changed: #messageList!
----- Method: Lexicon>>startingWindowTitle (in category 'window title') -----
startingWindowTitle
"Answer the initial window title to apply"
^ 'Vocabulary of ', targetClass nameForViewer!
----- Method: Lexicon>>switchToVocabulary: (in category 'vocabulary') -----
switchToVocabulary: aVocabulary
"Make aVocabulary be the current one in the receiver"
self preserveSelectorIfPossibleSurrounding:
[self useVocabulary: aVocabulary.
self reformulateCategoryList.
self adjustWindowTitle]
!
----- Method: Lexicon>>targetObject (in category 'model glue') -----
targetObject
"Answer the object to which this tool is bound."
^ nil!
----- Method: Lexicon>>toggleSearch (in category 'search') -----
toggleSearch
"Toggle the determination of whether a categories pane or a search pane shows"
self hasSearchPane
ifTrue: [self showCategoriesPane]
ifFalse: [self showSearchPane]!
----- Method: Lexicon>>updateSelectorsVisitedfrom:to: (in category 'history') -----
updateSelectorsVisitedfrom: oldSelector to: newSelector
"Update the list of selectors visited."
newSelector == oldSelector ifTrue: [^ self].
self selectorsVisited remove: newSelector ifAbsent: [].
(selectorsVisited includes: oldSelector)
ifTrue:
[selectorsVisited add: newSelector after: oldSelector]
ifFalse:
[selectorsVisited add: newSelector]
!
----- Method: Lexicon>>useVocabulary: (in category 'vocabulary') -----
useVocabulary: aVocabulary
"Set up the receiver to use the given vocabulary"
currentVocabulary := aVocabulary!
----- Method: Lexicon>>wantsAnnotationPane (in category 'toolbuilder') -----
wantsAnnotationPane
"This kind of browser always wants annotation panes, so answer true"
^ true!
----- Method: ProtocolBrowser class>>openFullProtocolForClass: (in category 'instance creation') -----
openFullProtocolForClass: aClass
"Create and schedule a browser for the entire protocol of the class."
"ProtocolBrowser openFullProtocolForClass: ProtocolBrowser."
| aPBrowser label |
aPBrowser := ProtocolBrowser new on: aClass.
label := 'Entire protocol of: ', aClass name.
self open: aPBrowser name: label!
----- Method: ProtocolBrowser class>>openSubProtocolForClass: (in category 'instance creation') -----
openSubProtocolForClass: aClass
"Create and schedule a browser for the entire protocol of the class."
"ProtocolBrowser openSubProtocolForClass: ProtocolBrowser."
| aPBrowser label |
aPBrowser := ProtocolBrowser new onSubProtocolOf: aClass.
label := 'Sub-protocol of: ', aClass name.
self open: aPBrowser name: label!
----- Method: ProtocolBrowser>>getList (in category 'accessing') -----
getList
"Answer the receiver's message list."
^ messageList!
----- Method: ProtocolBrowser>>growable (in category 'accessing') -----
growable
"Answer whether the receiver is subject to manual additions and deletions"
^ false!
----- Method: ProtocolBrowser>>initListFrom:highlighting: (in category 'private') -----
initListFrom: selectorCollection highlighting: aClass
"Make up the messageList with items from aClass in boldface."
| defClass item |
messageList := OrderedCollection new.
selectorCollection do: [ :selector |
defClass := aClass whichClassIncludesSelector: selector.
item := selector, ' (' , defClass name , ')'.
defClass == aClass ifTrue: [item := item asText allBold].
messageList add: (
MethodReference new
setClass: defClass
methodSymbol: selector
stringVersion: item
)
].
selectedClass := aClass.!
----- Method: ProtocolBrowser>>list (in category 'accessing') -----
list
"Answer the receiver's message list."
^ messageList!
----- Method: ProtocolBrowser>>on: (in category 'private') -----
on: aClass
"Initialize with the entire protocol for the class, aClass."
self initListFrom: aClass allSelectors asSortedCollection
highlighting: aClass!
----- Method: ProtocolBrowser>>onSubProtocolOf: (in category 'private') -----
onSubProtocolOf: aClass
"Initialize with the entire protocol for the class, aClass,
but excluding those inherited from Object."
| selectors |
selectors := Set new.
aClass withAllSuperclasses do:
[:each | (each == Object or: [each == ProtoObject])
ifFalse: [selectors addAll: each selectors]].
self initListFrom: selectors asSortedCollection
highlighting: aClass!
----- Method: ProtocolBrowser>>selectedClassOrMetaClass (in category 'class list') -----
selectedClassOrMetaClass
^selectedClass!
----- Method: ProtocolBrowser>>selector (in category 'accessing') -----
selector
"Answer the receiver's selected selector."
^ selectedSelector!
----- Method: ProtocolBrowser>>selector: (in category 'accessing') -----
selector: aString
"Set the currently selected message selector to be aString."
selectedSelector := aString.
self changed: #selector!
----- Method: ProtocolBrowser>>setClassAndSelectorIn: (in category 'private') -----
setClassAndSelectorIn: csBlock
"Decode strings of the form <selectorName> (<className> [class])"
| i classAndSelString selString sel |
sel := self selection ifNil: [^ csBlock value: nil value: nil].
(sel isKindOf: MethodReference) ifTrue: [
sel setClassAndSelectorIn: csBlock
] ifFalse: [
selString := sel asString.
i := selString indexOf: $(.
"Rearrange to <className> [class] <selectorName> , and use MessageSet"
classAndSelString := (selString copyFrom: i + 1 to: selString size - 1) , ' ' ,
(selString copyFrom: 1 to: i - 1) withoutTrailingBlanks.
MessageSet parse: classAndSelString toClassAndSelector: csBlock.
].
!
----- Method: ProtocolBrowser>>setSelector: (in category 'accessing') -----
setSelector: aString
"Set the currently selected message selector to be aString."
selectedSelector := aString!
MessageSet subclass: #RecentMessageSet
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Browser'!
!RecentMessageSet commentStamp: 'sw 8/1/2002 17:40' prior: 0!
RecentMessageSet is a message set that shows the most recently-submitted methods, in chronological order.!
----- Method: RecentMessageSet>>addExtraShiftedItemsTo: (in category 'message list') -----
addExtraShiftedItemsTo: aMenu
"The shifted selector-list menu is being built. Overridden here to defeat the presence of the items that add or change order, since RecentMessageSet defines methods & order explicitly based on external criteria"
aMenu add: 'set size of recent history...' action: #setRecentHistorySize!
----- Method: RecentMessageSet>>contents:notifying: (in category 'contents') -----
contents: c notifying: n
| result |
result := super contents: c notifying: n.
result == true ifTrue:
[self reformulateList].
^ result!
----- Method: RecentMessageSet>>growable (in category 'update') -----
growable
"Answer whether the receiver can be changed by manual additions & deletions"
^ false!
----- Method: RecentMessageSet>>maybeSetSelection (in category 'selection') -----
maybeSetSelection
"After a browser's message list is changed, this message is dispatched to the model, to give it a chance to refigure a selection"
self messageListIndex: 1!
----- Method: RecentMessageSet>>messageListMenu:shifted: (in category 'message functions') -----
messageListMenu: aMenu shifted: shifted
"Answer the message-list menu"
shifted ifTrue: [^ self shiftedMessageListMenu: aMenu].
aMenu addList:#(
('what to show...' offerWhatToShowMenu)
-
('browse full (b)' browseMethodFull)
('browse hierarchy (h)' classHierarchy)
('browse method (O)' openSingleMessageBrowser)
('browse protocol (p)' browseFullProtocol)
-
('fileOut (o)' fileOutMessage)
('printOut' printOutMessage)
('copy selector (c)' copySelector)
-
('senders of... (n)' browseSendersOfMessages)
('implementors of... (m)' browseMessages)
('inheritance (i)' methodHierarchy)
('versions (v)' browseVersions)
-
('inst var refs...' browseInstVarRefs)
('inst var defs...' browseInstVarDefs)
('class var refs...' browseClassVarRefs)
('class variables' browseClassVariables)
('class refs (N)' browseClassRefs)
-
('remove method (x)' removeMessage)
('remove from RecentSubmissions' removeFromRecentSubmissions)
-
('more...' shiftedYellowButtonActivity)).
^ aMenu!
----- Method: RecentMessageSet>>reformulateList (in category 'update') -----
reformulateList
| myList |
"Reformulate the receiver's list. Exclude methods now deleted"
myList := Utilities recentMethodSubmissions reversed select: [ :each | each isValid].
self initializeMessageList: myList.
self messageListIndex: (messageList size min: 1). "0 or 1"
self changed: #messageList.
self changed: #messageListIndex!
----- Method: RecentMessageSet>>removeFromRecentSubmissions (in category 'message functions') -----
removeFromRecentSubmissions
"Remove the currently-selected method from the RecentSubmissions list"
| aClass methodSym |
((aClass := self selectedClassOrMetaClass) notNil and: [(methodSym := self selectedMessageName) notNil])
ifTrue:
[Utilities purgeFromRecentSubmissions: (MethodReference new setStandardClass: aClass methodSymbol: methodSym).
self reformulateList]!
----- Method: RecentMessageSet>>setRecentHistorySize (in category 'message list') -----
setRecentHistorySize
"Let the user specify the recent history size"
| aReply aNumber |
aReply := UIManager default request: 'How many recent methods
should be maintained?' initialAnswer: Utilities numberOfRecentSubmissionsToStore asString.
aReply isEmptyOrNil ifFalse:
[aNumber := aReply asNumber rounded.
(aNumber > 1 and: [aNumber <= 1000])
ifTrue:
[Utilities numberOfRecentSubmissionsToStore: aNumber.
self inform: 'Okay, ', aNumber asString, ' is the new size of the recent method history']
ifFalse:
[self inform: 'Sorry, must be a number between 2 & 1000']]
!
----- Method: RecentMessageSet>>updateListsAndCodeIn: (in category 'update') -----
updateListsAndCodeIn: aWindow
| recentFromUtilities |
"RAA 20 june 2000 - a recent change to how messages were displayed in the list caused them not to match what was stored in Utilities. This caused the recent submissions to be continuously updated. The hack below fixed that problem"
self flag: #mref. "in second pass, use simpler test"
self canDiscardEdits ifFalse: [^ self].
recentFromUtilities := Utilities mostRecentlySubmittedMessage,' '.
(messageList first asStringOrText asString beginsWith: recentFromUtilities)
ifFalse:
[self reformulateList]
ifTrue:
[self updateCodePaneIfNeeded]!
MessageSet subclass: #TimeProfileBrowser
instanceVariableNames: 'selectedClass selectedSelector block tally'
classVariableNames: 'TextMenu'
poolDictionaries: ''
category: 'Tools-Debugger'!
!TimeProfileBrowser commentStamp: '<historical>' prior: 0!
A TimeProfileBrowser is a browser visualizing the runtime profile of an executed Smalltalk block. It is useful for finding performance bottlenecks in code. When optimizing code it can
be hard to know what methods actually constitute the bulk of the execution time. Is it a few
methods that take very long time to execute or is it perhaps a single method that gets executed a thousand times?
The block is first spied on using a MessageTally instance (which has even more funtionality than used by the TimeProfileBrowser) which samples the block during it's execution and collects the amount of time approximately spent in the methods executed. Then the methods are shown in the browser with their relative execution time in percent.
Example:
TimeProfileBrowser onBlock: [20 timesRepeat: [Transcript show: 100 factorial printString]]
!
----- Method: TimeProfileBrowser class>>onBlock: (in category 'instance creation') -----
onBlock: block
"Open a profile browser on the given block, thereby running the block and
collecting the message tally."
"TimeProfileBrowser onBlock: [20 timesRepeat:
[Transcript show: 100 factorial printString]]"
| inst result |
inst := self new.
result := inst runBlock: block.
self open: inst name: 'Time Profile'.
^ result!
----- Method: TimeProfileBrowser class>>spyOn: (in category 'instance creation') -----
spyOn: block
"Open a profile browser on the given block, thereby running the block and
collecting the message tally."
"TimeProfileBrowser spyOn: [20 timesRepeat:
[Transcript show: 100 factorial printString]]"
^self onBlock: block!
----- Method: TimeProfileBrowser class>>spyOnProcess:forMilliseconds: (in category 'instance creation') -----
spyOnProcess: aProcess forMilliseconds: msecDuration
"Run aProcess for msecDuration milliseconds, then open a TimeProfileBrowser on the results."
"| p |
p := [100000 timesRepeat: [3.14159 printString]] fork.
(Delay forMilliseconds: 100) wait.
TimeProfileBrowser spyOnProcess: p forMilliseconds: 1000"
| inst |
inst := self new.
inst runProcess: aProcess forMilliseconds: msecDuration pollingEvery: MessageTally defaultPollPeriod.
self open: inst name: (String streamContents: [ :s | s nextPutAll: 'Time Profile for '; print: msecDuration; nextPutAll: ' msec' ]).
^ inst!
----- Method: TimeProfileBrowser>>initializeMessageList: (in category 'private') -----
initializeMessageList: anArray
messageList := anArray.
messageListIndex := 0.
contents := ''!
----- Method: TimeProfileBrowser>>messageListKey:from: (in category 'private') -----
messageListKey: aChar from: view
"Respond to a Command key. Cmd-D means re-run block."
aChar == $d ifTrue: [^Cursor execute showWhile: [ block value ]].
^super messageListKey: aChar from: view!
----- Method: TimeProfileBrowser>>messageListMenu:shifted: (in category 'private') -----
messageListMenu: aMenu shifted: shifted
"Add a menu to the inherited one."
| menu |
menu := super messageListMenu: aMenu shifted: shifted.
" menu addItem: (0)."
^menu!
----- Method: TimeProfileBrowser>>runBlock: (in category 'private') -----
runBlock: aBlock
^self runBlock: aBlock pollingEvery: MessageTally defaultPollPeriod!
----- Method: TimeProfileBrowser>>runBlock:pollingEvery: (in category 'private') -----
runBlock: aBlock pollingEvery: pollPeriod
| stream list result |
block := MessageSend
receiver: self
selector: #runBlock:pollingEvery:
arguments: {
aBlock.
pollPeriod}. "so we can re-run it"
tally := MessageTally new.
tally
maxClassNameSize: 1000;
maxClassPlusSelectorSize: 1000;
maxTabs: 100.
result := tally spyEvery: pollPeriod on: aBlock.
stream := ReadWriteStream
with: (String streamContents:
[:s |
tally
report: s;
close]).
stream reset.
list := OrderedCollection new.
[stream atEnd] whileFalse: [list add: stream nextLine].
self initializeMessageList: list.
self changed: #messageList.
self changed: #messageListIndex.
^result!
----- Method: TimeProfileBrowser>>runProcess:forMilliseconds:pollingEvery: (in category 'private') -----
runProcess: aProcess forMilliseconds: msecDuration pollingEvery: pollPeriod
| stream list result |
block := MessageSend
receiver: self
selector: #runProcess:forMilliseconds:pollingEvery:
arguments: {
aProcess.
msecDuration.
pollPeriod}. "so we can re-run it"
tally := MessageTally new.
tally
maxClassNameSize: 1000;
maxClassPlusSelectorSize: 1000;
maxTabs: 100.
result := tally
spyEvery: pollPeriod
onProcess: aProcess
forMilliseconds: msecDuration.
stream := ReadWriteStream
with: (String streamContents:
[:s |
tally
report: s;
close]).
stream reset.
list := OrderedCollection new.
[stream atEnd] whileFalse: [list add: stream nextLine].
self initializeMessageList: list.
self changed: #messageList.
self changed: #messageListIndex.
^result!
----- Method: TimeProfileBrowser>>selectedClass (in category 'accessing') -----
selectedClass
"Answer the receiver's 'selectedClass'."
^selectedClass!
----- Method: TimeProfileBrowser>>selectedClass: (in category 'accessing') -----
selectedClass: anObject
"Set the receiver's instance variable 'selectedClass' to be anObject."
selectedClass := anObject!
----- Method: TimeProfileBrowser>>selectedMessage (in category 'message list') -----
selectedMessage
"Answer the source method for the currently selected message."
| source |
self setClassAndSelectorIn:
[:class :selector |
source := class sourceMethodAt: selector ifAbsent: [^'Missing'].
Preferences browseWithPrettyPrint
ifTrue:
[source := class prettyPrinterClass
format: source
in: class
notifying: nil
decorated: false].
self selectedClass: class.
self selectedSelector: selector.
^source asText makeSelectorBoldIn: class].
^''!
----- Method: TimeProfileBrowser>>selectedSelector (in category 'accessing') -----
selectedSelector
"Answer the receiver's 'selectedSelector'."
^selectedSelector!
----- Method: TimeProfileBrowser>>selectedSelector: (in category 'accessing') -----
selectedSelector: anObject
"Set the receiver's instance variable 'selectedSelector' to be anObject."
selectedSelector := anObject!
----- Method: TimeProfileBrowser>>setClassAndSelectorIn: (in category 'private') -----
setClassAndSelectorIn: csBlock
"Decode strings of the form <selectorName> (<className> [class]) "
| string strm class sel parens |
self flag: #mref. "fix for faster references to methods"
[string := self selection asString.
string first == $* ifTrue: [^contents := nil]. "Ignore lines starting with *"
parens := string includes: $(. "Does it have open-paren?"
strm := ReadStream on: string.
parens
ifTrue: [strm skipTo: $(. "easy case"
class := strm upTo: $).
strm next: 2.
sel := strm upToEnd]
ifFalse: [strm position: (string findString: ' class>>').
strm position > 0
ifFalse: [strm position: (string findLast: [ :ch | ch == $ ])]
ifTrue:
[ | subString | "find the next to last space character"
subString := strm contents copyFrom: 1 to: (string findLast: [ :ch | ch == $ ]) - 1.
strm position: (subString findLast: [ :ch | ch == $ ])].
"ifFalse: [strm position: (string findLast: [ :ch | ch == $ ])."
class := strm upTo: $>.
strm next.
sel := strm upToEnd].
^ MessageSet parse: (class, ' ', sel) toClassAndSelector: csBlock]
on: Error do: [:ex | ^ contents := nil]!
----- Method: TimeProfileBrowser>>tally (in category 'accessing') -----
tally
"Answer the receiver's 'tally'."
^tally!
----- Method: TimeProfileBrowser>>tally: (in category 'accessing') -----
tally: anObject
"Set the receiver's instance variable 'tally' to be anObject."
tally := anObject!
Browser subclass: #PackagePaneBrowser
instanceVariableNames: 'package packageListIndex packageList'
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Browser'!
!PackagePaneBrowser commentStamp: '<historical>' prior: 0!
A package browser represents a hierarchical query path through an organization of class and method information. It parses class categories into a two-level hierarchy on the first '-' character, giving "packages" (e.g., Magnitude, Collections, Graphics, etc.), and "categories" (e.g., Magnitude-General and Magnitude-Number).
Instance Variables:
package <Symbol> the "category header," e.g., #Magnitudes or #Collections
packageListIndex <Integer> The index in the package list
packageList <OrderedCollection of String> the list of package names
!
----- Method: PackagePaneBrowser class>>prototypicalToolWindow (in category 'instance creation') -----
prototypicalToolWindow
"Answer an example of myself seen in a tool window, for the benefit of parts-launching tools"
| aWindow |
aWindow := self new openEditString: nil.
^ ToolBuilder build: aWindow!
----- Method: PackagePaneBrowser class>>registerInAppRegistry (in category 'class initialization') -----
registerInAppRegistry
"Register the receiver in the SystemBrowser AppRegistry"
SystemBrowser register: self.!
----- Method: PackagePaneBrowser class>>windowColorSpecification (in category 'window color') -----
windowColorSpecification
"Answer a WindowColorSpec object that declares my preference"
^ WindowColorSpec classSymbol: self name wording: 'Package Browser' brightColor: #(1.0 1.0 0.6) pastelColor: #(0.976 0.976 0.835) helpMessage: 'A system browser with an extra pane at top-left for module.'!
----- Method: PackagePaneBrowser>>buildPackageListWith: (in category 'initialize-release') -----
buildPackageListWith: builder
| listSpec |
listSpec := builder pluggableListSpec new.
listSpec
model: self;
list: #packageList;
getIndex: #packageListIndex;
setIndex: #packageListIndex:;
menu: #packageMenu:;
keyPress: #packageListKey:from:.
^listSpec
!
----- Method: PackagePaneBrowser>>categoryExistsForPackage (in category 'package list') -----
categoryExistsForPackage
^ self hasPackageSelected
and: [(systemOrganizer categories indexOf: self package asSymbol) ~= 0]
!
----- Method: PackagePaneBrowser>>changeCategoryForClass:srcSystemCategory:atListMorph:internal:copy: (in category 'dragNDrop') -----
changeCategoryForClass: class srcSystemCategory: srcSystemCategorySel atListMorph: dstListMorph internal: internal copy: copyFlag
"only move semantic"
| newClassCategory success |
self flag: #stringSymbolProblem.
success := copyFlag not ifFalse: [^ false].
newClassCategory := self dstCategoryDstListMorph: dstListMorph internal: internal.
(success := newClassCategory notNil & (newClassCategory ~= class category))
ifTrue:
[class category: newClassCategory.
self changed: #classList.
internal ifFalse: [self selectClass: class]].
^ success!
----- Method: PackagePaneBrowser>>classList (in category 'class list') -----
classList
"Answer an array of the class names of the selected category. Answer an
empty array if no selection exists."
^ self hasSystemCategorySelected
ifFalse:
[self packageClasses]
ifTrue: [systemOrganizer listAtCategoryNumber:
(systemOrganizer categories indexOf: self selectedSystemCategoryName asSymbol)]!
----- Method: PackagePaneBrowser>>defaultBrowserTitle (in category 'initialize-release') -----
defaultBrowserTitle
^ 'Package Browser'!
----- Method: PackagePaneBrowser>>dstCategoryDstListMorph:internal: (in category 'dragNDrop util') -----
dstCategoryDstListMorph: dstListMorph internal: internal
| dropItem |
^ internal & (dstListMorph getListSelector == #systemCategoryList)
ifTrue: [(dropItem := dstListMorph potentialDropItem) ifNotNil: [(self package , '-' , dropItem) asSymbol]]
ifFalse: [self selectedSystemCategoryName]!
----- Method: PackagePaneBrowser>>hasPackageSelected (in category 'package list') -----
hasPackageSelected
^ packageListIndex ~= 0!
----- Method: PackagePaneBrowser>>hasSystemCategorySelected (in category 'system category list') -----
hasSystemCategorySelected
^ systemCategoryListIndex ~= 0!
----- Method: PackagePaneBrowser>>openEditString: (in category 'initialize-release') -----
openEditString: aString
"Create a pluggable version of all the views for a Browser, including views and controllers."
"Example:
PackagePaneBrowser fullOnClass: Browser.
"
| builder max |
builder := ToolBuilder default.
max := self wantsOptionalButtons ifTrue:[0.42] ifFalse:[0.5].
^self buildWindowWith: builder specs: {
(0 at 0 corner: 0.15 at max) -> [self buildPackageListWith: builder].
(0.15 at 0 corner: 0.35 at max) -> [self buildSystemCategoryListWith: builder].
(0.35 at 0 corner: 0.6@(max-0.1)) -> [self buildClassListWith: builder].
(0.35@(max-0.1) corner: 0.6 at max) -> [self buildSwitchesWith: builder].
(0.6 at 0 corner: 0.75 at max) -> [self buildMessageCategoryListWith: builder].
(0.75 at 0 corner: 1 at max) -> [self buildMessageListWith: builder].
(0 at max corner: 1 at 1) -> [self buildCodePaneWith: builder].
}!
----- Method: PackagePaneBrowser>>package (in category 'package list') -----
package
"Answer the receiver's 'package'."
^ self hasPackageSelected
ifFalse: [nil]
ifTrue: [self packageList at: packageListIndex]
!
----- Method: PackagePaneBrowser>>packageClasses (in category 'class list') -----
packageClasses
^ self categoryExistsForPackage
ifFalse: [Array new]
ifTrue:
[systemOrganizer listAtCategoryNumber:
(systemOrganizer categories indexOf: self package asSymbol)]!
----- Method: PackagePaneBrowser>>packageList (in category 'package list') -----
packageList
"Answer a list of the packages in the current system organization."
| str cats stream |
str := Set new: 100.
stream := WriteStream on: (Array new: 100).
systemOrganizer categories do:
[ :categ |
cats := categ asString copyUpTo: $-.
(str includes: cats) ifFalse:
[str add: cats.
stream nextPut: cats]].
^stream contents!
----- Method: PackagePaneBrowser>>packageListIndex (in category 'package list') -----
packageListIndex
"Answer the index of the current package selection."
^packageListIndex!
----- Method: PackagePaneBrowser>>packageListIndex: (in category 'package list') -----
packageListIndex: anInteger
"Set anInteger to be the index of the current package selection."
packageListIndex := anInteger.
anInteger = 0
ifFalse: [package := self packageList at: packageListIndex].
messageCategoryListIndex := 0.
systemCategoryListIndex := 0.
messageListIndex := 0.
classListIndex := 0.
self setClassOrganizer.
self changed: #packageSelectionChanged.
self changed: #packageListIndex. "update my selection"
self changed: #systemCategoryList. "update the category list"
self systemCategoryListIndex: 0. "update category list selection"
!
----- Method: PackagePaneBrowser>>packageMenu: (in category 'package list') -----
packageMenu: aMenu
"Answer a Menu of operations on class packages to be
displayed when the operate menu button is pressed."
^aMenu
labels: 'find class...\recent classes...\reorganize\update' withCRs
lines: #(2)
selections: #(#findClass #recent #editSystemCategories #updatePackages)!
----- Method: PackagePaneBrowser>>selectCategoryForClass: (in category 'system category list') -----
selectCategoryForClass: theClass
"Set the package and category lists to display the given class."
| cat |
cat := theClass category.
self packageListIndex: (self packageList indexOf: (cat copyUpTo: $-)).
self systemCategoryListIndex: (self systemCategoryList indexOf:
(cat copyFrom: ((cat indexOf: $- ifAbsent: [0]) + 1) to: cat size)).!
----- Method: PackagePaneBrowser>>selectedClass (in category 'class list') -----
selectedClass
"Answer the class that is currently selected. Answer nil if no selection
exists."
| name envt |
(name := self selectedClassName) ifNil: [^ nil].
"(envt := self selectedEnvironment) ifNil: [^ nil]."
envt:= Smalltalk.
^ envt at: name!
----- Method: PackagePaneBrowser>>selectedSystemCategoryName (in category 'system category list') -----
selectedSystemCategoryName
"Answer the name of the selected system category or nil."
systemCategoryListIndex = 0
ifTrue: [^nil].
packageListIndex = 0
ifTrue: [^ self systemCategoryList at: systemCategoryListIndex].
^ self package , '-' , (self systemCategoryList at: systemCategoryListIndex)!
----- Method: PackagePaneBrowser>>systemCategoryList (in category 'system category list') -----
systemCategoryList
"Answer the sequenceable collection containing the class categories that
the receiver accesses."
| prefix |
packageListIndex = 0 ifTrue: [^ systemOrganizer categories].
prefix := self package, '-'.
^ Array streamContents:
[:strm |
systemOrganizer categories do:
[ :cat | (cat beginsWith: prefix) ifTrue:
[strm nextPut: (cat copyFrom: prefix size + 1 to: cat size)]]]!
----- Method: PackagePaneBrowser>>systemOrganizer: (in category 'initialize-release') -----
systemOrganizer: aSystemOrganizer
"Initialize the receiver as a perspective on the system organizer,
aSystemOrganizer. Typically there is only one--the system variable
SystemOrganization."
super systemOrganizer: aSystemOrganizer .
packageListIndex := 0!
----- Method: PackagePaneBrowser>>updatePackages (in category 'package list') -----
updatePackages
"Update the contents of the package list."
self editSelection: #none.
self changed: #packageList.
self changed: #package.
self packageListIndex: 0 !
CodeHolder subclass: #ChangeList
instanceVariableNames: 'changeList list listIndex listSelections file lostMethodPointer showsVersions'
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Changes'!
!ChangeList commentStamp: '<historical>' prior: 0!
A ChangeList represents a list of changed methods that reside on a file in fileOut format. The classes and methods in my list are not necessarily in this image!! Used as the model for both Version Lists and Changed Methods (in Screen Menu, Changes...). Note that the two kinds of window have different controller classes!!!!
It holds three lists:
changeList - a list of ChangeRecords
list - a list of one-line printable headers
listSelections - a list of Booleans (true = selected, false = not selected) multiple OK.
listIndex
Items that are removed (removeDoits, remove an item) are removed from all three lists.
Most recently clicked item is the one showing in the bottom pane.!
----- Method: ChangeList class>>browseChangesFile: (in category 'fileIn/Out') -----
browseChangesFile: fullName
"Browse the selected file in fileIn format."
fullName
ifNotNil:
[ChangeList browseStream: (FileStream readOnlyFileNamed: fullName)]
ifNil:
[Beeper beep]!
----- Method: ChangeList class>>browseCompressedChangesFile: (in category 'fileIn/Out') -----
browseCompressedChangesFile: fullName
"Browse the selected file in fileIn format."
| zipped unzipped stream |
fullName ifNil: [^Beeper beep].
stream := FileStream readOnlyFileNamed: fullName.
[stream converter: Latin1TextConverter new.
zipped := GZipReadStream on: stream.
unzipped := zipped contents asString]
ensure: [stream close].
stream := (MultiByteBinaryOrTextStream with: unzipped) reset.
ChangeList browseStream: stream!
----- Method: ChangeList class>>browseFile: (in category 'public access') -----
browseFile: fileName "ChangeList browseFile: 'AutoDeclareFix.st'"
"Opens a changeList on the file named fileName"
^ self browseStream: (FileStream readOnlyFileNamed: fileName)!
----- Method: ChangeList class>>browseRecent: (in category 'public access') -----
browseRecent: charCount
"ChangeList browseRecent: 5000"
"Opens a changeList on the end of the changes log file"
^ self browseRecent: charCount on: (SourceFiles at: 2) !
----- Method: ChangeList class>>browseRecent:on: (in category 'public access') -----
browseRecent: charCount on: origChangesFile
"Opens a changeList on the end of the specified changes log file"
| changeList end changesFile |
changesFile := origChangesFile readOnlyCopy.
changesFile setConverterForCode.
end := changesFile size.
Cursor read
showWhile: [changeList := self new
scanFile: changesFile
from: (0 max: end - charCount)
to: end].
changesFile close.
self
open: changeList
name: 'Recent changes'
multiSelect: true!
----- Method: ChangeList class>>browseRecentLog (in category 'public access') -----
browseRecentLog
"ChangeList browseRecentLog"
"Prompt with a menu of how far back to go to browse the current image's changes log file"
^ self
browseRecentLogOn: (SourceFiles at: 2)
startingFrom: SmalltalkImage current lastQuitLogPosition!
----- Method: ChangeList class>>browseRecentLogOn: (in category 'public access') -----
browseRecentLogOn: origChangesFile
"figure out where the last snapshot or quit was, then browse the recent entries."
| end done block pos chunk changesFile positions prevBlock |
changesFile := origChangesFile readOnlyCopy.
positions := SortedCollection new.
end := changesFile size.
prevBlock := end.
block := end - 1024 max: 0.
done := false.
[done
or: [positions size > 0]]
whileFalse: [changesFile position: block.
"ignore first fragment"
changesFile nextChunk.
[changesFile position < prevBlock]
whileTrue: [pos := changesFile position.
chunk := changesFile nextChunk.
((chunk indexOfSubCollection: '----' startingAt: 1) = 1) ifTrue: [
({ '----QUIT'. '----SNAPSHOT' } anySatisfy: [ :str |
chunk beginsWith: str ])
ifTrue: [positions add: pos]]].
block = 0
ifTrue: [done := true]
ifFalse: [prevBlock := block.
block := block - 1024 max: 0]].
changesFile close.
positions isEmpty
ifTrue: [self inform: 'File ' , changesFile name , ' does not appear to be a changes file']
ifFalse: [self browseRecentLogOn: origChangesFile startingFrom: positions last]!
----- Method: ChangeList class>>browseRecentLogOn:startingFrom: (in category 'public access') -----
browseRecentLogOn: origChangesFile startingFrom: initialPos
"Prompt with a menu of how far back to go when browsing a changes file."
| end banners positions pos chunk i changesFile |
changesFile := origChangesFile readOnlyCopy.
banners := OrderedCollection new.
positions := OrderedCollection new.
end := changesFile size.
changesFile setConverterForCode.
pos := initialPos.
[pos = 0
or: [banners size > 20]]
whileFalse: [changesFile position: pos.
chunk := changesFile nextChunk.
i := chunk indexOfSubCollection: 'priorSource: ' startingAt: 1.
i > 0
ifTrue: [positions addLast: pos.
banners
addLast: (chunk copyFrom: 5 to: i - 2).
pos := Number
readFrom: (chunk copyFrom: i + 13 to: chunk size)]
ifFalse: [pos := 0]].
changesFile close.
banners size == 0 ifTrue: [^ self inform:
'this image has never been saved
since changes were compressed'].
pos := UIManager default chooseFrom: banners values: positions
title: 'Browse as far back as...'.
pos == nil
ifTrue: [^ self].
self browseRecent: end - pos on: origChangesFile!
----- Method: ChangeList class>>browseRecentLogOnPath: (in category 'public access') -----
browseRecentLogOnPath: fullName
"figure out where the last snapshot or quit was, then browse the recent entries."
fullName
ifNotNil:
[self browseRecentLogOn: (FileStream readOnlyFileNamed: fullName)]
ifNil:
[Beeper beep]
!
----- Method: ChangeList class>>browseStream: (in category 'public access') -----
browseStream: changesFile
"Opens a changeList on a fileStream"
| changeList charCount |
changesFile readOnly.
changesFile setConverterForCode.
charCount := changesFile size.
charCount > 1000000 ifTrue:
[(self confirm: 'The file ', changesFile name , '
is really long (' , charCount printString , ' characters).
Would you prefer to view only the last million characters?')
ifTrue: [charCount := 1000000]].
"changesFile setEncoderForSourceCodeNamed: changesFile name."
Cursor read showWhile:
[changeList := self new
scanFile: changesFile from: changesFile size-charCount to: changesFile size].
changesFile close.
self open: changeList name: changesFile localName , ' log' multiSelect: true!
----- Method: ChangeList class>>fileReaderServicesForFile:suffix: (in category 'fileIn/Out') -----
fileReaderServicesForFile: fullName suffix: suffix
| services |
services := OrderedCollection new.
(FileStream isSourceFileSuffix: suffix) | (suffix = '*')
ifTrue: [ services add: self serviceBrowseChangeFile ].
(suffix = 'changes') | (suffix = '*')
ifTrue: [ services add: self serviceBrowseDotChangesFile ].
(fullName asLowercase endsWith: '.cs.gz') | (suffix = '*')
ifTrue: [ services add: self serviceBrowseCompressedChangeFile ].
^services!
----- Method: ChangeList class>>getRecentLocatorWithPrompt: (in category 'public access') -----
getRecentLocatorWithPrompt: aPrompt
"Prompt with a menu of how far back to go. Return nil if user backs out. Otherwise return the number of characters back from the end of the .changes file the user wishes to include"
"ChangeList getRecentPosition"
| end changesFile banners positions pos chunk i |
changesFile := (SourceFiles at: 2) readOnlyCopy.
banners := OrderedCollection new.
positions := OrderedCollection new.
end := changesFile size.
pos := SmalltalkImage current lastQuitLogPosition.
[pos = 0 or: [banners size > 20]] whileFalse:
[changesFile position: pos.
chunk := changesFile nextChunk.
i := chunk indexOfSubCollection: 'priorSource: ' startingAt: 1.
i > 0 ifTrue: [positions addLast: pos.
banners addLast: (chunk copyFrom: 5 to: i-2).
pos := Number readFrom: (chunk copyFrom: i+13 to: chunk size)]
ifFalse: [pos := 0]].
changesFile close.
pos := UIManager default chooseFrom: banners values: positions title: aPrompt.
pos == nil ifTrue: [^ nil].
^ end - pos!
----- Method: ChangeList class>>initialize (in category 'initialize-release') -----
initialize
FileList registerFileReader: self!
----- Method: ChangeList class>>open:name:multiSelect: (in category 'instance creation') -----
open: aChangeList name: aString multiSelect: multiSelect
"Create a standard system view for the messageSet, whose label is aString.
The listView may be either single or multiple selection type"
^ToolBuilder default open: aChangeList label: aString!
----- Method: ChangeList class>>serviceBrowseChangeFile (in category 'fileIn/Out') -----
serviceBrowseChangeFile
"Answer a service for opening a changelist browser on a file"
^ (SimpleServiceEntry
provider: self
label: 'changelist browser'
selector: #browseStream:
description: 'open a changelist tool on this file'
buttonLabel: 'changes')
argumentGetter: [ :fileList | fileList readOnlyStream ]!
----- Method: ChangeList class>>serviceBrowseCompressedChangeFile (in category 'fileIn/Out') -----
serviceBrowseCompressedChangeFile
"Answer a service for opening a changelist browser on a file"
^ SimpleServiceEntry
provider: self
label: 'changelist browser'
selector: #browseCompressedChangesFile:
description: 'open a changelist tool on this file'
buttonLabel: 'changes'!
----- Method: ChangeList class>>serviceBrowseDotChangesFile (in category 'fileIn/Out') -----
serviceBrowseDotChangesFile
"Answer a service for opening a changelist browser on the tail end of a .changes file"
^ SimpleServiceEntry
provider: self
label: 'recent changes in file'
selector: #browseRecentLogOnPath:
description: 'open a changelist tool on recent changes in file'
buttonLabel: 'recent changes'!
----- Method: ChangeList class>>services (in category 'fileIn/Out') -----
services
"Answer potential file services associated with this class"
^ { self serviceBrowseChangeFile.
self serviceBrowseDotChangesFile.
self serviceBrowseCompressedChangeFile }!
----- Method: ChangeList class>>unload (in category 'class initialization') -----
unload
FileList unregisterFileReader: self !
----- Method: ChangeList class>>windowColorSpecification (in category 'window color') -----
windowColorSpecification
"Answer a WindowColorSpec object that declares my preference"
^ WindowColorSpec classSymbol: self name wording: 'Change List' brightColor: #lightBlue pastelColor: #paleBlue helpMessage: 'A tool that presents a list of all the changes found in an external file.'!
----- Method: ChangeList>>acceptFrom: (in category 'menu actions') -----
acceptFrom: aView
aView controller text = aView controller initialText ifFalse: [
aView flash.
^ self inform: 'You can only accept this version as-is.
If you want to edit, copy the text to a browser'].
(aView setText: aView controller text from: self) ifTrue:
[aView ifNotNil: [aView controller accept]]. "initialText"
!
----- Method: ChangeList>>addItem:text: (in category 'initialization-release') -----
addItem: item text: text
| cr |
cr := Character cr.
changeList addLast: item.
list addLast: (text collect: [:x | x = cr ifTrue: [$/] ifFalse: [x]])!
----- Method: ChangeList>>annotation (in category 'viewing access') -----
annotation
"Answer the string to be shown in an annotation pane. Make plain that the annotation is associated with the current in-image version of the code, not of the selected disk-based version, and if the corresponding method is missing from the in-image version, mention that fact."
| annot aChange aClass |
annot := super annotation.
annot asString = '------' ifTrue: [^ annot].
^ ((aChange := self currentChange) notNil and: [aChange methodSelector notNil])
ifFalse:
[annot]
ifTrue:
[((aClass := aChange methodClass) isNil or: [(aClass includesSelector: aChange methodSelector) not])
ifTrue:
[aChange methodClassName, ' >> ', aChange methodSelector, ' is not present in the current image.']
ifFalse:
['current version: ', annot]]!
----- Method: ChangeList>>browseAllVersionsOfSelections (in category 'menu actions') -----
browseAllVersionsOfSelections
"Opens a Versions browser on all the currently selected methods, showing each alongside all of their historical versions."
| oldSelection aList |
oldSelection := self listIndex.
aList := OrderedCollection new.
Cursor read showWhile: [
1 to: changeList size do: [:i |
(listSelections at: i) ifTrue: [
listIndex := i.
self browseVersions.
aList add: i.
]]].
listIndex := oldSelection.
aList size == 0 ifTrue: [^ self inform: 'no selected methods have in-memory counterparts'].
!
----- Method: ChangeList>>browseCurrentVersionsOfSelections (in category 'menu actions') -----
browseCurrentVersionsOfSelections
"Opens a message-list browser on the current in-memory versions of all methods that are currently seleted"
| aClass aChange aList |
aList := OrderedCollection new.
Cursor read showWhile: [
1 to: changeList size do: [:i |
(listSelections at: i) ifTrue: [
aChange := changeList at: i.
(aChange type = #method
and: [(aClass := aChange methodClass) notNil
and: [aClass includesSelector: aChange methodSelector]])
ifTrue: [
aList add: (
MethodReference new
setStandardClass: aClass
methodSymbol: aChange methodSelector
)
]]]].
aList size == 0 ifTrue: [^ self inform: 'no selected methods have in-memory counterparts'].
MessageSet
openMessageList: aList
name: 'Current versions of selected methods in ', file localName!
----- Method: ChangeList>>browseVersions (in category 'menu actions') -----
browseVersions
| change class browser |
listIndex = 0
ifTrue: [^ nil ].
change := changeList at: listIndex.
((class := change methodClass) notNil
and: [class includesSelector: change methodSelector])
ifFalse: [ ^nil ].
browser := super browseVersions.
browser ifNotNil: [ browser addedChangeRecord: change ].
^browser!
----- Method: ChangeList>>buildChangeListWith:multiSelect: (in category 'toolbuilder') -----
buildChangeListWith: builder multiSelect: multiSelect
| listSpec |
multiSelect ifTrue:[
listSpec := builder pluggableMultiSelectionListSpec new.
listSpec getSelectionList: #listSelectionAt:.
listSpec setSelectionList: #listSelectionAt:put:.
] ifFalse:[
listSpec := builder pluggableListSpec new.
].
listSpec
model: self;
list: #list;
getIndex: #listIndex;
setIndex: #toggleListIndex:;
menu: (self showsVersions ifTrue: [#versionsMenu:] ifFalse: [#changeListMenu:]);
keyPress: #changeListKey:from:.
^listSpec!
----- Method: ChangeList>>buildMorphicCodePaneWith: (in category 'menu actions') -----
buildMorphicCodePaneWith: editString
| codePane |
codePane := AcceptableCleanTextMorph
on: self
text: #contents
accept: #contents:
readSelection: #contentsSelection
menu: #codePaneMenu:shifted:.
codePane font: Preferences standardCodeFont.
editString ifNotNil: [
codePane editString: editString.
codePane hasUnacceptedEdits: true
].
^codePane
!
----- Method: ChangeList>>buildWith: (in category 'toolbuilder') -----
buildWith: builder
^self buildWith: builder multiSelect: self showsVersions not!
----- Method: ChangeList>>buildWith:multiSelect: (in category 'toolbuilder') -----
buildWith: builder multiSelect: multiSelect
"Open a morphic view for the messageSet, whose label is labelString.
The listView may be either single or multiple selection type"
| windowSpec max |
max := self wantsOptionalButtons ifTrue:[0.33] ifFalse:[0.4].
windowSpec := self buildWindowWith: builder specs: {
(0 at 0 corner: 1 at max) -> [self buildChangeListWith: builder multiSelect: multiSelect].
(0 at max corner: 1 at 1) -> [self buildCodePaneWith: builder].
}.
^builder build: windowSpec!
----- Method: ChangeList>>changeList (in category 'accessing') -----
changeList
^ changeList!
----- Method: ChangeList>>changeListButtonSpecs (in category 'initialization-release') -----
changeListButtonSpecs
^#(
('select all' selectAll 'select all entries')
('deselect all' deselectAll 'deselect all entries')
('select conflicts' selectAllConflicts 'select all methods that occur in any change set')
('file in selections' fileInSelections 'file in all selected entries')
)!
----- Method: ChangeList>>changeListKey:from: (in category 'menu actions') -----
changeListKey: aChar from: view
"Respond to a Command key in the list pane."
aChar == $D ifTrue: [^ self toggleDiffing].
aChar == $a ifTrue: [^ self selectAll].
^ self arrowKey: aChar from: view!
----- Method: ChangeList>>changeListMenu: (in category 'menu actions') -----
changeListMenu: aMenu
"Fill aMenu up so that it comprises the primary changelist-browser menu"
Smalltalk isMorphic ifTrue:
[aMenu addTitle: 'change list'.
aMenu addStayUpItemSpecial].
aMenu addList: #(
('fileIn selections' fileInSelections 'import the selected items into the image')
('fileOut selections... ' fileOutSelections 'create a new file containing the selected items')
-
('compare to current' compareToCurrentVersion 'open a separate window which shows the text differences between the on-file version and the in-image version.' )
('toggle diffing (D)' toggleDiffing 'start or stop showing diffs in the code pane.')
-
('select conflicts with any changeset' selectAllConflicts 'select methods in the file which also occur in any change-set in the system')
('select conflicts with current changeset' selectConflicts 'select methods in the file which also occur in the current change-set')
('select conflicts with...' selectConflictsWith 'allows you to designate a file or change-set against which to check for code conflicts.')
-
('select unchanged methods' selectUnchangedMethods 'select methods in the file whose in-image versions are the same as their in-file counterparts' )
('select new methods' selectNewMethods 'select methods in the file that do not current occur in the image')
('select methods for this class' selectMethodsForThisClass 'select all methods in the file that belong to the currently-selected class')
-
('select all (a)' selectAll 'select all the items in the list')
('deselect all' deselectAll 'deselect all the items in the list')
('invert selections' invertSelections 'select every item that is not currently selected, and deselect every item that *is* currently selected')
-
('browse all versions of single selection' browseVersions 'open a version browser showing the versions of the currently selected method')
('browse all versions of selections' browseAllVersionsOfSelections 'open a version browser showing all the versions of all the selected methods')
('browse current versions of selections' browseCurrentVersionsOfSelections 'open a message-list browser showing the current (in-image) counterparts of the selected methods')
('destroy current methods of selections' destroyCurrentCodeOfSelections 'remove (*destroy*) the in-image counterparts of all selected methods')
-
('remove doIts' removeDoIts 'remove all items that are doIts rather than methods')
('remove older versions' removeOlderMethodVersions 'remove all but the most recent versions of methods in the list')
('remove up-to-date versions' removeExistingMethodVersions 'remove all items whose code is the same as the counterpart in-image code')
('remove selected items' removeSelections 'remove the selected items from the change-list')
('remove unselected items' removeNonSelections 'remove all the items not currently selected from the change-list')).
^ aMenu
!
----- Method: ChangeList>>changes:file: (in category 'accessing') -----
changes: changeRecords file: aFile
file := aFile.
changeList := OrderedCollection new.
list := OrderedCollection new.
listIndex := 0.
changeRecords do: [:each |
(each respondsTo: #methodClass)
ifFalse: [self addItem: ChangeRecord new text: each asString]
ifTrue:
[self addItem: each text: ('method: ' , each methodClass name , (each isMetaClassChange ifTrue: [' class '] ifFalse: [' '])
, each methodSelector
, '; ' , each stamp)]].
listSelections := Array new: list size withAll: false!
----- Method: ChangeList>>compareToCurrentVersion (in category 'menu actions') -----
compareToCurrentVersion
"If the current selection corresponds to a method in the system, then spawn a window showing the diffs as text"
| change class s1 s2 |
listIndex = 0
ifTrue: [^ self].
change := changeList at: listIndex.
((class := change methodClass) notNil
and: [class includesSelector: change methodSelector])
ifTrue: [s1 := (class sourceCodeAt: change methodSelector) asString.
s2 := change string.
s1 = s2
ifTrue: [^ self inform: 'Exact Match'].
(StringHolder new
textContents: (TextDiffBuilder buildDisplayPatchFrom: s1 to: s2 inClass: class prettyDiffs: self showingPrettyDiffs))
openLabel: 'Comparison to Current Version']
ifFalse: [self flash]!
----- Method: ChangeList>>contents (in category 'viewing access') -----
contents
"Answer the contents string, obeying diffing directives if needed"
^ self showingAnyKindOfDiffs
ifFalse:
[self undiffedContents]
ifTrue:
[self showsVersions
ifTrue:
[self diffedVersionContents]
ifFalse:
[self contentsDiffedFromCurrent]]!
----- Method: ChangeList>>contents: (in category 'viewing access') -----
contents: aString
listIndex = 0 ifTrue: [self changed: #flash. ^ false].
lostMethodPointer ifNotNil: [^ self restoreDeletedMethod].
self okToChange "means not dirty" ifFalse: ["is dirty"
self inform: 'This is a view of a method on a file.\Please cancel your changes. You may\accept, but only when the method is untouched.' withCRs. ^ false].
"Can't accept changes here. Method text must be unchanged!!"
(changeList at: listIndex) fileIn.
^ true!
----- Method: ChangeList>>contentsDiffedFromCurrent (in category 'viewing access') -----
contentsDiffedFromCurrent
"Answer the contents diffed forward from current (in-memory) method version"
| aChange aClass |
listIndex = 0
ifTrue: [^ ''].
aChange := changeList at: listIndex.
^ ((aChange type == #method and: [(aClass := aChange methodClass) notNil]) and: [aClass includesSelector: aChange methodSelector])
ifTrue:
[Utilities methodDiffFor: aChange text class: aClass selector: aChange methodSelector prettyDiffs: self showingPrettyDiffs]
ifFalse:
[(changeList at: listIndex) text]!
----- Method: ChangeList>>contentsSymbolQuints (in category 'viewing access') -----
contentsSymbolQuints
"Answer a list of quintuplets representing information on the alternative views available in the code pane"
^ self sourceAndDiffsQuintsOnly!
----- Method: ChangeList>>currentChange (in category 'accessing') -----
currentChange
"return the current change being viewed, or nil if none"
listIndex = 0 ifTrue: [ ^nil ].
^changeList at: listIndex!
----- Method: ChangeList>>deselectAll (in category 'menu actions') -----
deselectAll
"Deselect all items in the list pane, and clear the code pane"
listIndex := 0.
listSelections atAllPut: false.
self changed: #allSelections.
self contentsChanged!
----- Method: ChangeList>>destroyCurrentCodeOfSelections (in category 'menu actions') -----
destroyCurrentCodeOfSelections
"Actually remove from the system any in-memory methods with class and selector identical to items current selected. This may seem rather arcane but believe me it has its great uses, when trying to split out code. To use effectively, first file out a change set that you wish to split off. Then open a ChangeList browser on that fileout. Now look through the methods, and select any of them which you want to remove completely from the system, then issue this command. For those methods where you have made changes to pre-existing versions, of course, you won't want to remove them from the system, so use this mechanism with care!!"
| aClass aChange aList |
aList := OrderedCollection new.
1 to: changeList size do:
[:index |
(listSelections at: index) ifTrue:
[aChange := changeList at: index.
(aChange type = #method
and: [(aClass := aChange methodClass) notNil
and: [aClass includesSelector: aChange methodSelector]])
ifTrue:
[aList add: {aClass. aChange methodSelector}]]].
aList size > 0 ifTrue:
[(self confirm: 'Warning!! This will actually remove ', aList size printString, ' method(s) from the system!!') ifFalse: [^ self]].
aList do:
[:aPair | Transcript cr; show: 'Removed: ', aPair first printString, '.', aPair second.
aPair first removeSelector: aPair second]!
----- Method: ChangeList>>diffedVersionContents (in category 'viewing access') -----
diffedVersionContents
"Answer diffed version contents, maybe pretty maybe not"
| change class earlier later |
(listIndex = 0
or: [changeList size < listIndex])
ifTrue: [^ ''].
change := changeList at: listIndex.
later := change text.
class := change methodClass.
(listIndex == changeList size or: [class == nil])
ifTrue: [^ later].
earlier := (changeList at: listIndex + 1) text.
^ TextDiffBuilder buildDisplayPatchFrom: earlier to: later inClass: class prettyDiffs: self showingPrettyDiffs!
----- Method: ChangeList>>file (in category 'accessing') -----
file
^file!
----- Method: ChangeList>>fileInSelections (in category 'menu actions') -----
fileInSelections
| any |
any := false.
listSelections with: changeList do:
[:selected :item | selected ifTrue: [any := true. item fileIn]].
any ifFalse:
[self inform: 'nothing selected, so nothing done']!
----- Method: ChangeList>>fileOutSelections (in category 'menu actions') -----
fileOutSelections
| fileName internalStream |
fileName := UIManager default request: 'Enter the base of file name' initialAnswer: 'Filename'.
internalStream := WriteStream on: (String new: 1000).
internalStream header; timeStamp.
listSelections with: changeList do:
[:selected :item | selected ifTrue: [item fileOutOn: internalStream]].
FileStream writeSourceCodeFrom: internalStream baseName: fileName isSt: true useHtml: false.
!
----- Method: ChangeList>>initialize (in category 'initialization-release') -----
initialize
"Initialize a blank ChangeList. Set the contentsSymbol to reflect whether diffs will initally be shown or not"
contentsSymbol := Preferences diffsInChangeList
ifTrue:
[self defaultDiffsSymbol]
ifFalse:
[#source].
changeList := OrderedCollection new.
list := OrderedCollection new.
listIndex := 0.
super initialize!
----- Method: ChangeList>>invertSelections (in category 'menu actions') -----
invertSelections
"Invert the selectedness of each item in the changelist"
listSelections := listSelections collect: [ :ea | ea not].
listIndex := 0.
self changed: #allSelections.
self contentsChanged!
----- Method: ChangeList>>list (in category 'viewing access') -----
list
^ list!
----- Method: ChangeList>>listHasSingleEntry (in category 'accessing') -----
listHasSingleEntry
"does the list of changes have only a single item?"
^list size = 1!
----- Method: ChangeList>>listIndex (in category 'viewing access') -----
listIndex
^ listIndex!
----- Method: ChangeList>>listSelectionAt: (in category 'viewing access') -----
listSelectionAt: index
^ listSelections at: index!
----- Method: ChangeList>>listSelectionAt:put: (in category 'viewing access') -----
listSelectionAt: index put: value
^ listSelections at: index put: value!
----- Method: ChangeList>>listSelections (in category 'accessing') -----
listSelections
listSelections ifNil: [
list ifNotNil: [
listSelections := Array new: list size withAll: false]].
^ listSelections!
----- Method: ChangeList>>optionalButtonHeight (in category 'initialization-release') -----
optionalButtonHeight
^ 15!
----- Method: ChangeList>>perform:orSendTo: (in category 'menu actions') -----
perform: selector orSendTo: otherTarget
"Selector was just chosen from a menu by a user. If I can respond, then perform it on myself. If not, send it to otherTarget, presumably the editPane from which the menu was invoked."
(#accept == selector) ifTrue:
[otherTarget isMorph ifFalse: [^ self acceptFrom: otherTarget view]].
"weird special case just for mvc changlist"
^ super perform: selector orSendTo: otherTarget!
----- Method: ChangeList>>removeDoIts (in category 'menu actions') -----
removeDoIts
"Remove doits from the receiver, other than initializes. 1/26/96 sw"
| newChangeList newList |
newChangeList := OrderedCollection new.
newList := OrderedCollection new.
changeList with: list do:
[:chRec :str |
(chRec type ~~ #doIt or:
[str endsWith: 'initialize'])
ifTrue:
[newChangeList add: chRec.
newList add: str]].
newChangeList size < changeList size
ifTrue:
[changeList := newChangeList.
list := newList.
listIndex := 0.
listSelections := Array new: list size withAll: false].
self changed: #list.
!
----- Method: ChangeList>>removeExistingMethodVersions (in category 'menu actions') -----
removeExistingMethodVersions
"Remove all up to date version of entries from the receiver"
| newChangeList newList str keep cls sel |
newChangeList := OrderedCollection new.
newList := OrderedCollection new.
changeList with: list do:[:chRec :strNstamp |
keep := true.
(cls := chRec methodClass) ifNotNil:[
str := chRec string.
sel := cls parserClass new parseSelector: str.
keep := (cls sourceCodeAt: sel ifAbsent:['']) asString ~= str.
].
keep ifTrue:[
newChangeList add: chRec.
newList add: strNstamp]].
newChangeList size < changeList size
ifTrue:
[changeList := newChangeList.
list := newList.
listIndex := 0.
listSelections := Array new: list size withAll: false].
self changed: #list!
----- Method: ChangeList>>removeNonSelections (in category 'menu actions') -----
removeNonSelections
"Remove the unselected items from the receiver."
| newChangeList newList |
newChangeList := OrderedCollection new.
newList := OrderedCollection new.
1 to: changeList size do:
[:i | (listSelections at: i) ifTrue:
[newChangeList add: (changeList at: i).
newList add: (list at: i)]].
newChangeList size == 0 ifTrue:
[^ self inform: 'That would remove everything.
Why would you want to do that?'].
newChangeList size < changeList size
ifTrue:
[changeList := newChangeList.
list := newList.
listIndex := 0.
listSelections := Array new: list size withAll: false].
self changed: #list
!
----- Method: ChangeList>>removeOlderMethodVersions (in category 'menu actions') -----
removeOlderMethodVersions
"Remove older versions of entries from the receiver."
| newChangeList newList found str |
newChangeList := OrderedCollection new.
newList := OrderedCollection new.
found := OrderedCollection new.
changeList reverseWith: list do:
[:chRec :strNstamp | str := strNstamp copyUpTo: $;.
(found includes: str)
ifFalse:
[found add: str.
newChangeList add: chRec.
newList add: strNstamp]].
newChangeList size < changeList size
ifTrue:
[changeList := newChangeList reversed.
list := newList reversed.
listIndex := 0.
listSelections := Array new: list size withAll: false].
self changed: #list!
----- Method: ChangeList>>removeSelections (in category 'menu actions') -----
removeSelections
"Remove the selected items from the receiver. 9/18/96 sw"
| newChangeList newList |
newChangeList := OrderedCollection new.
newList := OrderedCollection new.
1 to: changeList size do:
[:i | (listSelections at: i) ifFalse:
[newChangeList add: (changeList at: i).
newList add: (list at: i)]].
newChangeList size < changeList size
ifTrue:
[changeList := newChangeList.
list := newList.
listIndex := 0.
listSelections := Array new: list size withAll: false].
self changed: #list
!
----- Method: ChangeList>>restoreDeletedMethod (in category 'viewing access') -----
restoreDeletedMethod
"If lostMethodPointer is not nil, then this is a version browser for a method that has been removed. In this case we want to establish a sourceCode link to prior versions. We do this by installing a dummy method with the correct source code pointer prior to installing this version."
| dummyMethod class selector |
dummyMethod := CompiledMethod toReturnSelf setSourcePointer: lostMethodPointer.
class := (changeList at: listIndex) methodClass.
selector := (changeList at: listIndex) methodSelector.
class addSelectorSilently: selector withMethod: dummyMethod.
(changeList at: listIndex) fileIn.
"IF for some reason, the dummy remains, remove it, but (N.B.!!) we might not get control back if the compile (fileIn above) fails."
(class compiledMethodAt: selector) == dummyMethod
ifTrue: [class basicRemoveSelector: selector].
^ true!
----- Method: ChangeList>>scanCategory (in category 'scanning') -----
scanCategory
"Scan anything that involves more than one chunk; method name is historical only"
| itemPosition item tokens stamp isComment anIndex |
itemPosition := file position.
item := file nextChunk.
isComment := (item includesSubString: 'commentStamp:').
(isComment or: [item includesSubString: 'methodsFor:']) ifFalse:
["Maybe a preamble, but not one we recognize; bail out with the preamble trick"
^ self addItem: (ChangeRecord new file: file position: itemPosition type: #preamble)
text: ('preamble: ' , item contractTo: 50)].
tokens := Scanner new scanTokens: item.
tokens size >= 3 ifTrue:
[stamp := ''.
anIndex := tokens indexOf: #stamp: ifAbsent: [nil].
anIndex ifNotNil: [stamp := tokens at: (anIndex + 1)].
tokens second == #methodsFor:
ifTrue: [^ self scanCategory: tokens third class: tokens first
meta: false stamp: stamp].
tokens third == #methodsFor:
ifTrue: [^ self scanCategory: tokens fourth class: tokens first
meta: true stamp: stamp]].
tokens second == #commentStamp:
ifTrue:
[stamp := tokens third.
self addItem:
(ChangeRecord new file: file position: file position type: #classComment
class: tokens first category: nil meta: false stamp: stamp)
text: 'class comment for ' , tokens first,
(stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp]).
file nextChunk.
^ file skipStyleChunk]!
----- Method: ChangeList>>scanCategory:class:meta:stamp: (in category 'scanning') -----
scanCategory: category class: class meta: meta stamp: stamp
| itemPosition method |
[itemPosition := file position.
method := file nextChunk.
file skipStyleChunk.
method size > 0] "done when double terminators"
whileTrue:
[self addItem: (ChangeRecord new file: file position: itemPosition type: #method
class: class category: category meta: meta stamp: stamp)
text: 'method: ' , class , (meta ifTrue: [' class '] ifFalse: [' '])
, (self class parserClass new parseSelector: method)
, (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp])]!
----- Method: ChangeList>>scanFile:from:to: (in category 'scanning') -----
scanFile: aFile from: startPosition to: stopPosition
| itemPosition item prevChar |
file := aFile.
changeList := OrderedCollection new.
list := OrderedCollection new.
listIndex := 0.
file position: startPosition.
'Scanning ', aFile localName, '...'
displayProgressAt: Sensor cursorPoint
from: startPosition to: stopPosition
during: [:bar |
[file position < stopPosition]
whileTrue:
[bar value: file position.
[file atEnd not and: [file peek isSeparator]]
whileTrue: [prevChar := file next].
(file peekFor: $!!)
ifTrue:
[(prevChar = Character cr or: [prevChar = Character lf])
ifTrue: [self scanCategory]]
ifFalse:
[itemPosition := file position.
item := file nextChunk.
file skipStyleChunk.
item size > 0 ifTrue:
[self addItem: (ChangeRecord new file: file position: itemPosition type: #doIt)
text: 'do it: ' , (item contractTo: 50)]]]].
listSelections := Array new: list size withAll: false!
----- Method: ChangeList>>selectAll (in category 'menu actions') -----
selectAll
listIndex := 0.
listSelections atAllPut: true.
self changed: #allSelections!
----- Method: ChangeList>>selectAllConflicts (in category 'menu actions') -----
selectAllConflicts
"Selects all method definitions in the receiver which are also in any existing change set in the system. This makes no statement about whether the content of the methods differ, only whether there is a change represented."
| aClass aChange |
Cursor read showWhile:
[1 to: changeList size do:
[:i | aChange := changeList at: i.
listSelections at: i put:
(aChange type = #method
and: [(aClass := aChange methodClass) notNil
and: [ChangesOrganizer doesAnyChangeSetHaveClass: aClass andSelector: aChange methodSelector]])]].
self changed: #allSelections!
----- Method: ChangeList>>selectConflicts (in category 'menu actions') -----
selectConflicts
"Selects all method definitions for which there is ALSO an entry in changes"
| change class |
Cursor read showWhile:
[1 to: changeList size do:
[:i | change := changeList at: i.
listSelections at: i put:
(change type = #method
and: [(class := change methodClass) notNil
and: [(ChangeSet current atSelector: change methodSelector
class: class) ~~ #none]])]].
self changed: #allSelections!
----- Method: ChangeList>>selectConflicts: (in category 'menu actions') -----
selectConflicts: changeSetOrList
"Selects all method definitions for which there is ALSO an entry in the specified changeSet or changList"
| change class systemChanges |
Cursor read showWhile:
[(changeSetOrList isKindOf: ChangeSet) ifTrue: [
1 to: changeList size do:
[:i | change := changeList at: i.
listSelections at: i put:
(change type = #method
and: [(class := change methodClass) notNil
and: [(changeSetOrList atSelector: change methodSelector
class: class) ~~ #none]])]]
ifFalse: ["a ChangeList"
1 to: changeList size do:
[:i | change := changeList at: i.
listSelections at: i put:
(change type = #method
and: [(class := change methodClass) notNil
and: [changeSetOrList list includes: (list at: i)]])]]
].
self changed: #allSelections!
----- Method: ChangeList>>selectConflictsWith (in category 'menu actions') -----
selectConflictsWith
"Selects all method definitions for which there is ALSO an entry in the specified changeSet or changList chosen by the user. 4/11/96 tk"
| aStream all index |
aStream := WriteStream on: (String new: 200).
(all := ChangesOrganizer allChangeSets copy) do:
[:sel | aStream nextPutAll: (sel name contractTo: 40); cr].
ChangeList allSubInstancesDo:
[:sel | aStream nextPutAll: (sel file name); cr.
all addLast: sel].
aStream skip: -1.
index := (UIManager default chooseFrom: (aStream contents substrings)).
index > 0 ifTrue: [
self selectConflicts: (all at: index)].
!
----- Method: ChangeList>>selectMethodsForThisClass (in category 'menu actions') -----
selectMethodsForThisClass
| name |
self currentChange ifNil: [ ^self ].
name := self currentChange methodClassName.
name ifNil: [ ^self ].
^self selectSuchThat: [ :change |
change methodClassName = name ].!
----- Method: ChangeList>>selectNewMethods (in category 'menu actions') -----
selectNewMethods
"Selects all method definitions for which there is no counterpart method in the current image"
| change class |
Cursor read showWhile:
[1 to: changeList size do:
[:i | change := changeList at: i.
listSelections at: i put:
((change type = #method and:
[((class := change methodClass) isNil) or:
[(class includesSelector: change methodSelector) not]]))]].
self changed: #allSelections!
----- Method: ChangeList>>selectSuchThat (in category 'menu actions') -----
selectSuchThat
"query the user for a selection criterio. By Lex Spoon. NB: the UI for invoking this from a changelist browser is currently commented out; to reenfranchise it, you'll need to mild editing to ChangeList method #changeListMenu:"
| code block |
code := UIManager default request: 'selection criteria for a change named aChangeRecord?\For instance, ''aChangeRecord category = ''System-Network''''' withCRs.
code isEmpty ifTrue: [^ self ].
block := Compiler evaluate: '[:aChangeRecord | ', code, ']'.
self selectSuchThat: block!
----- Method: ChangeList>>selectSuchThat: (in category 'menu actions') -----
selectSuchThat: aBlock
"select all changes for which block returns true"
listSelections := changeList collect: [ :change | aBlock value: change ].
self changed: #allSelections!
----- Method: ChangeList>>selectUnchangedMethods (in category 'menu actions') -----
selectUnchangedMethods
"Selects all method definitions for which there is already a method in the current image, whose source is exactly the same. 9/18/96 sw"
| change class |
Cursor read showWhile:
[1 to: changeList size do:
[:i | change := changeList at: i.
listSelections at: i put:
((change type = #method and:
[(class := change methodClass) notNil]) and:
[(class includesSelector: change methodSelector) and:
[change string withBlanksCondensed = (class sourceCodeAt: change methodSelector) asString withBlanksCondensed ]])]].
self changed: #allSelections!
----- Method: ChangeList>>selectedClass (in category 'viewing access') -----
selectedClass
^(self selectedClassOrMetaClass ifNil: [ ^nil ]) theNonMetaClass !
----- Method: ChangeList>>selectedClassOrMetaClass (in category 'viewing access') -----
selectedClassOrMetaClass
| c |
^ (c := self currentChange) ifNotNil: [c methodClass]!
----- Method: ChangeList>>selectedMessageName (in category 'viewing access') -----
selectedMessageName
| c |
^ (c := self currentChange) ifNotNil: [c methodSelector]!
----- Method: ChangeList>>setLostMethodPointer: (in category 'accessing') -----
setLostMethodPointer: sourcePointer
lostMethodPointer := sourcePointer!
----- Method: ChangeList>>showsVersions (in category 'accessing') -----
showsVersions
^ false!
----- Method: ChangeList>>toggleListIndex: (in category 'viewing access') -----
toggleListIndex: newListIndex
listIndex ~= 0 ifTrue: [listSelections at: listIndex put: false].
newListIndex ~= 0 ifTrue: [listSelections at: newListIndex put: true].
listIndex := newListIndex.
self changed: #listIndex.
self contentsChanged!
----- Method: ChangeList>>undiffedContents (in category 'viewing access') -----
undiffedContents
^ listIndex = 0
ifTrue: ['']
ifFalse: [(changeList at: listIndex) text]!
----- Method: ChangeList>>wantsPrettyDiffOption (in category 'initialization-release') -----
wantsPrettyDiffOption
"Answer whether pretty-diffs are meaningful for this tool"
^ true!
ChangeList subclass: #ChangeListForProjects
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Changes'!
!ChangeListForProjects commentStamp: '<historical>' prior: 0!
A ChangeList that looks at the changes in a revokable project. This class has no users at present.!
----- Method: ChangeListForProjects>>contents (in category 'contents') -----
contents
^ self showingAnyKindOfDiffs
ifFalse: [self undiffedContents]
ifTrue: [self currentDiffedFromContents]
"Current is writing over one in list. Show how I would change it"!
----- Method: ChangeListForProjects>>currentDiffedFromContents (in category 'contents') -----
currentDiffedFromContents
"Answer the current in-memory method diffed from the current contents"
| aChange aClass |
listIndex = 0
ifTrue: [^ ''].
aChange := changeList at: listIndex.
^ ((aChange type == #method
and: [(aClass := aChange methodClass) notNil])
and: [aClass includesSelector: aChange methodSelector])
ifTrue: [TextDiffBuilder
buildDisplayPatchFrom: aChange text
to: (aClass sourceCodeAt: aChange methodSelector)
inClass: aClass
prettyDiffs: self showingPrettyDiffs]
ifFalse: [(changeList at: listIndex) text]!
ChangeList subclass: #VersionsBrowser
instanceVariableNames: 'classOfMethod selectorOfMethod addedChangeRecord'
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Changes'!
!VersionsBrowser commentStamp: 'nk 11/25/2003 10:04' prior: 0!
VersionsBrowser shows all the versions of a particular method, and lets you compare them, revert to selected versions, and so on.!
VersionsBrowser subclass: #ClassCommentVersionsBrowser
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Changes'!
!ClassCommentVersionsBrowser commentStamp: 'asm 8/13/2002 23:20' prior: 0!
A class-comment-versions-browser tool!
----- Method: ClassCommentVersionsBrowser class>>browseCommentOf: (in category 'instance creation') -----
browseCommentOf: class
| changeList |
Cursor read showWhile:
[changeList := self new scanVersionsOf: class.
changeList ifNil: [^ self inform: 'No versions available'].
self open: changeList name: 'Recent versions of ',class name,'''s comments' multiSelect: false ]
!
----- Method: ClassCommentVersionsBrowser class>>commentRecordsOf: (in category 'utilities') -----
commentRecordsOf: aClass
"Return a list of ChangeRecords for all versions of the method at selector. Source code can be retrieved by sending string to any one. Return nil if the method is absent."
| aList |
aList := self new
scanVersionsOf: aClass.
^ aList ifNotNil: [aList changeList]!
----- Method: ClassCommentVersionsBrowser class>>timeStampFor:class:reverseOrdinal: (in category 'utilities') -----
timeStampFor: aSelector class: aClass reverseOrdinal: anInteger
"Answer the time stamp corresponding to some version of the given method, nil if none. The reverseOrdinal parameter is interpreted as: 1 = current version; 2 = last-but-one version, etc."
| aChangeList |
aChangeList := self new scanVersionsOf: aClass.
^ aChangeList ifNil: [nil] ifNotNil:
[aChangeList list size >= anInteger
ifTrue:
[(aChangeList changeList at: anInteger) stamp]
ifFalse:
[nil]]!
----- Method: ClassCommentVersionsBrowser class>>windowColorSpecification (in category 'window color') -----
windowColorSpecification
"Answer a WindowColorSpec object that declares my preference"
^ WindowColorSpec classSymbol: self name wording: 'Class Comment Versions Browser' brightColor: #(0.769 0.653 1.0) pastelColor: #(0.819 0.753 1.0) helpMessage: 'A tool for viewing prior versions of a class comment.'!
----- Method: ClassCommentVersionsBrowser>>classCommentIndicated (in category 'misc') -----
classCommentIndicated
"Answer whether the receiver is pointed at a class comment"
^ true!
----- Method: ClassCommentVersionsBrowser>>compareToCurrentVersion (in category 'menu') -----
compareToCurrentVersion
"If the current selection corresponds to a method in the system, then spawn a window showing the diffs as text"
| change s1 s2 |
listIndex = 0
ifTrue: [^ self].
change := changeList at: listIndex.
s1 := classOfMethod organization classComment.
s2 := change string.
s1 = s2
ifTrue: [^ self inform: 'Exact Match'].
(StringHolder new
textContents: (TextDiffBuilder buildDisplayPatchFrom: s1 to: s2 inClass: classOfMethod prettyDiffs: self showingPrettyDiffs))
openLabel: 'Comparison to Current Version'!
----- Method: ClassCommentVersionsBrowser>>contentsSymbolQuints (in category 'misc') -----
contentsSymbolQuints
"Answer a list of quintuplets representing information on the alternative views available in the code pane"
^ #(
(source togglePlainSource showingPlainSourceString 'source' 'the textual source code as writen')
(showDiffs toggleRegularDiffing showingRegularDiffsString 'showDiffs' 'the textual source diffed from its prior version'))!
----- Method: ClassCommentVersionsBrowser>>diffedVersionContents (in category 'basic function') -----
diffedVersionContents
"Answer diffed version contents, maybe pretty maybe not"
| change class earlier later |
(listIndex = 0
or: [changeList size < listIndex])
ifTrue: [^ ''].
change := changeList at: listIndex.
later := change text.
class := self selectedClass.
(listIndex == changeList size or: [class == nil])
ifTrue: [^ later].
earlier := (changeList at: listIndex + 1) text.
^ TextDiffBuilder buildDisplayPatchFrom: earlier to: later inClass: class prettyDiffs: self showingPrettyDiffs!
----- Method: ClassCommentVersionsBrowser>>offerVersionsHelp (in category 'menu') -----
offerVersionsHelp
(StringHolder new contents: self versionsHelpString)
openLabel: 'Class Comment Versions Browsers'!
----- Method: ClassCommentVersionsBrowser>>openSingleMessageBrowser (in category 'menu') -----
openSingleMessageBrowser
| mr |
"Create and schedule a message list browser populated only by the currently selected message"
mr := MethodReference new
setStandardClass: self selectedClass
methodSymbol: #Comment.
self systemNavigation
browseMessageList: (Array with: mr)
name: mr asStringOrText
autoSelect: nil!
----- Method: ClassCommentVersionsBrowser>>priorSourceOrNil (in category 'misc') -----
priorSourceOrNil
"If the currently-selected method has a previous version, return its source, else return nil"
| aClass aSelector changeRecords |
(aClass := self selectedClass) ifNil: [^ nil].
(aSelector := self selectedMessageName) ifNil: [^ nil].
changeRecords := self class commentRecordsOf: self selectedClass.
(changeRecords == nil or: [changeRecords size <= 1]) ifTrue: [^ nil].
^ (changeRecords at: 2) string
!
----- Method: ClassCommentVersionsBrowser>>reformulateList (in category 'basic function') -----
reformulateList
classOfMethod organization classComment ifNil: [^ self].
self scanVersionsOf: classOfMethod.
self changed: #list. "for benefit of mvc"
listIndex := 1.
self changed: #listIndex.
self contentsChanged!
----- Method: ClassCommentVersionsBrowser>>scanVersionsOf: (in category 'basic function') -----
scanVersionsOf: class
"Scan for all past versions of the class comment of the given class"
| oldCommentRemoteStr sourceFilesCopy position prevPos stamp preamble tokens prevFileIndex |
classOfMethod := class.
oldCommentRemoteStr := class organization commentRemoteStr.
currentCompiledMethod := oldCommentRemoteStr.
selectorOfMethod := #Comment.
changeList := OrderedCollection new.
list := OrderedCollection new.
listIndex := 0.
oldCommentRemoteStr ifNil:[^ nil] ifNotNil: [oldCommentRemoteStr sourcePointer].
sourceFilesCopy := SourceFiles collect:
[:x | x isNil ifTrue: [ nil ]
ifFalse: [x readOnlyCopy]].
position := oldCommentRemoteStr position.
file := sourceFilesCopy at: oldCommentRemoteStr sourceFileNumber.
[position notNil & file notNil]
whileTrue:
[file position: (0 max: position-150). " Skip back to before the preamble"
[file position < (position-1)] "then pick it up from the front"
whileTrue: [preamble := file nextChunk].
prevPos := nil.
stamp := ''.
(preamble findString: 'commentStamp:' startingAt: 1) > 0
ifTrue: [tokens := Scanner new scanTokens: preamble.
(tokens at: tokens size-3) = #commentStamp:
ifTrue: ["New format gives change stamp and unified prior pointer"
stamp := tokens at: tokens size-2.
prevPos := tokens last.
prevFileIndex := sourceFilesCopy fileIndexFromSourcePointer: prevPos.
prevPos := sourceFilesCopy filePositionFromSourcePointer: prevPos]]
ifFalse: ["The stamp get lost, maybe after a condenseChanges"
stamp := '<historical>'].
self addItem:
(ChangeRecord new file: file position: position type: #classComment
class: class name category: nil meta: class stamp: stamp)
text: stamp , ' ' , class name , ' class comment'.
prevPos = 0 ifTrue:[prevPos := nil].
position := prevPos.
prevPos notNil
ifTrue:[file := sourceFilesCopy at: prevFileIndex]].
sourceFilesCopy do: [:x | x notNil ifTrue: [x close]].
listSelections := Array new: list size withAll: false!
----- Method: ClassCommentVersionsBrowser>>selectedClass (in category 'misc') -----
selectedClass
"Answer the class currently selected in the browser. In the case of a VersionsBrowser, the class and selector are always the same, regardless of which version is selected and indeed whether or not any entry is selected in the list pane"
^ classOfMethod!
----- Method: ClassCommentVersionsBrowser>>updateListsAndCodeIn: (in category 'basic function') -----
updateListsAndCodeIn: aWindow
| aComment |
aComment := classOfMethod organization commentRemoteStr.
aComment == currentCompiledMethod
ifFalse:
["Do not attempt to formulate if there is no source pointer.
It probably means it has been recompiled, but the source hasn't been written
(as during a display of the 'save text simply?' confirmation)."
aComment last ~= 0 ifTrue: [self reformulateList]].
^ true
!
----- Method: ClassCommentVersionsBrowser>>versionsMenu: (in category 'menu') -----
versionsMenu: aMenu
"Fill aMenu with menu items appropriate to the receiver"
Smalltalk isMorphic ifTrue:
[aMenu title: 'versions'.
aMenu addStayUpItemSpecial].
^ aMenu addList: #(
('compare to current' compareToCurrentVersion 'compare selected version to the current version')
('revert to selected version' fileInSelections 'resubmit the selected version, so that it becomes the current version')
('remove from changes' removeMethodFromChanges 'remove this method from the current change set, if present')
('edit current method (O)' openSingleMessageBrowser 'open a single-message browser on the current version of this method')
-
('toggle diffing (D)' toggleDiffing 'toggle whether or not diffs should be shown here')
('update list' reformulateList 'reformulate the list of versions, in case it somehow got out of synch with reality')
-
('help...' offerVersionsHelp 'provide an explanation of the use of this tool'))
!
----- Method: ClassCommentVersionsBrowser>>wantsPrettyDiffOption (in category 'misc') -----
wantsPrettyDiffOption
"Answer whether pretty-diffs are meaningful for this tool"
^ false!
----- Method: VersionsBrowser class>>browseVersionsForClass:selector: (in category 'instance creation') -----
browseVersionsForClass: aClass selector: aSelector
self
browseVersionsOf: (aClass compiledMethodAt: aSelector)
class: aClass
meta: aClass isMeta
category: (aClass organization categoryOfElement: aSelector)
selector: aSelector!
----- Method: VersionsBrowser class>>browseVersionsOf:class:meta:category:selector: (in category 'instance creation') -----
browseVersionsOf: method class: class meta: meta category: msgCategory selector: selector
^ self browseVersionsOf: method class: class meta: meta category: msgCategory selector: selector lostMethodPointer: nil!
----- Method: VersionsBrowser class>>browseVersionsOf:class:meta:category:selector:lostMethodPointer: (in category 'instance creation') -----
browseVersionsOf: method class: class meta: meta category: msgCategory selector: selector lostMethodPointer: sourcePointer
| changeList browser |
Cursor read showWhile:
[changeList := (browser := self new)
scanVersionsOf: method class: class meta: meta
category: msgCategory selector: selector].
changeList ifNil: [ self inform: 'No versions available'. ^nil ].
sourcePointer ifNotNil:
[changeList setLostMethodPointer: sourcePointer].
self open: changeList name: 'Recent versions of ' ,
selector multiSelect: false.
^browser!
----- Method: VersionsBrowser class>>timeStampFor:class:reverseOrdinal: (in category 'instance creation') -----
timeStampFor: aSelector class: aClass reverseOrdinal: anInteger
"Answer the time stamp corresponding to some version of the given method, nil if none. The reverseOrdinal parameter is interpreted as: 1 = current version; 2 = last-but-one version, etc."
| method aChangeList |
method := aClass compiledMethodAt: aSelector ifAbsent: [^ nil].
aChangeList := self new
scanVersionsOf: method class: aClass meta: aClass isMeta
category: nil selector: aSelector.
^ aChangeList ifNil: [nil] ifNotNil:
[aChangeList list size >= anInteger
ifTrue:
[(aChangeList changeList at: anInteger) stamp]
ifFalse:
[nil]]!
----- Method: VersionsBrowser class>>versionCountForSelector:class: (in category 'instance creation') -----
versionCountForSelector: aSelector class: aClass
"Answer the number of versions known to the system for the given class and method, including the current version. A result of greater than one means that there is at least one superseded version. Answer zero if no logged version can be obtained."
| method aChangeList |
method := aClass compiledMethodAt: aSelector ifAbsent: [^ 0].
aChangeList := self new
scanVersionsOf: method class: aClass meta: aClass isMeta
category: nil selector: aSelector.
^ aChangeList ifNil: [0] ifNotNil: [aChangeList list size]!
----- Method: VersionsBrowser class>>windowColorSpecification (in category 'window color') -----
windowColorSpecification
"Answer a WindowColorSpec object that declares my preference"
^ WindowColorSpec classSymbol: self name wording: 'Versions Browser' brightColor: #(0.869 0.753 1.0) pastelColor: #(0.919 0.853 1.0) helpMessage: 'A tool for viewing prior versions of a method.'!
----- Method: VersionsBrowser>>addPriorVersionsCountForSelector:ofClass:to: (in category 'misc') -----
addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream
"Add an annotation detailing the prior versions count. Specially handled here for the case of a selector no longer in the system, whose prior versions are seen in a versions browser -- in this case, the inherited version of this method will not work."
(aClass includesSelector: aSelector) ifTrue:
[^ super addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream].
aStream nextPutAll:
((changeList size > 0
ifTrue:
[changeList size == 1
ifTrue:
['Deleted - one prior version']
ifFalse:
['Deleted - ', changeList size printString, ' prior versions']]
ifFalse:
['surprisingly, no prior versions']), self annotationSeparator)!
----- Method: VersionsBrowser>>addedChangeRecord (in category 'init & update') -----
addedChangeRecord
^addedChangeRecord!
----- Method: VersionsBrowser>>addedChangeRecord: (in category 'init & update') -----
addedChangeRecord: aChangeRecord
addedChangeRecord := aChangeRecord.
self reformulateList.!
----- Method: VersionsBrowser>>changeListButtonSpecs (in category 'init & update') -----
changeListButtonSpecs
^#(
('compare to current'
compareToCurrentVersion
'opens a separate window which shows the text differences between the selected version and the current version')
('revert'
fileInSelections
'reverts the method to the version selected')
('remove from changes'
removeMethodFromChanges
'remove this method from the current change set')
('help'
offerVersionsHelp
'further explanation about use of Versions browsers')
)!
----- Method: VersionsBrowser>>changeListKey:from: (in category 'menu') -----
changeListKey: aChar from: view
"Respond to a Command key in the list pane. of the versions browser"
^ self messageListKey: aChar from: view!
----- Method: VersionsBrowser>>classCommentIndicated (in category 'misc') -----
classCommentIndicated
"Answer whether the receiver is pointed at a class comment"
^ false!
----- Method: VersionsBrowser>>compareToOtherVersion (in category 'menu') -----
compareToOtherVersion
"Prompt the user for a reference version, then spawn a window
showing the diffs between the older and the newer of the current
version and the reference version as text."
| change1 change2 s1 s2 |
change1 := changeList at: listIndex ifAbsent: [ ^self ].
change2 := ((UIManager default
chooseFrom: (list copyWithoutIndex: listIndex)
values: (changeList copyWithoutIndex: listIndex))) ifNil: [ ^self ].
"compare earlier -> later"
"change1 timeStamp < change2 timeStamp
ifFalse: [ | temp | temp := change1. change1 := change2. change2 := temp ]."
s1 := change1 string.
s2 := change2 string.
s1 = s2
ifTrue: [^ self inform: 'Exact Match' translated].
(StringHolder new
textContents: (TextDiffBuilder
buildDisplayPatchFrom: s1
to: s2
inClass: classOfMethod
prettyDiffs: self showingPrettyDiffs))
openLabel: (('Comparison from {1} to {2}' translated) format: { change1 stamp. change2 stamp })!
----- Method: VersionsBrowser>>fileInSelections (in category 'menu') -----
fileInSelections
super fileInSelections.
self reformulateList!
----- Method: VersionsBrowser>>findOriginalChangeSet (in category 'menu') -----
findOriginalChangeSet
| changeSet |
self currentChange ifNil: [^ self].
changeSet := self currentChange originalChangeSetForSelector: self selectedMessageName.
changeSet = #sources ifTrue:
[^ self inform: 'This version is in the .sources file.'].
changeSet ifNil:
[^ self inform: 'This version was not found in any changeset nor in the .sources file.'].
(ChangeSorter new myChangeSet: changeSet) open!
----- Method: VersionsBrowser>>initialExtent (in category 'user interface') -----
initialExtent
"adopt the extent so that the revert button fits in"
^650 at 400!
----- Method: VersionsBrowser>>offerVersionsHelp (in category 'menu') -----
offerVersionsHelp
(StringHolder new contents: self versionsHelpString)
openLabel: 'Versions Browsers'!
----- Method: VersionsBrowser>>optionalButtonPairs (in category 'toolbuilder') -----
optionalButtonPairs
^ #(('revert' fileInSelections 'resubmit the selected version, so that it becomes the current version')) , super optionalButtonPairs!
----- Method: VersionsBrowser>>reformulateList (in category 'init & update') -----
reformulateList
| aMethod |
"Some uncertainty about how to deal with lost methods here"
aMethod := classOfMethod compiledMethodAt: selectorOfMethod ifAbsent: [^ self].
self scanVersionsOf: aMethod class: classOfMethod theNonMetaClass meta: classOfMethod isMeta category: (classOfMethod whichCategoryIncludesSelector: selectorOfMethod) selector: selectorOfMethod.
self changed: #list. "for benefit of mvc"
listIndex := 1.
self changed: #listIndex.
self contentsChanged
!
----- Method: VersionsBrowser>>removeMethodFromChanges (in category 'menu') -----
removeMethodFromChanges
"Remove my method from the current change set"
ChangeSet current removeSelectorChanges: selectorOfMethod class: classOfMethod.
self changed: #annotation
!
----- Method: VersionsBrowser>>scanVersionsOf:class:meta:category:selector: (in category 'init & update') -----
scanVersionsOf: method class: class meta: meta category: category selector: selector
| position prevPos prevFileIndex preamble tokens sourceFilesCopy stamp cat |
selectorOfMethod := selector.
currentCompiledMethod := method.
classOfMethod := meta ifTrue: [class class] ifFalse: [class].
cat := category ifNil: [''].
changeList := OrderedCollection new.
list := OrderedCollection new.
self addedChangeRecord ifNotNilDo: [ :change |
self addItem: change text: ('{1} (in {2})' translated format: { change stamp. change fileName }) ].
listIndex := 0.
position := method filePosition.
sourceFilesCopy := SourceFiles collect:
[:x | x isNil ifTrue: [ nil ]
ifFalse: [x readOnlyCopy]].
method fileIndex == 0 ifTrue: [^ nil].
file := sourceFilesCopy at: method fileIndex.
[position notNil & file notNil]
whileTrue:
[file position: (0 max: position-150). "Skip back to before the preamble"
preamble := method getPreambleFrom: file at: (0 max: position - 3).
"Preamble is likely a linked method preamble, if we're in
a changes file (not the sources file). Try to parse it
for prior source position and file index"
prevPos := nil.
stamp := ''.
(preamble findString: 'methodsFor:' startingAt: 1) > 0
ifTrue: [tokens := Scanner new scanTokens: preamble]
ifFalse: [tokens := Array new "ie cant be back ref"].
((tokens size between: 7 and: 8)
and: [(tokens at: tokens size-5) = #methodsFor:])
ifTrue:
[(tokens at: tokens size-3) = #stamp:
ifTrue: ["New format gives change stamp and unified prior pointer"
stamp := tokens at: tokens size-2.
prevPos := tokens last.
prevFileIndex := sourceFilesCopy fileIndexFromSourcePointer: prevPos.
prevPos := sourceFilesCopy filePositionFromSourcePointer: prevPos]
ifFalse: ["Old format gives no stamp; prior pointer in two parts"
prevPos := tokens at: tokens size-2.
prevFileIndex := tokens last].
cat := tokens at: tokens size-4.
(prevPos = 0 or: [prevFileIndex = 0]) ifTrue: [prevPos := nil]].
((tokens size between: 5 and: 6)
and: [(tokens at: tokens size-3) = #methodsFor:])
ifTrue:
[(tokens at: tokens size-1) = #stamp:
ifTrue: ["New format gives change stamp and unified prior pointer"
stamp := tokens at: tokens size].
cat := tokens at: tokens size-2].
self addItem:
(ChangeRecord new file: file position: position type: #method
class: class name category: category meta: meta stamp: stamp)
text: stamp , ' ' , class name , (meta ifTrue: [' class '] ifFalse: [' ']) , selector, ' {', cat, '}'.
position := prevPos.
prevPos notNil ifTrue:
[file := sourceFilesCopy at: prevFileIndex]].
sourceFilesCopy do: [:x | x notNil ifTrue: [x close]].
listSelections := Array new: list size withAll: false!
----- Method: VersionsBrowser>>selectedClass (in category 'misc') -----
selectedClass
"Answer the class currently selected in the browser. In the case of a VersionsBrowser, the class and selector are always the same, regardless of which version is selected and indeed whether or not any entry is selected in the list pane"
^ classOfMethod theNonMetaClass!
----- Method: VersionsBrowser>>selectedClassOrMetaClass (in category 'misc') -----
selectedClassOrMetaClass
"Answer the class or metaclass currently selected in the browser. In the case of a VersionsBrowser, the class and selector are always the same, regardless of which version is selected and indeed whether or not any entry is selected in the list pane"
^ classOfMethod!
----- Method: VersionsBrowser>>selectedMessageName (in category 'misc') -----
selectedMessageName
"Answer the message name currently selected in the browser. In the case of a VersionsBrowser, the class and selector are always the same, regardless of which version is selected and indeed whether or not any entry is selected in the list pane"
^ selectorOfMethod!
----- Method: VersionsBrowser>>showsVersions (in category 'misc') -----
showsVersions
^ true!
----- Method: VersionsBrowser>>updateListsAndCodeIn: (in category 'init & update') -----
updateListsAndCodeIn: aWindow
| aMethod |
aMethod := classOfMethod compiledMethodAt: selectorOfMethod ifAbsent: [^ false].
aMethod == currentCompiledMethod
ifFalse:
["Do not attempt to formulate if there is no source pointer.
It probably means it has been recompiled, but the source hasn't been written
(as during a display of the 'save text simply?' confirmation)."
aMethod last ~= 0 ifTrue: [self reformulateList]].
^ true
!
----- Method: VersionsBrowser>>versionFrom: (in category 'menu') -----
versionFrom: secsSince1901
| strings vTime |
"Return changeRecord of the version in effect at that time. Accept in the VersionsBrowser does not use this code."
changeList do: [:cngRec |
(strings := cngRec stamp findTokens: ' ') size > 2 ifTrue: [
vTime := strings second asDate asSeconds +
strings third asTime asSeconds.
vTime <= secsSince1901 ifTrue: ["this one"
^ cngRec == changeList first ifTrue: [nil] ifFalse: [cngRec]]]].
"was not defined that early. Don't delete the method."
^ changeList last "earliest one may be OK" !
----- Method: VersionsBrowser>>versionsHelpString (in category 'menu') -----
versionsHelpString
^ 'Each entry in the list pane represents a version of the source code for the same method; the topmost entry is the current version, the next entry is the next most recent, etc.
To revert to an earlier version, select it (in the list pane) and then do any of the following:
* Choose "revert to this version" from the list pane menu.
* Hit the "revert" button,
* Type ENTER in the code pane
* Type cmd-s (alt-s) in the code pane.
The code pane shows the source for the selected version. If "diffing" is in effect, then differences betwen the selected version and the version before it are pointed out in the pane. Turn diffing on and off by choosing "toggle diffing" from the list pane menu, or hitting the "diffs" button, or hitting cmd-D when the cursor is over the list pane.
To get a comparison between the selected version and the current version, choose "compare to current" from the list pane menu or hit the "compare to current" button. (This is meaningless if the current version is selected, and is unnecessary if you''re interested in diffs from between the current version and the next-most-recent version, since the standard in-pane "diff" feature will give you that.)
You can also compare the selected version with any other version using the "compare to version..." menu choice.
If further versions of the method in question have been submitted elsewhere since you launched a particular Versions Browser, it will still stay nicely up-to-date if you''re in Morphic and have asked that smart updating be maintained; if you''re in mvc or in morphic but with smart-updating turned off, a versions browser is only brought up to date when you activate its window (and when you issue "revert" from within it, of course,) and you can also use the "update list" command to make certain the versions list is up to date.
Hit the "remove from changes" button, or choose the corresponding command in the list pane menu, to have the method in question deleted from the current change set. This is useful if you''ve put debugging code into a method, and now want to strip it out and cleanse your current change set of all memory of the excursion.
Note: the annotation pane in versions browsers shows information about the *current* version of the method in the image, not about the selected version.'!
----- Method: VersionsBrowser>>versionsMenu: (in category 'menu') -----
versionsMenu: aMenu
"Fill aMenu with menu items appropriate to the receiver"
Smalltalk isMorphic ifTrue:
[aMenu title: 'Versions' translated.
aMenu addStayUpItemSpecial].
listIndex > 0 ifTrue:[
(list size > 1 ) ifTrue: [ aMenu addTranslatedList: #(
('compare to current' compareToCurrentVersion 'compare selected version to the current version')
('compare to version...' compareToOtherVersion 'compare selected version to another selected version'))].
"Note: Revert to selected should be visible for lists of length one for having the ability to revert to an accidentally deleted method"
aMenu addTranslatedList: #(
('revert to selected version' fileInSelections 'resubmit the selected version, so that it becomes the current version') )].
aMenu addTranslatedList: #(
('remove from changes' removeMethodFromChanges 'remove this method from the current change set, if present')
('edit current method (O)' openSingleMessageBrowser 'open a single-message browser on the current version of this method')
('find original change set' findOriginalChangeSet 'locate the changeset which originally contained this version')
-
('toggle diffing (D)' toggleDiffing 'toggle whether or not diffs should be shown here')
('update list' reformulateList 'reformulate the list of versions, in case it somehow got out of synch with reality')
-
('senders (n)' browseSenders 'browse all senders of this selector')
('implementors (m)' browseImplementors 'browse all implementors of this selector')
-
('help...' offerVersionsHelp 'provide an explanation of the use of this tool')).
^aMenu!
CodeHolder subclass: #ChangeSorter
instanceVariableNames: 'parent myChangeSet currentClassName currentSelector priorChangeSetList changeSetCategory'
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Changes'!
!ChangeSorter commentStamp: '<historical>' prior: 0!
I display a ChangeSet. Two of me are in a DualChangeSorter.!
ChangeSorter subclass: #ChangeSetBrowser
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Changes'!
!ChangeSetBrowser commentStamp: '<historical>' prior: 0!
A tool allowing you to browse the methods of a single change set.!
----- Method: ChangeSetBrowser>>addModelItemsToWindowMenu: (in category 'initialization') -----
addModelItemsToWindowMenu: aMenu
"Add model-related items to the given window menu"
| oldTarget |
oldTarget := aMenu defaultTarget.
aMenu defaultTarget: self.
aMenu addLine.
aMenu add: 'rename change set' action: #rename.
aMenu add: 'make changes go to me' action: #newCurrent.
aMenu addLine.
aMenu add: 'file out' action: #fileOut.
aMenu add: 'browse methods' action: #browseChangeSet.
aMenu addLine.
myChangeSet hasPreamble
ifTrue:
[aMenu add: 'edit preamble' action: #addPreamble.
aMenu add: 'remove preamble' action: #removePreamble]
ifFalse:
[aMenu add: 'add preamble' action: #addPreamble].
myChangeSet hasPostscript
ifTrue:
[aMenu add: 'edit postscript...' action: #editPostscript.
aMenu add: 'remove postscript' action: #removePostscript]
ifFalse:
[aMenu add: 'add postscript...' action: #editPostscript].
aMenu addLine.
aMenu add: 'destroy change set' action: #remove.
aMenu addLine.
Smalltalk isMorphic ifTrue:
[aMenu addLine.
aMenu add: 'what to show...' target: self action: #offerWhatToShowMenu].
aMenu addLine.
aMenu add: 'more...' action: #offerShiftedChangeSetMenu.
aMenu defaultTarget: oldTarget.
^ aMenu!
----- Method: ChangeSetBrowser>>offerUnshiftedChangeSetMenu (in category 'menu') -----
offerUnshiftedChangeSetMenu
"The user chose 'more' from the shifted window menu; go back to the regular window menu"
self containingWindow ifNotNil: [self containingWindow offerWindowMenu] !
----- Method: ChangeSetBrowser>>shiftedChangeSetMenu: (in category 'menu') -----
shiftedChangeSetMenu: aMenu
"Set up aMenu to hold items relating to the change-set-list pane when the shift key is down"
Smalltalk isMorphic ifTrue:
[aMenu title: 'Change set (shifted)'.
aMenu addStayUpItemSpecial].
aMenu add: 'conflicts with other change sets' action: #browseMethodConflicts.
aMenu balloonTextForLastItem:
'Browse all methods that occur both in this change set and in at least one other change set.'.
aMenu addLine.
aMenu add: 'check for slips' action: #lookForSlips.
aMenu balloonTextForLastItem:
'Check this change set for halts and references to Transcript.'.
aMenu add: 'check for unsent messages' action: #checkForUnsentMessages.
aMenu balloonTextForLastItem:
'Check this change set for messages that are not sent anywhere in the system'.
aMenu add: 'check for uncommented methods' action: #checkForUncommentedMethods.
aMenu balloonTextForLastItem:
'Check this change set for methods that do not have comments'.
aMenu add: 'check for uncommented classes' action: #checkForUncommentedClasses.
aMenu balloonTextForLastItem:
'Check for classes with code in this changeset which lack class comments'.
Utilities authorInitialsPerSe isEmptyOrNil ifFalse:
[aMenu add: 'check for other authors' action: #checkForAlienAuthorship.
aMenu balloonTextForLastItem:
'Check this change set for methods whose current authoring stamp does not start with "', Utilities authorInitials, '"'.
aMenu add: 'check for any other authors' action: #checkForAnyAlienAuthorship.
aMenu balloonTextForLastItem:
'Check this change set for methods any of whose previous authoring stamps do not start with "', Utilities authorInitials, '"'].
aMenu add: 'check for uncategorized methods' action: #checkForUnclassifiedMethods.
aMenu balloonTextForLastItem:
'Check to see if any methods in the selected change set have not yet been assigned to a category. If any are found, open a browser on them.'.
aMenu addLine.
aMenu add: 'inspect change set' action: #inspectChangeSet.
aMenu balloonTextForLastItem:
'Open an inspector on this change set. (There are some details in a change set which you don''t see in a change sorter.)'.
aMenu add: 'update' action: #update.
aMenu balloonTextForLastItem:
'Update the display for this change set. (This is done automatically when you activate this window, so is seldom needed.)'.
aMenu add: 'go to change set''s project' action: #goToChangeSetsProject.
aMenu balloonTextForLastItem:
'If this change set is currently associated with a Project, go to that project right now.'.
aMenu add: 'trim history' action: #trimHistory.
aMenu balloonTextForLastItem:
' Drops any methods added and then removed, as well as renaming and reorganization of newly-added classes. NOTE: can cause confusion if later filed in over an earlier version of these changes'.
aMenu add: 'clear this change set' action: #clearChangeSet.
aMenu balloonTextForLastItem:
'Reset this change set to a pristine state where it holds no information. CAUTION: this is destructive and irreversible!!'.
aMenu add: 'expunge uniclasses' action: #expungeUniclasses.
aMenu balloonTextForLastItem:
'Remove from the change set all memory of uniclasses, e.g. classes added on behalf of etoys, fabrik, etc., whose classnames end with a digit.'.
aMenu add: 'uninstall this change set' action: #uninstallChangeSet.
aMenu balloonTextForLastItem:
'Attempt to uninstall this change set. CAUTION: this may not work completely and is irreversible!!'.
aMenu addLine.
aMenu add: 'more...' action: #offerUnshiftedChangeSetMenu.
aMenu balloonTextForLastItem:
'Takes you back to the primary change-set menu.'.
^ aMenu!
----- Method: ChangeSetBrowser>>wantsAnnotationPane (in category 'initialization') -----
wantsAnnotationPane
"This kind of browser always wants annotation panes, so answer true"
^ true!
----- Method: ChangeSetBrowser>>wantsOptionalButtons (in category 'initialization') -----
wantsOptionalButtons
"Sure, why not?"
^ true!
----- Method: ChangeSorter class>>allChangeSetNames (in category 'deprecated') -----
allChangeSetNames
^ ChangesOrganizer allChangeSetNames!
----- Method: ChangeSorter class>>allChangeSets (in category 'deprecated') -----
allChangeSets
^ ChangesOrganizer allChangeSets!
----- Method: ChangeSorter class>>allChangeSetsWithClass:selector: (in category 'deprecated') -----
allChangeSetsWithClass: class selector: selector
^ ChangesOrganizer allChangeSetsWithClass: class selector: selector!
----- Method: ChangeSorter class>>assuredChangeSetNamed: (in category 'deprecated') -----
assuredChangeSetNamed: aName
^ ChangesOrganizer assuredChangeSetNamed: aName!
----- Method: ChangeSorter class>>basicNewChangeSet: (in category 'deprecated') -----
basicNewChangeSet: newName
^ ChangesOrganizer basicNewChangeSet: newName!
----- Method: ChangeSorter class>>belongsInAdditions: (in category 'deprecated') -----
belongsInAdditions: aChangeSet
^ ChangesOrganizer belongsInAdditions: aChangeSet!
----- Method: ChangeSorter class>>belongsInAll: (in category 'deprecated') -----
belongsInAll: aChangeSet
^ ChangesOrganizer belongsInAll: aChangeSet!
----- Method: ChangeSorter class>>belongsInMyInitials: (in category 'deprecated') -----
belongsInMyInitials: aChangeSet
^ ChangesOrganizer belongsInMyInitials: aChangeSet!
----- Method: ChangeSorter class>>belongsInNumbered: (in category 'deprecated') -----
belongsInNumbered: aChangeSet
^ ChangesOrganizer belongsInNumbered: aChangeSet!
----- Method: ChangeSorter class>>belongsInProjectChangeSets: (in category 'deprecated') -----
belongsInProjectChangeSets: aChangeSet
^ ChangesOrganizer belongsInProjectChangeSets: aChangeSet!
----- Method: ChangeSorter class>>belongsInProjectsInRelease: (in category 'deprecated') -----
belongsInProjectsInRelease: aChangeSet
^ ChangesOrganizer belongsInProjectsInRelease: aChangeSet!
----- Method: ChangeSorter class>>belongsInRecentUpdates: (in category 'deprecated') -----
belongsInRecentUpdates: aChangeSet
^ ChangesOrganizer belongsInRecentUpdates: aChangeSet!
----- Method: ChangeSorter class>>browseChangeSetsWithClass:selector: (in category 'browse') -----
browseChangeSetsWithClass: class selector: selector
"Put up a menu comprising a list of change sets that hold changes for the given class and selector. If the user selects one, open a single change-sorter onto it"
| hits index |
hits := self allChangeSets select:
[:cs | (cs atSelector: selector class: class) ~~ #none].
hits isEmpty ifTrue: [^ self inform: class name, '.', selector , '
is not in any change set'].
index := hits size == 1
ifTrue: [1]
ifFalse: [(UIManager default chooseFrom: (hits collect: [:cs | cs name])
lines: #())].
index = 0 ifTrue: [^ self].
(ChangeSorter new myChangeSet: (hits at: index)) open.
!
----- Method: ChangeSorter class>>browseChangeSetsWithSelector: (in category 'browse') -----
browseChangeSetsWithSelector: aSelector
"Put up a list of all change sets that contain an addition, deletion, or change of any method with the given selector"
| hits index |
hits := self allChangeSets select:
[:cs | cs hasAnyChangeForSelector: aSelector].
hits isEmpty ifTrue: [^ self inform: aSelector , '
is not in any change set'].
index := hits size == 1
ifTrue: [1]
ifFalse: [(UIManager default chooseFrom: (hits collect: [:cs | cs name])
lines: #())].
index = 0 ifTrue: [^ self].
(ChangeSetBrowser new myChangeSet: (hits at: index)) open
"ChangeSorter browseChangeSetsWithSelector: #clearPenTrails"
!
----- Method: ChangeSorter class>>buildAggregateChangeSet (in category 'deprecated') -----
buildAggregateChangeSet
^ ChangesOrganizer buildAggregateChangeSet
!
----- Method: ChangeSorter class>>changeSet:containsClass: (in category 'deprecated') -----
changeSet: aChangeSet containsClass: aClass
^ ChangesOrganizer changeSet: aChangeSet containsClass: aClass!
----- Method: ChangeSorter class>>changeSetCategoryNamed: (in category 'deprecated') -----
changeSetCategoryNamed: aName
^ ChangesOrganizer changeSetCategoryNamed: aName!
----- Method: ChangeSorter class>>changeSetNamed: (in category 'deprecated') -----
changeSetNamed: aName
^ ChangesOrganizer changeSetNamed: aName!
----- Method: ChangeSorter class>>changeSetNamesInReleaseImage (in category 'deprecated') -----
changeSetNamesInReleaseImage
^ ChangesOrganizer changeSetNamesInReleaseImage!
----- Method: ChangeSorter class>>changeSetNamesInThreeOh (in category 'deprecated') -----
changeSetNamesInThreeOh
^ ChangesOrganizer changeSetNamesInThreeOh!
----- Method: ChangeSorter class>>changeSetsNamedSuchThat: (in category 'deprecated') -----
changeSetsNamedSuchThat: nameBlock
^ ChangesOrganizer changeSetsNamedSuchThat: nameBlock!
----- Method: ChangeSorter class>>countOfChangeSetsWithClass:andSelector: (in category 'deprecated') -----
countOfChangeSetsWithClass: aClass andSelector: aSelector
^ ChangesOrganizer countOfChangeSetsWithClass: aClass andSelector: aSelector!
----- Method: ChangeSorter class>>deleteChangeSetsNumberedLowerThan: (in category 'deprecated') -----
deleteChangeSetsNumberedLowerThan: anInteger
^ ChangesOrganizer deleteChangeSetsNumberedLowerThan: anInteger!
----- Method: ChangeSorter class>>doesAnyChangeSetHaveClass:andSelector: (in category 'deprecated') -----
doesAnyChangeSetHaveClass: aClass andSelector: aSelector
^ ChangesOrganizer doesAnyChangeSetHaveClass: aClass andSelector: aSelector!
----- Method: ChangeSorter class>>existingOrNewChangeSetNamed: (in category 'deprecated') -----
existingOrNewChangeSetNamed: aName
^ ChangesOrganizer existingOrNewChangeSetNamed: aName!
----- Method: ChangeSorter class>>fileOutChangeSetsNamed: (in category 'deprecated') -----
fileOutChangeSetsNamed: nameList
^ ChangesOrganizer fileOutChangeSetsNamed: nameList!
----- Method: ChangeSorter class>>gatherChangeSets (in category 'deprecated') -----
gatherChangeSets
^ ChangesOrganizer gatherChangeSets!
----- Method: ChangeSorter class>>highestNumberedChangeSet (in category 'deprecated') -----
highestNumberedChangeSet
^ ChangesOrganizer highestNumberedChangeSet
!
----- Method: ChangeSorter class>>initialize (in category 'class initialization') -----
initialize
"ChangeSorter initialize"
FileList registerFileReader: self.
self registerInFlapsRegistry.
!
----- Method: ChangeSorter class>>initializeChangeSetCategories (in category 'deprecated') -----
initializeChangeSetCategories
^ ChangesOrganizer initializeChangeSetCategories!
----- Method: ChangeSorter class>>mostRecentChangeSetWithChangeForClass:selector: (in category 'deprecated') -----
mostRecentChangeSetWithChangeForClass: class selector: selector
^ ChangesOrganizer mostRecentChangeSetWithChangeForClass: class selector: selector!
----- Method: ChangeSorter class>>newChangeSet (in category 'deprecated') -----
newChangeSet
^ ChangesOrganizer newChangeSet!
----- Method: ChangeSorter class>>newChangeSet: (in category 'deprecated') -----
newChangeSet: aName
^ ChangesOrganizer newChangeSet: aName!
----- Method: ChangeSorter class>>newChangesFromStream:named: (in category 'deprecated') -----
newChangesFromStream: aStream named: aName
^ ChangesOrganizer newChangesFromStream: aStream named: aName!
----- Method: ChangeSorter class>>noteChangeSetsInRelease (in category 'deprecated') -----
noteChangeSetsInRelease
^ ChangesOrganizer noteChangeSetsInRelease!
----- Method: ChangeSorter class>>open (in category 'instance creation') -----
open
"Open a new instance of the receiver's class"
self new open!
----- Method: ChangeSorter class>>promoteToTop: (in category 'deprecated') -----
promoteToTop: aChangeSet
^ ChangesOrganizer promoteToTop: aChangeSet!
----- Method: ChangeSorter class>>prototypicalToolWindow (in category 'browse') -----
prototypicalToolWindow
"Answer a window representing a prototypical instance of the receiver"
^ToolBuilder build: self new!
----- Method: ChangeSorter class>>recentUpdateMarker (in category 'deprecated') -----
recentUpdateMarker
^ ChangesOrganizer recentUpdateMarker!
----- Method: ChangeSorter class>>recentUpdateMarker: (in category 'deprecated') -----
recentUpdateMarker: aNumber
^ ChangesOrganizer recentUpdateMarker: aNumber!
----- Method: ChangeSorter class>>registerInFlapsRegistry (in category 'deprecated') -----
registerInFlapsRegistry
"Register the receiver in the system's flaps registry"
self environment
at: #Flaps
ifPresent: [:cl | cl registerQuad: #(ChangeSorter prototypicalToolWindow 'Change Set' 'A tool that allows you to view and manipulate all the code changes in a single change set')
forFlapNamed: 'Tools']!
----- Method: ChangeSorter class>>removeChangeSet: (in category 'deprecated') -----
removeChangeSet: aChangeSet
^ ChangesOrganizer removeChangeSet: aChangeSet!
----- Method: ChangeSorter class>>removeChangeSetsNamedSuchThat: (in category 'deprecated') -----
removeChangeSetsNamedSuchThat: nameBlock
^ ChangesOrganizer removeChangeSetsNamedSuchThat: nameBlock!
----- Method: ChangeSorter class>>removeEmptyUnnamedChangeSets (in category 'deprecated') -----
removeEmptyUnnamedChangeSets
^ ChangesOrganizer removeEmptyUnnamedChangeSets!
----- Method: ChangeSorter class>>reorderChangeSets (in category 'deprecated') -----
reorderChangeSets
^ ChangesOrganizer reorderChangeSets!
----- Method: ChangeSorter class>>secondaryChangeSet (in category 'deprecated') -----
secondaryChangeSet
^ ChangesOrganizer secondaryChangeSet!
----- Method: ChangeSorter class>>unload (in category 'deprecated') -----
unload
"Unload the receiver from global registries"
self environment at: #FileList ifPresent: [:cl |
cl unregisterFileReader: self].
self environment at: #Flaps ifPresent: [:cl |
cl unregisterQuadsWithReceiver: self] !
----- Method: ChangeSorter class>>windowColorSpecification (in category 'window color') -----
windowColorSpecification
"Answer a WindowColorSpec object that declares my preference"
^ WindowColorSpec classSymbol: self name wording: 'Change Sorter' brightColor: #lightBlue pastelColor: #paleBlue helpMessage: 'A tool that lets you see the code for one change set at a time.'!
----- Method: ChangeSorter>>aboutToStyle: (in category 'code pane') -----
aboutToStyle: aStyler
"This is a notification that aStyler is about to re-style its text.
Set the classOrMetaClass in aStyler, so that identifiers
will be resolved correctly.
Answer true to allow styling to proceed, or false to veto the styling"
self isModeStyleable ifFalse: [^false].
self currentSelector ifNil: [^false].
aStyler classOrMetaClass: self selectedClassOrMetaClass.
^true!
----- Method: ChangeSorter>>addPreamble (in category 'changeSet menu') -----
addPreamble
myChangeSet assurePreambleExists.
self okToChange ifTrue:
[currentClassName := nil.
currentSelector := nil.
self showChangeSet: myChangeSet]!
----- Method: ChangeSorter>>addPriorVersionsCountForSelector:ofClass:to: (in category 'annotation') -----
addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream
"Add an annotation detailing the prior versions count. Specially handled here for the case of a selector no longer in the system, whose prior version is pointed to by the lost-method pointer in the change held on to by the changeset"
(aClass includesSelector: aSelector) ifTrue:
[^ super addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream].
aStream nextPutAll:
((myChangeSet methodInfoFromRemoval: {aClass name. aSelector})
ifNil:
['no prior versions']
ifNotNil:
['version(s) retrievable here']), self annotationSeparator!
----- Method: ChangeSorter>>addToCategoryOpposite (in category 'changeSet menu') -----
addToCategoryOpposite
"Add the current change set to the category viewed on the opposite side, if it's of the sort to accept things like that"
| categoryOpposite |
categoryOpposite := (parent other: self) changeSetCategory.
categoryOpposite acceptsManualAdditions
ifTrue:
[categoryOpposite addChangeSet: myChangeSet.
categoryOpposite reconstituteList.
self update]
ifFalse:
[self inform:
'sorry, this command only makes sense
if the category showing on the opposite
side is a static category whose
members are manually maintained']!
----- Method: ChangeSorter>>annotationForPackageforSelector:ofClass: (in category 'annotation') -----
annotationForPackageforSelector: aSelector ofClass: aClass
"Provide a line of content for an annotation pane, representing
information about the given selector and class"
"requestList"
| aCategory |
aClass ifNil: [ ^nil] .
aSelector ifNil: [ aClass theNonMetaClass category asString ] .
aSelector ifNotNil: [ aCategory := aClass organization categoryOfElement: aSelector.
(aCategory notNil and: [ aCategory first = $* ])
ifTrue: [^ aCategory asString]] .
"Ok. So the selector catagory does not indicate our package. We defer to the class catagory"
^ aClass theNonMetaClass category asString.
!
----- Method: ChangeSorter>>basicClassList (in category 'class list') -----
basicClassList
"Computed. View should try to preserve selections, even though index changes"
^ myChangeSet ifNotNil: [myChangeSet changedClassNames] ifNil: [OrderedCollection new]
!
----- Method: ChangeSorter>>basicMessageList (in category 'message list') -----
basicMessageList
| probe newSelectors className |
currentClassName ifNil: [^ #()].
className := (self withoutItemAnnotation: currentClassName) .
probe := (className endsWith: ' class')
ifTrue: [className]
ifFalse: [className asSymbol].
newSelectors := myChangeSet selectorsInClass: probe.
(newSelectors includes: (self selectedMessageName))
ifFalse: [currentSelector := nil].
^ newSelectors asSortedCollection
!
----- Method: ChangeSorter>>beginNote (in category 'annotation') -----
beginNote
"return the string at the beginning of item annotation"
^' {'
!
----- Method: ChangeSorter>>browseChangeSet (in category 'changeSet menu') -----
browseChangeSet
"Open a message list browser on the new and changed methods in the current change set"
ChangedMessageSet openFor: myChangeSet
!
----- Method: ChangeSorter>>browseMethodConflicts (in category 'changeSet menu') -----
browseMethodConflicts
"Check to see if any other change set also holds changes to any methods in the selected change set; if so, open a browser on all such."
| aList |
aList := myChangeSet
messageListForChangesWhich: [ :aClass :aSelector |
(ChangesOrganizer allChangeSetsWithClass: aClass selector: aSelector) size > 1
]
ifNone: [^ self inform: 'No other change set has changes
for any method in this change set.'].
MessageSet
openMessageList: aList
name: 'Methods in "', myChangeSet name, '" that are also in other change sets (', aList size printString, ')'
!
----- Method: ChangeSorter>>browseVersions (in category 'message list') -----
browseVersions
"Create and schedule a changelist browser on the versions of the
selected message."
| class selector method category pair sourcePointer |
(selector := self selectedMessageName) ifNil: [^ self].
class := self selectedClassOrMetaClass.
(class includesSelector: selector)
ifTrue: [method := class compiledMethodAt: selector.
category := class whichCategoryIncludesSelector: selector.
sourcePointer := nil]
ifFalse: [pair := myChangeSet methodInfoFromRemoval: {class name. selector}.
pair ifNil: [^ nil].
sourcePointer := pair first.
method := CompiledMethod toReturnSelf setSourcePointer: sourcePointer.
category := pair last].
VersionsBrowser
browseVersionsOf: method
class: self selectedClass meta: class isMeta
category: category selector: selector
lostMethodPointer: sourcePointer.
!
----- Method: ChangeSorter>>buildWith: (in category 'toolbuilder') -----
buildWith: builder
"
ToolBuilder open: ChangeSorter.
"
| windowSpec |
windowSpec := builder pluggableWindowSpec new.
windowSpec label: 'Change Sorter'.
windowSpec model: self.
windowSpec children: OrderedCollection new.
windowSpec label: #labelString.
self buildWith: builder in: windowSpec rect: (0 at 0 extent: 1 at 1).
^builder build: windowSpec!
----- Method: ChangeSorter>>buildWith:in:rect: (in category 'toolbuilder') -----
buildWith: builder in: window rect: rect
| csListHeight msgListHeight csMsgListHeight listSpec textSpec |
contents := ''.
csListHeight := 0.25.
msgListHeight := 0.25.
csMsgListHeight := csListHeight + msgListHeight.
listSpec := builder pluggableListSpec new.
listSpec
model: self;
list: #changeSetList;
getSelected: #currentCngSet;
setSelected: #showChangeSetNamed:;
menu: #changeSetMenu:shifted:;
keyPress: #changeSetListKey:from:;
autoDeselect: false;
frame: (((0 at 0 extent: 0.5 at csListHeight)
scaleBy: rect extent) translateBy: rect origin).
window children add: listSpec.
listSpec := builder pluggableListSpec new.
listSpec
model: self;
list: #classList;
getSelected: #currentClassName;
setSelected: #currentClassName:;
menu: #classListMenu:shifted:;
keyPress: #classListKey:from:;
frame: (((0.5 at 0 extent: 0.5 at csListHeight)
scaleBy: rect extent) translateBy: rect origin).
window children add: listSpec.
listSpec := builder pluggableListSpec new.
listSpec
model: self;
list: #messageList;
getSelected: #currentSelector;
setSelected: #currentSelector:;
menu: #messageMenu:shifted:;
keyPress: #messageListKey:from:;
frame: (((0 at csListHeight extent: 1 at msgListHeight)
scaleBy: rect extent) translateBy: rect origin).
window children add: listSpec.
textSpec := builder pluggableTextSpec new.
textSpec
model: self;
getText: #contents;
setText: #contents:notifying:;
selection: #contentsSelection;
menu: #codePaneMenu:shifted:;
frame: (((0 at csMsgListHeight corner: 1 at 1) scaleBy: rect extent) translateBy: rect origin).
window children add: textSpec.
^window!
----- Method: ChangeSorter>>categorySubmenu:shifted: (in category 'changeSet menu') -----
categorySubmenu: aMenu shifted: shiftedIgnored
"Fill aMenu with less-frequently-needed category items"
aMenu title: 'Change set category'.
aMenu addStayUpItem.
aMenu addList: #(
('make a new category...' makeNewCategory 'Creates a new change-set-category (you will be asked to supply a name) which will start out its life with this change set in it')
('make a new category with class...' makeNewCategoryShowingClassChanges 'Creates a new change-set-category that includes change sets that change a particular class (you will be asked to supply a name)')
('rename this category' renameCategory 'Rename this change-set category. Only applies when the current category being shown is a manually-maintained, user-defined category, such as you can create for yourself by choosing "make a new category..." from this same menu.')
('remove this category' removeCategory 'Remove this change-set category. Only applies when the current category being shown is a manually-maintained, user-defined category, such as you can create for yourself by choosing "make a new category..." from this same menu.')
('show categories of this changeset' showCategoriesOfChangeSet 'Show a list of all the change-set categories that contain this change-set; if the you choose one of the categories from this pop-up, that category will be installed in this change sorter')
-).
parent ifNotNil:
[aMenu addList: #(
('add change set to category opposite' addToCategoryOpposite 'Adds this change set to the category on the other side of the change sorter. Only applies if the category shown on the opposite side is a manually-maintained, user-defined category, such as you can create for yourself by choosing "make a new category..." from this same menu.'))].
aMenu addList: #(
('remove change set from this category' removeFromCategory 'Removes this change set from the current category. Only applies when the current category being shown is a manually-maintained, user-defined category, such as you can create for yourself by choosing "make a new category..." from this same menu.')
-
('file out category''s change sets' fileOutAllChangeSets 'File out every change set in this category that has anything in it. The usual checks for slips are suppressed when this command is done.')
('set recent-updates marker' setRecentUpdatesMarker 'Allows you to specify a number that will demarcate which updates are considered "recent" and which are not. This will govern which updates are included in the RecentUpdates category in a change sorter')
('fill aggregate change set' fillAggregateChangeSet 'Creates a change-set named Aggregate into which all the changes in all the change sets in this category will be copied.')
-
('back to main menu' offerUnshiftedChangeSetMenu 'Takes you back to the shifted change-set menu.')
('back to shifted menu' offerShiftedChangeSetMenu 'Takes you back to the primary change-set menu.')).
^ aMenu!
----- Method: ChangeSorter>>changeSet (in category 'access') -----
changeSet
^ myChangeSet!
----- Method: ChangeSorter>>changeSetCategories (in category 'changeSet menu') -----
changeSetCategories
^ ChangesOrganizer changeSetCategories!
----- Method: ChangeSorter>>changeSetCategory (in category 'access') -----
changeSetCategory
"Answer the current changeSetCategory object that governs which change sets are shown in this ChangeSorter"
^ changeSetCategory ifNil:
[self setDefaultChangeSetCategory]!
----- Method: ChangeSorter>>changeSetCurrentlyDisplayed (in category 'access') -----
changeSetCurrentlyDisplayed
^ myChangeSet!
----- Method: ChangeSorter>>changeSetList (in category 'changeSet menu') -----
changeSetList
"Answer a list of ChangeSet names to be shown in the change sorter."
^ self changeSetCategory changeSetList!
----- Method: ChangeSorter>>changeSetListKey:from: (in category 'changeSet menu') -----
changeSetListKey: aChar from: view
"Respond to a Command key. I am a model with a listView that has a list of changeSets."
aChar == $b ifTrue: [^ self browseChangeSet].
aChar == $B ifTrue: [^ self openChangeSetBrowser].
aChar == $c ifTrue: [^ self copyAllToOther].
aChar == $D ifTrue: [^ self toggleDiffing].
aChar == $f ifTrue: [^ self findCngSet].
aChar == $m ifTrue: [^ self newCurrent].
aChar == $n ifTrue: [^ self newSet].
aChar == $o ifTrue: [^ self fileOut].
aChar == $p ifTrue: [^ self addPreamble].
aChar == $r ifTrue: [^ self rename].
aChar == $s ifTrue: [^ self chooseChangeSetCategory].
aChar == $x ifTrue: [^ self remove].
aChar == $- ifTrue: [^ self subtractOtherSide].
^ self messageListKey: aChar from: view!
----- Method: ChangeSorter>>changeSetMenu:shifted: (in category 'changeSet menu') -----
changeSetMenu: aMenu shifted: isShifted
"Set up aMenu to hold commands for the change-set-list pane. This could be for a single or double changeSorter"
isShifted ifTrue: [^ self shiftedChangeSetMenu: aMenu].
Smalltalk isMorphic
ifTrue:
[aMenu title: 'Change Set'.
aMenu addStayUpItemSpecial]
ifFalse:
[aMenu title: 'Change Set:
' , myChangeSet name].
aMenu add: 'make changes go to me (m)' action: #newCurrent.
aMenu addLine.
aMenu add: 'new change set... (n)' action: #newSet.
aMenu add: 'find...(f)' action: #findCngSet.
aMenu add: 'show category... (s)' action: #chooseChangeSetCategory.
aMenu balloonTextForLastItem:
'Lets you choose which change sets should be listed in this change sorter'.
aMenu add: 'select change set...' action: #chooseCngSet.
aMenu addLine.
aMenu add: 'rename change set (r)' action: #rename.
aMenu add: 'file out (o)' action: #fileOut.
aMenu add: 'mail to list' action: #mailOut.
aMenu add: 'browse methods (b)' action: #browseChangeSet.
aMenu add: 'browse change set (B)' action: #openChangeSetBrowser.
aMenu addLine.
parent
ifNotNil:
[aMenu add: 'copy all to other side (c)' action: #copyAllToOther.
aMenu add: 'submerge into other side' action: #submergeIntoOtherSide.
aMenu add: 'subtract other side (-)' action: #subtractOtherSide.
aMenu addLine].
myChangeSet hasPreamble
ifTrue:
[aMenu add: 'edit preamble (p)' action: #addPreamble.
aMenu add: 'remove preamble' action: #removePreamble]
ifFalse: [aMenu add: 'add preamble (p)' action: #addPreamble].
myChangeSet hasPostscript
ifTrue:
[aMenu add: 'edit postscript...' action: #editPostscript.
aMenu add: 'remove postscript' action: #removePostscript]
ifFalse: [aMenu add: 'add postscript...' action: #editPostscript].
aMenu addLine.
aMenu add: 'category functions...' action: #offerCategorySubmenu.
aMenu balloonTextForLastItem:
'Various commands relating to change-set-categories'.
aMenu addLine.
aMenu add: 'destroy change set (x)' action: #remove.
aMenu addLine.
aMenu add: 'more...' action: #offerShiftedChangeSetMenu.
^ aMenu!
----- Method: ChangeSorter>>checkForAlienAuthorship (in category 'changeSet menu') -----
checkForAlienAuthorship
"Open a message list browser on all uncommented methods in the current change set that have alien authorship"
myChangeSet checkForAlienAuthorship
!
----- Method: ChangeSorter>>checkForAnyAlienAuthorship (in category 'changeSet menu') -----
checkForAnyAlienAuthorship
"Open a message list browser on all uncommented methods in the current change set that have alien authorship, even historically"
myChangeSet checkForAnyAlienAuthorship
!
----- Method: ChangeSorter>>checkForUnclassifiedMethods (in category 'changeSet menu') -----
checkForUnclassifiedMethods
"Open a message list browser on all methods in the current change set that have not been categorized"
myChangeSet checkForUnclassifiedMethods
!
----- Method: ChangeSorter>>checkForUncommentedClasses (in category 'changeSet menu') -----
checkForUncommentedClasses
"Open a class list browser on classes in the change set that lack class comments"
myChangeSet checkForUncommentedClasses!
----- Method: ChangeSorter>>checkForUncommentedMethods (in category 'changeSet menu') -----
checkForUncommentedMethods
"Open a message list browser on all uncommented methods in the current change set"
myChangeSet checkForUncommentedMethods
!
----- Method: ChangeSorter>>checkForUnsentMessages (in category 'changeSet menu') -----
checkForUnsentMessages
"Open a message list browser on all unsent messages in the current change set"
myChangeSet checkForUnsentMessages
!
----- Method: ChangeSorter>>checkThatSidesDiffer: (in category 'changeSet menu') -----
checkThatSidesDiffer: escapeBlock
"If the change sets on both sides of the dual sorter are the same, put up an error message and escape via escapeBlock, else proceed happily"
(myChangeSet == (parent other: self) changeSet)
ifTrue:
[self inform:
'This command requires that the
change sets selected on the two
sides of the change sorter *not*
be the same.'.
^ escapeBlock value]
!
----- Method: ChangeSorter>>chooseChangeSetCategory (in category 'changeSet menu') -----
chooseChangeSetCategory
"Present the user with a list of change-set-categories and let her choose one"
| cats result |
self okToChange ifFalse: [^ self].
Smalltalk isMorphic ifTrue: [^ self chooseChangeSetCategoryInMorphic]. "gives balloon help"
cats := self changeSetCategories elementsInOrder.
result := UIManager default
chooseFrom: (cats collect: [:cat | cat categoryName])
values: cats.
result ifNotNil:
[changeSetCategory := result.
self changed: #changeSetList.
(self changeSetList includes: myChangeSet name) ifFalse:
[self showChangeSet: (ChangesOrganizer changeSetNamed: self changeSetList first)].
self changed: #relabel]!
----- Method: ChangeSorter>>chooseChangeSetCategoryInMorphic (in category 'changeSet menu') -----
chooseChangeSetCategoryInMorphic
"Present the user with a list of change-set-categories and let her choose one. In this morphic variant, we include balloon help"
| aMenu |
aMenu := MenuMorph new defaultTarget: self.
aMenu title:
'Choose the category of
change sets to show in
this Change Sorter
(red = current choice)'.
self changeSetCategories elementsInOrder do:
[:aCategory |
aMenu add: aCategory categoryName target: self selector: #showChangeSetCategory: argument: aCategory.
aCategory == changeSetCategory ifTrue:
[aMenu lastItem color: Color red].
aMenu balloonTextForLastItem: aCategory documentation].
aMenu popUpInWorld!
----- Method: ChangeSorter>>chooseCngSet (in category 'changeSet menu') -----
chooseCngSet
"Present the user with an alphabetical list of change set names, and let her choose one"
| changeSetsSortedAlphabetically chosen |
self okToChange ifFalse: [^ self].
changeSetsSortedAlphabetically := self changeSetList asSortedCollection:
[:a :b | a asLowercase withoutLeadingDigits < b asLowercase withoutLeadingDigits].
chosen := UIManager default chooseFrom: changeSetsSortedAlphabetically values: changeSetsSortedAlphabetically.
chosen ifNil: [^ self].
self showChangeSet: (ChangesOrganizer changeSetNamed: chosen)!
----- Method: ChangeSorter>>classList (in category 'class list') -----
classList
"return the classlist with package note appended."
^ self basicClassList collect: [: each |
each asString, (self packageNoteForClass: (Smalltalk classNamed: each) selector: nil) ] .!
----- Method: ChangeSorter>>classListKey:from: (in category 'class list') -----
classListKey: aChar from: view
"Respond to a Command key in the class-list pane."
aChar == $x ifTrue: [^ self removeClass].
aChar == $d ifTrue: [^ self forgetClass].
^ self messageListKey: aChar from: view "picks up b,h,p"!
----- Method: ChangeSorter>>classListMenu:shifted: (in category 'class list') -----
classListMenu: aMenu shifted: shifted
"Fill aMenu with items appropriate for the class list"
aMenu title: 'class list'.
Smalltalk isMorphic ifTrue: [aMenu addStayUpItemSpecial].
(parent notNil and: [shifted not])
ifTrue: [aMenu addList: #( "These two only apply to dual change sorters"
('copy class chgs to other side' copyClassToOther)
('move class chgs to other side' moveClassToOther))].
aMenu addList: (shifted
ifFalse: [#(
-
('delete class from change set (d)' forgetClass)
('remove class from system (x)' removeClass)
-
('browse full (b)' browseMethodFull)
('browse hierarchy (h)' spawnHierarchy)
('browse protocol (p)' browseFullProtocol)
-
('printOut' printOutClass)
('fileOut' fileOutClass)
-
('inst var refs...' browseInstVarRefs)
('inst var defs...' browseInstVarDefs)
('class var refs...' browseClassVarRefs)
('class vars' browseClassVariables)
('class refs (N)' browseClassRefs)
-
('more...' offerShiftedClassListMenu))]
ifTrue: [#(
-
('unsent methods' browseUnusedMethods)
('unreferenced inst vars' showUnreferencedInstVars)
('unreferenced class vars' showUnreferencedClassVars)
-
('sample instance' makeSampleInstance)
('inspect instances' inspectInstances)
('inspect subinstances' inspectSubInstances)
-
('more...' offerUnshiftedClassListMenu ))]).
^ aMenu!
----- Method: ChangeSorter>>classMenu: (in category 'class list') -----
classMenu: aMenu
"Set up aMenu for the class-list. Retained for backward compatibility with old change sorters in image segments"
^ self classListMenu: aMenu shifted: false!
----- Method: ChangeSorter>>classMenu:shifted: (in category 'class list') -----
classMenu: aMenu shifted: shifted
"Fill aMenu with items appropriate for the class list. Retained for bkwd compatibility"
^ self classListMenu: aMenu shifted: shifted!
----- Method: ChangeSorter>>clearChangeSet (in category 'changeSet menu') -----
clearChangeSet
"Clear out the current change set, after getting a confirmation."
| message |
self okToChange ifFalse: [^ self].
myChangeSet isEmpty ifFalse:
[message := 'Are you certain that you want to\forget all the changes in this set?' withCRs.
(self confirm: message) ifFalse: [^ self]].
myChangeSet clear.
self changed: #classList.
self changed: #messageList.
self setContents.
self contentsChanged.
!
----- Method: ChangeSorter>>contents:notifying: (in category 'code pane') -----
contents: aString notifying: aController
"Compile the code in aString. Notify aController of any syntax errors.
Create an error if the category of the selected message is unknown.
Answer false if the compilation fails. Otherwise, if the compilation
created a new method, deselect the current selection. Then answer true."
| category selector class oldSelector |
(class := self selectedClassOrMetaClass) ifNil:
[(myChangeSet preambleString == nil or: [aString size == 0]) ifTrue: [ ^ false].
(aString count: [:char | char == $"]) odd
ifTrue: [self inform: 'unmatched double quotes in preamble']
ifFalse: [(Scanner new scanTokens: aString) size > 0 ifTrue: [
self inform: 'Part of the preamble is not within double-quotes.
To put a double-quote inside a comment, type two double-quotes in a row.
(Ignore this warning if you are including a doIt in the preamble.)']].
myChangeSet preambleString: aString.
self currentSelector: nil. "forces update with no 'unsubmitted chgs' feedback"
^ true].
oldSelector := self selectedMessageName.
category := class organization categoryOfElement: oldSelector.
selector := class compile: aString
classified: category
notifying: aController.
selector ifNil: [^ false].
(self messageList includes: selector)
ifTrue: [self currentSelector: selector]
ifFalse: [self currentSelector: oldSelector].
self update.
^ true!
----- Method: ChangeSorter>>copyAllToOther (in category 'changeSet menu') -----
copyAllToOther
"Copy this entire change set into the one on the other side"
| companionSorter |
self checkThatSidesDiffer: [^ self].
(companionSorter := parent other: self) changeSetCurrentlyDisplayed assimilateAllChangesFoundIn: myChangeSet.
companionSorter changed: #classList. "Later the changeSet itself will notice..."
companionSorter changed: #messageList!
----- Method: ChangeSorter>>copyClassToOther (in category 'class list') -----
copyClassToOther
"Place these changes in the other changeSet also"
| otherSorter otherChangeSet |
self checkThatSidesDiffer: [^ self].
self okToChange ifFalse: [^ Beeper beep].
currentClassName ifNil: [^ Beeper beep].
otherSorter := parent other: self.
otherChangeSet := otherSorter changeSet.
otherChangeSet absorbClass: self selectedClassOrMetaClass name from: myChangeSet.
otherSorter showChangeSet: otherChangeSet.!
----- Method: ChangeSorter>>copyMethodToOther (in category 'message list') -----
copyMethodToOther
"Place this change in the other changeSet also"
| other cls sel |
self checkThatSidesDiffer: [^ self].
currentSelector ifNotNil:
[other := (parent other: self) changeSet.
cls := self selectedClassOrMetaClass.
sel := self selectedMessageName.
other absorbMethod: sel class: cls from: myChangeSet.
(parent other: self) showChangeSet: other]
!
----- Method: ChangeSorter>>currentClassName (in category 'class list') -----
currentClassName
^ currentClassName!
----- Method: ChangeSorter>>currentClassName: (in category 'class list') -----
currentClassName: aString
currentClassName := aString.
currentSelector := nil. "fix by wod"
self changed: #currentClassName.
self changed: #messageList.
self setContents.
self contentsChanged.!
----- Method: ChangeSorter>>currentCngSet (in category 'changeSet menu') -----
currentCngSet
^ myChangeSet name!
----- Method: ChangeSorter>>currentSelector (in category 'message list') -----
currentSelector
^ currentSelector!
----- Method: ChangeSorter>>currentSelector: (in category 'message list') -----
currentSelector: messageName
currentSelector := messageName.
self changed: #currentSelector.
self setContents.
self contentsChanged.!
----- Method: ChangeSorter>>editPostscript (in category 'changeSet menu') -----
editPostscript
"Allow the user to edit the receiver's change-set's postscript -- in a separate window"
myChangeSet editPostscript!
----- Method: ChangeSorter>>editPreamble (in category 'changeSet menu') -----
editPreamble
"Allow the user to edit the receiver's change-set's preamble -- in a separate window."
myChangeSet editPreamble!
----- Method: ChangeSorter>>endNote (in category 'annotation') -----
endNote
"return the string at the beginning of item annotation"
^'}'
!
----- Method: ChangeSorter>>expungeUniclasses (in category 'changeSet menu') -----
expungeUniclasses
"remove all memory of uniclasses in the receiver"
self okToChange ifFalse: [^ self].
myChangeSet expungeUniclasses.
self changed: #classList.
self changed: #messageList.
!
----- Method: ChangeSorter>>fileIntoNewChangeSet (in category 'changeSet menu') -----
fileIntoNewChangeSet
"Obtain a file designation from the user, and file its contents into a
new change set whose name is a function of the filename. Show the
new set and leave the current changeSet unaltered."
| aNewChangeSet stream |
self okToChange
ifFalse: [^ self].
ChangeSet promptForDefaultChangeSetDirectoryIfNecessary.
stream := StandardFileMenu oldFileStreamFrom: ChangeSet defaultChangeSetDirectory.
stream
ifNil: [^ self].
aNewChangeSet := self class
newChangesFromStream: stream
named: (FileDirectory localNameFor: stream name).
aNewChangeSet
ifNotNil: [self showChangeSet: aNewChangeSet]!
----- Method: ChangeSorter>>fileOut (in category 'changeSet menu') -----
fileOut
"File out the current change set."
myChangeSet fileOut.
parent modelWakeUp. "notice object conversion methods created"
!
----- Method: ChangeSorter>>fileOutAllChangeSets (in category 'changeSet menu') -----
fileOutAllChangeSets
"File out all nonempty change sets in the current category, probably"
self changeSetCategory fileOutAllChangeSets!
----- Method: ChangeSorter>>fileOutClass (in category 'class list') -----
fileOutClass
"this is a hack!!!! makes a new change set, called the class name, adds author initials to try to make a unique change set name, files it out and removes it. kfr 16 june 2000"
| aSet |
"File out the selected class set."
aSet := self class newChangeSet: (self withoutItemAnnotation: currentClassName).
aSet absorbClass: self selectedClassOrMetaClass name from: myChangeSet.
aSet fileOut.
self class removeChangeSet: aSet.
parent modelWakeUp. "notice object conversion methods created"
!
----- Method: ChangeSorter>>fillAggregateChangeSet (in category 'changeSet menu') -----
fillAggregateChangeSet
"Create a change-set named Aggregate and pour into it all the changes in all the change-sets of the currently-selected category"
self changeSetCategory fillAggregateChangeSet!
----- Method: ChangeSorter>>findCngSet (in category 'changeSet menu') -----
findCngSet
"Search for a changeSet by name. Pop up a menu of all changeSets whose name contains the string entered by the user. If only one matches, then the pop-up menu is bypassed"
| index pattern candidates nameList |
self okToChange ifFalse: [^ self].
pattern := UIManager default request: 'ChangeSet name or fragment?'.
pattern isEmpty ifTrue: [^ self].
nameList := self changeSetList asSet.
candidates := ChangeSet allChangeSets select:
[:c | (nameList includes: c name) and:
[c name includesSubstring: pattern caseSensitive: false]].
candidates size = 0 ifTrue: [^ Beeper beep].
candidates size = 1 ifTrue:
[^ self showChangeSet: candidates first].
index := (UIManager default chooseFrom:
(candidates collect: [:each | each name]) asStringWithCr).
index = 0 ifFalse: [self showChangeSet: (candidates at: index)].
!
----- Method: ChangeSorter>>forget (in category 'message list') -----
forget
"Drop this method from the changeSet"
self okToChange ifFalse: [^ self].
currentSelector ifNotNil: [
myChangeSet removeSelectorChanges: self selectedMessageName
class: self selectedClassOrMetaClass.
currentSelector := nil.
self showChangeSet: myChangeSet]!
----- Method: ChangeSorter>>forgetClass (in category 'class list') -----
forgetClass
"Remove all mention of this class from the changeSet"
self okToChange ifFalse: [^ self].
currentClassName ifNotNil: [
myChangeSet removeClassChanges: (self withoutItemAnnotation: currentClassName).
currentClassName := nil.
currentSelector := nil.
self showChangeSet: myChangeSet].
!
----- Method: ChangeSorter>>goToChangeSetsProject (in category 'changeSet menu') -----
goToChangeSetsProject
"Transport the user to a project which bears the selected changeSet as its current changeSet"
| aProject |
(aProject := myChangeSet correspondingProject)
ifNotNil:
[aProject enter: false revert: false saveForRevert: false]
ifNil:
[self inform: 'Has no project']!
----- Method: ChangeSorter>>initialize (in category 'initialize') -----
initialize
super initialize.
myChangeSet := ChangeSet current.!
----- Method: ChangeSorter>>inspectChangeSet (in category 'changeSet menu') -----
inspectChangeSet
"Open a message list browser on the new and changed methods in the current change set"
myChangeSet inspectWithLabel: 'Change set: ', myChangeSet name
!
----- Method: ChangeSorter>>label (in category 'access') -----
label
^ self labelString!
----- Method: ChangeSorter>>labelString (in category 'access') -----
labelString
"The label for my entire window. The large button that displays my name is gotten via mainButtonName"
^ String streamContents:
[:aStream |
aStream nextPutAll: (ChangeSet current == myChangeSet
ifTrue: ['Changes go to "', myChangeSet name, '"']
ifFalse: ['ChangeSet: ', myChangeSet name]).
(self changeSetCategory categoryName ~~ #All)
ifTrue:
[aStream nextPutAll: ' - ', self parenthesizedCategoryName]]!
----- Method: ChangeSorter>>lookForSlips (in category 'changeSet menu') -----
lookForSlips
"Open a message list browser on the new and changed methods in the current change set"
myChangeSet lookForSlips
!
----- Method: ChangeSorter>>mailOut (in category 'changeSet menu') -----
mailOut
"Create a mail with a gzipped attachment holding out the current change
set. "
myChangeSet mailOut.
parent modelWakeUp!
----- Method: ChangeSorter>>mainButtonName (in category 'changeSet menu') -----
mainButtonName
^ myChangeSet name!
----- Method: ChangeSorter>>makeNewCategory (in category 'changeSet menu') -----
makeNewCategory
"Create a new, static change-set category, which will be populated entirely by change sets that have been manually placed in it"
| catName aCategory |
catName := UIManager default request: 'Please give the new category a name' initialAnswer: ''.
catName isEmptyOrNil ifTrue: [^ self].
catName := catName asSymbol.
(self changeSetCategories includesKey: catName) ifTrue:
[^ self inform: 'Sorry, there is already a category of that name'].
aCategory := StaticChangeSetCategory new categoryName: catName.
self changeSetCategories elementAt: catName put: aCategory.
aCategory addChangeSet: myChangeSet.
self showChangeSetCategory: aCategory!
----- Method: ChangeSorter>>makeNewCategoryShowingClassChanges (in category 'changeSet menu') -----
makeNewCategoryShowingClassChanges
"Create a new, static change-set category, which will be populated entirely by change sets that have been manually placed in it"
| catName aCategory clsName |
clsName := self selectedClass ifNotNil: [self selectedClass name ] ifNil: [''].
clsName := UIManager default request: 'Which class?' initialAnswer: clsName.
clsName isEmptyOrNil ifTrue: [^ self].
catName := ('Changes to ', clsName) asSymbol.
(self changeSetCategories includesKey: catName) ifTrue:
[^ self inform: 'Sorry, there is already a category of that name'].
aCategory := ChangeSetCategoryWithParameters new categoryName: catName.
aCategory membershipSelector: #changeSet:containsClass: ; parameters: { clsName }.
self changeSetCategories elementAt: catName put: aCategory.
aCategory reconstituteList.
self showChangeSetCategory: aCategory!
----- Method: ChangeSorter>>messageList (in category 'message list') -----
messageList
| thisClass |
(thisClass := self selectedClassOrMetaClass) ifNil: [^ #() ] .
^self basicMessageList collect: [ :each |
each asString , (self packageNoteForClass: thisClass selector: each) ] .
!
----- Method: ChangeSorter>>messageListKey:from: (in category 'class list') -----
messageListKey: aChar from: view
"Respond to a Command key in the message-list pane."
aChar == $d ifTrue: [^ self forget].
super messageListKey: aChar from: view!
----- Method: ChangeSorter>>messageListMenu:shifted: (in category 'message list') -----
messageListMenu: aMenu shifted: shifted
"Fill aMenu with items appropriate for the message list; could be for a single or double changeSorter"
^ self messageMenu: aMenu shifted: shifted!
----- Method: ChangeSorter>>messageMenu:shifted: (in category 'message list') -----
messageMenu: aMenu shifted: shifted
"Fill aMenu with items appropriate for the message list; could be for a single or double changeSorter"
shifted ifTrue: [^ self shiftedMessageMenu: aMenu].
aMenu title: 'message list'.
Smalltalk isMorphic ifTrue: [aMenu addStayUpItemSpecial].
parent ifNotNil:
[aMenu addList: #(
('copy method to other side' copyMethodToOther)
('move method to other side' moveMethodToOther))].
aMenu addList: #(
('delete method from changeSet (d)' forget)
-
('remove method from system (x)' removeMessage)
-
('browse full (b)' browseMethodFull)
('browse hierarchy (h)' spawnHierarchy)
('browse method (O)' openSingleMessageBrowser)
('browse protocol (p)' browseFullProtocol)
-
('fileOut' fileOutMessage)
('printOut' printOutMessage)
-
('senders of... (n)' browseSendersOfMessages)
('implementors of... (m)' browseMessages)
('inheritance (i)' methodHierarchy)
('versions (v)' browseVersions)
-
('more...' shiftedYellowButtonActivity)).
^ aMenu
!
----- Method: ChangeSorter>>methodConflictsWithOppositeCategory (in category 'changeSet menu') -----
methodConflictsWithOppositeCategory
"Check to see if ANY change set on the other side shares any methods with the selected change set; if so, open a browser on all such."
| aList otherCategory |
otherCategory := (parent other: self) changeSetCategory.
aList := myChangeSet
messageListForChangesWhich: [ :aClass :aSelector |
aClass notNil and:
[otherCategory
hasChangeForClassName: aClass name
selector: aSelector
otherThanIn: myChangeSet]
]
ifNone: [^ self inform:
'There are no methods that appear both in
this change set and in any change set
(other than this one) on the other side.'].
MessageSet
openMessageList: aList
name: 'Methods in "', myChangeSet name, '" also in some other change set in category ', otherCategory categoryName,' (', aList size printString, ')'
!
----- Method: ChangeSorter>>methodConflictsWithOtherSide (in category 'changeSet menu') -----
methodConflictsWithOtherSide
"Check to see if the change set on the other side shares any methods with the selected change set; if so, open a browser on all such."
| aList other |
self checkThatSidesDiffer: [^ self].
other := (parent other: self) changeSet.
aList := myChangeSet
messageListForChangesWhich: [ :aClass :aSelector |
aClass notNil and: [(other methodChangesAtClass: aClass name) includesKey: aSelector]
]
ifNone: [^ self inform: 'There are no methods that appear
both in this change set and
in the one on the other side.'].
MessageSet
openMessageList: aList
name: 'Methods in "', myChangeSet name, '" that are also in ', other name,' (', aList size printString, ')'
!
----- Method: ChangeSorter>>modelWakeUp (in category 'access') -----
modelWakeUp
"A window with me as model is being entered.
Make sure I am up-to-date with the changeSets."
self canDiscardEdits ifTrue: [self update]!
----- Method: ChangeSorter>>moveClassToOther (in category 'class list') -----
moveClassToOther
"Place class changes in the other changeSet and remove them from this one"
self checkThatSidesDiffer: [^ self].
(self okToChange and: [currentClassName notNil]) ifFalse: [^ Beeper beep].
self copyClassToOther.
self forgetClass!
----- Method: ChangeSorter>>moveMethodToOther (in category 'message list') -----
moveMethodToOther
"Place this change in the other changeSet and remove it from this side"
| other cls sel |
self checkThatSidesDiffer: [^self].
self okToChange ifFalse: [^Beeper beep].
currentSelector ifNotNil:
[other := (parent other: self) changeSet.
other == myChangeSet ifTrue: [^Beeper beep].
cls := self selectedClassOrMetaClass.
sel := self selectedMessageName.
other
absorbMethod: sel
class: cls
from: myChangeSet.
(parent other: self) showChangeSet: other.
self forget "removes the method from this side"]!
----- Method: ChangeSorter>>myChangeSet: (in category 'access') -----
myChangeSet: anObject
myChangeSet := anObject!
----- Method: ChangeSorter>>newCurrent (in category 'changeSet menu') -----
newCurrent
"make my change set be the current one that changes go into"
ChangeSet newChanges: myChangeSet.
self update. "Because list of changes in a category may thus have changed"
self changed: #relabel.!
----- Method: ChangeSorter>>newSet (in category 'changeSet menu') -----
newSet
"Create a new changeSet and show it., making it the current one. Reject name if already in use."
| aSet |
self okToChange ifFalse: [^ self].
aSet := self class newChangeSet.
aSet ifNotNil:
[self changeSetCategory acceptsManualAdditions ifTrue:
[changeSetCategory addChangeSet: aSet].
self update.
(changeSetCategory includesChangeSet: aSet) ifTrue:
[self showChangeSet: aSet].
self changed: #relabel]!
----- Method: ChangeSorter>>noteString: (in category 'annotation') -----
noteString: aString
^ self beginNote , aString asString , self endNote!
----- Method: ChangeSorter>>offerCategorySubmenu (in category 'changeSet menu') -----
offerCategorySubmenu
"Offer a menu of category-related items"
self offerMenuFrom: #categorySubmenu:shifted: shifted: false!
----- Method: ChangeSorter>>offerShiftedChangeSetMenu (in category 'changeSet menu') -----
offerShiftedChangeSetMenu
"Offer the shifted version of the change set menu"
self offerMenuFrom: #changeSetMenu:shifted: shifted: true!
----- Method: ChangeSorter>>offerUnshiftedChangeSetMenu (in category 'changeSet menu') -----
offerUnshiftedChangeSetMenu
"Offer the unshifted version of the change set menu"
self offerMenuFrom: #changeSetMenu:shifted: shifted: false!
----- Method: ChangeSorter>>open (in category 'creation') -----
open
"ChangeSorterPluggable new open"
^ToolBuilder open: self!
----- Method: ChangeSorter>>openChangeSetBrowser (in category 'changeSet menu') -----
openChangeSetBrowser
"Open a ChangeSet browser on the current change set"
ToolBuilder open: (ChangeSetBrowser new myChangeSet: myChangeSet)!
----- Method: ChangeSorter>>packageNoteForClass:selector: (in category 'annotation') -----
packageNoteForClass: aClass selector: aSelector
"return the category name that represents the package name for aClass>>aSelector.
when selector is nil or in a normal catagory return "
| package |
package := (self annotationForPackageforSelector: aSelector
ofClass: aClass) ifNil: ['<class was deleted???>'] .
^ self noteString: package
!
----- Method: ChangeSorter>>parent (in category 'access') -----
parent
^ parent!
----- Method: ChangeSorter>>parent: (in category 'access') -----
parent: anObject
parent := anObject!
----- Method: ChangeSorter>>parenthesizedCategoryName (in category 'access') -----
parenthesizedCategoryName
"Answer my category name in parentheses"
^ ' (', self changeSetCategory categoryName, ')'!
----- Method: ChangeSorter>>promoteToTopChangeSet (in category 'changeSet menu') -----
promoteToTopChangeSet
"Move the selected change-set to the top of the list"
self class promoteToTop: myChangeSet.
(parent ifNil: [self]) modelWakeUp!
----- Method: ChangeSorter>>remove (in category 'changeSet menu') -----
remove
"Completely destroy my change set. Check if it's OK first"
self okToChange ifFalse: [^ self].
self removePrompting: true.
self update!
----- Method: ChangeSorter>>removeCategory (in category 'changeSet menu') -----
removeCategory
"Remove the current category"
| itsName |
self changeSetCategory acceptsManualAdditions ifFalse:
[^ self inform: 'sorry, you can only remove manually-added categories.'].
(self confirm: 'Really remove the change-set-category
named ', (itsName := changeSetCategory categoryName), '?') ifFalse: [^ self].
self changeSetCategories removeElementAt: itsName.
self setDefaultChangeSetCategory.
self update!
----- Method: ChangeSorter>>removeContainedInClassCategories (in category 'changeSet menu') -----
removeContainedInClassCategories
| matchExpression |
myChangeSet removePreamble.
matchExpression := UIManager default request: 'Enter class category name (wildcard is ok)' initialAnswer: 'System-*'.
(Smalltalk organization categories
select: [:each | matchExpression match: each])
do: [:eachCat |
| classNames |
classNames := Smalltalk organization listAtCategoryNamed: eachCat.
classNames
do: [:eachClassName |
myChangeSet removeClassChanges: eachClassName.
myChangeSet removeClassChanges: eachClassName , ' class'].
self showChangeSet: myChangeSet]!
----- Method: ChangeSorter>>removeFromCategory (in category 'changeSet menu') -----
removeFromCategory
"Add the current change set to the category viewed on the opposite side, if it's of the sort to accept things like that"
| aCategory |
(aCategory := self changeSetCategory) acceptsManualAdditions
ifTrue:
[aCategory removeElementAt: myChangeSet name.
aCategory reconstituteList.
self update]
ifFalse:
[self inform:
'sorry, this command only makes
sense for static categories whose
members are manually maintained']!
----- Method: ChangeSorter>>removeFromCurrentChanges (in category 'message list') -----
removeFromCurrentChanges
"Redisplay after removal in case we are viewing the current changeSet"
super removeFromCurrentChanges.
currentSelector := nil.
self showChangeSet: myChangeSet!
----- Method: ChangeSorter>>removeMessage (in category 'message list') -----
removeMessage
"Remove the selected msg from the system. Real work done by the
parent, a ChangeSorter"
| confirmation sel |
self okToChange
ifFalse: [^ self].
currentSelector
ifNotNil: [confirmation := self systemNavigation confirmRemovalOf: (sel := self selectedMessageName) on: self selectedClassOrMetaClass.
confirmation == 3
ifTrue: [^ self].
self selectedClassOrMetaClass removeSelector: sel.
self update.
confirmation == 2
ifTrue: [self systemNavigation browseAllCallsOn: sel]]!
----- Method: ChangeSorter>>removePostscript (in category 'changeSet menu') -----
removePostscript
(myChangeSet hasPostscript and: [myChangeSet postscriptHasDependents]) ifTrue:
[^ self inform:
'Cannot remove the postscript right
now because there is at least one
window open on that postscript.
Close that window and try again.'].
myChangeSet removePostscript.
self showChangeSet: myChangeSet!
----- Method: ChangeSorter>>removePreamble (in category 'changeSet menu') -----
removePreamble
myChangeSet removePreamble.
self showChangeSet: myChangeSet!
----- Method: ChangeSorter>>removePrompting: (in category 'changeSet menu') -----
removePrompting: doPrompt
"Completely destroy my change set. Check if it's OK first, and if doPrompt is true, get the user to confirm his intentions first."
| message aName changeSetNumber msg |
aName := myChangeSet name.
myChangeSet okayToRemove ifFalse: [^ self]. "forms current changes for some project"
(myChangeSet isEmpty or: [doPrompt not]) ifFalse:
[message := 'Are you certain that you want to
remove (destroy) the change set
named "', aName, '" ?'.
(self confirm: message) ifFalse: [^ self]].
doPrompt ifTrue:
[msg := myChangeSet hasPreamble
ifTrue:
[myChangeSet hasPostscript
ifTrue:
['a preamble and a postscript']
ifFalse:
['a preamble']]
ifFalse:
[myChangeSet hasPostscript
ifTrue:
['a postscript']
ifFalse:
['']].
msg isEmpty ifFalse:
[(self confirm:
'Caution!! This change set has
', msg, ' which will be
lost if you destroy the change set.
Do you really want to go ahead with this?') ifFalse: [^ self]]].
"Go ahead and remove the change set"
changeSetNumber := myChangeSet name initialIntegerOrNil.
changeSetNumber ifNotNil: [SystemVersion current unregisterUpdate: changeSetNumber].
ChangesOrganizer removeChangeSet: myChangeSet.
self showChangeSet: ChangeSet current.!
----- Method: ChangeSorter>>rename (in category 'changeSet menu') -----
rename
"Store a new name string into the selected ChangeSet. reject duplicate name; allow user to back out"
| newName |
newName := UIManager default request: 'New name for this change set'
initialAnswer: myChangeSet name.
(newName = myChangeSet name or: [newName size == 0]) ifTrue:
[^ Beeper beep].
(self class changeSetNamed: newName) ifNotNil:
[^ Utilities inform: 'Sorry that name is already used'].
myChangeSet name: newName.
self update.
self changed: #mainButtonName.
self changed: #relabel.!
----- Method: ChangeSorter>>renameCategory (in category 'changeSet menu') -----
renameCategory
"Obtain a new name for the category and, if acceptable, apply it"
| catName oldName |
self changeSetCategory acceptsManualAdditions ifFalse:
[^ self inform: 'sorry, you can only rename manually-added categories.'].
catName := UIManager default request: 'Please give the new category a name' initialAnswer: (oldName := changeSetCategory categoryName).
catName isEmptyOrNil ifTrue: [^ self].
(catName := catName asSymbol) = oldName ifTrue: [^ self inform: 'no change.'].
(self changeSetCategories includesKey: catName) ifTrue:
[^ self inform: 'Sorry, there is already a category of that name'].
changeSetCategory categoryName: catName.
self changeSetCategories removeElementAt: oldName.
self changeSetCategories elementAt: catName put: changeSetCategory.
self update!
----- Method: ChangeSorter>>reorderChangeSets (in category 'changeSet menu') -----
reorderChangeSets
"apply a standard reordering -- let the class handle this"
^ self class reorderChangeSets!
----- Method: ChangeSorter>>selectedClass (in category 'class list') -----
selectedClass
"Answer the currently-selected class. If there is no selection, or if the selection refers to a class no longer extant, return nil"
| c |
^ currentClassName ifNotNil: [(c := self selectedClassOrMetaClass)
ifNotNil: [c theNonMetaClass]]!
----- Method: ChangeSorter>>selectedClassOrMetaClass (in category 'traits') -----
selectedClassOrMetaClass
"Careful, the class may have been removed!!"
| cName tName className |
currentClassName ifNil: [^ nil].
className := (self withoutItemAnnotation: currentClassName) .
(className endsWith: ' class')
ifTrue: [cName := (className copyFrom: 1 to: className size-6) asSymbol.
^ (Smalltalk at: cName ifAbsent: [^nil]) class].
(currentClassName endsWith: ' classTrait')
ifTrue: [tName := (className copyFrom: 1 to: className size-11) asSymbol.
^ (Smalltalk at: tName ifAbsent: [^nil]) classTrait].
cName := className asSymbol.
^ Smalltalk at: cName ifAbsent: [nil]!
----- Method: ChangeSorter>>selectedMessageName (in category 'message list') -----
selectedMessageName
currentSelector ifNil: [^ nil].
^ (self withoutItemAnnotation: currentSelector) asSymbol!
----- Method: ChangeSorter>>setContents (in category 'code pane') -----
setContents
"return the source code that shows in the bottom pane"
| sel class strm changeType |
self clearUserEditFlag.
currentClassName ifNil: [^ contents := myChangeSet preambleString ifNil: ['']].
class := self selectedClassOrMetaClass.
(sel := self selectedMessageName) == nil
ifFalse: [changeType := (myChangeSet atSelector: (sel := sel asSymbol) class: class).
changeType == #remove
ifTrue: [^ contents := 'Method has been removed (see versions)'].
changeType == #addedThenRemoved
ifTrue: [^ contents := 'Added then removed (see versions)'].
class ifNil: [^ contents := 'Method was added, but cannot be found!!'].
(class includesSelector: sel)
ifFalse: [^ contents := 'Method was added, but cannot be found!!'].
contents := class sourceCodeAt: sel.
(#(prettyPrint prettyDiffs) includes: contentsSymbol) ifTrue:
[contents := class prettyPrinterClass
format: contents in: class notifying: nil].
self showingAnyKindOfDiffs
ifTrue: [contents := self diffFromPriorSourceFor: contents].
^ contents := contents asText makeSelectorBoldIn: class]
ifTrue: [strm := WriteStream on: (String new: 100).
(myChangeSet classChangeAt: currentClassName) do:
[:each |
each = #remove ifTrue: [strm nextPutAll: 'Entire class was removed.'; cr].
each = #addedThenRemoved ifTrue: [strm nextPutAll: 'Class was added then removed.'].
each = #rename ifTrue: [strm nextPutAll: 'Class name was changed.'; cr].
each = #add ifTrue: [strm nextPutAll: 'Class definition was added.'; cr].
each = #change ifTrue: [strm nextPutAll: 'Class definition was changed.'; cr].
each = #reorganize ifTrue: [strm nextPutAll: 'Class organization was changed.'; cr].
each = #comment ifTrue: [strm nextPutAll: 'New class comment.'; cr.
]].
^ contents := strm contents].!
----- Method: ChangeSorter>>setDefaultChangeSetCategory (in category 'creation') -----
setDefaultChangeSetCategory
"Set a default ChangeSetCategory for the receiver, and answer it"
^ changeSetCategory := self class changeSetCategoryNamed: #All!
----- Method: ChangeSorter>>setRecentUpdatesMarker (in category 'changeSet menu') -----
setRecentUpdatesMarker
"Allow the user to change the recent-updates marker"
| result |
result := UIManager default request:
('Enter the lowest change-set number
that you wish to consider "recent"?
(note: highest change-set number
in this image at this time is ', ChangeSet highestNumberedChangeSet asString, ')') initialAnswer: self class recentUpdateMarker asString.
(result notNil and: [result startsWithDigit]) ifTrue:
[self class recentUpdateMarker: result asInteger.
Smalltalk isMorphic ifTrue: [SystemWindow wakeUpTopWindowUponStartup]]!
----- Method: ChangeSorter>>shiftedChangeSetMenu: (in category 'changeSet menu') -----
shiftedChangeSetMenu: aMenu
"Set up aMenu to hold items relating to the change-set-list pane when the shift key is down"
Smalltalk isMorphic ifTrue:
[aMenu title: 'Change set (shifted)'.
aMenu addStayUpItemSpecial].
"CONFLICTS SECTION"
aMenu add: 'conflicts with other change sets' action: #browseMethodConflicts.
aMenu balloonTextForLastItem:
'Browse all methods that occur both in this change set and in at least one other change set.'.
parent ifNotNil:
[aMenu add: 'conflicts with change set opposite' action: #methodConflictsWithOtherSide.
aMenu balloonTextForLastItem:
'Browse all methods that occur both in this change set and in the one on the opposite side of the change sorter.'.
aMenu add: 'conflicts with category opposite' action: #methodConflictsWithOppositeCategory.
aMenu balloonTextForLastItem:
'Browse all methods that occur both in this change set and in ANY change set in the category list on the opposite side of this change sorter, other of course than this change set itself. (Caution -- this could be VERY slow)'].
aMenu addLine.
"CHECKS SECTION"
aMenu add: 'check for slips' action: #lookForSlips.
aMenu balloonTextForLastItem:
'Check this change set for halts and references to Transcript.'.
aMenu add: 'check for unsent messages' action: #checkForUnsentMessages.
aMenu balloonTextForLastItem:
'Check this change set for messages that are not sent anywhere in the system'.
aMenu add: 'check for uncommented methods' action: #checkForUncommentedMethods.
aMenu balloonTextForLastItem:
'Check this change set for methods that do not have comments'.
aMenu add: 'check for uncommented classes' action: #checkForUncommentedClasses.
aMenu balloonTextForLastItem:
'Check for classes with code in this changeset which lack class comments'.
Utilities authorInitialsPerSe isEmptyOrNil ifFalse:
[aMenu add: 'check for other authors' action: #checkForAlienAuthorship.
aMenu balloonTextForLastItem:
'Check this change set for methods whose current authoring stamp does not start with "', Utilities authorInitials, '"'.
aMenu add: 'check for any other authors' action: #checkForAnyAlienAuthorship.
aMenu balloonTextForLastItem:
'Check this change set for methods any of whose authoring stamps do not start with "', Utilities authorInitials, '"'].
aMenu add: 'check for uncategorized methods' action: #checkForUnclassifiedMethods.
aMenu balloonTextForLastItem:
'Check to see if any methods in the selected change set have not yet been assigned to a category. If any are found, open a browser on them.'.
aMenu addLine.
aMenu add: 'inspect change set' action: #inspectChangeSet.
aMenu balloonTextForLastItem:
'Open an inspector on this change set. (There are some details in a change set which you don''t see in a change sorter.)'.
aMenu add: 'update' action: #update.
aMenu balloonTextForLastItem:
'Update the display for this change set. (This is done automatically when you activate this window, so is seldom needed.)'.
aMenu add: 'go to change set''s project' action: #goToChangeSetsProject.
aMenu balloonTextForLastItem:
'If this change set is currently associated with a Project, go to that project right now.'.
aMenu add: 'promote to top of list' action: #promoteToTopChangeSet.
aMenu balloonTextForLastItem:
'Make this change set appear first in change-set lists in all change sorters.'.
aMenu add: 'trim history' action: #trimHistory.
aMenu balloonTextForLastItem:
' Drops any methods added and then removed, as well as renaming and reorganization of newly-added classes. NOTE: can cause confusion if later filed in over an earlier version of these changes'.
aMenu add: 'remove contained in class categories...' action: #removeContainedInClassCategories.
aMenu balloonTextForLastItem: ' Drops any changes in given class categories'.
aMenu add: 'clear this change set' action: #clearChangeSet.
aMenu balloonTextForLastItem:
'Reset this change set to a pristine state where it holds no information. CAUTION: this is destructive and irreversible!!'.
aMenu add: 'expunge uniclasses' action: #expungeUniclasses.
aMenu balloonTextForLastItem:
'Remove from the change set all memory of uniclasses, e.g. classes added on behalf of etoys, fabrik, etc., whose classnames end with a digit.'.
aMenu add: 'uninstall this change set' action: #uninstallChangeSet.
aMenu balloonTextForLastItem:
'Attempt to uninstall this change set. CAUTION: this may not work completely and is irreversible!!'.
aMenu addLine.
aMenu add: 'file into new...' action: #fileIntoNewChangeSet.
aMenu balloonTextForLastItem:
'Load a fileout from disk and place its changes into a new change set (seldom needed -- much better to do this from a file-list browser these days.)'.
aMenu add: 'reorder all change sets' action: #reorderChangeSets.
aMenu balloonTextForLastItem:
'Applies a standard reordering of all change-sets in the system -- at the bottom will come the sets that come with the release; next will come all the numbered updates; finally, at the top, will come all other change sets'.
aMenu addLine.
aMenu add: 'more...' action: #offerUnshiftedChangeSetMenu.
aMenu balloonTextForLastItem:
'Takes you back to the primary change-set menu.'.
^ aMenu!
----- Method: ChangeSorter>>shiftedMessageMenu: (in category 'message list') -----
shiftedMessageMenu: aMenu
"Arm the menu so that it holds items appropriate to the message-list while the shift key is down. Answer the menu."
^ aMenu addList: #(
-
('method pane' makeIsolatedCodePane)
('toggle diffing (D)' toggleDiffing)
('implementors of sent messages' browseAllMessages)
('change category...' changeCategory)
-
('sample instance' makeSampleInstance)
('inspect instances' inspectInstances)
('inspect subinstances' inspectSubInstances)
-
('change sets with this method' findMethodInChangeSets)
('revert to previous version' revertToPreviousVersion)
('revert & remove from changes' revertAndForget)
-
('more...' unshiftedYellowButtonActivity))!
----- Method: ChangeSorter>>showCategoriesOfChangeSet (in category 'changeSet menu') -----
showCategoriesOfChangeSet
"Show a list of all the categories in which the selected change-set occurs at the moment. Install the one the user chooses, if any."
| aMenu |
Smalltalk isMorphic
ifFalse:
[self inform:
'Only available in morphic, right now, sorry.
It would not take much to make this
also work in mvc, so if you are
inclined to do that, thanks in advance...']
ifTrue:
[aMenu := MenuMorph new defaultTarget: self.
aMenu title:
'Categories which
contain change set
"', myChangeSet name, '"'.
self changeSetCategories elementsInOrder do:
[:aCategory |
(aCategory includesChangeSet: myChangeSet)
ifTrue:
[aMenu add: aCategory categoryName target: self selector: #showChangeSetCategory: argument: aCategory.
aCategory == changeSetCategory ifTrue:
[aMenu lastItem color: Color red]].
aMenu balloonTextForLastItem: aCategory documentation].
aMenu popUpInWorld]!
----- Method: ChangeSorter>>showChangeSet: (in category 'access') -----
showChangeSet: chgSet
myChangeSet == chgSet ifFalse: [
myChangeSet := chgSet.
currentClassName := nil.
currentSelector := nil].
self changed: #relabel.
self changed: #currentCngSet. "new -- list of sets"
self changed: #mainButtonName. "old, button"
self changed: #classList.
self changed: #messageList.
self setContents.
self contentsChanged.!
----- Method: ChangeSorter>>showChangeSetCategory: (in category 'changeSet menu') -----
showChangeSetCategory: aChangeSetCategory
"Show the given change-set category"
changeSetCategory := aChangeSetCategory.
self changed: #changeSetList.
(self changeSetList includes: myChangeSet name) ifFalse:
[self showChangeSet: (ChangesOrganizer changeSetNamed: self changeSetList first)].
self changed: #relabel!
----- Method: ChangeSorter>>showChangeSetNamed: (in category 'access') -----
showChangeSetNamed: aName
self showChangeSet: (ChangesOrganizer changeSetNamed: aName) !
----- Method: ChangeSorter>>submergeIntoOtherSide (in category 'changeSet menu') -----
submergeIntoOtherSide
"Copy the contents of the receiver to the other side, then remove the receiver -- all after checking that all is well."
| other message nextToView i all |
self checkThatSidesDiffer: [^ self].
self okToChange ifFalse: [^ self].
other := (parent other: self) changeSet.
other == myChangeSet ifTrue: [^ self inform: 'Both sides are the same!!'].
myChangeSet isEmpty ifTrue: [^ self inform: 'Nothing to copy. To remove,
simply choose "remove".'].
myChangeSet okayToRemove ifFalse: [^ self].
message := 'Please confirm: copy all changes
in "', myChangeSet name, '" into "', other name, '"
and then destroy the change set
named "', myChangeSet name, '"?'.
(self confirm: message) ifFalse: [^ self].
(myChangeSet hasPreamble or: [myChangeSet hasPostscript]) ifTrue:
[(self confirm:
'Caution!! This change set has a preamble or
a postscript or both. If you submerge it into
the other side, these will be lost.
Do you really want to go ahead with this?') ifFalse: [^ self]].
other assimilateAllChangesFoundIn: myChangeSet.
all := ChangeSet allChangeSets.
nextToView := ((all includes: myChangeSet)
and: [(i := all indexOf: myChangeSet) < all size])
ifTrue: [all at: i+1]
ifFalse: [other].
self removePrompting: false.
self showChangeSet: nextToView.
parent modelWakeUp.
!
----- Method: ChangeSorter>>subtractOtherSide (in category 'changeSet menu') -----
subtractOtherSide
"Subtract the changes found on the other side from the requesting side."
self checkThatSidesDiffer: [^ self].
myChangeSet forgetAllChangesFoundIn: ((parent other: self) changeSet).
self showChangeSet: myChangeSet!
----- Method: ChangeSorter>>toggleDiffing (in category 'code pane') -----
toggleDiffing
"Toggle whether diffs should be shown in the code pane"
self okToChange ifTrue:
[super toggleDiffing.
self changed: #contents.
self update]
!
----- Method: ChangeSorter>>trimHistory (in category 'changeSet menu') -----
trimHistory
"Drop non-essential history (rename, reorg, method removals) from newly-added classes."
myChangeSet trimHistory
!
----- Method: ChangeSorter>>uninstallChangeSet (in category 'changeSet menu') -----
uninstallChangeSet
"Attempt to uninstall the current change set, after confirmation."
self okToChange ifFalse: [^ self].
(self confirm: 'Uninstalling a changeSet is unreliable at best.
It will only work if the changeSet consists only of single
changes, additions and removals of methods, and if
no subsequent changes have been to any of them.
No changes to classes will be undone.
The changeSet will be cleared after uninstallation.
Do you still wish to attempt to uninstall this changeSet?')
ifFalse: [^ self].
myChangeSet uninstall.
self changed: #relabel.
self changed: #classList.
self changed: #messageList.
self setContents.
self contentsChanged.
!
----- Method: ChangeSorter>>update (in category 'changeSet menu') -----
update
"recompute all of my panes"
self updateIfNecessary.
parent ifNotNil: [(parent other: self) updateIfNecessary]!
----- Method: ChangeSorter>>updateIfNecessary (in category 'changeSet menu') -----
updateIfNecessary
"Recompute all of my panes."
| newList |
self okToChange ifFalse: [^ self].
myChangeSet ifNil: [^ self]. "Has been known to happen though shouldn't"
(myChangeSet isMoribund or: [(changeSetCategory notNil and: [changeSetCategory includesChangeSet: myChangeSet]) not]) ifTrue:
[self changed: #changeSetList.
^ self showChangeSet: self changeSetCategory defaultChangeSetToShow].
newList := self changeSetList.
(priorChangeSetList == nil or: [priorChangeSetList ~= newList])
ifTrue:
[priorChangeSetList := newList.
self changed: #changeSetList].
self showChangeSet: myChangeSet!
----- Method: ChangeSorter>>veryDeepFixupWith: (in category 'creation') -----
veryDeepFixupWith: deepCopier
super veryDeepFixupWith: deepCopier.
parent := deepCopier references at: parent ifAbsent: [parent].
self updateIfNecessary!
----- Method: ChangeSorter>>veryDeepInner: (in category 'creation') -----
veryDeepInner: deepCopier
"Copy all of my instance variables. Some need to be not copied at all, but shared."
super veryDeepInner: deepCopier.
"parent := parent. Weakly copied"
"myChangeSet := myChangeSet. Weakly copied"
currentClassName := currentClassName veryDeepCopyWith: deepCopier.
"currentSelector := currentSelector. Symbol"
priorChangeSetList := priorChangeSetList veryDeepCopyWith: deepCopier.
changeSetCategory := changeSetCategory.
!
----- Method: ChangeSorter>>wantsOptionalButtons (in category 'code pane') -----
wantsOptionalButtons
"No optional buttons for ChangeSorter"
^false!
----- Method: ChangeSorter>>withoutItemAnnotation: (in category 'annotation') -----
withoutItemAnnotation: aStringOrNil
"return the current item without the package annotation we added on"
| endItemIndex |
aStringOrNil ifNil: [^nil] .
( endItemIndex := aStringOrNil findString: self beginNote) = 0
ifTrue: [^ aStringOrNil ] .
^ aStringOrNil first: endItemIndex - 1!
----- Method: CodeHolder>>abbreviatedWordingFor: (in category 'commands') -----
abbreviatedWordingFor: aButtonSelector
"Answer the abbreviated form of wording, from a static table which you're welcome to edit. Answer nil if there is no entry -- in which case the long firm will be used on the corresponding browser button."
#(
(browseMethodFull 'browse')
(browseSendersOfMessages 'senders')
(browseMessages 'impl')
(browseVersions 'vers')
(methodHierarchy 'inher')
(classHierarchy 'hier')
(browseInstVarRefs 'iVar')
(browseClassVarRefs 'cVar')
(offerMenu 'menu')) do:
[:pair | pair first == aButtonSelector ifTrue: [^ pair second]].
^ nil!
----- Method: CodeHolder>>aboutToStyle: (in category 'contents') -----
aboutToStyle: aStyler
"This is a notification that aStyler is about to re-style its text.
The default is to answer false to veto the styling"
^false!
----- Method: CodeHolder>>addModelItemsToWindowMenu: (in category 'tiles') -----
addModelItemsToWindowMenu: aMenu
"Add model-related item to the window menu"
super addModelItemsToWindowMenu: aMenu.
Smalltalk isMorphic ifTrue:
[aMenu addLine.
aMenu add: 'what to show...' translated target: self action: #offerWhatToShowMenu]!
----- Method: CodeHolder>>addOptionalAnnotationsTo:at:plus: (in category 'annotation') -----
addOptionalAnnotationsTo: window at: fractions plus: verticalOffset
"Add an annotation pane to the window if preferences indicate a desire for it, and return the incoming verticalOffset plus the height of the added pane, if any"
| aTextMorph divider delta |
self wantsAnnotationPane ifFalse: [^ verticalOffset].
aTextMorph := PluggableTextMorph
on: self
text: #annotation
accept: #annotation:
readSelection: nil
menu: #annotationPaneMenu:shifted:.
aTextMorph
askBeforeDiscardingEdits: true;
acceptOnCR: true;
borderWidth: 0;
hideScrollBarsIndefinitely.
divider := BorderedSubpaneDividerMorph forBottomEdge.
divider extent: 4 at 4; color: Color transparent; borderColor: #raised; borderWidth: 2.
delta := self defaultAnnotationPaneHeight.
window
addMorph: aTextMorph
fullFrame: (LayoutFrame
fractions: fractions
offsets: (0 at verticalOffset corner: 0@(verticalOffset + delta - 2))).
window
addMorph: divider
fullFrame: (LayoutFrame
fractions: fractions
offsets: (0@(verticalOffset + delta - 2) corner: 0@(verticalOffset + delta))).
^ verticalOffset + delta!
----- Method: CodeHolder>>addPriorVersionsCountForSelector:ofClass:to: (in category 'annotation') -----
addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream
"add an annotation detailing the prior versions count"
| versionsCount |
versionsCount := VersionsBrowser versionCountForSelector: aSelector class: aClass.
aStream nextPutAll:
((versionsCount > 1
ifTrue:
[versionsCount == 2 ifTrue:
['1 prior version']
ifFalse:
[versionsCount printString, ' prior versions']]
ifFalse:
['no prior versions']), self annotationSeparator)!
----- Method: CodeHolder>>adoptMessageInCurrentChangeset (in category 'commands') -----
adoptMessageInCurrentChangeset
"Add the receiver's method to the current change set if not already there"
self setClassAndSelectorIn: [:cl :sel |
cl ifNotNil:
[ChangeSet current adoptSelector: sel forClass: cl.
self changed: #annotation]]
!
----- Method: CodeHolder>>annotation (in category 'annotation') -----
annotation
"Provide a line of content for an annotation pane, representing information about the method associated with the selected class and selector in the receiver."
| aSelector aClass |
((aSelector := self selectedMessageName) == nil or: [(aClass := self selectedClassOrMetaClass) == nil]) ifTrue: [^ ''].
^ self annotationForSelector: aSelector ofClass: aClass!
----- Method: CodeHolder>>annotationForClassCommentFor: (in category 'annotation') -----
annotationForClassCommentFor: aClass
"Provide a line of content for an annotation pane, given that the receiver is pointing at the clas comment of the given class."
| aStamp nonMeta |
aStamp := (nonMeta := aClass theNonMetaClass) organization commentStamp.
^ aStamp
ifNil:
[nonMeta name, ' has no class comment']
ifNotNil:
['class comment for ', nonMeta name,
(aStamp = '<historical>'
ifFalse:
[' - ', aStamp]
ifTrue:
[''])]!
----- Method: CodeHolder>>annotationForClassDefinitionFor: (in category 'annotation') -----
annotationForClassDefinitionFor: aClass
"Provide a line of content for an annotation pane, given that the receiver is pointing at the class definition of the given class."
^ 'Class definition for ', aClass name!
----- Method: CodeHolder>>annotationForHierarchyFor: (in category 'annotation') -----
annotationForHierarchyFor: aClass
"Provide a line of content for an annotation pane, given that the receiver is pointing at the hierarchy of the given class."
^ 'Hierarchy for ', aClass name!
----- Method: CodeHolder>>annotationForSelector:ofClass: (in category 'annotation') -----
annotationForSelector: aSelector ofClass: aClass
"Provide a line of content for an annotation pane, representing
information about the given selector and class"
| stamp sendersCount implementorsCount aCategory separator aString aList aComment aStream requestList |
aSelector == #Comment
ifTrue: [^ self annotationForClassCommentFor: aClass].
aSelector == #Definition
ifTrue: [^ self annotationForClassDefinitionFor: aClass].
aSelector == #Hierarchy
ifTrue: [^ self annotationForHierarchyFor: aClass].
aStream := ReadWriteStream on: ''.
requestList := self annotationRequests.
separator := requestList size > 1
ifTrue: [self annotationSeparator]
ifFalse: [''].
requestList
do: [:aRequest |
aRequest == #firstComment
ifTrue: [aComment := aClass firstCommentAt: aSelector.
aComment isEmptyOrNil
ifFalse: [aStream nextPutAll: aComment , separator]].
aRequest == #masterComment
ifTrue: [aComment := aClass supermostPrecodeCommentFor: aSelector.
aComment isEmptyOrNil
ifFalse: [aStream nextPutAll: aComment , separator]].
aRequest == #documentation
ifTrue: [aComment := aClass precodeCommentOrInheritedCommentFor: aSelector.
aComment isEmptyOrNil
ifFalse: [aStream nextPutAll: aComment , separator]].
aRequest == #timeStamp
ifTrue: [stamp := self timeStamp.
aStream
nextPutAll: (stamp size > 0
ifTrue: [stamp , separator]
ifFalse: ['no timeStamp' , separator])].
aRequest == #messageCategory
ifTrue: [aCategory := aClass organization categoryOfElement: aSelector.
aCategory
ifNotNil: ["woud be nil for a method no longer present,
e.g. in a recent-submissions browser"
aStream nextPutAll: aCategory , separator]].
aRequest == #sendersCount
ifTrue: [sendersCount := (self systemNavigation allCallsOn: aSelector) size.
sendersCount := sendersCount == 1
ifTrue: ['1 sender']
ifFalse: [sendersCount printString , ' senders'].
aStream nextPutAll: sendersCount , separator].
aRequest == #implementorsCount
ifTrue: [implementorsCount := self systemNavigation numberOfImplementorsOf: aSelector.
implementorsCount := implementorsCount == 1
ifTrue: ['1 implementor']
ifFalse: [implementorsCount printString , ' implementors'].
aStream nextPutAll: implementorsCount , separator].
aRequest == #priorVersionsCount
ifTrue: [self
addPriorVersionsCountForSelector: aSelector
ofClass: aClass
to: aStream].
aRequest == #priorTimeStamp
ifTrue: [stamp := VersionsBrowser
timeStampFor: aSelector
class: aClass
reverseOrdinal: 2.
stamp
ifNotNil: [aStream nextPutAll: 'prior time stamp: ' , stamp , separator]].
aRequest == #recentChangeSet
ifTrue: [aString := ChangesOrganizer mostRecentChangeSetWithChangeForClass: aClass selector: aSelector.
aString size > 0
ifTrue: [aStream nextPutAll: aString , separator]].
aRequest == #allChangeSets
ifTrue: [aList := ChangesOrganizer allChangeSetsWithClass: aClass selector: aSelector.
aList size > 0
ifTrue: [aList size = 1
ifTrue: [aStream nextPutAll: 'only in change set ']
ifFalse: [aStream nextPutAll: 'in change sets: '].
aList
do: [:aChangeSet | aStream nextPutAll: aChangeSet name , ' ']]
ifFalse: [aStream nextPutAll: 'in no change set'].
aStream nextPutAll: separator]].
^ aStream contents!
----- Method: CodeHolder>>annotationPaneMenu:shifted: (in category 'annotation') -----
annotationPaneMenu: aMenu shifted: shifted
^ aMenu
labels: 'change pane size'
lines: #()
selections: #(toggleAnnotationPaneSize)!
----- Method: CodeHolder>>annotationRequests (in category 'annotation') -----
annotationRequests
^ Preferences defaultAnnotationRequests!
----- Method: CodeHolder>>annotationSeparator (in category 'annotation') -----
annotationSeparator
"Answer the separator to be used between annotations"
^ ' · '!
----- Method: CodeHolder>>browseImplementors (in category 'commands') -----
browseImplementors
"Create and schedule a message set browser on all implementors of the currently selected message selector. Do nothing if no message is selected."
| aMessageName |
(aMessageName := self selectedMessageName) ifNotNil:
[self systemNavigation browseAllImplementorsOf: aMessageName]!
----- Method: CodeHolder>>browseSenders (in category 'commands') -----
browseSenders
"Create and schedule a message set browser on all senders of the currently selected message selector. Of there is no message currently selected, offer a type-in"
self sendQuery: #browseAllCallsOn: to: self systemNavigation!
----- Method: CodeHolder>>buildClassBrowserEditString: (in category 'construction') -----
buildClassBrowserEditString: aString
"Create and schedule a new class browser for the current selection, with initial textual contents set to aString. This is used specifically in spawning where a class is established but a method-category is not."
| newBrowser |
newBrowser := Browser new.
newBrowser setClass: self selectedClassOrMetaClass selector: nil.
newBrowser editSelection: #newMessage.
Browser openBrowserView: (newBrowser openOnClassWithEditString: aString)
label: 'Class Browser: ', self selectedClassOrMetaClass name
!
----- Method: CodeHolder>>buildCodePaneWith: (in category 'toolbuilder') -----
buildCodePaneWith: builder
| textSpec top buttonSpec annoSpec |
self wantsOptionalButtons ifTrue:[
top := builder pluggablePanelSpec new.
top children: OrderedCollection new.
buttonSpec := self buildOptionalButtonsWith: builder.
buttonSpec frame: (0 at 0 corner: 1 at 0.11).
top children add: buttonSpec.
].
textSpec := builder pluggableCodePaneSpec new.
textSpec
model: self;
getText: #contents;
setText: #contents:notifying:;
selection: #contentsSelection;
menu: #codePaneMenu:shifted:.
self wantsAnnotationPane ifTrue:[
top ifNil:[
top := builder pluggablePanelSpec new.
top children: OrderedCollection new.
].
annoSpec := builder pluggableInputFieldSpec new.
annoSpec model: self; getText: #annotation.
annoSpec frame: (0 at 0.88 corner: 1 at 1).
top children add: annoSpec.
].
top ifNotNil:[
textSpec frame: (0 @ (buttonSpec ifNil:[0] ifNotNil:[0.12])
corner: 1 @ (annoSpec ifNil:[1] ifNotNil:[0.88])).
top children add: textSpec.
].
^top ifNil:[textSpec]!
----- Method: CodeHolder>>buildCodeProvenanceButtonWith: (in category 'toolbuilder') -----
buildCodeProvenanceButtonWith: builder
| buttonSpec |
buttonSpec := builder pluggableActionButtonSpec new.
buttonSpec model: self.
buttonSpec label: #codePaneProvenanceString.
buttonSpec action: #offerWhatToShowMenu.
buttonSpec help: 'Governs what view is shown in the code pane. Click here to change the view'.
^buttonSpec!
----- Method: CodeHolder>>buildMorphicCodePaneWith: (in category 'construction') -----
buildMorphicCodePaneWith: editString
"Construct the pane that shows the code.
Respect the Preference for standardCodeFont."
| codePane |
codePane := MorphicTextEditor default
on: self
text: #contents
accept: #contents:notifying:
readSelection: #contentsSelection
menu: #codePaneMenu:shifted:.
codePane font: Preferences standardCodeFont.
editString
ifNotNil: [codePane editString: editString.
codePane hasUnacceptedEdits: true].
^ codePane!
----- Method: CodeHolder>>buildOptionalButtonsWith: (in category 'toolbuilder') -----
buildOptionalButtonsWith: builder
| panelSpec buttonSpec |
panelSpec := builder pluggablePanelSpec new.
panelSpec children: OrderedCollection new.
self optionalButtonPairs do:[:spec|
buttonSpec := builder pluggableActionButtonSpec new.
buttonSpec model: self.
buttonSpec label: spec first.
buttonSpec action: spec second.
spec second == #methodHierarchy ifTrue:[
buttonSpec color: #inheritanceButtonColor.
].
spec size > 2 ifTrue:[buttonSpec help: spec third].
panelSpec children add: buttonSpec.
].
"What to show"
panelSpec children add: (self buildCodeProvenanceButtonWith: builder).
panelSpec layout: #horizontal. "buttons"
^panelSpec!
----- Method: CodeHolder>>canShowMultipleMessageCategories (in category 'message category functions') -----
canShowMultipleMessageCategories
"Answer whether the receiver is capable of showing multiple message categories"
^ false!
----- Method: CodeHolder>>categoryFromUserWithPrompt:for: (in category 'categories') -----
categoryFromUserWithPrompt: aPrompt for: aClass
"self new categoryFromUserWithPrompt: 'testing' for: SystemDictionary"
| labels myCategories reject lines cats newName menuIndex |
labels := OrderedCollection with: 'new...'.
labels addAll: (myCategories := aClass organization categories asSortedCollection:
[:a :b | a asLowercase < b asLowercase]).
reject := myCategories asSet.
reject
add: ClassOrganizer nullCategory;
add: ClassOrganizer default.
lines := OrderedCollection with: 1 with: (myCategories size + 1).
aClass allSuperclasses do:
[:cls |
cats := cls organization categories reject:
[:cat | reject includes: cat].
cats isEmpty ifFalse:
[lines add: labels size.
labels addAll: (cats asSortedCollection:
[:a :b | a asLowercase < b asLowercase]).
reject addAll: cats]].
newName := (labels size = 1 or:
[menuIndex := (UIManager default chooseFrom: labels lines: lines title: aPrompt).
menuIndex = 0 ifTrue: [^ nil].
menuIndex = 1])
ifTrue:
[UIManager default request: 'Please type new category name'
initialAnswer: 'category name']
ifFalse:
[labels at: menuIndex].
^ newName ifNotNil: [newName asSymbol]!
----- Method: CodeHolder>>categoryOfCurrentMethod (in category 'categories') -----
categoryOfCurrentMethod
"Answer the category that owns the current method. If unable to determine a category, answer nil."
| aClass aSelector |
^ (aClass := self selectedClassOrMetaClass)
ifNotNil: [(aSelector := self selectedMessageName)
ifNotNil: [aClass whichCategoryIncludesSelector: aSelector]]!
----- Method: CodeHolder>>changeCategory (in category 'categories') -----
changeCategory
"Present a menu of the categories of messages for the current class,
and let the user choose a new category for the current message"
| aClass aSelector |
(aClass := self selectedClassOrMetaClass) ifNotNil:
[(aSelector := self selectedMessageName) ifNotNil:
[(self letUserReclassify: aSelector in: aClass) ifTrue:
["ChangeSet current reorganizeClass: aClass."
"Decided on further review that the above, when present, could cause more
unexpected harm than good"
self methodCategoryChanged]]]!
----- Method: CodeHolder>>codePaneProvenanceButton (in category 'controls') -----
codePaneProvenanceButton
"Answer a button that reports on, and allow the user to modify,
the code-pane-provenance setting"
| aButton |
aButton := UpdatingSimpleButtonMorph newWithLabel: 'source'.
aButton setNameTo: 'codeProvenance'.
aButton useSquareCorners.
aButton target: self;
wordingSelector: #codePaneProvenanceString;
actionSelector: #offerWhatToShowMenu.
aButton setBalloonText: 'Governs what view is shown in the code pane. Click here to change the view'.
aButton actWhen: #buttonDown.
aButton color: Color white;
borderStyle: BorderStyle thinGray; vResizing: #spaceFill.
^ aButton!
----- Method: CodeHolder>>codePaneProvenanceString (in category 'controls') -----
codePaneProvenanceString
"Answer a string that reports on code-pane-provenance"
| symsAndWordings |
(symsAndWordings := self contentsSymbolQuints) do:
[:aQuad |
contentsSymbol == aQuad first ifTrue: [^ aQuad fourth]].
^ symsAndWordings first fourth "default to plain source, for example if nil as initially"!
----- Method: CodeHolder>>commentContents (in category 'contents') -----
commentContents
"documentation for the selected method"
| poss aClass aSelector |
^ (poss := (aClass := self selectedClassOrMetaClass)
ifNil:
['----']
ifNotNil:
[(aSelector := self selectedMessageName)
ifNil:
['---']
ifNotNil:
[(aClass precodeCommentOrInheritedCommentFor: aSelector)", String cr, String cr, self timeStamp"
"which however misses comments that are between the temps declaration and the body of the method; those are picked up by ·aClass commentOrInheritedCommentFor: aSelector· but that method will get false positives from comments *anywhere* in the method source"]])
isEmptyOrNil
ifTrue:
[aSelector
ifNotNil:
[((aClass methodHeaderFor: aSelector), '
Has no comment') asText makeSelectorBoldIn: aClass]
ifNil:
['Hamna']]
ifFalse: [aSelector
ifNotNil: [((aClass methodHeaderFor: aSelector), '
', poss) asText makeSelectorBoldIn: aClass]
ifNil: [poss]]!
----- Method: CodeHolder>>contents (in category 'contents') -----
contents
"Answer the source code or documentation for the selected method"
self showingByteCodes ifTrue:
[^ self selectedBytecodes].
self showingDocumentation ifTrue:
[^ self commentContents].
^ self selectedMessage!
----- Method: CodeHolder>>contentsChanged (in category 'contents') -----
contentsChanged
super contentsChanged.
self changed: #annotation!
----- Method: CodeHolder>>contentsSymbol (in category 'contents') -----
contentsSymbol
"Answer a symbol indicating what kind of content should be shown for the method; for normal showing of source code, this symbol is #source. A nil value in the contentsSymbol slot will be set to #source by this method"
^ contentsSymbol ifNil:
[contentsSymbol := Preferences browseWithPrettyPrint
ifTrue:
[#prettyPrint]
ifFalse:
[#source]]!
----- Method: CodeHolder>>contentsSymbol: (in category 'contents') -----
contentsSymbol: aSymbol
"Set the contentsSymbol as indicated. #source means to show source code, #comment means to show the first comment found in the source code"
contentsSymbol := aSymbol!
----- Method: CodeHolder>>contentsSymbolQuints (in category 'controls') -----
contentsSymbolQuints
"Answer a list of quintuplets representing information on the alternative views available in the code pane
first element: the contentsSymbol used
second element: the selector to call when this item is chosen.
third element: the selector to call to obtain the wording of the menu item.
fourth element: the wording to represent this view
fifth element: balloon help
A hypen indicates a need for a seperator line in a menu of such choices"
^ #(
(source togglePlainSource showingPlainSourceString 'source' 'the textual source code as written')
(documentation toggleShowDocumentation showingDocumentationString 'documentation' 'the first comment in the method')
-
(prettyPrint togglePrettyPrint prettyPrintString 'prettyPrint' 'the method source presented in a standard text format')
-
(showDiffs toggleRegularDiffing showingRegularDiffsString 'showDiffs' 'the textual source diffed from its prior version')
(prettyDiffs togglePrettyDiffing showingPrettyDiffsString 'prettyDiffs' 'formatted textual source diffed from formatted form of prior version')
-
(decompile toggleDecompile showingDecompileString 'decompile' 'source code decompiled from byteCodes')
(byteCodes toggleShowingByteCodes showingByteCodesString 'byteCodes' 'the bytecodes that comprise the compiled method')
-
(tiles toggleShowingTiles showingTilesString 'tiles' 'universal tiles representing the method'))!
----- Method: CodeHolder>>copyUpOrCopyDown (in category 'commands') -----
copyUpOrCopyDown
"Used to copy down code from a superclass to a subclass or vice-versa in one easy step, if you know what you're doing. Prompt the user for which class to copy down or copy up to, then spawn a fresh browser for that class, with the existing code planted in it, and with the existing method category also established."
| aClass aSelector allClasses implementors aMenu aColor |
Smalltalk isMorphic ifFalse: [^ self inform:
'Sorry, for the moment you have to be in
Morphic to use this feature.'].
((aClass := self selectedClassOrMetaClass) isNil or: [(aSelector := self selectedMessageName) == nil])
ifTrue: [^ Beeper beep].
allClasses := self systemNavigation hierarchyOfClassesSurrounding: aClass.
implementors := self systemNavigation hierarchyOfImplementorsOf: aSelector forClass: aClass.
aMenu := MenuMorph new defaultTarget: self.
aMenu title:
aClass name, '.', aSelector, '
Choose where to insert a copy of this method
(blue = current, black = available, red = other implementors'.
allClasses do:
[:cl |
aColor := cl == aClass
ifTrue: [#blue]
ifFalse:
[(implementors includes: cl)
ifTrue: [#red]
ifFalse: [#black]].
(aColor == #red)
ifFalse:
[aMenu add: cl name selector: #spawnToClass: argument: cl]
ifTrue:
[aMenu add: cl name selector: #spawnToCollidingClass: argument: cl].
aMenu lastItem color: (Color colorFrom: aColor)].
aMenu popUpInWorld!
----- Method: CodeHolder>>decompiledSourceIntoContents (in category 'message list') -----
decompiledSourceIntoContents
"Obtain a source string by decompiling the method's code, and place
that source string into my contents. Also return the string.
Get temps from source file if shift key is pressed."
| class |
class := self selectedClassOrMetaClass.
"Was method deleted while in another project?"
currentCompiledMethod := (class compiledMethodAt: self selectedMessageName ifAbsent: [^ '']).
contents := (Sensor leftShiftDown not)
ifTrue: [currentCompiledMethod decompileWithTemps]
ifFalse: [currentCompiledMethod decompile].
contents := contents decompileString asText makeSelectorBoldIn: class.
^ contents copy!
----- Method: CodeHolder>>decorateButtons (in category 'controls') -----
decorateButtons
"Change screen feedback for any buttons in the UI of the receiver that may wish it. Initially, it is only the Inheritance button that is decorated, but one can imagine others."
self changed: #inheritanceButtonColor.!
----- Method: CodeHolder>>defaultAnnotationPaneHeight (in category 'annotation') -----
defaultAnnotationPaneHeight
"Answer the receiver's preferred default height for new annotation panes."
^ Preferences parameterAt: #defaultAnnotationPaneHeight ifAbsentPut: [25]!
----- Method: CodeHolder>>defaultButtonPaneHeight (in category 'annotation') -----
defaultButtonPaneHeight
"Answer the user's preferred default height for new button panes."
^ Preferences parameterAt: #defaultButtonPaneHeight ifAbsentPut: [25]!
----- Method: CodeHolder>>defaultDiffsSymbol (in category 'diffs') -----
defaultDiffsSymbol
"Answer the code symbol to use when generically switching to diffing"
^ Preferences diffsWithPrettyPrint
ifTrue:
[#prettyDiffs]
ifFalse:
[#showDiffs]!
----- Method: CodeHolder>>didCodeChangeElsewhere (in category 'self-updating') -----
didCodeChangeElsewhere
"Determine whether the code for the currently selected method and class has been changed somewhere else."
| aClass aSelector aCompiledMethod |
currentCompiledMethod ifNil: [^ false].
(aClass := self selectedClassOrMetaClass) ifNil: [^ false].
(aSelector := self selectedMessageName) ifNil: [^ false].
self classCommentIndicated
ifTrue: [^ currentCompiledMethod ~~ aClass organization commentRemoteStr].
^ (aCompiledMethod := aClass compiledMethodAt: aSelector ifAbsent: [^ false]) ~~ currentCompiledMethod
and: [aCompiledMethod last ~= 0 "either not yet installed"
or: [ currentCompiledMethod last = 0 "or these methods don't have source pointers"]]!
----- Method: CodeHolder>>diffButton (in category 'diffs') -----
diffButton
"Return a checkbox that lets the user decide whether diffs should be shown or not. Not sent any more but retained against the possibility of existing subclasses outside the base image using it."
| outerButton aButton |
outerButton := AlignmentMorph newRow.
outerButton wrapCentering: #center; cellPositioning: #leftCenter.
outerButton color: Color transparent.
outerButton hResizing: #shrinkWrap; vResizing: #shrinkWrap.
outerButton addMorph: (aButton := UpdatingThreePhaseButtonMorph checkBox).
aButton
target: self;
actionSelector: #toggleRegularDiffing;
getSelector: #showingRegularDiffs.
outerButton addMorphBack: (StringMorph contents: 'diffs') lock.
outerButton setBalloonText: 'If checked, then code differences from the previous version, if any, will be shown.'.
^ outerButton
!
----- Method: CodeHolder>>diffFromPriorSourceFor: (in category 'diffs') -----
diffFromPriorSourceFor: sourceCode
"If there is a prior version of source for the selected method, return a diff, else just return the source code"
| prior |
^ (prior := self priorSourceOrNil)
ifNil: [sourceCode]
ifNotNil: [TextDiffBuilder buildDisplayPatchFrom: prior to: sourceCode inClass: self selectedClass prettyDiffs: self showingPrettyDiffs]!
----- Method: CodeHolder>>getSelectorAndSendQuery:to: (in category 'misc') -----
getSelectorAndSendQuery: querySelector to: queryPerformer
"Obtain a selector relevant to the current context, and then send the querySelector to the queryPerformer with the selector obtained as its argument. If no message is currently selected, then obtain a method name from a user type-in"
self getSelectorAndSendQuery: querySelector to: queryPerformer with: { }.
!
----- Method: CodeHolder>>getSelectorAndSendQuery:to:with: (in category 'misc') -----
getSelectorAndSendQuery: querySelector to: queryPerformer with: queryArgs
"Obtain a selector relevant to the current context, and then send the querySelector to the queryPerformer with the selector obtained and queryArgs as its arguments. If no message is currently selected, then obtain a method name from a user type-in"
| strm array |
strm := WriteStream on: (array := Array new: queryArgs size + 1).
strm nextPut: nil.
strm nextPutAll: queryArgs.
self selectedMessageName ifNil: [ | selector |
selector := UIManager default request: 'Type selector:' initialAnswer: 'flag:'.
selector := selector copyWithout: Character space.
^ selector isEmptyOrNil ifFalse: [
(Symbol hasInterned: selector
ifTrue: [ :aSymbol |
array at: 1 put: aSymbol.
queryPerformer perform: querySelector withArguments: array])
ifFalse: [ self inform: 'no such selector']
]
].
self selectMessageAndEvaluate: [:selector |
array at: 1 put: selector.
queryPerformer perform: querySelector withArguments: array
]!
----- Method: CodeHolder>>inheritanceButtonColor (in category 'toolbuilder') -----
inheritanceButtonColor
"Check to see if the currently-viewed method has a super send or an override, and if so, change screen feedback, unless the #decorateBrowserButtons says not to."
| flags aColor |
((currentCompiledMethod isKindOf: CompiledMethod) and: [Preferences decorateBrowserButtons])
ifFalse: [^Color transparent].
"This table duplicates the old logic, but adds two new colors for the cases where there is a superclass definition, but this method doesn't call it."
flags := 0.
self isThisAnOverride ifTrue: [ flags := flags bitOr: 4 ].
currentCompiledMethod sendsToSuper ifTrue: [ flags := flags bitOr: 2 ].
self isThereAnOverride ifTrue: [ flags := flags bitOr: 1 ].
aColor := {
Color transparent.
Color tan lighter.
Color green muchLighter.
Color blue muchLighter.
Color red muchLighter. "has super but doesn't call it"
(Color r: 0.94 g: 0.823 b: 0.673). "has sub; has super but doesn't call it"
Color green muchLighter.
Color blue muchLighter.
} at: flags + 1.
^aColor!
----- Method: CodeHolder>>installTextualCodingPane (in category 'tiles') -----
installTextualCodingPane
"Install text into the code pane"
| aWindow codePane aPane boundsToUse |
(aWindow := self containingWindow) ifNil: [self error: 'where''s that window?'].
codePane := aWindow findDeepSubmorphThat:
[:m | ((m isKindOf: PluggableTextMorph) and: [m getTextSelector == #contents]) or:
[m isKindOf: PluggableTileScriptorMorph]] ifAbsent: [self error: 'no code pane'].
aPane := self buildMorphicCodePaneWith: nil.
boundsToUse := (codePane bounds origin- (1 at 1)) corner: (codePane owner bounds corner " (1 at 1").
aWindow replacePane: codePane with: aPane.
aPane vResizing: #spaceFill; hResizing: #spaceFill; borderWidth: 0.
aPane bounds: boundsToUse.
aPane owner clipSubmorphs: false.
self contentsChanged!
----- Method: CodeHolder>>isModeStyleable (in category 'contents') -----
isModeStyleable
"determine the current mode can be styled"
^ self showingSource or: [self showingPrettyPrint]!
----- Method: CodeHolder>>isThereAnOverride (in category 'misc') -----
isThereAnOverride
"Answer whether any subclass of my selected class implements my
selected selector"
| aName aClass |
aName := self selectedMessageName ifNil: [^ false].
aClass := self selectedClassOrMetaClass ifNil: [^ false].
aClass allSubclassesDo: [ :cls | (cls includesSelector: aName) ifTrue: [ ^true ]].
^ false!
----- Method: CodeHolder>>isThisAnOverride (in category 'misc') -----
isThisAnOverride
"Answer whether any superclass of my selected class implements my selected selector"
| aName aClass |
aName := self selectedMessageName ifNil: [^ false].
aClass := self selectedClassOrMetaClass ifNil: [^ false].
aClass allSuperclassesDo: [ :cls | (cls includesSelector: aName) ifTrue: [ ^true ]].
^ false!
----- Method: CodeHolder>>letUserReclassify:in: (in category 'categories') -----
letUserReclassify: anElement in: aClass
"Put up a list of categories and solicit one from the user.
Answer true if user indeed made a change, else false"
| currentCat newCat |
currentCat := aClass organization categoryOfElement: anElement.
newCat := self
categoryFromUserWithPrompt: 'choose category (currently "', currentCat, '")'
for: aClass.
(newCat ~~ nil and: [newCat ~= currentCat])
ifTrue:
[aClass organization classify: anElement under: newCat suppressIfDefault: false.
^ true]
ifFalse:
[^ false]!
----- Method: CodeHolder>>listPaneWithSelector: (in category 'categories & search pane') -----
listPaneWithSelector: aSelector
"If, among my window's paneMorphs, there is a list pane defined with aSelector as its retriever, answer it, else answer nil"
| aWindow |
^ (aWindow := self containingWindow) ifNotNil:
[aWindow paneMorphSatisfying:
[:aMorph | (aMorph isKindOf: PluggableListMorph) and:
[aMorph getListSelector == aSelector]]]!
----- Method: CodeHolder>>makeSampleInstance (in category 'traits') -----
makeSampleInstance
| aClass nonMetaClass anInstance |
((aClass := self selectedClassOrMetaClass) isNil or: [aClass isTrait]) ifTrue: [^ self].
nonMetaClass := aClass theNonMetaClass.
anInstance := self sampleInstanceOfSelectedClass.
(anInstance isNil and: [nonMetaClass ~~ UndefinedObject]) ifTrue:
[^ self inform: 'Sorry, cannot make an instance of ', nonMetaClass name].
(Smalltalk isMorphic and: [anInstance isMorph])
ifTrue:
[self currentHand attachMorph: anInstance]
ifFalse:
[anInstance inspectWithLabel: 'An instance of ', nonMetaClass name]!
----- Method: CodeHolder>>menuButton (in category 'misc') -----
menuButton
"Answer a button that brings up a menu. Useful when adding new features, but at present is between uses"
| aButton |
aButton := IconicButton new target: self;
borderWidth: 0;
labelGraphic: (ScriptingSystem formAtKey: #TinyMenu);
color: Color transparent;
actWhen: #buttonDown;
actionSelector: #offerMenu;
yourself.
aButton setBalloonText: 'click here to get a menu with further options'.
^ aButton
!
----- Method: CodeHolder>>messageListKey:from: (in category 'message list menu') -----
messageListKey: aChar from: view
"Respond to a Command key. I am a model with a code pane, and I also
have a listView that has a list of methods. The view knows how to get
the list and selection."
| sel class |
aChar == $D ifTrue: [^ self toggleDiffing].
sel := self selectedMessageName.
aChar == $m ifTrue: "These next two put up a type in if no message selected"
[^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllImplementorsOf: to: self systemNavigation].
aChar == $n ifTrue:
[^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllCallsOn: to: self systemNavigation].
"The following require a class selection"
(class := self selectedClassOrMetaClass) ifNil: [^ self arrowKey: aChar from: view].
aChar == $b ifTrue: [^ Browser fullOnClass: class selector: sel].
aChar == $N ifTrue: [^ self browseClassRefs].
aChar == $i ifTrue: [^ self methodHierarchy].
aChar == $h ifTrue: [^ self classHierarchy].
aChar == $p ifTrue: [^ self browseFullProtocol].
"The following require a method selection"
sel ifNotNil:
[aChar == $o ifTrue: [^ self fileOutMessage].
aChar == $c ifTrue: [^ self copySelector].
aChar == $v ifTrue: [^ self browseVersions].
aChar == $O ifTrue: [^ self openSingleMessageBrowser].
aChar == $x ifTrue: [^ self removeMessage].
aChar == $d ifTrue: [^ self removeMessageFromBrowser].
(aChar == $C and: [self canShowMultipleMessageCategories])
ifTrue: [^ self showHomeCategory]].
^ self arrowKey: aChar from: view!
----- Method: CodeHolder>>methodCategoryChanged (in category 'categories') -----
methodCategoryChanged
self changed: #annotation!
----- Method: CodeHolder>>modelWakeUpIn: (in category 'misc') -----
modelWakeUpIn: aWindow
"The window has been activated. Respond to possible changes that may have taken place while it was inactive"
self updateListsAndCodeIn: aWindow.
self decorateButtons.
self refreshAnnotation.
super modelWakeUpIn: aWindow!
----- Method: CodeHolder>>newSearchPane (in category 'categories & search pane') -----
newSearchPane
"Answer a new search pane for the receiver"
| aTextMorph |
aTextMorph := PluggableTextMorph on: self
text: #lastSearchString accept: #lastSearchString:
readSelection: nil menu: nil.
aTextMorph setProperty: #alwaysAccept toValue: true.
aTextMorph askBeforeDiscardingEdits: false.
aTextMorph acceptOnCR: true.
aTextMorph setBalloonText: 'Type here and hit ENTER, and all methods whose selectors match what you typed will appear in the list pane below.'.
^ aTextMorph!
----- Method: CodeHolder>>offerMenu (in category 'commands') -----
offerMenu
"Offer a menu to the user from the bar of tool buttons"
self offerDurableMenuFrom: #messageListMenu:shifted: shifted: false!
----- Method: CodeHolder>>offerShiftedClassListMenu (in category 'commands') -----
offerShiftedClassListMenu
"Offer the shifted class-list menu."
^ self offerMenuFrom: #classListMenu:shifted: shifted: true!
----- Method: CodeHolder>>offerUnshiftedClassListMenu (in category 'commands') -----
offerUnshiftedClassListMenu
"Offer the shifted class-list menu."
^ self offerMenuFrom: #classListMenu:shifted: shifted: false!
----- Method: CodeHolder>>offerWhatToShowMenu (in category 'what to show') -----
offerWhatToShowMenu
"Offer a menu governing what to show"
| builder menuSpec item |
builder := ToolBuilder default.
menuSpec := builder pluggableMenuSpec new.
self contentsSymbolQuints do: [:aQuint | aQuint == #-
ifTrue: [menuSpec addSeparator]
ifFalse: [
item := menuSpec add: (self perform: aQuint third)
target: self selector: aQuint second argumentList: #().
item help: aQuint fifth.
].
].
builder runModal: (builder open: menuSpec).!
----- Method: CodeHolder>>okayToAccept (in category 'misc') -----
okayToAccept
"Answer whether it is okay to accept the receiver's input"
self showingDocumentation ifTrue:
[self inform:
'Sorry, for the moment you can
only submit changes here when
you are showing source. Later, you
will be able to edit the isolated comment
here and save it back, but only if YOU
implement it!!.'.
^ false].
self showingAnyKindOfDiffs ifFalse:
[^ true].
^ (UIManager default chooseFrom: {
'accept anyway -- I''ll take my chances'.
'um, let me reconsider'.
} title:
'Caution!! You are "showing diffs" here, so
there is a danger that some of the text in the
code pane is contaminated by the "diff" display') = 1!
----- Method: CodeHolder>>optionalButtonPairs (in category 'controls') -----
optionalButtonPairs
"Answer a tuple (formerly pairs) defining buttons, in the format:
button label
selector to send
help message"
| aList |
aList := #(
('browse' browseMethodFull 'view this method in a browser')
('senders' browseSendersOfMessages 'browse senders of...')
('implementors' browseMessages 'browse implementors of...')
('versions' browseVersions 'browse versions')),
(Preferences decorateBrowserButtons
ifTrue:
[{#('inheritance' methodHierarchy 'browse method inheritance
green: sends to super
tan: has override(s)
mauve: both of the above
pink: is an override but doesn''t call super
pinkish tan: has override(s), also is an override but doesn''t call super' )}]
ifFalse:
[{#('inheritance' methodHierarchy 'browse method inheritance')}]),
#(
('hierarchy' classHierarchy 'browse class hierarchy')
('inst vars' browseInstVarRefs 'inst var refs...')
('class vars' browseClassVarRefs 'class var refs...')).
^ aList!
----- Method: CodeHolder>>prettyDiffButton (in category 'diffs') -----
prettyDiffButton
"Return a checkbox that lets the user decide whether prettyDiffs should be shown or not"
| outerButton aButton |
outerButton := AlignmentMorph newRow.
outerButton wrapCentering: #center; cellPositioning: #leftCenter.
outerButton color: Color transparent.
outerButton hResizing: #shrinkWrap; vResizing: #shrinkWrap.
outerButton addMorph: (aButton := UpdatingThreePhaseButtonMorph checkBox).
aButton
target: self;
actionSelector: #togglePrettyDiffing;
getSelector: #showingPrettyDiffs.
outerButton addMorphBack: (StringMorph contents: 'prettyDiffs') lock.
(self isKindOf: VersionsBrowser)
ifTrue:
[outerButton setBalloonText: 'If checked, then pretty-printed code differences from the previous version, if any, will be shown.']
ifFalse:
[outerButton setBalloonText: 'If checked, then pretty-printed code differences between the file-based method and the in-memory version, if any, will be shown.'].
^ outerButton
!
----- Method: CodeHolder>>prettyPrintString (in category 'what to show') -----
prettyPrintString
"Answer whether the receiver is showing pretty-print"
^ ((contentsSymbol == #prettyPrint)
ifTrue:
['<yes>']
ifFalse:
['<no>']), 'prettyPrint'!
----- Method: CodeHolder>>priorSourceOrNil (in category 'misc') -----
priorSourceOrNil
"If the currently-selected method has a previous version, return its source, else return nil"
| aClass aSelector changeRecords |
(aClass := self selectedClassOrMetaClass) ifNil: [^ nil].
(aSelector := self selectedMessageName) ifNil: [^ nil].
changeRecords := aClass changeRecordsAt: aSelector.
(changeRecords == nil or: [changeRecords size <= 1]) ifTrue: [^ nil].
^ (changeRecords at: 2) string
!
----- Method: CodeHolder>>refreshAnnotation (in category 'misc') -----
refreshAnnotation
"If the receiver has an annotation pane that does not bear unaccepted edits, refresh it"
(self dependents detect: [:m | (m inheritsFromAnyIn: #('PluggableTextView' 'PluggableTextMorph')) and: [m getTextSelector == #annotation]] ifNone: [nil]) ifNotNilDo:
[:aPane | aPane hasUnacceptedEdits ifFalse:
[aPane update: #annotation]]!
----- Method: CodeHolder>>refusesToAcceptCode (in category 'misc') -----
refusesToAcceptCode
"Answer whether receiver, given its current contentsSymbol, could accept code happily if asked to"
^ (#(byteCodes documentation tiles) includes: self contentsSymbol)!
----- Method: CodeHolder>>regularDiffButton (in category 'diffs') -----
regularDiffButton
"Return a checkbox that lets the user decide whether regular diffs should be shown or not"
| outerButton aButton |
outerButton := AlignmentMorph newRow.
outerButton wrapCentering: #center; cellPositioning: #leftCenter.
outerButton color: Color transparent.
outerButton hResizing: #shrinkWrap; vResizing: #shrinkWrap.
outerButton addMorph: (aButton := UpdatingThreePhaseButtonMorph checkBox).
aButton
target: self;
actionSelector: #toggleRegularDiffing;
getSelector: #showingRegularDiffs.
outerButton addMorphBack: (StringMorph contents: 'diffs') lock.
outerButton setBalloonText: 'If checked, then code differences from the previous version, if any, will be shown.'.
^ outerButton
!
----- Method: CodeHolder>>releaseCachedState (in category 'misc') -----
releaseCachedState
"Can always be found again. Don't write on a file."
currentCompiledMethod := nil.!
----- Method: CodeHolder>>removeClass (in category 'commands') -----
removeClass
"Remove the selected class from the system, at interactive user request. Make certain the user really wants to do this, since it is not reversible. Answer true if removal actually happened."
| message className classToRemove result |
self okToChange ifFalse: [^ false].
classToRemove := self selectedClassOrMetaClass ifNil: [Beeper beep. ^ false].
classToRemove := classToRemove theNonMetaClass.
className := classToRemove name.
message := 'Are you certain that you
want to REMOVE the class ', className, '
from the system?'.
(result := self confirm: message)
ifTrue:
[classToRemove subclasses size > 0
ifTrue: [(self confirm: 'class has subclasses: ' , message)
ifFalse: [^ false]].
classToRemove removeFromSystem.
self changed: #classList.
true].
^ result!
----- Method: CodeHolder>>restoreTextualCodingPane (in category 'diffs') -----
restoreTextualCodingPane
"If the receiver is showing tiles, restore the textual coding pane"
self showingTiles ifTrue:
[contentsSymbol := #source.
self installTextualCodingPane]!
----- Method: CodeHolder>>sampleInstanceOfSelectedClass (in category 'misc') -----
sampleInstanceOfSelectedClass
| aClass |
"Return a sample instance of the class currently being pointed at"
(aClass := self selectedClassOrMetaClass) ifNil: [^ nil].
^ aClass theNonMetaClass initializedInstance!
----- Method: CodeHolder>>searchPane (in category 'categories & search pane') -----
searchPane
"Answer the search pane associated with the receiver in its window, or nil if none. Morphic only"
^ self textPaneWithSelector: #lastSearchString!
----- Method: CodeHolder>>selectedBytecodes (in category 'message list') -----
selectedBytecodes
"Answer text to show in a code pane when in showing-byte-codes mode"
^ (self selectedClassOrMetaClass compiledMethodAt: self selectedMessageName ifAbsent: [^ '' asText]) symbolic asText!
----- Method: CodeHolder>>selectedMessage (in category 'message list') -----
selectedMessage
"Answer a copy of the source code for the selected message. This generic version is probably actually never reached, since every subclass probably reimplements and does not send to super. In time, ideally, most, or all, reimplementors would vanish and all would defer instead to a universal version right here. Everything in good time."
| class selector method |
contents ifNotNil: [^ contents copy].
self showingDecompile ifTrue:[^ self decompiledSourceIntoContents].
class := self selectedClassOrMetaClass.
(class isNil or: [(selector := self selectedMessageName) isNil]) ifTrue: [^ ''].
method := class compiledMethodAt: selector ifAbsent: [^ '']. "method deleted while in another project"
currentCompiledMethod := method.
^ contents := (self showComment
ifFalse: [self sourceStringPrettifiedAndDiffed]
ifTrue: [ self commentContents])
copy asText makeSelectorBoldIn: class!
----- Method: CodeHolder>>selectedMessageCategoryName (in category 'categories') -----
selectedMessageCategoryName
"Answer the name of the message category of the message of the currently selected context."
^ self selectedClass organization categoryOfElement: self selectedMessageName!
----- Method: CodeHolder>>sendQuery:to: (in category 'misc') -----
sendQuery: querySelector to: queryPerformer
"Apply a query to the primary selector associated with the current context. If no such selection exists, obtain one by user type-in. Then send querySelector to queryPerformer with the selector as its argument."
| aSelector aString |
aSelector := self selectedMessageName ifNil:
[aString :=UIManager default request: 'Type selector:' initialAnswer: 'flag:'.
^ aString isEmptyOrNil ifFalse:
[(Symbol hasInterned: aString ifTrue:
[:aSymbol | queryPerformer perform: querySelector with: aSymbol])
ifFalse:
[self inform: 'no such selector']]].
queryPerformer perform: querySelector with: aSelector!
----- Method: CodeHolder>>setClassAndSelectorIn: (in category 'misc') -----
setClassAndSelectorIn: csBlock
"Evaluate csBlock with my selected class and and selector as its arguments; provide nil arguments if I don't have a method currently selected"
| aName |
(aName := self selectedMessageName)
ifNil:
[csBlock value: nil value: nil]
ifNotNil:
[csBlock value: self selectedClassOrMetaClass value: aName]
!
----- Method: CodeHolder>>setContentsToForceRefetch (in category 'what to show') -----
setContentsToForceRefetch
"Set the receiver's contents such that on the next update the contents will be formulated afresh. This is a critical and obscure difference between Browsers on the one hand and MessageSets on the other, and has over the years been the source of much confusion and much difficulty. By centralizing the different handling here, we don't need so many idiosyncratic overrides in MessageSet any more"
contents := nil!
----- Method: CodeHolder>>shiftedYellowButtonActivity (in category 'commands') -----
shiftedYellowButtonActivity
"Offer the shifted selector-list menu"
^ self offerMenuFrom: #messageListMenu:shifted: shifted: true!
----- Method: CodeHolder>>showByteCodes: (in category 'what to show') -----
showByteCodes: aBoolean
"Get into or out of bytecode-showoing mode"
self okToChange ifFalse: [^ self changed: #flash].
aBoolean
ifTrue:
[contentsSymbol := #byteCodes]
ifFalse:
[contentsSymbol == #byteCodes ifTrue: [contentsSymbol := #source]].
self contentsChanged!
----- Method: CodeHolder>>showComment (in category 'what to show') -----
showComment
"Answer whether the receiver should show documentation rather than, say, source code"
^ self contentsSymbol == #documentation
!
----- Method: CodeHolder>>showDecompile: (in category 'what to show') -----
showDecompile: aBoolean
"Set the decompile toggle as indicated"
self contentsSymbol: (aBoolean ifFalse: [#source] ifTrue: [#decompile])!
----- Method: CodeHolder>>showDiffs (in category 'diffs') -----
showDiffs
"Answer whether the receiver is showing diffs of source code. The preferred protocol here is #showingRegularDiffs, but this message is still sent by some preexisting buttons so is retained."
^ contentsSymbol == #showDiffs
!
----- Method: CodeHolder>>showDiffs: (in category 'diffs') -----
showDiffs: aBoolean
"Set whether I'm showing diffs as indicated; use the global preference to determine which kind of diffs to institute."
self showingAnyKindOfDiffs
ifFalse:
[aBoolean ifTrue:
[contentsSymbol := self defaultDiffsSymbol]]
ifTrue:
[aBoolean ifFalse:
[contentsSymbol := #source]].
self setContentsToForceRefetch.
self contentsChanged!
----- Method: CodeHolder>>showDocumentation: (in category 'what to show') -----
showDocumentation: aBoolean
"Set the showDocumentation toggle as indicated"
self contentsSymbol: (aBoolean ifFalse: [#source] ifTrue: [#documentation])!
----- Method: CodeHolder>>showPrettyDiffs: (in category 'diffs') -----
showPrettyDiffs: aBoolean
"Set whether I'm showing pretty diffs as indicated"
self showingPrettyDiffs
ifFalse:
[aBoolean ifTrue:
[contentsSymbol := #prettyDiffs]]
ifTrue:
[aBoolean ifFalse:
[contentsSymbol := #source]].
self setContentsToForceRefetch.
self contentsChanged!
----- Method: CodeHolder>>showRegularDiffs: (in category 'diffs') -----
showRegularDiffs: aBoolean
"Set whether I'm showing regular diffs as indicated"
self showingRegularDiffs
ifFalse:
[aBoolean ifTrue:
[contentsSymbol := #showDiffs]]
ifTrue:
[aBoolean ifFalse:
[contentsSymbol := #source]].
self setContentsToForceRefetch.
self contentsChanged!
----- Method: CodeHolder>>showUnreferencedClassVars (in category 'traits') -----
showUnreferencedClassVars
"Search for all class variables known to the selected class, and put up a
list of those that have no references anywhere in the system. The
search includes superclasses, so that you don't need to navigate your
way to the class that defines each class variable in order to determine
whether it is unreferenced"
| cls aList aReport |
((cls := self selectedClass) isNil or: [cls isTrait]) ifTrue: [^ self].
aList := self systemNavigation allUnreferencedClassVariablesOf: cls.
aList size == 0
ifTrue: [^ self inform: 'There are no unreferenced
class variables in
' , cls name].
aReport := String
streamContents: [:aStream |
aStream nextPutAll: 'Unreferenced class variable(s) in ' , cls name;
cr.
aList
do: [:el | aStream tab; nextPutAll: el; cr]].
Transcript cr; show: aReport.
UIManager default chooseFrom: aList values: aList
title: 'Unreferenced
class variables in
' , cls name!
----- Method: CodeHolder>>showUnreferencedInstVars (in category 'traits') -----
showUnreferencedInstVars
"Search for all instance variables known to the selected class, and put up a list of those that have no references anywhere in the system. The search includes superclasses, so that you don't need to navigate your way to the class that defines each inst variable in order to determine whether it is unreferenced"
| cls aList aReport |
((cls := self selectedClassOrMetaClass) isNil or: [cls isTrait]) ifTrue: [^ self].
aList := cls allUnreferencedInstanceVariables.
aList size == 0 ifTrue: [^ self inform: 'There are no unreferenced
instance variables in
', cls name].
aReport := String streamContents:
[:aStream |
aStream nextPutAll: 'Unreferenced instance variable(s) in ', cls name; cr.
aList do: [:el | aStream tab; nextPutAll: el; cr]].
Transcript cr; show: aReport.
UIManager default chooseFrom: aList values: aList title: 'Unreferenced
instance variables in
', cls name!
----- Method: CodeHolder>>showingAnyKindOfDiffs (in category 'diffs') -----
showingAnyKindOfDiffs
"Answer whether the receiver is currently set to show any kind of diffs"
^ #(showDiffs prettyDiffs) includes: contentsSymbol!
----- Method: CodeHolder>>showingByteCodes (in category 'what to show') -----
showingByteCodes
"Answer whether the receiver is showing bytecodes"
^ contentsSymbol == #byteCodes!
----- Method: CodeHolder>>showingByteCodesString (in category 'what to show') -----
showingByteCodesString
"Answer whether the receiver is showing bytecodes"
^ (self showingByteCodes
ifTrue:
['<yes>']
ifFalse:
['<no>']), 'byteCodes'!
----- Method: CodeHolder>>showingDecompile (in category 'what to show') -----
showingDecompile
"Answer whether the receiver should show decompile rather than, say, source code"
^ self contentsSymbol == #decompile
!
----- Method: CodeHolder>>showingDecompileString (in category 'what to show') -----
showingDecompileString
"Answer a string characerizing whether decompilation is showing"
^ (self showingDecompile
ifTrue:
['<yes>']
ifFalse:
['<no>']), 'decompile'!
----- Method: CodeHolder>>showingDiffsString (in category 'diffs') -----
showingDiffsString
"Answer a string representing whether I'm showing diffs. Not sent any more but retained so that prexisting buttons that sent this will not raise errors."
^ (self showingRegularDiffs
ifTrue:
['<yes>']
ifFalse:
['<no>']), 'showDiffs'!
----- Method: CodeHolder>>showingDocumentation (in category 'what to show') -----
showingDocumentation
"Answer whether the receiver should show documentation rather than, say, source code"
^ self contentsSymbol == #documentation
!
----- Method: CodeHolder>>showingDocumentationString (in category 'what to show') -----
showingDocumentationString
"Answer a string characerizing whether documentation is showing"
^ (self showingDocumentation
ifTrue:
['<yes>']
ifFalse:
['<no>']), 'documentation'!
----- Method: CodeHolder>>showingPlainSource (in category 'what to show') -----
showingPlainSource
"Answer whether the receiver is showing plain source"
^ contentsSymbol == #source!
----- Method: CodeHolder>>showingPlainSourceString (in category 'what to show') -----
showingPlainSourceString
"Answer a string telling whether the receiver is showing plain source"
^ (self showingPlainSource
ifTrue:
['<yes>']
ifFalse:
['<no>']), 'source'!
----- Method: CodeHolder>>showingPrettyDiffs (in category 'diffs') -----
showingPrettyDiffs
"Answer whether the receiver is showing pretty diffs of source code"
^ contentsSymbol == #prettyDiffs
!
----- Method: CodeHolder>>showingPrettyDiffsString (in category 'diffs') -----
showingPrettyDiffsString
"Answer a string representing whether I'm showing pretty diffs"
^ (self showingPrettyDiffs
ifTrue:
['<yes>']
ifFalse:
['<no>']), 'prettyDiffs'!
----- Method: CodeHolder>>showingPrettyPrint (in category 'what to show') -----
showingPrettyPrint
"Answer whether the receiver is showing pretty-print"
^ contentsSymbol == #prettyPrint!
----- Method: CodeHolder>>showingRegularDiffs (in category 'diffs') -----
showingRegularDiffs
"Answer whether the receiver is showing regular diffs of source code"
^ contentsSymbol == #showDiffs
!
----- Method: CodeHolder>>showingRegularDiffsString (in category 'diffs') -----
showingRegularDiffsString
"Answer a string representing whether I'm showing regular diffs"
^ (self showingRegularDiffs
ifTrue:
['<yes>']
ifFalse:
['<no>']), 'showDiffs'!
----- Method: CodeHolder>>showingSource (in category 'what to show') -----
showingSource
"Answer whether the receiver is currently showing source code"
^ self contentsSymbol == #source
!
----- Method: CodeHolder>>sourceAndDiffsQuintsOnly (in category 'controls') -----
sourceAndDiffsQuintsOnly
"Answer a list of quintuplets representing information on the alternative views available in the code pane for the case where the only plausible choices are showing source or either of the two kinds of diffs"
^ #(
(source togglePlainSource showingPlainSourceString 'source' 'the textual source code as writen')
(showDiffs toggleRegularDiffing showingRegularDiffsString 'showDiffs' 'the textual source diffed from its prior version')
(prettyDiffs togglePrettyDiffing showingPrettyDiffsString 'prettyDiffs' 'formatted textual source diffed from formatted form of prior version'))!
----- Method: CodeHolder>>sourceStringPrettifiedAndDiffed (in category 'message list') -----
sourceStringPrettifiedAndDiffed
"Answer a copy of the source code for the selected message, transformed by diffing and pretty-printing exigencies"
| class selector sourceString |
class := self selectedClassOrMetaClass.
selector := self selectedMessageName.
(class isNil or: [selector isNil]) ifTrue: [^'missing'].
sourceString := class ultimateSourceCodeAt: selector ifAbsent: [^'error'].
self validateMessageSource: sourceString forSelector: selector.
(#(#prettyPrint #prettyDiffs)
includes: contentsSymbol)
ifTrue:
[sourceString := class prettyPrinterClass
format: sourceString
in: class
notifying: nil].
self showingAnyKindOfDiffs
ifTrue: [sourceString := self diffFromPriorSourceFor: sourceString].
^sourceString!
----- Method: CodeHolder>>spawn: (in category 'commands') -----
spawn: aString
"Create and schedule a spawned message category browser for the currently selected message category. The initial text view contains the characters in aString. In the spawned browser, preselect the current selector (if any) as the going-in assumption, though upon acceptance this will often change"
| newBrowser aCategory aClass |
(aClass := self selectedClassOrMetaClass) isNil ifTrue:
[^ aString isEmptyOrNil ifFalse: [(Workspace new contents: aString) openLabel: 'spawned workspace']].
(aCategory := self categoryOfCurrentMethod)
ifNil:
[self buildClassBrowserEditString: aString]
ifNotNil:
[newBrowser := Browser new setClass: aClass selector: self selectedMessageName.
self suggestCategoryToSpawnedBrowser: newBrowser.
Browser openBrowserView: (newBrowser openMessageCatEditString: aString)
label: 'category "', aCategory, '" in ',
newBrowser selectedClassOrMetaClassName]!
----- Method: CodeHolder>>spawnFullProtocol (in category 'commands') -----
spawnFullProtocol
"Create and schedule a new protocol browser on the currently selected class or meta."
| aClassOrMetaclass |
(aClassOrMetaclass := self selectedClassOrMetaClass) ifNotNil:
[ProtocolBrowser openFullProtocolForClass: aClassOrMetaclass]!
----- Method: CodeHolder>>spawnHierarchy (in category 'traits') -----
spawnHierarchy
"Create and schedule a new hierarchy browser on the currently selected class or meta."
| newBrowser aSymbol aBehavior messageCatIndex selectedClassOrMetaClass |
(selectedClassOrMetaClass := self selectedClassOrMetaClass)
ifNil: [^ self].
selectedClassOrMetaClass isTrait ifTrue: [^self].
newBrowser := HierarchyBrowser new initHierarchyForClass: selectedClassOrMetaClass.
((aSymbol := self selectedMessageName) notNil and: [(MessageSet isPseudoSelector: aSymbol) not])
ifTrue:
[aBehavior := selectedClassOrMetaClass.
messageCatIndex := aBehavior organization numberOfCategoryOfElement: aSymbol.
newBrowser messageCategoryListIndex: messageCatIndex + 1.
newBrowser messageListIndex:
((aBehavior organization listAtCategoryNumber: messageCatIndex) indexOf: aSymbol)].
Browser
openBrowserView: (newBrowser openSystemCatEditString: nil)
label: newBrowser labelString.
Smalltalk isMorphic
ifTrue: ["this workaround only needed in morphic"
newBrowser assureSelectionsShow]!
----- Method: CodeHolder>>spawnProtocol (in category 'commands') -----
spawnProtocol
| aClassOrMetaclass |
"Create and schedule a new protocol browser on the currently selected class or meta."
(aClassOrMetaclass := self selectedClassOrMetaClass) ifNotNil:
[ProtocolBrowser openSubProtocolForClass: aClassOrMetaclass]!
----- Method: CodeHolder>>spawnToClass: (in category 'commands') -----
spawnToClass: aClass
"Used to copy down code from a superclass to a subclass in one easy step, if you know what you're doing. Spawns a new message-category browser for the indicated class, populating it with the source code seen in the current tool."
| aCategory newBrowser org |
(aCategory := self categoryOfCurrentMethod)
ifNil:
[self buildClassBrowserEditString: self contents]
ifNotNil:
[((org := aClass organization) categories includes: aCategory)
ifFalse: [org addCategory: aCategory].
newBrowser := Browser new setClass: aClass selector: nil.
newBrowser selectMessageCategoryNamed: aCategory.
Browser openBrowserView: (newBrowser openMessageCatEditString: self contents)
label: 'category "', aCategory, '" in ',
newBrowser selectedClassOrMetaClassName]!
----- Method: CodeHolder>>spawnToCollidingClass: (in category 'commands') -----
spawnToCollidingClass: aClass
"Potentially used to copy down code from a superclass to a subclass in one easy step, in the case where the given class already has its own version of code, which would consequently be clobbered if the spawned code were accepted."
self inform: 'That would be destructive of
some pre-existing code already in that
class for this selector. For the moment,
we will not let you do this to yourself.'!
----- Method: CodeHolder>>stepIn: (in category 'self-updating') -----
stepIn: aSystemWindow
self updateListsAndCodeIn: aSystemWindow!
----- Method: CodeHolder>>suggestCategoryToSpawnedBrowser: (in category 'misc') -----
suggestCategoryToSpawnedBrowser: aBrowser
"aBrowser is a message-category browser being spawned from the receiver. Tell it what it needs to know to get its category info properly set up."
aBrowser setOriginalCategoryIndexForCurrentMethod!
----- Method: CodeHolder>>textPaneWithSelector: (in category 'categories & search pane') -----
textPaneWithSelector: aSelector
"If, among my window's paneMorphs, there is a text pane defined with aSelector as its retriever, answer it, else answer nil"
| aWindow |
^ (aWindow := self containingWindow) ifNotNil:
[aWindow paneMorphSatisfying:
[:aMorph | (aMorph isKindOf: PluggableTextMorph) and:
[aMorph getTextSelector == aSelector]]]!
----- Method: CodeHolder>>toggleDecompile (in category 'what to show') -----
toggleDecompile
"Toggle the setting of the showingDecompile flag, unless there are unsubmitted edits that the user declines to discard"
| wasShowing |
self okToChange ifTrue:
[wasShowing := self showingDecompile.
self restoreTextualCodingPane.
self showDecompile: wasShowing not.
self setContentsToForceRefetch.
self contentsChanged]
!
----- Method: CodeHolder>>toggleDiff (in category 'diffs') -----
toggleDiff
"Retained for backward compatibility with existing buttons in existing images"
self toggleDiffing!
----- Method: CodeHolder>>toggleDiffing (in category 'diffs') -----
toggleDiffing
"Toggle whether diffs should be shown in the code pane. If any kind of diffs were being shown, stop showing diffs. If no kind of diffs were being shown, start showing whatever kind of diffs are called for by default."
| wasShowingDiffs |
self okToChange ifTrue:
[wasShowingDiffs := self showingAnyKindOfDiffs.
self restoreTextualCodingPane.
self showDiffs: wasShowingDiffs not.
self setContentsToForceRefetch.
self contentsChanged]
!
----- Method: CodeHolder>>togglePlainSource (in category 'diffs') -----
togglePlainSource
"Toggle whether plain source shown in the code pane"
| wasShowingPlainSource |
self okToChange ifTrue:
[wasShowingPlainSource := self showingPlainSource.
self restoreTextualCodingPane.
wasShowingPlainSource
ifTrue:
[self showDocumentation: true]
ifFalse:
[contentsSymbol := #source].
self setContentsToForceRefetch.
self changed: #contents]
!
----- Method: CodeHolder>>togglePrettyDiffing (in category 'diffs') -----
togglePrettyDiffing
"Toggle whether pretty-diffing should be shown in the code pane"
| wasShowingDiffs |
self okToChange ifTrue:
[wasShowingDiffs := self showingPrettyDiffs.
self restoreTextualCodingPane.
self showPrettyDiffs: wasShowingDiffs not.
self setContentsToForceRefetch.
self contentsChanged]
!
----- Method: CodeHolder>>togglePrettyPrint (in category 'diffs') -----
togglePrettyPrint
"Toggle whether pretty-print is in effectin the code pane"
self restoreTextualCodingPane.
self okToChange ifTrue:
[self showingPrettyPrint
ifTrue:
[contentsSymbol := #source]
ifFalse:
[contentsSymbol := #prettyPrint].
self setContentsToForceRefetch.
self contentsChanged]
!
----- Method: CodeHolder>>toggleRegularDiffing (in category 'diffs') -----
toggleRegularDiffing
"Toggle whether regular-diffing should be shown in the code pane"
| wasShowingDiffs |
self okToChange ifTrue:
[wasShowingDiffs := self showingRegularDiffs.
self restoreTextualCodingPane.
self showRegularDiffs: wasShowingDiffs not.
self setContentsToForceRefetch.
self contentsChanged]
!
----- Method: CodeHolder>>toggleShowDocumentation (in category 'what to show') -----
toggleShowDocumentation
"Toggle the setting of the showingDocumentation flag, unless there are unsubmitted edits that the user declines to discard"
| wasShowing |
self okToChange ifTrue:
[wasShowing := self showingDocumentation.
self restoreTextualCodingPane.
self showDocumentation: wasShowing not.
self setContentsToForceRefetch.
self contentsChanged]
!
----- Method: CodeHolder>>toggleShowingByteCodes (in category 'what to show') -----
toggleShowingByteCodes
"Toggle whether the receiver is showing bytecodes"
self restoreTextualCodingPane.
self showByteCodes: self showingByteCodes not.
self setContentsToForceRefetch.
self contentsChanged!
----- Method: CodeHolder>>unshiftedYellowButtonActivity (in category 'commands') -----
unshiftedYellowButtonActivity
"Offer the unshifted shifted selector-list menu"
^ self offerMenuFrom: #messageListMenu:shifted: shifted: false!
----- Method: CodeHolder>>updateCodePaneIfNeeded (in category 'self-updating') -----
updateCodePaneIfNeeded
"If the code for the currently selected method has changed underneath me, then update the contents of my code pane unless it holds unaccepted edits"
self didCodeChangeElsewhere
ifTrue:
[self hasUnacceptedEdits
ifFalse:
[self setContentsToForceRefetch.
self contentsChanged]
ifTrue:
[self changed: #codeChangedElsewhere]]!
----- Method: CodeHolder>>updateListsAndCodeIn: (in category 'self-updating') -----
updateListsAndCodeIn: aWindow
super updateListsAndCodeIn: aWindow.
self updateCodePaneIfNeeded!
----- Method: CodeHolder>>useSelector:orGetSelectorAndSendQuery:to: (in category 'misc') -----
useSelector: incomingSelector orGetSelectorAndSendQuery: querySelector to: queryPerformer
"If incomingSelector is not nil, use it, else obtain a selector from user type-in. Using the determined selector, send the query to the performer provided."
| aSelector |
incomingSelector
ifNotNil:
[queryPerformer perform: querySelector with: incomingSelector]
ifNil:
[aSelector :=UIManager default request: 'Type selector:' initialAnswer: 'flag:'.
aSelector isEmptyOrNil ifFalse:
[(Symbol hasInterned: aSelector ifTrue:
[:aSymbol | queryPerformer perform: querySelector with: aSymbol])
ifFalse:
[self inform: 'no such selector']]]!
----- Method: CodeHolder>>validateMessageSource:forSelector: (in category 'message list') -----
validateMessageSource: sourceString forSelector: aSelector
"Check whether there is evidence that method source is invalid"
| sourcesName |
(self selectedClass compilerClass == Object compilerClass
and: [(sourceString asString findString: aSelector keywords first ) ~= 1])
ifTrue: [sourcesName := FileDirectory localNameFor: SmalltalkImage current sourcesName.
self inform: 'There may be a problem with your sources file!!
The source code for every method should (usually) start with the
method selector but this is not the case with this method!! You may
proceed with caution but it is recommended that you get a new source file.
This can happen if you download the "' , sourcesName , '" file,
or the ".changes" file you use, as TEXT. It must be transfered
in BINARY mode, even if it looks like a text file,
to preserve the CR line ends.
Mac users: This may have been caused by Stuffit Expander.
To prevent the files above to be converted to Mac line ends
when they are expanded, do this: Start the program, then
from Preferences... in the File menu, choose the Cross
Platform panel, then select "Never" and press OK.
Then expand the compressed archive again.
(Occasionally, the source code for a method may legitimately
start with a non-alphabetic character -- for example, Behavior
method #formalHeaderPartsFor:. In such rare cases, you can
happily disregard this warning.)'].!
----- Method: CodeHolder>>wantsDiffFeedback (in category 'diffs') -----
wantsDiffFeedback
"Answer whether the receiver is showing diffs of source code"
^ self showingAnyKindOfDiffs!
----- Method: CodeHolder>>wantsStepsIn: (in category 'self-updating') -----
wantsStepsIn: aWindow
^ Preferences smartUpdating!
CodeHolder subclass: #Debugger
instanceVariableNames: 'interruptedProcess interruptedController contextStack contextStackTop contextStackIndex contextStackList receiverInspector contextVariablesInspector externalInterrupt proceedValue selectingPC debuggerMap savedCursor isolationHead failedProject errorWasInUIProcess labelString message'
classVariableNames: 'ContextStackKeystrokes ErrorRecursion'
poolDictionaries: ''
category: 'Tools-Debugger'!
!Debugger commentStamp: '<historical>' prior: 0!
I represent the machine state at the time of an interrupted process. I also represent a query path into the state of the process. The debugger is typically viewed through a window that views the stack of suspended contexts, the code for, and execution point in, the currently selected message, and inspectors on both the receiver of the currently selected message, and the variables in the current context.
Special note on recursive errors:
Some errors affect Squeak's ability to present a debugger. This is normally an unrecoverable situation. However, if such an error occurs in an isolation layer, Squeak will attempt to exit from the isolation layer and then present a debugger. Here is the chain of events in such a recovery.
* A recursive error is detected.
* The current project is queried for an isolationHead
* Changes in the isolationHead are revoked
* The parent project of isolated project is returned to
* The debugger is opened there and execution resumes.
If the user closes that debugger, execution continues in the outer project and layer. If, after repairing some damage, the user proceeds from the debugger, then the isolationHead is re-invoked, the failed project is re-entered, and execution resumes in that world. !
----- Method: Debugger class>>context: (in category 'instance creation') -----
context: aContext
"Answer an instance of me for debugging the active process starting with the given context."
^ self context: aContext isolationHead: nil!
----- Method: Debugger class>>context:isolationHead: (in category 'instance creation') -----
context: aContext isolationHead: isolationHead
"Answer an instance of me for debugging the active process starting with the given context."
^ self new
process: Processor activeProcess
controller:
((Smalltalk isMorphic not and: [ScheduledControllers inActiveControllerProcess])
ifTrue: [ScheduledControllers activeController]
ifFalse: [nil])
context: aContext
isolationHead: isolationHead
!
----- Method: Debugger class>>informExistingDebugger:label: (in category 'instance creation') -----
informExistingDebugger: aContext label: aString
"Walking the context chain, we try to find out if we're in a debugger stepping situation.
If we find the relevant contexts, we must rearrange them so they look just like they would
if the methods were excuted outside of the debugger."
| ctx quickStepMethod oldSender baseContext |
ctx := thisContext.
quickStepMethod := ContextPart compiledMethodAt: #quickSend:to:with:super:.
[ctx sender == nil or: [ctx sender method == quickStepMethod]] whileFalse: [ctx := ctx sender].
ctx sender == nil ifTrue: [^self].
baseContext := ctx.
"baseContext is now the context created by the #quickSend... method."
oldSender := ctx := ctx sender home sender.
"oldSender is the context which originally sent the #quickSend... method"
[ctx == nil or: [ctx receiver isKindOf: self]] whileFalse: [ctx := ctx sender].
ctx == nil ifTrue: [^self].
"ctx is the context of the Debugger method #doStep"
ctx receiver labelString: aString.
ctx receiver externalInterrupt: false; proceedValue: aContext receiver.
baseContext swapSender: baseContext sender sender sender. "remove intervening contexts"
thisContext swapSender: oldSender. "make myself return to debugger"
ErrorRecursion := false.
^aContext!
----- Method: Debugger class>>initialize (in category 'class initialization') -----
initialize
ErrorRecursion := false.
ContextStackKeystrokes := Dictionary new
at: $e put: #send;
at: $t put: #doStep;
at: $T put: #stepIntoBlock;
at: $p put: #proceed;
at: $r put: #restart;
at: $f put: #fullStack;
at: $w put: #where;
yourself.
"Debugger initialize"!
----- Method: Debugger class>>openContext:label:contents: (in category 'class initialization') -----
openContext: aContext label: aString contents: contentsStringOrNil
| isolationHead |
"Open a notifier in response to an error, halt, or notify. A notifier view just shows a short view of the sender stack and provides a menu that lets the user open a full debugger."
<primitive: 19> "Simulation guard"
ErrorRecursion not & Preferences logDebuggerStackToFile ifTrue:
[Smalltalk logError: aString inContext: aContext to: 'SqueakDebug.log'].
ErrorRecursion ifTrue:
[ErrorRecursion := false.
(isolationHead := Project current isolationHead)
ifNil: [self primitiveError: aString]
ifNotNil: [isolationHead revoke]].
ErrorRecursion := true.
self informExistingDebugger: aContext label: aString.
(Debugger context: aContext isolationHead: isolationHead)
openNotifierContents: contentsStringOrNil
label: aString.
ErrorRecursion := false.
Processor activeProcess suspend.
!
----- Method: Debugger class>>openInterrupt:onProcess: (in category 'opening') -----
openInterrupt: aString onProcess: interruptedProcess
"Open a notifier in response to an interrupt. An interrupt occurs when the user types the interrupt key (cmd-. on Macs, ctrl-c or alt-. on other systems) or when the low-space watcher detects that memory is low."
| debugger |
<primitive: 19> "Simulation guard"
debugger := self new.
debugger
process: interruptedProcess
controller: ((Smalltalk isMorphic not
and: [ScheduledControllers activeControllerProcess == interruptedProcess])
ifTrue: [ScheduledControllers activeController])
context: interruptedProcess suspendedContext.
debugger externalInterrupt: true.
Preferences logDebuggerStackToFile ifTrue:
[(aString includesSubString: 'Space') &
(aString includesSubString: 'low') ifTrue: [
Smalltalk logError: aString inContext: debugger interruptedContext to:'LowSpaceDebug.log']].
Preferences eToyFriendly ifTrue: [World stopRunningAll].
^ debugger
openNotifierContents: nil
label: aString
!
----- Method: Debugger class>>openOn:context:label:contents:fullView: (in category 'opening') -----
openOn: process context: context label: title contents: contentsStringOrNil fullView: bool
"Open a notifier in response to an error, halt, or notify. A notifier view just shows a short view of the sender stack and provides a menu that lets the user open a full debugger."
| controller errorWasInUIProcess |
Smalltalk isMorphic
ifTrue: [errorWasInUIProcess := Project spawnNewProcessIfThisIsUI: process]
ifFalse: [controller := ScheduledControllers activeControllerProcess == process
ifTrue: [ScheduledControllers activeController]].
WorldState addDeferredUIMessage: [
[ | debugger |
debugger := self new process: process controller: controller context: context.
Smalltalk isMorphic
ifTrue: ["schedule debugger in deferred UI message to address redraw
problems after opening a debugger e.g. from the testrunner."
"WorldState addDeferredUIMessage: ["bool
ifTrue: [debugger openFullNoSuspendLabel: title]
ifFalse: [debugger openNotifierContents: contentsStringOrNil label: title]]
ifFalse: ["deferred UI message would require special controller in MVC"
bool
ifTrue: [debugger openFullNoSuspendLabel: title]
ifFalse: [debugger openNotifierContents: contentsStringOrNil label: title]].
debugger errorWasInUIProcess: errorWasInUIProcess.
Preferences logDebuggerStackToFile ifTrue: [
Smalltalk logError: title inContext: context to: 'SqueakDebug.log'].
Smalltalk isMorphic
ifFalse: [ScheduledControllers searchForActiveController "needed since openNoTerminate (see debugger #open...) does not set up activeControllerProcess if activeProcess (this fork) is not the current activeControllerProcess (see #scheduled:from:)"].
] on: Error do: [:ex |
self primitiveError:
'Orginal error: ',
title asString, '.
Debugger error: ',
([ex description] on: Error do: ['a ', ex class printString]), ':'
]
].
process suspend.
!
----- Method: Debugger class>>windowColorSpecification (in category 'window color') -----
windowColorSpecification
"Answer a WindowColorSpec object that declares my preference"
^ WindowColorSpec classSymbol: self name wording: 'Debugger' brightColor: #lightRed pastelColor: #veryPaleRed helpMessage: 'The system debugger.'!
----- Method: Debugger>>abandon (in category 'context stack menu') -----
abandon
"abandon the debugger from its pre-debug notifier"
self abandon: self topView!
----- Method: Debugger>>abandon: (in category 'context stack menu') -----
abandon: aTopView
"abandon the notifier represented by aTopView"
ToolBuilder default close: aTopView!
----- Method: Debugger>>aboutToStyle: (in category 'code pane') -----
aboutToStyle: aStyler
"This is a notification that aStyler is about to re-style its text.
Set the classOrMetaClass in aStyler, so that identifiers
will be resolved correctly.
Answer true to allow styling to proceed, or false to veto the styling"
self isModeStyleable ifFalse: [^false].
aStyler
classOrMetaClass: self selectedClassOrMetaClass;
sourceMap: self debuggerMap.
^true!
----- Method: Debugger>>askForCategoryIn:default: (in category 'context stack menu') -----
askForCategoryIn: aClass default: aString
| categories index category |
categories := OrderedCollection with: 'new ...'.
categories addAll: (aClass allMethodCategoriesIntegratedThrough: Object).
index := UIManager default
chooseFrom: categories
title: 'Please provide a good category for the new method!!' translated.
index = 0 ifTrue: [^ aString].
category := index = 1 ifTrue: [UIManager default request: 'Enter category name:']
ifFalse: [categories at: index].
^ category isEmpty ifTrue: [^ aString] ifFalse: [category]!
----- Method: Debugger>>askForSuperclassOf:toImplement:ifCancel: (in category 'private') -----
askForSuperclassOf: aClass toImplement: aSelector ifCancel: cancelBlock
| classes chosenClassIndex |
classes := aClass withAllSuperclasses.
chosenClassIndex := UIManager default
chooseFrom: (classes collect: [:c | c name])
title: 'Define #', aSelector, ' in which class?'.
chosenClassIndex = 0 ifTrue: [^ cancelBlock value].
^ classes at: chosenClassIndex!
----- Method: Debugger>>browseMessages (in category 'context stack menu') -----
browseMessages
"Present a menu of all messages sent by the currently selected message.
Open a message set browser of all implementors of the message chosen.
Do nothing if no message is chosen."
contextStackIndex = 0 ifTrue: [^ self].
super browseMessages.!
----- Method: Debugger>>browseSendersOfMessages (in category 'context stack menu') -----
browseSendersOfMessages
"Present a menu of the currently selected message, as well as all
messages sent by it. Open a message set browser of all implementors
of the message chosen."
contextStackIndex = 0 ifTrue: [^ self].
super browseSendersOfMessages!
----- Method: Debugger>>browseVersions (in category 'context stack menu') -----
browseVersions
"Create and schedule a message set browser on all versions of the
currently selected message selector."
| class selector |
class := self selectedClassOrMetaClass.
selector := self selectedMessageName.
VersionsBrowser
browseVersionsOf: (class compiledMethodAt: selector)
class: self selectedClass theNonMetaClass
meta: class isMeta
category: self selectedMessageCategoryName
selector: selector!
----- Method: Debugger>>buildFullWith: (in category 'toolbuilder') -----
buildFullWith: builder
| windowSpec listSpec textSpec extent |
windowSpec := builder pluggableWindowSpec new.
windowSpec model: self.
windowSpec label: 'Debugger'.
Display height < 800 "a small screen"
ifTrue:[extent := RealEstateAgent standardWindowExtent]
ifFalse:[extent := 600 at 700].
windowSpec extent: extent.
windowSpec children: OrderedCollection new.
listSpec := builder pluggableListSpec new.
listSpec
model: self;
list: #contextStackList;
getIndex: #contextStackIndex;
setIndex: #toggleContextStackIndex:;
menu: #contextStackMenu:shifted:;
keyPress: #contextStackKey:from:;
frame: (0 at 0 corner: 1 at 0.22).
windowSpec children add: listSpec.
textSpec := self buildCodePaneWith: builder.
textSpec frame: (0 at 0.22corner: 1 at 0.8).
windowSpec children add: textSpec.
listSpec := builder pluggableListSpec new.
listSpec
model: self receiverInspector;
list: #fieldList;
getIndex: #selectionIndex;
setIndex: #toggleIndex:;
menu: #fieldListMenu:;
keyPress: #inspectorKey:from:;
frame: (0 at 0.8 corner: 0.2 at 1).
windowSpec children add: listSpec.
textSpec := builder pluggableTextSpec new.
textSpec
model: self receiverInspector;
getText: #contents;
setText: #accept:;
selection: #contentsSelection;
menu: #codePaneMenu:shifted:;
frame: (0.2 at 0.8 corner: 0.5 at 1).
windowSpec children add: textSpec.
listSpec := builder pluggableListSpec new.
listSpec
model: self contextVariablesInspector;
list: #fieldList;
getIndex: #selectionIndex;
setIndex: #toggleIndex:;
menu: #fieldListMenu:;
keyPress: #inspectorKey:from:;
frame: (0.5 at 0.8 corner: 0.7 at 1).
windowSpec children add: listSpec.
textSpec := builder pluggableTextSpec new.
textSpec
model: self contextVariablesInspector;
getText: #contents;
setText: #accept:;
selection: #contentsSelection;
menu: #codePaneMenu:shifted:;
frame: (0.7 at 0.8 corner: 1 at 1).
windowSpec children add: textSpec.
^builder build: windowSpec!
----- Method: Debugger>>buildNotifierWith:label:message: (in category 'toolbuilder') -----
buildNotifierWith: builder label: label message: messageString
| windowSpec listSpec textSpec panelSpec buttonSpec quads |
windowSpec := builder pluggableWindowSpec new.
windowSpec model: self.
windowSpec extent: 450 @ 156. "nice and wide to show plenty of the error msg"
windowSpec label: label.
windowSpec children: OrderedCollection new.
panelSpec := builder pluggablePanelSpec new.
panelSpec children: OrderedCollection new.
quads := self preDebugButtonQuads.
(self interruptedContext selector == #doesNotUnderstand:) ifTrue: [
quads := quads copyWith:
{ 'Create'. #createMethod. #magenta. 'create the missing method' }
].
quads do:[:spec|
buttonSpec := builder pluggableButtonSpec new.
buttonSpec model: self.
buttonSpec label: spec first.
buttonSpec action: spec second.
buttonSpec help: spec fourth.
panelSpec children add: buttonSpec.
].
panelSpec layout: #horizontal. "buttons"
panelSpec frame: (0 at 0 corner: 1 at 0.2).
windowSpec children add: panelSpec.
Preferences eToyFriendly | messageString notNil ifFalse:[
listSpec := builder pluggableListSpec new.
listSpec
model: self;
list: #contextStackList;
getIndex: #contextStackIndex;
setIndex: #debugAt:;
frame: (0 at 0.2 corner: 1 at 1).
windowSpec children add: listSpec.
] ifTrue:[
message := messageString.
textSpec := builder pluggableTextSpec new.
textSpec
model: self;
getText: #preDebugMessageString;
setText: nil;
selection: nil;
menu: #debugProceedMenu:;
frame: (0 at 0.2corner: 1 at 1).
windowSpec children add: textSpec.
].
^windowSpec!
----- Method: Debugger>>buildWith: (in category 'toolbuilder') -----
buildWith: aBuilder
^self buildFullWith: aBuilder!
----- Method: Debugger>>checkContextSelection (in category 'private') -----
checkContextSelection
contextStackIndex = 0 ifTrue: [self contextStackIndex: 1 oldContextWas: nil].
!
----- Method: Debugger>>close: (in category 'context stack menu') -----
close: aScheduledController
"The argument is a controller on a view of the receiver.
That view is closed."
aScheduledController close
!
----- Method: Debugger>>codePaneMenu:shifted: (in category 'code pane menu') -----
codePaneMenu: aMenu shifted: shifted
aMenu add: 'run to here' target: self selector: #runToSelection: argument: thisContext sender receiver selectionInterval.
aMenu addLine.
super codePaneMenu: aMenu shifted: shifted.
^aMenu.!
----- Method: Debugger>>contents (in category 'accessing') -----
contents
"Depending on the current selection, different information is retrieved.
Answer a string description of that information. This information is the
method in the currently selected context."
contents == nil ifTrue: [^ String new].
^ contents copy!
----- Method: Debugger>>contents:notifying: (in category 'accessing') -----
contents: aText notifying: aController
"The retrieved information has changed and its source must now be updated.
In this case, the retrieved information is the method of the selected context."
| result selector classOfMethod category h ctxt newMethod |
contextStackIndex = 0 ifTrue:
[^false].
self selectedContext isExecutingBlock ifTrue:
[h := self selectedContext activeHome.
h ifNil:
[self inform: 'Method for block not found on stack, can''t edit and continue'.
^false].
(self confirm: 'I will have to revert to the method from\which this block originated. Is that OK?' withCRs) ifFalse:
[^false].
self resetContext: h.
result := self contents: aText notifying: aController.
self contentsChanged.
^result].
classOfMethod := self selectedClass.
category := self selectedMessageCategoryName.
selector := self selectedClass parserClass new parseSelector: aText.
(selector == self selectedMessageName
or: [(self selectedMessageName beginsWith: 'DoIt')
and: [selector numArgs = self selectedMessageName numArgs]]) ifFalse:
[self inform: 'can''t change selector'.
^false].
selector := classOfMethod
compile: aText
classified: category
notifying: aController.
selector ifNil: [^false]. "compile cancelled"
contents := aText.
newMethod := classOfMethod compiledMethodAt: selector.
newMethod isQuick ifTrue:
[self down.
self selectedContext jump: (self selectedContext previousPc - self selectedContext pc)].
ctxt := interruptedProcess popTo: self selectedContext.
ctxt == self selectedContext
ifFalse:
[self inform: 'Method saved, but current context unchanged\because of unwind error. Click OK to see error' withCRs]
ifTrue:
[newMethod isQuick ifFalse:
[interruptedProcess
restartTopWith: newMethod;
stepToSendOrReturn].
contextVariablesInspector object: nil].
self resetContext: ctxt.
Smalltalk isMorphic ifTrue:
[World
addAlarm: #changed:
withArguments: #(contentsSelection)
for: self
at: (Time millisecondClockValue + 200)].
^true!
----- Method: Debugger>>contentsSelection (in category 'code pane') -----
contentsSelection
^ self pcRange!
----- Method: Debugger>>contextStackIndex (in category 'context stack (message list)') -----
contextStackIndex
"Answer the index of the selected context."
^contextStackIndex!
----- Method: Debugger>>contextStackIndex:oldContextWas: (in category 'private') -----
contextStackIndex: anInteger oldContextWas: oldContext
"Change the context stack index to anInteger, perhaps in response to user selection."
| isNewMethod selectedContextSlotName index |
contextStackIndex := anInteger.
anInteger = 0 ifTrue:
[currentCompiledMethod := contents := nil.
self changed: #contextStackIndex.
self decorateButtons.
self contentsChanged.
contextVariablesInspector object: nil.
receiverInspector object: self receiver.
^self].
selectedContextSlotName := contextVariablesInspector selectedSlotName.
isNewMethod := oldContext == nil
or: [oldContext method ~~ (currentCompiledMethod := self selectedContext method)].
isNewMethod ifTrue:
[contents := self selectedMessage.
self contentsChanged.
self pcRange].
self changed: #contextStackIndex.
self decorateButtons.
contextVariablesInspector object: self selectedContext.
((index := contextVariablesInspector fieldList indexOf: selectedContextSlotName) ~= 0
and: [index ~= contextVariablesInspector selectionIndex]) ifTrue:
[contextVariablesInspector toggleIndex: index].
receiverInspector object: self receiver.
isNewMethod ifFalse:
[self changed: #contentsSelection]!
----- Method: Debugger>>contextStackKey:from: (in category 'context stack menu') -----
contextStackKey: aChar from: view
"Respond to a keystroke in the context list"
| selector |
selector := ContextStackKeystrokes at: aChar ifAbsent: [nil].
selector ifNil: [self messageListKey: aChar from: view]
ifNotNil: [self perform: selector]!
----- Method: Debugger>>contextStackList (in category 'context stack (message list)') -----
contextStackList
"Answer the array of contexts."
^contextStackList!
----- Method: Debugger>>contextStackMenu:shifted: (in category 'context stack menu') -----
contextStackMenu: aMenu shifted: shifted
"Set up the menu appropriately for the context-stack-list, either shifted or unshifted as per the parameter provided"
^ shifted ifFalse:[
aMenu addList: {
{'fullStack (f)'. #fullStack}.
{'restart (r)'. #restart}.
{'proceed (p)'. #proceed}.
{'step (t)'. #doStep}.
{'step through (T)'. #stepIntoBlock}.
{'send (e)'. #send}.
{'where (w)'. #where}.
{'peel to first like this'. #peelToFirst}.
#-.
{'return entered value'. #returnValue}.
#-.
{'toggle break on entry'. #toggleBreakOnEntry}.
{'senders of... (n)'. #browseSendersOfMessages}.
{'implementors of... (m)'. #browseMessages}.
{'inheritance (i)'. #methodHierarchy}.
#-.
{'versions (v)'. #browseVersions}.
{'inst var refs...'. #browseInstVarRefs}.
#-.
{'inst var defs...'. #browseInstVarDefs}.
{'class var refs...'. #browseClassVarRefs}.
{'class variables'. #browseClassVariables}.
#-.
{'class refs (N)'. #browseClassRefs}.
{'browse full (b)'. #browseMethodFull}.
{'file out '. #fileOutMessage}.
#-.
{'mail out bug report'. #mailOutBugReport}.
{'more...'. #shiftedYellowButtonActivity}.
}.
] ifTrue: [
aMenu addList: {
{'browse class hierarchy'. #classHierarchy}.
{'browse class'. #browseClass}.
{'browse method (O)'. #openSingleMessageBrowser}.
{'implementors of sent messages'. #browseAllMessages}.
{'change sets with this method'. #findMethodInChangeSets}.
#-.
{'inspect instances'. #inspectInstances}.
{'inspect subinstances'. #inspectSubInstances}.
#-.
{'revert to previous version'. #revertToPreviousVersion}.
{'remove from current change set'. #removeFromCurrentChanges}.
{'revert & remove from changes'. #revertAndForget}.
#-.
{'more...'. #unshiftedYellowButtonActivity}.
}
].!
----- Method: Debugger>>contextVariablesInspector (in category 'accessing') -----
contextVariablesInspector
"Answer the instance of Inspector that is providing a view of the
variables of the selected context."
^contextVariablesInspector!
----- Method: Debugger>>createMethod (in category 'private') -----
createMethod
"Should only be called when this Debugger was created in response to a
MessageNotUnderstood exception. Create a stub for the method that was
missing and proceed into it."
| msg chosenClass |
msg := contextStackTop tempAt: 1.
chosenClass := self
askForSuperclassOf: contextStackTop receiver class
toImplement: msg selector
ifCancel: [^self].
self implement: msg inClass: chosenClass.
!
----- Method: Debugger>>customButtonSpecs (in category 'initialize') -----
customButtonSpecs
"Answer an array of elements of the form wording, selector, help-message, that characterize the custom button row of a debugger."
| list |
list := #(('Proceed' proceed 'close the debugger and proceed.')
('Restart' restart 'reset this context to its start.')
('Into' send 'step Into message sends')
('Over' doStep 'step Over message sends')
('Through' stepIntoBlock 'step into a block')
('Full Stack' fullStack 'show full stack')
('Where' where 'select current pc range')
('Tally' tally 'time in milliseconds to execute')).
Preferences restartAlsoProceeds ifTrue:
[list := list collect: [:each |
each second == #restart
ifTrue: [each copy at: 3 put: 'proceed from the beginning of this context.'; yourself]
ifFalse: [each]]].
^ list!
----- Method: Debugger>>debug (in category 'notifier menu') -----
debug
"Open a full DebuggerView."
| topView |
topView := self topView.
topView model: nil. "so close won't release me."
self breakDependents.
ToolBuilder default close: topView.
^ self openFullNoSuspendLabel: topView label!
----- Method: Debugger>>debugAt: (in category 'initialize') -----
debugAt: anInteger
self toggleContextStackIndex: anInteger.
^ self debug.!
----- Method: Debugger>>debugProceedMenu: (in category 'context stack menu') -----
debugProceedMenu: aMenu
^ aMenu labels:
'proceed
debug'
lines: #()
selections: #(proceed debug )
!
----- Method: Debugger>>debuggerMap (in category 'accessing') -----
debuggerMap
^debuggerMap ifNil:
[debuggerMap := self selectedContext debuggerMap].!
----- Method: Debugger>>doItContext (in category 'code pane') -----
doItContext
"Answer the context in which a text selection can be evaluated."
contextStackIndex = 0
ifTrue: [^super doItContext]
ifFalse: [^self selectedContext]!
----- Method: Debugger>>doItReceiver (in category 'code pane') -----
doItReceiver
"Answer the object that should be informed of the result of evaluating a
text selection."
^self receiver!
----- Method: Debugger>>doNothing: (in category 'accessing') -----
doNothing: newText
"Notifier window can't accept text"!
----- Method: Debugger>>doStep (in category 'context stack menu') -----
doStep
"Send the selected message in the accessed method, and regain control
after the invoked method returns."
| currentContext newContext |
self okToChange ifFalse: [^ self].
self checkContextSelection.
currentContext := self selectedContext.
newContext := interruptedProcess completeStep: currentContext.
newContext == currentContext ifTrue: [
newContext := interruptedProcess stepToSendOrReturn].
self contextStackIndex > 1
ifTrue: [self resetContext: newContext]
ifFalse: [newContext == currentContext
ifTrue: [self changed: #contentsSelection.
self updateInspectors]
ifFalse: [self resetContext: newContext]].
!
----- Method: Debugger>>down (in category 'context stack menu') -----
down
"move down the context stack to the previous (enclosing) context"
self toggleContextStackIndex: contextStackIndex+1!
----- Method: Debugger>>errorWasInUIProcess: (in category 'initialize') -----
errorWasInUIProcess: boolean
errorWasInUIProcess := boolean!
----- Method: Debugger>>expandStack (in category 'context stack (message list)') -----
expandStack
"A Notifier is being turned into a full debugger. Show a substantial amount of stack in the context pane."
self newStack: (contextStackTop stackOfSize: 20).
contextStackIndex := 0.
receiverInspector := Inspector inspect: nil.
contextVariablesInspector := ContextVariablesInspector inspect: nil.
proceedValue := nil!
----- Method: Debugger>>externalInterrupt: (in category 'private') -----
externalInterrupt: aBoolean
externalInterrupt := aBoolean !
----- Method: Debugger>>fullStack (in category 'context stack menu') -----
fullStack
"Change from displaying the minimal stack to a full one."
self contextStackList size > 20 "Already expanded"
ifTrue:
[self changed: #flash]
ifFalse:
[self contextStackIndex = 0 ifFalse: [
self toggleContextStackIndex: self contextStackIndex].
self fullyExpandStack]!
----- Method: Debugger>>fullyExpandStack (in category 'context stack (message list)') -----
fullyExpandStack
"Expand the stack to include all of it, rather than the first four or five
contexts."
self okToChange ifFalse: [^ self].
self newStack: contextStackTop contextStack.
self changed: #contextStackList!
----- Method: Debugger>>getSelectedText (in category 'tally support') -----
getSelectedText
| m interval text |
m := self getTextMorphWithSelection.
interval := m selectionInterval.
text := m text.
^ text copyFrom: interval first to: interval last
!
----- Method: Debugger>>getTextMorphWithSelection (in category 'tally support') -----
getTextMorphWithSelection
"This is extremely ugly... We I need to get a reference of the code pane, which is not easily accessible"
^ (self dependents select: [:m| m isKindOf: PluggableTextMorph])
detect: [:m| m selectionInterval first > 1] ifNone: [nil]!
----- Method: Debugger>>implement:inClass: (in category 'context stack menu') -----
implement: aMessage inClass: aClass
aClass
compile: aMessage createStubMethod
classified: (self askForCategoryIn: aClass default: 'as yet unclassified').
self setContentsToForceRefetch.
self selectedContext privRefreshWith: (aClass lookupSelector: aMessage selector).
self selectedContext method numArgs > 0 ifTrue:
[(self selectedContext tempAt: 1) arguments withIndexDo:
[:arg :index|
self selectedContext tempAt: index put: arg]].
self resetContext: self selectedContext.
self debug.
!
----- Method: Debugger>>initialExtent (in category 'initialize') -----
initialExtent
"Make the full debugger longer!!"
dependents size < 9 ifTrue: [^ super initialExtent]. "Pre debug window"
RealEstateAgent standardWindowExtent y < 400 "a tiny screen"
ifTrue: [^ super initialExtent].
^ 600 at 700
!
----- Method: Debugger>>interruptedContext (in category 'accessing') -----
interruptedContext
"Answer the suspended context of the interrupted process."
^contextStackTop!
----- Method: Debugger>>interruptedProcess (in category 'accessing') -----
interruptedProcess
"Answer the interrupted process."
^interruptedProcess!
----- Method: Debugger>>isNotifier (in category 'accessing') -----
isNotifier
"Return true if this debugger has not been expanded into a full sized window"
^ receiverInspector == nil!
----- Method: Debugger>>isolationRecoveryAdvice (in category 'private') -----
isolationRecoveryAdvice
"Return a notifier message string to be presented in case of recovery from recursive error by revoking the changes in an isolation layer. This surely ranks as one of Squeak's longer help messages."
^ 'Warning!! You have encountered a recursive error situation.
Don''t panic, but do read the following advice. If you were just fooling around, the simplest thing to do is to quit and NOT save, and restart Squeak. If you care about recovery, then read on...
In the process of diagnosing one error, further errors occurred, making it impossible to give you a debugger to work with. Squeak has jumped to an outer project where many of the objects and code changes that might have caused this problem are not involved in normal operation. If you are looking at this window, chances are that this first level of recovery was successful. If there are changes you care a lot about, try to save them now. Then, hopefully, from the state in this debugger, you can determine what the problem was and fix it. Do not save this image until you are confident of its recovery.
You are no longer in the world that is damaged. The two most likely causes of recursive errors are malformed objects (for instance a corrupt value encountered in any display of the desktop) and recurring code errors (such as a change that causes errors in any attempt to display the desktop).
In the case of malformed objects, you can attempt to repair them by altering various bindings in the corrupted environment. Open this debugger and examine the state of the objects closest to the error.
In the case of code errors, note that you are no longer in a world where the erroneous code is in effect. The only simple option available is for you to browse to the changeSet for the project in distress, and remove one or more of the changes (later it will be possible to edit the code remotely from here).
If you feel you have repaired the problem, then you may proceed from this debugger. This will put you back in the project that failed with the changes that failed for another try. Note that the debugger from which you are proceeding is the second one that occurred; you will likely find the first one waiting for you when you reenter the failed project!! Also note that if your error occurred while displaying a morph, it may now be flagged as undisplayable (red with yellow cross); if so, use the morph debug menu to choose ''start drawing again''.
If you have not repaired the problem, you should close this debugger and delete the failed project after retrieving whatever may be of value in it.
Good luck.
- The Squeak Fairy Godmother
PS: If you feel you need the help of a quantum mechanic, do NOT close this window. Instead, the best thing to do (after saving anything that seems safe to save) would be to use the ''save as...'' command in the world menu, and give it a new image name, such as OOPS. There is a good chance that someone who knows their way around Squeak can help you out.
'!
----- Method: Debugger>>labelString (in category 'accessing') -----
labelString
^labelString!
----- Method: Debugger>>labelString: (in category 'accessing') -----
labelString: aString
labelString := aString.
self changed: #relabel!
----- Method: Debugger>>lowSpaceChoices (in category 'private') -----
lowSpaceChoices
"Return a notifier message string to be presented when space is running low."
^ 'Warning!! Squeak is almost out of memory!!
Low space detection is now disabled. It will be restored when you close or proceed from this error notifier. Don''t panic, but do proceed with caution.
Here are some suggestions:
If you suspect an infinite recursion (the same methods calling each other again and again), then close this debugger, and fix the problem.
If you want this computation to finish, then make more space available (read on) and choose "proceed" in this debugger. Here are some ways to make more space available...
> Close any windows that are not needed.
> Get rid of some large objects (e.g., images).
> Leave this window on the screen, choose "save as..." from the screen menu, quit, restart the Squeak VM with a larger memory allocation, then restart the image you just saved, and choose "proceed" in this window.
If you want to investigate further, choose "debug" in this window. Do not use the debugger "fullStack" command unless you are certain that the stack is not very deep. (Trying to show the full stack will definitely use up all remaining memory if the low-space problem is caused by an infinite recursion!!).
'
!
----- Method: Debugger>>mailOutBugReport (in category 'context stack menu') -----
mailOutBugReport
"Compose a useful bug report showing the state of the process as well as vital image statistics as suggested by Chris Norton -
'Squeak could pre-fill the bug form with lots of vital, but
oft-repeated, information like what is the image version, last update
number, VM version, platform, available RAM, author...'
and address it to the list with the appropriate subject prefix."
| messageStrm |
MailSender default ifNil: [^self].
Cursor write
showWhile:
["Prepare the message"
messageStrm := WriteStream on: (String new: 1500).
messageStrm nextPutAll: 'From: ';
nextPutAll: MailSender userName;
cr;
nextPutAll: 'To: squeak-dev at lists.squeakfoundation.org';
cr;
nextPutAll: 'Subject: ';
nextPutAll: '[BUG]'; nextPutAll: self interruptedContext printString;
cr;cr;
nextPutAll: 'here insert explanation of what you were doing, suspect changes you''ve made and so forth.';cr;cr.
self interruptedContext errorReportOn: messageStrm.
MailSender sendMessage: (MailMessage from: messageStrm contents)].
!
----- Method: Debugger>>messageListIndex (in category 'context stack (message list)') -----
messageListIndex
"Answer the index of the currently selected context."
^contextStackIndex!
----- Method: Debugger>>messageListMenu:shifted: (in category 'context stack menu') -----
messageListMenu: aMenu shifted: shifted
"The context-stack menu takes the place of the message-list menu in the debugger, so pass it on"
^ self contextStackMenu: aMenu shifted: shifted!
----- Method: Debugger>>newStack: (in category 'private') -----
newStack: stack
| oldStack diff |
oldStack := contextStack.
contextStack := stack.
(oldStack == nil or: [oldStack last ~~ stack last])
ifTrue: [contextStackList := contextStack collect: [:ctx | ctx printString].
^ self].
"May be able to re-use some of previous list"
diff := stack size - oldStack size.
contextStackList := diff <= 0
ifTrue: [contextStackList copyFrom: 1-diff to: oldStack size]
ifFalse: [diff > 1
ifTrue: [contextStack collect: [:ctx | ctx printString]]
ifFalse: [(Array with: stack first printString) , contextStackList]]!
----- Method: Debugger>>notifierButtonHeight (in category 'initialize') -----
notifierButtonHeight
^ 18!
----- Method: Debugger>>openFullNoSuspendLabel: (in category 'initialize') -----
openFullNoSuspendLabel: aString
"Create and schedule a full debugger with the given label. Do not terminate the current active process."
| oldContextStackIndex |
oldContextStackIndex := contextStackIndex.
self expandStack. "Sets contextStackIndex to zero."
ToolBuilder open: self label: aString.
self toggleContextStackIndex: oldContextStackIndex.!
----- Method: Debugger>>openNotifierContents:label: (in category 'initialize') -----
openNotifierContents: msgString label: label
"Create and schedule a notifier view with the given label and message. A notifier view shows just the message or the first several lines of the stack, with a menu that allows the user to open a full debugger if so desired."
"NOTE: When this method returns, a new process has been scheduled to run the windows, and thus this notifier, but the previous active porcess has not been suspended. The sender will do this."
| msg builder spec |
Sensor flushKeyboard.
savedCursor := Sensor currentCursor.
Sensor currentCursor: Cursor normal.
(label beginsWith: 'Space is low')
ifTrue: [msg := self lowSpaceChoices, (msgString ifNil: [''])]
ifFalse: [msg := msgString].
isolationHead ifNotNil:
["We have already revoked the isolation layer -- now jump to the parent project."
msg := self isolationRecoveryAdvice, msgString.
failedProject := Project current.
isolationHead parent enterForEmergencyRecovery].
builder := ToolBuilder default.
spec := self buildNotifierWith: builder label: label message: msg.
self expandStack.
builder open: spec.
errorWasInUIProcess := Project spawnNewProcessIfThisIsUI: interruptedProcess.
!
----- Method: Debugger>>optionalButtonPairs (in category 'initialize') -----
optionalButtonPairs
"Actually, return triples. Only the custom debugger-specific buttons are shown"
^ self customButtonSpecs!
----- Method: Debugger>>pc (in category 'code pane') -----
pc
^ self pcRange!
----- Method: Debugger>>pcRange (in category 'code pane') -----
pcRange
"Answer the indices in the source code for the method corresponding to
the selected context's program counter value."
(selectingPC and: [contextStackIndex ~= 0]) ifFalse:
[^1 to: 0].
self selectedContext isDead ifTrue:
[^1 to: 0].
^self selectedContext debuggerMap
rangeForPC: self selectedContext pc
contextIsActiveContext: contextStackIndex = 1!
----- Method: Debugger>>peelToFirst (in category 'context stack menu') -----
peelToFirst
"Peel the stack back to the second occurance of the currently selected message. Very useful for an infinite recursion. Gets back to the second call so you can see one complete recursion cycle, and how it was called at the beginning. Also frees a lot of space!!"
| ctxt |
contextStackIndex = 0 ifTrue: [^ Beeper beep].
"self okToChange ifFalse: [^ self]."
ctxt := interruptedProcess popTo: self selectedContext findSecondToOldestSimilarSender.
self resetContext: ctxt.
!
----- Method: Debugger>>perform:orSendTo: (in category 'code pane menu') -----
perform: selector orSendTo: otherTarget
"Selector was just chosen from a menu by a user. If can respond, then perform it on myself. If not, send it to otherTarget, presumably the editPane from which the menu was invoked."
| result |
(#(debug proceed) includes: selector) "When I am a notifier window"
ifTrue: [^ self perform: selector]
ifFalse: [result := super perform: selector orSendTo: otherTarget.
selector == #doIt ifTrue: [
result ~~ #failedDoit ifTrue: [self proceedValue: result]].
^ result]!
----- Method: Debugger>>populateImplementInMenu: (in category 'context stack menu') -----
populateImplementInMenu: aMenu
| msg |
msg := self selectedContext at: 1.
self selectedContext receiver class withAllSuperclasses do:
[:each |
aMenu add: each name target: self selector: #implement:inClass: argumentList: (Array with: msg with: each)].
^ aMenu
!
----- Method: Debugger>>preDebugButtonQuads (in category 'initialize') -----
preDebugButtonQuads
^Preferences eToyFriendly
ifTrue: [
{
{'Store log' translated. #storeLog. #blue. 'write a log of the encountered problem' translated}.
{'Abandon' translated. #abandon. #black. 'abandon this execution by closing this window' translated}.
{'Debug' translated. #debug. #red. 'bring up a debugger' translated}}]
ifFalse: [
{
{'Proceed' translated. #proceed. #blue. 'continue execution' translated}.
{'Abandon' translated. #abandon. #black. 'abandon this execution by closing this window' translated}.
{'Debug' translated. #debug. #red. 'bring up a debugger' translated}}]
!
----- Method: Debugger>>preDebugMessageString (in category 'toolbuilder') -----
preDebugMessageString
^ message ifNil: ['An error has occurred; you should probably just hit ''abandon''. Sorry!!'].!
----- Method: Debugger>>proceed (in category 'context stack menu') -----
proceed
"Proceed execution of the receiver's model, starting after the expression at
which an interruption occurred."
Smalltalk okayToProceedEvenIfSpaceIsLow ifTrue: [
self proceed: self topView].
!
----- Method: Debugger>>proceed: (in category 'context stack menu') -----
proceed: aTopView
"Proceed from the interrupted state of the currently selected context. The
argument is the topView of the receiver. That view is closed."
self okToChange ifFalse: [^ self].
self checkContextSelection.
self resumeProcess: aTopView!
----- Method: Debugger>>proceedValue (in category 'accessing') -----
proceedValue
"Answer the value to return to the selected context when the interrupted
process proceeds."
^proceedValue!
----- Method: Debugger>>proceedValue: (in category 'accessing') -----
proceedValue: anObject
"Set the value to be returned to the selected context when the interrupted
process proceeds."
proceedValue := anObject!
----- Method: Debugger>>process:controller:context: (in category 'private') -----
process: aProcess controller: aController context: aContext
^ self process: aProcess controller: aController context: aContext isolationHead: nil!
----- Method: Debugger>>process:controller:context:isolationHead: (in category 'private') -----
process: aProcess controller: aController context: aContext isolationHead: projectOrNil
super initialize.
Smalltalk at: #MessageTally ifPresentAndInMemory: [:c | c new close].
contents := nil.
interruptedProcess := aProcess.
interruptedController := aController.
contextStackTop := aContext.
self newStack: (contextStackTop stackOfSize: 1).
contextStackIndex := 1.
externalInterrupt := false.
selectingPC := true.
isolationHead := projectOrNil.
Smalltalk isMorphic ifTrue:
[errorWasInUIProcess := false]!
----- Method: Debugger>>receiver (in category 'accessing') -----
receiver
"Answer the receiver of the selected context, if any. Answer nil
otherwise."
contextStackIndex = 0
ifTrue: [^nil]
ifFalse: [^self selectedContext receiver]!
----- Method: Debugger>>receiverInspector (in category 'accessing') -----
receiverInspector
"Answer the instance of Inspector that is providing a view of the
variables of the selected context's receiver."
^receiverInspector!
----- Method: Debugger>>receiverInspectorObject:context: (in category 'accessing') -----
receiverInspectorObject: obj context: ctxt
"set context before object so it can refer to context when building field list"
receiverInspector context: ctxt.
receiverInspector object: obj.
!
----- Method: Debugger>>release (in category 'initialize') -----
release
self windowIsClosing.
super release.
!
----- Method: Debugger>>resetContext: (in category 'private') -----
resetContext: aContext
"Used when a new context becomes top-of-stack, for instance when the
method of the selected context is re-compiled, or the simulator steps or
returns to a new method. There is room for much optimization here, first
to save recomputing the whole stack list (and text), and secondly to avoid
recomposing all that text (by editing the paragraph instead of recreating it)."
| oldContext |
oldContext := self selectedContext.
contextStackTop := aContext.
self newStack: contextStackTop contextStack.
self changed: #contextStackList.
self contextStackIndex: 1 oldContextWas: oldContext.
self contentsChanged.
!
----- Method: Debugger>>restart (in category 'context stack menu') -----
restart
"Proceed from the initial state of the currently selected context. The
argument is a controller on a view of the receiver. That view is closed."
"Closing now depends on a preference #restartAlsoProceeds - hmm 9/7/2001 16:46"
| ctxt noUnwindError |
self okToChange ifFalse: [^ self].
self checkContextSelection.
ctxt := interruptedProcess popTo: self selectedContext.
noUnwindError := false.
ctxt == self selectedContext ifTrue: [
noUnwindError := true.
interruptedProcess restartTop; stepToSendOrReturn].
self resetContext: ctxt.
(Preferences restartAlsoProceeds and: [noUnwindError]) ifTrue: [self proceed].
!
----- Method: Debugger>>resumeProcess: (in category 'private') -----
resumeProcess: aTopView
Smalltalk isMorphic
ifFalse: [aTopView erase].
savedCursor
ifNotNil: [Sensor currentCursor: savedCursor].
isolationHead
ifNotNil: [failedProject enterForEmergencyRecovery.
isolationHead invoke.
isolationHead := nil].
interruptedProcess isTerminated ifFalse: [
Smalltalk isMorphic
ifTrue: [errorWasInUIProcess
ifTrue: [Project resumeProcess: interruptedProcess]
ifFalse: [interruptedProcess resume]]
ifFalse: [ScheduledControllers activeControllerNoTerminate: interruptedController andProcess: interruptedProcess]].
"if old process was terminated, just terminate current one"
interruptedProcess := nil.
"Before delete, so release doesn't terminate it"
Smalltalk isMorphic
ifTrue: [aTopView delete.
World displayWorld]
ifFalse: [aTopView controller closeAndUnscheduleNoErase].
Smalltalk installLowSpaceWatcher.
"restart low space handler"
errorWasInUIProcess == false
ifFalse: [Processor terminateActive]!
----- Method: Debugger>>returnValue (in category 'context stack menu') -----
returnValue
"Force a return of a given value to the previous context!!"
| previous selectedContext expression value |
contextStackIndex = 0 ifTrue: [^Beeper beep].
selectedContext := self selectedContext.
expression := UIManager default request: 'Enter expression for return value:'.
value := Compiler new
evaluate: expression
in: selectedContext
to: selectedContext receiver.
previous := selectedContext sender.
self resetContext: previous.
interruptedProcess popTo: previous value: value!
----- Method: Debugger>>runToSelection: (in category 'code pane menu') -----
runToSelection: selectionInterval
| currentContext |
self pc first >= selectionInterval first ifTrue: [ ^self ].
currentContext := self selectedContext.
[ currentContext == self selectedContext and: [ self pc first < selectionInterval first ] ] whileTrue: [ self doStep ].!
----- Method: Debugger>>selectPC (in category 'context stack menu') -----
selectPC
"Toggle the flag telling whether to automatically select the expression
currently being executed by the selected context."
selectingPC := selectingPC not!
----- Method: Debugger>>selectedClass (in category 'class list') -----
selectedClass
"Answer the class in which the currently selected context's method was
found."
^self selectedContext methodClass!
----- Method: Debugger>>selectedClassOrMetaClass (in category 'class list') -----
selectedClassOrMetaClass
"Answer the class in which the currently selected context's method was
found."
^self selectedClass!
----- Method: Debugger>>selectedContext (in category 'private') -----
selectedContext
contextStackIndex = 0
ifTrue: [^contextStackTop]
ifFalse: [^contextStack at: contextStackIndex]!
----- Method: Debugger>>selectedMessage (in category 'context stack (message list)') -----
selectedMessage
"Answer the source code of the currently selected context."
^contents := self selectedContext debuggerMap sourceText asText makeSelectorBold!
----- Method: Debugger>>selectedMessageCategoryName (in category 'message category list') -----
selectedMessageCategoryName
"Answer the name of the message category of the message of the
currently selected context."
^self selectedClass organization categoryOfElement: self selectedMessageName!
----- Method: Debugger>>selectedMessageName (in category 'context stack (message list)') -----
selectedMessageName
"Answer the message selector of the currently selected context.
If the method is unbound we can still usefully answer its old selector."
| selector |
selector := self selectedContext selector.
^(selector ~~ self selectedContext method selector
and: [selector beginsWith: 'DoIt'])
ifTrue: [self selectedContext method selector]
ifFalse: [selector]!
----- Method: Debugger>>send (in category 'context stack menu') -----
send
"Send the selected message in the accessed method, and take control in
the method invoked to allow further step or send."
self okToChange ifFalse: [^ self].
self checkContextSelection.
interruptedProcess step: self selectedContext.
self resetContext: interruptedProcess stepToSendOrReturn.
!
----- Method: Debugger>>step (in category 'dependents access') -----
step
"Update the inspectors."
receiverInspector ifNotNil: [receiverInspector step].
contextVariablesInspector ifNotNil: [contextVariablesInspector step].
!
----- Method: Debugger>>stepIntoBlock (in category 'context stack menu') -----
stepIntoBlock
"Send messages until you return to the present method context.
Used to step into a block in the method."
interruptedProcess stepToHome: self selectedContext.
self resetContext: interruptedProcess stepToSendOrReturn.!
----- Method: Debugger>>storeLog (in category 'notifier menu') -----
storeLog
| logFileName |
logFileName := Preferences debugLogTimestamp
ifTrue: ['SqueakDebug-' , Time totalSeconds printString , '.log']
ifFalse: ['SqueakDebug.log'].
Smalltalk logError: labelString printString inContext: contextStackTop to: logFileName
!
----- Method: Debugger>>tally (in category 'tally support') -----
tally
self getTextMorphWithSelection ifNotNilDo: [:o| o tallyIt] ifNil: [Beeper beep]
!
----- Method: Debugger>>toggleBreakOnEntry (in category 'breakpoints') -----
toggleBreakOnEntry
"Install or uninstall a halt-on-entry breakpoint"
| selectedMethod |
self selectedClassOrMetaClass isNil ifTrue:[^self].
selectedMethod := self selectedClassOrMetaClass >> self selectedMessageName.
selectedMethod hasBreakpoint
ifTrue:
[BreakpointManager unInstall: selectedMethod]
ifFalse:
[BreakpointManager
installInClass: self selectedClassOrMetaClass
selector: self selectedMessageName].!
----- Method: Debugger>>toggleContextStackIndex: (in category 'context stack (message list)') -----
toggleContextStackIndex: anInteger
"If anInteger is the same as the index of the selected context, deselect it.
Otherwise, the context whose index is anInteger becomes the selected
context."
self contextStackIndex:
(contextStackIndex = anInteger
ifTrue: [0]
ifFalse: [anInteger])
oldContextWas:
(contextStackIndex = 0
ifTrue: [nil]
ifFalse: [contextStack at: contextStackIndex])!
----- Method: Debugger>>up (in category 'context stack menu') -----
up
"move up the context stack to the next (enclosed) context"
contextStackIndex > 1 ifTrue: [self toggleContextStackIndex: contextStackIndex-1]!
----- Method: Debugger>>updateInspectors (in category 'dependents access') -----
updateInspectors
"Update the inspectors on the receiver's variables."
receiverInspector == nil ifFalse: [receiverInspector update].
contextVariablesInspector == nil ifFalse: [contextVariablesInspector update]!
----- Method: Debugger>>wantsAnnotationPane (in category 'toolbuilder') -----
wantsAnnotationPane
"Annotations don't look good in debugger. Suppress 'em."
^false!
----- Method: Debugger>>wantsOptionalButtons (in category 'initialize') -----
wantsOptionalButtons
"The debugger benefits so majorly from the optional buttons that we put them up regardless of the global setting. Some traditionalists will want to change this method manually!!"
^ true!
----- Method: Debugger>>wantsSteps (in category 'dependents access') -----
wantsSteps
^ true!
----- Method: Debugger>>where (in category 'context stack menu') -----
where
"Select the expression whose evaluation was interrupted."
selectingPC := true.
self contextStackIndex: contextStackIndex oldContextWas: self selectedContext
!
----- Method: Debugger>>windowIsClosing (in category 'initialize') -----
windowIsClosing
"My window is being closed; clean up. Restart the low space watcher."
interruptedProcess == nil ifTrue: [^ self].
interruptedProcess terminate.
interruptedProcess := nil.
interruptedController := nil.
contextStack := nil.
contextStackTop := nil.
receiverInspector := nil.
contextVariablesInspector := nil.
Smalltalk installLowSpaceWatcher. "restart low space handler"
!
CodeHolder subclass: #MethodHolder
instanceVariableNames: 'methodClass methodSelector'
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Base'!
----- Method: MethodHolder class>>isolatedCodePaneForClass:selector: (in category 'instance creation') -----
isolatedCodePaneForClass: aClass selector: aSelector
"Answer a MethodMorph on the given class and selector"
| aCodePane aMethodHolder |
aMethodHolder := self new.
aMethodHolder methodClass: aClass methodSelector: aSelector.
aCodePane := MethodMorph on: aMethodHolder text: #contents accept: #contents:notifying:
readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
aMethodHolder addDependent: aCodePane.
aCodePane borderWidth: 2; color: Color white.
aCodePane scrollBarOnLeft: false.
aCodePane width: 300.
^ aCodePane!
----- Method: MethodHolder class>>makeIsolatedCodePaneForClass:selector: (in category 'instance creation') -----
makeIsolatedCodePaneForClass: aClass selector: aSelector
"Create, and place in the morphic Hand, an isolated code pane bearing source code for the given class and selector"
(self isolatedCodePaneForClass: aClass selector: aSelector) openInHand!
----- Method: MethodHolder>>addModelMenuItemsTo:forMorph:hand: (in category 'menu') -----
addModelMenuItemsTo: aCustomMenu forMorph: aMorph hand: aHandMorph
aCustomMenu addLine.
aCustomMenu add: 'whose script is this?' translated target: self action: #identifyScript
!
----- Method: MethodHolder>>changeMethodSelectorTo: (in category 'miscellaneous') -----
changeMethodSelectorTo: aSelector
"Change my method selector as noted. Reset currentCompiledMethod"
methodSelector := aSelector.
currentCompiledMethod := methodClass compiledMethodAt: aSelector ifAbsent: [nil]!
----- Method: MethodHolder>>compiledMethod (in category 'miscellaneous') -----
compiledMethod
^ methodClass compiledMethodAt: methodSelector!
----- Method: MethodHolder>>contents (in category 'contents') -----
contents
"Answer the contents, with due respect for my contentsSymbol"
contents := methodClass sourceCodeAt: methodSelector ifAbsent: [''].
currentCompiledMethod := methodClass compiledMethodAt: methodSelector ifAbsent: [nil].
self showingDecompile ifTrue: [^ self decompiledSourceIntoContents].
self showingDocumentation ifTrue: [^ self commentContents].
^ contents := self sourceStringPrettifiedAndDiffed asText makeSelectorBoldIn: methodClass!
----- Method: MethodHolder>>contents:notifying: (in category 'contents') -----
contents: input notifying: aController
| selector |
(selector := methodClass parserClass new parseSelector: input asText) ifNil:
[self inform: 'Sorry - invalid format for the
method name and arguments -- cannot accept.'.
^ false].
selector == methodSelector ifFalse:
[self inform:
'You cannot change the name of
the method here -- it must continue
to be ', methodSelector.
^ false].
selector := methodClass
compile: input asText
classified: self selectedMessageCategoryName
notifying: aController.
selector == nil ifTrue: [^ false].
contents := input asString copy.
currentCompiledMethod := methodClass compiledMethodAt: methodSelector.
^ true!
----- Method: MethodHolder>>doItReceiver (in category 'menu') -----
doItReceiver
"If there is an instance associated with me, answer it, for true mapping of self. If not, then do what other code-bearing tools do, viz. give access to the class vars."
(self dependents detect: [:m | m isKindOf: MethodMorph]) ifNotNilDo:
[:mm | (mm owner isKindOf: ScriptEditorMorph) ifTrue:
[^ mm owner playerScripted]].
^ self selectedClass ifNil: [FakeClassPool new]!
----- Method: MethodHolder>>identifyScript (in category 'miscellaneous') -----
identifyScript
| msg aPlayer |
msg := methodClass isUniClass
ifTrue:
[aPlayer := methodClass someInstance.
aPlayer costume
ifNotNil:
['This holds code for a script
named ', methodSelector, ' belonging
to an object named ', aPlayer externalName]
ifNil:
['This formerly held code for a script
named ', methodSelector, ' for a Player
who once existed but now is moribund.']]
ifFalse:
['This holds code for the method
named ', methodSelector, '
for class ', methodClass name].
self inform: msg!
----- Method: MethodHolder>>methodClass:methodSelector: (in category 'miscellaneous') -----
methodClass: aClass methodSelector: aSelector
methodClass := aClass.
methodSelector := aSelector.
currentCompiledMethod := aClass compiledMethodAt: aSelector ifAbsent: [nil]!
----- Method: MethodHolder>>selectedClass (in category 'selection') -----
selectedClass
^ methodClass theNonMetaClass!
----- Method: MethodHolder>>selectedClassOrMetaClass (in category 'selection') -----
selectedClassOrMetaClass
^ methodClass!
----- Method: MethodHolder>>selectedMessageCategoryName (in category 'selection') -----
selectedMessageCategoryName
^ methodClass organization categoryOfElement: methodSelector!
----- Method: MethodHolder>>selectedMessageName (in category 'selection') -----
selectedMessageName
^ methodSelector!
----- Method: MethodHolder>>versions (in category 'miscellaneous') -----
versions
"Return a VersionsBrowser (containing a list of ChangeRecords) of older versions of this method."
^ VersionsBrowser new scanVersionsOf: self compiledMethod
class: self selectedClass
meta: methodClass isMeta
category: self selectedMessageCategoryName
"(classOfMethod whichCategoryIncludesSelector: selectorOfMethod)"
selector: methodSelector!
StringHolder subclass: #Inspector
instanceVariableNames: 'object selectionIndex timeOfLastListUpdate selectionUpdateTime context'
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Inspector'!
!Inspector commentStamp: '<historical>' prior: 0!
I represent a query path into the internal representation of an object. As a StringHolder, the string I represent is the value of the currently selected variable of the observed object.!
Inspector subclass: #BasicInspector
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Inspector'!
----- Method: BasicInspector>>inspect: (in category 'as yet unclassified') -----
inspect: anObject
"Initialize the receiver so that it is inspecting anObject. There is no
current selection."
self initialize.
object := anObject.
selectionIndex := 0.
contents := ''!
Inspector subclass: #CompiledMethodInspector
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Inspector'!
----- Method: CompiledMethodInspector>>contentsIsString (in category 'selecting') -----
contentsIsString
"Hacked so contents empty when deselected"
^ #(0 2 3) includes: selectionIndex!
----- Method: CompiledMethodInspector>>fieldList (in category 'accessing') -----
fieldList
| keys |
keys := OrderedCollection new.
keys add: 'self'.
keys add: 'all bytecodes'.
keys add: 'header'.
1 to: object numLiterals do: [ :i |
keys add: 'literal', i printString ].
object initialPC to: object size do: [ :i |
keys add: i printString ].
^ keys asArray
!
----- Method: CompiledMethodInspector>>selection (in category 'selecting') -----
selection
| bytecodeIndex |
selectionIndex = 0 ifTrue: [^ ''].
selectionIndex = 1 ifTrue: [^ object ].
selectionIndex = 2 ifTrue: [^ object symbolic].
selectionIndex = 3 ifTrue: [^ object headerDescription].
selectionIndex <= (object numLiterals + 3)
ifTrue: [ ^ object objectAt: selectionIndex - 2 ].
bytecodeIndex := selectionIndex - object numLiterals - 3.
^ object at: object initialPC + bytecodeIndex - 1!
----- Method: CompiledMethodInspector>>selectionUnmodifiable (in category 'selecting') -----
selectionUnmodifiable
"Answer if the current selected variable is unmodifiable via acceptance in the code pane. For most inspectors, no selection and a selection of self (selectionIndex = 1) are unmodifiable"
^ true!
Inspector subclass: #ContextVariablesInspector
instanceVariableNames: 'fieldList'
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Debugger'!
!ContextVariablesInspector commentStamp: '<historical>' prior: 0!
I represent a query path into the internal representation of a ContextPart. Typically this is a context at a point in the query path of a Debugger. As a StringHolder, the string I represent is the value of the currently selected variable of the observed temporary variable of the context.!
----- Method: ContextVariablesInspector>>doItContext (in category 'code') -----
doItContext
^object!
----- Method: ContextVariablesInspector>>doItReceiver (in category 'code') -----
doItReceiver
^object receiver!
----- Method: ContextVariablesInspector>>fieldList (in category 'accessing') -----
fieldList
"Refer to the comment in Inspector|fieldList."
object == nil ifTrue: [^Array with: 'thisContext'].
^fieldList ifNil:[fieldList := (Array with: 'thisContext' with: 'stack top' with: 'all temp vars') , object tempNames]!
----- Method: ContextVariablesInspector>>inspect: (in category 'accessing') -----
inspect: anObject
"Initialize the receiver so that it is inspecting anObject. There is no
current selection.
Because no object's inspectorClass method answers this class, it is OK for this method to
override Inspector >> inspect: "
fieldList := nil.
object := anObject.
self initialize.
!
----- Method: ContextVariablesInspector>>replaceSelectionValue: (in category 'selecting') -----
replaceSelectionValue: anObject
"Refer to the comment in Inspector|replaceSelectionValue:."
^selectionIndex = 1
ifTrue: [object]
ifFalse: [object namedTempAt: selectionIndex - 3 put: anObject]!
----- Method: ContextVariablesInspector>>selection (in category 'selecting') -----
selection
"Refer to the comment in Inspector|selection."
selectionIndex = 0 ifTrue:[^''].
selectionIndex = 1 ifTrue: [^object].
selectionIndex = 2 ifTrue: [^object stackPtr > 0 ifTrue: [object top]].
selectionIndex = 3 ifTrue: [^object tempsAndValues].
^object debuggerMap namedTempAt: selectionIndex - 3 in: object!
Inspector subclass: #DictionaryInspector
instanceVariableNames: 'keyArray'
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Inspector'!
----- Method: DictionaryInspector>>addEntry (in category 'menu') -----
addEntry
| newKey aKey |
newKey := UIManager default request:
'Enter new key, then type RETURN.
(Expression will be evaluated for value.)
Examples: #Fred ''a string'' 3+4'.
aKey := Compiler evaluate: newKey.
object at: aKey put: nil.
self calculateKeyArray.
selectionIndex := self numberOfFixedFields + (keyArray indexOf: aKey).
self changed: #inspectObject.
self changed: #selectionIndex.
self changed: #fieldList.
self update!
----- Method: DictionaryInspector>>addEntry: (in category 'selecting') -----
addEntry: aKey
object at: aKey put: nil.
self calculateKeyArray.
selectionIndex := self numberOfFixedFields + (keyArray indexOf: aKey).
self changed: #inspectObject.
self changed: #selectionIndex.
self changed: #fieldList.
self update!
----- Method: DictionaryInspector>>calculateKeyArray (in category 'selecting') -----
calculateKeyArray
"Recalculate the KeyArray from the object being inspected"
keyArray := object keysSortedSafely asArray.
selectionIndex := 0.
!
----- Method: DictionaryInspector>>contentsIsString (in category 'selecting') -----
contentsIsString
"Hacked so contents empty when deselected"
^ (selectionIndex = 0)!
----- Method: DictionaryInspector>>copyName (in category 'menu') -----
copyName
"Copy the name of the current variable, so the user can paste it into the
window below and work with is. If collection, do (xxx at: 1)."
| sel |
self selectionIndex <= self numberOfFixedFields
ifTrue: [super copyName]
ifFalse: [sel := String streamContents: [:strm |
strm nextPutAll: '(self at: '.
(keyArray at: selectionIndex - self numberOfFixedFields)
storeOn: strm.
strm nextPutAll: ')'].
Clipboard clipboardText: sel asText "no undo allowed"]!
----- Method: DictionaryInspector>>fieldList (in category 'accessing') -----
fieldList
^ self baseFieldList
, (keyArray collect: [:key | key printString])!
----- Method: DictionaryInspector>>fieldListMenu: (in category 'menu') -----
fieldListMenu: aMenu
^ aMenu labels:
'inspect
copy name
references
objects pointing to this value
senders of this key
refresh view
add key
rename key
remove
basic inspect'
lines: #(6 9)
selections: #(inspectSelection copyName selectionReferences objectReferencesToSelection sendersOfSelectedKey refreshView addEntry renameEntry removeSelection inspectBasic)
!
----- Method: DictionaryInspector>>initialize (in category 'initialize-release') -----
initialize
super initialize.
self calculateKeyArray!
----- Method: DictionaryInspector>>numberOfFixedFields (in category 'private') -----
numberOfFixedFields
^ 2 + object class instSize!
----- Method: DictionaryInspector>>refreshView (in category 'selecting') -----
refreshView
| i |
i := selectionIndex.
self calculateKeyArray.
selectionIndex := i.
self changed: #fieldList.
self changed: #contents.!
----- Method: DictionaryInspector>>removeSelection (in category 'menu') -----
removeSelection
selectionIndex = 0 ifTrue: [^ self changed: #flash].
object removeKey: (keyArray at: selectionIndex - self numberOfFixedFields).
selectionIndex := 0.
contents := ''.
self calculateKeyArray.
self changed: #inspectObject.
self changed: #selectionIndex.
self changed: #fieldList.
self changed: #selection.!
----- Method: DictionaryInspector>>renameEntry (in category 'menu') -----
renameEntry
| newKey aKey value |
value := object at: (keyArray at: selectionIndex - self numberOfFixedFields).
newKey := UIManager default request:
'Enter new key, then type RETURN.
(Expression will be evaluated for value.)
Examples: #Fred ''a string'' 3+4'
initialAnswer: (keyArray at: selectionIndex - self numberOfFixedFields) printString.
aKey := Compiler evaluate: newKey.
object removeKey: (keyArray at: selectionIndex - self numberOfFixedFields).
object at: aKey put: value.
self calculateKeyArray.
selectionIndex := self numberOfFixedFields + (keyArray indexOf: aKey).
self changed: #selectionIndex.
self changed: #inspectObject.
self changed: #fieldList.
self update!
----- Method: DictionaryInspector>>replaceSelectionValue: (in category 'selecting') -----
replaceSelectionValue: anObject
selectionIndex <= self numberOfFixedFields
ifTrue: [^ super replaceSelectionValue: anObject].
^ object
at: (keyArray at: selectionIndex - self numberOfFixedFields)
put: anObject!
----- Method: DictionaryInspector>>selection (in category 'selecting') -----
selection
selectionIndex <= (self numberOfFixedFields) ifTrue: [^ super selection].
^ object at: (keyArray at: selectionIndex - self numberOfFixedFields) ifAbsent:[nil]!
----- Method: DictionaryInspector>>selectionReferences (in category 'menu') -----
selectionReferences
"Create a browser on all references to the association of the current selection."
self selectionIndex = 0 ifTrue: [^ self changed: #flash].
object class == MethodDictionary ifTrue: [^ self changed: #flash].
self systemNavigation browseAllCallsOn: (object associationAt: (keyArray at: selectionIndex - self numberOfFixedFields)).
!
----- Method: DictionaryInspector>>sendersOfSelectedKey (in category 'menu') -----
sendersOfSelectedKey
"Create a browser on all senders of the selected key"
| aKey |
self selectionIndex = 0
ifTrue: [^ self changed: #flash].
((aKey := keyArray at: selectionIndex - self numberOfFixedFields) isSymbol)
ifFalse: [^ self changed: #flash].
SystemNavigation default browseAllCallsOn: aKey!
Inspector subclass: #ExternalStructureInspector
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Inspector'!
----- Method: ExternalStructureInspector>>fieldList (in category 'accessing') -----
fieldList
^ (Array with: 'self: ', object defaultLabelForInspector with: 'all inst vars'), self recordFieldList!
----- Method: ExternalStructureInspector>>recordFieldList (in category 'accessing') -----
recordFieldList
| fields |
fields := object class fields.
(fields first isKindOf: Array) ifFalse: [fields := Array with: fields].
^fields collect: [ :field | field first ] thenSelect: [:name | name notNil]!
----- Method: ExternalStructureInspector>>replaceSelectionValue: (in category 'selecting') -----
replaceSelectionValue: anObject
"Add colon to fieldname to get setter selector, and send it to object with the argument.
Refer to the comment in Inspector|replaceSelectionValue:."
selectionIndex = 1
ifTrue: [^object]
ifFalse: [^object perform: ((self fieldList at: selectionIndex), ':') asSymbol with: anObject]!
----- Method: ExternalStructureInspector>>selection (in category 'selecting') -----
selection
"Refer to the comment in Inspector|selection."
selectionIndex = 0 ifTrue:[^object printString].
selectionIndex = 1 ifTrue: [^object].
selectionIndex = 2 ifTrue:[^object longPrintString].
selectionIndex > 2
ifTrue: [^object perform: (self fieldList at: selectionIndex)]!
----- Method: Inspector class>>inspect: (in category 'instance creation') -----
inspect: anObject
"Answer an instance of me to provide an inspector for anObject."
"We call basicNew to avoid a premature initialization; the instance method
inspect: anObject will do a self initialize."
^self basicNew inspect: anObject!
----- Method: Inspector class>>openOn: (in category 'instance creation') -----
openOn: anObject
"Create and schedule an instance of me on the model, anInspector. "
^ self openOn: anObject withEvalPane: true!
----- Method: Inspector class>>openOn:withEvalPane: (in category 'instance creation') -----
openOn: anObject withEvalPane: withEval
"Create and schedule an instance of me on the model, anInspector. "
^ self openOn: anObject withEvalPane: withEval withLabel: anObject defaultLabelForInspector!
----- Method: Inspector class>>openOn:withEvalPane:withLabel: (in category 'instance creation') -----
openOn: anObject withEvalPane: withEval withLabel: label
^ToolBuilder open: (self inspect: anObject) label: label!
----- Method: Inspector>>accept: (in category 'selecting') -----
accept: aString
| result |
result := self doItReceiver class evaluatorClass new
evaluate: (ReadStream on: aString)
in: self doItContext
to: self doItReceiver
notifying: nil "fix this"
ifFail: [self changed: #flash.
^ false].
result == #failedDoit ifTrue: [^ false].
self replaceSelectionValue: result.
self changed: #contents.
^ true!
----- Method: Inspector>>addCollectionItemsTo: (in category 'menu commands') -----
addCollectionItemsTo: aMenu
"If the current selection is an appropriate collection, add items to aMenu that cater to that kind of selection"
| sel |
((((sel := self selection) isMemberOf: Array) or: [sel isMemberOf: OrderedCollection]) and:
[sel size > 0]) ifTrue: [
aMenu addList: #(
('inspect element...' inspectElement))].
(sel isKindOf: MorphExtension) ifTrue: [
aMenu addList: #(
('inspect property...' inspectElement))].!
----- Method: Inspector>>baseFieldList (in category 'accessing') -----
baseFieldList
"Answer an Array consisting of 'self'
and the instance variable names of the inspected object."
^ (Array with: 'self' with: 'all inst vars')
, object class allInstVarNames!
----- Method: Inspector>>browseFullProtocol (in category 'menu commands') -----
browseFullProtocol
"Open up a protocol-category browser on the value of the receiver's current selection. If in mvc, an old-style protocol browser is opened instead."
| objectToRepresent |
Smalltalk isMorphic ifFalse: [^ self spawnProtocol].
objectToRepresent := self selectionIndex == 0 ifTrue: [object] ifFalse: [self selection].
InstanceBrowser new openOnObject: objectToRepresent showingSelector: nil!
----- Method: Inspector>>buildCodePaneWith: (in category 'toolbuilder') -----
buildCodePaneWith: builder
| textSpec |
textSpec := builder pluggableTextSpec new.
textSpec
model: self;
getText: #trash;
setText: #trash:;
selection: #contentsSelection;
menu: #codePaneMenu:shifted:;
askBeforeDiscardingEdits: false.
^textSpec!
----- Method: Inspector>>buildFieldListWith: (in category 'toolbuilder') -----
buildFieldListWith: builder
| listSpec |
listSpec := builder pluggableListSpec new.
listSpec
model: self;
list: #fieldList;
getIndex: #selectionIndex;
setIndex: #toggleIndex:;
menu: #fieldListMenu:;
keyPress: #inspectorKey:from:.
^listSpec!
----- Method: Inspector>>buildValuePaneWith: (in category 'toolbuilder') -----
buildValuePaneWith: builder
| textSpec |
textSpec := builder pluggableTextSpec new.
textSpec
model: self;
getText: #contents;
setText: #accept:;
selection: #contentsSelection;
menu: #codePaneMenu:shifted:.
^textSpec!
----- Method: Inspector>>buildWith: (in category 'toolbuilder') -----
buildWith: builder
"Inspector openOn: SystemOrganization"
| windowSpec |
windowSpec := self buildWindowWith: builder specs: {
(0 at 0 corner: 0.3 at 0.7) -> [self buildFieldListWith: builder].
(0.3 at 0.0corner: 1 at 0.7) -> [self buildValuePaneWith: builder].
(0.0 at 0.7corner: 1 at 1) -> [self buildCodePaneWith: builder].
}.
^builder build: windowSpec!
----- Method: Inspector>>chasePointers (in category 'menu commands') -----
chasePointers
| selected saved |
self selectionIndex == 0 ifTrue: [^ self changed: #flash].
selected := self selection.
saved := self object.
[self object: nil.
(Smalltalk includesKey: #PointerFinder)
ifTrue: [PointerFinder on: selected]
ifFalse: [self inspectPointers]]
ensure: [self object: saved]!
----- Method: Inspector>>classOfSelection (in category 'menu commands') -----
classOfSelection
"Answer the class of the receiver's current selection"
self selectionUnmodifiable ifTrue: [^ object class].
^ self selection class!
----- Method: Inspector>>classVarRefs (in category 'menu commands') -----
classVarRefs
"Request a browser of methods that store into a chosen instance variable"
| aClass |
(aClass := self classOfSelection) ifNotNil:
[self systemNavigation browseClassVarRefs: aClass].
!
----- Method: Inspector>>contentsIsString (in category 'selecting') -----
contentsIsString
"Hacked so contents empty when deselected and = long printString when item 2"
^ (selectionIndex = 2) | (selectionIndex = 0)!
----- Method: Inspector>>context: (in category 'accessing') -----
context: ctxt
"Set the context of inspection. Currently only used by my subclass ClosureEnvInspector. The inst var is here because we do primitiveChangeClassTo: between subclasses (see inspect:) between different subclasses, but also context could be used as a general concept in all inspectors"
context := ctxt!
----- Method: Inspector>>convertToCurrentVersion:refStream: (in category 'object fileIn') -----
convertToCurrentVersion: varDict refStream: smartRefStrm
timeOfLastListUpdate ifNil: [timeOfLastListUpdate := 0].
^super convertToCurrentVersion: varDict refStream: smartRefStrm.
!
----- Method: Inspector>>copyName (in category 'menu commands') -----
copyName
"Copy the name of the current variable, so the user can paste it into the
window below and work with is. If collection, do (xxx at: 1)."
| sel aClass variableNames |
self selectionUnmodifiable
ifTrue: [^ self changed: #flash].
aClass := self object class.
variableNames := aClass allInstVarNames.
(aClass isVariable and: [selectionIndex > (variableNames size + 2)])
ifTrue: [sel := '(self basicAt: ' , (selectionIndex - (variableNames size + 2)) asString , ')']
ifFalse: [sel := variableNames at: selectionIndex - 2].
(self selection isKindOf: Collection)
ifTrue: [sel := '(' , sel , ' at: 1)'].
Clipboard clipboardText: sel asText!
----- Method: Inspector>>defsOfSelection (in category 'menu commands') -----
defsOfSelection
"Open a browser on all defining references to the selected instance variable, if that's what currently selected. "
| aClass sel |
self selectionUnmodifiable ifTrue: [^ self changed: #flash].
(aClass := self object class) isVariable ifTrue: [^ self changed: #flash].
sel := aClass allInstVarNames at: self selectionIndex - 2.
self systemNavigation browseAllStoresInto: sel from: aClass!
----- Method: Inspector>>doItReceiver (in category 'code') -----
doItReceiver
"Answer the object that should be informed of the result of evaluating a
text selection."
^object!
----- Method: Inspector>>explorePointers (in category 'menu commands') -----
explorePointers
PointerExplorer new openExplorerFor: self selection!
----- Method: Inspector>>exploreSelection (in category 'menu commands') -----
exploreSelection
self selectionIndex = 0 ifTrue: [^ self changed: #flash].
^ self selection explore!
----- Method: Inspector>>fieldList (in category 'accessing') -----
fieldList
"Answer the base field list plus an abbreviated list of indices."
object class isVariable ifFalse: [^ self baseFieldList].
^ self baseFieldList ,
(object basicSize <= (self i1 + self i2)
ifTrue: [(1 to: object basicSize)
collect: [:i | i printString]]
ifFalse: [(1 to: self i1) , (object basicSize-(self i2-1) to: object basicSize)
collect: [:i | i printString]])!
----- Method: Inspector>>fieldListMenu: (in category 'menu commands') -----
fieldListMenu: aMenu
"Arm the supplied menu with items for the field-list of the receiver"
Smalltalk isMorphic ifTrue:
[aMenu addStayUpItemSpecial].
aMenu addList: #(
('inspect (i)' inspectSelection)
('explore (I)' exploreSelection)).
self addCollectionItemsTo: aMenu.
aMenu addList: #(
-
('method refs to this inst var' referencesToSelection)
('methods storing into this inst var' defsOfSelection)
('objects pointing to this value' objectReferencesToSelection)
('chase pointers' chasePointers)
('explore pointers' explorePointers)
-
('browse full (b)' browseMethodFull)
('browse class' browseClass)
('browse hierarchy (h)' classHierarchy)
('browse protocol (p)' browseFullProtocol)
-
('inst var refs...' browseInstVarRefs)
('inst var defs...' browseInstVarDefs)
('class var refs...' classVarRefs)
('class variables' browseClassVariables)
('class refs (N)' browseClassRefs)
-
('copy name (c)' copyName)
('basic inspect' inspectBasic)).
Smalltalk isMorphic ifTrue:
[aMenu addList: #(
-
('tile for this value (t)' tearOffTile)
('viewer for this value (v)' viewerForValue))].
^ aMenu
" -
('alias for this value' aliasForValue)
('watcher for this slot' watcherForSlot)"
!
----- Method: Inspector>>i1 (in category 'accessing') -----
i1
"This is the max index shown before skipping to the
last i2 elements of very long arrays"
^ 100!
----- Method: Inspector>>i2 (in category 'accessing') -----
i2
"This is the number of elements to show at the end
of very long arrays"
^ 10!
----- Method: Inspector>>initialExtent (in category 'accessing') -----
initialExtent
"Answer the desired extent for the receiver when it is first opened on the screen. "
^ 250 @ 200!
----- Method: Inspector>>initialize (in category 'initialize-release') -----
initialize
selectionIndex := 0.
super initialize!
----- Method: Inspector>>inspect: (in category 'initialize-release') -----
inspect: anObject
"Initialize the receiver so that it is inspecting anObject. There is no current selection.
Normally the receiver will be of the correct class (as defined by anObject inspectorClass),
because it will have just been created by sedning inspect to anObject. However, the
debugger uses two embedded inspectors, which are re-targetted on the current receiver
each time the stack frame changes. The left-hand inspector in the debugger has its
class changed by the code here. Care should be taken if this method is overridden to
ensure that the overriding code calls 'super inspect: anObject', or otherwise ensures that
the class of these embedded inspectors are changed back."
| c |
c := anObject inspectorClass.
(self class ~= c and: [self class format = c format]) ifTrue: [
self primitiveChangeClassTo: c basicNew].
"Set 'object' before sending the initialize message, because some implementations
of initialize (e.g., in DictionaryInspector) require 'object' to be non-nil."
object := anObject.
self initialize!
----- Method: Inspector>>inspectBasic (in category 'menu commands') -----
inspectBasic
"Bring up a non-special inspector"
selectionIndex = 0 ifTrue: [^ object basicInspect].
self selection basicInspect!
----- Method: Inspector>>inspectElement (in category 'menu commands') -----
inspectElement
| sel selSize countString count nameStrs |
"Create and schedule an Inspector on an element of the receiver's model's currently selected collection."
self selectionIndex = 0 ifTrue: [^ self changed: #flash].
((sel := self selection) isKindOf: SequenceableCollection) ifFalse:
[(sel isKindOf: MorphExtension) ifTrue: [^ sel inspectElement].
^ sel inspect].
(selSize := sel size) == 1 ifTrue: [^ sel first inspect].
selSize <= 20 ifTrue:
[nameStrs := (1 to: selSize) asArray collect: [:ii |
ii printString, ' ', (((sel at: ii) printStringLimitedTo: 25) replaceAll: Character cr with: Character space)].
count := UIManager default chooseFrom: (nameStrs substrings) title: 'which element?'.
count = 0 ifTrue: [^ self].
^ (sel at: count) inspect].
countString := UIManager default request: 'Which element? (1 to ', selSize printString, ')' initialAnswer: '1'.
countString isEmptyOrNil ifTrue: [^ self].
count := Integer readFrom: (ReadStream on: countString).
(count > 0 and: [count <= selSize])
ifTrue: [(sel at: count) inspect]
ifFalse: [Beeper beep]!
----- Method: Inspector>>inspectSelection (in category 'menu commands') -----
inspectSelection
"Create and schedule an Inspector on the receiver's model's currently selected object."
self selectionIndex = 0 ifTrue: [^ self changed: #flash].
self selection inspect.
^ self selection!
----- Method: Inspector>>inspectorKey:from: (in category 'menu commands') -----
inspectorKey: aChar from: view
"Respond to a Command key issued while the cursor is over my field list"
aChar == $i ifTrue: [^ self selection inspect].
aChar == $I ifTrue: [^ self selection explore].
aChar == $b ifTrue: [^ self browseMethodFull].
aChar == $h ifTrue: [^ self classHierarchy].
aChar == $c ifTrue: [^ self copyName].
aChar == $p ifTrue: [^ self browseFullProtocol].
aChar == $N ifTrue: [^ self browseClassRefs].
aChar == $t ifTrue: [^ self tearOffTile].
aChar == $v ifTrue: [^ self viewerForValue].
^ self arrowKey: aChar from: view!
----- Method: Inspector>>modelWakeUpIn: (in category 'accessing') -----
modelWakeUpIn: aWindow
| newText |
self updateListsAndCodeIn: aWindow.
newText := self contentsIsString
ifTrue: [newText := self selection]
ifFalse: ["keep it short to reduce time to compute it"
self selectionPrintString ].
newText = contents ifFalse:
[contents := newText.
self changed: #contents]!
----- Method: Inspector>>noteSelectionIndex:for: (in category 'accessing') -----
noteSelectionIndex: anInteger for: aSymbol
aSymbol == #fieldList
ifTrue:
[selectionIndex := anInteger]!
----- Method: Inspector>>object (in category 'accessing') -----
object
"Answer the object being inspected by the receiver."
^object!
----- Method: Inspector>>object: (in category 'accessing') -----
object: anObject
"Set anObject to be the object being inspected by the receiver."
| oldIndex |
anObject == object
ifTrue: [self update]
ifFalse:
[oldIndex := selectionIndex <= 2 ifTrue: [selectionIndex] ifFalse: [0].
self inspect: anObject.
oldIndex := oldIndex min: self fieldList size.
self changed: #inspectObject.
oldIndex > 0
ifTrue: [self toggleIndex: oldIndex].
self changed: #fieldList.
self changed: #contents]!
----- Method: Inspector>>objectReferencesToSelection (in category 'menu commands') -----
objectReferencesToSelection
"Open a list inspector on all the objects that point to the value of the selected instance variable, if any. "
self selectionIndex == 0 ifTrue: [^ self changed: #flash].
self systemNavigation
browseAllObjectReferencesTo: self selection
except: (Array with: self object)
ifNone: [:obj | self changed: #flash].
!
----- Method: Inspector>>printStringErrorText (in category 'private') -----
printStringErrorText
| nm |
nm := self selectionIndex < 3
ifTrue: ['self']
ifFalse: [self selectedSlotName].
^ ('<error in printString: evaluate "' , nm , ' printString" to debug>') asText.!
----- Method: Inspector>>referencesToSelection (in category 'menu commands') -----
referencesToSelection
"Open a browser on all references to the selected instance variable, if that's what currently selected. 1/25/96 sw"
| aClass sel |
self selectionUnmodifiable ifTrue: [^ self changed: #flash].
(aClass := self object class) isVariable ifTrue: [^ self changed: #flash].
sel := aClass allInstVarNames at: self selectionIndex - 2.
self systemNavigation browseAllAccessesTo: sel from: aClass!
----- Method: Inspector>>replaceSelectionValue: (in category 'selecting') -----
replaceSelectionValue: anObject
"The receiver has a list of variables of its inspected object. One of these
is selected. The value of the selected variable is set to the value,
anObject."
| basicIndex si |
selectionIndex <= 2 ifTrue: [
self toggleIndex: (si := selectionIndex).
self toggleIndex: si.
^ object].
object class isVariable
ifFalse: [^ object instVarAt: selectionIndex - 2 put: anObject].
basicIndex := selectionIndex - 2 - object class instSize.
(object basicSize <= (self i1 + self i2) or: [basicIndex <= self i1])
ifTrue: [^object basicAt: basicIndex put: anObject]
ifFalse: [^object basicAt: object basicSize - (self i1 + self i2) + basicIndex
put: anObject]!
----- Method: Inspector>>selectedClass (in category 'accessing') -----
selectedClass
"Answer the class of the receiver's current selection"
self selectionUnmodifiable ifTrue: [^ object class].
^ self selection class!
----- Method: Inspector>>selectedSlotName (in category 'selecting') -----
selectedSlotName
^ self fieldList at: self selectionIndex ifAbsent: []!
----- Method: Inspector>>selection (in category 'selecting') -----
selection
"The receiver has a list of variables of its inspected object.
One of these is selected. Answer the value of the selected variable."
| basicIndex |
selectionIndex = 0 ifTrue: [^ ''].
selectionIndex = 1 ifTrue: [^ object].
selectionIndex = 2 ifTrue: [^ object longPrintStringLimitedTo: 20000].
(selectionIndex - 2) <= object class instSize
ifTrue: [^ object instVarAt: selectionIndex - 2].
basicIndex := selectionIndex - 2 - object class instSize.
(object basicSize <= (self i1 + self i2) or: [basicIndex <= self i1])
ifTrue: [^ object basicAt: basicIndex]
ifFalse: [^ object basicAt: object basicSize - (self i1 + self i2) + basicIndex]!
----- Method: Inspector>>selectionIndex (in category 'selecting') -----
selectionIndex
"The receiver has a list of variables of its inspected object. One of these
is selected. Answer the index into the list of the selected variable."
^selectionIndex!
----- Method: Inspector>>selectionPrintString (in category 'selecting') -----
selectionPrintString
| text |
selectionUpdateTime := [text := [self selection printStringLimitedTo: 5000]
on: Error
do: [text := self printStringErrorText.
text
addAttribute: TextColor red
from: 1
to: text size.
text]] timeToRun.
^ text!
----- Method: Inspector>>selectionUnmodifiable (in category 'selecting') -----
selectionUnmodifiable
"Answer if the current selected variable is modifiable via acceptance in the code pane. For most inspectors, no selection and a selection of 'self' (selectionIndex = 1) and 'all inst vars' (selectionIndex = 2) are unmodifiable"
^ selectionIndex <= 2!
----- Method: Inspector>>spawnFullProtocol (in category 'menu commands') -----
spawnFullProtocol
"Spawn a window showing full protocol for the receiver's selection"
| objectToRepresent |
objectToRepresent := self selectionIndex == 0 ifTrue: [object] ifFalse: [self selection].
ProtocolBrowser openFullProtocolForClass: objectToRepresent class!
----- Method: Inspector>>spawnProtocol (in category 'menu commands') -----
spawnProtocol
"Spawn a protocol on browser on the receiver's selection"
| objectToRepresent |
objectToRepresent := self selectionIndex == 0 ifTrue: [object] ifFalse: [self selection].
ProtocolBrowser openSubProtocolForClass: objectToRepresent class!
----- Method: Inspector>>stepAt:in: (in category 'stepping') -----
stepAt: millisecondClockValue in: aWindow
| newText |
(Preferences smartUpdating and: [(millisecondClockValue - self timeOfLastListUpdate) > 8000]) "Not more often than once every 8 seconds"
ifTrue:
[self updateListsAndCodeIn: aWindow.
timeOfLastListUpdate := millisecondClockValue].
newText := self contentsIsString
ifTrue: [self selection]
ifFalse: ["keep it short to reduce time to compute it"
self selectionPrintString ].
newText = contents ifFalse:
[contents := newText.
self changed: #contents]!
----- Method: Inspector>>stepTimeIn: (in category 'accessing') -----
stepTimeIn: aSystemWindow
^ (selectionUpdateTime ifNil: [0]) * 10 max: 1000!
----- Method: Inspector>>timeOfLastListUpdate (in category 'accessing') -----
timeOfLastListUpdate
^ timeOfLastListUpdate ifNil: [timeOfLastListUpdate := 0]!
----- Method: Inspector>>toggleIndex: (in category 'selecting') -----
toggleIndex: anInteger
"The receiver has a list of variables of its inspected object. One of these
is selected. If anInteger is the index of this variable, then deselect it.
Otherwise, make the variable whose index is anInteger be the selected
item."
selectionUpdateTime := 0.
selectionIndex = anInteger
ifTrue:
["same index, turn off selection"
selectionIndex := 0.
contents := '']
ifFalse:
["different index, new selection"
selectionIndex := anInteger.
self contentsIsString
ifTrue: [contents := self selection]
ifFalse: [contents := self selectionPrintString]].
self changed: #selection.
self changed: #contents.
self changed: #selectionIndex.!
----- Method: Inspector>>trash (in category 'accessing') -----
trash
"What goes in the bottom pane"
^ ''!
----- Method: Inspector>>trash: (in category 'accessing') -----
trash: newText
"Don't save it"
^ true!
----- Method: Inspector>>update (in category 'accessing') -----
update
"Reshow contents, assuming selected value may have changed."
selectionIndex = 0
ifFalse:
[self contentsIsString
ifTrue: [contents := self selection]
ifFalse: [contents := self selectionPrintString].
self changed: #contents.
self changed: #selection.
self changed: #selectionIndex]!
----- Method: Inspector>>viewerForValue (in category 'menu commands') -----
viewerForValue
"Open up a viewer on the value of the receiver's current selection"
| objectToRepresent |
objectToRepresent := self selectionIndex == 0 ifTrue: [object] ifFalse: [self selection].
objectToRepresent beViewed
!
----- Method: Inspector>>wantsSteps (in category 'accessing') -----
wantsSteps
^ true!
Inspector subclass: #InspectorBrowser
instanceVariableNames: 'fieldList msgList msgListIndex'
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Inspector'!
----- Method: InspectorBrowser class>>openAsMorphOn: (in category 'as yet unclassified') -----
openAsMorphOn: anObject
"(InspectorBrowser openAsMorphOn: SystemOrganization) openInMVC"
| window inspector |
inspector := self inspect: anObject.
window := (SystemWindow labelled: anObject defaultLabelForInspector)
model: inspector.
window addMorph: (PluggableListMorph on: inspector list: #fieldList
selected: #selectionIndex changeSelected: #toggleIndex: menu: #fieldListMenu:)
frame: (0 at 0 corner: 0.3 at 0.5).
window addMorph: (PluggableTextMorph on: inspector text: #contents accept: #accept:
readSelection: nil menu: #codePaneMenu:shifted:)
frame: (0.3 at 0 corner: 1.0 at 0.5).
window addMorph: (PluggableListMorph on: inspector list: #msgList
selected: #msgListIndex changeSelected: #msgListIndex: menu: #msgListMenu:)
frame: (0 at 0.5 corner: 0.3 at 1.0).
window addMorph: (PluggableTextMorph on: inspector text: #msgText accept: #msgAccept:from:
readSelection: nil menu: #msgPaneMenu:shifted:)
frame: (0.3 at 0.5 corner: 1.0 at 1.0).
window setUpdatablePanesFrom: #(fieldList msgList).
window position: 16 at 0. "Room for scroll bar."
^ window!
----- Method: InspectorBrowser>>fieldList (in category 'as yet unclassified') -----
fieldList
fieldList ifNotNil: [^ fieldList].
^ (fieldList := super fieldList)!
----- Method: InspectorBrowser>>initialize (in category 'initialize-release') -----
initialize
super initialize.
fieldList := nil.
msgListIndex := 0.
self changed: #msgText
!
----- Method: InspectorBrowser>>inspect: (in category 'initialize-release') -----
inspect: anObject
"Initialize the receiver so that it is inspecting anObject. There is no current selection.
Overriden so that my class is not changed to 'anObject inspectorClass'."
object := anObject.
self initialize
!
----- Method: InspectorBrowser>>msgAccept:from: (in category 'as yet unclassified') -----
msgAccept: newText from: editor
| category |
category := msgListIndex = 0
ifTrue: [ClassOrganizer default]
ifFalse: [object class organization categoryOfElement: (msgList at: msgListIndex)].
^ (object class compile: newText classified: category notifying: editor) ~~ nil!
----- Method: InspectorBrowser>>msgList (in category 'messages') -----
msgList
msgList ifNotNil: [^ msgList].
^ (msgList := object class selectors asSortedArray)!
----- Method: InspectorBrowser>>msgListIndex (in category 'as yet unclassified') -----
msgListIndex
^msgListIndex!
----- Method: InspectorBrowser>>msgListIndex: (in category 'as yet unclassified') -----
msgListIndex: anInteger
"A selection has been made in the message pane"
msgListIndex := anInteger.
self changed: #msgText.!
----- Method: InspectorBrowser>>msgListMenu: (in category 'messages') -----
msgListMenu: aMenu
^ aMenu labels: 'Not yet implemented' lines: #(0) selections: #(flash)!
----- Method: InspectorBrowser>>msgPaneMenu:shifted: (in category 'as yet unclassified') -----
msgPaneMenu: aMenu shifted: shifted
^ aMenu labels:
'find...(f)
find again (g)
set search string (h)
do again (j)
undo (z)
copy (c)
cut (x)
paste (v)
do it (d)
print it (p)
inspect it (i)
accept (s)
cancel (l)'
lines: #(0 3 5 8 11)
selections: #(find findAgain setSearchString again undo copySelection cut paste doIt printIt inspectIt accept cancel)!
----- Method: InspectorBrowser>>msgText (in category 'as yet unclassified') -----
msgText
msgListIndex = 0 ifTrue: [^ nil].
^ object class sourceCodeAt: (msgList at: msgListIndex)!
----- Method: InspectorBrowser>>step (in category 'as yet unclassified') -----
step
| list fieldString msg |
(list := super fieldList) = fieldList ifFalse:
[fieldString := selectionIndex > 0 ifTrue: [fieldList at: selectionIndex] ifFalse: [nil].
fieldList := list.
selectionIndex := fieldList indexOf: fieldString ifAbsent: [0].
self changed: #fieldList.
self changed: #selectionIndex].
list := msgList. msgList := nil. "force recomputation"
list = self msgList ifFalse:
[msg := msgListIndex > 0 ifTrue: [list at: msgListIndex] ifFalse: [nil].
msgListIndex := msgList indexOf: msg ifAbsent: [0].
self changed: #msgList.
self changed: #msgListIndex].
super step!
----- Method: InspectorBrowser>>wantsSteps (in category 'as yet unclassified') -----
wantsSteps
^ true!
Inspector subclass: #OrderedCollectionInspector
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Inspector'!
----- Method: OrderedCollectionInspector>>fieldList (in category 'as yet unclassified') -----
fieldList
object ifNil: [ ^ OrderedCollection new].
^ self baseFieldList ,
(object size <= (self i1 + self i2)
ifTrue: [(1 to: object size)
collect: [:i | i printString]]
ifFalse: [(1 to: self i1) , (object size-(self i2-1) to: object size)
collect: [:i | i printString]])
"
OrderedCollection new inspect
(OrderedCollection newFrom: #(3 5 7 123)) inspect
(OrderedCollection newFrom: (1 to: 1000)) inspect
"!
----- Method: OrderedCollectionInspector>>replaceSelectionValue: (in category 'as yet unclassified') -----
replaceSelectionValue: anObject
"The receiver has a list of variables of its inspected object. One of these
is selected. The value of the selected variable is set to the value, anObject."
(selectionIndex - 2) <= object class instSize
ifTrue: [^ super replaceSelectionValue: anObject].
object at: self selectedObjectIndex put: anObject!
----- Method: OrderedCollectionInspector>>selectedObjectIndex (in category 'as yet unclassified') -----
selectedObjectIndex
"Answer the index of the inspectee's collection that the current selection refers to."
| basicIndex |
basicIndex := selectionIndex - 2 - object class instSize.
^ (object size <= (self i1 + self i2) or: [basicIndex <= self i1])
ifTrue: [basicIndex]
ifFalse: [object size - (self i1 + self i2) + basicIndex]!
----- Method: OrderedCollectionInspector>>selection (in category 'as yet unclassified') -----
selection
"The receiver has a list of variables of its inspected object.
One of these is selected. Answer the value of the selected variable."
(selectionIndex - 2) <= object class instSize
ifTrue: [^ super selection].
^ object at: self selectedObjectIndex!
Inspector subclass: #SetInspector
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Inspector'!
!SetInspector commentStamp: '<historical>' prior: 0!
A verison of the Inspector specialized for inspecting Sets. It displays the elements of the set like elements of an array. Note that the indices, being phyical locations in the hash table, are not meaningful outside of the set.!
----- Method: SetInspector>>arrayIndexForSelection (in category 'selecting') -----
arrayIndexForSelection
^ (self fieldList at: selectionIndex) asInteger!
----- Method: SetInspector>>copyName (in category 'menu commands') -----
copyName
"Copy the name of the current variable, so the user can paste it into the
window below and work with is. If collection, do (xxx at: 1)."
| sel |
self selectionIndex <= (2 + object class instSize)
ifTrue: [super copyName]
ifFalse: [sel := '(self array at: '
, (String streamContents:
[:strm | self arrayIndexForSelection storeOn: strm]) , ')'.
Clipboard clipboardText: sel asText]!
----- Method: SetInspector>>fieldList (in category 'accessing') -----
fieldList
object
ifNil: [^ Set new].
^ self baseFieldList
, (object array
withIndexCollect: [:each :i | each ifNotNil: [i printString]])
select: [:each | each notNil]!
----- Method: SetInspector>>fieldListMenu: (in category 'menu') -----
fieldListMenu: aMenu
^ aMenu labels:
'inspect
copy name
objects pointing to this value
refresh view
remove
basic inspect'
lines: #( 5 8)
selections: #(inspectSelection copyName objectReferencesToSelection update removeSelection inspectBasic)
!
----- Method: SetInspector>>removeSelection (in category 'menu') -----
removeSelection
(selectionIndex <= object class instSize) ifTrue: [^ self changed: #flash].
object remove: self selection.
selectionIndex := 0.
contents := ''.
self changed: #inspectObject.
self changed: #fieldList.
self changed: #selection.
self changed: #selectionIndex.!
----- Method: SetInspector>>replaceSelectionValue: (in category 'selecting') -----
replaceSelectionValue: anObject
^ object array at: self arrayIndexForSelection put: anObject!
----- Method: SetInspector>>selection (in category 'selecting') -----
selection
selectionIndex = 0 ifTrue: [^ ''].
selectionIndex = 1 ifTrue: [^ object].
selectionIndex = 2 ifTrue: [^ object longPrintString].
(selectionIndex - 2) <= object class instSize
ifTrue: [^ object instVarAt: selectionIndex - 2].
^ object array at: self arrayIndexForSelection!
SetInspector subclass: #WeakSetInspector
instanceVariableNames: 'flagObject'
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Inspector'!
!WeakSetInspector commentStamp: '<historical>' prior: 0!
A verison of the SetInspector specialized for inspecting WeakSets. It knows about the flag object used to indicate empty locations in the hash table.!
----- Method: WeakSetInspector>>fieldList (in category 'accessing') -----
fieldList
| slotIndices |
object ifNil: [^ Set new].
"Implementation note: do not use objectArray withIndexCollect: as super
because this might collect indices in a WeakArray, leading to constantly changing fieldList
as explained at http://bugs.squeak.org/view.php?id=6812"
slotIndices := (Array new: object size) writeStream.
object array withIndexDo: [:each :i |
(each notNil and: [each ~= flagObject]) ifTrue: [slotIndices nextPut: i printString]].
^ self baseFieldList
, slotIndices contents!
----- Method: WeakSetInspector>>initialize (in category 'initialize-release') -----
initialize
super initialize.
flagObject := object instVarNamed: 'flag'. !
StringHolder subclass: #SelectorBrowser
instanceVariableNames: 'selectorIndex selectorList classListIndex classList'
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Browser'!
----- Method: SelectorBrowser class>>prototypicalToolWindow (in category 'instance creation') -----
prototypicalToolWindow
"Answer an example of myself seen in a tool window, for the benefit of parts-launching tools"
| aWindow |
aWindow := ToolBuilder build: self new.
aWindow setLabel: 'Selector Browser'.
aWindow applyModelExtent.
^ aWindow!
----- Method: SelectorBrowser class>>windowColorSpecification (in category 'window color') -----
windowColorSpecification
"Answer a WindowColorSpec object that declares my preference"
^ WindowColorSpec classSymbol: self name wording: 'Method Finder' brightColor: #lightCyan pastelColor: #palePeach helpMessage: 'A tool for finding methods by giving sample arguments and values.'!
----- Method: SelectorBrowser>>buildClassListWith: (in category 'as yet unclassified') -----
buildClassListWith: builder
| listSpec |
listSpec := builder pluggableListSpec new.
listSpec
model: self;
list: #classList;
getIndex: #classListIndex;
setIndex: #classListIndex:;
keyPress: #arrowKey:from:.
^listSpec
!
----- Method: SelectorBrowser>>buildEditViewWith: (in category 'as yet unclassified') -----
buildEditViewWith: builder
| textSpec |
textSpec := builder pluggableInputFieldSpec new.
textSpec
model: self;
getText: #contents;
setText: #contents:notifying:;
selection: #contentsSelection;
menu: #codePaneMenu:shifted:.
^textSpec!
----- Method: SelectorBrowser>>buildExamplePaneWith: (in category 'as yet unclassified') -----
buildExamplePaneWith: builder
| textSpec |
textSpec := builder pluggableTextSpec new.
textSpec
model: self;
getText: #byExample;
setText: #byExample:;
selection: #contentsSelection;
menu: #codePaneMenu:shifted:.
^textSpec!
----- Method: SelectorBrowser>>buildMessageListWith: (in category 'as yet unclassified') -----
buildMessageListWith: builder
| listSpec |
listSpec := builder pluggableListSpec new.
listSpec
model: self;
list: #messageList;
getIndex: #messageListIndex;
setIndex: #messageListIndex:;
menu: #selectorMenu:;
keyPress: #messageListKey:from:.
^listSpec
!
----- Method: SelectorBrowser>>buildWith: (in category 'as yet unclassified') -----
buildWith: builder
"Create a Browser that lets you type part of a selector, shows a list of selectors, shows the classes of the one you chose, and spawns a full browser on it. Answer the window
SelectorBrowser new open "
| windowSpec |
selectorIndex := classListIndex := 0.
windowSpec := self buildWindowWith: builder specs: {
(0 at 0 corner: 0.5 at 0.14) -> [self buildEditViewWith: builder].
(0 at 0.14 corner: 0.5 at 0.6) -> [self buildMessageListWith: builder].
(0.5 at 0 corner: 1 at 0.6) -> [self buildClassListWith: builder].
(0 at 0.6 corner: 1 at 1) -> [self buildExamplePaneWith: builder].
}.
^builder build: windowSpec!
----- Method: SelectorBrowser>>byExample (in category 'as yet unclassified') -----
byExample
"The comment in the bottom pane"
false ifTrue: [MethodFinder methodFor: #( (4 3) 7 (0 5) 5 (5 5) 10)].
"to keep the method methodFor: from being removed from the system"
^ 'Type a fragment of a selector in the top pane. Accept it.
Or, use an example to find a method in the system. Type receiver, args, and answer in the top pane with periods between the items. 3. 4. 7
Or, in this pane, use examples to find a method in the system. Select the line of code and choose "print it".
MethodFinder methodFor: #( (4 3) 7 (0 5) 5 (5 5) 10).
This will discover (data1 + data2).
You supply inputs and answers and the system will find the method. Each inner array is a list of inputs. It contains the receiver and zero or more arguments. For Booleans and any computed arguments, use brace notation.
MethodFinder methodFor: { {1. 3}. true. {20. 10}. false}.
This will discover the expressions (data1 < data2), (data2 > data1), and many others.
MethodFinder methodFor: { {''29 Apr 1999'' asDate}. ''Thursday''.
{''30 Apr 1999'' asDate}. ''Friday'' }.
This will discover the expression (data1 weekday)
Receiver and arguments do not have to be in the right order.
See MethodFinder.verify for more examples.'!
----- Method: SelectorBrowser>>byExample: (in category 'as yet unclassified') -----
byExample: newText
"Don't save it"
^ true!
----- Method: SelectorBrowser>>classList (in category 'as yet unclassified') -----
classList
^ classList!
----- Method: SelectorBrowser>>classListIndex (in category 'as yet unclassified') -----
classListIndex
^ classListIndex!
----- Method: SelectorBrowser>>classListIndex: (in category 'as yet unclassified') -----
classListIndex: anInteger
classListIndex := anInteger.
classListIndex > 0 ifTrue:
[self dependents do:
[:dep | ((dep isKindOf: PluggableListView) and:
[dep setSelectionSelectorIs: #classListIndex:])
ifTrue: [dep controller controlTerminate]].
Browser fullOnClass: self selectedClass selector: self selectedMessageName.
"classListIndex := 0"]
!
----- Method: SelectorBrowser>>classListSelectorTitle (in category 'as yet unclassified') -----
classListSelectorTitle
^ 'Class List Menu'!
----- Method: SelectorBrowser>>contents:notifying: (in category 'as yet unclassified') -----
contents: aString notifying: aController
"Take what the user typed and find all selectors containing it"
| tokens raw sorted |
contents := aString.
classList := #(). classListIndex := 0.
selectorIndex := 0.
tokens := contents asString findTokens: ' .'.
selectorList := Cursor wait showWhile: [
tokens size = 1
ifTrue: [raw := (Symbol selectorsContaining: contents asString).
sorted := raw as: SortedCollection.
sorted sortBlock: [:x :y | x asLowercase <= y asLowercase].
sorted asArray]
ifFalse: [self quickList]]. "find selectors from a single example of data"
self changed: #messageList.
self changed: #classList.
^ true!
----- Method: SelectorBrowser>>implementors (in category 'as yet unclassified') -----
implementors
| aSelector |
(aSelector := self selectedMessageName) ifNotNil:
[self systemNavigation browseAllImplementorsOf: aSelector]!
----- Method: SelectorBrowser>>initialExtent (in category 'as yet unclassified') -----
initialExtent
^ 350 at 250
!
----- Method: SelectorBrowser>>listFromResult: (in category 'as yet unclassified') -----
listFromResult: resultOC
"ResultOC is of the form #('(data1 op data2)' '(...)'). Answer a sorted array."
(resultOC first beginsWith: 'no single method') ifTrue: [^ #()].
^ resultOC sortBy: [:a :b |
(a copyFrom: 6 to: a size) < (b copyFrom: 6 to: b size)].
!
----- Method: SelectorBrowser>>markMatchingClasses (in category 'as yet unclassified') -----
markMatchingClasses
"If an example is used, mark classes matching the example instance with an asterisk."
| unmarkedClassList firstPartOfSelector receiverString receiver |
self flag: #mref. "allows for old-fashioned style"
"Only 'example' queries can be marked."
(contents asString includes: $.) ifFalse: [^ self].
unmarkedClassList := classList copy.
"Get the receiver object of the selected statement in the message list."
firstPartOfSelector := (Scanner new scanTokens: (selectorList at: selectorIndex)) second.
receiverString := (ReadStream on: (selectorList at: selectorIndex))
upToAll: firstPartOfSelector.
receiver := Compiler evaluate: receiverString.
unmarkedClassList do: [ :classAndMethod | | class |
(classAndMethod isKindOf: MethodReference) ifTrue: [
(receiver isKindOf: classAndMethod actualClass) ifTrue: [
classAndMethod stringVersion: '*', classAndMethod stringVersionDefault.
]
] ifFalse: [
class := Compiler evaluate:
((ReadStream on: classAndMethod) upToAll: firstPartOfSelector).
(receiver isKindOf: class) ifTrue: [
classList add: '*', classAndMethod.
classList remove: classAndMethod
]
].
].
!
----- Method: SelectorBrowser>>messageList (in category 'as yet unclassified') -----
messageList
"Find all the selectors containing what the user typed in."
^ selectorList!
----- Method: SelectorBrowser>>messageListIndex (in category 'as yet unclassified') -----
messageListIndex
"Answer the index of the selected message selector."
^ selectorIndex!
----- Method: SelectorBrowser>>messageListIndex: (in category 'as yet unclassified') -----
messageListIndex: anInteger
"Set the selected message selector to be the one indexed by anInteger.
Find all classes it is in."
selectorIndex := anInteger.
selectorIndex = 0
ifTrue: [^ self].
classList := self systemNavigation allImplementorsOf: self selectedMessageName.
self markMatchingClasses.
classListIndex := 0.
self changed: #messageListIndex.
"update my selection"
self changed: #classList!
----- Method: SelectorBrowser>>messageListKey:from: (in category 'as yet unclassified') -----
messageListKey: aChar from: view
"Respond to a command key. Handle (m) and (n) here,
else defer to the StringHolder behaviour."
aChar == $m ifTrue: [^ self implementors].
aChar == $n ifTrue: [^ self senders].
super messageListKey: aChar from: view
!
----- Method: SelectorBrowser>>open (in category 'as yet unclassified') -----
open
"Create a Browser that lets you type part of a selector, shows a list of selectors,
shows the classes of the one you chose, and spwns a full browser on it.
SelectorBrowser new open
"
^ToolBuilder open: self!
----- Method: SelectorBrowser>>quickList (in category 'as yet unclassified') -----
quickList
"Compute the selectors for the single example of receiver and args, in the very top pane"
| data result resultArray newExp dataStrings mf dataObjects aa statements |
data := contents asString.
"delete t
railing period. This should be fixed in the Parser!!"
[data last isSeparator] whileTrue: [data := data allButLast].
data last = $. ifTrue: [data := data allButLast]. "Eval"
mf := MethodFinder new.
data := mf cleanInputs: data. "remove common mistakes"
dataObjects := Compiler evaluate: '{', data, '}'. "#( data1 data2 result )"
statements := (Compiler new parse: 'zort ' , data in: Object notifying: nil)
body statements select: [:each | (each isKindOf: ReturnNode) not].
dataStrings := statements collect:
[:node | String streamContents:
[:strm | (node isMessage) ifTrue: [strm nextPut: $(].
node shortPrintOn: strm.
(node isMessage) ifTrue: [strm nextPut: $)].]].
dataObjects size < 2 ifTrue: [self inform: 'If you are giving an example of receiver, \args, and result, please put periods between the parts.\Otherwise just type one selector fragment' withCRs. ^#()].
dataObjects := Array with: dataObjects allButLast with: dataObjects last. "#( (data1
data2) result )"
result := mf load: dataObjects; findMessage.
(result first beginsWith: 'no single method') ifFalse: [
aa := self testObjects: dataObjects strings: dataStrings.
dataObjects := aa second. dataStrings := aa third].
resultArray := self listFromResult: result.
resultArray isEmpty ifTrue: [self inform: result first].
dataStrings size = (dataObjects first size + 1) ifTrue:
[resultArray := resultArray collect: [:expression |
newExp := expression.
dataObjects first withIndexDo: [:lit :i |
newExp := newExp copyReplaceAll: 'data', i printString
with: (dataStrings at: i)].
newExp, ' --> ', dataStrings last]].
^ resultArray!
----- Method: SelectorBrowser>>searchResult: (in category 'as yet unclassified') -----
searchResult: anExternalSearchResult
self contents: ''.
classList := #(). classListIndex := 0.
selectorIndex := 0.
selectorList := self listFromResult: anExternalSearchResult.
self changed: #messageList.
self changed: #classList.
Smalltalk isMorphic ifTrue: [self changed: #contents.].
!
----- Method: SelectorBrowser>>selectedClass (in category 'as yet unclassified') -----
selectedClass
"Answer the currently selected class."
| pairString |
self flag: #mref. "allows for old-fashioned style"
classListIndex = 0 ifTrue: [^nil].
pairString := classList at: classListIndex.
(pairString isKindOf: MethodReference) ifTrue: [
^pairString actualClass
].
(pairString includes: $*) ifTrue: [pairString := pairString allButFirst].
MessageSet
parse: pairString
toClassAndSelector: [:cls :sel | ^ cls].!
----- Method: SelectorBrowser>>selectedClassName (in category 'as yet unclassified') -----
selectedClassName
"Answer the name of the currently selected class."
classListIndex = 0 ifTrue: [^nil].
^ self selectedClass name!
----- Method: SelectorBrowser>>selectedMessageName (in category 'as yet unclassified') -----
selectedMessageName
"Answer the name of the currently selected message."
| example tokens |
selectorIndex = 0 ifTrue: [^nil].
example := selectorList at: selectorIndex.
tokens := Scanner new scanTokens: example.
tokens size = 1 ifTrue: [^ tokens first].
tokens first == #'^' ifTrue: [^ nil].
(tokens second includes: $:) ifTrue: [^ example findSelector].
Symbol hasInterned: tokens second ifTrue: [:aSymbol | ^ aSymbol].
^ nil!
----- Method: SelectorBrowser>>selectorList: (in category 'as yet unclassified') -----
selectorList: anExternalList
self contents: ''.
classList := #(). classListIndex := 0.
selectorIndex := 0.
selectorList := anExternalList.
self changed: #messageList.
self changed: #classList.
Smalltalk isMorphic ifTrue: [self changed: #contents.].
!
----- Method: SelectorBrowser>>selectorMenu: (in category 'as yet unclassified') -----
selectorMenu: aMenu
^ aMenu labels:
'senders (n)
implementors (m)
copy selector to clipboard'
lines: #()
selections: #(senders implementors copyName)!
----- Method: SelectorBrowser>>selectorMenuTitle (in category 'as yet unclassified') -----
selectorMenuTitle
^ self selectedMessageName ifNil: ['<no selection>']!
----- Method: SelectorBrowser>>senders (in category 'as yet unclassified') -----
senders
| aSelector |
(aSelector := self selectedMessageName) ifNotNil:
[self systemNavigation browseAllCallsOn: aSelector]!
----- Method: SelectorBrowser>>testObjects:strings: (in category 'as yet unclassified') -----
testObjects: dataObjects strings: dataStrings
| dataObjs dataStrs selectors classes didUnmodifiedAnswer answerMod do ds result ddo dds |
"Try to make substitutions in the user's inputs and search for the selector again.
1 no change to answer.
2 answer Array -> OrderedCollection.
2 answer Character -> String
4 answer Symbol or String of len 1 -> Character
For each of these, try straight, and try converting args:
Character -> String
Symbol or String of len 1 -> Character
Return array with result, dataObjects, dataStrings. Don't ever do a find on the same set of data twice."
dataObjs := dataObjects. dataStrs := dataStrings.
selectors := {#asString. #first. #asOrderedCollection}.
classes := {Character. String. Array}.
didUnmodifiedAnswer := false.
selectors withIndexDo: [:ansSel :ansInd | "Modify the answer object"
answerMod := false.
do := dataObjs copyTwoLevel. ds := dataStrs copy.
(dataObjs last isKindOf: (classes at: ansInd)) ifTrue: [
((ansSel ~~ #first) or: [dataObjs last size = 1]) ifTrue: [
do at: do size put: (do last perform: ansSel). "asString"
ds at: ds size put: ds last, ' ', ansSel.
result := MethodFinder new load: do; findMessage.
(result first beginsWith: 'no single method') ifFalse: [
"found a selector!!"
^ Array with: result first with: do with: ds].
answerMod := true]].
selectors allButLast withIndexDo: [:argSel :argInd | "Modify an argument object"
"for args, no reason to do Array -> OrderedCollection. Identical protocol."
didUnmodifiedAnswer not | answerMod ifTrue: [
ddo := do copyTwoLevel. dds := ds copy.
dataObjs first withIndexDo: [:arg :ind |
(arg isKindOf: (classes at: argInd)) ifTrue: [
((argSel ~~ #first) or: [arg size = 1]) ifTrue: [
ddo first at: ind put: ((ddo first at: ind) perform: argSel). "asString"
dds at: ind put: (dds at: ind), ' ', argSel.
result := MethodFinder new load: ddo; findMessage.
(result first beginsWith: 'no single method') ifFalse: [
"found a selector!!"
^ Array with: result first with: ddo with: dds] .
didUnmodifiedAnswer not & answerMod not ifTrue: [
didUnmodifiedAnswer := true].
]]]]].
].
^ Array with: 'no single method does that function' with: dataObjs with: dataStrs!
----- Method: StringHolder>>browseAllMessages (in category '*Tools') -----
browseAllMessages
"Create and schedule a message set browser on all implementors of all the messages sent by the current method."
| aClass aName method filteredList |
(aName := self selectedMessageName) ifNotNil: [
method := (aClass := self selectedClassOrMetaClass) compiledMethodAt: aName.
filteredList := method messages reject:
[:each | #(new initialize = ) includes: each].
self systemNavigation browseAllImplementorsOfList: filteredList asSortedCollection
title: 'All messages sent in ', aClass name, '.', aName]
!
----- Method: StringHolder>>browseClass (in category '*Tools') -----
browseClass
"Open an class browser on this class and method"
self selectedClassOrMetaClass ifNotNil: [
Browser newOnClass: self selectedClassOrMetaClass
selector: self selectedMessageName]!
----- Method: StringHolder>>browseClassRefs (in category '*Tools-traits') -----
browseClassRefs
| cls |
cls := self selectedClass.
(cls notNil and: [cls isTrait not])
ifTrue: [self systemNavigation browseAllCallsOnClass: cls theNonMetaClass]
!
----- Method: StringHolder>>browseClassVarRefs (in category '*Tools-traits') -----
browseClassVarRefs
"1/17/96 sw: devolve responsibility to the class, so that the code that does the real work can be shared"
| cls |
cls := self selectedClass.
(cls notNil and: [cls isTrait not])
ifTrue: [self systemNavigation browseClassVarRefs: cls]!
----- Method: StringHolder>>browseClassVariables (in category '*Tools-traits') -----
browseClassVariables
"Browse the class variables of the selected class. 2/5/96 sw"
| cls |
cls := self selectedClass.
(cls notNil and: [cls isTrait not])
ifTrue: [self systemNavigation browseClassVariables: cls]
!
----- Method: StringHolder>>browseFullProtocol (in category '*Tools-traits') -----
browseFullProtocol
"Open up a protocol-category browser on the value of the receiver's current selection. If in mvc, an old-style protocol browser is opened instead. Someone who still uses mvc might wish to make the protocol-category-browser work there too, thanks."
| aClass |
(Smalltalk isMorphic and: [Smalltalk includesKey: #Lexicon]) ifFalse: [^ self spawnFullProtocol].
((aClass := self selectedClassOrMetaClass) notNil and: [aClass isTrait not]) ifTrue:
[(Smalltalk at: #Lexicon) new openOnClass: aClass showingSelector: self selectedMessageName]!
----- Method: StringHolder>>browseInstVarDefs (in category '*Tools-traits') -----
browseInstVarDefs
| cls |
cls := self selectedClassOrMetaClass.
(cls notNil and: [cls isTrait not])
ifTrue: [self systemNavigation browseInstVarDefs: cls]!
----- Method: StringHolder>>browseInstVarRefs (in category '*Tools-traits') -----
browseInstVarRefs
"1/26/96 sw: real work moved to class, so it can be shared"
| cls |
cls := self selectedClassOrMetaClass.
(cls notNil and: [cls isTrait not])
ifTrue: [self systemNavigation browseInstVarRefs: cls]!
----- Method: StringHolder>>browseLocalImplementors (in category '*Tools') -----
browseLocalImplementors
"Present a menu of all messages sent by the currently selected message.
Open a message set browser of all implementors of the message chosen in or below
the selected class.
Do nothing if no message is chosen."
self getSelectorAndSendQuery: #browseAllImplementorsOf:localTo:
to: self systemNavigation
with: { self selectedClass }!
----- Method: StringHolder>>browseLocalSendersOfMessages (in category '*Tools') -----
browseLocalSendersOfMessages
"Present a menu of the currently selected message, as well as all
messages sent by it. Open a message set browser of all implementors
of the message chosen in or below the selected class"
self getSelectorAndSendQuery: #browseAllCallsOn:localTo:
to: self systemNavigation
with: { self selectedClass }!
----- Method: StringHolder>>browseMessages (in category '*Tools') -----
browseMessages
"Present a menu of all messages sent by the currently selected message.
Open a message set browser of all implementors of the message chosen."
self getSelectorAndSendQuery: #browseAllImplementorsOf: to: self systemNavigation!
----- Method: StringHolder>>browseMethodFull (in category '*Tools') -----
browseMethodFull
"Create and schedule a full Browser and then select the current class and message."
| myClass |
(myClass := self selectedClassOrMetaClass) ifNotNil:
[Browser fullOnClass: myClass selector: self selectedMessageName]!
----- Method: StringHolder>>browseSendersOfMessages (in category '*Tools') -----
browseSendersOfMessages
"Present a menu of the currently selected message, as well as all messages sent by it. Open a message set browser of all senders of the selector chosen."
self getSelectorAndSendQuery: #browseAllCallsOn: to: self systemNavigation!
----- Method: StringHolder>>browseUnusedMethods (in category '*Tools') -----
browseUnusedMethods
| classes unsent messageList cls |
(cls := self selectedClass)
ifNil: [^ self].
classes := Array with: cls with: cls class.
unsent := Set new.
classes
do: [:c | unsent addAll: c selectors].
unsent := self systemNavigation allUnSentMessagesIn: unsent.
messageList := OrderedCollection new.
classes
do: [:c | (c selectors
select: [:s | unsent includes: s]) asSortedCollection
do: [:sel | messageList add: c name , ' ' , sel]].
self systemNavigation browseMessageList: messageList name: 'Unsent Methods in ' , cls name!
----- Method: StringHolder>>browseVersions (in category '*Tools') -----
browseVersions
"Create and schedule a Versions Browser, showing all versions of the
currently selected message. Answer the browser or nil."
| selector class |
self classCommentIndicated
ifTrue: [ ClassCommentVersionsBrowser browseCommentOf: self selectedClass.
^nil ].
(selector := self selectedMessageName)
ifNil:[ self inform: 'Sorry, only actual methods have retrievable versions.'. ^nil ]
ifNotNil: [
class := self selectedClassOrMetaClass.
^VersionsBrowser
browseVersionsOf: (class compiledMethodAt: selector)
class: self selectedClass
meta: class isMeta
category: (class organization categoryOfElement: selector)
selector: selector]!
----- Method: StringHolder>>classHierarchy (in category '*Tools') -----
classHierarchy
"Create and schedule a class list browser on the receiver's hierarchy."
self systemNavigation
spawnHierarchyForClass: self selectedClassOrMetaClass "OK if nil"
selector: self selectedMessageName
!
----- Method: StringHolder>>classListKey:from: (in category '*Tools') -----
classListKey: aChar from: view
"Respond to a Command key. I am a model with a list of classes and a
code pane, and I also have a listView that has a list of methods. The
view knows how to get the list and selection."
aChar == $f ifTrue: [^ self findMethod].
aChar == $r ifTrue: [^ self recent].
aChar == $h ifTrue: [^ self spawnHierarchy].
aChar == $x ifTrue: [^ self removeClass].
^ self messageListKey: aChar from: view!
----- Method: StringHolder>>copyName (in category '*Tools') -----
copyName
"Copy the current selector to the clipboard"
| selector |
(selector := self selectedMessageName) ifNotNil:
[Clipboard clipboardText: selector asString asText]!
----- Method: StringHolder>>copySelector (in category '*Tools') -----
copySelector
"Copy the selected selector to the clipboard"
| selector |
(selector := self selectedMessageName) ifNotNil:
[Clipboard clipboardText: selector asString]!
----- Method: StringHolder>>fileOutMessage (in category '*Tools') -----
fileOutMessage
"Put a description of the selected message on a file"
self selectedMessageName ifNotNil:
[Cursor write showWhile:
[self selectedClassOrMetaClass fileOutMethod: self selectedMessageName]]!
----- Method: StringHolder>>findMethodInChangeSets (in category '*Tools') -----
findMethodInChangeSets
"Find and open a changeSet containing the current method."
| aName |
(aName := self selectedMessageName) ifNotNil: [
ChangeSorter browseChangeSetsWithClass: self selectedClassOrMetaClass
selector: aName]!
----- Method: StringHolder>>inspectInstances (in category '*Tools') -----
inspectInstances
"Inspect all instances of the selected class."
| myClass |
(myClass := self selectedClassOrMetaClass) ifNotNil:
[myClass theNonMetaClass inspectAllInstances].
!
----- Method: StringHolder>>inspectSubInstances (in category '*Tools') -----
inspectSubInstances
"Inspect all instances of the selected class and all its subclasses"
| aClass |
(aClass := self selectedClassOrMetaClass) ifNotNil: [
aClass theNonMetaClass inspectSubInstances].
!
----- Method: StringHolder>>makeIsolatedCodePane (in category '*Tools') -----
makeIsolatedCodePane
| msgName |
(msgName := self selectedMessageName) ifNil: [^ Beeper beep].
MethodHolder makeIsolatedCodePaneForClass: self selectedClassOrMetaClass selector: msgName!
----- Method: StringHolder>>messageListKey:from: (in category '*Tools') -----
messageListKey: aChar from: view
"Respond to a Command key. I am a model with a code pane, and I also
have a listView that has a list of methods. The view knows how to get
the list and selection."
| sel class |
aChar == $D ifTrue: [^ self toggleDiffing].
sel := self selectedMessageName.
aChar == $m ifTrue: "These next two put up a type in if no message selected"
[^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllImplementorsOf: to: self systemNavigation].
aChar == $n ifTrue:
[^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllCallsOn: to: self systemNavigation].
"The following require a class selection"
(class := self selectedClassOrMetaClass) ifNil: [^ self arrowKey: aChar from: view].
aChar == $b ifTrue: [^ Browser fullOnClass: class selector: sel].
aChar == $N ifTrue: [^ self browseClassRefs].
aChar == $i ifTrue: [^ self methodHierarchy].
aChar == $h ifTrue: [^ self classHierarchy].
aChar == $p ifTrue: [^ self browseFullProtocol].
"The following require a method selection"
sel ifNotNil:
[aChar == $o ifTrue: [^ self fileOutMessage].
aChar == $c ifTrue: [^ self copySelector].
aChar == $v ifTrue: [^ self browseVersions].
aChar == $O ifTrue: [^ self openSingleMessageBrowser].
aChar == $x ifTrue: [^ self removeMessage]].
^ self arrowKey: aChar from: view!
----- Method: StringHolder>>messageListSelectorTitle (in category '*Tools') -----
messageListSelectorTitle
| selector aString aStamp aSize |
(selector := self selectedMessageName)
ifNil:
[aSize := self messageList size.
^ (aSize == 0 ifTrue: ['no'] ifFalse: [aSize printString]), ' message', (aSize == 1 ifTrue: [''] ifFalse: ['s'])]
ifNotNil:
[Preferences timeStampsInMenuTitles
ifFalse: [^ nil].
aString := selector truncateWithElipsisTo: 28.
^ (aStamp := self timeStamp) size > 0
ifTrue:
[aString, String cr, aStamp]
ifFalse:
[aString]]!
----- Method: StringHolder>>methodHierarchy (in category '*Tools') -----
methodHierarchy
"Create and schedule a method browser on the hierarchy of implementors."
self systemNavigation
methodHierarchyBrowserForClass: self selectedClassOrMetaClass
selector: self selectedMessageName
!
----- Method: StringHolder>>offerDurableMenuFrom:shifted: (in category '*Tools') -----
offerDurableMenuFrom: menuRetriever shifted: aBoolean
"Pop up (morphic only) a menu whose target is the receiver and whose contents are provided by sending the menuRetriever to the receiver. The menuRetriever takes two arguments: a menu, and a boolean representing the shift state; put a stay-up item at the top of the menu."
| aMenu |
aMenu := MenuMorph new defaultTarget: self.
aMenu addStayUpItem.
self perform: menuRetriever with: aMenu with: aBoolean.
aMenu popUpInWorld!
----- Method: StringHolder>>offerMenuFrom:shifted: (in category '*Tools') -----
offerMenuFrom: menuRetriever shifted: aBoolean
"Pop up, in morphic or mvc as the case may be, a menu whose target is the receiver and whose contents are provided by sending the menuRetriever to the receiver. The menuRetriever takes two arguments: a menu, and a boolean representing the shift state."
| aMenu |
Smalltalk isMorphic
ifTrue:
[aMenu := MenuMorph new defaultTarget: self.
self perform: menuRetriever with: aMenu with: aBoolean.
aMenu popUpInWorld]
ifFalse:
[aMenu := CustomMenu new.
self perform: menuRetriever with: aMenu with: aBoolean.
aMenu invokeOn: self]!
----- Method: StringHolder>>openSingleMessageBrowser (in category '*Tools') -----
openSingleMessageBrowser
| msgName mr |
"Create and schedule a message list browser populated only by the currently selected message"
(msgName := self selectedMessageName) ifNil: [^ self].
mr := MethodReference new
setStandardClass: self selectedClassOrMetaClass
methodSymbol: msgName.
self systemNavigation
browseMessageList: (Array with: mr)
name: mr asStringOrText
autoSelect: nil!
----- Method: StringHolder>>packageListKey:from: (in category '*Tools') -----
packageListKey: aChar from: view
"Respond to a Command key in the package pane in the PackageBrowser"
aChar == $f ifTrue: [^ self findClass].
^ self classListKey: aChar from: view
!
----- Method: StringHolder>>printOutMessage (in category '*Tools') -----
printOutMessage
"Write a file with the text of the selected message, for printing by a web browser"
self selectedMessageName ifNotNil: [
self selectedClassOrMetaClass fileOutMethod: self selectedMessageName
asHtml: true]!
----- Method: StringHolder>>removeFromCurrentChanges (in category '*Tools') -----
removeFromCurrentChanges
"Tell the changes mgr to forget that the current msg was changed."
ChangeSet current removeSelectorChanges: self selectedMessageName
class: self selectedClassOrMetaClass.
self changed: #annotation!
----- Method: StringHolder>>revertAndForget (in category '*Tools') -----
revertAndForget
"Revert to the previous version of the current method, and tell the changes mgr to forget that it was ever changed. Danger!! Use only if you really know what you're doing!!"
self okToChange ifFalse: [^ self].
self revertToPreviousVersion.
self removeFromCurrentChanges.
self contentsChanged
!
----- Method: StringHolder>>revertToPreviousVersion (in category '*Tools') -----
revertToPreviousVersion
"Revert to the previous version of the current method"
| aClass aSelector changeRecords |
self okToChange ifFalse: [^ self].
aClass := self selectedClassOrMetaClass.
aClass ifNil: [^ self changed: #flash].
aSelector := self selectedMessageName.
changeRecords := aClass changeRecordsAt: aSelector.
(changeRecords == nil or: [changeRecords size <= 1]) ifTrue: [self changed: #flash. ^ Beeper beep].
changeRecords second fileIn.
self contentsChanged
!
----- Method: StringHolder>>selectMessageAndEvaluate: (in category '*Tools') -----
selectMessageAndEvaluate: aBlock
"Allow the user to choose one selector, chosen from the currently selected message's selector, as well as those of all messages sent by it, and evaluate aBlock on behalf of chosen selector. If there is only one possible choice, simply make it; if there are multiple choices, put up a menu, and evaluate aBlock on behalf of the the chosen selector, doing nothing if the user declines to choose any"
| selector method messages |
(selector := self selectedMessageName) ifNil: [^ self].
method := (self selectedClassOrMetaClass ifNil: [^ self])
compiledMethodAt: selector
ifAbsent: [].
(method isNil or: [(messages := method messages) size == 0])
ifTrue: [^ aBlock value: selector].
(messages size == 1 and: [messages includes: selector])
ifTrue:
[^ aBlock value: selector]. "If only one item, there is no choice"
self systemNavigation
showMenuOf: messages
withFirstItem: selector
ifChosenDo: [:sel | aBlock value: sel]!
----- Method: StringHolder>>systemCatListKey:from: (in category '*Tools') -----
systemCatListKey: aChar from: view
"Respond to a Command key. I am a model with a code pane, and I also have a listView that has a list of methods. The view knows how to get the list and selection."
aChar == $f ifTrue: [^ self findClass].
aChar == $x ifTrue: [^ self removeSystemCategory].
^ self classListKey: aChar from: view!
----- Method: StringHolder>>timeStamp (in category '*Tools') -----
timeStamp
"Answer the time stamp for the chosen class and method, if any, else an empty string"
| selector aMethod |
(selector := self selectedMessageName) ifNotNil:
[self selectedClassOrMetaClass
ifNil:
[^ String new]
ifNotNil:
[aMethod := self selectedClassOrMetaClass compiledMethodAt: selector ifAbsent: [nil].
aMethod ifNotNil: [^ Utilities timeStampForMethod: aMethod]]].
^ String new!
StringHolder subclass: #SyntaxError
instanceVariableNames: 'class selector category debugger doitFlag'
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Debugger'!
!SyntaxError commentStamp: '<historical>' prior: 0!
I represent syntax error report for syntax errors encountered when filing in class descriptions from a non-interactive source such as an external file. As a StringHolder, the string to be viewed is the method code or expression containing the error.
The user may fix the error and accept the method to continue the fileIn.
!
----- Method: SyntaxError class>>buildMVCViewOn: (in category 'instance creation') -----
buildMVCViewOn: aSyntaxError
"Answer an MVC view on the given SyntaxError."
| topView aListView aCodeView |
topView := StandardSystemView new
model: aSyntaxError;
label: 'Syntax Error';
minimumSize: 380 at 220.
aListView := PluggableListView on: aSyntaxError
list: #list
selected: #listIndex
changeSelected: nil
menu: #listMenu:.
aListView window: (0 at 0 extent: 380 at 20).
topView addSubView: aListView.
aCodeView := PluggableTextView on: aSyntaxError
text: #contents
accept: #contents:notifying:
readSelection: #contentsSelection
menu: #codePaneMenu:shifted:.
aCodeView window: (0 at 0 extent: 380 at 200).
topView addSubView: aCodeView below: aListView.
^ topView
!
----- Method: SyntaxError class>>buildMorphicViewOn: (in category 'instance creation') -----
buildMorphicViewOn: aSyntaxError
"Answer an Morphic view on the given SyntaxError."
| window |
window := (SystemWindow labelled: 'Syntax Error') model: aSyntaxError.
window addMorph: (PluggableListMorph on: aSyntaxError list: #list
selected: #listIndex changeSelected: nil menu: #listMenu:)
frame: (0 at 0 corner: 1 at 0.15).
window addMorph: (PluggableTextMorph on: aSyntaxError text: #contents
accept: #contents:notifying: readSelection: #contentsSelection
menu: #codePaneMenu:shifted:)
frame: (0 at 0.15 corner: 1 at 1).
^ window openInWorldExtent: 380 at 220!
----- Method: SyntaxError class>>errorInClass:withCode:doitFlag: (in category 'instance creation') -----
errorInClass: aClass withCode: codeString doitFlag: doit
"Open a view whose model is a syntax error. The error occurred when trying to add the given method code to the given class."
self open:
(self new setClass: aClass
code: codeString
debugger: (Debugger context: thisContext)
doitFlag: doit).
!
----- Method: SyntaxError class>>open: (in category 'instance creation') -----
open: aSyntaxError
"Answer a standard system view whose model is an instance of me."
| topView |
<primitive: 19> "Simulation guard"
Smalltalk isMorphic
ifTrue:
[self buildMorphicViewOn: aSyntaxError.
Project spawnNewProcessIfThisIsUI: Processor activeProcess.
^ Processor activeProcess suspend].
topView := self buildMVCViewOn: aSyntaxError.
topView controller openNoTerminateDisplayAt: Display extent // 2.
Cursor normal show.
Processor activeProcess suspend.
!
----- Method: SyntaxError>>category: (in category 'initialization') -----
category: aSymbol
"Record the message category of method being compiled. This is used when the user corrects the error and accepts."
category := aSymbol.
!
----- Method: SyntaxError>>contents:notifying: (in category 'other') -----
contents: aString notifying: aController
"Compile the code in aString and notify aController of any errors. If there are no errors, then automatically proceed."
doitFlag
ifTrue: [Compiler new evaluate: aString in: nil to: nil
notifying: aController ifFail: [^ false]]
ifFalse: [(class compile: aString classified: category
notifying: aController) ifNil: [^ false]].
aController hasUnacceptedEdits: false.
self proceed!
----- Method: SyntaxError>>debug (in category 'menu') -----
debug
"Show the stack of the process leading to this syntax editor, typically showing the stack of the compiler as called from fileIn."
debugger openFullNoSuspendLabel: 'Stack of the Syntax Error'.
Smalltalk isMorphic ifFalse: [Processor terminateActive].
!
----- Method: SyntaxError>>list (in category 'message list') -----
list
"Answer an array of one element made up of the class name, message category, and message selector in which the syntax error was found. This is the single item in the message list of a view/browser on the receiver."
selector ifNil: [^ Array with: (class name, ' ', category, ' ', '<none>')].
^ Array with: (class name, ' ', category, ' ', selector)
!
----- Method: SyntaxError>>listIndex (in category 'message list') -----
listIndex
"There is always exactly one element in my list and it is always selected."
^ 1
!
----- Method: SyntaxError>>listMenu: (in category 'menu') -----
listMenu: aMenu
^ aMenu labels:
'proceed
debug calling process
browse full'
lines: #()
selections: #(proceed debug browseMethodFull)
!
----- Method: SyntaxError>>notify:at:in: (in category 'other') -----
notify: error at: location in: source
"Open a syntax error view, inserting the given error message into the given source at the given location. This message is sent to the 'requestor' when the parser or compiler finds a syntax error."
| aClass aString |
aClass := thisContext sender receiver encoder classEncoding.
aString :=
source contents
copyReplaceFrom: location
to: location - 1
with: error.
self setClass: aClass
code: aString
debugger: (Debugger context: thisContext)
doitFlag: false.
self class open: self.
!
----- Method: SyntaxError>>proceed (in category 'menu') -----
proceed
"The user has has edited and presumably fixed the syntax error and the filein can now proceed."
debugger proceed: self topView.
!
----- Method: SyntaxError>>selectedClass (in category 'text menu support') -----
selectedClass
"Answer the class in which the syntax error occurred."
^ class
!
----- Method: SyntaxError>>selectedClassOrMetaClass (in category 'text menu support') -----
selectedClassOrMetaClass
"Answer the class of the method being compiled."
^ class
!
----- Method: SyntaxError>>selectedMessageName (in category 'text menu support') -----
selectedMessageName
"Answer the selector of the method being compiled."
^ selector
!
----- Method: SyntaxError>>setClass:code:debugger:doitFlag: (in category 'initialization') -----
setClass: aClass code: aString debugger: aDebugger doitFlag: flag
| types printables badChar |
class := aClass.
debugger := aDebugger.
selector := aClass parserClass new parseSelector: aString.
types := Scanner classPool at: #TypeTable. "dictionary"
printables := '!!@#$%&*-_=+<>{}?/\,·£¢§¶ªº–—“‘”’…Úæگ׿«»`~`' asSet.
badChar := aString detect: [:aChar | (types at: aChar asciiValue ifAbsent: [#xLetter]) == #xBinary and: [
(printables includes: aChar) not]] ifNone: [nil].
contents := badChar
ifNil: [aString]
ifNotNil: ['<<<This string contains a character (ascii value ',
badChar asciiValue printString,
') that is not normally used in code>>> ', aString].
category ifNil: [category := aClass organization categoryOfElement: selector].
category ifNil: [category := ClassOrganizer default].
doitFlag := flag!
StringHolder subclass: #Workspace
instanceVariableNames: 'bindings acceptDroppedMorphs acceptAction mustDeclareVariables'
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Base'!
!Workspace commentStamp: 'ls 10/14/2003 12:13' prior: 0!
A Workspace is a text area plus a lot of support for executable code. It is a great place to execute top-level commands to compute something useful, and it is a great place to develop bits of a program before those bits get put into class methods.
To open a new workspace, execute:
Workspace open
A workspace can have its own variables, called "workspace variables", to hold intermediate results. For example, if you type into a workspace "x := 5" and do-it, then later you could type in "y := x * 2" and y would become 10.
Additionally, in Morphic, a workspace can gain access to morphs that are on the screen. If acceptDroppedMorphss is turned on, then whenever a morph is dropped on the workspace, a variable will be created which references that morph. This functionality is toggled with the window-wide menu of a workspace.
The instance variables of this class are:
bindings - holds the workspace variables for this workspace
acceptDroppedMorphss - whether dropped morphs should create new variables!
----- Method: Workspace class>>prototypicalToolWindow (in category 'instance creation') -----
prototypicalToolWindow
"Answer an example of myself seen in a tool window, for the benefit of parts-launching tools"
| aWorkspace |
aWorkspace := ToolBuilder build: self new.
^ aWorkspace!
----- Method: Workspace>>acceptAction (in category 'accessing') -----
acceptAction
^acceptAction!
----- Method: Workspace>>acceptAction: (in category 'accessing') -----
acceptAction: anAction
acceptAction := anAction.!
----- Method: Workspace>>acceptContents: (in category 'accessing') -----
acceptContents: aString
acceptAction ifNotNil:[acceptAction value: aString].
^super acceptContents: aString.!
----- Method: Workspace>>acceptDroppedMorphsWording (in category 'as yet unclassified') -----
acceptDroppedMorphsWording
^ self acceptsDroppingMorphForReference
ifTrue: ['<yes> create textual references to dropped morphs' translated]
ifFalse: ['<no> create textual references to dropped morphs' translated]
!
----- Method: Workspace>>acceptDroppingMorph:event:inMorph: (in category 'drag and drop') -----
acceptDroppingMorph: dropee event: evt inMorph: targetMorph
"Return the dropee to its old position, and add a reference to it at the cursor point."
| bindingName externalName |
externalName := dropee externalName.
externalName := externalName isOctetString
ifTrue: [externalName] ifFalse: ['a' , externalName].
bindingName := externalName translateToLowercase, dropee identityHash printString.
targetMorph correctSelectionWithString: bindingName, ' '.
(self bindingOf: bindingName) value: dropee.
dropee rejectDropMorphEvent: evt.
^ true "success"
!
----- Method: Workspace>>acceptsDroppingMorphForReference (in category 'drag and drop') -----
acceptsDroppingMorphForReference
^ acceptDroppedMorphs
!
----- Method: Workspace>>acceptsDroppingMorphForReference: (in category 'drag and drop') -----
acceptsDroppingMorphForReference: trueFalse
acceptDroppedMorphs := trueFalse
!
----- Method: Workspace>>addModelItemsToWindowMenu: (in category 'menu commands') -----
addModelItemsToWindowMenu: aMenu
aMenu addLine.
aMenu
add: 'save contents to file...'
target: self
action: #saveContentsInFile.
aMenu
add: 'reset variables'
target: self
action: #initializeBindings.
aMenu
addUpdating: #mustDeclareVariableWording
target: self
action: #toggleVariableDeclarationMode.
aMenu
addUpdating: #acceptDroppedMorphsWording
target: self
action: #toggleDroppingMorphForReference!
----- Method: Workspace>>appendContentsOfFile (in category 'menu commands') -----
appendContentsOfFile
"Prompt for a file, and if one is obtained, append its contents to the contents of the receiver. Caution: as currently implemented this abandons any custom style information previously in the workspace. Someone should fix this. Also, for best results you should accept the contents of the workspace before requesting this."
| aFileStream |
(aFileStream := FileList2 modalFileSelector) ifNil: [^ self].
contents := (contents ifNil: ['']) asString, aFileStream contentsOfEntireFile.
aFileStream close.
self changed: #contents!
----- Method: Workspace>>bindingOf: (in category 'binding') -----
bindingOf: aString
mustDeclareVariables ifTrue: [^ nil].
"I want to have workspace that force the user to declare
variables. Still subclasses may want to do something else"
bindings isNil
ifTrue: [self initializeBindings].
(bindings includesKey: aString)
ifFalse: [bindings at: aString put: nil].
^ bindings associationAt: aString!
----- Method: Workspace>>convertToCurrentVersion:refStream: (in category 'object fileIn') -----
convertToCurrentVersion: varDict refStream: smartRefStrm
acceptDroppedMorphs ifNil: [acceptDroppedMorphs := false].
^super convertToCurrentVersion: varDict refStream: smartRefStrm.
!
----- Method: Workspace>>initialExtent (in category 'initialize-release') -----
initialExtent
"Start small. Window aspect ratio is 5 sqrt::1 . Good asthetics. -wiz"
^ 447 at 200!
----- Method: Workspace>>initialize (in category 'initialize-release') -----
initialize
super initialize.
acceptDroppedMorphs := false.
mustDeclareVariables := false!
----- Method: Workspace>>initializeBindings (in category 'binding') -----
initializeBindings
bindings := Dictionary new!
----- Method: Workspace>>mustDeclareVariableWording (in category 'variable declarations') -----
mustDeclareVariableWording
^ mustDeclareVariables not
ifTrue: ['<yes> automatically create variable declaration' translated]
ifFalse: ['<no> automatically create variable declaration' translated]!
----- Method: Workspace>>mustDeclareVariables: (in category 'accessing') -----
mustDeclareVariables: aBoolean
mustDeclareVariables := aBoolean!
----- Method: Workspace>>saveContentsInFile (in category 'as yet unclassified') -----
saveContentsInFile
"A bit of a hack to pass along this message to the controller or morph. (Possibly this Workspace menu item could be deleted, since it's now in the text menu.)"
| textMorph textView |
textMorph := self dependents detect: [:dep | dep isKindOf: PluggableTextMorph] ifNone: [nil].
textMorph notNil ifTrue: [^ textMorph saveContentsInFile].
textView := self dependents detect: [:dep | dep isKindOf: PluggableTextView] ifNone: [nil].
textView notNil ifTrue: [^ textView controller saveContentsInFile].
!
----- Method: Workspace>>setBindings: (in category 'accessing') -----
setBindings: aDictionary
"Sets the Workspace to use the specified dictionary as its namespace"
bindings := aDictionary.
!
----- Method: Workspace>>toggleDroppingMorphForReference (in category 'drag and drop') -----
toggleDroppingMorphForReference
acceptDroppedMorphs := acceptDroppedMorphs not.
!
----- Method: Workspace>>toggleVariableDeclarationMode (in category 'variable declarations') -----
toggleVariableDeclarationMode
mustDeclareVariables := mustDeclareVariables not!
----- Method: Workspace>>wantsAnnotationPane (in category 'accessing') -----
wantsAnnotationPane
"We have nothing to annotate"
^false!
----- Method: Workspace>>wantsDroppedMorph:event:inMorph: (in category 'drag and drop') -----
wantsDroppedMorph: dropee event: evt inMorph: target
^ acceptDroppedMorphs
!
----- Method: Workspace>>wantsOptionalButtons (in category 'accessing') -----
wantsOptionalButtons
"We have no optional buttons (yet)"
^false!
----- Method: TheWorldMenu>>browseRecentLog (in category '*Tools') -----
browseRecentLog
ChangeList browseRecentLog!
----- Method: TheWorldMenu>>inspectWorldModel (in category '*Tools') -----
inspectWorldModel
| insp |
insp := InspectorBrowser openOn: myWorld model.
myWorld addMorph: insp; startStepping: insp!
----- Method: TheWorldMenu>>openChangeSorter1 (in category '*Tools') -----
openChangeSorter1
ToolBuilder open: ChangeSorter new!
----- Method: TheWorldMenu>>openChangeSorter2 (in category '*Tools') -----
openChangeSorter2
ToolBuilder open: DualChangeSorter new!
----- Method: TheWorldMenu>>openMessageNames (in category '*Tools') -----
openMessageNames
"Bring a MessageNames tool to the front"
MessageNames openMessageNames!
----- Method: TheWorldMenu>>openProcessBrowser (in category '*Tools') -----
openProcessBrowser
ProcessBrowser open!
----- Method: TheWorldMenu>>openSelectorBrowser (in category '*Tools') -----
openSelectorBrowser
ToolBuilder open: SelectorBrowser new!
----- Method: TheWorldMenu>>startThenBrowseMessageTally (in category '*Tools') -----
startThenBrowseMessageTally
(self confirm: 'MessageTally will start now,
and stop when the cursor goes
to the top of the screen')
ifTrue: [TimeProfileBrowser
onBlock: [[Sensor peekMousePt y > 10]
whileTrue: [World doOneCycle]]]!
----- Method: BlockClosure>>timeProfile (in category '*Tools') -----
timeProfile
^TimeProfileBrowser onBlock: self!
----- Method: CompiledMethod>>explorerContents (in category '*Tools-Inspector') -----
explorerContents
"(CompiledMethod compiledMethodAt: #explorerContents) explore"
^Array streamContents:
[:s| | tokens |
tokens := Scanner new scanTokens: (self headerDescription readStream skipTo: $"; upTo: $").
s nextPut: (ObjectExplorerWrapper
with: ((0 to: tokens size by: 2) collect:
[:i| i = 0 ifTrue: [self header] ifFalse: [{tokens at: i - 1. tokens at: i}]])
name: 'header'
model: self).
(1 to: self numLiterals) do:
[:key|
s nextPut: (ObjectExplorerWrapper
with: (self literalAt: key)
name: ('literal', key printString contractTo: 32)
model: self)].
self isQuick
ifTrue: [s nextPut: (ObjectExplorerWrapper
with: self symbolic
name: #symbolic
model: self)]
ifFalse:
[self symbolicLinesDo:
[:pc :line|
pc <= 1
ifTrue:
[s nextPut: (ObjectExplorerWrapper
with: line
name: 'pragma'
model: self)]
ifFalse:
[s nextPut: (ObjectExplorerWrapper
with: line
name: pc printString
model: self)]]].
"should be self numLiterals + 1 * Smalltalk wordSize + 1"
self endPC + 1
to: self basicSize
do: [:key|
s nextPut: (ObjectExplorerWrapper
with: (self basicAt: key)
name: key printString
model: self)]]!
----- Method: CompiledMethod>>inspectorClass (in category '*Tools-Inspector') -----
inspectorClass
"Answer the class of the inspector to be used on the receiver. Called by inspect;
use basicInspect to get a normal (less useful) type of inspector."
^ CompiledMethodInspector!
AppRegistry subclass: #SystemBrowser
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Base'!
!SystemBrowser commentStamp: '<historical>' prior: 0!
This is the AppRegistry class for class browsing!
----- Method: SystemBrowser class>>addRegistryMenuItemsTo:inAccountOf: (in category 'registration') -----
addRegistryMenuItemsTo: aMenu inAccountOf: aBrowser
"Add some useful options related Browser registry to the
browsers windows menu"
aMenu addLine;
add: 'Register this Browser as default'
target: [self default: aBrowser class]
action: #value;
add: 'Choose new default Browser'
target: self
action: #askForDefault!
----- Method: SystemBrowser class>>defaultOpenBrowser (in category 'instance creation') -----
defaultOpenBrowser
^self default openBrowser!
----- Method: SystemBrowser class>>initialize (in category 'class initialization') -----
initialize
| pref |
pref := Preferences preferenceAt: #browserShowsPackagePane.
Preferences
addPreference: #browserShowsPackagePane
categories: pref categoryList
default: pref defaultValue
balloonHelp: pref helpString
projectLocal: pref localToProject
changeInformee: self
changeSelector: #packagePanePreferenceChanged
!
----- Method: SystemBrowser class>>packagePanePreferenceChanged (in category 'events') -----
packagePanePreferenceChanged
| theOtherOne |
self registeredClasses size = 2
ifTrue: [theOtherOne := (self registeredClasses copyWithout: PackagePaneBrowser) first]
ifFalse: [theOtherOne := nil].
(Preferences valueOfFlag: #browserShowsPackagePane ifAbsent: [false])
ifTrue: [self default: PackagePaneBrowser]
ifFalse: [self default: theOtherOne].
SystemNavigation default browserClass: self default.!
----- Method: SystemBrowser class>>unload (in category 'initialize-release') -----
unload
| pref |
pref := Preferences preferenceAt: #browserShowsPackagePane.
Preferences
addPreference: #browserShowsPackagePane
categories: pref categoryList
default: pref defaultValue
balloonHelp: pref helpString
projectLocal: pref localToProject
changeInformee: nil
changeSelector: nil
!
ElementCategory subclass: #ChangeSetCategory
instanceVariableNames: 'membershipSelector'
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Changes'!
!ChangeSetCategory commentStamp: '<historical>' prior: 0!
A ChangeSetCategory represents a list of change sets to be shown in a ChangeSorter. It computes whether a given change set is in the list by sending its membershipSelector to ChangeSorter (i.e. the class object) with the change set as message argument.!
----- Method: ChangeSetCategory>>acceptsManualAdditions (in category 'queries') -----
acceptsManualAdditions
"Answer whether the user is allowed manually to manipulate the contents of the change-set-category."
^ false!
----- Method: ChangeSetCategory>>changeSetList (in category 'queries') -----
changeSetList
"Answer the list of change-set names in the category"
| aChangeSet |
self reconstituteList.
keysInOrder size == 0 ifTrue:
["don't tolerate emptiness, because ChangeSorters gag when they have no change-set selected"
aChangeSet := ChangesOrganizer assuredChangeSetNamed: 'New Changes'.
self elementAt: aChangeSet name put: aChangeSet].
^ keysInOrder reversed!
----- Method: ChangeSetCategory>>defaultChangeSetToShow (in category 'miscellaneous') -----
defaultChangeSetToShow
"Answer the name of a change-set to show"
^ ChangeSet current!
----- Method: ChangeSetCategory>>fileOutAllChangeSets (in category 'services') -----
fileOutAllChangeSets
"File out all the nonempty change sets in the current category, suppressing the checks for slips that might otherwise ensue. Obtain user confirmation before undertaking this possibly prodigious task."
| aList |
aList := self elementsInOrder select:
[:aChangeSet | aChangeSet isEmpty not].
aList size == 0 ifTrue: [^ self inform: 'sorry, all the change sets in this category are empty'].
(self confirm: 'This will result in filing out ', aList size printString, ' change set(s)
Are you certain you want to do this?') ifFalse: [^ self].
Preferences setFlag: #checkForSlips toValue: false during:
[ChangesOrganizer fileOutChangeSetsNamed: (aList collect: [:m | m name]) asSortedArray]!
----- Method: ChangeSetCategory>>fillAggregateChangeSet (in category 'services') -----
fillAggregateChangeSet
"Create a change-set named Aggregate and pour into it all the changes in all the change-sets of the currently-selected category"
| aggChangeSet |
aggChangeSet := ChangesOrganizer assuredChangeSetNamed: #Aggregate.
aggChangeSet clear.
aggChangeSet setPreambleToSay: '"Change Set: Aggregate
Created at ', Time now printString, ' on ', Date today printString, ' by combining all the changes in all the change sets in the category ', categoryName printString, '"'.
(self elementsInOrder copyWithout: aggChangeSet) do:
[:aChangeSet | aggChangeSet assimilateAllChangesFoundIn: aChangeSet].
Smalltalk isMorphic ifTrue: [SystemWindow wakeUpTopWindowUponStartup]
!
----- Method: ChangeSetCategory>>hasChangeForClassName:selector:otherThanIn: (in category 'queries') -----
hasChangeForClassName: aClassName selector: aSelector otherThanIn: excludedChangeSet
"Answer whether any change set in this category, other than the excluded one, has a change marked for the given class and selector"
self elementsInOrder do:
[:aChangeSet |
(aChangeSet ~~ excludedChangeSet and:
[((aChangeSet methodChangesAtClass: aClassName) includesKey: aSelector)]) ifTrue: [^ true]].
^ false!
----- Method: ChangeSetCategory>>includesChangeSet: (in category 'queries') -----
includesChangeSet: aChangeSet
"Answer whether the receiver includes aChangeSet in its retrieval list"
^ ChangesOrganizer perform: membershipSelector with: aChangeSet!
----- Method: ChangeSetCategory>>membershipSelector: (in category 'initialization') -----
membershipSelector: aSelector
"Set the membershipSelector"
membershipSelector := aSelector!
----- Method: ChangeSetCategory>>reconstituteList (in category 'miscellaneous') -----
reconstituteList
"Clear out the receiver's elements and rebuild them"
| newMembers |
"First determine newMembers and check if they have not changed..."
newMembers := ChangesOrganizer allChangeSets select:
[:aChangeSet | ChangesOrganizer perform: membershipSelector with: aChangeSet].
(newMembers collect: [:cs | cs name]) = keysInOrder ifTrue: [^ self "all current"].
"Things have changed. Need to recompute the whole category"
self clear.
newMembers do:
[:aChangeSet | self fasterElementAt: aChangeSet name asSymbol put: aChangeSet]
!
ChangeSetCategory subclass: #ChangeSetCategoryWithParameters
instanceVariableNames: 'parameters'
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Changes'!
----- Method: ChangeSetCategoryWithParameters>>acceptsManualAdditions (in category 'as yet unclassified') -----
acceptsManualAdditions
"Answer whether the user is allowed manually to manipulate the contents of the change-set-category."
^ true!
----- Method: ChangeSetCategoryWithParameters>>addChangeSet: (in category 'as yet unclassified') -----
addChangeSet: aChangeSet
self inform: 'sorry, you can''t do that'!
----- Method: ChangeSetCategoryWithParameters>>includesChangeSet: (in category 'as yet unclassified') -----
includesChangeSet: aChangeSet
"Answer whether the receiver includes aChangeSet in its retrieval list"
^ ChangesOrganizer perform: membershipSelector withArguments: { aChangeSet } , parameters!
----- Method: ChangeSetCategoryWithParameters>>parameters: (in category 'as yet unclassified') -----
parameters: anArray
parameters := anArray!
----- Method: ChangeSetCategoryWithParameters>>reconstituteList (in category 'as yet unclassified') -----
reconstituteList
"Clear out the receiver's elements and rebuild them"
| newMembers |
"First determine newMembers and check if they have not changed..."
newMembers := ChangesOrganizer allChangeSets select:
[:aChangeSet | ChangesOrganizer perform: membershipSelector withArguments: { aChangeSet }, parameters].
(newMembers collect: [:cs | cs name]) = keysInOrder ifTrue: [^ self "all current"].
"Things have changed. Need to recompute the whole category"
self clear.
newMembers do:
[:aChangeSet | self fasterElementAt: aChangeSet name asSymbol put: aChangeSet]!
ChangeSetCategory subclass: #StaticChangeSetCategory
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Changes'!
!StaticChangeSetCategory commentStamp: '<historical>' prior: 0!
StaticChangeSetCategory is a user-defined change-set category that has in it only those change sets specifically placed there.!
----- Method: StaticChangeSetCategory>>acceptsManualAdditions (in category 'queries') -----
acceptsManualAdditions
"Answer whether the user is allowed manually to manipulate the contents of the change-set-category."
^ true!
----- Method: StaticChangeSetCategory>>addChangeSet: (in category 'add') -----
addChangeSet: aChangeSet
"Add the change set manually"
self elementAt: aChangeSet name put: aChangeSet!
----- Method: StaticChangeSetCategory>>includesChangeSet: (in category 'queries') -----
includesChangeSet: aChangeSet
"Answer whether the receiver includes aChangeSet in its retrieval list"
^ elementDictionary includesKey: aChangeSet name!
----- Method: StaticChangeSetCategory>>reconstituteList (in category 'updating') -----
reconstituteList
"Reformulate the list. Here, since we have a manually-maintained list, at this juncture we only make sure change-set-names are still up to date, and we purge moribund elements"
| survivors |
survivors := elementDictionary select: [:aChangeSet | aChangeSet isMoribund not].
self clear.
(survivors asSortedCollection: [:a :b | a name <= b name]) reverseDo:
[:aChangeSet | self addChangeSet: aChangeSet]!
----- Method: FloatArray>>inspectorClass (in category '*Tools-Inspector') -----
inspectorClass
"Answer the class of the inspector to be used on the receiver. Called by inspect;
use basicInspect to get a normal (less useful) type of inspector."
^OrderedCollectionInspector!
----- Method: OrderedCollection>>inspectorClass (in category '*Tools-Inspector') -----
inspectorClass
"Answer the class of the inspector to be used on the receiver. Called by inspect;
use basicInspect to get a normal (less useful) type of inspector."
^OrderedCollectionInspector!
Model subclass: #CPUWatcher
instanceVariableNames: 'tally watcher threshold'
classVariableNames: 'CurrentCPUWatcher'
poolDictionaries: ''
category: 'Tools-Process Browser'!
!CPUWatcher commentStamp: '<historical>' prior: 0!
CPUWatcher implements a simple runaway process monitoring tool
that will suspend a process that is taking up too much of Squeak's
time and allow user interaction. By default it watches for a Process that
is taking more than 80% of the time; this threshold can be changed.
CPUWatcher can also be used to show cpu percentages for each process
from within the ProcessBrowser.
CPUWatcher startMonitoring. "process period 20 seconds, sample rate 100 msec"
CPUWatcher current monitorProcessPeriod: 10 sampleRate: 20.
CPUWatcher current threshold: 0.5. "change from 80% to 50%"
CPUWatcher stopMonitoring.
!
----- Method: CPUWatcher class>>current (in category 'as yet unclassified') -----
current
^CurrentCPUWatcher
!
----- Method: CPUWatcher class>>currentWatcherProcess (in category 'as yet unclassified') -----
currentWatcherProcess
^CurrentCPUWatcher ifNotNil: [ CurrentCPUWatcher watcherProcess ]
!
----- Method: CPUWatcher class>>dumpTallyOnTranscript (in category 'as yet unclassified') -----
dumpTallyOnTranscript
self current ifNotNil: [
ProcessBrowser dumpTallyOnTranscript: self current tally
]!
----- Method: CPUWatcher class>>initialize (in category 'as yet unclassified') -----
initialize
"CPUWatcher initialize"
Smalltalk addToStartUpList: self.
Smalltalk addToShutDownList: self.!
----- Method: CPUWatcher class>>isMonitoring (in category 'as yet unclassified') -----
isMonitoring
^CurrentCPUWatcher notNil and: [ CurrentCPUWatcher isMonitoring ]
!
----- Method: CPUWatcher class>>monitorPreferenceChanged (in category 'as yet unclassified') -----
monitorPreferenceChanged
Preferences cpuWatcherEnabled
ifTrue: [ self startMonitoring ]
ifFalse: [ self stopMonitoring ]!
----- Method: CPUWatcher class>>shutDown (in category 'as yet unclassified') -----
shutDown
self stopMonitoring.!
----- Method: CPUWatcher class>>startMonitoring (in category 'as yet unclassified') -----
startMonitoring
"CPUWatcher startMonitoring"
^self startMonitoringPeriod: 20 rate: 100 threshold: 0.8!
----- Method: CPUWatcher class>>startMonitoringPeriod:rate:threshold: (in category 'as yet unclassified') -----
startMonitoringPeriod: pd rate: rt threshold: th
"CPUWatcher startMonitoring"
CurrentCPUWatcher ifNotNil: [ ^CurrentCPUWatcher startMonitoring. ].
CurrentCPUWatcher := (self new)
monitorProcessPeriod: pd sampleRate: rt;
threshold: th;
yourself.
^CurrentCPUWatcher
!
----- Method: CPUWatcher class>>startUp (in category 'as yet unclassified') -----
startUp
self monitorPreferenceChanged.!
----- Method: CPUWatcher class>>stopMonitoring (in category 'as yet unclassified') -----
stopMonitoring
"CPUWatcher stopMonitoring"
CurrentCPUWatcher ifNotNil: [ CurrentCPUWatcher stopMonitoring. ].
CurrentCPUWatcher := nil.
!
----- Method: CPUWatcher>>catchThePig: (in category 'porcine capture') -----
catchThePig: aProcess
| rules |
"nickname, allow-stop, allow-debug"
rules := ProcessBrowser nameAndRulesFor: aProcess.
(ProcessBrowser isUIProcess: aProcess)
ifTrue: [ "aProcess debugWithTitle: 'Interrupted from the CPUWatcher'." ]
ifFalse: [ rules second ifFalse: [ ^self ].
ProcessBrowser suspendProcess: aProcess.
self openWindowForSuspendedProcess: aProcess ]
!
----- Method: CPUWatcher>>debugProcess: (in category 'process operations') -----
debugProcess: aProcess
| uiPriority oldPriority |
uiPriority := Processor activeProcess priority.
aProcess priority >= uiPriority ifTrue: [
oldPriority := ProcessBrowser setProcess: aProcess toPriority: uiPriority - 1
].
ProcessBrowser debugProcess: aProcess.!
----- Method: CPUWatcher>>debugProcess:fromMenu: (in category 'process operations') -----
debugProcess: aProcess fromMenu: aMenuMorph
aMenuMorph delete.
self debugProcess: aProcess.!
----- Method: CPUWatcher>>findThePig (in category 'porcine capture') -----
findThePig
"tally has been updated. Look at it to see if there is a bad process.
This runs at a very high priority, so make it fast"
| countAndProcess |
countAndProcess := tally sortedCounts first.
(countAndProcess key / tally size > self threshold) ifTrue: [ | proc |
proc := countAndProcess value.
proc == Processor backgroundProcess ifTrue: [ ^self ]. "idle process? OK"
self catchThePig: proc
].
!
----- Method: CPUWatcher>>isMonitoring (in category 'accessing') -----
isMonitoring
^watcher notNil!
----- Method: CPUWatcher>>monitorProcessPeriod:sampleRate: (in category 'startup-shutdown') -----
monitorProcessPeriod: secs sampleRate: msecs
self stopMonitoring.
watcher := [ [ | promise |
promise := Processor tallyCPUUsageFor: secs every: msecs.
tally := promise value.
promise := nil.
self findThePig.
] repeat ] forkAt: Processor highestPriority.
Processor yield !
----- Method: CPUWatcher>>openMVCWindowForSuspendedProcess: (in category 'porcine capture') -----
openMVCWindowForSuspendedProcess: aProcess
ProcessBrowser new openAsMVC.!
----- Method: CPUWatcher>>openMorphicWindowForSuspendedProcess: (in category 'porcine capture') -----
openMorphicWindowForSuspendedProcess: aProcess
| menu rules |
menu := MenuMorph new.
"nickname allow-stop allow-debug"
rules := ProcessBrowser nameAndRulesFor: aProcess.
menu add: 'Dismiss this menu' target: menu selector: #delete; addLine.
menu add: 'Open Process Browser' target: ProcessBrowser selector: #open.
menu add: 'Resume'
target: self
selector: #resumeProcess:fromMenu:
argumentList: { aProcess . menu }.
menu add: 'Terminate'
target: self
selector: #terminateProcess:fromMenu:
argumentList: { aProcess . menu }.
rules third ifTrue: [
menu add: 'Debug at a lower priority'
target: self
selector: #debugProcess:fromMenu:
argumentList: { aProcess . menu }.
].
menu addTitle: aProcess identityHash asString,
' ', rules first,
' is taking too much time and has been suspended.
What do you want to do with it?'.
menu stayUp: true.
menu popUpInWorld
!
----- Method: CPUWatcher>>openWindowForSuspendedProcess: (in category 'porcine capture') -----
openWindowForSuspendedProcess: aProcess
Smalltalk isMorphic
ifTrue: [ WorldState addDeferredUIMessage: [ self openMorphicWindowForSuspendedProcess: aProcess ] ]
ifFalse: [ [ self openMVCWindowForSuspendedProcess: aProcess ] forkAt: Processor userSchedulingPriority ]
!
----- Method: CPUWatcher>>resumeProcess:fromMenu: (in category 'process operations') -----
resumeProcess: aProcess fromMenu: aMenuMorph
aMenuMorph delete.
ProcessBrowser resumeProcess: aProcess.!
----- Method: CPUWatcher>>startMonitoring (in category 'startup-shutdown') -----
startMonitoring
self
monitorProcessPeriod: 20 sampleRate: 100!
----- Method: CPUWatcher>>stopMonitoring (in category 'startup-shutdown') -----
stopMonitoring
watcher ifNotNil: [
ProcessBrowser terminateProcess: watcher.
watcher := nil.
]!
----- Method: CPUWatcher>>tally (in category 'accessing') -----
tally
^tally copy!
----- Method: CPUWatcher>>terminateProcess:fromMenu: (in category 'process operations') -----
terminateProcess: aProcess fromMenu: aMenuMorph
aMenuMorph delete.
ProcessBrowser terminateProcess: aProcess.!
----- Method: CPUWatcher>>threshold (in category 'accessing') -----
threshold
"What fraction of the time can a process be the active process before we stop it?"
^threshold!
----- Method: CPUWatcher>>threshold: (in category 'accessing') -----
threshold: thresh
"What fraction of the time can a process be the active process before we stop it?"
threshold := (thresh max: 0.02) min: 1.0!
----- Method: CPUWatcher>>watcherProcess (in category 'accessing') -----
watcherProcess
^watcher!
Model subclass: #DualChangeSorter
instanceVariableNames: 'leftCngSorter rightCngSorter'
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Changes'!
!DualChangeSorter commentStamp: '<historical>' prior: 0!
This class presents a view of a two change sets at once, and supports copying changes between change sets.
!
----- Method: DualChangeSorter class>>open (in category 'opening') -----
open
"Open a new instance of the receiver's class"
self new open!
----- Method: DualChangeSorter class>>prototypicalToolWindow (in category 'opening') -----
prototypicalToolWindow
"Answer an example of myself seen in a tool window, for the benefit of parts-launching tools"
^ ToolBuilder build: self new!
----- Method: DualChangeSorter class>>registerInFlapsRegistry (in category 'class initialization') -----
registerInFlapsRegistry
"Register the receiver in the system's flaps registry"
self environment
at: #Flaps
ifPresent: [:cl | cl registerQuad: #(DualChangeSorter prototypicalToolWindow 'Change Sorter' 'Shows two change sets side by side')
forFlapNamed: 'Tools']!
----- Method: DualChangeSorter class>>unload (in category 'class initialization') -----
unload
"Unload the receiver from global registries"
self environment at: #Flaps ifPresent: [:cl |
cl unregisterQuadsWithReceiver: self] !
----- Method: DualChangeSorter class>>windowColorSpecification (in category 'window color') -----
windowColorSpecification
"Answer a WindowColorSpec object that declares my preference"
^ WindowColorSpec classSymbol: self name wording: 'Dual Change Sorter' brightColor: #lightBlue pastelColor: #paleBlue helpMessage: 'Lets you view and manipulate two change sets concurrently.'!
----- Method: DualChangeSorter>>buildWith: (in category 'toolbuilder') -----
buildWith: builder
| windowSpec window |
leftCngSorter := ChangeSorter new myChangeSet: ChangeSet current.
leftCngSorter parent: self.
rightCngSorter := ChangeSorter new myChangeSet:
ChangeSorter secondaryChangeSet.
rightCngSorter parent: self.
windowSpec := builder pluggableWindowSpec new.
windowSpec model: self.
windowSpec label: 'Change Sorter'.
windowSpec children: OrderedCollection new.
windowSpec label: #labelString.
leftCngSorter buildWith: builder in: windowSpec rect: (0 at 0 extent: 0.5 at 1).
rightCngSorter buildWith: builder in: windowSpec rect: (0.5 at 0 extent: 0.5 at 1).
window := builder build: windowSpec.
leftCngSorter addDependent: window. "so it will get changed: #relabel"
rightCngSorter addDependent: window. "so it will get changed: #relabel"
^window!
----- Method: DualChangeSorter>>isLeftSide: (in category 'other') -----
isLeftSide: theOne
"Which side am I?"
^ theOne == leftCngSorter!
----- Method: DualChangeSorter>>labelString (in category 'other') -----
labelString
"The window label"
| leftName rightName changesName |
leftName := leftCngSorter changeSetCategory categoryName.
rightName := rightCngSorter changeSetCategory categoryName.
changesName := 'Changes go to "', ChangeSet current name, '"'.
^ ((leftName ~~ #All) or: [rightName ~~ #All])
ifTrue:
['(', leftName, ') - ', changesName, ' - (', rightName, ')']
ifFalse:
[changesName]!
----- Method: DualChangeSorter>>modelWakeUp (in category 'other') -----
modelWakeUp
"A window with me as model is being entered. Make sure I am up-to-date with the changeSets."
"Dumb way"
leftCngSorter canDiscardEdits
ifTrue: [leftCngSorter update] "does both"
ifFalse: [rightCngSorter update].
!
----- Method: DualChangeSorter>>okToChange (in category 'initialization') -----
okToChange
^ leftCngSorter okToChange & rightCngSorter okToChange!
----- Method: DualChangeSorter>>open (in category 'initialization') -----
open
^ToolBuilder open: self!
----- Method: DualChangeSorter>>other: (in category 'other') -----
other: theOne
"Return the other side's ChangeSorter"
^ theOne == leftCngSorter
ifTrue: [rightCngSorter]
ifFalse: [leftCngSorter]!
----- Method: DualChangeSorter>>release (in category 'initialization') -----
release
leftCngSorter release.
rightCngSorter release.!
----- Method: Model>>addItem: (in category '*Tools') -----
addItem: classAndMethod
"Make a linked message list and put this method in it"
| list |
self flag: #mref. "classAndMethod is a String"
MessageSet
parse: classAndMethod
toClassAndSelector: [ :class :sel |
class ifNil: [^self].
list := OrderedCollection with: (
MethodReference new
setClass: class
methodSymbol: sel
stringVersion: classAndMethod
).
MessageSet
openMessageList: list
name: 'Linked by HyperText'.
]
!
Model subclass: #PointerFinder
instanceVariableNames: 'goal parents toDo toDoNext hasGemStone pointerList objectList parentsSize todoSize depth pointerListIndex'
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Debugger'!
!PointerFinder commentStamp: '<historical>' prior: 0!
I can search for reasons why a certain object isn't garbage collected. I'm a quick port of a VisualWorks program written by Hans-Martin Mosner. Call me as shown below. I'll search for a path from a global variable to the given object, presenting it in a small morphic UI.
Examples:
PointerFinder on: self currentHand
PointerFinder on: StandardSystemView someInstance
Now, let's see why this image contains more HandMorphs as expected...
HandMorph allInstancesDo: [:e | PointerFinder on: e]!
----- Method: PointerFinder class>>on: (in category 'instance creation') -----
on: anObject
^ self new goal: anObject; search; open!
----- Method: PointerFinder class>>pointersTo: (in category 'utilities') -----
pointersTo: anObject
"Find all occurrences in the system of pointers to the argument anObject."
"(PointerFinder pointersTo: Browser) inspect."
^ self pointersTo: anObject except: #()
!
----- Method: PointerFinder class>>pointersTo:except: (in category 'utilities') -----
pointersTo: anObject except: objectsToExclude
"Find all occurrences in the system of pointers to the argument anObject.
Remove objects in the exclusion list from the results."
| results anObj lastObj |
Smalltalk garbageCollect.
"big collection shouldn't grow, so it's contents array is always the same"
results := OrderedCollection new: 1000.
"allObjectsDo: is expanded inline to keep spurious
method and block contexts out of the results"
anObj := self someObject.
lastObj := Object new.
[lastObj == anObj] whileFalse: [
anObj isInMemory ifTrue: [
(anObj pointsTo: anObject) ifTrue: [
"exclude the results collector and contexts in call chain"
((anObj ~~ results collector) and:
[(anObj ~~ objectsToExclude) and:
[(anObj ~~ thisContext) and:
[(anObj ~~ thisContext sender) and:
[anObj ~~ thisContext sender sender]]]])
ifTrue: [ results add: anObj ].
]].
anObj := anObj nextObject.
].
objectsToExclude do: [ :obj | results removeAllSuchThat: [ :el | el == obj]].
^ results asArray
!
----- Method: PointerFinder class>>pointersToItem:of: (in category 'utilities') -----
pointersToItem: index of: anArray
"Find all occurrences in the system of pointers to the given element of the given array.
This is useful for tracing up a pointer chain from an inspector on the results of a previous call of pointersTo:. To find out who points to the second element of the results, one would evaluate:
PointerFinder pointersToItem: 2 of: self
in the inspector."
^ self pointersTo: (anArray at: index) except: (Array with: anArray)!
----- Method: PointerFinder>>arrowKey:from: (in category 'morphic ui') -----
arrowKey: key from: aController
key = $i ifTrue: [^ self inspectObject].
^ super arrowKey: key from: aController!
----- Method: PointerFinder>>buildList (in category 'application') -----
buildList
| list obj parent object key |
list := OrderedCollection new.
obj := goal.
[list addFirst: obj.
obj := parents at: obj ifAbsent: [].
obj == nil] whileFalse.
list removeFirst.
parent := Smalltalk.
objectList := OrderedCollection new.
pointerList := OrderedCollection new.
[list isEmpty]
whileFalse:
[object := list removeFirst.
key := nil.
(parent isKindOf: Dictionary)
ifTrue: [list size >= 2
ifTrue:
[key := parent keyAtValue: list second ifAbsent: [].
key == nil
ifFalse:
[object := list removeFirst; removeFirst.
pointerList add: key printString , ' -> ' , object class name]]].
key == nil
ifTrue:
[parent class == object ifTrue: [key := 'CLASS'].
key == nil ifTrue: [1 to: parent class instSize do: [:i | key == nil ifTrue: [(parent instVarAt: i)
== object ifTrue: [key := parent class allInstVarNames at: i]]]].
key == nil ifTrue: [1 to: parent basicSize do: [:i | key == nil ifTrue: [(parent basicAt: i)
== object ifTrue: [key := i printString]]]].
key == nil ifTrue: [(parent isMorph and: [object isKindOf: Array]) ifTrue: [key := 'submorphs?']].
key == nil ifTrue: [(parent isCompiledMethod and: [object isVariableBinding]) ifTrue: [key := 'literals?']].
key == nil ifTrue: [key := '???'].
pointerList add: key , ': ' , object class name].
objectList add: object.
parent := object]!
----- Method: PointerFinder>>follow:from: (in category 'application') -----
follow: anObject from: parentObject
anObject == goal
ifTrue:
[parents at: anObject put: parentObject.
^ true].
anObject isLiteral ifTrue: [^ false].
"Remove this after switching to new CompiledMethod format --bf 2/12/2006"
(anObject class isPointers or: [anObject isCompiledMethod]) ifFalse: [^ false].
anObject class isWeak ifTrue: [^ false].
(parents includesKey: anObject)
ifTrue: [^ false].
parents at: anObject put: parentObject.
toDoNext add: anObject.
^ false!
----- Method: PointerFinder>>followObject: (in category 'application') -----
followObject: anObject
(self follow: anObject class from: anObject)
ifTrue: [^ true].
"Remove this after switching to new CompiledMethod format --bf 2/12/2006"
anObject isCompiledMethod ifTrue: [
1 to: anObject numLiterals do:
[:i |
(self follow: (anObject literalAt: i) from: anObject)
ifTrue: [^ true]].
^false].
1 to: anObject class instSize do:
[:i |
(self follow: (anObject instVarAt: i) from: anObject)
ifTrue: [^ true]].
1 to: anObject basicSize do:
[:i |
(self follow: (anObject basicAt: i) from: anObject)
ifTrue: [^ true]].
^ false!
----- Method: PointerFinder>>goal: (in category 'application') -----
goal: anObject
goal := anObject!
----- Method: PointerFinder>>initialExtent (in category 'morphic ui') -----
initialExtent
^ 300 @ 300!
----- Method: PointerFinder>>initialize (in category 'application') -----
initialize
parents := IdentityDictionary new: 20000.
parents at: Smalltalk put: nil.
parents at: Processor put: nil.
parents at: self put: nil.
toDo := OrderedCollection new: 5000.
toDo add: Smalltalk.
toDoNext := OrderedCollection new: 5000!
----- Method: PointerFinder>>inspectObject (in category 'morphic ui') -----
inspectObject
pointerListIndex = 0 ifTrue: [^ Beeper beep].
(objectList at: pointerListIndex) inspect!
----- Method: PointerFinder>>isLiteral (in category 'application') -----
isLiteral
"Horrible hack to omit other Pointer Finders from scanning."
^ true!
----- Method: PointerFinder>>isSelfEvaluating (in category 'self evaluating') -----
isSelfEvaluating
^ false!
----- Method: PointerFinder>>menu:shifted: (in category 'morphic ui') -----
menu: aMenu shifted: shifted
^ MenuMorph new
defaultTarget: self;
add: 'Inspect (i)' action: #inspectObject;
balloonTextForLastItem: 'Live long and prosper!!';
addLine;
add: 'Search again' action: #searchAgain;
balloonTextForLastItem: 'Search again\for the same object' withCRs;
yourself!
----- Method: PointerFinder>>open (in category 'morphic ui') -----
open
| window list |
window := (SystemWindow labelled: 'Pointer Finder')
model: self.
list := PluggableListMorph new
doubleClickSelector: #inspectObject;
on: self
list: #pointerList
selected: #pointerListIndex
changeSelected: #pointerListIndex:
menu: #menu:shifted:
keystroke: #arrowKey:from:.
"For doubleClick to work best disable autoDeselect"
list autoDeselect: false.
window addMorph: list frame: (0 at 0 extent: 1 at 1).
list color: Color lightMagenta.
window openInWorld!
----- Method: PointerFinder>>perform:orSendTo: (in category 'morphic ui') -----
perform: selector orSendTo: otherTarget
selector == #inspectObject ifTrue: [^ self inspectObject].
selector == #searchAgain ifTrue: [^ self searchAgain].
^ super perform: selector orSendTo: otherTarget!
----- Method: PointerFinder>>pointerList (in category 'morphic ui') -----
pointerList
^ pointerList asArray!
----- Method: PointerFinder>>pointerListIndex (in category 'morphic ui') -----
pointerListIndex
^ pointerListIndex ifNil: [0]!
----- Method: PointerFinder>>pointerListIndex: (in category 'morphic ui') -----
pointerListIndex: anInteger
pointerListIndex := anInteger.
self changed: #pointerListIndex!
----- Method: PointerFinder>>search (in category 'application') -----
search
Smalltalk garbageCollect.
self initialize.
Cursor wait showWhile: [
[[toDo isEmpty or: [self followObject: toDo removeFirst]] whileFalse.
toDo isEmpty and: [toDoNext isEmpty not]]
whileTrue:
[toDo := toDoNext.
toDoNext := OrderedCollection new: 5000]].
self buildList!
----- Method: PointerFinder>>searchAgain (in category 'morphic ui') -----
searchAgain
self pointerListIndex: 0.
self search.
self changed: #pointerList!
----- Method: PointerFinder>>update (in category 'application') -----
update
('done: ' , parents size asString , ' todo: ' , toDo size asString , ' ') displayAt: 0 at 0!
Model subclass: #ProcessBrowser
instanceVariableNames: 'selectedProcess selectedContext methodText processList processListIndex stackList stackListIndex sourceMap selectedClass selectedSelector searchString autoUpdateProcess lastUpdate startedCPUWatcher'
classVariableNames: 'Browsers SuspendedProcesses WellKnownProcesses'
poolDictionaries: ''
category: 'Tools-Process Browser'!
!ProcessBrowser commentStamp: '<historical>' prior: 0!
Change Set: ProcessBrowser
Date: 14 March 2000
Author: Ned Konz
email: ned at bike-nomad.com
This is distributed under the Squeak License.
Added 14 March:
CPUWatcher integration
automatically start and stop CPUWatcher
added CPUWatcher to process list menu
Added 29 October:
MVC version
2.8, 2.7 compatibility
rearranged menus
added pointer inspection and chasing
added suspend/resume
recognized more well-known processes
misc. bug fixes
Added 26 October: highlight pc in source code
Added 27 October: added 'signal semaphore'
added 'inspect receiver', 'explore receiver', 'message tally' to stack list menu
added 'find context', 'next context' to process list menu
added 'change priority' and 'debug' choices to process list menu
27 October mods by Bob Arning:
alters process display in Ned's ProcessBrowser to
- show process priority
- drop 'a Process in' that appears on each line
- show in priority order
- prettier names for known processes
- fix to Utilities to forget update downloading process when it ends (1 less dead
process)
- correct stack dump for the active process
!
----- Method: ProcessBrowser class>>debugProcess: (in category 'process control') -----
debugProcess: aProcess
self resumeProcess: aProcess.
aProcess debugWithTitle: 'Interrupted from the Process Browser'.
!
----- Method: ProcessBrowser class>>dumpTallyOnTranscript: (in category 'CPU utilization') -----
dumpTallyOnTranscript: tally
"tally is from ProcessorScheduler>>tallyCPUUsageFor:
Dumps lines with percentage of time, hash of process, and a friendly name"
tally sortedCounts do: [ :assoc | | procName |
procName := (self nameAndRulesFor: assoc value) first.
Transcript print: (((assoc key / tally size) * 100.0) roundTo: 1);
nextPutAll: '% ';
print: assoc value identityHash; space;
nextPutAll: procName;
cr.
].
Transcript flush.!
----- Method: ProcessBrowser class>>initialize (in category 'class initialization') -----
initialize
"ProcessBrowser initialize"
Browsers ifNil: [ Browsers := WeakSet new ].
SuspendedProcesses ifNil: [ SuspendedProcesses := IdentityDictionary new ].
Smalltalk addToStartUpList: self.
Smalltalk addToShutDownList: self.
self registerInFlapsRegistry.
self registerWellKnownProcesses!
----- Method: ProcessBrowser class>>isUIProcess: (in category 'process control') -----
isUIProcess: aProcess
^aProcess == (Smalltalk isMorphic
ifTrue: [ Project uiProcess ]
ifFalse: [ ScheduledControllers activeControllerProcess ])!
----- Method: ProcessBrowser class>>nameAndRulesFor: (in category 'process control') -----
nameAndRulesFor: aProcess
"Answer a nickname and two flags: allow-stop, and allow-debug"
^ [aProcess caseOf: WellKnownProcesses
otherwise:
[(aProcess priority = Processor timingPriority
and: [aProcess suspendedContext receiver == Delay])
ifTrue: [{'the timer interrupt watcher'. false. false}]
ifFalse: [{aProcess suspendedContext asString. true. true}]]]
ifError: [:err :rcvr | {aProcess suspendedContext asString. true. true}]!
----- Method: ProcessBrowser class>>open (in category 'instance creation') -----
open
"ProcessBrowser open"
"Create and schedule a ProcessBrowser."
Smalltalk garbageCollect.
^ToolBuilder open: self new!
----- Method: ProcessBrowser class>>prototypicalToolWindow (in category 'instance creation') -----
prototypicalToolWindow
"Answer a window representing a prototypical instance of the receiver"
^ self new asPrototypeInWindow!
----- Method: ProcessBrowser class>>registerInFlapsRegistry (in category 'class initialization') -----
registerInFlapsRegistry
"Register the receiver in the system's flaps registry"
self environment
at: #Flaps
ifPresent: [:cl | cl registerQuad: #(ProcessBrowser prototypicalToolWindow 'Processes' 'A Process Browser shows you all the running processes')
forFlapNamed: 'Tools'.]!
----- Method: ProcessBrowser class>>registerWellKnownProcess:label:allowStop:allowDebug: (in category 'process control') -----
registerWellKnownProcess: aBlockForProcess label: nickname allowStop: allowStop allowDebug: allowDebug
"Add an entry to the registry of well known processes. aBlockForProcess
evaluates to a known process to be identified by nickname, and allowStop
and allowDebug are flags controlling allowable actions for this process
in the browser."
WellKnownProcesses add: aBlockForProcess->[{nickname . allowStop . allowDebug}]!
----- Method: ProcessBrowser class>>registerWellKnownProcesses (in category 'class initialization') -----
registerWellKnownProcesses
"Associate each well-known process with a nickname and two flags: allow-stop, and allow-debug.
Additional processes may be added to this list as required"
WellKnownProcesses := OrderedCollection new.
self registerWellKnownProcess: []
label: 'no process'
allowStop: false
allowDebug: false.
self registerWellKnownProcess: [Smalltalk lowSpaceWatcherProcess]
label: 'the low space watcher'
allowStop: false
allowDebug: false.
self registerWellKnownProcess: [WeakArray runningFinalizationProcess]
label: 'the WeakArray finalization process'
allowStop: false
allowDebug: false.
self registerWellKnownProcess: [Processor activeProcess]
label: 'the UI process'
allowStop: false
allowDebug: true.
self registerWellKnownProcess: [Processor backgroundProcess]
label: 'the idle process'
allowStop: false
allowDebug: false.
self registerWellKnownProcess: [Sensor interruptWatcherProcess]
label: 'the user interrupt watcher'
allowStop: false
allowDebug: false.
self registerWellKnownProcess: [Sensor eventTicklerProcess]
label: 'the event tickler'
allowStop: false
allowDebug: false.
self registerWellKnownProcess: [Project uiProcess]
label: 'the inactive Morphic UI process'
allowStop: false
allowDebug: false.
self registerWellKnownProcess:
[Smalltalk at: #SoundPlayer ifPresent: [:sp | sp playerProcess]]
label: 'the Sound Player'
allowStop: false
allowDebug: false.
self registerWellKnownProcess:
[ScheduledControllers ifNotNil: [ScheduledControllers activeControllerProcess]]
label: 'the inactive MVC controller process'
allowStop: false
allowDebug: true.
self registerWellKnownProcess:
[Smalltalk at: #CPUWatcher ifPresent: [:cw | cw currentWatcherProcess]]
label: 'the CPUWatcher'
allowStop: false
allowDebug: false
!
----- Method: ProcessBrowser class>>resumeProcess: (in category 'process control') -----
resumeProcess: aProcess
| priority |
priority := self suspendedProcesses
removeKey: aProcess
ifAbsent: [aProcess priority].
aProcess priority: priority.
aProcess suspendedContext ifNotNil: [ aProcess resume ]
!
----- Method: ProcessBrowser class>>setProcess:toPriority: (in category 'process control') -----
setProcess: aProcess toPriority: priority
| oldPriority |
oldPriority := self suspendedProcesses at: aProcess ifAbsent: [ ].
oldPriority ifNotNil: [ self suspendedProcesses at: aProcess put: priority ].
aProcess priority: priority.
^oldPriority!
----- Method: ProcessBrowser class>>shutDown (in category 'system startup') -----
shutDown
Browsers do: [ :ea | ea isAutoUpdating ifTrue: [ ea pauseAutoUpdate ]]!
----- Method: ProcessBrowser class>>startUp (in category 'system startup') -----
startUp
Browsers
do: [:ea | | paused | ea isAutoUpdatingPaused
ifTrue: [ea initialize; startAutoUpdate]]!
----- Method: ProcessBrowser class>>suspendProcess: (in category 'process control') -----
suspendProcess: aProcess
| priority |
priority := aProcess priority.
self suspendedProcesses at: aProcess put: priority.
"Need to take the priority down below the caller's
so that it can keep control after signaling the Semaphore"
(aProcess suspendingList isKindOf: Semaphore)
ifTrue: [aProcess priority: Processor lowestPriority.
aProcess suspendingList signal].
[aProcess suspend]
on: Error
do: [:ex | self suspendedProcesses removeKey: aProcess].
aProcess priority: priority.
!
----- Method: ProcessBrowser class>>suspendedProcesses (in category 'process control') -----
suspendedProcesses
"Answer a collection of processes that my instances have suspended.
This is so that they don't get garbage collected."
^ SuspendedProcesses
ifNil: [SuspendedProcesses := IdentityDictionary new]!
----- Method: ProcessBrowser class>>tallyCPUUsageFor: (in category 'CPU utilization') -----
tallyCPUUsageFor: seconds
"Compute CPU usage using a 10-msec sample for the given number of seconds,
then dump the usage statistics on the Transcript. The UI is free to continue, meanwhile"
"ProcessBrowser tallyCPUUsageFor: 10"
^self tallyCPUUsageFor: seconds every: 10!
----- Method: ProcessBrowser class>>tallyCPUUsageFor:every: (in category 'CPU utilization') -----
tallyCPUUsageFor: seconds every: msec
"Compute CPU usage using a msec millisecond sample for the given number of seconds,
then dump the usage statistics on the Transcript. The UI is free to continue, meanwhile"
"ProcessBrowser tallyCPUUsageFor: 10 every: 100"
| promise |
promise := Processor tallyCPUUsageFor: seconds every: msec.
[ | tally |
tally := promise value.
Smalltalk isMorphic
ifTrue: [ Project current addDeferredUIMessage: [ self dumpTallyOnTranscript: tally ] ]
ifFalse: [ [ Transcript open ] forkAt: Processor userSchedulingPriority.
[ (Delay forSeconds: 1) wait.
self dumpTallyOnTranscript: tally ] forkAt: Processor userSchedulingPriority.]
] fork.!
----- Method: ProcessBrowser class>>terminateProcess: (in category 'process control') -----
terminateProcess: aProcess
aProcess ifNotNil: [
self suspendedProcesses
removeKey: aProcess
ifAbsent: [].
aProcess terminate
].
!
----- Method: ProcessBrowser class>>unload (in category 'class initialization') -----
unload
"Unload the receiver from global registries"
self environment at: #Flaps ifPresent: [:cl |
cl unregisterQuadsWithReceiver: self] !
----- Method: ProcessBrowser class>>unregisterWellKnownProcess: (in category 'process control') -----
unregisterWellKnownProcess: aProcess
"Remove the first registry entry that matches aProcess. Use
with caution if more than one registry entry may match aProcess."
"self unregisterWellKnownProcess: Smalltalk lowSpaceWatcherProcess"
| entry |
entry := WellKnownProcesses
detect: [:e | e key value == aProcess]
ifNone: [^ self].
WellKnownProcesses remove: entry!
----- Method: ProcessBrowser class>>wasProcessSuspendedByProcessBrowser: (in category 'process control') -----
wasProcessSuspendedByProcessBrowser: aProcess
^self suspendedProcesses includesKey: aProcess!
----- Method: ProcessBrowser>>asPrototypeInWindow (in category 'views') -----
asPrototypeInWindow
"Create a pluggable version of me, answer a window"
| window aTextMorph |
window := (SystemWindow labelled: 'later') model: self.
window
addMorph: ((PluggableListMorph
on: self
list: #processNameList
selected: #processListIndex
changeSelected: #processListIndex:
menu: #processListMenu:
keystroke: #processListKey:from:)
enableDragNDrop: false)
frame: (0 @ 0 extent: 0.5 @ 0.5).
window
addMorph: ((PluggableListMorph
on: self
list: #stackNameList
selected: #stackListIndex
changeSelected: #stackListIndex:
menu: #stackListMenu:
keystroke: #stackListKey:from:)
enableDragNDrop: false)
frame: (0.5 @ 0.0 extent: 0.5 @ 0.5).
aTextMorph := PluggableTextMorph
on: self
text: #selectedMethod
accept: nil
readSelection: nil
menu: nil.
window
addMorph: aTextMorph
frame: (0 @ 0.5 corner: 1 @ 1).
window setLabel: 'Process Browser'.
^ window!
----- Method: ProcessBrowser>>browseContext (in category 'stack list') -----
browseContext
selectedContext
ifNil: [^ self].
Browser newOnClass: self selectedClass selector: self selectedSelector!
----- Method: ProcessBrowser>>buildWith: (in category 'toolbuilder') -----
buildWith: builder
"Create a pluggable version of me, answer a window"
| windowSpec listSpec textSpec |
windowSpec := builder pluggableWindowSpec new.
windowSpec model: self.
windowSpec label: 'Process Browser'.
windowSpec children: OrderedCollection new.
listSpec := builder pluggableListSpec new.
listSpec
model: self;
list: #processNameList;
getIndex: #processListIndex;
setIndex: #processListIndex:;
menu: #processListMenu:;
keyPress: #processListKey:from:;
frame: (0 @ 0 extent: 0.5 @ 0.5).
windowSpec children add: listSpec.
listSpec := builder pluggableListSpec new.
listSpec
model: self;
list: #stackNameList;
getIndex: #stackListIndex;
setIndex: #stackListIndex:;
menu: #stackListMenu:;
keyPress: #stackListKey:from:;
frame: (0.5 @ 0.0 extent: 0.5 @ 0.5).
windowSpec children add: listSpec.
textSpec := builder pluggableTextSpec new.
textSpec
model: self;
getText: #selectedMethod;
setText: nil;
selection: nil;
menu: nil;
frame: (0 @ 0.5 corner: 1 @ 1).
windowSpec children add: textSpec.
^builder build: windowSpec!
----- Method: ProcessBrowser>>changePriority (in category 'process actions') -----
changePriority
| str newPriority nameAndRules |
nameAndRules := self nameAndRulesForSelectedProcess.
nameAndRules third
ifFalse: [self inform: 'Nope, won''t change priority of ' , nameAndRules first.
^ self].
str := UIManager default
request: 'New priority'
initialAnswer: selectedProcess priority asString.
newPriority := str asNumber asInteger.
newPriority
ifNil: [^ self].
(newPriority < 1
or: [newPriority > Processor highestPriority])
ifTrue: [self inform: 'Bad priority'.
^ self].
self class setProcess: selectedProcess toPriority: newPriority.
self updateProcessList!
----- Method: ProcessBrowser>>changeStackListTo: (in category 'stack list') -----
changeStackListTo: aCollection
stackList := aCollection.
self changed: #stackNameList.
self stackListIndex: 0!
----- Method: ProcessBrowser>>chasePointers (in category 'process actions') -----
chasePointers
| saved |
selectedProcess
ifNil: [^ self].
saved := selectedProcess.
[selectedProcess := nil.
(Smalltalk includesKey: #PointerFinder)
ifTrue: [PointerFinder on: saved]
ifFalse: [self inspectPointers]]
ensure: [selectedProcess := saved]!
----- Method: ProcessBrowser>>debugProcess (in category 'process actions') -----
debugProcess
| nameAndRules |
nameAndRules := self nameAndRulesForSelectedProcess.
nameAndRules third
ifFalse: [self inform: 'Nope, won''t debug ' , nameAndRules first.
^ self].
self class debugProcess: selectedProcess.!
----- Method: ProcessBrowser>>exploreContext (in category 'stack list') -----
exploreContext
selectedContext explore!
----- Method: ProcessBrowser>>exploreProcess (in category 'process list') -----
exploreProcess
selectedProcess explore!
----- Method: ProcessBrowser>>exploreReceiver (in category 'stack list') -----
exploreReceiver
selectedContext ifNotNil: [ selectedContext receiver explore ]!
----- Method: ProcessBrowser>>findContext (in category 'process list') -----
findContext
| initialProcessIndex initialStackIndex found |
initialProcessIndex := self processListIndex.
initialStackIndex := self stackListIndex.
searchString := UIManager default
request: 'Enter a string to search for in the process stack lists'
initialAnswer: searchString.
searchString isEmpty
ifTrue: [^ false].
self processListIndex: 1.
self stackListIndex: 1.
found := self nextContext.
found
ifFalse: [self processListIndex: initialProcessIndex.
self stackListIndex: initialStackIndex].
^ found!
----- Method: ProcessBrowser>>hasView (in category 'views') -----
hasView
^self dependents isEmptyOrNil not!
----- Method: ProcessBrowser>>initialize (in category 'initialize-release') -----
initialize
methodText := ''.
stackListIndex := 0.
searchString := ''.
lastUpdate := 0.
startedCPUWatcher := Preferences cpuWatcherEnabled and: [ self startCPUWatcher ].
self updateProcessList; processListIndex: 1.
Browsers add: self!
----- Method: ProcessBrowser>>inspectContext (in category 'stack list') -----
inspectContext
selectedContext inspect!
----- Method: ProcessBrowser>>inspectPointers (in category 'process actions') -----
inspectPointers
| tc pointers |
selectedProcess ifNil: [^self].
tc := thisContext.
pointers := PointerFinder pointersTo: selectedProcess
except: {
self processList.
tc.
self}.
pointers isEmpty ifTrue: [^self].
OrderedCollectionInspector
openOn: pointers
withEvalPane: false
withLabel: 'Objects pointing to ' , selectedProcess browserPrintString!
----- Method: ProcessBrowser>>inspectProcess (in category 'process list') -----
inspectProcess
selectedProcess inspect!
----- Method: ProcessBrowser>>inspectReceiver (in category 'stack list') -----
inspectReceiver
selectedContext
ifNotNil: [selectedContext receiver inspect]!
----- Method: ProcessBrowser>>isAutoUpdating (in category 'updating') -----
isAutoUpdating
^autoUpdateProcess notNil and: [ autoUpdateProcess isSuspended not ]!
----- Method: ProcessBrowser>>isAutoUpdatingPaused (in category 'updating') -----
isAutoUpdatingPaused
^autoUpdateProcess notNil and: [ autoUpdateProcess isSuspended ]!
----- Method: ProcessBrowser>>messageTally (in category 'stack list') -----
messageTally
| secString secs |
secString := UIManager default request: 'Profile for how many seconds?' initialAnswer: '4'.
secs := secString asNumber asInteger.
(secs isNil
or: [secs isZero])
ifTrue: [^ self].
[ TimeProfileBrowser spyOnProcess: selectedProcess forMilliseconds: secs * 1000 ] forkAt: selectedProcess priority + 1.!
----- Method: ProcessBrowser>>moreStack (in category 'stack list') -----
moreStack
self updateStackList: 2000!
----- Method: ProcessBrowser>>nameAndRulesFor: (in category 'process actions') -----
nameAndRulesFor: aProcess
"Answer a nickname and two flags: allow-stop, and allow-debug"
aProcess == autoUpdateProcess ifTrue: [ ^{'my auto-update process'. true. true} ].
^self class nameAndRulesFor: aProcess
!
----- Method: ProcessBrowser>>nameAndRulesForSelectedProcess (in category 'process actions') -----
nameAndRulesForSelectedProcess
"Answer a nickname and two flags: allow-stop, and allow-debug"
^self nameAndRulesFor: selectedProcess!
----- Method: ProcessBrowser>>nextContext (in category 'process list') -----
nextContext
| initialProcessIndex initialStackIndex found |
searchString isEmpty ifTrue: [ ^false ].
initialProcessIndex := self processListIndex.
initialStackIndex := self stackListIndex.
found := false.
initialProcessIndex
to: self processList size
do: [:pi | found
ifFalse: [self processListIndex: pi.
self stackNameList
withIndexDo: [:name :si | (found not
and: [pi ~= initialProcessIndex
or: [si > initialStackIndex]])
ifTrue: [(name includesSubString: searchString)
ifTrue: [self stackListIndex: si.
found := true]]]]].
found
ifFalse: [self processListIndex: initialProcessIndex.
self stackListIndex: initialStackIndex].
^ found!
----- Method: ProcessBrowser>>notify:at:in: (in category 'process list') -----
notify: errorString at: location in: aStream
"A syntax error happened when I was trying to highlight my pc.
Raise a signal so that it can be ignored."
Warning signal: 'syntax error'!
----- Method: ProcessBrowser>>openAsMVC (in category 'views') -----
openAsMVC
"Create a pluggable version of me, answer a window"
| window processListView stackListView methodTextView |
window := StandardSystemView new model: self controller: StandardSystemController new.
window borderWidth: 1.
processListView := PluggableListView
on: self
list: #processNameList
selected: #processListIndex
changeSelected: #processListIndex:
menu: #processListMenu:
keystroke: #processListKey:from:.
processListView
window: (0 @ 0 extent: 300 @ 200).
window addSubView: processListView.
stackListView := PluggableListView
on: self
list: #stackNameList
selected: #stackListIndex
changeSelected: #stackListIndex:
menu: #stackListMenu:
keystroke: #stackListKey:from:.
stackListView
window: (300 @ 0 extent: 300 @ 200).
window addSubView: stackListView toRightOf: processListView.
methodTextView := PluggableTextView
on: self
text: #selectedMethod
accept: nil
readSelection: nil
menu: nil.
methodTextView askBeforeDiscardingEdits: false.
methodTextView
window: (0 @ 200 corner: 600 @ 400).
window addSubView: methodTextView below: processListView.
window setUpdatablePanesFrom: #(#processNameList #stackNameList ).
window label: 'Process Browser'.
window minimumSize: 300 @ 200.
window subViews
do: [:each | each controller].
window controller open.
startedCPUWatcher ifTrue: [ self setUpdateCallbackAfter: 7 ].
^ window!
----- Method: ProcessBrowser>>openAsMorph (in category 'views') -----
openAsMorph
"Create a pluggable version of me, answer a window"
| window aTextMorph |
window := (SystemWindow labelled: 'later')
model: self.
window
addMorph: ((PluggableListMorph
on: self
list: #processNameList
selected: #processListIndex
changeSelected: #processListIndex:
menu: #processListMenu:
keystroke: #processListKey:from:)
enableDragNDrop: false)
frame: (0 @ 0 extent: 0.5 @ 0.5).
window
addMorph: ((PluggableListMorph
on: self
list: #stackNameList
selected: #stackListIndex
changeSelected: #stackListIndex:
menu: #stackListMenu:
keystroke: #stackListKey:from:)
enableDragNDrop: false)
frame: (0.5 @ 0.0 extent: 0.5 @ 0.5).
aTextMorph := PluggableTextMorph
on: self
text: #selectedMethod
accept: nil
readSelection: nil
menu: nil.
aTextMorph askBeforeDiscardingEdits: false.
window
addMorph: aTextMorph
frame: (0 @ 0.5 corner: 1 @ 1).
window setUpdatablePanesFrom: #(#processNameList #stackNameList ).
(window setLabel: 'Process Browser') openInWorld.
startedCPUWatcher ifTrue: [ self setUpdateCallbackAfter: 7 ].
^ window!
----- Method: ProcessBrowser>>pauseAutoUpdate (in category 'updating') -----
pauseAutoUpdate
self isAutoUpdating
ifTrue: [ autoUpdateProcess suspend ].
self updateProcessList!
----- Method: ProcessBrowser>>pcRange (in category 'stack list') -----
pcRange
"Answer the indices in the source code for the method corresponding to
the selected context's program counter value."
(selectedContext isNil or: [methodText isEmptyOrNil])
ifTrue: [^ 1 to: 0].
^selectedContext debuggerMap
rangeForPC: (selectedContext pc ifNotNilDo: [:pc| pc] ifNil: [selectedContext method endPC])
contextIsActiveContext: stackListIndex = 1!
----- Method: ProcessBrowser>>perform:orSendTo: (in category 'message handling') -----
perform: selector orSendTo: otherTarget
"Selector was just chosen from a menu by a user. If can respond, then
perform it on myself. If not, send it to otherTarget, presumably the
editPane from which the menu was invoked."
(self respondsTo: selector)
ifTrue: [^ self perform: selector]
ifFalse: [^ super perform: selector orSendTo: otherTarget]!
----- Method: ProcessBrowser>>prettyNameForProcess: (in category 'process list') -----
prettyNameForProcess: aProcess
| nameAndRules |
aProcess ifNil: [ ^'<nil>' ].
nameAndRules := self nameAndRulesFor: aProcess.
^ aProcess browserPrintStringWith: nameAndRules first!
----- Method: ProcessBrowser>>processList (in category 'accessing') -----
processList
^ processList!
----- Method: ProcessBrowser>>processListIndex (in category 'accessing') -----
processListIndex
^ processListIndex!
----- Method: ProcessBrowser>>processListIndex: (in category 'accessing') -----
processListIndex: index
processListIndex := index.
selectedProcess := processList
at: index
ifAbsent: [].
self updateStackList.
self changed: #processListIndex.!
----- Method: ProcessBrowser>>processListKey:from: (in category 'process list') -----
processListKey: aKey from: aView
^ aKey caseOf: {
[$i] -> [self inspectProcess].
[$I] -> [self exploreProcess].
[$c] -> [self chasePointers].
[$P] -> [self inspectPointers].
[$t] -> [self terminateProcess].
[$r] -> [self resumeProcess].
[$s] -> [self suspendProcess].
[$d] -> [self debugProcess].
[$p] -> [self changePriority].
[$m] -> [self messageTally].
[$f] -> [self findContext].
[$g] -> [self nextContext].
[$a] -> [self toggleAutoUpdate].
[$u] -> [self updateProcessList].
[$S] -> [self signalSemaphore].
[$k] -> [self moreStack]}
otherwise: [self arrowKey: aKey from: aView]!
----- Method: ProcessBrowser>>processListMenu: (in category 'process list') -----
processListMenu: menu
| pw |
selectedProcess
ifNotNil: [| nameAndRules |
nameAndRules := self nameAndRulesForSelectedProcess.
menu addList: {{'inspect (i)'. #inspectProcess}. {'explore (I)'. #exploreProcess}. {'inspect Pointers (P)'. #inspectPointers}}.
(Smalltalk includesKey: #PointerFinder)
ifTrue: [ menu add: 'chase pointers (c)' action: #chasePointers. ].
nameAndRules second
ifTrue: [menu add: 'terminate (t)' action: #terminateProcess.
selectedProcess isSuspended
ifTrue: [menu add: 'resume (r)' action: #resumeProcess]
ifFalse: [menu add: 'suspend (s)' action: #suspendProcess]].
nameAndRules third
ifTrue: [menu addList: {{'change priority (p)'. #changePriority}. {'debug (d)'. #debugProcess}}].
menu addList: {{'profile messages (m)'. #messageTally}}.
(selectedProcess suspendingList isKindOf: Semaphore)
ifTrue: [menu add: 'signal Semaphore (S)' action: #signalSemaphore].
menu add: 'full stack (k)' action: #moreStack.
menu addLine].
menu addList: {{'find context... (f)'. #findContext}. {'find again (g)'. #nextContext}}.
menu addLine.
menu
add: (self isAutoUpdating
ifTrue: ['turn off auto-update (a)']
ifFalse: ['turn on auto-update (a)'])
action: #toggleAutoUpdate.
menu add: 'update list (u)' action: #updateProcessList.
pw := Smalltalk at: #CPUWatcher ifAbsent: [].
pw ifNotNil: [
menu addLine.
pw isMonitoring
ifTrue: [ menu add: 'stop CPUWatcher' action: #stopCPUWatcher ]
ifFalse: [ menu add: 'start CPUWatcher' action: #startCPUWatcher ]
].
^ menu!
----- Method: ProcessBrowser>>processNameList (in category 'process list') -----
processNameList
"since processList is a WeakArray, we have to strengthen the result"
| pw tally |
pw := Smalltalk at: #CPUWatcher ifAbsent: [ ].
tally := pw ifNotNil: [ pw current ifNotNil: [ pw current tally ] ].
^ (processList asOrderedCollection
copyWithout: nil)
collect: [:each | | percent |
percent := tally
ifNotNil: [ ((((tally occurrencesOf: each) * 100.0 / tally size) roundTo: 1)
asString padded: #left to: 2 with: $ ), '% ' ]
ifNil: [ '' ].
percent, (self prettyNameForProcess: each)
] !
----- Method: ProcessBrowser>>resumeProcess (in category 'process actions') -----
resumeProcess
selectedProcess
ifNil: [^ self].
self class resumeProcess: selectedProcess.
self updateProcessList!
----- Method: ProcessBrowser>>selectedClass (in category 'accessing') -----
selectedClass
"Answer the class in which the currently selected context's method was
found."
^ selectedClass
ifNil: [selectedClass := selectedContext receiver
ifNil: [selectedSelector := selectedContext method selector.
selectedContext method methodClass]
ifNotNil: [selectedContext methodClass]]!
----- Method: ProcessBrowser>>selectedMethod (in category 'accessing') -----
selectedMethod
^ methodText ifNil: [methodText := selectedContext
ifNil: ['']
ifNotNil: [| pcRange |
methodText := [ selectedContext sourceCode ]
ifError: [ :err :rcvr | 'error getting method text' ].
pcRange := self pcRange.
methodText asText
addAttribute: TextColor red
from: pcRange first
to: pcRange last;
addAttribute: TextEmphasis bold
from: pcRange first
to: pcRange last]]!
----- Method: ProcessBrowser>>selectedSelector (in category 'accessing') -----
selectedSelector
"Answer the class in which the currently selected context's method was
found."
^ selectedSelector
ifNil: [selectedSelector := selectedContext receiver
ifNil: [selectedClass := selectedContext method methodClass
selectedContext method selector]
ifNotNil: [selectedContext selector]]!
----- Method: ProcessBrowser>>setUpdateCallbackAfter: (in category 'updating') -----
setUpdateCallbackAfter: seconds
| d |
d := Delay forSeconds: seconds.
[d wait.
d := nil.
Project current addDeferredUIMessage: [self updateProcessList]] fork!
----- Method: ProcessBrowser>>signalSemaphore (in category 'process actions') -----
signalSemaphore
(selectedProcess suspendingList isKindOf: Semaphore)
ifFalse: [^ self].
[selectedProcess suspendingList signal] fork.
(Delay forMilliseconds: 300) wait.
"Hate to make the UI wait, but it's convenient..."
self updateProcessList!
----- Method: ProcessBrowser>>stackList (in category 'accessing') -----
stackList
^ stackList!
----- Method: ProcessBrowser>>stackListIndex (in category 'accessing') -----
stackListIndex
^ stackListIndex!
----- Method: ProcessBrowser>>stackListIndex: (in category 'accessing') -----
stackListIndex: index
stackListIndex := index.
selectedContext := (stackList notNil
and: [index > 0]) ifTrue:
[stackList at: index ifAbsent: []].
selectedClass := nil.
selectedSelector := nil.
methodText := nil.
self changed: #stackListIndex.
self changed: #selectedMethod!
----- Method: ProcessBrowser>>stackListKey:from: (in category 'views') -----
stackListKey: aKey from: aView
^ aKey caseOf: {
[$c] -> [self inspectContext].
[$C] -> [self exploreContext].
[$i] -> [self inspectReceiver].
[$I] -> [self exploreReceiver].
[$b] -> [self browseContext]}
otherwise: [self arrowKey: aKey from: aView]!
----- Method: ProcessBrowser>>stackListMenu: (in category 'stack list') -----
stackListMenu: aMenu
| menu |
selectedContext
ifNil: [^ aMenu].
menu := aMenu
labels: 'inspect context (c)
explore context (C)
inspect receiver (i)
explore receiver (I)
browse (b)'
lines: #(2 4 )
selections: #(#inspectContext #exploreContext #inspectReceiver #exploreReceiver #browseContext ).
^ menu!
----- Method: ProcessBrowser>>stackNameList (in category 'stack list') -----
stackNameList
^ stackList
ifNil: [#()]
ifNotNil: [stackList
collect: [:each | each asString]]!
----- Method: ProcessBrowser>>startAutoUpdate (in category 'updating') -----
startAutoUpdate
self isAutoUpdatingPaused
ifTrue: [^ autoUpdateProcess resume].
self isAutoUpdating
ifFalse: [autoUpdateProcess := [[self hasView]
whileTrue: [(Delay forSeconds: 2) wait.
Project current addDeferredUIMessage: [self updateProcessList]].
autoUpdateProcess := nil] fork].
self updateProcessList
!
----- Method: ProcessBrowser>>startCPUWatcher (in category 'initialize-release') -----
startCPUWatcher
"Answers whether I started the CPUWatcher"
| pw |
pw := Smalltalk at: #CPUWatcher ifAbsent: [ ^self ].
pw ifNotNil: [
pw isMonitoring ifFalse: [
pw startMonitoringPeriod: 5 rate: 100 threshold: 0.85.
self setUpdateCallbackAfter: 7.
^true
]
].
^false
!
----- Method: ProcessBrowser>>stopAutoUpdate (in category 'updating') -----
stopAutoUpdate
autoUpdateProcess ifNotNil: [
autoUpdateProcess terminate.
autoUpdateProcess := nil].
self updateProcessList!
----- Method: ProcessBrowser>>stopCPUWatcher (in category 'initialize-release') -----
stopCPUWatcher
| pw |
pw := Smalltalk at: #CPUWatcher ifAbsent: [ ^self ].
pw ifNotNil: [
pw stopMonitoring.
self updateProcessList.
startedCPUWatcher := false. "so a manual restart won't be killed later"
]
!
----- Method: ProcessBrowser>>suspendProcess (in category 'process actions') -----
suspendProcess
| nameAndRules |
selectedProcess isSuspended
ifTrue: [^ self].
nameAndRules := self nameAndRulesForSelectedProcess.
nameAndRules second
ifFalse: [self inform: 'Nope, won''t suspend ' , nameAndRules first.
^ self].
self class suspendProcess: selectedProcess.
self updateProcessList!
----- Method: ProcessBrowser>>terminateProcess (in category 'process actions') -----
terminateProcess
| nameAndRules |
nameAndRules := self nameAndRulesForSelectedProcess.
nameAndRules second
ifFalse: [self inform: 'Nope, won''t kill ' , nameAndRules first.
^ self].
self class terminateProcess: selectedProcess.
self updateProcessList!
----- Method: ProcessBrowser>>text (in category 'accessing') -----
text
^methodText!
----- Method: ProcessBrowser>>toggleAutoUpdate (in category 'updating') -----
toggleAutoUpdate
self isAutoUpdating
ifTrue: [ self stopAutoUpdate ]
ifFalse: [ self startAutoUpdate ].
!
----- Method: ProcessBrowser>>updateProcessList (in category 'process list') -----
updateProcessList
| oldSelectedProcess newIndex now |
now := Time millisecondClockValue.
now - lastUpdate < 500
ifTrue: [^ self].
"Don't update too fast"
lastUpdate := now.
oldSelectedProcess := selectedProcess.
processList := selectedProcess := selectedSelector := nil.
Smalltalk garbageCollectMost.
"lose defunct processes"
processList := Process allSubInstances
reject: [:each | each isTerminated].
processList := processList
sortBy: [:a :b | a priority >= b priority].
processList := WeakArray withAll: processList.
newIndex := processList
indexOf: oldSelectedProcess
ifAbsent: [0].
self changed: #processNameList.
self processListIndex: newIndex!
----- Method: ProcessBrowser>>updateStackList (in category 'stack list') -----
updateStackList
self updateStackList: 20!
----- Method: ProcessBrowser>>updateStackList: (in category 'stack list') -----
updateStackList: depth
| suspendedContext oldHighlight |
selectedProcess
ifNil: [^ self changeStackListTo: nil].
(stackList notNil and: [ stackListIndex > 0 ])
ifTrue: [oldHighlight := stackList at: stackListIndex].
selectedProcess == Processor activeProcess
ifTrue: [self
changeStackListTo: (thisContext stackOfSize: depth)]
ifFalse: [suspendedContext := selectedProcess suspendedContext.
suspendedContext
ifNil: [self changeStackListTo: nil]
ifNotNil: [self
changeStackListTo: (suspendedContext stackOfSize: depth)]].
self
stackListIndex: (stackList
ifNil: [0]
ifNotNil: [stackList indexOf: oldHighlight])!
----- Method: ProcessBrowser>>wasProcessSuspendedByProcessBrowser: (in category 'process actions') -----
wasProcessSuspendedByProcessBrowser: aProcess
^self class suspendedProcesses includesKey: aProcess!
----- Method: ProcessBrowser>>windowIsClosing (in category 'initialize-release') -----
windowIsClosing
startedCPUWatcher ifTrue: [ CPUWatcher stopMonitoring ]!
ObjectExplorerWrapper subclass: #PointerExplorerWrapper
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Explorer'!
!PointerExplorerWrapper commentStamp: 'avi 8/21/2004 19:58' prior: 0!
A subclass of ObjectExplorerWrapper for use with PointerExplorer. #contents is overridden to work backwards: it returns wrappers for the objects pointing to item rather than for the objects that item points to.!
----- Method: PointerExplorerWrapper>>contents (in category 'accessing') -----
contents
| objects |
objects := Utilities pointersTo: item except: (Array with: self with: model).
^(objects reject: [:ea | ea class = self class])
collect: [:ea| self class with: ea name: ea identityHash asString model: item]!
----- Method: PointerExplorerWrapper>>hasContents (in category 'testing') -----
hasContents
^true!
----- Method: Set>>inspectorClass (in category '*Tools-Inspector') -----
inspectorClass
"Answer the class of the inspector to be used on the receiver. Called by inspect;
use basicInspect to get a normal (less useful) type of inspector."
^ SetInspector!
----- Method: ScreenController>>browseRecentLog (in category '*Tools') -----
browseRecentLog
"Open a changelist browser on changes submitted since the last snapshot. 1/17/96 sw"
ChangeList browseRecentLog!
----- Method: ScreenController>>chooseDirtyBrowser (in category '*Tools') -----
chooseDirtyBrowser
"Put up a list of browsers with unsubmitted edits and activate the one selected by the user, if any."
"ScheduledControllers screenController chooseDirtyBrowser"
ScheduledControllers findWindowSatisfying:
[:c | (c model isKindOf: Browser) and: [c model canDiscardEdits not]].
!
----- Method: ScreenController>>openChangeManager (in category '*Tools') -----
openChangeManager
"Open a dual change sorter. For looking at two change sets at once."
DualChangeSorter new open!
----- Method: ScreenController>>openFile (in category '*Tools') -----
openFile
FileList openFileDirectly!
----- Method: ScreenController>>openFileList (in category '*Tools') -----
openFileList
"Create and schedule a FileList view for specifying files to access."
FileList open!
----- Method: ScreenController>>openPackageBrowser (in category '*Tools') -----
openPackageBrowser
"Create and schedule a Browser view for browsing code."
PackagePaneBrowser openBrowser!
----- Method: ScreenController>>openSelectorBrowser (in category '*Tools') -----
openSelectorBrowser
"Create and schedule a selector fragment window."
SelectorBrowser new open!
----- Method: ScreenController>>openSimpleChangeSorter (in category '*Tools') -----
openSimpleChangeSorter
ChangeSorter new open!
ClassTestCase subclass: #FileListTest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-FileList-Tests'!
----- Method: FileListTest>>checkIsServiceIsFromDummyTool: (in category 'private') -----
checkIsServiceIsFromDummyTool: service
^ (service instVarNamed: #provider) = DummyToolWorkingWithFileList
& service label = 'menu label'
& (service instVarNamed: #selector) = #loadAFileForTheDummyTool:!
----- Method: FileListTest>>setUp (in category 'initialize') -----
setUp
DummyToolWorkingWithFileList initialize.!
----- Method: FileListTest>>tearDown (in category 'initialize') -----
tearDown
DummyToolWorkingWithFileList unregister.!
----- Method: FileListTest>>testAllRegisteredServices (in category 'test') -----
testAllRegisteredServices
"(self selector: #testAllRegisteredServices) debug"
self shouldnt: [FileList allRegisteredServices] raise: Error!
----- Method: FileListTest>>testMenuReturned (in category 'test') -----
testMenuReturned
"(self selector: #testToolRegistered) debug"
self assert: (FileList registeredFileReaderClasses includes: DummyToolWorkingWithFileList)!
----- Method: FileListTest>>testService (in category 'test') -----
testService
"a stupid test to check that the class returns a service"
"(self selector: #testService) debug"
| service |
service := (DummyToolWorkingWithFileList fileReaderServicesForFile: 'abab.kkk' suffix: 'kkk') first.
self assert: (self checkIsServiceIsFromDummyTool: service).
service := (DummyToolWorkingWithFileList fileReaderServicesForFile: 'zkk.gz' suffix: 'gz').
self assert: service isEmpty!
----- Method: FileListTest>>testServicesForFileEnding (in category 'test') -----
testServicesForFileEnding
"(self selector: #testServicesForFileEnding) debug"
self assert: (((FileList new directory: FileDirectory default; yourself) itemsForFile: 'aaa.kkk') anySatisfy: [ :ea | self checkIsServiceIsFromDummyTool: ea ]).
!
----- Method: FileListTest>>testToolRegistered (in category 'test') -----
testToolRegistered
"(self selector: #testToolRegistered) debug"
self assert: (FileList registeredFileReaderClasses includes: DummyToolWorkingWithFileList)!
----- Method: FileListTest>>testToolRegisteredUsingInterface (in category 'test') -----
testToolRegisteredUsingInterface
"(self selector: #testToolRegisteredUsingInterface) debug"
self assert: (FileList isReaderNamedRegistered: #DummyToolWorkingWithFileList)!
ClassTestCase subclass: #MethodReferenceTest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tools-Browser-Tests'!
----- Method: MethodReferenceTest>>testEquals (in category 'Running') -----
testEquals
| aMethodReference anotherMethodReference |
aMethodReference := MethodReference new.
anotherMethodReference := MethodReference new.
"
two fresh instances should be equals between them"
self
should: [aMethodReference = anotherMethodReference].
self
should: [aMethodReference hash = anotherMethodReference hash].
"
two instances representing the same method (same class and
same selector) should be equals"
aMethodReference setStandardClass: String methodSymbol: #foo.
anotherMethodReference setStandardClass: String methodSymbol: #foo.
self
should: [aMethodReference = anotherMethodReference].
self
should: [aMethodReference hash = anotherMethodReference hash] !
----- Method: MethodReferenceTest>>testNotEquals (in category 'Running') -----
testNotEquals
| aMethodReference anotherMethodReference |
aMethodReference := MethodReference new.
anotherMethodReference := MethodReference new.
""
aMethodReference setStandardClass: String methodSymbol: #foo.
anotherMethodReference setStandardClass: String class methodSymbol: #foo.
"
differente classes, same selector -> no more equals"
self
shouldnt: [aMethodReference = anotherMethodReference].
"
same classes, diferente selector -> no more equals"
anotherMethodReference setStandardClass: String methodSymbol: #bar.
self
shouldnt: [aMethodReference = anotherMethodReference] !
More information about the Packages
mailing list