git.chise.org Git - chise/xemacs-chise.git.1/blob - lisp/help.el

   1 ;;; help.el --- help commands for XEmacs.
   2
   3 ;; Copyright (C) 1985, 1986, 1992-4, 1997 Free Software Foundation, Inc.
   4 ;; Copyright (C) 2001 Ben Wing.
   5
   6 ;; Maintainer: FSF
   7 ;; Keywords: help, internal, dumped
   8
   9 ;; This file is part of XEmacs.
  10
  11 ;; XEmacs is free software; you can redistribute it and/or modify it
  12 ;; under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; XEmacs is distributed in the hope that it will be useful, but
  17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with XEmacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Synched up with: FSF 19.30.
  27
  28 ;;; Commentary:
  29
  30 ;; This file is dumped with XEmacs.
  31
  32 ;; This code implements XEmacs's on-line help system, the one invoked by
  33 ;;`M-x help-for-help'.
  34
  35 ;; 06/11/1997 -- Converted to use char-after instead of broken
  36 ;;  following-char. -slb
  37
  38 ;;; Code:
  39
  40 ;; Get the macro make-help-screen when this is compiled,
  41 ;; or run interpreted, but not when the compiled code is loaded.
  42 (eval-when-compile (require 'help-macro))
  43
  44 (defgroup help nil
  45   "Support for on-line help systems."
  46   :group 'emacs)
  47
  48 (defgroup help-appearance nil
  49   "Appearance of help buffers."
  50   :group 'help)
  51
  52 (defvar help-map (let ((map (make-sparse-keymap)))
  53                    (set-keymap-name map 'help-map)
  54                    (set-keymap-prompt
  55                     map (gettext "(Type ? for further options)"))
  56                    map)
  57   "Keymap for characters following the Help key.")
  58
  59 ;; global-map definitions moved to keydefs.el
  60 (fset 'help-command help-map)
  61
  62 (define-key help-map (vector help-char) 'help-for-help)
  63 (define-key help-map "?" 'help-for-help)
  64 (define-key help-map 'help 'help-for-help)
  65 (define-key help-map '(f1) 'help-for-help)
  66
  67 (define-key help-map "\C-l" 'describe-copying) ; on \C-c in FSFmacs
  68 (define-key help-map "\C-d" 'describe-distribution)
  69 (define-key help-map "\C-w" 'describe-no-warranty)
  70 (define-key help-map "a" 'hyper-apropos) ; 'command-apropos in FSFmacs
  71 (define-key help-map "A" 'command-apropos)
  72
  73 (define-key help-map "b" 'describe-bindings)
  74 (define-key help-map "B" 'describe-beta)
  75 (define-key help-map "\C-p" 'describe-pointer)
  76
  77 (define-key help-map "C" 'customize)
  78 (define-key help-map "c" 'describe-key-briefly)
  79 (define-key help-map "k" 'describe-key)
  80
  81 (define-key help-map "d" 'describe-function)
  82 (define-key help-map "e" 'describe-last-error)
  83 (define-key help-map "f" 'describe-function)
  84
  85 (define-key help-map "F" 'xemacs-local-faq)
  86
  87 (define-key help-map "i" 'info)
  88 (define-key help-map '(control i) 'Info-query)
  89 ;; FSFmacs has Info-goto-emacs-command-node on C-f, no binding
  90 ;; for Info-elisp-ref
  91 (define-key help-map '(control c) 'Info-goto-emacs-command-node)
  92 (define-key help-map '(control k) 'Info-goto-emacs-key-command-node)
  93 (define-key help-map '(control f) 'Info-elisp-ref)
  94
  95 (define-key help-map "l" 'view-lossage)
  96
  97 (define-key help-map "m" 'describe-mode)
  98
  99 (define-key help-map "\C-n" 'view-emacs-news)
 100 (define-key help-map "n" 'view-emacs-news)
 101
 102 (define-key help-map "p" 'finder-by-keyword)
 103
 104 ;; Do this right with an autoload cookie in finder.el.
 105 ;;(autoload 'finder-by-keyword "finder"
 106 ;;  "Find packages matching a given keyword." t)
 107
 108 (define-key help-map "s" 'describe-syntax)
 109
 110 (define-key help-map "t" 'help-with-tutorial)
 111
 112 (define-key help-map "w" 'where-is)
 113
 114 (define-key help-map "v" 'describe-variable)
 115
 116 (if (fboundp 'view-last-error)
 117     (define-key help-map "e" 'view-last-error))
 118
 119
 120 (define-key help-map "q" 'help-quit)
 121
 122 ;#### This stuff was an attempt to have font locking and hyperlinks in the
 123 ;help buffer, but it doesn't really work.  Some of this stuff comes from
 124 ;FSF Emacs; but the FSF Emacs implementation is rather broken, as usual.
 125 ;What needs to happen is this:
 126 ;
 127 ; -- we probably need a "hyperlink mode" from which help-mode is derived.
 128 ; -- this means we probably need multiple inheritance of modes!
 129 ;    Thankfully this is not hard to implement; we already have the
 130 ;    ability for a keymap to have multiple parents.  However, we'd
 131 ;    have to define any multiply-inherited-from modes using a standard
 132 ;    `define-mode' construction instead of manually doing it, because
 133 ;    we don't want each guy calling `kill-all-local-variables' and
 134 ;    messing up the previous one.
 135 ; -- we need to scan the buffer ourselves (not from font-lock, because
 136 ;    the user might not have font-lock enabled) and highlight only
 137 ;    those words that are *documented* functions and variables (and
 138 ;    probably excluding words without dashes in them unless enclosed
 139 ;    in quotes, so that common words like "list" and "point" don't
 140 ;    become hyperlinks.
 141 ; -- we should *not* use font-lock keywords like below.  Instead we
 142 ;    should add the font-lock stuff ourselves during the scanning phase,
 143 ;    if font-lock is enabled in this buffer.
 144
 145 ;(defun help-follow-reference (event extent user-data)
 146 ;  (let ((symbol (intern-soft (extent-string extent))))
 147 ;    (cond ((and symbol (fboundp symbol))
 148 ;          (describe-function symbol))
 149 ;         ((and symbol (boundp symbol))
 150 ;          (describe-variable symbol))
 151 ;         (t nil))))
 152
 153 ;(defvar help-font-lock-keywords
 154 ;  (let ((name-char "[-+a-zA-Z0-9_*]") (sym-char "[-+a-zA-Z0-9_:*]"))
 155 ;    (list
 156 ;     ;;
 157 ;     ;; The symbol itself.
 158 ;     (list (concat "\\`\\(" name-char "+\\)\\(:\\)?")
 159 ;          '(1 (if (match-beginning 2)
 160 ;                  'font-lock-function-name-face
 161 ;                'font-lock-variable-name-face)
 162 ;              nil t))
 163 ;     ;;
 164 ;     ;; Words inside `' which tend to be symbol names.
 165 ;     (list (concat "`\\(" sym-char sym-char "+\\)'")
 166 ;          1 '(prog1
 167 ;                 'font-lock-reference-face
 168 ;               (add-list-mode-item (match-beginning 1)
 169 ;                              (match-end 1)
 170 ;                              nil
 171 ;                              'help-follow-reference))
 172 ;          t)
 173 ;     ;;
 174 ;     ;; CLisp `:' keywords as references.
 175 ;     (list (concat "\\<:" sym-char "+\\>") 0 'font-lock-reference-face t)))
 176 ;  "Default expressions to highlight in Help mode.")
 177
 178 ;(put 'help-mode 'font-lock-defaults '(help-font-lock-keywords))
 179
 180 (define-derived-mode help-mode view-major-mode "Help"
 181   "Major mode for viewing help text.
 182 Entry to this mode runs the normal hook `help-mode-hook'.
 183 Commands:
 184 \\{help-mode-map}"
 185   )
 186
 187 (define-key help-mode-map "q" 'help-mode-quit)
 188 (define-key help-mode-map "Q" 'help-mode-bury)
 189 (define-key help-mode-map "f" 'find-function-at-point)
 190 (define-key help-mode-map "d" 'describe-function-at-point)
 191 (define-key help-mode-map "v" 'describe-variable-at-point)
 192 (define-key help-mode-map "i" 'Info-elisp-ref)
 193 (define-key help-mode-map "c" 'customize-variable)
 194 (define-key help-mode-map [tab] 'help-next-symbol)
 195 (define-key help-mode-map [(shift tab)] 'help-prev-symbol)
 196 (define-key help-mode-map "n" 'help-next-section)
 197 (define-key help-mode-map "p" 'help-prev-section)
 198
 199 (defun describe-function-at-point ()
 200   "Describe directly the function at point in the other window."
 201   (interactive)
 202   (let ((symb (function-at-point)))
 203     (when symb
 204       (describe-function symb))))
 205
 206 (defun describe-variable-at-point ()
 207   "Describe directly the variable at point in the other window."
 208   (interactive)
 209   (let ((symb (variable-at-point)))
 210     (when symb
 211       (describe-variable symb))))
 212
 213 (defun help-next-symbol ()
 214   "Move point to the next quoted symbol."
 215   (interactive)
 216   (search-forward "`" nil t))
 217
 218 (defun help-prev-symbol ()
 219   "Move point to the previous quoted symbol."
 220   (interactive)
 221   (search-backward "'" nil t))
 222
 223 (defun help-next-section ()
 224   "Move point to the next quoted symbol."
 225   (interactive)
 226   (search-forward-regexp "^\\w+:" nil t))
 227
 228 (defun help-prev-section ()
 229   "Move point to the previous quoted symbol."
 230   (interactive)
 231   (search-backward-regexp "^\\w+:" nil t))
 232
 233 (defun help-mode-bury ()
 234   "Bury the help buffer, possibly restoring the previous window configuration."
 235   (interactive)
 236   (help-mode-quit t))
 237
 238 (defun help-mode-quit (&optional bury)
 239   "Exit from help mode, possibly restoring the previous window configuration.
 240 If the optional argument BURY is non-nil, the help buffer is buried,
 241 otherwise it is killed."
 242   (interactive)
 243   (let ((buf (current-buffer)))
 244     (cond (help-window-config
 245            (set-window-configuration help-window-config))
 246           ((not (one-window-p))
 247            (delete-window)))
 248     (if bury
 249         (bury-buffer buf)
 250       (kill-buffer buf))))
 251
 252 (defun help-quit ()
 253   (interactive)
 254   nil)
 255
 256 ;; This is a grody hack of the same genotype as `advertised-undo'; if the
 257 ;; bindings of Backspace and C-h are the same, we want the menubar to claim
 258 ;; that `info' is invoked with `C-h i', not `BS i'.
 259
 260 (defun deprecated-help-command ()
 261   (interactive)
 262   (if (eq 'help-command (key-binding "\C-h"))
 263       (setq unread-command-event (character-to-event ?\C-h))
 264     (help-for-help)))
 265
 266 ;;(define-key global-map 'backspace 'deprecated-help-command)
 267
 268 ;; help-with-tutorial moved to help-nomule.el and mule-help.el.
 269
 270 ;; used by describe-key, describe-key-briefly, insert-key-binding, etc.
 271 (defun key-or-menu-binding (key &optional menu-flag)
 272   "Return the command invoked by KEY.
 273 Like `key-binding', but handles menu events and toolbar presses correctly.
 274 KEY is any value returned by `next-command-event'.
 275 MENU-FLAG is a symbol that should be set to t if KEY is a menu event,
 276  or nil otherwise."
 277   (let (defn)
 278     (and menu-flag (set menu-flag nil))
 279     ;; If the key typed was really a menu selection, grab the form out
 280     ;; of the event object and intuit the function that would be called,
 281     ;; and describe that instead.
 282     (if (and (vectorp key) (= 1 (length key))
 283              (or (misc-user-event-p (aref key 0))
 284                  (eq (car-safe (aref key 0)) 'menu-selection)))
 285         (let ((event (aref key 0)))
 286           (setq defn (if (eventp event)
 287                          (list (event-function event) (event-object event))
 288                        (cdr event)))
 289           (and menu-flag (set menu-flag t))
 290           (when (eq (car defn) 'eval)
 291             (setq defn (car (cdr defn))))
 292           (when (eq (car-safe defn) 'call-interactively)
 293             (setq defn (car (cdr defn))))
 294           (when (and (consp defn) (null (cdr defn)))
 295             (setq defn (car defn))))
 296       ;; else
 297       (setq defn (key-binding key)))
 298     ;; kludge: if a toolbar button was pressed on, try to find the
 299     ;; binding of the toolbar button.
 300     (if (and (eq defn 'press-toolbar-button)
 301              (vectorp key)
 302              (button-press-event-p (aref key (1- (length key)))))
 303         ;; wait for the button release.  We're on shaky ground here ...
 304         (let ((event (next-command-event))
 305               button)
 306           (if (and (button-release-event-p event)
 307                    (event-over-toolbar-p event)
 308                    (eq 'release-and-activate-toolbar-button
 309                        (key-binding (vector event)))
 310                    (setq button (event-toolbar-button event)))
 311               (toolbar-button-callback button)
 312             ;; if anything went wrong, try returning the binding of
 313             ;; the button-up event, of the original binding
 314             (or (key-or-menu-binding (vector event))
 315                 defn)))
 316       ;; no toolbar kludge
 317       defn)
 318     ))
 319
 320 (defun describe-key-briefly (key &optional insert)
 321   "Print the name of the function KEY invokes.  KEY is a string.
 322 If INSERT (the prefix arg) is non-nil, insert the message in the buffer."
 323   (interactive "kDescribe key briefly: \nP")
 324   (let ((standard-output (if insert (current-buffer) t))
 325         defn menup)
 326     (setq defn (key-or-menu-binding key 'menup))
 327     (if (or (null defn) (integerp defn))
 328         (princ (format "%s is undefined" (key-description key)))
 329       ;; If it's a keyboard macro which trivially invokes another command,
 330       ;; document that instead.
 331       (if (or (stringp defn) (vectorp defn))
 332           (setq defn (or (key-binding defn)
 333                          defn)))
 334       (let ((last-event (and (vectorp key)
 335                              (aref key (1- (length key))))))
 336         (princ (format (cond (insert
 337                               "%s (%s)")
 338                              ((or (button-press-event-p last-event)
 339                                   (button-release-event-p last-event))
 340                               (gettext "%s at that spot runs the command %s"))
 341                              (t
 342                               (gettext "%s runs the command %s")))
 343                        ;; This used to say 'This menu item' but it
 344                        ;; could also be a scrollbar event.  We can't
 345                        ;; distinguish at the moment.
 346                        (if menup
 347                            (if insert "item" "This item")
 348                          (key-description key))
 349                        (if (symbolp defn) defn (prin1-to-string defn))))))))
 350
 351 ;; #### this is a horrible piece of shit function that should
 352 ;; not exist.  In FSF 19.30 this function has gotten three times
 353 ;; as long and has tons and tons of dumb shit checking
 354 ;; special-display-buffer-names and such crap.  I absolutely
 355 ;; refuse to insert that Ebolification here.  I wanted to delete
 356 ;; this function entirely but Mly bitched.
 357 ;;
 358 ;; If your user-land code calls this function, rewrite it to
 359 ;; call with-displaying-help-buffer.
 360
 361 (defun print-help-return-message (&optional function)
 362   "Display or return message saying how to restore windows after help command.
 363 Computes a message and applies the optional argument FUNCTION to it.
 364 If FUNCTION is nil, applies `message' to it, thus printing it."
 365   (and (not (get-buffer-window standard-output))
 366        (funcall
 367         (or function 'message)
 368         (concat
 369          (substitute-command-keys
 370           (if (one-window-p t)
 371               (if pop-up-windows
 372                   (gettext "Type \\[delete-other-windows] to remove help window.")
 373                 (gettext "Type \\[switch-to-buffer] RET to remove help window."))
 374    (gettext "Type \\[switch-to-buffer-other-window] RET to restore the other window.")))
 375          (substitute-command-keys
 376           (gettext "  \\[scroll-other-window] to scroll the help."))))))
 377
 378 (defcustom help-selects-help-window t
 379   "*If nil, use the \"old Emacs\" behavior for Help buffers.
 380 This just displays the buffer in another window, rather than selecting
 381 the window."
 382   :type 'boolean
 383   :group 'help-appearance)
 384
 385 (defcustom help-max-help-buffers 10
 386   "*Maximum help buffers to allow before they start getting killed.
 387 If this is a positive integer, before a help buffer is displayed
 388 by `with-displaying-help-buffer', any excess help buffers which
 389 are not being displayed are first killed.  Otherwise, if it is
 390 zero or nil, only one help buffer, \"*Help*\" is ever used."
 391   :type '(choice integer (const :tag "None" nil))
 392   :group 'help-appearance)
 393
 394 (defvar help-buffer-list nil
 395   "List of help buffers used by `help-register-and-maybe-prune-excess'")
 396
 397 (defun help-register-and-maybe-prune-excess (newbuf)
 398   "Register use of a help buffer and possibly kill any excess ones."
 399   ;; remove new buffer from list
 400   (setq help-buffer-list (remove newbuf help-buffer-list))
 401   ;; maybe kill excess help buffers
 402   (if (and (integerp help-max-help-buffers)
 403            (> (length help-buffer-list) help-max-help-buffers))
 404       (let ((keep-list nil)
 405             (num-kill (- (length help-buffer-list)
 406                          help-max-help-buffers)))
 407         (while help-buffer-list
 408           (let ((buf (car help-buffer-list)))
 409             (if (and (or (equal buf newbuf) (get-buffer buf))
 410                      (string-match "^*Help" buf)
 411                      (save-excursion (set-buffer buf)
 412                                      (eq major-mode 'help-mode)))
 413                 (if (and (>= num-kill (length help-buffer-list))
 414                          (not (get-buffer-window buf t t)))
 415                     (kill-buffer buf)
 416                   (setq keep-list (cons buf keep-list)))))
 417           (setq help-buffer-list (cdr help-buffer-list)))
 418         (setq help-buffer-list (nreverse keep-list))))
 419   ;; push new buffer
 420   (setq help-buffer-list (cons newbuf help-buffer-list)))
 421
 422 (defvar help-buffer-prefix-string "Help"
 423   "Initial string to use in constructing help buffer names.
 424 You should never set this directory, only let-bind it.")
 425
 426 (defun help-buffer-name (name)
 427   "Return a name for a Help buffer using string NAME for context."
 428   (if (and (integerp help-max-help-buffers)
 429            (> help-max-help-buffers 0)
 430            (stringp name))
 431       (if help-buffer-prefix-string
 432           (format "*%s: %s*" help-buffer-prefix-string name)
 433         (format "*%s*" name))
 434     (format "*%s*" help-buffer-prefix-string)))
 435
 436 ;; Use this function for displaying help when C-h something is pressed
 437 ;; or in similar situations.  Do *not* use it when you are displaying
 438 ;; a help message and then prompting for input in the minibuffer --
 439 ;; this macro usually selects the help buffer, which is not what you
 440 ;; want in those situations.
 441
 442 ;; #### Should really be a macro to eliminate the requirement of
 443 ;; caller to code a lambda form in THUNK -- mrb
 444
 445 ;; #### BEFORE you rush to make this a macro, think about backward
 446 ;; compatibility.  The right way would be to create a macro with
 447 ;; another name (which is a shame, because w-d-h-b is a perfect name
 448 ;; for a macro) that uses with-displaying-help-buffer internally.
 449
 450 (defcustom mode-for-help 'help-mode
 451   "*Mode that help buffers are put into.")
 452
 453 (defvar help-sticky-window nil
 454 ;; Window into which help buffers will be displayed, rather than
 455 ;; always searching for a new one.  This is INTERNAL and liable to
 456 ;; change its interface and/or name at any moment.  It should be
 457 ;; bound, not set.
 458 )
 459
 460 (defvar help-window-config nil)
 461
 462 (make-variable-buffer-local 'help-window-config)
 463 (put 'help-window-config 'permanent-local t)
 464
 465 (defun with-displaying-help-buffer (thunk &optional name)
 466   "Form which makes a help buffer with given NAME and evaluates BODY there.
 467 The actual name of the buffer is generated by the function `help-buffer-name'."
 468   (let* ((winconfig (current-window-configuration))
 469          (was-one-window (one-window-p))
 470          (buffer-name (help-buffer-name name))
 471          (help-not-visible
 472           (not (and (windows-of-buffer buffer-name) ;shortcut
 473                     (memq (selected-frame)
 474                           (mapcar 'window-frame
 475                                   (windows-of-buffer buffer-name)))))))
 476     (help-register-and-maybe-prune-excess buffer-name)
 477     ;; if help-sticky-window is bogus or deleted, get rid of it.
 478     (if (and help-sticky-window (or (not (windowp help-sticky-window))
 479                                     (not (window-live-p help-sticky-window))))
 480         (setq help-sticky-window nil))
 481     (prog1
 482         (let ((temp-buffer-show-function
 483                (if help-sticky-window
 484                    #'(lambda (buffer)
 485                        (set-window-buffer help-sticky-window buffer))
 486                  temp-buffer-show-function)))
 487           (with-output-to-temp-buffer buffer-name
 488             (prog1 (funcall thunk)
 489               (save-excursion
 490                 (set-buffer standard-output)
 491                 (funcall mode-for-help)))))
 492       (let ((helpwin (get-buffer-window buffer-name)))
 493         (when helpwin
 494           ;; If the *Help* buffer is already displayed on this
 495           ;; frame, don't override the previous configuration
 496           (when help-not-visible
 497             (with-current-buffer (window-buffer helpwin)
 498               (setq help-window-config winconfig)))
 499           (when help-selects-help-window
 500             (select-window helpwin))
 501           (cond ((eq helpwin (selected-window))
 502                  (display-message 'command
 503                    (substitute-command-keys "Type \\[help-mode-quit] to remove help window, \\[scroll-up] to scroll the help.")))
 504                 (was-one-window
 505                  (display-message 'command
 506                    (substitute-command-keys "Type \\[delete-other-windows] to remove help window, \\[scroll-other-window] to scroll the help.")))
 507                 (t
 508                  (display-message 'command
 509                    (substitute-command-keys "Type \\[switch-to-buffer-other-window] to restore the other window, \\[scroll-other-window] to scroll the help.")))))))))
 510
 511 (defun describe-key (key)
 512   "Display documentation of the function invoked by KEY.
 513 KEY is a string, or vector of events.
 514 When called interactively, KEY may also be a menu selection."
 515   (interactive "kDescribe key: ")
 516   (let ((defn (key-or-menu-binding key))
 517         (key-string (key-description key)))
 518     (if (or (null defn) (integerp defn))
 519         (message "%s is undefined" key-string)
 520       (with-displaying-help-buffer
 521        (lambda ()
 522          (princ key-string)
 523          (princ " runs ")
 524          (if (symbolp defn)
 525              (princ (format "`%s'" defn))
 526            (princ defn))
 527          (princ "\n\n")
 528          (cond ((or (stringp defn) (vectorp defn))
 529                 (let ((cmd (key-binding defn)))
 530                   (if (not cmd)
 531                       (princ "a keyboard macro")
 532                     (progn
 533                       (princ "a keyboard macro which runs the command ")
 534                       (princ cmd)
 535                       (princ ":\n\n")
 536                       (if (documentation cmd) (princ (documentation cmd)))))))
 537                ((and (consp defn) (not (eq 'lambda (car-safe defn))))
 538                 (let ((describe-function-show-arglist nil))
 539                   (describe-function-1 (car defn))))
 540                ((symbolp defn)
 541                 (describe-function-1 defn))
 542                ((documentation defn)
 543                 (princ (documentation defn)))
 544                (t
 545                 (princ "not documented"))))
 546        (format "key `%s'" key-string)))))
 547
 548 (defun describe-mode ()
 549   "Display documentation of current major mode and minor modes.
 550 For this to work correctly for a minor mode, the mode's indicator variable
 551 \(listed in `minor-mode-alist') must also be a function whose documentation
 552 describes the minor mode."
 553   (interactive)
 554   (with-displaying-help-buffer
 555    (lambda ()
 556      ;; XEmacs change: print the major-mode documentation before
 557      ;; the minor modes.
 558      (princ mode-name)
 559      (princ " mode:\n")
 560      (princ (documentation major-mode))
 561      (princ "\n\n----\n\n")
 562      (let ((minor-modes minor-mode-alist))
 563        (while minor-modes
 564          (let* ((minor-mode (car (car minor-modes)))
 565                 (indicator (car (cdr (car minor-modes)))))
 566            ;; Document a minor mode if it is listed in minor-mode-alist,
 567            ;; bound locally in this buffer, non-nil, and has a function
 568            ;; definition.
 569            (if (and (boundp minor-mode)
 570                     (symbol-value minor-mode)
 571                     (fboundp minor-mode))
 572                (let ((pretty-minor-mode minor-mode))
 573                  (if (string-match "-mode\\'" (symbol-name minor-mode))
 574                      (setq pretty-minor-mode
 575                            (capitalize
 576                             (substring (symbol-name minor-mode)
 577                                        0 (match-beginning 0)))))
 578                  (while (and (consp indicator) (extentp (car indicator)))
 579                    (setq indicator (cdr indicator)))
 580                  (while (and indicator (symbolp indicator))
 581                    (setq indicator (symbol-value indicator)))
 582                  (princ (format "%s minor mode (indicator%s):\n"
 583                                 pretty-minor-mode indicator))
 584                  (princ (documentation minor-mode))
 585                  (princ "\n\n----\n\n"))))
 586          (setq minor-modes (cdr minor-modes)))))
 587    (format "%s mode" mode-name)))
 588
 589 ;; So keyboard macro definitions are documented correctly
 590 (fset 'defining-kbd-macro (symbol-function 'start-kbd-macro))
 591
 592 ;; view a read-only file intelligently
 593 (defun Help-find-file (file)
 594   (if (fboundp 'view-file)
 595       (view-file file)
 596     (find-file-read-only file)
 597     (goto-char (point-min))))
 598
 599 (defun describe-distribution ()
 600   "Display info on how to obtain the latest version of XEmacs."
 601   (interactive)
 602   (Help-find-file (locate-data-file "DISTRIB")))
 603
 604 (defun describe-beta ()
 605   "Display info on how to deal with Beta versions of XEmacs."
 606   (interactive)
 607   (Help-find-file (locate-data-file "BETA")))
 608
 609 (defun describe-copying ()
 610   "Display info on how you may redistribute copies of XEmacs."
 611   (interactive)
 612   (Help-find-file (locate-data-file "COPYING")))
 613
 614 (defun describe-pointer ()
 615   "Show a list of all defined mouse buttons, and their definitions."
 616   (interactive)
 617   (describe-bindings nil t))
 618
 619 (defun describe-project ()
 620   "Display info on the GNU project."
 621   (interactive)
 622   (Help-find-file (locate-data-file "GNU")))
 623
 624 (defun describe-no-warranty ()
 625   "Display info on all the kinds of warranty XEmacs does NOT have."
 626   (interactive)
 627   (describe-copying)
 628   (let (case-fold-search)
 629     (search-forward "NO WARRANTY")
 630     (recenter 0)))
 631
 632 (defun describe-bindings (&optional prefix mouse-only-p)
 633   "Show a list of all defined keys, and their definitions.
 634 The list is put in a buffer, which is displayed.
 635 If optional first argument PREFIX is supplied, only commands
 636 which start with that sequence of keys are described.
 637 If optional second argument MOUSE-ONLY-P (prefix arg, interactively)
 638 is non-nil then only the mouse bindings are displayed."
 639   (interactive (list nil current-prefix-arg))
 640   (with-displaying-help-buffer
 641    (lambda ()
 642      (describe-bindings-1 prefix mouse-only-p))
 643    (format "bindings for %s" major-mode)))
 644
 645 (defun describe-bindings-1 (&optional prefix mouse-only-p)
 646   (let ((heading (if mouse-only-p
 647             (gettext "button          binding\n------          -------\n")
 648             (gettext "key             binding\n---             -------\n")))
 649         (buffer (current-buffer))
 650         (minor minor-mode-map-alist)
 651         (extent-maps (mapcar-extents
 652                       'extent-keymap
 653                       nil (current-buffer) (point) (point) nil 'keymap))
 654         (local (current-local-map))
 655         (shadow '()))
 656     (set-buffer standard-output)
 657     (while extent-maps
 658       (insert "Bindings for Text Region:\n"
 659               heading)
 660       (describe-bindings-internal
 661        (car extent-maps) nil shadow prefix mouse-only-p)
 662        (insert "\n")
 663        (setq shadow (cons (car extent-maps) shadow)
 664              extent-maps (cdr extent-maps)))
 665     (while minor
 666       (let ((sym (car (car minor)))
 667             (map (cdr (car minor))))
 668         (if (symbol-value-in-buffer sym buffer nil)
 669             (progn
 670               (insert (format "Minor Mode Bindings for `%s':\n"
 671                               sym)
 672                       heading)
 673               (describe-bindings-internal map nil shadow prefix mouse-only-p)
 674               (insert "\n")
 675               (setq shadow (cons map shadow))))
 676         (setq minor (cdr minor))))
 677     (if local
 678         (progn
 679           (insert "Local Bindings:\n" heading)
 680           (describe-bindings-internal local nil shadow prefix mouse-only-p)
 681           (insert "\n")
 682           (setq shadow (cons local shadow))))
 683     (insert "Global Bindings:\n" heading)
 684     (describe-bindings-internal (current-global-map)
 685                                 nil shadow prefix mouse-only-p)
 686     (when (and prefix function-key-map (not mouse-only-p))
 687       (insert "\nFunction key map translations:\n" heading)
 688       (describe-bindings-internal function-key-map nil nil
 689                                   prefix mouse-only-p))
 690     (set-buffer buffer)
 691     standard-output))
 692
 693 (defun describe-prefix-bindings ()
 694   "Describe the bindings of the prefix used to reach this command.
 695 The prefix described consists of all but the last event
 696 of the key sequence that ran this command."
 697   (interactive)
 698   (let* ((key (this-command-keys))
 699          (prefix (make-vector (1- (length key)) nil))
 700          i)
 701     (setq i 0)
 702     (while (< i (length prefix))
 703       (aset prefix i (aref key i))
 704       (setq i (1+ i)))
 705     (with-displaying-help-buffer
 706      (lambda ()
 707        (princ "Key bindings starting with ")
 708        (princ (key-description prefix))
 709        (princ ":\n\n")
 710        (describe-bindings-1 prefix nil))
 711      (format "%s prefix" (key-description prefix)))))
 712
 713 ;; Make C-h after a prefix, when not specifically bound,
 714 ;; run describe-prefix-bindings.
 715 (setq prefix-help-command 'describe-prefix-bindings)
 716
 717 (defun describe-installation ()
 718   "Display a buffer showing information about this XEmacs was compiled."
 719   (interactive)
 720   (if (and (boundp 'Installation-string)
 721            (stringp Installation-string))
 722       (with-displaying-help-buffer
 723        (lambda ()
 724          (princ
 725           (if (fboundp 'decode-coding-string)
 726               (decode-coding-string Installation-string 'automatic-conversion)
 727             Installation-string)))
 728        "Installation")
 729     (error "No Installation information available.")))
 730
 731 (defun view-emacs-news ()
 732   "Display info on recent changes to XEmacs."
 733   (interactive)
 734   (Help-find-file (locate-data-file "NEWS")))
 735
 736 (defun xemacs-www-page ()
 737   "Go to the XEmacs World Wide Web page."
 738   (interactive)
 739   (if (fboundp 'browse-url)
 740       (browse-url "http://www.xemacs.org/")
 741     (error "xemacs-www-page requires browse-url")))
 742
 743 (defun xemacs-www-faq ()
 744   "View the latest and greatest XEmacs FAQ using the World Wide Web."
 745   (interactive)
 746   (if (fboundp 'browse-url)
 747       (browse-url "http://www.xemacs.org/faq/index.html")
 748     (error "xemacs-www-faq requires browse-url")))
 749
 750 (defun xemacs-local-faq ()
 751   "View the local copy of the XEmacs FAQ.
 752 If you have access to the World Wide Web, you should use `xemacs-www-faq'
 753 instead, to ensure that you get the most up-to-date information."
 754   (interactive)
 755   (save-window-excursion
 756     (info)
 757     (Info-find-node "xemacs-faq" "Top"))
 758   (switch-to-buffer "*info*"))
 759
 760 (defun view-sample-init-el ()
 761   "Display the sample init.el file."
 762   (interactive)
 763   (Help-find-file (locate-data-file "sample.init.el")))
 764
 765 (defcustom view-lossage-key-count 100
 766   "*Number of keys `view-lossage' shows.
 767 The maximum number of available keys is governed by `recent-keys-ring-size'."
 768   :type 'integer
 769   :group 'help)
 770
 771 (defcustom view-lossage-message-count 100
 772   "*Number of minibuffer messages `view-lossage' shows."
 773   :type 'integer
 774   :group 'help)
 775
 776 (defun print-recent-messages (n)
 777   "Print N most recent messages to standard-output, most recent first.
 778 If N is nil, all messages will be printed."
 779   (save-excursion
 780     (let ((buffer (get-buffer-create " *Message-Log*"))
 781           oldpoint extent)
 782       (goto-char (point-max buffer) buffer)
 783       (set-buffer standard-output)
 784       (while (and (not (bobp buffer))
 785                   (or (null n) (>= (decf n) 0)))
 786         (setq oldpoint (point buffer))
 787         (setq extent (extent-at oldpoint buffer
 788                                 'message-multiline nil 'before))
 789         ;; If the message was multiline, move all the way to the
 790         ;; beginning.
 791         (if extent
 792             (goto-char (extent-start-position extent) buffer)
 793           (forward-line -1 buffer))
 794         (insert-buffer-substring buffer (point buffer) oldpoint)))))
 795
 796 (defun view-lossage ()
 797   "Display recent input keystrokes and recent minibuffer messages.
 798 The number of keys shown is controlled by `view-lossage-key-count'.
 799 The number of messages shown is controlled by `view-lossage-message-count'."
 800   (interactive)
 801   (with-displaying-help-buffer
 802    (lambda ()
 803      (princ (key-description (recent-keys view-lossage-key-count)))
 804      (save-excursion
 805        (set-buffer standard-output)
 806        (goto-char (point-min))
 807        (insert "Recent keystrokes:\n\n")
 808        (while (progn (move-to-column 50) (not (eobp)))
 809          (search-forward " " nil t)
 810          (insert "\n")))
 811      ;; XEmacs addition: copy the messages from " *Message-Log*",
 812      ;; reversing their order and handling multiline messages
 813      ;; correctly.
 814      (princ "\n\n\nRecent minibuffer messages (most recent first):\n\n")
 815      (print-recent-messages view-lossage-message-count))
 816    "lossage"))
 817
 818 (define-function 'help 'help-for-help)
 819
 820 (make-help-screen help-for-help
 821   "A B C F I K L M N P S T V W C-c C-d C-f C-i C-k C-n C-w;  ? for more help:"
 822   "Type a Help option:
 823 \(Use SPC or DEL to scroll through this text.  Type \\<help-map>\\[help-quit] to exit the Help command.)
 824
 825 \\[hyper-apropos]       Type a substring; it shows a hypertext list of
 826         functions and variables that contain that substring.
 827         See also the `apropos' command.
 828 \\[command-apropos]     Type a substring; it shows a list of commands
 829         (interactively callable functions) that contain that substring.
 830 \\[describe-bindings]   Table of all key bindings.
 831 \\[describe-key-briefly]        Type a command key sequence;
 832         it displays the function name that sequence runs.
 833 \\[customize]   Customize Emacs options.
 834 \\[Info-goto-emacs-command-node]        Type a function name; it displays the Info node for that command.
 835 \\[describe-function]   Type a function name; it shows its documentation.
 836 \\[Info-elisp-ref]      Type a function name; it jumps to the full documentation
 837         in the XEmacs Lisp Programmer's Manual.
 838 \\[xemacs-local-faq]    Local copy of the XEmacs FAQ.
 839 \\[info]        Info documentation reader.
 840 \\[Info-query]  Type an Info file name; it displays it in Info reader.
 841 \\[describe-key]        Type a command key sequence;
 842         it displays the documentation for the command bound to that key.
 843 \\[Info-goto-emacs-key-command-node]    Type a command key sequence;
 844         it displays the Info node for the command bound to that key.
 845 \\[view-lossage]        Recent input keystrokes and minibuffer messages.
 846 \\[describe-mode]       Documentation of current major and minor modes.
 847 \\[view-emacs-news]     News of recent XEmacs changes.
 848 \\[finder-by-keyword]   Type a topic keyword; it finds matching packages.
 849 \\[describe-pointer]    Table of all mouse-button bindings.
 850 \\[describe-syntax]     Contents of syntax table with explanations.
 851 \\[help-with-tutorial]  XEmacs learn-by-doing tutorial.
 852 \\[describe-variable]   Type a variable name; it displays its documentation and value.
 853 \\[where-is]    Type a command name; it displays which keystrokes invoke that command.
 854 \\[describe-distribution]       XEmacs ordering information.
 855 \\[describe-no-warranty]        Information on absence of warranty for XEmacs.
 856 \\[describe-copying]    XEmacs copying permission (General Public License)."
 857   help-map)
 858
 859 (defmacro with-syntax-table (syntab &rest body)
 860   "Evaluate BODY with the SYNTAB as the current syntax table."
 861   `(let ((stab (syntax-table)))
 862      (unwind-protect
 863          (progn
 864            (set-syntax-table (copy-syntax-table ,syntab))
 865            ,@body)
 866        (set-syntax-table stab))))
 867 (put 'with-syntax-table 'lisp-indent-function 1)
 868 (put 'with-syntax-table 'edebug-form-spec '(form body))
 869
 870 (defun function-called-at-point ()
 871   "Return the function which is called by the list containing point.
 872 If that gives no function, return the function whose name is around point.
 873 If that doesn't give a function, return nil."
 874   (or (ignore-errors
 875         (save-excursion
 876           (save-restriction
 877             (narrow-to-region (max (point-min) (- (point) 1000))
 878                               (point-max))
 879             (backward-up-list 1)
 880             (forward-char 1)
 881             (let (obj)
 882               (setq obj (read (current-buffer)))
 883               (and (symbolp obj) (fboundp obj) obj)))))
 884       (ignore-errors
 885         (with-syntax-table emacs-lisp-mode-syntax-table
 886           (save-excursion
 887             (or (not (zerop (skip-syntax-backward "_w")))
 888                 (eq (char-syntax (char-after (point))) ?w)
 889                 (eq (char-syntax (char-after (point))) ?_)
 890                 (forward-sexp -1))
 891             (skip-chars-forward "`'")
 892             (let ((obj (read (current-buffer))))
 893               (and (symbolp obj) (fboundp obj) obj)))))))
 894
 895 (defun function-at-point ()
 896   "Return the function whose name is around point.
 897 If that gives no function, return the function which is called by the
 898 list containing point.  If that doesn't give a function, return nil."
 899   (or (ignore-errors
 900         (with-syntax-table emacs-lisp-mode-syntax-table
 901           (save-excursion
 902             (or (not (zerop (skip-syntax-backward "_w")))
 903                 (eq (char-syntax (char-after (point))) ?w)
 904                 (eq (char-syntax (char-after (point))) ?_)
 905                 (forward-sexp -1))
 906             (skip-chars-forward "`'")
 907             (let ((obj (read (current-buffer))))
 908               (and (symbolp obj) (fboundp obj) obj)))))
 909       (ignore-errors
 910         (save-excursion
 911           (save-restriction
 912             (narrow-to-region (max (point-min) (- (point) 1000))
 913                               (point-max))
 914             (backward-up-list 1)
 915             (forward-char 1)
 916             (let (obj)
 917               (setq obj (read (current-buffer)))
 918               (and (symbolp obj) (fboundp obj) obj)))))))
 919
 920 (defun function-at-event (event)
 921   "Return the function whose name is around the position of EVENT.
 922 EVENT should be a mouse event.  When calling from a popup or context menu,
 923 use `last-popup-menu-event' to find out where the mouse was clicked.
 924 \(You cannot use (interactive \"e\"), unfortunately.  This returns a
 925 misc-user event.)
 926
 927 If the event contains no position, or the position is not over text, or
 928 there is no function around that point, nil is returned."
 929   (if (and event (event-buffer event) (event-point event))
 930       (save-excursion
 931         (set-buffer (event-buffer event))
 932         (goto-char (event-point event))
 933         (function-at-point))))
 934
 935 ;; Default to nil for the non-hackers?  Not until we find a way to
 936 ;; distinguish hackers from non-hackers automatically!
 937 (defcustom describe-function-show-arglist t
 938   "*If non-nil, describe-function will show its arglist,
 939 unless the function is autoloaded."
 940   :type 'boolean
 941   :group 'help-appearance)
 942
 943 (defun describe-symbol-find-file (symbol)
 944   (loop for (file . load-data) in load-history
 945     do (when (memq symbol load-data)
 946          (return file))))
 947
 948 (define-obsolete-function-alias
 949   'describe-function-find-file
 950   'describe-symbol-find-file)
 951
 952 (defun describe-function (function)
 953   "Display the full documentation of FUNCTION (a symbol).
 954 When run interactively, it defaults to any function found by
 955 `function-at-point'."
 956   (interactive
 957     (let* ((fn (function-at-point))
 958            (val (let ((enable-recursive-minibuffers t))
 959                   (completing-read
 960                     (if fn
 961                         (format (gettext "Describe function (default %s): ")
 962                                 fn)
 963                         (gettext "Describe function: "))
 964                     obarray 'fboundp t nil 'function-history
 965                     (symbol-name fn)))))
 966       (list (intern val))))
 967   (with-displaying-help-buffer
 968    (lambda ()
 969      (describe-function-1 function)
 970      ;; Return the text we displayed.
 971      (buffer-string nil nil standard-output))
 972     (format "function `%s'" function)))
 973
 974 (defun function-obsolete-p (function)
 975   "Return non-nil if FUNCTION is obsolete."
 976   (not (null (get function 'byte-obsolete-info))))
 977
 978 (defun function-obsoleteness-doc (function)
 979   "If FUNCTION is obsolete, return a string describing this."
 980   (let ((obsolete (get function 'byte-obsolete-info)))
 981     (if obsolete
 982         (format "Obsolete; %s"
 983                 (if (stringp (car obsolete))
 984                     (car obsolete)
 985                   (format "use `%s' instead." (car obsolete)))))))
 986
 987 (defun function-compatible-p (function)
 988   "Return non-nil if FUNCTION is present for Emacs compatibility."
 989   (not (null (get function 'byte-compatible-info))))
 990
 991 (defun function-compatibility-doc (function)
 992   "If FUNCTION is Emacs compatible, return a string describing this."
 993   (let ((compatible (get function 'byte-compatible-info)))
 994     (if compatible
 995         (format "Emacs Compatible; %s"
 996                 (if (stringp (car compatible))
 997                     (car compatible)
 998                   (format "use `%s' instead." (car compatible)))))))
 999
1000 ;Here are all the possibilities below spelled out, for the benefit
1001 ;of the I18N3 snarfer.
1002 ;
1003 ;(gettext "a built-in function")
1004 ;(gettext "an interactive built-in function")
1005 ;(gettext "a built-in macro")
1006 ;(gettext "an interactive built-in macro")
1007 ;(gettext "a compiled Lisp function")
1008 ;(gettext "an interactive compiled Lisp function")
1009 ;(gettext "a compiled Lisp macro")
1010 ;(gettext "an interactive compiled Lisp macro")
1011 ;(gettext "a Lisp function")
1012 ;(gettext "an interactive Lisp function")
1013 ;(gettext "a Lisp macro")
1014 ;(gettext "an interactive Lisp macro")
1015 ;(gettext "a mocklisp function")
1016 ;(gettext "an interactive mocklisp function")
1017 ;(gettext "a mocklisp macro")
1018 ;(gettext "an interactive mocklisp macro")
1019 ;(gettext "an autoloaded Lisp function")
1020 ;(gettext "an interactive autoloaded Lisp function")
1021 ;(gettext "an autoloaded Lisp macro")
1022 ;(gettext "an interactive autoloaded Lisp macro")
1023
1024 ;; taken out of `describe-function-1'
1025 (defun function-arglist (function)
1026   "Return a string giving the argument list of FUNCTION.
1027 For example:
1028
1029         (function-arglist 'function-arglist)
1030         => (function-arglist FUNCTION)
1031
1032 This function is used by `describe-function-1' to list function
1033 arguments in the standard Lisp style."
1034   (let* ((fnc (indirect-function function))
1035          (fndef (if (eq (car-safe fnc) 'macro)
1036                     (cdr fnc)
1037                   fnc))
1038          (arglist
1039           (cond ((compiled-function-p fndef)
1040                  (compiled-function-arglist fndef))
1041                 ((eq (car-safe fndef) 'lambda)
1042                  (nth 1 fndef))
1043                 ((subrp fndef)
1044                  (let* ((doc (documentation function))
1045                         (args (and (string-match
1046                                     "[\n\t ]*\narguments: ?(\\(.*\\))\n?\\'"
1047                                     doc)
1048                                    (match-string 1 doc))))
1049                    ;; If there are no arguments documented for the
1050                    ;; subr, rather don't print anything.
1051                    (cond ((null args) t)
1052                          ((equal args "") nil)
1053                          (args))))
1054                 (t t))))
1055     (cond ((listp arglist)
1056            (prin1-to-string
1057             (cons function (mapcar (lambda (arg)
1058                                      (if (memq arg '(&optional &rest))
1059                                          arg
1060                                        (intern (upcase (symbol-name arg)))))
1061                                    arglist))
1062             t))
1063           ((stringp arglist)
1064            (format "(%s %s)" function arglist)))))
1065
1066 (defun function-documentation (function &optional strip-arglist)
1067   "Return a string giving the documentation for FUNCTION, if any.
1068 If the optional argument STRIP-ARGLIST is non-nil, remove the arglist
1069 part of the documentation of internal subroutines."
1070   (let ((doc (condition-case nil
1071                  (or (documentation function)
1072                      (gettext "not documented"))
1073                (void-function ""))))
1074     (if (and strip-arglist
1075              (string-match "[\n\t ]*\narguments: ?(\\(.*\\))\n?\\'" doc))
1076         (setq doc (substring doc 0 (match-beginning 0))))
1077     doc))
1078 ;  (let ((name-char "[-+a-zA-Z0-9_*]") (sym-char "[-+a-zA-Z0-9_:*]"))
1079 ;    (list
1080 ;     ;;
1081 ;     ;; The symbol itself.
1082 ;     (list (concat "\\`\\(" name-char "+\\)\\(:\\)?")
1083 ;          '(1 (if (match-beginning 2)
1084 ;                  'font-lock-function-name-face
1085 ;                'font-lock-variable-name-face)
1086 ;              nil t))
1087 ;     ;;
1088 ;     ;; Words inside `' which tend to be symbol names.
1089 ;     (list (concat "`\\(" sym-char sym-char "+\\)'")
1090 ;          1 '(prog1
1091 ;                 'font-lock-reference-face
1092 ;               (add-list-mode-item (match-beginning 1)
1093 ;                              (match-end 1)
1094 ;                              nil
1095 ;                              'help-follow-reference))
1096 ;          t)
1097 ;     ;;
1098 ;     ;; CLisp `:' keywords as references.
1099 ;     (list (concat "\\<:" sym-char "+\\>") 0 'font-lock-reference-face t)))
1100
1101 ;; replacement for `princ' that puts the text in the specified face,
1102 ;; if possible
1103 (defun Help-princ-face (object face)
1104   (cond ((bufferp standard-output)
1105         (let ((opoint (point standard-output)))
1106           (princ object)
1107           (put-nonduplicable-text-property opoint (point standard-output)
1108                                            'face face standard-output)))
1109        ((markerp standard-output)
1110         (let ((buf (marker-buffer standard-output))
1111               (pos (marker-position standard-output)))
1112           (princ object)
1113           (put-nonduplicable-text-property
1114            pos (marker-position standard-output) 'face face buf)))
1115        (t princ object)))
1116
1117 ;; replacement for `prin1' that puts the text in the specified face,
1118 ;; if possible
1119 (defun Help-prin1-face (object face)
1120   (cond ((bufferp standard-output)
1121         (let ((opoint (point standard-output)))
1122           (prin1 object)
1123           (put-nonduplicable-text-property opoint (point standard-output)
1124                                            'face face standard-output)))
1125        ((markerp standard-output)
1126         (let ((buf (marker-buffer standard-output))
1127               (pos (marker-position standard-output)))
1128           (prin1 object)
1129           (put-nonduplicable-text-property
1130            pos (marker-position standard-output) 'face face buf)))
1131        (t prin1 object)))
1132
1133 (defvar help-symbol-regexp
1134   (let ((sym-char "[+a-zA-Z0-9_:*]")
1135         (sym-char-no-dash "[-+a-zA-Z0-9_:*]"))
1136     (concat "\\("
1137             ;; a symbol with a - in it.
1138             "\\<\\(" sym-char-no-dash "+\\(-" sym-char-no-dash "+\\)+\\)\\>"
1139             "\\|"
1140             "`\\(" sym-char "+\\)'"
1141             "\\)")))
1142
1143 (defun help-symbol-run-function-1 (ev ex fun)
1144   (let ((help-sticky-window
1145          ;; if we were called from a help buffer, make sure the new help
1146          ;; goes in the same window.
1147          (if (and (event-buffer ev)
1148                   (symbol-value-in-buffer 'help-window-config
1149                                           (event-buffer ev)))
1150              (event-window ev)
1151            help-sticky-window)))
1152     (funcall fun (extent-property ex 'help-symbol))))
1153
1154 (defun help-symbol-run-function (fun)
1155   (let ((ex (extent-at-event last-popup-menu-event 'help-symbol)))
1156     (when ex
1157       (help-symbol-run-function-1 last-popup-menu-event ex fun))))
1158
1159 (defvar help-symbol-function-context-menu
1160   '(["View %_Documentation" (help-symbol-run-function 'describe-function)]
1161     ["Find %_Function Source" (help-symbol-run-function 'find-function)]
1162     ["Find %_Tag" (help-symbol-run-function 'find-tag)]
1163     ))
1164
1165 (defvar help-symbol-variable-context-menu
1166   '(["View %_Documentation" (help-symbol-run-function 'describe-variable)]
1167     ["Find %_Variable Source" (help-symbol-run-function 'find-variable)]
1168     ["Find %_Tag" (help-symbol-run-function 'find-tag)]
1169     ))
1170
1171 (defvar help-symbol-function-and-variable-context-menu
1172   '(["View Function %_Documentation" (help-symbol-run-function
1173                                       'describe-function)]
1174     ["View Variable D%_ocumentation" (help-symbol-run-function
1175                                       'describe-variable)]
1176     ["Find %_Function Source" (help-symbol-run-function 'find-function)]
1177     ["Find %_Variable Source" (help-symbol-run-function 'find-variable)]
1178     ["Find %_Tag" (help-symbol-run-function 'find-tag)]
1179     ))
1180
1181 (defun frob-help-extents (buffer)
1182   ;; Look through BUFFER, starting at the buffer's point and continuing
1183   ;; till end of file, and find documented functions and variables.
1184   ;; any such symbol found is tagged with an extent, that sets up these
1185   ;; properties:
1186   ;; 1. mouse-face is 'highlight (so the extent gets highlighted on mouse over)
1187   ;; 2. help-symbol is the name of the symbol.
1188   ;; 3. face is 'font-lock-reference-face.
1189   ;; 4. context-menu is a list of context menu items, specific to whether
1190   ;;    the symbol is a function, variable, or both.
1191   ;; 5. activate-function will cause the function or variable to be described,
1192   ;;    replacing the existing help contents.
1193   (save-excursion
1194     (set-buffer buffer)
1195     (let (b e name)
1196       (while (re-search-forward help-symbol-regexp nil t)
1197         (setq b (or (match-beginning 2) (match-beginning 4)))
1198         (setq e (or (match-end 2) (match-end 4)))
1199         (setq name (buffer-substring b e))
1200         (let* ((sym (intern-soft name))
1201                (var (and sym (boundp sym)
1202                          (documentation-property sym
1203                                                  'variable-documentation t)))
1204                (fun (and sym (fboundp sym)
1205                          (documentation sym t))))
1206           (when (or var fun)
1207             (let ((ex (make-extent b e)))
1208               (set-extent-property ex 'mouse-face 'highlight)
1209               (set-extent-property ex 'help-symbol sym)
1210               (set-extent-property ex 'face 'font-lock-reference-face)
1211               (set-extent-property
1212                ex 'context-menu
1213                (cond ((and var fun)
1214                       help-symbol-function-and-variable-context-menu)
1215                      (var help-symbol-variable-context-menu)
1216                      (fun help-symbol-function-context-menu)))
1217               (set-extent-property
1218                ex 'activate-function
1219                (if fun
1220                    #'(lambda (ev ex)
1221                        (help-symbol-run-function-1 ev ex 'describe-function))
1222                  #'(lambda (ev ex)
1223                      (help-symbol-run-function-1 ev ex 'describe-variable))))
1224               ))))))) ;; 11 parentheses!
1225
1226 (defun describe-function-1 (function &optional nodoc)
1227   "This function does the work for `describe-function'."
1228   (princ "`")
1229   ;; (Help-princ-face function 'font-lock-function-name-face) overkill
1230   (princ function)
1231   (princ "' is ")
1232   (let* ((def function)
1233          aliases file-name autoload-file kbd-macro-p fndef macrop)
1234     (while (and (symbolp def) (fboundp def))
1235       (when (not (eq def function))
1236         (setq aliases
1237               (if aliases
1238                   ;; I18N3 Need gettext due to concat
1239                   (concat aliases
1240                           (format
1241                            "\n     which is an alias for `%s', "
1242                            (symbol-name def)))
1243                 (format "an alias for `%s', " (symbol-name def)))))
1244       (setq def (symbol-function def)))
1245     (if (and (fboundp 'compiled-function-annotation)
1246              (compiled-function-p def))
1247         (setq file-name (compiled-function-annotation def)))
1248     (if (eq 'macro (car-safe def))
1249         (setq fndef (cdr def)
1250               file-name (and (compiled-function-p (cdr def))
1251                              (fboundp 'compiled-function-annotation)
1252                              (compiled-function-annotation (cdr def)))
1253               macrop t)
1254       (setq fndef def))
1255     (if aliases (princ aliases))
1256     (let ((int #'(lambda (string an-p macro-p)
1257                    (princ (format
1258                            (gettext (concat
1259                                      (cond ((commandp def)
1260                                             "an interactive ")
1261                                            (an-p "an ")
1262                                            (t "a "))
1263                                      "%s"
1264                                      (if macro-p " macro" " function")))
1265                            string)))))
1266       (cond ((or (stringp def) (vectorp def))
1267              (princ "a keyboard macro.")
1268              (setq kbd-macro-p t))
1269             ((subrp fndef)
1270              (funcall int "built-in" nil macrop))
1271             ((compiled-function-p fndef)
1272              (funcall int "compiled Lisp" nil macrop))
1273             ((eq (car-safe fndef) 'lambda)
1274              (funcall int "Lisp" nil macrop))
1275             ((eq (car-safe fndef) 'mocklisp)
1276              (funcall int "mocklisp" nil macrop))
1277             ((eq (car-safe def) 'autoload)
1278              (setq autoload-file (elt def 1))
1279              (funcall int "autoloaded Lisp" t (elt def 4)))
1280             ((and (symbolp def) (not (fboundp def)))
1281              (princ "a symbol with a void (unbound) function definition."))
1282             (t
1283              nil)))
1284     (princ "\n")
1285     (if autoload-file
1286         (princ (format "  -- autoloads from \"%s\"\n" autoload-file)))
1287     (or file-name
1288         (setq file-name (describe-symbol-find-file function)))
1289     (if file-name
1290         (princ (format "  -- loaded from \"%s\"\n" file-name)))
1291 ;;     (terpri)
1292     (if describe-function-show-arglist
1293         (let ((arglist (function-arglist function)))
1294           (when arglist
1295             (Help-princ-face arglist 'font-lock-comment-face)
1296             (terpri))))
1297     (terpri)
1298     (cond (kbd-macro-p
1299            (princ "These characters are executed:\n\n\t")
1300            (princ (key-description def))
1301            (cond ((setq def (key-binding def))
1302                   (princ (format "\n\nwhich executes the command `%s'.\n\n"
1303                                  def))
1304                   (describe-function-1 def))))
1305           (nodoc nil)
1306           (t
1307            ;; tell the user about obsoleteness.
1308            ;; If the function is obsolete and is aliased, don't
1309            ;; even bother to report the documentation, as a further
1310            ;; encouragement to use the new function.
1311            (let ((obsolete (function-obsoleteness-doc function))
1312                  (compatible (function-compatibility-doc function)))
1313              (when obsolete
1314                (princ obsolete)
1315                (terpri)
1316                (terpri))
1317              (when compatible
1318                (princ compatible)
1319                (terpri)
1320                (terpri))
1321              (unless (and obsolete aliases)
1322                (let ((doc (function-documentation function t)))
1323                  (princ "Documentation:\n")
1324                  (let ((oldp (point standard-output))
1325                        newp)
1326                    (princ doc)
1327                    (setq newp (point standard-output))
1328                    (goto-char oldp standard-output)
1329                    (frob-help-extents standard-output)
1330                    (goto-char newp standard-output))
1331                  (unless (or (equal doc "")
1332                              (eq ?\n (aref doc (1- (length doc)))))
1333                    (terpri)))))))))
1334
1335
1336 ;;; [Obnoxious, whining people who complain very LOUDLY on Usenet
1337 ;;; are binding this to keys.]
1338 (defun describe-function-arglist (function)
1339   (interactive (list (or (function-at-point)
1340                          (error "no function call at point"))))
1341   (message nil)
1342   (message (function-arglist function)))
1343
1344 (defun variable-at-point ()
1345   (ignore-errors
1346     (with-syntax-table emacs-lisp-mode-syntax-table
1347       (save-excursion
1348         (or (not (zerop (skip-syntax-backward "_w")))
1349             (eq (char-syntax (char-after (point))) ?w)
1350             (eq (char-syntax (char-after (point))) ?_)
1351             (forward-sexp -1))
1352         (skip-chars-forward "'")
1353         (let ((obj (read (current-buffer))))
1354           (and (symbolp obj) (boundp obj) obj))))))
1355
1356 (defun variable-at-event (event)
1357   "Return the variable whose name is around the position of EVENT.
1358 EVENT should be a mouse event.  When calling from a popup or context menu,
1359 use `last-popup-menu-event' to find out where the mouse was clicked.
1360 \(You cannot use (interactive \"e\"), unfortunately.  This returns a
1361 misc-user event.)
1362
1363 If the event contains no position, or the position is not over text, or
1364 there is no variable around that point, nil is returned."
1365   (if (and event (event-buffer event) (event-point event))
1366       (save-excursion
1367         (set-buffer (event-buffer event))
1368         (goto-char (event-point event))
1369         (variable-at-point))))
1370
1371 (defun variable-obsolete-p (variable)
1372   "Return non-nil if VARIABLE is obsolete."
1373   (not (null (get variable 'byte-obsolete-variable))))
1374
1375 (defun variable-obsoleteness-doc (variable)
1376   "If VARIABLE is obsolete, return a string describing this."
1377   (let ((obsolete (get variable 'byte-obsolete-variable)))
1378     (if obsolete
1379         (format "Obsolete; %s"
1380                 (if (stringp obsolete)
1381                     obsolete
1382                   (format "use `%s' instead." obsolete))))))
1383
1384 (defun variable-compatible-p (variable)
1385   "Return non-nil if VARIABLE is Emacs compatible."
1386   (not (null (get variable 'byte-compatible-variable))))
1387
1388 (defun variable-compatibility-doc (variable)
1389   "If VARIABLE is Emacs compatible, return a string describing this."
1390   (let ((compatible (get variable 'byte-compatible-variable)))
1391     (if compatible
1392         (format "Emacs Compatible; %s"
1393                 (if (stringp compatible)
1394                     compatible
1395                   (format "use `%s' instead." compatible))))))
1396
1397 (defun built-in-variable-doc (variable)
1398   "Return a string describing whether VARIABLE is built-in."
1399   (let ((type (built-in-variable-type variable)))
1400     (case type
1401       (integer "a built-in integer variable")
1402       (const-integer "a built-in constant integer variable")
1403       (boolean "a built-in boolean variable")
1404       (const-boolean "a built-in constant boolean variable")
1405       (object "a simple built-in variable")
1406       (const-object "a simple built-in constant variable")
1407       (const-specifier "a built-in constant specifier variable")
1408       (current-buffer "a built-in buffer-local variable")
1409       (const-current-buffer "a built-in constant buffer-local variable")
1410       (default-buffer "a built-in default buffer-local variable")
1411       (selected-console "a built-in console-local variable")
1412       (const-selected-console "a built-in constant console-local variable")
1413       (default-console "a built-in default console-local variable")
1414       (t
1415        (if type "an unknown type of built-in variable?"
1416          "a variable declared in Lisp")))))
1417
1418 (defun describe-variable (variable)
1419   "Display the full documentation of VARIABLE (a symbol)."
1420   (interactive
1421    (let* ((v (variable-at-point))
1422           (val (let ((enable-recursive-minibuffers t))
1423                  (completing-read
1424                    (if v
1425                        (format "Describe variable (default %s): " v)
1426                        (gettext "Describe variable: "))
1427                    obarray 'boundp t nil 'variable-history
1428                    (symbol-name v)))))
1429      (list (intern val))))
1430   (with-displaying-help-buffer
1431    (lambda ()
1432      (let ((origvar variable)
1433            aliases)
1434        (let ((print-escape-newlines t))
1435          (princ "`")
1436          ;; (Help-princ-face (symbol-name variable)
1437          ;;               'font-lock-variable-name-face) overkill
1438          (princ (symbol-name variable))
1439          (princ "' is ")
1440          (while (variable-alias variable)
1441            (let ((newvar (variable-alias variable)))
1442              (if aliases
1443                  ;; I18N3 Need gettext due to concat
1444                  (setq aliases
1445                        (concat aliases
1446                                (format "\n     which is an alias for `%s',"
1447                                        (symbol-name newvar))))
1448                (setq aliases
1449                      (format "an alias for `%s',"
1450                              (symbol-name newvar))))
1451              (setq variable newvar)))
1452          (if aliases
1453              (princ (format "%s" aliases)))
1454          (princ (built-in-variable-doc variable))
1455          (princ ".\n")
1456          (let ((file-name (describe-symbol-find-file variable)))
1457            (if file-name
1458                (princ (format "  -- loaded from \"%s\"\n" file-name))))
1459          (princ "\nValue: ")
1460          (if (not (boundp variable))
1461              (Help-princ-face "void\n" 'font-lock-comment-face)
1462            (Help-prin1-face (symbol-value variable) 'font-lock-comment-face)
1463            (terpri))
1464          (terpri)
1465          (cond ((local-variable-p variable (current-buffer))
1466                 (let* ((void (cons nil nil))
1467                        (def (condition-case nil
1468                                 (default-value variable)
1469                               (error void))))
1470                   (princ "This value is specific to the current buffer.\n")
1471                   (if (local-variable-p variable nil)
1472                       (princ "(Its value is local to each buffer.)\n"))
1473                   (terpri)
1474                   (if (if (eq def void)
1475                           (boundp variable)
1476                         (not (eq (symbol-value variable) def)))
1477                       ;; #### I18N3 doesn't localize properly!
1478                       (progn (princ "Default-value: ")
1479                              (if (eq def void)
1480                                  (princ "void\n")
1481                                (prin1 def)
1482                                (terpri))
1483                              (terpri)))))
1484                ((local-variable-p variable (current-buffer) t)
1485                 (princ "Setting it would make its value buffer-local.\n\n"))))
1486        (princ "Documentation:")
1487        (terpri)
1488        (let ((doc (documentation-property variable 'variable-documentation))
1489              (obsolete (variable-obsoleteness-doc origvar))
1490              (compatible (variable-compatibility-doc origvar)))
1491          (when obsolete
1492            (princ obsolete)
1493            (terpri)
1494            (terpri))
1495          (when compatible
1496            (princ compatible)
1497            (terpri)
1498            (terpri))
1499          ;; don't bother to print anything if variable is obsolete and aliased.
1500          (when (or (not obsolete) (not aliases))
1501            (if doc
1502                ;; note: documentation-property calls substitute-command-keys.
1503                (let ((oldp (point standard-output))
1504                      newp)
1505                  (princ doc)
1506                  (setq newp (point standard-output))
1507                  (goto-char oldp standard-output)
1508                  (frob-help-extents standard-output)
1509                  (goto-char newp standard-output))
1510              (princ "not documented as a variable."))))
1511        (terpri)))
1512    (format "variable `%s'" variable)))
1513
1514 (defun sorted-key-descriptions (keys &optional separator)
1515   "Sort and separate the key descriptions for KEYS.
1516 The sorting is done by length (shortest bindings first), and the bindings
1517 are separated with SEPARATOR (\", \" by default)."
1518   (mapconcat 'key-description
1519              (sort keys #'(lambda (x y)
1520                             (< (length x) (length y))))
1521              (or separator ", ")))
1522
1523 (defun where-is (definition &optional insert)
1524   "Print message listing key sequences that invoke specified command.
1525 Argument is a command definition, usually a symbol with a function definition.
1526 When run interactively, it defaults to any function found by
1527 `function-at-point'.
1528 If INSERT (the prefix arg) is non-nil, insert the message in the buffer."
1529   (interactive
1530    (let ((fn (function-at-point))
1531          (enable-recursive-minibuffers t)
1532          val)
1533      (setq val (read-command
1534                 (if fn (format "Where is command (default %s): " fn)
1535                   "Where is command: ")
1536                 (and fn (symbol-name fn))))
1537      (list (if (equal (symbol-name val) "")
1538                fn val)
1539            current-prefix-arg)))
1540   (let ((keys (where-is-internal definition)))
1541     (if keys
1542         (if insert
1543             (princ (format "%s (%s)" (sorted-key-descriptions keys)
1544                            definition) (current-buffer))
1545           (message "%s is on %s" definition (sorted-key-descriptions keys)))
1546       (if insert
1547           (princ (format (if (commandp definition) "M-x %s RET"
1548                            "M-: (%s ...)") definition) (current-buffer))
1549         (message "%s is not on any keys" definition))))
1550   nil)
1551
1552 ;; `locate-library' moved to "packages.el"
1553
1554 \f
1555 ;; Functions ported from C into Lisp in XEmacs
1556
1557 (defun describe-syntax ()
1558   "Describe the syntax specifications in the syntax table.
1559 The descriptions are inserted in a buffer, which is then displayed."
1560   (interactive)
1561   (with-displaying-help-buffer
1562    (lambda ()
1563      ;; defined in syntax.el
1564      (describe-syntax-table (syntax-table) standard-output))
1565    (format "syntax-table for %s" major-mode)))
1566
1567 (defun list-processes ()
1568   "Display a list of all processes.
1569 \(Any processes listed as Exited or Signaled are actually eliminated
1570 after the listing is made.)"
1571   (interactive)
1572   (with-output-to-temp-buffer "*Process List*"
1573     (set-buffer standard-output)
1574     (buffer-disable-undo standard-output)
1575     (make-local-variable 'truncate-lines)
1576     (setq truncate-lines t)
1577     ;;      00000000001111111111222222222233333333334444444444
1578     ;;      01234567890123456789012345678901234567890123456789
1579     ;; rewritten for I18N3.  This one should stay rewritten
1580     ;; so that the dashes will line up properly.
1581     (princ "Proc         Status   Buffer         Tty         Command\n----         ------   ------         ---         -------\n")
1582     (let ((tail (process-list)))
1583       (while tail
1584         (let* ((p (car tail))
1585                (pid (process-id p))
1586                (s (process-status p)))
1587           (setq tail (cdr tail))
1588           (princ (format "%-13s" (process-name p)))
1589           (princ s)
1590           (if (and (eq s 'exit) (/= (process-exit-status p) 0))
1591               (princ (format " %d" (process-exit-status p))))
1592           (if (memq s '(signal exit closed))
1593               ;; Do delete-exited-processes' work
1594               (delete-process p))
1595           (indent-to 22 1)              ;####
1596           (let ((b (process-buffer p)))
1597             (cond ((not b)
1598                    (princ "(none)"))
1599                   ((not (buffer-name b))
1600                    (princ "(killed)"))
1601                   (t
1602                    (princ (buffer-name b)))))
1603           (indent-to 37 1)              ;####
1604           (let ((tn (process-tty-name p)))
1605             (cond ((not tn)
1606                    (princ "(none)"))
1607                   (t
1608                    (princ (format "%s" tn)))))
1609           (indent-to 49 1)              ;####
1610           (if (not (integerp pid))
1611               (progn
1612                 (princ "network stream connection ")
1613                 (princ (car pid))
1614                 (princ "@")
1615                 (princ (cdr pid)))
1616             (let ((cmd (process-command p)))
1617               (while cmd
1618                 (princ (car cmd))
1619                 (setq cmd (cdr cmd))
1620                 (if cmd (princ " ")))))
1621           (terpri))))))
1622
1623 ;; Stop gap for 21.0 until we do help-char etc properly.
1624 (defun help-keymap-with-help-key (keymap form)
1625   "Return a copy of KEYMAP with an help-key binding according to help-char
1626  invoking FORM like help-form.  An existing binding is not overridden.
1627  If FORM is nil then no binding is made."
1628   (let ((map (copy-keymap keymap))
1629         (key (if (characterp help-char)
1630                  (vector (character-to-event help-char))
1631                help-char)))
1632     (when (and form key (not (lookup-key map key)))
1633       (define-key map key
1634         `(lambda () (interactive) (help-print-help-form ,form))))
1635     map))
1636
1637 (defun help-print-help-form (form)
1638   (let ((string (eval form)))
1639     (if (stringp string)
1640         (with-displaying-help-buffer
1641          (insert string)))))
1642
1643 ;;; help.el ends here