From 44e75f509b39cef3d4ec00fc373f1706daa14eed Mon Sep 17 00:00:00 2001 From: Miles Bader Date: Tue, 9 Oct 2001 11:15:19 +0000 Subject: [PATCH] New file, contents mostly from `help.el'. (describe-variable): Use `condition-case' instead of `ignore-errors'. --- lisp/help-funs.el | 563 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 563 insertions(+) create mode 100644 lisp/help-funs.el diff --git a/lisp/help-funs.el b/lisp/help-funs.el new file mode 100644 index 00000000000..6f84bc512bf --- /dev/null +++ b/lisp/help-funs.el @@ -0,0 +1,563 @@ +;;; help-funs.el --- Complex help functions + +;; Copyright (C) 1985, 1986, 1993, 1994, 1998, 1999, 2000, 2001 +;; Free Software Foundation, Inc. + +;; Maintainer: FSF +;; Keywords: help, internal + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This file contains those help commands which are complicated, and +;; which may not be used in every session. For example +;; `describe-function' will probably be heavily used when doing elisp +;; programming, but not if just editing C files. Simpler help commands +;; are in help.el + +;;; Code: + +;;;###autoload +(defun help-with-tutorial (&optional arg) + "Select the Emacs learn-by-doing tutorial. +If there is a tutorial version written in the language +of the selected language environment, that version is used. +If there's no tutorial in that language, `TUTORIAL' is selected. +With arg, you are asked to choose which language." + (interactive "P") + (let ((lang (if arg + (read-language-name 'tutorial "Language: " "English") + (if (get-language-info current-language-environment 'tutorial) + current-language-environment + "English"))) + file filename) + (setq filename (get-language-info lang 'tutorial)) + (setq file (expand-file-name (concat "~/" filename))) + (delete-other-windows) + (if (get-file-buffer file) + (switch-to-buffer (get-file-buffer file)) + (switch-to-buffer (create-file-buffer file)) + (setq buffer-file-name file) + (setq default-directory (expand-file-name "~/")) + (setq buffer-auto-save-file-name nil) + (insert-file-contents (expand-file-name filename data-directory)) + (goto-char (point-min)) + (search-forward "\n<<") + (beginning-of-line) + (delete-region (point) (progn (end-of-line) (point))) + (let ((n (- (window-height (selected-window)) + (count-lines (point-min) (point)) + 6))) + (if (< n 12) + (newline n) + ;; Some people get confused by the large gap. + (newline (/ n 2)) + (insert "[Middle of page left blank for didactic purposes. " + "Text continues below]") + (newline (- n (/ n 2))))) + (goto-char (point-min)) + (set-buffer-modified-p nil)))) + +;;;###autoload +(defun locate-library (library &optional nosuffix path interactive-call) + "Show the precise file name of Emacs library LIBRARY. +This command searches the directories in `load-path' like `M-x load-library' +to find the file that `M-x load-library RET LIBRARY RET' would load. +Optional second arg NOSUFFIX non-nil means don't add suffixes `.elc' or `.el' +to the specified name LIBRARY. + +If the optional third arg PATH is specified, that list of directories +is used instead of `load-path'. + +When called from a program, the file name is normaly returned as a +string. When run interactively, the argument INTERACTIVE-CALL is t, +and the file name is displayed in the echo area." + (interactive (list (read-string "Locate library: ") + nil nil + t)) + (let (result) + (catch 'answer + (mapc + (lambda (dir) + (mapc + (lambda (suf) + (let ((try (expand-file-name (concat library suf) dir))) + (and (file-readable-p try) + (null (file-directory-p try)) + (progn + (setq result try) + (throw 'answer try))))) + (if nosuffix + '("") + '(".elc" ".el" "") + (let ((basic '(".elc" ".el" "")) + (compressed '(".Z" ".gz" ""))) + ;; If autocompression mode is on, + ;; consider all combinations of library suffixes + ;; and compression suffixes. + (if (rassq 'jka-compr-handler file-name-handler-alist) + (apply 'nconc + (mapcar (lambda (compelt) + (mapcar (lambda (baselt) + (concat baselt compelt)) + basic)) + compressed)) + basic))))) + (or path load-path))) + (and interactive-call + (if result + (message "Library is file %s" result) + (message "No library %s in search path" library))) + result)) + + +;; Functions + +;;;###autoload +(defun describe-function (function) + "Display the full documentation of FUNCTION (a symbol)." + (interactive + (let ((fn (function-called-at-point)) + (enable-recursive-minibuffers t) + val) + (setq val (completing-read (if fn + (format "Describe function (default %s): " fn) + "Describe function: ") + obarray 'fboundp t nil nil (symbol-name fn))) + (list (if (equal val "") + fn (intern val))))) + (if (null function) + (message "You didn't specify a function") + (with-output-to-temp-buffer "*Help*" + (prin1 function) + ;; Use " is " instead of a colon so that + ;; it is easier to get out the function name using forward-sexp. + (princ " is ") + (describe-function-1 function nil (interactive-p)) + (print-help-return-message) + (save-excursion + (set-buffer standard-output) + ;; Return the text we displayed. + (buffer-string))))) + +(defun describe-function-1 (function parens interactive-p) + (let* ((def (if (symbolp function) + (symbol-function function) + function)) + file-name string need-close + (beg (if (commandp def) "an interactive " "a "))) + (setq string + (cond ((or (stringp def) + (vectorp def)) + "a keyboard macro") + ((subrp def) + (if (eq 'unevalled (cdr (subr-arity def))) + (concat beg "special form") + (concat beg "built-in function"))) + ((byte-code-function-p def) + (concat beg "compiled Lisp function")) + ((symbolp def) + (while (symbolp (symbol-function def)) + (setq def (symbol-function def))) + (format "an alias for `%s'" def)) + ((eq (car-safe def) 'lambda) + (concat beg "Lisp function")) + ((eq (car-safe def) 'macro) + "a Lisp macro") + ((eq (car-safe def) 'mocklisp) + "a mocklisp function") + ((eq (car-safe def) 'autoload) + (setq file-name (nth 1 def)) + (format "%s autoloaded %s" + (if (commandp def) "an interactive" "an") + (if (eq (nth 4 def) 'keymap) "keymap" + (if (nth 4 def) "Lisp macro" "Lisp function")) + )) + ;; perhaps use keymapp here instead + ((eq (car-safe def) 'keymap) + (let ((is-full nil) + (elts (cdr-safe def))) + (while elts + (if (char-table-p (car-safe elts)) + (setq is-full t + elts nil)) + (setq elts (cdr-safe elts))) + (if is-full + "a full keymap" + "a sparse keymap"))) + (t ""))) + (when (and parens (not (equal string ""))) + (setq need-close t) + (princ "(")) + (princ string) + (with-current-buffer "*Help*" + (save-excursion + (save-match-data + (if (re-search-backward "alias for `\\([^`']+\\)'" nil t) + (help-xref-button 1 'help-function def))))) + (or file-name + (setq file-name (symbol-file function))) + (if file-name + (progn + (princ " in `") + ;; We used to add .el to the file name, + ;; but that's completely wrong when the user used load-file. + (princ file-name) + (princ "'") + ;; Make a hyperlink to the library. + (with-current-buffer "*Help*" + (save-excursion + (re-search-backward "`\\([^`']+\\)'" nil t) + (help-xref-button 1 'help-function-def function file-name))))) + (if need-close (princ ")")) + (princ ".") + (terpri) + (when (commandp function) + (let ((keys (where-is-internal + function overriding-local-map nil nil))) + (when keys + (princ "It is bound to ") + ;; FIXME: This list can be very long (f.ex. for self-insert-command). + (princ (mapconcat 'key-description keys ", ")) + (princ ".") + (terpri)))) + ;; Handle symbols aliased to other symbols. + (setq def (indirect-function def)) + ;; If definition is a macro, find the function inside it. + (if (eq (car-safe def) 'macro) + (setq def (cdr def))) + (let ((arglist (cond ((byte-code-function-p def) + (car (append def nil))) + ((eq (car-safe def) 'lambda) + (nth 1 def)) + ((and (eq (car-safe def) 'autoload) + (not (eq (nth 4 def) 'keymap))) + (concat "[Arg list not available until " + "function definition is loaded.]")) + (t t)))) + (cond ((listp arglist) + (princ (cons (if (symbolp function) function "anonymous") + (mapcar (lambda (arg) + (if (memq arg '(&optional &rest)) + arg + (intern (upcase (symbol-name arg))))) + arglist))) + (terpri)) + ((stringp arglist) + (princ arglist) + (terpri)))) + (let ((doc (documentation function))) + (if doc + (progn (terpri) + (princ doc) + (if (subrp def) + (with-current-buffer standard-output + (beginning-of-line) + ;; Builtins get the calling sequence at the end of + ;; the doc string. Move it to the same place as + ;; for other functions. + + ;; In cases where `function' has been fset to a + ;; subr we can't search for function's name in + ;; the doc string. Kluge round that using the + ;; printed representation. The arg list then + ;; shows the wrong function name, but that + ;; might be a useful hint. + (let* ((rep (prin1-to-string def)) + (name (progn + (string-match " \\([^ ]+\\)>$" rep) + (match-string 1 rep)))) + (if (looking-at (format "(%s[ )]" (regexp-quote name))) + (let ((start (point-marker))) + (goto-char (point-min)) + (forward-paragraph) + (insert-buffer-substring (current-buffer) start) + (insert ?\n) + (delete-region (1- start) (point-max))) + (goto-char (point-min)) + (forward-paragraph) + (insert + "[Missing arglist. Please make a bug report.]\n"))) + (goto-char (point-max)))) + (help-setup-xref (list #'describe-function function) + interactive-p)) + (princ "not documented"))))) + + +;; Variables + +;;;###autoload +(defun variable-at-point () + "Return the bound variable symbol found around point. +Return 0 if there is no such symbol." + (condition-case () + (with-syntax-table emacs-lisp-mode-syntax-table + (save-excursion + (or (not (zerop (skip-syntax-backward "_w"))) + (eq (char-syntax (following-char)) ?w) + (eq (char-syntax (following-char)) ?_) + (forward-sexp -1)) + (skip-chars-forward "'") + (let ((obj (read (current-buffer)))) + (or (and (symbolp obj) (boundp obj) obj) + 0)))) + (error 0))) + +;;;###autoload +(defun describe-variable (variable &optional buffer) + "Display the full documentation of VARIABLE (a symbol). +Returns the documentation as a string, also. +If VARIABLE has a buffer-local value in BUFFER (default to the current buffer), +it is displayed along with the global value." + (interactive + (let ((v (variable-at-point)) + (enable-recursive-minibuffers t) + val) + (setq val (completing-read (if (symbolp v) + (format + "Describe variable (default %s): " v) + "Describe variable: ") + obarray 'boundp t nil nil + (if (symbolp v) (symbol-name v)))) + (list (if (equal val "") + v (intern val))))) + (unless (bufferp buffer) (setq buffer (current-buffer))) + (if (not (symbolp variable)) + (message "You did not specify a variable") + (let (valvoid) + (with-current-buffer buffer + (with-output-to-temp-buffer "*Help*" + (prin1 variable) + (if (not (boundp variable)) + (progn + (princ " is void") + (setq valvoid t)) + (let ((val (symbol-value variable))) + (with-current-buffer standard-output + (princ "'s value is ") + (terpri) + (let ((from (point))) + (pp val) + (help-xref-on-pp from (point)) + (if (< (point) (+ from 20)) + (save-excursion + (goto-char from) + (delete-char -1))))))) + (terpri) + (when (local-variable-p variable) + (princ (format "Local in buffer %s; " (buffer-name))) + (if (not (default-boundp variable)) + (princ "globally void") + (let ((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) + (help-xref-on-pp from (point)) + (if (< (point) (+ from 20)) + (save-excursion + (goto-char from) + (delete-char -1))))))) + (terpri)) + (terpri) + (with-current-buffer standard-output + (when (> (count-lines (point-min) (point-max)) 10) + ;; Note that setting the syntax table like below + ;; makes forward-sexp move over a `'s' at the end + ;; of a symbol. + (set-syntax-table emacs-lisp-mode-syntax-table) + (goto-char (point-min)) + (if valvoid + (forward-line 1) + (forward-sexp 1) + (delete-region (point) (progn (end-of-line) (point))) + (insert " value is shown below.\n\n") + (save-excursion + (insert "\n\nValue:")))) + ;; 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)))) + (save-excursion + (forward-line -1) + (insert "Automatically becomes buffer-local when set in any fashion.\n")))) + (princ "Documentation:") + (terpri) + (let ((doc (documentation-property variable 'variable-documentation))) + (princ (or doc "not documented as a variable."))) + (help-setup-xref (list #'describe-variable variable (current-buffer)) + (interactive-p)) + + ;; Make a link to customize if this variable can be customized. + ;; Note, it is not reliable to test only for a custom-type property + ;; because those are only present after the var's definition + ;; has been loaded. + (if (or (get variable 'custom-type) ; after defcustom + (get variable 'custom-loads) ; from loaddefs.el + (get variable 'standard-value)) ; from cus-start.el + (let ((customize-label "customize")) + (terpri) + (terpri) + (princ (concat "You can " customize-label " this variable.")) + (with-current-buffer standard-output + (save-excursion + (re-search-backward + (concat "\\(" customize-label "\\)") nil t) + (help-xref-button 1 'help-customize-variable variable))))) + ;; Make a hyperlink to the library if appropriate. (Don't + ;; change the format of the buffer's initial line in case + ;; anything expects the current format.) + (let ((file-name (symbol-file variable))) + (when (equal file-name "loaddefs.el") + ;; Find the real def site of the preloaded variable. + (let ((location + (condition-case nil + (find-variable-noselect variable file-name) + (error nil)))) + (when location + (with-current-buffer (car location) + (goto-char (cdr location)) + (when (re-search-backward + "^;;; Generated autoloads from \\(.*\\)" nil t) + (setq file-name (match-string 1))))))) + (when file-name + (princ "\n\nDefined in `") + (princ file-name) + (princ "'.") + (with-current-buffer standard-output + (save-excursion + (re-search-backward "`\\([^`']+\\)'" nil t) + (help-xref-button 1 'help-variable-def + variable file-name))))) + + (print-help-return-message) + (save-excursion + (set-buffer standard-output) + ;; Return the text we displayed. + (buffer-string))))))) + + +;; `help-manyarg-func-alist' is defined primitively (in doc.c). +;; New primitives with `MANY' or `UNEVALLED' arglists should be added +;; to this alist. +;; The parens and function name are redundant, but it's messy to add +;; them in `documentation'. + +;; This will find any missing items: +;; (let (l) +;; (mapatoms (lambda (x) +;; (if (and (fboundp x) +;; (subrp (symbol-function x)) +;; (not (numberp (cdr (subr-arity (symbol-function x))))) +;; (not (assq x help-manyarg-func-alist))) +;; (push x l)))) +;; l) +(defconst help-manyarg-func-alist + (purecopy + '((list . "(list &rest OBJECTS)") + (vector . "(vector &rest OBJECTS)") + (make-byte-code . "(make-byte-code &rest ELEMENTS)") + (call-process + . "(call-process PROGRAM &optional INFILE BUFFER DISPLAY &rest ARGS)") + (call-process-region + . "(call-process-region START END PROGRAM &optional DELETE BUFFER DISPLAY &rest ARGS)") + (string . "(string &rest CHARACTERS)") + (+ . "(+ &rest NUMBERS-OR-MARKERS)") + (- . "(- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS)") + (* . "(* &rest NUMBERS-OR-MARKERS)") + (/ . "(/ DIVIDEND DIVISOR &rest DIVISORS)") + (max . "(max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS)") + (min . "(min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS)") + (logand . "(logand &rest INTS-OR-MARKERS)") + (logior . "(logior &rest INTS-OR-MARKERS)") + (logxor . "(logxor &rest INTS-OR-MARKERS)") + (encode-time + . "(encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE)") + (insert . "(insert &rest ARGS)") + (insert-and-inherit . "(insert-and-inherit &rest ARGS)") + (insert-before-markers . "(insert-before-markers &rest ARGS)") + (message . "(message STRING &rest ARGUMENTS)") + (message-box . "(message-box STRING &rest ARGUMENTS)") + (message-or-box . "(message-or-box STRING &rest ARGUMENTS)") + (propertize . "(propertize STRING &rest PROPERTIES)") + (format . "(format STRING &rest OBJECTS)") + (apply . "(apply FUNCTION &rest ARGUMENTS)") + (run-hooks . "(run-hooks &rest HOOKS)") + (run-hook-with-args . "(run-hook-with-args HOOK &rest ARGS)") + (run-hook-with-args-until-failure + . "(run-hook-with-args-until-failure HOOK &rest ARGS)") + (run-hook-with-args-until-success + . "(run-hook-with-args-until-success HOOK &rest ARGS)") + (funcall . "(funcall FUNCTION &rest ARGUMENTS)") + (append . "(append &rest SEQUENCES)") + (concat . "(concat &rest SEQUENCES)") + (vconcat . "(vconcat &rest SEQUENCES)") + (nconc . "(nconc &rest LISTS)") + (widget-apply . "(widget-apply WIDGET PROPERTY &rest ARGS)") + (make-hash-table . "(make-hash-table &rest KEYWORD-ARGS)") + (insert-string . "(insert-string &rest ARGS)") + (start-process . "(start-process NAME BUFFER PROGRAM &rest PROGRAM-ARGS)") + (setq-default . "(setq-default SYMBOL VALUE [SYMBOL VALUE...])") + (save-excursion . "(save-excursion &rest BODY)") + (save-current-buffer . "(save-current-buffer &rest BODY)") + (save-restriction . "(save-restriction &rest BODY)") + (or . "(or CONDITIONS ...)") + (and . "(and CONDITIONS ...)") + (if . "(if COND THEN ELSE...)") + (cond . "(cond CLAUSES...)") + (progn . "(progn BODY ...)") + (prog1 . "(prog1 FIRST BODY...)") + (prog2 . "(prog2 X Y BODY...)") + (setq . "(setq SYM VAL SYM VAL ...)") + (quote . "(quote ARG)") + (function . "(function ARG)") + (defun . "(defun NAME ARGLIST [DOCSTRING] BODY...)") + (defmacro . "(defmacro NAME ARGLIST [DOCSTRING] BODY...)") + (defvar . "(defvar SYMBOL [INITVALUE DOCSTRING])") + (defconst . "(defconst SYMBOL INITVALUE [DOCSTRING])") + (let* . "(let* VARLIST BODY...)") + (let . "(let VARLIST BODY...)") + (while . "(while TEST BODY...)") + (catch . "(catch TAG BODY...)") + (unwind-protect . "(unwind-protect BODYFORM UNWINDFORMS...)") + (condition-case . "(condition-case VAR BODYFORM HANDLERS...)") + (track-mouse . "(track-mouse BODY ...)") + (ml-if . "(ml-if COND THEN ELSE...)") + (ml-provide-prefix-argument . "(ml-provide-prefix-argument ARG1 ARG2)") + (ml-prefix-argument-loop . "(ml-prefix-argument-loop ...)") + (with-output-to-temp-buffer + . "(with-output-to-temp-buffer BUFFNAME BODY ...)") + (save-window-excursion . "(save-window-excursion BODY ...)") + (find-operation-coding-system + . "(find-operation-coding-system OPERATION ARGUMENTS ...)") + (insert-before-markers-and-inherit + . "(insert-before-markers-and-inherit &rest ARGS)")))) + + +(provide 'help-funs) + +;;; help-funs.el ends here + + -- 2.39.2