;;; help-fns.el --- Complex help functions -*- lexical-binding: t -*-
-;; Copyright (C) 1985-1986, 1993-1994, 1998-2012
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1985-1986, 1993-1994, 1998-2013 Free Software
+;; Foundation, Inc.
;; Maintainer: FSF
;; Keywords: help, internal
arglist)))
(unless (zerop rest) (push '&rest arglist) (push 'rest arglist))
(nreverse arglist))))
- ((and (eq (car-safe def) 'autoload) (not (eq (nth 4 def) 'keymap)))
+ ((and (autoloadp def) (not (eq (nth 4 def) 'keymap)))
"[Arg list not available until function definition is loaded.]")
(t t)))
found via `load-path'. The return value can also be `C-source', which
means that OBJECT is a function or variable defined in C. If no
suitable file is found, return nil."
- (let* ((autoloaded (eq (car-safe type) 'autoload))
+ (let* ((autoloaded (autoloadp type))
(file-name (or (and autoloaded (nth 1 type))
(symbol-file
object (if (memq type (list 'defvar 'defface))
(declare-function ad-get-advice-info "advice" (function))
+(defun help-fns--key-bindings (function)
+ (when (commandp function)
+ (let ((pt2 (with-current-buffer standard-output (point)))
+ (remapped (command-remapping function)))
+ (unless (memq remapped '(ignore undefined))
+ (let ((keys (where-is-internal
+ (or remapped function) overriding-local-map nil nil))
+ non-modified-keys)
+ (if (and (eq function 'self-insert-command)
+ (vectorp (car-safe keys))
+ (consp (aref (car keys) 0)))
+ (princ "It is bound to many ordinary text characters.\n")
+ ;; Which non-control non-meta keys run this command?
+ (dolist (key keys)
+ (if (member (event-modifiers (aref key 0)) '(nil (shift)))
+ (push key non-modified-keys)))
+ (when remapped
+ (princ "Its keys are remapped to ")
+ (princ (if (symbolp remapped)
+ (concat "`" (symbol-name remapped) "'")
+ "an anonymous command"))
+ (princ ".\n"))
+
+ (when keys
+ (princ (if remapped
+ "Without this remapping, it would be bound to "
+ "It is bound to "))
+ ;; If lots of ordinary text characters run this command,
+ ;; don't mention them one by one.
+ (if (< (length non-modified-keys) 10)
+ (princ (mapconcat 'key-description keys ", "))
+ (dolist (key non-modified-keys)
+ (setq keys (delq key keys)))
+ (if keys
+ (progn
+ (princ (mapconcat 'key-description keys ", "))
+ (princ ", and many ordinary text characters"))
+ (princ "many ordinary text characters"))))
+ (when (or remapped keys non-modified-keys)
+ (princ ".")
+ (terpri)))))
+
+ (with-current-buffer standard-output
+ (fill-region-as-paragraph pt2 (point))
+ (unless (looking-back "\n\n")
+ (terpri))))))
+
(defun help-fns--compiler-macro (function)
- (let ((handler nil))
- ;; FIXME: Copied from macroexp.el.
- (while (and (symbolp function)
- (not (setq handler (get function 'compiler-macro)))
- (fboundp function))
- ;; Follow the sequence of aliases.
- (setq function (symbol-function function)))
+ (let ((handler (function-get function 'compiler-macro)))
(when handler
- (princ "This function has a compiler macro")
+ (insert "\nThis function has a compiler macro")
(let ((lib (get function 'compiler-macro-file)))
;; FIXME: rather than look at the compiler-macro-file property,
;; just look at `handler' itself.
(when (stringp lib)
- (princ (format " in `%s'" lib))
- (with-current-buffer standard-output
- (save-excursion
- (re-search-backward "`\\([^`']+\\)'" nil t)
- (help-xref-button 1 'help-function-cmacro function lib)))))
- (princ ".\n\n"))))
+ (insert (format " in `%s'" lib))
+ (save-excursion
+ (re-search-backward "`\\([^`']+\\)'" nil t)
+ (help-xref-button 1 'help-function-cmacro function lib))))
+ (insert ".\n"))))
+
+(defun help-fns--signature (function doc real-def real-function)
+ (unless (keymapp function) ; If definition is a keymap, skip arglist note.
+ (let* ((advertised (gethash real-def advertised-signature-table t))
+ (arglist (if (listp advertised)
+ advertised (help-function-arglist real-def)))
+ (usage (help-split-fundoc doc function)))
+ (if usage (setq doc (cdr usage)))
+ (let* ((use (cond
+ ((and usage (not (listp advertised))) (car usage))
+ ((listp arglist)
+ (format "%S" (help-make-usage function arglist)))
+ ((stringp arglist) arglist)
+ ;; Maybe the arglist is in the docstring of a symbol
+ ;; this one is aliased to.
+ ((let ((fun real-function))
+ (while (and (symbolp fun)
+ (setq fun (symbol-function fun))
+ (not (setq usage (help-split-fundoc
+ (documentation fun)
+ function)))))
+ usage)
+ (car usage))
+ ((or (stringp real-def)
+ (vectorp real-def))
+ (format "\nMacro: %s" (format-kbd-macro real-def)))
+ (t "[Missing arglist. Please make a bug report.]")))
+ (high (help-highlight-arguments use doc)))
+ (let ((fill-begin (point)))
+ (insert (car high) "\n")
+ (fill-region fill-begin (point)))
+ (cdr high)))))
+
+(defun help-fns--parent-mode (function)
+ ;; If this is a derived mode, link to the parent.
+ (let ((parent-mode (and (symbolp function)
+ (get function
+ 'derived-mode-parent))))
+ (when parent-mode
+ (insert "\nParent mode: `")
+ (let ((beg (point)))
+ (insert (format "%s" parent-mode))
+ (make-text-button beg (point)
+ 'type 'help-function
+ 'help-args (list parent-mode)))
+ (insert "'.\n"))))
+
+(defun help-fns--obsolete (function)
+ ;; Ignore lambda constructs, keyboard macros, etc.
+ (let* ((obsolete (and (symbolp function)
+ (get function 'byte-obsolete-info)))
+ (use (car obsolete)))
+ (when obsolete
+ (insert "\nThis "
+ (if (eq (car-safe (symbol-function function)) 'macro)
+ "macro"
+ "function")
+ " is obsolete")
+ (when (nth 2 obsolete)
+ (insert (format " since %s" (nth 2 obsolete))))
+ (insert (cond ((stringp use) (concat ";\n" use))
+ (use (format ";\nuse `%s' instead." use))
+ (t "."))
+ "\n"))))
;; We could use `symbol-file' but this is a wee bit more efficient.
(defun help-fns--autoloaded-p (function file)
(concat beg "Lisp macro"))
((eq (car-safe def) 'closure)
(concat beg "Lisp closure"))
- ((eq (car-safe def) 'autoload)
+ ((autoloadp def)
(format "%s autoloaded %s"
(if (commandp def) "an interactive" "an")
(if (eq (nth 4 def) 'keymap) "keymap"
(fill-region-as-paragraph (save-excursion (goto-char pt1) (forward-line 0) (point))
(point)))
(terpri)(terpri)
- (when (commandp function)
- (let ((pt2 (with-current-buffer (help-buffer) (point)))
- (remapped (command-remapping function)))
- (unless (memq remapped '(ignore undefined))
- (let ((keys (where-is-internal
- (or remapped function) overriding-local-map nil nil))
- non-modified-keys)
- (if (and (eq function 'self-insert-command)
- (vectorp (car-safe keys))
- (consp (aref (car keys) 0)))
- (princ "It is bound to many ordinary text characters.\n")
- ;; Which non-control non-meta keys run this command?
- (dolist (key keys)
- (if (member (event-modifiers (aref key 0)) '(nil (shift)))
- (push key non-modified-keys)))
- (when remapped
- (princ "Its keys are remapped to `")
- (princ (symbol-name remapped))
- (princ "'.\n"))
-
- (when keys
- (princ (if remapped
- "Without this remapping, it would be bound to "
- "It is bound to "))
- ;; If lots of ordinary text characters run this command,
- ;; don't mention them one by one.
- (if (< (length non-modified-keys) 10)
- (princ (mapconcat 'key-description keys ", "))
- (dolist (key non-modified-keys)
- (setq keys (delq key keys)))
- (if keys
- (progn
- (princ (mapconcat 'key-description keys ", "))
- (princ ", and many ordinary text characters"))
- (princ "many ordinary text characters"))))
- (when (or remapped keys non-modified-keys)
- (princ ".")
- (terpri)))))
-
- (with-current-buffer (help-buffer)
- (fill-region-as-paragraph pt2 (point))
- (unless (looking-back "\n\n")
- (terpri)))))
- (help-fns--compiler-macro function)
- (let* ((advertised (gethash real-def advertised-signature-table t))
- (arglist (if (listp advertised)
- advertised (help-function-arglist real-def)))
- (doc-raw (condition-case err
- (documentation function t)
- (error (format "No Doc! %S" err))))
+
+ (let* ((doc-raw (documentation function t))
;; If the function is autoloaded, and its docstring has
;; key substitution constructs, load the library.
(doc (progn
- (and (eq (car-safe real-def) 'autoload)
+ (and (autoloadp real-def) doc-raw
help-enable-auto-load
(string-match "\\([^\\]=\\|[^=]\\|\\`\\)\\\\[[{<]"
doc-raw)
(load (cadr real-def) t))
- (substitute-command-keys doc-raw)))
- (usage (help-split-fundoc doc function)))
- (with-current-buffer standard-output
- ;; If definition is a keymap, skip arglist note.
- (unless (keymapp function)
- (if usage (setq doc (cdr usage)))
- (let* ((use (cond
- ((and usage (not (listp advertised))) (car usage))
- ((listp arglist)
- (format "%S" (help-make-usage function arglist)))
- ((stringp arglist) arglist)
- ;; Maybe the arglist is in the docstring of a symbol
- ;; this one is aliased to.
- ((let ((fun real-function))
- (while (and (symbolp fun)
- (setq fun (symbol-function fun))
- (not (setq usage (help-split-fundoc
- (documentation fun)
- function)))))
- usage)
- (car usage))
- ((or (stringp real-def)
- (vectorp real-def))
- (format "\nMacro: %s" (format-kbd-macro real-def)))
- (t "[Missing arglist. Please make a bug report.]")))
- (high (help-highlight-arguments use doc)))
- (let ((fill-begin (point)))
- (insert (car high) "\n")
- (fill-region fill-begin (point)))
- (setq doc (cdr high))))
-
- ;; If this is a derived mode, link to the parent.
- (let ((parent-mode (and (symbolp real-function)
- (get real-function
- 'derived-mode-parent))))
- (when parent-mode
- (with-current-buffer standard-output
- (insert "\nParent mode: `")
- (let ((beg (point)))
- (insert (format "%s" parent-mode))
- (make-text-button beg (point)
- 'type 'help-function
- 'help-args (list parent-mode))))
- (princ "'.\n")))
-
- (let* ((obsolete (and
- ;; function might be a lambda construct.
- (symbolp function)
- (get function 'byte-obsolete-info)))
- (use (car obsolete)))
- (when obsolete
- (princ "\nThis function is obsolete")
- (when (nth 2 obsolete)
- (insert (format " since %s" (nth 2 obsolete))))
- (insert (cond ((stringp use) (concat ";\n" use))
- (use (format ";\nuse `%s' instead." use))
- (t "."))
- "\n"))
- (insert "\n"
- (or doc "Not documented."))))))))
+ (substitute-command-keys doc-raw))))
+
+ (help-fns--key-bindings function)
+ (with-current-buffer standard-output
+ (setq doc (help-fns--signature function doc real-def real-function))
+
+ (help-fns--compiler-macro function)
+ (help-fns--parent-mode function)
+ (help-fns--obsolete function)
+
+ (insert "\n"
+ (or doc "Not documented.")))))))
\f
;; Variables
(message "You did not specify a variable")
(save-excursion
(let ((valvoid (not (with-current-buffer buffer (boundp variable))))
+ (permanent-local (get variable 'permanent-local))
val val-start-pos locus)
;; Extract the value before setting up the output buffer,
;; in case `buffer' *is* the output buffer.
(princ "value is ")
(let ((from (point))
(line-beg (line-beginning-position))
- ;;
(print-rep
(let ((print-quoted t))
(prin1-to-string val))))
(when locus
(cond
((bufferp locus)
- (princ (format "%socal in buffer %s; "
- (if (get variable 'permanent-local)
- "Permanently l" "L")
- (buffer-name))))
+ (princ (format "Local in buffer %s; "
+ (buffer-name buffer))))
((framep locus)
(princ (format "It is a frame-local variable; ")))
((terminal-live-p locus)
(princ (format "It is local to %S" locus))))
(if (not (default-boundp variable))
(princ "globally void")
- (let ((val (default-value variable)))
+ (let ((global-val (default-value variable)))
(with-current-buffer standard-output
(princ "global value is ")
- (terpri)
- ;; Fixme: pp can take an age if you happen to
- ;; ask for a very large expression. We should
- ;; probably print it raw once and check it's a
- ;; sensible size before prettyprinting. -- fx
- (let ((from (point)))
- (pp val)
- ;; See previous comment for this function.
- ;; (help-xref-on-pp from (point))
- (if (< (point) (+ from 20))
- (delete-region (1- from) from))))))
+ (if (eq val global-val)
+ (princ "the same.")
+ (terpri)
+ ;; Fixme: pp can take an age if you happen to
+ ;; ask for a very large expression. We should
+ ;; probably print it raw once and check it's a
+ ;; sensible size before prettyprinting. -- fx
+ (let ((from (point)))
+ (pp global-val)
+ ;; See previous comment for this function.
+ ;; (help-xref-on-pp from (point))
+ (if (< (point) (+ from 20))
+ (delete-region (1- from) from)))))))
(terpri))
;; If the value is large, move it to the end.
(obsolete (get variable 'byte-obsolete-variable))
(use (car obsolete))
(safe-var (get variable 'safe-local-variable))
- (doc (condition-case err
- (or (documentation-property
- variable 'variable-documentation)
- (documentation-property
- alias 'variable-documentation))
- (error (format "Doc not found: %S" err))))
+ (doc (or (documentation-property
+ variable 'variable-documentation)
+ (documentation-property
+ alias 'variable-documentation)))
(extra-line nil))
- ;; Add a note for variables that have been make-var-buffer-local.
- (when (and (local-variable-if-set-p variable)
- (or (not (local-variable-p variable))
- (with-temp-buffer
- (local-variable-if-set-p variable))))
+
+ ;; Mention if it's a local variable.
+ (cond
+ ((and (local-variable-if-set-p variable)
+ (or (not (local-variable-p variable))
+ (with-temp-buffer
+ (local-variable-if-set-p variable))))
(setq extra-line t)
(princ " Automatically becomes ")
- (if (get variable 'permanent-local)
+ (if permanent-local
(princ "permanently "))
(princ "buffer-local when set.\n"))
+ ((not permanent-local))
+ ((bufferp locus)
+ (princ " This variable's buffer-local value is permanent.\n"))
+ (t
+ (princ " This variable's value is permanent \
+if it is given a local binding.\n")))
- ;; Mention if it's an alias
+ ;; Mention if it's an alias.
(unless (eq alias variable)
(setq extra-line t)
(princ (format " This variable is an alias for `%s'.\n" alias)))
(not (file-remote-p (buffer-file-name)))
(dir-locals-find-file
(buffer-file-name))))
- (type "file"))
- (princ " This variable is a directory local variable")
- (when file
+ (dir-file t))
+ (princ " This variable's value is directory-local")
+ (if (null file)
+ (princ ".\n")
+ (princ ", set ")
(if (consp file) ; result from cache
;; If the cache element has an mtime, we
;; assume it came from a file.
(setq file (expand-file-name
dir-locals-file (car file)))
;; Otherwise, assume it was set directly.
- (setq type "directory")))
- (princ (format "\n from the %s \"%s\"" type file)))
- (princ ".\n"))
- (princ " This variable is a file local variable.\n")))
+ (setq dir-file nil)))
+ (princ (if dir-file
+ "by the file\n `"
+ "for the directory\n `"))
+ (with-current-buffer standard-output
+ (insert-text-button
+ file 'type 'help-dir-local-var-def
+ 'help-args (list variable file)))
+ (princ "'.\n")))
+ (princ " This variable's value is file-local.\n")))
(when (memq variable ignored-local-variables)
(setq extra-line t)
- (princ " This variable is ignored when used as a file local \
+ (princ " This variable is ignored as a file-local \
variable.\n"))
;; Can be both risky and safe, eg auto-fill-function.
(when (risky-local-variable-p variable)
(setq extra-line t)
- (princ " This variable is potentially risky when used as a \
-file local variable.\n")
+ (princ " This variable may be risky if used as a \
+file-local variable.\n")
(when (assq variable safe-local-variable-values)
(princ " However, you have added it to \
`safe-local-variable-values'.\n")))
(princ " This variable is safe as a file local variable ")
(princ "if its value\n satisfies the predicate ")
(princ (if (byte-code-function-p safe-var)
- "which is byte-compiled expression.\n"
+ "which is a byte-compiled expression.\n"
(format "`%s'.\n" safe-var))))
(if extra-line (terpri))
HCoop / bpt / emacs.git / blobdiff