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