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!