The Trunk: Morphic-mt.1757.mcz

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

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

Name: Morphic-mt.1757
Author: mt
Time: 25 April 2021, 8:26:52.104934 am
UUID: 433d3730-4e0c-7e42-a021-a53d5b4092c8
Ancestors: Morphic-mt.1756

Complements Kernel-mt.1391.

Please read comment in #checkCommandKey.

Also see http://forum.world.st/Please-try-it-out-Fixing-the-input-mapping-for-keystroke-events-td5129004.html

=============== Diff against Morphic-mt.1756 ===============

Item was changed:
  SystemOrganization addCategory: #'Morphic-Balloon'!
  SystemOrganization addCategory: #'Morphic-Basic'!
  SystemOrganization addCategory: #'Morphic-Basic-NewCurve'!
  SystemOrganization addCategory: #'Morphic-Borders'!
  SystemOrganization addCategory: #'Morphic-Collections-Arrayed'!
  SystemOrganization addCategory: #'Morphic-Demo'!
  SystemOrganization addCategory: #'Morphic-Events'!
  SystemOrganization addCategory: #'Morphic-Explorer'!
  SystemOrganization addCategory: #'Morphic-Kernel'!
  SystemOrganization addCategory: #'Morphic-Layouts'!
  SystemOrganization addCategory: #'Morphic-Menus'!
  SystemOrganization addCategory: #'Morphic-Menus-DockingBar'!
  SystemOrganization addCategory: #'Morphic-Pluggable Widgets'!
  SystemOrganization addCategory: #'Morphic-Sound-Synthesis'!
  SystemOrganization addCategory: #'Morphic-Support'!
  SystemOrganization addCategory: #'Morphic-Text Support'!
  SystemOrganization addCategory: #'Morphic-TrueType'!
  SystemOrganization addCategory: #'Morphic-Widgets'!
  SystemOrganization addCategory: #'Morphic-Windows'!
  SystemOrganization addCategory: #'Morphic-Worlds'!
+ SystemOrganization addCategory: #Morphic!

Item was added:
+ ----- Method: KeyboardEvent>>asMorph (in category 'converting') -----
+ asMorph
+ "Answers a graphical reprsentation for this keyboard event. Does not work for keyUp and keyDown because we do not have platform-specific mapping tables for the key codes."
+
+ | box color hasModifiers |
+ box := Morph new
+ color: Color transparent;
+ layoutPolicy: TableLayout new;
+ listDirection: #leftToRight;
+ hResizing: #shrinkWrap;
+ vResizing: #shrinkWrap;
+ cellGap: 2;
+ yourself.
+ color := self userInterfaceTheme get: #textColor for: #PluggableButtonMorph.
+
+ self labelsForPhysicalModifiers
+ do: [:modifier |
+ hasModifiers := true.
+ box addMorphBack: (ToolIcons keyboardButtonLabeled: modifier dyed: color) asMorph]
+ separatedBy: [
+ box addMorphBack: (('+' asText addAttribute: (TextColor color: color); asMorph) lock)].
+
+ (self isKeystroke not
+ and: [self keyValue between: 16 and: 18]
+ and: [hasModifiers == true "some VMs are strange!!"])
+ ifTrue: [ "keyUp and keyDown; just the raw modifier keys"
+ ^ box].
+
+ hasModifiers == true ifTrue: [
+ box addMorphBack: (('+' asText addAttribute: (TextColor color: color); asMorph) lock)].
+
+ (self keyValue between: 28 and: 31)
+ ifTrue: [ "arrow keys"
+ box addMorphBack: (ToolIcons keyboardButtonLabeled: (
+ ScrollBar
+ arrowOfDirection: (#(left right top bottom) at: self keyValue - 27)
+ size: Preferences standardButtonFont height
+ color: Color black) dyed: color) asMorph.
+ ^ box].
+
+ box addMorphBack: (ToolIcons keyboardButtonLabeled: self labelForPhysicalKey dyed: color) asMorph.
+
+ ^ box!

Item was added:
+ ----- Method: KeyboardEvent>>checkCommandKey (in category 'debugging') -----
+ checkCommandKey
+
+ self flag: #debuggingOnly. "mt: This check documents a trade-off for having platform-specific modifiers and writing cross-platform compatible applications. If you want to support all three modifiers (i.e. CTRL, CMD, OPT), be aware that
+ (1) you should first check for CTRL/OPT then CMD, because
+ (2) physical CTRL and ALT keys on Linux/Windows are mapped to the pairs CTRL+CMD and CMD+OPT respectively and thus overshadow some key bindings if checked in the wrong order -- and that's why
+ (3) you should effectively only use CTRL/CMD, OPT/CMD, or CTRL/OPT in an application on Linux/Windows. And communicate the physical keys being CTRL and ALT.
+
+ Note that point (3) documents the best practice for handling keystroke (not keyUp or keyDown) events while maintaining cross-platform compatibility."
+
+ ^ self commandKeyPressed
+ and: [self controlKeyPressed not
+ and: [self optionKeyPressed not]]!

Item was added:
+ ----- Method: KeyboardEvent>>labelForPhysicalKey (in category 'printing') -----
+ labelForPhysicalKey
+
+ ^ (self keyValue <= 32 or: [self keyValue = 127])
+ ifFalse: [
+ self keyCharacter asUppercase asString]
+ ifTrue: [
+ (self isKeystroke and: [self controlKeyPressed] and: [self keyValue < 28 "no arrows or space"])
+ ifTrue: [
+ "Most likely a physical key with a readable (uppercase) label. Be aware that this cannot cover the cases where the physical contro key was pressed together with the CTRL modifier."
+ (self keyValue bitOr: 16r40) asCharacter asString "+64"]
+ ifFalse: [
+ self keyValue caseOf: {
+ [ 1 ] -> [ 'Home' translated ].
+ [ 4 ] -> [ 'End' translated ].
+ [ 5 ] -> [ 'Insert' translated ].
+ [ 8 ] -> [ 'Backspace' translated ].
+ [ 9 ] -> [ 'Tab' ].
+ [ 10 ] -> [ 'LF' ].
+ [ 11 ] -> [ 'PageUp' translated ].
+ [ 12 ] -> [ 'PageDown' translated ].
+ [ 13 ] -> [ 'Return' translated "CR" ].
+ [ 16 ] -> [ 'Shift' translated "Windows only?!!" ].
+ [ 17 ] -> [ 'Ctrl' translated "Windows only?!!" ].
+ [ 18 ] -> [ 'Alt' "Windows only?!!" ].
+ [ 27 ] -> [ 'Esc' ].
+ [ 32 ] -> [ 'Space' translated ].
+ [ 127 ] -> [ 'Del' translated ].
+ } otherwise: [
+ 'ASCII-', (self keyValue printPaddedWith: $0 to: 2 base: 10)]]]!

Item was added:
+ ----- Method: KeyboardEvent>>labelForPhysicalKeyDown (in category 'printing') -----
+ labelForPhysicalKeyDown
+ "#keyDown and #keyUp -- needs platform-specific mapping for virtual key codes"
+
+ ^ (self keyValue <= 32 or: [self keyValue = 127])
+ ifFalse: [
+ (self keyValue between: 65 and: 90) "Windows"
+ ifTrue: [self keyCharacter asUppercase asString]
+ ifFalse: ['ASCII-', (self keyValue printPaddedWith: $0 to: 2 base: 10)]]
+ ifTrue: [
+ self keyValue caseOf: {
+ [ 1 ] -> [ 'Home' translated ].
+ [ 4 ] -> [ 'End' translated ].
+ [ 5 ] -> [ 'Insert' translated ].
+ [ 8 ] -> [ 'Backspace' translated ].
+ [ 9 ] -> [ 'Tab' ].
+ [ 10 ] -> [ 'LF' ].
+ [ 11 ] -> [ 'PageUp' translated ].
+ [ 12 ] -> [ 'PageDown' translated ].
+ [ 13 ] -> [ 'Return' translated "CR" ].
+ [ 16 ] -> [ 'Shift' translated "Windows only?!!" ].
+ [ 17 ] -> [ 'Ctrl' translated "Windows only?!!" ].
+ [ 18 ] -> [ 'Alt' "Windows only?!!" ].
+ [ 27 ] -> [ 'Esc' ].
+ [ 32 ] -> [ 'Space' translated ].
+ [ 127 ] -> [ 'Del' translated ].
+ } otherwise: [
+ 'ASCII-', (self keyValue printPaddedWith: $0 to: 2 base: 10)]]!

Item was added:
+ ----- Method: KeyboardEvent>>labelForPhysicalKeyStroke (in category 'printing') -----
+ labelForPhysicalKeyStroke
+
+ ^ (self keyValue <= 32 or: [self keyValue = 127])
+ ifFalse: [
+ self keyCharacter asUppercase asString]
+ ifTrue: [
+ (self controlKeyPressed and: [self keyValue < 28 "no arrows or space"])
+ ifTrue: [
+ "Most likely a physical key with a readable (uppercase) label. Be aware that this cannot cover the cases where the physical contro key was pressed together with the CTRL modifier."
+ (self keyValue bitOr: 16r40) asCharacter asString "+64"]
+ ifFalse: [
+ self keyValue caseOf: {
+ [ 1 ] -> [ 'Home' translated ].
+ [ 4 ] -> [ 'End' translated ].
+ [ 5 ] -> [ 'Insert' translated ].
+ [ 8 ] -> [ 'Backspace' translated ].
+ [ 9 ] -> [ 'Tab' ].
+ [ 10 ] -> [ 'LF' ].
+ [ 11 ] -> [ 'PageUp' translated ].
+ [ 12 ] -> [ 'PageDown' translated ].
+ [ 13 ] -> [ 'Return' translated "CR" ].
+ [ 16 ] -> [ 'Shift' translated "Windows only?!!" ].
+ [ 17 ] -> [ 'Ctrl' translated "Windows only?!!" ].
+ [ 18 ] -> [ 'Alt' "Windows only?!!" ].
+ [ 27 ] -> [ 'Esc' ].
+ [ 32 ] -> [ 'Space' translated ].
+ [ 127 ] -> [ 'Del' translated ].
+ } otherwise: [
+ 'ASCII-', (self keyValue printPaddedWith: $0 to: 2 base: 10)]]]!

Item was added:
+ ----- Method: KeyboardEvent>>labelsForPhysicalModifiers (in category 'printing') -----
+ labelsForPhysicalModifiers
+ "Help users understand the physical modifier keys that where involved in this event. Note that, due to historical reasons, the SHIFT modifier comes first on macOS but last on other platforms."
+
+ | result |
+ result := OrderedCollection new.
+
+ Smalltalk platformName = 'Mac OS'
+ ifTrue: [
+ self shiftPressed ifTrue: [result add: 'Shift'].
+ self controlKeyPressed ifTrue: [result add: 'Ctrl'].
+ self optionKeyPressed ifTrue: [result add: 'Opt'].
+ self commandKeyPressed ifTrue: [result add: 'Cmd']]
+ ifFalse: [ "Linux/Windows"
+ self controlKeyPressed
+ ifTrue: [result add: 'Ctrl']
+ ifFalse: [
+ Smalltalk platformName = 'Win32'
+ ifTrue: [
+ (self commandKeyPressed or: [self optionKeyPressed])
+ ifTrue: [result add: 'Alt']]
+ ifFalse: ["Linux/ARM"
+ self commandKeyPressed
+ ifTrue: [result add: 'Alt']
+ ifFalse: [self optionKeyPressed
+ ifTrue: [
+ result add: 'Strg'.
+ result add: 'Alt']]]].
+ self shiftPressed ifTrue: [result add: 'Shift']].
+ ^ result!

Item was changed:
  ----- Method: KeyboardEvent>>printKeyStringOn: (in category 'printing') -----
  printKeyStringOn: aStream
  "Print a readable string representing the receiver on a given stream"
 
  | kc inBrackets firstBracket keyString |
  kc := self keyCharacter.
  inBrackets := false.
  firstBracket := [ inBrackets ifFalse: [ aStream nextPut: $<. inBrackets := true ]].
  self controlKeyPressed ifTrue: [ firstBracket value. aStream nextPutAll: 'Ctrl-' ].
  self commandKeyPressed ifTrue: [ firstBracket value. aStream nextPutAll: 'Cmd-' ].
+ self optionKeyPressed ifTrue: [ firstBracket value. aStream nextPutAll: 'Opt-' ].
+ self shiftPressed ifTrue: [ firstBracket value. aStream nextPutAll: 'Shift-' ].
- (buttons anyMask: 32) ifTrue: [ firstBracket value. aStream nextPutAll: 'Opt-' ].
- (self shiftPressed and: [ (keyValue between: 1 and: 31) or: [self keyCharacter = Character delete ]])
- ifTrue: [ firstBracket value. aStream nextPutAll: 'Shift-' ].
 
  keyString := (kc caseOf: {
  [ Character space ] -> [ 'space' ].
  [ Character tab ] -> [ 'tab' ].
  [ Character cr ] -> [ 'cr' ].
  [ Character lf ] -> [ 'lf' ].
  [ Character enter ] -> [ 'enter' ].
 
  [ Character backspace ] -> [ 'backspace' ].
  [ Character delete ] -> [ 'delete' ].
 
  [ Character escape ] -> [ 'escape' ].
 
  [ Character arrowDown ] -> [ 'down' ].
  [ Character arrowUp ] -> [ 'up' ].
  [ Character arrowLeft ] -> [ 'left' ].
  [ Character arrowRight ] -> [ 'right' ].
 
  [ Character end ] -> [ 'end' ].
  [ Character home ] -> [ 'home' ].
  [ Character pageDown ] -> [ 'pageDown' ].
  [ Character pageUp ] -> [ 'pageUp' ].
 
  [ Character euro ] -> [ 'euro' ].
  [ Character insert ] -> [ 'insert' ].
 
  } otherwise: [ String with: kc ]).
 
  keyString size > 1 ifTrue: [ firstBracket value ].
  aStream nextPutAll: keyString.
 
  inBrackets ifTrue: [aStream nextPut: $> ]!

Item was changed:
  ----- Method: KeyboardEvent>>printOn: (in category 'printing') -----
  printOn: aStream
  "Print the receiver on a stream"
 
  aStream nextPut: $[.
  aStream nextPutAll: self cursorPoint printString; space.
  aStream nextPutAll: type; space.
 
  self isKeystroke ifTrue: [
  aStream nextPutAll: ''''.
  self printKeyStringOn: aStream.
+ aStream nextPut: $'; space.
+ aStream nextPutAll: '['.
+ self printPhysicalModifiersOn: aStream.
+ aStream nextPutAll: '] '].
- aStream nextPut: $'; space].
 
  aStream nextPut: $(.
  aStream nextPutAll: keyValue printString.
  aStream nextPut: $); space.
 
  aStream nextPutAll: timeStamp printString.
  aStream nextPut: $]!

Item was added:
+ ----- Method: KeyboardEvent>>printPhysicalModifiersOn: (in category 'printing') -----
+ printPhysicalModifiersOn: aStream
+ "Help users understand the physical modifier keys that where involved in this event."
+
+ self labelsForPhysicalModifiers
+ do: [:modifier | aStream nextPutAll: modifier]
+ separatedBy: [aStream nextPutAll: ' + '].!

Item was added:
+ Morph subclass: #KeyboardExerciser
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Demo'!

Item was added:
+ ----- Method: KeyboardExerciser class>>descriptionForPartsBin (in category 'parts bin') -----
+ descriptionForPartsBin
+ "KeyboardExerciser descriptionForPartsBin"
+ ^ self partName: 'Exercise Keyboard'
+ categories: #('Demo')
+ documentation: 'An exerciser for key stroke, key down, and key up'!

Item was added:
+ ----- Method: KeyboardExerciser>>checkButton: (in category 'initialization') -----
+ checkButton: checkIndex
+
+ 1 to: 3 do: [:index |
+ (self submorphs at: index)
+ state: #off].
+
+ (self submorphs at: checkIndex) state: #on.!

Item was added:
+ ----- Method: KeyboardExerciser>>clear (in category 'initialization') -----
+ clear
+
+ (self submorphs allButFirst: 3) do: [:m | m delete].!

Item was added:
+ ----- Method: KeyboardExerciser>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+
+ super drawOn: aCanvas.
+
+ aCanvas
+ drawString: 'Move your mouse cursor to here and start typing. Try modifiers, too.'
+ at: self topLeft
+ font: Preferences standardButtonFont
+ color: Color gray.!

Item was added:
+ ----- Method: KeyboardExerciser>>handleEvent:deemphasize: (in category 'actions') -----
+ handleEvent: mouseEvent deemphasize: morph
+
+ morph color: Color transparent.!

Item was added:
+ ----- Method: KeyboardExerciser>>handleEvent:emphasize: (in category 'actions') -----
+ handleEvent: mouseEvent emphasize: morph
+
+ morph color: (self userInterfaceTheme get: #selectionColor for: #PluggableListMorph).!

Item was added:
+ ----- Method: KeyboardExerciser>>handleEvent:inspect: (in category 'actions') -----
+ handleEvent: mouseEvent inspect: morph
+
+ mouseEvent shiftPressed
+ ifTrue: [(morph valueOfProperty: #event) explore]
+ ifFalse: [(morph valueOfProperty: #event) inspect].!

Item was added:
+ ----- Method: KeyboardExerciser>>handlesKeyboard: (in category 'event handling') -----
+ handlesKeyboard: evt
+
+ ^ (self valueOfProperty: #eventCheck) value: evt!

Item was added:
+ ----- Method: KeyboardExerciser>>handlesMouseOver: (in category 'event handling') -----
+ handlesMouseOver: evt
+
+ ^ true!

Item was added:
+ ----- Method: KeyboardExerciser>>initialize (in category 'initialization') -----
+ initialize
+
+ super initialize.
+
+ self
+ color: (self userInterfaceTheme get: #color for: #ScrollPane);
+ extent: 300@50;
+ layoutPolicy: TableLayout new;
+ listDirection: #leftToRight;
+ wrapDirection: #topToBottom;
+ hResizing: #rigid;
+ vResizing: #shrinkWrap;
+ cellGap: 10;
+ layoutInset: 20;
+ yourself.
+
+ #(processKeyStroke 'Test key stroke'
+ processKeyDown 'Test key down'
+ processKeyUp 'Test key up')
+ groupsDo: [:selector :label |
+ self addMorphBack: (ThreePhaseButtonMorph checkBox
+ target: self;
+ actionSelector: selector;
+ label: label;
+ yourself)].
+
+ self processKeyStroke.!

Item was added:
+ ----- Method: KeyboardExerciser>>keyDown: (in category 'event handling') -----
+ keyDown: evt
+
+ self logEvent: evt.!

Item was added:
+ ----- Method: KeyboardExerciser>>keyStroke: (in category 'event handling') -----
+ keyStroke: evt
+
+ self logEvent: evt.!

Item was added:
+ ----- Method: KeyboardExerciser>>keyUp: (in category 'event handling') -----
+ keyUp: evt
+
+ self logEvent: evt.!

Item was added:
+ ----- Method: KeyboardExerciser>>logEvent: (in category 'event handling') -----
+ logEvent: evt
+
+ | eventMorph |
+ eventMorph := evt asMorph.
+ eventMorph
+ balloonText: 'Click to inspect. Shift+click to explore.\\' withCRs, evt printString;
+ setProperty: #event toValue: evt copy.
+
+ eventMorph
+ on: #mouseEnter send: #handleEvent:emphasize: to: self;
+ on: #mouseLeave send: #handleEvent:deemphasize: to: self;
+ on: #mouseDown send: #handleEvent:inspect: to: self.
+
+ self addMorphBack: eventMorph.!

Item was added:
+ ----- Method: KeyboardExerciser>>mouseEnter: (in category 'event handling') -----
+ mouseEnter: evt
+
+ self comeToFront.
+ evt hand newKeyboardFocus: self.!

Item was added:
+ ----- Method: KeyboardExerciser>>processKeyDown (in category 'initialization') -----
+ processKeyDown
+
+ self setProperty: #eventCheck toValue: [:evt | evt isKeyDown].
+ self checkButton: 2.
+ self clear.!

Item was added:
+ ----- Method: KeyboardExerciser>>processKeyStroke (in category 'initialization') -----
+ processKeyStroke
+
+ self setProperty: #eventCheck toValue: [:evt | evt isKeystroke].
+ self checkButton: 1.
+ self clear.!

Item was added:
+ ----- Method: KeyboardExerciser>>processKeyUp (in category 'initialization') -----
+ processKeyUp
+
+ self setProperty: #eventCheck toValue: [:evt | evt isKeyUp].
+ self checkButton: 3.
+ self clear.!

Item was changed:
  ----- Method: UserInputEvent>>anyModifierKeyPressed (in category 'modifier state') -----
  anyModifierKeyPressed
+ "ignore, however, the shift keys 'cause that's not REALLY a modifier key "
- "ignore, however, the shift keys 'cause that's not REALLY a command key "
 
+ ^ self buttons anyMask: (2r1110 "cmd | opt | ctrl" bitShift: MouseEvent numButtons)!
- ^ self buttons anyMask: 16r70 "cmd | opt | ctrl"!

Item was changed:
  ----- Method: UserInputEvent>>commandKeyPressed (in category 'modifier state') -----
  commandKeyPressed
  "Answer true if the command key on the keyboard was being held down when this event occurred."
 
+ ^ self buttons anyMask: (2r1000 "cmd" bitShift: MouseEvent numButtons)!
- ^buttons anyMask: (1 bitShift: MouseEvent numButtons + 3)!

Item was changed:
  ----- Method: UserInputEvent>>controlKeyPressed (in category 'modifier state') -----
  controlKeyPressed
  "Answer if the control key on the keyboard was being held down when this event occurred."
 
+ ^ self buttons anyMask: (2r0010 "ctrl" bitShift: MouseEvent numButtons)!
- ^buttons anyMask: (1 bitShift: MouseEvent numButtons + 1)!

Item was added:
+ ----- Method: UserInputEvent>>optionKeyPressed (in category 'modifier state') -----
+ optionKeyPressed
+ "Answer if the option key on the keyboard was being held down when this event occurred."
+
+ ^ self buttons anyMask: (2r0100 "opt" bitShift: MouseEvent numButtons)!

Item was changed:
  ----- Method: UserInputEvent>>shiftPressed (in category 'modifier state') -----
  shiftPressed
  "Answer true if the shift key on the keyboard was being held down when this event occurred."
 
+ ^ self buttons anyMask: (2r0001 "shift" bitShift: MouseEvent numButtons)!
- ^buttons anyMask: (1 bitShift: MouseEvent numButtons)
- !