X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/c1473b4cfeb477ced05d457868c5e1eb97a58eb0..c5cde04220c3961df41d290dfe3ddbcba821fa26:/lisp/apropos.el diff --git a/lisp/apropos.el b/lisp/apropos.el index a56cd4218e..d3d66f2a07 100644 --- a/lisp/apropos.el +++ b/lisp/apropos.el @@ -1,11 +1,11 @@ ;;; 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-2011 Free Software Foundation, Inc. ;; Author: Joe Wells -;; Rewritten: Daniel Pfeiffer +;; Daniel Pfeiffer (rewrite) ;; Keywords: help +;; Package: emacs ;; This file is part of GNU Emacs. @@ -83,7 +83,7 @@ Slows them down more or less. Set this non-nil if you have a fast machine." :group 'apropos :type 'face) -(defcustom apropos-label-face '(italic variable-pitch) +(defcustom apropos-label-face '(italic) "Face for label (`Command', `Variable' ...) in Apropos output. A value of nil means don't use any special font for them, and also turns off mouse highlighting." @@ -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 @@ -121,15 +121,12 @@ If value is `verbose', the computed score is shown for each match." (const :tag "show scores" verbose))) (defvar apropos-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map button-buffer-map) + (let ((map (copy-keymap button-buffer-map))) + (set-keymap-parent map special-mode-map) ;; Use `apropos-follow' instead of just using the button ;; definition of RET, so that users can use it anywhere in an ;; apropos item, not just on top of a button. (define-key map "\C-m" 'apropos-follow) - (define-key map " " 'scroll-up) - (define-key map "\177" 'scroll-down) - (define-key map "q" 'quit-window) map) "Keymap used in Apropos mode.") @@ -158,7 +155,17 @@ If value is `verbose', the computed score is shown for each match." "List of elc files already scanned in current run of `apropos-documentation'.") (defvar apropos-accumulator () - "Alist of symbols already found in current apropos run.") + "Alist of symbols already found in current apropos run. +Each element has the form + + (SYMBOL SCORE FUN-DOC VAR-DOC PLIST WIDGET-DOC FACE-DOC CUS-GROUP-DOC) + +where SYMBOL is the symbol name, SCORE is its relevance score (a +number), FUN-DOC is the function docstring, VAR-DOC is the +variable docstring, PLIST is the list of the symbols names in the +property list, WIDGET-DOC is the widget docstring, FACE-DOC is +the face docstring, and CUS-GROUP-DOC is the custom group +docstring. Each docstring is either nil or a string.") (defvar apropos-item () "Current item in or for `apropos-accumulator'.") @@ -179,8 +186,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." @@ -191,6 +197,7 @@ term, and the rest of the words are alternative terms.") (define-button-type 'apropos-function 'apropos-label "Function" 'apropos-short-label "f" + 'face '(font-lock-function-name-face button) 'help-echo "mouse-2, RET: Display more help on this function" 'follow-link t 'action (lambda (button) @@ -199,6 +206,7 @@ term, and the rest of the words are alternative terms.") (define-button-type 'apropos-macro 'apropos-label "Macro" 'apropos-short-label "m" + 'face '(font-lock-function-name-face button) 'help-echo "mouse-2, RET: Display more help on this macro" 'follow-link t 'action (lambda (button) @@ -207,6 +215,7 @@ term, and the rest of the words are alternative terms.") (define-button-type 'apropos-command 'apropos-label "Command" 'apropos-short-label "c" + 'face '(font-lock-function-name-face button) 'help-echo "mouse-2, RET: Display more help on this command" 'follow-link t 'action (lambda (button) @@ -220,6 +229,7 @@ term, and the rest of the words are alternative terms.") (define-button-type 'apropos-variable 'apropos-label "Variable" 'apropos-short-label "v" + 'face '(font-lock-variable-name-face button) 'help-echo "mouse-2, RET: Display more help on this variable" 'follow-link t 'action (lambda (button) @@ -228,6 +238,7 @@ term, and the rest of the words are alternative terms.") (define-button-type 'apropos-face 'apropos-label "Face" 'apropos-short-label "F" + 'face '(font-lock-variable-name-face button) 'help-echo "mouse-2, RET: Display more help on this face" 'follow-link t 'action (lambda (button) @@ -236,6 +247,7 @@ term, and the rest of the words are alternative terms.") (define-button-type 'apropos-group 'apropos-label "Group" 'apropos-short-label "g" + 'face '(font-lock-builtin-face button) 'help-echo "mouse-2, RET: Display more help on this group" 'follow-link t 'action (lambda (button) @@ -245,14 +257,16 @@ term, and the rest of the words are alternative terms.") (define-button-type 'apropos-widget 'apropos-label "Widget" 'apropos-short-label "w" + 'face '(font-lock-builtin-face button) 'help-echo "mouse-2, RET: Display more help on this widget" 'follow-link t 'action (lambda (button) (widget-browse-other-window (button-get button 'apropos-symbol)))) (define-button-type 'apropos-plist - 'apropos-label "Plist" + 'apropos-label "Properties" 'apropos-short-label "p" + 'face '(font-lock-keyword-face button) 'help-echo "mouse-2, RET: Display more help on this plist" 'follow-link t 'action (lambda (button) @@ -375,8 +389,8 @@ Value is a list of offsets of the words into the string." "Return apropos score for documentation string DOC." (let ((l (length doc))) (if (> l 0) - (let ((score 0) i) - (when (setq i (string-match apropos-pattern-quoted doc)) + (let ((score 0)) + (when (string-match apropos-pattern-quoted doc) (setq score 10000)) (dolist (s (apropos-calc-scores doc apropos-all-words) score) (setq score (+ score 50 (/ (* (- l s) 50) l))))) @@ -411,7 +425,7 @@ This requires that at least 2 keywords (unless only one was given)." "Return t if DOC is really matched by the current keywords." (apropos-true-hit doc apropos-all-words)) -(define-derived-mode apropos-mode fundamental-mode "Apropos" +(define-derived-mode apropos-mode special-mode "Apropos" "Major mode for following hyperlinks in output of apropos commands. \\{apropos-mode-map}") @@ -467,7 +481,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 +504,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 +584,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 +608,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))) @@ -635,21 +654,32 @@ thus be found in `load-history'." "(not documented)")) (when (boundp symbol) (apropos-documentation-property - symbol 'variable-documentation t)) - (when (setq properties (symbol-plist symbol)) - (setq doc (list (car properties))) - (while (setq properties (cdr (cdr properties))) - (setq doc (cons (car properties) doc))) - (mapconcat #'symbol-name (nreverse doc) " ")) - (when (get symbol 'widget-type) - (apropos-documentation-property - symbol 'widget-documentation t)) - (when (facep symbol) + symbol 'variable-documentation t)) + (when (setq properties (symbol-plist symbol)) + (setq doc (list (car properties))) + (while (setq properties (cdr (cdr properties))) + (setq doc (cons (car properties) doc))) + (mapconcat #'symbol-name (nreverse doc) " ")) + (when (get symbol 'widget-type) (apropos-documentation-property - symbol 'face-documentation t)) + symbol 'widget-documentation t)) + (when (facep symbol) + (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))))) + (apropos-documentation-property + symbol 'group-documentation t))))) symbols))) (apropos-print keys nil text))) @@ -721,8 +751,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 @@ -806,7 +835,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 +854,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))) @@ -954,19 +990,13 @@ If non-nil TEXT is a string that will be printed as a heading." (with-output-to-temp-buffer "*Apropos*" (let ((p apropos-accumulator) (old-buffer (current-buffer)) + (inhibit-read-only t) symbol item) (set-buffer standard-output) (apropos-mode) - (if (display-mouse-p) - (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")) - (insert "In this buffer, go to the name of the command, or function," - " or variable,\n" - (substitute-command-keys - "and type \\[apropos-follow] to get full documentation.\n\n")) + (insert (substitute-command-keys "Type \\[apropos-follow] on ") + (if apropos-multi-type "a type label" "an entry") + " to view its full documentation.\n\n") (if text (insert text "\n\n")) (dolist (apropos-item p) (when (and spacing (not (bobp))) @@ -980,6 +1010,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! @@ -1047,8 +1078,7 @@ If non-nil TEXT is a string that will be printed as a heading." (apropos-print-doc 5 'apropos-widget t) (apropos-print-doc 4 'apropos-plist nil)) (set (make-local-variable 'truncate-partial-width-windows) t) - (set (make-local-variable 'truncate-lines) t) - (setq buffer-read-only t)))) + (set (make-local-variable 'truncate-lines) t)))) (prog1 apropos-accumulator (setq apropos-accumulator ()))) ; permit gc @@ -1064,25 +1094,51 @@ If non-nil TEXT is a string that will be printed as a heading." (defun apropos-print-doc (i type do-keys) - (when (stringp (setq i (nth i apropos-item))) - (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 - (insert-text-button - (if apropos-compact-layout - (button-type-get type 'apropos-label) - (format "<%s>" (button-type-get type 'apropos-short-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)) - (or (bolp) (terpri)))) + (let ((doc (nth i apropos-item))) + (when (stringp doc) + (if apropos-compact-layout + (insert (propertize "\t" 'display '(space :align-to 32)) " ") + (insert " ")) + (if apropos-multi-type + (let ((button-face (button-type-get type 'face))) + (unless (consp button-face) + (setq button-face (list button-face))) + (insert-text-button + (if apropos-compact-layout + (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 (append button-face apropos-label-face) + 'apropos-symbol (car apropos-item)) + (insert (if apropos-compact-layout " " ": "))) + + ;; 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))) + + (let ((opoint (point)) + (ocol (current-column))) + (cond ((equal doc "") + (setq doc "(not documented)")) + (do-keys + (setq doc (substitute-command-keys doc)))) + (insert doc) + (if (equal doc "(not documented)") + (put-text-property opoint (point) 'font-lock-face 'shadow)) + ;; The labeling buttons might make the line too long, so fill it if + ;; necessary. + (let ((fill-column (+ 5 (if (integerp emacs-lisp-docstring-fill-column) + emacs-lisp-docstring-fill-column + fill-column))) + (fill-prefix (make-string ocol ?\s))) + (fill-region opoint (point) nil t))) + (or (bolp) (terpri))))) (defun apropos-follow () "Invokes any button at point, otherwise invokes the nearest label button." @@ -1094,7 +1150,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 ") @@ -1109,5 +1166,4 @@ If non-nil TEXT is a string that will be printed as a heading." (provide 'apropos) -;; arch-tag: d56fa2ac-e56b-4ce3-84ff-852f9c0dc66e ;;; apropos.el ends here