'From Squeak3.3alpha of 12 January 2002 [latest update: #4654] on 22 January 2002 at 11:00:44 am'! "Change Set: misc-sw Date: 22 January 2002 Author: Scott Wallace ¥ Removes gratuitous occurrences of '..' from four methods. ¥ Include a stay-up item in the shifted selector-list menu of a message list. ¥ Fixes the method SystemDictionary.browseAllUnSentMessages. This ancient method is slow and often not too useful (because it retrieves > 4000 methods!!) but at least it now works again. ¥ Stop putting up that annoying 'no change made' msg when the user backs out of a rename in a change sorter" ! !Browser methodsFor: 'message functions' stamp: 'sw 1/16/2002 21:54'! 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) - ('fetch documentation' fetchDocPane) ('more...' unshiftedYellowButtonActivity)). ^ aMenu ! ! !CategoryViewer methodsFor: 'entries' stamp: 'sw 1/16/2002 20:03'! phraseForCommandFrom: aMethodInterface "Answer a phrase for the non-slot-like command represented by aMethodInterface - classic tiles" | aRow resultType cmd names argType argTile selfTile aPhrase balloonTextSelector stat inst aDocString universal tileBearingHelp | aDocString _ aMethodInterface documentationOrNil. names _ scriptedPlayer class namedTileScriptSelectors. resultType _ aMethodInterface resultType. cmd _ aMethodInterface selector. (universal _ scriptedPlayer isUniversalTiles) ifTrue: [aPhrase _ scriptedPlayer universalTilesForInterface: aMethodInterface] ifFalse: [cmd numArgs == 0 ifTrue: [aPhrase _ PhraseTileMorph new vocabulary: self currentVocabulary. aPhrase setOperator: cmd type: resultType rcvrType: #Player] ifFalse: ["only one arg supported in classic tiles, so if this is fed with a selector with > 1 arg, results will be very strange" argType _ aMethodInterface typeForArgumentNumber: 1. aPhrase _ PhraseTileMorph new vocabulary: self currentVocabulary. aPhrase setOperator: cmd type: resultType rcvrType: #Player argType: argType. argTile _ ScriptingSystem tileForArgType: argType. argTile position: aPhrase lastSubmorph position. aPhrase lastSubmorph addMorph: argTile]]. (scriptedPlayer slotInfo includesKey: cmd) ifTrue: [balloonTextSelector _ #userSlot]. (scriptedPlayer belongsToUniClass and: [scriptedPlayer class includesSelector: cmd]) ifTrue: [aDocString ifNil: [aDocString _ (scriptedPlayer class userScriptForPlayer: scriptedPlayer selector: cmd) documentationOrNil]. aDocString ifNil: [balloonTextSelector _ #userScript]]. tileBearingHelp _ universal ifTrue: [aPhrase submorphs second] ifFalse: [aPhrase operatorTile]. aDocString ifNotNil: [tileBearingHelp setBalloonText: aDocString] ifNil: [balloonTextSelector ifNil: [tileBearingHelp setProperty: #inherentSelector toValue: cmd. balloonTextSelector _ #methodComment]. tileBearingHelp balloonTextSelector: balloonTextSelector]. aPhrase markAsPartsDonor. cmd == #emptyScript ifTrue: [aPhrase setProperty: #newPermanentScript toValue: true. aPhrase setProperty: #newPermanentPlayer toValue: scriptedPlayer. aPhrase submorphs second setBalloonText: 'drag and drop to add a new script']. universal ifFalse: [selfTile _ self tileForSelf. selfTile position: aPhrase firstSubmorph position. aPhrase firstSubmorph addMorph: selfTile]. aRow _ ViewerLine newRow borderWidth: 0; color: self color. aRow elementSymbol: cmd asSymbol. aRow addMorphBack: (ScriptingSystem tryButtonFor: aPhrase). aRow addMorphBack: (Morph new extent: 4@2; beTransparent). aRow addMorphBack: (self infoButtonFor: cmd). aRow addMorphBack: aPhrase. (names includes: cmd) ifTrue: [aPhrase userScriptSelector: cmd. aPhrase beTransparent. aRow addMorphBack: AlignmentMorph newVariableTransparentSpacer. aRow addMorphBack: (stat _ (inst _ scriptedPlayer scriptInstantiationForSelector: cmd) statusControlMorph). inst updateStatusMorph: stat]. aRow beSticky; disableDragNDrop. ^ aRow! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 1/16/2002 22:36'! rename "Store a new name string into the selected ChangeSet. reject duplicate name; allow user to back out" | newName | newName _ FillInTheBlank request: 'New name for this change set' initialAnswer: myChangeSet name. (newName = myChangeSet name or: [newName size == 0]) ifTrue: [^ self 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.! ! !CompoundTileMorph methodsFor: 'initialization' stamp: 'sw 1/16/2002 20:03'! initialize | r | super initialize. self color: Color orange muchLighter. self borderWidth: 1. self layoutInset: 2. self listDirection: #topToBottom. self hResizing: #spaceFill; vResizing: #shrinkWrap; cellInset: (0 @ 1); minCellSize: (200@14). r _ AlignmentMorph newRow color: color; layoutInset: 0. r setProperty: #demandsBoolean toValue: true. r addMorphBack: (Morph new color: color; extent: 2@5). "spacer" r addMorphBack: (StringMorph new contents: 'Test'). r addMorphBack: (Morph new color: color; extent: 5@5). "spacer" r addMorphBack: (testPart _ BooleanScriptEditor new borderWidth: 0; layoutInset: 1). testPart color: Color transparent. testPart hResizing: #spaceFill. self addMorphBack: r. r _ AlignmentMorph newRow color: color; layoutInset: 0. r addMorphBack: (Morph new color: color; extent: 30@5). "spacer" r addMorphBack: (StringMorph new contents: 'Yes'). r addMorphBack: (Morph new color: color; extent: 5@5). "spacer" r addMorphBack: (yesPart _ ScriptEditorMorph new borderWidth: 0; layoutInset: 2). yesPart hResizing: #spaceFill. yesPart color: Color transparent. self addMorphBack: r. r _ AlignmentMorph newRow color: color; layoutInset: 0. r addMorphBack: (Morph new color: color; extent: 35@5). "spacer" r addMorphBack: (StringMorph new contents: 'No'). r addMorphBack: (Morph new color: color; extent: 5@5). "spacer" r addMorphBack: (noPart _ ScriptEditorMorph new borderWidth: 0; layoutInset: 2). noPart hResizing: #spaceFill. noPart color: Color transparent. self addMorphBack: r. self bounds: self fullBounds! ! !Debugger methodsFor: 'initialize' stamp: 'sw 1/16/2002 20:03'! buildMVCNotifierButtonView | aView bHeight priorButton buttonView | aView _ View new model: self. bHeight _ self notifierButtonHeight. aView window: (0@0 extent: 350@bHeight). priorButton _ nil. self preDebugButtonQuads do: [:aSpec | buttonView _ PluggableButtonView on: self getState: nil action: aSpec second. buttonView label: aSpec first; insideColor: (Color perform: aSpec third) muchLighter lighter; borderWidthLeft: 1 right: 1 top: 0 bottom: 0; window: (0@0 extent: 117@bHeight). priorButton ifNil: [aView addSubView: buttonView] ifNotNil: [aView addSubView: buttonView toRightOf: priorButton]. priorButton _ buttonView]. ^ aView! ! !Player methodsFor: 'slots-user' stamp: 'sw 1/16/2002 20:07'! chooseSlotTypeFor: aGetter "Let the user designate a type for the slot associated with the given getter" | typeChoices typeChosen slotName | slotName _ Utilities inherentSelectorForGetter: aGetter. typeChoices _ Vocabulary typeChoices. typeChosen _ (SelectionMenu selections: typeChoices lines: #()) startUpWithCaption: ('Choose the TYPE for ', slotName, ' (currently ', (self slotInfoAt: slotName) type, ')'). typeChosen isEmptyOrNil ifTrue: [^ self]. (self typeForSlot: slotName) capitalized = typeChosen ifTrue: [^ self]. (self slotInfoAt: slotName) type: typeChosen. self class allInstancesDo: "allSubInstancesDo:" [:anInst | anInst instVarNamed: slotName asString put: (anInst valueOfType: typeChosen from: (anInst instVarNamed: slotName))]. self updateAllViewers. "does siblings too" ! ! !SystemDictionary methodsFor: 'browsing' stamp: 'sw 1/16/2002 21:03'! browseAllUnSentMessages "Create and schedule a message browser on each method whose message is not sent in any method in the system." self browseAllImplementorsOfList: self allUnSentMessages title: 'Messages implemented but not sent' "Smalltalk browseAllUnSentMessages"! !