[squeak-dev] The Inbox: ToolBuilder-MVC-bp.14.mcz

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@0 corner: 640@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@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!