apropos.el 16.1 KB
Newer Older
Eric S. Raymond's avatar
Eric S. Raymond committed
1 2
;;; apropos.el --- faster apropos commands.

Karl Heuer's avatar
Karl Heuer committed
3
;; Copyright (C) 1989, 1994 Free Software Foundation, Inc.
Eric S. Raymond's avatar
Eric S. Raymond committed
4

Eric S. Raymond's avatar
Eric S. Raymond committed
5
;; Author: Joe Wells <jbw@bigbird.bu.edu>
Eric S. Raymond's avatar
Eric S. Raymond committed
6
;; Keywords: help
Eric S. Raymond's avatar
Eric S. Raymond committed
7

Richard M. Stallman's avatar
Richard M. Stallman committed
8 9 10 11
;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
Eric S. Raymond's avatar
Eric S. Raymond committed
12
;; the Free Software Foundation; either version 2, or (at your option)
Richard M. Stallman's avatar
Richard M. Stallman committed
13 14 15 16 17 18 19 20 21 22 23
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.

Eric S. Raymond's avatar
Eric S. Raymond committed
24
;;; Commentary:
Richard M. Stallman's avatar
Richard M. Stallman committed
25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45

;; The ideas for this package were derived from the C code in
;; src/keymap.c and elsewhere.  The functions in this file should
;; always be byte-compiled for speed.  Someone should rewrite this in
;; C (as part of src/keymap.c) for speed.

;; The idea for super-apropos is based on the original implementation
;; by Lynn Slater <lrs@esl.com>.

;; History:
;; Fixed bug, current-local-map can return nil.
;; Change, doesn't calculate key-bindings unless needed.
;; Added super-apropos capability, changed print functions.
;; Made fast-apropos and super-apropos share code.
;; Sped up fast-apropos again.
;; Added apropos-do-all option.
;; Added fast-command-apropos.
;; Changed doc strings to comments for helping functions.
;; Made doc file buffer read-only, buried it.
;; Only call substitute-command-keys if do-all set.

Eric S. Raymond's avatar
Eric S. Raymond committed
46 47
;;; Code:

Richard M. Stallman's avatar
Richard M. Stallman committed
48 49 50 51 52 53
(defvar apropos-do-all nil
  "*Whether `apropos' and `super-apropos' should do everything that they can.
Makes them run 2 or 3 times slower.  Set this non-nil if you have a fast
machine.")

;;;###autoload
54
(defun apropos (regexp &optional do-all pred no-header)
Richard M. Stallman's avatar
Richard M. Stallman committed
55
  "Show all symbols whose names contain matches for REGEXP.
56 57
If optional argument DO-ALL is non-nil (prefix argument if interactive),
or if `apropos-do-all' is non-nil, does more (time-consuming) work such as
Richard M. Stallman's avatar
Richard M. Stallman committed
58 59 60
showing key bindings.  Optional argument PRED is called with each symbol, and
if it returns nil, the symbol is not shown.

61 62 63
Optional argument NO-HEADER means don't print `Function:' or `Variable:'
in the output.

Richard M. Stallman's avatar
Richard M. Stallman committed
64 65 66 67 68 69 70 71
Returns list of symbols and documentation found."
  (interactive "sApropos (regexp): \nP")
  (setq do-all (or apropos-do-all do-all))
  (let ((apropos-accumulate (apropos-internal regexp pred)))
    (if (null apropos-accumulate)
	(message "No apropos matches for `%s'" regexp)
      (apropos-get-doc apropos-accumulate)
      (with-output-to-temp-buffer "*Help*"
72 73
	(apropos-print-matches apropos-accumulate regexp nil
			       do-all no-header)))
Richard M. Stallman's avatar
Richard M. Stallman committed
74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95
    apropos-accumulate))

;; Takes LIST of symbols and adds documentation.  Modifies LIST in place.
;; Resulting alist is of form ((symbol fn-doc var-doc) ...).  Should only be
;; called by apropos.  Returns LIST.

(defun apropos-get-doc (list)
  (let ((p list)
	fn-doc var-doc symbol)
    (while (consp p)
      (setq symbol (car p)
	    fn-doc (and (fboundp symbol)
			(documentation symbol))
	    var-doc (documentation-property symbol 'variable-documentation)
	    fn-doc (and fn-doc
			(substring fn-doc 0 (string-match "\n" fn-doc)))
	    var-doc (and var-doc
			 (substring var-doc 0 (string-match "\n" var-doc))))
      (setcar p (list symbol fn-doc var-doc))
      (setq p (cdr p)))
    list))

96 97 98 99 100 101 102 103
;; Variables bound by super-apropos and used by its subroutines.
;; It would be good to say what each one is for, but I don't know -- rms.
(defvar apropos-item)
(defvar apropos-var-doc)
(defvar apropos-fn-doc)
(defvar apropos-accumulate)
(defvar apropos-regexp
  "Within `super-apropos', this holds the REGEXP argument.")
104
(defvar apropos-files-scanned)
105

Richard M. Stallman's avatar
Richard M. Stallman committed
106 107 108
;;;###autoload
(defun super-apropos (regexp &optional do-all)
  "Show symbols whose names/documentation contain matches for REGEXP.
109 110
If optional argument DO-ALL is non-nil (prefix argument if interactive),
or if `apropos-do-all' is non-nil, does more (time-consuming) work such as
Richard M. Stallman's avatar
Richard M. Stallman committed
111 112 113 114 115 116
showing key bindings and documentation that is not stored in the documentation
file.

Returns list of symbols and documentation found."
  (interactive "sSuper Apropos: \nP")
  (setq do-all (or apropos-do-all do-all))
117
  (let ((apropos-regexp regexp)
118 119 120 121 122
	apropos-accumulate apropos-fn-doc apropos-var-doc apropos-item
	apropos-files-scanned)
    (setq apropos-accumulate
	  (super-apropos-check-doc-file apropos-regexp))
    (if do-all (mapatoms 'super-apropos-accumulate))
Richard M. Stallman's avatar
Richard M. Stallman committed
123
    (if (null apropos-accumulate)
124
	(message "No apropos matches for `%s'" apropos-regexp)
Richard M. Stallman's avatar
Richard M. Stallman committed
125
      (with-output-to-temp-buffer "*Help*"
126 127
	(setq apropos-accumulate
	      (apropos-print-matches apropos-accumulate nil t do-all))))
Richard M. Stallman's avatar
Richard M. Stallman committed
128 129 130 131 132 133
    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)
134
  (let* ((doc-file (concat doc-directory internal-doc-file-name))
135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165
	 (doc-buffer (get-buffer-create  " apropos-temp"))
	 type symbol doc sym-list)
    (unwind-protect
	(save-excursion
	  (set-buffer doc-buffer)
	  (buffer-disable-undo)
	  (erase-buffer)
	  (insert-file-contents doc-file)
	  (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))))
		  apropos-item (assq symbol sym-list))
	    (and (if (= type 1)
		     (and (fboundp symbol) (documentation symbol))
		   (documentation-property symbol 'variable-documentation))
		 (or apropos-item
		     (setq apropos-item (list symbol nil nil)
			   sym-list (cons apropos-item sym-list)))
		 (setcar (nthcdr type apropos-item) doc))))
      (kill-buffer doc-buffer))
Richard M. Stallman's avatar
Richard M. Stallman committed
166 167
    sym-list))

168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210
(defun super-apropos-check-elc-file (regexp file)
  (let* ((doc-buffer (get-buffer-create " apropos-temp"))
	 symbol doc length beg end this-is-a-variable)
    (unwind-protect
	(save-excursion
	  (set-buffer doc-buffer)
	  (buffer-disable-undo)
	  (erase-buffer)
	  (insert-file-contents file)
	  (while (search-forward "\n#@" nil t)
	    ;; Read the comment length, and advance over it.
	    (setq length (read (current-buffer)))
	    (setq beg (point))
	    (setq end (+ (point) length 1))
	    (if (re-search-forward regexp end t)
		(progn 
		  (setq this-is-a-variable (save-excursion
					     (goto-char end)
					     (looking-at "(defvar\\|(defconst"))
			symbol (save-excursion
				 (goto-char end)
				 (skip-chars-forward "(a-z")
				 (forward-char 1)
				 (read doc-buffer))
			symbol (if (consp symbol)
				   (nth 1 symbol)
				 symbol)
			doc (buffer-substring (1+ beg) (- end 2))
			apropos-item (assq symbol apropos-accumulate))
		  (and (if this-is-a-variable
			   (documentation-property symbol 'variable-documentation)
			 (and (fboundp symbol) (documentation symbol)))
		       (or apropos-item
			   (setq apropos-item (list symbol nil nil)
				 apropos-accumulate (cons apropos-item
							  apropos-accumulate)))
		       (setcar (nthcdr (if this-is-a-variable 2 1)
				       apropos-item)
			       doc))))
	    (goto-char end)))
      (kill-buffer doc-buffer))
    apropos-accumulate))

Richard M. Stallman's avatar
Richard M. Stallman committed
211 212
;; 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
213
;; documentation on that symbol if it matches a variable regexp.
Richard M. Stallman's avatar
Richard M. Stallman committed
214 215

(defun super-apropos-accumulate (symbol)
216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244
  (let (doc)
    (cond ((string-match apropos-regexp (symbol-name symbol))
	   (setq apropos-item (apropos-get-accum-item symbol))
	   (setcar (cdr apropos-item)
		   (or (safe-documentation symbol)
		       (nth 1 apropos-item)))
	   (setcar (nthcdr 2 apropos-item)
		   (or (safe-documentation-property symbol)
		       (nth 2 apropos-item))))
	  ((or (consp (setq doc (safe-documentation symbol)))
	       (consp (setq doc (safe-documentation-property symbol))))
	   ;; This symbol's doc is stored in a file.
	   ;; Scan the file if we have not scanned it before.
	   (let ((file (car doc)))
	     (or (member file apropos-files-scanned)
		 (progn
		   (setq apropos-files-scanned
			 (cons file apropos-files-scanned))
		   (super-apropos-check-elc-file apropos-regexp file)))))
	  (t
	   (and (stringp (setq doc (safe-documentation symbol)))
		(setq apropos-fn-doc doc)
		(string-match apropos-regexp apropos-fn-doc)
		(setcar (cdr (apropos-get-accum-item symbol)) apropos-fn-doc))
	   (and (stringp (setq doc (safe-documentation-property symbol)))
		(setq apropos-var-doc doc)
		(string-match apropos-regexp apropos-var-doc)
		(setcar (nthcdr 2 (apropos-get-accum-item symbol))
			apropos-var-doc)))))
Richard M. Stallman's avatar
Richard M. Stallman committed
245 246 247 248 249 250 251 252 253 254 255
  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.

256 257
(defun apropos-print-matches (matches &optional regexp
				      spacing do-all no-header)
Richard M. Stallman's avatar
Richard M. Stallman committed
258 259 260 261 262
  (setq matches (sort matches (function
			       (lambda (a b)
				 (string-lessp (car a) (car b))))))
  (let ((p matches)
	(old-buffer (current-buffer))
263
	item keys-done symbol tem)
Richard M. Stallman's avatar
Richard M. Stallman committed
264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287
    (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))
288 289 290 291 292 293 294
	       (let ((substed (if do-all (substitute-command-keys tem) tem)))
		 (if no-header
		     (princ "  ")
		   (princ "  Function: ")
		   (if (> (length substed) 67)
		       (princ "\n  ")))
		 (princ substed))))
Richard M. Stallman's avatar
Richard M. Stallman committed
295 296
	(or (bolp) (terpri))
	(cond ((setq tem (nth 2 item))
297 298 299 300 301 302 303
	       (let ((substed (if do-all (substitute-command-keys tem) tem)))
		 (if no-header
		     (princ "  ")
		   (princ "  Variable: ")
		   (if (> (length substed) 67)
		       (princ "\n  ")))
		 (princ substed))))
304 305
	(or (bolp) (terpri)))
      (help-mode)))
306
  matches)
Richard M. Stallman's avatar
Richard M. Stallman committed
307 308 309 310 311 312 313 314

;; 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))
315 316 317 318 319 320 321 322 323 324
	 ;; Get a list of the top-level maps now active.
	 (top-maps
	  (if overriding-local-map
	      (list overriding-local-map (current-global-map))
	    (append (current-minor-mode-maps)
		    (if current-local-map
			(list current-local-map (current-global-map))
		      (list (current-global-map))))))
	 ;; Turn that into a list of all the maps including submaps.
	 (maps (apply 'append (mapcar 'accessible-keymaps top-maps)))
Richard M. Stallman's avatar
Richard M. Stallman committed
325 326 327 328 329 330 331 332 333 334 335 336
	 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))
337 338 339 340
      ;; Skip the leading `keymap', doc string, etc.
      (if (eq (car map) 'keymap)
	  (setq map (cdr map)))
      (while (stringp (car-safe map))
Richard M. Stallman's avatar
Richard M. Stallman committed
341
	(setq map (cdr map)))
342

343 344
      (while (consp map)
	(cond ((consp (car map))
Richard M. Stallman's avatar
Richard M. Stallman committed
345
	       (setq command (cdr (car map))
346
		     key (car (car map)))
347 348 349 350 351 352
	       ;; Skip any menu prompt and help string in this key binding.
	       (while (and (consp command) (stringp (car command)))
		 (setq command (cdr command)))
	       ;; Skip any cached equivalent key.
	       (and (consp command)
		    (consp (car command))
353 354 355 356 357
		    (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)
358 359 360
		    (if regexp
			(string-match regexp (symbol-name command))
		      t)
361 362 363 364 365 366 367 368 369 370 371
		    (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))
372 373 374
		    ;; check if this binding is already recorded
		    ;; (this can happen due to inherited keymaps)
		    (not (member key (nthcdr 3 item)))
375 376 377 378 379 380 381 382 383 384 385 386 387 388
		    ;; 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)
389 390 391
			(if regexp
			    (string-match regexp (symbol-name command))
			  t)
392 393 394 395 396 397 398 399 400 401 402
			(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))
403 404 405
			;; check if this binding is already recorded
			;; (this can happen due to inherited keymaps)
			(not (member key (nthcdr 3 item)))
406 407 408 409
			;; add this key binding to the item in alist
			(nconc item (cons key nil)))
		   (setq i (1+ i))))))
	(setq map (cdr map)))))
Richard M. Stallman's avatar
Richard M. Stallman committed
410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428
  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)
      (progn
	(setq apropos-accumulate
	      (cons (list symbol nil nil) apropos-accumulate))
	(assq symbol apropos-accumulate))))

(defun safe-documentation (function)
  "Like documentation, except it avoids calling `get_doc_string'.
Will return nil instead."
  (while (symbolp function)
    (setq function (if (fboundp function)
		       (symbol-function function)
		     0)))
429 430
  (if (eq (car-safe function) 'macro)
      (setq function (cdr function)))
431 432 433 434
  (if (byte-code-function-p function)
      (if (> (length function) 4)
	  (aref function 4))
    (if (not (consp function))
Richard M. Stallman's avatar
Richard M. Stallman committed
435
	nil
436 437 438 439 440 441
      (if (not (memq (car function) '(lambda autoload)))
	  nil
	(setq function (nth 2 function))
	(if (stringp function)
	    function
	  nil)))))
Richard M. Stallman's avatar
Richard M. Stallman committed
442 443 444 445 446 447 448 449 450

(defun safe-documentation-property (symbol)
  "Like documentation-property, except it avoids calling `get_doc_string'.
Will return nil instead."
  (setq symbol (get symbol 'variable-documentation))
  (if (numberp symbol)
      nil
    symbol))

Eric S. Raymond's avatar
Eric S. Raymond committed
451
;;; apropos.el ends here