[squeak-dev] The Inbox: MorphicTests-rkrk.11.mcz

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@100.
        canvas fillColor: Color black.
        smallRect := 0@0 corner: 20@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@100.
        canvas fillColor: Color black.
        smallRect := 0@0 corner: 20@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@0.
        p2 costume position: 0@0.
        self assert: (p1 overlapsAny: p2).
        "Different position"
        p1 costume position: 0@0.
        p2 costume position: 500@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@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.!