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