home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.004 / xemacs-1 / xemacs-19.13 / lisp / prim / keymap.el < prev    next >
Encoding:
Text File  |  1995-06-30  |  15.9 KB  |  374 lines
  1. ;; Keymap functions.
  2. ;; Copyright (C) 1993, 1994 Free Software Foundation, Inc.
  3. ;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
  4.  
  5. ;; This file is part of XEmacs.
  6.  
  7. ;; XEmacs is free software; you can redistribute it and/or modify it
  8. ;; under the terms of the GNU General Public License as published by
  9. ;; the Free Software Foundation; either version 2, or (at your option)
  10. ;; any later version.
  11.  
  12. ;; XEmacs is distributed in the hope that it will be useful, but
  13. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. ;; General Public License for more details.
  16.  
  17. ;; You should have received a copy of the GNU General Public License
  18. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  19. ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21. ;;; Synched up with: FSF 19.28.
  22.  
  23. ;; Used by C code (lookup-key and friends) but defined here.
  24. (defvar minor-mode-map-alist nil
  25.   "Alist of keymaps to use for minor modes.
  26. Each element looks like (VARIABLE . KEYMAP); KEYMAP is used to read
  27. key sequences and look up bindings iff VARIABLE's value is non-nil.
  28. If two active keymaps bind the same key, the keymap appearing earlier
  29. in the list takes precedence.")
  30.  
  31. (defvar modeline-map (let ((m (make-sparse-keymap)))
  32.                (set-keymap-name m 'modeline-map)
  33.                m)
  34.   "Keymap consulted for mouse-clicks on the modeline of a window.
  35. This variable may be buffer-local; its value will be looked up in
  36. the buffer of the window whose modeline was clicked upon.")
  37.  
  38. (defvar toolbar-map (let ((m (make-sparse-keymap)))
  39.               (set-keymap-name m 'toolbar-map)
  40.               m)
  41.   "Keymap consulted for mouse-clicks over a toolbar.")
  42.  
  43. ;Prevent the \{...} documentation construct
  44. ;from mentioning keys that run this command.
  45. (put 'undefined 'suppress-keymap t)
  46.  
  47. (defun undefined ()
  48.   (interactive)
  49.   (ding))
  50.  
  51. (defun suppress-keymap (map &optional nodigits)
  52.   "Make MAP override all normally self-inserting keys to be undefined.
  53. Normally, as an exception, digits and minus-sign are set to make prefix args,
  54. but optional second arg NODIGITS non-nil treats them like other chars."
  55.   (substitute-key-definition 'self-insert-command 'undefined map global-map)
  56.   (or nodigits
  57.       (let ((string (make-string 1 ?0)))
  58.     (define-key map "-" 'negative-argument)
  59.     ;; Make plain numbers do numeric args.
  60.     (while (<= (aref string 0) ?9)
  61.       (define-key map string 'digit-argument)
  62.       (aset string 0 (1+ (aref string 0)))))))
  63.  
  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
  69. as OLDDEF in OLDMAP, unless that keybinding is already present in keymap.
  70. If optional fifth argument PREFIX is defined, then only those occurrences of
  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)
  82.               (if (eq binding olddef)
  83.               ;; The new bindings always go in KEYMAP even if we
  84.               ;; found them in OLDMAP or one of it's children.
  85.               ;; If KEYMAP will be shadowing OLDMAP, then do not
  86.               ;; redefine the key if there is another binding
  87.               ;; in KEYMAP that will shadow OLDDEF.
  88.               (or (and shadowing
  89.                    (lookup-key keymap key))
  90.                   ;; define-key will give an error if a prefix
  91.                   ;; of the key is already defined.  Otherwise
  92.                   ;; it will define the key in the map. 
  93.                   ;; #### - Perhaps this should be protected?
  94.                   (define-key
  95.                 keymap
  96.                 (vconcat prefix (list key))
  97.                 newdef))))
  98.           map)
  99.       )))
  100.  
  101. ;; from Bill Dubuque <wgd@martigny.ai.mit.edu>
  102. (defun insert-key-binding (key)         ; modeled after describe-key
  103.   (interactive "kInsert command bound to key: ")
  104.   (let (defn)
  105.     ;; If the key typed was really a menu selection, grab the form out
  106.     ;; of the event object and intuit the function that would be called,
  107.     ;; and describe that instead.
  108.     (if (and (vectorp key) (= 1 (length key))
  109.              (or (misc-user-event-p (aref key 0))
  110.                  (eq (car-safe (aref key 0)) 'menu-selection)))
  111.         (let ((event (aref key 0)))
  112.           (setq defn (if (eventp event)
  113.                          (list (event-function event) (event-object event))
  114.                        (cdr event)))
  115.           (if (eq (car defn) 'eval)
  116.               (setq defn (` (lambda ()
  117.                               (interactive)
  118.                               (, (car (cdr defn)))))))
  119.           (if (eq (car-safe defn) 'call-interactively)
  120.               (setq defn (car (cdr defn))))
  121.           (if (and (consp defn) (null (cdr defn)))
  122.               (setq defn (car defn))))
  123.       (setq defn (key-binding key)))
  124.     (if (or (null defn) (integerp defn))
  125.         (error "%s is undefined" (key-description key))
  126.       (if (or (stringp defn) (vectorp defn))
  127.           (setq defn (key-binding defn))) ;; a keyboard macro
  128.       (insert (format "%s" defn)))))
  129.  
  130. ;; from Bill Dubuque <wgd@martigny.ai.mit.edu>
  131. (defun read-command-or-command-sexp (prompt)
  132.   "Read a command symbol or command sexp.
  133. A command sexp is wrapped in an interactive lambda if needed.
  134. Prompts with PROMPT."
  135.   ;; Todo: it would be better if we could reject symbols that are not
  136.   ;; commandp (as does 'read-command') but that is not easy to do
  137.   ;; because we must supply arg4 = require-match = nil for sexp case.
  138.   (let ((result (car (read-from-string
  139.                       (completing-read prompt obarray 'commandp)))))
  140.     (if (and (consp result)
  141.              (not (eq (car result) 'lambda)))
  142.         (` (lambda ()
  143.              (interactive)
  144.              (, result)))
  145.       result)))
  146.  
  147. (defun local-key-binding (keys)
  148.   "Return the binding for command KEYS in current local keymap only.
  149. KEYS is a string, a vector of events, or a vector of key-description lists
  150. as described in the documentation for the `define-key' function.
  151. The binding is probably a symbol with a function definition; see
  152. the documentation for `lookup-key' for more information."
  153.   (let ((map (current-local-map)))
  154.     (if map
  155.         (lookup-key map keys)
  156.         nil)))
  157.  
  158. (defun global-key-binding (keys)
  159.   "Return the binding for command KEYS in current global keymap only.
  160. KEYS is a string or vector of events, a sequence of keystrokes.
  161. The binding is probably a symbol with a function definition; see
  162. the documentation for `lookup-key' for more information."
  163.   (lookup-key (current-global-map) keys))
  164.  
  165. ;; from Bill Dubuque <wgd@martigny.ai.mit.edu>
  166. (defun global-set-key (keys function)
  167.   "Give KEY a global binding as COMMAND.
  168. COMMAND is a symbol naming an interactively-callable function.
  169. KEYS is a string, a vector of events, or a vector of key-description lists
  170. as described in the documentation for the `define-key' function.
  171. Note that if KEY has a local binding in the current buffer
  172. that local binding will continue to shadow any global binding."
  173.   ;;(interactive "kSet key globally: \nCSet key %s to command: ")
  174.   (interactive (list (setq keys (read-key-sequence "Set key globally: "))
  175.                      ;; Command sexps are allowed here so that this arg
  176.                      ;; may be supplied interactively via insert-key-binding.
  177.                      (read-command-or-command-sexp
  178.                        (format "Set key %s to command: "
  179.                                (key-description keys)))))
  180.   (define-key (current-global-map) keys function))
  181.  
  182. ;; from Bill Dubuque <wgd@martigny.ai.mit.edu>
  183. (defun local-set-key (keys function)
  184.   "Give KEY a local binding as COMMAND.
  185. COMMAND is a symbol naming an interactively-callable function.
  186. KEYS is a string, a vector of events, or a vector of key-description lists
  187. as described in the documentation for the `define-key' function.
  188. The binding goes in the current buffer's local map,
  189. which is shared with other buffers in the same major mode."
  190.   ;;(interactive "kSet key locally: \nCSet key %s locally to command: ")
  191.   (interactive (list (setq keys (read-key-sequence "Set key locally: "))
  192.                      ;; Command sexps are allowed here so that this arg
  193.                      ;; may be supplied interactively via insert-key-binding.
  194.                      (read-command-or-command-sexp
  195.                        (format "Set key %s locally to command: "
  196.                                (key-description keys)))))
  197.   (if (null (current-local-map))
  198.       (use-local-map (make-sparse-keymap)))
  199.   (define-key (current-local-map) keys function))
  200.  
  201. (defun global-unset-key (keys)
  202.   "Remove global binding of KEY.
  203. KEYS is a string, a vector of events, or a vector of key-description lists
  204. as described in the documentation for the `define-key' function."
  205.   (interactive "kUnset key globally: ")
  206.   (global-set-key keys nil))
  207.  
  208. (defun local-unset-key (keys)
  209.   "Remove local binding of KEY.
  210. KEYS is a string, a vector of events, or a vector of key-description lists
  211. as described in the documentation for the `define-key' function."
  212.   (interactive "kUnset key locally: ")
  213.   (if (current-local-map)
  214.       (define-key (current-local-map) keys nil)))
  215.  
  216.  
  217. ;; Yet more RMS brain-death.
  218. (defun minor-mode-key-binding (key &optional accept-default)
  219.   "Find the visible minor mode bindings of KEY.
  220. Return an alist of pairs (MODENAME . BINDING), where MODENAME is the
  221. the symbol which names the minor mode binding KEY, and BINDING is
  222. KEY's definition in that mode.  In particular, if KEY has no
  223. minor-mode bindings, return nil.  If the first binding is a
  224. non-prefix, all subsequent bindings will be omitted, since they would
  225. be ignored.  Similarly, the list doesn't include non-prefix bindings
  226. that come after prefix bindings.
  227.  
  228. If optional argument ACCEPT-DEFAULT is non-nil, recognize default
  229. bindings; see the description of `lookup-key' for more details about this."
  230.   (let ((tail minor-mode-map-alist)
  231.         a s v)
  232.     (while tail
  233.       (setq a (car tail)
  234.             tail (cdr tail))
  235.       (and (consp a)
  236.            (symbolp (setq s (car a)))
  237.            (boundp s)
  238.            (symbol-value s)
  239.            ;; indirect-function deals with autoloadable keymaps
  240.            (setq v (indirect-function (cdr a)))
  241.            (setq v (lookup-key v key accept-default))
  242.            ;; Terminate loop, with v set to non-nil value
  243.            (setq tail nil)))
  244.     v))
  245.     
  246.  
  247. (defun current-minor-mode-maps ()
  248.   "Return a list of keymaps for the minor modes of the current buffer."
  249.   (let ((l '())
  250.         (tail minor-mode-map-alist)
  251.         a s v)
  252.     (while tail
  253.       (setq a (car tail)
  254.             tail (cdr tail))
  255.       (and (consp a)
  256.            (symbolp (setq s (car a)))
  257.            (boundp s)
  258.            (symbol-value s)
  259.            ;; indirect-function deals with autoloadable keymaps
  260.            (setq v (indirect-function (cdr a)))
  261.            (setq l (cons v l))))
  262.     (nreverse l)))
  263.  
  264.  
  265. ;;#### What a crock
  266. (defun define-prefix-command (name &optional mapvar)
  267.   "Define COMMAND as a prefix command.
  268. A new sparse keymap is stored as COMMAND's function definition.
  269. If second optional argument MAPVAR is not specified,
  270.  COMMAND's value (as well as its function definition) is set to the keymap.
  271. If a second optional argument MAPVAR is given and is not `t',
  272.   the map is stored as its value.
  273. Regardless of MAPVAR, COMMAND's function-value is always set to the keymap."
  274.   (let ((map (make-sparse-keymap)))
  275.     (set-keymap-name map name)
  276.     (fset name map)
  277.     (cond ((not mapvar)
  278.            (set name map))
  279.           ((eq mapvar 't)
  280.            )
  281.           (t
  282.            (set mapvar map)))
  283.     name))
  284.  
  285.  
  286. ;;; Converting vectors of events to a read-equivalent form.
  287. ;;; This is used both by call-interactively (for the command history)
  288. ;;; and by macros.el (for saving keyboard macros to a file).
  289.  
  290. (defun events-to-keys (events &optional no-mice)
  291.  "Given a vector of event objects, returns a vector of key descriptors,
  292. or a string (if they all fit in the ASCII range).
  293. Optional arg NO-MICE means that button events are not allowed."
  294.  (if (and events (symbolp events)) (setq events (vector events)))
  295.  (cond ((stringp events)
  296.         events)
  297.        ((not (vectorp events))
  298.         (signal 'wrong-type-argument (list 'vectorp events)))
  299.        ((let* ((length (length events))
  300.                (string (make-string length 0))
  301.                c ce
  302.                (i 0))
  303.           (while (< i length)
  304.             (setq ce (aref events i))
  305.             (or (eventp ce) (setq ce (character-to-event ce)))
  306.             ;; Normalize `c' to `?c' and `(control k)' to `?\C-k'
  307.             ;; By passing t for the `allow-meta' arg we could get kbd macros
  308.             ;; with meta in them to translate to the string form instead of
  309.             ;; the list/symbol form; but I expect that would cause confusion,
  310.             ;; so let's use the list/symbol form whenever there's 
  311.             ;; any ambiguity.
  312.             (setq c (event-to-character ce))
  313.             (if (and c
  314.                      character-set-property
  315.                      (key-press-event-p ce))
  316.                 (cond ((symbolp (event-key ce))
  317.                        (if (get (event-key ce) character-set-property)
  318.                            ;; Don't use a string for `backspace' and `tab' to
  319.                            ;;  avoid that unpleasant little ambiguity.
  320.                            (setq c nil)))
  321.                       ((and (= (event-modifier-bits ce) 1) ;control
  322.                             (integerp (event-key ce)))
  323.                        (let* ((te (character-to-event c)))
  324.                          (if (and (symbolp (event-key te))
  325.                                   (get (event-key te) character-set-property))
  326.                              ;; Don't "normalize" (control i) to tab
  327.                              ;;  to avoid the ambiguity in the other direction
  328.                              (setq c nil))
  329.                          (deallocate-event te)))))
  330.             (if c
  331.                 (aset string i c)
  332.                 (setq i length string nil))
  333.             (setq i (1+ i)))
  334.           string))
  335.        (t
  336.         (let* ((length (length events))
  337.                (new (copy-sequence events))
  338.                event mods key
  339.                (i 0))
  340.           (while (< i length)
  341.             (setq event (aref events i))
  342.             (cond ((key-press-event-p event)
  343.                    (setq mods (event-modifiers event)
  344.                          key (event-key event))
  345.                    (if (numberp key)
  346.                        (setq key (intern (make-string 1 key))))
  347.                    (aset new i (if mods
  348.                                    (nconc mods (cons key nil))
  349.                                    key)))
  350.                   ((misc-user-event-p event)
  351.                    (aset new i (list 'menu-selection
  352.                                      (event-function event)
  353.                                      (event-object event))))
  354.                   ((or (button-press-event-p event)
  355.                        (button-release-event-p event))
  356.                    (if no-mice
  357.                        (error 
  358.                          "Mouse events can't be saved in keyboard macros."))
  359.                    (setq mods (event-modifiers event)
  360.                          key (intern (concat "button"
  361.                                              (event-button event)
  362.                                              (if (button-release-event-p event)
  363.                                                  "up" ""))))
  364.                    (aset new i (if mods
  365.                                    (nconc mods (cons key nil))
  366.                                    key)))
  367.                   ((or (and event (symbolp event))
  368.                        (and (consp event) (symbolp (car event))))
  369.                    (aset new i event))
  370.                   (t
  371.                    (signal 'wrong-type-argument (list 'eventp event))))
  372.             (setq i (1+ i)))
  373.           new))))
  374.