[squeak-dev] Squeak 4.5: MorphicTests-nice.24.mcz

commits at source.squeak.org commits at source.squeak.org
Fri Jan 24 20:29:46 UTC 2014


Chris Muller uploaded a new version of MorphicTests to project Squeak 4.5:
http://source.squeak.org/squeak45/MorphicTests-nice.24.mcz

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

Name: MorphicTests-nice.24
Author: nice
Time: 16 December 2013, 5:25:47.407 pm
UUID: e33a9ad3-2f39-4c19-a3a7-dc87f18177fc
Ancestors: MorphicTests-fbs.23

MorphicToolBuilderTests as other kind of TestCase should go in MorphicTests

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

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

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!

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

----- Method: TextAnchorTest>>testBeginWithAnAnchor (in category 'initialize-release') -----
testBeginWithAnAnchor
	| text morph model |
	text := Text streamContents:
		[ : stream | stream
			 nextPutAll:
			(Text
				string: (String value: 1)
				attributes: {TextAnchor new anchoredMorph: Morph new. 
					TextColor color: Color transparent}) ;
			 nextPutAll: ' should be able to begin with an embedded object. ' ].
	model := text -> nil.
	morph := PluggableTextMorph
		on: model
		text: #key
		accept: nil.
	[ morph openInWorld ] ensure: [ morph delete ]!

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

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: #CircleMorphBugs
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicTests-Basic'!

----- Method: CircleMorphBugs>>testCircleInstance (in category 'as yet unclassified') -----
testCircleInstance
""
"self run: #testCircleInstance" 

| circ |
self assert: (circ := CircleMorph initializedInstance) extent = circ extent x asPoint

!

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

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

	self assert: (FormCanvas extent: 222 at 111) clipRect = (0 at 0 corner: 222 at 111).
	self assert: (FormCanvas extent: 2222 at 11) clipRect = (0 at 0 corner: 2222 at 11).
	self assert: (FormCanvas extent: 22222 at 1) clipRect = (0 at 0 corner: 22222 at 1).
!

----- 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.
	
	"This should not throw an exception."
	canvas
		frameAndFillRoundRect: smallRect
		radius: smallRect width / 2 + 1
		fillStyle: fill
		borderWidth: 0
		borderColor: Color lightGray.!

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

	"This should not throw an exception."
	canvas
		frameAndFillRoundRect: smallRect
		radius: 0
		fillStyle: fill
		borderWidth: 0
		borderColor: Color lightGray.!

TestCase subclass: #LayoutFrameTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicTests-Layouts'!

----- Method: LayoutFrameTest>>testInset (in category 'as yet unclassified') -----
testInset
	| lf rectangle |
	lf := LayoutFrame new
		leftFraction: 0 offset: 10;
		topFraction: 0 offset: 10;
		rightFraction: 1 offset: -10;
		bottomFraction: 1 offset: -10;
		yourself.
	rectangle := lf layout: nil in: (50 at 10 corner: 150 at 70).
	self assert: (60 at 20 corner: 140 at 60) = rectangle!

----- Method: LayoutFrameTest>>testLeftTopAligned (in category 'as yet unclassified') -----
testLeftTopAligned
	| lf rectangle |
	lf := LayoutFrame new
		leftFraction: 0 offset: 10;
		topFraction: 0 offset: 10;
		rightFraction: 0 offset: 60;
		bottomFraction: 0 offset: 25;
		yourself.
	rectangle := lf layout: nil in: (50 at 10 corner: 150 at 70).
	self assert: (60 at 20 corner: 110 at 35) = rectangle!

----- Method: LayoutFrameTest>>testRightBottomQuadrant (in category 'as yet unclassified') -----
testRightBottomQuadrant
	| lf rectangle |
	lf := LayoutFrame new
		leftFraction: 1/2 offset: 1;
		topFraction: 1/2 offset: 1;
		rightFraction: 1 offset: -2;
		bottomFraction: 1 offset: -2;
		yourself.
	rectangle := lf layout: nil in: (50 at 10 corner: 150 at 70).
	self assert: (101 at 41 corner: 148 at 68) = rectangle!

----- Method: LayoutFrameTest>>testSpaceFill (in category 'as yet unclassified') -----
testSpaceFill
	| lf rectangle |
	lf := LayoutFrame new
		leftFraction: 0 offset: 0;
		topFraction: 0 offset: 0;
		rightFraction: 1 offset: 0;
		bottomFraction: 1 offset: 0;
		yourself.
	rectangle := lf layout: nil in: (50 at 10 corner: 150 at 70).
	self assert: (50 at 10 corner: 150 at 70) = rectangle!

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: #MorphBugs
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicTests-Basic'!

----- Method: MorphBugs>>adhereToEdgeTest (in category 'as yet unclassified') -----
adhereToEdgeTest
	"self new adhereToEdgeTest"
	"self run: #adhereToEdgeTest"

	| r |
	r := RectangleMorph new openInWorld .

	"This should not throw an exception."
	[ r adhereToEdge: #eternity ] ensure: [ r delete ].
	r delete .

^true !

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
	"This should not throw an exception."
	morph openInWorld.!

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

!PolygonMorphTest commentStamp: 'nice 2/16/2008 02:13' prior: 0!
This class holds tests for PolygonMorph!

----- Method: PolygonMorphTest>>testBoundsBug1035 (in category 'bounds') -----
testBoundsBug1035
	"This is a non regression test for http://bugs.squeak.org/view.php?id=1035
	PolygonMorph used to position badly when container bounds were growing"
	
	| submorph aMorph |
	
	submorph := (PolygonMorph
		vertices: {0 at 0. 100 at 0. 0 at 100}
		color: Color red borderWidth: 0 borderColor: Color transparent)
			color: Color red.

	submorph bounds. "0 at 0 corner: 100 at 100"

	aMorph := Morph new
		color: Color blue;
		layoutPolicy: ProportionalLayout new;
		addMorph: submorph
		fullFrame: (LayoutFrame fractions: (0.1 @ 0.1 corner: 0.9 @ 0.9)).

	submorph bounds. "0 at 0 corner: 100 at 100 NOT YET UPDATED"
	aMorph fullBounds. "0 at 0 corner: 50 at 40. CORRECT"
	submorph bounds. "5 at 4 corner: 45 at 36 NOW UPDATED OK"

	aMorph extent: 100 at 100.
	submorph bounds. "5 at 4 corner: 45 at 36 NOT YET UPDATED"
	aMorph fullBounds. "-10 at -14 corner: 100 at 100 WRONG"
	submorph bounds. "-10 at -14 corner: 70 at 66 NOW WRONG POSITION (BUT RIGHT EXTENT)"

	self assert: aMorph fullBounds = (0 @ 0 extent: 100 at 100).
	self assert: submorph bounds = (10 @ 10 corner: 90 at 90).
!

TestCase subclass: #MorphicUIManagerTest
	instanceVariableNames: 'cases'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicTests-ToolBuilder'!

!MorphicUIManagerTest commentStamp: 'wiz 1/3/2007 13:57' prior: 0!
A MorphicUIBugTest is a class for testing the shortcomings and repairs of the MorphicUI manager.
.

Instance Variables
	cases:		<aCollection>

cases
	- a list of morphs that may need to be deleted during teardown.
	the tests are expected to fill this list it starts out empty by default.
	
	
!

----- Method: MorphicUIManagerTest>>defaultTimeout (in category 'as yet unclassified') -----
defaultTimeout
	^ 60 "seconds"!

----- Method: MorphicUIManagerTest>>findWindowInWorldLabeled: (in category 'as yet unclassified') -----
findWindowInWorldLabeled: aLabel

	^World submorphs
		detect: [ :each |
			(each isKindOf: SystemWindow)
				and: [ each label = aLabel ] ]
		ifNone: nil.!

----- Method: MorphicUIManagerTest>>setUp (in category 'as yet unclassified') -----
setUp
"default. tests will add morphs to list. Teardown will delete."

cases := #() .!

----- Method: MorphicUIManagerTest>>tearDown (in category 'as yet unclassified') -----
tearDown
"default. tests will add morphs to list. Teardown will delete."

cases do: [ :each | each delete ] .!

----- Method: MorphicUIManagerTest>>testOpenWorkspace (in category 'as yet unclassified') -----
testOpenWorkspace
	"self new testOpenWorkspace"
	"MorphicUIBugTest run: #testOpenWorkspace"
	
	| window myLabel foundWindow myModel |
	self assert: Smalltalk isMorphic.
	myLabel := 'Workspace from SUnit test' .
	foundWindow := self findWindowInWorldLabeled: myLabel .
	self assert: foundWindow isNil.
	window := UIManager default edit: '"MorphicUIBugTest run: #openWorkspaceTest"'  label: myLabel.
	window := window.
	foundWindow := self findWindowInWorldLabeled: myLabel.
	cases := Array with: foundWindow . "For teardown."
	myModel := foundWindow submorphs detect: #isMorphicModel.
	self assert: myModel model class == Workspace.
	self assert: foundWindow model class == Workspace.
	foundWindow delete!

----- Method: MorphicUIManagerTest>>testOpenWorkspaceAns (in category 'as yet unclassified') -----
testOpenWorkspaceAns
"Test if method opening a workspace answers the window opened"

"MorphicUIBugTest run: #testOpenWorkspaceAns"


| window myLabel foundWindow |

self assert: ( Smalltalk isMorphic ) .

myLabel := 'Workspace from ', 'SUnit test' .
foundWindow := self findWindowInWorldLabeled: myLabel .
self assert: ( foundWindow isNil ) .

window := 
UIManager default edit: '"MorphicUIBugTest run: #openWorkspaceTest"'  label: myLabel .

foundWindow := self findWindowInWorldLabeled: myLabel .

cases := Array with: foundWindow . "For teardown."

self assert: ( window == foundWindow ) .

foundWindow delete .!

----- Method: MorphicUIManagerTest>>testShowAllBinParts (in category 'as yet unclassified') -----
testShowAllBinParts
	"self new testShowAllBinParts"
	"MorphicUIBugTest run: #testShowAllBinParts"

	self assert: Smalltalk isMorphic.
	"This should not throw an exception."
	cases := Array with: ObjectsTool  initializedInstance showAll openCenteredInWorld!

----- Method: MorphicUIManagerTest>>testUIManagerNoAcceptInitially (in category 'as yet unclassified') -----
testUIManagerNoAcceptInitially
	"Ensure that UIManager does not invoke the accept: action initially."

	| accepted window |
	accepted := false.
	window := UIManager default edit: Text new label: 'Test' accept: [:val| accepted := true].
	window delete.
	self deny: accepted.!

MorphicUIManagerTest subclass: #StickynessBugz
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicTests-Basic'!

!StickynessBugz commentStamp: 'wiz 11/24/2006 00:24' prior: 0!
A StickynessBugz is for mantis #5500 rectangles and ellipses don't act sticky when rotated even when they are..

Instance Variables
!

----- Method: StickynessBugz>>testForTiltedStickyness (in category 'as yet unclassified') -----
testForTiltedStickyness
"self new testForTiltedStickyness"
"self run: #testForTiltedStickyness"


| m |
m := RectangleMorph new openCenteredInWorld .

cases := Array with: m . "save for tear down."

self assert: ( m topRendererOrSelf isSticky not ) .

m beSticky .

self assert: ( m topRendererOrSelf isSticky ) .

m addFlexShell .

cases := Array with: m topRendererOrSelf .

m topRendererOrSelf rotationDegrees: 45.0 .

self assert: ( m topRendererOrSelf isSticky ) .

m beUnsticky .

self assert: ( m topRendererOrSelf isSticky not ) .

m topRendererOrSelf delete.
^true 






!

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

!RenderBugz commentStamp: 'fbs 5/8/2013 12:27' prior: 0!
A RenderBugz is an infinite recursion bug test for TransformationMorphs.

In 3.9 (7067) and before, when TransformationMorph has no rendee there are several methods that will infinitely recurse until manually stopped or the image runs out of memory.

So far the ones I've caught are the getters and setters for heading and forwardDirection.

So there  are tests for them here.

Ideally there would be a way to run a test against a stopwatch to catch endless recursion.
Found it. Now incorperated. And the tests should be both save to run and cleanup after themselves even when they fail. 

So far we have not tested the normal cases of rendering working. 
I will leave that as a separate task for another time. 

So this is an automatic test when the bugs are fixed and interactive (crash) tests when the bugs are present.

Instance Variables


Revision notes. wiz 5/15/2008 22:58

When running tests from the TestRunner browser the test would sporadically fail.
When they failed a transfomation morph would be left on the screen and not removed by the 
ensureBlock. 

So I changed things to fall under MorphicUIBugTests because that had a cleanup mechansizm for left over morphs.

I also added one routine to test for time and one parameter to determine the time limit.
To my surprise doubling or tripling the time limit still produced sporadic errors when the test is run repeatedly enough ( I am using a 400mz iMac. )  So now the parameter is set to 4. Things will probably fail there if tried long enough. At that point try 5 etc. 

I am reluctant to make the number larger than necessary. The tighter the test the more you know what is working.

I also added a dummy test to check specifically for the timing bug. It fails on the same sporadic basis as the other test went the time parameter is short enough. This lends confidence to the theory that the timing difficulty is coming from outside the test. The sunit runner puts up a progress morph for each test. So the morphic display stuff is busy and probably also the GC.

Revision notes. fbs 05/08/2013 12:26 UTC

Copied MorphicUIBugTest's setUp/tearDown here because these tests have nothing to do with the MorphicUIManager tests.!

----- Method: RenderBugz>>long (in category 'utility') -----
long
"return time limit in milliseconds for tests"
^4!

----- Method: RenderBugz>>setUp (in category 'running') -----
setUp
	"default. tests will add morphs to list. Teardown will delete."
	cases := #().!

----- Method: RenderBugz>>shouldntTakeLong: (in category 'utility') -----
shouldntTakeLong: aBlock
"Check for infinite recursion. Test should finish in a reasonable time."

^self should:  aBlock  
		notTakeMoreThanMilliseconds: self long .
!

----- Method: RenderBugz>>tearDown (in category 'running') -----
tearDown
	"default. tests will add morphs to list. Teardown will delete."
	cases do: [ :each | each delete ].!

----- Method: RenderBugz>>testForward (in category 'tests') -----
testForward
"If the bug exist there will be an infinte recursion."
"self new testForward"
"self run: #testForward"

| t |
cases := {
t := TransformationMorph new openCenteredInWorld } .

 self shouldntTakeLong: [self assert: ( t forwardDirection = 0.0 ) ]  .

^true  
!

----- Method: RenderBugz>>testHeading (in category 'tests') -----
testHeading
"If the bug exist there will be an infinte recursion."
"self new testHeading"
"self run: #testHeading"

| t |
cases := {
t := TransformationMorph new openCenteredInWorld } .

 self shouldntTakeLong: [ [self assert: ( t heading = 0.0 ) ] 
				ensure: [ t delete ] ]  .

^true  
!

----- Method: RenderBugz>>testSetForward (in category 'tests') -----
testSetForward
"If the bug exist there will be an infinte reccursion."
"self new testSetForward"
"self run: #testSetForward"

| t |
cases := {
t := TransformationMorph new openCenteredInWorld } .

 self 	shouldntTakeLong: [ t forwardDirection: 180.0 . 
					self assert: ( t forwardDirection = 0.0 )  ]  .

"and without a rendee it should not change things."

^true  
!

----- Method: RenderBugz>>testSetHeading (in category 'tests') -----
testSetHeading
"If the bug exist there will be an infinte recursion."
"self new testSetHeading"
"self run: #testSetHeading"

| t |
cases := {
t := TransformationMorph new openCenteredInWorld } .

 self shouldntTakeLong: [ t heading:  180 .
					 self assert: ( t heading = 0.0 ) .]  .

^true  
!

----- Method: RenderBugz>>testTestTime (in category 'tests') -----
testTestTime
"This is a control case. Should always pass. 
If it does not something external to the tests are slowing things down 
past the 1 millisecond mark."

"self new testTestTime"
"self run: #testTestTime"

| t |

cases := {
t := TransformationMorph new openCenteredInWorld } .

 self shouldntTakeLong: [ self assert: ( true )  ]  .
^true  
!

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

----- Method: UnimplementedCallBugz>>testPolyIntersect (in category 'as yet unclassified') -----
testPolyIntersect
	"self run: #testPolyIntersect"
	"This should not throw an exception."
	PolygonMorph initializedInstance 
		intersects: ( Rectangle
			center: Display center 
			extent: 100 asPoint ).!

ToolBuilderTests subclass: #MorphicToolBuilderTests
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicTests-ToolBuilder'!

!MorphicToolBuilderTests commentStamp: 'ar 2/11/2005 15:02' prior: 0!
Tests for the Morphic tool builder.!

----- Method: MorphicToolBuilderTests>>acceptWidgetText (in category 'support') -----
acceptWidgetText
	widget hasUnacceptedEdits: true.
	widget accept.!

----- Method: MorphicToolBuilderTests>>buttonWidgetEnabled (in category 'support') -----
buttonWidgetEnabled
	"Answer whether the current widget (a button) is currently enabled"
	^widget enabled!

----- Method: MorphicToolBuilderTests>>changeListWidget (in category 'support') -----
changeListWidget
	widget changeModelSelection: widget getCurrentSelectionIndex + 1.!

----- Method: MorphicToolBuilderTests>>expectedButtonSideEffects (in category 'support') -----
expectedButtonSideEffects
	^#(getColor getState getEnabled)!

----- Method: MorphicToolBuilderTests>>fireButtonWidget (in category 'support') -----
fireButtonWidget
	widget performAction.!

----- Method: MorphicToolBuilderTests>>fireMenuItemWidget (in category 'support') -----
fireMenuItemWidget
	(widget itemWithWording: 'Menu Item')
		ifNotNil: [:item | item doButtonAction]!

----- Method: MorphicToolBuilderTests>>setUp (in category 'support') -----
setUp
	super setUp.
	builder := MorphicToolBuilder new.!

----- Method: MorphicToolBuilderTests>>testWindowDynamicLabel (in category 'tests-window') -----
testWindowDynamicLabel
	self makeWindow.
	self assert: (widget label = 'TestLabel').!

----- Method: MorphicToolBuilderTests>>testWindowStaticLabel (in category 'tests-window') -----
testWindowStaticLabel
	| spec |
	spec := builder pluggableWindowSpec new.
	spec model: self.
	spec children: #().
	spec label: 'TestLabel'.
	widget := builder build: spec.
	self assert: (widget label = 'TestLabel').!

----- Method: MorphicToolBuilderTests>>widgetColor (in category 'support') -----
widgetColor
	"Answer color from widget"
	^widget color!

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"
	TextMorph initialize.!

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

----- Method: WorldStateTest>>testDeferredUIQueueTimeout (in category 'tests') -----
testDeferredUIQueueTimeout
	"Ensure that the World's deferredUIMessage will take no more time than
	specified by WorldState's deferredExecutionTimeLimit"
	| firstWasRun secondWasRun thirdWasRun |
	firstWasRun := secondWasRun := thirdWasRun := false.
	WorldState addDeferredUIMessage:[
		firstWasRun := true.
		(Delay forMilliseconds: WorldState deferredExecutionTimeLimit + 50) wait.
	].
	WorldState addDeferredUIMessage:[
		secondWasRun := true.
	].
	WorldState addDeferredUIMessage:[
		thirdWasRun := true.
	].
	self deny: firstWasRun.
	self deny: secondWasRun.
	self deny: thirdWasRun.
	World doOneCycleNow.
	self assert: firstWasRun.
	self deny: secondWasRun.
	self deny: thirdWasRun.
	World doOneCycleNow.
	self assert: firstWasRun.
	self assert: secondWasRun.
	self assert: thirdWasRun.
!



More information about the Squeak-dev mailing list