X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/7ad8fe5e2876518a8f33b80050f98dab4ff78398..2b34df4ebc935a834a77b930b35c4a42f7236440:/lisp/apropos.el diff --git a/lisp/apropos.el b/lisp/apropos.el index a56cd4218e..45463784cb 100644 --- a/lisp/apropos.el +++ b/lisp/apropos.el @@ -1,10 +1,10 @@ ;;; apropos.el --- apropos commands for users and programmers -;; Copyright (C) 1989, 1994, 1995, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. +;; Copyright (C) 1989, 1994, 1995, 2001, 2002, 2003, 2004, 2005, 2006, +;; 2007, 2008, 2009 Free Software Foundation, Inc. ;; Author: Joe Wells -;; Rewritten: Daniel Pfeiffer +;; Daniel Pfeiffer (rewrite) ;; Keywords: help ;; This file is part of GNU Emacs. @@ -112,7 +112,7 @@ If value is `verbose', the computed score is shown for each match." (const :tag "show scores" verbose))) (defcustom apropos-documentation-sort-by-scores t - "*Non-nil means sort matches by scores; best match is shown first. + "Non-nil means sort matches by scores; best match is shown first. This applies to `apropos-documentation' only. If value is `verbose', the computed score is shown for each match." :group 'apropos @@ -179,8 +179,7 @@ term, and the rest of the words are alternative terms.") 'face apropos-symbol-face 'help-echo "mouse-2, RET: Display more help on this symbol" 'follow-link t - 'action #'apropos-symbol-button-display-help - 'skip t) + 'action #'apropos-symbol-button-display-help) (defun apropos-symbol-button-display-help (button) "Display further help for the `apropos-symbol' button BUTTON." @@ -467,7 +466,7 @@ while a list of strings is used as a word list." (apropos-parse-pattern pattern) (let ((message (let ((standard-output (get-buffer-create "*Apropos*"))) - (print-help-return-message 'identity)))) + (help-print-return-message 'identity)))) (or do-all (setq do-all apropos-do-all)) (setq apropos-accumulator (apropos-internal apropos-regexp @@ -490,8 +489,12 @@ while a list of strings is used as a word list." (setq score (apropos-score-symbol symbol)) (unless var-predicate (if (fboundp symbol) - (if (setq doc (documentation symbol t)) - (progn + (if (setq doc (condition-case nil + (documentation symbol t) + (error 'error))) + ;; Eg alias to undefined function. + (if (eq doc 'error) + "(documentation error)" (setq score (+ score (apropos-score-doc doc))) (substring doc 0 (string-match "\n" doc))) "(not documented)"))) @@ -566,17 +569,18 @@ Returns list of symbols and documentation found." FILE should be one of the libraries currently loaded and should thus be found in `load-history'." (interactive - (let ((libs - (nconc (delq nil - (mapcar - (lambda (l) - (setq l (file-name-nondirectory l)) - (while - (not (equal (setq l (file-name-sans-extension l)) - l))) - l) - (mapcar 'car load-history))) - (mapcar 'car load-history)))) + (let* ((libs (delq nil (mapcar 'car load-history))) + (libs + (nconc (delq nil + (mapcar + (lambda (l) + (setq l (file-name-nondirectory l)) + (while + (not (equal (setq l (file-name-sans-extension l)) + l))) + l) + libs)) + libs))) (list (completing-read "Describe library: " libs nil t)))) (let ((symbols nil) ;; (autoloads nil) @@ -589,7 +593,7 @@ thus be found in `load-history'." (re (concat "\\(?:\\`\\|[\\/]\\)" (regexp-quote file) "\\(\\.\\|\\'\\)"))) (while (and lh (null lh-entry)) - (if (string-match re (caar lh)) + (if (and (caar lh) (string-match re (caar lh))) (setq lh-entry (car lh)) (setq lh (cdr lh))))) (unless lh-entry (error "Unknown library `%s'" file))) @@ -645,8 +649,19 @@ thus be found in `load-history'." (apropos-documentation-property symbol 'widget-documentation t)) (when (facep symbol) - (apropos-documentation-property - symbol 'face-documentation t)) + (let ((alias (get symbol 'face-alias))) + (if alias + (if (facep alias) + (format "%slias for the face `%s'." + (if (get symbol 'obsolete-face) + "Obsolete a" + "A") + alias) + ;; Never happens in practice because fails + ;; (facep symbol) test. + "(alias for undefined face)") + (apropos-documentation-property + symbol 'face-documentation t)))) (when (get symbol 'custom-group) (apropos-documentation-property symbol 'group-documentation t))))) @@ -806,7 +821,7 @@ Returns list of symbols and documentation found." ;; Finds all documentation related to APROPOS-REGEXP in internal-doc-file-name. (defun apropos-documentation-check-doc-file () - (let (type symbol (sepa 2) sepb) + (let (type symbol (sepa 2) sepb doc) (insert ?\^_) (backward-char) (insert-file-contents (concat doc-directory internal-doc-file-name)) @@ -825,7 +840,14 @@ Returns list of symbols and documentation found." 3) ; variable documentation symbol (read) doc (buffer-substring (1+ (point)) (1- sepb))) - (when (apropos-true-hit-doc doc) + (when (and (apropos-true-hit-doc doc) + ;; The DOC file lists all built-in funcs and vars. + ;; If any are not currently bound, they can + ;; only be platform-specific stuff (eg NS) not + ;; in use on the current platform. + ;; So we exclude them. + (cond ((= 3 type) (boundp symbol)) + ((= 2 type) (fboundp symbol)))) (or (and (setq apropos-item (assq symbol apropos-accumulator)) (setcar (cdr apropos-item) (apropos-score-doc doc))) @@ -961,8 +983,7 @@ If non-nil TEXT is a string that will be printed as a heading." (insert "If moving the mouse over text changes the text's color, " "you can click\n" - "mouse-2 (second button from right) on that text to " - "get more information.\n")) + "or press return on that text to get more information.\n")) (insert "In this buffer, go to the name of the command, or function," " or variable,\n" (substitute-command-keys @@ -980,6 +1001,7 @@ If non-nil TEXT is a string that will be printed as a heading." (cons nil (cdr apropos-item))))) (insert-text-button (symbol-name symbol) 'type 'apropos-symbol + 'skip apropos-multi-type ;; Can't use default, since user may have ;; changed the variable! ;; Just say `no' to variables containing faces! @@ -1068,20 +1090,25 @@ If non-nil TEXT is a string that will be printed as a heading." (if apropos-compact-layout (insert (propertize "\t" 'display '(space :align-to 32)) " ") (insert " ")) - ;; If the query is only for a single type, there's - ;; no point writing it over and over again. - (when apropos-multi-type + (if (null apropos-multi-type) + ;; If the query is only for a single type, there's no point + ;; writing it over and over again. Insert a blank button, and + ;; put the 'apropos-label property there (needed by + ;; apropos-symbol-button-display-help). + (insert-text-button + " " 'type type 'skip t + 'face 'default 'apropos-symbol (car apropos-item)) (insert-text-button (if apropos-compact-layout - (button-type-get type 'apropos-label) - (format "<%s>" (button-type-get type 'apropos-short-label))) + (format "<%s>" (button-type-get type 'apropos-short-label)) + (button-type-get type 'apropos-label)) 'type type ;; Can't use the default button face, since user may have changed the ;; variable! Just say `no' to variables containing faces! 'face apropos-label-face 'apropos-symbol (car apropos-item)) (insert (if apropos-compact-layout " " ": "))) - (insert (if do-keys (substitute-command-keys i) i)) + (insert (if do-keys (substitute-command-keys i) i)) (or (bolp) (terpri)))) (defun apropos-follow () @@ -1094,7 +1121,8 @@ If non-nil TEXT is a string that will be printed as a heading." (defun apropos-describe-plist (symbol) "Display a pretty listing of SYMBOL's plist." - (help-setup-xref (list 'apropos-describe-plist symbol) (interactive-p)) + (help-setup-xref (list 'apropos-describe-plist symbol) + (called-interactively-p 'interactive)) (with-help-window (help-buffer) (set-buffer standard-output) (princ "Symbol ")