X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/7cb78ecd636d513a4ef95b677034512caf6424d3..9dec0f7642296c34dfd3700c6094808ce6ed289e:/lisp/apropos.el diff --git a/lisp/apropos.el b/lisp/apropos.el index a0ac773cd2..09de0c08e1 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, 2010 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 @@ -466,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 @@ -489,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 (ignore-errors (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)"))) @@ -565,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) @@ -588,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))) @@ -644,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))))) @@ -720,8 +736,7 @@ Returns list of symbols and documentation found." (apropos-sort-by-scores apropos-documentation-sort-by-scores) f v sf sv) (unwind-protect - (save-excursion - (set-buffer standard-input) + (with-current-buffer standard-input (apropos-documentation-check-doc-file) (if do-all (mapatoms @@ -805,7 +820,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)) @@ -824,7 +839,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))) @@ -960,8 +982,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 @@ -1078,8 +1099,8 @@ If non-nil TEXT is a string that will be printed as a heading." '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! @@ -1099,7 +1120,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 ")