Squeak 4.5: MorphicTests-nice.24.mcz

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@111) clipRect = (0@0 corner: 222@111).
        self assert: (FormCanvas extent: 2222@11) clipRect = (0@0 corner: 2222@11).
        self assert: (FormCanvas extent: 22222@1) clipRect = (0@0 corner: 22222@1).
!

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

        | fill canvas smallRect |
        fill := GradientFillStyle sample.
        canvas := FormCanvas extent: 100@100.
        canvas fillColor: Color black.
        smallRect := 0@0 corner: 20@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@100.
        canvas fillColor: Color black.
        smallRect := 0@0 corner: 20@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@10 corner: 150@70).
        self assert: (60@20 corner: 140@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@10 corner: 150@70).
        self assert: (60@20 corner: 110@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@10 corner: 150@70).
        self assert: (101@41 corner: 148@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@10 corner: 150@70).
        self assert: (50@10 corner: 150@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@0. 100@0. 0@100}
                color: Color red borderWidth: 0 borderColor: Color transparent)
                        color: Color red.

        submorph bounds. "0@0 corner: 100@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@0 corner: 100@100 NOT YET UPDATED"
        aMorph fullBounds. "0@0 corner: 50@40. CORRECT"
        submorph bounds. "5@4 corner: 45@36 NOW UPDATED OK"

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

        self assert: aMorph fullBounds = (0 @ 0 extent: 100@100).
        self assert: submorph bounds = (10 @ 10 corner: 90@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.
!