- (interactive "sSuper Apropos: \nP")
- (setq do-all (or apropos-do-all do-all))
- (let (apropos-accumulate fn-doc var-doc item)
- (setq apropos-accumulate (super-apropos-check-doc-file regexp))
- (if (null apropos-accumulate)
- (message "No apropos matches for `%s'" regexp)
- (if do-all (mapatoms 'super-apropos-accumulate))
- (with-output-to-temp-buffer "*Help*"
- (apropos-print-matches apropos-accumulate nil t do-all)))
- apropos-accumulate))
-
-;; Finds all documentation related to REGEXP in internal-doc-file-name.
-;; Returns an alist of form ((symbol fn-doc var-doc) ...).
-
-(defun super-apropos-check-doc-file (regexp)
- (let* ((doc-file (concat data-directory internal-doc-file-name))
- (doc-buffer (find-file-noselect doc-file t))
- ;; (doc-buffer (or (get-file-buffer doc-file)
- ;; (find-file-noselect doc-file)))
- type symbol doc sym-list)
- (save-excursion
- (set-buffer doc-buffer)
- ;; a user said he might accidentally edit the doc file
- (setq buffer-read-only t)
- (bury-buffer doc-buffer)
- (goto-char (point-min))
- (while (re-search-forward regexp nil t)
- (search-backward "\C-_")
- (setq type (if (eq ?F (char-after (1+ (point))))
- 1 ;function documentation
- 2) ;variable documentation
- symbol (progn
- (forward-char 2)
- (read doc-buffer))
- doc (buffer-substring
- (point)
- (progn
- (if (search-forward "\C-_" nil 'move)
- (1- (point))
- (point))))
- item (assq symbol sym-list))
- (or item
- (setq item (list symbol nil nil)
- sym-list (cons item sym-list)))
- (setcar (nthcdr type item) doc)))
- sym-list))
-
-;; This is passed as the argument to map-atoms, so it is called once for every
-;; symbol in obarray. Takes one argument SYMBOL, and finds any memory-resident
-;; documentation on that symbol if it matches a variable regexp. WARNING: this
-;; function depends on the symbols fn-doc var-doc regexp and item being bound
-;; correctly when it is called!"
-
-(defun super-apropos-accumulate (symbol)
- (cond ((string-match regexp (symbol-name symbol))
- (setq item (apropos-get-accum-item symbol))
- (setcar (cdr item) (or (safe-documentation symbol)
- (nth 1 item)))
- (setcar (nthcdr 2 item) (or (safe-documentation-property symbol)
- (nth 2 item))))
- (t
- (and (setq fn-doc (safe-documentation symbol))
- (string-match regexp fn-doc)
- (setcar (cdr (apropos-get-accum-item symbol)) fn-doc))
- (and (setq var-doc (safe-documentation-property symbol))
- (string-match regexp var-doc)
- (setcar (nthcdr 2 (apropos-get-accum-item symbol)) var-doc))))
- nil)
-
-;; Prints the symbols and documentation in alist MATCHES of form ((symbol
-;; fn-doc var-doc) ...). Uses optional argument REGEXP to speed up searching
-;; for keybindings. The names of all symbols in MATCHES must match REGEXP.
-;; Displays in the buffer pointed to by standard-output. Optional argument
-;; SPACING means put blank lines in between each symbol's documentation.
-;; Optional argument DO-ALL means do more time-consuming work, specifically,
-;; consulting key bindings. Should only be called within a
-;; with-output-to-temp-buffer.
-
-(defun apropos-print-matches (matches &optional regexp spacing do-all)
- (setq matches (sort matches (function
- (lambda (a b)
- (string-lessp (car a) (car b))))))
- (let ((p matches)
- (old-buffer (current-buffer))
- item keys-done symbol tem)
- (save-excursion
- (set-buffer standard-output)
- (or matches (princ "No matches found."))
- (while (consp p)
- (setq item (car p)
- symbol (car item)
- p (cdr p))
- (or (not spacing) (bobp) (terpri))
- (princ symbol) ;print symbol name
- ;; don't calculate key-bindings unless needed
- (cond ((and do-all (commandp symbol) (not keys-done))
- (save-excursion
- (set-buffer old-buffer)
- (apropos-match-keys matches regexp))
- (setq keys-done t)))
- (cond ((and do-all
- (or (setq tem (nthcdr 3 item))
- (commandp symbol)))
- (indent-to 30 1)
- (if tem
- (princ (mapconcat 'key-description tem ", "))
- (princ "(not bound to any keys)"))))
- (terpri)
- (cond ((setq tem (nth 1 item))
- (princ " Function: ")
- (princ (if do-all (substitute-command-keys tem) tem))))
- (or (bolp) (terpri))
- (cond ((setq tem (nth 2 item))
- (princ " Variable: ")
- (princ (if do-all (substitute-command-keys tem) tem))))
- (or (bolp) (terpri)))))
- t)
-
-;; Find key bindings for symbols that are cars in ALIST. Optionally, first
-;; match the symbol name against REGEXP. Modifies ALIST in place. Each key
-;; binding is added as a string to the end of the list in ALIST whose car is
-;; the corresponding symbol. The pointer to ALIST is returned.
-
-(defun apropos-match-keys (alist &optional regexp)
- (let* ((current-local-map (current-local-map))
- (maps (append (and current-local-map
- (accessible-keymaps current-local-map))
- (accessible-keymaps (current-global-map))))
- map ;map we are now inspecting
- sequence ;key sequence to reach map
- i ;index into vector map
- command ;what is bound to current keys
- key ;last key to reach command
- local ;local binding for sequence + key
- item) ;symbol data item in alist
- ;; examine all reachable keymaps
- (while (consp maps)
- (setq map (cdr (car maps))
- sequence (car (car maps)) ;keys to reach this map
- maps (cdr maps))
- ;; Skip the leading `keymap', doc string, etc.
- (if (eq (car map) 'keymap)
- (setq map (cdr map)))
- (while (stringp (car-safe map))
- (setq map (cdr map)))
- (while (consp map)
- (cond ((consp (car map))
- (setq command (cdr (car map))
- key (car (car map)))
- ;; Skip any menu prompt in this key binding.
- (and (consp command) (symbolp (cdr command))
- (setq command (cdr command)))
- ;; if is a symbol, and matches optional regexp, and is a car
- ;; in alist, and is not shadowed by a different local binding,
- ;; record it
- (and (symbolp command)
- (if regexp (string-match regexp (symbol-name command)))
- (setq item (assq command alist))
- (if (or (vectorp sequence) (not (integerp key)))
- (setq key (vconcat sequence (vector key)))
- (setq key (concat sequence (char-to-string key))))
- ;; checking if shadowed by local binding.
- ;; either no local map, no local binding, or runs off the
- ;; binding tree (number), or is the same binding
- (or (not current-local-map)
- (not (setq local (lookup-key current-local-map key)))
- (numberp local)
- (eq command local))
- ;; add this key binding to the item in alist
- (nconc item (cons key nil))))
- ((vectorp (car map))
- (let ((i 0)
- (vec (car map))
- (len (length (car map))))
- (while (< i len)
- (setq command (aref vec i))
- (setq key i)
- ;; Skip any menu prompt in this key binding.
- (and (consp command) (symbolp (cdr command))
- (setq command (cdr command)))
- ;; This is the same as the code in the previous case.
- (and (symbolp command)
- (if regexp (string-match regexp (symbol-name command)))
- (setq item (assq command alist))
- (if (or (vectorp sequence) (not (integerp key)))
- (setq key (vconcat sequence (vector key)))
- (setq key (concat sequence (char-to-string key))))
- ;; checking if shadowed by local binding.
- ;; either no local map, no local binding, or runs off the
- ;; binding tree (number), or is the same binding
- (or (not current-local-map)
- (not (setq local (lookup-key current-local-map key)))
- (numberp local)
- (eq command local))
- ;; add this key binding to the item in alist
- (nconc item (cons key nil)))
- (setq i (1+ i))))))
- (setq map (cdr map)))))
- alist)
-
-;; Get an alist item in alist apropos-accumulate whose car is SYMBOL. Creates
-;; the item if not already present. Modifies apropos-accumulate in place.
-
-(defun apropos-get-accum-item (symbol)
- (or (assq symbol apropos-accumulate)