Squeak 4.6: ToolBuilder-SUnit-fbs.19.mcz

Chris Muller uploaded a new version of ToolBuilder-SUnit to project Squeak 4.6:
http://source.squeak.org/squeak46/ToolBuilder-SUnit-fbs.19.mcz

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

Name: ToolBuilder-SUnit-fbs.19
Author: fbs
Time: 9 January 2014, 2:54:40.438 pm
UUID: 3e30756c-2af8-0741-836f-0d42a9d5af32
Ancestors: ToolBuilder-SUnit-fbs.18

Move ToolBuilder's SUnit "extensions" - the stubs we use to test ToolBuilder-built components - back to ToolBuilder-SUnit. Otherwise we break the modularity between SUnit('s GUI) and ToolBuilder.

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

SystemOrganization addCategory: #'ToolBuilder-SUnit'!

Object subclass: #WidgetStub
        instanceVariableNames: 'spec state'
        classVariableNames: ''
        poolDictionaries: ''
        category: 'ToolBuilder-SUnit'!

WidgetStub subclass: #ButtonStub
        instanceVariableNames: ''
        classVariableNames: ''
        poolDictionaries: ''
        category: 'ToolBuilder-SUnit'!

----- Method: ButtonStub>>click (in category 'simulating') -----
click
        | action |
        action := spec action.
        action isSymbol
                ifTrue: [self model perform: action]
                ifFalse: [action value]!

----- Method: ButtonStub>>color (in category 'simulating') -----
color
        ^ state at: #color!

----- Method: ButtonStub>>isEnabled (in category 'simulating') -----
isEnabled
        ^ state at: #enabled!

----- Method: ButtonStub>>isPressed (in category 'simulating') -----
isPressed
        ^ state at: #state!

----- Method: ButtonStub>>label (in category 'simulating') -----
label
        ^ state at: #label!

----- Method: ButtonStub>>stateVariables (in category 'events') -----
stateVariables
        ^ #(label color state enabled)!

WidgetStub subclass: #CompositeStub
        instanceVariableNames: ''
        classVariableNames: ''
        poolDictionaries: ''
        category: 'ToolBuilder-SUnit'!

----- Method: CompositeStub>>children (in category 'accessing') -----
children
        ^ state at: #children ifAbsent: [#()]!

----- Method: CompositeStub>>children: (in category 'accessing') -----
children: anObject
        state at: #children put: anObject!

----- Method: CompositeStub>>stateVariables (in category 'accessing') -----
stateVariables
        ^ #(children)!

----- Method: CompositeStub>>widgetNamed: (in category 'accessing') -----
widgetNamed: aString
        self name = aString
                ifTrue: [^ self]
                ifFalse: [self children do: [:ea | (ea widgetNamed: aString) ifNotNil: [:w | ^ w]]].
        ^ nil!

CompositeStub subclass: #PanelStub
        instanceVariableNames: ''
        classVariableNames: ''
        poolDictionaries: ''
        category: 'ToolBuilder-SUnit'!

CompositeStub subclass: #WindowStub
        instanceVariableNames: ''
        classVariableNames: ''
        poolDictionaries: ''
        category: 'ToolBuilder-SUnit'!

----- Method: WindowStub>>close (in category 'simulating') -----
close
        spec model perform: spec closeAction!

----- Method: WindowStub>>stateVariables (in category 'events') -----
stateVariables
        ^ super stateVariables, #(label)!

WidgetStub subclass: #ListStub
        instanceVariableNames: 'list index'
        classVariableNames: ''
        poolDictionaries: ''
        category: 'ToolBuilder-SUnit'!

----- Method: ListStub>>click: (in category 'simulating') -----
click: aString
        self clickItemAt: (self list indexOf: aString)!

----- Method: ListStub>>clickItemAt: (in category 'simulating') -----
clickItemAt: anInteger
        | selector |
        selector := spec setIndex.
        selector
                ifNil: [self model perform: spec setSelected with: (self list at: anInteger)]
                ifNotNil: [self model perform: selector with: anInteger]
!

----- Method: ListStub>>list (in category 'simulating') -----
list
        ^ list ifNil: [Array new]!

----- Method: ListStub>>menu (in category 'simulating') -----
menu
        ^ MenuStub fromSpec:
                (self model
                        perform: spec menu
                        with: (PluggableMenuSpec withModel: self model))!

----- Method: ListStub>>refresh (in category 'events') -----
refresh
        self refreshList.
        self refreshIndex!

----- Method: ListStub>>refreshIndex (in category 'events') -----
refreshIndex
        | selector |
        selector := spec getIndex.
        index := selector
                ifNil: [self list indexOf: (self model perform: spec getSelected)]
                ifNotNil: [spec model perform: selector]
!

----- Method: ListStub>>refreshList (in category 'events') -----
refreshList
        list := self model perform: spec list!

----- Method: ListStub>>selectedIndex (in category 'simulating') -----
selectedIndex
        ^ index ifNil: [0]!

----- Method: ListStub>>selectedItem (in category 'simulating') -----
selectedItem
        | items idx |
        (items  := self list) isEmpty ifTrue: [^ nil].
        (idx := self selectedIndex) = 0 ifTrue: [^ nil].
        ^ items at: idx
        !

----- Method: ListStub>>update: (in category 'events') -----
update: aSelector
        aSelector = spec list ifTrue: [^ self refreshList].
        aSelector = spec getSelected ifTrue: [^ self refreshIndex].
        aSelector = spec getIndex ifTrue: [^ self refreshIndex].
        ^ super update: aSelector!

WidgetStub subclass: #MenuStub
        instanceVariableNames: ''
        classVariableNames: ''
        poolDictionaries: ''
        category: 'ToolBuilder-SUnit'!

----- Method: MenuStub>>click: (in category 'as yet unclassified') -----
click: aString
        | item |
        item := self items detect: [:ea | ea label = aString] ifNone: [^ self].
        item action isSymbol
                ifTrue: [self model perform: item action]
                ifFalse: [item action value]!

----- Method: MenuStub>>items (in category 'as yet unclassified') -----
items
        ^ spec items!

----- Method: MenuStub>>labels (in category 'as yet unclassified') -----
labels
        ^ self items keys!

WidgetStub subclass: #TextStub
        instanceVariableNames: ''
        classVariableNames: ''
        poolDictionaries: ''
        category: 'ToolBuilder-SUnit'!

----- Method: TextStub>>accept: (in category 'simulating') -----
accept: aString
        state at: #getText put: aString.
        ^ self model perform: spec setText with: aString asText!

----- Method: TextStub>>color (in category 'simulating') -----
color
        ^ state at: #color!

----- Method: TextStub>>stateVariables (in category 'events') -----
stateVariables
        ^ #(color selection getText)!

----- Method: TextStub>>text (in category 'simulating') -----
text
        ^ state at: #getText!

WidgetStub subclass: #TreeNodeStub
        instanceVariableNames: 'item'
        classVariableNames: ''
        poolDictionaries: ''
        category: 'ToolBuilder-SUnit'!

----- Method: TreeNodeStub class>>fromSpec:item: (in category 'instance creation') -----
fromSpec: aSpec item: anObject
        ^ self new setSpec: aSpec item: anObject!

----- Method: TreeNodeStub>>children (in category 'simulating') -----
children
        ^ (self model perform: spec getChildren with: item)
                collect: [:ea | TreeNodeStub fromSpec: spec item: ea]!

----- Method: TreeNodeStub>>item (in category 'simulating') -----
item
        ^ item!

----- Method: TreeNodeStub>>label (in category 'simulating') -----
label
        ^ self model perform: spec label with: item!

----- Method: TreeNodeStub>>matches: (in category 'private') -----
matches: aString
        ^ self label = aString!

----- Method: TreeNodeStub>>openPath: (in category 'events') -----
openPath: anArray
        | child |
        anArray isEmpty
                ifTrue: [self select]
                ifFalse: [child := self children
                                                                detect: [:ea | ea matches: anArray first]
                                                                ifNone: [^ self select].
                                child openPath: anArray allButFirst]
        !

----- Method: TreeNodeStub>>printOn: (in category 'printing') -----
printOn: aStream
        aStream
                print: self class;
                nextPut: $<;
                print: item;
                nextPut: $>!

----- Method: TreeNodeStub>>select (in category 'simulating') -----
select
        self model perform: spec setSelected with: item!

----- Method: TreeNodeStub>>selectPath: (in category 'private') -----
selectPath: anArray
        | child |
        anArray isEmpty ifTrue: [^ self select].
        child := self children detect: [:ea | ea matches: anArray first] ifNone: [^ self select].
        child selectPath: anArray allButFirst.!

----- Method: TreeNodeStub>>setSpec:item: (in category 'initialize-release') -----
setSpec: aSpec item: anObject
        super setSpec: aSpec.
        item := anObject!

WidgetStub subclass: #TreeStub
        instanceVariableNames: 'roots'
        classVariableNames: ''
        poolDictionaries: ''
        category: 'ToolBuilder-SUnit'!

----- Method: TreeStub>>openPath: (in category 'private') -----
openPath: anArray
        | first |
        first := roots detect: [:ea | ea matches: anArray first] ifNone: [^ self].
        first openPath: anArray allButFirst!

----- Method: TreeStub>>roots: (in category 'private') -----
roots: anArray
        roots := anArray collect: [:ea | TreeNodeStub fromSpec: spec item: ea].
!

----- Method: TreeStub>>select: (in category 'simulating') -----
select: anArray
        self openPath: anArray!

----- Method: TreeStub>>setSpec: (in category 'initialize-release') -----
setSpec: aSpec
        super setSpec: aSpec.
        self update: spec roots!

----- Method: TreeStub>>update: (in category 'events') -----
update: anObject
        anObject == spec roots ifTrue: [^ self updateRoots].
        anObject == spec getSelectedPath ifTrue: [^ self updateSelectedPath].
        (anObject isKindOf: Array) ifTrue: [^ self openPath: anObject allButFirst].
        super update: anObject
        !

----- Method: TreeStub>>updateRoots (in category 'events') -----
updateRoots
        ^ self roots: (self model perform: spec roots)
!

----- Method: TreeStub>>updateSelectedPath (in category 'events') -----
updateSelectedPath
        | path first |
        path := self model perform: spec getSelectedPath.
        first := roots detect: [:ea | ea item = path first] ifNone: [^ self].
        first selectPath: path allButFirst.!

----- Method: WidgetStub class>>fromSpec: (in category 'instance creation') -----
fromSpec: aSpec
        ^ self new setSpec: aSpec!

----- Method: WidgetStub>>model (in category 'simulating') -----
model
        ^ spec model!

----- Method: WidgetStub>>name (in category 'accessing') -----
name
        ^ spec name ifNil: [' ']!

----- Method: WidgetStub>>printOn: (in category 'printing') -----
printOn: aStream
        aStream
                print: self class;
                nextPut: $<;
                nextPutAll: self name;
                nextPut: $>!

----- Method: WidgetStub>>refresh (in category 'events') -----
refresh
        self stateVariables do: [:var | self refresh: var]!

----- Method: WidgetStub>>refresh: (in category 'events') -----
refresh: var
        | value |
        value := spec perform: var.
        self refresh: var with: value!

----- Method: WidgetStub>>refresh:with: (in category 'events') -----
refresh: var with: value
        state
                at: var
                put: (value isSymbol
                  ifTrue: [spec model perform: value]
                                ifFalse: [value])!

----- Method: WidgetStub>>setSpec: (in category 'initialize-release') -----
setSpec: aSpec
        state := IdentityDictionary new.
        spec := aSpec.
        spec model addDependent: self.
        self refresh.!

----- Method: WidgetStub>>spec (in category 'accessing') -----
spec
        ^ spec!

----- Method: WidgetStub>>stateVariables (in category 'events') -----
stateVariables
        ^ #()!

----- Method: WidgetStub>>update: (in category 'events') -----
update: aSymbol
       
        self stateVariables do:
                [:var |
                (spec perform: var) == aSymbol ifTrue:
                        [self refresh: var with: aSymbol.
                        ^ self]]!

----- Method: WidgetStub>>widgetNamed: (in category 'accessing') -----
widgetNamed: aString
        ^ self name = aString
                ifTrue: [self]
                ifFalse: [nil]!

ToolBuilder subclass: #SUnitToolBuilder
        instanceVariableNames: 'widgets'
        classVariableNames: ''
        poolDictionaries: ''
        category: 'ToolBuilder-SUnit'!

!SUnitToolBuilder commentStamp: 'cwp 6/7/2005 00:53' prior: 0!
I create a set of "stub" widgets that are useful for testing. Instead of drawing themselves in some GUI, they simulate graphical widgets for testing purposes. Through my widgets, unit tests can simulate user actions and make assertions about the state of the display.

See TestRunnerPlusTest for examples.!

----- Method: SUnitToolBuilder>>buildPluggableButton: (in category 'building') -----
buildPluggableButton: aSpec
        | w |
        w := ButtonStub fromSpec: aSpec.
        self register: w id: aSpec name.
        ^w!

----- Method: SUnitToolBuilder>>buildPluggableList: (in category 'building') -----
buildPluggableList: aSpec
        | w |
        w := ListStub fromSpec: aSpec.
        self register: w id: aSpec name.
        ^w!

----- Method: SUnitToolBuilder>>buildPluggableMenu: (in category 'building') -----
buildPluggableMenu: aSpec
        ^ MenuStub fromSpec: aSpec!

----- Method: SUnitToolBuilder>>buildPluggablePanel: (in category 'building') -----
buildPluggablePanel: aSpec
        | w |
        w := PanelStub fromSpec: aSpec.
        self register: w id: aSpec name.
        ^w!

----- Method: SUnitToolBuilder>>buildPluggableText: (in category 'building') -----
buildPluggableText: aSpec
        | w |
        w := TextStub fromSpec: aSpec.
        self register: w id: aSpec name.
        ^w!

----- Method: SUnitToolBuilder>>buildPluggableTree: (in category 'building') -----
buildPluggableTree: aSpec
        | w |
        w := TreeStub fromSpec: aSpec.
        self register: w id: aSpec name.
        ^w!

----- Method: SUnitToolBuilder>>buildPluggableWindow: (in category 'building') -----
buildPluggableWindow: aSpec
        | window children |
        window := WindowStub fromSpec: aSpec.
        children := aSpec children.
        children isSymbol
                ifFalse: [window children: (children collect: [:ea | ea buildWith: self])].
        self register: window id: aSpec name.
        ^ window!

----- Method: SUnitToolBuilder>>close: (in category 'opening') -----
close: aWidget
        aWidget close!

----- Method: SUnitToolBuilder>>open: (in category 'opening') -----
open: anObject
        ^ self build: anObject!

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

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

ToolBuilderTests subclass: #SUnitToolBuilderTests
        instanceVariableNames: ''
        classVariableNames: ''
        poolDictionaries: ''
        category: 'ToolBuilder-SUnit'!

----- Method: SUnitToolBuilderTests>>acceptWidgetText (in category 'support') -----
acceptWidgetText
        widget accept: 'Some text'!

----- Method: SUnitToolBuilderTests>>buttonWidgetEnabled (in category 'support') -----
buttonWidgetEnabled
        ^ widget isEnabled!

----- Method: SUnitToolBuilderTests>>changeListWidget (in category 'support') -----
changeListWidget
        widget clickItemAt: widget selectedIndex + 1!

----- Method: SUnitToolBuilderTests>>fireButtonWidget (in category 'support') -----
fireButtonWidget
        widget click!

----- Method: SUnitToolBuilderTests>>fireMenuItemWidget (in category 'support') -----
fireMenuItemWidget
        widget click: 'Menu Item'!

----- Method: SUnitToolBuilderTests>>setUp (in category 'running') -----
setUp
        super setUp.
        builder := SUnitToolBuilder new.!

----- Method: SUnitToolBuilderTests>>testHandlingNotification (in category 'tests') -----
testHandlingNotification
        | receivedSignal resumed |
        receivedSignal := resumed := false.
        [ | count |
        "client-code puts up progress, and signals some notications"
        count := 0.
        'doing something'
                displayProgressFrom: 0
                to: 10
                during:
                        [ : bar | 10 timesRepeat:
                                [ bar value: (count := count + 1).
                                (Delay forMilliseconds: 200) wait.
                                Notification signal: 'message'.
                                resumed := true ] ] ]
                on: Notification
                do:
                        [ : noti | receivedSignal := true.
                        noti resume ].
        self
                 assert: receivedSignal ;
                 assert: resumed!

----- Method: SUnitToolBuilderTests>>testListCached (in category 'tests') -----
testListCached
       
        self makeItemList.
        queries := Bag new.
        self changed: #getList.
        widget list.
        widget list.
        self assert: queries size = 1!

----- Method: SUnitToolBuilderTests>>testListSelectionCached (in category 'tests') -----
testListSelectionCached
       
        self makeItemList.
        queries := Bag new.
        self changed: #getListSelection.
        widget selectedIndex.
        widget selectedIndex.
        self assert: queries size = 1!

----- Method: SUnitToolBuilderTests>>testTextCached (in category 'tests') -----
testTextCached
       
        self makeText.
        queries := Bag new.
        self changed: #getText.
        widget text.
        widget text.
        self assert: queries size = 1!

----- Method: SUnitToolBuilderTests>>widgetColor (in category 'support') -----
widgetColor
        ^ widget color!