cgit.sxemacs.org Git - sxemacs/blob - lisp/help.el

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