+(defcustom shifted-motion-keys-select-region t
+ "*If non-nil, shifted motion keys select text, like in MS Windows.
+
+More specifically, if a keystroke that matches one of the key
+specifications in `motion-keys-for-shifted-motion' is pressed along
+with the Shift key, and the command invoked moves the cursor and
+preserves the active region (see `zmacs-region-stays'), the
+intervening text will be added to the active region.
+
+When the region has been enabled or augmented as a result of a shifted
+motion key, an unshifted motion key will normally deselect the region.
+However, if `unshifted-motion-keys-deselect-region' is nil, the region
+will remain active, augmented by the characters moved over by this
+motion key.
+
+This functionality is specifically interpreted in terms of keys, and
+*NOT* in terms of particular commands, because that produces the most
+intuitive behavior: `forward-char' will work with shifted motion
+when invoked by `right' but not `C-f', and user-written motion commands
+bound to motion keys will automatically work with shifted motion."
+ :type 'boolean
+ :group 'editing-basics)
+
+(defcustom unshifted-motion-keys-deselect-region t
+ "*If non-nil, unshifted motion keys deselect a shifted-motion region.
+This only occurs after a region has been selected or augmented using
+shifted motion keys (not when using the traditional set-mark-then-move
+method), and has no effect if `shifted-motion-keys-select-region' is
+nil."
+ :type 'boolean
+ :group 'editing-basics)
+
+(defcustom motion-keys-for-shifted-motion
+ ;; meta-shift-home/end are NOT shifted motion commands.
+ '(left right up down (home) (control home) (meta control home)
+ (end) (control end) (meta control end) prior next
+ kp-left kp-right kp-up kp-down (kp-home) (control kp-home)
+ (meta control kp-home) (kp-end) (control kp-end) (meta control kp-end)
+ kp-prior kp-next)
+ "*List of keys considered motion keys for the purpose of shifted selection.
+When one of these keys is pressed along with the Shift key, and the
+command invoked moves the cursor and preserves the active region (see
+`zmacs-region-stays'), the intervening text will be added to the active
+region. See `shifted-motion-keys-select-region' for more details.
+
+Each entry should be a keysym or a list (MODIFIERS ... KEYSYM),
+i.e. zero or more modifiers followed by a keysym. When a keysym alone
+is given, a keystroke consisting of that keysym, with or without any
+modifiers, is considered a motion key. When the list form is given,
+only a keystroke with exactly those modifiers and no others (with the
+exception of the Shift key) is considered a motion key.
+
+NOTE: Currently, the keysym cannot be a non-alphabetic character key
+such as the `=/+' key. In any case, the shifted-motion paradigm does
+not make much sense with those keys. The keysym can, however, be an
+alphabetic key without problem, and you can specify the key using
+either a character or a symbol, uppercase or lowercase."
+ :type '(repeat (choice (const :tag "normal cursor-pad (\"gray\") keys"
+ :inline t
+ (left
+ right up down
+ (home) (control home) (meta control home)
+ (end) (control end) (meta control end)
+ prior next))
+ (const :tag "keypad motion keys"
+ :inline t
+ (kp-left
+ kp-right kp-up kp-down
+ (kp-home) (control kp-home)
+ (meta control kp-home)
+ (kp-end) (control kp-end)
+ (meta control kp-end)
+ kp-prior kp-next))
+ (const :tag "alphabetic motion keys"
+ :inline t
+ ((control b) (control f)
+ (control p) (control n)
+ (control a) (control e)
+ (control v) (meta v)
+ (meta b) (meta f)
+ (meta a) (meta e)
+ (meta m) ; back-to-indentation
+ (meta r) ; move-to-window-line
+ (meta control b) (meta control f)
+ (meta control p) (meta control n)
+ (meta control a) (meta control e)
+ (meta control d) ;; down-list
+ (meta control u) ;; backward-up-list
+ ))
+ symbol))
+ :group 'editing-basics)
+
+(defun handle-pre-motion-command-current-command-is-motion ()
+ (and (key-press-event-p last-input-event)
+ (let ((key (event-key last-input-event))
+ (mods (delq 'shift (event-modifiers last-input-event))))
+ ;(princ (format "key: %s mods: %s\n" key mods) 'external-debugging-output)
+ (catch 'handle-pre-motion-command-current-command-is-motion
+ (flet ((keysyms-equal (a b)
+ (if (characterp a)
+ (setq a (intern (char-to-string (downcase a)))))
+ (if (characterp b)
+ (setq b (intern (char-to-string (downcase b)))))
+ (eq a b)))
+ (mapc #'(lambda (keysym)
+ (when (if (listp keysym)
+ (and (equal mods (butlast keysym))
+ (keysyms-equal key (car (last keysym))))
+ (keysyms-equal key keysym))
+ (throw
+ 'handle-pre-motion-command-current-command-is-motion
+ t)))
+ motion-keys-for-shifted-motion)
+ nil)))))
+
+(defun handle-pre-motion-command ()
+ (if (and
+ (handle-pre-motion-command-current-command-is-motion)
+ zmacs-regions
+ shifted-motion-keys-select-region
+ (not (region-active-p))
+ ;; Special-case alphabetic keysyms, because the `shift'
+ ;; modifier does not appear on them. (Unfortunately, we have no
+ ;; way of determining Shift-key status on non-alphabetic ASCII
+ ;; keysyms. However, in this case, using Shift will invoke a
+ ;; separate command from the non-shifted version, so the
+ ;; "shifted motion" paradigm makes no sense.)
+ (or (memq 'shift (event-modifiers last-input-event))
+ (let ((key (event-key last-input-event)))
+ (and (characterp key)
+ (not (eq key (downcase key)))))))
+ (let ((in-shifted-motion-command t))
+ (push-mark nil nil t))))
+
+(defun handle-post-motion-command ()
+ (if
+ (and
+ (handle-pre-motion-command-current-command-is-motion)
+ zmacs-regions
+ (region-active-p))
+ ;; Special-case alphabetic keysyms, because the `shift'
+ ;; modifier does not appear on them. See above.
+ (cond ((or (memq 'shift (event-modifiers last-input-event))
+ (let ((key (event-key last-input-event)))
+ (and (characterp key)
+ (not (eq key (downcase key))))))
+ (if shifted-motion-keys-select-region
+ (putf this-command-properties 'shifted-motion-command t))
+ (setq zmacs-region-stays t))
+ ((and (getf last-command-properties 'shifted-motion-command)
+ unshifted-motion-keys-deselect-region)
+ (setq zmacs-region-stays nil)))))
+