[squeak-dev] The Inbox: MorphicTests-ct.88.mczcommits at source.squeak.org commits at source.squeak.orgThu Jul 14 14:11:23 UTC 2022
A new version of MorphicTests was added to project The Inbox: http://source.squeak.org/inbox/MorphicTests-ct.88.mcz ==================== Summary ==================== Name: MorphicTests-ct.88 Author: ct Time: 9 July 2022, 7:31:39.249611 pm UUID: 84ddbf6c-cab7-7546-9339-6140fe321128 Ancestors: MorphicTests-mt.87 Complements ToolBuilder-Morphic-ct.320 (tests for file dialogs). =============== Diff against MorphicTests-mt.87 =============== Item was removed: - SystemOrganization addCategory: #'MorphicTests-Basic'! - SystemOrganization addCategory: #'MorphicTests-Events'! - 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'! Item was removed: - TestCase subclass: #BalloonFontTest - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'MorphicTests-Widgets'! Item was removed: - ----- 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.! Item was removed: - ----- 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)! Item was removed: - TestCase subclass: #BorderedMorphTests - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'MorphicTests-Basic'! Item was removed: - ----- Method: BorderedMorphTests>>test01OldInstVarRefs (in category 'tests') ----- - test01OldInstVarRefs - "Only BorderedMorph should reference the (deprecated) borderWidth and borderColor isntance variables." - - self - assert: 2 - equals: (SystemNavigation default allAccessesTo: #borderWidth from: BorderedMorph) size. - - self - assert: 2 - equals: (SystemNavigation default allAccessesTo: #borderColor from: BorderedMorph) size.! Item was removed: - ----- Method: BorderedMorphTests>>test02ConvertColorSymbols (in category 'tests') ----- - test02ConvertColorSymbols - "The use of #inset or #raised as border color should result in the use of a new border style." - - | sut | - sut := BorderedMorph new. - self - assert: #simple equals: sut borderStyle style; - assert: Color black equals: sut borderStyle color. - - sut borderColor: #raised. - self - assert: #raised equals: sut borderStyle style; - assert: Color black equals: sut borderStyle color. - - "Enable color tracking." - sut borderColor: Color transparent. - self assert: sut color equals: sut borderStyle color. - - sut borderColor: #inset. - self - assert: #inset equals: sut borderStyle style; - assert: sut color equals: sut borderStyle color. - ! Item was removed: - ----- Method: BorderedMorphTests>>test03ColorTracking (in category 'tests') ----- - test03ColorTracking - - | sut c1 c2 | - sut := BorderedMorph new. - self assert: Color black equals: sut borderStyle baseColor. - - sut borderInset. - self - assert: Color transparent equals: sut borderStyle baseColor; - assert: sut borderStyle topLeftColor ~= sut color; - assert: sut borderStyle bottomRightColor ~= sut color; - assert: sut borderStyle bottomRightColor ~= sut borderStyle topLeftColor. - - c1 := sut borderStyle topLeftColor. - c2 := sut borderStyle bottomRightColor. - sut color: Color yellow. - self - assert: Color transparent equals: sut borderStyle baseColor; - assert: sut borderStyle topLeftColor ~= c1; - assert: sut borderStyle bottomRightColor ~= c2. - - c1 := sut borderStyle topLeftColor. - c2 := sut borderStyle bottomRightColor. - sut borderStyle: BorderStyle raised. - self - assert: Color transparent equals: sut borderStyle baseColor; - assert: sut borderStyle topLeftColor = c2; - assert: sut borderStyle bottomRightColor = c1.! Item was removed: - ----- Method: BorderedMorphTests>>test04InnerBounds (in category 'tests') ----- - test04InnerBounds - "Check whether a changed border width triggers a layout re-computation." - - | sut | - sut := Morph new. - sut changeTableLayout. - sut addMorph: (Morph new - hResizing: #spaceFill; - vResizing: #spaceFill; - yourself). - - self - assert: 0 equals: sut borderWidth; - assert: sut fullBounds equals: sut bounds; - assert: sut bounds equals: sut innerBounds; - assert: sut bounds equals: sut firstSubmorph bounds. - - sut borderStyle: (BorderStyle raised width: 10). - - self - assert: 10 equals: sut borderWidth; - assert: sut fullBounds equals: sut bounds; - assert: (sut bounds insetBy: 10) equals: sut innerBounds; - assert: sut innerBounds equals: sut firstSubmorph bounds.! Item was removed: - ----- Method: BorderedMorphTests>>test05Convenience (in category 'tests') ----- - test05Convenience - "Check whether a the convenience messages #borderWidth: and #borderColor: work." - - | sut | - sut := Morph new. - sut - borderWidth: 5; - borderColor: Color yellow. - - self - assert: 5 equals: sut borderWidth; - assert: Color yellow equals: sut borderColor. - - sut := Morph new. - sut - borderColor: Color yellow; - borderWidth: 5. - - self - assert: Color yellow equals: sut borderColor; - assert: 5 equals: sut borderWidth.! Item was removed: - TestCase subclass: #CircleMorphBugs - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'MorphicTests-Basic'! Item was removed: - ----- Method: CircleMorphBugs>>testCircleInstance (in category 'tests') ----- - testCircleInstance - "" - "self run: #testCircleInstance" - - | circ | - self assert: (circ := CircleMorph initializedInstance) extent = circ extent x asPoint - - ! Item was removed: - 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. - ! Item was removed: - ----- Method: CircleMorphTest>>setUp (in category 'running') ----- - setUp - morph := CircleMorph new! Item was removed: - TestCase subclass: #FormCanvasTest - instanceVariableNames: 'morph' - classVariableNames: '' - poolDictionaries: '' - category: 'MorphicTests-Support'! Item was removed: - ----- 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). - ! Item was removed: - ----- 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.! Item was removed: - ----- 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.! Item was removed: - TestCase subclass: #GridLayoutTest - instanceVariableNames: 'container' - classVariableNames: '' - poolDictionaries: '' - category: 'MorphicTests-Layouts'! Item was removed: - ----- Method: GridLayoutTest>>addMorph (in category 'support') ----- - addMorph - - | newMorph | - newMorph := Morph new - position: 0 at 0; extent: 10 at 10; - hResizing: #spaceFill; vResizing: #spaceFill; - color: Color random; - yourself. - container addMorph: newMorph. - ^ newMorph! Item was removed: - ----- Method: GridLayoutTest>>setUp (in category 'running') ----- - setUp - - super setUp. - container := Morph new - color: Color random; - position: 0 at 0; - extent: 100 at 100; - layoutPolicy: GridLayout new; - gridOrigin: 0 at 0; - gridModulus: 20 at 20; - yourself.! Item was removed: - ----- Method: GridLayoutTest>>test01Position (in category 'tests') ----- - test01Position - - | m o | - m := self addMorph. - o := container position. - { - 0 at 0 . 0 at 0 . - 9 at 9 . 0 at 0 . - 10 at 10 . 20 at 20 . - 25 at 25 . 20 at 20 - } pairsDo: [:newPosition :expectedGrid | - m position: newPosition + o. - container fullBounds. - self assert: expectedGrid + o equals: m position].! Item was removed: - ----- Method: GridLayoutTest>>test02Extent (in category 'tests') ----- - test02Extent - - | m | - m := self addMorph. - { - 20 at 20 . 20 at 20 . - 50 at 50 . 60 at 60 . - 49 at 49 . 40 at 40 . - } pairsDo: [:newExtent :expectedGrid | - m extent: newExtent. - container fullBounds. - self assert: expectedGrid equals: m extent].! Item was removed: - ----- Method: GridLayoutTest>>test03ExtentRigid (in category 'tests') ----- - test03ExtentRigid - "The morph's extent will not be changed to match the grid cells when its resizing strategy is #rigid." - - | m | - m := self addMorph. - m hResizing: #rigid; vResizing: #rigid. - { - 20 at 20 . 20 at 20 . - 50 at 50 . 50 at 50 . - 49 at 49 . 49 at 49 . - 0 at 0 . 0 at 0 - } pairsDo: [:newExtent :expectedGrid | - m extent: newExtent. - container fullBounds. - self assert: expectedGrid equals: m extent].! Item was removed: - ----- Method: GridLayoutTest>>test04ExtentMinimum (in category 'tests') ----- - test04ExtentMinimum - - | m | - m := self addMorph. - m extent: 0 at 0. - container fullBounds. - self assert: container gridModulus equals: m extent.! Item was removed: - ----- Method: GridLayoutTest>>test05AdhereToEdge (in category 'tests') ----- - test05AdhereToEdge - "The grid should be ignored for morphs that snap to their owner's edges." - - | m | - m := Morph new color: Color random; extent: 10 at 10; yourself. - container addMorph: m. - - "1) Manual adhere-to-edge will not work." - m position: 0@(100 - 10). - container fullBounds. - self assert: 0 at 100 equals: m position. - - "2) Use adhere-to-edge property." - m setToAdhereToEdge: #bottom. - container fullBounds. - self assert: 0@(100 - 10) equals: m position.! Item was removed: - ----- Method: GridLayoutTest>>test06Origin (in category 'tests') ----- - test06Origin - "The grid's origin should be relative to its morph's position so that the morph can be moved around without the grid changing." - - container position: 0 at 0. - container removeAllMorphs. - self test01Position. - - container position: 10 at 10. - container removeAllMorphs. - self test01Position.! Item was removed: - HandMorph subclass: #HandMorphForEventTests - instanceVariableNames: 'eventsDuringCapture eventsDuringBubble eventsRejected eventsFiltered eventsIgnored isHandling' - classVariableNames: '' - poolDictionaries: '' - category: 'MorphicTests-Events'! Item was removed: - ----- Method: HandMorphForEventTests>>eventsDuringBubble (in category 'accessing') ----- - eventsDuringBubble - ^ eventsDuringBubble ifNil: [eventsDuringBubble := OrderedCollection new]! Item was removed: - ----- Method: HandMorphForEventTests>>eventsDuringCapture (in category 'accessing') ----- - eventsDuringCapture - ^ eventsDuringCapture ifNil: [eventsDuringCapture := OrderedCollection new]! Item was removed: - ----- Method: HandMorphForEventTests>>eventsFiltered (in category 'accessing') ----- - eventsFiltered - ^ eventsFiltered ifNil: [eventsFiltered := OrderedCollection new]! Item was removed: - ----- Method: HandMorphForEventTests>>eventsIgnored (in category 'accessing') ----- - eventsIgnored - ^ eventsIgnored ifNil: [eventsIgnored := OrderedCollection new]! Item was removed: - ----- Method: HandMorphForEventTests>>eventsRejected (in category 'accessing') ----- - eventsRejected - ^ eventsRejected ifNil: [eventsRejected := OrderedCollection new]! Item was removed: - ----- Method: HandMorphForEventTests>>filterEvent:for: (in category 'event filtering') ----- - filterEvent: anEvent for: aMorphOrNil - - self eventsFiltered add: anEvent copy -> aMorphOrNil. - ^ anEvent! Item was removed: - ----- Method: HandMorphForEventTests>>handleEvent: (in category 'events-processing') ----- - handleEvent: anEvent - - (isHandling == true and: [(#(mouseOver mouseMove) includes: anEvent type) not]) ifTrue: [Error signal: 'Recursive handling detected!!']. - isHandling := true. - self eventsDuringBubble add: anEvent copy. - [^ super handleEvent: anEvent] - ensure: [isHandling := false].! Item was removed: - ----- Method: HandMorphForEventTests>>handleEventSilently: (in category 'events-processing') ----- - handleEventSilently: anEvent - - ^ super handleEvent: anEvent! Item was removed: - ----- Method: HandMorphForEventTests>>ignoreEvent: (in category 'event filtering') ----- - ignoreEvent: anEvent - "Log ignored event to support debugging." - - super ignoreEvent: anEvent. - self eventsIgnored add: anEvent copy -> (thisContext stackOfSize: 5).! Item was removed: - ----- Method: HandMorphForEventTests>>processEvent:using: (in category 'events-processing') ----- - processEvent: anEvent using: dispatcher - - self eventsDuringCapture add: anEvent copy. - ^ super processEvent: anEvent using: dispatcher! Item was removed: - ----- Method: HandMorphForEventTests>>rejectsEvent: (in category 'events-processing') ----- - rejectsEvent: anEvent - - ^ (super rejectsEvent: anEvent) - ifTrue: [self eventsRejected add: anEvent copy. true] - ifFalse: [false]! Item was removed: - TestCase subclass: #LayoutFrameTest - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'MorphicTests-Layouts'! Item was removed: - ----- Method: LayoutFrameTest>>testInset (in category 'tests') ----- - 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! Item was removed: - ----- Method: LayoutFrameTest>>testLeftTopAligned (in category 'tests') ----- - 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! Item was removed: - ----- Method: LayoutFrameTest>>testRightBottomQuadrant (in category 'tests') ----- - 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! Item was removed: - ----- Method: LayoutFrameTest>>testSpaceFill (in category 'tests') ----- - 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! Item was removed: - TestCase subclass: #MCPTest - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'MorphicTests-Kernel'! Item was removed: - ----- Method: MCPTest>>defaultBounds (in category 'constants') ----- - defaultBounds - "the default bounds for morphs" - ^ 0 @ 0 corner: 50 @ 40 ! Item was removed: - ----- Method: MCPTest>>defaultTop (in category 'constants') ----- - defaultTop - "the default top for morphs" - ^ self defaultBounds top ! Item was removed: - ----- Method: MCPTest>>testIsMorphicModel (in category 'tests') ----- - testIsMorphicModel - "test isMorphicModel" - self deny: Object new isMorphicModel. - self deny: Morph new isMorphicModel. - self assert: MorphicModel new isMorphicModel. - ! Item was removed: - ----- Method: MCPTest>>testIsSystemWindow (in category 'tests') ----- - testIsSystemWindow - "test isSystemWindow" - self deny: Object new isSystemWindow. - self assert: SystemWindow new isSystemWindow.! Item was removed: - ----- 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! Item was removed: - MorphTest subclass: #MorphBugs - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'MorphicTests-Basic'! Item was removed: - ----- Method: MorphBugs>>testAdhereToEdgeEternity (in category 'tests') ----- - testAdhereToEdgeEternity - - | r | - r := RectangleMorph new openInWorld: self getWorld. - - self - shouldnt: [ r adhereToEdge: #eternity ] - raise: Exception.! Item was removed: - Morph subclass: #MorphForEventTests - instanceVariableNames: 'eventsDuringCapture eventsDuringBubble eventsRejected eventsFiltered handlesMouseDown keyStrokesReceived fullFocusDispatch eventDispatcher' - classVariableNames: '' - poolDictionaries: '' - category: 'MorphicTests-Events'! Item was removed: - ----- Method: MorphForEventTests>>defaultEventDispatcher (in category 'events-processing') ----- - defaultEventDispatcher - - ^ self eventDispatcher ifNil: [super defaultEventDispatcher]! Item was removed: - ----- Method: MorphForEventTests>>eventDispatcher (in category 'accessing') ----- - eventDispatcher - - ^ eventDispatcher! Item was removed: - ----- Method: MorphForEventTests>>eventDispatcher: (in category 'accessing') ----- - eventDispatcher: anEventDispatcher - - eventDispatcher := anEventDispatcher.! Item was removed: - ----- Method: MorphForEventTests>>eventsDuringBubble (in category 'accessing') ----- - eventsDuringBubble - ^ eventsDuringBubble ifNil: [eventsDuringBubble := OrderedCollection new]! Item was removed: - ----- Method: MorphForEventTests>>eventsDuringCapture (in category 'accessing') ----- - eventsDuringCapture - ^ eventsDuringCapture ifNil: [eventsDuringCapture := OrderedCollection new]! Item was removed: - ----- Method: MorphForEventTests>>eventsFiltered (in category 'accessing') ----- - eventsFiltered - ^ eventsFiltered ifNil: [eventsFiltered := OrderedCollection new]! Item was removed: - ----- Method: MorphForEventTests>>eventsRejected (in category 'accessing') ----- - eventsRejected - ^ eventsRejected ifNil: [eventsRejected := OrderedCollection new]! Item was removed: - ----- Method: MorphForEventTests>>filterEvent:for: (in category 'event filtering') ----- - filterEvent: anEvent for: aMorphOrNil - - self eventsFiltered add: anEvent copy -> aMorphOrNil. - ^ anEvent! Item was removed: - ----- Method: MorphForEventTests>>fullFocusDispatch (in category 'accessing') ----- - fullFocusDispatch - ^ fullFocusDispatch ifNil: [false]! Item was removed: - ----- Method: MorphForEventTests>>fullFocusDispatch: (in category 'accessing') ----- - fullFocusDispatch: aBoolean - fullFocusDispatch := aBoolean.! Item was removed: - ----- Method: MorphForEventTests>>handleEvent: (in category 'events-processing') ----- - handleEvent: anEvent - - self eventsDuringBubble add: anEvent copy. - ^ super handleEvent: anEvent! Item was removed: - ----- Method: MorphForEventTests>>handlesKeyboard: (in category 'event handling') ----- - handlesKeyboard: evt - ^ true! Item was removed: - ----- Method: MorphForEventTests>>handlesMouseDown: (in category 'event handling') ----- - handlesMouseDown: evt - ^ handlesMouseDown ifNil: [true]! Item was removed: - ----- Method: MorphForEventTests>>handlesMouseMove: (in category 'event handling') ----- - handlesMouseMove: evt - ^ true! Item was removed: - ----- Method: MorphForEventTests>>handlesMouseOver: (in category 'event handling') ----- - handlesMouseOver: evt - ^ true! Item was removed: - ----- Method: MorphForEventTests>>handlesMouseOverDragging: (in category 'event handling') ----- - handlesMouseOverDragging: evt - ^ true! Item was removed: - ----- Method: MorphForEventTests>>handlesMouseStillDown: (in category 'event handling') ----- - handlesMouseStillDown: evt - ^ true! Item was removed: - ----- Method: MorphForEventTests>>keyStroke: (in category 'event handling') ----- - keyStroke: evt - - self keyStrokesReceived add: evt.! Item was removed: - ----- Method: MorphForEventTests>>keyStrokesReceived (in category 'accessing') ----- - keyStrokesReceived - ^ keyStrokesReceived ifNil: [keyStrokesReceived := OrderedCollection new]! Item was removed: - ----- Method: MorphForEventTests>>noMouseDown (in category 'accessing') ----- - noMouseDown - - handlesMouseDown := false.! Item was removed: - ----- Method: MorphForEventTests>>processEvent:using: (in category 'events-processing') ----- - processEvent: anEvent using: dispatcher - - self eventsDuringCapture add: anEvent copy. - ^ super processEvent: anEvent using: dispatcher! Item was removed: - ----- Method: MorphForEventTests>>processFocusEvent:using: (in category 'events-processing') ----- - processFocusEvent: anEvent using: defaultDispatcher - - ^ self fullFocusDispatch - ifTrue: [defaultDispatcher dispatchFocusEventFully: anEvent with: self] - ifFalse: [defaultDispatcher dispatchFocusEvent: anEvent with: self] - - - ! Item was removed: - ----- Method: MorphForEventTests>>rejectsEvent: (in category 'events-processing') ----- - rejectsEvent: anEvent - - ^ (super rejectsEvent: anEvent) - ifTrue: [self eventsRejected add: anEvent copy. true] - ifFalse: [false]! Item was removed: - TestCase subclass: #MorphLayoutTest - instanceVariableNames: 'reset' - classVariableNames: '' - poolDictionaries: '' - category: 'MorphicTests-Layouts'! Item was removed: - ----- Method: MorphLayoutTest>>ensureLayout: (in category 'helper') ----- - ensureLayout: aMorph - - ^ aMorph - fullBounds; - yourself! Item was removed: - ----- Method: MorphLayoutTest>>makeYellow: (in category 'helper') ----- - makeYellow: aMorph - - aMorph color: Color yellow.! Item was removed: - ----- Method: MorphLayoutTest>>testAdhereToEdge (in category 'tests') ----- - testAdhereToEdge - - | child container | - container := Morph new - extent: 300 @ 200; - addMorphBack: (child := Morph new extent: 100 @ 100). - - child adhereToEdge: #right. - self ensureLayout: container. - self assert: 200 @ 0 equals: child position. - - child adhereToEdge: #bottom. - self ensureLayout: container. - self assert: 200 @ 100 equals: child position. - - child adhereToEdge: #topLeft. - self ensureLayout: container. - self assert: 0 @ 0 equals: child position! Item was removed: - ----- Method: MorphLayoutTest>>testLayoutPropertyAssertions (in category 'tests') ----- - testLayoutPropertyAssertions - - | morph | - morph := Morph new. - - self should: [morph vResizing: #shrriinkWraap] raise: Error. - self should: [morph hResizing: #spaceFlll] raise: Error. - self should: [morph cellSpacing: 0] raise: Error. - self should: [morph cellSpacing: #glob] raise: Error. - self should: [morph listSpacing: 2] raise: Error. - self should: [morph listSpacing: #eq] raise: Error! Item was removed: - ----- Method: MorphLayoutTest>>testManualPositions (in category 'tests') ----- - testManualPositions - - | container greenMorph redMorph | - container := Morph new - addMorphBack: (redMorph := Morph new color: Color red; extent: 30 @ 20; position: 20 @ 20); - addMorphBack: (greenMorph := Morph new color: Color green; extent: 200 @ 300; position: 80 @ 80). - - self ensureLayout: container. - self assert: Morph new extent equals: container extent. - - container extent: 300 @ 300. - self assert: 300 @ 300 equals: container extent! Item was removed: - ----- Method: MorphLayoutTest>>testOwnerChangedHandler (in category 'tests') ----- - testOwnerChangedHandler - - | m1 m2 | - m1 := Morph new extent: 100 at 100; yourself. - m2 := Morph new extent: 10 at 10; yourself. - - m1 addMorph: m2. - self ensureLayout: m1. - self assert: 10 at 10 equals: m2 extent. - - m2 ownerChangedHandler: [:m | m extent: m owner extent]. - self ensureLayout: m1. - self assert: 100 at 100 equals: m2 extent. - - m2 color: Color red. - m2 ownerChangedHandler: (MessageSend receiver: self selector: #makeYellow:). - self assert: Color red equals: m2 color. - self ensureLayout: m1. - self assert: Color yellow equals: m2 color. - - m2 ownerChangedHandler: #delete. - self assert: m1 hasSubmorphs. - self ensureLayout: m1. - self deny: m1 hasSubmorphs.! Item was removed: - 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! Item was removed: - ----- Method: MorphTest>>createAndAddMorphs: (in category 'support') ----- - createAndAddMorphs: someNames - - (self createMorphs: someNames) do: [:newMorph | - morph addMorphBack: newMorph].! Item was removed: - ----- Method: MorphTest>>createMorphs: (in category 'support') ----- - createMorphs: someNames - - ^ someNames collect: [:nm | Morph new name: nm]! Item was removed: - ----- Method: MorphTest>>createMorphs:inLayers: (in category 'support') ----- - createMorphs: names inLayers: layerNumbers - - ^ names with: layerNumbers collect: [:name :layer | - Morph new name: name; morphicLayerNumber: layer; yourself]! Item was removed: - ----- Method: MorphTest>>getSubmorph: (in category 'support') ----- - getSubmorph: name - - ^ morph submorphs detect: [:m | m knownName = name]! Item was removed: - ----- Method: MorphTest>>getSubmorphNames (in category 'support') ----- - getSubmorphNames - - ^ morph submorphs collect: [:m | m knownName asSymbol]! Item was removed: - ----- Method: MorphTest>>getSubmorphs: (in category 'support') ----- - getSubmorphs: someNames - - ^ someNames collect: [:nm | self getSubmorph: nm]! Item was removed: - ----- Method: MorphTest>>getWorld (in category 'initialize-release') ----- - getWorld - - ^ world ifNil: [world := PasteUpMorph newWorldForProject: nil]! Item was removed: - ----- Method: MorphTest>>setUp (in category 'initialize-release') ----- - setUp - morph := Morph new! Item was removed: - ----- Method: MorphTest>>tearDown (in category 'initialize-release') ----- - tearDown - - morph delete.! Item was removed: - ----- Method: MorphTest>>test01LayerNumberDefault (in category 'tests - submorphs - layers') ----- - test01LayerNumberDefault - - self assert: Morph new morphicLayerNumber isNumber.! Item was removed: - ----- Method: MorphTest>>test02LayerNumberCustom (in category 'tests - submorphs - layers') ----- - test02LayerNumberCustom - - | m | - m := Morph new. - self deny: 50 equals: m morphicLayerNumber. - m morphicLayerNumber: 50. - self assert: 50 equals: m morphicLayerNumber.! Item was removed: - ----- Method: MorphTest>>test03LayerNumberFromOwner (in category 'tests - submorphs - layers') ----- - test03LayerNumberFromOwner - "If not specified, inherit the owner's layer number." - - | m1 m2 | - m1 := Morph new. - m2 := Morph new. - m1 addMorph: m2. - - m1 morphicLayerNumber: 50. - self assert: 50 equals: m2 morphicLayerNumber. - - m2 morphicLayerNumber: 25. - self assert: 25 equals: m2 morphicLayerNumber. - ! Item was removed: - ----- Method: MorphTest>>test04AddMorphInLayer (in category 'tests - submorphs - layers') ----- - test04AddMorphInLayer - - | container builder unordered ordered | - container := Morph new. - builder := [Morph new]. - - unordered := #(6.5 100 20 15 5.0 6 7 100 20 -10). - unordered := unordered collect: [:layerNumber | - {layerNumber . builder value morphicLayerNumber: layerNumber}]. - unordered do: [:spec | - container addMorphBackInLayer: spec second]. - - ordered := unordered. "No need to reverse the list because add-to-back directly maps to the resulting submorph order." - ordered := ordered sorted: [:a :b | a first <= b first]. "Must be stable." - ordered := ordered collect: [:spec | spec second]. "Just the morphs." - - self assert: (ordered hasEqualElements: container submorphs).! Item was removed: - ----- Method: MorphTest>>test05AddMorphFrontInLayer (in category 'tests - submorphs - layers') ----- - test05AddMorphFrontInLayer - - | container builder unordered ordered | - container := Morph new. - builder := [Morph new]. - - unordered := #(6.5 100 20 15 5.0 6 7 100 20 -10). - unordered := unordered collect: [:layerNumber | - {layerNumber . builder value morphicLayerNumber: layerNumber}]. - unordered do: [:spec | - container addMorphFrontInLayer: spec second]. - - ordered := unordered reversed. "Submorph order will be reversed due to add-to-front." - ordered := ordered sorted: [:a :b | a first <= b first]. "Must be stable." - ordered := ordered collect: [:spec | spec second]. "Just the morphs." - - self assert: (ordered hasEqualElements: container submorphs).! Item was removed: - ----- Method: MorphTest>>test06AddMorphBackInLayer (in category 'tests - submorphs - layers') ----- - test06AddMorphBackInLayer - - | container builder unordered ordered | - container := Morph new. - builder := [Morph new]. - - unordered := #(6.5 100 20 15 5.0 6 7 100 20 -10). - unordered := unordered collect: [:layerNumber | - {layerNumber . builder value morphicLayerNumber: layerNumber}]. - unordered do: [:spec | - container addMorphBackInLayer: spec second]. - - ordered := unordered. "No need to reverse the list because add-to-back directly maps to the resulting submorph order." - ordered := ordered sorted: [:a :b | a first <= b first]. "Must be stable." - ordered := ordered collect: [:spec | spec second]. "Just the morphs." - - self assert: (ordered hasEqualElements: container submorphs).! Item was removed: - ----- Method: MorphTest>>test07ChangeLayerNumber (in category 'tests - submorphs - layers') ----- - test07ChangeLayerNumber - - | container m1 m2 | - container := Morph new. - m1 := Morph new. - m2 := Morph new. - - m1 morphicLayerNumber: 20. "behind m2" - m2 morphicLayerNumber: 10. "in front of m1" - - container addMorphInLayer: m1. - container addMorphInLayer: m2. - self assert: ({m2 . m1} hasEqualElements: container submorphs). - - m1 morphicLayerNumber: 5. "go in front of m2" - container addMorphInLayer: m1. - self assert: ({m1 . m2} hasEqualElements: container submorphs). - - m1 morphicLayerNumber: 50. "go behind m2 again" - container addMorphInLayer: m1. - self assert: ({m2 . m1} hasEqualElements: container submorphs). - ! Item was removed: - ----- Method: MorphTest>>test08ChangeLayerNumberAuto (in category 'tests - submorphs - layers') ----- - test08ChangeLayerNumberAuto - - | container m1 m2 | - container := Morph new. - m1 := Morph new. - m2 := Morph new. - - m1 morphicLayerNumber: 20. "behind m2" - m2 morphicLayerNumber: 10. "in front of m1" - - container addMorphInLayer: m1. - container addMorphInLayer: m2. - self assert: ({m2 . m1} hasEqualElements: container submorphs). - - m1 morphicLayerNumber: 5. "go in front of m2" - self assert: ({m1 . m2} hasEqualElements: container submorphs). - - m1 morphicLayerNumber: 50. "go behind m2 again" - self assert: ({m2 . m1} hasEqualElements: container submorphs).! Item was removed: - ----- Method: MorphTest>>test09IgnoreLayer (in category 'tests - submorphs - layers') ----- - test09IgnoreLayer - - | container m1 m2 | - container := Morph new. - m1 := Morph new. - m2 := Morph new. - - m1 morphicLayerNumber: 1. - m2 morphicLayerNumber: 999. - - container addMorphFrontInLayer: m1. - container addMorphFront: m2. "Ignore the layer of m1." - self assert: ({m2 . m1} hasEqualElements: container submorphs). - - container addMorphFrontInLayer: m1. - self assert: ({m1 . m2} hasEqualElements: container submorphs).! Item was removed: - ----- Method: MorphTest>>test10TransformKeepsLayer (in category 'tests - submorphs - layers') ----- - test10TransformKeepsLayer - - | transform | - transform := morph addFlexShell. - - morph morphicLayerNumber: 50. - self assert: 50 equals: transform morphicLayerNumber. - - transform morphicLayerNumber: 20. - self assert: 20 equals: transform morphicLayerNumber. - - transform removeMorph: morph. - transform morphicLayerNumber: 50. - self - assert: 20 equals: morph morphicLayerNumber; - assert: 50 equals: transform morphicLayerNumber! Item was removed: - ----- Method: MorphTest>>test11NamedLayers (in category 'tests - submorphs - layers') ----- - test11NamedLayers - - #( - frontmostLayer - - balloonLayer - haloLayer - menuLayer - - dialogLayer - - progressLayer - navigatorLayer - windowLayer - - defaultLayer - - backmostLayer - - ) overlappingPairsDo: [:a :b | - self assert: (Morph perform: a) <= (Morph perform: b)]! Item was removed: - ----- Method: MorphTest>>test12ResetLayerToDefault (in category 'tests - submorphs - layers') ----- - test12ResetLayerToDefault - - | default | - default := morph morphicLayerNumber. - - morph morphicLayerNumber: default * 2. - self deny: default equals: morph morphicLayerNumber. - - morph morphicLayerNumber: nil. - self assert: default equals: morph morphicLayerNumber! Item was removed: - ----- Method: MorphTest>>test13AddAllMorphsInLayers (in category 'tests - submorphs - layers') ----- - test13AddAllMorphsInLayers - - morph addAllMorphsInLayers: (self createMorphs: #(a b) inLayers: #(5 4)). - self assert: #(b a) equals: self getSubmorphNames. - - morph addAllMorphsInLayers: (self createMorphs: #(x y z) inLayers: #(3 3 5)). - self assert: #(x y b a z) equals: self getSubmorphNames.! Item was removed: - ----- Method: MorphTest>>test14AddAllMorphsFrontInLayers (in category 'tests - submorphs - layers') ----- - test14AddAllMorphsFrontInLayers - - morph addAllMorphsFrontInLayers: (self createMorphs: #(a b) inLayers: #(5 4)). - self assert: #(b a) equals: self getSubmorphNames. - - morph addAllMorphsFrontInLayers: (self createMorphs: #(x y z) inLayers: #(3 3 5)). - self assert: #(x y b z a) equals: self getSubmorphNames.! Item was removed: - ----- Method: MorphTest>>test15AddAllMorphsBackInLayers (in category 'tests - submorphs - layers') ----- - test15AddAllMorphsBackInLayers - - morph addAllMorphsBackInLayers: (self createMorphs: #(a b) inLayers: #(5 4)). - self assert: #(b a) equals: self getSubmorphNames. - - morph addAllMorphsBackInLayers: (self createMorphs: #(x y z) inLayers: #(3 3 5)). - self assert: #(x y b a z) equals: self getSubmorphNames.! Item was removed: - ----- Method: MorphTest>>testAddAllMorphs (in category 'tests - submorphs - add/remove') ----- - 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.! Item was removed: - ----- Method: MorphTest>>testAddAllMorphsAfter (in category 'tests - submorphs - add/remove') ----- - 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.! Item was removed: - ----- Method: MorphTest>>testAddAllMorphsInFrontOf (in category 'tests - submorphs - add/remove') ----- - 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.! Item was removed: - ----- Method: MorphTest>>testIntoWorldCollapseOutOfWorld (in category 'tests - 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). - ! Item was removed: - ----- Method: MorphTest>>testIntoWorldDeleteOutOfWorld (in category 'tests - 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). - ! Item was removed: - ----- Method: MorphTest>>testIntoWorldTransferToNewGuy (in category 'tests - 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). - ! Item was removed: - ----- Method: MorphTest>>testIsMorph (in category 'tests - classification') ----- - testIsMorph - self assert: (morph isMorph).! Item was removed: - ----- Method: MorphTest>>testOpenInWorld (in category 'tests - initialization') ----- - testOpenInWorld - "This should not throw an exception." - morph openInWorld.! Item was removed: - MorphicEventDispatcher subclass: #MorphicEventDispatcherForEventTests - instanceVariableNames: 'eventsSeen morphsSeen' - classVariableNames: '' - poolDictionaries: '' - category: 'MorphicTests-Events'! Item was removed: - ----- Method: MorphicEventDispatcherForEventTests>>dispatchEvent:with: (in category 'dispatching') ----- - dispatchEvent: anEvent with: aMorph - - self eventsSeen add: anEvent copy. - self morphsSeen add: aMorph. - ^ super dispatchEvent: anEvent with: aMorph! Item was removed: - ----- Method: MorphicEventDispatcherForEventTests>>eventsSeen (in category 'accessing') ----- - eventsSeen - - ^ eventsSeen ifNil: [eventsSeen := OrderedCollection new]! Item was removed: - ----- Method: MorphicEventDispatcherForEventTests>>morphsSeen (in category 'accessing') ----- - morphsSeen - - ^ morphsSeen ifNil: [morphsSeen := OrderedCollection new]! Item was removed: - UserInputEventTests subclass: #MorphicEventDispatcherTests - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'MorphicTests-Events'! Item was removed: - ----- Method: MorphicEventDispatcherTests>>test01EventBubbling (in category 'tests') ----- - test01EventBubbling - - | m1 m2 m3 | - m1 := MorphForEventTests new. - m2 := MorphForEventTests new. - m3 := MorphForEventTests new. - - m1 addMorph: m2. - m2 addMorph: m3. - - m1 openInWorld: world. - - self assert: m3 eventsDuringBubble isEmpty. - self assert: m2 eventsDuringBubble isEmpty. - self assert: m1 eventsDuringBubble isEmpty. - - hand handleEvent: (self redMouseDownAt: m3 center). - - self assert: (m3 eventsDuringBubble anySatisfy: [:ea | ea isMouseDown]). - self assert: (m2 eventsDuringBubble anySatisfy: [:ea | ea isMouseDown]). - self assert: (m1 eventsDuringBubble anySatisfy: [:ea | ea isMouseDown]).! Item was removed: - ----- Method: MorphicEventDispatcherTests>>test02EventCapturing (in category 'tests') ----- - test02EventCapturing - - | m1 m2 m3 | - m1 := MorphForEventTests new. - m2 := MorphForEventTests new. - m3 := MorphForEventTests new. - - m1 addMorph: m2. - m2 addMorph: m3. - - m1 openInWorld: world. - - self assert: m3 eventsDuringCapture isEmpty. - self assert: m2 eventsDuringCapture isEmpty. - self assert: m1 eventsDuringCapture isEmpty. - - hand handleEvent: (self redMouseDownAt: m3 center). - - self assert: (m3 eventsDuringCapture anySatisfy: [:ea | ea isMouseDown]). - self assert: (m2 eventsDuringCapture anySatisfy: [:ea | ea isMouseDown]). - self assert: (m1 eventsDuringCapture anySatisfy: [:ea | ea isMouseDown]).! Item was removed: - ----- Method: MorphicEventDispatcherTests>>test03EventRejecting (in category 'tests') ----- - test03EventRejecting - - | m1 m2 m3 | - m1 := MorphForEventTests new. - m2 := MorphForEventTests new. - m3 := MorphForEventTests new. - - m1 addMorph: m2. - m2 addMorph: m3. - - m2 lock. "to reject events" - m1 openInWorld: world. - - self assert: m2 eventsRejected isEmpty. - - hand handleEvent: (self redMouseDownAt: m3 center). - - self assert: (m2 eventsRejected anySatisfy: [:ea | ea isMouseDown]). - self assert: m2 eventsDuringBubble isEmpty. - self assert: m2 eventsDuringCapture notEmpty. - - self assert: m1 eventsRejected isEmpty. - self assert: m1 eventsDuringBubble notEmpty. - self assert: m1 eventsDuringCapture notEmpty. - - self assert: m3 eventsRejected isEmpty. - self assert: m3 eventsDuringBubble isEmpty. - self assert: m3 eventsDuringCapture isEmpty.! Item was removed: - ----- Method: MorphicEventDispatcherTests>>test04OverlappingSiblings (in category 'tests') ----- - test04OverlappingSiblings - "Only one of two overlapping siblings gets the event." - - | m1 m2 m3 | - m1 := MorphForEventTests new. - m2 := MorphForEventTests new. - m3 := MorphForEventTests new. - - m1 addMorph: m2. - m1 addMorph: m3. - - m2 bounds: m3 bounds. "full overlap" - - m1 openInWorld: world. - - hand handleEvent: (self redMouseDownAt: m3 center). - - self assert: (m3 eventsDuringBubble anySatisfy: [:ea | ea isMouseDown]). - self assert: (m2 eventsDuringBubble isEmpty). - - self assert: (m3 eventsDuringCapture anySatisfy: [:ea | ea isMouseDown]). - self assert: (m2 eventsDuringCapture isEmpty).! Item was removed: - ----- Method: MorphicEventDispatcherTests>>test05FocusEventBubbling (in category 'tests') ----- - test05FocusEventBubbling - - | m1 m2 m3 | - m1 := MorphForEventTests new. - m2 := MorphForEventTests new. - m3 := MorphForEventTests new. - - m1 addMorph: m2. - m2 addMorph: m3. - - m1 openInWorld: world. - - self assert: m3 eventsDuringBubble isEmpty. - self assert: m2 eventsDuringBubble isEmpty. - self assert: m1 eventsDuringBubble isEmpty. - - hand newMouseFocus: m2. "Not m3!! Due to focus, m3 is not considered during capturing/bubbling phase." - hand handleEvent: (self redMouseDownAt: m3 center). - - self assert: m3 eventsDuringBubble isEmpty. - self assert: (m2 eventsDuringBubble anySatisfy: [:ea | ea isMouseDown]). - self assert: (m1 eventsDuringBubble anySatisfy: [:ea | ea isMouseDown]). - - hand newKeyboardFocus: m2. - hand handleEvent: (self keystroke: $x at: m3 center). - - self assert: m3 eventsDuringBubble isEmpty. - self assert: (m2 eventsDuringBubble anySatisfy: [:ea | ea isKeystroke]). - self assert: (m1 eventsDuringBubble anySatisfy: [:ea | ea isKeystroke]). - ! Item was removed: - ----- Method: MorphicEventDispatcherTests>>test06FocusEventCapturing (in category 'tests') ----- - test06FocusEventCapturing - "There is no capturing phase for focus events." - - | m1 m2 m3 | - m1 := MorphForEventTests new. - m2 := MorphForEventTests new. - m3 := MorphForEventTests new. - - m1 addMorph: m2. - m2 addMorph: m3. - - m1 openInWorld: world. - - self assert: m3 eventsDuringCapture isEmpty. - self assert: m2 eventsDuringCapture isEmpty. - self assert: m1 eventsDuringCapture isEmpty. - - hand newMouseFocus: m2. "Not m3!! Due to focus, m3 is not considered during capturing/bubbling phase." - hand handleEvent: (self redMouseDownAt: m3 center). - - self assert: m3 eventsDuringCapture isEmpty. - self assert: m2 eventsDuringCapture isEmpty. - self assert: m1 eventsDuringCapture isEmpty. - - hand newKeyboardFocus: m2. - hand handleEvent: (self keystroke: $x at: m3 center). - - self assert: m3 eventsDuringCapture isEmpty. - self assert: m2 eventsDuringCapture isEmpty. - self assert: m1 eventsDuringCapture isEmpty.! Item was removed: - ----- Method: MorphicEventDispatcherTests>>test07EventNoBubbling (in category 'tests') ----- - test07EventNoBubbling - "There is no bubbling if no morph handles the event." - - | m1 m2 m3 | - m1 := MorphForEventTests new noMouseDown. - m2 := MorphForEventTests new noMouseDown. - m3 := MorphForEventTests new noMouseDown. - - m1 addMorph: m2. - m2 addMorph: m3. - - m1 openInWorld: world. - - self assert: m3 eventsDuringBubble isEmpty. - self assert: m2 eventsDuringBubble isEmpty. - self assert: m1 eventsDuringBubble isEmpty. - - hand handleEvent: (self redMouseDownAt: m3 center). - - self assert: (m3 eventsDuringBubble noneSatisfy: [:ea | ea isMouseDown]). - self assert: (m2 eventsDuringBubble noneSatisfy: [:ea | ea isMouseDown]). - self assert: (m1 eventsDuringBubble noneSatisfy: [:ea | ea isMouseDown]).! Item was removed: - ----- Method: MorphicEventDispatcherTests>>test08FocusEventBubblingNoHand (in category 'tests') ----- - test08FocusEventBubblingNoHand - "If you drag something, do not bubble up to the hand." - - | m1 | - m1 := MorphForEventTests new noMouseDown. - hand grabMorph: m1. - - hand newKeyboardFocus: m1. - - self assert: (hand eventsDuringBubble noneSatisfy: [:ea | ea isKeystroke]). - self assert: (m1 eventsDuringBubble noneSatisfy: [:ea | ea isKeystroke]). - - self - shouldnt: [hand handleEventSilently: (self keystroke: $x at: 0 at 0)] - raise: Error. - - self assert: (hand eventsDuringBubble noneSatisfy: [:ea | ea isKeystroke]). - self assert: (m1 eventsDuringBubble anySatisfy: [:ea | ea isKeystroke]). - ! Item was removed: - ----- Method: MorphicEventDispatcherTests>>test09FocusEventCapturingNoHand (in category 'tests') ----- - test09FocusEventCapturingNoHand - "Avoid duplication of capture step in hand for focus events." - - | m1 | - m1 := MorphForEventTests new noMouseDown. - hand grabMorph: m1. - - hand newKeyboardFocus: m1. - - self assert: (hand eventsDuringCapture noneSatisfy: [:ea | ea isKeystroke]). - self assert: (m1 eventsDuringCapture noneSatisfy: [:ea | ea isKeystroke]). - - hand handleEventSilently: (self keystroke: $x at: 0 at 0). - - self assert: (hand eventsDuringCapture noneSatisfy: [:ea | ea isKeystroke]). - self assert: (m1 eventsDuringCapture noneSatisfy: [:ea | ea isKeystroke]).! Item was removed: - ----- Method: MorphicEventDispatcherTests>>test10NoDuplicateKeyStroke (in category 'tests') ----- - test10NoDuplicateKeyStroke - "Verifies that the event bubbling mechanism does not send keystroke events twice after the event was handled, as usual, by a morph." - - | m1 m2 m3 | - m1 := MorphForEventTests new. - m2 := MorphForEventTests new. - m3 := MorphForEventTests new. - - m1 addMorph: m2. - m2 addMorph: m3. - - m1 openInWorld: world. - - self assert: m3 keyStrokesReceived isEmpty. - self assert: m2 keyStrokesReceived isEmpty. - self assert: m1 keyStrokesReceived isEmpty. - - hand handleEvent: (self keystroke: $x at: m3 center). - - self assert: (m3 eventsDuringBubble anySatisfy: [:ea | ea isKeystroke]). - self assert: (m2 eventsDuringBubble anySatisfy: [:ea | ea isKeystroke]). - self assert: (m1 eventsDuringBubble anySatisfy: [:ea | ea isKeystroke]). - - self assert: m3 keyStrokesReceived first keyCharacter = $x. - self assert: m2 keyStrokesReceived isEmpty. - self assert: m1 keyStrokesReceived isEmpty. - ! Item was removed: - ----- Method: MorphicEventDispatcherTests>>test11FocusEventReject (in category 'tests') ----- - test11FocusEventReject - "If a morph with mouse focus or keyboard focus rejects the event, that focus should be cleared." - - | m1 m2 | - m1 := MorphForEventTests new. - m1 fullFocusDispatch: false. - m1 on: #mouseDown send: #hide to: m1. - m1 on: #keyStroke send: #hide to: m1. - m1 openInWorld: world. - - hand newMouseFocus: m1. - hand handleEvent: (self redMouseDownAt: m1 center). - self assert: hand mouseFocus isNil. - - hand newKeyboardFocus: m1. - hand handleEvent: (self keystroke: $x at: m1 center). - self assert: hand keyboardFocus isNil. - - m2 := MorphForEventTests new. - m2 bounds: m1 bounds. - m1 addMorph: m2. - m1 fullFocusDispatch: true. - - hand newMouseFocus: m1. - hand handleEvent: (self redMouseDownAt: m2 center). - self assert: hand mouseFocus isNil. - - hand newKeyboardFocus: m2. - hand handleEvent: (self keystroke: $x at: m2 center). - self assert: hand keyboardFocus isNil. - ! Item was removed: - ----- Method: MorphicEventDispatcherTests>>test12CustomEventDispatcher (in category 'tests') ----- - test12CustomEventDispatcher - "Each morph can choose to use a custom event dispatcher." - - | m1 m2 | - m1 := MorphForEventTests new. - m1 eventDispatcher: MorphicEventDispatcherForEventTests new. - - m2 := MorphForEventTests new. - m2 eventDispatcher: MorphicEventDispatcherForEventTests new. - - m2 bounds: m1 bounds. - m1 addMorph: m2. "full overlap" - - m1 openInWorld: world. - - self deny: (m1 eventDispatcher eventsSeen anySatisfy: [:ea | ea isMouseDown]). - self deny: (m2 eventDispatcher eventsSeen anySatisfy: [:ea | ea isMouseDown]). - - hand handleEvent: (self redMouseDownAt: m2 center). - - self assert: (m1 eventDispatcher eventsSeen anySatisfy: [:ea | ea isMouseDown]). - self assert: (m2 eventDispatcher eventsSeen anySatisfy: [:ea | ea isMouseDown]).! Item was removed: - UserInputEventTests subclass: #MorphicEventFilterTests - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'MorphicTests-Events'! Item was removed: - ----- Method: MorphicEventFilterTests>>test01EventBubbleFilter (in category 'tests') ----- - test01EventBubbleFilter - - | m1 m2 m3 filter | - m1 := MorphForEventTests new. - m2 := MorphForEventTests new. - m3 := MorphForEventTests new. - - m1 addMorph: m2. - m2 addMorph: m3. - - m1 openInWorld: world. - - filter := MorphForEventTests new. - - m1 addEventBubbleFilter: filter. - m2 addEventBubbleFilter: filter. - m3 addEventBubbleFilter: filter. - - hand handleEvent: (self redMouseDownAt: m3 center). - - self assert: {m3.m2.m1} equals: (filter eventsFiltered select: [:ea | ea key isMouseDown] thenCollect: [:ea | ea value]) asArray.! Item was removed: - ----- Method: MorphicEventFilterTests>>test02EventCaptureFilter (in category 'tests') ----- - test02EventCaptureFilter - - | m1 m2 m3 filter | - m1 := MorphForEventTests new. - m2 := MorphForEventTests new. - m3 := MorphForEventTests new. - - m1 addMorph: m2. - m2 addMorph: m3. - - m1 openInWorld: world. - - filter := MorphForEventTests new. - - m1 addEventCaptureFilter: filter. - m2 addEventCaptureFilter: filter. - m3 addEventCaptureFilter: filter. - - hand handleEvent: (self redMouseDownAt: m3 center). - - self assert: {m1.m2.m3} equals: (filter eventsFiltered select: [:ea | ea key isMouseDown] thenCollect: [:ea | ea value]) asArray.! Item was removed: - ----- Method: MorphicEventFilterTests>>test03FocusEventBubbleFilter (in category 'tests') ----- - test03FocusEventBubbleFilter - - | m1 m2 m3 filter | - m1 := MorphForEventTests new. - m2 := MorphForEventTests new. - m3 := MorphForEventTests new. - - m1 addMorph: m2. - m2 addMorph: m3. - - m1 openInWorld: world. - - filter := MorphForEventTests new. - - m1 addEventBubbleFilter: filter. - m2 addEventBubbleFilter: filter. - m3 addEventBubbleFilter: filter. - - hand newMouseFocus: m2. - hand handleEvent: (self redMouseDownAt: m3 center). - - self assert: {m2.m1} equals: (filter eventsFiltered select: [:ea | ea key isMouseDown] thenCollect: [:ea | ea value]) asArray.! Item was removed: - ----- Method: MorphicEventFilterTests>>test04FocusEventCaptureFilter (in category 'tests') ----- - test04FocusEventCaptureFilter - - | m1 m2 m3 filter | - m1 := MorphForEventTests new. - m2 := MorphForEventTests new. - m3 := MorphForEventTests new. - - m1 addMorph: m2. - m2 addMorph: m3. - - m1 openInWorld: world. - - filter := MorphForEventTests new. - - m1 addEventCaptureFilter: filter. - m2 addEventCaptureFilter: filter. - m3 addEventCaptureFilter: filter. - - hand newMouseFocus: m2. - hand handleEvent: (self redMouseDownAt: m3 center). - - self assert: {m1.m2} equals: (filter eventsFiltered select: [:ea | ea key isMouseDown] thenCollect: [:ea | ea value]) asArray.! Item was removed: - ----- Method: MorphicEventFilterTests>>test05IgnoreEvent (in category 'tests') ----- - test05IgnoreEvent - - | m1 m2 m3 filter | - m1 := MorphForEventTests new. - m2 := MorphForEventTests new. - m3 := MorphForEventTests new. - - m1 addMorph: m2. - m2 addMorph: m3. - - m1 openInWorld: world. - - filter := PluggableEventFilter on: [:event | event ignore]. - - m1 addEventCaptureFilter: filter. - - hand handleEvent: (self redMouseDownAt: m3 center). - - self assert: m1 eventsDuringBubble isEmpty. - self assert: m2 eventsDuringBubble isEmpty. - self assert: m3 eventsDuringBubble isEmpty. - - self assert: m1 eventsDuringCapture notEmpty. - self assert: m2 eventsDuringCapture isEmpty. - self assert: m3 eventsDuringCapture isEmpty.! Item was removed: - ----- Method: MorphicEventFilterTests>>test06IgnoreFocusEvent (in category 'tests') ----- - test06IgnoreFocusEvent - - | m1 m2 m3 filter | - m1 := MorphForEventTests new. - m2 := MorphForEventTests new. - m3 := MorphForEventTests new. - - m1 addMorph: m2. - m2 addMorph: m3. - - m1 openInWorld: world. - - filter := PluggableEventFilter on: [:event | event ignore]. - - m1 addEventCaptureFilter: filter. - - hand newMouseFocus: m3. - hand handleEvent: (self redMouseDownAt: m3 center). - - self assert: m1 eventsDuringBubble isEmpty. - self assert: m2 eventsDuringBubble isEmpty. - self assert: m3 eventsDuringBubble isEmpty. - - self assert: m1 eventsDuringCapture isEmpty. - self assert: m2 eventsDuringCapture isEmpty. - self assert: m3 eventsDuringCapture isEmpty.! Item was removed: - ----- Method: MorphicEventFilterTests>>test07TransformEvent (in category 'tests') ----- - test07TransformEvent - - | m1 m2 m3 filter | - m1 := MorphForEventTests new. - m2 := MorphForEventTests new. - m3 := MorphForEventTests new. - - m1 addMorph: m2. - m2 addMorph: m3. - - m1 openInWorld: world. - - filter := PluggableEventFilter on: [:event | self keystroke: $x at: m3 center]. - m2 addEventCaptureFilter: filter. - - hand handleEvent: (self redMouseDownAt: m3 center). - - self assert: (m1 eventsDuringCapture anySatisfy: [:evt | evt isMouseDown]). - self assert: (m2 eventsDuringCapture anySatisfy: [:evt | evt isMouseDown]). - self assert: (m3 eventsDuringCapture anySatisfy: [:evt | evt isKeystroke]). - - self assert: (m3 eventsDuringBubble anySatisfy: [:evt | evt isKeystroke]). - self assert: (m2 eventsDuringBubble anySatisfy: [:evt | evt isKeystroke]). - self assert: (m1 eventsDuringBubble anySatisfy: [:evt | evt isKeystroke]). - ! Item was removed: - ----- Method: MorphicEventFilterTests>>test08TransformEventAgain (in category 'tests') ----- - test08TransformEventAgain - - | m1 m2 m3 filter | - m1 := MorphForEventTests new. - m2 := MorphForEventTests new. - m3 := MorphForEventTests new. - - m1 addMorph: m2. - m2 addMorph: m3. - - m1 openInWorld: world. - - filter := PluggableEventFilter on: [:event | self keystroke: $x at: m3 center]. - m2 addEventBubbleFilter: filter. - - hand handleEvent: (self redMouseDownAt: m3 center). - - self assert: (m1 eventsDuringCapture anySatisfy: [:evt | evt isMouseDown]). - self assert: (m2 eventsDuringCapture anySatisfy: [:evt | evt isMouseDown]). - self assert: (m3 eventsDuringCapture anySatisfy: [:evt | evt isMouseDown]). - - self assert: (m3 eventsDuringBubble anySatisfy: [:evt | evt isMouseDown]). - self assert: (m2 eventsDuringBubble anySatisfy: [:evt | evt isMouseDown]). - self assert: (m1 eventsDuringBubble anySatisfy: [:evt | evt isKeystroke]). - ! Item was removed: - ----- Method: MorphicEventFilterTests>>test09KeyboardShortcut (in category 'tests') ----- - test09KeyboardShortcut - - | m1 m2 m3 filter hit | - m1 := MorphForEventTests new. - m2 := MorphForEventTests new. - m3 := MorphForEventTests new. - - m1 addMorph: m2. - m2 addMorph: m3. - - m1 openInWorld: world. - - filter := PluggableEventFilter on: [:event | - hit := false. - (event isKeystroke and: [event keyCharacter = $x]) ifTrue: [ - hit := true. - event ignore]. - event]. - - m1 addKeyboardCaptureFilter: filter. - - hand handleEvent: (self keystroke: $x at: m3 center). - - self assert: hit. - - self assert: (m1 eventsDuringCapture anySatisfy: [:evt | evt isKeystroke]). - self assert: (m2 eventsDuringCapture noneSatisfy: [:evt | evt isKeystroke]). - self assert: (m3 eventsDuringCapture noneSatisfy: [:evt | evt isKeystroke]). - - self assert: (m3 eventsDuringBubble noneSatisfy: [:evt | evt isKeystroke]). - self assert: (m2 eventsDuringBubble noneSatisfy: [:evt | evt isKeystroke]). - self assert: (m1 eventsDuringBubble noneSatisfy: [:evt | evt isKeystroke]). - - m1 eventsDuringCapture removeAll. - hand handleEvent: (self keystroke: $o at: m3 center). - - self deny: hit. - - self assert: (m1 eventsDuringCapture anySatisfy: [:evt | evt isKeystroke]). - self assert: (m2 eventsDuringCapture anySatisfy: [:evt | evt isKeystroke]). - self assert: (m3 eventsDuringCapture anySatisfy: [:evt | evt isKeystroke]). - - self assert: (m3 eventsDuringBubble anySatisfy: [:evt | evt isKeystroke]). - self assert: (m2 eventsDuringBubble anySatisfy: [:evt | evt isKeystroke]). - self assert: (m1 eventsDuringBubble anySatisfy: [:evt | evt isKeystroke]). - - - - ! Item was removed: - UserInputEventTests subclass: #MorphicEventTests - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'MorphicTests-Events'! Item was removed: - ----- Method: MorphicEventTests>>test01WantsKeyboardFocus (in category 'tests') ----- - test01WantsKeyboardFocus - - | ptm | - ptm := PluggableTextMorph new. - ptm setText: 'test01WantsKeyboardFocus'. - ptm openInWorld: world. - - self deny: (ptm hasKeyboardFocus: hand). - self deny: (ptm textMorph hasKeyboardFocus: hand). - - self assert: ptm wantsKeyboardFocus. - self assert: ptm keyboardFocusDelegate == ptm textMorph. - - hand handleEvent: (self redMouseDownAt: ptm center). - self assert: (ptm hasKeyboardFocus: hand). - self assert: (ptm textMorph hasKeyboardFocus: hand). - ! Item was removed: - ----- Method: MorphicEventTests>>test02MouseOver (in category 'tests') ----- - test02MouseOver - - | m1 m2 | - m1 := MorphForEventTests new. - m2 := MorphForEventTests new. - - m1 extent: 20 at 20; topLeft: 0 at 0. - m2 extent: 20 at 20; topLeft: 40 at 0. - - m1 openInWorld: world. - m2 openInWorld: world. - - hand handleEvent: (self redMouseDownAt: m1 center). - hand handleEvent: (self redMouseUpAt: m1 center). - hand handleEvent: (self redMouseDownAt: m2 center). - hand handleEvent: (self redMouseUpAt: m2 center). - - self - checkEventOrder: #(mouseMove mouseEnter mouseDown mouseUp mouseLeave) - forEvents: m1 eventsDuringBubble - ignoreMouseOver: true. - - self - checkEventOrder: #(mouseMove mouseEnter mouseDown mouseUp) - forEvents: m2 eventsDuringBubble - ignoreMouseOver: true. - ! Item was removed: - ----- Method: MorphicEventTests>>test03EventHandler (in category 'tests') ----- - test03EventHandler - "Test a morph's event handler, which is configured via #on:send:to:. Note that the handler only reacts on #mouseDown but we do send a #mouseUp to reset the mouse focus to ensure the same event-dispatching flow for all three mouse buttons." - - | m | - m := Morph new. - m extent: 20 at 20; topLeft: 0 at 0. - - m wantsHaloFromClick: false. - m wantsYellowButtonMenu: false. - m wantsMetaMenu: false. - - m on: #mouseDown send: #value: to: [:evt| - evt redButtonPressed ifTrue:[m color: Color red]. - evt yellowButtonPressed ifTrue:[m color: Color yellow]. - evt blueButtonPressed ifTrue:[m color: Color blue]]. - - m color: Color blue. - m openInWorld: world. - - self assert: hand mouseFocus isNil. - hand handleEvent: (self redMouseDownAt: m center). - hand handleEvent: (self redMouseUpAt: m center). - self assert: Color red equals: m color. - - self assert: hand mouseFocus isNil. - hand handleEvent: (self yellowMouseDownAt: m center). - hand handleEvent: (self yellowMouseUpAt: m center). - self assert: Color yellow equals: m color. - - self assert: hand mouseFocus isNil. - hand handleEvent: (self blueMouseDownAt: m center). - hand handleEvent: (self blueMouseUpAt: m center). - self assert: Color blue equals: m color.! Item was removed: - ValueHolder subclass: #MorphicTestTextModel - instanceVariableNames: 'flags result' - classVariableNames: '' - poolDictionaries: '' - category: 'MorphicTests-Text Support'! Item was removed: - ----- Method: MorphicTestTextModel>>debugExpression: (in category 'do-its general') ----- - debugExpression: anExpression - - self flags add: #expressionDebugged. - self result: (Compiler evaluate: anExpression).! Item was removed: - ----- Method: MorphicTestTextModel>>doItContext (in category 'do-its support') ----- - doItContext - - self flags add: #doItContext. - ^ nil! Item was removed: - ----- Method: MorphicTestTextModel>>doItReceiver (in category 'do-its support') ----- - doItReceiver - - self flags add: #doItReceiver. - ^ self result! Item was removed: - ----- Method: MorphicTestTextModel>>exploreIt:result: (in category 'do-its') ----- - exploreIt: expression result: object - - self flags add: #explored. - self result: object.! Item was removed: - ----- Method: MorphicTestTextModel>>expressionEvaluated:result: (in category 'do-its general') ----- - expressionEvaluated: anExpression result: anObject - - self flags add: #expressionEvaluated. - self result: anObject.! Item was removed: - ----- Method: MorphicTestTextModel>>flags (in category 'accessing') ----- - flags - - ^ flags ifNil: [flags := Bag new]! Item was removed: - ----- Method: MorphicTestTextModel>>hasFlag: (in category 'accessing') ----- - hasFlag: aSymbol - - ^ self flags includes: aSymbol! Item was removed: - ----- Method: MorphicTestTextModel>>inspectIt:result: (in category 'do-its') ----- - inspectIt: expression result: object - - self flags add: #inspected. - self result: object.! Item was removed: - ----- Method: MorphicTestTextModel>>printIt:result: (in category 'do-its') ----- - printIt: expression result: object - - self flags add: #printed. - self result: object printString.! Item was removed: - ----- Method: MorphicTestTextModel>>result (in category 'accessing') ----- - result - - ^ result! Item was removed: - ----- Method: MorphicTestTextModel>>result: (in category 'accessing') ----- - result: anObject - - result := anObject.! Item was removed: - MorphicTestTextModel subclass: #MorphicTestTextModelWithEvaluationSupport - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'MorphicTests-Text Support'! Item was removed: - ----- Method: MorphicTestTextModelWithEvaluationSupport>>evaluateExpression: (in category 'do-its general') ----- - evaluateExpression: anExpression - - self flags add: #expressionEvaluated. - self result: (Compiler evaluate: anExpression asString). - ^ self result! Item was removed: - 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.! Item was removed: - ----- Method: MorphicToolBuilderTests>>acceptWidgetText (in category 'support') ----- - acceptWidgetText - widget hasUnacceptedEdits: true. - widget accept.! Item was removed: - ----- Method: MorphicToolBuilderTests>>buttonWidgetEnabled (in category 'support') ----- - buttonWidgetEnabled - "Answer whether the current widget (a button) is currently enabled" - ^widget enabled! Item was removed: - ----- Method: MorphicToolBuilderTests>>changeListWidget (in category 'support') ----- - changeListWidget - widget changeModelSelection: widget getCurrentSelectionIndex + 1.! Item was removed: - ----- Method: MorphicToolBuilderTests>>expectedButtonSideEffects (in category 'support') ----- - expectedButtonSideEffects - ^#()! Item was removed: - ----- Method: MorphicToolBuilderTests>>fireButtonWidget (in category 'support') ----- - fireButtonWidget - widget performAction.! Item was removed: - ----- Method: MorphicToolBuilderTests>>fireMenuItemWidget (in category 'support') ----- - fireMenuItemWidget - (widget itemWithWording: 'Menu Item') - ifNotNil: [:item | item doButtonAction]! Item was removed: - ----- Method: MorphicToolBuilderTests>>getState (in category 'support') ----- - getState - queries add: #getState. - ^false! Item was removed: - ----- Method: MorphicToolBuilderTests>>makeButton (in category 'tests-button') ----- - makeButton - super makeButton. - widget wantsGradient: false. - ^ widget! Item was removed: - ----- Method: MorphicToolBuilderTests>>setUp (in category 'support') ----- - setUp - super setUp. - builder := MorphicToolBuilder new.! Item was removed: - ----- Method: MorphicToolBuilderTests>>testWindowDynamicLabel (in category 'tests-window') ----- - testWindowDynamicLabel - self makeWindow. - self assert: (widget label = 'TestLabel').! Item was removed: - ----- 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').! Item was removed: - ----- Method: MorphicToolBuilderTests>>widgetColor (in category 'support') ----- - widgetColor - "Answer color from widget" - ^widget color! Item was removed: - TestCase subclass: #MorphicUIManagerTest - instanceVariableNames: 'cases uiManager' - 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. - - - ! Item was removed: - ----- Method: MorphicUIManagerTest>>defaultTimeout (in category 'accessing') ----- - defaultTimeout - ^ super defaultTimeout * 10 "seconds"! Item was removed: - ----- Method: MorphicUIManagerTest>>findWindowInWorldLabeled: (in category 'private') ----- - findWindowInWorldLabeled: aLabel - "Look in the world and in the hand for windows. Yes, windows may spawn in the hand." - | world | - world := Project current world. - ^ world submorphs, (world hands gather: [:hand | hand submorphs]) - detect: [ :each | - each isSystemWindow - and: [ each label = aLabel ] ] - ifNone: [].! Item was removed: - ----- Method: MorphicUIManagerTest>>setUp (in category 'initialize-release') ----- - setUp - "default. tests will add morphs to list. Teardown will delete." - - cases := #(). - uiManager := MorphicUIManager new.! Item was removed: - ----- Method: MorphicUIManagerTest>>tearDown (in category 'initialize-release') ----- - tearDown - "default. tests will add morphs to list. Teardown will delete." - - cases do: [ :each | each delete ].! Item was removed: - ----- Method: MorphicUIManagerTest>>testOpenWorkspace (in category 'tests') ----- - testOpenWorkspace - "self new testOpenWorkspace" - "MorphicUIBugTest run: #testOpenWorkspace" - - | window myLabel foundWindow myModel | - myLabel := 'Workspace from SUnit test' . - foundWindow := self findWindowInWorldLabeled: myLabel . - self assert: foundWindow isNil. - - window := uiManager edit: '"MorphicUIBugTest run: #openWorkspaceTest"' label: myLabel. - 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.! Item was removed: - ----- Method: MorphicUIManagerTest>>testOpenWorkspaceAns (in category 'tests') ----- - testOpenWorkspaceAns - "Test if method opening a workspace answers the window opened" - - "MorphicUIBugTest run: #testOpenWorkspaceAns" - - | window myLabel foundWindow | - myLabel := 'Workspace from ', 'SUnit test' . - foundWindow := self findWindowInWorldLabeled: myLabel . - self assert: ( foundWindow isNil ) . - - window := uiManager edit: '"MorphicUIBugTest run: #openWorkspaceTest"' label: myLabel. - foundWindow := self findWindowInWorldLabeled: myLabel . - - cases := Array with: foundWindow . "For teardown." - self assert: ( window == foundWindow ) .! Item was removed: - ----- Method: MorphicUIManagerTest>>testShowAllBinParts (in category 'tests') ----- - testShowAllBinParts - "self new testShowAllBinParts" - "MorphicUIBugTest run: #testShowAllBinParts" - - | tool | - self - shouldnt: [tool := ObjectsTool initializedInstance showAll openCenteredInWorld] - raise: Error. - - cases := Array with: tool.! Item was removed: - ----- Method: MorphicUIManagerTest>>testUIManagerNoAcceptInitially (in category 'tests') ----- - testUIManagerNoAcceptInitially - "Ensure that UIManager does not invoke the accept: action initially." - - | accepted window | - accepted := false. - window := uiManager edit: Text new label: 'Test' accept: [:val| accepted := true]. - window delete. - self deny: accepted.! Item was removed: - TestCase subclass: #NewParagraphTest - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'MorphicTests-Text Support'! Item was removed: - ----- Method: NewParagraphTest>>test01RecomposeWithTrailingLineBreak (in category 'tests') ----- - test01RecomposeWithTrailingLineBreak - - | text para | - text := 'a\b\c\' withCRs asText. - para := NewParagraph new. - - para compose: text style: TextStyle default from: 1 in: (0 at 0 extent: 9999 at 999). - self assert: 4 equals: para lines size. - - text replaceFrom: 1 to: 0 with: 'x' asText. - para recomposeFrom: 1 to: 1 delta: 1. - self assert: 4 equals: para lines size. "Keep trailing null-line" - - text replaceFrom: 8 to: 7 with: 'x' asText. - para recomposeFrom: 8 to: 8 delta: 1. - self assert: 4 equals: para lines size. "No trailing null-line"! Item was removed: - ClassTestCase subclass: #PasteUpMorphTest - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'MorphicTests-Worlds'! - - !PasteUpMorphTest commentStamp: '<historical>' prior: 0! - I am a TestCase for PasteUpMorph.! Item was removed: - ----- 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.! Item was removed: - ----- 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.! Item was removed: - ----- 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! Item was removed: - ----- Method: PasteUpMorphTest>>testPlayWithMe1Romoval (in category 'tests') ----- - testPlayWithMe1Romoval - "A trivial test for checking that PlayWithMe classes are all removed" - self deny: ( Smalltalk hasClassNamed: 'PlayWithMe1' ) .! Item was removed: - TestCase subclass: #PluggableTextMorphTest - instanceVariableNames: 'widget model' - classVariableNames: '' - poolDictionaries: '' - category: 'MorphicTests-Widgets'! Item was removed: - ----- Method: PluggableTextMorphTest>>setUp (in category 'running') ----- - setUp - - super setUp. - - model := ValueHolder new contents: ''; yourself. - widget := PluggableTextMorph on: model text: #contents accept: #contents:.! Item was removed: - ----- Method: PluggableTextMorphTest>>test01TextChangeInModel (in category 'tests') ----- - test01TextChangeInModel - - model contents: 'Hello, World!!'. - self assert: model contents equals: widget text asString.! Item was removed: - ----- 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.! Item was removed: - ----- 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.! Item was removed: - ----- 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.! Item was removed: - 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! Item was removed: - ----- Method: PolygonMorphTest>>testBoundsBug1035 (in category 'tests') ----- - 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). - ! Item was removed: - ----- Method: PolygonMorphTest>>testContainsPoint (in category 'tests') ----- - testContainsPoint - "See http://forum.world.st/Bug-in-PolygonMorph-gt-gt-filledForm-td5112218.html" - - | polygon offset | - offset := 100 at 100. - polygon := PolygonMorph new - borderWidth: 0; - setVertices: {0 at 0. 200 at 0. 200 at 200. 0@ 200} + offset; - yourself. - - 0 to: polygon width - 1 do: [:x | - 0 to: polygon height - 1 do: [:y | - self assert: (polygon containsPoint: (x at y) + offset)]].! Item was removed: - 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.! Item was removed: - ----- Method: RenderBugz>>long (in category 'utility') ----- - long - "return time limit in milliseconds for tests" - ^4! Item was removed: - ----- Method: RenderBugz>>setUp (in category 'running') ----- - setUp - "default. tests will add morphs to list. Teardown will delete." - cases := #().! Item was removed: - ----- 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 . - ! Item was removed: - ----- Method: RenderBugz>>tearDown (in category 'running') ----- - tearDown - "default. tests will add morphs to list. Teardown will delete." - cases do: [ :each | each delete ].! Item was removed: - ----- 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 - ! Item was removed: - ----- 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 - ! Item was removed: - ----- 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 - ! Item was removed: - ----- 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 - ! Item was removed: - ----- 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 - ! Item was removed: - SliderTest subclass: #ScrollBarTest - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'MorphicTests-Widgets'! Item was removed: - ----- Method: ScrollBarTest class>>shouldInheritSelectors (in category 'testing') ----- - shouldInheritSelectors - ^ true! Item was removed: - ----- Method: ScrollBarTest>>subjectClass (in category 'running') ----- - subjectClass - - ^ ScrollBar! Item was removed: - ScrollPaneTest subclass: #ScrollPaneLeftBarTest - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'MorphicTests-Widgets'! Item was removed: - ----- Method: ScrollPaneLeftBarTest class>>shouldInheritSelectors (in category 'testing') ----- - shouldInheritSelectors - - ^ true! Item was removed: - ----- Method: ScrollPaneLeftBarTest>>setUp (in category 'running') ----- - setUp - - super setUp. - sut scrollBarOnLeft: true.! Item was removed: - ScrollPaneTest subclass: #ScrollPaneRetractableBarsTest - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'MorphicTests-Widgets'! Item was removed: - ----- Method: ScrollPaneRetractableBarsTest class>>shouldInheritSelectors (in category 'testing') ----- - shouldInheritSelectors - - ^ true! Item was removed: - ----- Method: ScrollPaneRetractableBarsTest>>setUp (in category 'running') ----- - setUp - - super setUp. - sut retractable: true.! Item was removed: - ----- 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.! Item was removed: - ----- 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.! Item was removed: - ----- 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.! Item was removed: - ----- 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.! Item was removed: - ----- Method: ScrollPaneRetractableBarsTest>>test10ShrinkWrapHorizontally (in category 'tests') ----- - test10ShrinkWrapHorizontally - - sut vResizing: #rigid. - sut hResizing: #shrinkWrap. - sut vScrollBarPolicy: #always. - - content extent: 300 at 300. - sut extent: 100 at 100. - - sut hScrollBarPolicy: #always. - self refresh. - self assert: 300 equals: content width. - self assert: content width equals: sut width. - - sut hScrollBarPolicy: #whenNeeded. - self refresh. - self assert: 300 equals: content width. - self assert: content width equals: sut width. - - content width: 450. - self refresh. - self assert: (sut right = sut vScrollBar left or: [sut left = sut vScrollBar right]).! Item was removed: - ----- Method: ScrollPaneRetractableBarsTest>>test11ShrinkWrapVertically (in category 'tests') ----- - test11ShrinkWrapVertically - - sut vResizing: #shrinkWrap. - sut hResizing: #rigid. - sut hScrollBarPolicy: #always. - - content extent: 300 at 300. - sut extent: 100 at 100. - - sut vScrollBarPolicy: #always. - self refresh. - self assert: 300 equals: content height. - self assert: content height equals: sut height. - - sut vScrollBarPolicy: #whenNeeded. - self refresh. - self assert: 300 equals: content height. - self assert: content height equals: sut height. - - content height: 450. - self refresh. - self assert: sut bottom equals: sut hScrollBar top.! Item was removed: - TestCase subclass: #ScrollPaneTest - instanceVariableNames: 'sut content' - classVariableNames: '' - poolDictionaries: '' - category: 'MorphicTests-Widgets'! Item was removed: - ----- Method: ScrollPaneTest>>refresh (in category 'running') ----- - refresh - - sut fullBounds. ! Item was removed: - ----- Method: ScrollPaneTest>>scrollToBottomRight (in category 'running') ----- - scrollToBottomRight - - sut hScrollBar setValue: sut hScrollBar maximumValue. - sut vScrollBar setValue: sut vScrollBar maximumValue.! Item was removed: - ----- Method: ScrollPaneTest>>scrollToTopLeft (in category 'running') ----- - scrollToTopLeft - - sut - hScrollBarValue: 0; - vScrollBarValue: 0; - setScrollDeltas.! Item was removed: - ----- 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!!" - hScrollBarPolicy: #whenNeeded; - vScrollBarPolicy: #whenNeeded. - content := Morph new. - sut scroller addMorph: content.! Item was removed: - ----- Method: ScrollPaneTest>>test00SetUp (in category 'tests') ----- - test00SetUp - - self assert: 100 at 100 equals: sut extent.! Item was removed: - ----- Method: ScrollPaneTest>>test01ScrollBarPolicyWhenNeeded (in category 'tests') ----- - test01ScrollBarPolicyWhenNeeded - - sut extent: 125 at 125. - - sut - hScrollBarPolicy: #whenNeeded; - vScrollBarPolicy: #whenNeeded. - - content extent: 100 at 100. - self refresh. - - self - deny: sut hIsScrollbarShowing; - deny: sut vIsScrollbarShowing. - - content extent: 125 at 125. - self refresh. - - self - deny: sut hIsScrollbarShowing; - deny: sut vIsScrollbarShowing. - - content extent: 150 at 150. - self refresh. - - self - assert: sut hIsScrollbarShowing; - assert: sut vIsScrollbarShowing. - - content extent: 125 at 125. - self refresh. - - self - deny: sut hIsScrollbarShowing; - deny: sut vIsScrollbarShowing.! Item was removed: - ----- 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.! Item was removed: - ----- 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.! Item was removed: - ----- 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. - ! Item was removed: - ----- 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.! Item was removed: - ----- 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. - ! Item was removed: - ----- 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.! Item was removed: - ----- 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.! Item was removed: - ----- 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. - ! Item was removed: - ----- Method: ScrollPaneTest>>test10ShrinkWrapHorizontally (in category 'tests') ----- - test10ShrinkWrapHorizontally - - sut vResizing: #rigid. - sut hResizing: #shrinkWrap. - sut vScrollBarPolicy: #always. - - content extent: 300 at 300. - sut extent: 100 at 100. - - sut hScrollBarPolicy: #always. - self refresh. - self assert: 300 equals: content width. - self assert: content width + sut scrollBarThickness equals: sut width. - - sut hScrollBarPolicy: #whenNeeded. - self refresh. - self assert: 300 equals: content width. - self assert: content width + sut scrollBarThickness equals: sut width. - - content width: 450. - self refresh. - self assert: (sut right = sut vScrollBar right or: [sut left = sut vScrollBar left]).! Item was removed: - ----- Method: ScrollPaneTest>>test11ShrinkWrapVertically (in category 'tests') ----- - test11ShrinkWrapVertically - - sut vResizing: #shrinkWrap. - sut hResizing: #rigid. - sut hScrollBarPolicy: #always. - - content extent: 300 at 300. - sut extent: 100 at 100. - - sut vScrollBarPolicy: #always. - self refresh. - self assert: 300 equals: content height. - self assert: content height + sut scrollBarThickness equals: sut height. - - sut vScrollBarPolicy: #whenNeeded. - self refresh. - self assert: 300 equals: content height. - self assert: content height + sut scrollBarThickness equals: sut height. - - content height: 450. - self refresh. - self assert: sut bottom equals: sut hScrollBar bottom.! Item was removed: - ClassTestCase subclass: #SimpleSwitchMorphTest - instanceVariableNames: 'testSwitch' - classVariableNames: '' - poolDictionaries: '' - category: 'MorphicTests-Widgets'! - - !SimpleSwitchMorphTest commentStamp: '<historical>' prior: 0! - I test the behavior of SimpleSwitchMorph! Item was removed: - ----- Method: SimpleSwitchMorphTest>>classToBeTested (in category 'accessing') ----- - classToBeTested - ^ SimpleSwitchMorph ! Item was removed: - ----- Method: SimpleSwitchMorphTest>>setUp (in category 'initialize-release') ----- - setUp - super setUp. - testSwitch := SimpleSwitchMorph new! Item was removed: - ----- Method: SimpleSwitchMorphTest>>testName (in category 'tests') ----- - testName - - self assert: testSwitch externalName = 'SimpleSwitch'! Item was removed: - ----- Method: SimpleSwitchMorphTest>>testState (in category 'tests') ----- - testState - self assert: testSwitch isOff. - self deny: testSwitch isOn. - testSwitch toggleState. - self assert: testSwitch isOn. - self deny: testSwitch isOff! Item was removed: - ----- Method: SimpleSwitchMorphTest>>testSwitching (in category 'tests') ----- - 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.! Item was removed: - TestCase subclass: #SliderTest - instanceVariableNames: 'sut' - classVariableNames: '' - poolDictionaries: '' - category: 'MorphicTests-Widgets'! Item was removed: - ----- 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.! Item was removed: - ----- Method: SliderTest>>subjectClass (in category 'running') ----- - subjectClass - - ^ Slider! Item was removed: - ----- Method: SliderTest>>test01Value (in category 'tests') ----- - test01Value - - self assert: 0.0 equals: sut value. - self assert: 0.0 equals: sut model contents.! Item was removed: - ----- 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.! Item was removed: - ----- 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. - ! Item was removed: - ----- 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.! Item was removed: - ----- 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.! Item was removed: - ----- 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.! Item was removed: - ----- Method: SliderTest>>test07Quantum (in category 'tests') ----- - test07Quantum - - sut maximumValue: 100. - sut quantum: 5. - - sut setValue: 23. - self assert: 25 equals: sut value.! Item was removed: - ----- Method: SliderTest>>test08MinEqualsMax (in category 'tests') ----- - test08MinEqualsMax - - sut - maximumValue: 50; - minimumValue: 50. - - self assert: 50 equals: sut value.! Item was removed: - ----- 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.! Item was removed: - 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 - ! Item was removed: - ----- Method: StickynessBugz>>testForTiltedStickyness (in category 'tests') ----- - 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 - - - - - - - ! Item was removed: - TestCase subclass: #SystemWindowTest - instanceVariableNames: 'sut' - classVariableNames: '' - poolDictionaries: '' - category: 'MorphicTests-Widgets'! Item was removed: - ----- Method: SystemWindowTest>>setUp (in category 'running') ----- - setUp - - super setUp. - sut := SystemWindow new.! Item was removed: - ----- Method: SystemWindowTest>>test01Culling (in category 'tests') ----- - test01Culling - "Check whether system windows follow the specs for occlusion culling. See WorldState >> #drawWorld:submorphs:invalidAreasOn: and Morph >> #areasRemainingToFill:." - - sut extent: 500 at 500; fullBounds. - sut cornerStyle: #square. - - self assert: (sut areasRemainingToFill: (20 at 20 center: sut center)) isEmpty. - self assert: (sut areasRemainingToFill: sut bounds) isEmpty. - self assert: (sut areasRemainingToFill: sut outerBounds) isEmpty. - self assert: (sut areasRemainingToFill: sut fullBounds) isEmpty.! Item was removed: - TestCase subclass: #TableLayoutTest - instanceVariableNames: 'container reset' - classVariableNames: '' - poolDictionaries: '' - category: 'MorphicTests-Layouts'! Item was removed: - ----- Method: TableLayoutTest>>defaultFont (in category 'helper') ----- - defaultFont - - ^ TextStyle defaultFont! Item was removed: - ----- Method: TableLayoutTest>>defaultMorphSize (in category 'helper') ----- - defaultMorphSize - - ^ Morph new extent! Item was removed: - ----- Method: TableLayoutTest>>ensureLayout: (in category 'helper') ----- - ensureLayout: aMorph - - ^ aMorph - fullBounds; - yourself! Item was removed: - ----- Method: TableLayoutTest>>expectedFailures (in category 'failures') ----- - expectedFailures - - ^ #(testDialogMinimalExtent)! Item was removed: - ----- Method: TableLayoutTest>>newContainer (in category 'helper') ----- - newContainer - - ^ Morph new - layoutPolicy: TableLayout new; - vResizing: #shrinkWrap; - hResizing: #shrinkWrap; - listDirection: #leftToRight; - color: self randomColor! Item was removed: - ----- Method: TableLayoutTest>>newMorph (in category 'helper') ----- - newMorph - - ^ Morph new - layoutPolicy: TableLayout new; - color: self randomColor! Item was removed: - ----- Method: TableLayoutTest>>randomColor (in category 'helper') ----- - randomColor - - ^ Color h: 360 atRandom s: 1 v: 1! Item was removed: - ----- Method: TableLayoutTest>>repeat:times: (in category 'helper') ----- - repeat: aNumber times: aString - - ^ String streamContents: [:stream | - aNumber timesRepeat: [stream nextPutAll: aString]]! Item was removed: - ----- Method: TableLayoutTest>>setUp (in category 'running') ----- - setUp - - super setUp. - reset := { - ([:enable | [self useRetractableScrollBars: enable]] - value: self useRetractableScrollBars). - ([:previous | [Preferences setFlag: #alwaysShowVScrollbar toValue: previous]] - value: (Preferences valueOfFlag: #alwaysShowVScrollbar)) - }. - self useRetractableScrollBars: false. - Preferences setFlag: #alwaysShowVScrollbar toValue: false.! Item was removed: - ----- Method: TableLayoutTest>>tearDown (in category 'running') ----- - tearDown - - reset do: #value. - super tearDown.! Item was removed: - ----- Method: TableLayoutTest>>testBrowser (in category 'tests - example layouts') ----- - testBrowser - " replicate the layout used by the system browser with a table layout " - - | buttons | - buttons := #('browse' 'senders' 'implementors' 'versions' 'inheritance' 'hierarchy' 'vars' 'source') collect: [:label | - self newMorph - hResizing: #spaceFill; - vResizing: #shrinkWrap; - wrapCentering: #center; - layoutPolicy: TableLayout new; - layoutInset: 8; - addMorph: (StringMorph new contents: label)]. - - container := self newContainer - listDirection: #topToBottom; - layoutInset: 8; - cellGap: 8; - addMorphBack: (self newContainer - cellGap: 8; - listDirection: #leftToRight; - hResizing: #spaceFill; - vResizing: #spaceFill; - minimumHeight: 30; - addMorphBack: (self newMorph hResizing: #spaceFill; vResizing: #spaceFill); - addMorphBack: (self newMorph hResizing: #spaceFill; vResizing: #spaceFill); - addMorphBack: (self newMorph hResizing: #spaceFill; vResizing: #spaceFill); - addMorphBack: (self newMorph hResizing: #spaceFill; vResizing: #spaceFill)); - addMorphBack: (self newContainer - vResizing: #shrinkWrap; - hResizing: #spaceFill; - cellGap: 2; - addAllMorphsBack: buttons); - addMorphBack: (self newMorph - minimumHeight: 100; - hResizing: #spaceFill; - vResizing: #spaceFill). - - container extent: 0 @ 0. - "container openInHand." - - self ensureLayout: container. - self assert: 100 + 30 + self defaultFont lineGridForMorphs + (8 * 6) equals: container height! Item was removed: - ----- Method: TableLayoutTest>>testCellGap (in category 'tests') ----- - testCellGap - - | first gap second | - gap := 13. - container := self newContainer - cellGap: gap; - addMorphBack: (first := self newMorph); - addMorphBack: (second := self newMorph). - - container listDirection: #leftToRight. - self ensureLayout: container. - self assert: (self defaultMorphSize x * 2 + gap) @ self defaultMorphSize y equals: container extent. - self assert: (0 @ 0 extent: first extent) equals: first bounds. - self assert: (first width + gap @ 0 extent: second extent) equals: second bounds. - - container listDirection: #topToBottom. - self ensureLayout: container. - self assert: self defaultMorphSize x @ (self defaultMorphSize y * 2 + gap) equals: container extent. - self assert: (0 @ 0 extent: first extent) equals: first bounds. - self assert: (0 @ (first height + gap) extent: second extent) equals: second bounds. - - container listDirection: #rightToLeft. - self ensureLayout: container. - " changing listDirection here moves our container in the world, reset for easier assertions " - container position: 0 @ 0. - - self assert: (self defaultMorphSize x * 2 + gap) @ self defaultMorphSize y equals: container extent. - self assert: (0 @ 0 extent: second extent) equals: second bounds. - self assert: (second width + gap @ 0 extent: first extent) equals: first bounds. - - container listDirection: #bottomToTop. - self ensureLayout: container. - container position: 0 @ 0. - self assert: self defaultMorphSize x @ (self defaultMorphSize y * 2 + gap) equals: container extent. - self assert: (0 @ 0 extent: second extent) equals: second bounds. - self assert: (0 @ (second height + gap) extent: first extent) equals: first bounds! Item was removed: - ----- Method: TableLayoutTest>>testCellInset (in category 'tests') ----- - testCellInset - - | first second inset | - container := self newContainer - addMorphBack: (first := self newMorph); - addMorphBack: (second := self newMorph). - - inset := 13. - self ensureLayout: (container cellInset: inset). - self assert: (self defaultMorphSize x * 2 + (inset * 4)) @ (self defaultMorphSize y + (inset * 2)) equals: container extent. - - inset := Rectangle left: 13 right: 7 top: 3 bottom: 17. - self ensureLayout: (container cellInset: inset). - self assert: (self defaultMorphSize x * 2 + (inset left + inset right * 2)) @ (self defaultMorphSize y + (inset top + inset right * 2)) equals: container extent. - - inset := 7 @ 13. - self ensureLayout: (container cellInset: inset). - self assert: (self defaultMorphSize x * 2) + (inset x * 2 * 2) @ (self defaultMorphSize y + (inset y * 2)) equals: container extent! Item was removed: - ----- Method: TableLayoutTest>>testCheckBoxGroup (in category 'tests - example layouts') ----- - testCheckBoxGroup - - | group groupContents labels boxHeight | - labels := Dictionary new. - group := self newContainer - hResizing: #shrinkWrap; - vResizing: #shrinkWrap; - layoutPolicy: TableLayout new; - listDirection: #topToBottom; - layoutInset: 0; - cellPositioning: #topLeft; - borderStyle: (SimpleBorder color: Color black width: 2); - yourself. - group addMorphBack: (labels at: #groupLabel put: 'Favorite Ice Cream' asMorph). - - groupContents := self newContainer - hResizing: #shrinkWrap; - vResizing: #shrinkWrap; - layoutPolicy: TableLayout new; - listDirection: #topToBottom; - cellGap: 0; - cellPositioning: #topLeft; - yourself. - group addMorphBack: groupContents. - - boxHeight := 16. - #('Vanilla' 'Chocolate') withIndexDo: [:label :index | - | checkBox | - checkBox := self newContainer - hResizing: #shrinkWrap; - vResizing: #shrinkWrap; - layoutPolicy: TableLayout new; - listDirection: #rightToLeft; - yourself. - checkBox - addMorphBack: (labels at: (#box, index asString) asSymbol put: label asMorph); - addMorphBack: (self newMorph extent: 16 at boxHeight; borderColor: Color black; borderWidth: 2). - groupContents addMorphBack: checkBox]. - - self ensureLayout: group. - self - assert: (labels at: #groupLabel) width + (group borderWidth * 2) - equals: group width. - self - assert: (labels at: #groupLabel) height - + ((labels at: #box1) height max: boxHeight) - + ((labels at: #box2) height max: boxHeight) - + (group borderWidth * 2) - equals: group height.! Item was removed: - ----- Method: TableLayoutTest>>testDialog (in category 'tests - example layouts') ----- - testDialog - " construct a typical yes/no confirm dialog. - - the test itself is currently expected to fail, as we do not support minimum extent that is derived from layout for rigid containers " - - | contentLabel font spacing | - spacing := 8. - container := self newContainer - listDirection: #topToBottom; - hResizing: #rigid; - cellGap: spacing; - layoutInset: (Rectangle left: 0 right: 0 top: 0 bottom: spacing); - addMorphBack: (self newContainer - cellGap: spacing; - hResizing: #spaceFill; - layoutInset: spacing; - addMorphBack: (self newMorph extent: 16 asPoint); - addMorphBack: (TextMorph new contents: 'Please Confirm'; hResizing: #spaceFill; centered); - addMorphBack: (self newMorph extent: 16 asPoint)); - addMorphBack: (contentLabel := TextMorph new margins: spacing @ 0; vResizing: #shrinkWrap; hResizing: #spaceFill); - addMorphBack: (self newContainer - cellGap: spacing; - addMorphBack: (self newMorph extent: 50 @ 26); - addMorphBack: (self newMorph extent: 50 @ 26)). - "container openInHand." - - font := self defaultFont. - contentLabel contents: (self repeat: 80 times: 'a '). - - container width: (font widthOfString: contentLabel contents) + 2 + (spacing * 2). - self ensureLayout: container. - self assert: (font widthOfString: contentLabel contents) + 2 + (spacing * 2) equals: container width. - - container width: (font widthOfString: contentLabel contents) // 2. - self ensureLayout: container. - self assert: ((font widthOfString: contentLabel contents) // 2) equals: container width.! Item was removed: - ----- Method: TableLayoutTest>>testDialogMinimalExtent (in category 'tests - example layouts') ----- - testDialogMinimalExtent - "Like #testDialog, but tests for the minimal extent, too." - - self testDialog. - - " ensure we can't resize below our children's width " - container width: 0. - self ensureLayout: container. - self assert: container firstSubmorph width equals: container width.! Item was removed: - ----- Method: TableLayoutTest>>testDisableLayoutEmptyArrangement (in category 'tests') ----- - testDisableLayoutEmptyArrangement - - container := Morph new - layoutPolicy: TableLayout new; - listDirection: #rightToLeft; "... to not get into the layout's fast lane ..." - wrapCentering: #center; "... to actually trigger the bug ..." - addMorphBack: Morph new; - addMorphBack: Morph new; - yourself. - - container submorphsDo: [:m | m disableLayout: true]. - self shouldnt: [self ensureLayout: container] raise: Error.! Item was removed: - ----- Method: TableLayoutTest>>testInnerTopLeft (in category 'tests') ----- - testInnerTopLeft - "The morph that is layed out in the owner must be in the top-left corner, regardless of its resizing properties." - - | inner | - container := self newContainer - hResizing: #rigid; - vResizing: #rigid; - addMorphBack: (inner := self newMorph - layoutPolicy: nil; - addMorphBack: self newMorph; - yourself); - yourself. - - #(rigid shrinkWrap spaceFill) do: [:h | #(rigid shrinkWrap spaceFill) do: [:v | - inner hResizing: h; vResizing: v. - self ensureLayout: container. - self assert: container topLeft equals: inner topLeft]].! Item was removed: - ----- Method: TableLayoutTest>>testListCentering (in category 'tests') ----- - testListCentering - - | firstChild secondChild thirdChild | - container := self newContainer - hResizing: #rigid; - vResizing: #rigid; - listDirection: #topToBottom; - wrapCentering: #topLeft; - extent: 100 @ 200; - addMorphBack: (firstChild := self newMorph extent: 50 @ 50); - addMorphBack: (secondChild := self newMorph extent: 80 @ 50); - addMorphBack: (thirdChild := self newMorph extent: 50 @ 50). - - container listCentering: #topLeft. - self ensureLayout: container. - " 15 is (80 - 50) / 2, because of the wrapCentering we fill to the large child and then center " - self assert: 15 @ 0 equals: firstChild position. - self assert: 0 @ 50 equals: secondChild position. - self assert: 15 @ 100 equals: thirdChild position. - - container listCentering: #bottomRight. - self ensureLayout: container. - self assert: 15 @ 50 equals: firstChild position. - self assert: 0 @ 100 equals: secondChild position. - self assert: 15 @ 150 equals: thirdChild position. - - container listCentering: #justified. - self ensureLayout: container. - self assert: 15 @ 0 equals: firstChild position. - " center of the parent morph: " - self assert: 0 @ ((200 / 2) - (50 / 2)) equals: secondChild position. - self assert: 15 @ 150 equals: thirdChild position. - - container listCentering: #center. - self ensureLayout: container. - self assert: 15 @ 25 equals: firstChild position. - self assert: 0 @ ((200 / 2) - (50 / 2)) equals: secondChild position. - self assert: 15 @ 125 equals: thirdChild position! Item was removed: - ----- Method: TableLayoutTest>>testPluggableTextMorph (in category 'tests') ----- - testPluggableTextMorph - - | ptm ptmExtent | - ptmExtent := 100 @ (TextStyle defaultFont height * 3). - ptm := PluggableTextMorph new - extent: ptmExtent; - setText: 'Hello World!! Hello World!! Hello World!! Hello World!!'; - wrapFlag: true. - - container := self newContainer addMorphBack: ptm. - self ensureLayout: container. - self assert: ptmExtent equals: container extent. - - self assert: ptm vIsScrollbarShowing. - self deny: ptm hIsScrollbarShowing. - - "Make it a one-liner." - ptm wrapFlag: false. - self ensureLayout: container. - self deny: ptm vIsScrollbarShowing. - self assert: ptm hIsScrollbarShowing. - - "Make it a one-liner without the horizontal scrollbar." - ptm hideScrollBarsIndefinitely. - self ensureLayout: container. - self deny: ptm vIsScrollbarShowing. - self deny: ptm hIsScrollbarShowing. - ! Item was removed: - ----- Method: TableLayoutTest>>testPluggableTextMorphScrollBarNotNeeded (in category 'tests') ----- - testPluggableTextMorphScrollBarNotNeeded - "The entire test might fit if the scroll bar would only disappear..." - - | ptm | - ptm := PluggableTextMorph new - extent: 100 at 50; - setText: 'Hello World!! Hello World!! \\\ Hello World!! Hello World!!' withCRs. - container := self newContainer addMorphBack: ptm. - - "Make it fit exactly first." - ptm hResizing: #shrinkWrap; vResizing: #shrinkWrap. - self ensureLayout: container. - ptm hResizing: #rigid; vResizing: #rigid. - ptm wrapFlag: true. - - "No scrollbars required." - self ensureLayout: container. - self deny: ptm vIsScrollbarShowing. - - "It wraps immediately." - ptm width: ptm width - 5. - self ensureLayout: container. - self assert: ptm vIsScrollbarShowing. - - "No scrollbars required." - ptm width: ptm width + 5. - self ensureLayout: container. - self deny: ptm vIsScrollbarShowing.! Item was removed: - ----- Method: TableLayoutTest>>testPluggableTextMorphShrinkWrap (in category 'tests') ----- - testPluggableTextMorphShrinkWrap - - | ptm | - ptm := PluggableTextMorph new - extent: 100 at 50; - setText: 'Hello World!! Hello World!! \\\ Hello World!! Hello World!!' withCRs. - container := self newContainer addMorphBack: ptm. - - ptm wrapFlag: false. "for the inner text morph" - ptm hResizing: #shrinkWrap; vResizing: #shrinkWrap. "for the outer scroll pane" - self ensureLayout: container. - - self deny: ptm vIsScrollbarShowing. - self deny: ptm hIsScrollbarShowing. - self assert: ptm innerExtent equals: ptm textMorph extent.! Item was removed: - ----- Method: TableLayoutTest>>testScrollPaneBarUpdate (in category 'tests - scroll panes') ----- - testScrollPaneBarUpdate - - | child container | - container := ScrollPane new color: Color green; extent: 300 @ 300; showVScrollBarOnlyWhenNeeded; showHScrollBarOnlyWhenNeeded. - container scroller addMorphBack: (child := Morph new color: Color red; extent: 100 @ 100). - - self ensureLayout: container. - self assert: container hScrollBar owner isNil. - self assert: container vScrollBar owner isNil. - - child extent: 400 @ 100. - self ensureLayout: container. - self assert: container hScrollBar owner notNil. - self assert: container vScrollBar owner isNil. - - child extent: 400 @ 400. - self ensureLayout: container. - self assert: container hScrollBar owner notNil. - self assert: container hScrollBar owner notNil! Item was removed: - ----- Method: TableLayoutTest>>testScrollPaneShrinkWrap (in category 'tests') ----- - testScrollPaneShrinkWrap - - | scroll scrollContent | - container := self newContainer - vResizing: #rigid; - addMorphBack: (self newMorph extent: 50 @ 50); - addMorphBack: (scroll := ScrollPane new - hResizing: #shrinkWrap; - vResizing: #spaceFill; - showVScrollBarOnlyWhenNeeded; - hideHScrollBarIndefinitely). - - " shrinkWrap the horizontal axis but scroll vertically " - scroll scroller - layoutPolicy: TableLayout new; - addMorphBack: (scrollContent := self newMorph extent: 200 @ 500). - - container extent: 1 @ 300. - self ensureLayout: container. - self assert: container left = (container layoutChanged; fullBounds; left). "Do not be jumpy." - self assert: (200 + scroll scrollBarThickness + scroll borderWidth) @ 300 equals: scroll extent. - - scrollContent extent: 300 @ 500. - self ensureLayout: container. - self assert: (300 + scroll scrollBarThickness + scroll borderWidth) @ 300 equals: scroll extent! Item was removed: - ----- Method: TableLayoutTest>>testScrollerFill (in category 'tests - scroll panes') ----- - testScrollerFill - "A scroll pane's scroller (i.e., the transform morph) has always #spaceFill behavior within the scroll pane's layout. Thus, submorphs (here: title and content) can themselves be #spaceFill. Embed a text morph to check height-for-width compatibility." - - | content title | - container := ScrollPane new. - - container scroller - layoutPolicy: TableLayout new; - color: Color random; - addMorphBack: (title := TextMorph new hResizing: #spaceFill; contents: 'Here comes an interesting title'); - addMorphBack: (content := self newMorph extent: 400 @ 400; hResizing: #spaceFill). - container extent: 50 @ 50. "Pick an extent so that the title must wrap!!" - self ensureLayout: container. - - "container openInHand." - - container extent: 500 @ 500. - self ensureLayout: container. - self assert: 500 @ 500 equals: container extent. - self assert: 500 - (container borderWidth * 2) @ 400 equals: content extent. - - container extent: 300 @ 300. - self ensureLayout: container. - self assert: 300 @ 300 equals: container extent. - self assert: 300 - container borderWidth - container scrollBarThickness @ 400 equals: content extent! Item was removed: - ----- Method: TableLayoutTest>>testScrollerFillWithContainer (in category 'tests - scroll panes') ----- - testScrollerFillWithContainer - "A scroll pane's scroller (i.e., the transform morph) has always #spaceFill behavior within the scroll pane's layout. Thus, submorphs (here: title and content) can themselves be #spaceFill. Embed a text morph to check height-for-width compatibility. Add an extra container between scroller and title/content." - - | content title | - container := ScrollPane new. - - container scroller - layoutPolicy: TableLayout new; - addMorphBack: (self newContainer - hResizing: #spaceFill; - vResizing: #spaceFill; - listDirection: #topToBottom; - addMorphBack: (title := TextMorph new hResizing: #spaceFill; contents: 'Here comes an interesting title'); - addMorphBack: (content := self newMorph extent: 400 @ 400; hResizing: #spaceFill)). - container extent: 50 @ 50. "Pick an extent so that the title must wrap!!" - self ensureLayout: container. - - "container openInHand." - - container extent: 500 @ 500. - self ensureLayout: container. - self assert: 500 @ 500 equals: container extent. - self assert: 500 - (container borderWidth * 2) @ 400 equals: content extent. - - container extent: 300 @ 300. - self ensureLayout: container. - self assert: 300 @ 300 equals: container extent. - self assert: 300 - container borderWidth - container scrollBarThickness @ 400 equals: content extent! Item was removed: - ----- Method: TableLayoutTest>>testShrinkWrapAndSpaceFill (in category 'tests') ----- - testShrinkWrapAndSpaceFill - - | shrinkWrapped spaceFilled | - container := self newContainer - addMorphBack: (spaceFilled := self newMorph hResizing: #spaceFill; vResizing: #spaceFill); - addMorphBack: (shrinkWrapped := self newMorph hResizing: #shrinkWrap; vResizing: #shrinkWrap). - - " minimal size " - self ensureLayout: container. - self assert: 1 equals: spaceFilled width. - self assert: self defaultMorphSize equals: shrinkWrapped extent. - - " scale up horizontally " - self ensureLayout: (container extent: self defaultMorphSize x * 2 @ self defaultMorphSize y). - self assert: self defaultMorphSize equals: spaceFilled extent. - self assert: self defaultMorphSize equals: shrinkWrapped extent. - - " scale up in horizontally and vertically " - self ensureLayout: (container extent: self defaultMorphSize * 2). - self assert: self defaultMorphSize x @ (self defaultMorphSize y * 2) equals: spaceFilled extent. - self assert: self defaultMorphSize equals: shrinkWrapped extent! Item was removed: - ----- Method: TableLayoutTest>>testShrinkWrapIssue (in category 'tests') ----- - testShrinkWrapIssue - "A container that has no layout policy does MUST trigger layout computation for its submorphs in time." - - | container inner item1 item2 | - container := Morph new - hResizing: #shrinkWrap; - vResizing: #shrinkWrap; - yourself. - inner := self newContainer - listDirection: #topToBottom; - yourself. - container addMorphBack: inner. - - inner - addMorphBack: (item1 := self newMorph extent: 50 at 50; yourself); - addMorphBack: (item2 := self newMorph extent: 50 at 50; yourself). - - self ensureLayout: container. - self assert: 50 at 100 equals: container extent. - - item1 width: 100. - item2 width: 200. - self ensureLayout: container. - self assert: 200 at 100 equals: container extent.! Item was removed: - ----- Method: TableLayoutTest>>testShrinkWrapScrollPaneAlwaysShowBars (in category 'tests') ----- - testShrinkWrapScrollPaneAlwaysShowBars - - | scroll scrollContent | - container := self newContainer - vResizing: #shrinkWrap; - hResizing: #shrinkWrap; - addMorphBack: (scroll := ScrollPane new - hResizing: #shrinkWrap; - vResizing: #shrinkWrap; - alwaysShowHScrollBar; - alwaysShowVScrollBar). - - scroll scroller - layoutPolicy: TableLayout new; - addMorphBack: (scrollContent := self newMorph extent: 300 @ 300). - - self ensureLayout: container. - self assert: (300 @ 300) + scroll scrollBarThickness + scroll borderWidth equals: container extent! Item was removed: - ----- Method: TableLayoutTest>>testSidebarAndScrollingView (in category 'tests - example layouts') ----- - testSidebarAndScrollingView - " construct a container that has a fixed size sidebar on the left and a scrolling window that adapts flexibly to the container's size " - - | scrolling sidebar content title | - container := self newContainer - addMorphBack: (sidebar := self newMorph width: 200; hResizing: #rigid; vResizing: #spaceFill); - addMorphBack: (scrolling := ScrollPane new hResizing: #spaceFill; vResizing: #spaceFill). - - scrolling scroller - layoutPolicy: TableLayout new; - addMorphBack: (self newContainer - hResizing: #spaceFill; - vResizing: #spaceFill; - listDirection: #topToBottom; - addMorphBack: (title := TextMorph new hResizing: #spaceFill; contents: 'Here comes a title'); - addMorphBack: (content := self newMorph extent: 400 @ 400; hResizing: #spaceFill)). - self ensureLayout: container. - - "container openInHand." - - container extent: 500 @ 500. - self ensureLayout: container. - self assert: 200 @ 500 equals: sidebar extent. - self assert: 300 @ 500 equals: scrolling extent. - self assert: 300 - (scrolling borderWidth * 2) @ 400 equals: content extent. - - container extent: 300 @ 300. - self ensureLayout: container. - self assert: 200 @ 300 equals: sidebar extent. - self assert: 100 @ 300 equals: scrolling extent. - self assert: 100 - scrolling borderWidth - scrolling scrollBarThickness @ 400 equals: content extent! Item was removed: - ----- Method: TableLayoutTest>>testTwoTextMorphsHorizontal (in category 'tests') ----- - testTwoTextMorphsHorizontal - - | str1 str2 label2 label1 heightAt200 | - str1 := 'abc def'. - str2 := 'tzu ghj qwe'. - container := self newContainer - hResizing: #spaceFill; - vResizing: #shrinkWrap; - addMorphBack: (label1 := TextMorph new contents: str1; wrapFlag: true; hResizing: #spaceFill); - addMorphBack: (label2 := TextMorph new contents: str2; wrapFlag: true; hResizing: #spaceFill). - - container width: 200. - self ensureLayout: container. - heightAt200 := container height. - - self assert: 100 equals: label1 width. - self assert: 100 equals: label2 width. - - container width: 100. - self ensureLayout: container. - self assert: 50 equals: label1 width. - self assert: 50 equals: label2 width. - self assert: container height > heightAt200. - - container width: 10000. - self ensureLayout: container. - self assert: 5000 equals: label1 width. - self assert: 5000 equals: label2 width. - self assert: self defaultFont lineGrid equals: container height! Item was removed: - ----- Method: TableLayoutTest>>testTwoTextMorphsVertical (in category 'tests') ----- - testTwoTextMorphsVertical - - | str1 str2 label2 label1 font minWidth | - str1 := 'abc def'. - str2 := 'tzu ghj qwe'. - container := self newContainer - hResizing: #spaceFill; - vResizing: #shrinkWrap; - listDirection: #topToBottom; - addMorphBack: (label1 := TextMorph new contents: str1; wrapFlag: true; hResizing: #spaceFill); - addMorphBack: (label2 := TextMorph new contents: str2; wrapFlag: true; hResizing: #spaceFill). - - font := self defaultFont. - minWidth := label1 minWidth max: label2 minWidth. - - #(1 2 4 8) do: [:factor | - container width: factor * minWidth. - self ensureLayout: container. - self assert: container width equals: label1 width. - self assert: container width equals: label2 width. - self assert: 0 equals: container height \\ font lineGrid].! Item was removed: - ----- Method: TableLayoutTest>>testWrappingLayout (in category 'tests') ----- - testWrappingLayout - - container := self newContainer - hResizing: #rigid; - listDirection: #leftToRight; - wrapDirection: #none; - addMorphBack: (self newMorph extent: 50 @ 50); - addMorphBack: (self newMorph extent: 50 @ 50); - addMorphBack: (self newMorph extent: 50 @ 50). - - container width: 50. - self ensureLayout: container. - self assert: 50 @ 50 equals: container extent. - self assert: #(0 50 100) equals: (container submorphs collect: #left). - - container wrapDirection: #leftToRight. - self ensureLayout: container. - self assert: 50 @ 150 equals: container extent. - self assert: #(0 0 0) equals: (container submorphs collect: #left). - - container width: 125. - self ensureLayout: container. - self assert: 125 @ 100 equals: container extent. - self assert: #(0 50 0) equals: (container submorphs collect: #left)! Item was removed: - ----- Method: TableLayoutTest>>useRetractableScrollBars (in category 'running') ----- - useRetractableScrollBars - - ^ ScrollPane classPool at: #UseRetractableScrollBars! Item was removed: - ----- Method: TableLayoutTest>>useRetractableScrollBars: (in category 'running') ----- - useRetractableScrollBars: aBoolean - "Re-implemented to avoid triggering #allSubInstancesDo:." - - ScrollPane classPool at: #UseRetractableScrollBars put: aBoolean.! Item was removed: - 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! Item was removed: - ----- Method: TestInWorldMorph>>initialize (in category 'initialization') ----- - initialize - super initialize. - outOfWorldCount := intoWorldCount := 0.! Item was removed: - ----- Method: TestInWorldMorph>>intoWorld: (in category 'accessing') ----- - intoWorld: aWorld - aWorld ifNil:[^self]. - super intoWorld: aWorld. - intoWorldCount := intoWorldCount + 1. - ! Item was removed: - ----- Method: TestInWorldMorph>>intoWorldCount (in category 'accessing') ----- - intoWorldCount - ^intoWorldCount! Item was removed: - ----- Method: TestInWorldMorph>>outOfWorld: (in category 'accessing') ----- - outOfWorld: aWorld - aWorld ifNil:[^self]. - super outOfWorld: aWorld. - outOfWorldCount := outOfWorldCount + 1. - ! Item was removed: - ----- Method: TestInWorldMorph>>outOfWorldCount (in category 'accessing') ----- - outOfWorldCount - ^outOfWorldCount! Item was removed: - TestCase subclass: #TextAnchorTest - instanceVariableNames: 'anchoredMorph anchorAttribute font text textMorph' - classVariableNames: '' - poolDictionaries: '' - category: 'MorphicTests-Text Support'! Item was removed: - ----- Method: TextAnchorTest>>after:paddingChangesTo: (in category 'utility') ----- - after: aBlock paddingChangesTo: assertBlock - - anchoredMorph := TextAnchorTestMorph new. - anchorAttribute anchoredMorph: anchoredMorph. - aBlock value. - self prepareTextMorph. - assertBlock value: (textMorph paragraph lines first). ! Item was removed: - ----- Method: TextAnchorTest>>expectedFailures (in category 'failures') ----- - expectedFailures - - ^ #(testResizeAnchoredMorph)! Item was removed: - ----- Method: TextAnchorTest>>prepareTextMorph (in category 'utility') ----- - prepareTextMorph - - textMorph := text asMorph. - textMorph font: font. - self refreshTextMorph.! Item was removed: - ----- Method: TextAnchorTest>>refreshTextMorph (in category 'utility') ----- - refreshTextMorph - - textMorph imageForm. - "textMorph fullBounds. --- not yet working."! Item was removed: - ----- Method: TextAnchorTest>>setUp (in category 'running') ----- - setUp - - super setUp. - anchoredMorph := TextAnchorTestMorph new. - anchorAttribute := TextAnchor new anchoredMorph: anchoredMorph. - text := Text streamContents: [:stream | - stream - nextPutAll: 'Here is a contrived example '; - nextPutAll: (Text - string: Character startOfHeader asString - attributes: { - anchorAttribute. - TextColor color: Color transparent}); - nextPutAll: ' whose morph is in the center.' ]. - font := TextStyle defaultFont. - self prepareTextMorph.! Item was removed: - ----- Method: TextAnchorTest>>testBeginWithAnAnchor (in category 'tests') ----- - testBeginWithAnAnchor - - text := Text streamContents: [:stream | - stream - nextPutAll: (Text - string: Character startOfHeader asString - attributes: { - anchorAttribute. - TextColor color: Color transparent}) ; - nextPutAll: ' should be able to begin with an embedded object. ']. - self prepareTextMorph. - self - assert: (anchoredMorph ownerChain includes: textMorph); - assert: anchoredMorph topLeft >= textMorph topLeft.! Item was removed: - ----- Method: TextAnchorTest>>testHavingADocumentAnchorAndRelativeTextAnchorPosition (in category 'tests') ----- - testHavingADocumentAnchorAndRelativeTextAnchorPosition - - anchoredMorph := Morph new. - anchoredMorph textAnchorProperties - positionInDocument: 20 @ 10; - anchorLayout: #document. - anchorAttribute anchoredMorph: anchoredMorph. - self prepareTextMorph. - - self - assert: (anchoredMorph ownerChain includes: textMorph); - assert: anchoredMorph topLeft >= textMorph topLeft; - assert: anchoredMorph top > textMorph top! Item was removed: - ----- Method: TextAnchorTest>>testHavingADocumentAnchorShouldNotAffectTheLineHeight (in category 'tests') ----- - testHavingADocumentAnchorShouldNotAffectTheLineHeight - - | firstLine | - anchoredMorph := Morph new. - anchoredMorph height: font height * 2. - anchoredMorph textAnchorProperties - positionInDocument: 20 @ 10; - anchorLayout: #document. - anchorAttribute anchoredMorph: anchoredMorph. - self prepareTextMorph. - - firstLine := textMorph paragraph lines first. - self - assert: firstLine lineHeight < anchoredMorph height - description: '#document layouted anchor should not affect line height'. - ! Item was removed: - ----- Method: TextAnchorTest>>testHavingAMultilineDocumentAnchorAndRelativeTextAnchorPosition (in category 'tests') ----- - testHavingAMultilineDocumentAnchorAndRelativeTextAnchorPosition - - | secondLine | - text := Text streamContents: [ :stream | - stream - nextPutAll: 'Example with more than one line. - Here is an example '; - nextPutAll: (Text - string: Character startOfHeader asString - attributes: {anchorAttribute}); - nextPutAll: ' without a morph in the center.' ]. - anchoredMorph := Morph new - height: 50; - yourself. - anchoredMorph textAnchorProperties - positionInDocument: 20 @ 10; - anchorLayout: #document. - anchorAttribute anchoredMorph: anchoredMorph. - self prepareTextMorph. - - secondLine := textMorph paragraph lines second. - self - assert: (anchoredMorph ownerChain includes: textMorph); - assert: anchoredMorph topLeft >= textMorph topLeft; - assert: anchoredMorph top > textMorph top; - assert: anchoredMorph top > secondLine top.! Item was removed: - ----- Method: TextAnchorTest>>testHavingAnAnchorCanBeAlignedDifferently (in category 'tests') ----- - testHavingAnAnchorCanBeAlignedDifferently - - | line | - anchoredMorph textAnchorProperties verticalAlignment: #(top baseline). - anchoredMorph textAnchorProperties padding. 1. - self prepareTextMorph. - line := textMorph paragraph lines first. - self assert: anchoredMorph top = (line top + line baseline).! Item was removed: - ----- Method: TextAnchorTest>>testHavingAnAnchorInTheCenter (in category 'tests') ----- - testHavingAnAnchorInTheCenter - - self - assert: (anchoredMorph ownerChain includes: textMorph); - assert: anchoredMorph topLeft >= textMorph topLeft! Item was removed: - ----- Method: TextAnchorTest>>testHavingAnAnchorInTheCenterWithHorizontalPadding (in category 'tests') ----- - testHavingAnAnchorInTheCenterWithHorizontalPadding - - anchoredMorph textAnchorProperties padding. 30 at 0. - - self - assert: (anchoredMorph ownerChain includes: textMorph); - assert: (anchoredMorph topLeft >= textMorph topLeft)! Item was removed: - ----- Method: TextAnchorTest>>testHavingAnInlineAnchorAndRelativeTextAnchorPosition (in category 'tests') ----- - testHavingAnInlineAnchorAndRelativeTextAnchorPosition - - | positionWithRelativePosition positionWithoutRelativePosition | - anchoredMorph textAnchorProperties - positionInDocument: 20 at 10; - anchorLayout: #inline. - self refreshTextMorph. - positionWithRelativePosition := anchoredMorph topLeft. - - anchoredMorph textAnchorProperties positionInDocument: nil. - self refreshTextMorph. - positionWithoutRelativePosition := anchoredMorph topLeft. - - self assert: positionWithRelativePosition = positionWithoutRelativePosition! Item was removed: - ----- Method: TextAnchorTest>>testLayoutingSetsTheMorphPosition (in category 'tests') ----- - testLayoutingSetsTheMorphPosition - - anchoredMorph := Morph new. - anchoredMorph textAnchorProperties - anchorLayout: #inline. - anchorAttribute anchoredMorph: anchoredMorph. - self prepareTextMorph. - - textMorph position: 100 at 100. - - self assert: anchoredMorph position >= (100 at 100).! Item was removed: - ----- Method: TextAnchorTest>>testPaddingBottom (in category 'tests-padding') ----- - testPaddingBottom - - self - after: [ - anchoredMorph height: 20. - anchoredMorph textAnchorProperties verticalAlignment: #(bottom baseline). - anchoredMorph textAnchorProperties padding: (anchoredMorph textAnchorProperties padding bottom: 10)] - paddingChangesTo: [:line | - self assert: line baseline equals: anchoredMorph bottom + 10 ]! Item was removed: - ----- Method: TextAnchorTest>>testPaddingBottomAndBottom (in category 'tests-padding') ----- - testPaddingBottomAndBottom - - self - after: [ - anchoredMorph height: 20. - anchoredMorph textAnchorProperties verticalAlignment: #(bottom bottom). - anchoredMorph textAnchorProperties padding: (anchoredMorph textAnchorProperties padding bottom: 10)] - paddingChangesTo: [:line | - self assert: line baseline + font descent "= visual line bottom" equals: anchoredMorph bottom + 10 ]! Item was removed: - ----- Method: TextAnchorTest>>testPaddingBottomAndBottomWithConvenienceAlignment (in category 'tests-padding') ----- - testPaddingBottomAndBottomWithConvenienceAlignment - - self - after: [ - anchoredMorph height: 20. - anchoredMorph textAnchorProperties verticalAlignment: #bottom. - anchoredMorph textAnchorProperties padding: (anchoredMorph textAnchorProperties padding bottom: 10)] - paddingChangesTo: [:line | - self assert: line baseline + font descent "= visual line bottom" equals: anchoredMorph bottom + 10 ]! Item was removed: - ----- Method: TextAnchorTest>>testPaddingTop (in category 'tests-padding') ----- - testPaddingTop - - self - after: [ - anchoredMorph height: 20. - anchoredMorph textAnchorProperties verticalAlignment: #(top baseline). - anchoredMorph textAnchorProperties padding: (anchoredMorph textAnchorProperties padding top: 10)] - paddingChangesTo: [:line | - self assert: line baseline equals: anchoredMorph top - 10 ]! Item was removed: - ----- Method: TextAnchorTest>>testPaddingTopAndBottom (in category 'tests-padding') ----- - testPaddingTopAndBottom - - self - after: [ - anchoredMorph height: 30. - anchoredMorph textAnchorProperties verticalAlignment: #(#bottom #bottom). - anchoredMorph textAnchorProperties padding: (anchoredMorph textAnchorProperties padding bottom: 10). - anchoredMorph textAnchorProperties padding: (anchoredMorph textAnchorProperties padding top: 10).] - paddingChangesTo: [:line | - self assert: line baseline + font descent "= visual line bottom" equals: anchoredMorph bottom + 10. - self - deny: line baseline - font ascent "= visual line top" - equals: anchoredMorph top - 10 - description: 'We only apply padding to the morph position'.]! Item was removed: - ----- Method: TextAnchorTest>>testPaddingTopAndTop (in category 'tests-padding') ----- - testPaddingTopAndTop - - self - after: [ - anchoredMorph height: 20. - anchoredMorph textAnchorProperties verticalAlignment: #(top top). - anchoredMorph textAnchorProperties padding: (anchoredMorph textAnchorProperties padding top: 10)] - paddingChangesTo: [:line | - self assert: line baseline - font ascent "= visual line top" equals: anchoredMorph top - 10 ]! Item was removed: - ----- Method: TextAnchorTest>>testResizeAnchoredMorph (in category 'tests') ----- - testResizeAnchoredMorph - - | anchoredMorph priorExtent | - anchoredMorph := EllipseMorph new. - anchoredMorph extent: 50 at 50. - - text := 'Hello, World!!\-> X <-\Hello, World!!' withCRs asText - copyReplaceTokens: 'X' - with: (Text string: Character startOfHeader asString attribute: (TextAnchor new anchoredMorph: anchoredMorph)). - self prepareTextMorph. - - "Height is easy because morph is higher than the font." - priorExtent := textMorph extent. - anchoredMorph height: anchoredMorph height + 15. - self refreshTextMorph. - self assert: priorExtent y + 15 equals: textMorph height. - - "Width must be at least the text width." - anchoredMorph width: textMorph width. - self refreshTextMorph. - - priorExtent := textMorph extent. - anchoredMorph width: anchoredMorph width + 15. - self refreshTextMorph. - self assert: priorExtent x + 15 equals: textMorph width.! Item was removed: - ----- Method: TextAnchorTest>>testTextAnchorWithAForm (in category 'tests') ----- - testTextAnchorWithAForm - - anchorAttribute anchoredMorph: (Form dotOfSize: 60). - self prepareTextMorph. - - self - assert: textMorph paragraph lines first baseline > 20; - assert: textMorph submorphs isEmpty! Item was removed: - ----- Method: TextAnchorTest>>testTextAnchorWithMorphDefiningItsOwnBaseline (in category 'tests') ----- - testTextAnchorWithMorphDefiningItsOwnBaseline - - self - after: [ - anchoredMorph textAnchorProperties - morphBaselineGetter: #myBaseline; - verticalAlignment: #(baseline baseline). - anchoredMorph height: 20] - paddingChangesTo: [:line | - self assert: anchoredMorph top + 5 = line baseline ]! Item was removed: - ----- Method: TextAnchorTest>>testTextAnchorsDoNotBreakNormalRendering (in category 'tests') ----- - testTextAnchorsDoNotBreakNormalRendering - - text := Text streamContents: [ :stream | - stream - nextPutAll: 'Here is an example '; - nextPutAll: (Text - string: Character startOfHeader asString - attributes: {}); - nextPutAll: ' without a morph in the center. ' ]. - - [self - shouldnt: [ - self prepareTextMorph. - textMorph openInWorld] - raise: Error] ensure: [ textMorph delete ]! Item was removed: - ----- Method: TextAnchorTest>>testTwoTextAnchorsOneWithNestedInterval (in category 'tests') ----- - testTwoTextAnchorsOneWithNestedInterval - - | anchorAttribute2 anchoredMorph2 | - anchoredMorph2 := RectangleMorph new. - anchoredMorph height: 40. - anchoredMorph2 height: 40. - anchorAttribute2 := TextAnchor new anchoredMorph: anchoredMorph2. - text := Text streamContents: [:stream | - stream - nextPutAll: 'contrived '; - nextPutAll: Character startOfHeader asString asText; - nextPutAll: ' whose morph is in the center.'; - nextPutAll: Character startOfHeader asString asText; - nextPutAll: 'and some more text!!']. - text addAttribute: anchorAttribute from: 11 to: 61. - text addAttribute: anchorAttribute2 from: 42 to: 48. - textMorph hResizing: #shrinkWrap. - self prepareTextMorph. - - self assert: textMorph paragraph lines first lineHeight < 50. - self assert: anchoredMorph right < anchoredMorph2 left! Item was removed: - Morph subclass: #TextAnchorTestMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'MorphicTests-Text Support'! Item was removed: - ----- Method: TextAnchorTestMorph>>initialize (in category 'initialization') ----- - initialize - - super initialize. - self height: 20.! Item was removed: - ----- Method: TextAnchorTestMorph>>myBaseline (in category 'text-anchor') ----- - myBaseline - - ^ 5! Item was removed: - TestCase subclass: #TextEditorTest - instanceVariableNames: 'model widget' - classVariableNames: '' - poolDictionaries: '' - category: 'MorphicTests-Text Support'! Item was removed: - ----- Method: TextEditorTest>>editor (in category 'running') ----- - editor - - ^ widget textMorph editor! Item was removed: - ----- 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: ''.! Item was removed: - ----- 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.! Item was removed: - ----- 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.! Item was removed: - ----- Method: TextEditorTest>>test03DebugExpression (in category 'tests') ----- - test03DebugExpression - - self text: 'Morph new'. - self editor debugIt. - - self - assert: (model hasFlag: #expressionDebugged); - assert: (model result isKindOf: Morph).! Item was removed: - ----- Method: TextEditorTest>>test04PrintIt (in category 'tests') ----- - test04PrintIt - - self text: '3+4'. - self editor printIt. - - self - assert: (model hasFlag: #printed); - assert: '7' equals: model result.! Item was removed: - ----- 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).! Item was removed: - ----- 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).! Item was removed: - ----- 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.! Item was removed: - ----- 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.! Item was removed: - HashAndEqualsTestCase subclass: #TextLineTest - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'MorphicTests-Text Support'! Item was removed: - ----- Method: TextLineTest>>setUp (in category 'running') ----- - setUp - super setUp. - prototypes - add: (TextLine - start: 1 - stop: 50 - internalSpaces: 2 - paddingWidth: 1) ! Item was removed: - ClassTestCase subclass: #TextMorphTest - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'MorphicTests-Basic'! Item was removed: - ----- Method: TextMorphTest>>testInitialize (in category 'tests') ----- - testInitialize - "For now, just make sure initialization doesn't throw exception" - TextMorph initialize.! Item was removed: - TestCase subclass: #UnimplementedCallBugz - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'MorphicTests-Basic'! Item was removed: - ----- Method: UnimplementedCallBugz>>testPolyIntersect (in category 'tests') ----- - testPolyIntersect - "self run: #testPolyIntersect" - "This should not throw an exception." - PolygonMorph initializedInstance - intersects: ( Rectangle - center: Display center - extent: 100 asPoint ).! Item was removed: - TestCase subclass: #UserInputEventTests - instanceVariableNames: 'hand world reset' - classVariableNames: '' - poolDictionaries: '' - category: 'MorphicTests-Events'! Item was removed: - ----- Method: UserInputEventTests class>>isAbstract (in category 'testing') ----- - isAbstract - - ^ self == UserInputEventTests! Item was removed: - ----- Method: UserInputEventTests>>blueMouseDownAt: (in category 'support') ----- - blueMouseDownAt: point - - ^ MouseButtonEvent new - setType: #mouseDown - position: point - which: 2r000 "no change" - buttons: 2r001 "blue pressed" - hand: hand - stamp: Time millisecondClockValue! Item was removed: - ----- Method: UserInputEventTests>>blueMouseUpAt: (in category 'support') ----- - blueMouseUpAt: point - - ^ MouseButtonEvent new - setType: #mouseUp - position: point - which: 2r001 "blue changed" - buttons: 2r000 "nothing pressed" - hand: hand - stamp: Time millisecondClockValue! Item was removed: - ----- Method: UserInputEventTests>>checkEventOrder:forEvents:ignoreMouseOver: (in category 'support') ----- - checkEventOrder: someEventTypes forEvents: someEvents ignoreMouseOver: ignoreMouseOver - "Use this to verify the order of events" - - ((someEvents - select: [:ea | ea isMouseOver not or: [ignoreMouseOver not]]) - collect: [:ea | ea type]) - with: someEventTypes - do: [:t1 :t2 | self assert: t2 equals: t1]. - ! Item was removed: - ----- Method: UserInputEventTests>>keystroke:at: (in category 'support') ----- - keystroke: char at: point - - ^ KeyboardEvent new - setType: #keystroke - buttons: 0 "no modifiers" - position: point - keyValue: char asciiValue - hand: hand - stamp: Time millisecondClockValue! Item was removed: - ----- Method: UserInputEventTests>>redMouseDownAt: (in category 'support') ----- - redMouseDownAt: point - - ^ MouseButtonEvent new - setType: #mouseDown - position: point - which: 2r000 "no change" - buttons: 2r100 "red/left pressed" - hand: hand - stamp: Time millisecondClockValue! Item was removed: - ----- Method: UserInputEventTests>>redMouseUpAt: (in category 'support') ----- - redMouseUpAt: point - - ^ MouseButtonEvent new - setType: #mouseUp - position: point - which: 2r100 "red/left changed" - buttons: 2r000 "nothing pressed" - hand: hand - stamp: Time millisecondClockValue! Item was removed: - ----- Method: UserInputEventTests>>setUp (in category 'running') ----- - setUp - - super setUp. - - world := (PasteUpMorph newWorldForProject: nil) - extent: 300 at 200; - yourself. - - hand := HandMorphForEventTests new. - - world - removeHand: world firstHand; "the default hand" - addHand: hand. - - reset := { - [:enable | [Morph haloForAll: enable]] - value: Morph haloForAll - }. - Morph haloForAll: false.! Item was removed: - ----- Method: UserInputEventTests>>tearDown (in category 'running') ----- - tearDown - - hand showHardwareCursor: true. "Nasty side-effect" - reset do: #value. - super tearDown.! Item was removed: - ----- Method: UserInputEventTests>>yellowMouseDownAt: (in category 'support') ----- - yellowMouseDownAt: point - - ^ MouseButtonEvent new - setType: #mouseDown - position: point - which: 2r000 "no change" - buttons: 2r010 "yellow pressed" - hand: hand - stamp: Time millisecondClockValue! Item was removed: - ----- Method: UserInputEventTests>>yellowMouseUpAt: (in category 'support') ----- - yellowMouseUpAt: point - - ^ MouseButtonEvent new - setType: #mouseUp - position: point - which: 2r010 "yellow changed" - buttons: 2r000 "nothing pressed" - hand: hand - stamp: Time millisecondClockValue! Item was removed: - ClassTestCase subclass: #WorldStateTest - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'MorphicTests-Worlds'! Item was removed: - ----- Method: WorldStateTest>>testActiveVariablesObsoletion (in category 'tests') ----- - testActiveVariablesObsoletion - "Only the code for backwards compatibility may access the bindings for Active(World|Hand|Event)." - - #(ActiveWorld ActiveHand ActiveEvent) do: [:literal | - self - assert: 1 "Active(World|Hand|Event)Variable class >> #value:during:" - equals: (self systemNavigation allCallsOnClass: (self environment bindingOf: literal)) size].! Item was removed: - ----- Method: WorldStateTest>>testActiveVariablesRenamed (in category 'tests') ----- - testActiveVariablesRenamed - "Document the desire to rename Active(World|Hand|Event)Variable to Active(World|Hand|Event) after the Squeak 6.0 release." - - #(ActiveWorld ActiveHand ActiveEvent) do: [:className | - (SystemVersion current majorVersionNumber >= 6 - and: [SystemVersion current minorVersionNumber >= 1]) - ifTrue: [self assert: ((Smalltalk classNamed: className) includesBehavior: DynamicVariable)] - ifFalse: [self deny: (Smalltalk at: className) isBehavior] ].! Item was removed: - ----- 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. - Project current world doOneCycleNow. - self assert: firstWasRun. - self deny: secondWasRun. - self deny: thirdWasRun. - Project current world doOneCycleNow. - self assert: firstWasRun. - self assert: secondWasRun. - self assert: thirdWasRun. - ! Item was removed: - ----- Method: WorldStateTest>>testWorldVariableObsoletion (in category 'tests') ----- - testWorldVariableObsoletion - "Only the code for backwards compatibility may access the global World binding." - - self - assert: 0 - equals: (self systemNavigation allCallsOnClass: (self environment bindingOf: #World)) size.!
More information about the Squeak-dev mailing list |