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