The Inbox: Morphic-ct.1636.mcz

Christoph Thiede uploaded a new version of Morphic to project The Inbox:
http://source.squeak.org/inbox/Morphic-ct.1636.mcz

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

Name: Morphic-ct.1636
Author: ct
Time: 29 February 2020, 1:39:06.752872 pm
UUID: a0a951d1-1df6-6243-9671-b4ebec0afa85
Ancestors: Morphic-mt.1631

Adds protection against event-handling errors as proposed by Marcel et al. in [1]. I did not note any subjective performance impact, but we might want to write measures/tests for this. Please review!

Minimum example (don't execute this BEFORE loading this commit):

        c := Morph newSubclass.
        c compile: 'handleMouseMove: evt ^self error'.
        m := c new.
        m openInHand.

[1] http://forum.world.st/bug-in-a-ToolBuilder-Squeak5-3rc2-tp5112536p5112551.html

=============== Diff against Morphic-mt.1631 ===============

Item was changed:
  ----- Method: HandMorph>>fullDrawOn: (in category 'drawing') -----
  fullDrawOn: aCanvas
  "A HandMorph has unusual drawing requirements:
  1. the hand itself (i.e., the cursor) appears in front of its submorphs
  2. morphs being held by the hand cast a shadow on the world/morphs below
  The illusion is that the hand plucks up morphs and carries them above the world."
 
  "Note: This version caches an image of the morphs being held by the hand for
  better performance. This cache is invalidated if one of those morphs changes."
 
  | disableCaching subBnds |
  self visible ifFalse: [^self].
  (aCanvas isVisible: self fullBounds) ifFalse: [^self].
+ ((self hasProperty: #errorOnDraw) or: [self hasProperty: #errorOnEvent])
+ ifTrue: [^self drawErrorOn: aCanvas].
- (self hasProperty: #errorOnDraw) ifTrue:[^self drawErrorOn: aCanvas].
  disableCaching := false.
  disableCaching
  ifTrue:
  [self nonCachingFullDrawOn: aCanvas.
  ^self].
  submorphs isEmpty
  ifTrue:
  [cacheCanvas := nil.
  ^self drawOn: aCanvas]. "just draw the hand itself"
 
  "special handling of a single submorph that wants to do its own thing
  when being dragged"
  (submorphs size = 1
  and: [submorphs first handledOwnDraggingBy: self on: aCanvas])
  ifTrue: [^ self drawOn: aCanvas].
 
  subBnds := Rectangle merging: (submorphs collect: [:m | m fullBounds]).
  self updateCacheCanvas: aCanvas.
  (cacheCanvas isNil
  or: [cachedCanvasHasHoles and: [cacheCanvas depth = 1]])
  ifTrue:
  ["could not use caching due to translucency; do full draw"
 
  self nonCachingFullDrawOn: aCanvas.
  ^self].
 
  "draw the shadow"
  aCanvas asShadowDrawingCanvas translateBy: self shadowOffset
  during:
  [:shadowCanvas |
  cachedCanvasHasHoles
  ifTrue:
  ["Have to draw the real shadow of the form"
 
  shadowCanvas paintImage: cacheCanvas form at: subBnds origin]
  ifFalse:
  ["Much faster if only have to shade the edge of a solid rectangle"
 
  (subBnds areasOutside: (subBnds translateBy: self shadowOffset negated))
  do: [:r | shadowCanvas fillRectangle: r color: Color black]]].
 
  "draw morphs in front of the shadow using the cached Form"
  cachedCanvasHasHoles
  ifTrue: [aCanvas paintImage: cacheCanvas form at: subBnds origin]
  ifFalse:
  [aCanvas
  drawImage: cacheCanvas form
  at: subBnds origin
  sourceRect: cacheCanvas form boundingBox].
  self drawOn: aCanvas "draw the hand itself in front of morphs"!

Item was added:
+ ----- Method: KeyboardEvent>>isHighFrequentEvent (in category 'testing') -----
+ isHighFrequentEvent
+
+ ^ false!

Item was changed:
  ----- Method: Morph>>buildDebugMenu: (in category 'debug and other') -----
  buildDebugMenu: aHand
  "Answer a debugging menu for the receiver.  The hand argument is seemingly historical and plays no role presently"
 
  | aMenu aPlayer |
  aMenu := MenuMorph new defaultTarget: self.
  aMenu addStayUpItem.
  (self hasProperty: #errorOnDraw) ifTrue:
  [aMenu add: 'start drawing again' translated action: #resumeAfterDrawError.
  aMenu addLine].
+ (self hasProperty: #errorOnEvent) ifTrue:
+ [aMenu add: 'start event handling again' translated action: #resumeAfterEventError.
+ aMenu addLine].
  (self hasProperty: #errorOnStep) ifTrue:
  [aMenu add: 'start stepping again' translated action: #resumeAfterStepError.
  aMenu addLine].
 
  aMenu add: 'inspect morph' translated action: #inspectInMorphic:.
  aMenu add: 'inspect owner chain' translated action: #inspectOwnerChain.
  Smalltalk isMorphic ifFalse:
  [aMenu add: 'inspect morph (in MVC)' translated action: #inspect].
 
  self isMorphicModel ifTrue:
  [aMenu add: 'inspect model' translated target: self model action: #inspect;
  add: 'explore model' translated target: self model action: #explore].
  (aPlayer := self player) ifNotNil:
  [aMenu add: 'inspect player' translated target: aPlayer action: #inspect].
 
       aMenu add: 'explore morph' translated target: self selector: #exploreInMorphic:.
 
  aMenu addLine.
  aPlayer ifNotNil:
  [ aMenu add: 'viewer for Player' translated target: self player action: #beViewed.
  aMenu balloonTextForLastItem: 'Opens a viewer on my Player -- this is the same thing you get if you click on the cyan "View" halo handle' translated ].
 
  aMenu add: 'viewer for Morph' translated target: self action: #viewMorphDirectly.
  aMenu balloonTextForLastItem: 'Opens a Viewer on this Morph, rather than on its Player' translated.
  aMenu addLine.
 
  aPlayer ifNotNil:
  [aPlayer class isUniClass ifTrue: [
  aMenu add: 'browse player class' translated target: aPlayer selector: #haveFullProtocolBrowsedShowingSelector: argumentList: #(nil)]].
  aMenu add: 'browse morph class' translated target: self selector: #browseHierarchy.
+ self isMorphicModel
- (self isMorphicModel)
  ifTrue: [aMenu
  add: 'browse model class'
  target: self model
  selector: #browseHierarchy].
  aMenu addLine.
 
  self addViewingItemsTo: aMenu.
  aMenu
  add: 'make own subclass' translated action: #subclassMorph;
  add: 'save morph in file' translated  action: #saveOnFile;
  addLine;
  add: 'call #tempCommand' translated action: #tempCommand;
  add: 'define #tempCommand' translated action: #defineTempCommand;
  addLine;
 
  add: 'control-menu...' translated target: self selector: #invokeMetaMenu:;
  add: 'edit balloon help' translated action: #editBalloonHelpText.
 
  ^ aMenu!

Item was changed:
  ----- Method: Morph>>fullDrawOn: (in category 'drawing') -----
  fullDrawOn: aCanvas
  "Draw the full Morphic structure on the given Canvas"
 
  self visible ifFalse: [^ self].
+ (aCanvas isVisible: self fullBounds) ifFalse: [^self].
+ ((self hasProperty: #errorOnDraw) or: [self hasProperty: #errorOnEvent])
+ ifTrue: [^self drawErrorOn: aCanvas].
+
+ "Note: At some point we should generalize this into some sort of multi-canvas so that we can cross-optimize some drawing operations."
- (aCanvas isVisible: self fullBounds) ifFalse:[^self].
- (self hasProperty: #errorOnDraw) ifTrue:[^self drawErrorOn: aCanvas].
- "Note: At some point we should generalize this into some sort of
- multi-canvas so that we can cross-optimize some drawing operations."
 
  "Pass 1: Draw eventual drop-shadow"
  self hasDropShadow ifTrue: [self drawDropShadowOn: aCanvas].
  (self hasRolloverBorder and: [(aCanvas seesNothingOutside: self bounds) not])
  ifTrue: [self drawRolloverBorderOn: aCanvas].
 
  "Pass 2: Draw receiver itself"
  (aCanvas isVisible: self bounds) ifTrue:[aCanvas drawMorph: self].
  self drawSubmorphsOn: aCanvas.
  self drawOverlayOn: aCanvas.!

Item was changed:
  ----- Method: Morph>>handleEvent: (in category 'events-processing') -----
  handleEvent: anEvent
  "Apply event filters and then handle the resulting event. We have to return the event to chain filters."
 
  | filteredEvent |
+ (self hasProperty: #errorOnEvent) ifTrue: [^ anEvent].
  filteredEvent := self sendFilterEventBubble: anEvent for: self.
  filteredEvent wasIgnored ifFalse: [filteredEvent sentTo: self].
  ^ filteredEvent!

Item was changed:
  ----- Method: Morph>>resumeAfterDrawError (in category 'debug and other') -----
  resumeAfterDrawError
 
  self changed.
+ self removeProperty: #errorOnDraw.
- self removeProperty:#errorOnDraw.
  self changed.!

Item was added:
+ ----- Method: Morph>>resumeAfterEventError (in category 'debug and other') -----
+ resumeAfterEventError
+
+ self removeProperty: #errorOnEvent.
+ self changed.!

Item was changed:
  ----- Method: Morph>>resumeAfterStepError (in category 'debug and other') -----
  resumeAfterStepError
  "Resume stepping after an error has occured."
 
  self startStepping. "Will #step"
+ self removeProperty: #errorOnStep. "Will remove prop only if #step was okay"
- self removeProperty:#errorOnStep. "Will remove prop only if #step was okay"
  !

Item was added:
+ ----- Method: MorphicEvent>>isHighFrequentEvent (in category 'testing') -----
+ isHighFrequentEvent
+ "A high frequent event is one that occurs really often. If an event handler raises an error each time it receives a particular event, this could stall your image. For this reason, we handle high frequent events with extra care. On the contrary, cathing too many event errors would restrict convenience of tools (ex: a menu item that raises an error). See WorldState >> #processEventsSafely:."
+
+ ^ true!

Item was added:
+ ----- Method: MorphicProject>>fatalEventHandlingError: (in category 'scheduling & debugging') -----
+ fatalEventHandlingError: errMsg
+ "Morphic event handling failed and could not be recovered. So we end up here."
+
+ self primitiveError: errMsg.
+
+ "Hm... we should jump into a 'safe' worldState here, but how do we find it?!!"!

Item was added:
+ ----- Method: MouseButtonEvent>>isHighFrequentEvent (in category 'testing') -----
+ isHighFrequentEvent
+
+ ^ false!

Item was changed:
  ----- Method: WorldState>>displayWorldSafely: (in category 'update cycle') -----
  displayWorldSafely: aWorld
  "Update this world's display and keep track of errors during draw methods."
 
+ ^ self
+ doSafely: [aWorld displayWorld]
+ onErrorThat: [:error | true]
+ setErrorFlag: #errorOnDraw
+ ifFatal: [:error | Project current fatalDrawingError: error]
+ afterErrorDo: [aWorld fullRepaintNeeded]!
- | finished classesWithErrors |
- finished := false.
-
- [finished] whileFalse: [
- [aWorld displayWorld. finished := true] on: Error, Halt, Warning do: [:ex |
- "Handle a drawing error"
- | err rcvr errCtx errMorph |
- err := ex description.
- rcvr := ex receiver.
-
- errCtx := thisContext.
- [
- errCtx := errCtx sender.
- "Search the sender chain to find the morph causing the problem"
- [errCtx notNil and:[(errCtx receiver isMorph) not]]
- whileTrue:[errCtx := errCtx sender].
- "If we're at the root of the context chain then we have a fatal drawing problem"
- errCtx ifNil:[^Project current fatalDrawingError: err].
- errMorph := errCtx receiver.
- "If the morph causing the problem has already the #drawError flag set,
- then search for the next morph above in the caller chain."
- errMorph hasProperty: #errorOnDraw
- ] whileTrue.
- errMorph setProperty: #errorOnDraw toValue: true.
-
- "Catch all errors, one for each receiver class."
- classesWithErrors ifNil: [classesWithErrors := IdentitySet new].
- (classesWithErrors includes: rcvr class) ifFalse: [
- classesWithErrors add: rcvr class.
- ToolSet debugException: ex].
-
- "Repaint all to catch all errors now and not if the debugger will appear."
- aWorld fullRepaintNeeded.
- ]].!

Item was changed:
  ----- Method: WorldState>>doOneCycleNowFor: (in category 'update cycle') -----
  doOneCycleNowFor: aWorld
  "Immediately do one cycle of the interaction loop.
  This should not be called directly, but only via doOneCycleFor:"
 
  | capturingGesture |
  DisplayScreen checkForNewScreenSize.
  capturingGesture := false.
  "self flag: #bob. " "need to consider remote hands in lower worlds"
 
  "process user input events"
  LastCycleTime := Time millisecondClockValue.
  self handsDo: [:h |
  ActiveHand := h.
+ self processEventsSafely: h.
- h processEvents.
  capturingGesture := capturingGesture or: [ h isCapturingGesturePoints ].
  ActiveHand := nil
  ].
 
  "the default is the primary hand"
  ActiveHand := self hands first.
 
  "The gesture recognizer needs enough points to be accurate.
  Therefore morph stepping is disabled while capturing points for the recognizer"
  capturingGesture ifFalse:
  [aWorld runStepMethods. "there are currently some variations here"
  self displayWorldSafely: aWorld].
  !

Item was added:
+ ----- Method: WorldState>>doSafely:onErrorThat:setErrorFlag:ifFatal:afterErrorDo: (in category 'update cycle') -----
+ doSafely: aBlock onErrorThat: errorPredicate setErrorFlag: errorFlag ifFatal: fatalErrorBlock afterErrorDo: postErrorBlock
+ "Evaluate aBlock and keep track of errors during morph invocations."
+
+ | finished classesWithErrors |
+ finished := false.
+ classesWithErrors := IdentitySet new.
+ [finished] whileFalse: [
+ [aBlock value. finished := true] on: Error, Halt, Warning do: [:ex |
+ | err rcvr errCtxt errMorph |
+ (errorPredicate cull: ex)
+ ifFalse: [ex pass].
+ err := ex description.
+ rcvr := ex receiver.
+
+ errCtxt := thisContext.
+ [
+ errCtxt := errCtxt sender.
+ "Search the sender chain to find the morph causing the problem"
+ [errCtxt notNil and: [(errCtxt receiver isMorph) not]]
+ whileTrue: [errCtxt := errCtxt sender].
+ "If we're at the root of the context chain then we have a fatal problem"
+ errCtxt ifNil: [^ fatalErrorBlock cull: err].
+ errMorph := errCtxt receiver.
+ "If the morph causing the problem has already the error flag set, then search for the next morph above in the caller chain."
+ errMorph hasProperty: errorFlag
+ ] whileTrue.
+ errMorph setProperty: errorFlag toValue: true.
+
+ "Catch all errors, one for each receiver class."
+ (classesWithErrors includes: rcvr class) ifFalse: [
+ classesWithErrors add: rcvr class.
+ ToolSet debugException: ex].
+
+ postErrorBlock cull: err.
+ ]].!

Item was added:
+ ----- Method: WorldState>>processEventsSafely: (in category 'update cycle') -----
+ processEventsSafely: aHandMorph
+
+ ^ self
+ doSafely: [aHandMorph processEvents]
+ onErrorThat: [:error | ActiveEvent isHighFrequentEvent]
+ setErrorFlag: #errorOnEvent
+ ifFatal: [:error | Project current fatalEventHandlingError: error]
+ afterErrorDo: []!