Mercurial > hg > xemacs-beta
annotate lisp/wid-browse.el @ 5818:15b0715c204d
Avoid passing patterns to with charset property to FcNameUnparse.
Prevents crash reported by Raymond Toy.
| author | Stephen J. Turnbull <stephen@xemacs.org> |
|---|---|
| date | Sat, 18 Oct 2014 21:20:42 +0900 |
| parents | 308d34e9f07d |
| children |
| rev | line source |
|---|---|
| 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 |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
613
diff
changeset
|
12 ;; XEmacs is free software: you can redistribute it and/or modify it |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
613
diff
changeset
|
13 ;; under the terms of the GNU General Public License as published by the |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
613
diff
changeset
|
14 ;; Free Software Foundation, either version 3 of the License, or (at your |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
613
diff
changeset
|
15 ;; option) any later version. |
| 209 | 16 |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
613
diff
changeset
|
17 ;; XEmacs is distributed in the hope that it will be useful, but WITHOUT |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
613
diff
changeset
|
18 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
613
diff
changeset
|
19 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
613
diff
changeset
|
20 ;; for more details. |
| 209 | 21 |
| 22 ;; You should have received a copy of the GNU General Public License | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
613
diff
changeset
|
23 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>. |
| 209 | 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-hooks 'widget-browse-mode-hook)) | |
| 86 | |
| 87 ;;; Commands. | |
| 88 | |
| 89 ;;;###autoload | |
| 90 (defun widget-browse-at (pos) | |
| 91 "Browse the widget under point." | |
| 92 (interactive "d") | |
| 93 (let* ((field (get-char-property pos 'field)) | |
| 94 (button (get-char-property pos 'button)) | |
| 95 (doc (get-char-property pos 'widget-doc)) | |
| 96 (text (cond (field "This is an editable text area.") | |
| 97 (button "This is an active area.") | |
| 98 (doc "This is documentation text.") | |
| 99 (t "This is unidentified text."))) | |
| 100 (widget (or field button doc))) | |
| 101 (when widget | |
| 102 (widget-browse widget)) | |
| 103 (message text))) | |
| 104 | |
| 105 (defvar widget-browse-history nil) | |
| 106 | |
| 107 ;;;###autoload | |
| 108 (defun widget-browse (widget) | |
| 109 "Create a widget browser for WIDGET." | |
| 110 (interactive (list (completing-read "Widget: " | |
| 111 obarray | |
| 112 (lambda (symbol) | |
| 113 (get symbol 'widget-type)) | |
| 114 t nil 'widget-browse-history))) | |
| 115 (if (stringp widget) | |
| 116 (setq widget (intern widget))) | |
| 117 (unless (if (symbolp widget) | |
| 118 (get widget 'widget-type) | |
| 119 (and (consp widget) | |
| 120 (get (widget-type widget) 'widget-type))) | |
| 121 (error "Not a widget.")) | |
| 122 ;; Create the buffer. | |
| 123 (if (symbolp widget) | |
| 124 (let ((buffer (format "*Browse %s Widget*" widget))) | |
| 125 (kill-buffer (get-buffer-create buffer)) | |
| 126 (switch-to-buffer (get-buffer-create buffer))) | |
| 127 (kill-buffer (get-buffer-create "*Browse Widget*")) | |
| 128 (switch-to-buffer (get-buffer-create "*Browse Widget*"))) | |
| 129 (widget-browse-mode) | |
| 130 | |
| 131 ;; Quick way to get out. | |
| 132 ;; (widget-create 'push-button | |
| 133 ;; :action (lambda (widget &optional event) | |
| 134 ;; (bury-buffer)) | |
| 135 ;; "Quit") | |
| 136 ;; (widget-insert "\n") | |
| 137 | |
| 138 ;; Top text indicating whether it is a class or object browser. | |
| 139 (if (listp widget) | |
| 140 (widget-insert "Widget object browser.\n\nClass: ") | |
| 141 (widget-insert "Widget class browser.\n\n") | |
| 142 (widget-create 'widget-browse | |
| 143 :format "%[%v%]\n%d" | |
| 144 :doc (get widget 'widget-documentation) | |
| 145 widget) | |
| 146 (unless (eq (preceding-char) ?\n) | |
| 147 (widget-insert "\n")) | |
| 148 (widget-insert "\nSuper: ") | |
| 149 (setq widget (get widget 'widget-type))) | |
| 150 | |
| 151 ;; Now show the attributes. | |
| 152 (let ((name (car widget)) | |
| 153 (items (cdr widget)) | |
| 154 key value printer) | |
| 155 (widget-create 'widget-browse | |
| 156 :format "%[%v%]" | |
| 157 name) | |
| 158 (widget-insert "\n") | |
| 159 (while items | |
| 160 (setq key (nth 0 items) | |
| 161 value (nth 1 items) | |
| 162 printer (or (get key 'widget-keyword-printer) | |
| 163 'widget-browse-sexp) | |
| 164 items (cdr (cdr items))) | |
| 165 (widget-insert "\n" (symbol-name key) "\n\t") | |
| 166 (funcall printer widget key value) | |
| 167 (widget-insert "\n"))) | |
| 168 (widget-setup) | |
| 169 (goto-char (point-min))) | |
| 170 | |
| 171 ;;;###autoload | |
| 172 (defun widget-browse-other-window (&optional widget) | |
| 173 "Show widget browser for WIDGET in other window." | |
| 174 (interactive) | |
| 175 (let ((window (selected-window))) | |
| 176 (switch-to-buffer-other-window "*Browse Widget*") | |
| 177 (if widget | |
| 178 (widget-browse widget) | |
| 179 (call-interactively 'widget-browse)) | |
| 180 (select-window window))) | |
| 181 | |
| 182 | |
| 183 ;;; The `widget-browse' Widget. | |
| 184 | |
| 185 (define-widget 'widget-browse 'push-button | |
| 186 "Button for creating a widget browser. | |
| 187 The :value of the widget shuld be the widget to be browsed." | |
| 188 :format "%[[%v]%]" | |
| 189 :value-create 'widget-browse-value-create | |
| 190 :action 'widget-browse-action) | |
| 191 | |
| 192 (defun widget-browse-action (widget &optional event) | |
| 193 ;; Create widget browser for WIDGET's :value. | |
| 194 (widget-browse (widget-get widget :value))) | |
| 195 | |
| 196 (defun widget-browse-value-create (widget) | |
| 197 ;; Insert type name. | |
| 198 (let ((value (widget-get widget :value))) | |
| 199 (cond ((symbolp value) | |
| 200 (insert (symbol-name value))) | |
| 201 ((consp value) | |
| 202 (insert (symbol-name (widget-type value)))) | |
| 203 (t | |
| 204 (insert "strange"))))) | |
| 205 | |
| 206 ;;; Keyword Printer Functions. | |
| 207 | |
| 208 (defun widget-browse-widget (widget key value) | |
| 209 "Insert description of WIDGET's KEY VALUE. | |
| 210 VALUE is assumed to be a widget." | |
| 211 (widget-create 'widget-browse value)) | |
| 212 | |
| 213 (defun widget-browse-widgets (widget key value) | |
| 214 "Insert description of WIDGET's KEY VALUE. | |
| 215 VALUE is assumed to be a list of widgets." | |
| 216 (while value | |
| 217 (widget-create 'widget-browse | |
| 218 (car value)) | |
| 219 (setq value (cdr value)) | |
| 220 (when value | |
| 221 (widget-insert " ")))) | |
| 222 | |
| 223 (defun widget-browse-sexp (widget key value) | |
| 224 "Insert description of WIDGET's KEY VALUE. | |
| 225 Nothing is assumed about value." | |
| 226 (let ((pp (condition-case signal | |
| 502 | 227 (declare-fboundp (pp-to-string value)) |
| 209 | 228 (error (prin1-to-string signal))))) |
| 229 (when (string-match "\n\\'" pp) | |
| 230 (setq pp (substring pp 0 (1- (length pp))))) | |
| 231 (if (cond ((string-match "\n" pp) | |
| 232 nil) | |
| 233 ((> (length pp) (- (window-width) (current-column))) | |
| 234 nil) | |
| 235 (t t)) | |
| 236 (widget-insert pp) | |
| 237 (widget-create 'push-button | |
| 238 :tag "show" | |
| 239 :action (lambda (widget &optional event) | |
| 240 (with-output-to-temp-buffer | |
| 241 "*Pp Eval Output*" | |
| 242 (princ (widget-get widget :value)))) | |
| 243 pp)))) | |
| 244 | |
| 245 (defun widget-browse-sexps (widget key value) | |
| 246 "Insert description of WIDGET's KEY VALUE. | |
| 247 VALUE is assumed to be a list of widgets." | |
| 248 (let ((target (current-column))) | |
| 249 (while value | |
| 250 (widget-browse-sexp widget key (car value)) | |
| 251 (setq value (cdr value)) | |
| 252 (when value | |
| 253 (widget-insert "\n" (make-string target ?\ )))))) | |
| 254 | |
| 255 ;;; Keyword Printers. | |
| 256 | |
| 257 (put :parent 'widget-keyword-printer 'widget-browse-widget) | |
| 258 (put :children 'widget-keyword-printer 'widget-browse-widgets) | |
| 259 (put :buttons 'widget-keyword-printer 'widget-browse-widgets) | |
| 260 (put :button 'widget-keyword-printer 'widget-browse-widget) | |
| 261 (put :args 'widget-keyword-printer 'widget-browse-sexps) | |
| 262 | |
| 263 ;;; Widget Minor Mode. | |
| 264 | |
| 265 (defvar widget-minor-mode nil | |
| 266 "I non-nil, we are in Widget Minor Mode.") | |
| 267 (make-variable-buffer-local 'widget-minor-mode) | |
| 268 | |
| 269 (defvar widget-minor-mode-map nil | |
| 270 "Keymap used in Widget Minor Mode.") | |
| 271 | |
| 272 (unless widget-minor-mode-map | |
| 273 (setq widget-minor-mode-map (make-sparse-keymap)) | |
| 274 (set-keymap-parent widget-minor-mode-map widget-keymap)) | |
| 275 | |
| 276 ;;;###autoload | |
| 277 (defun widget-minor-mode (&optional arg) | |
| 278 "Togle minor mode for traversing widgets. | |
| 279 With arg, turn widget mode on if and only if arg is positive." | |
| 280 (interactive "P") | |
| 281 (cond ((null arg) | |
| 282 (setq widget-minor-mode (not widget-minor-mode))) | |
| 283 ((<= arg 0) | |
| 284 (setq widget-minor-mode nil)) | |
| 285 (t | |
| 286 (setq widget-minor-mode t))) | |
| 287 (force-mode-line-update)) | |
| 288 | |
| 289 (add-to-list 'minor-mode-alist '(widget-minor-mode " Widget")) | |
| 290 | |
| 291 (add-to-list 'minor-mode-map-alist | |
| 292 (cons 'widget-minor-mode widget-minor-mode-map)) | |
| 293 | |
| 294 ;;; The End: | |
| 295 | |
| 296 (provide 'wid-browse) | |
| 297 | |
| 298 ;; wid-browse.el ends here |