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