[Pkg] Squeak3.10bc: ToolBuilder-SUnit-kph.13.mcz

[squeak-dev-noreply at lists.squeakfoundation.org]

A new version of ToolBuilder-SUnit was added to project Squeak3.10bc:
http://www.squeaksource.com/310bc/ToolBuilder-SUnit-kph.13.mcz

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

Name: ToolBuilder-SUnit-kph.13
Author: kph
Time: 13 December 2008, 4:52:45 am
UUID: 7a603810-767d-419e-bd93-e81dafcfa378
Ancestors: ToolBuilder-SUnit-cwp.12

Saved from SystemVersion

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

SystemOrganization addCategory: #'ToolBuilder-SUnit'!

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>>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!

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!

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

WidgetStub subclass: #ButtonStub
	instanceVariableNames: 'enabled'
	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
	^ self model perform: spec color!

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

----- Method: ButtonStub>>isEnabled (in category 'simulating') -----
isEnabled
	enabled ifNil: [enabled _ spec model perform: spec enabled].
	^ enabled!

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

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

----- Method: CompositeStub>>children: (in category 'accessing') -----
children: anObject
	children := anObject!

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

----- Method: CompositeStub>>widgetNamed: (in category 'accessing') -----
widgetNamed: aString
	self name = aString
		ifTrue: [^ self]
		ifFalse: [children do: [:ea | (ea widgetNamed: aString) ifNotNilDo: [: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>>eventAccessors (in category 'events') -----
eventAccessors
	^ super eventAccessors, #(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>>eventAccessors (in category 'events') -----
eventAccessors
	^ #(list getIndex setIndex getSelected setSelected menu keyPress autoDeselect)!

----- 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: 'text'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ToolBuilder-SUnit'!

----- Method: TextStub>>accept: (in category 'simulating') -----
accept: aString
	^ self model perform: spec setText with: aString asText!

----- Method: TextStub>>color (in category 'simulating') -----
color
	^ self model perform: spec color!

----- Method: TextStub>>eventAccessors (in category 'events') -----
eventAccessors
	^ #(setText selection menu color)!

----- Method: TextStub>>refresh (in category 'events') -----
refresh
	self refreshText!

----- Method: TextStub>>refreshText (in category 'events') -----
refreshText
	text := self model perform: spec getText!

----- Method: TextStub>>text (in category 'simulating') -----
text
	^ text!

----- Method: TextStub>>update: (in category 'events') -----
update: aSymbol
	aSymbol = spec getText ifTrue: [^ self refreshText].
	super update: aSymbol!

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>>eventAccessors (in category 'events') -----
eventAccessors
	^ #(roots getSelectedPath setSelected getChildren hasChildren label icon help menu keyPress)!

----- 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>>eventAccessors (in category 'events') -----
eventAccessors
	^ #()!

----- 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!

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

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

----- Method: WidgetStub>>update: (in category 'events') -----
update: aSelector
	| recognized |
	recognized := self eventAccessors collect: [:ea | spec perform: ea].
	(recognized includes: aSelector)
		ifTrue: [spec model perform: aSelector]!

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