'From Squeak3.7alpha of ''11 September 2003'' [latest update: #5623] on 16 January 2004 at 9:40:17 pm'! "Change Set: KCP-117-CleanUtilities Date: 16 January 2004 Author: stephane ducasse Yet another bundles of simple cleans of Utilities. We will slowly get rid of it."! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'sd 1/16/2004 21:31'! verboseFileOut "File out the receiver, to a file whose name is a function of the change-set name and either of the date & time or chosen to have a unique numeric tag, depending on the preference 'changeSetVersionNumbers'" ChangeSet current fileOut. Transcript cr; show: 'Changes filed out ', Date dateAndTimeNow printString! ! !ChangeSetCategory methodsFor: 'services' stamp: 'sd 1/16/2004 21:37'! 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: [ChangeSorter fileOutChangeSetsNamed: (aList collect: [:m | m name]) asSortedArray]! ! !EToySystem class methodsFor: 'development support' stamp: 'sd 1/16/2004 20:55'! stripMethodsForExternalRelease "EToySystem stripMethodsForExternalRelease" SmalltalkImage current stripMethods: self methodsToStripForExternalRelease messageCode: '2.3External'! ! !Flaps class methodsFor: 'miscellaneous' stamp: 'sd 1/16/2004 21:33'! fileOutChanges "Bug workaround for squeak-flap 'fileOutChanges' buttons which for a while were mistakenly sending their requests here..." ^ ChangeSet current verboseFileOut. ! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'sd 1/16/2004 21:14'! browseClassFromIt "Launch a hierarchy browser for the class indicated by the current selection. If multiple classes matching the selection exist, let the user choose among them." | aClass | self lineSelectAndEmptyCheck: [^ self]. aClass _ Utilities classFromPattern: (self selection string copyWithout: Character cr) withCaption: 'choose a class to browse...'. aClass ifNil: [^ view flash]. self terminateAndInitializeAround: [self systemNavigation spawnHierarchyForClass: aClass selector: nil]! ! !ScreenController methodsFor: 'menu messages' stamp: 'sd 1/16/2004 21:32'! fileOutChanges ChangeSet current verboseFileOut.! ! !SmalltalkImage methodsFor: 'utilities' stamp: 'sd 1/16/2004 20:54'! stripMethods: tripletList messageCode: messageString "Used to 'cap' methods that need to be protected for proprietary reasons, etc.; call this with a list of triplets of symbols of the form ( <#instance or #class> ), and with a string to be produced as part of the error msg if any of the methods affected is reached" | aClass sel keywords codeString | tripletList do: [:triplet | (aClass _ (Smalltalk at: triplet first ifAbsent: [nil])) notNil ifTrue: [triplet second == #class ifTrue: [aClass _ aClass class]. sel _ triplet third. keywords _ sel keywords. (keywords size == 1 and: [keywords first asSymbol isKeyword not]) ifTrue: [codeString _ keywords first asString] ifFalse: [codeString _ ''. keywords withIndexDo: [:kwd :index | codeString _ codeString, ' ', (keywords at: index), ' ', 'arg', index printString]]. codeString _ codeString, ' self codeStrippedOut: ', (messageString surroundedBySingleQuotes). aClass compile: codeString classified: 'stripped']]! ! !StringHolder methodsFor: 'message list menu' stamp: 'sd 1/16/2004 21:14'! classHierarchy "Create and schedule a class list browser on the receiver's hierarchy." self systemNavigation spawnHierarchyForClass: self selectedClassOrMetaClass "OK if nil" selector: self selectedMessageName ! ! !StringHolder methodsFor: 'message list menu' stamp: 'sd 1/16/2004 21:10'! methodHierarchy "Create and schedule a method browser on the hierarchy of implementors." self systemNavigation methodHierarchyBrowserForClass: self selectedClassOrMetaClass selector: self selectedMessageName ! ! !CodeHolder methodsFor: 'commands' stamp: 'sd 1/16/2004 21:05'! 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! ! !ChangeSorter class methodsFor: 'utilities' stamp: 'sd 1/16/2004 21:36'! 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! ! !SystemDictionary methodsFor: 'ui' stamp: 'sd 1/16/2004 20:49'! inspectGlobals "Smalltalk inspectGlobals" | associations aDict | associations _ ((self keys select: [:aKey | ((self at: aKey) isKindOf: Class) not]) asSortedArray collect:[:aKey | self associationAt: aKey]). aDict _ IdentityDictionary new. associations do: [:as | aDict add: as]. aDict inspectWithLabel: 'The Globals'! ! !SystemNavigation methodsFor: 'browse' stamp: 'sd 1/16/2004 21:09'! methodHierarchyBrowserForClass: aClass selector: sel "Create and schedule a message set browser on all implementors of the currently selected message selector. Do nothing if no message is selected." "SystemNavigation default methodHierarchyBrowserForClass: ParagraphEditor selector: #isControlActive" | list tab stab aClassNonMeta isMeta theClassOrMeta | aClass ifNil: [^ self]. sel ifNil: [^ self]. aClassNonMeta _ aClass theNonMetaClass. isMeta _ aClassNonMeta ~~ aClass. list _ OrderedCollection new. tab _ ''. aClass allSuperclasses reverseDo: [:cl | (cl includesSelector: sel) ifTrue: [list addLast: tab , cl name, ' ', sel]. tab _ tab , ' ']. aClassNonMeta allSubclassesWithLevelDo: [:cl :level | theClassOrMeta _ isMeta ifTrue: [cl class] ifFalse: [cl]. (theClassOrMeta includesSelector: sel) ifTrue: [stab _ ''. 1 to: level do: [:i | stab _ stab , ' ']. list addLast: tab , stab , theClassOrMeta name, ' ', sel]] startingLevel: 0. self browseMessageList: list name: 'Inheritance of ' , sel ! ! !SystemNavigation methodsFor: 'browse' stamp: 'sd 1/16/2004 21:13'! spawnHierarchyForClass: aClass selector: aSelector "Create and schedule a new class hierarchy browser on the requested class/selector." "SystemNavigation default spawnHierarchyForClass: SmallInteger selector: #hash" | newBrowser | (aClass == nil) ifTrue: [^ self]. (newBrowser _ Browser new) setClass: aClass selector: aSelector. newBrowser spawnHierarchy. ! ! !SystemNavigation methodsFor: 'query' stamp: 'sd 1/16/2004 21:01'! hierarchyOfClassesSurrounding: aClass "Answer a list of classes in the hierarchy both above and below the given class" "SystemNavigation default hierarchyOfClassesSurrounding: StringHolder" | list aClassNonMeta isMeta theClassOrMeta | aClass ifNil: [^ OrderedCollection new]. aClass ifNil: [^ self]. aClassNonMeta _ aClass theNonMetaClass. isMeta _ aClassNonMeta ~~ aClass. list _ OrderedCollection new. aClass allSuperclasses reverseDo: [:cl | list addLast: cl]. aClassNonMeta allSubclassesWithLevelDo: [:cl :level | theClassOrMeta _ isMeta ifTrue: [cl class] ifFalse: [cl]. list addLast: theClassOrMeta] startingLevel: 0. ^ list ! ! !SystemNavigation methodsFor: 'query' stamp: 'sd 1/16/2004 21:03'! hierarchyOfImplementorsOf: aSelector forClass: aClass "Answer a list of classes in the hierarchy both above and below the given class which implement the given selector." "SystemNavigation default hierarchyOfImplementorsOf: #contents forClass: StringHolder" ^ (self hierarchyOfClassesSurrounding: aClass) select: [:cl | cl includesSelector: aSelector] ! ! !TheWorldMenu methodsFor: 'construction' stamp: 'sd 1/16/2004 21:32'! changesMenu "Build the changes menu for the world." | menu | menu _ self menu: 'changes...'. self fillIn: menu from: { { 'file out current change set' . { ChangeSet current . #verboseFileOut}. 'Write the current change set out to a file whose name reflects the change set name and the current date & time.'}. { 'create new change set...' . { ChangeSorter . #newChangeSet}. 'Create a new change set and make it the current one.'}. { 'browse changed methods' . { ChangeSet . #browseChangedMessages}. 'Open a message-list browser showing all methods in the current change set'}. { 'check change set for slips' . { self . #lookForSlips}. 'Check the current change set for halts, references to the Transcript, etc., and if any such thing is found, open up a message-list browser detailing all possible slips.'}. nil. { 'simple change sorter' . {self. #openChangeSorter1}. 'Open a 3-paned changed-set viewing tool'}. { 'dual change sorter' . {self. #openChangeSorter2}. 'Open a change sorter that shows you two change sets at a time, making it easy to copy and move methods and classes between them.'}. { 'find a change sorter (C)' . { #myWorld . #findAChangeSorter: }. 'Brings an open change sorter to the front, creating one if necessary, and makes it the active window'}. nil. { 'browse recent submissions' . { Utilities . #browseRecentSubmissions}. 'Open a new recent-submissions browser. A recent-submissions browser is a message-list browser that shows the most recent methods that have been submitted. If you submit changes within that browser, it will keep up-to-date, always showing the most recent submissions.'}. { 'find recent submissions (R)' . { #myWorld . #openRecentSubmissionsBrowser:}. 'Make an open recent-submissions browser be the front-window, expanding a collapsed one or creating a new one if necessary. A recent-submissions browser is a message-list browser that shows the most recent methods that have been submitted, latest first. If you submit changes within that browser, it will keep up-to-date, always showing the most recent submissions at the top of the browser.'}. nil. { 'recently logged changes...' . { ChangeList . #browseRecentLog}.'Open a change-list browser on the latter part of the changes log. You can use this browser to recover logged changes which were not saved in your image, in the event of a crash or other interruption.'}. { 'recent log file...' . { Smalltalk . #writeRecentToFile}. 'Create a file holding the logged changes (going as far back as you wish), and open a window on that file.'}. nil. { 'save world as morph file' . {self. #saveWorldInFile}. 'Save a file that, when reloaded, reconstitutes the current World.'}. nil. }. self projectForMyWorld isIsolated ifTrue: [ self fillIn: menu from: { { 'propagate changes upward' . {self. #propagateChanges}. 'The changes made in this isolated project will propagate to projects up to the next isolation layer.'}. }. ] ifFalse: [ self fillIn: menu from: { { 'isolate changes of this project' . {self. #beIsolated}. 'Isolate this project and its subprojects from the rest of the system. Changes to methods here will be revoked when you leave this project.'}. }. ]. ^ menu! ! !Utilities class methodsFor: 'deprecated' stamp: 'sd 1/16/2004 21:37'! fileOutChangeSetsNamed: nameList "File out the list of change sets whose names are provided" self deprecated: 'Use ChangeSorter fileOutChangeSetsNamed: nameList'. ChangeSorter fileOutChangeSetsNamed: nameList! ! !Utilities class methodsFor: 'deprecated' stamp: 'sd 1/16/2004 21:31'! fileOutChanges "File out the current change set to a file whose name is a function of the current date and time." self deprecated: 'Use ChangeSet current verboseFileOut'. ChangeSet current verboseFileOut! ! !Utilities class methodsFor: 'deprecated' stamp: 'sd 1/16/2004 21:02'! hierarchyOfClassesSurrounding: aClass "Answer a list of classes in the hierarchy both above and below the given class " self deprecated: 'Use SystemNavigation default hierarchyOfClassesSurrounding: aClass'. SystemNavigation default hierarchyOfClassesSurrounding: aClass. ! ! !Utilities class methodsFor: 'deprecated' stamp: 'sd 1/16/2004 21:03'! hierarchyOfImplementorsOf: aSelector forClass: aClass "Answer a list of classes in the hierarchy both above and below the given class which implement the given selector." self deprecated: 'Use SystemNavigation default hierarchyOfImplementorsOf: aSelector forClass: aClass'. SystemNavigation default hierarchyOfImplementorsOf: aSelector forClass: aClass! ! !Utilities class methodsFor: 'deprecated' stamp: 'sd 1/16/2004 21:09'! methodHierarchyBrowserForClass: aClass selector: sel "Create and schedule a message set browser on all implementors of the currently selected message selector. Do nothing if no message is selected." self deprecated: 'Use SystemNavigation default methodHierarchyBrowserForClass: aClass selector: sel'. SystemNavigation default methodHierarchyBrowserForClass: aClass selector: sel! ! !Utilities class methodsFor: 'deprecated' stamp: 'sd 1/16/2004 21:14'! spawnHierarchyForClass: aClass selector: aSelector "Utilities spawnHierarchyForClass: SmallInteger selector: #hash" self deprecated: 'SystemNavigation default spawnHierarchyForClass: aClass selector: aSelector'. SystemNavigation default spawnHierarchyForClass: aClass selector: aSelector! ! !Utilities class methodsFor: 'deprecated' stamp: 'sd 1/16/2004 20:56'! stripMethods: tripletList messageCode: messageString "Used to 'cap' methods that need to be protected for proprietary reasons, etc.; call this with a list of triplets of symbols of the form ( <#instance or #class> ), and with a string to be produced as part of the error msg if any of the methods affected is reached" self deprecated: 'Use SmalltalkImage current stripMethods: tripletList messageCode: messageString'. SmalltalkImage current stripMethods: tripletList messageCode: messageString! ! !Utilities class methodsFor: 'investigations' stamp: 'sd 1/16/2004 20:50'! inspectGlobals "Utilities inspectGlobals" self deprecated: 'use Smalltalk inspectGlobals'. Smalltalk inspectGlobals. ! ! !Viewer methodsFor: 'queries' stamp: 'sd 1/16/2004 21:10'! browseMethodInheritance: aSelector "Open an inheritance browser on aSelector" | aClass | aClass _ scriptedPlayer class whichClassIncludesSelector: aSelector. self systemNavigation methodHierarchyBrowserForClass: aClass selector: aSelector! !