Bernhard Pieber uploaded a new version of ToolBuilder-MVC to project The Inbox:
http://source.squeak.org/inbox/ToolBuilder-MVC-bp.14.mcz

==================== Summary ====================

Name: ToolBuilder-MVC-bp.14
Author: bp
Time: 9 July 2009, 12:20:20 am
UUID: 695c8a3c-cf27-46cf-9a13-0e5b75501ea5
Ancestors: ToolBuilder-MVC-sd.13

Added tearDown to restore display

==================== Snapshot ====================

SystemOrganization addCategory: #'ToolBuilder-MVC'!

ToolBuilderTests subclass: #MVCToolBuilderTests
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-MVC'!

!MVCToolBuilderTests commentStamp: 'ar 2/11/2005 15:02' prior: 0!
Tests for the MVC tool builder.!

----- Method: MVCToolBuilderTests>>acceptWidgetText (in category 'support') -----
acceptWidgetText
	widget hasUnacceptedEdits: true.
	widget controller accept.!

----- Method: MVCToolBuilderTests>>changeListWidget (in category 'support') -----
changeListWidget
	widget changeModelSelection: widget getCurrentSelectionIndex + 1.!

----- Method: MVCToolBuilderTests>>fireButtonWidget (in category 'support') -----
fireButtonWidget
	widget performAction.!

----- Method: MVCToolBuilderTests>>setUp (in category 'support') -----
setUp
	super setUp.
	builder := MVCToolBuilder new.!

----- Method: MVCToolBuilderTests>>tearDown (in category 'support') -----
tearDown
	ScreenController new restoreDisplay.
	super tearDown!

----- Method: MVCToolBuilderTests>>testAddAction (in category 'tests-not applicable') -----
testAddAction
	"MVCToolBuilder does not implement #buildPluggableMenu:"!

----- Method: MVCToolBuilderTests>>testAddTargetSelectorArgumentList (in category 'tests-not applicable') -----
testAddTargetSelectorArgumentList
	"MVCToolBuilder does not implement #buildPluggableMenu:"!

----- Method: MVCToolBuilderTests>>testButtonFiresBlock (in category 'tests-not applicable') -----
testButtonFiresBlock
	"MVC buttons only support action Symbols"!

----- Method: MVCToolBuilderTests>>testButtonFiresMessage (in category 'tests-not applicable') -----
testButtonFiresMessage
	"MVC buttons only support action Symbols, not MessageSends"!

----- Method: MVCToolBuilderTests>>testButtonInitiallyDisabled (in category 'tests-not applicable') -----
testButtonInitiallyDisabled
	"MVC does not have button enablement"!

----- Method: MVCToolBuilderTests>>testButtonInitiallyDisabledSelector (in category 'tests-not applicable') -----
testButtonInitiallyDisabledSelector
	"MVC does not have button enablement"!

----- Method: MVCToolBuilderTests>>testGetButtonColor (in category 'tests-not applicable') -----
testGetButtonColor
	"MVC buttons do not have color"!

----- Method: MVCToolBuilderTests>>testGetButtonEnabled (in category 'tests-not applicable') -----
testGetButtonEnabled
	"MVC does not have button enablement"!

----- Method: MVCToolBuilderTests>>testGetButtonSideEffectFree (in category 'tests-not applicable') -----
testGetButtonSideEffectFree
	"MVC button ask for their state on any change notification"!

----- Method: MVCToolBuilderTests>>testGetInputFieldColor (in category 'tests-not applicable') -----
testGetInputFieldColor
	"MVC input fields do not have color"!

----- Method: MVCToolBuilderTests>>testGetPanelChildren (in category 'tests-not applicable') -----
testGetPanelChildren
	"MVC panels do not allow changing children"!

----- Method: MVCToolBuilderTests>>testGetTextColor (in category 'tests-not applicable') -----
testGetTextColor
	"not supported in MVC"!

----- Method: MVCToolBuilderTests>>testGetWindowChildren (in category 'tests-not applicable') -----
testGetWindowChildren
	"not supported in MVC"!

----- Method: MVCToolBuilderTests>>testGetWindowLabel (in category 'tests-not applicable') -----
testGetWindowLabel
	"not supported in MVC"!

----- Method: MVCToolBuilderTests>>testTreeExpandPath (in category 'tests-not applicable') -----
testTreeExpandPath
	"MVCToollBuilder does not implement trees"!

----- Method: MVCToolBuilderTests>>testTreeExpandPathFirst (in category 'tests-not applicable') -----
testTreeExpandPathFirst
	"MVCToollBuilder does not implement trees"!

----- Method: MVCToolBuilderTests>>testTreeGetSelectionPath (in category 'tests-not applicable') -----
testTreeGetSelectionPath
	"MVCToollBuilder does not implement trees"!

----- Method: MVCToolBuilderTests>>testTreeRoots (in category 'tests-not applicable') -----
testTreeRoots
	"MVCToollBuilder does not implement trees"!

----- Method: MVCToolBuilderTests>>testTreeWidgetID (in category 'tests-not applicable') -----
testTreeWidgetID
	"MVCToollBuilder does not implement trees"!

----- Method: MVCToolBuilderTests>>testWindowCloseAction (in category 'tests-not applicable') -----
testWindowCloseAction
	"This can only work if we're actually run in MVC"
	World isNil ifTrue: [super testWindowCloseAction]!

ToolBuilder subclass: #MVCToolBuilder
	instanceVariableNames: 'panes topSize widgets'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-MVC'!

!MVCToolBuilder commentStamp: 'ar 2/11/2005 15:02' prior: 0!
The MVC tool builder.!

----- Method: MVCToolBuilder class>>isActiveBuilder (in category 'accessing') -----
isActiveBuilder
	"Answer whether I am the currently active builder"
	"This is really a way of answering whether 'Smalltalk isMVC'"
	ScheduledControllers ifNil:[^false].
	^ScheduledControllers activeControllerProcess == Processor activeProcess!

----- Method: MVCToolBuilder>>asWindow: (in category 'private') -----
asWindow: aRectangle
	^(aRectangle origin * topSize extent) truncated
		corner: (aRectangle corner * topSize extent) truncated!

----- Method: MVCToolBuilder>>buildPluggableButton: (in category 'pluggable widgets') -----
buildPluggableButton: aSpec
	| widget label state |
	label := aSpec label.
	state := aSpec state.
	widget := PluggableButtonView on: aSpec model
				getState: (state isSymbol ifTrue:[state])
				action: aSpec action
				label: (label isSymbol ifTrue:[label]).
	self register: widget id: aSpec name.
	(label isSymbol or:[label == nil]) ifFalse:[widget label: label].
	self setFrame: aSpec frame in: widget.
	parent ifNotNil:[parent addSubView: widget].
	^widget!

----- Method: MVCToolBuilder>>buildPluggableList: (in category 'pluggable widgets') -----
buildPluggableList: aSpec
	| widget listClass getIndex setIndex |
	aSpec getSelected ifNil:[
		listClass := PluggableListView.
		getIndex := aSpec getIndex.
		setIndex := aSpec setIndex.
	] ifNotNil:[
		listClass := PluggableListViewByItem.
		getIndex := aSpec getSelected.
		setIndex := aSpec setSelected.
	].
	widget := listClass on: aSpec model
				list: aSpec list
				selected: getIndex
				changeSelected: setIndex
				menu: aSpec menu
				keystroke: aSpec keyPress.
	self register: widget id: aSpec name.
	self setFrame: aSpec frame in: widget.
	parent ifNotNil:[parent addSubView: widget].
	panes ifNotNil:[
		aSpec list ifNotNil:[panes add: aSpec list].
	].
	^widget!

----- Method: MVCToolBuilder>>buildPluggablePanel: (in category 'pluggable widgets') -----
buildPluggablePanel: aSpec
	| widget children |
	widget := View new model: aSpec model.
	self register: widget id: aSpec name.
	children := aSpec children.
	children isSymbol ifTrue:[
		"@@@@ FIXME: PluggablePanes need to remember their getChildrenSelector"
		"widget getChildrenSelector: children.
		widget update: children."
		children := #().
	].
	self buildAll: children in: widget.
	self setFrame: aSpec frame in: widget.
	parent ifNotNil:[parent addSubView: widget].
	self setLayout: aSpec layout in: widget.
	^widget!

----- Method: MVCToolBuilder>>buildPluggableText: (in category 'pluggable widgets') -----
buildPluggableText: aSpec
	| widget |
	widget := PluggableTextView on: aSpec model
				text: aSpec getText 
				accept: aSpec setText
				readSelection: aSpec selection 
				menu: aSpec menu.
	self register: widget id: aSpec name.
	self setFrame: aSpec frame in: widget.
	parent ifNotNil:[parent addSubView: widget].
	panes ifNotNil:[
		aSpec getText ifNotNil:[panes add: aSpec getText].
	].
	^widget!

----- Method: MVCToolBuilder>>buildPluggableWindow: (in category 'pluggable widgets') -----
buildPluggableWindow: aSpec
	| widget children |
	topSize := 0 at 0 corner: 640 at 480.
	aSpec layout == #proportional ifFalse:[
		"This needs to be implemented - probably by adding a single pane and then the rest"
		^self error: 'Not implemented'.
	].
	widget := StandardSystemView new.
	self register: widget id: aSpec name.
	widget model: aSpec model.
	children := aSpec children.
	children isSymbol ifTrue:[
		"This isn't implemented by StandardSystemView, so we fake it"
		children := widget model perform: children.
	].
	aSpec extent ifNotNil:[topSize :=  0 at 0 extent: aSpec extent].
	widget window: topSize.
	panes := OrderedCollection new.
	self buildAll: children in: widget.
	widget setUpdatablePanesFrom: panes.
	^widget!

----- Method: MVCToolBuilder>>close: (in category 'opening') -----
close: aWidget
	"Close a previously opened widget"
	aWidget controller closeAndUnschedule.!

----- Method: MVCToolBuilder>>open: (in category 'opening') -----
open: anObject
	"Build and open the object. Answer the widget opened."
	| window |
	window := self build: anObject.
	window controller open.
	^window!

----- Method: MVCToolBuilder>>open:label: (in category 'opening') -----
open: anObject label: aString
	"Build an open the object, labeling it appropriately.  Answer the widget opened."
	| window |
	window := self build: anObject.
	window label: aString.
	window controller open.
	^window!

----- Method: MVCToolBuilder>>pluggableTreeSpec (in category 'defaults') -----
pluggableTreeSpec
	"We have no tree widget in MVC right now"
	^nil!

----- Method: MVCToolBuilder>>register:id: (in category 'private') -----
register: widget id: id
	id ifNil:[^self].
	widgets ifNil:[widgets := Dictionary new].
	widgets at: id put: widget.!

----- Method: MVCToolBuilder>>runModal: (in category 'opening') -----
runModal: aWidget
	"Run the (previously opened) widget modally, e.g., 
	do not return control to the sender before the user has responded."

	self error: 'Please implement me'.!

----- Method: MVCToolBuilder>>setFrame:in: (in category 'private') -----
setFrame: aRectangle in: widget
	| win |
	aRectangle ifNil:[^nil].
	win := self asWindow: aRectangle.
	widget window: win.!

----- Method: MVCToolBuilder>>setLayout:in: (in category 'private') -----
setLayout: layout in: widget
	layout == #proportional ifTrue:[^self].
	layout == #horizontal ifTrue:[
		| prev |
		prev := nil.
		widget subViews do:[:next|
			prev ifNotNil:[
				next align: next viewport topLeft with: prev viewport topRight.
			].
			prev := next.
		].
		^self].
	layout == #vertical ifTrue:[
		| prev |
		prev := nil.
		widget subViews do:[:next|
			prev ifNotNil:[
				next align: next viewport topLeft with: prev viewport bottomLeft.
			].
			prev := next.
		].
		^self].
	^self error: 'Unknown layout: ', layout.!

----- Method: MVCToolBuilder>>widgetAt:ifAbsent: (in category 'private') -----
widgetAt: id ifAbsent: aBlock
	widgets ifNil:[^aBlock value].
	^widgets at: id ifAbsent: aBlock!

UIManager subclass: #MVCUIManager
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-MVC'!

!MVCUIManager commentStamp: 'ar 2/11/2005 21:53' prior: 0!
The MVC ui manager.!

----- Method: MVCUIManager class>>isActiveManager (in category 'accessing') -----
isActiveManager
	"Answer whether I should act as the active ui manager"
	"This is really a way of answering whether 'Smalltalk isMVC'"
	ScheduledControllers ifNil:[^false].
	^ScheduledControllers activeControllerProcess == Processor activeProcess!

----- Method: MVCUIManager>>chooseDirectory:from: (in category 'ui requests') -----
chooseDirectory: label from: dir
	"Let the user choose a directory"
	^self notYetImplemented!

----- Method: MVCUIManager>>chooseFileMatching:label: (in category 'ui requests') -----
chooseFileMatching: patterns label: labelString
	"Let the user choose a file matching the given patterns"
	^self notYetImplemented!

----- Method: MVCUIManager>>chooseFrom:lines:title: (in category 'ui requests') -----
chooseFrom: aList lines: linesArray title: aString
	"Choose an item from the given list. Answer the index of the selected item."
	| menu |
	menu := PopUpMenu labelArray: aList lines: linesArray.
	^aString isEmpty ifTrue:[menu startUp] ifFalse:[menu startUpWithCaption: aString]!

----- Method: MVCUIManager>>chooseFrom:values:lines:title: (in category 'ui requests') -----
chooseFrom: labelList values: valueList lines: linesArray title: aString
	"Choose an item from the given list. Answer the selected item."
	| menu |
	menu := SelectionMenu labels: labelList lines: linesArray selections: valueList.
	^aString isEmpty ifTrue:[menu startUp] ifFalse:[menu startUpWithCaption: aString]!

----- Method: MVCUIManager>>confirm: (in category 'ui requests') -----
confirm: queryString
	"Put up a yes/no menu with caption queryString. Answer true if the 
	response is yes, false if no. This is a modal question--the user must 
	respond yes or no."
	^PopUpMenu confirm: queryString!

----- Method: MVCUIManager>>confirm:orCancel: (in category 'ui requests') -----
confirm: aString orCancel: cancelBlock
	"Put up a yes/no/cancel menu with caption aString. Answer true if  
	the response is yes, false if no. If cancel is chosen, evaluate  
	cancelBlock. This is a modal question--the user must respond yes or no."
	^PopUpMenu confirm: aString orCancel: cancelBlock!

----- Method: MVCUIManager>>displayProgress:at:from:to:during: (in category 'ui requests') -----
displayProgress: titleString at: aPoint from: minVal to: maxVal during: workBlock
	"Display titleString as a caption over a progress bar while workBlock is evaluated."
	^ProgressInitiationException 
		display: titleString
		at: aPoint 
		from: minVal 
		to: maxVal 
		during: workBlock!

----- Method: MVCUIManager>>edit:label:accept: (in category 'ui requests') -----
edit: aText label: labelString accept: anAction
	"Open an editor on the given string/text"

	Workspace new
		acceptContents: aText;
		acceptAction: anAction;
		openLabel: labelString
!

----- Method: MVCUIManager>>inform: (in category 'ui requests') -----
inform: aString
	"Display a message for the user to read and then dismiss"
	^PopUpMenu inform: aString!

----- Method: MVCUIManager>>informUser:during: (in category 'ui requests') -----
informUser: aString during: aBlock
	"Display a message above (or below if insufficient room) the cursor 
	during execution of the given block.
		UIManager default informUser: 'Just a sec!!' during: [(Delay forSeconds: 1) wait].
	"
	(SelectionMenu labels: '')
		displayAt: Sensor cursorPoint
		withCaption: aString
		during: [aBlock value]!

----- Method: MVCUIManager>>informUserDuring: (in category 'ui requests') -----
informUserDuring: aBlock
	"Display a message above (or below if insufficient room) the cursor 
	during execution of the given block.
		UIManager default informUserDuring:[:bar|
			#(one two three) do:[:info|
				bar value: info.
				(Delay forSeconds: 1) wait]]"
	aBlock value:[:string| Transcript cr; show: string].!

----- Method: MVCUIManager>>multiLineRequest:centerAt:initialAnswer:answerHeight: (in category 'ui requests') -----
multiLineRequest: queryString centerAt: aPoint initialAnswer: defaultAnswer answerHeight: answerHeight
	"Create a multi-line instance of me whose question is queryString with
	the given initial answer. Invoke it centered at the given point, and
	answer the string the user accepts.  Answer nil if the user cancels.  An
	empty string returned means that the ussr cleared the editing area and
	then hit 'accept'.  Because multiple lines are invited, we ask that the user
	use the ENTER key, or (in morphic anyway) hit the 'accept' button, to 
	submit; that way, the return key can be typed to move to the next line."
	^FillInTheBlank multiLineRequest: queryString centerAt: aPoint initialAnswer: defaultAnswer answerHeight: answerHeight!

----- Method: MVCUIManager>>request:initialAnswer: (in category 'ui requests') -----
request: queryString initialAnswer: defaultAnswer 
	"Create an instance of me whose question is queryString with the given 
	initial answer. Invoke it centered at the given point, and answer the 
	string the user accepts. Answer the empty string if the user cancels."
	^FillInTheBlank request: queryString initialAnswer: defaultAnswer !

----- Method: MVCUIManager>>requestPassword: (in category 'ui requests') -----
requestPassword: queryString
	"Create an instance of me whose question is queryString. Invoke it centered
	at the cursor, and answer the string the user accepts. Answer the empty 
	string if the user cancels."
	^FillInTheBlank requestPassword: queryString!