home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / prim / help.el < prev    next >
Encoding:
Text File  |  1995-08-02  |  32.6 KB  |  881 lines
  1. ;;; help.el --- help commands for XEmacs.
  2. ;; Copyright (C) 1985, 1986, 1992, 1993, 1994 Free Software Foundation, Inc.
  3.  
  4. ;; This file is part of XEmacs.
  5.  
  6. ;; XEmacs is free software; you can redistribute it and/or modify it
  7. ;; under the terms of the GNU General Public License as published by
  8. ;; the Free Software Foundation; either version 2, or (at your option)
  9. ;; any later version.
  10.  
  11. ;; XEmacs is distributed in the hope that it will be useful, but
  12. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14. ;; General Public License for more details.
  15.  
  16. ;; You should have received a copy of the GNU General Public License
  17. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  18. ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. ;;; Commentary:
  21.  
  22. ;; This code implements XEmacs's on-line help system, the one invoked by
  23. ;;`M-x help-for-help'.
  24.  
  25. ;;; Code:
  26.  
  27. (defvar help-map (let ((map (make-sparse-keymap)))
  28.                    (set-keymap-name map 'help-map)
  29.                    (set-keymap-prompt
  30.                      map (purecopy (gettext "(Type ? for further options)")))
  31.                    map)
  32.   "Keymap for characters following the Help key.")
  33.  
  34. (fset 'help-command help-map)
  35.  
  36. (define-key help-map '(control h) 'help-for-help)
  37. (define-key help-map "?" 'help-for-help)
  38.  
  39. (define-key help-map "\C-l" 'describe-copying)
  40. (define-key help-map "\C-d" 'describe-distribution)
  41. (define-key help-map "\C-w" 'describe-no-warranty)
  42. (define-key help-map "a" 'hyper-apropos)
  43. (define-key help-map "A" 'command-apropos)
  44.  
  45. (define-key help-map "b" 'describe-bindings)
  46. (define-key help-map "\C-p" 'describe-pointer)
  47.  
  48. (define-key help-map "c" 'describe-key-briefly)
  49. (define-key help-map "k" 'describe-key)
  50.  
  51. (define-key help-map "d" 'describe-function)
  52. (define-key help-map "e" 'describe-last-error)
  53. (define-key help-map "f" 'describe-function)
  54.  
  55. ;;; Setup so Hyperbole can be autoloaded from a key.
  56. ;;; Choose a key on which to place the Hyperbole menus.
  57. ;;; For most people this key binding will work and will be equivalent
  58. ;;; to {C-h h}.
  59. ;;;
  60. (or (where-is-internal 'hyperbole)
  61.     (where-is-internal 'hui:menu)
  62.     (define-key help-map "h" 'hyperbole))
  63. (autoload 'hyperbole "hsite" "Hyperbole info manager menus." t)
  64.  
  65. (define-key help-map "i" 'info)
  66. (define-key help-map '(control i) 'Info-query)
  67. (define-key help-map '(control c) 'Info-goto-emacs-command-node)
  68. (define-key help-map '(control k) 'Info-goto-emacs-key-command-node)
  69. (define-key help-map '(control f) 'Info-elisp-ref)
  70.  
  71. (define-key help-map "l" 'view-lossage)
  72.  
  73. (define-key help-map "m" 'describe-mode)
  74.  
  75. (define-key help-map "\C-n" 'view-emacs-news)
  76. (define-key help-map "n" 'view-emacs-news)
  77.  
  78. (define-key help-map "p" 'finder-by-keyword)
  79. (autoload 'finder-by-keyword "finder"
  80.   "Find packages matching a given keyword." t)
  81.  
  82. (define-key help-map "s" 'describe-syntax)
  83.  
  84. (define-key help-map "t" 'help-with-tutorial)
  85.  
  86. (define-key help-map "w" 'where-is)
  87.  
  88. (define-key help-map "v" 'describe-variable)
  89.  
  90. (if (fboundp 'view-last-error)
  91.     (define-key help-map "e" 'view-last-error))
  92.  
  93.  
  94. (define-key help-map "q" 'help-quit)
  95.  
  96. (defun help-quit ()
  97.   (interactive)
  98.   nil)
  99.  
  100. ;; This is a grody hack of the same genotype as `advertised-undo'; if the
  101. ;; bindings of Backspace and C-h are the same, we want the menubar to claim
  102. ;; that `info' in invoked with `C-h i', not `BS i'.
  103.  
  104. (defun deprecated-help-command ()
  105.   (interactive)
  106.   (if (eq 'help-command (key-binding "\C-h"))
  107.       (setq unread-command-event (character-to-event ?\C-h))
  108.     (help-for-help)))
  109.  
  110. ;;(define-key global-map 'backspace 'deprecated-help-command)
  111.  
  112. (defun help-with-tutorial (&optional tutorial)
  113.   "Select the XEmacs learn-by-doing tutorial.
  114. Optional arg TUTORIAL specifies the tutorial file; default is \"TUTORIAL\"."
  115.   (interactive)
  116.   (if (null tutorial)
  117.       (setq tutorial "TUTORIAL"))
  118.   (let ((file (expand-file-name (concat "~/" tutorial))))
  119.     (delete-other-windows)
  120.     (if (get-file-buffer file)
  121.     (switch-to-buffer (get-file-buffer file))
  122.       (switch-to-buffer (create-file-buffer file))
  123.       (setq buffer-file-name file)
  124.       (setq default-directory (expand-file-name "~/"))
  125.       (setq buffer-auto-save-file-name nil)
  126.       (insert-file-contents (expand-file-name tutorial data-directory))
  127.       (goto-char (point-min))
  128.       (search-forward "\n<<")
  129.       (beginning-of-line)
  130.       (delete-region (point) (progn (end-of-line) (point)))
  131.       (let ((n (- (window-height (selected-window))
  132.           (count-lines (point-min) (point))
  133.           6)))
  134.     (if (< n 12)
  135.         (newline n)
  136.       ;; Some people get confused by the large gap.
  137.       (newline (/ n 2))
  138.       (insert "[Middle of page left blank for didactic purposes.  "
  139.           "Text continues below]")
  140.       (newline (- n (/ n 2)))))
  141.       (goto-char (point-min))
  142.       (set-buffer-modified-p nil))))
  143.  
  144. (defun key-or-menu-binding (key &optional menu-flag)
  145.   ;; KEY          is any value returned by next-command-event
  146.   ;; MENU-FLAG    is a symbol that should be set to T if KEY is a menu event,
  147.   ;;          or NIL otherwise
  148.   (let (defn)
  149.     (and menu-flag (set menu-flag nil))
  150.     ;; If the key typed was really a menu selection, grab the form out
  151.     ;; of the event object and intuit the function that would be called,
  152.     ;; and describe that instead.
  153.     (if (and (vectorp key) (= 1 (length key))
  154.          (or (misc-user-event-p (aref key 0))
  155.          (eq (car-safe (aref key 0)) 'menu-selection)))
  156.     (let ((event (aref key 0)))
  157.       (setq defn (if (eventp event)
  158.              (list (event-function event) (event-object event))
  159.                (cdr event)))
  160.       (and menu-flag (set menu-flag t))
  161.       (if (eq (car defn) 'eval)
  162.           (setq defn (car (cdr defn))))
  163.       (if (eq (car-safe defn) 'call-interactively)
  164.           (setq defn (car (cdr defn))))
  165.       (if (and (consp defn) (null (cdr defn)))
  166.           (setq defn (car defn))))
  167.       ;; else
  168.       (setq defn (key-binding key)))
  169.     defn
  170.     ))
  171.  
  172. (defun describe-key-briefly (key)
  173.   "Print the name of the function KEY invokes.  KEY is a string."
  174.   (interactive "kDescribe key briefly: ")
  175.   (let (defn menup)
  176.     (setq defn (key-or-menu-binding key 'menup))    
  177.     (if (or (null defn) (integerp defn))
  178.         (message "%s is undefined" (key-description key))
  179.       ;; If it's a keyboard macro which trivially invokes another command,
  180.       ;; document that instead.
  181.       (if (or (stringp defn) (vectorp defn))
  182.       (setq defn (or (key-binding defn)
  183.              defn)))
  184.       (message "%s runs the command %s"
  185.            ;; This used to say 'This menu item' but it could also
  186.            ;; be a scrollbar event.  We can't distinguish at the
  187.            ;; moment.
  188.            (if menup "This item" (key-description key))
  189.            (if (symbolp defn) defn (prin1-to-string defn))))))
  190.  
  191. (defun print-help-return-message (&optional function)
  192.   "Display or return message saying how to restore windows after help command.
  193. Computes a message and applies the optional argument FUNCTION to it.
  194. If FUNCTION is nil, applies `message' to it, thus printing it."
  195.   (and (not (get-buffer-window standard-output))
  196.        (funcall
  197.     (or function 'message)
  198.     (concat
  199.          (substitute-command-keys
  200.           (if (one-window-p t)
  201.               (if pop-up-windows
  202.                   (gettext "Type \\[delete-other-windows] to remove help window.")
  203.                 (gettext "Type \\[switch-to-buffer] RET to remove help window."))
  204.    (gettext "Type \\[switch-to-buffer-other-window] RET to restore the other window.")))
  205.          (substitute-command-keys
  206.           (gettext "  \\[scroll-other-window] to scroll the help."))))))
  207.  
  208. (defun describe-key (key)
  209.   "Display documentation of the function invoked by KEY.
  210. KEY is a string, or vector of events.
  211. When called interactvely, KEY may also be a menu selection."
  212.   (interactive "kDescribe key: ")
  213.   (let (defn)
  214.     ;; If the key typed was really a menu selection, grab the form out
  215.     ;; of the event object and intuit the function that would be called,
  216.     ;; and describe that instead.
  217.     (if (and (vectorp key) (= 1 (length key))
  218.          (or (misc-user-event-p (aref key 0))
  219.          (eq (car-safe (aref key 0)) 'menu-selection)))
  220.     (let ((event (aref key 0)))
  221.       (setq defn (if (eventp event)
  222.              (list (event-function event) (event-object event))
  223.                (cdr event)))
  224.       (if (eq (car defn) 'eval)
  225.           (setq defn (car (cdr defn))))
  226.       (if (eq (car-safe defn) 'call-interactively)
  227.           (setq defn (car (cdr defn))))
  228.       (if (and (consp defn) (null (cdr defn)))
  229.           (setq defn (car defn))))
  230.       ;; else
  231.       (setq defn (key-binding key)))
  232.     (if (or (null defn) (integerp defn))
  233.         (message "%s is undefined" (key-description key))
  234.       (with-output-to-temp-buffer "*Help*"
  235. ;    (princ (key-description key))
  236. ;    (princ " runs the command ")
  237.     (prin1 defn)
  238.     (princ ":\n")
  239.     (cond ((or (stringp defn) (vectorp defn))
  240.                (let ((cmd (key-binding defn)))
  241.                  (if (not cmd)
  242.                      (princ "a keyboard macro")
  243.                    (progn
  244.                      (princ (format "a keyboard macro which runs the command %s:\n\n"
  245.                                     cmd))
  246.                      (princ cmd)
  247.              (princ "\n")
  248.                      (if (documentation cmd) (princ (documentation cmd)))))))
  249.               ((and (consp defn) (not (eq 'lambda (car-safe defn))))
  250.                (princ "\n")
  251.                (let ((describe-function-show-arglist nil))
  252.                  (describe-function-1 (car defn) standard-output)))
  253.               ((documentation defn)
  254.                (princ (documentation defn)))
  255.               (t
  256.                (princ "not documented")))
  257.     (print-help-return-message)))))
  258.  
  259.  
  260. (defun describe-mode ()
  261.   "Display documentation of current major mode and minor modes.
  262. For this to work correctly for a minor mode, the mode's indicator variable
  263. \(listed in `minor-mode-alist') must also be a function whose documentation
  264. describes the minor mode."
  265.   (interactive)
  266.   (with-output-to-temp-buffer "*Help*"
  267.     (let ((minor-modes minor-mode-alist))
  268.       (while minor-modes
  269.     (let* ((minor-mode (car (car minor-modes)))
  270.            (indicator (car (cdr (car minor-modes)))))
  271.       ;; Document a minor mode if it is listed in minor-mode-alist,
  272.       ;; bound locally in this buffer, non-nil, and has a function
  273.       ;; definition.
  274.       (if (and (boundp minor-mode)
  275.                    (symbol-value minor-mode)
  276.            (fboundp minor-mode))
  277.           (let ((pretty-minor-mode minor-mode))
  278.         (if (string-match "-mode\\'" (symbol-name minor-mode))
  279.             (setq pretty-minor-mode
  280.               (capitalize
  281.                (substring (symbol-name minor-mode)
  282.                       0 (match-beginning 0)))))
  283.         (while (and indicator (symbolp indicator))
  284.           (setq indicator (symbol-value indicator)))
  285.         (princ (format "%s minor mode (indicator%s):\n"
  286.                    pretty-minor-mode indicator))
  287.         (princ (documentation minor-mode))
  288.         (princ "\n\n"))))
  289.     (setq minor-modes (cdr minor-modes))))
  290.     (princ mode-name)
  291.     (princ " mode:\n")
  292.     (princ (documentation major-mode))
  293.     (print-help-return-message)))
  294.  
  295. (defun describe-distribution ()
  296.   "Display info on how to obtain the latest version of XEmacs."
  297.   (interactive)
  298.   (find-file-read-only
  299.    (expand-file-name "DISTRIB" data-directory)))
  300.  
  301. (defun describe-copying ()
  302.   "Display info on how you may redistribute copies of XEmacs."
  303.   (interactive)
  304.   (find-file-read-only
  305.    (expand-file-name "COPYING" data-directory))
  306.   (goto-char (point-min)))
  307.  
  308. (defun describe-pointer ()
  309.   "Show a list of all defined mouse buttons, and their definitions.
  310. This is the same as \\[universal-argument] \\[describe-bindings]."
  311.   (interactive)
  312.   (describe-bindings nil t))
  313.  
  314. (defun describe-no-warranty ()
  315.   "Display info on all the kinds of warranty XEmacs does NOT have."
  316.   (interactive)
  317.   (describe-copying)
  318.   (let (case-fold-search)
  319.     (search-forward "NO WARRANTY")
  320.     (recenter 0)))
  321.  
  322. (defun describe-bindings (&optional prefix mouse-only-p)
  323.   "Show a list of all defined keys, and their definitions.
  324. The list is put in a buffer, which is displayed.
  325. If the optional argument PREFIX is supplied, only commands which
  326. start with that sequence of keys are described.
  327. If the second argument (prefix arg, interactively) is non-null
  328. then only the mouse bindings are displayed."
  329.   (interactive (list nil current-prefix-arg))
  330.   (with-output-to-temp-buffer "*Help*"
  331.     (describe-bindings-1 prefix mouse-only-p)
  332.     (print-help-return-message)))
  333.  
  334. (defun describe-bindings-1 (&optional prefix mouse-only-p)
  335.   (let ((heading (if mouse-only-p
  336.             (gettext "button          binding\n------          -------\n")
  337.             (gettext "key             binding\n---             -------\n")))
  338.         (buffer (current-buffer))
  339.         (minor minor-mode-map-alist)
  340.         (local (current-local-map))
  341.         (shadow '()))
  342.     (set-buffer standard-output)
  343.     (while minor
  344.       (let ((sym (car (car minor)))
  345.             (map (cdr (car minor))))
  346.         (if (symbol-value-in-buffer sym buffer nil)
  347.             (progn
  348.               (insert (format "Minor Mode Bindings for `%s':\n"
  349.                               sym)
  350.                       heading)
  351.               (describe-bindings-internal map nil shadow prefix mouse-only-p)
  352.               (insert "\n")
  353.               (setq shadow (cons map shadow))))
  354.         (setq minor (cdr minor))))
  355.     (if local
  356.         (progn
  357.           (insert "Local Bindings:\n" heading)
  358.           (describe-bindings-internal local nil shadow prefix mouse-only-p)
  359.           (insert "\n")
  360.           (setq shadow (cons local shadow))))
  361.     (insert "Global Bindings:\n" heading)
  362.     (describe-bindings-internal (current-global-map)
  363.                                 nil shadow prefix mouse-only-p)
  364.     (set-buffer buffer)))
  365.  
  366. (defun describe-prefix-bindings ()
  367.   "Describe the bindings of the prefix used to reach this command.
  368. The prefix described consists of all but the last event
  369. of the key sequence that ran this command."
  370.   (interactive)
  371.   (let* ((key (this-command-keys))
  372.      (prefix (make-vector (1- (length key)) nil))
  373.      i)
  374.     (setq i 0)
  375.     (while (< i (length prefix))
  376.       (aset prefix i (aref key i))
  377.       (setq i (1+ i)))
  378.     (with-output-to-temp-buffer "*Help*"
  379.       (princ "Key bindings starting with ")
  380.       (princ (key-description prefix))
  381.       (princ ":\n\n")
  382.       (describe-bindings-1 prefix nil))))
  383.  
  384. ;; Make C-h after a prefix, when not specifically bound, 
  385. ;; run describe-prefix-bindings.
  386. (setq prefix-help-command 'describe-prefix-bindings)
  387.  
  388. (defun xemacs-www-page ()
  389.   "Go to the XEmacs World Wide Web page."
  390.   (interactive)
  391.   (w3-fetch "http://xemacs.cs.uiuc.edu/"))
  392.  
  393. (defun xemacs-www-faq ()
  394.   "View the latest and greatest XEmacs FAQ using the World Wide Web."
  395.   (interactive)
  396.   (w3-fetch "http://xemacs.cs.uiuc.edu/XEmacs-faq_toc.html"))
  397.  
  398. (defun xemacs-local-faq ()
  399.   "View the local copy of the XEmacs FAQ.
  400. If you have access to the World Wide Web, you should use `xemacs-www-faq'
  401. instead, to ensure that you get the most up-to-date information."
  402.   (interactive)
  403.   (save-window-excursion
  404.     (info)
  405.     (Info-find-node "xemacs-faq" "Top"))
  406.   (switch-to-buffer "*info*"))
  407.  
  408. (defun view-emacs-news ()
  409.   "Display info on recent changes to XEmacs."
  410.   (interactive)
  411.   (require 'outl-mouse)
  412.   (find-file (expand-file-name "NEWS" data-directory)))
  413.  
  414. (defun view-lossage ()
  415.   "Display last 100 input keystrokes."
  416.   (interactive)
  417.   (with-output-to-temp-buffer "*Help*"
  418.     (princ (key-description (recent-keys)))
  419.     (save-excursion
  420.       (set-buffer standard-output)
  421.       (goto-char (point-min))
  422.       (while (progn (move-to-column 50) (not (eobp)))
  423.     (search-forward " " nil t)
  424.     (insert "\n")))
  425.     (print-help-return-message)))
  426.  
  427. (define-function 'help 'help-for-help)
  428. (defun help-for-help ()
  429.   "You have typed \\[help-for-help], the help character.  Type a Help option:
  430. \(Use \\<help-map>\\[scroll-up] or \\[scroll-down] to scroll through this text.
  431. Type \\[help-quit] to exit the Help command.)
  432.  
  433. \\[hyper-apropos]    Give a substring, and see a hypertext list of
  434.         functions and variables that contain that substring.
  435.     See also the `apropos'  command.
  436. \\[command-apropos]    Give a substring, and see a list of commands
  437.         (functions interactively callable) that contain that substring.
  438. \\[describe-bindings]    Display table of all key bindings.
  439. \\[describe-key-briefly]    Type a command key sequence;
  440.         it prints the function name that sequence runs.
  441. \\[describe-function]    Type a function name and get documentation of it.
  442. \\[Info-goto-emacs-command-node]    Type a function name;
  443.      it takes you to the Info node for that command.
  444. \\[info]    The  info  documentation reader.
  445. \\[describe-key]    Type a command key sequence;
  446.         it displays the full documentation.
  447. \\[Info-goto-emacs-key-command-node]    Type a command key sequence;
  448.         it takes you to the Info node for the command bound to that key.
  449. \\[view-lossage]    Shows last 100 characters you typed.
  450. \\[describe-mode]    Print documentation of current major mode,
  451.         which describes the commands peculiar to it.
  452. \\[view-emacs-news]    Shows emacs news file.
  453. \\[finder-by-keyword]    Find packages matching a given topic keyword.
  454. \\[describe-pointer]    Display table of all mouse-button bindings.
  455. \\[describe-syntax]    Display contents of syntax table, plus explanations
  456. \\[help-with-tutorial]    Select the XEmacs learn-by-doing tutorial.
  457. \\[describe-variable]    Type name of a variable;
  458.         it displays the variable's documentation and value.
  459. \\[where-is]    Type command name;
  460.         it prints which keystrokes invoke that command.
  461. \\[describe-copying]    print XEmacs copying permission (General Public License).
  462. \\[describe-distribution]    XEmacs ordering information.
  463. \\[view-emacs-news]    print print news of recent XEmacs changes.
  464. \\[describe-no-warranty]    print information on absence of warranty for XEmacs.
  465. \\[Info-query]    Info reader, prompt for topic name."
  466.   (interactive)
  467.   (let ((help-key (copy-event last-command-event))
  468.     event char)
  469.     (message (gettext "A B C F I K L M N P S T V W C-c C-d C-n C-w.  Type %s again for more help: ")
  470.          ;; arrgh, no room for "C-i C-k C-f" !!
  471.          (single-key-description help-key))
  472.     (setq event (next-command-event)
  473.       char (event-to-character event))
  474.     (if (or (equal event help-key)
  475.         (eq char ??)
  476.         (eq 'help-command (key-binding event)))
  477.     (save-window-excursion
  478.       (switch-to-buffer "*Help*")
  479.       ;; #### I18N3 should mark buffer as output-translating
  480.       (delete-other-windows)
  481.       (erase-buffer)
  482.       (insert (documentation 'help-for-help))
  483.       (goto-char (point-min))
  484.       (while (or (equal event help-key)
  485.              (eq char ??)
  486.              (eq 'help-command (key-binding event))
  487.              (eq char ? )
  488.              (eq 'scroll-up (key-binding event))
  489.              (eq 'scroll-down (key-binding event)))
  490.         (if (or (eq char ? )
  491.             (eq 'scroll-up (key-binding event)))
  492.         (scroll-up))
  493.         (if (eq 'scroll-down (key-binding event))
  494.         (scroll-down))
  495.         ;; write this way for I18N3 snarfing
  496.         (if (pos-visible-in-window-p (point-max))
  497.         (message "A B C F I K L M N P S T V W C-c C-d C-n C-w C-i C-k C-f: ")
  498.           (message "A B C F I K L M N P S T V W C-c C-d C-n C-w C-i C-k C-f or Space to scroll: "))
  499.         (let ((cursor-in-echo-area t))
  500.           (setq event (next-command-event event)
  501.             char (or (event-to-character event) event))))))
  502.     (let ((defn (or (lookup-key help-map (vector event))
  503.              (and (numberp char)
  504.               (lookup-key help-map (make-string 1 (downcase char)))))))
  505.       (message nil)
  506.       (if defn
  507.        (call-interactively defn)
  508.      (ding)))))
  509.  
  510. ;; Return a function which is called by the list containing point.
  511. ;; If that gives no function, return a function whose name is around point.
  512. ;; If that doesn't give a function, return nil.
  513. (defun function-called-at-point ()
  514.   (or (condition-case ()
  515.       (save-excursion
  516.         (save-restriction
  517.           (narrow-to-region (max (point-min) (- (point) 1000)) (point-max))
  518.           (backward-up-list 1)
  519.           (forward-char 1)
  520.           (let (obj)
  521.         (setq obj (read (current-buffer)))
  522.         (and (symbolp obj) (fboundp obj) obj))))
  523.     (error nil))
  524.       (condition-case ()
  525.       (save-excursion
  526.         (forward-sexp -1)
  527.         (skip-chars-forward "`'")
  528.         (let ((obj (read (current-buffer))))
  529.           (and (symbolp obj) (fboundp obj) obj)))
  530.     (error nil))))
  531.  
  532. (defvar describe-function-show-arglist t  ; default to nil for the non-hackers?
  533.   "*If true, then describe-function will show its arglist if the function is
  534. not an autoload.")
  535.  
  536.  
  537. (defun describe-function (function)
  538.   "Display the full documentation of FUNCTION (a symbol)."
  539.   (interactive
  540.     (let* ((fn (function-called-at-point))
  541.            (val (let ((enable-recursive-minibuffers t))
  542.                   (completing-read
  543.                     (if fn
  544.                         (format (gettext "Describe function (default %s): ")
  545.                 fn)
  546.                         (gettext "Describe function: "))
  547.                     obarray 'fboundp t))))
  548.       (list (if (equal val "") fn (intern val)))))
  549.   (with-output-to-temp-buffer "*Help*"
  550.     (describe-function-1 function standard-output)
  551.     (print-help-return-message)
  552.     (save-excursion (set-buffer standard-output) (buffer-string))))
  553.  
  554. (defun function-obsoleteness-doc (function)
  555.   "If FUNCTION is obsolete, return a string describing this."
  556.   (let ((obsolete (get function 'byte-obsolete-info)))
  557.     (if obsolete
  558.     (format "Obsolete; %s"
  559.         (if (stringp (car obsolete))
  560.             (car obsolete)
  561.           (format "use `%s' instead." (car obsolete)))))))
  562.  
  563. (defun describe-function-1 (function stream &optional nodoc)
  564.   (prin1 function stream)
  565.   (princ ": " stream)
  566.   (let* ((def function)
  567.          (doc (or (documentation function)
  568.                   (gettext "not documented")))
  569.      aliases kbd-macro-p fndef macrop)
  570.     (while (symbolp def)
  571.       (or (eq def function)
  572.       (if aliases
  573.           ;; I18N3 Need gettext due to concat
  574.           (setq aliases (concat aliases 
  575.                     (format "\n     which is an alias for %s, "
  576.                         (symbol-name def))))
  577.         (setq aliases (format "an alias for %s, " (symbol-name def)))))
  578.       (setq def (symbol-function def)))
  579.     (if (eq 'macro (car-safe def))
  580.     (setq fndef (cdr def)
  581.           macrop t)
  582.       (setq fndef def))
  583.     (if describe-function-show-arglist
  584.         (if (cond ((eq 'autoload (car-safe fndef))
  585.                    nil)
  586.                   ((eq 'lambda (car-safe fndef))
  587.                    (princ (or (nth 1 fndef) "()") stream)
  588.                    t)
  589.                   ((compiled-function-p fndef)
  590.                    (princ (or (aref fndef 0) "()") stream)
  591.                    t)
  592.                   ((and (subrp fndef)
  593.                         (string-match "[\n\t ]*\narguments: ?\\((.*)\\)\n?\\'"
  594.                                       doc))
  595.                    (princ (substring doc (match-beginning 1) (match-end 1))
  596.                           stream)
  597.                    (setq doc (substring doc 0 (match-beginning 0)))
  598.                    t)
  599.                   (t
  600.                    nil))
  601.             (princ "\n  -- " stream)))
  602.     (if aliases (princ aliases stream))
  603.     (let ((int #'(lambda (string)
  604.            (princ (format (if (commandp def)
  605.                       (gettext "an interactive %s")
  606.                     (gettext "a %s"))
  607.                   string)
  608.               stream))))
  609.       (cond ((or (stringp def) (vectorp def))
  610.              (princ "a keyboard macro." stream)
  611.          (setq kbd-macro-p t))
  612.             ((subrp fndef)
  613.              (funcall int (if macrop
  614.                   (gettext "built-in macro.")
  615.                 (gettext "built-in function."))))
  616.             ((compiled-function-p fndef)
  617.              (funcall int (if macrop (gettext "compiled Lisp macro.")
  618.                 (gettext "compiled Lisp function."))))
  619.             ((symbolp fndef)
  620.              (princ (format "alias for `%s'."
  621.                 (prin1-to-string def)) stream))
  622.             ((eq (car-safe fndef) 'lambda)
  623.              (funcall int (if macrop (gettext "Lisp macro.")
  624.                 (gettext "Lisp function."))))
  625.             ((eq (car-safe fndef) 'mocklisp)
  626.              (princ (if macrop (gettext "a mocklisp macro.")
  627.               (gettext "a mocklisp function."))
  628.             stream))
  629.             ((eq (car-safe def) 'autoload)
  630.          (if (elt def 4)
  631.          (funcall int (gettext "autoloaded Lisp macro"))
  632.            (funcall int (gettext "autoloaded Lisp function")))
  633.          (princ (format "\n  -- loads from \"%s\"" (elt def 1)) stream))
  634.             (t
  635.              nil)))
  636.     (terpri)
  637.     (cond (kbd-macro-p
  638.        (princ "These characters are executed:\n\n\t" stream)
  639.        (princ (key-description def) stream)
  640.        (cond ((setq def (key-binding def))
  641.           (princ (format "\n\nwhich executes the command %s.\n\n" def) stream)
  642.           (describe-function-1 def stream))))
  643.       (nodoc nil)
  644.       (t
  645.        ;; tell the user about obsoleteness.
  646.        ;; If the function is obsolete and is aliased, don't
  647.        ;; even bother to report the documentation, as a further
  648.        ;; encouragement to use the new function.
  649.        (let ((obsolete (function-obsoleteness-doc function)))
  650.          (if obsolete
  651.          (progn
  652.            (princ obsolete stream)
  653.            (terpri stream)
  654.            (terpri stream)))
  655.          (if (not (and obsolete aliases))
  656.          (princ doc stream)))))))
  657.  
  658.  
  659. (defun describe-function-arglist (function)
  660.   (interactive (list (or (function-called-at-point)
  661.              (error "no function call at point"))))
  662.   (let ((b nil))
  663.     (unwind-protect
  664.     (save-excursion
  665.       (set-buffer (setq b (get-buffer-create " *arglist*")))
  666.       (buffer-disable-undo b)
  667.       (erase-buffer)
  668.       (describe-function-1 function b t)
  669.       (goto-char (point-min))
  670.       (end-of-line)
  671.       (or (eobp) (delete-char 1))
  672.       (just-one-space)
  673.       (end-of-line)
  674.       (message (buffer-substring (point-min) (point))))
  675.       (and b (kill-buffer b)))))
  676.  
  677.  
  678. (defun variable-at-point ()
  679.   (condition-case ()
  680.       (save-excursion
  681.     (forward-sexp -1)
  682.     (skip-chars-forward "'")
  683.     (let ((obj (read (current-buffer))))
  684.       (and (symbolp obj) (boundp obj) obj)))
  685.     (error nil)))
  686.  
  687. (defun variable-obsoleteness-doc (variable)
  688.   "If VARIABLE is obsolete, return a string describing this."
  689.   (let ((obsolete (get variable 'byte-obsolete-variable)))
  690.     (if obsolete
  691.     (format "Obsolete; %s"
  692.         (if (stringp obsolete)
  693.             obsolete
  694.           (format "use `%s' instead." obsolete))))))
  695.  
  696. (defun describe-variable (variable)
  697.   "Display the full documentation of VARIABLE (a symbol)."
  698.   (interactive 
  699.    (let* ((v (variable-at-point))
  700.           (val (let ((enable-recursive-minibuffers t))
  701.                  (completing-read
  702.                    (if v
  703.                        (format "Describe variable (default %s): " v)
  704.                        (gettext "Describe variable: "))
  705.                    obarray 'boundp t))))
  706.      (list (if (equal val "") v (intern val)))))
  707.   (with-output-to-temp-buffer "*Help*"
  708.     (let ((origvar variable)
  709.       aliases)
  710.       (let ((print-escape-newlines t))
  711.     (while (variable-alias variable)
  712.       (let ((newvar (variable-alias variable)))
  713.         (if aliases
  714.         ;; I18N3 Need gettext due to concat
  715.         (setq aliases
  716.               (concat aliases 
  717.                   (format ",\n     which is an alias for %s"
  718.                       (symbol-name newvar))))
  719.           (setq aliases
  720.             (format "%s is an alias for %s"
  721.                 (symbol-name variable)
  722.                 (symbol-name newvar))))
  723.         (setq variable newvar)))
  724.     (if aliases
  725.         (princ (format "%s.\n" aliases)))
  726.     (princ (format "%s's value is " variable))
  727.     (if (not (boundp variable))
  728.         (princ "void.")
  729.           (prin1 (symbol-value variable)))
  730.     (terpri)
  731.     (cond ((local-variable-p variable (current-buffer))
  732.            (let* ((void (cons nil nil))
  733.               (def (condition-case nil
  734.                    (default-value variable)
  735.                  (error void))))
  736.          (princ "This value is specific to the current buffer.")
  737.          (terpri)
  738.          (if (local-variable-p variable nil)
  739.              (progn
  740.                (princ "(Its value is local to each buffer.)")
  741.                (terpri)))
  742.          (if (if (eq def void)
  743.              (boundp variable)
  744.                        (not (eq (symbol-value variable) def)))
  745.              ;; #### I18N3 doesn't localize properly!
  746.              (progn (princ "Its default-value is ")
  747.                 (if (eq def void)
  748.                 (princ "void.")
  749.                               (prin1 def))
  750.                 (terpri)))))
  751.           ((local-variable-p variable (current-buffer) t)
  752.            (princ "Setting it would make its value buffer-local.\n")
  753.            (terpri))))
  754.       (terpri)
  755.       (princ "Documentation:")
  756.       (terpri)
  757.       (let ((doc (documentation-property variable 'variable-documentation))
  758.         (obsolete (variable-obsoleteness-doc origvar)))
  759.     (if obsolete
  760.         (progn
  761.           (princ obsolete)
  762.           (terpri)
  763.           (terpri)))
  764.     ;; don't bother to print anything if variable is obsolete and aliased.
  765.     (if (or (not obsolete) (not aliases))
  766.         (if doc
  767.         ;; note: documentation-property calls substitute-command-keys.
  768.         (princ doc)
  769.           (princ "not documented as a variable."))))
  770.       (print-help-return-message)
  771.       ;; Return the text we displayed.
  772.       (save-excursion (set-buffer standard-output) (buffer-string)))))
  773.  
  774. (defun where-is (definition)
  775.   "Print message listing key sequences that invoke specified command.
  776. Argument is a command definition, usually a symbol with a function definition."
  777.   (interactive "CWhere is command: ")
  778.   (let ((keys (where-is-internal definition)))
  779.     (if keys
  780.     (message "%s is on %s" definition
  781.                  (mapconcat 'key-description
  782.                             (sort keys #'(lambda (x y)
  783.                                            (< (length x) (length y))))
  784.                             ", "))
  785.         (message "%s is not on any keys" definition)))
  786.   nil)
  787.  
  788. (defun command-apropos (string)
  789.   "Like apropos but lists only symbols that are names of commands
  790. \(interactively callable functions).  Argument REGEXP is a regular expression
  791. that is matched against command symbol names.  Returns list of symbols and
  792. documentation found."
  793.   (interactive "sCommand apropos (regexp): ")
  794.   (let ((message
  795.      (let ((standard-output (get-buffer-create "*Help*")))
  796.        (print-help-return-message 'identity))))
  797.     (apropos string t 'commandp)
  798.     (and message (message message))))
  799.  
  800. (defun locate-library (library &optional nosuffix)
  801.   "Show the full path name of XEmacs library LIBRARY.
  802. This command searches the directories in `load-path' like `M-x load-library'
  803. to find the file that `M-x load-library RET LIBRARY RET' would load.
  804. Optional second arg NOSUFFIX non-nil means don't add suffixes `.elc' or `.el'
  805. to the specified name LIBRARY (a la calling `load' instead of `load-library')."
  806.   (interactive "sLocate library: \nP")
  807.   (let ((file (locate-file library load-path (if nosuffix nil ".elc:.el:"))))
  808.     (if file
  809.     (message "Library is file %s" file)
  810.       (message "No library %s in search path" library))
  811.     file))
  812.  
  813. (defun describe-syntax ()
  814.   "Describe the syntax specifications in the syntax table.
  815. The descriptions are inserted in a buffer, which is then displayed."
  816.   (interactive)
  817.   (with-output-to-temp-buffer "*Help*"
  818.     ;; defined in syntax.el
  819.     (describe-syntax-table (syntax-table) standard-output)))
  820.  
  821. (defun list-processes ()
  822.   "Display a list of all processes.
  823. \(Any processes listed as Exited or Signaled are actually eliminated
  824. after the listing is made.)"
  825.   (interactive)
  826.   (with-output-to-temp-buffer "*Process List*"
  827.     (set-buffer standard-output)
  828.     (buffer-disable-undo standard-output)
  829.     (make-local-variable 'truncate-lines)
  830.     (setq truncate-lines t)
  831.     (let ((stream standard-output))
  832.       ;;      00000000001111111111222222222233333333334444444444
  833.       ;;      01234567890123456789012345678901234567890123456789
  834.       ;; rewritten for I18N3.  This one should stay rewritten
  835.       ;; so that the dashes will line up properly.
  836.       (princ "Proc         Status   Buffer         Tty         Command\n----         ------   ------         ---         -------\n" stream)
  837.       (let ((tail (process-list)))
  838.         (while tail
  839.           (let* ((p (car tail))
  840.                  (pid (process-id p))
  841.                  (s (process-status p)))
  842.             (setq tail (cdr tail))
  843.             (princ (format "%-13s" (process-name p)) stream)
  844.             ;(if (and (eq system-type 'vax-vms)
  845.             ;         (eq s 'signal)
  846.             ;         (< (process-exit-status p) NSIG))
  847.             ;    (princ (aref sys_errlist (process-exit-status p)) stream))
  848.             (princ s stream)
  849.             (if (and (eq s 'exit) (/= (process-exit-status p) 0))
  850.                 (princ (format " %d" (process-exit-status p)) stream))
  851.             (if (memq s '(signal exit closed))
  852.                 ;; Do delete-exited-processes' work
  853.                 (delete-process p))
  854.             (indent-to 22 1)            ;####
  855.             (let ((b (process-buffer p)))
  856.               (cond ((not b)
  857.                      (princ "(none)" stream))
  858.                     ((not (buffer-name b))
  859.                      (princ "(killed)" stream))
  860.                     (t
  861.                      (princ (buffer-name b) stream))))
  862.             (indent-to 37 1)            ;####
  863.             (let ((tn (process-tty-name p)))
  864.               (cond ((not tn)
  865.                      (princ "(none)" stream))
  866.                     (t
  867.                      (princ (format "%s" tn) stream))))
  868.             (indent-to 49 1)            ;####
  869.             (if (not (integerp pid))
  870.                 (progn
  871.                   (princ "network stream connection " stream)
  872.                   (princ (car pid) stream)
  873.                   (princ "@" stream)
  874.                   (princ (cdr pid) stream))
  875.                 (let ((cmd (process-command p)))
  876.                   (while cmd
  877.                     (princ (car cmd) stream)
  878.                     (setq cmd (cdr cmd))
  879.                     (if cmd (princ " " stream)))))
  880.             (terpri stream)))))))
  881.