1;;; help-fns.el --- Complex help functions -*- lexical-binding: t -*-
2
3;; Copyright (C) 1985-1986, 1993-1994, 1998-2021 Free Software
4;; Foundation, Inc.
5
6;; Maintainer: emacs-devel@gnu.org
7;; Keywords: help, internal
8;; Package: emacs
9
10;; This file is part of GNU Emacs.
11
12;; GNU Emacs is free software: you can redistribute it and/or modify
13;; it under the terms of the GNU General Public License as published by
14;; the Free Software Foundation, either version 3 of the License, or
15;; (at your option) any later version.
16
17;; GNU Emacs is distributed in the hope that it will be useful,
18;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
20;; GNU General Public License for more details.
21
22;; You should have received a copy of the GNU General Public License
23;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
24
25;;; Commentary:
26
27;; This file contains those help commands which are complicated, and
28;; which may not be used in every session.  For example
29;; `describe-function' will probably be heavily used when doing elisp
30;; programming, but not if just editing C files.  Simpler help commands
31;; are in help.el
32
33;;; Code:
34
35(require 'cl-lib)
36(require 'help-mode)
37(require 'radix-tree)
38(eval-when-compile (require 'subr-x))   ;For when-let.
39
40(defvar help-fns-describe-function-functions nil
41  "List of functions to run in help buffer in `describe-function'.
42Those functions will be run after the header line and argument
43list was inserted, and before the documentation is inserted.
44The functions will be called with one argument: the function's symbol.
45They can assume that a newline was output just before they were called,
46and they should terminate any of their own output with a newline.
47By convention they should indent their output by 2 spaces.")
48
49(defvar help-fns-describe-variable-functions nil
50  "List of functions to run in help buffer in `describe-variable'.
51Those functions will be run after the header line and value was inserted,
52and before the documentation will be inserted.
53The functions will receive the variable name as argument.
54They can assume that a newline was output just before they were called,
55and they should terminate any of their own output with a newline.
56By convention they should indent their output by 2 spaces.
57Current buffer is the buffer in which we queried the variable,
58and the output should go to `standard-output'.")
59
60(defvar help-fns-describe-face-functions nil
61  "List of functions to run in help buffer in `describe-face'.
62The functions will be used (and take the same parameters) as
63described in `help-fns-describe-variable-functions', except that
64the functions are called with two parameters: The face and the
65frame.")
66
67(defvar help-fns--activated-functions nil
68  "Internal variable let-bound to help functions that have triggered.
69Help functions can check the contents of this list to see whether
70a specific previous help function has inserted something in the
71current help buffer.")
72
73;; Functions
74
75(defvar help-definition-prefixes nil
76  ;; FIXME: We keep `definition-prefixes' as a hash-table so as to
77  ;; avoid pre-loading radix-tree and because it takes slightly less
78  ;; memory.  But when we use this table it's more efficient to
79  ;; represent it as a radix tree, since the main operation is to do
80  ;; `radix-tree-prefixes'.  Maybe we should just bite the bullet and
81  ;; use a radix tree for `definition-prefixes' (it's not *that*
82  ;; costly, really).
83  "Radix-tree representation replacing `definition-prefixes'.")
84
85(defun help-definition-prefixes ()
86  "Return the up-to-date radix-tree form of `definition-prefixes'."
87  (when (> (hash-table-count definition-prefixes) 0)
88    (maphash (lambda (prefix files)
89               (let ((old (radix-tree-lookup help-definition-prefixes prefix)))
90                 (setq help-definition-prefixes
91                       (radix-tree-insert help-definition-prefixes
92                                          prefix (append old files)))))
93             definition-prefixes)
94    (clrhash definition-prefixes))
95  help-definition-prefixes)
96
97(defun help--loaded-p (file)
98  "Try and figure out if FILE has already been loaded."
99  ;; FIXME: this regexp business is not good enough: for file
100  ;; `toto', it will say `toto' is loaded when in reality it was
101  ;; just cedet/semantic/toto that has been loaded.
102  (or (let ((feature (intern-soft file)))
103        (and feature (featurep feature)))
104      (let* ((re (load-history-regexp file))
105             (done nil))
106        (dolist (x load-history)
107          (and (stringp (car x)) (string-match-p re (car x)) (setq done t)))
108        done)))
109
110(defun help--load-prefixes (prefixes)
111  (pcase-dolist (`(,prefix . ,files) prefixes)
112    (setq help-definition-prefixes
113          (radix-tree-insert help-definition-prefixes prefix nil))
114    (dolist (file files)
115      ;; FIXME: Should we scan help-definition-prefixes to remove
116      ;; other prefixes of the same file?
117      (unless (help--loaded-p file)
118        (with-demoted-errors "while loading: %S"
119          (load file 'noerror 'nomessage))))))
120
121
122(define-obsolete-variable-alias 'help-enable-completion-auto-load
123  'help-enable-completion-autoload "27.1")
124
125(defcustom help-enable-completion-autoload t
126  "Whether completion for Help commands can perform autoloading.
127If non-nil, whenever invoking completion for `describe-function'
128or `describe-variable' load files that might contain definitions
129with the current prefix.  The files are chosen according to
130`definition-prefixes'."
131  :type 'boolean
132  :group 'help
133  :version "26.3")
134
135(defcustom help-enable-symbol-autoload nil
136  "Perform autoload if docs are missing from autoload objects."
137  :type 'boolean
138  :group 'help
139  :version "28.1")
140
141(defun help--symbol-class (s)
142  "Return symbol class characters for symbol S."
143  (when (stringp s)
144    (setq s (intern-soft s)))
145  (concat
146   (when (fboundp s)
147     (concat
148      (cond
149       ((commandp s) "c")
150       ((eq (car-safe (symbol-function s)) 'macro) "m")
151       (t "f"))
152      (and (let ((flist (indirect-function s)))
153             (advice--p (if (eq 'macro (car-safe flist)) (cdr flist) flist)))
154           "!")
155      (and (get s 'byte-obsolete-info) "-")))
156   (when (boundp s)
157     (concat
158      (if (custom-variable-p s) "u" "v")
159      (and (local-variable-if-set-p s) "'")
160      (and (ignore-errors (not (equal (symbol-value s) (default-value s)))) "*")
161      (and (get s 'byte-obsolete-variable) "-")))
162   (and (facep s) "a")
163   (and (fboundp 'cl-find-class) (cl-find-class s) "t")))
164
165(defun help--symbol-completion-table-affixation (completions)
166  (mapcar (lambda (c)
167            (let* ((s (intern c))
168                   (doc (condition-case nil (documentation s) (error nil)))
169                   (doc (and doc (substring doc 0 (string-search "\n" doc)))))
170              (list c (propertize
171                       (format "%-4s" (help--symbol-class s))
172                       'face 'completions-annotations)
173                    (if doc (propertize (format " -- %s" doc)
174                                        'face 'completions-annotations)
175                      ""))))
176          completions))
177
178(defun help--symbol-completion-table (string pred action)
179  (if (eq action 'metadata)
180      `(metadata
181        ,@(when completions-detailed
182            '((affixation-function . help--symbol-completion-table-affixation)))
183        (category . symbol-help))
184    (when help-enable-completion-autoload
185      (let ((prefixes (radix-tree-prefixes (help-definition-prefixes) string)))
186        (help--load-prefixes prefixes)))
187    (let ((prefix-completions
188           (and help-enable-completion-autoload
189                (mapcar #'intern (all-completions string definition-prefixes)))))
190      (complete-with-action action obarray string
191                            (if pred (lambda (sym)
192                                       (or (funcall pred sym)
193                                           (memq sym prefix-completions))))))))
194
195(defvar describe-function-orig-buffer nil
196  "Buffer that was current when `describe-function' was invoked.
197Functions on `help-fns-describe-function-functions' can use this
198to get buffer-local values.")
199
200(defun help-fns--describe-function-or-command-prompt (&optional want-command)
201  "Prompt for a function from `describe-function' or `describe-command'.
202If optional argument WANT-COMMAND is non-nil, prompt for an
203interactive command."
204  (let* ((fn (if want-command
205                 (caar command-history)
206               (function-called-at-point)))
207         (prompt (format-prompt (if want-command
208                                    "Describe command"
209                                  "Describe function")
210                                fn))
211         (enable-recursive-minibuffers t)
212         (val (completing-read
213               prompt
214               #'help--symbol-completion-table
215               (lambda (f) (if want-command
216                          (commandp f)
217                        (or (fboundp f) (get f 'function-documentation))))
218               t nil nil
219               (and fn (symbol-name fn)))))
220    (unless (equal val "")
221      (setq fn (intern val)))
222    ;; These error messages are intended to be less technical for the
223    ;; `describe-command' case, as they are directed at users that are
224    ;; not necessarily ELisp programmers.
225    (unless (and fn (symbolp fn))
226      (user-error (if want-command
227                      "You didn't specify a command's symbol"
228                    "You didn't specify a function symbol")))
229    (unless (or (fboundp fn) (get fn 'function-documentation))
230      (user-error (if want-command
231                      "Symbol is not a command: %s"
232                    "Symbol's function definition is void: %s")
233                  fn))
234    (list fn)))
235
236;;;###autoload
237(defun describe-function (function)
238  "Display the full documentation of FUNCTION (a symbol).
239When called from Lisp, FUNCTION may also be a function object.
240
241See the `help-enable-symbol-autoload' variable for special
242handling of autoloaded functions."
243  (interactive (help-fns--describe-function-or-command-prompt))
244
245  ;; We save describe-function-orig-buffer on the help xref stack, so
246  ;; it is restored by the back/forward buttons.  'help-buffer'
247  ;; expects (current-buffer) to be a help buffer when processing
248  ;; those buttons, so we can't change the current buffer before
249  ;; calling that.
250  (let ((describe-function-orig-buffer
251         (or describe-function-orig-buffer
252             (current-buffer)))
253        (help-buffer-under-preparation t))
254
255    (help-setup-xref
256     (list (lambda (function buffer)
257             (let ((describe-function-orig-buffer
258                    (if (buffer-live-p buffer) buffer)))
259               (describe-function function)))
260           function describe-function-orig-buffer)
261     (called-interactively-p 'interactive))
262
263    (save-excursion
264      (with-help-window (help-buffer)
265        (if (get function 'reader-construct)
266            (princ function)
267          (prin1 function))
268        ;; Use " is " instead of a colon so that
269        ;; it is easier to get out the function name using forward-sexp.
270        (princ " is ")
271        (describe-function-1 function)
272        (with-current-buffer standard-output
273          ;; Return the text we displayed.
274          (buffer-string))))))
275
276;;;###autoload
277(defun describe-command (command)
278  "Display the full documentation of COMMAND (a symbol).
279When called from Lisp, COMMAND may also be a function object."
280  (interactive (help-fns--describe-function-or-command-prompt 'is-command))
281  (describe-function command))
282
283;; Could be this, if we make symbol-file do the work below.
284;; (defun help-C-file-name (subr-or-var kind)
285;;   "Return the name of the C file where SUBR-OR-VAR is defined.
286;; KIND should be `var' for a variable or `subr' for a subroutine."
287;;   (symbol-file (if (symbolp subr-or-var) subr-or-var
288;; 		 (subr-name subr-or-var))
289;; 	       (if (eq kind 'var) 'defvar 'defun)))
290;;;###autoload
291(defun help-C-file-name (subr-or-var kind)
292  "Return the name of the C file where SUBR-OR-VAR is defined.
293KIND should be `var' for a variable or `subr' for a subroutine.
294If we can't find the file name, nil is returned."
295  (let ((docbuf (get-buffer-create " *DOC*"))
296	(name (if (eq 'var kind)
297		  (concat "V" (symbol-name subr-or-var))
298		(concat "F" (if (symbolp subr-or-var)
299                                (symbol-name subr-or-var)
300                              (subr-name (advice--cd*r subr-or-var)))))))
301    (with-current-buffer docbuf
302      (goto-char (point-min))
303      (if (eobp)
304	  (insert-file-contents-literally
305	   (expand-file-name internal-doc-file-name doc-directory)))
306      (let ((file (catch 'loop
307		    (while t
308		      (let ((pnt (search-forward (concat "\^_" name "\n")
309                                                 nil t)))
310                        (if (not pnt)
311                            (throw 'loop nil)
312			  (re-search-backward "\^_S\\(.*\\)")
313			  (let ((file (match-string 1)))
314			    (if (member file build-files)
315			        (throw 'loop file)
316			      (goto-char pnt)))))))))
317        (if (not file)
318            nil
319	  (if (string-match "^ns.*\\(\\.o\\|obj\\)\\'" file)
320	      (setq file (replace-match ".m" t t file 1))
321	    (if (string-match "\\.\\(o\\|obj\\)\\'" file)
322	        (setq file (replace-match ".c" t t file))))
323	  (if (string-match "\\.\\(c\\|m\\)\\'" file)
324	      (concat "src/" file)
325	    file))))))
326
327(defcustom help-downcase-arguments nil
328  "If non-nil, argument names in *Help* buffers are downcased."
329  :type 'boolean
330  :group 'help
331  :version "23.2")
332
333(defun help-highlight-arg (arg)
334  "Highlight ARG as an argument name for a *Help* buffer.
335Return ARG in face `help-argument-name'; ARG is also downcased
336if the variable `help-downcase-arguments' is non-nil."
337  (propertize (if help-downcase-arguments (downcase arg) arg)
338	      'face 'help-argument-name))
339
340(defun help-do-arg-highlight (doc args)
341  (with-syntax-table (make-syntax-table emacs-lisp-mode-syntax-table)
342    (modify-syntax-entry ?\- "w")
343    (dolist (arg args)
344      (setq doc (replace-regexp-in-string
345                 ;; This is heuristic, but covers all common cases
346                 ;; except ARG1-ARG2
347                 (concat "\\<"                   ; beginning of word
348                         "\\(?:[a-z-]*-\\)?"     ; for xxx-ARG
349                         "\\("
350                         (regexp-quote arg)
351                         "\\)"
352                         "\\(?:es\\|s\\|th\\)?"  ; for ARGth, ARGs
353                         "\\(?:-[a-z0-9-]+\\)?"  ; for ARG-xxx, ARG-n
354                         "\\(?:-[{([<`\"‘].*?\\)?"; for ARG-{x}, (x), <x>, [x], `x', ‘x’
355                         "\\>")                  ; end of word
356                 (help-highlight-arg arg)
357                 doc t t 1)))
358    doc))
359
360(defun help-highlight-arguments (usage doc &rest args)
361  (when (and usage (string-match "^(" usage))
362    (with-temp-buffer
363      (insert usage)
364      (goto-char (point-min))
365      (let ((case-fold-search nil)
366            (next (not (or args (looking-at "\\["))))
367            (opt nil))
368        ;; Make a list of all arguments
369        (skip-chars-forward "^ ")
370        (while next
371          (or opt (not (looking-at " &")) (setq opt t))
372          (if (not (re-search-forward " \\([\\[(]*\\)\\([^] &).]+\\)" nil t))
373              (setq next nil)
374            (setq args (cons (match-string 2) args))
375            (when (and opt (string= (match-string 1) "("))
376              ;; A pesky CL-style optional argument with default value,
377              ;; so let's skip over it
378              (search-backward "(")
379              (goto-char (scan-sexps (point) 1)))))
380        ;; Highlight arguments in the USAGE string
381        (setq usage (help-do-arg-highlight (buffer-string) args))
382        ;; Highlight arguments in the DOC string
383        (setq doc (and doc (help-do-arg-highlight doc args))))))
384  ;; Return value is like the one from help-split-fundoc, but highlighted
385  (cons usage doc))
386
387;; The following function was compiled from the former functions
388;; `describe-simplify-lib-file-name' and `find-source-lisp-file' with
389;; some excerpts from `describe-function-1' and `describe-variable'.
390;; The only additional twists provided are (1) locate the defining file
391;; for autoloaded functions, and (2) give preference to files in the
392;; "install directory" (directories found via `load-path') rather than
393;; to files in the "compile directory" (directories found by searching
394;; the loaddefs.el file).  We autoload it because it's also used by
395;; `describe-face' (instead of `describe-simplify-lib-file-name').
396
397;;;###autoload
398(defun find-lisp-object-file-name (object type)
399  "Guess the file that defined the Lisp object OBJECT, of type TYPE.
400OBJECT should be a symbol associated with a function, variable, or face;
401  alternatively, it can be a function definition.
402If TYPE is `defvar', search for a variable definition.
403If TYPE is `defface', search for a face definition.
404If TYPE is not a symbol, search for a function definition.
405
406The return value is the absolute name of a readable file where OBJECT is
407defined.  If several such files exist, preference is given to a file
408found via `load-path'.  The return value can also be `C-source', which
409means that OBJECT is a function or variable defined in C.  If no
410suitable file is found, return nil."
411  (let* ((autoloaded (autoloadp type))
412	 (file-name (or (and autoloaded (nth 1 type))
413			(symbol-file
414                         ;; FIXME: Why do we have this weird "If TYPE is the
415                         ;; value returned by `symbol-function' for a function
416                         ;; symbol" exception?
417			 object (or (if (symbolp type) type) 'defun)))))
418    (cond
419     (autoloaded
420      ;; An autoloaded function: Locate the file since `symbol-function'
421      ;; has only returned a bare string here.
422      (setq file-name
423	    (locate-file file-name load-path '(".el" ".elc") 'readable)))
424     ((and (stringp file-name)
425	   (string-match "[.]*loaddefs.el\\'" file-name))
426      ;; An autoloaded variable or face.  Visit loaddefs.el in a buffer
427      ;; and try to extract the defining file.  The following form is
428      ;; from `describe-function-1' and `describe-variable'.
429      (let ((location
430	     (condition-case nil
431		 (find-function-search-for-symbol object nil file-name)
432	       (error nil))))
433	(when (cdr location)
434	  (with-current-buffer (car location)
435	    (goto-char (cdr location))
436	    (when (re-search-backward
437		   "^;;; Generated autoloads from \\(.*\\)" nil t)
438	      (setq file-name
439		    (locate-file
440		     (file-name-sans-extension
441		      (match-string-no-properties 1))
442		     load-path '(".el" ".elc") 'readable))))))))
443
444    (cond
445     ((and (not file-name) (subrp type))
446      ;; A built-in function.  The form is from `describe-function-1'.
447      (if (get-buffer " *DOC*")
448	  (help-C-file-name type 'subr)
449	'C-source))
450     ((and (not file-name) (symbolp object)
451           (eq type 'defvar)
452	   (integerp (get object 'variable-documentation)))
453      ;; A variable defined in C.  The form is from `describe-variable'.
454      (if (get-buffer " *DOC*")
455	  (help-C-file-name object 'var)
456	'C-source))
457     ((not (stringp file-name))
458      ;; If we don't have a file-name string by now, we lost.
459      nil)
460     ;; Now, `file-name' should have become an absolute file name.
461     ;; For files loaded from ~/.foo.elc, try ~/.foo.
462     ;; This applies to config files like ~/.emacs,
463     ;; which people sometimes compile.
464     ((let (fn)
465	(and (string-match "\\`\\..*\\.elc\\'"
466			   (file-name-nondirectory file-name))
467	     (string-equal (file-name-directory file-name)
468			   (file-name-as-directory (expand-file-name "~")))
469	     (file-readable-p (setq fn (file-name-sans-extension file-name)))
470	     fn)))
471     ;; When the Elisp source file can be found in the install
472     ;; directory, return the name of that file.
473     ((let ((lib-name
474	     (if (string-match "[.]elc\\'" file-name)
475		 (substring-no-properties file-name 0 -1)
476	       file-name)))
477	(or (and (file-readable-p lib-name) lib-name)
478	    ;; The library might be compressed.
479	    (and (file-readable-p (concat lib-name ".gz")) lib-name))))
480     ((let* ((lib-name (file-name-nondirectory file-name))
481	     ;; The next form is from `describe-simplify-lib-file-name'.
482	     (file-name
483	      ;; Try converting the absolute file name to a library
484	      ;; name, convert that back to a file name and see if we
485	      ;; get the original one.  If so, they are equivalent.
486	      (if (equal file-name (locate-file lib-name load-path '("")))
487		  (if (string-match "[.]elc\\'" lib-name)
488		      (substring-no-properties lib-name 0 -1)
489		    lib-name)
490		file-name))
491	     (src-file (locate-library file-name t nil 'readable)))
492	(and src-file (file-readable-p src-file) src-file))))))
493
494(defun help-fns--key-bindings (function)
495  (when (commandp function)
496    (let ((pt2 (with-current-buffer standard-output (point)))
497          (remapped (command-remapping function)))
498      (unless (memq remapped '(ignore undefined))
499        (let ((keys (where-is-internal
500                     (or remapped function) overriding-local-map nil nil))
501              non-modified-keys)
502          (if (and (eq function 'self-insert-command)
503                   (vectorp (car-safe keys))
504                   (consp (aref (car keys) 0)))
505              (princ "It is bound to many ordinary text characters.\n")
506            ;; Which non-control non-meta keys run this command?
507            (dolist (key keys)
508              (if (member (event-modifiers (aref key 0)) '(nil (shift)))
509                  (push key non-modified-keys)))
510            (when remapped
511              (princ "Its keys are remapped to ")
512              (princ (if (symbolp remapped)
513                         (format-message "`%s'" remapped)
514		       "an anonymous command"))
515              (princ ".\n"))
516
517            (when keys
518              (princ (if remapped
519                         "Without this remapping, it would be bound to "
520                       "It is bound to "))
521              ;; If lots of ordinary text characters run this command,
522              ;; don't mention them one by one.
523              (if (< (length non-modified-keys) 10)
524                  (with-current-buffer standard-output
525                    (insert (mapconcat #'help--key-description-fontified
526                                       keys ", ")))
527                (dolist (key non-modified-keys)
528                  (setq keys (delq key keys)))
529                (if keys
530                    (with-current-buffer standard-output
531                      (insert (mapconcat #'help--key-description-fontified
532                                        keys ", "))
533                      (insert ", and many ordinary text characters"))
534                  (princ "many ordinary text characters"))))
535            (when (or remapped keys non-modified-keys)
536              (princ ".")
537              (terpri)))))
538
539      (with-current-buffer standard-output
540        (fill-region-as-paragraph pt2 (point))
541        (unless (looking-back "\n\n" (- (point) 2))
542          (terpri))))))
543
544(defun help-fns--compiler-macro (function)
545  (let ((handler (function-get function 'compiler-macro)))
546    (when handler
547      (insert "  This function has a compiler macro")
548      (if (symbolp handler)
549          (progn
550            (insert (format-message " `%s'" handler))
551            (save-excursion
552              (re-search-backward (substitute-command-keys "`\\([^`']+\\)'")
553                                  nil t)
554              (help-xref-button 1 'help-function handler)))
555        ;; FIXME: Obsolete since 24.4.
556        (let ((lib (get function 'compiler-macro-file)))
557          (when (stringp lib)
558            (insert (format-message " in `%s'" lib))
559            (save-excursion
560              (re-search-backward (substitute-command-keys "`\\([^`']+\\)'")
561                                  nil t)
562              (help-xref-button 1 'help-function-cmacro function lib)))))
563      (insert ".\n"))))
564
565(defun help-fns--signature (function doc real-def real-function buffer)
566  "Insert usage at point and return docstring.  With highlighting."
567  (if (keymapp function)
568      doc                       ; If definition is a keymap, skip arglist note.
569    (let* ((advertised (gethash real-def advertised-signature-table t))
570           (arglist (if (listp advertised)
571                        advertised (help-function-arglist real-def)))
572           (usage (help-split-fundoc doc function)))
573      (if usage (setq doc (cdr usage)))
574      (let* ((use (cond
575                   ((and usage (not (listp advertised))) (car usage))
576                   ((listp arglist)
577                    (help--make-usage-docstring function arglist))
578                   ((stringp arglist) arglist)
579                   ;; Maybe the arglist is in the docstring of a symbol
580                   ;; this one is aliased to.
581                   ((let ((fun real-function))
582                      (while (and (symbolp fun)
583                                  (setq fun (symbol-function fun))
584                                  (not (setq usage (help-split-fundoc
585                                                    (documentation fun)
586                                                    function)))))
587                      usage)
588                    (car usage))
589                   ((or (stringp real-def)
590                        (vectorp real-def))
591                    (format "\nMacro: %s"
592                            (help--docstring-quote
593                             (format-kbd-macro real-def))))
594                   (t "[Missing arglist.]")))
595             ;; Insert "`X", not "(\` X)", when documenting `X.
596             (use1 (replace-regexp-in-string
597                    "\\`(\\\\=\\\\\\\\=` \\([^\n ]*\\))\\'"
598                    "\\\\=`\\1" use t))
599             (high (if buffer
600                       (let (subst-use1 subst-doc)
601                         (with-current-buffer buffer
602                           (setq subst-use1 (substitute-command-keys use1))
603                           (setq subst-doc (substitute-command-keys doc)))
604                         (help-highlight-arguments subst-use1 subst-doc))
605                     (cons use1 doc))))
606        (let ((fill-begin (point))
607              (high-usage (car high))
608              (high-doc (cdr high)))
609          (unless (and (symbolp function)
610                       (get function 'reader-construct))
611            (insert high-usage "\n"))
612          (fill-region fill-begin (point))
613          high-doc)))))
614
615(defun help-fns--parent-mode (function)
616  ;; If this is a derived mode, link to the parent.
617  (let ((parent-mode (and (symbolp function)
618                          (get function
619                               'derived-mode-parent))))
620    (when parent-mode
621      (insert (substitute-command-keys "  Parent mode: `"))
622      (let ((beg (point)))
623        (insert (format "%s" parent-mode))
624        (make-text-button beg (point)
625                          'type 'help-function
626                          'help-args (list parent-mode)))
627      (insert (substitute-command-keys "'.\n")))))
628
629(defun help-fns--obsolete (function)
630  ;; Ignore lambda constructs, keyboard macros, etc.
631  (let* ((obsolete (and (symbolp function)
632			(get function 'byte-obsolete-info)))
633         (use (car obsolete)))
634    (when obsolete
635      (insert "  This "
636	      (if (eq (car-safe (symbol-function function)) 'macro)
637		  "macro"
638		"function")
639	      " is obsolete")
640      (when (nth 2 obsolete)
641        (insert (format " since %s" (nth 2 obsolete))))
642      (insert (cond ((stringp use) (concat ";\n  " use))
643                    (use (format-message ";\n  use `%s' instead." use))
644                    (t "."))
645              "\n"))))
646
647(add-hook 'help-fns-describe-function-functions
648          #'help-fns--globalized-minor-mode)
649(defun help-fns--globalized-minor-mode (function)
650  (when (and (symbolp function)
651             (get function 'globalized-minor-mode))
652    (help-fns--customize-variable function " the global mode variable.")
653    (terpri)))
654
655;; We could use `symbol-file' but this is a wee bit more efficient.
656(defun help-fns--autoloaded-p (function file)
657  "Return non-nil if FUNCTION has previously been autoloaded.
658FILE is the file where FUNCTION was probably defined."
659  (let* ((file (file-name-sans-extension (file-truename file)))
660	 (load-hist load-history)
661	 (target (cons t function))
662	 found)
663    (while (and load-hist (not found))
664      (and (stringp (caar load-hist))
665	   (equal (file-name-sans-extension (caar load-hist)) file)
666	   (setq found (member target (cdar load-hist))))
667      (setq load-hist (cdr load-hist)))
668    found))
669
670(defun help-fns--interactive-only (function)
671  "Insert some help blurb if FUNCTION should only be used interactively."
672  ;; Ignore lambda constructs, keyboard macros, etc.
673  (and (symbolp function)
674       (not (eq (car-safe (symbol-function function)) 'macro))
675       (let* ((interactive-only
676               (or (get function 'interactive-only)
677                   (if (boundp 'byte-compile-interactive-only-functions)
678                       (memq function
679                             byte-compile-interactive-only-functions)))))
680         (when interactive-only
681           (insert "  This function is for interactive use only"
682                   ;; Cf byte-compile-form.
683                   (cond ((stringp interactive-only)
684                          (format ";\n  in Lisp code %s" interactive-only))
685                         ((and (symbolp 'interactive-only)
686                               (not (eq interactive-only t)))
687                          (format-message ";\n  in Lisp code use `%s' instead."
688                                          interactive-only))
689                         (t "."))
690                   "\n")))))
691
692(add-hook 'help-fns-describe-function-functions #'help-fns--side-effects)
693(defun help-fns--side-effects (function)
694  (when (and (symbolp function)
695             (or (function-get function 'pure)
696                 (function-get function 'side-effect-free)))
697    (insert "  This function does not change global state, "
698            "including the match data.\n")))
699
700(add-hook 'help-fns-describe-function-functions #'help-fns--disabled)
701(defun help-fns--disabled (function)
702  (when (and (symbolp function)
703             (function-get function 'disabled))
704    (insert "  This function is disabled.\n")))
705
706(defun help-fns--first-release (symbol)
707  "Return the likely first release that defined SYMBOL, or nil."
708  ;; Code below relies on the etc/NEWS* files.
709  ;; FIXME: Maybe we should also use the */ChangeLog* files when available.
710  ;; FIXME: Maybe we should also look for announcements of the addition
711  ;; of the *packages* in which the function is defined.
712  (let* ((name (symbol-name symbol))
713         (re (concat "\\_<" (regexp-quote name) "\\_>"))
714         (news (directory-files data-directory t "\\`NEWS\\(\\'\\|\\.\\)"))
715         (place nil)
716         (first nil))
717    (with-temp-buffer
718      (dolist (f news)
719        (erase-buffer)
720        (insert-file-contents f)
721        (goto-char (point-min))
722        (search-forward "\n*")
723        (while (re-search-forward re nil t)
724          (let ((pos (match-beginning 0)))
725            (save-excursion
726              ;; Almost all entries are of the form "* ... in Emacs NN.MM."
727              ;; but there are also a few in the form "* Emacs NN.MM is a bug
728              ;; fix release ...".
729              (if (not (re-search-backward "^\\* .* Emacs \\([0-9.]+[0-9]\\)"
730                                           nil t))
731                  (message "Ref found in non-versioned section in %S"
732                           (file-name-nondirectory f))
733                (let ((version (match-string 1)))
734                  (when (or (null first) (version< version first))
735                    (setq place (list f pos))
736                    (setq first version)))))))))
737    (when first
738      (make-text-button first nil 'type 'help-news 'help-args place))))
739
740(add-hook 'help-fns-describe-function-functions
741          #'help-fns--mention-first-release)
742(add-hook 'help-fns-describe-variable-functions
743          #'help-fns--mention-first-release)
744(defun help-fns--mention-first-release (object)
745  ;; Don't output anything if we've already output the :version from
746  ;; the `defcustom'.
747  (unless (memq 'help-fns--customize-variable-version
748                help-fns--activated-functions)
749    (when-let ((first (and (symbolp object)
750                           (help-fns--first-release object))))
751      (with-current-buffer standard-output
752        (insert (format "  Probably introduced at or before Emacs version %s.\n"
753                        first))))))
754
755(declare-function shortdoc-display-group "shortdoc")
756(declare-function shortdoc-function-groups "shortdoc")
757
758(add-hook 'help-fns-describe-function-functions
759          #'help-fns--mention-shortdoc-groups)
760(defun help-fns--mention-shortdoc-groups (object)
761  (require 'shortdoc)
762  (when-let ((groups (and (symbolp object)
763                          (shortdoc-function-groups object))))
764    (let ((start (point))
765          (times 0))
766      (with-current-buffer standard-output
767        (insert "  Other relevant functions are documented in the ")
768        (mapc
769         (lambda (group)
770           (when (> times 0)
771             (insert (if (= times (1- (length groups)))
772                         " and "
773                       ", ")))
774           (setq times (1+ times))
775           (insert-text-button
776            (symbol-name group)
777            'action (lambda (_)
778                      (shortdoc-display-group group object))
779            'follow-link t
780            'help-echo (purecopy "mouse-1, RET: show documentation group")))
781         groups)
782        (insert (if (= (length groups) 1)
783                    " group.\n"
784                  " groups.\n")))
785      (save-restriction
786        (narrow-to-region start (point))
787        (fill-region-as-paragraph (point-min) (point-max))
788        (goto-char (point-max))))))
789
790(defun help-fns-short-filename (filename)
791  (let* ((abbrev (abbreviate-file-name filename))
792         (short abbrev))
793    (dolist (dir load-path)
794      (let ((rel (file-relative-name filename dir)))
795        (if (< (length rel) (length short))
796            (setq short rel)))
797      (let ((rel (file-relative-name abbrev dir)))
798        (if (< (length rel) (length short))
799            (setq short rel))))
800    short))
801
802(defun help-fns--analyze-function (function)
803  ;; FIXME: Document/explain the differences between FUNCTION,
804  ;; REAL-FUNCTION, DEF, and REAL-DEF.
805  "Return information about FUNCTION.
806Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)."
807  (let* ((advised (and (symbolp function)
808		       (advice--p (advice--symbol-function function))))
809	 ;; If the function is advised, use the symbol that has the
810	 ;; real definition, if that symbol is already set up.
811	 (real-function
812	  (or (and advised
813                   (advice--cd*r (advice--symbol-function function)))
814	      function))
815	 ;; Get the real definition, if any.
816	 (def (if (symbolp real-function)
817                  (cond ((symbol-function real-function))
818                        ((get real-function 'function-documentation)
819                         nil)
820                        (t (signal 'void-function (list real-function))))
821		real-function))
822	 (aliased (and def
823                       (or (symbolp def)
824                           ;; Advised & aliased function.
825                           (and advised (symbolp real-function)
826                                (not (eq 'autoload (car-safe def))))
827                           (and (subrp def) (symbolp function)
828                                (not (string= (subr-name def)
829                                              (symbol-name function)))))))
830	 (real-def (cond
831                    ((and aliased (not (subrp def)))
832                     (let ((f real-function))
833                       (while (and (fboundp f)
834                                   (symbolp (symbol-function f)))
835                         (setq f (symbol-function f)))
836                       f))
837		    ((subrp def) (intern (subr-name def)))
838                    (t def))))
839
840    ;; If we don't have a doc string, then try to load the file.
841    (when (and help-enable-symbol-autoload
842               (autoloadp real-def)
843               ;; Empty documentation slot.
844               (not (nth 2 real-def)))
845      (condition-case err
846          (autoload-do-load real-def)
847        (error (message "Error while autoloading: %S" err))))
848
849    (list real-function def aliased real-def)))
850
851(defun help-fns-function-description-header (function)
852  "Print a line describing FUNCTION to `standard-output'."
853  (pcase-let* ((`(,_real-function ,def ,aliased ,real-def)
854                (help-fns--analyze-function function))
855               (file-name (find-lisp-object-file-name function (if aliased 'defun
856                                                                 def)))
857               (beg (if (and (or (byte-code-function-p def)
858                                 (keymapp def)
859                                 (memq (car-safe def) '(macro lambda closure)))
860                             (stringp file-name)
861                             (help-fns--autoloaded-p function file-name))
862                        (concat
863                         "an autoloaded " (if (commandp def)
864                                              "interactive "))
865                      (if (commandp def) "an interactive " "a "))))
866
867    ;; Print what kind of function-like object FUNCTION is.
868    (princ (cond ((or (stringp def) (vectorp def))
869		  "a keyboard macro")
870		 ((and (symbolp function)
871                       (get function 'reader-construct))
872                  "a reader construct")
873		 ;; Aliases are Lisp functions, so we need to check
874		 ;; aliases before functions.
875		 (aliased
876		  (format-message "an alias for `%s'" real-def))
877                 ((subr-native-elisp-p def)
878                  (concat beg "native compiled Lisp function"))
879		 ((subrp def)
880		  (concat beg (if (eq 'unevalled (cdr (subr-arity def)))
881		                  "special form"
882                                "built-in function")))
883		 ((autoloadp def)
884		  (format "an autoloaded %s"
885                          (cond
886			   ((commandp def) "interactive Lisp function")
887			   ((eq (nth 4 def) 'keymap) "keymap")
888			   ((nth 4 def) "Lisp macro")
889                           (t "Lisp function"))))
890		 ((or (eq (car-safe def) 'macro)
891		      ;; For advised macros, def is a lambda
892		      ;; expression or a byte-code-function-p, so we
893		      ;; need to check macros before functions.
894		      (macrop function))
895		  (concat beg "Lisp macro"))
896		 ((byte-code-function-p def)
897		  (concat beg "compiled Lisp function"))
898                 ((module-function-p def)
899                  (concat beg "module function"))
900		 ((eq (car-safe def) 'lambda)
901		  (concat beg "Lisp function"))
902		 ((eq (car-safe def) 'closure)
903		  (concat beg "Lisp closure"))
904		 ((keymapp def)
905		  (let ((is-full nil)
906			(elts (cdr-safe def)))
907		    (while elts
908		      (if (char-table-p (car-safe elts))
909			  (setq is-full t
910				elts nil))
911		      (setq elts (cdr-safe elts)))
912		    (concat beg (if is-full "keymap" "sparse keymap"))))
913		 (t "")))
914
915    (if (and aliased (not (fboundp real-def)))
916	(princ ",\nwhich is not defined.")
917      (with-current-buffer standard-output
918	(save-excursion
919	  (save-match-data
920	    (when (re-search-backward (substitute-command-keys
921                                       "alias for `\\([^`']+\\)'")
922                                      nil t)
923	      (help-xref-button 1 'help-function real-def)))))
924
925      (if (not file-name)
926	  (with-current-buffer standard-output
927            (setq help-mode--current-data (list :symbol function)))
928	;; We used to add .el to the file name,
929	;; but that's completely wrong when the user used load-file.
930	(princ (format-message " in `%s'"
931                               (if (eq file-name 'C-source)
932                                   "C source code"
933                                 (help-fns-short-filename file-name))))
934	;; Make a hyperlink to the library.
935	(with-current-buffer standard-output
936          (setq help-mode--current-data (list :symbol function
937                                              :file file-name))
938	  (save-excursion
939	    (re-search-backward (substitute-command-keys "`\\([^`']+\\)'")
940                                nil t)
941	    (help-xref-button 1 'help-function-def function file-name))))
942      (princ "."))))
943
944(defun help-fns--ensure-empty-line ()
945  (unless (eolp) (insert "\n"))
946  (unless (eq ?\n (char-before (1- (point)))) (insert "\n")))
947
948;;;###autoload
949(defun describe-function-1 (function)
950  (let ((pt1 (with-current-buffer (help-buffer) (point))))
951    (help-fns-function-description-header function)
952    (with-current-buffer (help-buffer)
953      (fill-region-as-paragraph (save-excursion (goto-char pt1) (forward-line 0) (point))
954                                (point))))
955  (terpri)(terpri)
956
957  (pcase-let* ((`(,real-function ,def ,_aliased ,real-def)
958                (help-fns--analyze-function function))
959               (doc-raw (condition-case nil
960                            ;; FIXME: Maybe `documentation' should return nil
961                            ;; for invalid functions i.s.o. signaling an error.
962                            (documentation function t)
963                          ;; E.g. an alias for a not yet defined function.
964                          ((invalid-function void-function) nil)))
965               (key-bindings-buffer (current-buffer)))
966
967    ;; If the function is autoloaded, and its docstring has
968    ;; key substitution constructs, load the library.
969    (and (autoloadp real-def) doc-raw
970         help-enable-autoload
971         (string-match "\\([^\\]=\\|[^=]\\|\\`\\)\\\\[[{<]" doc-raw)
972         (autoload-do-load real-def))
973
974    (help-fns--key-bindings function)
975    (with-current-buffer standard-output
976      (let ((doc (condition-case nil
977                     ;; FIXME: Maybe `help-fns--signature' should return `doc'
978                     ;; for invalid functions i.s.o. signaling an error.
979                     (help-fns--signature
980                      function doc-raw
981                      (if (subrp def) (indirect-function real-def) real-def)
982                      real-function key-bindings-buffer)
983                   ;; E.g. an alias for a not yet defined function.
984                   ((invalid-function void-function) doc-raw))))
985        (help-fns--ensure-empty-line)
986        (insert (or doc "Not documented."))
987        (help-fns--run-describe-functions
988         help-fns-describe-function-functions function))
989      ;; Avoid asking the user annoying questions if she decides
990      ;; to save the help buffer, when her locale's codeset
991      ;; isn't UTF-8.
992      (unless (memq text-quoting-style '(straight grave))
993        (set-buffer-file-coding-system 'utf-8)))))
994
995;; Add defaults to `help-fns-describe-function-functions'.
996(add-hook 'help-fns-describe-function-functions #'help-fns--obsolete)
997(add-hook 'help-fns-describe-function-functions #'help-fns--interactive-only)
998(add-hook 'help-fns-describe-function-functions #'help-fns--parent-mode)
999(add-hook 'help-fns-describe-function-functions #'help-fns--compiler-macro)
1000
1001
1002;; Variables
1003
1004;;;###autoload
1005(defun variable-at-point (&optional any-symbol)
1006  "Return the bound variable symbol found at or before point.
1007Return 0 if there is no such symbol.
1008If ANY-SYMBOL is non-nil, don't insist the symbol be bound."
1009  (with-syntax-table emacs-lisp-mode-syntax-table
1010    (or (condition-case ()
1011	    (save-excursion
1012	      (skip-chars-forward "'")
1013	      (or (not (zerop (skip-syntax-backward "_w")))
1014		  (eq (char-syntax (following-char)) ?w)
1015		  (eq (char-syntax (following-char)) ?_)
1016		  (forward-sexp -1))
1017	      (skip-chars-forward "'")
1018	      (let ((obj (read (current-buffer))))
1019		(and (symbolp obj) (boundp obj) obj)))
1020          (error nil))
1021        (let* ((str (find-tag-default))
1022               (sym (if str (intern-soft str))))
1023          (if (and sym (or any-symbol (boundp sym)))
1024              sym
1025            (save-match-data
1026              (when (and str (string-match "\\`\\W*\\(.*?\\)\\W*\\'" str))
1027                (setq sym (intern-soft (match-string 1 str)))
1028                (and (or any-symbol (boundp sym)) sym)))))
1029        0)))
1030
1031(defun describe-variable-custom-version-info (variable &optional type)
1032  (let ((custom-version (get variable 'custom-version))
1033	(cpv (get variable 'custom-package-version))
1034        (type (or type "variable"))
1035	(output nil))
1036    (if custom-version
1037	(setq output
1038	      (format "  This %s was introduced, or its default value was changed, in\n  version %s of Emacs.\n"
1039                      type custom-version))
1040      (when cpv
1041	(let* ((package (car-safe cpv))
1042	       (version (if (listp (cdr-safe cpv))
1043			    (car (cdr-safe cpv))
1044			  (cdr-safe cpv)))
1045	       (pkg-versions (assq package customize-package-emacs-version-alist))
1046	       (emacsv (cdr (assoc version pkg-versions))))
1047	  (if (and package version)
1048	      (setq output
1049		    (format (concat "  This %s was introduced, or its default value was changed, in\n  version %s of the %s package"
1050				    (if emacsv
1051					(format " that is part of Emacs %s" emacsv))
1052				    ".\n")
1053			    type version package))))))
1054    output))
1055
1056;;;###autoload
1057(defun describe-variable (variable &optional buffer frame)
1058  "Display the full documentation of VARIABLE (a symbol).
1059Returns the documentation as a string, also.
1060If VARIABLE has a buffer-local value in BUFFER or FRAME
1061\(default to the current buffer and current frame),
1062it is displayed along with the global value."
1063  (interactive
1064   (let ((v (variable-at-point))
1065	 (enable-recursive-minibuffers t)
1066         (orig-buffer (current-buffer))
1067	 val)
1068     (setq val (completing-read
1069                (format-prompt "Describe variable" (and (symbolp v) v))
1070                #'help--symbol-completion-table
1071                (lambda (vv)
1072                  (or (get vv 'variable-documentation)
1073                      (and (not (keywordp vv))
1074                           ;; Since the variable may only exist in the
1075                           ;; original buffer, we have to look for it
1076                           ;; there.
1077                           (buffer-local-boundp vv orig-buffer))))
1078                t nil nil
1079                (if (symbolp v) (symbol-name v))))
1080     (list (if (equal val "")
1081	       v (intern val)))))
1082  (let (file-name
1083        (help-buffer-under-preparation t))
1084    (unless (buffer-live-p buffer) (setq buffer (current-buffer)))
1085    (unless (frame-live-p frame) (setq frame (selected-frame)))
1086    (if (not (symbolp variable))
1087	(user-error "You didn't specify a variable")
1088      (save-excursion
1089	(let ((valvoid (not (with-current-buffer buffer (boundp variable))))
1090	      val val-start-pos locus)
1091	  ;; Extract the value before setting up the output buffer,
1092	  ;; in case `buffer' *is* the output buffer.
1093	  (unless valvoid
1094	    (with-selected-frame frame
1095	      (with-current-buffer buffer
1096		(setq val (symbol-value variable)
1097		      locus (variable-binding-locus variable)))))
1098	  (help-setup-xref (list #'describe-variable variable buffer)
1099			   (called-interactively-p 'interactive))
1100	  (with-help-window (help-buffer)
1101	    (with-current-buffer buffer
1102	      (prin1 variable)
1103	      (setq file-name (find-lisp-object-file-name variable 'defvar))
1104
1105	      (princ (if file-name
1106		         (progn
1107		           (princ (format-message
1108                                   " is a variable defined in `%s'.\n\n"
1109                                   (if (eq file-name 'C-source)
1110                                       "C source code"
1111                                     (help-fns-short-filename file-name))))
1112		           (with-current-buffer standard-output
1113                             (setq help-mode--current-data
1114                                   (list :symbol variable
1115                                         :type (if (eq file-name 'C-source)
1116                                                   'variable
1117                                                 'defvar)
1118                                         :file file-name))
1119                             (save-excursion
1120			       (re-search-backward (substitute-command-keys
1121                                                    "`\\([^`']+\\)'")
1122                                                   nil t)
1123			       (help-xref-button 1 'help-variable-def
1124					         variable file-name)))
1125		           (if valvoid
1126			       "It is void as a variable."
1127                             "Its "))
1128	               (with-current-buffer standard-output
1129                         (setq help-mode--current-data (list :symbol variable
1130                                                             :type 'variable)))
1131                       (if valvoid
1132		           " is void as a variable."
1133                         (substitute-command-keys "'s ")))))
1134	    (unless valvoid
1135	      (with-current-buffer standard-output
1136		(setq val-start-pos (point))
1137		(princ "value is")
1138		(let ((line-beg (line-beginning-position))
1139		      (print-rep
1140		       (let ((rep
1141			      (let ((print-quoted t)
1142                                    (print-circle t))
1143				(cl-prin1-to-string val))))
1144			 (if (and (symbolp val) (not (booleanp val)))
1145			     (format-message "`%s'" rep)
1146			   rep))))
1147		  (if (< (+ (length print-rep) (point) (- line-beg)) 68)
1148		      (insert " " print-rep)
1149		    (terpri)
1150                    (let ((buf (current-buffer)))
1151                      (with-temp-buffer
1152                        (lisp-mode-variables nil)
1153                        (set-syntax-table emacs-lisp-mode-syntax-table)
1154                        (insert print-rep)
1155                        (pp-buffer)
1156                        (let ((pp-buffer (current-buffer)))
1157                          (with-current-buffer buf
1158                            (insert-buffer-substring pp-buffer)))))
1159                    ;; Remove trailing newline.
1160                    (and (= (char-before) ?\n) (delete-char -1)))
1161		  (let* ((sv (get variable 'standard-value))
1162			 (origval (and (consp sv)
1163				       (condition-case nil
1164					   (eval (car sv) t)
1165					 (error :help-eval-error))))
1166                         from)
1167		    (when (and (consp sv)
1168                               (not (equal origval val))
1169                               (not (equal origval :help-eval-error)))
1170		      (princ "\nOriginal value was \n")
1171		      (setq from (point))
1172		      (if (and (symbolp origval) (not (booleanp origval)))
1173			  (let* ((rep (cl-prin1-to-string origval))
1174				 (print-rep (format-message "`%s'" rep)))
1175			    (insert print-rep))
1176			(cl-prin1 origval))
1177                      (save-restriction
1178                        (narrow-to-region from (point))
1179                        (save-excursion (pp-buffer)))
1180		      (if (< (point) (+ from 20))
1181			  (delete-region (1- from) from)))))))
1182	    (terpri)
1183	    (when locus
1184	      (cond
1185               ((bufferp locus)
1186                (princ (format "Local in buffer %s; "
1187                               (buffer-name buffer))))
1188               ((terminal-live-p locus)
1189                (princ "It is a terminal-local variable; "))
1190               (t
1191                (princ (format "It is local to %S" locus))))
1192	      (if (not (default-boundp variable))
1193		  (princ "globally void")
1194		(let ((global-val (default-value variable)))
1195		  (with-current-buffer standard-output
1196		    (princ "global value is ")
1197		    (if (eq val global-val)
1198			(princ "the same.")
1199		      (terpri)
1200		      ;; Fixme: pp can take an age if you happen to
1201		      ;; ask for a very large expression.  We should
1202		      ;; probably print it raw once and check it's a
1203		      ;; sensible size before prettyprinting.  -- fx
1204		      (let ((from (point)))
1205                        (cl-prin1 global-val)
1206                        (save-restriction
1207                          (narrow-to-region from (point))
1208                          (save-excursion (pp-buffer)))
1209			;; See previous comment for this function.
1210			;; (help-xref-on-pp from (point))
1211			(if (< (point) (+ from 20))
1212			    (delete-region (1- from) from)))))))
1213              (terpri))
1214
1215	    ;; If the value is large, move it to the end.
1216	    (with-current-buffer standard-output
1217	      (when (> (count-lines (point-min) (point-max)) 10)
1218		;; Note that setting the syntax table like below
1219		;; makes forward-sexp move over a `'s' at the end
1220		;; of a symbol.
1221		(set-syntax-table emacs-lisp-mode-syntax-table)
1222		(goto-char val-start-pos)
1223		(when (looking-at "value is") (replace-match ""))
1224		(save-excursion
1225		  (insert "\n\nValue:")
1226                  (setq-local help-button-cache (point-marker)))
1227		(insert "value is shown ")
1228		(insert-button "below"
1229			       'action help-button-cache
1230			       'follow-link t
1231			       'help-echo "mouse-2, RET: show value")
1232		(insert ".\n")))
1233            (terpri)
1234
1235            (let* ((alias (condition-case nil
1236                              (indirect-variable variable)
1237                            (error variable)))
1238                   (doc (or (documentation-property
1239                             variable 'variable-documentation)
1240                            (documentation-property
1241                             alias 'variable-documentation))))
1242
1243	      (with-current-buffer standard-output
1244		(insert (or doc "Not documented as a variable.")))
1245
1246              ;; Output the indented administrative bits.
1247              (with-current-buffer buffer
1248                (help-fns--run-describe-functions
1249                 help-fns-describe-variable-functions variable))
1250
1251              (with-current-buffer standard-output
1252                ;; If we have the long value of the variable at the
1253                ;; end, remove superfluous empty lines before it.
1254                (unless (eobp)
1255                  (while (looking-at-p "\n")
1256                    (delete-char 1)))))
1257
1258	    (with-current-buffer standard-output
1259	      ;; Return the text we displayed.
1260	      (buffer-string))))))))
1261
1262(defun help-fns--run-describe-functions (functions &rest args)
1263  (with-current-buffer standard-output
1264    (unless (bolp)
1265      (insert "\n"))
1266    (help-fns--ensure-empty-line))
1267  (let ((help-fns--activated-functions nil))
1268    (dolist (func functions)
1269      (let ((size (buffer-size standard-output)))
1270        (apply func args)
1271        ;; This function inserted something, so register it.
1272        (when (> (buffer-size standard-output) size)
1273          (push func help-fns--activated-functions)))))
1274  (with-current-buffer standard-output
1275    (help-fns--ensure-empty-line)))
1276
1277(add-hook 'help-fns-describe-variable-functions #'help-fns--customize-variable)
1278(defun help-fns--customize-variable (variable &optional text)
1279  ;; Make a link to customize if this variable can be customized.
1280  (when (custom-variable-p variable)
1281    (let ((customize-label "customize"))
1282      (princ (concat "  You can " customize-label (or text " this variable.")))
1283      (with-current-buffer standard-output
1284	(save-excursion
1285	  (re-search-backward
1286	   (concat "\\(" customize-label "\\)") nil t)
1287	  (help-xref-button 1 'help-customize-variable variable)))
1288      (terpri))))
1289
1290(add-hook 'help-fns-describe-variable-functions
1291          #'help-fns--customize-variable-version)
1292(defun help-fns--customize-variable-version (variable)
1293  (when (custom-variable-p variable)
1294    ;; Note variable's version or package version.
1295    (when-let ((output (describe-variable-custom-version-info variable)))
1296      (princ output))))
1297
1298(add-hook 'help-fns-describe-variable-functions #'help-fns--var-safe-local)
1299(defun help-fns--var-safe-local (variable)
1300  (let ((safe-var (get variable 'safe-local-variable)))
1301    (when safe-var
1302      (princ "  This variable is safe as a file local variable ")
1303      (princ "if its value\n  satisfies the predicate ")
1304      (princ (if (byte-code-function-p safe-var)
1305		 "which is a byte-compiled expression.\n"
1306	       (format-message "`%s'.\n" safe-var))))))
1307
1308(add-hook 'help-fns-describe-variable-functions #'help-fns--var-risky)
1309(defun help-fns--var-risky (variable)
1310  ;; Can be both risky and safe, eg auto-fill-function.
1311  (when (risky-local-variable-p variable)
1312    (princ "  This variable may be risky if used as a \
1313file-local variable.\n")
1314    (when (assq variable safe-local-variable-values)
1315      (princ (substitute-command-keys
1316              "  However, you have added it to \
1317`safe-local-variable-values'.\n")))))
1318
1319(add-hook 'help-fns-describe-variable-functions #'help-fns--var-ignored-local)
1320(defun help-fns--var-ignored-local (variable)
1321  (when (memq variable ignored-local-variables)
1322    (princ "  This variable is ignored as a file-local \
1323variable.\n")))
1324
1325(add-hook 'help-fns-describe-variable-functions #'help-fns--var-file-local)
1326(defun help-fns--var-file-local (variable)
1327  (when (boundp variable)
1328    (let ((val (symbol-value variable)))
1329      (when (member (cons variable val)
1330                    file-local-variables-alist)
1331        (if (member (cons variable val)
1332                    dir-local-variables-alist)
1333	    (let ((file (and buffer-file-name
1334                             (not (file-remote-p buffer-file-name))
1335                             (dir-locals-find-file buffer-file-name)))
1336                  (is-directory nil))
1337	      (princ (substitute-command-keys
1338		      "  This variable's value is directory-local"))
1339              (when (consp file)       ; result from cache
1340                ;; If the cache element has an mtime, we
1341                ;; assume it came from a file.
1342                (if (nth 2 file)
1343                    ;; (car file) is a directory.
1344                    (setq file (dir-locals--all-files (car file)))
1345                  ;; Otherwise, assume it was set directly.
1346                  (setq file (car file)
1347                        is-directory t)))
1348              (if (null file)
1349                  (princ ".\n")
1350                (princ ", set ")
1351                (princ (substitute-command-keys
1352                        (cond
1353                         (is-directory "for the directory\n  `")
1354                         ;; Many files matched.
1355                         ((and (consp file) (cdr file))
1356                          (setq file (file-name-directory (car file)))
1357                          (format "by one of the\n  %s files in the directory\n  `"
1358                                  dir-locals-file))
1359                         (t (setq file (car file))
1360                            "by the file\n  `"))))
1361	        (with-current-buffer standard-output
1362	          (insert-text-button
1363	           file 'type 'help-dir-local-var-def
1364                   'help-args (list variable file)))
1365	        (princ (substitute-command-keys "'.\n"))))
1366          (princ (substitute-command-keys
1367	          "  This variable's value is file-local.\n")))))))
1368
1369(add-hook 'help-fns-describe-variable-functions #'help-fns--var-watchpoints)
1370(defun help-fns--var-watchpoints (variable)
1371  (let ((watchpoints (get-variable-watchers variable)))
1372    (when watchpoints
1373      (princ "  Calls these functions when changed: ")
1374      ;; FIXME: Turn function names into hyperlinks.
1375      (princ watchpoints)
1376      (terpri))))
1377
1378(add-hook 'help-fns-describe-variable-functions #'help-fns--var-obsolete)
1379(defun help-fns--var-obsolete (variable)
1380  (let* ((obsolete (get variable 'byte-obsolete-variable))
1381	 (use (car obsolete)))
1382    (when obsolete
1383      (princ "  This variable is obsolete")
1384      (if (nth 2 obsolete)
1385          (princ (format " since %s" (nth 2 obsolete))))
1386      (princ (cond ((stringp use) (concat ";\n  " use))
1387		   (use (format-message ";\n  use `%s' instead."
1388                                        (car obsolete)))
1389		   (t ".")))
1390      (terpri))))
1391
1392(add-hook 'help-fns-describe-variable-functions #'help-fns--var-alias)
1393(defun help-fns--var-alias (variable)
1394  ;; Mention if it's an alias.
1395  (let ((alias (condition-case nil
1396                   (indirect-variable variable)
1397                 (error variable))))
1398    (unless (eq alias variable)
1399      (princ (format-message
1400              "  This variable is an alias for `%s'.\n"
1401              alias)))))
1402
1403(add-hook 'help-fns-describe-variable-functions #'help-fns--var-aliases)
1404(defun help-fns--var-aliases (variable)
1405  ;; Mention if it has any aliases.
1406  (let (aliases alias)
1407    (mapatoms
1408     (lambda (sym)
1409       (when (and (boundp sym)
1410		  (setq alias (indirect-variable sym))
1411                  (eq alias variable)
1412		  (not (eq alias sym)))
1413	 (push sym aliases)))
1414     obarray)
1415    (when aliases
1416      (princ
1417       (if (= (length aliases) 1)
1418           (format-message
1419            "  This variable has an alias: `%s'.\n" (car aliases))
1420         (format-message
1421          "  This variable has the following aliases: %s.\n"
1422          (mapconcat
1423           (lambda (sym)
1424             (format "`%s'" sym))
1425           aliases ",\n    ")))))))
1426
1427(add-hook 'help-fns-describe-variable-functions #'help-fns--var-bufferlocal)
1428(defun help-fns--var-bufferlocal (variable)
1429  (let ((permanent-local (get variable 'permanent-local))
1430        (locus (variable-binding-locus variable)))
1431    ;; Mention if it's a local variable.
1432    (cond
1433     ((and (local-variable-if-set-p variable)
1434	   (or (not (local-variable-p variable))
1435	       (with-temp-buffer
1436	         (local-variable-if-set-p variable))))
1437      (princ "  Automatically becomes ")
1438      (if permanent-local
1439	  (princ "permanently "))
1440      (princ "buffer-local when set.\n"))
1441     ((not permanent-local))
1442     ((bufferp locus)
1443      (princ
1444       (substitute-command-keys
1445        "  This variable's buffer-local value is permanent.\n")))
1446     (t
1447      (princ (substitute-command-keys
1448	      "  This variable's value is permanent \
1449if it is given a local binding.\n"))))))
1450
1451
1452;; Faces.
1453
1454;;;###autoload
1455(defun describe-face (face &optional frame)
1456  "Display the properties of face FACE on FRAME.
1457Interactively, FACE defaults to the faces of the character after point
1458and FRAME defaults to the selected frame.
1459
1460If the optional argument FRAME is given, report on face FACE in that frame.
1461If FRAME is t, report on the defaults for face FACE (for new frames).
1462If FRAME is omitted or nil, use the selected frame."
1463  (interactive (list (read-face-name "Describe face"
1464                                     (or (face-at-point t) 'default)
1465                                     t)))
1466  (let ((help-buffer-under-preparation t))
1467    (help-setup-xref (list #'describe-face face)
1468		     (called-interactively-p 'interactive))
1469    (unless face
1470      (setq face 'default))
1471    (if (not (listp face))
1472        (setq face (list face)))
1473    (with-help-window (help-buffer)
1474      (with-current-buffer standard-output
1475        (dolist (f face (buffer-string))
1476	  (if (stringp f) (setq f (intern f)))
1477	  ;; We may get called for anonymous faces (i.e., faces
1478	  ;; expressed using prop-value plists).  Those can't be
1479	  ;; usefully customized, so ignore them.
1480	  (when (symbolp f)
1481	    (insert "Face: " (symbol-name f))
1482	    (if (not (facep f))
1483	        (insert "   undefined face.\n")
1484	      (let ((customize-label "customize this face")
1485		    file-name)
1486	        (insert (concat " (" (propertize "sample" 'font-lock-face f) ")"))
1487	        (princ (concat " (" customize-label ")\n"))
1488	        ;; FIXME not sure how much of this belongs here, and
1489	        ;; how much in `face-documentation'.  The latter is
1490	        ;; not used much, but needs to return nil for
1491	        ;; undocumented faces.
1492	        (let ((alias (get f 'face-alias))
1493		      (face f)
1494		      obsolete)
1495		  (when alias
1496		    (setq face alias)
1497		    (insert
1498		     (format-message
1499                      "\n  %s is an alias for the face `%s'.\n%s"
1500                      f alias
1501                      (if (setq obsolete (get f 'obsolete-face))
1502                          (format-message
1503                           "  This face is obsolete%s; use `%s' instead.\n"
1504                           (if (stringp obsolete)
1505                               (format " since %s" obsolete)
1506                             "")
1507                           alias)
1508                        ""))))
1509		  (insert "\nDocumentation:\n"
1510                          (substitute-command-keys
1511                           (or (face-documentation face)
1512                               "Not documented as a face."))
1513			  "\n\n"))
1514	        (with-current-buffer standard-output
1515		  (save-excursion
1516		    (re-search-backward
1517		     (concat "\\(" customize-label "\\)") nil t)
1518		    (help-xref-button 1 'help-customize-face f)))
1519	        (setq file-name (find-lisp-object-file-name f 'defface))
1520	        (if (not file-name)
1521                    (setq help-mode--current-data (list :symbol f))
1522                  (setq help-mode--current-data (list :symbol f
1523                                                      :file file-name))
1524		  (princ (substitute-command-keys "Defined in `"))
1525		  (princ (help-fns-short-filename file-name))
1526		  (princ (substitute-command-keys "'"))
1527		  ;; Make a hyperlink to the library.
1528		  (save-excursion
1529		    (re-search-backward
1530                     (substitute-command-keys "`\\([^`']+\\)'") nil t)
1531		    (help-xref-button 1 'help-face-def f file-name))
1532		  (princ ".")
1533		  (terpri)
1534		  (terpri))))
1535	    (terpri)
1536            (help-fns--run-describe-functions
1537             help-fns-describe-face-functions f frame)))))))
1538
1539(add-hook 'help-fns-describe-face-functions
1540          #'help-fns--face-custom-version-info)
1541(defun help-fns--face-custom-version-info (face _frame)
1542  (when-let ((version-info (describe-variable-custom-version-info face 'face)))
1543    (insert version-info)
1544    (terpri)))
1545
1546(add-hook 'help-fns-describe-face-functions #'help-fns--face-attributes)
1547(defun help-fns--face-attributes (face frame)
1548  (let* ((attrs '((:family . "Family")
1549		  (:foundry . "Foundry")
1550		  (:width . "Width")
1551		  (:height . "Height")
1552		  (:weight . "Weight")
1553		  (:slant . "Slant")
1554		  (:foreground . "Foreground")
1555		  (:distant-foreground . "DistantForeground")
1556		  (:background . "Background")
1557		  (:underline . "Underline")
1558		  (:overline . "Overline")
1559		  (:strike-through . "Strike-through")
1560		  (:box . "Box")
1561		  (:inverse-video . "Inverse")
1562		  (:stipple . "Stipple")
1563		  (:font . "Font")
1564		  (:fontset . "Fontset")
1565                  (:extend . "Extend")
1566		  (:inherit . "Inherit")))
1567         (max-width (apply #'max (mapcar (lambda (x) (length (cdr x)))
1568					 attrs))))
1569    (dolist (a attrs)
1570      (let ((attr (face-attribute face (car a) frame)))
1571	(insert (make-string (- max-width (length (cdr a))) ?\s)
1572		(cdr a) ": " (format "%s" attr))
1573	(if (and (eq (car a) :inherit)
1574		 (not (eq attr 'unspecified)))
1575	    ;; Make a hyperlink to the parent face.
1576	    (save-excursion
1577	      (re-search-backward ": \\([^:]+\\)" nil t)
1578	      (help-xref-button 1 'help-face attr)))
1579	(insert "\n")))
1580    (terpri)))
1581
1582(defvar help-xref-stack-item)
1583
1584;;;###autoload
1585(defun describe-symbol (symbol &optional buffer frame)
1586  "Display the full documentation of SYMBOL.
1587Will show the info of SYMBOL as a function, variable, and/or face.
1588Optional arguments BUFFER and FRAME specify for which buffer and
1589frame to show the information about SYMBOL; they default to the
1590current buffer and the selected frame, respectively."
1591  (interactive
1592   (let* ((v-or-f (symbol-at-point))
1593          (found (if v-or-f (cl-some (lambda (x) (funcall (nth 1 x) v-or-f))
1594                                     describe-symbol-backends)))
1595          (v-or-f (if found v-or-f (function-called-at-point)))
1596          (found (or found v-or-f))
1597          (enable-recursive-minibuffers t)
1598          (val (completing-read (format-prompt "Describe symbol"
1599                                               (and found v-or-f))
1600				#'help--symbol-completion-table
1601				(lambda (vv)
1602                                  (cl-some (lambda (x) (funcall (nth 1 x) vv))
1603                                           describe-symbol-backends))
1604				t nil nil
1605				(if found (symbol-name v-or-f)))))
1606     (list (if (equal val "")
1607	       (or v-or-f "") (intern val)))))
1608  (let ((help-buffer-under-preparation t))
1609    (if (not (symbolp symbol))
1610        (user-error "You didn't specify a function or variable"))
1611    (unless (buffer-live-p buffer) (setq buffer (current-buffer)))
1612    (unless (frame-live-p frame) (setq frame (selected-frame)))
1613    (with-current-buffer (help-buffer)
1614      ;; Push the previous item on the stack before clobbering the output buffer.
1615      (help-setup-xref nil nil)
1616      (let* ((docs
1617              (nreverse
1618               (delq nil
1619                     (mapcar (pcase-lambda (`(,name ,testfn ,descfn))
1620                               (when (funcall testfn symbol)
1621                                 ;; Don't record the current entry in the stack.
1622                                 (setq help-xref-stack-item nil)
1623                                 (cons name
1624                                       (funcall descfn symbol buffer frame))))
1625                             describe-symbol-backends))))
1626             (single (null (cdr docs))))
1627        (while (cdr docs)
1628          (goto-char (point-min))
1629          (let ((inhibit-read-only t)
1630                (name (caar docs))        ;Name of doc currently at BOB.
1631                (doc (cdr (cadr docs))))  ;Doc to add at BOB.
1632            (when doc
1633              (insert doc)
1634              (delete-region (point)
1635                             (progn (skip-chars-backward " \t\n") (point)))
1636              (insert "\n\n" (make-separator-line) "\n")
1637              (when name
1638                (insert (symbol-name symbol)
1639                        " is also a " name "." "\n\n"))))
1640          (setq docs (cdr docs)))
1641        (unless single
1642          ;; Don't record the `describe-variable' item in the stack.
1643          (setq help-xref-stack-item nil)
1644          (help-setup-xref (list #'describe-symbol symbol) nil))
1645        (goto-char (point-min))))))
1646
1647;;;###autoload
1648(defun describe-syntax (&optional buffer)
1649  "Describe the syntax specifications in the syntax table of BUFFER.
1650The descriptions are inserted in a help buffer, which is then displayed.
1651BUFFER defaults to the current buffer."
1652  (interactive)
1653  (setq buffer (or buffer (current-buffer)))
1654  (let ((help-buffer-under-preparation t))
1655    (help-setup-xref (list #'describe-syntax buffer)
1656		     (called-interactively-p 'interactive))
1657    (with-help-window (help-buffer)
1658      (let ((table (with-current-buffer buffer (syntax-table))))
1659        (with-current-buffer standard-output
1660	  (describe-vector table 'internal-describe-syntax-value)
1661	  (while (setq table (char-table-parent table))
1662	    (insert "\nThe parent syntax table is:")
1663	    (describe-vector table 'internal-describe-syntax-value)))))))
1664
1665(defun help-describe-category-set (value)
1666  (insert (cond
1667	   ((null value) "default")
1668	   ((char-table-p value) "deeper char-table ...")
1669	   (t (condition-case nil
1670		  (category-set-mnemonics value)
1671                (error "Invalid"))))))
1672
1673;;;###autoload
1674(defun describe-categories (&optional buffer)
1675  "Describe the category specifications in the current category table.
1676The descriptions are inserted in a buffer, which is then displayed.
1677If BUFFER is non-nil, then describe BUFFER's category table instead.
1678BUFFER should be a buffer or a buffer name."
1679  (interactive)
1680  (let ((help-buffer-under-preparation t))
1681    (setq buffer (or buffer (current-buffer)))
1682    (help-setup-xref (list #'describe-categories buffer)
1683		     (called-interactively-p 'interactive))
1684    (with-help-window (help-buffer)
1685      (let* ((table (with-current-buffer buffer (category-table)))
1686	     (docs (char-table-extra-slot table 0)))
1687        (if (or (not (vectorp docs)) (/= (length docs) 95))
1688	    (error "Invalid first extra slot in this category table\n"))
1689        (with-current-buffer standard-output
1690          (setq-default help-button-cache (make-marker))
1691	  (insert "Legend of category mnemonics ")
1692          (insert-button "(longer descriptions at the bottom)"
1693                         'action help-button-cache
1694                         'follow-link t
1695                         'help-echo "mouse-2, RET: show full legend")
1696          (insert "\n")
1697	  (let ((pos (point)) (items 0) lines n)
1698	    (dotimes (i 95)
1699	      (if (aref docs i) (setq items (1+ items))))
1700	    (setq lines (1+ (/ (1- items) 4)))
1701	    (setq n 0)
1702	    (dotimes (i 95)
1703	      (let ((elt (aref docs i)))
1704	        (when elt
1705		  (string-match ".*" elt)
1706		  (setq elt (match-string 0 elt))
1707		  (if (>= (length elt) 17)
1708		      (setq elt (concat (substring elt 0 14) "...")))
1709		  (if (< (point) (point-max))
1710		      (move-to-column (* 20 (/ n lines)) t))
1711		  (insert (+ i ?\s) ?: elt)
1712		  (if (< (point) (point-max))
1713		      (forward-line 1)
1714		    (insert "\n"))
1715		  (setq n (1+ n))
1716		  (if (= (% n lines) 0)
1717		      (goto-char pos))))))
1718	  (goto-char (point-max))
1719	  (insert "\n"
1720		  "character(s)\tcategory mnemonics\n"
1721		  "------------\t------------------")
1722	  (describe-vector table 'help-describe-category-set)
1723          (set-marker help-button-cache (point))
1724	  (insert "Legend of category mnemonics:\n")
1725	  (dotimes (i 95)
1726	    (let ((elt (aref docs i)))
1727	      (when elt
1728	        (if (string-match "\n" elt)
1729		    (setq elt (substring elt (match-end 0))))
1730	        (insert (+ i ?\s) ": " elt "\n"))))
1731	  (while (setq table (char-table-parent table))
1732	    (insert "\nThe parent category table is:")
1733	    (describe-vector table 'help-describe-category-set)))))))
1734
1735(defun help-fns-find-keymap-name (keymap)
1736  "Find the name of the variable with value KEYMAP.
1737Return nil if KEYMAP is not a valid keymap, or if there is no
1738variable with value KEYMAP."
1739  (when (keymapp keymap)
1740    (let ((name (catch 'found-keymap
1741                  (mapatoms (lambda (symb)
1742                              (when (and (boundp symb)
1743                                         (eq (symbol-value symb) keymap)
1744                                         (not (eq symb 'keymap))
1745                                         (throw 'found-keymap symb)))))
1746                  nil)))
1747      ;; Follow aliasing.
1748      (or (ignore-errors (indirect-variable name)) name))))
1749
1750(defun help-fns--most-relevant-active-keymap ()
1751  "Return the name of the most relevant active keymap.
1752The heuristic to determine which keymap is most likely to be
1753relevant to a user follows this order:
1754
17551. 'keymap' text property at point
17562. 'local-map' text property at point
17573. the `current-local-map'
1758
1759This is used to set the default value for the interactive prompt
1760in `describe-keymap'.  See also `Searching the Active Keymaps'."
1761  (help-fns-find-keymap-name (or (get-char-property (point) 'keymap)
1762                         (if (get-text-property (point) 'local-map)
1763                             (get-char-property (point) 'local-map)
1764                           (current-local-map)))))
1765
1766(defvar keymap-name-history nil
1767  "History for input to `describe-keymap'.")
1768
1769;;;###autoload
1770(defun describe-keymap (keymap)
1771  "Describe key bindings in KEYMAP.
1772When called interactively, prompt for a variable that has a
1773keymap value."
1774  (interactive
1775   (let* ((km (help-fns--most-relevant-active-keymap))
1776          (val (completing-read
1777                (format-prompt "Keymap" km)
1778                obarray
1779                (lambda (m) (and (boundp m) (keymapp (symbol-value m))))
1780                t nil 'keymap-name-history
1781                (symbol-name km))))
1782     (unless (equal val "")
1783       (setq km (intern val)))
1784     (unless (and km (keymapp (symbol-value km)))
1785       (user-error "Not a keymap: %s" km))
1786     (list km)))
1787  (let (used-gentemp
1788        (help-buffer-under-preparation t))
1789    (unless (and (symbolp keymap)
1790                 (boundp keymap)
1791                 (keymapp (symbol-value keymap)))
1792      (when (not (keymapp keymap))
1793        (if (symbolp keymap)
1794            (error "Not a keymap variable: %S" keymap)
1795          (error "Not a keymap")))
1796      (let ((sym nil))
1797        (unless sym
1798          (setq sym (cl-gentemp "KEYMAP OBJECT (no variable) "))
1799          (setq used-gentemp t)
1800          (set sym keymap))
1801        (setq keymap sym)))
1802    ;; Follow aliasing.
1803    (setq keymap (or (ignore-errors (indirect-variable keymap)) keymap))
1804    (help-setup-xref (list #'describe-keymap keymap)
1805                     (called-interactively-p 'interactive))
1806    (let* ((name (symbol-name keymap))
1807           (doc (documentation-property keymap 'variable-documentation))
1808           (file-name (find-lisp-object-file-name keymap 'defvar)))
1809      (with-help-window (help-buffer)
1810        (with-current-buffer standard-output
1811          (unless used-gentemp
1812            (princ (format-message "%S is a keymap variable" keymap))
1813            (if (not file-name)
1814                (progn
1815                  (setq help-mode--current-data (list :symbol keymap))
1816                  (princ ".\n\n"))
1817              (princ (format-message
1818                      " defined in `%s'.\n\n"
1819                      (if (eq file-name 'C-source)
1820                          "C source code"
1821                        (help-fns-short-filename file-name))))
1822              (save-excursion
1823                (re-search-backward (substitute-command-keys
1824                                     "`\\([^`']+\\)'")
1825                                    nil t)
1826                (setq help-mode--current-data (list :symbol keymap
1827                                                    :file file-name))
1828                (help-xref-button 1 'help-variable-def
1829                                  keymap file-name))))
1830          (when (and (not (equal "" doc)) doc)
1831            (princ "Documentation:\n")
1832            (princ (format-message "%s\n\n" doc)))
1833          ;; Use `insert' instead of `princ', so control chars (e.g. \377)
1834          ;; insert correctly.
1835          (insert (substitute-command-keys (concat "\\{" name "}"))))))
1836    ;; Cleanup.
1837    (when used-gentemp
1838      (makunbound keymap))))
1839
1840;;;###autoload
1841(defun describe-mode (&optional buffer)
1842  "Display documentation of current major mode and minor modes.
1843A brief summary of the minor modes comes first, followed by the
1844major mode description.  This is followed by detailed
1845descriptions of the minor modes, each on a separate page.
1846
1847For this to work correctly for a minor mode, the mode's indicator
1848variable \(listed in `minor-mode-alist') must also be a function
1849whose documentation describes the minor mode.
1850
1851If called from Lisp with a non-nil BUFFER argument, display
1852documentation for the major and minor modes of that buffer."
1853  (interactive "@")
1854  (let ((help-buffer-under-preparation t))
1855    (unless buffer (setq buffer (current-buffer)))
1856    (help-setup-xref (list #'describe-mode buffer)
1857		     (called-interactively-p 'interactive))
1858    ;; For the sake of help-do-xref and help-xref-go-back,
1859    ;; don't switch buffers before calling `help-buffer'.
1860    (with-help-window (help-buffer)
1861      (with-current-buffer buffer
1862	(let (minors)
1863	  ;; Older packages do not register in minor-mode-list but only in
1864	  ;; minor-mode-alist.
1865	  (dolist (x minor-mode-alist)
1866	    (setq x (car x))
1867	    (unless (memq x minor-mode-list)
1868	      (push x minor-mode-list)))
1869	  ;; Find enabled minor mode we will want to mention.
1870	  (dolist (mode minor-mode-list)
1871	    ;; Document a minor mode if it is listed in minor-mode-alist,
1872	    ;; non-nil, and has a function definition.
1873	    (let ((fmode (or (get mode :minor-mode-function) mode)))
1874	      (and (boundp mode) (symbol-value mode)
1875		   (fboundp fmode)
1876		   (let ((pretty-minor-mode
1877			  (if (string-match "\\(\\(-minor\\)?-mode\\)?\\'"
1878					    (symbol-name fmode))
1879			      (capitalize
1880			       (substring (symbol-name fmode)
1881					  0 (match-beginning 0)))
1882			    fmode)))
1883		     (push (list fmode pretty-minor-mode
1884				 (format-mode-line (assq mode minor-mode-alist)))
1885			   minors)))))
1886	  ;; Narrowing is not a minor mode, but its indicator is part of
1887	  ;; mode-line-modes.
1888	  (when (buffer-narrowed-p)
1889	    (push '(narrow-to-region "Narrow" " Narrow") minors))
1890	  (setq minors
1891		(sort minors
1892		      (lambda (a b) (string-lessp (cadr a) (cadr b)))))
1893	  (when minors
1894	    (princ "Enabled minor modes:\n")
1895	    (make-local-variable 'help-button-cache)
1896	    (with-current-buffer standard-output
1897	      (dolist (mode minors)
1898		(let ((mode-function (nth 0 mode))
1899		      (pretty-minor-mode (nth 1 mode))
1900		      (indicator (nth 2 mode)))
1901		  (save-excursion
1902		    (goto-char (point-max))
1903		    (princ "\n\f\n")
1904		    (push (point-marker) help-button-cache)
1905		    ;; Document the minor modes fully.
1906                    (insert-text-button
1907                     pretty-minor-mode 'type 'help-function
1908                     'help-args (list mode-function)
1909                     'button '(t))
1910		    (princ (format " minor mode (%s):\n"
1911				   (if (zerop (length indicator))
1912				       "no indicator"
1913				     (format "indicator%s"
1914					     indicator))))
1915		    (princ (help-split-fundoc (documentation mode-function)
1916                                              nil 'doc)))
1917		  (insert-button pretty-minor-mode
1918				 'action (car help-button-cache)
1919				 'follow-link t
1920				 'help-echo "mouse-2, RET: show full information")
1921		  (newline)))
1922	      (forward-line -1)
1923	      (fill-paragraph nil)
1924	      (forward-line 1))
1925
1926	    (princ "\n(Information about these minor modes follows the major mode info.)\n\n"))
1927	  ;; Document the major mode.
1928	  (let ((mode mode-name))
1929	    (with-current-buffer standard-output
1930              (let ((start (point)))
1931		(insert (format-mode-line mode nil nil buffer))
1932		(add-text-properties start (point) '(face bold)))))
1933	  (princ " mode")
1934	  (let* ((mode major-mode)
1935		 (file-name (find-lisp-object-file-name mode nil)))
1936	    (if (not file-name)
1937		(setq help-mode--current-data (list :symbol mode))
1938	      (princ (format-message " defined in `%s'"
1939                                     (help-fns-short-filename file-name)))
1940	      ;; Make a hyperlink to the library.
1941	      (with-current-buffer standard-output
1942		(save-excursion
1943		  (re-search-backward (substitute-command-keys "`\\([^`']+\\)'")
1944                                      nil t)
1945                  (setq help-mode--current-data (list :symbol mode
1946                                                      :file file-name))
1947                  (help-xref-button 1 'help-function-def mode file-name)))))
1948          (let ((fundoc (help-split-fundoc (documentation major-mode) nil 'doc)))
1949            (with-current-buffer standard-output
1950              (insert ":\n")
1951              (insert fundoc)
1952              (insert (help-fns--list-local-commands))))))))
1953    ;; For the sake of IELM and maybe others
1954    nil)
1955
1956(defun help-fns--list-local-commands ()
1957  (let ((functions nil))
1958    (mapatoms
1959     (lambda (sym)
1960       (when (and (commandp sym)
1961                  ;; Ignore aliases.
1962                  (not (symbolp (symbol-function sym)))
1963                  ;; Ignore everything bound.
1964                  (not (where-is-internal sym nil t))
1965                  (apply #'derived-mode-p (command-modes sym)))
1966         (push sym functions))))
1967    (with-temp-buffer
1968      (when functions
1969        (setq functions (sort functions #'string<))
1970        (insert "\n\nOther commands for this mode, not bound to any keys:\n\n")
1971        (dolist (function functions)
1972          (insert (format "`%s'\n" function))))
1973      (buffer-string))))
1974
1975
1976;; Widgets.
1977
1978(defvar describe-widget-functions
1979  '(button-describe widget-describe)
1980  "A list of functions for `describe-widget' to call.
1981Each function should take one argument, a buffer position, and return
1982non-nil if it described a widget at that position.")
1983
1984;;;###autoload
1985(defun describe-widget (&optional pos)
1986  "Display a buffer with information about a widget.
1987You can use this command to describe buttons (e.g., the links in a *Help*
1988buffer), editable fields of the customization buffers, etc.
1989
1990Interactively, click on a widget to describe it, or hit RET to describe the
1991widget at point.
1992
1993When called from Lisp, POS may be a buffer position or a mouse position list.
1994
1995Calls each function of the list `describe-widget-functions' in turn, until
1996one of them returns non-nil."
1997  (interactive
1998   (list
1999    (let ((key
2000           (read-key
2001            "Click on a widget, or hit RET to describe the widget at point")))
2002      (cond ((eq key ?\C-m) (point))
2003            ((and (mouse-event-p key)
2004                  (eq (event-basic-type key) 'mouse-1)
2005                  (equal (event-modifiers key) '(click)))
2006             (event-end key))
2007            ((eq key ?\C-g) (signal 'quit nil))
2008            (t (user-error "You didn't specify a widget"))))))
2009  (let (buf
2010        (help-buffer-under-preparation t))
2011    ;; Allow describing a widget in a different window.
2012    (when (posnp pos)
2013      (setq buf (window-buffer (posn-window pos))
2014            pos (posn-point pos)))
2015    (with-current-buffer (or buf (current-buffer))
2016      (unless (cl-some (lambda (fun) (when (fboundp fun) (funcall fun pos)))
2017                       describe-widget-functions)
2018        (message "No widget found at that position")))))
2019
2020
2021;;; Replacements for old lib-src/ programs.  Don't seem especially useful.
2022
2023;; Replaces lib-src/digest-doc.c.
2024;;;###autoload
2025(defun doc-file-to-man (file)
2026  "Produce an nroff buffer containing the doc-strings from the DOC file."
2027  (interactive (list (read-file-name "Name of DOC file: " doc-directory
2028                                     internal-doc-file-name t)))
2029  (or (file-readable-p file)
2030      (error "Cannot read file `%s'" file))
2031  (pop-to-buffer (generate-new-buffer "*man-doc*"))
2032  (setq buffer-undo-list t)
2033  (insert ".TH \"Command Summary for GNU Emacs\"\n"
2034          ".AU Richard M. Stallman\n")
2035  (insert-file-contents file)
2036  (let (notfirst)
2037    (while (search-forward "\^_" nil 'move)
2038      (if (= (following-char) ?S)
2039          (delete-region (1- (point)) (line-end-position))
2040        (delete-char -1)
2041        (if notfirst
2042            (insert "\n.DE\n")
2043          (setq notfirst t))
2044        (insert "\n.SH ")
2045        (insert (if (= (following-char) ?F) "Function " "Variable "))
2046        (delete-char 1)
2047        (forward-line 1)
2048        (insert ".DS L\n"))))
2049  (insert "\n.DE\n")
2050  (setq buffer-undo-list nil)
2051  (nroff-mode))
2052
2053;; Replaces lib-src/sorted-doc.c.
2054;;;###autoload
2055(defun doc-file-to-info (file)
2056  "Produce a texinfo buffer with sorted doc-strings from the DOC file."
2057  (interactive (list (read-file-name "Name of DOC file: " doc-directory
2058                                     internal-doc-file-name t)))
2059  (or (file-readable-p file)
2060      (error "Cannot read file `%s'" file))
2061  (let ((i 0) type name doc alist)
2062    (with-temp-buffer
2063      (insert-file-contents file)
2064      ;; The characters "@{}" need special treatment.
2065      (while (re-search-forward "[@{}]" nil t)
2066        (backward-char)
2067        (insert "@")
2068        (forward-char 1))
2069      (goto-char (point-min))
2070      (while (search-forward "\^_" nil t)
2071        (when (/= (following-char) ?S)
2072          (setq type (char-after)
2073                name (buffer-substring (1+ (point)) (line-end-position))
2074                doc (buffer-substring (line-beginning-position 2)
2075                                      (if (search-forward  "\^_" nil 'move)
2076                                          (1- (point))
2077                                        (point)))
2078                alist (cons (list name type doc) alist))
2079          (backward-char 1))))
2080    (pop-to-buffer (generate-new-buffer "*info-doc*"))
2081    (setq buffer-undo-list t)
2082    ;; Write the output header.
2083    (insert "\\input texinfo  @c -*-texinfo-*-\n"
2084            "@setfilename emacsdoc.info\n"
2085            "@settitle Command Summary for GNU Emacs\n"
2086            "@finalout\n"
2087            "\n@node Top\n"
2088            "@unnumbered Command Summary for GNU Emacs\n\n"
2089            "@table @asis\n\n"
2090            "@iftex\n"
2091            "@global@let@ITEM@item\n"
2092            "@def@item{@filbreak@vskip5pt@ITEM}\n"
2093            "@font@tensy cmsy10 scaled @magstephalf\n"
2094            "@font@teni cmmi10 scaled @magstephalf\n"
2095            "@def\\{{@tensy@char110}}\n" ; this backslash goes with cmr10
2096            "@def|{{@tensy@char106}}\n"
2097            "@def@{{{@tensy@char102}}\n"
2098            "@def@}{{@tensy@char103}}\n"
2099            "@def<{{@teni@char62}}\n"
2100            "@def>{{@teni@char60}}\n"
2101            "@chardef@@64\n"
2102            "@catcode43=12\n"
2103            "@tableindent-0.2in\n"
2104            "@end iftex\n")
2105    ;; Sort the array by name; within each name, by type (functions first).
2106    (setq alist (sort alist (lambda (e1 e2)
2107                              (if (string-equal (car e1) (car e2))
2108                                  (<= (cadr e1) (cadr e2))
2109                                (string-lessp (car e1) (car e2))))))
2110    ;; Print each function.
2111    (dolist (e alist)
2112      (insert "\n@item "
2113              (if (char-equal (cadr e) ?\F) "Function" "Variable")
2114              " @code{" (car e) "}\n@display\n"
2115              (nth 2 e)
2116              "\n@end display\n")
2117      ;; Try to avoid a save size overflow in the TeX output routine.
2118      (if (zerop (setq i (% (1+ i) 100)))
2119          (insert "\n@end table\n@table @asis\n")))
2120    (insert "@end table\n"
2121            "@bye\n")
2122    (setq buffer-undo-list nil)
2123    (texinfo-mode)))
2124
2125(provide 'help-fns)
2126
2127;;; help-fns.el ends here
2128