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

   1 ;;; hyper-apropos.el --- Hypertext emacs lisp documentation interface.
   2
   3 ;; Copyright (C)  1997 Free Software Foundation, Inc.
   4 ;; Copyright (C) 1994, 1995 Tinker Systems and INS Engineering Corp.
   5 ;; Copyright (C) 1995 Sun Microsystems.
   6 ;; Copyright (C) 1996 Ben Wing.
   7
   8 ;; Maintainer: Jonathan Stigelman <Stig@hackvan.com>
   9 ;; Keywords: lisp, tools, help, docs, matching
  10
  11 ;; This file is part of XEmacs.
  12
  13 ;; XEmacs is free software; you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 2 of the License, or
  16 ;; (at your option) any later version.
  17 ;;
  18 ;; XEmacs is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22 ;;
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with XEmacs; if not, write to the Free Software
  25 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  26
  27 ;;; Synched up with: Not in FSF.
  28
  29 ;;; Commentary:
  30
  31 ;;  based upon emacs-apropos.el by Frank C. Guida <fcg@philabs.philips.com>
  32 ;;
  33 ;;  Rather than run apropos and print all the documentation at once,
  34 ;;  I find it easier to view a "table of contents" first, then
  35 ;;  get the details for symbols as you need them.
  36 ;;
  37 ;;  This version of apropos prints two lists of symbols matching the
  38 ;;  given regexp:  functions/macros and variables/constants.
  39 ;;
  40 ;;  The user can then do the following:
  41 ;;
  42 ;;      - add an additional regexp to narrow the search
  43 ;;      - display documentation for the current symbol
  44 ;;      - find the tag for the current symbol
  45 ;;      - show any keybindings if the current symbol is a command
  46 ;;      - invoke functions
  47 ;;      - set variables
  48 ;;
  49 ;;  An additional feature is the ability to search the current tags
  50 ;;  table, allowing you to interrogate functions not yet loaded (this
  51 ;;  isn't available with the standard package).
  52 ;;
  53 ;;  Mouse bindings and menus are provided for XEmacs.
  54 ;;
  55 ;; additions by Ben Wing <ben@xemacs.org> July 1995:
  56 ;; added support for function aliases, made programmer's apropos be the
  57 ;; default, various other hacking.
  58 ;; Massive changes by Christoph Wedler <wedler@fmi.uni-passau.de>
  59 ;; Some changes for XEmacs 20.3 by hniksic
  60
  61 ;; ### The maintainer is supposed to be stig, but I haven't seen him
  62 ;; around for ages.  The real maintainer for the moment is Hrvoje
  63 ;; Niksic <hniksic@srce.hr>.
  64
  65 ;;; Code:
  66
  67 (defgroup hyper-apropos nil
  68   "Hypertext emacs lisp documentation interface."
  69   :group 'docs
  70   :group 'lisp
  71   :group 'tools
  72   :group 'help
  73   :group 'matching)
  74
  75 (defcustom hyper-apropos-show-brief-docs t
  76   "*If non-nil, display some documentation in the \"*Hyper Apropos*\" buffer.
  77 Setting this to nil will speed up searches."
  78   :type 'boolean
  79   :group 'hyper-apropos)
  80 (define-obsolete-variable-alias
  81   'hypropos-show-brief-docs 'hyper-apropos-show-brief-docs)
  82 ;; I changed this to true because I think it's more useful this way. --ben
  83
  84 (defcustom hyper-apropos-programming-apropos t
  85   "*If non-nil, list all the functions and variables.
  86 This will cause more output to be generated, and take a longer time.
  87
  88 Otherwise, only the interactive functions and user variables will be listed."
  89   :type 'boolean
  90   :group 'hyper-apropos)
  91 (define-obsolete-variable-alias
  92   'hypropos-programming-apropos 'hyper-apropos-programming-apropos)
  93
  94 (defcustom hyper-apropos-shrink-window nil
  95   "*If non-nil, shrink *Hyper Help* buffer if possible."
  96   :type 'boolean
  97   :group 'hyper-apropos)
  98 (define-obsolete-variable-alias
  99   'hypropos-shrink-window 'hyper-apropos-shrink-window)
 100
 101 (defcustom hyper-apropos-prettyprint-long-values t
 102   "*If non-nil, then try to beautify the printing of very long values."
 103   :type 'boolean
 104   :group 'hyper-apropos)
 105 (define-obsolete-variable-alias
 106   'hypropos-prettyprint-long-values 'hyper-apropos-prettyprint-long-values)
 107
 108 (defgroup hyper-apropos-faces nil
 109   "Faces defined by hyper-apropos."
 110   :prefix "hyper-apropos-"
 111   :group 'faces)
 112
 113 (defface hyper-apropos-documentation
 114   '((((class color) (background light))
 115      (:foreground "darkred"))
 116     (((class color) (background dark))
 117      (:foreground "gray90")))
 118   "Hyper-apropos documentation."
 119   :group 'hyper-apropos-faces)
 120
 121 (defface hyper-apropos-hyperlink
 122   '((((class color) (background light))
 123      (:foreground "blue4"))
 124     (((class color) (background dark))
 125      (:foreground "lightseagreen"))
 126     (t
 127      (:bold t)))
 128   "Hyper-apropos hyperlinks."
 129   :group 'hyper-apropos-faces)
 130
 131 (defface hyper-apropos-major-heading '((t (:bold t)))
 132   "Hyper-apropos major heading."
 133   :group 'hyper-apropos-faces)
 134
 135 (defface hyper-apropos-section-heading '((t (:bold t :italic t)))
 136   "Hyper-apropos section heading."
 137   :group 'hyper-apropos-faces)
 138
 139 (defface hyper-apropos-heading '((t (:bold t)))
 140   "Hyper-apropos heading."
 141   :group 'hyper-apropos-faces)
 142
 143 (defface hyper-apropos-warning '((t (:bold t :foreground "red")))
 144   "Hyper-apropos warning."
 145   :group 'hyper-apropos-faces)
 146
 147 ;;; Internal variables below this point
 148
 149 (defvar hyper-apropos-ref-buffer)
 150 (defvar hyper-apropos-prev-wconfig)
 151
 152 (defvar hyper-apropos-help-map
 153   (let ((map (make-sparse-keymap)))
 154     (suppress-keymap map)
 155     (set-keymap-name map 'hyper-apropos-help-map)
 156     ;; movement
 157     (define-key map " "     'scroll-up)
 158     (define-key map "b"     'scroll-down)
 159     (define-key map [delete] 'scroll-down)
 160     (define-key map [backspace] 'scroll-down)
 161     (define-key map "/"     'isearch-forward)
 162     (define-key map "?"     'isearch-backward)
 163     ;; follow links
 164     (define-key map [return] 'hyper-apropos-get-doc)
 165     (define-key map "s"     'hyper-apropos-set-variable)
 166     (define-key map "t"     'hyper-apropos-find-tag)
 167     (define-key map "l"     'hyper-apropos-last-help)
 168     (define-key map "c"     'hyper-apropos-customize-variable)
 169     (define-key map "f"     'hyper-apropos-find-function)
 170     (define-key map [button2] 'hyper-apropos-mouse-get-doc)
 171     (define-key map [button3] 'hyper-apropos-popup-menu)
 172     ;; for the totally hardcore...
 173     (define-key map "D"     'hyper-apropos-disassemble)
 174     ;; administrativa
 175     (define-key map "a"     'hyper-apropos)
 176     (define-key map "n"     'hyper-apropos)
 177     (define-key map "q"     'hyper-apropos-quit)
 178     map)
 179   "Keybindings for the *Hyper Help* buffer and the *Hyper Apropos* buffer")
 180 (define-obsolete-variable-alias
 181   'hypropos-help-map 'hyper-apropos-help-map)
 182
 183 (defvar hyper-apropos-map
 184   (let ((map (make-sparse-keymap)))
 185     (set-keymap-name map 'hyper-apropos-map)
 186     (set-keymap-parents map (list hyper-apropos-help-map))
 187     ;; slightly different scrolling...
 188     (define-key map " "     'hyper-apropos-scroll-up)
 189     (define-key map "b"     'hyper-apropos-scroll-down)
 190     (define-key map [delete] 'hyper-apropos-scroll-down)
 191     (define-key map [backspace] 'hyper-apropos-scroll-down)
 192     ;; act on the current line...
 193     (define-key map "w"     'hyper-apropos-where-is)
 194     (define-key map "i"     'hyper-apropos-invoke-fn)
 195 ;; this is already defined in the parent-keymap above, isn't it?
 196 ;;     (define-key map "s"     'hyper-apropos-set-variable)
 197     ;; more administrativa...
 198     (define-key map "P"     'hyper-apropos-toggle-programming-flag)
 199     (define-key map "k"     'hyper-apropos-add-keyword)
 200     (define-key map "e"     'hyper-apropos-eliminate-keyword)
 201     map)
 202   "Keybindings for the *Hyper Apropos* buffer.
 203 This map inherits from `hyper-apropos-help-map.'")
 204 (define-obsolete-variable-alias
 205   'hypropos-map 'hyper-apropos-map)
 206
 207 ;;(defvar hyper-apropos-mousable-keymap
 208 ;;  (let ((map (make-sparse-keymap)))
 209 ;;    (define-key map [button2] 'hyper-apropos-mouse-get-doc)
 210 ;;    map))
 211
 212 (defvar hyper-apropos-mode-hook nil
 213   "*User function run after hyper-apropos mode initialization.  Usage:
 214 \(add-hook 'hyper-apropos-mode-hook #'(lambda () ... your init forms ...)).")
 215
 216 ;; ---------------------------------------------------------------------- ;;
 217
 218 (defconst hyper-apropos-junk-regexp
 219   "^Apropos\\|^Functions\\|^Variables\\|^$")
 220
 221 (defvar hyper-apropos-currently-showing nil)    ; symbol documented in
 222                                                 ; help buffer now
 223 (defvar hyper-apropos-help-history nil) ; chain of symbols followed as links in
 224                                         ; help buffer
 225 (defvar hyper-apropos-face-history nil)
 226 ;;;(defvar hyper-apropos-variable-history nil)
 227 ;;;(defvar hyper-apropos-function-history nil)
 228 (defvar hyper-apropos-regexp-history nil)
 229 (defvar hyper-apropos-last-regexp nil)  ; regex used for last apropos
 230 (defconst hyper-apropos-apropos-buf "*Hyper Apropos*")
 231 (defconst hyper-apropos-help-buf "*Hyper Help*")
 232
 233 ;;;###autoload
 234 (defun hyper-apropos (regexp toggle-apropos)
 235   "Display lists of functions and variables matching REGEXP
 236 in buffer \"*Hyper Apropos*\".  If optional prefix arg is given, then the
 237 value of `hyper-apropos-programming-apropos' is toggled for this search.
 238 See also `hyper-apropos-mode'."
 239   (interactive (list (read-from-minibuffer "List symbols matching regexp: "
 240                                            nil nil nil 'hyper-apropos-regexp-history)
 241                      current-prefix-arg))
 242   (or (memq major-mode '(hyper-apropos-mode hyper-apropos-help-mode))
 243       (setq hyper-apropos-prev-wconfig (current-window-configuration)))
 244   (if (string= "" regexp)
 245       (if (get-buffer hyper-apropos-apropos-buf)
 246           (if toggle-apropos
 247               (hyper-apropos-toggle-programming-flag)
 248             (message "Using last search results"))
 249         (error "Be more specific..."))
 250     (set-buffer (get-buffer-create hyper-apropos-apropos-buf))
 251     (setq buffer-read-only nil)
 252     (erase-buffer)
 253     (if toggle-apropos
 254         (set (make-local-variable 'hyper-apropos-programming-apropos)
 255              (not (default-value 'hyper-apropos-programming-apropos))))
 256     (let ((flist (apropos-internal regexp
 257                                    (if hyper-apropos-programming-apropos
 258                                        #'fboundp
 259                                      #'commandp)))
 260           (vlist (apropos-internal regexp
 261                                    (if hyper-apropos-programming-apropos
 262                                        #'boundp
 263                                      #'user-variable-p))))
 264       (insert-face (format "Apropos search for: %S\n\n" regexp)
 265                    'hyper-apropos-major-heading)
 266       (insert-face "* = command (M-x) or user-variable.\n"
 267                    'hyper-apropos-documentation)
 268       (insert-face "\
 269 a = autoloaded, b = byte-compiled, i = internal, l = lambda, m = macro.\n\n"
 270                    'hyper-apropos-documentation)
 271       (insert-face "Functions and Macros:\n\n" 'hyper-apropos-major-heading)
 272       (hyper-apropos-grok-functions flist)
 273       (insert-face "\n\nVariables and Constants:\n\n"
 274                    'hyper-apropos-major-heading)
 275       (hyper-apropos-grok-variables vlist)
 276       (goto-char (point-min))))
 277   (switch-to-buffer hyper-apropos-apropos-buf)
 278   (hyper-apropos-mode regexp))
 279
 280 (defun hyper-apropos-toggle-programming-flag ()
 281   (interactive)
 282   (with-current-buffer hyper-apropos-apropos-buf
 283     (set (make-local-variable 'hyper-apropos-programming-apropos)
 284          (not hyper-apropos-programming-apropos)))
 285   (message "Re-running apropos...")
 286   (hyper-apropos hyper-apropos-last-regexp nil))
 287
 288 (defun hyper-apropos-grok-functions (fns)
 289   (let (bind doc type)
 290     (dolist (fn fns)
 291       (setq bind (symbol-function fn)
 292             type (cond ((subrp bind) ?i)
 293                        ((compiled-function-p bind) ?b)
 294                        ((consp bind) (or (cdr
 295                                           (assq (car bind) '((autoload . ?a)
 296                                                              (lambda . ?l)
 297                                                              (macro . ?m))))
 298                                          ??))
 299                        (t ?\ )))
 300       (insert type (if (commandp fn) "* " "  "))
 301       (let ((e (insert-face (format "%S" fn) 'hyper-apropos-hyperlink)))
 302         (set-extent-property e 'mouse-face 'highlight))
 303       (insert-char ?\  (let ((l (- 30 (length (format "%S" fn)))))
 304                          (if (natnump l) l 0)))
 305       (and hyper-apropos-show-brief-docs
 306            (setq doc
 307            ;; A symbol's function slot can point to an unbound symbol.
 308            ;; In that case, `documentation' will fail.
 309                  (ignore-errors
 310                    (documentation fn)))
 311            (if  (string-match
 312                  "^([^\n\t )]+[\t ]*\\([^\n)]+\\)?)\\(:[\t ]*\\|\n?\\'\\)"
 313                  doc)
 314                (setq doc (substring doc (match-end 0) (string-match "\n" doc)))
 315              t)
 316            (insert-face (if doc
 317                             (concat " - "
 318                                     (substring doc 0 (string-match "\n" doc)))
 319                           " Not documented.")
 320                         'hyper-apropos-documentation))
 321       (insert ?\n))))
 322
 323 (defun hyper-apropos-grok-variables (vars)
 324   (let (doc userp)
 325     (dolist (var vars)
 326       (setq userp (user-variable-p var))
 327       (insert (if userp " * " "   "))
 328       (let ((e (insert-face (format "%S" var) 'hyper-apropos-hyperlink)))
 329         (set-extent-property e 'mouse-face 'highlight))
 330       (insert-char ?\  (let ((l (- 30 (length (format "%S" var)))))
 331                          (if (natnump l) l 0)))
 332       (and hyper-apropos-show-brief-docs
 333            (setq doc (documentation-property var 'variable-documentation))
 334            (insert-face (if doc
 335                             (concat " - " (substring doc (if userp 1 0)
 336                                                      (string-match "\n" doc)))
 337                           " - Not documented.")
 338                         'hyper-apropos-documentation))
 339       (insert ?\n))))
 340
 341 ;; ---------------------------------------------------------------------- ;;
 342
 343 (defun hyper-apropos-mode (regexp)
 344   "Improved apropos mode for displaying Emacs documentation.  Function and
 345 variable names are displayed in the buffer \"*Hyper Apropos*\".
 346
 347 Functions are preceded by a single character to indicates their types:
 348     a = autoloaded, b = byte-compiled, i = internal, l = lambda, m = macro.
 349 Interactive functions are also preceded by an asterisk.
 350 Variables are preceded by an asterisk if they are user variables.
 351
 352 General Commands:
 353
 354         SPC     - scroll documentation or apropos window forward
 355           b     - scroll documentation or apropos window backward
 356           k     - eliminate all hits that don't contain keyword
 357           n     - new search
 358           /     - isearch-forward
 359           q     - quit and restore previous window configuration
 360
 361   Operations for Symbol on Current Line:
 362
 363         RET     - toggle display of symbol's documentation
 364                   (also on button2 in xemacs)
 365           w     - show the keybinding if symbol is a command
 366           i     - invoke function on current line
 367           s     - set value of variable on current line
 368           t     - display the C or lisp source (find-tag)"
 369   (delete-other-windows)
 370   (setq mode-name "Hyper-Apropos"
 371         major-mode 'hyper-apropos-mode
 372         buffer-read-only t
 373         truncate-lines t
 374         hyper-apropos-last-regexp regexp
 375         modeline-buffer-identification
 376         (list (cons modeline-buffer-id-left-extent "Hyper Apropos: ")
 377               (cons modeline-buffer-id-right-extent (concat "\"" regexp "\""))))
 378   (use-local-map hyper-apropos-map)
 379   (run-hooks 'hyper-apropos-mode-hook))
 380
 381 ;; ---------------------------------------------------------------------- ;;
 382
 383 ;; similar to `describe-key-briefly', copied from help.el by CW
 384
 385 ;;;###autoload
 386 (defun hyper-describe-key (key)
 387   (interactive "kDescribe key: ")
 388   (hyper-describe-key-briefly key t))
 389
 390 ;;;###autoload
 391 (defun hyper-describe-key-briefly (key &optional show)
 392   (interactive "kDescribe key briefly: \nP")
 393   (let (menup defn interm final msg)
 394     (setq defn (key-or-menu-binding key 'menup))
 395     (if (or (null defn) (integerp defn))
 396         (or (numberp show) (message "%s is undefined" (key-description key)))
 397       (cond ((stringp defn)
 398              (setq interm defn
 399                    final (key-binding defn)))
 400             ((vectorp defn)
 401              (setq interm (append defn nil))
 402              (while (and interm
 403                          (member (key-binding (vector (car interm)))
 404                                  '(universal-argument digit-argument)))
 405                (setq interm (cdr interm)))
 406              (while (and interm
 407                          (not (setq final (key-binding (vconcat interm)))))
 408                (setq interm (butlast interm)))
 409              (if final
 410                  (setq interm (vconcat interm))
 411                (setq interm defn
 412                      final (key-binding defn)))))
 413       (setq msg (format
 414                  "%s runs %s%s%s"
 415                  ;; This used to say 'This menu item' but it could also
 416                  ;; be a scrollbar event.  We can't distinguish at the
 417                  ;; moment.
 418                  (if menup "This item" (key-description key))
 419                  ;;(if (symbolp defn) defn (key-description defn))
 420                  (if (symbolp defn) defn (prin1-to-string defn))
 421                  (if final (concat ", " (key-description interm) " runs ") "")
 422                  (if final
 423                      (if (symbolp final) final (prin1-to-string final))
 424                    "")))
 425       (if (numberp show)
 426           (or (not (symbolp defn))
 427               (memq (symbol-function defn)
 428                     '(zkey-init-kbd-macro zkey-init-kbd-fn))
 429               (progn (princ msg) (princ "\n")))
 430         (message "%s" msg)
 431         (if final (setq defn final))
 432         (if (and (or (symbolp defn) (symbolp (setq defn (car-safe defn))))
 433                  defn
 434                  show)
 435             (hyper-apropos-get-doc defn t))))))
 436
 437 ;;;###autoload
 438 (defun hyper-describe-face (symbol &optional this-ref-buffer)
 439   "Describe face..
 440 See also `hyper-apropos' and `hyper-describe-function'."
 441   ;; #### - perhaps a prefix arg should suppress the prompt...
 442   (interactive
 443    (let (v val)
 444      (setq v (hyper-apropos-this-symbol))       ; symbol under point
 445      (or (find-face v)
 446          (setq v (variable-at-point)))
 447      (setq val (let ((enable-recursive-minibuffers t))
 448                  (completing-read
 449                   (concat (if (hyper-apropos-follow-ref-buffer current-prefix-arg)
 450                               "Follow face"
 451                             "Describe face")
 452                           (if v
 453                               (format " (default %s): " v)
 454                             ": "))
 455                   (mapcar #'(lambda (x) (list (symbol-name x)))
 456                           (face-list))
 457                   nil t nil 'hyper-apropos-face-history)))
 458      (list (if (string= val "")
 459                (progn (push (symbol-name v) hyper-apropos-face-history) v)
 460              (intern-soft val))
 461            current-prefix-arg)))
 462   (if (null symbol)
 463       (message "Sorry, nothing to describe.")
 464     (or (memq major-mode '(hyper-apropos-mode hyper-apropos-help-mode))
 465         (setq hyper-apropos-prev-wconfig (current-window-configuration)))
 466     (hyper-apropos-get-doc symbol t nil this-ref-buffer)))
 467
 468 ;;;###autoload
 469 (defun hyper-describe-variable (symbol &optional this-ref-buffer)
 470   "Hypertext drop-in replacement for `describe-variable'.
 471 See also `hyper-apropos' and `hyper-describe-function'."
 472   ;; #### - perhaps a prefix arg should suppress the prompt...
 473   (interactive (list (hyper-apropos-read-variable-symbol
 474                       (if (hyper-apropos-follow-ref-buffer current-prefix-arg)
 475                           "Follow variable"
 476                         "Describe variable"))
 477                      current-prefix-arg))
 478   (if (null symbol)
 479       (message "Sorry, nothing to describe.")
 480     (or (memq major-mode '(hyper-apropos-mode hyper-apropos-help-mode))
 481         (setq hyper-apropos-prev-wconfig (current-window-configuration)))
 482     (hyper-apropos-get-doc symbol t nil this-ref-buffer)))
 483
 484 (defun hyper-where-is (symbol)
 485   "Print message listing key sequences that invoke specified command."
 486   (interactive (list (hyper-apropos-read-function-symbol "Where is function")))
 487   (if (null symbol)
 488       (message "Sorry, nothing to describe.")
 489     (where-is symbol)))
 490
 491 ;;;###autoload
 492 (defun hyper-describe-function (symbol &optional this-ref-buffer)
 493   "Hypertext replacement for `describe-function'.  Unlike `describe-function'
 494 in that the symbol under the cursor is the default if it is a function.
 495 See also `hyper-apropos' and `hyper-describe-variable'."
 496   ;; #### - perhaps a prefix arg should suppress the prompt...
 497   (interactive (list (hyper-apropos-read-function-symbol
 498                       (if (hyper-apropos-follow-ref-buffer current-prefix-arg)
 499                           "Follow function"
 500                         "Describe function"))
 501                      current-prefix-arg))
 502   (if (null symbol)
 503       (message "Sorry, nothing to describe.")
 504     (or (memq major-mode '(hyper-apropos-mode hyper-apropos-help-mode))
 505         (setq hyper-apropos-prev-wconfig (current-window-configuration)))
 506     (hyper-apropos-get-doc symbol t nil this-ref-buffer)))
 507
 508 ;;;###autoload
 509 (defun hyper-apropos-read-variable-symbol (prompt &optional predicate)
 510   "Hypertext drop-in replacement for `describe-variable'.
 511 See also `hyper-apropos' and `hyper-describe-function'."
 512   ;; #### - perhaps a prefix arg should suppress the prompt...
 513   (or predicate (setq predicate 'boundp))
 514   (let (v val)
 515     (setq v (hyper-apropos-this-symbol))        ; symbol under point
 516     (or (funcall predicate v)
 517         (setq v (variable-at-point)))
 518     (or (funcall predicate v)
 519         (setq v nil))
 520     (setq val (let ((enable-recursive-minibuffers t))
 521                 (completing-read
 522                  (concat prompt
 523                          (if v
 524                              (format " (default %s): " v)
 525                            ": "))
 526                  obarray predicate t nil 'variable-history)))
 527     (if (string= val "")
 528         (progn (push (symbol-name v) variable-history) v)
 529       (intern-soft val))))
 530 ;;;###autoload
 531 (define-obsolete-function-alias
 532   'hypropos-read-variable-symbol 'hyper-apropos-read-variable-symbol)
 533
 534 (defun hyper-apropos-read-function-symbol (prompt)
 535   "Read function symbol from minibuffer."
 536   (let ((fn (hyper-apropos-this-symbol))
 537         val)
 538     (or (fboundp fn)
 539         (setq fn (function-at-point)))
 540     (setq val (let ((enable-recursive-minibuffers t))
 541                 (completing-read (if fn
 542                                      (format "%s (default %s): " prompt fn)
 543                                    (format "%s: " prompt))
 544                                  obarray 'fboundp t nil
 545                                  'function-history)))
 546     (if (equal val "")
 547         (progn (push (symbol-name fn) function-history) fn)
 548       (intern-soft val))))
 549
 550 (defun hyper-apropos-last-help (arg)
 551   "Go back to the last symbol documented in the *Hyper Help* buffer."
 552   (interactive "P")
 553   (let ((win (get-buffer-window hyper-apropos-help-buf)))
 554     (or arg (setq arg (if win 1 0)))
 555     (cond ((= arg 0))
 556           ((<= (length hyper-apropos-help-history) arg)
 557            ;; go back as far as we can...
 558            (setcdr (nreverse hyper-apropos-help-history) nil))
 559           (t
 560            (setq hyper-apropos-help-history
 561                  (nthcdr arg hyper-apropos-help-history))))
 562     (if (or win (> arg 0))
 563         (hyper-apropos-get-doc (car hyper-apropos-help-history) t)
 564       (display-buffer hyper-apropos-help-buf))))
 565
 566 (defun hyper-apropos-insert-face (string &optional face)
 567   "Insert STRING and fontify some parts with face `hyper-apropos-hyperlink'."
 568   (let ((beg (point)) end)
 569     (insert-face string (or face 'hyper-apropos-documentation))
 570     (setq end (point))
 571     (goto-char beg)
 572     (while (re-search-forward
 573             "`\\([-a-zA-Z0-9_][-a-zA-Z0-9_][-a-zA-Z0-9_.]+\\)'"
 574             end 'limit)
 575       (let ((e (make-extent (match-beginning 1) (match-end 1))))
 576         (set-extent-face e 'hyper-apropos-hyperlink)
 577         (set-extent-property e 'mouse-face 'highlight)))
 578     (goto-char beg)
 579     (while (re-search-forward
 580             "M-x \\([-a-zA-Z0-9_][-a-zA-Z0-9_][-a-zA-Z0-9_.]+\\)"
 581             end 'limit)
 582       (let ((e (make-extent (match-beginning 1) (match-end 1))))
 583         (set-extent-face e 'hyper-apropos-hyperlink)
 584         (set-extent-property e 'mouse-face 'highlight)))))
 585
 586 (defun hyper-apropos-insert-keybinding (keys string)
 587   (if keys
 588       (insert "  (" string " bound to \""
 589               (mapconcat 'key-description
 590                          (sort* keys #'< :key #'length)
 591                          "\", \"")
 592               "\")\n")))
 593
 594 (defun hyper-apropos-insert-section-heading (alias-desc &optional desc)
 595   (or desc (setq desc alias-desc
 596                  alias-desc nil))
 597   (if alias-desc
 598       (setq desc (concat alias-desc
 599                          (if (memq (aref desc 0)
 600                                    '(?a ?e ?i ?o ?u))
 601                              ", an " ", a ")
 602                          desc)))
 603   (aset desc 0 (upcase (aref desc 0))) ; capitalize
 604   (goto-char (point-max))
 605   (newline 3) (delete-blank-lines) (newline 2)
 606   (hyper-apropos-insert-face desc 'hyper-apropos-section-heading))
 607
 608 (defun hyper-apropos-insert-value (string symbol val)
 609   (insert-face string 'hyper-apropos-heading)
 610   (insert (if (symbol-value symbol)
 611               (if (or (null val) (eq val t) (integerp val))
 612                   (prog1
 613                       (symbol-value symbol)
 614                     (set symbol nil))
 615                 "see below")
 616             "is void")))
 617
 618 (defun hyper-apropos-follow-ref-buffer (this-ref-buffer)
 619   (and (not this-ref-buffer)
 620        (eq major-mode 'hyper-apropos-help-mode)
 621        hyper-apropos-ref-buffer
 622        (buffer-live-p hyper-apropos-ref-buffer)))
 623
 624 (defun hyper-apropos-get-alias (symbol alias-p next-symbol &optional use)
 625   "Return (TERMINAL-SYMBOL . ALIAS-DESC)."
 626   (let (aliases)
 627     (while (funcall alias-p symbol)
 628       (setq aliases (cons (if use (funcall use symbol) symbol) aliases))
 629       (setq symbol (funcall next-symbol symbol)))
 630     (cons symbol
 631           (and aliases
 632                (concat "an alias for `"
 633                        (mapconcat 'symbol-name
 634                                   (nreverse aliases)
 635                                   "',\nwhich is an alias for `")
 636                        "'")))))
 637
 638 (defun hyper-apropos-get-doc (&optional symbol force type this-ref-buffer)
 639   ;; #### - update this docstring
 640   "Toggle display of documentation for the symbol on the current line."
 641   ;; SYMBOL is the symbol to document.  FORCE, if non-nil, means to
 642   ;; regenerate the documentation even if it already seems to be there.  And
 643   ;; TYPE, if present, forces the generation of only variable documentation
 644   ;; or only function documentation.  Normally, if both are present, then
 645   ;; both will be generated.
 646   ;;
 647   ;; TYPES TO IMPLEMENT: obsolete face
 648   ;;
 649   (interactive)
 650   (or symbol
 651       (setq symbol (hyper-apropos-this-symbol)))
 652   (or type
 653       (setq type '(function variable face)))
 654   (if (and (eq hyper-apropos-currently-showing symbol)
 655            (get-buffer hyper-apropos-help-buf)
 656            (get-buffer-window hyper-apropos-help-buf)
 657            (not force))
 658       ;; we're already displaying this help, so toggle its display.
 659       (delete-windows-on hyper-apropos-help-buf)
 660     ;; OK, we've got to refresh and display it...
 661     (or (eq symbol (car hyper-apropos-help-history))
 662         (setq hyper-apropos-help-history
 663               (if (eq major-mode 'hyper-apropos-help-mode)
 664                   ;; if we're following a link in the help buffer, then
 665                   ;; record that in the help history.
 666                   (cons symbol hyper-apropos-help-history)
 667                 ;; otherwise clear the history because it's a new search.
 668                 (list symbol))))
 669     (save-excursion
 670       (if (hyper-apropos-follow-ref-buffer this-ref-buffer)
 671           (set-buffer hyper-apropos-ref-buffer)
 672         (setq hyper-apropos-ref-buffer (current-buffer)))
 673       (let (standard-output
 674             ok beg
 675             newsym symtype doc obsolete
 676             (local mode-name)
 677             global local-str global-str
 678             font fore back undl
 679             aliases alias-desc desc)
 680         (save-excursion
 681           (set-buffer (get-buffer-create hyper-apropos-help-buf))
 682           ;;(setq standard-output (current-buffer))
 683           (setq buffer-read-only nil)
 684           (erase-buffer)
 685           (insert-face (format "`%s'" symbol) 'hyper-apropos-major-heading)
 686           (insert (format " (buffer: %s, mode: %s)\n"
 687                           (buffer-name hyper-apropos-ref-buffer)
 688                           local)))
 689         ;; function ----------------------------------------------------------
 690         (and (memq 'function type)
 691              (fboundp symbol)
 692              (progn
 693                (setq ok t)
 694                (setq aliases (hyper-apropos-get-alias (symbol-function symbol)
 695                                                  'symbolp
 696                                                  'symbol-function)
 697                      newsym (car aliases)
 698                      alias-desc (cdr aliases))
 699                (if (eq 'macro (car-safe newsym))
 700                    (setq desc "macro"
 701                          newsym (cdr newsym))
 702                  (setq desc "function"))
 703                (setq symtype (cond ((subrp newsym)                   'subr)
 704                                    ((compiled-function-p newsym)     'bytecode)
 705                                    ((eq (car-safe newsym) 'autoload) 'autoload)
 706                                    ((eq (car-safe newsym) 'lambda)   'lambda))
 707                      desc (concat (if (commandp symbol) "interactive ")
 708                                   (cdr (assq symtype
 709                                              '((subr     . "built-in ")
 710                                                (bytecode . "compiled Lisp ")
 711                                                (autoload . "autoloaded Lisp ")
 712                                                (lambda   . "Lisp "))))
 713                                   desc
 714                                   (case symtype
 715                                     ((autoload) (format ",\n(autoloaded from \"%s\")"
 716                                                         (nth 1 newsym)))
 717                                     ((bytecode) (format ",\n(loaded from \"%s\")"
 718                                                         (symbol-file symbol)))))
 719                      local (current-local-map)
 720                      global (current-global-map)
 721                      obsolete (get symbol 'byte-obsolete-info)
 722                      doc (or (documentation symbol) "function not documented"))
 723                (save-excursion
 724                  (set-buffer hyper-apropos-help-buf)
 725                  (goto-char (point-max))
 726                  (setq standard-output (current-buffer))
 727                  (hyper-apropos-insert-section-heading alias-desc desc)
 728                  (insert ":\n")
 729                  (if local
 730                      (hyper-apropos-insert-keybinding
 731                       (where-is-internal symbol (list local) nil nil nil)
 732                       "locally"))
 733                  (hyper-apropos-insert-keybinding
 734                   (where-is-internal symbol (list global) nil nil nil)
 735                   "globally")
 736                  (insert "\n")
 737                  (if obsolete
 738                      (hyper-apropos-insert-face
 739                       (format "%s is an obsolete function; %s\n\n" symbol
 740                               (if (stringp (car obsolete))
 741                                   (car obsolete)
 742                                 (format "use `%s' instead." (car obsolete))))
 743                       'hyper-apropos-warning))
 744                  (setq beg (point))
 745                  (insert-face "arguments: " 'hyper-apropos-heading)
 746                  (cond ((eq symtype 'lambda)
 747                         (princ (or (nth 1 newsym) "()")))
 748                        ((eq symtype 'bytecode)
 749                         (princ (or (compiled-function-arglist newsym)
 750                                    "()")))
 751                        ((and (eq symtype 'subr)
 752                              (string-match
 753                               "[\n\t ]*\narguments: ?\\((.*)\\)\n?\\'"
 754                               doc))
 755                         (insert (substring doc
 756                                            (match-beginning 1)
 757                                            (match-end 1)))
 758                         (setq doc (substring doc 0 (match-beginning 0))))
 759                        ((and (eq symtype 'subr)
 760                              (string-match
 761                               "\
 762 \[\n\t ]*([^\n\t )]+[\t ]*\\([^\n)]+\\)?)\\(:[\t ]*\\|\n?\\'\\)"
 763                               doc))
 764                         (insert "("
 765                                 (if (match-end 1)
 766                                     (substring doc
 767                                                (match-beginning 1)
 768                                                (match-end 1)))
 769                                 ")")
 770                         (setq doc (substring doc (match-end 0))))
 771                        (t (princ "[not available]")))
 772                  (insert "\n\n")
 773                  (hyper-apropos-insert-face doc)
 774                  (insert "\n")
 775                  (indent-rigidly beg (point) 2))))
 776         ;; variable ----------------------------------------------------------
 777         (and (memq 'variable type)
 778              (or (boundp symbol) (default-boundp symbol))
 779              (progn
 780                (setq ok t)
 781                (setq aliases (hyper-apropos-get-alias symbol
 782                                                  'variable-alias
 783                                                  'variable-alias
 784                                                  'variable-alias)
 785                      newsym (car aliases)
 786                      alias-desc (cdr aliases))
 787                (setq symtype (or (local-variable-p newsym (current-buffer))
 788                                  (and (local-variable-p newsym
 789                                                         (current-buffer) t)
 790                                       'auto-local))
 791                      desc (concat (and (get newsym 'custom-type)
 792                                        "customizable ")
 793                                   (if (user-variable-p newsym)
 794                                       "user variable"
 795                                     "variable")
 796                                   (cond ((eq symtype t) ", buffer-local")
 797                                         ((eq symtype 'auto-local)
 798                                          ", local when set")))
 799                      local (and (boundp newsym)
 800                                 (symbol-value newsym))
 801                      local-str (and (boundp newsym)
 802                                     (prin1-to-string local))
 803                      global (and (eq symtype t)
 804                                  (default-boundp newsym)
 805                                  (default-value newsym))
 806                      global-str (and (eq symtype t)
 807                                      (default-boundp newsym)
 808                                      (prin1-to-string global))
 809                      obsolete (get symbol 'byte-obsolete-variable)
 810                      doc (or (documentation-property symbol
 811                                                      'variable-documentation)
 812                              "variable not documented"))
 813                (save-excursion
 814                  (set-buffer hyper-apropos-help-buf)
 815                  (goto-char (point-max))
 816                  (setq standard-output (current-buffer))
 817                  (hyper-apropos-insert-section-heading alias-desc desc)
 818                  (when (and (user-variable-p newsym)
 819                             (get newsym 'custom-type))
 820                    (let ((e (make-extent (point-at-bol) (point))))
 821                      (set-extent-property e 'mouse-face 'highlight)
 822                      (set-extent-property e 'help-echo
 823                                           (format "Customize %s" newsym))
 824                      (set-extent-property
 825                       e 'hyper-apropos-custom
 826                       `(lambda () (customize-variable (quote ,newsym))))))
 827                  (insert ":\n\n")
 828                  (setq beg (point))
 829                  (if obsolete
 830                      (hyper-apropos-insert-face
 831                       (format "%s is an obsolete function; %s\n\n" symbol
 832                               (if (stringp obsolete)
 833                                   obsolete
 834                                 (format "use `%s' instead." obsolete)))
 835                       'hyper-apropos-warning))
 836                  ;; generally, the value of the variable is short and the
 837                  ;; documentation of the variable long, so it's desirable
 838                  ;; to see all of the value and the start of the
 839                  ;; documentation.  Some variables, though, have huge and
 840                  ;; nearly meaningless values that force you to page
 841                  ;; forward just to find the doc string.  That is
 842                  ;; undesirable.
 843                  (if (and (or (null local-str) (< (length local-str) 69))
 844                           (or (null global-str) (< (length global-str) 69)))
 845                                         ; 80 cols.  docstrings assume this.
 846                      (progn (insert-face "value: " 'hyper-apropos-heading)
 847                             (insert (or local-str "is void"))
 848                             (if (eq symtype t)
 849                                 (progn
 850                                   (insert "\n")
 851                                   (insert-face "default value: " 'hyper-apropos-heading)
 852                                   (insert (or global-str "is void"))))
 853                             (insert "\n\n")
 854                             (hyper-apropos-insert-face doc))
 855                    (hyper-apropos-insert-value "value: " 'local-str local)
 856                    (if (eq symtype t)
 857                        (progn
 858                          (insert ", ")
 859                          (hyper-apropos-insert-value "default-value: "
 860                                                 'global-str global)))
 861                    (insert "\n\n")
 862                    (hyper-apropos-insert-face doc)
 863                    (if local-str
 864                        (progn
 865                          (newline 3) (delete-blank-lines) (newline 1)
 866                          (insert-face "value: " 'hyper-apropos-heading)
 867                          (if hyper-apropos-prettyprint-long-values
 868                              (condition-case nil
 869                                  (cl-prettyprint local)
 870                                (error (insert local-str)))
 871                            (insert local-str))))
 872                    (if global-str
 873                        (progn
 874                          (newline 3) (delete-blank-lines) (newline 1)
 875                          (insert-face "default value: " 'hyper-apropos-heading)
 876                          (if hyper-apropos-prettyprint-long-values
 877                              (condition-case nil
 878                                  (cl-prettyprint global)
 879                                (error (insert global-str)))
 880                            (insert global-str)))))
 881                  (indent-rigidly beg (point) 2))))
 882         ;; face --------------------------------------------------------------
 883         (and (memq 'face type)
 884              (find-face symbol)
 885              (progn
 886                (setq ok t)
 887                (copy-face symbol 'hyper-apropos-temp-face 'global)
 888                (mapcar #'(lambda (property)
 889                            (setq symtype (face-property-instance symbol
 890                                                                  property))
 891                            (if symtype
 892                                (set-face-property 'hyper-apropos-temp-face
 893                                                   property
 894                                                   symtype)))
 895                        built-in-face-specifiers)
 896                (setq font (cons (face-property-instance symbol 'font nil 0 t)
 897                                 (face-property-instance symbol 'font))
 898                      fore (cons (face-foreground-instance symbol nil 0 t)
 899                                 (face-foreground-instance symbol))
 900                      back (cons (face-background-instance symbol nil 0 t)
 901                                 (face-background-instance symbol))
 902                      undl (cons (face-underline-p symbol nil 0 t)
 903                                 (face-underline-p symbol))
 904                      doc  (face-doc-string symbol))
 905                ;; #### - add some code here
 906                (save-excursion
 907                  (set-buffer hyper-apropos-help-buf)
 908                  (setq standard-output (current-buffer))
 909                  (hyper-apropos-insert-section-heading
 910                   (concat "Face"
 911                           (when (get symbol 'face-defface-spec)
 912                             (let* ((str " (customizable)")
 913                                    (e (make-extent 1 (length str) str)))
 914                               (set-extent-property e 'mouse-face 'highlight)
 915                               (set-extent-property e 'help-echo
 916                                                    (format "Customize %s" symbol))
 917                               (set-extent-property e 'unique t)
 918                               (set-extent-property e 'duplicable t)
 919                               (set-extent-property
 920                                e 'hyper-apropos-custom
 921                                `(lambda () (customize-face (quote ,symbol))))
 922                               str))
 923                           ":\n\n  "))
 924                  (insert-face "\
 925 ABCDEFHIJKLMNOPQRSTUVWXYZ abcdefhijklmnopqrstuvwxyz 0123456789"
 926                               'hyper-apropos-temp-face)
 927                  (newline 2)
 928                  (insert-face "  Font: " 'hyper-apropos-heading)
 929                  (insert (format (if (numberp (car font)) "(%s)\n" "%s\n")
 930                                  (and (cdr font)
 931                                       (font-instance-name (cdr font)))))
 932                  (insert-face "  Foreground: " 'hyper-apropos-heading)
 933                  (insert (format (if (numberp (car fore)) "(%s)\n" "%s\n")
 934                                  (and (cdr fore)
 935                                       (color-instance-name (cdr fore)))))
 936                  (insert-face "  Background: " 'hyper-apropos-heading)
 937                  (insert (format (if (numberp (car back)) "(%s)\n" "%s\n")
 938                                  (and (cdr back)
 939                                       (color-instance-name (cdr back)))))
 940                  (insert-face "  Underline: " 'hyper-apropos-heading)
 941                  (insert (format (if (numberp (car undl)) "(%s)\n" "%s\n")
 942                                  (cdr undl)))
 943                  (if doc
 944                      (progn
 945                        (newline)
 946                        (setq beg (point))
 947                        (insert doc)
 948                        (indent-rigidly beg (point) 2))))))
 949         ;; not bound & property list -----------------------------------------
 950         (or ok
 951             (save-excursion
 952               (set-buffer hyper-apropos-help-buf)
 953               (hyper-apropos-insert-section-heading
 954                "symbol is not currently bound\n")))
 955         (if (and (setq symtype (symbol-plist symbol))
 956                  (or (> (length symtype) 2)
 957                      (not (memq 'variable-documentation symtype))))
 958             (save-excursion
 959               (set-buffer hyper-apropos-help-buf)
 960               (goto-char (point-max))
 961               (setq standard-output (current-buffer))
 962               (hyper-apropos-insert-section-heading "property-list:\n\n")
 963               (while symtype
 964                 (if (memq (car symtype)
 965                           '(variable-documentation byte-obsolete-info))
 966                     (setq symtype (cdr symtype))
 967                   (insert-face (concat "  " (symbol-name (car symtype))
 968                                        ": ")
 969                                'hyper-apropos-heading)
 970                   (setq symtype (cdr symtype))
 971                   (indent-to 32)
 972                   (insert (prin1-to-string (car symtype)) "\n"))
 973                 (setq symtype (cdr symtype)))))))
 974     (save-excursion
 975       (set-buffer hyper-apropos-help-buf)
 976       (goto-char (point-min))
 977       ;; pop up window and shrink it if it's wasting space
 978       (if hyper-apropos-shrink-window
 979           (shrink-window-if-larger-than-buffer
 980            (display-buffer (current-buffer)))
 981         (display-buffer (current-buffer)))
 982       (hyper-apropos-help-mode))
 983     (setq hyper-apropos-currently-showing symbol)))
 984 ;;;###autoload
 985 (define-obsolete-function-alias
 986   'hypropos-get-doc 'hyper-apropos-get-doc)
 987
 988 ; -----------------------------------------------------------------------------
 989
 990 (defun hyper-apropos-help-mode ()
 991   "Major mode for hypertext XEmacs help.  In this mode, you can quickly
 992 follow links between back and forth between the documentation strings for
 993 different variables and functions.  Common commands:
 994
 995 \\{hyper-apropos-help-map}"
 996   (setq buffer-read-only t
 997         major-mode           'hyper-apropos-help-mode
 998         mode-name            "Hyper-Help")
 999   (set-syntax-table emacs-lisp-mode-syntax-table)
1000   (use-local-map hyper-apropos-help-map))
1001
1002 ;; ---------------------------------------------------------------------- ;;
1003
1004 (defun hyper-apropos-scroll-up ()
1005   "Scroll up the \"*Hyper Help*\" buffer if it's visible.
1006 Otherwise, scroll the selected window up."
1007   (interactive)
1008   (let ((win (get-buffer-window hyper-apropos-help-buf))
1009         (owin (selected-window)))
1010     (if win
1011         (progn
1012           (select-window win)
1013           (condition-case nil
1014                (scroll-up nil)
1015               (error (goto-char (point-max))))
1016           (select-window owin))
1017       (scroll-up nil))))
1018
1019 (defun hyper-apropos-scroll-down ()
1020   "Scroll down the \"*Hyper Help*\" buffer if it's visible.
1021 Otherwise, scroll the selected window down."
1022   (interactive)
1023   (let ((win (get-buffer-window hyper-apropos-help-buf))
1024         (owin (selected-window)))
1025     (if win
1026         (progn
1027           (select-window win)
1028           (condition-case nil
1029                (scroll-down nil)
1030               (error (goto-char (point-max))))
1031           (select-window owin))
1032       (scroll-down nil))))
1033
1034 ;; ---------------------------------------------------------------------- ;;
1035
1036 (defun hyper-apropos-mouse-get-doc (event)
1037   "Get the documentation for the symbol the mouse is on."
1038   (interactive "e")
1039   (mouse-set-point event)
1040   (let ((e (extent-at (point) nil 'hyper-apropos-custom)))
1041     (if e
1042         (funcall (extent-property e 'hyper-apropos-custom))
1043       (save-excursion
1044         (let ((symbol (hyper-apropos-this-symbol)))
1045           (if symbol
1046               (hyper-apropos-get-doc symbol)
1047             (error "Click on a symbol")))))))
1048
1049 ;; ---------------------------------------------------------------------- ;;
1050
1051 (defun hyper-apropos-add-keyword (pattern)
1052   "Use additional keyword to narrow regexp match.
1053 Deletes lines which don't match PATTERN."
1054   (interactive "sAdditional Keyword: ")
1055   (save-excursion
1056     (goto-char (point-min))
1057     (let (buffer-read-only)
1058       (keep-lines (concat pattern "\\|" hyper-apropos-junk-regexp))
1059       )))
1060
1061 (defun hyper-apropos-eliminate-keyword (pattern)
1062   "Use additional keyword to eliminate uninteresting matches.
1063 Deletes lines which match PATTERN."
1064   (interactive "sKeyword to eliminate: ")
1065   (save-excursion
1066     (goto-char (point-min))
1067     (let (buffer-read-only)
1068       (flush-lines pattern))
1069       ))
1070
1071 ;; ---------------------------------------------------------------------- ;;
1072
1073 (defun hyper-apropos-this-symbol ()
1074   (save-excursion
1075     (cond ((eq major-mode 'hyper-apropos-mode)
1076            (beginning-of-line)
1077            (if (looking-at hyper-apropos-junk-regexp)
1078                nil
1079              (forward-char 3)
1080              (read (point-marker))))
1081           (t
1082            (let* ((st (progn
1083                         (skip-syntax-backward "w_")
1084                         ;; !@(*$^%%# stupid backquote implementation!!!
1085                         (skip-chars-forward "`")
1086                         (point)))
1087                   (en (progn
1088                         (skip-syntax-forward "w_")
1089                         (skip-chars-backward ".':") ; : for Local Variables
1090                         (point))))
1091              (and (not (eq st en))
1092                   (intern-soft (buffer-substring st en))))))))
1093
1094 (defun hyper-apropos-where-is (symbol)
1095   "Find keybinding for symbol on current line."
1096   (interactive (list (hyper-apropos-this-symbol)))
1097   (where-is symbol))
1098
1099 (defun hyper-apropos-invoke-fn (fn)
1100   "Interactively invoke the function on the current line."
1101   (interactive (list (hyper-apropos-this-symbol)))
1102   (cond ((not (fboundp fn))
1103          (error "%S is not a function" fn))
1104         (t (call-interactively fn))))
1105
1106 ;;;###autoload
1107 (defun hyper-set-variable (var val &optional this-ref-buffer)
1108   (interactive
1109    (let ((var (hyper-apropos-read-variable-symbol
1110                (if (hyper-apropos-follow-ref-buffer current-prefix-arg)
1111                    "In ref buffer, set user option"
1112                  "Set user option")
1113                'user-variable-p)))
1114      (list var (hyper-apropos-read-variable-value var) current-prefix-arg)))
1115   (hyper-apropos-set-variable var val this-ref-buffer))
1116
1117 ;;;###autoload
1118 (defun hyper-apropos-set-variable (var val &optional this-ref-buffer)
1119   "Interactively set the variable on the current line."
1120   (interactive
1121    (let ((var (hyper-apropos-this-symbol)))
1122      (or (and var (boundp var))
1123          (and (setq var (and (eq major-mode 'hyper-apropos-help-mode)
1124                              (save-excursion
1125                                (goto-char (point-min))
1126                                (hyper-apropos-this-symbol))))
1127               (boundp var))
1128          (setq var nil))
1129      (list var (hyper-apropos-read-variable-value var))))
1130   (and var
1131        (boundp var)
1132        (progn
1133          (if (hyper-apropos-follow-ref-buffer this-ref-buffer)
1134              (save-excursion
1135                (set-buffer hyper-apropos-ref-buffer)
1136                (set var val))
1137            (set var val))
1138          (hyper-apropos-get-doc var t '(variable) this-ref-buffer))))
1139 ;;;###autoload
1140 (define-obsolete-function-alias
1141   'hypropos-set-variable 'hyper-apropos-set-variable)
1142
1143 (defun hyper-apropos-read-variable-value (var &optional this-ref-buffer)
1144   (and var
1145        (boundp var)
1146        (let ((prop (get var 'variable-interactive))
1147              (print-readably t)
1148              val str)
1149          (hyper-apropos-get-doc var t '(variable) current-prefix-arg)
1150          (if prop
1151              (call-interactively (list 'lambda '(arg)
1152                                        (list 'interactive prop)
1153                                        'arg))
1154            (setq val (if (hyper-apropos-follow-ref-buffer this-ref-buffer)
1155                          (save-excursion
1156                            (set-buffer hyper-apropos-ref-buffer)
1157                            (symbol-value var))
1158                        (symbol-value var))
1159                  str (prin1-to-string val))
1160            (eval-minibuffer
1161             (format "Set %s `%s' to value (evaluated): "
1162                     (if (user-variable-p var) "user option" "Variable")
1163                     var)
1164             (condition-case nil
1165                 (progn
1166                   (read str)
1167                   (format (if (or (consp val)
1168                                   (and (symbolp val)
1169                                        (not (memq val '(t nil)))))
1170                               "'%s" "%s")
1171                           str))
1172               (error nil)))))))
1173
1174 (defun hyper-apropos-customize-variable ()
1175   (interactive)
1176   (let ((var (hyper-apropos-this-symbol)))
1177     (customize-variable var)))
1178
1179 ;; ---------------------------------------------------------------------- ;;
1180
1181 (defun hyper-apropos-find-tag (&optional tag-name)
1182   "Find the tag for the symbol on the current line in other window.  In
1183 order for this to work properly, the variable `tag-table-alist' or
1184 `tags-file-name' must be set so that a TAGS file with tags for the emacs
1185 source is found for the \"*Hyper Apropos*\" buffer."
1186   (interactive)
1187   ;; there ought to be a default tags file for this...
1188   (or tag-name (setq tag-name (symbol-name (hyper-apropos-this-symbol))))
1189   (find-tag-other-window (list tag-name)))
1190
1191 ;; ---------------------------------------------------------------------- ;;
1192
1193 (defun hyper-apropos-find-function (fn)
1194   "Find the function for the symbol on the current line in other
1195 window.  (See also `find-function'.)"
1196   (interactive
1197    (let ((fn (hyper-apropos-this-symbol)))
1198      (or (fboundp fn)
1199          (and (setq fn (and (eq major-mode 'hyper-apropos-help-mode)
1200                             (save-excursion
1201                               (goto-char (point-min))
1202                               (hyper-apropos-this-symbol))))
1203               (fboundp fn))
1204          (setq fn nil))
1205      (list fn)))
1206   (if fn
1207       (find-function-other-window fn)))
1208
1209 ;; ---------------------------------------------------------------------- ;;
1210
1211 (defun hyper-apropos-disassemble (sym)
1212   "Disassemble FUN if it is byte-coded.  If it's a lambda, prettyprint it."
1213   (interactive (list (hyper-apropos-this-symbol)))
1214   (let ((fun sym) (trail nil) macrop)
1215     (while (and (symbolp fun) (not (memq fun trail)))
1216       (setq trail (cons fun trail)
1217             fun (symbol-function fun)))
1218     (and (symbolp fun)
1219          (error "Loop detected in function binding of `%s'" fun))
1220     (setq macrop (and  (consp fun)
1221                        (eq 'macro (car fun))))
1222     (cond ((compiled-function-p (if macrop (cdr fun) fun))
1223            (disassemble fun)
1224            (set-buffer "*Disassemble*")
1225            (goto-char (point-min))
1226            (forward-sexp 2)
1227            (insert (format " for function `%S'" sym))
1228            )
1229           ((consp fun)
1230            (with-current-buffer "*Disassemble*"
1231              (cl-prettyprint (if macrop
1232                                  (cons 'defmacro (cons sym (cdr (cdr fun))))
1233                                (cons 'defun (cons sym (cdr fun))))))
1234            (set-buffer "*Disassemble*")
1235            (emacs-lisp-mode))
1236           ((or (vectorp fun) (stringp fun))
1237            ;; #### - do something fancy here
1238            (with-output-to-temp-buffer "*Disassemble*"
1239              (princ (format "%s is a keyboard macro:\n\n\t" sym))
1240              (prin1 fun)))
1241           (t
1242            (error "Sorry, cannot disassemble `%s'" sym)))))
1243
1244 ;; ---------------------------------------------------------------------- ;;
1245
1246 (defun hyper-apropos-quit ()
1247   (interactive)
1248   "Quit Hyper Apropos and restore original window config."
1249   (let ((buf (get-buffer hyper-apropos-apropos-buf)))
1250     (and buf (bury-buffer buf)))
1251   (set-window-configuration hyper-apropos-prev-wconfig))
1252
1253 ;; ---------------------------------------------------------------------- ;;
1254
1255 ;;;###autoload
1256 (defun hyper-apropos-popup-menu (event)
1257   (interactive "e")
1258   (mouse-set-point event)
1259   (let* ((sym (or (hyper-apropos-this-symbol)
1260                   (and (eq major-mode 'hyper-apropos-help-mode)
1261                        (save-excursion
1262                          (goto-char (point-min))
1263                          (hyper-apropos-this-symbol)))))
1264          (notjunk (not (null sym)))
1265          (command-p (if (commandp sym) t))
1266          (variable-p (and sym (boundp sym)))
1267          (customizable-p (and variable-p
1268                               (get sym 'custom-type)
1269                               t))
1270          (function-p (fboundp sym))
1271          (apropos-p (eq 'hyper-apropos-mode
1272                         (save-excursion (set-buffer (event-buffer event))
1273                                         major-mode)))
1274          (name (if sym (symbol-name sym) ""))
1275          (hyper-apropos-menu
1276           (delete
1277            nil
1278            (list (concat "Hyper-Help: " name)
1279             (vector "Display documentation" 'hyper-apropos-get-doc   notjunk)
1280             (vector "Set variable"      'hyper-apropos-set-variable variable-p)
1281             (vector "Customize variable" 'hyper-apropos-customize-variable
1282                     customizable-p)
1283             (vector "Show keys for"     'hyper-apropos-where-is      command-p)
1284             (vector "Invoke command"    'hyper-apropos-invoke-fn     command-p)
1285             (vector "Find function"    'hyper-apropos-find-function function-p)
1286             (vector "Find tag"          'hyper-apropos-find-tag notjunk)
1287             (and apropos-p
1288                  ["Add keyword..." hyper-apropos-add-keyword    t])
1289             (and apropos-p
1290                  ["Eliminate keyword..." hyper-apropos-eliminate-keyword  t])
1291             (if apropos-p
1292                 ["Programmers' Apropos" hyper-apropos-toggle-programming-flag
1293                  :style toggle :selected hyper-apropos-programming-apropos]
1294               ["Programmers' Help" hyper-apropos-toggle-programming-flag
1295                :style toggle :selected hyper-apropos-programming-apropos])
1296             (and hyper-apropos-programming-apropos
1297                  (vector "Disassemble function"
1298                          'hyper-apropos-disassemble
1299                          function-p))
1300             ["Help"                     describe-mode           t]
1301             ["Quit"                     hyper-apropos-quit              t]
1302             ))))
1303     (popup-menu hyper-apropos-menu)))
1304 ;;;###autoload
1305 (define-obsolete-function-alias
1306   'hypropos-popup-menu 'hyper-apropos-popup-menu)
1307
1308 (provide 'hyper-apropos)
1309
1310 ;; end of hyper-apropos.el