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