Robert Krahn uploaded a new version of MorphicTests to project The Inbox:
http://source.squeak.org/inbox/MorphicTests-rkrk.11.mcz

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

Name: MorphicTests-rkrk.11
Author: rkrk
Time: 24 September 2009, 3:39:36 am
UUID: 7168c8d1-f45b-4968-bbd1-677b6783b81b
Ancestors: MorphicTests-ar.10

Tests for FormCanvas>>frameAndFillRoundRect:radius:fillStyle:borderWidth:borderColor:. It raises errors in degenerate cases when fillStyle is more than a Color (e.g. a GradientFillStyle).

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

SystemOrganization addCategory: #'MorphicTests-Basic'!
SystemOrganization addCategory: #'MorphicTests-Kernel'!
SystemOrganization addCategory: #'MorphicTests-Text Support'!
SystemOrganization addCategory: #'MorphicTests-Widgets'!
SystemOrganization addCategory: #'MorphicTests-Support'!
SystemOrganization addCategory: #'MorphicTests-Worlds'!

HashAndEqualsTestCase subclass: #TextAnchorTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicTests-Text Support'!

----- Method: TextAnchorTest>>setUp (in category 'initialize-release') -----
setUp
	super setUp.
	prototypes
		add: (TextAnchor new anchoredMorph: RectangleMorph new initialize);
		
		add: (TextAnchor new anchoredMorph: EllipseMorph new initialize) !

HashAndEqualsTestCase subclass: #TextLineTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicTests-Text Support'!

----- Method: TextLineTest>>setUp (in category 'initialize-release') -----
setUp
	super setUp.
	prototypes
		add: (TextLine
				start: 1
				stop: 50
				internalSpaces: 2
				paddingWidth: 1) !

Morph subclass: #TestInWorldMorph
	instanceVariableNames: 'intoWorldCount outOfWorldCount'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicTests-Kernel'!

!TestInWorldMorph commentStamp: 'sd 6/5/2005 10:25' prior: 0!
Helper class for MorphTest!

----- Method: TestInWorldMorph>>initialize (in category 'as yet unclassified') -----
initialize
	super initialize.
	outOfWorldCount := intoWorldCount := 0.!

----- Method: TestInWorldMorph>>intoWorld: (in category 'as yet unclassified') -----
intoWorld: aWorld
	aWorld ifNil:[^self].
	super intoWorld: aWorld.
	intoWorldCount := intoWorldCount + 1.
!

----- Method: TestInWorldMorph>>intoWorldCount (in category 'as yet unclassified') -----
intoWorldCount
	^intoWorldCount!

----- Method: TestInWorldMorph>>outOfWorld: (in category 'as yet unclassified') -----
outOfWorld: aWorld
	aWorld ifNil:[^self].
	super outOfWorld: aWorld.
	outOfWorldCount := outOfWorldCount + 1.
!

----- Method: TestInWorldMorph>>outOfWorldCount (in category 'as yet unclassified') -----
outOfWorldCount
	^outOfWorldCount!

TestCase subclass: #BalloonFontTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicTests-Widgets'!

----- Method: BalloonFontTest>>testDefaultFont (in category 'tests') -----
testDefaultFont
	"(self selector: #testDefaultFont) debug"
	self assert: RectangleMorph new balloonFont = BalloonMorph balloonFont.
	self assert: RectangleMorph new defaultBalloonFont = BalloonMorph balloonFont.!

----- Method: BalloonFontTest>>testSpecificFont (in category 'tests') -----
testSpecificFont
	"(self selector: #testSpecificFont) debug"
	| aMorph |
	aMorph := RectangleMorph new.
	self assert: RectangleMorph new balloonFont = BalloonMorph balloonFont.
	self assert: RectangleMorph new defaultBalloonFont = BalloonMorph balloonFont.
	aMorph
		balloonFont: (StrikeFont familyName: #ComicPlain size: 19).
	self assert: aMorph balloonFont
			= (StrikeFont familyName: #ComicPlain size: 19).
	"The next test is horrible because I do no know how to access the font 
	with the appropiate interface"
	self assert: (((BalloonMorph getTextMorph: 'lulu' for: aMorph) text runs at: 1)
			at: 1) font
			= (StrikeFont familyName: #ComicPlain size: 19)!

TestCase subclass: #FormCanvasTest
	instanceVariableNames: 'morph'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicTests-Support'!

----- Method: FormCanvasTest>>testFrameAndFillDegenerateRoundRect01 (in category 'tests') -----
testFrameAndFillDegenerateRoundRect01

	| fill canvas smallRect |
	fill := GradientFillStyle sample.
	canvas := FormCanvas extent: 100 at 100.
	canvas fillColor: Color black.
	smallRect := 0 at 0 corner: 20 at 20.
	self shouldnt: [
		canvas
			frameAndFillRoundRect: smallRect
			radius: smallRect width / 2 + 1
			fillStyle: fill
			borderWidth: 0
			borderColor: Color lightGray]
		raise: Error.!

----- Method: FormCanvasTest>>testFrameAndFillDegenerateRoundRect02 (in category 'tests') -----
testFrameAndFillDegenerateRoundRect02

	| fill canvas smallRect |
	fill := GradientFillStyle sample.
	canvas := FormCanvas extent: 100 at 100.
	canvas fillColor: Color black.
	smallRect := 0 at 0 corner: 20 at 20.
	self shouldnt: [
		canvas
			frameAndFillRoundRect: smallRect
			radius: 0
			fillStyle: fill
			borderWidth: 0
			borderColor: Color lightGray]
		raise: Error.!

TestCase subclass: #MCPTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicTests-Kernel'!

----- Method: MCPTest>>defaultBounds (in category 'constants') -----
defaultBounds
	"the default bounds for morphs"
	^ 0 @ 0 corner: 50 @ 40 !

----- Method: MCPTest>>defaultTop (in category 'constants') -----
defaultTop
	"the default top for morphs"
	^ self defaultBounds top !

----- Method: MCPTest>>testIsMorphicModel (in category 'tests') -----
testIsMorphicModel
	"test isMorphicModel"
	self deny: Object new isMorphicModel.
	self deny: Morph new isMorphicModel.
	self assert: MorphicModel new isMorphicModel.
!

----- Method: MCPTest>>testIsSystemWindow (in category 'tests') -----
testIsSystemWindow
	"test isSystemWindow"
	self deny: Object new isSystemWindow.
	self assert: SystemWindow new isSystemWindow.!

----- Method: MCPTest>>testTop (in category 'tests') -----
testTop
	"test the #top: messages and its consequences"

	| morph factor newTop newBounds |
	morph := Morph new.
	""
	factor := 10.
	newTop := self defaultTop + factor.
	newBounds := self defaultBounds translateBy: 0 @ factor.
	""
	morph top: newTop.
	""
	self assert: morph top = newTop;
		 assert: morph bounds = newBounds!

TestCase subclass: #MorphTest
	instanceVariableNames: 'morph world'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicTests-Kernel'!

!MorphTest commentStamp: '<historical>' prior: 0!
This is the unit test for the class Morph. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: 
	- http://www.c2.com/cgi/wiki?UnitTest
	- http://minnow.cc.gatech.edu/squeak/1547
	- the sunit class category!

MorphTest subclass: #CircleMorphTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicTests-Basic'!

!CircleMorphTest commentStamp: 'tlk 5/21/2006 14:16' prior: 0!
A CircleMorphTest is a subclass of MorphTest.  It was first implemented when removing some unused and broken functionality.

My fixtures are morph, a CircleMorph and world.
!

----- Method: CircleMorphTest>>setUp (in category 'initialize-release') -----
setUp
	morph := CircleMorph new!

----- Method: MorphTest>>getWorld (in category 'initialize-release') -----
getWorld
	^ world
		ifNil: [world := MorphicProject new world]!

----- Method: MorphTest>>setUp (in category 'initialize-release') -----
setUp
	morph := Morph new!

----- Method: MorphTest>>tearDown (in category 'initialize-release') -----
tearDown
	morph delete.
	world
		ifNotNil: [Project deletingProject: world project]!

----- Method: MorphTest>>testIntoWorldCollapseOutOfWorld (in category 'testing - into/outOf World') -----
testIntoWorldCollapseOutOfWorld
	| m1 m2 collapsed |
	"Create the guys"
	m1 := TestInWorldMorph new.
	m2 := TestInWorldMorph new.
	self assert: (m1 intoWorldCount = 0).
	self assert: (m1 outOfWorldCount = 0).
	self assert: (m2 intoWorldCount = 0).
	self assert: (m2 outOfWorldCount = 0).

	"add them to basic morph"
	morph addMorphFront: m1.
	m1 addMorphFront: m2.
	self assert: (m1 intoWorldCount = 0).
	self assert: (m1 outOfWorldCount = 0).
	self assert: (m2 intoWorldCount = 0).
	self assert: (m2 outOfWorldCount = 0).

	"open the guy"
	morph openInWorld.
	self assert: (m1 intoWorldCount = 1).
	self assert: (m1 outOfWorldCount = 0).
	self assert: (m2 intoWorldCount = 1).
	self assert: (m2 outOfWorldCount = 0).

	"collapse it"
	collapsed := 	CollapsedMorph new beReplacementFor: morph.
	self assert: (m1 intoWorldCount = 1).
	self assert: (m1 outOfWorldCount = 1).
	self assert: (m2 intoWorldCount = 1).
	self assert: (m2 outOfWorldCount = 1).

	"expand it"
	collapsed collapseOrExpand.
	self assert: (m1 intoWorldCount = 2).
	self assert: (m1 outOfWorldCount = 1).
	self assert: (m2 intoWorldCount = 2).
	self assert: (m2 outOfWorldCount = 1).

	"delete it"
	morph delete.
	self assert: (m1 intoWorldCount = 2).
	self assert: (m1 outOfWorldCount = 2).
	self assert: (m2 intoWorldCount = 2).
	self assert: (m2 outOfWorldCount = 2).
!

----- Method: MorphTest>>testIntoWorldDeleteOutOfWorld (in category 'testing - into/outOf World') -----
testIntoWorldDeleteOutOfWorld
	| m1 m2 |
	"Create the guys"
	m1 := TestInWorldMorph new.
	m2 := TestInWorldMorph new.
	self assert: (m1 intoWorldCount = 0).
	self assert: (m1 outOfWorldCount = 0).
	self assert: (m2 intoWorldCount = 0).
	self assert: (m2 outOfWorldCount = 0).

	morph addMorphFront: m1.
	m1 addMorphFront:  m2.
	self assert: (m1 intoWorldCount = 0).
	self assert: (m1 outOfWorldCount = 0).
	self assert: (m2 intoWorldCount = 0).
	self assert: (m2 outOfWorldCount = 0).

	morph openInWorld.
	self assert: (m1 intoWorldCount = 1).
	self assert: (m1 outOfWorldCount = 0).
	self assert: (m2 intoWorldCount = 1).
	self assert: (m2 outOfWorldCount = 0).

	morph delete.
	self assert: (m1 intoWorldCount = 1).
	self assert: (m1 outOfWorldCount = 1).
	self assert: (m2 intoWorldCount = 1).
	self assert: (m2 outOfWorldCount = 1).
	!

----- Method: MorphTest>>testIntoWorldTransferToNewGuy (in category 'testing - into/outOf World') -----
testIntoWorldTransferToNewGuy
	| m1 m2 |
	"Create the guys"
	m1 := TestInWorldMorph new.
	m2 := TestInWorldMorph new.
	self assert: (m1 intoWorldCount = 0).
	self assert: (m1 outOfWorldCount = 0).
	self assert: (m2 intoWorldCount = 0).
	self assert: (m2 outOfWorldCount = 0).

	morph addMorphFront: m1.
	m1 addMorphFront:  m2.
	self assert: (m1 intoWorldCount = 0).
	self assert: (m1 outOfWorldCount = 0).
	self assert: (m2 intoWorldCount = 0).
	self assert: (m2 outOfWorldCount = 0).

	morph openInWorld.
	self assert: (m1 intoWorldCount = 1).
	self assert: (m1 outOfWorldCount = 0).
	self assert: (m2 intoWorldCount = 1).
	self assert: (m2 outOfWorldCount = 0).

	morph addMorphFront: m2.
	self assert: (m1 intoWorldCount = 1).
	self assert: (m1 outOfWorldCount = 0).
	self assert: (m2 intoWorldCount = 1).
	self assert: (m2 outOfWorldCount = 0).

	morph addMorphFront: m1.
	self assert: (m1 intoWorldCount = 1).
	self assert: (m1 outOfWorldCount = 0).
	self assert: (m2 intoWorldCount = 1).
	self assert: (m2 outOfWorldCount = 0).

	m2 addMorphFront: m1.
	self assert: (m1 intoWorldCount = 1).
	self assert: (m1 outOfWorldCount = 0).
	self assert: (m2 intoWorldCount = 1).
	self assert: (m2 outOfWorldCount = 0).

	morph delete.
	self assert: (m1 intoWorldCount = 1).
	self assert: (m1 outOfWorldCount = 1).
	self assert: (m2 intoWorldCount = 1).
	self assert: (m2 outOfWorldCount = 1).
!

----- Method: MorphTest>>testIsMorph (in category 'testing - classification') -----
testIsMorph
	self assert: (morph isMorph).!

----- Method: MorphTest>>testOpenInWorld (in category 'testing - initialization') -----
testOpenInWorld
	self shouldnt: [morph openInWorld] raise: Error.!

----- Method: MorphTest>>testOverlapAny (in category 'testing - etoys') -----
testOverlapAny
	"self debug: #testOverlapAny"
	| p1 p2 |
	p1 := Morph new assuredPlayer.
	p2 := EllipseMorph new assuredPlayer.
	"Same position"
	p1 costume position: 0 at 0.
	p2 costume position: 0 at 0.
	self assert: (p1 overlapsAny: p2).
	"Different position"
	p1 costume position: 0 at 0.
	p2 costume position: 500 at 0.
	self assert: (p1 overlapsAny: p2) not.!

----- Method: MorphTest>>testOverlapAnyDeletedPlayer (in category 'testing - etoys') -----
testOverlapAnyDeletedPlayer
	"self debug: #testOverlapAnyDeletedPlayer"
	| me friend sibling |
	me := Morph new assuredPlayer assureUniClass; yourself.
	friend := EllipseMorph new assuredPlayer assureUniClass; yourself.
	sibling := friend getNewClone.
	sibling costume delete.
	self getWorld addMorph: me costume.
	"Same position but deleted"
	me costume position: 0 @ 0.
	friend costume position: 0 @ 0.
	sibling costume position: 0 @ 0.
	self assert: (me overlapsAny: friend) not.
	self assert: (me overlapsAny: sibling) not!

----- Method: MorphTest>>testOverlapAnyScriptedPlayer (in category 'testing - etoys') -----
testOverlapAnyScriptedPlayer
	"self debug: #testOverlapAnyScriptedPlayer"
	| me friend other sibling |
	me := Morph new assuredPlayer assureUniClass; yourself.
	friend := EllipseMorph new assuredPlayer assureUniClass; yourself.
	sibling := friend getNewClone.
	other := EllipseMorph new assuredPlayer assureUniClass; yourself.
	self getWorld addMorph: me costume;
		 addMorph: friend costume;
		 addMorph: other costume;
		 addMorph: sibling costume.
	"myself"
	self assert: (me overlapsAny: me) not.
	"Same position with sibling"
	me costume position: 0 @ 0.
	friend costume position: 500 @ 0.
	other costume position: 500 @ 0.
	sibling costume position: 0 at 0.
	self assert: (me overlapsAny: friend).
	"Different position with sibling but same class"
	me costume position: 0 @ 0.
	friend costume position: 500 @ 0.
	sibling costume position: 500@ 0.
	other costume position: 0 @ 0.
	self assert: (me overlapsAny: friend) not!

----- Method: MorphTest>>testOverlapAnyUnscriptedPlayer (in category 'testing - etoys') -----
testOverlapAnyUnscriptedPlayer
	"self debug: #testOverlapAnyUnscriptedPlayer"
	| p1 p2 p3 |
	p1 := Morph new assuredPlayer.
	p2 := EllipseMorph new assuredPlayer.
	p3 := EllipseMorph new assuredPlayer.
	self getWorld addMorph: p1 costume;
		 addMorph: p2 costume;
		 addMorph: p3 costume.
	"Same class, same position"
	p1 costume position: 0 @ 0.
	p2 costume position: 500 @ 0.
	p3 costume position: 0 @ 0.
	self
		assert: (p1 overlapsAny: p2).
	"Same class, different position"
	p1 costume position: 0 @ 0.
	p2 costume position: 1000 @ 0.
	p3 costume position: 500 @ 0.
	self assert: (p1 overlapsAny: p2) not.
!

TestCase subclass: #TileMorphTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicTests-Basic'!

----- Method: TileMorphTest>>testArrowAction (in category 'testing') -----
testArrowAction
	"self debug: #testArrowAction"
	| dummy tile |
	dummy := Morph new.
	tile := TileMorph new setOperator: '+'.
	dummy addMorph: tile.
	tile arrowAction: 1.
	self assert: tile codeString = '-'.

	tile := TileMorph new setOperator: '<'.
	dummy addMorph: tile.
	tile arrowAction: 1.
	"Because receiver is not tile"
	self assert: tile codeString = '='.

	tile := true newTileMorphRepresentative.
	dummy addMorph: tile.
	tile arrowAction: 1.
	self assert: tile codeString = '(false)'.
!

----- Method: TileMorphTest>>testAssignmentTile (in category 'testing') -----
testAssignmentTile
	"self debug: #testAssignmentTile"

	| player viewer tile phrase |
	player := Morph new assuredPlayer.
	viewer := CategoryViewer new invisiblySetPlayer: player.
	viewer  makeSetter: #(#getX #Number) event: nil from: player costume.
	phrase := ActiveHand firstSubmorph.
	ActiveHand removeAllMorphs.
	tile := phrase submorphs second.

	self assert: tile codeString = 'setX: '.
	tile arrowAction: 1.
	self assert: tile codeString = 'setX: self getX + '.

!

----- Method: TileMorphTest>>testSoundTile (in category 'testing') -----
testSoundTile
	"self debug: #testSoundTile"
	| tile dummy |
	dummy := Morph new.
	tile := SoundTile new literal: 'croak'.
	dummy addMorph: tile.
	tile arrowAction: 1.
	self assert: tile codeString = '(''horn'')'.

	!

ClassTestCase subclass: #PasteUpMorphTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicTests-Worlds'!

!PasteUpMorphTest commentStamp: '<historical>' prior: 0!
I am a TestCase for PasteUpMorph.!

----- Method: PasteUpMorphTest>>testCursorWrapped (in category 'tests') -----
testCursorWrapped
	"self debug: #testCursorWrapped"
	| holder |
	holder := PasteUpMorph new.
	self assert: holder cursor = 1.
	holder cursorWrapped: 2.
	self assert: holder cursor = 1.
	holder addMorph: Morph new;
		 addMorph: Morph new;
		 addMorph: Morph new.
	holder cursorWrapped: 3.
	self assert: holder cursor = 3.
	holder cursorWrapped: 5.
	self assert: holder cursor = 2.
	holder cursorWrapped: 0.
	self assert: holder cursor = 3.
	holder cursorWrapped: -1.
	self assert: holder cursor = 2.!

----- Method: PasteUpMorphTest>>testCursorWrappedWithFraction (in category 'tests') -----
testCursorWrappedWithFraction
	"self debug: #testCursorWrappedWithFraction"
	| holder |
	holder := PasteUpMorph new.
	holder addMorph: Morph new;
		 addMorph: Morph new;
		 addMorph: Morph new.
	holder cursorWrapped: 3.5.
	self assert: holder cursor = 3.5.
	holder cursorWrapped: 5.5.
	self assert: holder cursor = 2.5.
	holder cursorWrapped: 0.5.
	self assert: holder cursor = 3.5.
	holder cursorWrapped: -0.5.
	self assert: holder cursor = 2.5.!

----- Method: PasteUpMorphTest>>testGridToGradient (in category 'tests') -----
testGridToGradient
	"A trivial test for checking that you can change from a grid to a  
	gradient background. A recent [FIX] will make this pass."
	| pum |
	pum := PasteUpMorph new.
	pum setStandardTexture.
	"The following should fail without the fix"
	self
		shouldnt: [pum gradientFillColor: Color red]
		raise: MessageNotUnderstood!

----- Method: PasteUpMorphTest>>testPlayWithMe1Romoval (in category 'tests') -----
testPlayWithMe1Romoval
	"A trivial test for checking that PlayWithMe classes are all removed"
	self deny: ( Smalltalk hasClassNamed: 'PlayWithMe1' ) .!

ClassTestCase subclass: #SimpleSwitchMorphTest
	instanceVariableNames: 'testSwitch'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicTests-Widgets'!

!SimpleSwitchMorphTest commentStamp: '<historical>' prior: 0!
I test the behavior of SimpleSwitchMorph!

----- Method: SimpleSwitchMorphTest>>classToBeTested (in category 'as yet unclassified') -----
classToBeTested
	^ SimpleSwitchMorph !

----- Method: SimpleSwitchMorphTest>>setUp (in category 'as yet unclassified') -----
setUp
	super setUp.
	testSwitch := SimpleSwitchMorph new!

----- Method: SimpleSwitchMorphTest>>testName (in category 'as yet unclassified') -----
testName

	self assert: testSwitch externalName = 'SimpleSwitch'!

----- Method: SimpleSwitchMorphTest>>testState (in category 'as yet unclassified') -----
testState
	self assert: testSwitch isOff.
	self deny: testSwitch isOn.
	testSwitch toggleState.
	self assert: testSwitch isOn.
	self deny: testSwitch isOff!

----- Method: SimpleSwitchMorphTest>>testSwitching (in category 'as yet unclassified') -----
testSwitching

	testSwitch setSwitchState: false.
	self assert: testSwitch isOff.
	self assert: testSwitch color = testSwitch offColor.
	testSwitch setSwitchState: true.
	self assert: testSwitch isOn.
	self assert: testSwitch color = testSwitch onColor.!

ClassTestCase subclass: #TextMorphTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicTests-Basic'!

----- Method: TextMorphTest>>testInitialize (in category 'testing') -----
testInitialize
	"For now, just make sure initialization doesn't throw exception"

	self shouldnt: [TextMorph initialize] raise: Error.!