Squeak 4.6: MorphicTests-mt.31.mcz

Chris Muller uploaded a new version of MorphicTests to project Squeak 4.6:
http://source.squeak.org/squeak46/MorphicTests-mt.31.mcz

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

Name: MorphicTests-mt.31
Author: mt
Time: 19 May 2015, 4:17:55.16 pm
UUID: 60717262-4e28-a549-a8a2-6918f0a28581
Ancestors: MorphicTests-mt.30

Tests added for scroll panes.

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

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

ValueHolder subclass: #MorphicTestTextModel
        instanceVariableNames: 'flags result'
        classVariableNames: ''
        poolDictionaries: ''
        category: 'MorphicTests-Text Support'!

----- Method: MorphicTestTextModel>>debugExpression: (in category 'do-its general') -----
debugExpression: anExpression

        self flags add: #expressionDebugged.
        self result: (Compiler evaluate: anExpression).!

----- Method: MorphicTestTextModel>>doItContext (in category 'do-its support') -----
doItContext

        self flags add: #doItContext.
        ^ nil!

----- Method: MorphicTestTextModel>>doItReceiver (in category 'do-its support') -----
doItReceiver

        self flags add: #doItReceiver.
        ^ self result!

----- Method: MorphicTestTextModel>>exploreIt:result: (in category 'do-its') -----
exploreIt: expression result: object

        self flags add: #explored.
        self result: object.!

----- Method: MorphicTestTextModel>>expressionEvaluated:result: (in category 'do-its general') -----
expressionEvaluated: anExpression result: anObject

        self flags add: #expressionEvaluated.
        self result: anObject.!

----- Method: MorphicTestTextModel>>flags (in category 'as yet unclassified') -----
flags

        ^ flags ifNil: [flags := Bag new]!

----- Method: MorphicTestTextModel>>hasFlag: (in category 'as yet unclassified') -----
hasFlag: aSymbol

        ^ self flags includes: aSymbol!

----- Method: MorphicTestTextModel>>inspectIt:result: (in category 'do-its') -----
inspectIt: expression result: object

        self flags add: #inspected.
        self result: object.!

----- Method: MorphicTestTextModel>>printIt:result: (in category 'do-its') -----
printIt: expression result: object

        self flags add: #printed.
        self result: object printString.!

----- Method: MorphicTestTextModel>>result (in category 'as yet unclassified') -----
result

        ^ result!

----- Method: MorphicTestTextModel>>result: (in category 'as yet unclassified') -----
result: anObject

        result := anObject.!

MorphicTestTextModel subclass: #MorphicTestTextModelWithEvaluationSupport
        instanceVariableNames: ''
        classVariableNames: ''
        poolDictionaries: ''
        category: 'MorphicTests-Text Support'!

----- Method: MorphicTestTextModelWithEvaluationSupport>>evaluateExpression: (in category 'do-its general') -----
evaluateExpression: anExpression

        self flags add: #expressionEvaluated.
        self result: (Compiler evaluate: anExpression asString).
        ^ self result!

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

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!

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

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

----- Method: MorphBugs>>testAdhereToEdgeEternity (in category 'tests') -----
testAdhereToEdgeEternity

        | r |
        r := RectangleMorph new openInWorld: self getWorld.

        self
                shouldnt: [ r adhereToEdge: #eternity ]
                raise: Exception.!

----- Method: MorphTest>>createAndAddMorphs: (in category 'support') -----
createAndAddMorphs: someNames

        (self createMorphs: #(a b)) do: [:newMorph |
                morph addMorphBack: newMorph].!

----- Method: MorphTest>>createMorphs: (in category 'support') -----
createMorphs: someNames

        ^ someNames collect: [:nm | Morph new name: nm]!

----- Method: MorphTest>>getSubmorph: (in category 'support') -----
getSubmorph: name

        ^ morph submorphs detect: [:m | m knownName = name]!

----- Method: MorphTest>>getSubmorphNames (in category 'support') -----
getSubmorphNames

        ^ morph submorphs collect: [:m | m knownName asSymbol]!

----- Method: MorphTest>>getSubmorphs: (in category 'support') -----
getSubmorphs: someNames

        ^ someNames collect: [:nm | self getSubmorph: nm]!

----- Method: MorphTest>>getWorld (in category 'initialize-release') -----
getWorld

        ^ world ifNil: [
                world := PasteUpMorph newWorldForProject: nil.
                world
                        viewBox: (0@0 extent: world extent);
                        yourself]!

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

----- Method: MorphTest>>tearDown (in category 'initialize-release') -----
tearDown

        morph delete.!

----- Method: MorphTest>>testAddAllMorphs (in category 'testing - add/remove submorphs') -----
testAddAllMorphs

        self createAndAddMorphs: #(a b).
        self assert: #(a b) equals: self getSubmorphNames.

        morph addAllMorphs: (self createMorphs: #(x y)).
        self assert: #(a b x y) equals: self getSubmorphNames.
       
        morph removeAllMorphs.
        morph addAllMorphs: (self createMorphs: #(x y)).
        self assert: #(x y) equals: self getSubmorphNames.!

----- Method: MorphTest>>testAddAllMorphsAfter (in category 'testing - add/remove submorphs') -----
testAddAllMorphsAfter

        self createAndAddMorphs: #(a b).
        self assert: #(a b) equals: self getSubmorphNames.

        morph
                addAllMorphs: (self createMorphs: #(x y))
                after: (self getSubmorph: #a).
        self assert: #(a x y b) equals: self getSubmorphNames.
       
        morph
                addAllMorphs: (self getSubmorphs: #(x y))
                after: (self getSubmorph: #b).
        self assert: #(a b x y) equals: self getSubmorphNames.

        morph
                addAllMorphs: (self getSubmorphs: #(a x))
                after: (self getSubmorph: #y).
        self assert: #(b y a x) equals: self getSubmorphNames.

        morph
                addAllMorphs: (self getSubmorphs: #(x y))
                after: (self getSubmorph: #a).
        self assert: #(b a x y) equals: self getSubmorphNames.!

----- Method: MorphTest>>testAddAllMorphsInFrontOf (in category 'testing - add/remove submorphs') -----
testAddAllMorphsInFrontOf

        self createAndAddMorphs: #(a b).
        self assert: #(a b) equals: self getSubmorphNames.

        morph
                addAllMorphs: (self createMorphs: #(x y))
                inFrontOf: (self getSubmorph: #b).
        self assert: #(a x y b) equals: self getSubmorphNames.
       
        morph
                addAllMorphs: (self getSubmorphs: #(x y))
                inFrontOf: (self getSubmorph: #a).
        self assert: #(x y a b) equals: self getSubmorphNames.

        morph
                addAllMorphs: (self getSubmorphs: #(y b))
                inFrontOf: (self getSubmorph: #x).
        self assert: #(y b x a) equals: self getSubmorphNames.

        morph
                addAllMorphs: (self getSubmorphs: #(x y))
                inFrontOf: (self getSubmorph: #b).
        self assert: #(x y b a) equals: self getSubmorphNames.!

----- 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
        "Look in the world and in the hand for windows. Yes, windows may spawn in the hand."
       
        ^ World submorphs, (World hands gather: [:hand | hand submorphs])
                detect: [ :each |
                        (each isKindOf: SystemWindow)
                                and: [ each label = aLabel ] ]
                ifNone: [].!

----- 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: #PluggableTextMorphTest
        instanceVariableNames: 'widget model'
        classVariableNames: ''
        poolDictionaries: ''
        category: 'MorphicTests-Widgets'!

----- Method: PluggableTextMorphTest>>setUp (in category 'running') -----
setUp

        super setUp.
       
        model := ValueHolder new contents: ''; yourself.
        widget := PluggableTextMorph on: model text: #contents accept: #contents:.!

----- Method: PluggableTextMorphTest>>test01TextChangeInModel (in category 'tests') -----
test01TextChangeInModel

        model contents: 'Hello, World!!'.
        self assert: model contents equals: widget text asString.!

----- Method: PluggableTextMorphTest>>test02TextChangeInWidget (in category 'tests') -----
test02TextChangeInWidget

        widget replaceSelectionWith: 'Hello, World!!'.
        self assert: '' equals: model contents.
       
        widget accept.
        self assert: widget text asString equals: model contents asString.!

----- Method: PluggableTextMorphTest>>test03TriggerAcceptFromModel (in category 'tests') -----
test03TriggerAcceptFromModel

        widget replaceSelectionWith: 'Hello, World!!'.
        self assert: widget hasUnacceptedEdits.
       
        model changed: #acceptChanges.
        self assert: widget text asString equals: model contents asString.!

----- Method: PluggableTextMorphTest>>test04TriggerAcceptFromWidget (in category 'tests') -----
test04TriggerAcceptFromWidget

        widget replaceSelectionWith: 'Hello, World!!'.
        self assert: widget hasUnacceptedEdits.
       
        widget accept.
        self assert: widget text asString equals: model contents asString.!

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: #ScrollPaneTest
        instanceVariableNames: 'sut content'
        classVariableNames: ''
        poolDictionaries: ''
        category: 'MorphicTests-Widgets'!

ScrollPaneTest subclass: #ScrollPaneLeftBarTest
        instanceVariableNames: ''
        classVariableNames: ''
        poolDictionaries: ''
        category: 'MorphicTests-Widgets'!

----- Method: ScrollPaneLeftBarTest class>>shouldInheritSelectors (in category 'testing') -----
shouldInheritSelectors

        ^ true!

----- Method: ScrollPaneLeftBarTest>>setUp (in category 'running') -----
setUp

        super setUp.
        sut scrollBarOnLeft: true.!

ScrollPaneTest subclass: #ScrollPaneRetractableBarsTest
        instanceVariableNames: ''
        classVariableNames: ''
        poolDictionaries: ''
        category: 'MorphicTests-Widgets'!

----- Method: ScrollPaneRetractableBarsTest class>>shouldInheritSelectors (in category 'testing') -----
shouldInheritSelectors

        ^ true!

----- Method: ScrollPaneRetractableBarsTest>>setUp (in category 'running') -----
setUp

        super setUp.
        sut retractable: true.!

----- Method: ScrollPaneRetractableBarsTest>>test01ScrollBarPolicyWhenNeeded (in category 'tests') -----
test01ScrollBarPolicyWhenNeeded

        sut
                hScrollBarPolicy: #whenNeeded;
                vScrollBarPolicy: #whenNeeded.
               
        content extent: 100@100.
        self refresh.
       
        self
                deny: sut hIsScrollbarShowing;
                deny: sut vIsScrollbarShowing.
               
        content extent: 150@150.
        self refresh.

        self
                deny: sut hIsScrollbarShowing;
                deny: sut vIsScrollbarShowing.!

----- Method: ScrollPaneRetractableBarsTest>>test02ScrollBarPolicyAlways (in category 'tests') -----
test02ScrollBarPolicyAlways

        sut
                hScrollBarPolicy: #always;
                vScrollBarPolicy: #always.
               
        content extent: 50@50.
        self refresh.
       
        self
                deny: sut hIsScrollbarShowing;
                deny: sut vIsScrollbarShowing.
               
        content extent: 150@150.
        self refresh.

        self
                deny: sut hIsScrollbarShowing;
                deny: sut vIsScrollbarShowing.!

----- Method: ScrollPaneRetractableBarsTest>>test06ScrollRanges (in category 'tests') -----
test06ScrollRanges
       
        content extent: 200@300.
        self refresh.
       
        self
                assert: 200 equals: sut hTotalScrollRange;
                assert: 300 equals: sut vTotalScrollRange;
                assert: 100 equals: sut hLeftoverScrollRange;
                assert: 200 equals: sut vLeftoverScrollRange.

        sut hScrollBarValue: 50.
        sut vScrollBarValue: 30.
       
        "Scrolling does not affect the scroll ranges."
        self
                assert: 200 equals: sut hTotalScrollRange;
                assert: 300 equals: sut vTotalScrollRange;
                assert: 100 equals: sut hLeftoverScrollRange;
                assert: 200 equals: sut vLeftoverScrollRange.!

----- Method: ScrollPaneRetractableBarsTest>>test08ScrollToShow (in category 'tests') -----
test08ScrollToShow

        content extent: 300@300.
        self refresh.
       
        "1a) Scroll down/right to show bottom right corner."
        self scrollToTopLeft.
        sut scrollToShow: (50@50 corner: 100@100).
        self assert: 0@0 equals: sut scroller offset.
       
        "1b) Scroll up/left to show top left corner."
        self scrollToBottomRight.
        sut scrollToShow: (100@100 corner: 150@150).
        self assert: 100@100 equals: sut scroller offset.

        "2a) Too big, so show bottom right corner because we scroll down/right."
        self scrollToTopLeft.
        sut scrollToShow: (0@0 corner: 100@100).
        self assert: 0@0 equals: sut scroller offset.

        "2b) Too big, so show top left corner because we scroll up/left."
        self scrollToBottomRight.
        sut scrollToShow: (50@50 corner: 150@150).
        self assert: 50@50 equals: sut scroller offset.

        "3) No negative offsets."
        self scrollToTopLeft.
        sut scrollToShow: (-10 @ -10 corner: 50@50).
        self assert: 0@0 equals: sut scroller offset.!

----- Method: ScrollPaneTest>>refresh (in category 'running') -----
refresh
        "Since there is now direct communication between the content and the scroll pane, re-layouting as to be explicit."
       
        sut
                resizeScrollBars;
                resizeScroller;
                setScrollDeltas.
                !

----- Method: ScrollPaneTest>>scrollToBottomRight (in category 'running') -----
scrollToBottomRight

        sut hScrollBar setValue: sut hScrollBar maximumValue.
        sut vScrollBar setValue: sut vScrollBar maximumValue.!

----- Method: ScrollPaneTest>>scrollToTopLeft (in category 'running') -----
scrollToTopLeft

        sut
                hScrollBarValue: 0;
                vScrollBarValue: 0;
                setScrollDeltas.!

----- Method: ScrollPaneTest>>setUp (in category 'running') -----
setUp

        super setUp.
        sut := ScrollPane new.
        sut
                retractable: false;
                scrollBarOnLeft: false;
                extent: 100@100;
                borderWidth: 0. "Very important for the math in tests!!"
        content := Morph new.
        sut scroller addMorph: content.!

----- Method: ScrollPaneTest>>test00SetUp (in category 'tests') -----
test00SetUp

        self assert: 100@100 equals: sut extent.!

----- Method: ScrollPaneTest>>test01ScrollBarPolicyWhenNeeded (in category 'tests') -----
test01ScrollBarPolicyWhenNeeded

        sut
                hScrollBarPolicy: #whenNeeded;
                vScrollBarPolicy: #whenNeeded.
               
        content extent: 100@100.
        self refresh.
       
        self
                deny: sut hIsScrollbarShowing;
                deny: sut vIsScrollbarShowing.
               
        content extent: 150@150.
        self refresh.

        self
                assert: sut hIsScrollbarShowing;
                assert: sut vIsScrollbarShowing.!

----- Method: ScrollPaneTest>>test02ScrollBarPolicyAlways (in category 'tests') -----
test02ScrollBarPolicyAlways

        sut
                hScrollBarPolicy: #always;
                vScrollBarPolicy: #always.
               
        content extent: 50@50.
        self refresh.
       
        self
                assert: sut hIsScrollbarShowing;
                assert: sut vIsScrollbarShowing.
               
        content extent: 150@150.
        self refresh.

        self
                assert: sut hIsScrollbarShowing;
                assert: sut vIsScrollbarShowing.!

----- Method: ScrollPaneTest>>test03ScrollBarPolicyNever (in category 'tests') -----
test03ScrollBarPolicyNever

        sut
                hScrollBarPolicy: #never;
                vScrollBarPolicy: #never.
               
        content extent: 50@50.
        self refresh.
       
        self
                deny: sut hIsScrollbarShowing;
                deny: sut vIsScrollbarShowing.
               
        content extent: 150@150.
        self refresh.

        self
                deny: sut hIsScrollbarShowing;
                deny: sut vIsScrollbarShowing.!

----- Method: ScrollPaneTest>>test04ScrollingCallIn (in category 'tests') -----
test04ScrollingCallIn

        content extent: 200@200.
        self refresh.
       
        self
                assert: 0 equals: sut hScrollBar value;
                assert: 0 equals: sut vScrollBar value;
                assert: 0@0 equals: sut scroller offset.
               
        sut hScrollBar setValue: 50.
        sut vScrollBar setValue: 50.

        self
                assert: 50 equals: sut hScrollBar value;
                assert: 50 equals: sut vScrollBar value;
                assert: 50@50 equals: sut scroller offset.
!

----- Method: ScrollPaneTest>>test05ScrollingCallOut (in category 'tests') -----
test05ScrollingCallOut
        "There is no automatic call-out from pane to scroll bars yet."
       
        content extent: 200@200.
        self refresh.
       
        self
                assert: 0 equals: sut hScrollBar value;
                assert: 0 equals: sut vScrollBar value;
                assert: 0@0 equals: sut scroller offset.
               
        sut hScrollBarValue: 50.
        sut vScrollBarValue: 50.

        self
                assert: 0 equals: sut hScrollBar value;
                assert: 0 equals: sut vScrollBar value;
                assert: 50@50 equals: sut scroller offset.
       
        sut hSetScrollDelta.
        sut vSetScrollDelta.
       
        self
                assert: 50 equals: sut hScrollBar value;
                assert: 50 equals: sut vScrollBar value.!

----- Method: ScrollPaneTest>>test06ScrollRanges (in category 'tests') -----
test06ScrollRanges
       
        content extent: 200@300.
        self refresh.
       
        self
                assert: 200 equals: sut hTotalScrollRange;
                assert: 300 equals: sut vTotalScrollRange;
                assert: 100 equals: sut hLeftoverScrollRange - sut scrollBarThickness;
                assert: 200 equals: sut vLeftoverScrollRange - sut scrollBarThickness.

        sut hScrollBarValue: 50.
        sut vScrollBarValue: 30.
       
        "Scrolling does not affect the scroll ranges."
        self
                assert: 200 equals: sut hTotalScrollRange;
                assert: 300 equals: sut vTotalScrollRange;
                assert: 100 equals: sut hLeftoverScrollRange - sut scrollBarThickness;
                assert: 200 equals: sut vLeftoverScrollRange - sut scrollBarThickness.
!

----- Method: ScrollPaneTest>>test07GuardOffsets (in category 'tests') -----
test07GuardOffsets
        "Scroll bars will never report negative values because they have 0 as minimum. Programmatic access, however, might provide those. Visual appearance should not break then."
       
        content extent: 200@300.
        self refresh.

        sut hScrollBarValue: -10.
        sut vScrollBarValue: -20.
       
        self assert: 0@0 equals: sut scroller offset.!

----- Method: ScrollPaneTest>>test08ScrollToShow (in category 'tests') -----
test08ScrollToShow

        content extent: 300@300.
        self refresh.
       
        "1a) Scroll down/right to show bottom right corner."
        self scrollToTopLeft.
        sut scrollToShow: (50@50 corner: 100@100).
        self assert: (sut scrollBarThickness @ sut scrollBarThickness) equals: sut scroller offset.
       
        "1b) Scroll up/left to show top left corner."
        self scrollToBottomRight.
        sut scrollToShow: (100@100 corner: 150@150).
        self assert: 100@100 equals: sut scroller offset.

        "2a) Too big, so show bottom right corner because we scroll down/right."
        self scrollToTopLeft.
        sut scrollToShow: (0@0 corner: 100@100).
        self assert: (sut scrollBarThickness @ sut scrollBarThickness) equals: sut scroller offset.

        "2b) Too big, so show top left corner because we scroll up/left."
        self scrollToBottomRight.
        sut scrollToShow: (50@50 corner: 150@150).
        self assert: 50@50 equals: sut scroller offset.

        "3) No negative offsets."
        self scrollToTopLeft.
        sut scrollToShow: (-10 @ -10 corner: 50@50).
        self assert: 0@0 equals: sut scroller offset.!

----- Method: ScrollPaneTest>>test09HideShowTransition (in category 'tests') -----
test09HideShowTransition

        content extent: 300@300.
        self refresh.

        "1) Horizontal bar not needed anymore."
        sut extent: 100@100.
        sut vScrollBar setValue: 50.
        sut width: content width + sut vScrollBar width.
        self assert: sut vLeftoverScrollRange equals: sut vScrollBar maximumValue.

        "2) Vertical bar not needed anymore."
        sut extent: 100@100.
        sut hScrollBar setValue: 50.
        sut height: content height + sut hScrollBar height.
        self assert: sut hLeftoverScrollRange equals: sut hScrollBar maximumValue.
!

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

SliderTest subclass: #ScrollBarTest
        instanceVariableNames: ''
        classVariableNames: ''
        poolDictionaries: ''
        category: 'MorphicTests-Widgets'!

----- Method: ScrollBarTest class>>shouldInheritSelectors (in category 'testing') -----
shouldInheritSelectors
        ^ true!

----- Method: ScrollBarTest>>subjectClass (in category 'running') -----
subjectClass

        ^ ScrollBar!

----- Method: SliderTest>>setUp (in category 'running') -----
setUp

        super setUp.
        sut := self subjectClass
                on: (ValueHolder new contents: 0.0)
                getValue: #contents
                setValue: #contents:.
        sut extent: 400@20.!

----- Method: SliderTest>>subjectClass (in category 'running') -----
subjectClass

        ^ Slider!

----- Method: SliderTest>>test01Value (in category 'tests') -----
test01Value

        self assert: 0.0 equals: sut value.
        self assert: 0.0 equals: sut model contents.!

----- Method: SliderTest>>test02SetValue (in category 'tests') -----
test02SetValue

        sut setValue: 0.5.
        self
                assert: 0.5 equals: sut value;
                assert: 0.5 equals: sut model contents.!

----- Method: SliderTest>>test03MinMax (in category 'tests') -----
test03MinMax

        sut
                minimumValue: 10;
                maximumValue: 20.

        sut setValue: 5.
        self assert: 10 equals: sut value truncated.
       
        sut setValue: 30.
        self assert: 20 equals: sut value truncated.

        sut maximumValue: 15.
        self assert: 15 equals: sut value truncated.

        sut setValue: 10.
        sut minimumValue: 12.
        self assert: 12 equals: sut value truncated.
!

----- Method: SliderTest>>test04Descending (in category 'tests') -----
test04Descending

        | px |
        sut setValue: 0.3.
        px := sut thumb position.
       
        sut descending: sut descending not.
        self assert: px ~= sut thumb position.!

----- Method: SliderTest>>test05SliderWithoutModel (in category 'tests') -----
test05SliderWithoutModel

        | swm |
        swm := Slider new.
       
        self assert: 0.0 equals: swm value.
        swm setValue: 0.6.
        self assert: 0.6 equals: swm value.!

----- Method: SliderTest>>test06Truncate (in category 'tests') -----
test06Truncate

        self assert: sut truncate not.
       
        sut maximumValue: 100.
        sut truncate: true.

        sut setValue: 23.45.
        self assert: 23 equals: sut value.

        sut setValue: 23.65.
        self assert: 24 equals: sut value.!

----- Method: SliderTest>>test07Quantum (in category 'tests') -----
test07Quantum

        sut maximumValue: 100.
        sut quantum: 5.

        sut setValue: 23.
        self assert: 25 equals: sut value.!

----- Method: SliderTest>>test08MinEqualsMax (in category 'tests') -----
test08MinEqualsMax

        sut
                maximumValue: 50;
                minimumValue: 50.

        self assert: 50 equals: sut value.!

----- Method: SliderTest>>test09SliderWithoutGetter (in category 'tests') -----
test09SliderWithoutGetter

        sut getValueSelector: nil.
        sut setValue: 0.5.
               
        self assert: 0.5 equals: sut value.
        self assert: 0.5 equals: sut model contents.!

TestCase subclass: #TextEditorTest
        instanceVariableNames: 'model widget'
        classVariableNames: ''
        poolDictionaries: ''
        category: 'MorphicTests-Text Support'!

----- Method: TextEditorTest>>editor (in category 'running') -----
editor

        ^ widget textMorph editor!

----- Method: TextEditorTest>>setUp (in category 'running') -----
setUp

        super setUp.
        model := MorphicTestTextModel new.
        widget := PluggableTextMorph on: model text: #contents accept: #contents:.
       
        "We don't do real keyboard event handling. To be sure to set the model in the editor."
        self editor model: model.
       
        model contents: ''.!

----- Method: TextEditorTest>>test01Setup (in category 'tests') -----
test01Setup

        self assert: model dependents size = 1.
        self assert: self editor model == model.
        self assert: widget text isEmpty.
        self assert: model contents isEmpty.!

----- Method: TextEditorTest>>test02EvaluateExpression (in category 'tests') -----
test02EvaluateExpression

        model := MorphicTestTextModelWithEvaluationSupport new.
        widget model: model.
       
        self text: '3+4'.
        self editor doIt.

        self
                assert: (model hasFlag: #expressionEvaluated);
                assert: 7 equals: model result.!

----- Method: TextEditorTest>>test03DebugExpression (in category 'tests') -----
test03DebugExpression

        self text: 'Morph new'.
        self editor debugIt.

        self
                assert: (model hasFlag: #expressionDebugged);
                assert: (model result isKindOf: Morph).!

----- Method: TextEditorTest>>test04PrintIt (in category 'tests') -----
test04PrintIt

        self text: '3+4'.
        self editor printIt.

        self
                assert: (model hasFlag: #printed);
                assert: '7' equals: model result.!

----- Method: TextEditorTest>>test05ExploreIt (in category 'tests') -----
test05ExploreIt

        self text: '1@1 corner: 20@20'.
        self editor exploreIt.

        self
                assert: (model hasFlag: #explored);
                assert: (model result isKindOf: Rectangle).!

----- Method: TextEditorTest>>test06InspectIt (in category 'tests') -----
test06InspectIt

        self text: '1@1 corner: 20@20'.
        self editor inspectIt.
       
        self
                assert: (model hasFlag: #inspected);
                assert: (model result isKindOf: Rectangle).!

----- Method: TextEditorTest>>test07DoItReceiver (in category 'tests') -----
test07DoItReceiver

        self text: 'self color'.
        model result: (Morph new color: Color yellow).
        self editor doIt.
       
        self
                assert: (model hasFlag: #expressionEvaluated);
                assert: Color yellow equals: model result.!

----- Method: TextEditorTest>>text: (in category 'running') -----
text: aString
        "Text editors have a short lifetime in pluggable text morphs."
       
        model contents: aString.
       
        "We don't do real keyboard event handling. To be sure to set the model in the editor."
        self editor model: model.!

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

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