;;; help-fns.el --- Complex help functions
-;; Copyright (C) 1985, 1986, 1993, 1994, 1998, 1999, 2000, 2001,
-;; 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1986, 1993, 1994, 1998, 1999, 2000, 2001, 2002,
+;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: help, internal
+;; Package: emacs
;; This file is part of GNU Emacs.
;;; Code:
-(require 'help-mode)
-
;; Functions
;;;###autoload
fn (intern val)))))
(if (null function)
(message "You didn't specify a function")
- (help-setup-xref (list #'describe-function function) (interactive-p))
+ (help-setup-xref (list #'describe-function function)
+ (called-interactively-p 'interactive))
(save-excursion
(with-help-window (help-buffer)
(prin1 function)
(concat "src/" file)
file)))))
-(defface help-argument-name '((((supports :slant italic)) :inherit italic))
- "Face to highlight argument names in *Help* buffers."
- :group 'help)
+(defcustom help-downcase-arguments nil
+ "If non-nil, argument names in *Help* buffers are downcased."
+ :type 'boolean
+ :group 'help
+ :version "23.2")
-(defun help-default-arg-highlight (arg)
- "Default function to highlight arguments in *Help* buffers.
-It returns ARG in face `help-argument-name'; ARG is also
-downcased if it displays differently than the default
-face (according to `face-differs-from-default-p')."
- (propertize (if (face-differs-from-default-p 'help-argument-name)
- (downcase arg)
- arg)
- 'face 'help-argument-name))
+(defun help-highlight-arg (arg)
+ "Highlight ARG as an argument name for a *Help* buffer.
+Return ARG in face `help-argument-name'; ARG is also downcased
+if the variable `help-downcase-arguments' is non-nil."
+ (propertize (if help-downcase-arguments (downcase arg) arg)
+ 'face 'help-argument-name))
(defun help-do-arg-highlight (doc args)
(with-syntax-table (make-syntax-table emacs-lisp-mode-syntax-table)
"\\(?:-[a-z0-9-]+\\)?" ; for ARG-xxx, ARG-n
"\\(?:-[{([<`\"].*?\\)?"; for ARG-{x}, (x), <x>, [x], `x'
"\\>") ; end of word
- (help-default-arg-highlight arg)
+ (help-highlight-arg arg)
doc t t 1)))))
(defun help-highlight-arguments (usage doc &rest args)
"Guess the file that defined the Lisp object OBJECT, of type TYPE.
OBJECT should be a symbol associated with a function, variable, or face;
alternatively, it can be a function definition.
-If TYPE is `variable', search for a variable definition.
-If TYPE is `face', search for a face definition.
+If TYPE is `defvar', search for a variable definition.
+If TYPE is `defface', search for a face definition.
If TYPE is the value returned by `symbol-function' for a function symbol,
search for a function definition.
(condition-case nil
(find-function-search-for-symbol object nil file-name)
(error nil))))
- (when location
+ (when (cdr location)
(with-current-buffer (car location)
(goto-char (cdr location))
(when (re-search-backward
"^;;; Generated autoloads from \\(.*\\)" nil t)
(setq file-name
(locate-file
- (match-string-no-properties 1)
- load-path nil 'readable))))))))
+ (file-name-sans-extension
+ (match-string-no-properties 1))
+ load-path '(".el" ".elc") 'readable))))))))
(cond
((and (not file-name) (subrp type))
((not (stringp file-name))
;; If we don't have a file-name string by now, we lost.
nil)
+ ;; Now, `file-name' should have become an absolute file name.
+ ;; For files loaded from ~/.emacs.elc, try ~/.emacs.
+ ((let (fn)
+ (and (string-equal file-name
+ (expand-file-name ".emacs.elc" "~"))
+ (file-readable-p (setq fn (expand-file-name ".emacs" "~")))
+ fn)))
+ ;; When the Elisp source file can be found in the install
+ ;; directory, return the name of that file.
((let ((lib-name
(if (string-match "[.]elc\\'" file-name)
(substring-no-properties file-name 0 -1)
file-name)))
- ;; When the Elisp source file can be found in the install
- ;; directory return the name of that file - `file-name' should
- ;; have become an absolute file name ny now.
(or (and (file-readable-p lib-name) lib-name)
;; The library might be compressed.
(and (file-readable-p (concat lib-name ".gz")) lib-name))))
(princ " in `")
;; We used to add .el to the file name,
;; but that's completely wrong when the user used load-file.
- (princ (if (eq file-name 'C-source) "C source code" file-name))
+ (princ (if (eq file-name 'C-source)
+ "C source code"
+ (file-name-nondirectory file-name)))
(princ "'")
;; Make a hyperlink to the library.
(with-current-buffer standard-output
(save-excursion
(re-search-backward "`\\([^`']+\\)'" nil t)
- (help-xref-button 1 'help-function-def real-function file-name))))
+ (help-xref-button 1 'help-function-def function file-name))))
(princ ".")
(with-current-buffer (help-buffer)
(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))))
- (if (and (eq function 'self-insert-command)
- (eq (key-binding "a") 'self-insert-command)
- (eq (key-binding "b") 'self-insert-command)
- (eq (key-binding "c") 'self-insert-command))
- (princ "It is bound to many ordinary text characters.\n")
- (let* ((remapped (command-remapping function))
- (keys (where-is-internal
- (or remapped function) overriding-local-map nil nil))
- non-modified-keys)
- ;; 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 "It is remapped to `")
- (princ (symbol-name remapped))
- (princ "'"))
-
- (when keys
- (princ (if remapped ", which is 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))))
+ (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 "It is remapped to `")
+ (princ (symbol-name remapped))
+ (princ "'"))
+
+ (when keys
+ (princ (if remapped ", which is 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)))))
- (let* ((arglist (help-function-arglist def))
+ ;; Note that list* etc do not get this property until
+ ;; cl-hack-byte-compiler runs, after bytecomp is loaded.
+ (when (and (symbolp function)
+ (eq (get function 'byte-compile)
+ 'cl-byte-compile-compiler-macro))
+ (princ "This function has a compiler macro")
+ (let ((lib (get function 'compiler-macro-file)))
+ (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"))
+ (let* ((advertised (gethash def advertised-signature-table t))
+ (arglist (if (listp advertised)
+ advertised (help-function-arglist def)))
(doc (documentation function))
(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
- (usage (setq doc (cdr usage)) (car usage))
+ ((and usage (not (listp advertised))) (car usage))
((listp arglist)
(format "%S" (help-make-usage function arglist)))
((stringp arglist) arglist)
(setq val (symbol-value variable)
locus (variable-binding-locus variable)))))
(help-setup-xref (list #'describe-variable variable buffer)
- (interactive-p))
+ (called-interactively-p 'interactive))
(with-help-window (help-buffer)
(with-current-buffer buffer
(prin1 variable)
(if file-name
(progn
(princ " is a variable defined in `")
- (princ (if (eq file-name 'C-source) "C source code" file-name))
+ (princ (if (eq file-name 'C-source)
+ "C source code"
+ (file-name-nondirectory file-name)))
(princ "'.\n")
(with-current-buffer standard-output
(save-excursion
(if valvoid
(princ " is void as a variable.")
(princ "'s "))))
- (if valvoid
- nil
+ (unless valvoid
(with-current-buffer standard-output
(setq val-start-pos (point))
(princ "value is ")
- (terpri)
(let ((from (point)))
+ (terpri)
(pp val)
- ;; Hyperlinks in variable's value are quite frequently
- ;; inappropriate e.g C-h v <RET> features <RET>
- ;; (help-xref-on-pp from (point))
- (if (< (point) (+ from 20))
- (delete-region (1- from) from)))))
+ (if (< (point) (+ 68 (line-beginning-position 0)))
+ (delete-region from (1+ from))
+ (delete-region (1- from) from))
+ (let* ((sv (get variable 'standard-value))
+ (origval (and (consp sv)
+ (condition-case nil
+ (eval (car sv))
+ (error :help-eval-error)))))
+ (when (and (consp sv)
+ (not (equal origval val))
+ (not (equal origval :help-eval-error)))
+ (princ "\nOriginal value was \n")
+ (setq from (point))
+ (pp origval)
+ (if (< (point) (+ from 20))
+ (delete-region (1- from) from)))))))
(terpri)
-
(when locus
(if (bufferp locus)
(princ (format "%socal in buffer %s; "
(use (format ";\n use `%s' instead." (car obsolete)))
(t ".")))
(terpri))
+
+ (when (member (cons variable val) file-local-variables-alist)
+ (setq extra-line t)
+ (if (member (cons variable val) dir-local-variables-alist)
+ (let ((file (and (buffer-file-name)
+ (not (file-remote-p (buffer-file-name)))
+ (dir-locals-find-file (buffer-file-name)))))
+ (princ " This variable is a directory local variable")
+ (when file
+ (princ (concat "\n from the file \""
+ (if (consp file)
+ (car file)
+ file)
+ "\"")))
+ (princ ".\n"))
+ (princ " This variable is a file local variable.\n")))
+
+ (when (memq variable ignored-local-variables)
+ (setq extra-line t)
+ (princ " This variable is ignored when used 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")
+ (when (assq variable safe-local-variable-values)
+ (princ " However, you have added it to \
+`safe-local-variable-values'.\n")))
+
(when safe-var
(setq extra-line t)
(princ " This variable is safe as a file local variable ")
(terpri)
(princ output))))
- (save-excursion
- (set-buffer standard-output)
+ (with-current-buffer standard-output
;; Return the text we displayed.
(buffer-string))))))))
BUFFER defaults to the current buffer."
(interactive)
(setq buffer (or buffer (current-buffer)))
- (help-setup-xref (list #'describe-syntax buffer) (interactive-p))
+ (help-setup-xref (list #'describe-syntax buffer)
+ (called-interactively-p 'interactive))
(with-help-window (help-buffer)
(let ((table (with-current-buffer buffer (syntax-table))))
(with-current-buffer standard-output
BUFFER should be a buffer or a buffer name."
(interactive)
(setq buffer (or buffer (current-buffer)))
- (help-setup-xref (list #'describe-categories buffer) (interactive-p))
+ (help-setup-xref (list #'describe-categories buffer)
+ (called-interactively-p 'interactive))
(with-help-window (help-buffer)
- (let ((table (with-current-buffer buffer (category-table))))
+ (let* ((table (with-current-buffer buffer (category-table)))
+ (docs (char-table-extra-slot table 0)))
+ (if (or (not (vectorp docs)) (/= (length docs) 95))
+ (error "Invalid first extra slot in this category table\n"))
(with-current-buffer standard-output
+ (insert "Legend of category mnemonics (see the tail for the longer description)\n")
+ (let ((pos (point)) (items 0) lines n)
+ (dotimes (i 95)
+ (if (aref docs i) (setq items (1+ items))))
+ (setq lines (1+ (/ (1- items) 4)))
+ (setq n 0)
+ (dotimes (i 95)
+ (let ((elt (aref docs i)))
+ (when elt
+ (string-match ".*" elt)
+ (setq elt (match-string 0 elt))
+ (if (>= (length elt) 17)
+ (setq elt (concat (substring elt 0 14) "...")))
+ (if (< (point) (point-max))
+ (move-to-column (* 20 (/ n lines)) t))
+ (insert (+ i ?\s) ?: elt)
+ (if (< (point) (point-max))
+ (forward-line 1)
+ (insert "\n"))
+ (setq n (1+ n))
+ (if (= (% n lines) 0)
+ (goto-char pos))))))
+ (goto-char (point-max))
+ (insert "\n"
+ "character(s)\tcategory mnemonics\n"
+ "------------\t------------------")
(describe-vector table 'help-describe-category-set)
- (let ((docs (char-table-extra-slot table 0)))
- (if (or (not (vectorp docs)) (/= (length docs) 95))
- (insert "Invalid first extra slot in this char table\n")
- (insert "Meanings of mnemonic characters are:\n")
- (dotimes (i 95)
- (let ((elt (aref docs i)))
- (when elt
- (insert (+ i ?\s) ": " elt "\n"))))
- (while (setq table (char-table-parent table))
- (insert "\nThe parent category table is:")
- (describe-vector table 'help-describe-category-set))))))))
+ (insert "Legend of category mnemonics:\n")
+ (dotimes (i 95)
+ (let ((elt (aref docs i)))
+ (when elt
+ (if (string-match "\n" elt)
+ (setq elt (substring elt (match-end 0))))
+ (insert (+ i ?\s) ": " elt "\n"))))
+ (while (setq table (char-table-parent table))
+ (insert "\nThe parent category table is:")
+ (describe-vector table 'help-describe-category-set))))))
+
+\f
+;;; Replacements for old lib-src/ programs. Don't seem especially useful.
+
+;; Replaces lib-src/digest-doc.c.
+;;;###autoload
+(defun doc-file-to-man (file)
+ "Produce an nroff buffer containing the doc-strings from the DOC file."
+ (interactive (list (read-file-name "Name of DOC file: " doc-directory
+ internal-doc-file-name t)))
+ (or (file-readable-p file)
+ (error "Cannot read file `%s'" file))
+ (pop-to-buffer (generate-new-buffer "*man-doc*"))
+ (setq buffer-undo-list t)
+ (insert ".TH \"Command Summary for GNU Emacs\"\n"
+ ".AU Richard M. Stallman\n")
+ (insert-file-contents file)
+ (let (notfirst)
+ (while (search-forward "\1f" nil 'move)
+ (if (looking-at "S")
+ (delete-region (1- (point)) (line-end-position))
+ (delete-char -1)
+ (if notfirst
+ (insert "\n.DE\n")
+ (setq notfirst t))
+ (insert "\n.SH ")
+ (insert (if (looking-at "F") "Function " "Variable "))
+ (delete-char 1)
+ (forward-line 1)
+ (insert ".DS L\n"))))
+ (insert "\n.DE\n")
+ (setq buffer-undo-list nil)
+ (nroff-mode))
+
+;; Replaces lib-src/sorted-doc.c.
+;;;###autoload
+(defun doc-file-to-info (file)
+ "Produce a texinfo buffer with sorted doc-strings from the DOC file."
+ (interactive (list (read-file-name "Name of DOC file: " doc-directory
+ internal-doc-file-name t)))
+ (or (file-readable-p file)
+ (error "Cannot read file `%s'" file))
+ (let ((i 0) type name doc alist)
+ (with-temp-buffer
+ (insert-file-contents file)
+ ;; The characters "@{}" need special treatment.
+ (while (re-search-forward "[@{}]" nil t)
+ (backward-char)
+ (insert "@")
+ (forward-char 1))
+ (goto-char (point-min))
+ (while (search-forward "\1f" nil t)
+ (unless (looking-at "S")
+ (setq type (char-after)
+ name (buffer-substring (1+ (point)) (line-end-position))
+ doc (buffer-substring (line-beginning-position 2)
+ (if (search-forward "\1f" nil 'move)
+ (1- (point))
+ (point)))
+ alist (cons (list name type doc) alist))
+ (backward-char 1))))
+ (pop-to-buffer (generate-new-buffer "*info-doc*"))
+ (setq buffer-undo-list t)
+ ;; Write the output header.
+ (insert "\\input texinfo @c -*-texinfo-*-\n"
+ "@setfilename emacsdoc.info\n"
+ "@settitle Command Summary for GNU Emacs\n"
+ "@finalout\n"
+ "\n@node Top\n"
+ "@unnumbered Command Summary for GNU Emacs\n\n"
+ "@table @asis\n\n"
+ "@iftex\n"
+ "@global@let@ITEM@item\n"
+ "@def@item{@filbreak@vskip5pt@ITEM}\n"
+ "@font@tensy cmsy10 scaled @magstephalf\n"
+ "@font@teni cmmi10 scaled @magstephalf\n"
+ "@def\\{{@tensy@char110}}\n" ; this backslash goes with cmr10
+ "@def|{{@tensy@char106}}\n"
+ "@def@{{{@tensy@char102}}\n"
+ "@def@}{{@tensy@char103}}\n"
+ "@def<{{@teni@char62}}\n"
+ "@def>{{@teni@char60}}\n"
+ "@chardef@@64\n"
+ "@catcode43=12\n"
+ "@tableindent-0.2in\n"
+ "@end iftex\n")
+ ;; Sort the array by name; within each name, by type (functions first).
+ (setq alist (sort alist (lambda (e1 e2)
+ (if (string-equal (car e1) (car e2))
+ (<= (cadr e1) (cadr e2))
+ (string-lessp (car e1) (car e2))))))
+ ;; Print each function.
+ (dolist (e alist)
+ (insert "\n@item "
+ (if (char-equal (cadr e) ?\F) "Function" "Variable")
+ " @code{" (car e) "}\n@display\n"
+ (nth 2 e)
+ "\n@end display\n")
+ ;; Try to avoid a save size overflow in the TeX output routine.
+ (if (zerop (setq i (% (1+ i) 100)))
+ (insert "\n@end table\n@table @asis\n")))
+ (insert "@end table\n"
+ "@bye\n")
+ (setq buffer-undo-list nil)
+ (texinfo-mode)))
(provide 'help-fns)
-;; arch-tag: 9e10331c-ae81-4d13-965d-c4819aaab0b3
;;; help-fns.el ends here