'From Squeak3.1alpha of 5 February 2001 [latest update: #4101] on 29 May 2001 at 11:30:54 am'! "Change Set: methodRefs Date: 29 May 2001 Author: Bob Arning Implements MethodReference to be used in places where we once used strings of the form 'Blah class fooMessage' This will avoid the extra work of reparsing the string and looking up symbols. May have benefits elsewhere as well. Browsing senders of #mref will point out some of the odd situations still to be cleaned up "! Object subclass: #MethodReference instanceVariableNames: 'classSymbol classIsMeta methodSymbol stringVersion ' classVariableNames: '' poolDictionaries: '' category: 'Tools-Browser'! !Behavior methodsFor: 'accessing' stamp: 'RAA 5/28/2001 13:38'! confirmRemovalOf: aSelector "Determine if it is okay to remove the given selector. Answer 1 if it should be removed, 2 if it should be removed followed by a senders browse, and 3 if it should not be removed." | count aMenu answer caption allCalls | allCalls _ Smalltalk allCallsOn: aSelector. (count _ allCalls size) == 0 ifTrue: [^ 1]. "no senders -- let the removal happen without warning" count == 1 ifTrue: [ (allCalls first actualClass == self and: [allCalls first methodSymbol == aSelector]) ifTrue: [^ 1] ]. "only sender is itself" aMenu _ PopUpMenu labels: 'Remove it Remove, then browse senders Don''t remove, but show me those senders Forget it -- do nothing -- sorry I asked'. caption _ 'This message has ', count printString, ' sender'. count > 1 ifTrue: [caption _ caption copyWith: $s]. answer _ aMenu startUpWithCaption: caption. answer == 3 ifTrue: [ Smalltalk browseMessageList: allCalls name: 'Senders of ', aSelector autoSelect: aSelector keywords first ]. answer == 0 ifTrue: [answer _ 3]. "If user didn't answer, treat it as cancel" ^ answer min: 3! ! !Behavior methodsFor: 'user interface' stamp: 'RAA 5/28/2001 13:29'! allCallsOn: aSymbol "Answer a SortedCollection of all the methods that call on aSymbol." | aSortedCollection special byte | aSortedCollection _ SortedCollection new. special _ Smalltalk hasSpecialSelector: aSymbol ifTrueSetByte: [:b | byte _ b ]. self withAllSubclassesDo: [ :class | (class whichSelectorsReferTo: aSymbol special: special byte: byte) do: [:sel | sel == #DoIt ifFalse: [ aSortedCollection add: ( MethodReference new setStandardClass: class methodSymbol: sel ) ] ] ]. ^aSortedCollection! ! !Behavior methodsFor: 'user interface' stamp: 'RAA 5/28/2001 11:35'! browseAllAccessesTo: instVarName "Collection browseAllAccessesTo: 'contents'." "Create and schedule a Message Set browser for all the receiver's methods or any methods of a subclass that refer to the instance variable name." | coll | coll _ OrderedCollection new. Cursor wait showWhile: [ self withAllSubAndSuperclassesDo: [:class | (class whichSelectorsAccess: instVarName) do: [:sel | sel == #DoIt ifFalse: [ coll add: ( MethodReference new setStandardClass: class methodSymbol: sel ) ] ] ]. ]. ^ Smalltalk browseMessageList: coll name: 'Accesses to ' , instVarName autoSelect: instVarName! ! !Behavior methodsFor: 'user interface' stamp: 'RAA 5/28/2001 13:38'! browseAllCallsOn: aSymbol "Create and schedule a Message Set browser for all the methods that call on aSymbol." | key label | label _ (aSymbol isKindOf: LookupKey) ifTrue: ['Users of ' , (key _ aSymbol key)] ifFalse: ['Senders of ' , (key _ aSymbol)]. ^ Smalltalk browseMessageList: (self allCallsOn: aSymbol) name: label autoSelect: key "Number browseAllCallsOn: #/."! ! !Behavior methodsFor: 'user interface' stamp: 'RAA 5/28/2001 11:36'! browseAllStoresInto: instVarName "Collection browseAllStoresInto: 'contents'." "Create and schedule a Message Set browser for all the receiver's methods or any methods of a subclass that refer to the instance variable name." | coll | coll _ OrderedCollection new. Cursor wait showWhile: [ self withAllSubAndSuperclassesDo: [:class | (class whichSelectorsStoreInto: instVarName) do: [:sel | sel == #DoIt ifFalse: [ coll add: ( MethodReference new setStandardClass: class methodSymbol: sel ) ] ] ]. ]. ^ Smalltalk browseMessageList: coll name: 'Stores into ' , instVarName autoSelect: instVarName! ! !Behavior methodsFor: 'user interface' stamp: 'RAA 5/28/2001 12:00'! withAllSubAndSuperclassesDo: aBlock self withAllSubclassesDo: aBlock. self allSuperclassesDo: aBlock. ! ! !ChangeSet methodsFor: 'method changes' stamp: 'RAA 5/28/2001 13:43'! browseMessagesWithPriorVersions "Open a message list browser on the new and changed methods in the receiver which have at least one prior version. 6/28/96 sw" | aList | aList _ self messageListForChangesWhich: [ :aClass :aSelector | (VersionsBrowser versionCountForSelector: aSelector class: aClass) > 1 ] ifNone: [^self inform: 'None!!']. Smalltalk browseMessageList: aList name: self name, ' methods that have prior versions'! ! !ChangeSet methodsFor: 'method changes' stamp: 'RAA 5/29/2001 10:06'! changedMessageList "Used by a message set browser to access the list view information." | messageList classNameInFull classNameInParts | messageList _ SortedCollection new. changeRecords associationsDo: [:clAssoc | clAssoc value methodChangeTypes associationsDo: [:mAssoc | (#(remove addedThenRemoved) includes: mAssoc value) ifFalse: [ classNameInFull _ clAssoc key asString. classNameInParts _ classNameInFull findTokens: ' '. messageList add: ( MethodReference new setClassSymbol: classNameInParts first asSymbol classIsMeta: classNameInParts size > 1 methodSymbol: mAssoc key stringVersion: classNameInFull, ' ' , mAssoc key ). ] ] ]. ^ messageList asArray! ! !ChangeSet methodsFor: 'method changes' stamp: 'RAA 5/28/2001 12:05'! messageListForChangesWhich: aBlock ifNone: ifEmptyBlock | answer | answer _ self changedMessageListAugmented select: [ :each | aBlock value: each actualClass value: each methodSymbol ]. answer isEmpty ifTrue: [^ifEmptyBlock value]. ^answer ! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'RAA 5/28/2001 11:46'! checkForUnsentMessages "Check the change set for unsent messages, and if any are found, open up a message-list browser on them" | nameLine allChangedSelectors augList unsent | nameLine _ '"', self name, '"'. allChangedSelectors _ Set new. (augList _ self changedMessageListAugmented) do: [ :each | each isValid ifTrue: [allChangedSelectors add: each methodSymbol] ]. unsent _ Smalltalk allUnSentMessagesIn: allChangedSelectors. unsent size = 0 ifTrue: [ ^self inform: 'There are no unsent messages in change set ', nameLine ]. Smalltalk browseMessageList: (augList select: [ :each | unsent includes: each methodSymbol]) name: 'Unsent messages in ', nameLine! ! !CodeServer methodsFor: 'as yet unclassified' stamp: 'RAA 5/28/2001 05:54'! chunk: request "Return Smalltalk source code as a chunk from the changes file. URL = machine:80/chunk.Point|min; included are: Point|at; Point|Comment Point|Hierarchy Point|Definition Point|class|x;y; Meant to be received by a Squeak client, not a browser. Reply not in HTML" | classAndMethod set strm chunk | self flag: #mref. "fix for faster references to methods" classAndMethod _ request message atPin: 2. classAndMethod _ classAndMethod copyReplaceAll: '|' with: ' '. classAndMethod _ classAndMethod copyReplaceAll: ';' with: ':'. set _ MessageSet messageList: (Array with: classAndMethod). set messageListIndex: 1. strm _ WriteStream on: (String new: 300). strm nextChunkPutWithStyle: (set selectedMessage). "String or text" chunk _ strm contents. request reply: 'content-length: ', chunk size printString, PWS crlfcrlf. request reply: chunk. ! ! !CodeServer methodsFor: 'as yet unclassified' stamp: 'RAA 5/28/2001 05:54'! smtlk: request "Return Smalltalk sourcecode in HTML. URL = machine:80/myswiki.smtlk.Point|min; included are: Point|min; Point|Comment Point|Hierarchy Point|Definition Point|class|x;y; NOTE: use ; instead of : in selector names!!!!!!" | classAndMethod set | self flag: #mref. "fix for faster references to methods" classAndMethod _ request message atPin: 2. classAndMethod _ classAndMethod copyReplaceAll: '|' with: ' '. classAndMethod _ classAndMethod copyReplaceAll: ';' with: ':'. set _ MessageSet messageList: (Array with: classAndMethod). request reply: PWS crlf, (HTMLformatter evalEmbedded: (self fileContents: 'swiki',(ServerAction pathSeparator),'smtlk.html') with: set).! ! !Dictionary methodsFor: 'removing' stamp: 'RAA 5/28/2001 13:38'! unreferencedKeys "TextConstants unreferencedKeys" | n | ^ 'Scanning for references . . .' displayProgressAt: Sensor cursorPoint from: 0 to: self size during: [:bar | n _ 0. self keys select: [:key | bar value: (n _ n+1). (Smalltalk allCallsOn: (self associationAt: key)) isEmpty]]! ! !EToyVocabulary methodsFor: 'initialization' stamp: 'RAA 5/28/2001 11:42'! morphClassesDeclaringViewerAdditions "Answer a list of actual morph classes implementing #additionsToViewerCategories" | survivors | survivors _ OrderedCollection new. (Smalltalk allImplementorsOf: #additionsToViewerCategories) do: [ :aMarker | (aMarker actualClass soleInstance isKindOf: Morph class) ifTrue: [ survivors add: aMarker actualClass soleInstance ] ]. ^ survivors "EToyVocabulary basicNew morphClassesDeclaringViewerAdditions"! ! !EventHandler methodsFor: 'access' stamp: 'RAA 5/29/2001 10:25'! messageList "Return a list of 'Class selector' for each message I can send. tk 9/13/97" | list | self flag: #mref. "is this still needed? I replaced the one use that I could spot with #methodRefList" list _ SortedCollection new. mouseDownRecipient ifNotNil: [list add: (mouseDownRecipient class classThatUnderstands: mouseDownSelector) name , ' ', mouseDownSelector]. mouseMoveRecipient ifNotNil: [list add: (mouseMoveRecipient class classThatUnderstands: mouseMoveSelector) name , ' ', mouseMoveSelector]. mouseStillDownRecipient ifNotNil: [list add: (mouseStillDownRecipient class classThatUnderstands: mouseStillDownSelector) name , ' ', mouseStillDownSelector]. mouseUpRecipient ifNotNil: [list add: (mouseUpRecipient class classThatUnderstands: mouseUpSelector) name , ' ', mouseUpSelector]. mouseEnterRecipient ifNotNil: [list add: (mouseEnterRecipient class classThatUnderstands: mouseEnterSelector) name , ' ', mouseEnterSelector]. mouseLeaveRecipient ifNotNil: [list add: (mouseLeaveRecipient class classThatUnderstands: mouseLeaveSelector) name , ' ', mouseLeaveSelector]. mouseEnterDraggingRecipient ifNotNil: [list add: (mouseEnterDraggingRecipient class classThatUnderstands: mouseEnterDraggingSelector) name , ' ', mouseEnterDraggingSelector]. mouseLeaveDraggingRecipient ifNotNil: [list add: (mouseLeaveDraggingRecipient class classThatUnderstands: mouseLeaveDraggingSelector) name , ' ', mouseLeaveDraggingSelector]. doubleClickRecipient ifNotNil: [list add: (doubleClickRecipient class classThatUnderstands: doubleClickSelector) name , ' ', doubleClickSelector]. keyStrokeRecipient ifNotNil: [list add: (keyStrokeRecipient class classThatUnderstands: keyStrokeSelector) name , ' ', keyStrokeSelector]. ^ list! ! !EventHandler methodsFor: 'access' stamp: 'RAA 5/29/2001 10:33'! methodRefList "Return a MethodReference for each message I can send. tk 9/13/97, raa 5/29/01" | list adder | list _ SortedCollection new. adder _ [ :recip :sel | recip ifNotNil: [ list add: ( MethodReference new setStandardClass: (recip class classThatUnderstands: sel) methodSymbol: sel ) ]. ]. adder value: mouseDownRecipient value: mouseDownSelector. adder value: mouseMoveRecipient value: mouseMoveSelector. adder value: mouseStillDownRecipient value: mouseStillDownSelector. adder value: mouseUpRecipient value: mouseUpSelector. adder value: mouseEnterRecipient value: mouseEnterSelector. adder value: mouseLeaveRecipient value: mouseLeaveSelector. adder value: mouseEnterDraggingRecipient value: mouseEnterDraggingSelector. adder value: mouseLeaveDraggingRecipient value: mouseLeaveDraggingSelector. adder value: doubleClickRecipient value: doubleClickSelector. adder value: keyStrokeRecipient value: keyStrokeSelector. ^ list! ! !MethodReference methodsFor: 'as yet unclassified' stamp: 'RAA 5/28/2001 11:56'! <= anotherMethodReference classSymbol < anotherMethodReference classSymbol ifTrue: [^true]. classSymbol > anotherMethodReference classSymbol ifTrue: [^false]. classIsMeta = anotherMethodReference classIsMeta ifFalse: [^classIsMeta not]. ^methodSymbol <= anotherMethodReference methodSymbol ! ! !MethodReference methodsFor: 'as yet unclassified' stamp: 'RAA 5/28/2001 11:56'! = anotherMethodReference classSymbol = anotherMethodReference classSymbol ifFalse: [^false]. classIsMeta = anotherMethodReference classIsMeta ifFalse: [^false]. ^methodSymbol = anotherMethodReference methodSymbol ! ! !MethodReference methodsFor: 'as yet unclassified' stamp: 'RAA 5/28/2001 07:42'! actualClass | actualClass | actualClass _ Smalltalk atOrBelow: classSymbol ifAbsent: [^nil]. classIsMeta ifTrue: [^actualClass class]. ^actualClass ! ! !MethodReference methodsFor: 'as yet unclassified' stamp: 'RAA 5/28/2001 06:19'! asStringOrText ^stringVersion! ! !MethodReference methodsFor: 'as yet unclassified' stamp: 'RAA 5/28/2001 08:11'! classIsMeta ^classIsMeta! ! !MethodReference methodsFor: 'as yet unclassified' stamp: 'RAA 5/28/2001 08:10'! classSymbol ^classSymbol! ! !MethodReference methodsFor: 'as yet unclassified' stamp: 'RAA 5/28/2001 07:44'! isValid ^(self actualClass ifNil: [^false]) includesSelector: methodSymbol! ! !MethodReference methodsFor: 'as yet unclassified' stamp: 'RAA 5/28/2001 08:10'! methodSymbol ^methodSymbol! ! !MethodReference methodsFor: 'as yet unclassified' stamp: 'RAA 5/28/2001 08:06'! setClass: aClass methodSymbol: methodSym stringVersion: aString classSymbol _ aClass theNonMetaClass name. classIsMeta _ aClass isMeta. methodSymbol _ methodSym. stringVersion _ aString.! ! !MethodReference methodsFor: 'as yet unclassified' stamp: 'RAA 5/28/2001 07:34'! setClassAndSelectorIn: csBlock ^csBlock value: self actualClass value: methodSymbol! ! !MethodReference methodsFor: 'as yet unclassified' stamp: 'RAA 5/28/2001 06:04'! setClassSymbol: classSym classIsMeta: isMeta methodSymbol: methodSym stringVersion: aString classSymbol _ classSym. classIsMeta _ isMeta. methodSymbol _ methodSym. stringVersion _ aString.! ! !MethodReference methodsFor: 'as yet unclassified' stamp: 'RAA 5/28/2001 11:34'! setStandardClass: aClass methodSymbol: methodSym classSymbol _ aClass theNonMetaClass name. classIsMeta _ aClass isMeta. methodSymbol _ methodSym. stringVersion _ aClass name , ' ' , methodSym.! ! !Model methodsFor: 'text links' stamp: 'RAA 5/29/2001 11:14'! 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'. ] ! ! !Morph methodsFor: 'naming' stamp: 'RAA 5/28/2001 13:39'! renameTo: aName "Set Player name in costume. Update Viewers. Fix all tiles (old style). fix References. New tiles: recompile, and recreate open scripts. If coming in from disk, and have name conflict, References will already have new name." | aPresenter putInViewer aPasteUp renderer oldKey assoc classes oldName | oldName _ self knownName. (renderer _ self topRendererOrSelf) setNameTo: aName. putInViewer _ false. ((aPresenter _ self presenter) isNil or: [renderer player isNil]) ifFalse: [putInViewer _ aPresenter currentlyViewing: renderer player. putInViewer ifTrue: [renderer player viewerFlapTab hibernate]]. "empty it temporarily" (aPasteUp _ self topPasteUp) ifNotNil: [aPasteUp allTileScriptingElements do: [:m | m bringUpToDate]]. "Fix References dictionary. See restoreReferences to know why oldKey is already aName, but oldName is the old name." oldKey _ References keyAtIdentityValue: renderer player ifAbsent: [nil]. oldKey ifNotNil: [assoc _ References associationAt: oldKey. oldKey = aName ifFalse: ["normal rename" assoc key: aName asSymbol. References rehash]]. putInViewer ifTrue: [aPresenter viewMorph: self]. "recreate my viewer" oldKey ifNil: [^ aName]. "Force strings in tiles to be remade with new name. New tiles only." Preferences universalTiles ifFalse: [^ aName]. classes _ (Smalltalk allCallsOn: assoc) collect: [ :each | each classSymbol]. (classes asSet) do: [:clsName | (Smalltalk at: clsName) replaceSilently: oldName to: aName]. "replace in text body of all methods. Can be wrong!!" "Redo the tiles that are showing. This is also done in caller in unhibernate." aPasteUp ifNotNil: [ aPasteUp allTileScriptingElements do: [:mm | "just ScriptEditorMorphs". (mm isKindOf: ScriptEditorMorph) ifTrue: [((mm playerScripted class compiledMethodAt: mm scriptName) hasLiteral: assoc) ifTrue: [mm hibernate; unhibernate]]]]. ^ aName! ! !Morph methodsFor: 'meta-actions' stamp: 'RAA 5/29/2001 10:39'! showActions "Put up a message list browser of all the code that this morph would run for mouseUp, mouseDown, mouseMove, mouseEnter, mouseLeave, and mouseLinger. tk 9/13/97" | list cls selector adder | list _ SortedCollection new. adder _ [ :mrClass :mrSel | list add: ( MethodReference new setStandardClass: mrClass methodSymbol: mrSel ) ]. "the eventHandler" self eventHandler ifNotNil: [ list _ self eventHandler methodRefList. (self eventHandler handlesMouseDown: nil) ifFalse:[adder value: HandMorph value: #grabMorph:] ]. "If not those, then non-default raw events" #(keyStroke: mouseDown: mouseEnter: mouseLeave: mouseMove: mouseUp: doButtonAction) do: [:sel | cls _ self class classThatUnderstands: sel. cls ifNotNil: ["want more than default behavior" cls == Morph ifFalse: [adder value: cls value: sel]]]. "The mechanism on a Button" (self respondsTo: #actionSelector) ifTrue: ["A button" selector _ self actionSelector. cls _ self target class classThatUnderstands: selector. cls ifNotNil: ["want more than default behavior" cls == Morph ifFalse: [adder value: cls value: selector]]]. MessageSet openMessageList: list name: 'Actions of ', self printString.! ! !PluggableListMorph methodsFor: 'initialization' stamp: 'RAA 5/29/2001 11:22'! list: listOfStrings | morphList h loc index converter item | scroller removeAllMorphs. list _ listOfStrings ifNil: [Array new]. list isEmpty ifTrue: [self setScrollDeltas. ^ self selectedMorph: nil]. "NOTE: we will want a quick StringMorph init message, possibly even combined with event install and positioning" font ifNil: [font _ Preferences standardListFont]. converter _ self valueOfProperty: #itemConversionMethod. converter ifNil: [converter _ #asStringOrText]. morphList _ list collect: [ :each | item _ each. item _ item perform: converter. item isText ifTrue: [StringMorph contents: item font: font emphasis: (item emphasisAt: 1)] ifFalse: [StringMorph contents: item font: font] ]. self highlightSelector ifNotNil:[ model perform: self highlightSelector with: list with: morphList. ]. "Lay items out vertically and install them in the scroller" h _ morphList first height "self listItemHeight". loc _ 0@0. morphList do: [:m | m bounds: (loc extent: 9999@h). loc _ loc + (0@h)]. scroller addAllMorphs: morphList. index _ self getCurrentSelectionIndex. self selectedMorph: ((index = 0 or: [index > morphList size]) ifTrue: [nil] ifFalse: [morphList at: index]). self setScrollDeltas. scrollBar setValue: 0.0! ! !String methodsFor: 'converting' stamp: 'RAA 5/28/2001 06:19'! asStringOrText "Answer this string." ^ self ! ! !StringHolder methodsFor: 'message list menu' stamp: 'RAA 5/28/2001 11:09'! 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) ifNotNil: [(Smalltalk at: #Lexicon) new openOnClass: aClass inWorld: ActiveWorld showingSelector: self selectedMessageName]! ! !StringHolder methodsFor: 'message list menu' stamp: 'RAA 5/29/2001 10:45'! 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. Smalltalk browseMessageList: (Array with: mr) name: mr asStringOrText autoSelect: nil! ! !CodeHolder methodsFor: 'annotation' stamp: 'RAA 5/28/2001 13:45'! 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 | aStream _ ReadWriteStream on: ''. separator _ self annotationSeparator. self annotationRequests do: [:aRequest | aRequest == #firstComment ifTrue: [aComment _ aClass firstCommentAt: 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 _ (Smalltalk allCallsOn: aSelector) size. sendersCount _ sendersCount == 1 ifTrue: ['1 sender'] ifFalse: [sendersCount printString, ' senders']. aStream nextPutAll: sendersCount, separator]. aRequest == #implementorsCount ifTrue: [implementorsCount _ Smalltalk 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 _ ChangeSorter mostRecentChangeSetWithChangeForClass: aClass selector: aSelector. aString size > 0 ifTrue: [aStream nextPutAll: aString, separator]]. aRequest == #allChangeSets ifTrue: [aList _ ChangeSorter 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! ! !CodeHolder methodsFor: 'misc' stamp: 'RAA 5/28/2001 11:42'! isThereAnOverride "Answer whether any subclass of my selected class implements my selected selector" | aName aClass | aName _ self selectedMessageName ifNil: [^ false]. aClass _ self selectedClassOrMetaClass. (Smalltalk allImplementorsOf: aName) do: [ :each | (each actualClass inheritsFrom: aClass) ifTrue: [^ true] ]. ^ false! ! !Browser methodsFor: 'class functions' stamp: 'RAA 5/28/2001 13:38'! 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: ((systemOrganizer listAtCategoryNamed: self selectedSystemCategoryName) indexOf: newName). obs _ Smalltalk allCallsOn: (Smalltalk associationAt: newName). obs isEmpty ifFalse: [ Smalltalk browseMessageList: obs name: 'Obsolete References to ' , oldName autoSelect: oldName ]. ! ! !ChangeList methodsFor: 'menu actions' stamp: 'RAA 5/28/2001 11:37'! 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! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'RAA 5/28/2001 12:06'! 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 | (ChangeSorter 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, ')' ! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'RAA 5/28/2001 12:07'! 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, ')' ! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'RAA 5/28/2001 12:07'! 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, ')' ! ! !MessageSet methodsFor: 'private' stamp: 'RAA 5/28/2001 06:18'! buildMorphicMessageList | aListMorph | (aListMorph _ PluggableListMorph new) setProperty: #highlightSelector toValue: #highlightMessageList:with:; setProperty: #itemConversionMethod toValue: #asStringOrText; on: self list: #messageList selected: #messageListIndex changeSelected: #messageListIndex: menu: #messageListMenu:shifted: keystroke: #messageListKey:from:. aListMorph enableDragNDrop: Preferences browseWithDragNDrop. aListMorph menuTitleSelector: #messageListSelectorTitle. ^aListMorph ! ! !MessageSet methodsFor: 'private' stamp: 'RAA 5/28/2001 11:47'! initializeMessageList: anArray | s | messageList _ OrderedCollection new. anArray do: [ :each | MessageSet parse: each toClassAndSelector: [ :class :sel | class ifNotNil: [ s _ class name , ' ' , sel , ' {' , ((class organization categoryOfElement: sel) ifNil: ['']) , '}'. messageList add: ( MethodReference new setClass: class methodSymbol: sel stringVersion: s ) ] ] ]. messageListIndex _ 0. contents _ ''! ! !MessageSet methodsFor: 'private' stamp: 'RAA 5/29/2001 10:12'! setClassAndSelectorIn: csBlock | sel | "Decode strings of the form [class] ." self flag: #mref. "compatibility with pre-MethodReference lists" sel _ self selection. ^(sel isKindOf: MethodReference) ifTrue: [ sel setClassAndSelectorIn: csBlock ] ifFalse: [ MessageSet parse: sel toClassAndSelector: csBlock ]! ! !MessageSet class methodsFor: 'utilities' stamp: 'RAA 5/29/2001 10:19'! 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] ] ]! ! !MessageSet class methodsFor: 'utilities' stamp: 'RAA 5/29/2001 10:20'! parse: methodRef toClassAndSelector: csBlock "Decode strings of the form [class] ." | tuple cl | self flag: #mref. "compatibility with pre-MethodReference lists" methodRef ifNil: [^ csBlock value: nil value: nil]. (methodRef isKindOf: MethodReference) ifTrue: [ ^methodRef setClassAndSelectorIn: csBlock ]. tuple _ methodRef asString findTokens: ' .'. cl _ Smalltalk atOrBelow: 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]! ! !ChangedMessageSet class methodsFor: 'as yet unclassified' stamp: 'RAA 5/29/2001 10:19'! 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! ! !ChangedMessageSet class methodsFor: 'as yet unclassified' stamp: 'RAA 5/28/2001 11:42'! openMessageList: messageList name: labelString autoSelect: autoSelectString changeSet: aChangeSet | messageSet | messageSet _ self messageList: messageList. messageSet changeSet: aChangeSet. messageSet autoSelectString: autoSelectString. Smalltalk isMorphic ifTrue: [self openAsMorph: messageSet name: labelString] ifFalse: [ScheduledControllers scheduleActive: (self open: messageSet name: labelString)]! ! !ProtocolBrowser methodsFor: 'private' stamp: 'RAA 5/28/2001 11:49'! 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 ) ].! ! !ProtocolBrowser methodsFor: 'private' stamp: 'RAA 5/28/2001 11:07'! setClassAndSelectorIn: csBlock "Decode strings of the form ( [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 [class] , and use MessageSet" classAndSelString _ (selString copyFrom: i + 1 to: selString size - 1) , ' ' , (selString copyFrom: 1 to: i - 1) withoutTrailingBlanks. MessageSet parse: classAndSelString toClassAndSelector: csBlock. ]. ! ! !Lexicon methodsFor: 'category list' stamp: 'RAA 5/28/2001 13:38'! 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. (Smalltalk allCallsOn: poolAssoc) do: [ :elem | (nonMeta isKindOf: elem actualClass) ifTrue: [ aList add: elem methodSymbol ] ]. ^ aList! ! !Lexicon methodsFor: 'senders' stamp: 'RAA 5/28/2001 13:38'! 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. (Smalltalk 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: [^ self beep]. self okToChange ifFalse: [^ self]. chosen _ (SelectionMenu selections: selectorSet asSortedArray) startUp. chosen isEmptyOrNil ifFalse: [self displaySelector: chosen]! ! !Lexicon methodsFor: 'senders' stamp: 'RAA 5/28/2001 13:38'! selectorsSendingSelectedSelector "Assumes lastSendersSearchSelector is already set" | selectorSet sel cl | autoSelectString _ (self lastSendersSearchSelector upTo: $:) asString. selectorSet _ Set new. (Smalltalk 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! ! !Lexicon methodsFor: 'senders' stamp: 'RAA 5/28/2001 13:38'! 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 _ FillInTheBlank 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. (Smalltalk 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]! ! !RecentMessageSet methodsFor: 'update' stamp: 'RAA 5/29/2001 10:19'! 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! ! !RecentMessageSet methodsFor: 'update' stamp: 'RAA 5/29/2001 10:42'! 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]! ! !SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'RAA 5/28/2001 11:50'! selectedClass "Answer the currently selected class." | pairString | self flag: #mref. "fix for faster references to methods" classListIndex = 0 ifTrue: [^nil]. pairString _ classList at: classListIndex. (pairString includes: $*) ifTrue: [pairString _ pairString allButFirst]. MessageSet parse: pairString toClassAndSelector: [:cls :sel | ^ cls].! ! !SwikiAction methodsFor: 'URL processing' stamp: 'RAA 5/28/2001 05:56'! smtlk: request "Return Smalltalk sourcecode. URL = machine:80/myswiki.smtlk.Point|at; included are: Point|at: Point|Comment Point|Hierarchy Point|Definition Point|class|x;y; NOTE: use ; instead of : in selector names!!!!!!" | classAndMethod set | self flag: #mref. "fix for faster references to methods" classAndMethod _ request message atPin: 3. classAndMethod _ classAndMethod copyReplaceAll: '|' with: ' '. classAndMethod _ classAndMethod copyReplaceAll: ';' with: ':'. set _ MessageSet messageList: (Array with: classAndMethod). request reply: PWS crlf, ((self formatterFor: 'smtlk') format: set).! ! !SyntaxMorph methodsFor: 'type checking' stamp: 'RAA 5/28/2001 09:44'! allSpecs | all | "Return all specs that the Viewer knows about. Maybe cache it." "SyntaxMorph new allSpecs" all _ OrderedCollection new. (Smalltalk allImplementorsOf: #additionsToViewerCategories) do: [ :pp | all addAll: pp actualClass additionsToViewerCategories ]. ^ all! ! !SystemDictionary methodsFor: 'browsing' stamp: 'RAA 5/29/2001 10:46'! browseAllCallsOn: aLiteral "Create and schedule a message browser on each method that refers to aLiteral. For example, Smalltalk browseAllCallsOn: #open:label:." (aLiteral isKindOf: LookupKey) ifTrue: [ ^self browseMessageList: (self allCallsOn: aLiteral) asSortedCollection name: 'Users of ' , aLiteral key autoSelect: aLiteral key ]. self browseMessageList: (self allCallsOn: aLiteral) asSortedCollection name: 'Senders of ' , aLiteral autoSelect: aLiteral keywords first! ! !SystemDictionary methodsFor: 'browsing' stamp: 'RAA 5/28/2001 09:33'! browseAllImplementorsOf: selector "Create and schedule a message browser on each method that implements the message whose selector is the argument, selector. For example, Smalltalk browseAllImplementorsOf: #at:put:." ^self browseMessageList: (self allImplementorsOf: selector) name: 'Implementors of ' , selector! ! !SystemDictionary methodsFor: 'browsing' stamp: 'RAA 5/28/2001 11:22'! browseAllSelect: aBlock name: aName autoSelect: autoSelectString "Create and schedule a message browser on each method that, when used as the block argument to aBlock gives a true result. Do not return an #DoIt traces." "Smalltalk browseAllSelect: [:method | method numLiterals > 10] name: 'Methods with more than 10 literals' autoSelect: 'isDigit'" ^ self browseMessageList: (self allSelectNoDoits: aBlock) name: aName autoSelect: autoSelectString! ! !SystemDictionary methodsFor: 'browsing' stamp: 'RAA 5/29/2001 11:00'! browseClassCommentsWithString: aString "Smalltalk browseClassCommentsWithString: 'my instances' " "Launch a message list browser on all class comments containing aString as a substring." | caseSensitive suffix list | suffix _ (caseSensitive _ Sensor shiftPressed) ifTrue: [' (case-sensitive)'] ifFalse: [' (use shift for case-sensitive)']. list _ Set new. Cursor wait showWhile: [ Smalltalk allClassesDo: [:class | (class organization classComment asString findString: aString startingAt: 1 caseSensitive: caseSensitive) > 0 ifTrue: [ list add: ( MethodReference new setStandardClass: class methodSymbol: #Comment ) ] ] ]. ^ self browseMessageList: list asSortedCollection name: 'Class comments containing ' , aString printString , suffix autoSelect: aString! ! !SystemDictionary methodsFor: 'browsing' stamp: 'RAA 5/28/2001 11:26'! browseMessageList: messageList name: label "Create and schedule a MessageSet browser on messageList." ^ self browseMessageList: messageList name: label autoSelect: nil! ! !SystemDictionary methodsFor: 'browsing' stamp: 'RAA 5/29/2001 10:46'! browseMessageList: messageList name: labelString autoSelect: autoSelectString | title aSize | "Create and schedule a MessageSet browser on the message list." messageList size = 0 ifTrue: [^ (PopUpMenu labels: ' OK ') startUpWithCaption: 'There are no ' , labelString]. title _ (aSize _ messageList size) > 1 ifFalse: [labelString] ifTrue: [ labelString, ' [', aSize printString, ']']. MessageSet openMessageList: messageList name: title autoSelect: autoSelectString! ! !SystemDictionary methodsFor: 'browsing' stamp: 'RAA 5/28/2001 13:56'! browseMethodsWithSourceString: aString "Smalltalk browseMethodsWithSourceString: 'SourceString' " "Launch a browser on all methods whose source code contains aString as a substring." | caseSensitive suffix | suffix _ (caseSensitive _ Sensor shiftPressed) ifTrue: [' (case-sensitive)'] ifFalse: [' (use shift for case-sensitive)']. ^ self browseMessageList: (self allMethodsWithSourceString: aString matchCase: caseSensitive) name: 'Methods containing ' , aString printString , suffix autoSelect: aString! ! !SystemDictionary methodsFor: 'browsing' stamp: 'RAA 5/28/2001 13:39'! browseObsoleteReferences "Smalltalk browseObsoleteReferences" | references | references _ OrderedCollection new. (Association allSubInstances select: [:x | ((x value isKindOf: Behavior) and: ['AnOb*' match: x value name]) or: ['AnOb*' match: x value class name]]) do: [:x | references addAll: (Smalltalk allCallsOn: x)]. Smalltalk browseMessageList: references name: 'References to Obsolete Classes'! ! !SystemDictionary methodsFor: 'retrieving' stamp: 'RAA 5/29/2001 10:46'! allCallsOn: aLiteral "Smalltalk browseAllCallsOn: #open:label:." "Answer a Collection of all the methods that call on aLiteral." | aCollection special thorough aList byte | #(23 48 'fred' (new open:label:)) size. "Example above should find #open:label:, though it is deeply embedded here." aCollection _ OrderedCollection new. special _ self hasSpecialSelector: aLiteral ifTrueSetByte: [:b | byte _ b ]. thorough _ (aLiteral isMemberOf: Symbol) and: ["Possibly search for symbols imbedded in literal arrays" Preferences thoroughSenders]. Cursor wait showWhile: [ self allBehaviorsDo: [:class | aList _ thorough ifTrue: [ class thoroughWhichSelectorsReferTo: aLiteral special: special byte: byte ] ifFalse: [ class whichSelectorsReferTo: aLiteral special: special byte: byte ]. aList do: [ :sel | sel == #DoIt ifFalse: [ aCollection add: ( MethodReference new setStandardClass: class methodSymbol: sel ) ] ] ] ]. ^ aCollection! ! !SystemDictionary methodsFor: 'retrieving' stamp: 'RAA 5/28/2001 13:51'! allCallsOn: firstLiteral and: secondLiteral "Answer a SortedCollection of all the methods that call on both aLiteral and secondLiteral." | aCollection secondArray firstSpecial secondSpecial firstByte secondByte | aCollection _ SortedCollection new. firstSpecial _ self hasSpecialSelector: firstLiteral ifTrueSetByte: [:b | firstByte _ b]. secondSpecial _ self hasSpecialSelector: secondLiteral ifTrueSetByte: [:b | secondByte _ b]. Cursor wait showWhile: [ self allBehaviorsDo: [:class | secondArray _ class whichSelectorsReferTo: secondLiteral special: secondSpecial byte: secondByte. ((class whichSelectorsReferTo: firstLiteral special: firstSpecial byte: firstByte) select: [:aSel | (secondArray includes: aSel)]) do: [:sel | aCollection add: ( MethodReference new setStandardClass: class methodSymbol: sel ) ] ] ]. ^aCollection! ! !SystemDictionary methodsFor: 'retrieving' stamp: 'RAA 5/28/2001 11:38'! allImplementorsOf: aSelector "Answer a SortedCollection of all the methods that implement the message aSelector." | aCollection | aCollection _ SortedCollection new. Cursor wait showWhile: [ self allBehaviorsDo: [ :class | (class includesSelector: aSelector) ifTrue: [ aCollection add: ( MethodReference new setStandardClass: class methodSymbol: aSelector ) ] ] ]. ^aCollection! ! !SystemDictionary methodsFor: 'retrieving' stamp: 'RAA 5/29/2001 11:02'! allMethodsWithSourceString: aString matchCase: caseSensitive "Answer a SortedCollection of all the methods that contain, in source code, aString as a substring. Search the class comments also" | list classCount adder | list _ Set new. adder _ [ :mrClass :mrSel | list add: ( MethodReference new setStandardClass: mrClass methodSymbol: mrSel ) ]. 'Searching all source code...' displayProgressAt: Sensor cursorPoint from: 0 to: Smalltalk classNames size during: [:bar | classCount _ 0. Smalltalk allClassesDo: [:class | bar value: (classCount _ classCount + 1). (Array with: class with: class class) do: [:cl | cl selectorsDo: [:sel | ((cl sourceCodeAt: sel) findString: aString startingAt: 1 caseSensitive: caseSensitive) > 0 ifTrue: [ sel == #DoIt ifFalse: [adder value: cl value: sel]]]. (cl organization classComment asString findString: aString startingAt: 1 caseSensitive: caseSensitive) > 0 ifTrue: [ list value: cl value: #Comment]. ]]]. ^ list asSortedCollection! ! !SystemDictionary methodsFor: 'retrieving' stamp: 'RAA 5/28/2001 11:38'! allSelectNoDoits: aBlock "Like allSelect:, but strip out Doits" | aCollection | aCollection _ SortedCollection new. Cursor execute showWhile: [ self allBehaviorsDo: [ :class | class selectorsDo: [:sel | ((sel ~~ #DoIt) and: [(aBlock value: (class compiledMethodAt: sel))]) ifTrue: [ aCollection add: ( MethodReference new setStandardClass: class methodSymbol: sel ) ] ] ] ]. ^aCollection! ! !SystemDictionary methodsFor: 'retrieving' stamp: 'RAA 5/28/2001 13:39'! poolUsers "Answer a dictionary of pool name -> classes that refer to it." "Smalltalk poolUsers" | poolUsers pool refs | poolUsers _ Dictionary new. Smalltalk keys do: [:k | ((pool _ Smalltalk at: k) isKindOf: Dictionary) ifTrue: [refs _ Smalltalk allClasses select: [:c | c sharedPools identityIncludes: pool] thenCollect: [:c | c name]. refs add: (Smalltalk allCallsOn: (Smalltalk associationAt: k)). poolUsers at: k put: refs]]. ^ poolUsers! ! !Environment methodsFor: 'system conversion' stamp: 'RAA 5/29/2001 11:05'! browseIndirectRefs "Smalltalk browseIndirectRefs" | cm lits browseList foundOne allClasses n | self flag: #mref. "no senders at the moment. also no Environments at the moment" browseList _ OrderedCollection new. allClasses _ OrderedCollection new. Smalltalk allClassesAnywhereDo: [:cls | allClasses addLast: cls]. 'Locating methods with indirect global references...' displayProgressAt: Sensor cursorPoint from: 0 to: allClasses size during: [:bar | n _ 0. allClasses do: [:cls | bar value: (n_ n+1). { cls. cls class } do: [:cl | cl selectors do: [:sel | cm _ cl compiledMethodAt: sel. lits _ cm literals. foundOne _ false. lits do: [:lit | lit class == Association ifTrue: [(lit value == cl or: [cl scopeHas: lit key ifTrue: [:ignored]]) ifFalse: [foundOne _ true]]]. foundOne ifTrue: [ browseList add: ( MethodReference new setStandardClass: cl methodSymbol: sel ) ]]]]]. Smalltalk browseMessageList: browseList asSortedCollection name: 'Indirect Global References' autoSelect: nil! ! !Text methodsFor: 'converting' stamp: 'RAA 5/28/2001 06:19'! asStringOrText "Answer the receiver itself." ^self! ! !TimeProfileBrowser methodsFor: 'private' stamp: 'RAA 5/28/2001 05:56'! setClassAndSelectorIn: csBlock "Decode strings of the form ( [class]) " | string strm class sel parens | self flag: #mref. "fix for faster references to methods" messageListIndex < 3 ifTrue: [^contents := nil]. "Ignore first 2 lines" string _ self selection asString. string isEmpty ifTrue: [^contents := nil]. 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]. class isEmpty ifTrue: [^contents := nil]. sel isEmpty ifTrue: [^contents := nil]. ^MessageSet parse: (class, ' ', sel) toClassAndSelector: csBlock! ! !Utilities class methodsFor: 'investigations' stamp: 'RAA 5/28/2001 13:39'! reportSenderCountsFor: selectorList "Produce a report on the number of senders of each of the selectors in the list. 1/27/96 sw" | total report thisSize | total _ 0. report _ ' '. selectorList do: [:selector | thisSize _ (Smalltalk allCallsOn: selector) size. report _ report, thisSize printString, String tab, selector printString, String cr. total _ total + thisSize]. report _ report, '--- ------------------ '. report _ report, total printString, String tab, 'TOTAL '. ^ report! ! !Utilities class methodsFor: 'miscellaneous' stamp: 'RAA 5/28/2001 10:02'! setClassAndSelectorFrom: messageIDString in: csBlock "Decode strings of the form [class] . If does not exist as a class, use nil for the class in the block" | aStream aClass maybeClass sel | (messageIDString isKindOf: MethodReference) ifTrue: [ ^messageIDString setClassAndSelectorIn: csBlock ]. aStream _ ReadStream on: messageIDString. aClass _ Smalltalk at: (aStream upTo: $ ) asSymbol ifAbsent: [nil]. maybeClass _ aStream upTo: $ . sel _ aStream upTo: $ . ((maybeClass = 'class') & (sel size ~= 0)) ifTrue: [aClass ifNil: [csBlock value: nil value: sel asSymbol] ifNotNil: [csBlock value: aClass class value: sel asSymbol]] ifFalse: [csBlock value: aClass value: maybeClass asSymbol] " Utilities setClassAndSelectorFrom: 'Utilities class oppositeModeTo:' in: [:aClass :aSelector | Transcript cr; show: 'Class = ', aClass name printString, ' selector = ', aSelector printString]. Utilities setClassAndSelectorFrom: 'MessageSet setClassAndSelectorIn:' in: [:aClass :aSelector | Transcript cr; show: 'Class = ', aClass name printString, ' selector = ', aSelector printString]. " ! ! !Utilities class methodsFor: 'recent method submissions' stamp: 'RAA 5/29/2001 11:02'! 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: 'Recently submitted methods -- youngest first ' autoSelect: nil! ! !Utilities class methodsFor: 'recent method submissions' stamp: 'RAA 5/29/2001 11:03'! dumpAnyOldStyleRecentSubmissions "simplify conversion by purging those recent submissions which are still Strings" RecentSubmissions _ self recentMethodSubmissions reject: [ :each | each isKindOf: String ].! ! !Utilities class methodsFor: 'recent method submissions' stamp: 'RAA 5/28/2001 10:51'! mostRecentlySubmittedMessage self flag: #mref. "fix for faster references to methods" ^ RecentSubmissions last asStringOrText asString! ! !Utilities class methodsFor: 'recent method submissions' stamp: 'RAA 5/28/2001 10:53'! noteMethodSubmission: selectorName forClass: class | submission | self flag: #mref. "fix for faster references to methods" self recentMethodSubmissions. "ensure it is valid" class wantsChangeSetLogging ifFalse: [^ self]. self purgeRecentSubmissionsOfMissingMethods. submission _ class name asString, ' ', selectorName. RecentSubmissions removeAllSuchThat: [ :each | each asStringOrText = submission ]. RecentSubmissions size >= self numberOfRecentSubmissionsToStore ifTrue: [ RecentSubmissions removeFirst ]. RecentSubmissions addLast: ( MethodReference new setClass: class methodSymbol: selectorName stringVersion: submission ) ! ! !Utilities class methodsFor: 'recent method submissions' stamp: 'RAA 5/28/2001 10:50'! purgeRecentSubmissionsOfMissingMethods "Utilities purgeRecentSubmissionsOfMissingMethods" | keep | self flag: #mref. "fix for faster references to methods" RecentSubmissions _ RecentSubmissions select: [:aSubmission | Utilities setClassAndSelectorFrom: aSubmission in: [ :aClass :aSelector | keep _ (aClass == nil) not and: [aClass isInMemory and: [(aClass compiledMethodAt: aSelector ifAbsent: [nil]) notNil]] ]. keep ]! ! !Utilities class methodsFor: 'recent method submissions' stamp: 'RAA 5/28/2001 07:39'! recentMethodSubmissions "Answer the list of recent method submissions, in order. 5/16/96 sw" self flag: #mref. "fix for faster references to methods" RecentSubmissions == nil ifTrue: [RecentSubmissions _ OrderedCollection new]. ^ RecentSubmissions! ! !Utilities class methodsFor: 'recent method submissions' stamp: 'RAA 5/29/2001 11:29'! revertLastMethodSubmission | changeRecords lastSubmission theClass theSelector | "If the most recent method submission was a method change, revert that change, and if it was a submission of a brand-new method, remove that method." RecentSubmissions isEmptyOrNil ifTrue: [^ self beep]. lastSubmission _ RecentSubmissions last. theClass _ lastSubmission actualClass ifNil: [^ self beep]. theSelector _ lastSubmission methodSymbol. changeRecords _ theClass changeRecordsAt: theSelector. changeRecords isEmptyOrNil ifTrue: [^ self beep]. changeRecords size == 1 ifTrue: ["method has no prior version, so reverting in this case means removing" theClass removeSelector: theSelector] ifFalse: [changeRecords second fileIn]. "Utilities revertLastMethodSubmission"! ! SmartRefStream class removeSelector: #analyzeConversionMethods! "Postscript: " Utilities dumpAnyOldStyleRecentSubmissions.!