[squeak-dev] Squeak 4.5: ToolBuilder-SUnit-fbs.19.mcz
commits at source.squeak.org
commits at source.squeak.org
Fri Jan 24 20:31:01 UTC 2014
Chris Muller uploaded a new version of ToolBuilder-SUnit to project Squeak 4.5:
http://source.squeak.org/squeak45/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!
More information about the Squeak-dev
mailing list
|