"{ Package: 'stx:goodies/monticello' }"

MCTool subclass:#MCCodeTool

	instanceVariableNames:'items'

	classVariableNames:''

	poolDictionaries:''

	category:'SCM-Monticello-UI'

!

MCCodeTool comment:'MCCodeTool is an abstract superclass for those Monticello browsers that display code.

It contains copies of the various CodeHolder methods that perform the various menu operations in the method list.

'

!

!MCCodeTool methodsFor:'menus'!

adoptMessageInCurrentChangeset

	"Add the receiver's method to the current change set if not already there"

	self selectedClassOrMetaClass ifNotNilDo: [ :cl |

		self selectedMessageName ifNotNilDo: [ :sel |

			ChangeSet current adoptSelector: sel forClass: cl.

			self changed: #annotations ]]

!

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]

!

browseMessages

	"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 selector chosen."

	self systemNavigation browseAllImplementorsOf: (self selectedMessageName ifNil: [ ^nil ])

!

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]

!

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 systemNavigation browseAllCallsOn: (self selectedMessageName ifNil: [ ^nil ])

!

browseVersions

	"Create and schedule a message set browser on all versions of the 

	currently selected message selector."

	| class selector compiledMethod |

	class _ self selectedClassOrMetaClass.

	selector _ self selectedMessageName.

	compiledMethod _ class compiledMethodAt: selector ifAbsent: [ ^self ].

	VersionsBrowser

		browseVersionsOf: compiledMethod

		class: class theNonMetaClass

		meta: class isMeta

		category: self selectedMessageCategoryName

		selector: selector

!

classHierarchy

	"Create and schedule a class list browser on the receiver's hierarchy."

	self systemNavigation  spawnHierarchyForClass: self selectedClassOrMetaClass

		selector: self selectedMessageName	"OK if nil"

!

classListMenu: aMenu 

	aMenu addList: #(

		-

		('browse full (b)'			browseMethodFull)

		('browse hierarchy (h)'		classHierarchy)

		('browse protocol (p)'		browseFullProtocol)

"		-

		('printOut'					printOutClass)

		('fileOut'					fileOutClass)

"		-

		('show hierarchy'			methodHierarchy)

"		('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...'				findMethodInChangeSets)).

	^aMenu

!

copySelector

	"Copy the selected selector to the clipboard"

	| selector |

	(selector _ self selectedMessageName) ifNotNil:

		[Clipboard clipboardText: selector asString]

!

fileOutMessage

	"Put a description of the selected message on a file"

	self selectedMessageName ifNotNil:

		[Cursor write showWhile:

			[self selectedClassOrMetaClass fileOutMethod: self selectedMessageName]]

!

findMethodInChangeSets

	"Find and open a changeSet containing the current method."

	| aName |

	(aName _ self selectedMessageName) ifNotNil: [

		ChangeSorter browseChangeSetsWithClass: self selectedClassOrMetaClass

					selector: aName]

!

methodHierarchy

	"Create and schedule a method browser on the hierarchy of implementors."

	self systemNavigation methodHierarchyBrowserForClass: self selectedClassOrMetaClass

		selector: self selectedMessageName

!

methodListKey: aKeystroke from: aListMorph 

	aKeystroke caseOf: {

		[$b] -> [self browseMethodFull].

		[$h] -> [self classHierarchy].

		[$O] -> [self openSingleMessageBrowser].

		[$p] -> [self browseFullProtocol].

		[$o] -> [self fileOutMessage].

		[$c] -> [self copySelector].

		[$n] -> [self browseSendersOfMessages].

		[$m] -> [self browseMessages].

		[$i] -> [self methodHierarchy].

		[$v] -> [self browseVersions]}

		 otherwise: []

!

methodListMenu: aMenu

	"Build the menu for the selected method, if any."

	self selectedMessageName ifNotNil: [

	aMenu addList:#(

			('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)).

		aMenu addList: #(

			-

			('browse senders (n)'						browseSendersOfMessages)

			('browse implementors (m)'					browseMessages)

			('inheritance (i)'						methodHierarchy)

			('versions (v)'							browseVersions)

		('change sets with this method'			findMethodInChangeSets)

"		('x revert to previous version'				revertToPreviousVersion)"

		('remove from current change set'		removeFromCurrentChanges)

"		('x revert & remove from changes'		revertAndForget)"

		('add to current change set'				adoptMessageInCurrentChangeset)

"		('x copy up or copy down...'				copyUpOrCopyDown)"

"		('x remove method (x)'					removeMessage)"

		"-"

		).

	].

"	aMenu addList: #(

			('x inst var refs...'						browseInstVarRefs)

			('x inst var defs...'						browseInstVarDefs)

			('x class var refs...'						browseClassVarRefs)

			('x class variables'						browseClassVariables)

			('x class refs (N)'							browseClassRefs)

	).

"

	^ aMenu

!

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

!

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]

!

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]

!

removeFromCurrentChanges

	"Tell the changes mgr to forget that the current msg was changed."

	ChangeSet current removeSelectorChanges: self selectedMessageName 

			class: self selectedClassOrMetaClass.

	self changed: #annotations

! !

!MCCodeTool methodsFor:'subclassResponsibility'!

annotations

	"Build an annotations string for the various browsers"

	^''

!

selectedClass

	"Answer the class that is selected, or nil"

	self subclassResponsibility

!

selectedClassOrMetaClass

	"Answer the class that is selected, or nil"

	self subclassResponsibility

!

selectedMessageCategoryName

	"Answer the method category of the method that is selected, or nil"

	self subclassResponsibility

!

selectedMessageName

	"Answer the name of the selected message"

	self subclassResponsibility

! !

!MCCodeTool class methodsFor:'documentation'!

version

    ^ '$Header: /cvs/stx/stx/goodies/monticello/MCCodeTool.st,v 1.2 2012-09-11 21:20:58 cg Exp $'

! !