lisp/keymap.el

   1 ;; keymap.el --- Keymap functions for XEmacs.
   2
   3 ;; Copyright (C) 1993-4, 1997 Free Software Foundation, Inc.
   4 ;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
   5
   6 ;; Maintainer: XEmacs Development Team
   7 ;; Keywords: internals, dumped
   8
   9 ;; This file is part of XEmacs.
  10
  11 ;; XEmacs is free software; you can redistribute it and/or modify it
  12 ;; under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; XEmacs is distributed in the hope that it will be useful, but
  17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with XEmacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Synched up with: FSF 19.28.
  27
  28 ;;; Commentary:
  29
  30 ;; This file is dumped with XEmacs.
  31
  32 ;;; Note: FSF does not have a file keymap.el.  This stuff is
  33 ;;; in keymap.c.
  34
  35 ;Prevent the \{...} documentation construct
  36 ;from mentioning keys that run this command.
  37
  38 ;;; Code:
  39
  40 (put 'undefined 'suppress-keymap t)
  41
  42 (defun undefined ()
  43   (interactive)
  44   (ding))
  45
  46 (defmacro kbd (keys)
  47   "Convert KEYS to the internal Emacs key representation.
  48 KEYS should be a string in the format used for saving keyboard macros
  49 \(see `insert-kbd-macro')."
  50   (if (or (stringp keys)
  51           (vectorp keys))
  52       (read-kbd-macro keys)
  53     `(read-kbd-macro ,keys)))
  54
  55 (defun suppress-keymap (map &optional nodigits)
  56   "Make MAP override all normally self-inserting keys to be undefined.
  57 Normally, as an exception, digits and minus-sign are set to make prefix args,
  58 but optional second arg NODIGITS non-nil treats them like other chars."
  59   (substitute-key-definition 'self-insert-command 'undefined map global-map)
  60   (or nodigits
  61       (let ((string (make-string 1 ?0)))
  62         (define-key map "-" 'negative-argument)
  63         ;; Make plain numbers do numeric args.
  64         (while (<= (aref string 0) ?9)
  65           (define-key map string 'digit-argument)
  66           (incf (aref string 0))))))
  67
  68 (defun substitute-key-definition (olddef newdef keymap &optional oldmap prefix)
  69   "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF.
  70 In other words, OLDDEF is replaced with NEWDEF wherever it appears.
  71 Prefix keymaps are checked recursively.  If optional fourth argument OLDMAP
  72 is specified, we redefine in KEYMAP as NEWDEF those chars which are defined
  73 as OLDDEF in OLDMAP, unless that keybinding is already present in KEYMAP.
  74 If optional fifth argument PREFIX is non-nil, then only those occurrences of
  75 OLDDEF found in keymaps accessible through the keymap bound to PREFIX in
  76 KEYMAP are redefined.  See also `accessible-keymaps'."
  77   (let ((maps (accessible-keymaps (or oldmap keymap) prefix))
  78         (shadowing (not (null oldmap)))
  79         prefix map)
  80     (while maps
  81       (setq prefix (car (car maps))
  82             map (cdr (car maps))
  83             maps (cdr maps))
  84       ;; Substitute in this keymap
  85       (map-keymap #'(lambda (key binding)
  86                       (if (eq binding olddef)
  87                           ;; The new bindings always go in KEYMAP even if we
  88                           ;; found them in OLDMAP or one of its children.
  89                           ;; If KEYMAP will be shadowing OLDMAP, then do not
  90                           ;; redefine the key if there is another binding
  91                           ;; in KEYMAP that will shadow OLDDEF.
  92                           (or (and shadowing
  93                                    (lookup-key keymap key))
  94                               ;; define-key will give an error if a prefix
  95                               ;; of the key is already defined.  Otherwise
  96                               ;; it will define the key in the map.
  97                               ;; #### - Perhaps this should be protected?
  98                               (define-key
  99                                 keymap
 100                                 (vconcat prefix (list key))
 101                                 newdef))))
 102                   map)
 103       )))
 104
 105
 106 ;; This used to wrap forms into an interactive lambda.  It is unclear
 107 ;; to me why this is needed in this function.  Anyway,
 108 ;; `key-or-menu-binding' doesn't do it, so this function no longer
 109 ;; does it, either.
 110 (defun insert-key-binding (key)         ; modeled after describe-key
 111   "Insert the command bound to KEY."
 112   (interactive "kInsert command bound to key: ")
 113   (let ((defn (key-or-menu-binding key)))
 114     (if (or (null defn) (integerp defn))
 115         (error "%s is undefined" (key-description key))
 116       (if (or (stringp defn) (vectorp defn))
 117           (setq defn (key-binding defn))) ;; a keyboard macro
 118       (insert (format "%s" defn)))))
 119
 120 (defun read-command-or-command-sexp (prompt)
 121   "Read a command symbol or command sexp.
 122 A command sexp is wrapped in an interactive lambda if needed.
 123 Prompts with PROMPT."
 124   ;; Todo: it would be better if we could reject symbols that are not
 125   ;; commandp (as does 'read-command') but that is not easy to do
 126   ;; because we must supply arg4 = require-match = nil for sexp case.
 127   (let ((result (car (read-from-string
 128                       (completing-read prompt obarray 'commandp)))))
 129     (if (and (consp result)
 130              (not (eq (car result) 'lambda)))
 131         `(lambda ()
 132            (interactive)
 133            ,result)
 134       result)))
 135
 136 (defun local-key-binding (keys &optional accept-defaults)
 137   "Return the binding for command KEYS in current local keymap only.
 138 KEYS is a string, a vector of events, or a vector of key-description lists
 139 as described in the documentation for the `define-key' function.
 140 The binding is probably a symbol with a function definition; see
 141 the documentation for `lookup-key' for more information."
 142   (let ((map (current-local-map)))
 143     (if map
 144         (lookup-key map keys accept-defaults)
 145         nil)))
 146
 147 (defun global-key-binding (keys &optional accept-defaults)
 148   "Return the binding for command KEYS in current global keymap only.
 149 KEYS is a string or vector of events, a sequence of keystrokes.
 150 The binding is probably a symbol with a function definition; see
 151 the documentation for `lookup-key' for more information."
 152   (lookup-key (current-global-map) keys accept-defaults))
 153
 154 (defun global-set-key (key command)
 155   "Give KEY a global binding as COMMAND.
 156 COMMAND is a symbol naming an interactively-callable function.
 157 KEY is a string, a vector of events, or a vector of key-description lists
 158 as described in the documentation for the `define-key' function.
 159 Note that if KEY has a local binding in the current buffer
 160 that local binding will continue to shadow any global binding."
 161   ;;(interactive "KSet key globally: \nCSet key %s to command: ")
 162   (interactive (list (setq key (read-key-sequence "Set key globally: "))
 163                      ;; Command sexps are allowed here so that this arg
 164                      ;; may be supplied interactively via insert-key-binding.
 165                      (read-command-or-command-sexp
 166                        (format "Set key %s to command: "
 167                                (key-description key)))))
 168   (define-key (current-global-map) key command)
 169   nil)
 170
 171 (defun local-set-key (key command)
 172   "Give KEY a local binding as COMMAND.
 173 COMMAND is a symbol naming an interactively-callable function.
 174 KEY is a string, a vector of events, or a vector of key-description lists
 175 as described in the documentation for the `define-key' function.
 176 The binding goes in the current buffer's local map,
 177 which is shared with other buffers in the same major mode."
 178   ;;(interactive "KSet key locally: \nCSet key %s locally to command: ")
 179   (interactive (list (setq key (read-key-sequence "Set key locally: "))
 180                      ;; Command sexps are allowed here so that this arg
 181                      ;; may be supplied interactively via insert-key-binding.
 182                      (read-command-or-command-sexp
 183                        (format "Set key %s locally to command: "
 184                                (key-description key)))))
 185   (if (null (current-local-map))
 186       (use-local-map (make-sparse-keymap)))
 187   (define-key (current-local-map) key command)
 188   nil)
 189
 190 (defun global-unset-key (key)
 191   "Remove global binding of KEY.
 192 KEY is a string, a vector of events, or a vector of key-description lists
 193 as described in the documentation for the `define-key' function."
 194   (interactive "kUnset key globally: ")
 195   (global-set-key key nil))
 196
 197 (defun local-unset-key (key)
 198   "Remove local binding of KEY.
 199 KEY is a string, a vector of events, or a vector of key-description lists
 200 as described in the documentation for the `define-key' function."
 201   (interactive "kUnset key locally: ")
 202   (if (current-local-map)
 203       (define-key (current-local-map) key nil)))
 204
 205 \f
 206 ;; FSF-inherited brain-death.
 207 (defun minor-mode-key-binding (key &optional accept-default)
 208   "Find the visible minor mode bindings of KEY.
 209 Return an alist of pairs (MODENAME . BINDING), where MODENAME is
 210 the symbol which names the minor mode binding KEY, and BINDING is
 211 KEY's definition in that mode.  In particular, if KEY has no
 212 minor-mode bindings, return nil.  If the first binding is a
 213 non-prefix, all subsequent bindings will be omitted, since they would
 214 be ignored.  Similarly, the list doesn't include non-prefix bindings
 215 that come after prefix bindings.
 216
 217 If optional argument ACCEPT-DEFAULT is non-nil, recognize default
 218 bindings; see the description of `lookup-key' for more details about this."
 219   (let ((tail minor-mode-map-alist)
 220         a s v)
 221     (while tail
 222       (setq a (car tail)
 223             tail (cdr tail))
 224       (and (consp a)
 225            (symbolp (setq s (car a)))
 226            (boundp s)
 227            (symbol-value s)
 228            ;; indirect-function deals with autoloadable keymaps
 229            (setq v (indirect-function (cdr a)))
 230            (setq v (lookup-key v key accept-default))
 231            ;; Terminate loop, with v set to non-nil value
 232            (setq tail nil)))
 233     v))
 234
 235
 236 (defun current-minor-mode-maps ()
 237   "Return a list of keymaps for the minor modes of the current buffer."
 238   (let ((l '())
 239         (tail minor-mode-map-alist)
 240         a s v)
 241     (while tail
 242       (setq a (car tail)
 243             tail (cdr tail))
 244       (and (consp a)
 245            (symbolp (setq s (car a)))
 246            (boundp s)
 247            (symbol-value s)
 248            ;; indirect-function deals with autoloadable keymaps
 249            (setq v (indirect-function (cdr a)))
 250            (setq l (cons v l))))
 251     (nreverse l)))
 252
 253 \f
 254 ;;#### What a crock
 255 (defun define-prefix-command (name &optional mapvar)
 256   "Define COMMAND as a prefix command.
 257 A new sparse keymap is stored as COMMAND's function definition.
 258 If second optional argument MAPVAR is not specified,
 259  COMMAND's value (as well as its function definition) is set to the keymap.
 260 If a second optional argument MAPVAR is given and is not `t',
 261   the map is stored as its value.
 262 Regardless of MAPVAR, COMMAND's function-value is always set to the keymap."
 263   (let ((map (make-sparse-keymap name)))
 264     (fset name map)
 265     (cond ((not mapvar)
 266            (set name map))
 267           ((eq mapvar 't)
 268            )
 269           (t
 270            (set mapvar map)))
 271     name))
 272
 273 \f
 274 ;;; Converting vectors of events to a read-equivalent form.
 275 ;;; This is used both by call-interactively (for the command history)
 276 ;;; and by macros.el (for saving keyboard macros to a file).
 277
 278 ;; #### why does (events-to-keys [backspace]) return "\C-h"?
 279 ;; BTW, this function is a mess, and macros.el does *not* use it, in
 280 ;; spite of the above comment.  `format-kbd-macro' is used to save
 281 ;; keyboard macros to a file.
 282 (defun events-to-keys (events &optional no-mice)
 283  "Given a vector of event objects, returns a vector of key descriptors,
 284 or a string (if they all fit in the ASCII range).
 285 Optional arg NO-MICE means that button events are not allowed."
 286  (if (and events (symbolp events)) (setq events (vector events)))
 287  (cond ((stringp events)
 288         events)
 289        ((not (vectorp events))
 290         (signal 'wrong-type-argument (list 'vectorp events)))
 291        ((let* ((length (length events))
 292                (string (make-string length 0))
 293                c ce
 294                (i 0))
 295           (while (< i length)
 296             (setq ce (aref events i))
 297             (or (eventp ce) (setq ce (character-to-event ce)))
 298             ;; Normalize `c' to `?c' and `(control k)' to `?\C-k'
 299             ;; By passing t for the `allow-meta' arg we could get kbd macros
 300             ;; with meta in them to translate to the string form instead of
 301             ;; the list/symbol form; but I expect that would cause confusion,
 302             ;; so let's use the list/symbol form whenever there's
 303             ;; any ambiguity.
 304             (setq c (event-to-character ce))
 305             (if (and c
 306                      character-set-property
 307                      (key-press-event-p ce))
 308                 (cond ((symbolp (event-key ce))
 309                        (if (get (event-key ce) character-set-property)
 310                            ;; Don't use a string for `backspace' and `tab' to
 311                            ;;  avoid that unpleasant little ambiguity.
 312                            (setq c nil)))
 313                       ((and (= (event-modifier-bits ce) 1) ;control
 314                             (integerp (event-key ce)))
 315                        (let* ((te (character-to-event c)))
 316                          (if (and (symbolp (event-key te))
 317                                   (get (event-key te) character-set-property))
 318                              ;; Don't "normalize" (control i) to tab
 319                              ;;  to avoid the ambiguity in the other direction
 320                              (setq c nil))
 321                          (deallocate-event te)))))
 322             (if c
 323                 (aset string i c)
 324                 (setq i length string nil))
 325             (setq i (1+ i)))
 326           string))
 327        (t
 328         (let* ((length (length events))
 329                (new (copy-sequence events))
 330                event mods key
 331                (i 0))
 332           (while (< i length)
 333             (setq event (aref events i))
 334             (cond ((key-press-event-p event)
 335                    (setq mods (event-modifiers event)
 336                          key (event-key event))
 337                    (if (numberp key)
 338                        (setq key (intern (make-string 1 key))))
 339                    (aset new i (if mods
 340                                    (nconc mods (cons key nil))
 341                                    key)))
 342                   ((misc-user-event-p event)
 343                    (aset new i (list 'menu-selection
 344                                      (event-function event)
 345                                      (event-object event))))
 346                   ((or (button-press-event-p event)
 347                        (button-release-event-p event))
 348                    (if no-mice
 349                        (error
 350                          "Mouse events can't be saved in keyboard macros."))
 351                    (setq mods (event-modifiers event)
 352                          key (intern (format "button%d%s"
 353                                              (event-button event)
 354                                              (if (button-release-event-p event)
 355                                                  "up" ""))))
 356                    (aset new i (if mods
 357                                    (nconc mods (cons key nil))
 358                                    key)))
 359                   ((or (and event (symbolp event))
 360                        (and (consp event) (symbolp (car event))))
 361                    (aset new i event))
 362                   (t
 363                    (signal 'wrong-type-argument (list 'eventp event))))
 364             (setq i (1+ i)))
 365           new))))
 366
 367 \f
 368 (defun next-key-event ()
 369   "Return the next available keyboard event."
 370   (let (event)
 371     (while (not (key-press-event-p (setq event (next-command-event))))
 372       (dispatch-event event))
 373     event))
 374
 375 (defun key-sequence-list-description (keys)
 376   "Convert a key sequence KEYS to the full [(modifiers... key)...] form.
 377 Argument KEYS can be in any form accepted by `define-key' function."
 378   (let ((vec
 379           (cond ((vectorp keys)
 380                  keys)
 381                 ((stringp keys)
 382                  (vconcat keys))
 383                 (t
 384                  (vector keys))))
 385          (event-to-list
 386           #'(lambda (ev)
 387             (append (event-modifiers ev) (list (event-key ev))))))
 388     (mapvector
 389      #'(lambda (key)
 390        (cond ((key-press-event-p key)
 391               (funcall event-to-list key))
 392              ((characterp key)
 393               (funcall event-to-list (character-to-event key)))
 394              ((listp key)
 395               key)
 396              (t
 397               (list key))))
 398      vec)))
 399
 400 \f
 401 ;;; Support keyboard commands to turn on various modifiers.
 402
 403 ;;; These functions -- which are not commands -- each add one modifier
 404 ;;; to the following event.
 405
 406 (defun event-apply-alt-modifier (ignore-prompt)
 407   (event-apply-modifier 'alt))
 408 (defun event-apply-super-modifier (ignore-prompt)
 409   (event-apply-modifier 'super))
 410 (defun event-apply-hyper-modifier (ignore-prompt)
 411   (event-apply-modifier 'hyper))
 412 (defun event-apply-shift-modifier (ignore-prompt)
 413   (event-apply-modifier 'shift))
 414 (defun event-apply-control-modifier (ignore-prompt)
 415   (event-apply-modifier 'control))
 416 (defun event-apply-meta-modifier (ignore-prompt)
 417   (event-apply-modifier 'meta))
 418
 419 ;;; #### `key-translate-map' is ignored for now.
 420 (defun event-apply-modifier (symbol)
 421   "Return the next key event, with a modifier flag applied.
 422 SYMBOL is the name of this modifier, as a symbol.
 423 `function-key-map' is scanned for prefix bindings."
 424   (let (events binding)
 425     ;; read keystrokes scanning `function-key-map'
 426     (while (keymapp
 427             (setq binding
 428                   (lookup-key
 429                    function-key-map
 430                    (vconcat
 431                     (setq events
 432                           (append events (list (next-key-event)))))))))
 433     (if binding                         ; found a binding
 434         (progn
 435           ;; allow for several modifiers
 436           (if (and (symbolp binding) (fboundp binding))
 437               (setq binding (funcall binding nil)))
 438           (setq events (append binding nil))
 439           ;; put remaining keystrokes back into input queue
 440           (setq unread-command-events
 441                 (mapcar 'character-to-event (cdr events))))
 442       (setq unread-command-events (cdr events)))
 443     ;; add a modifier SYMBOL to the first keystroke or event
 444     (vector
 445      (append (list symbol)
 446              (delq symbol
 447                    (aref (key-sequence-list-description (car events)) 0))))))
 448
 449 (defun synthesize-keysym (ignore-prompt)
 450   "Read a sequence of keys, and returned the corresponding key symbol.
 451 The characters must be from the [-_a-zA-Z0-9].  Reading is terminated
 452  by RET (which is discarded)."
 453   (let ((continuep t)
 454         event char list)
 455     (while continuep
 456       (setq event (next-key-event))
 457       (cond ((and (setq char (event-to-character event))
 458                   (or (memq char '(?- ?_))
 459                       (eq ?w (char-syntax char (standard-syntax-table)))))
 460              ;; Advance a character.
 461              (push char list))
 462             ((or (memq char '(?\r ?\n))
 463                  (memq (event-key event) '(return newline)))
 464              ;; Legal termination.
 465              (setq continuep nil))
 466             (char
 467              ;; Illegal character.
 468              (error "Illegal character in keysym: %c" char))
 469             (t
 470              ;; Illegal event.
 471              (error "Event has no character equivalent: %s" event))))
 472     (vector (intern (concat "" (nreverse list))))))
 473
 474 ;; This looks dirty.  The following code should maybe go to another
 475 ;; file, and `create-console-hook' should maybe default to nil.
 476 (add-hook
 477  'create-console-hook
 478  #'(lambda (console)
 479    (letf (((selected-console) console))
 480      (define-key function-key-map [?\C-x ?@ ?h] 'event-apply-hyper-modifier)
 481      (define-key function-key-map [?\C-x ?@ ?s] 'event-apply-super-modifier)
 482      (define-key function-key-map [?\C-x ?@ ?m] 'event-apply-meta-modifier)
 483      (define-key function-key-map [?\C-x ?@ ?S] 'event-apply-shift-modifier)
 484      (define-key function-key-map [?\C-x ?@ ?c] 'event-apply-control-modifier)
 485      (define-key function-key-map [?\C-x ?@ ?a] 'event-apply-alt-modifier)
 486      (define-key function-key-map [?\C-x ?@ ?k] 'synthesize-keysym))))
 487
 488 ;;; keymap.el ends here