Re: substitute-key-definition problem with menus in Emacs 21

[Richard Stallman]

Do these replacement functions do the job?

(defun substitute-key-definition (olddef newdef keymap &optional oldmap prefix)
  "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF.
In other words, OLDDEF is replaced with NEWDEF where ever it appears.
Alternatively, if optional fourth argument OLDMAP is specified, we redefine
in KEYMAP as NEWDEF those keys which are defined as OLDDEF in OLDMAP."
  ;; Don't document PREFIX in the doc string because we don't want to
  ;; advertise it.  It's meant for recursive calls only.  Here's its
  ;; meaning

  ;; If optional argument PREFIX is specified, it should be a key
  ;; prefix, a string.  Redefined bindings will then be bound to the
  ;; original key, with PREFIX added at the front.
  (or prefix (setq prefix ""))
  (let* ((scan (or oldmap keymap))
         (vec1 (vector nil))
         (prefix1 (vconcat prefix vec1))
         (key-substitution-in-progress
          (cons scan key-substitution-in-progress)))
    ;; Scan OLDMAP, finding each char or event-symbol that
    ;; has any definition, and act on it with hack-key.
    (while (consp scan)
      (if (consp (car scan))
          (let ((char (car (car scan)))
                (defn (cdr (car scan))))
            ;; The inside of this let duplicates exactly
            ;; the inside of the following let that handles array elements.
            (aset vec1 0 char)
            (aset prefix1 (length prefix) char)
            (substitute-key-definition-key defn olddef newdef prefix1 keymap))
        (if (vectorp (car scan))
            (let* ((array (car scan))
                   (len (length array))
                   (i 0))
              (while (< i len)
                (let ((char i) (defn (aref array i)))
                  ;; The inside of this let duplicates exactly
                  ;; the inside of the previous let.
                  (aset vec1 0 char)
                  (aset prefix1 (length prefix) char)
                  (substitute-key-definition-key defn olddef newdef prefix1 
keymap))
                (setq i (1+ i))))
          (if (char-table-p (car scan))
              (map-char-table
               (function (lambda (char defn)
                           ;; The inside of this duplicates exactly
                           ;; the inside of the previous let,
                           ;; except that it uses set-char-table-range
                           ;; instead of define-key.
                           (aset vec1 0 char)
                           (aset prefix1 (length prefix) char)
                           (substitute-key-definition-key defn olddef newdef 
prefix1 keymap)))
               (car scan)))))
      (setq scan (cdr scan)))))

(defun substitute-key-definition-key (defn olddef newdef prefix1 keymap)
  (let (inner-def skipped menu-item)
    ;; Find the actual command name within the binding.
    (if (eq (car-safe defn) 'menu-item)
        (setq menu-item defn defn (nth 2 defn))
      ;; Skip past menu-prompt.
      (while (stringp (car-safe defn))
        (setq skipped (cons (car defn) skipped))
        (setq defn (cdr defn)))
      ;; Skip past cached key-equivalence data for menu items.
      (and (consp defn) (consp (car defn))
           (setq defn (cdr defn))))
    ;; Look past a symbol that names a keymap.
    (setq inner-def defn)
    (while (and (symbolp inner-def)
                (fboundp inner-def))
      (setq inner-def (symbol-function inner-def)))
    (if (or (eq defn olddef)
            ;; Compare with equal if definition is a key sequence.
            ;; That is useful for operating on function-key-map.
            (and (or (stringp defn) (vectorp defn))
                 (equal defn olddef)))
        (define-key keymap prefix1
          (if menu-item
              (let ((copy (copy-sequence menu-item)))
                (setcar (nthcdr 2 copy) newdef)
                copy)
            (nconc (nreverse skipped) newdef)))
      (if (and (keymapp defn)
               ;; Avoid recursively scanning
               ;; where KEYMAP does not have a submap.
               (let ((elt (lookup-key keymap prefix1)))
                 (or (null elt)
                     (keymapp elt)))
               ;; Avoid recursively rescanning keymap being scanned.
               (not (memq inner-def
                          key-substitution-in-progress)))
          ;; If this one isn't being scanned already,
          ;; scan it now.
          (substitute-key-definition olddef newdef keymap
                                     inner-def
                                     prefix1)))))