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