| 1 | ;;; wid-browse.el --- functions for browsing widgets |
| 2 | ;; |
| 3 | ;; Copyright (C) 1997 Free Software Foundation, Inc. |
| 4 | ;; |
| 5 | ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> |
| 6 | ;; Keywords: extensions |
| 7 | |
| 8 | ;; This file is part of GNU Emacs. |
| 9 | |
| 10 | ;; GNU Emacs is free software; you can redistribute it and/or modify |
| 11 | ;; it under the terms of the GNU General Public License as published by |
| 12 | ;; the Free Software Foundation; either version 2, or (at your option) |
| 13 | ;; any later version. |
| 14 | |
| 15 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 18 | ;; GNU General Public License for more details. |
| 19 | |
| 20 | ;; You should have received a copy of the GNU General Public License |
| 21 | ;; along with GNU Emacs; see the file COPYING. If not, write to the |
| 22 | ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
| 23 | ;; Boston, MA 02110-1301, USA. |
| 24 | |
| 25 | ;;; Commentary: |
| 26 | ;; |
| 27 | ;; Widget browser. See `widget.el'. |
| 28 | |
| 29 | ;;; Code: |
| 30 | |
| 31 | (require 'easymenu) |
| 32 | (require 'custom) |
| 33 | (require 'wid-edit) |
| 34 | (eval-when-compile (require 'cl)) |
| 35 | |
| 36 | (defgroup widget-browse nil |
| 37 | "Customization support for browsing widgets." |
| 38 | :group 'widgets) |
| 39 | |
| 40 | ;;; The Mode. |
| 41 | |
| 42 | (defvar widget-browse-mode-map nil |
| 43 | "Keymap for `widget-browse-mode'.") |
| 44 | |
| 45 | (unless widget-browse-mode-map |
| 46 | (setq widget-browse-mode-map (make-sparse-keymap)) |
| 47 | (set-keymap-parent widget-browse-mode-map widget-keymap) |
| 48 | (define-key widget-browse-mode-map "q" 'bury-buffer)) |
| 49 | |
| 50 | (easy-menu-define widget-browse-mode-customize-menu |
| 51 | widget-browse-mode-map |
| 52 | "Menu used in widget browser buffers." |
| 53 | (customize-menu-create 'widgets)) |
| 54 | |
| 55 | (easy-menu-define widget-browse-mode-menu |
| 56 | widget-browse-mode-map |
| 57 | "Menu used in widget browser buffers." |
| 58 | '("Widget" |
| 59 | ["Browse" widget-browse t] |
| 60 | ["Browse At" widget-browse-at t])) |
| 61 | |
| 62 | (defcustom widget-browse-mode-hook nil |
| 63 | "Hook called when entering widget-browse-mode." |
| 64 | :type 'hook |
| 65 | :group 'widget-browse) |
| 66 | |
| 67 | (defun widget-browse-mode () |
| 68 | "Major mode for widget browser buffers. |
| 69 | |
| 70 | The following commands are available: |
| 71 | |
| 72 | \\[widget-forward] Move to next button or editable field. |
| 73 | \\[widget-backward] Move to previous button or editable field. |
| 74 | \\[widget-button-click] Activate button under the mouse pointer. |
| 75 | \\[widget-button-press] Activate button under point. |
| 76 | |
| 77 | Entry to this mode calls the value of `widget-browse-mode-hook' |
| 78 | if that value is non-nil." |
| 79 | (kill-all-local-variables) |
| 80 | (setq major-mode 'widget-browse-mode |
| 81 | mode-name "Widget") |
| 82 | (use-local-map widget-browse-mode-map) |
| 83 | (easy-menu-add widget-browse-mode-customize-menu) |
| 84 | (easy-menu-add widget-browse-mode-menu) |
| 85 | (run-mode-hooks 'widget-browse-mode-hook)) |
| 86 | |
| 87 | (put 'widget-browse-mode 'mode-class 'special) |
| 88 | |
| 89 | ;;; Commands. |
| 90 | |
| 91 | ;;;###autoload |
| 92 | (defun widget-browse-at (pos) |
| 93 | "Browse the widget under point." |
| 94 | (interactive "d") |
| 95 | (let* ((field (get-char-property pos 'field)) |
| 96 | (button (get-char-property pos 'button)) |
| 97 | (doc (get-char-property pos 'widget-doc)) |
| 98 | (text (cond (field "This is an editable text area.") |
| 99 | (button "This is an active area.") |
| 100 | (doc "This is documentation text.") |
| 101 | (t "This is unidentified text."))) |
| 102 | (widget (or field button doc))) |
| 103 | (when widget |
| 104 | (widget-browse widget)) |
| 105 | (message text))) |
| 106 | |
| 107 | (defvar widget-browse-history nil) |
| 108 | |
| 109 | ;;;###autoload |
| 110 | (defun widget-browse (widget) |
| 111 | "Create a widget browser for WIDGET." |
| 112 | (interactive (list (completing-read "Widget: " |
| 113 | obarray |
| 114 | (lambda (symbol) |
| 115 | (get symbol 'widget-type)) |
| 116 | t nil 'widget-browse-history))) |
| 117 | (if (stringp widget) |
| 118 | (setq widget (intern widget))) |
| 119 | (unless (if (symbolp widget) |
| 120 | (get widget 'widget-type) |
| 121 | (and (consp widget) |
| 122 | (get (widget-type widget) 'widget-type))) |
| 123 | (error "Not a widget")) |
| 124 | ;; Create the buffer. |
| 125 | (if (symbolp widget) |
| 126 | (let ((buffer (format "*Browse %s Widget*" widget))) |
| 127 | (kill-buffer (get-buffer-create buffer)) |
| 128 | (switch-to-buffer (get-buffer-create buffer))) |
| 129 | (kill-buffer (get-buffer-create "*Browse Widget*")) |
| 130 | (switch-to-buffer (get-buffer-create "*Browse Widget*"))) |
| 131 | (widget-browse-mode) |
| 132 | |
| 133 | ;; Quick way to get out. |
| 134 | ;; (widget-create 'push-button |
| 135 | ;; :action (lambda (widget &optional event) |
| 136 | ;; (bury-buffer)) |
| 137 | ;; "Quit") |
| 138 | ;; (widget-insert "\n") |
| 139 | |
| 140 | ;; Top text indicating whether it is a class or object browser. |
| 141 | (if (listp widget) |
| 142 | (widget-insert "Widget object browser.\n\nClass: ") |
| 143 | (widget-insert "Widget class browser.\n\n") |
| 144 | (widget-create 'widget-browse |
| 145 | :format "%[%v%]\n%d" |
| 146 | :doc (get widget 'widget-documentation) |
| 147 | widget) |
| 148 | (unless (eq (preceding-char) ?\n) |
| 149 | (widget-insert "\n")) |
| 150 | (widget-insert "\nSuper: ") |
| 151 | (setq widget (get widget 'widget-type))) |
| 152 | |
| 153 | ;; Now show the attributes. |
| 154 | (let ((name (car widget)) |
| 155 | (items (cdr widget)) |
| 156 | key value printer) |
| 157 | (widget-create 'widget-browse |
| 158 | :format "%[%v%]" |
| 159 | name) |
| 160 | (widget-insert "\n") |
| 161 | (while items |
| 162 | (setq key (nth 0 items) |
| 163 | value (nth 1 items) |
| 164 | printer (or (get key 'widget-keyword-printer) |
| 165 | 'widget-browse-sexp) |
| 166 | items (cdr (cdr items))) |
| 167 | (widget-insert "\n" (symbol-name key) "\n\t") |
| 168 | (funcall printer widget key value) |
| 169 | (widget-insert "\n"))) |
| 170 | (widget-setup) |
| 171 | (goto-char (point-min))) |
| 172 | |
| 173 | ;;;###autoload |
| 174 | (defun widget-browse-other-window (&optional widget) |
| 175 | "Show widget browser for WIDGET in other window." |
| 176 | (interactive) |
| 177 | (let ((window (selected-window))) |
| 178 | (switch-to-buffer-other-window "*Browse Widget*") |
| 179 | (if widget |
| 180 | (widget-browse widget) |
| 181 | (call-interactively 'widget-browse)) |
| 182 | (select-window window))) |
| 183 | |
| 184 | |
| 185 | ;;; The `widget-browse' Widget. |
| 186 | |
| 187 | (define-widget 'widget-browse 'push-button |
| 188 | "Button for creating a widget browser. |
| 189 | The :value of the widget shuld be the widget to be browsed." |
| 190 | :format "%[[%v]%]" |
| 191 | :value-create 'widget-browse-value-create |
| 192 | :action 'widget-browse-action) |
| 193 | |
| 194 | (defun widget-browse-action (widget &optional event) |
| 195 | ;; Create widget browser for WIDGET's :value. |
| 196 | (widget-browse (widget-get widget :value))) |
| 197 | |
| 198 | (defun widget-browse-value-create (widget) |
| 199 | ;; Insert type name. |
| 200 | (let ((value (widget-get widget :value))) |
| 201 | (cond ((symbolp value) |
| 202 | (insert (symbol-name value))) |
| 203 | ((consp value) |
| 204 | (insert (symbol-name (widget-type value)))) |
| 205 | (t |
| 206 | (insert "strange"))))) |
| 207 | |
| 208 | ;;; Keyword Printer Functions. |
| 209 | |
| 210 | (defun widget-browse-widget (widget key value) |
| 211 | "Insert description of WIDGET's KEY VALUE. |
| 212 | VALUE is assumed to be a widget." |
| 213 | (widget-create 'widget-browse value)) |
| 214 | |
| 215 | (defun widget-browse-widgets (widget key value) |
| 216 | "Insert description of WIDGET's KEY VALUE. |
| 217 | VALUE is assumed to be a list of widgets." |
| 218 | (while value |
| 219 | (widget-create 'widget-browse |
| 220 | (car value)) |
| 221 | (setq value (cdr value)) |
| 222 | (when value |
| 223 | (widget-insert " ")))) |
| 224 | |
| 225 | (defun widget-browse-sexp (widget key value) |
| 226 | "Insert description of WIDGET's KEY VALUE. |
| 227 | Nothing is assumed about value." |
| 228 | (let ((pp (condition-case signal |
| 229 | (pp-to-string value) |
| 230 | (error (prin1-to-string signal))))) |
| 231 | (when (string-match "\n\\'" pp) |
| 232 | (setq pp (substring pp 0 (1- (length pp))))) |
| 233 | (if (cond ((string-match "\n" pp) |
| 234 | nil) |
| 235 | ((> (length pp) (- (window-width) (current-column))) |
| 236 | nil) |
| 237 | (t t)) |
| 238 | (widget-insert pp) |
| 239 | (widget-create 'push-button |
| 240 | :tag "show" |
| 241 | :action (lambda (widget &optional event) |
| 242 | (with-output-to-temp-buffer |
| 243 | "*Pp Eval Output*" |
| 244 | (princ (widget-get widget :value)))) |
| 245 | pp)))) |
| 246 | |
| 247 | (defun widget-browse-sexps (widget key value) |
| 248 | "Insert description of WIDGET's KEY VALUE. |
| 249 | VALUE is assumed to be a list of widgets." |
| 250 | (let ((target (current-column))) |
| 251 | (while value |
| 252 | (widget-browse-sexp widget key (car value)) |
| 253 | (setq value (cdr value)) |
| 254 | (when value |
| 255 | (widget-insert "\n" (make-string target ?\ )))))) |
| 256 | |
| 257 | ;;; Keyword Printers. |
| 258 | |
| 259 | (put :parent 'widget-keyword-printer 'widget-browse-widget) |
| 260 | (put :children 'widget-keyword-printer 'widget-browse-widgets) |
| 261 | (put :buttons 'widget-keyword-printer 'widget-browse-widgets) |
| 262 | (put :button 'widget-keyword-printer 'widget-browse-widget) |
| 263 | (put :args 'widget-keyword-printer 'widget-browse-sexps) |
| 264 | |
| 265 | ;;; Widget Minor Mode. |
| 266 | |
| 267 | (defvar widget-minor-mode nil |
| 268 | "If non-nil, we are in Widget Minor Mode.") |
| 269 | (make-variable-buffer-local 'widget-minor-mode) |
| 270 | |
| 271 | (defvar widget-minor-mode-map nil |
| 272 | "Keymap used in Widget Minor Mode.") |
| 273 | |
| 274 | (unless widget-minor-mode-map |
| 275 | (setq widget-minor-mode-map (make-sparse-keymap)) |
| 276 | (set-keymap-parent widget-minor-mode-map widget-keymap)) |
| 277 | |
| 278 | ;;;###autoload |
| 279 | (defun widget-minor-mode (&optional arg) |
| 280 | "Togle minor mode for traversing widgets. |
| 281 | With arg, turn widget mode on if and only if arg is positive." |
| 282 | (interactive "P") |
| 283 | (cond ((null arg) |
| 284 | (setq widget-minor-mode (not widget-minor-mode))) |
| 285 | ((<= arg 0) |
| 286 | (setq widget-minor-mode nil)) |
| 287 | (t |
| 288 | (setq widget-minor-mode t))) |
| 289 | (force-mode-line-update)) |
| 290 | |
| 291 | (add-to-list 'minor-mode-alist '(widget-minor-mode " Widget")) |
| 292 | |
| 293 | (add-to-list 'minor-mode-map-alist |
| 294 | (cons 'widget-minor-mode widget-minor-mode-map)) |
| 295 | |
| 296 | ;;; The End: |
| 297 | |
| 298 | (provide 'wid-browse) |
| 299 | |
| 300 | ;;; arch-tag: d5ffb18f-8984-4735-8502-edf70456db21 |
| 301 | ;;; wid-browse.el ends here |