209
+ − 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 ;; Version: 1.9960
+ − 8 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
+ − 9
613
+ − 10 ;; This file is part of XEmacs.
209
+ − 11
613
+ − 12 ;; XEmacs is free software; you can redistribute it and/or modify
209
+ − 13 ;; it under the terms of the GNU General Public License as published by
+ − 14 ;; the Free Software Foundation; either version 2, or (at your option)
+ − 15 ;; any later version.
+ − 16
613
+ − 17 ;; XEmacs is distributed in the hope that it will be useful,
209
+ − 18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ − 19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ − 20 ;; GNU General Public License for more details.
+ − 21
+ − 22 ;; You should have received a copy of the GNU General Public License
613
+ − 23 ;; along with XEmacs; see the file COPYING. If not, write to the
209
+ − 24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+ − 25 ;; Boston, MA 02111-1307, USA.
+ − 26
+ − 27 ;;; Commentary:
+ − 28 ;;
+ − 29 ;; Widget browser. See `widget.el'.
+ − 30
+ − 31 ;;; Code:
+ − 32
+ − 33 (require 'easymenu)
+ − 34 (require 'custom)
+ − 35 (require 'wid-edit)
+ − 36 (eval-when-compile (require 'cl))
+ − 37
+ − 38 (defgroup widget-browse nil
+ − 39 "Customization support for browsing widgets."
+ − 40 :group 'widgets)
+ − 41
+ − 42 ;;; The Mode.
+ − 43
+ − 44 (defvar widget-browse-mode-map nil
+ − 45 "Keymap for `widget-browse-mode'.")
+ − 46
+ − 47 (unless widget-browse-mode-map
+ − 48 (setq widget-browse-mode-map (make-sparse-keymap))
+ − 49 (set-keymap-parent widget-browse-mode-map widget-keymap)
+ − 50 (define-key widget-browse-mode-map "q" 'bury-buffer))
+ − 51
+ − 52 (easy-menu-define widget-browse-mode-customize-menu
+ − 53 widget-browse-mode-map
+ − 54 "Menu used in widget browser buffers."
+ − 55 (customize-menu-create 'widgets))
+ − 56
+ − 57 (easy-menu-define widget-browse-mode-menu
+ − 58 widget-browse-mode-map
+ − 59 "Menu used in widget browser buffers."
+ − 60 '("Widget"
+ − 61 ["Browse" widget-browse t]
+ − 62 ["Browse At" widget-browse-at t]))
+ − 63
+ − 64 (defcustom widget-browse-mode-hook nil
+ − 65 "Hook called when entering widget-browse-mode."
+ − 66 :type 'hook
+ − 67 :group 'widget-browse)
+ − 68
+ − 69 (defun widget-browse-mode ()
+ − 70 "Major mode for widget browser buffers.
+ − 71
+ − 72 The following commands are available:
+ − 73
+ − 74 \\[widget-forward] Move to next button or editable field.
+ − 75 \\[widget-backward] Move to previous button or editable field.
+ − 76 \\[widget-button-click] Activate button under the mouse pointer.
+ − 77 \\[widget-button-press] Activate button under point.
+ − 78
+ − 79 Entry to this mode calls the value of `widget-browse-mode-hook'
+ − 80 if that value is non-nil."
+ − 81 (kill-all-local-variables)
+ − 82 (setq major-mode 'widget-browse-mode
+ − 83 mode-name "Widget")
+ − 84 (use-local-map widget-browse-mode-map)
+ − 85 (easy-menu-add widget-browse-mode-customize-menu)
+ − 86 (easy-menu-add widget-browse-mode-menu)
+ − 87 (run-hooks 'widget-browse-mode-hook))
+ − 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
502
+ − 229 (declare-fboundp (pp-to-string value))
209
+ − 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 "I 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 ;; wid-browse.el ends here