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