annotate lisp/apropos.el @ 51151:fe11e703042b

Summary: MIME support added for e-mail processing that skips encoded regions. Allow user to skip saving Fcc messages with large attachments. Fixed region skipping bug with multi-line comments - e.g. tex $ regions spanning multiple lines. Added support for postscript and uuencoded regions. Redundant dictionary file names purged. Dictionary definition field name changed from "Character Set" to "Coding System". Fixed bug in reloading dictionaries. Modified headers to reflect new version. XEmacs menu now adds customize item. (ispell-check-version): No longer an aliased function. Returns library path if not called interactively. Variable `temporary-file-directory' protected if not loaded. (check-ispell-version): Now the alias for `ispell-check-version'. (ispell-message-fcc-skip): New variable that determines if and when to query about saving Fcc copy of message if an attachment is large. (ispell-skip-html): Declared buffer-local. (ispell-local-dictionary-alist): Docstring expanded. Tag name changed from "Character Set" to "Coding System". (ispell-dictionary-alist-1): Removed redundant command-line option to load brasileiro, british, and castellano dictionary files. (ispell-dictionary-alist-2): Removed redundant command-line option to load czech dictionary file. (ispell-dictionary-alist-3): Moved francais-tex here. (ispell-dictionary-alist-4): Removed german and german8 dictionaries. The deutsch ones are the correct definitions. `nederlands' and `nederlands8' dictionaries moved here. (ispell-dictionary-alist-5): `polish' and `portugues' dictionaries moved here. Removed redundant command-line option to `norsk' and `portugues'. (ispell-dictionary-alist-6): Removed redundant command-line option to load `russian' and `slovak' dictionary files. (ispell-dictionary-alist): Tag name changed from "Character Set" to "Coding System". (ispell-version): Updated to 3.6. (ispell-library-directory): Calls non-deprecated function. (ispell-valid-dictionary-list): New function returning all valid dictionaries on machine. (ispell-checking-message): Documentation string improved. (ispell-skip-region-alist): Added uuencoded and postscript region skipping. Improved http/e-mail/file regexp to not match `/.\w'. (ispell-html-skip-alists): New variable for html region support. (ispell-send-string): Removed redundant xemacs check. (ispell-word): Fix spelling error in documentation string, added extent information to support highlighting in ispell-minor-mode. (ispell-command-loop): Disable horizontal scrollbar in XEmacs choices buffer. (ispell-show-choices): Directly select `choices-window'. (ispell-help): Use default buffer size for electric help. (ispell-adjusted-window-height): Correct for xemacs detection. (ispell-start-process): Don't double specify dictionary file name. (ispell-init-process): Set `ispell-library-path' each call. (ispell-change-dictionary): Now only completes valid dictionaries. (ispell-region): Add support for MIME region skipping and Fcc message query for large attachments. (ispell-begin-skip-region-regexp): Add documentation string. Added message support and cleaned up code for generic and html regions. (ispell-begin-skip-region): Function is now requires alist argument. (ispell-begin-tex-skip-regexp): Added comments and support improved html and message regions. (ispell-skip-region-list): New function for MIME and region skipping. (ispell-tex-arg-end): Add documentation string. (ispell-ignore-fcc): New function to query saving Fcc message. (ispell-skip-region): Calculate alist for key match dynamically, html skipping pushed to alists. (ispell-get-line): Add support for multi-line comment regions. (ispell): Check that variables to continue spelling are bound. (ispell-message-text-end): Postscript and uuencoded regions now supported as MIME regions, rather than as end-of-message region. (ispell-mime-multipartp): New function supporting MIME. (ispell-mime-skip-part): New function supporting MIME. (ispell-message): Add MIME support. (ispell-buffer-local-parsing): Variable `ispell-skip-html' now local. (ispell-buffer-local-dict): Fixed bug for detecting and reloading new dictionary.

申鐃緒申     1 ;;; apropos.el --- apropos commands for users and programmers
申鐃緒申     2 
申鐃緒申     3 ;; Copyright (C) 1989, 1994, 1995, 2001, 2002 Free Software Foundation, Inc.
申鐃緒申     4 
申鐃緒申     5 ;; Author: Joe Wells <[e-mail]>
申鐃緒申     6 ;; Rewritten: Daniel Pfeiffer <[e-mail]>
申鐃緒申     7 ;; Keywords: help
申鐃緒申     8 
申鐃緒申     9 ;; This file is part of GNU Emacs.
申鐃緒申    10 
申鐃緒申    11 ;; GNU Emacs is free software; you can redistribute it and/or modify
申鐃緒申    12 ;; it under the terms of the GNU General Public License as published by
申鐃緒申    13 ;; the Free Software Foundation; either version 2, or (at your option)
申鐃緒申    14 ;; any later version.
申鐃緒申    15 
申鐃緒申    16 ;; GNU Emacs is distributed in the hope that it will be useful,
申鐃緒申    17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
申鐃緒申    18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
申鐃緒申    19 ;; GNU General Public License for more details.
申鐃緒申    20 
申鐃緒申    21 ;; You should have received a copy of the GNU General Public License
申鐃緒申    22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
申鐃緒申    23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
申鐃緒申    24 ;; Boston, MA 02111-1307, USA.
申鐃緒申    25 
申鐃緒申    26 ;;; Commentary:
申鐃緒申    27 
申鐃緒申    28 ;; The ideas for this package were derived from the C code in
申鐃緒申    29 ;; src/keymap.c and elsewhere.  The functions in this file should
申鐃緒申    30 ;; always be byte-compiled for speed.  Someone should rewrite this in
申鐃緒申    31 ;; C (as part of src/keymap.c) for speed.
申鐃緒申    32 
申鐃緒申    33 ;; The idea for super-apropos is based on the original implementation
申鐃緒申    34 ;; by Lynn Slater <[e-mail]>.
申鐃緒申    35 
申鐃緒申    36 ;; History:
申鐃緒申    37 ;; Fixed bug, current-local-map can return nil.
申鐃緒申    38 ;; Change, doesn't calculate key-bindings unless needed.
申鐃緒申    39 ;; Added super-apropos capability, changed print functions.
申鐃緒申    40 ;;; Made fast-apropos and super-apropos share code.
申鐃緒申    41 ;;; Sped up fast-apropos again.
申鐃緒申    42 ;; Added apropos-do-all option.
申鐃緒申    43 ;;; Added fast-command-apropos.
申鐃緒申    44 ;; Changed doc strings to comments for helping functions.
申鐃緒申    45 ;;; Made doc file buffer read-only, buried it.
申鐃緒申    46 ;; Only call substitute-command-keys if do-all set.
申鐃緒申    47 
申鐃緒申    48 ;; Optionally use configurable faces to make the output more legible.
申鐃緒申    49 ;; Differentiate between command, function and macro.
申鐃緒申    50 ;; Apropos-command (ex command-apropos) does cmd and optionally user var.
申鐃緒申    51 ;; Apropos shows all 3 aspects of symbols (fn, var and plist)
申鐃緒申    52 ;; Apropos-documentation (ex super-apropos) now finds all it should.
申鐃緒申    53 ;; New apropos-value snoops through all values and optionally plists.
申鐃緒申    54 ;; Reading DOC file doesn't load nroff.
申鐃緒申    55 ;; Added hypertext following of documentation, mouse-2 on variable gives value
申鐃緒申    56 ;;   from buffer in active window.
申鐃緒申    57 
申鐃緒申    58 ;;; Code:
申鐃緒申    59 
申鐃緒申    60 (require 'button)
申鐃緒申    61 
申鐃緒申    62 (defgroup apropos nil
申鐃緒申    63   "Apropos commands for users and programmers"
申鐃緒申    64   :group 'help
申鐃緒申    65   :prefix "apropos")
申鐃緒申    66 
申鐃緒申    67 ;; I see a degradation of maybe 10-20% only.
申鐃緒申    68 (defcustom apropos-do-all nil
申鐃緒申    69   "*Whether the apropos commands should do more.
申鐃緒申    70 
申鐃緒申    71 Slows them down more or less.  Set this non-nil if you have a fast machine."
申鐃緒申    72   :group 'apropos
申鐃緒申    73   :type 'boolean)
申鐃緒申    74 
申鐃緒申    75 
申鐃緒申    76 (defcustom apropos-symbol-face 'bold
申鐃緒申    77   "*Face for symbol name in Apropos output, or nil for none."
申鐃緒申    78   :group 'apropos
申鐃緒申    79   :type 'face)
申鐃緒申    80 
申鐃緒申    81 (defcustom apropos-keybinding-face 'underline
申鐃緒申    82   "*Face for lists of keybinding in Apropos output, or nil for none."
申鐃緒申    83   :group 'apropos
申鐃緒申    84   :type 'face)
申鐃緒申    85 
申鐃緒申    86 (defcustom apropos-label-face 'italic
申鐃緒申    87   "*Face for label (`Command', `Variable' ...) in Apropos output.
申鐃緒申    88 A value of nil means don't use any special font for them, and also
申鐃緒申    89 turns off mouse highlighting."
申鐃緒申    90   :group 'apropos
申鐃緒申    91   :type 'face)
申鐃緒申    92 
申鐃緒申    93 (defcustom apropos-property-face 'bold-italic
申鐃緒申    94   "*Face for property name in apropos output, or nil for none."
申鐃緒申    95   :group 'apropos
申鐃緒申    96   :type 'face)
申鐃緒申    97 
申鐃緒申    98 (defcustom apropos-match-face 'secondary-selection
申鐃緒申    99   "*Face for matching text in Apropos documentation/value, or nil for none.
申鐃緒申   100 This applies when you look for matches in the documentation or variable value
申鐃緒申   101 for the regexp; the part that matches gets displayed in this font."
申鐃緒申   102   :group 'apropos
申鐃緒申   103   :type 'face)
申鐃緒申   104 
申鐃緒申   105 
申鐃緒申   106 (defvar apropos-mode-map
申鐃緒申   107   (let ((map (make-sparse-keymap)))
申鐃緒申   108     (set-keymap-parent map button-buffer-map)
申鐃緒申   109     ;; Use `apropos-follow' instead of just using the button
申鐃緒申   110     ;; definition of RET, so that users can use it anywhere in an
申鐃緒申   111     ;; apropos item, not just on top of a button.
申鐃緒申   112     (define-key map "\C-m" 'apropos-follow)
申鐃緒申   113     (define-key map " "    'scroll-up)
申鐃緒申   114     (define-key map "\177" 'scroll-down)
申鐃緒申   115     (define-key map "q"    'quit-window)
申鐃緒申   116     map)
申鐃緒申   117   "Keymap used in Apropos mode.")
申鐃緒申   118 
申鐃緒申   119 (defvar apropos-mode-hook nil
申鐃緒申   120   "*Hook run when mode is turned on.")
申鐃緒申   121 
申鐃緒申   122 (defvar apropos-show-scores nil
申鐃緒申   123   "*Show apropos scores if non-nil.")
申鐃緒申   124 
申鐃緒申   125 (defvar apropos-regexp nil
申鐃緒申   126   "Regexp used in current apropos run.")
申鐃緒申   127 
申鐃緒申   128 (defvar apropos-orig-regexp nil
申鐃緒申   129   "Regexp as entered by user.")
申鐃緒申   130 
申鐃緒申   131 (defvar apropos-all-regexp nil
申鐃緒申   132   "Regexp matching apropos-all-words.")
申鐃緒申   133 
申鐃緒申   134 (defvar apropos-files-scanned ()
申鐃緒申   135   "List of elc files already scanned in current run of `apropos-documentation'.")
申鐃緒申   136 
申鐃緒申   137 (defvar apropos-accumulator ()
申鐃緒申   138   "Alist of symbols already found in current apropos run.")
申鐃緒申   139 
申鐃緒申   140 (defvar apropos-item ()
申鐃緒申   141   "Current item in or for `apropos-accumulator'.")
申鐃緒申   142 
申鐃緒申   143 (defvar apropos-synonyms '(
申鐃緒申   144   ("find" "open" "edit")
申鐃緒申   145   ("kill" "cut")
申鐃緒申   146   ("yank" "paste"))
申鐃緒申   147   "List of synonyms known by apropos.
申鐃緒申   148 Each element is a list of words where the first word is the standard emacs
申鐃緒申   149 term, and the rest of the words are alternative terms.")
申鐃緒申   150 
申鐃緒申   151 (defvar apropos-words ()
申鐃緒申   152   "Current list of words.")
申鐃緒申   153 
申鐃緒申   154 (defvar apropos-all-words ()
申鐃緒申   155   "Current list of words and synonyms.")
申鐃緒申   156 
申鐃緒申   157 
申鐃緒申   158 ;;; Button types used by apropos
申鐃緒申   159 
申鐃緒申   160 (define-button-type 'apropos-symbol
申鐃緒申   161   'face apropos-symbol-face
申鐃緒申   162   'help-echo "mouse-2, RET: Display more help on this symbol"
申鐃緒申   163   'action #'apropos-symbol-button-display-help
申鐃緒申   164   'skip t)
申鐃緒申   165 
申鐃緒申   166 (defun apropos-symbol-button-display-help (button)
申鐃緒申   167   "Display further help for the `apropos-symbol' button BUTTON."
申鐃緒申   168   (button-activate
申鐃緒申   169    (or (apropos-next-label-button (button-start button))
申鐃緒申   170        (error "There is nothing to follow for `%s'" (button-label button)))))
申鐃緒申   171 
申鐃緒申   172 (define-button-type 'apropos-function
申鐃緒申   173   'apropos-label "Function"
申鐃緒申   174   'action (lambda (button)
申鐃緒申   175 	    (describe-function (button-get button 'apropos-symbol)))
申鐃緒申   176   'help-echo "mouse-2, RET: Display more help on this function")
申鐃緒申   177 (define-button-type 'apropos-macro
申鐃緒申   178   'apropos-label "Macro"
申鐃緒申   179   'action (lambda (button)
申鐃緒申   180 	    (describe-function (button-get button 'apropos-symbol)))
申鐃緒申   181   'help-echo "mouse-2, RET: Display more help on this macro")
申鐃緒申   182 (define-button-type 'apropos-command
申鐃緒申   183   'apropos-label "Command"
申鐃緒申   184   'action (lambda (button)
申鐃緒申   185 	    (describe-function (button-get button 'apropos-symbol)))
申鐃緒申   186   'help-echo "mouse-2, RET: Display more help on this command")
申鐃緒申   187 
申鐃緒申   188 ;; We used to use `customize-variable-other-window' instead for a
申鐃緒申   189 ;; customizable variable, but that is slow.  It is better to show an
申鐃緒申   190 ;; ordinary help buffer and let the user click on the customization
申鐃緒申   191 ;; button in that buffer, if he wants to.
申鐃緒申   192 ;; Likewise for `customize-face-other-window'.
申鐃緒申   193 (define-button-type 'apropos-variable
申鐃緒申   194   'apropos-label "Variable"
申鐃緒申   195   'help-echo "mouse-2, RET: Display more help on this variable"
申鐃緒申   196   'action (lambda (button)
申鐃緒申   197 	    (describe-variable (button-get button 'apropos-symbol))))
申鐃緒申   198 
申鐃緒申   199 (define-button-type 'apropos-face
申鐃緒申   200   'apropos-label "Face"
申鐃緒申   201   'help-echo "mouse-2, RET: Display more help on this face"
申鐃緒申   202   'action (lambda (button)
申鐃緒申   203 	    (describe-face (button-get button 'apropos-symbol))))
申鐃緒申   204 
申鐃緒申   205 (define-button-type 'apropos-group
申鐃緒申   206   'apropos-label "Group"
申鐃緒申   207   'help-echo "mouse-2, RET: Display more help on this group"
申鐃緒申   208   'action (lambda (button)
申鐃緒申   209 	    (customize-group-other-window
申鐃緒申   210 	     (button-get button 'apropos-symbol))))
申鐃緒申   211 
申鐃緒申   212 (define-button-type 'apropos-widget
申鐃緒申   213   'apropos-label "Widget"
申鐃緒申   214   'help-echo "mouse-2, RET: Display more help on this widget"
申鐃緒申   215   'action (lambda (button)
申鐃緒申   216 	    (widget-browse-other-window (button-get button 'apropos-symbol))))
申鐃緒申   217 
申鐃緒申   218 (define-button-type 'apropos-plist
申鐃緒申   219   'apropos-label "Plist"
申鐃緒申   220   'help-echo "mouse-2, RET: Display more help on this plist"
申鐃緒申   221   'action (lambda (button)
申鐃緒申   222 	    (apropos-describe-plist (button-get button 'apropos-symbol))))
申鐃緒申   223 
申鐃緒申   224 (defun apropos-next-label-button (pos)
申鐃緒申   225   "Return the next apropos label button after POS, or nil if there's none.
申鐃緒申   226 Will also return nil if more than one `apropos-symbol' button is encountered
申鐃緒申   227 before finding a label."
申鐃緒申   228   (let* ((button (next-button pos t))
申鐃緒申   229 	 (already-hit-symbol nil)
申鐃緒申   230 	 (label (and button (button-get button 'apropos-label)))
申鐃緒申   231 	 (type (and button (button-get button 'type))))
申鐃緒申   232     (while (and button
申鐃緒申   233 		(not label)
申鐃緒申   234 		(or (not (eq type 'apropos-symbol))
申鐃緒申   235 		    (not already-hit-symbol)))
申鐃緒申   236       (when (eq type 'apropos-symbol)
申鐃緒申   237 	(setq already-hit-symbol t))
申鐃緒申   238       (setq button (next-button (button-start button)))
申鐃緒申   239       (when button
申鐃緒申   240 	(setq label (button-get button 'apropos-label))
申鐃緒申   241 	(setq type (button-get button 'type))))
申鐃緒申   242     (and label button)))
申鐃緒申   243 
申鐃緒申   244 
申鐃緒申   245 (defun apropos-words-to-regexp (words wild)
申鐃緒申   246   "Make regexp matching any two of the words in WORDS."
申鐃緒申   247   (concat "\\("
申鐃緒申   248 	  (mapconcat 'identity words "\\|")
申鐃緒申   249 	  "\\)" wild
申鐃緒申   250 	  (if (cdr words)
申鐃緒申   251 	      (concat "\\("
申鐃緒申   252 		      (mapconcat 'identity words "\\|")
申鐃緒申   253 		      "\\)")
申鐃緒申   254 	    "")))
申鐃緒申   255 
申鐃緒申   256 (defun apropos-rewrite-regexp (regexp)
申鐃緒申   257   "Rewrite a list of words to a regexp matching all permutations.
申鐃緒申   258 If REGEXP is already a regexp, don't modify it."
申鐃緒申   259   (setq apropos-orig-regexp regexp)
申鐃緒申   260   (setq apropos-words () apropos-all-words ())
申鐃緒申   261   (if (string-equal (regexp-quote regexp) regexp)
申鐃緒申   262       ;; We don't actually make a regexp matching all permutations.
申鐃緒申   263       ;; Instead, for e.g. "a b c", we make a regexp matching
申鐃緒申   264       ;; any combination of two or more words like this:
申鐃緒申   265       ;; (a|b|c).*(a|b|c) which may give some false matches,
申鐃緒申   266       ;; but as long as it also gives the right ones, that's ok.
申鐃緒申   267       (let ((words (split-string regexp "[ \t]+")))
申鐃緒申   268 	(dolist (word words)
申鐃緒申   269 	  (let ((syn apropos-synonyms) (s word) (a word))
申鐃緒申   270 	    (while syn
申鐃緒申   271 	      (if (member word (car syn))
申鐃緒申   272 		  (progn
申鐃緒申   273 		    (setq a (mapconcat 'identity (car syn) "\\|"))
申鐃緒申   274 		    (if (member word (cdr (car syn)))
申鐃緒申   275 			(setq s a))
申鐃緒申   276 		    (setq syn nil))
申鐃緒申   277 		(setq syn (cdr syn))))
申鐃緒申   278 	    (setq apropos-words (cons s apropos-words)
申鐃緒申   279 		  apropos-all-words (cons a apropos-all-words))))
申鐃緒申   280 	(setq apropos-all-regexp (apropos-words-to-regexp apropos-all-words ".+"))
申鐃緒申   281 	(apropos-words-to-regexp apropos-words ".*?"))
申鐃緒申   282     (setq apropos-all-regexp regexp)))
申鐃緒申   283 
申鐃緒申   284 (defun apropos-calc-scores (str words)
申鐃緒申   285   "Return apropos scores for string STR matching WORDS.
申鐃緒申   286 Value is a list of offsets of the words into the string."
申鐃緒申   287   (let ((scores ())
申鐃緒申   288 	i)
申鐃緒申   289     (if words
申鐃緒申   290 	(dolist (word words scores)
申鐃緒申   291 	  (if (setq i (string-match word str))
申鐃緒申   292 	      (setq scores (cons i scores))))
申鐃緒申   293       ;; Return list of start and end position of regexp
申鐃緒申   294       (string-match apropos-regexp str)
申鐃緒申   295       (list (match-beginning 0) (match-end 0)))))
申鐃緒申   296 
申鐃緒申   297 (defun apropos-score-str (str)
申鐃緒申   298   "Return apropos score for string STR."
申鐃緒申   299   (if str
申鐃緒申   300       (let* (
申鐃緒申   301 	     (l (length str))
申鐃緒申   302 	     (score (- (/ l 10)))
申鐃緒申   303 	    i)
申鐃緒申   304 	(dolist (s (apropos-calc-scores str apropos-all-words) score)
申鐃緒申   305 	  (setq score (+ score 1000 (/ (* (- l s) 1000) l)))))
申鐃緒申   306       0))
申鐃緒申   307 
申鐃緒申   308 (defun apropos-score-doc (doc)
申鐃緒申   309   "Return apropos score for documentation string DOC."
申鐃緒申   310   (if doc
申鐃緒申   311       (let ((score 0)
申鐃緒申   312 	    (l (length doc))
申鐃緒申   313 	    i)
申鐃緒申   314 	(dolist (s (apropos-calc-scores doc apropos-all-words) score)
申鐃緒申   315 	  (setq score (+ score 50 (/ (* (- l s) 50) l)))))
申鐃緒申   316       0))
申鐃緒申   317 
申鐃緒申   318 (defun apropos-score-symbol (symbol &optional weight)
申鐃緒申   319   "Return apropos score for SYMBOL."
申鐃緒申   320   (setq symbol (symbol-name symbol))
申鐃緒申   321   (let ((score 0)
申鐃緒申   322 	(l (length symbol))
申鐃緒申   323 	i)
申鐃緒申   324     (dolist (s (apropos-calc-scores symbol apropos-words) (* score (or weight 3)))
申鐃緒申   325       (setq score (+ score (- 60 l) (/ (* (- l s) 60) l))))))
申鐃緒申   326 
申鐃緒申   327 (defun apropos-true-hit (str words)
申鐃緒申   328   "Return t if STR is a genuine hit.
申鐃緒申   329 This may fail if only one of the keywords is matched more than once.
申鐃緒申   330 This requires that at least 2 keywords (unless only one was given)."
申鐃緒申   331   (or (not str)
申鐃緒申   332       (not words)
申鐃緒申   333       (not (cdr words))
申鐃緒申   334       (> (length (apropos-calc-scores str words)) 1)))
申鐃緒申   335 
申鐃緒申   336 (defun apropos-false-hit-symbol (symbol)
申鐃緒申   337   "Return t if SYMBOL is not really matched by the current keywords."
申鐃緒申   338   (not (apropos-true-hit (symbol-name symbol) apropos-words)))
申鐃緒申   339 
申鐃緒申   340 (defun apropos-false-hit-str (str)
申鐃緒申   341   "Return t if STR is not really matched by the current keywords."
申鐃緒申   342   (not (apropos-true-hit str apropos-words)))
申鐃緒申   343 
申鐃緒申   344 (defun apropos-true-hit-doc (doc)
申鐃緒申   345   "Return t if DOC is really matched by the current keywords."
申鐃緒申   346   (apropos-true-hit doc apropos-all-words))
申鐃緒申   347 
申鐃緒申   348 ;;;###autoload
申鐃緒申   349 (define-derived-mode apropos-mode fundamental-mode "Apropos"
申鐃緒申   350   "Major mode for following hyperlinks in output of apropos commands.
申鐃緒申   351 
申鐃緒申   352 \\{apropos-mode-map}")
申鐃緒申   353 
申鐃緒申   354 ;;;###autoload
申鐃緒申   355 (defun apropos-variable (regexp &optional do-all)
申鐃緒申   356   "Show user variables that match REGEXP.
申鐃緒申   357 With optional prefix DO-ALL or if `apropos-do-all' is non-nil, also show
申鐃緒申   358 normal variables."
申鐃緒申   359   (interactive (list (read-string
申鐃緒申   360                       (concat "Apropos "
申鐃緒申   361                               (if (or current-prefix-arg apropos-do-all)
申鐃緒申   362 				  "variable"
申鐃緒申   363 				"user option")
申鐃緒申   364                               " (regexp or words): "))
申鐃緒申   365                      current-prefix-arg))
申鐃緒申   366   (apropos-command regexp nil
申鐃緒申   367 		   (if (or do-all apropos-do-all)
申鐃緒申   368 		       #'(lambda (symbol)
申鐃緒申   369 			   (and (boundp symbol)
申鐃緒申   370 				(get symbol 'variable-documentation)))
申鐃緒申   371 		     'user-variable-p)))
申鐃緒申   372 
申鐃緒申   373 ;; For auld lang syne:
申鐃緒申   374 ;;;###autoload
申鐃緒申   375 (defalias 'command-apropos 'apropos-command)
申鐃緒申   376 ;;;###autoload
申鐃緒申   377 (defun apropos-command (apropos-regexp &optional do-all var-predicate)
申鐃緒申   378   "Show commands (interactively callable functions) that match APROPOS-REGEXP.
申鐃緒申   379 With optional prefix DO-ALL, or if `apropos-do-all' is non-nil, also show
申鐃緒申   380 noninteractive functions.
申鐃緒申   381 
申鐃緒申   382 If VAR-PREDICATE is non-nil, show only variables, and only those that
申鐃緒申   383 satisfy the predicate VAR-PREDICATE."
申鐃緒申   384   (interactive (list (read-string (concat
申鐃緒申   385 				   "Apropos command "
申鐃緒申   386 				   (if (or current-prefix-arg
申鐃緒申   387 					   apropos-do-all)
申鐃緒申   388 				       "or function ")
申鐃緒申   389 				   "(regexp or words): "))
申鐃緒申   390 		     current-prefix-arg))
申鐃緒申   391   (setq apropos-regexp (apropos-rewrite-regexp apropos-regexp))
申鐃緒申   392   (let ((message
申鐃緒申   393 	 (let ((standard-output (get-buffer-create "*Apropos*")))
申鐃緒申   394 	   (print-help-return-message 'identity))))
申鐃緒申   395     (or do-all (setq do-all apropos-do-all))
申鐃緒申   396     (setq apropos-accumulator
申鐃緒申   397 	  (apropos-internal apropos-regexp
申鐃緒申   398 			    (or var-predicate
申鐃緒申   399 				(if do-all 'functionp 'commandp))))
申鐃緒申   400     (let ((tem apropos-accumulator))
申鐃緒申   401       (while tem
申鐃緒申   402 	(if (or (get (car tem) 'apropos-inhibit)
申鐃緒申   403 		(apropos-false-hit-symbol (car tem)))
申鐃緒申   404 	    (setq apropos-accumulator (delq (car tem) apropos-accumulator)))
申鐃緒申   405 	(setq tem (cdr tem))))
申鐃緒申   406     (let ((p apropos-accumulator)
申鐃緒申   407 	  doc symbol score)
申鐃緒申   408       (while p
申鐃緒申   409 	(setcar p (list
申鐃緒申   410 		   (setq symbol (car p))
申鐃緒申   411 		   (setq score (apropos-score-symbol symbol))
申鐃緒申   412 		   (unless var-predicate
申鐃緒申   413 		     (if (functionp symbol)
申鐃緒申   414 			 (if (setq doc (documentation symbol t))
申鐃緒申   415 			     (progn
申鐃緒申   416 			       (setq score (+ score (apropos-score-doc doc)))
申鐃緒申   417 			       (substring doc 0 (string-match "\n" doc)))
申鐃緒申   418 			   "(not documented)")))
申鐃緒申   419 		   (and var-predicate
申鐃緒申   420 			(funcall var-predicate symbol)
申鐃緒申   421 			(if (setq doc (documentation-property
申鐃緒申   422 				       symbol 'variable-documentation t))
申鐃緒申   423 			     (progn
申鐃緒申   424 			       (setq score (+ score (apropos-score-doc doc)))
申鐃緒申   425 			       (substring doc 0
申鐃緒申   426 					  (string-match "\n" doc)))))))
申鐃緒申   427 	(setcar (cdr (car p)) score)
申鐃緒申   428 	(setq p (cdr p))))
申鐃緒申   429     (and (apropos-print t nil)
申鐃緒申   430 	 message
申鐃緒申   431 	 (message message))))
申鐃緒申   432 
申鐃緒申   433 
申鐃緒申   434 ;;;###autoload
申鐃緒申   435 (defun apropos-documentation-property (symbol property raw)
申鐃緒申   436   "Like (documentation-property SYMBOL PROPERTY RAW) but handle errors."
申鐃緒申   437   (condition-case ()
申鐃緒申   438       (let ((doc (documentation-property symbol property raw)))
申鐃緒申   439 	(if doc (substring doc 0 (string-match "\n" doc))
申鐃緒申   440 	  "(not documented)"))
申鐃緒申   441     (error "(error retrieving documentation)")))
申鐃緒申   442 
申鐃緒申   443 
申鐃緒申   444 ;;;###autoload
申鐃緒申   445 (defun apropos (apropos-regexp &optional do-all)
申鐃緒申   446   "Show all bound symbols whose names match APROPOS-REGEXP.
申鐃緒申   447 With optional prefix DO-ALL or if `apropos-do-all' is non-nil, also
申鐃緒申   448 show unbound symbols and key bindings, which is a little more
申鐃緒申   449 time-consuming.  Returns list of symbols and documentation found."
申鐃緒申   450   (interactive "sApropos symbol (regexp or words): \nP")
申鐃緒申   451   (setq apropos-regexp (apropos-rewrite-regexp apropos-regexp))
申鐃緒申   452   (setq apropos-accumulator
申鐃緒申   453 	(apropos-internal apropos-regexp
申鐃緒申   454 			  (and (not do-all)
申鐃緒申   455 			       (not apropos-do-all)
申鐃緒申   456 			       (lambda (symbol)
申鐃緒申   457 				 (or (fboundp symbol)
申鐃緒申   458 				     (boundp symbol)
申鐃緒申   459 				     (facep symbol)
申鐃緒申   460 				     (symbol-plist symbol))))))
申鐃緒申   461   (let ((tem apropos-accumulator))
申鐃緒申   462     (while tem
申鐃緒申   463       (if (get (car tem) 'apropos-inhibit)
申鐃緒申   464 	  (setq apropos-accumulator (delq (car tem) apropos-accumulator)))
申鐃緒申   465       (setq tem (cdr tem))))
申鐃緒申   466   (let ((p apropos-accumulator)
申鐃緒申   467 	symbol doc properties)
申鐃緒申   468     (while p
申鐃緒申   469       (setcar p (list
申鐃緒申   470 		 (setq symbol (car p))
申鐃緒申   471 		 0
申鐃緒申   472 		 (when (fboundp symbol)
申鐃緒申   473 		   (if (setq doc (condition-case nil
申鐃緒申   474 				     (documentation symbol t)
申鐃緒申   475 				   (void-function
申鐃緒申   476 				    "(alias for undefined function)")
申鐃緒申   477 				   (error
申鐃緒申   478 				    "(error retrieving function documentation)")))
申鐃緒申   479 		       (substring doc 0 (string-match "\n" doc))
申鐃緒申   480 		     "(not documented)"))
申鐃緒申   481 		 (when (boundp symbol)
申鐃緒申   482 		   (apropos-documentation-property
申鐃緒申   483 		    symbol 'variable-documentation t))
申鐃緒申   484 		 (when (setq properties (symbol-plist symbol))
申鐃緒申   485 		   (setq doc (list (car properties)))
申鐃緒申   486 		   (while (setq properties (cdr (cdr properties)))
申鐃緒申   487 		     (setq doc (cons (car properties) doc)))
申鐃緒申   488 		   (mapconcat #'symbol-name (nreverse doc) " "))
申鐃緒申   489 		 (when (get symbol 'widget-type)
申鐃緒申   490 		   (apropos-documentation-property
申鐃緒申   491 		    symbol 'widget-documentation t))
申鐃緒申   492 		 (when (facep symbol)
申鐃緒申   493 		   (apropos-documentation-property
申鐃緒申   494 		    symbol 'face-documentation t))
申鐃緒申   495 		 (when (get symbol 'custom-group)
申鐃緒申   496 		   (apropos-documentation-property
申鐃緒申   497 		    symbol 'group-documentation t))))
申鐃緒申   498       (setq p (cdr p))))
申鐃緒申   499   (apropos-print
申鐃緒申   500    (or do-all apropos-do-all)
申鐃緒申   501    nil))
申鐃緒申   502 
申鐃緒申   503 
申鐃緒申   504 ;;;###autoload
申鐃緒申   505 (defun apropos-value (apropos-regexp &optional do-all)
申鐃緒申   506   "Show all symbols whose value's printed image matches APROPOS-REGEXP.
申鐃緒申   507 With optional prefix DO-ALL or if `apropos-do-all' is non-nil, also looks
申鐃緒申   508 at the function and at the names and values of properties.
申鐃緒申   509 Returns list of symbols and values found."
申鐃緒申   510   (interactive "sApropos value (regexp or words): \nP")
申鐃緒申   511   (setq apropos-regexp (apropos-rewrite-regexp apropos-regexp))
申鐃緒申   512   (or do-all (setq do-all apropos-do-all))
申鐃緒申   513   (setq apropos-accumulator ())
申鐃緒申   514    (let (f v p)
申鐃緒申   515      (mapatoms
申鐃緒申   516       (lambda (symbol)
申鐃緒申   517 	(setq f nil v nil p nil)
申鐃緒申   518 	(or (memq symbol '(apropos-regexp
申鐃緒申   519 			   apropos-orig-regexp apropos-all-regexp
申鐃緒申   520 			   apropos-words apropos-all-words
申鐃緒申   521 			   do-all apropos-accumulator
申鐃緒申   522 			   symbol f v p))
申鐃緒申   523 	    (setq v (apropos-value-internal 'boundp symbol 'symbol-value)))
申鐃緒申   524 	(if do-all
申鐃緒申   525 	    (setq f (apropos-value-internal 'fboundp symbol 'symbol-function)
申鐃緒申   526 		  p (apropos-format-plist symbol "\n    " t)))
申鐃緒申   527 	(if (apropos-false-hit-str v)
申鐃緒申   528 	    (setq v nil))
申鐃緒申   529 	(if (apropos-false-hit-str f)
申鐃緒申   530 	    (setq f nil))
申鐃緒申   531 	(if (apropos-false-hit-str p)
申鐃緒申   532 	    (setq p nil))
申鐃緒申   533 	(if (or f v p)
申鐃緒申   534 	    (setq apropos-accumulator (cons (list symbol
申鐃緒申   535 						  (+ (apropos-score-str f)
申鐃緒申   536 						     (apropos-score-str v)
申鐃緒申   537 						     (apropos-score-str p))
申鐃緒申   538 						  f v p)
申鐃緒申   539 					    apropos-accumulator))))))
申鐃緒申   540   (apropos-print nil "\n----------------\n"))
申鐃緒申   541 
申鐃緒申   542 
申鐃緒申   543 ;;;###autoload
申鐃緒申   544 (defun apropos-documentation (apropos-regexp &optional do-all)
申鐃緒申   545   "Show symbols whose documentation contain matches for APROPOS-REGEXP.
申鐃緒申   546 With optional prefix DO-ALL or if `apropos-do-all' is non-nil, also use
申鐃緒申   547 documentation that is not stored in the documentation file and show key
申鐃緒申   548 bindings.
申鐃緒申   549 Returns list of symbols and documentation found."
申鐃緒申   550   (interactive "sApropos documentation (regexp or words): \nP")
申鐃緒申   551   (setq apropos-regexp (apropos-rewrite-regexp apropos-regexp))
申鐃緒申   552   (or do-all (setq do-all apropos-do-all))
申鐃緒申   553   (setq apropos-accumulator () apropos-files-scanned ())
申鐃緒申   554   (let ((standard-input (get-buffer-create " apropos-temp"))
申鐃緒申   555 	f v sf sv)
申鐃緒申   556     (unwind-protect
申鐃緒申   557 	(save-excursion
申鐃緒申   558 	  (set-buffer standard-input)
申鐃緒申   559 	  (apropos-documentation-check-doc-file)
申鐃緒申   560 	  (if do-all
申鐃緒申   561 	      (mapatoms
申鐃緒申   562 	       (lambda (symbol)
申鐃緒申   563 		 (setq f (apropos-safe-documentation symbol)
申鐃緒申   564 		       v (get symbol 'variable-documentation))
申鐃緒申   565 		 (if (integerp v) (setq v))
申鐃緒申   566 		 (setq f (apropos-documentation-internal f)
申鐃緒申   567 		       v (apropos-documentation-internal v))
申鐃緒申   568 		 (setq sf (apropos-score-doc f)
申鐃緒申   569 		       sv (apropos-score-doc v))
申鐃緒申   570 		 (if (or f v)
申鐃緒申   571 		     (if (setq apropos-item
申鐃緒申   572 			       (cdr (assq symbol apropos-accumulator)))
申鐃緒申   573 			 (progn
申鐃緒申   574 			   (if f
申鐃緒申   575 			       (progn
申鐃緒申   576 				 (setcar (nthcdr 1 apropos-item) f)
申鐃緒申   577 				 (setcar apropos-item (+ (car apropos-item) sf))))
申鐃緒申   578 			   (if v
申鐃緒申   579 			       (progn
申鐃緒申   580 				 (setcar (nthcdr 2 apropos-item) v)
申鐃緒申   581 				 (setcar apropos-item (+ (car apropos-item) sv)))))
申鐃緒申   582 		       (setq apropos-accumulator
申鐃緒申   583 			     (cons (list symbol
申鐃緒申   584 					 (+ (apropos-score-symbol symbol 2) sf sv)
申鐃緒申   585 					 f v)
申鐃緒申   586 				   apropos-accumulator)))))))
申鐃緒申   587 	  (apropos-print nil "\n----------------\n"))
申鐃緒申   588       (kill-buffer standard-input))))
申鐃緒申   589 
申鐃緒申   590 
申鐃緒申   591 (defun apropos-value-internal (predicate symbol function)
申鐃緒申   592   (if (funcall predicate symbol)
申鐃緒申   593       (progn
申鐃緒申   594 	(setq symbol (prin1-to-string (funcall function symbol)))
申鐃緒申   595 	(if (string-match apropos-regexp symbol)
申鐃緒申   596 	    (progn
申鐃緒申   597 	      (if apropos-match-face
申鐃緒申   598 		  (put-text-property (match-beginning 0) (match-end 0)
申鐃緒申   599 				     'face apropos-match-face
申鐃緒申   600 				     symbol))
申鐃緒申   601 	      symbol)))))
申鐃緒申   602 
申鐃緒申   603 (defun apropos-documentation-internal (doc)
申鐃緒申   604   (if (consp doc)
申鐃緒申   605       (apropos-documentation-check-elc-file (car doc))
申鐃緒申   606     (and doc
申鐃緒申   607 	 (string-match apropos-all-regexp doc)
申鐃緒申   608 	 (save-match-data (apropos-true-hit-doc doc))
申鐃緒申   609 	 (progn
申鐃緒申   610 	   (if apropos-match-face
申鐃緒申   611 	       (put-text-property (match-beginning 0)
申鐃緒申   612 				  (match-end 0)
申鐃緒申   613 				  'face apropos-match-face
申鐃緒申   614 				  (setq doc (copy-sequence doc))))
申鐃緒申   615 	   doc))))
申鐃緒申   616 
申鐃緒申   617 (defun apropos-format-plist (pl sep &optional compare)
申鐃緒申   618   (setq pl (symbol-plist pl))
申鐃緒申   619   (let (p p-out)
申鐃緒申   620     (while pl
申鐃緒申   621       (setq p (format "%s %S" (car pl) (nth 1 pl)))
申鐃緒申   622       (if (or (not compare) (string-match apropos-regexp p))
申鐃緒申   623 	  (if apropos-property-face
申鐃緒申   624 	      (put-text-property 0 (length (symbol-name (car pl)))
申鐃緒申   625 				 'face apropos-property-face p))
申鐃緒申   626 	(setq p nil))
申鐃緒申   627       (if p
申鐃緒申   628 	  (progn
申鐃緒申   629 	    (and compare apropos-match-face
申鐃緒申   630 		 (put-text-property (match-beginning 0) (match-end 0)
申鐃緒申   631 				    'face apropos-match-face
申鐃緒申   632 				    p))
申鐃緒申   633 	    (setq p-out (concat p-out (if p-out sep) p))))
申鐃緒申   634       (setq pl (nthcdr 2 pl)))
申鐃緒申   635     p-out))
申鐃緒申   636 
申鐃緒申   637 
申鐃緒申   638 ;; Finds all documentation related to APROPOS-REGEXP in internal-doc-file-name.
申鐃緒申   639 
申鐃緒申   640 (defun apropos-documentation-check-doc-file ()
申鐃緒申   641   (let (type symbol (sepa 2) sepb beg end)
申鐃緒申   642     (insert ?\^_)
申鐃緒申   643     (backward-char)
申鐃緒申   644     (insert-file-contents (concat doc-directory internal-doc-file-name))
申鐃緒申   645     (forward-char)
申鐃緒申   646     (while (save-excursion
申鐃緒申   647 	     (setq sepb (search-forward "\^_"))
申鐃緒申   648 	     (not (eobp)))
申鐃緒申   649       (beginning-of-line 2)
申鐃緒申   650       (if (save-restriction
申鐃緒申   651 	    (narrow-to-region (point) (1- sepb))
申鐃緒申   652 	    (re-search-forward apropos-all-regexp nil t))
申鐃緒申   653 	  (progn
申鐃緒申   654 	    (setq beg (match-beginning 0)
申鐃緒申   655 		  end (point))
申鐃緒申   656 	    (goto-char (1+ sepa))
申鐃緒申   657 	    (setq type (if (eq ?F (preceding-char))
申鐃緒申   658 			   2	; function documentation
申鐃緒申   659 			 3)		; variable documentation
申鐃緒申   660 		  symbol (read)
申鐃緒申   661 		  beg (- beg (point) 1)
申鐃緒申   662 		  end (- end (point) 1)
申鐃緒申   663 		  doc (buffer-substring (1+ (point)) (1- sepb)))
申鐃緒申   664 	    (when (apropos-true-hit-doc doc)
申鐃緒申   665 	      (or (and (setq apropos-item (assq symbol apropos-accumulator))
申鐃緒申   666 		       (setcar (cdr apropos-item)
申鐃緒申   667 			       (+ (cadr apropos-item) (apropos-score-doc doc))))
申鐃緒申   668 		  (setq apropos-item (list symbol
申鐃緒申   669 					   (+ (apropos-score-symbol symbol 2)
申鐃緒申   670 					      (apropos-score-doc doc))
申鐃緒申   671 					   nil nil)
申鐃緒申   672 			apropos-accumulator (cons apropos-item
申鐃緒申   673 						  apropos-accumulator)))
申鐃緒申   674 	      (if apropos-match-face
申鐃緒申   675 		  (put-text-property beg end 'face apropos-match-face doc))
申鐃緒申   676 	      (setcar (nthcdr type apropos-item) doc))))
申鐃緒申   677       (setq sepa (goto-char sepb)))))
申鐃緒申   678 
申鐃緒申   679 (defun apropos-documentation-check-elc-file (file)
申鐃緒申   680   (if (member file apropos-files-scanned)
申鐃緒申   681       nil
申鐃緒申   682     (let (symbol doc beg end this-is-a-variable)
申鐃緒申   683       (setq apropos-files-scanned (cons file apropos-files-scanned))
申鐃緒申   684       (erase-buffer)
申鐃緒申   685       (insert-file-contents file)
申鐃緒申   686       (while (search-forward "\n#@" nil t)
申鐃緒申   687 	;; Read the comment length, and advance over it.
申鐃緒申   688 	(setq end (read)
申鐃緒申   689 	      beg (1+ (point))
申鐃緒申   690 	      end (+ (point) end -1))
申鐃緒申   691 	(forward-char)
申鐃緒申   692 	(if (save-restriction
申鐃緒申   693 	      ;; match ^ and $ relative to doc string
申鐃緒申   694 	      (narrow-to-region beg end)
申鐃緒申   695 	      (re-search-forward apropos-all-regexp nil t))
申鐃緒申   696 	    (progn
申鐃緒申   697 	      (goto-char (+ end 2))
申鐃緒申   698 	      (setq doc (buffer-substring beg end)
申鐃緒申   699 		    end (- (match-end 0) beg)
申鐃緒申   700 		    beg (- (match-beginning 0) beg))
申鐃緒申   701 	      (when (apropos-true-hit-doc doc)
申鐃緒申   702 		(setq this-is-a-variable (looking-at "(def\\(var\\|const\\) ")
申鐃緒申   703 		      symbol (progn
申鐃緒申   704 			       (skip-chars-forward "(a-z")
申鐃緒申   705 			       (forward-char)
申鐃緒申   706 			       (read))
申鐃緒申   707 		      symbol (if (consp symbol)
申鐃緒申   708 				 (nth 1 symbol)
申鐃緒申   709 			       symbol))
申鐃緒申   710 		(if (if this-is-a-variable
申鐃緒申   711 			(get symbol 'variable-documentation)
申鐃緒申   712 		      (and (fboundp symbol) (apropos-safe-documentation symbol)))
申鐃緒申   713 		    (progn
申鐃緒申   714 		      (or (and (setq apropos-item (assq symbol apropos-accumulator))
申鐃緒申   715 			       (setcar (cdr apropos-item)
申鐃緒申   716 				       (+ (cadr apropos-item) (apropos-score-doc doc))))
申鐃緒申   717 			  (setq apropos-item (list symbol
申鐃緒申   718 						   (+ (apropos-score-symbol symbol 2)
申鐃緒申   719 						      (apropos-score-doc doc))
申鐃緒申   720 						   nil nil)
申鐃緒申   721 				apropos-accumulator (cons apropos-item
申鐃緒申   722 							  apropos-accumulator)))
申鐃緒申   723 		      (if apropos-match-face
申鐃緒申   724 			  (put-text-property beg end 'face apropos-match-face
申鐃緒申   725 					     doc))
申鐃緒申   726 		      (setcar (nthcdr (if this-is-a-variable 3 2)
申鐃緒申   727 				      apropos-item)
申鐃緒申   728 			      doc))))))))))
申鐃緒申   729 
申鐃緒申   730 
申鐃緒申   731 
申鐃緒申   732 (defun apropos-safe-documentation (function)
申鐃緒申   733   "Like `documentation', except it avoids calling `get_doc_string'.
申鐃緒申   734 Will return nil instead."
申鐃緒申   735   (while (and function (symbolp function))
申鐃緒申   736     (setq function (if (fboundp function)
申鐃緒申   737 		       (symbol-function function))))
申鐃緒申   738   (if (eq (car-safe function) 'macro)
申鐃緒申   739       (setq function (cdr function)))
申鐃緒申   740   (setq function (if (byte-code-function-p function)
申鐃緒申   741 		     (if (> (length function) 4)
申鐃緒申   742 			 (aref function 4))
申鐃緒申   743 		   (if (eq (car-safe function) 'autoload)
申鐃緒申   744 		       (nth 2 function)
申鐃緒申   745 		     (if (eq (car-safe function) 'lambda)
申鐃緒申   746 			 (if (stringp (nth 2 function))
申鐃緒申   747 			     (nth 2 function)
申鐃緒申   748 			   (if (stringp (nth 3 function))
申鐃緒申   749 			       (nth 3 function)))))))
申鐃緒申   750   (if (integerp function)
申鐃緒申   751       nil
申鐃緒申   752     function))
申鐃緒申   753 
申鐃緒申   754 
申鐃緒申   755 (defun apropos-print (do-keys spacing)
申鐃緒申   756   "Output result of apropos searching into buffer `*Apropos*'.
申鐃緒申   757 The value of `apropos-accumulator' is the list of items to output.
申鐃緒申   758 Each element should have the format
申鐃緒申   759  (SYMBOL SCORE FN-DOC VAR-DOC [PLIST-DOC WIDGET-DOC FACE-DOC GROUP-DOC]).
申鐃緒申   760 The return value is the list that was in `apropos-accumulator', sorted
申鐃緒申   761 alphabetically by symbol name; but this function also sets
申鐃緒申   762 `apropos-accumulator' to nil before returning.
申鐃緒申   763 
申鐃緒申   764 If SPACING is non-nil, it should be a string;
申鐃緒申   765 separate items with that string."
申鐃緒申   766   (if (null apropos-accumulator)
申鐃緒申   767       (message "No apropos matches for `%s'" apropos-orig-regexp)
申鐃緒申   768     (setq apropos-accumulator
申鐃緒申   769 	  (sort apropos-accumulator (lambda (a b)
申鐃緒申   770 				      (or (> (cadr a) (cadr b))
申鐃緒申   771 					  (and (= (cadr a) (cadr b))
申鐃緒申   772 					       (string-lessp (car a) (car b)))))))
申鐃緒申   773     (with-output-to-temp-buffer "*Apropos*"
申鐃緒申   774       (let ((p apropos-accumulator)
申鐃緒申   775 	    (old-buffer (current-buffer))
申鐃緒申   776 	    symbol item)
申鐃緒申   777 	(set-buffer standard-output)
申鐃緒申   778 	(apropos-mode)
申鐃緒申   779 	(if (display-mouse-p)
申鐃緒申   780 	    (insert
申鐃緒申   781 	     "If moving the mouse over text changes the text's color, "
申鐃緒申   782 	     "you can click\n"
申鐃緒申   783 	     "mouse-2 (second button from right) on that text to "
申鐃緒申   784 	     "get more information.\n"))
申鐃緒申   785 	(insert "In this buffer, go to the name of the command, or function,"
申鐃緒申   786 		" or variable,\n"
申鐃緒申   787 		(substitute-command-keys
申鐃緒申   788 		 "and type \\[apropos-follow] to get full documentation.\n\n"))
申鐃緒申   789 	(while (consp p)
申鐃緒申   790 	  (when (and spacing (not (bobp)))
申鐃緒申   791 	    (princ spacing))
申鐃緒申   792 	  (setq apropos-item (car p)
申鐃緒申   793 		symbol (car apropos-item)
申鐃緒申   794 		p (cdr p))
申鐃緒申   795 	  (insert-text-button (symbol-name symbol)
申鐃緒申   796 			      'type 'apropos-symbol
申鐃緒申   797 			      ;; Can't use default, since user may have
申鐃緒申   798 			      ;; changed the variable!
申鐃緒申   799 			      ;; Just say `no' to variables containing faces!
申鐃緒申   800 			      'face apropos-symbol-face)
申鐃緒申   801 	  (if apropos-show-scores
申鐃緒申   802 	      (insert " (" (number-to-string (cadr apropos-item)) ") "))
申鐃緒申   803 	  ;; Calculate key-bindings if we want them.
申鐃緒申   804 	  (and do-keys
申鐃緒申   805 	       (commandp symbol)
申鐃緒申   806 	       (indent-to 30 1)
申鐃緒申   807 	       (if (let ((keys
申鐃緒申   808 			  (save-excursion
申鐃緒申   809 			    (set-buffer old-buffer)
申鐃緒申   810 			    (where-is-internal symbol)))
申鐃緒申   811 			 filtered)
申鐃緒申   812 		     ;; Copy over the list of key sequences,
申鐃緒申   813 		     ;; omitting any that contain a buffer or a frame.
申鐃緒申   814 		     (while keys
申鐃緒申   815 		       (let ((key (car keys))
申鐃緒申   816 			     (i 0)
申鐃緒申   817 			     loser)
申鐃緒申   818 			 (while (< i (length key))
申鐃緒申   819 			   (if (or (framep (aref key i))
申鐃緒申   820 				   (bufferp (aref key i)))
申鐃緒申   821 			       (setq loser t))
申鐃緒申   822 			   (setq i (1+ i)))
申鐃緒申   823 			 (or loser
申鐃緒申   824 			     (setq filtered (cons key filtered))))
申鐃緒申   825 		       (setq keys (cdr keys)))
申鐃緒申   826 		     (setq item filtered))
申鐃緒申   827 		   ;; Convert the remaining keys to a string and insert.
申鐃緒申   828 		   (insert
申鐃緒申   829 		    (mapconcat
申鐃緒申   830 		     (lambda (key)
申鐃緒申   831 		       (setq key (condition-case ()
申鐃緒申   832 				     (key-description key)
申鐃緒申   833 				   (error)))
申鐃緒申   834 		       (if apropos-keybinding-face
申鐃緒申   835 			   (put-text-property 0 (length key)
申鐃緒申   836 					      'face apropos-keybinding-face
申鐃緒申   837 					      key))
申鐃緒申   838 		       key)
申鐃緒申   839 		     item ", "))
申鐃緒申   840 		 (insert "M-x")
申鐃緒申   841 		 (put-text-property (- (point) 3) (point)
申鐃緒申   842 				    'face apropos-keybinding-face)
申鐃緒申   843 		 (insert " " (symbol-name symbol) " ")
申鐃緒申   844 		 (insert "RET")
申鐃緒申   845 		 (put-text-property (- (point) 3) (point)
申鐃緒申   846 				    'face apropos-keybinding-face)))
申鐃緒申   847 	  (terpri)
申鐃緒申   848 	  (apropos-print-doc 2
申鐃緒申   849 			     (if (commandp symbol)
申鐃緒申   850 				 'apropos-command
申鐃緒申   851 			       (if (apropos-macrop symbol)
申鐃緒申   852 				   'apropos-macro
申鐃緒申   853 				 'apropos-function))
申鐃緒申   854 			     t)
申鐃緒申   855 	  (apropos-print-doc 3 'apropos-variable t)
申鐃緒申   856 	  (apropos-print-doc 7 'apropos-group t)
申鐃緒申   857 	  (apropos-print-doc 6 'apropos-face t)
申鐃緒申   858 	  (apropos-print-doc 5 'apropos-widget t)
申鐃緒申   859 	  (apropos-print-doc 4 'apropos-plist nil))
申鐃緒申   860 	(setq buffer-read-only t))))
申鐃緒申   861   (prog1 apropos-accumulator
申鐃緒申   862     (setq apropos-accumulator ())))	; permit gc
申鐃緒申   863 
申鐃緒申   864 
申鐃緒申   865 (defun apropos-macrop (symbol)
申鐃緒申   866   "T if SYMBOL is a Lisp macro."
申鐃緒申   867   (and (fboundp symbol)
申鐃緒申   868        (consp (setq symbol
申鐃緒申   869 		    (symbol-function symbol)))
申鐃緒申   870        (or (eq (car symbol) 'macro)
申鐃緒申   871 	   (if (eq (car symbol) 'autoload)
申鐃緒申   872 	       (memq (nth 4 symbol)
申鐃緒申   873 		     '(macro t))))))
申鐃緒申   874 
申鐃緒申   875 
申鐃緒申   876 (defun apropos-print-doc (i type do-keys)
申鐃緒申   877   (if (stringp (setq i (nth i apropos-item)))
申鐃緒申   878       (progn
申鐃緒申   879 	(insert "  ")
申鐃緒申   880 	(insert-text-button (button-type-get type 'apropos-label)
申鐃緒申   881 			    'type type
申鐃緒申   882 			    ;; Can't use the default button face, since
申鐃緒申   883 			    ;; user may have changed the variable!
申鐃緒申   884 			    ;; Just say `no' to variables containing faces!
申鐃緒申   885 			    'face apropos-label-face
申鐃緒申   886 			    'apropos-symbol (car apropos-item))
申鐃緒申   887 	(insert ": ")
申鐃緒申   888 	(insert (if do-keys (substitute-command-keys i) i))
申鐃緒申   889 	(or (bolp) (terpri)))))
申鐃緒申   890 
申鐃緒申   891 
申鐃緒申   892 (defun apropos-follow ()
申鐃緒申   893   "Invokes any button at point, otherwise invokes the nearest label button."
申鐃緒申   894   (interactive)
申鐃緒申   895   (button-activate
申鐃緒申   896    (or (apropos-next-label-button (line-beginning-position))
申鐃緒申   897        (error "There is nothing to follow here"))))
申鐃緒申   898 
申鐃緒申   899 
申鐃緒申   900 (defun apropos-describe-plist (symbol)
申鐃緒申   901   "Display a pretty listing of SYMBOL's plist."
申鐃緒申   902   (with-output-to-temp-buffer "*Help*"
申鐃緒申   903     (set-buffer standard-output)
申鐃緒申   904     (princ "Symbol ")
申鐃緒申   905     (prin1 symbol)
申鐃緒申   906     (princ "'s plist is\n (")
申鐃緒申   907     (if apropos-symbol-face
申鐃緒申   908 	(put-text-property 8 (- (point) 14) 'face apropos-symbol-face))
申鐃緒申   909     (insert (apropos-format-plist symbol "\n  "))
申鐃緒申   910     (princ ")")
申鐃緒申   911     (print-help-return-message)))
申鐃緒申   912 
申鐃緒申   913 
申鐃緒申   914 (provide 'apropos)
申鐃緒申   915 
申鐃緒申   916 ;;; apropos.el ends here