[squeak-dev] Squeak 4.6: MorphicTests-mt.31.mczcommits at source.squeak.org commits at source.squeak.orgFri Jun 5 20:28:15 UTC 2015
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 at 111) clipRect = (0 at 0 corner: 222 at 111). self assert: (FormCanvas extent: 2222 at 11) clipRect = (0 at 0 corner: 2222 at 11). self assert: (FormCanvas extent: 22222 at 1) clipRect = (0 at 0 corner: 22222 at 1). ! ----- Method: FormCanvasTest>>testFrameAndFillDegenerateRoundRect01 (in category 'tests') ----- testFrameAndFillDegenerateRoundRect01 | fill canvas smallRect | fill := GradientFillStyle sample. canvas := FormCanvas extent: 100 at 100. canvas fillColor: Color black. smallRect := 0 at 0 corner: 20 at 20. "This should not throw an exception." canvas frameAndFillRoundRect: smallRect radius: smallRect width / 2 + 1 fillStyle: fill borderWidth: 0 borderColor: Color lightGray.! ----- Method: FormCanvasTest>>testFrameAndFillDegenerateRoundRect02 (in category 'tests') ----- testFrameAndFillDegenerateRoundRect02 | fill canvas smallRect | fill := GradientFillStyle sample. canvas := FormCanvas extent: 100 at 100. canvas fillColor: Color black. smallRect := 0 at 0 corner: 20 at 20. "This should not throw an exception." canvas frameAndFillRoundRect: smallRect radius: 0 fillStyle: fill borderWidth: 0 borderColor: Color lightGray.! TestCase subclass: #LayoutFrameTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-Layouts'! ----- Method: LayoutFrameTest>>testInset (in category 'as yet unclassified') ----- testInset | lf rectangle | lf := LayoutFrame new leftFraction: 0 offset: 10; topFraction: 0 offset: 10; rightFraction: 1 offset: -10; bottomFraction: 1 offset: -10; yourself. rectangle := lf layout: nil in: (50 at 10 corner: 150 at 70). self assert: (60 at 20 corner: 140 at 60) = rectangle! ----- Method: LayoutFrameTest>>testLeftTopAligned (in category 'as yet unclassified') ----- testLeftTopAligned | lf rectangle | lf := LayoutFrame new leftFraction: 0 offset: 10; topFraction: 0 offset: 10; rightFraction: 0 offset: 60; bottomFraction: 0 offset: 25; yourself. rectangle := lf layout: nil in: (50 at 10 corner: 150 at 70). self assert: (60 at 20 corner: 110 at 35) = rectangle! ----- Method: LayoutFrameTest>>testRightBottomQuadrant (in category 'as yet unclassified') ----- testRightBottomQuadrant | lf rectangle | lf := LayoutFrame new leftFraction: 1/2 offset: 1; topFraction: 1/2 offset: 1; rightFraction: 1 offset: -2; bottomFraction: 1 offset: -2; yourself. rectangle := lf layout: nil in: (50 at 10 corner: 150 at 70). self assert: (101 at 41 corner: 148 at 68) = rectangle! ----- Method: LayoutFrameTest>>testSpaceFill (in category 'as yet unclassified') ----- testSpaceFill | lf rectangle | lf := LayoutFrame new leftFraction: 0 offset: 0; topFraction: 0 offset: 0; rightFraction: 1 offset: 0; bottomFraction: 1 offset: 0; yourself. rectangle := lf layout: nil in: (50 at 10 corner: 150 at 70). self assert: (50 at 10 corner: 150 at 70) = rectangle! TestCase subclass: #MCPTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-Kernel'! ----- Method: MCPTest>>defaultBounds (in category 'constants') ----- defaultBounds "the default bounds for morphs" ^ 0 @ 0 corner: 50 @ 40 ! ----- Method: MCPTest>>defaultTop (in category 'constants') ----- defaultTop "the default top for morphs" ^ self defaultBounds top ! ----- Method: MCPTest>>testIsMorphicModel (in category 'tests') ----- testIsMorphicModel "test isMorphicModel" self deny: Object new isMorphicModel. self deny: Morph new isMorphicModel. self assert: MorphicModel new isMorphicModel. ! ----- Method: MCPTest>>testIsSystemWindow (in category 'tests') ----- testIsSystemWindow "test isSystemWindow" self deny: Object new isSystemWindow. self assert: SystemWindow new isSystemWindow.! ----- Method: MCPTest>>testTop (in category 'tests') ----- testTop "test the #top: messages and its consequences" | morph factor newTop newBounds | morph := Morph new. "" factor := 10. newTop := self defaultTop + factor. newBounds := self defaultBounds translateBy: 0 @ factor. "" morph top: newTop. "" self assert: morph top = newTop; assert: morph bounds = newBounds! TestCase subclass: #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 at 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 at 0. 100 at 0. 0 at 100} color: Color red borderWidth: 0 borderColor: Color transparent) color: Color red. submorph bounds. "0 at 0 corner: 100 at 100" aMorph := Morph new color: Color blue; layoutPolicy: ProportionalLayout new; addMorph: submorph fullFrame: (LayoutFrame fractions: (0.1 @ 0.1 corner: 0.9 @ 0.9)). submorph bounds. "0 at 0 corner: 100 at 100 NOT YET UPDATED" aMorph fullBounds. "0 at 0 corner: 50 at 40. CORRECT" submorph bounds. "5 at 4 corner: 45 at 36 NOW UPDATED OK" aMorph extent: 100 at 100. submorph bounds. "5 at 4 corner: 45 at 36 NOT YET UPDATED" aMorph fullBounds. "-10 at -14 corner: 100 at 100 WRONG" submorph bounds. "-10 at -14 corner: 70 at 66 NOW WRONG POSITION (BUT RIGHT EXTENT)" self assert: aMorph fullBounds = (0 @ 0 extent: 100 at 100). self assert: submorph bounds = (10 @ 10 corner: 90 at 90). ! TestCase subclass: #MorphicUIManagerTest instanceVariableNames: 'cases' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-ToolBuilder'! !MorphicUIManagerTest commentStamp: 'wiz 1/3/2007 13:57' prior: 0! A MorphicUIBugTest is a class for testing the shortcomings and repairs of the MorphicUI manager. . Instance Variables cases: <aCollection> cases - a list of morphs that may need to be deleted during teardown. the tests are expected to fill this list it starts out empty by default. ! ----- Method: MorphicUIManagerTest>>defaultTimeout (in category 'as yet unclassified') ----- defaultTimeout ^ 60 "seconds"! ----- Method: MorphicUIManagerTest>>findWindowInWorldLabeled: (in category 'as yet unclassified') ----- findWindowInWorldLabeled: aLabel "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 at 100. self refresh. self deny: sut hIsScrollbarShowing; deny: sut vIsScrollbarShowing. content extent: 150 at 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 at 50. self refresh. self deny: sut hIsScrollbarShowing; deny: sut vIsScrollbarShowing. content extent: 150 at 150. self refresh. self deny: sut hIsScrollbarShowing; deny: sut vIsScrollbarShowing.! ----- Method: ScrollPaneRetractableBarsTest>>test06ScrollRanges (in category 'tests') ----- test06ScrollRanges content extent: 200 at 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 at 300. self refresh. "1a) Scroll down/right to show bottom right corner." self scrollToTopLeft. sut scrollToShow: (50 at 50 corner: 100 at 100). self assert: 0 at 0 equals: sut scroller offset. "1b) Scroll up/left to show top left corner." self scrollToBottomRight. sut scrollToShow: (100 at 100 corner: 150 at 150). self assert: 100 at 100 equals: sut scroller offset. "2a) Too big, so show bottom right corner because we scroll down/right." self scrollToTopLeft. sut scrollToShow: (0 at 0 corner: 100 at 100). self assert: 0 at 0 equals: sut scroller offset. "2b) Too big, so show top left corner because we scroll up/left." self scrollToBottomRight. sut scrollToShow: (50 at 50 corner: 150 at 150). self assert: 50 at 50 equals: sut scroller offset. "3) No negative offsets." self scrollToTopLeft. sut scrollToShow: (-10 @ -10 corner: 50 at 50). self assert: 0 at 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 at 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 at 100 equals: sut extent.! ----- Method: ScrollPaneTest>>test01ScrollBarPolicyWhenNeeded (in category 'tests') ----- test01ScrollBarPolicyWhenNeeded sut hScrollBarPolicy: #whenNeeded; vScrollBarPolicy: #whenNeeded. content extent: 100 at 100. self refresh. self deny: sut hIsScrollbarShowing; deny: sut vIsScrollbarShowing. content extent: 150 at 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 at 50. self refresh. self assert: sut hIsScrollbarShowing; assert: sut vIsScrollbarShowing. content extent: 150 at 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 at 50. self refresh. self deny: sut hIsScrollbarShowing; deny: sut vIsScrollbarShowing. content extent: 150 at 150. self refresh. self deny: sut hIsScrollbarShowing; deny: sut vIsScrollbarShowing.! ----- Method: ScrollPaneTest>>test04ScrollingCallIn (in category 'tests') ----- test04ScrollingCallIn content extent: 200 at 200. self refresh. self assert: 0 equals: sut hScrollBar value; assert: 0 equals: sut vScrollBar value; assert: 0 at 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 at 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 at 200. self refresh. self assert: 0 equals: sut hScrollBar value; assert: 0 equals: sut vScrollBar value; assert: 0 at 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 at 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 at 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 at 300. self refresh. sut hScrollBarValue: -10. sut vScrollBarValue: -20. self assert: 0 at 0 equals: sut scroller offset.! ----- Method: ScrollPaneTest>>test08ScrollToShow (in category 'tests') ----- test08ScrollToShow content extent: 300 at 300. self refresh. "1a) Scroll down/right to show bottom right corner." self scrollToTopLeft. sut scrollToShow: (50 at 50 corner: 100 at 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 at 100 corner: 150 at 150). self assert: 100 at 100 equals: sut scroller offset. "2a) Too big, so show bottom right corner because we scroll down/right." self scrollToTopLeft. sut scrollToShow: (0 at 0 corner: 100 at 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 at 50 corner: 150 at 150). self assert: 50 at 50 equals: sut scroller offset. "3) No negative offsets." self scrollToTopLeft. sut scrollToShow: (-10 @ -10 corner: 50 at 50). self assert: 0 at 0 equals: sut scroller offset.! ----- Method: ScrollPaneTest>>test09HideShowTransition (in category 'tests') ----- test09HideShowTransition content extent: 300 at 300. self refresh. "1) Horizontal bar not needed anymore." sut extent: 100 at 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 at 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 at 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 at 1 corner: 20 at 20'. self editor exploreIt. self assert: (model hasFlag: #explored); assert: (model result isKindOf: Rectangle).! ----- Method: TextEditorTest>>test06InspectIt (in category 'tests') ----- test06InspectIt self text: '1 at 1 corner: 20 at 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. !
More information about the Squeak-dev mailing list |