The Trunk: MorphicTests-mt.37.mcz

Marcel Taeumel uploaded a new version of MorphicTests to project The Trunk:
http://source.squeak.org/trunk/MorphicTests-mt.37.mcz

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

Name: MorphicTests-mt.37
Author: mt
Time: 15 August 2016, 7:07:25.786171 pm
UUID: 96a07071-aad3-8544-8fe7-9ded73df9c18
Ancestors: MorphicTests-mt.36

Fixes Morphic tests.

=============== Diff against MorphicTests-mt.36 ===============

Item was changed:
  TestCase subclass: #MorphicUIManagerTest
+ instanceVariableNames: 'cases uiManager'
- instanceVariableNames: 'cases'
  classVariableNames: ''
  poolDictionaries: ''
  category: 'MorphicTests-ToolBuilder'!
 
  !MorphicUIManagerTest commentStamp: 'wiz 1/3/2007 13:57' prior: 0!
  A MorphicUIBugTest is a class for testing the shortcomings and repairs of the MorphicUI manager.
  .
 
  Instance Variables
  cases: <aCollection>
 
  cases
  - a list of morphs that may need to be deleted during teardown.
  the tests are expected to fill this list it starts out empty by default.
 
 
  !

Item was changed:
  ----- Method: MorphicUIManagerTest>>findWindowInWorldLabeled: (in category 'as yet unclassified') -----
  findWindowInWorldLabeled: aLabel
  "Look in the world and in the hand for windows. Yes, windows may spawn in the hand."
 
  ^ World submorphs, (World hands gather: [:hand | hand submorphs])
  detect: [ :each |
+ each isSystemWindow
- (each isKindOf: SystemWindow)
  and: [ each label = aLabel ] ]
  ifNone: [].!

Item was changed:
  ----- Method: MorphicUIManagerTest>>setUp (in category 'as yet unclassified') -----
  setUp
+ "default. tests will add morphs to list. Teardown will delete."
- "default. tests will add morphs to list. Teardown will delete."
 
+ cases := #().
+ uiManager := MorphicUIManager new.!
- cases := #() .!

Item was changed:
  ----- Method: MorphicUIManagerTest>>tearDown (in category 'as yet unclassified') -----
  tearDown
+ "default. tests will add morphs to list. Teardown will delete."
- "default. tests will add morphs to list. Teardown will delete."
 
+ cases do: [ :each | each delete ].!
- cases do: [ :each | each delete ] .!

Item was changed:
  ----- Method: MorphicUIManagerTest>>testOpenWorkspace (in category 'as yet unclassified') -----
  testOpenWorkspace
  "self new testOpenWorkspace"
  "MorphicUIBugTest run: #testOpenWorkspace"
 
  | window myLabel foundWindow myModel |
- self assert: Smalltalk isMorphic.
  myLabel := 'Workspace from SUnit test' .
  foundWindow := self findWindowInWorldLabeled: myLabel .
  self assert: foundWindow isNil.
+
+ window := uiManager edit: '"MorphicUIBugTest run: #openWorkspaceTest"'  label: myLabel.
- window := UIManager default edit: '"MorphicUIBugTest run: #openWorkspaceTest"'  label: myLabel.
- window := window.
  foundWindow := self findWindowInWorldLabeled: myLabel.
  cases := Array with: foundWindow . "For teardown."
+
  myModel := foundWindow submorphs detect: #isMorphicModel.
  self assert: myModel model class == Workspace.
+ self assert: foundWindow model class == Workspace.!
- self assert: foundWindow model class == Workspace.
- foundWindow delete!

Item was changed:
  ----- Method: MorphicUIManagerTest>>testOpenWorkspaceAns (in category 'as yet unclassified') -----
  testOpenWorkspaceAns
+ "Test if method opening a workspace answers the window opened"
- "Test if method opening a workspace answers the window opened"
 
+ "MorphicUIBugTest run: #testOpenWorkspaceAns"
- "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 ) .!
- | window myLabel foundWindow |
-
- self assert: ( Smalltalk isMorphic ) .
-
- myLabel := 'Workspace from ', 'SUnit test' .
- foundWindow := self findWindowInWorldLabeled: myLabel .
- self assert: ( foundWindow isNil ) .
-
- window :=
- UIManager default edit: '"MorphicUIBugTest run: #openWorkspaceTest"'  label: myLabel .
-
- foundWindow := self findWindowInWorldLabeled: myLabel .
-
- cases := Array with: foundWindow . "For teardown."
-
- self assert: ( window == foundWindow ) .
-
- foundWindow delete .!

Item was changed:
  ----- Method: MorphicUIManagerTest>>testShowAllBinParts (in category 'as yet unclassified') -----
  testShowAllBinParts
  "self new testShowAllBinParts"
  "MorphicUIBugTest run: #testShowAllBinParts"
 
+ | tool |
+ self
+ shouldnt: [tool := ObjectsTool  initializedInstance showAll openCenteredInWorld]
+ raise: Error.
+
+ cases := Array with: tool.!
- self assert: Smalltalk isMorphic.
- "This should not throw an exception."
- cases := Array with: ObjectsTool  initializedInstance showAll openCenteredInWorld!

Item was changed:
  ----- Method: MorphicUIManagerTest>>testUIManagerNoAcceptInitially (in category 'as yet unclassified') -----
  testUIManagerNoAcceptInitially
  "Ensure that UIManager does not invoke the accept: action initially."
 
  | accepted window |
  accepted := false.
+ window := uiManager edit: Text new label: 'Test' accept: [:val| accepted := true].
- window := UIManager default edit: Text new label: 'Test' accept: [:val| accepted := true].
  window delete.
  self deny: accepted.!

Item was changed:
  ----- Method: ScrollPaneTest>>setUp (in category 'running') -----
  setUp
 
  super setUp.
  sut := ScrollPane new.
  sut
  retractable: false;
  scrollBarOnLeft: false;
  extent: 100@100;
+ borderWidth: 0; "Very important for the math in tests!!"
+ hScrollBarPolicy: #whenNeeded;
+ vScrollBarPolicy: #whenNeeded.
- borderWidth: 0. "Very important for the math in tests!!"
  content := Morph new.
  sut scroller addMorph: content.!

Item was changed:
  TestCase subclass: #UserInputEventTests
+ instanceVariableNames: 'hand world priorWorld'
- instanceVariableNames: 'hand world'
  classVariableNames: ''
  poolDictionaries: ''
  category: 'MorphicTests-Events'!

Item was changed:
  ----- Method: UserInputEventTests>>setUp (in category 'running') -----
  setUp
 
  super setUp.
 
+ priorWorld := ActiveWorld.
+
  world := (PasteUpMorph newWorldForProject: nil)
  extent: 300@200;
  viewBox: (0@0 extent: 300@200);
  yourself.
 
  (world instVarNamed: #worldState)
  instVarNamed: #canvas
  put: (Form extent: 300@200 depth: 32) getCanvas.
 
  hand := HandMorphForEventTests new.
 
  world
  removeHand: world firstHand; "the default hand"
  addHand: hand.!

Item was changed:
  ----- Method: UserInputEventTests>>tearDown (in category 'running') -----
  tearDown
 
  hand showHardwareCursor: true. "Nasty side-effect"
+ ActiveWorld := priorWorld.
  super tearDown.!