Mercurial > hg > xemacs-beta
comparison lisp/custom/widget-edit.el @ 18:d95e72db5c07 r19-15b92
Import from CVS: tag r19-15b92
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 08:49:43 +0200 |
| parents | |
| children | 859a2309aef8 |
comparison
equal
deleted
inserted
replaced
| 17:4579af9d8826 | 18:d95e72db5c07 |
|---|---|
| 1 ;;; widget-edit.el --- Functions for creating and using widgets. | |
| 2 ;; | |
| 3 ;; Copyright (C) 1996 Free Software Foundation, Inc. | |
| 4 ;; | |
| 5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> | |
| 6 ;; Keywords: extensions | |
| 7 ;; Version: 1.24 | |
| 8 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ | |
| 9 | |
| 10 ;;; Commentary: | |
| 11 ;; | |
| 12 ;; See `widget.el'. | |
| 13 | |
| 14 ;;; Code: | |
| 15 | |
| 16 (require 'widget) | |
| 17 (require 'cl) | |
| 18 (autoload 'pp-to-string "pp") | |
| 19 (autoload 'Info-goto-node "info") | |
| 20 | |
| 21 (if (string-match "XEmacs" emacs-version) | |
| 22 ;; XEmacs spell `intangible' as `atomic'. | |
| 23 (defun widget-make-intangible (from to side) | |
| 24 "Make text between FROM and TO atomic with regard to movement. | |
| 25 Third argument should be `start-open' if it should be sticky to the rear, | |
| 26 and `end-open' if it should sticky to the front." | |
| 27 (require 'atomic-extents) | |
| 28 (let ((ext (make-extent from to))) | |
| 29 ;; XEmacs doesn't understant different kinds of read-only, so | |
| 30 ;; we have to use extents instead. | |
| 31 (put-text-property from to 'read-only nil) | |
| 32 (set-extent-property ext 'read-only t) | |
| 33 (set-extent-property ext 'start-open nil) | |
| 34 (set-extent-property ext 'end-open nil) | |
| 35 (set-extent-property ext side t) | |
| 36 (set-extent-property ext 'atomic t))) | |
| 37 (defun widget-make-intangible (from to size) | |
| 38 "Make text between FROM and TO intangible." | |
| 39 (put-text-property from to 'intangible 'front))) | |
| 40 | |
| 41 ;; The following should go away when bundled with Emacs. | |
| 42 (eval-and-compile | |
| 43 (condition-case () | |
| 44 (require 'custom) | |
| 45 (error nil)) | |
| 46 | |
| 47 (unless (and (featurep 'custom) (fboundp 'custom-declare-variable)) | |
| 48 ;; We have the old custom-library, hack around it! | |
| 49 (defmacro defgroup (&rest args) nil) | |
| 50 (defmacro defcustom (&rest args) nil) | |
| 51 (defmacro defface (&rest args) nil) | |
| 52 (when (fboundp 'copy-face) | |
| 53 (copy-face 'default 'widget-documentation-face) | |
| 54 (copy-face 'bold 'widget-button-face) | |
| 55 (copy-face 'italic 'widget-field-face)) | |
| 56 (defvar widget-mouse-face 'highlight) | |
| 57 (defvar widget-menu-max-size 40))) | |
| 58 | |
| 59 ;;; Compatibility. | |
| 60 | |
| 61 (unless (fboundp 'event-point) | |
| 62 ;; XEmacs function missing in Emacs. | |
| 63 (defun event-point (event) | |
| 64 "Return the character position of the given mouse-motion, button-press, | |
| 65 or button-release event. If the event did not occur over a window, or did | |
| 66 not occur over text, then this returns nil. Otherwise, it returns an index | |
| 67 into the buffer visible in the event's window." | |
| 68 (posn-point (event-start event)))) | |
| 69 | |
| 70 (unless (fboundp 'error-message-string) | |
| 71 ;; Emacs function missing in XEmacs. | |
| 72 (defun error-message-string (obj) | |
| 73 "Convert an error value to an error message." | |
| 74 (let ((buf (get-buffer-create " *error-message*"))) | |
| 75 (erase-buffer buf) | |
| 76 (display-error obj buf) | |
| 77 (buffer-string buf)))) | |
| 78 | |
| 79 ;;; Customization. | |
| 80 | |
| 81 (defgroup widgets nil | |
| 82 "Customization support for the Widget Library." | |
| 83 :link '(custom-manual "(widget)Top") | |
| 84 :link '(url-link :tag "Development Page" | |
| 85 "http://www.dina.kvl.dk/~abraham/custom/") | |
| 86 :prefix "widget-" | |
| 87 :group 'emacs) | |
| 88 | |
| 89 (defface widget-documentation-face '((((class color) | |
| 90 (background dark)) | |
| 91 (:foreground "lime green")) | |
| 92 (((class color) | |
| 93 (background light)) | |
| 94 (:foreground "dark green")) | |
| 95 (t nil)) | |
| 96 "Face used for documentation text." | |
| 97 :group 'widgets) | |
| 98 | |
| 99 (defface widget-button-face '((t (:bold t))) | |
| 100 "Face used for widget buttons." | |
| 101 :group 'widgets) | |
| 102 | |
| 103 (defcustom widget-mouse-face 'highlight | |
| 104 "Face used for widget buttons when the mouse is above them." | |
| 105 :type 'face | |
| 106 :group 'widgets) | |
| 107 | |
| 108 (defface widget-field-face '((((class grayscale color) | |
| 109 (background light)) | |
| 110 (:background "light gray")) | |
| 111 (((class grayscale color) | |
| 112 (background dark)) | |
| 113 (:background "dark gray")) | |
| 114 (t | |
| 115 (:italic t))) | |
| 116 "Face used for editable fields." | |
| 117 :group 'widgets) | |
| 118 | |
| 119 (defcustom widget-menu-max-size 40 | |
| 120 "Largest number of items allowed in a popup-menu. | |
| 121 Larger menus are read through the minibuffer." | |
| 122 :group 'widgets | |
| 123 :type 'integer) | |
| 124 | |
| 125 ;;; Utility functions. | |
| 126 ;; | |
| 127 ;; These are not really widget specific. | |
| 128 | |
| 129 (defun widget-plist-member (plist prop) | |
| 130 ;; Return non-nil if PLIST has the property PROP. | |
| 131 ;; PLIST is a property list, which is a list of the form | |
| 132 ;; (PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol. | |
| 133 ;; Unlike `plist-get', this allows you to distinguish between a missing | |
| 134 ;; property and a property with the value nil. | |
| 135 ;; The value is actually the tail of PLIST whose car is PROP. | |
| 136 (while (and plist (not (eq (car plist) prop))) | |
| 137 (setq plist (cdr (cdr plist)))) | |
| 138 plist) | |
| 139 | |
| 140 (defun widget-princ-to-string (object) | |
| 141 ;; Return string representation of OBJECT, any Lisp object. | |
| 142 ;; No quoting characters are used; no delimiters are printed around | |
| 143 ;; the contents of strings. | |
| 144 (save-excursion | |
| 145 (set-buffer (get-buffer-create " *widget-tmp*")) | |
| 146 (erase-buffer) | |
| 147 (let ((standard-output (current-buffer))) | |
| 148 (princ object)) | |
| 149 (buffer-string))) | |
| 150 | |
| 151 (defun widget-clear-undo () | |
| 152 "Clear all undo information." | |
| 153 (buffer-disable-undo (current-buffer)) | |
| 154 (buffer-enable-undo)) | |
| 155 | |
| 156 (defun widget-choose (title items &optional event) | |
| 157 "Choose an item from a list. | |
| 158 | |
| 159 First argument TITLE is the name of the list. | |
| 160 Second argument ITEMS is an alist (NAME . VALUE). | |
| 161 Optional third argument EVENT is an input event. | |
| 162 | |
| 163 The user is asked to choose between each NAME from the items alist, | |
| 164 and the VALUE of the chosen element will be returned. If EVENT is a | |
| 165 mouse event, and the number of elements in items is less than | |
| 166 `widget-menu-max-size', a popup menu will be used, otherwise the | |
| 167 minibuffer." | |
| 168 (cond ((and (< (length items) widget-menu-max-size) | |
| 169 event (fboundp 'x-popup-menu) window-system) | |
| 170 ;; We are in Emacs-19, pressed by the mouse | |
| 171 (x-popup-menu event | |
| 172 (list title (cons "" items)))) | |
| 173 ((and (< (length items) widget-menu-max-size) | |
| 174 event (fboundp 'popup-menu) window-system) | |
| 175 ;; We are in XEmacs, pressed by the mouse | |
| 176 (let ((val (get-popup-menu-response | |
| 177 (cons "" | |
| 178 (mapcar | |
| 179 (function | |
| 180 (lambda (x) | |
| 181 (vector (car x) (list (car x)) t))) | |
| 182 items))))) | |
| 183 (setq val (and val | |
| 184 (listp (event-object val)) | |
| 185 (stringp (car-safe (event-object val))) | |
| 186 (car (event-object val)))) | |
| 187 (cdr (assoc val items)))) | |
| 188 (t | |
| 189 (cdr (assoc (completing-read (concat title ": ") | |
| 190 items nil t) | |
| 191 items))))) | |
| 192 | |
| 193 ;;; Widget text specifications. | |
| 194 ;; | |
| 195 ;; These functions are for specifying text properties. | |
| 196 | |
| 197 (defun widget-specify-none (from to) | |
| 198 ;; Clear all text properties between FROM and TO. | |
| 199 (set-text-properties from to nil)) | |
| 200 | |
| 201 (defun widget-specify-text (from to) | |
| 202 ;; Default properties. | |
| 203 (add-text-properties from to (list 'read-only t | |
| 204 'front-sticky t | |
| 205 'start-open t | |
| 206 'end-open t | |
| 207 'rear-nonsticky nil))) | |
| 208 | |
| 209 (defun widget-specify-field (widget from to) | |
| 210 ;; Specify editable button for WIDGET between FROM and TO. | |
| 211 (widget-specify-field-update widget from to) | |
| 212 | |
| 213 ;; Make it possible to edit the front end of the field. | |
| 214 (add-text-properties (1- from) from (list 'rear-nonsticky t | |
| 215 'end-open t | |
| 216 'invisible t)) | |
| 217 (when (or (string-match "\\(.\\|\n\\)%v" (widget-get widget :format)) | |
| 218 (widget-get widget :hide-front-space)) | |
| 219 ;; WARNING: This is going to lose horrible if the character just | |
| 220 ;; before the field can be modified (e.g. if it belongs to a | |
| 221 ;; choice widget). We try to compensate by checking the format | |
| 222 ;; string, and hope the user hasn't changed the :create method. | |
| 223 (widget-make-intangible (- from 2) from 'end-open)) | |
| 224 | |
| 225 ;; Make it possible to edit back end of the field. | |
| 226 (add-text-properties to (1+ to) (list 'front-sticky nil | |
| 227 'read-only t | |
| 228 'start-open t)) | |
| 229 | |
| 230 (cond ((widget-get widget :size) | |
| 231 (put-text-property to (1+ to) 'invisible t) | |
| 232 (when (or (string-match "%v\\(.\\|\n\\)" (widget-get widget :format)) | |
| 233 (widget-get widget :hide-rear-space)) | |
| 234 ;; WARNING: This is going to lose horrible if the character just | |
| 235 ;; after the field can be modified (e.g. if it belongs to a | |
| 236 ;; choice widget). We try to compensate by checking the format | |
| 237 ;; string, and hope the user hasn't changed the :create method. | |
| 238 (widget-make-intangible to (+ to 2) 'start-open))) | |
| 239 ((string-match "XEmacs" emacs-version) | |
| 240 ;; XEmacs does not allow you to insert before a read-only | |
| 241 ;; character, even if it is start.open. | |
| 242 ;; XEmacs does allow you to delete an read-only extent, so | |
| 243 ;; making the terminating newline read only doesn't help. | |
| 244 ;; I tried putting an invisible intangible read-only space | |
| 245 ;; before the newline, which gave really weird effects. | |
| 246 ;; So for now, we just have trust the user not to delete the | |
| 247 ;; newline. | |
| 248 (put-text-property to (1+ to) 'read-only nil)))) | |
| 249 | |
| 250 (defun widget-specify-field-update (widget from to) | |
| 251 ;; Specify editable button for WIDGET between FROM and TO. | |
| 252 (let ((map (widget-get widget :keymap)) | |
| 253 (secret (widget-get widget :secret)) | |
| 254 (secret-to to) | |
| 255 (size (widget-get widget :size)) | |
| 256 (face (or (widget-get widget :value-face) | |
| 257 'widget-field-face))) | |
| 258 | |
| 259 (when secret | |
| 260 (while (and size | |
| 261 (not (zerop size)) | |
| 262 (> secret-to from) | |
| 263 (eq (char-after (1- secret-to)) ?\ )) | |
| 264 (setq secret-to (1- secret-to))) | |
| 265 | |
| 266 (save-excursion | |
| 267 (goto-char from) | |
| 268 (while (< (point) secret-to) | |
| 269 (let ((old (get-text-property (point) 'secret))) | |
| 270 (when old | |
| 271 (subst-char-in-region (point) (1+ (point)) secret old))) | |
| 272 (forward-char)))) | |
| 273 | |
| 274 (set-text-properties from to (list 'field widget | |
| 275 'read-only nil | |
| 276 'keymap map | |
| 277 'local-map map | |
| 278 'face face)) | |
| 279 | |
| 280 (when secret | |
| 281 (save-excursion | |
| 282 (goto-char from) | |
| 283 (while (< (point) secret-to) | |
| 284 (let ((old (following-char))) | |
| 285 (subst-char-in-region (point) (1+ (point)) old secret) | |
| 286 (put-text-property (point) (1+ (point)) 'secret old)) | |
| 287 (forward-char)))) | |
| 288 | |
| 289 (unless (widget-get widget :size) | |
| 290 (add-text-properties to (1+ to) (list 'field widget | |
| 291 'face face | |
| 292 'local-map map | |
| 293 'keymap map))))) | |
| 294 | |
| 295 (defun widget-specify-button (widget from to) | |
| 296 ;; Specify button for WIDGET between FROM and TO. | |
| 297 (let ((face (widget-apply widget :button-face-get))) | |
| 298 (add-text-properties from to (list 'button widget | |
| 299 'mouse-face widget-mouse-face | |
| 300 'start-open t | |
| 301 'end-open t | |
| 302 'face face)))) | |
| 303 | |
| 304 (defun widget-specify-sample (widget from to) | |
| 305 ;; Specify sample for WIDGET between FROM and TO. | |
| 306 (let ((face (widget-apply widget :sample-face-get))) | |
| 307 (when face | |
| 308 (add-text-properties from to (list 'start-open t | |
| 309 'end-open t | |
| 310 'face face))))) | |
| 311 | |
| 312 (defun widget-specify-doc (widget from to) | |
| 313 ;; Specify documentation for WIDGET between FROM and TO. | |
| 314 (add-text-properties from to (list 'widget-doc widget | |
| 315 'face 'widget-documentation-face))) | |
| 316 | |
| 317 (defmacro widget-specify-insert (&rest form) | |
| 318 ;; Execute FORM without inheriting any text properties. | |
| 319 `(save-restriction | |
| 320 (let ((inhibit-read-only t) | |
| 321 result | |
| 322 after-change-functions) | |
| 323 (insert "<>") | |
| 324 (narrow-to-region (- (point) 2) (point)) | |
| 325 (widget-specify-none (point-min) (point-max)) | |
| 326 (goto-char (1+ (point-min))) | |
| 327 (setq result (progn ,@form)) | |
| 328 (delete-region (point-min) (1+ (point-min))) | |
| 329 (delete-region (1- (point-max)) (point-max)) | |
| 330 (goto-char (point-max)) | |
| 331 result))) | |
| 332 | |
| 333 ;;; Widget Properties. | |
| 334 | |
| 335 (defun widget-put (widget property value) | |
| 336 "In WIDGET set PROPERTY to VALUE. | |
| 337 The value can later be retrived with `widget-get'." | |
| 338 (setcdr widget (plist-put (cdr widget) property value))) | |
| 339 | |
| 340 (defun widget-get (widget property) | |
| 341 "In WIDGET, get the value of PROPERTY. | |
| 342 The value could either be specified when the widget was created, or | |
| 343 later with `widget-put'." | |
| 344 (cond ((widget-plist-member (cdr widget) property) | |
| 345 (plist-get (cdr widget) property)) | |
| 346 ((car widget) | |
| 347 (widget-get (get (car widget) 'widget-type) property)) | |
| 348 (t nil))) | |
| 349 | |
| 350 (defun widget-member (widget property) | |
| 351 "Non-nil iff there is a definition in WIDGET for PROPERTY." | |
| 352 (cond ((widget-plist-member (cdr widget) property) | |
| 353 t) | |
| 354 ((car widget) | |
| 355 (widget-member (get (car widget) 'widget-type) property)) | |
| 356 (t nil))) | |
| 357 | |
| 358 (defun widget-apply (widget property &rest args) | |
| 359 "Apply the value of WIDGET's PROPERTY to the widget itself. | |
| 360 ARGS are passed as extra argments to the function." | |
| 361 (apply (widget-get widget property) widget args)) | |
| 362 | |
| 363 (defun widget-value (widget) | |
| 364 "Extract the current value of WIDGET." | |
| 365 (widget-apply widget | |
| 366 :value-to-external (widget-apply widget :value-get))) | |
| 367 | |
| 368 (defun widget-value-set (widget value) | |
| 369 "Set the current value of WIDGET to VALUE." | |
| 370 (widget-apply widget | |
| 371 :value-set (widget-apply widget | |
| 372 :value-to-internal value))) | |
| 373 | |
| 374 (defun widget-match-inline (widget vals) | |
| 375 ;; In WIDGET, match the start of VALS. | |
| 376 (cond ((widget-get widget :inline) | |
| 377 (widget-apply widget :match-inline vals)) | |
| 378 ((and vals | |
| 379 (widget-apply widget :match (car vals))) | |
| 380 (cons (list (car vals)) (cdr vals))) | |
| 381 (t nil))) | |
| 382 | |
| 383 ;;; Creating Widgets. | |
| 384 | |
| 385 ;;;###autoload | |
| 386 (defun widget-create (type &rest args) | |
| 387 "Create widget of TYPE. | |
| 388 The optional ARGS are additional keyword arguments." | |
| 389 (let ((widget (apply 'widget-convert type args))) | |
| 390 (widget-apply widget :create) | |
| 391 widget)) | |
| 392 | |
| 393 (defun widget-create-child-and-convert (parent type &rest args) | |
| 394 "As part of the widget PARENT, create a child widget TYPE. | |
| 395 The child is converted, using the keyword arguments ARGS." | |
| 396 (let ((widget (apply 'widget-convert type args))) | |
| 397 (widget-put widget :parent parent) | |
| 398 (unless (widget-get widget :indent) | |
| 399 (widget-put widget :indent (+ (or (widget-get parent :indent) 0) | |
| 400 (or (widget-get widget :extra-offset) 0) | |
| 401 (widget-get parent :offset)))) | |
| 402 (widget-apply widget :create) | |
| 403 widget)) | |
| 404 | |
| 405 (defun widget-create-child (parent type) | |
| 406 "Create widget of TYPE." | |
| 407 (let ((widget (copy-list type))) | |
| 408 (widget-put widget :parent parent) | |
| 409 (unless (widget-get widget :indent) | |
| 410 (widget-put widget :indent (+ (or (widget-get parent :indent) 0) | |
| 411 (or (widget-get widget :extra-offset) 0) | |
| 412 (widget-get parent :offset)))) | |
| 413 (widget-apply widget :create) | |
| 414 widget)) | |
| 415 | |
| 416 (defun widget-create-child-value (parent type value) | |
| 417 "Create widget of TYPE with value VALUE." | |
| 418 (let ((widget (copy-list type))) | |
| 419 (widget-put widget :value (widget-apply widget :value-to-internal value)) | |
| 420 (widget-put widget :parent parent) | |
| 421 (unless (widget-get widget :indent) | |
| 422 (widget-put widget :indent (+ (or (widget-get parent :indent) 0) | |
| 423 (or (widget-get widget :extra-offset) 0) | |
| 424 (widget-get parent :offset)))) | |
| 425 (widget-apply widget :create) | |
| 426 widget)) | |
| 427 | |
| 428 ;;;###autoload | |
| 429 (defun widget-delete (widget) | |
| 430 "Delete WIDGET." | |
| 431 (widget-apply widget :delete)) | |
| 432 | |
| 433 (defun widget-convert (type &rest args) | |
| 434 "Convert TYPE to a widget without inserting it in the buffer. | |
| 435 The optional ARGS are additional keyword arguments." | |
| 436 ;; Don't touch the type. | |
| 437 (let* ((widget (if (symbolp type) | |
| 438 (list type) | |
| 439 (copy-list type))) | |
| 440 (current widget) | |
| 441 (keys args)) | |
| 442 ;; First set the :args keyword. | |
| 443 (while (cdr current) ;Look in the type. | |
| 444 (let ((next (car (cdr current)))) | |
| 445 (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:)) | |
| 446 (setq current (cdr (cdr current))) | |
| 447 (setcdr current (list :args (cdr current))) | |
| 448 (setq current nil)))) | |
| 449 (while args ;Look in the args. | |
| 450 (let ((next (nth 0 args))) | |
| 451 (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:)) | |
| 452 (setq args (nthcdr 2 args)) | |
| 453 (widget-put widget :args args) | |
| 454 (setq args nil)))) | |
| 455 ;; Then Convert the widget. | |
| 456 (setq type widget) | |
| 457 (while type | |
| 458 (let ((convert-widget (plist-get (cdr type) :convert-widget))) | |
| 459 (if convert-widget | |
| 460 (setq widget (funcall convert-widget widget)))) | |
| 461 (setq type (get (car type) 'widget-type))) | |
| 462 ;; Finally set the keyword args. | |
| 463 (while keys | |
| 464 (let ((next (nth 0 keys))) | |
| 465 (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:)) | |
| 466 (progn | |
| 467 (widget-put widget next (nth 1 keys)) | |
| 468 (setq keys (nthcdr 2 keys))) | |
| 469 (setq keys nil)))) | |
| 470 ;; Convert the :value to internal format. | |
| 471 (if (widget-member widget :value) | |
| 472 (let ((value (widget-get widget :value))) | |
| 473 (widget-put widget | |
| 474 :value (widget-apply widget :value-to-internal value)))) | |
| 475 ;; Return the newly create widget. | |
| 476 widget)) | |
| 477 | |
| 478 (defun widget-insert (&rest args) | |
| 479 "Call `insert' with ARGS and make the text read only." | |
| 480 (let ((inhibit-read-only t) | |
| 481 after-change-functions | |
| 482 (from (point))) | |
| 483 (apply 'insert args) | |
| 484 (widget-specify-text from (point)))) | |
| 485 | |
| 486 ;;; Keymap and Comands. | |
| 487 | |
| 488 (defvar widget-keymap nil | |
| 489 "Keymap containing useful binding for buffers containing widgets. | |
| 490 Recommended as a parent keymap for modes using widgets.") | |
| 491 | |
| 492 (unless widget-keymap | |
| 493 (setq widget-keymap (make-sparse-keymap)) | |
| 494 (define-key widget-keymap "\t" 'widget-forward) | |
| 495 (define-key widget-keymap "\M-\t" 'widget-backward) | |
| 496 (define-key widget-keymap [(shift tab)] 'widget-backward) | |
| 497 (define-key widget-keymap [(shift tab)] 'widget-backward) | |
| 498 (define-key widget-keymap [backtab] 'widget-backward) | |
| 499 (if (string-match "XEmacs" (emacs-version)) | |
| 500 (define-key widget-keymap [button2] 'widget-button-click) | |
| 501 (define-key widget-keymap [menu-bar] 'nil) | |
| 502 (define-key widget-keymap [mouse-2] 'widget-button-click)) | |
| 503 (define-key widget-keymap "\C-m" 'widget-button-press)) | |
| 504 | |
| 505 (defvar widget-global-map global-map | |
| 506 "Keymap used for events the widget does not handle themselves.") | |
| 507 (make-variable-buffer-local 'widget-global-map) | |
| 508 | |
| 509 (defvar widget-field-keymap nil | |
| 510 "Keymap used inside an editable field.") | |
| 511 | |
| 512 (unless widget-field-keymap | |
| 513 (setq widget-field-keymap (copy-keymap widget-keymap)) | |
| 514 (define-key widget-field-keymap "\C-m" 'widget-field-activate) | |
| 515 (set-keymap-parent widget-field-keymap global-map)) | |
| 516 | |
| 517 (defvar widget-text-keymap nil | |
| 518 "Keymap used inside a text field.") | |
| 519 | |
| 520 (unless widget-text-keymap | |
| 521 (setq widget-text-keymap (copy-keymap widget-keymap)) | |
| 522 (set-keymap-parent widget-text-keymap global-map)) | |
| 523 | |
| 524 (defun widget-field-activate (pos &optional event) | |
| 525 "Activate the ediable field at point." | |
| 526 (interactive "@d") | |
| 527 (let* ((field (get-text-property pos 'field))) | |
| 528 (if field | |
| 529 (widget-apply field :action event) | |
| 530 (call-interactively | |
| 531 (lookup-key widget-global-map (this-command-keys)))))) | |
| 532 | |
| 533 (defun widget-button-click (event) | |
| 534 "Activate button below mouse pointer." | |
| 535 (interactive "@e") | |
| 536 (widget-button-press (event-point event) event)) | |
| 537 | |
| 538 (defun widget-button-press (pos &optional event) | |
| 539 "Activate button at POS." | |
| 540 (interactive "@d") | |
| 541 (let* ((button (get-text-property pos 'button))) | |
| 542 (if button | |
| 543 (widget-apply button :action event) | |
| 544 (call-interactively | |
| 545 (lookup-key widget-global-map (this-command-keys)))))) | |
| 546 | |
| 547 (defun widget-move (arg) | |
| 548 "Move point to the ARG next field or button. | |
| 549 ARG may be negative to move backward." | |
| 550 (while (> arg 0) | |
| 551 (setq arg (1- arg)) | |
| 552 (let ((next (cond ((get-text-property (point) 'button) | |
| 553 (next-single-property-change (point) 'button)) | |
| 554 ((get-text-property (point) 'field) | |
| 555 (next-single-property-change (point) 'field)) | |
| 556 (t | |
| 557 (point))))) | |
| 558 (if (null next) ; Widget extends to end. of buffer | |
| 559 (setq next (point-min))) | |
| 560 (let ((button (next-single-property-change next 'button)) | |
| 561 (field (next-single-property-change next 'field))) | |
| 562 (cond ((or (get-text-property next 'button) | |
| 563 (get-text-property next 'field)) | |
| 564 (goto-char next)) | |
| 565 ((and button field) | |
| 566 (goto-char (min button field))) | |
| 567 (button (goto-char button)) | |
| 568 (field (goto-char field)) | |
| 569 (t | |
| 570 (let ((button (next-single-property-change (point-min) 'button)) | |
| 571 (field (next-single-property-change (point-min) 'field))) | |
| 572 (cond ((and button field) (goto-char (min button field))) | |
| 573 (button (goto-char button)) | |
| 574 (field (goto-char field)) | |
| 575 (t | |
| 576 (error "No buttons or fields found"))))))))) | |
| 577 (while (< arg 0) | |
| 578 (if (= (point-min) (point)) | |
| 579 (forward-char 1)) | |
| 580 (setq arg (1+ arg)) | |
| 581 (let ((previous (cond ((get-text-property (1- (point)) 'button) | |
| 582 (previous-single-property-change (point) 'button)) | |
| 583 ((get-text-property (1- (point)) 'field) | |
| 584 (previous-single-property-change (point) 'field)) | |
| 585 (t | |
| 586 (point))))) | |
| 587 (if (null previous) ; Widget extends to beg. of buffer | |
| 588 (setq previous (point-max))) | |
| 589 (let ((button (previous-single-property-change previous 'button)) | |
| 590 (field (previous-single-property-change previous 'field))) | |
| 591 (cond ((and button field) | |
| 592 (goto-char (max button field))) | |
| 593 (button (goto-char button)) | |
| 594 (field (goto-char field)) | |
| 595 (t | |
| 596 (let ((button (previous-single-property-change | |
| 597 (point-max) 'button)) | |
| 598 (field (previous-single-property-change | |
| 599 (point-max) 'field))) | |
| 600 (cond ((and button field) (goto-char (max button field))) | |
| 601 (button (goto-char button)) | |
| 602 (field (goto-char field)) | |
| 603 (t | |
| 604 (error "No buttons or fields found")))))))) | |
| 605 (let ((button (previous-single-property-change (point) 'button)) | |
| 606 (field (previous-single-property-change (point) 'field))) | |
| 607 (cond ((and button field) | |
| 608 (goto-char (max button field))) | |
| 609 (button (goto-char button)) | |
| 610 (field (goto-char field))))) | |
| 611 (widget-echo-help (point)) | |
| 612 (run-hooks 'widget-move-hook)) | |
| 613 | |
| 614 (defun widget-forward (arg) | |
| 615 "Move point to the next field or button. | |
| 616 With optional ARG, move across that many fields." | |
| 617 (interactive "p") | |
| 618 (run-hooks 'widget-forward-hook) | |
| 619 (widget-move arg)) | |
| 620 | |
| 621 (defun widget-backward (arg) | |
| 622 "Move point to the previous field or button. | |
| 623 With optional ARG, move across that many fields." | |
| 624 (interactive "p") | |
| 625 (run-hooks 'widget-backward-hook) | |
| 626 (widget-move (- arg))) | |
| 627 | |
| 628 ;;; Setting up the buffer. | |
| 629 | |
| 630 (defvar widget-field-new nil) | |
| 631 ;; List of all newly created editable fields in the buffer. | |
| 632 (make-variable-buffer-local 'widget-field-new) | |
| 633 | |
| 634 (defvar widget-field-list nil) | |
| 635 ;; List of all editable fields in the buffer. | |
| 636 (make-variable-buffer-local 'widget-field-list) | |
| 637 | |
| 638 (defun widget-setup () | |
| 639 "Setup current buffer so editing string widgets works." | |
| 640 (let ((inhibit-read-only t) | |
| 641 (after-change-functions nil) | |
| 642 field) | |
| 643 (while widget-field-new | |
| 644 (setq field (car widget-field-new) | |
| 645 widget-field-new (cdr widget-field-new) | |
| 646 widget-field-list (cons field widget-field-list)) | |
| 647 (let ((from (widget-get field :value-from)) | |
| 648 (to (widget-get field :value-to))) | |
| 649 (widget-specify-field field from to) | |
| 650 (move-marker from (1- from)) | |
| 651 (move-marker to (1+ to))))) | |
| 652 (widget-clear-undo) | |
| 653 ;; We need to maintain text properties and size of the editing fields. | |
| 654 (make-local-variable 'after-change-functions) | |
| 655 (if widget-field-list | |
| 656 (setq after-change-functions '(widget-after-change)) | |
| 657 (setq after-change-functions nil))) | |
| 658 | |
| 659 (defvar widget-field-last nil) | |
| 660 ;; Last field containing point. | |
| 661 (make-variable-buffer-local 'widget-field-last) | |
| 662 | |
| 663 (defvar widget-field-was nil) | |
| 664 ;; The widget data before the change. | |
| 665 (make-variable-buffer-local 'widget-field-was) | |
| 666 | |
| 667 (defun widget-field-find (pos) | |
| 668 ;; Find widget whose editing field is located at POS. | |
| 669 ;; Return nil if POS is not inside and editing field. | |
| 670 ;; | |
| 671 ;; This is only used in `widget-field-modified', since ordinarily | |
| 672 ;; you would just test the field property. | |
| 673 (let ((fields widget-field-list) | |
| 674 field found) | |
| 675 (while fields | |
| 676 (setq field (car fields) | |
| 677 fields (cdr fields)) | |
| 678 (let ((from (widget-get field :value-from)) | |
| 679 (to (widget-get field :value-to))) | |
| 680 (if (and from to (< from pos) (> to pos)) | |
| 681 (setq fields nil | |
| 682 found field)))) | |
| 683 found)) | |
| 684 | |
| 685 (defun widget-after-change (from to old) | |
| 686 ;; Adjust field size and text properties. | |
| 687 (condition-case nil | |
| 688 (let ((field (widget-field-find from)) | |
| 689 (inhibit-read-only t)) | |
| 690 (cond ((null field)) | |
| 691 ((not (eq field (widget-field-find to))) | |
| 692 (debug) | |
| 693 (message "Error: `widget-after-change' called on two fields")) | |
| 694 (t | |
| 695 (let ((size (widget-get field :size))) | |
| 696 (if size | |
| 697 (let ((begin (1+ (widget-get field :value-from))) | |
| 698 (end (1- (widget-get field :value-to)))) | |
| 699 (widget-specify-field-update field begin end) | |
| 700 (cond ((< (- end begin) size) | |
| 701 ;; Field too small. | |
| 702 (save-excursion | |
| 703 (goto-char end) | |
| 704 (insert-char ?\ (- (+ begin size) end)) | |
| 705 (widget-specify-field-update field | |
| 706 begin | |
| 707 (+ begin size)))) | |
| 708 ((> (- end begin) size) | |
| 709 ;; Field too large and | |
| 710 (if (or (< (point) (+ begin size)) | |
| 711 (> (point) end)) | |
| 712 ;; Point is outside extra space. | |
| 713 (setq begin (+ begin size)) | |
| 714 ;; Point is within the extra space. | |
| 715 (setq begin (point))) | |
| 716 (save-excursion | |
| 717 (goto-char end) | |
| 718 (while (and (eq (preceding-char) ?\ ) | |
| 719 (> (point) begin)) | |
| 720 (delete-backward-char 1)))))) | |
| 721 (widget-specify-field-update field from to))) | |
| 722 (widget-apply field :notify field)))) | |
| 723 (error (debug)))) | |
| 724 | |
| 725 ;;; Widget Functions | |
| 726 ;; | |
| 727 ;; These functions are used in the definition of multiple widgets. | |
| 728 | |
| 729 (defun widget-children-value-delete (widget) | |
| 730 "Delete all :children and :buttons in WIDGET." | |
| 731 (mapcar 'widget-delete (widget-get widget :children)) | |
| 732 (widget-put widget :children nil) | |
| 733 (mapcar 'widget-delete (widget-get widget :buttons)) | |
| 734 (widget-put widget :buttons nil)) | |
| 735 | |
| 736 (defun widget-types-convert-widget (widget) | |
| 737 "Convert :args as widget types in WIDGET." | |
| 738 (widget-put widget :args (mapcar 'widget-convert (widget-get widget :args))) | |
| 739 widget) | |
| 740 | |
| 741 ;;; The `default' Widget. | |
| 742 | |
| 743 (define-widget 'default nil | |
| 744 "Basic widget other widgets are derived from." | |
| 745 :value-to-internal (lambda (widget value) value) | |
| 746 :value-to-external (lambda (widget value) value) | |
| 747 :create 'widget-default-create | |
| 748 :indent nil | |
| 749 :offset 0 | |
| 750 :format-handler 'widget-default-format-handler | |
| 751 :button-face-get 'widget-default-button-face-get | |
| 752 :sample-face-get 'widget-default-sample-face-get | |
| 753 :delete 'widget-default-delete | |
| 754 :value-set 'widget-default-value-set | |
| 755 :value-inline 'widget-default-value-inline | |
| 756 :menu-tag-get 'widget-default-menu-tag-get | |
| 757 :validate (lambda (widget) nil) | |
| 758 :action 'widget-default-action | |
| 759 :notify 'widget-default-notify) | |
| 760 | |
| 761 (defun widget-default-create (widget) | |
| 762 "Create WIDGET at point in the current buffer." | |
| 763 (widget-specify-insert | |
| 764 (let ((from (point)) | |
| 765 (tag (widget-get widget :tag)) | |
| 766 (doc (widget-get widget :doc)) | |
| 767 button-begin button-end | |
| 768 sample-begin sample-end | |
| 769 doc-begin doc-end | |
| 770 value-pos) | |
| 771 (insert (widget-get widget :format)) | |
| 772 (goto-char from) | |
| 773 ;; Parse % escapes in format. | |
| 774 (while (re-search-forward "%\\(.\\)" nil t) | |
| 775 (let ((escape (aref (match-string 1) 0))) | |
| 776 (replace-match "" t t) | |
| 777 (cond ((eq escape ?%) | |
| 778 (insert "%")) | |
| 779 ((eq escape ?\[) | |
| 780 (setq button-begin (point))) | |
| 781 ((eq escape ?\]) | |
| 782 (setq button-end (point))) | |
| 783 ((eq escape ?\{) | |
| 784 (setq sample-begin (point))) | |
| 785 ((eq escape ?\}) | |
| 786 (setq sample-end (point))) | |
| 787 ((eq escape ?n) | |
| 788 (when (widget-get widget :indent) | |
| 789 (insert "\n") | |
| 790 (insert-char ? (widget-get widget :indent)))) | |
| 791 ((eq escape ?t) | |
| 792 (if tag | |
| 793 (insert tag) | |
| 794 (let ((standard-output (current-buffer))) | |
| 795 (princ (widget-get widget :value))))) | |
| 796 ((eq escape ?d) | |
| 797 (when doc | |
| 798 (setq doc-begin (point)) | |
| 799 (insert doc) | |
| 800 (while (eq (preceding-char) ?\n) | |
| 801 (delete-backward-char 1)) | |
| 802 (insert "\n") | |
| 803 (setq doc-end (point)))) | |
| 804 ((eq escape ?v) | |
| 805 (if (and button-begin (not button-end)) | |
| 806 (widget-apply widget :value-create) | |
| 807 (setq value-pos (point)))) | |
| 808 (t | |
| 809 (widget-apply widget :format-handler escape))))) | |
| 810 ;; Specify button, sample, and doc, and insert value. | |
| 811 (and button-begin button-end | |
| 812 (widget-specify-button widget button-begin button-end)) | |
| 813 (and sample-begin sample-end | |
| 814 (widget-specify-sample widget sample-begin sample-end)) | |
| 815 (and doc-begin doc-end | |
| 816 (widget-specify-doc widget doc-begin doc-end)) | |
| 817 (when value-pos | |
| 818 (goto-char value-pos) | |
| 819 (widget-apply widget :value-create))) | |
| 820 (let ((from (copy-marker (point-min))) | |
| 821 (to (copy-marker (point-max)))) | |
| 822 (widget-specify-text from to) | |
| 823 (set-marker-insertion-type from t) | |
| 824 (set-marker-insertion-type to nil) | |
| 825 (widget-put widget :from from) | |
| 826 (widget-put widget :to to)))) | |
| 827 | |
| 828 (defun widget-default-format-handler (widget escape) | |
| 829 ;; We recognize the %h escape by default. | |
| 830 (let* ((buttons (widget-get widget :buttons)) | |
| 831 (doc-property (widget-get widget :documentation-property)) | |
| 832 (doc-try (cond ((widget-get widget :doc)) | |
| 833 ((symbolp doc-property) | |
| 834 (documentation-property (widget-get widget :value) | |
| 835 doc-property)) | |
| 836 (t | |
| 837 (funcall doc-property (widget-get widget :value))))) | |
| 838 (doc-text (and (stringp doc-try) | |
| 839 (> (length doc-try) 1) | |
| 840 doc-try))) | |
| 841 (cond ((eq escape ?h) | |
| 842 (when doc-text | |
| 843 (and (eq (preceding-char) ?\n) | |
| 844 (widget-get widget :indent) | |
| 845 (insert-char ? (widget-get widget :indent))) | |
| 846 ;; The `*' in the beginning is redundant. | |
| 847 (when (eq (aref doc-text 0) ?*) | |
| 848 (setq doc-text (substring doc-text 1))) | |
| 849 ;; Get rid of trailing newlines. | |
| 850 (when (string-match "\n+\\'" doc-text) | |
| 851 (setq doc-text (substring doc-text 0 (match-beginning 0)))) | |
| 852 (push (if (string-match "\n." doc-text) | |
| 853 ;; Allow multiline doc to be hiden. | |
| 854 (widget-create-child-and-convert | |
| 855 widget 'widget-help | |
| 856 :doc (progn | |
| 857 (string-match "\\`.*" doc-text) | |
| 858 (match-string 0 doc-text)) | |
| 859 :widget-doc doc-text | |
| 860 "?") | |
| 861 ;; A single line is just inserted. | |
| 862 (widget-create-child-and-convert | |
| 863 widget 'item :format "%d" :doc doc-text nil)) | |
| 864 buttons))) | |
| 865 (t | |
| 866 (error "Unknown escape `%c'" escape))) | |
| 867 (widget-put widget :buttons buttons))) | |
| 868 | |
| 869 (defun widget-default-button-face-get (widget) | |
| 870 ;; Use :button-face or widget-button-face | |
| 871 (or (widget-get widget :button-face) 'widget-button-face)) | |
| 872 | |
| 873 (defun widget-default-sample-face-get (widget) | |
| 874 ;; Use :sample-face. | |
| 875 (widget-get widget :sample-face)) | |
| 876 | |
| 877 (defun widget-default-delete (widget) | |
| 878 ;; Remove widget from the buffer. | |
| 879 (let ((from (widget-get widget :from)) | |
| 880 (to (widget-get widget :to)) | |
| 881 (inhibit-read-only t) | |
| 882 after-change-functions) | |
| 883 (widget-apply widget :value-delete) | |
| 884 (delete-region from to) | |
| 885 (set-marker from nil) | |
| 886 (set-marker to nil))) | |
| 887 | |
| 888 (defun widget-default-value-set (widget value) | |
| 889 ;; Recreate widget with new value. | |
| 890 (save-excursion | |
| 891 (goto-char (widget-get widget :from)) | |
| 892 (widget-apply widget :delete) | |
| 893 (widget-put widget :value value) | |
| 894 (widget-apply widget :create))) | |
| 895 | |
| 896 (defun widget-default-value-inline (widget) | |
| 897 ;; Wrap value in a list unless it is inline. | |
| 898 (if (widget-get widget :inline) | |
| 899 (widget-value widget) | |
| 900 (list (widget-value widget)))) | |
| 901 | |
| 902 (defun widget-default-menu-tag-get (widget) | |
| 903 ;; Use tag or value for menus. | |
| 904 (or (widget-get widget :menu-tag) | |
| 905 (widget-get widget :tag) | |
| 906 (widget-princ-to-string (widget-get widget :value)))) | |
| 907 | |
| 908 (defun widget-default-action (widget &optional event) | |
| 909 ;; Notify the parent when a widget change | |
| 910 (let ((parent (widget-get widget :parent))) | |
| 911 (when parent | |
| 912 (widget-apply parent :notify widget event)))) | |
| 913 | |
| 914 (defun widget-default-notify (widget child &optional event) | |
| 915 ;; Pass notification to parent. | |
| 916 (widget-default-action widget event)) | |
| 917 | |
| 918 ;;; The `item' Widget. | |
| 919 | |
| 920 (define-widget 'item 'default | |
| 921 "Constant items for inclusion in other widgets." | |
| 922 :convert-widget 'widget-item-convert-widget | |
| 923 :value-create 'widget-item-value-create | |
| 924 :value-delete 'ignore | |
| 925 :value-get 'widget-item-value-get | |
| 926 :match 'widget-item-match | |
| 927 :match-inline 'widget-item-match-inline | |
| 928 :action 'widget-item-action | |
| 929 :format "%t\n") | |
| 930 | |
| 931 (defun widget-item-convert-widget (widget) | |
| 932 ;; Initialize :value from :args in WIDGET. | |
| 933 (let ((args (widget-get widget :args))) | |
| 934 (when args | |
| 935 (widget-put widget :value (widget-apply widget | |
| 936 :value-to-internal (car args))) | |
| 937 (widget-put widget :args nil))) | |
| 938 widget) | |
| 939 | |
| 940 (defun widget-item-value-create (widget) | |
| 941 ;; Insert the printed representation of the value. | |
| 942 (let ((standard-output (current-buffer))) | |
| 943 (princ (widget-get widget :value)))) | |
| 944 | |
| 945 (defun widget-item-match (widget value) | |
| 946 ;; Match if the value is the same. | |
| 947 (equal (widget-get widget :value) value)) | |
| 948 | |
| 949 (defun widget-item-match-inline (widget values) | |
| 950 ;; Match if the value is the same. | |
| 951 (let ((value (widget-get widget :value))) | |
| 952 (and (listp value) | |
| 953 (<= (length value) (length values)) | |
| 954 (let ((head (subseq values 0 (length value)))) | |
| 955 (and (equal head value) | |
| 956 (cons head (subseq values (length value)))))))) | |
| 957 | |
| 958 (defun widget-item-action (widget &optional event) | |
| 959 ;; Just notify itself. | |
| 960 (widget-apply widget :notify widget event)) | |
| 961 | |
| 962 (defun widget-item-value-get (widget) | |
| 963 ;; Items are simple. | |
| 964 (widget-get widget :value)) | |
| 965 | |
| 966 ;;; The `push-button' Widget. | |
| 967 | |
| 968 (define-widget 'push-button 'item | |
| 969 "A pushable button." | |
| 970 :format "%[[%t]%]") | |
| 971 | |
| 972 ;;; The `link' Widget. | |
| 973 | |
| 974 (define-widget 'link 'item | |
| 975 "An embedded link." | |
| 976 :help-echo "Push me to follow the link." | |
| 977 :format "%[_%t_%]") | |
| 978 | |
| 979 ;;; The `info-link' Widget. | |
| 980 | |
| 981 (define-widget 'info-link 'link | |
| 982 "A link to an info file." | |
| 983 :action 'widget-info-link-action) | |
| 984 | |
| 985 (defun widget-info-link-action (widget &optional event) | |
| 986 "Open the info node specified by WIDGET." | |
| 987 (Info-goto-node (widget-value widget))) | |
| 988 | |
| 989 ;;; The `url-link' Widget. | |
| 990 | |
| 991 (define-widget 'url-link 'link | |
| 992 "A link to an www page." | |
| 993 :action 'widget-url-link-action) | |
| 994 | |
| 995 (defun widget-url-link-action (widget &optional event) | |
| 996 "Open the url specified by WIDGET." | |
| 997 (require 'browse-url) | |
| 998 (funcall browse-url-browser-function (widget-value widget))) | |
| 999 | |
| 1000 ;;; The `editable-field' Widget. | |
| 1001 | |
| 1002 (define-widget 'editable-field 'default | |
| 1003 "An editable text field." | |
| 1004 :convert-widget 'widget-item-convert-widget | |
| 1005 :keymap widget-field-keymap | |
| 1006 :format "%v" | |
| 1007 :value "" | |
| 1008 :action 'widget-field-action | |
| 1009 :validate 'widget-field-validate | |
| 1010 :valid-regexp "" | |
| 1011 :error "No match" | |
| 1012 :value-create 'widget-field-value-create | |
| 1013 :value-delete 'widget-field-value-delete | |
| 1014 :value-get 'widget-field-value-get | |
| 1015 :match 'widget-field-match) | |
| 1016 | |
| 1017 ;; History of field minibuffer edits. | |
| 1018 (defvar widget-field-history nil) | |
| 1019 | |
| 1020 (defun widget-field-action (widget &optional event) | |
| 1021 ;; Edit the value in the minibuffer. | |
| 1022 (let ((tag (widget-apply widget :menu-tag-get)) | |
| 1023 (invalid (widget-apply widget :validate))) | |
| 1024 (when invalid | |
| 1025 (error (widget-get invalid :error))) | |
| 1026 (widget-value-set widget | |
| 1027 (widget-apply widget | |
| 1028 :value-to-external | |
| 1029 (read-string (concat tag ": ") | |
| 1030 (widget-apply | |
| 1031 widget | |
| 1032 :value-to-internal | |
| 1033 (widget-value widget)) | |
| 1034 'widget-field-history))) | |
| 1035 (widget-apply widget :notify widget event) | |
| 1036 (widget-setup))) | |
| 1037 | |
| 1038 (defun widget-field-validate (widget) | |
| 1039 ;; Valid if the content matches `:valid-regexp'. | |
| 1040 (save-excursion | |
| 1041 (let ((value (widget-apply widget :value-get)) | |
| 1042 (regexp (widget-get widget :valid-regexp))) | |
| 1043 (if (string-match regexp value) | |
| 1044 nil | |
| 1045 widget)))) | |
| 1046 | |
| 1047 (defun widget-field-value-create (widget) | |
| 1048 ;; Create an editable text field. | |
| 1049 (insert " ") | |
| 1050 (let ((size (widget-get widget :size)) | |
| 1051 (value (widget-get widget :value)) | |
| 1052 (from (point))) | |
| 1053 (insert value) | |
| 1054 (and size | |
| 1055 (< (length value) size) | |
| 1056 (insert-char ?\ (- size (length value)))) | |
| 1057 (unless (memq widget widget-field-list) | |
| 1058 (setq widget-field-new (cons widget widget-field-new))) | |
| 1059 (widget-put widget :value-to (copy-marker (point))) | |
| 1060 (set-marker-insertion-type (widget-get widget :value-to) nil) | |
| 1061 (if (null size) | |
| 1062 (insert ?\n) | |
| 1063 (insert ?\ )) | |
| 1064 (widget-put widget :value-from (copy-marker from)) | |
| 1065 (set-marker-insertion-type (widget-get widget :value-from) t))) | |
| 1066 | |
| 1067 (defun widget-field-value-delete (widget) | |
| 1068 ;; Remove the widget from the list of active editing fields. | |
| 1069 (setq widget-field-list (delq widget widget-field-list)) | |
| 1070 ;; These are nil if the :format string doesn't contain `%v'. | |
| 1071 (when (widget-get widget :value-from) | |
| 1072 (set-marker (widget-get widget :value-from) nil)) | |
| 1073 (when (widget-get widget :value-from) | |
| 1074 (set-marker (widget-get widget :value-to) nil))) | |
| 1075 | |
| 1076 (defun widget-field-value-get (widget) | |
| 1077 ;; Return current text in editing field. | |
| 1078 (let ((from (widget-get widget :value-from)) | |
| 1079 (to (widget-get widget :value-to)) | |
| 1080 (size (widget-get widget :size)) | |
| 1081 (secret (widget-get widget :secret)) | |
| 1082 (old (current-buffer))) | |
| 1083 (if (and from to) | |
| 1084 (progn | |
| 1085 (set-buffer (marker-buffer from)) | |
| 1086 (setq from (1+ from) | |
| 1087 to (1- to)) | |
| 1088 (while (and size | |
| 1089 (not (zerop size)) | |
| 1090 (> to from) | |
| 1091 (eq (char-after (1- to)) ?\ )) | |
| 1092 (setq to (1- to))) | |
| 1093 (let ((result (buffer-substring-no-properties from to))) | |
| 1094 (when secret | |
| 1095 (let ((index 0)) | |
| 1096 (while (< (+ from index) to) | |
| 1097 (aset result index | |
| 1098 (get-text-property (+ from index) 'secret)) | |
| 1099 (setq index (1+ index))))) | |
| 1100 (set-buffer old) | |
| 1101 result)) | |
| 1102 (widget-get widget :value)))) | |
| 1103 | |
| 1104 (defun widget-field-match (widget value) | |
| 1105 ;; Match any string. | |
| 1106 (stringp value)) | |
| 1107 | |
| 1108 ;;; The `text' Widget. | |
| 1109 | |
| 1110 (define-widget 'text 'editable-field | |
| 1111 :keymap widget-text-keymap | |
| 1112 "A multiline text area.") | |
| 1113 | |
| 1114 ;;; The `menu-choice' Widget. | |
| 1115 | |
| 1116 (define-widget 'menu-choice 'default | |
| 1117 "A menu of options." | |
| 1118 :convert-widget 'widget-types-convert-widget | |
| 1119 :format "%[%t%]: %v" | |
| 1120 :case-fold t | |
| 1121 :tag "choice" | |
| 1122 :void '(item :format "invalid (%t)\n") | |
| 1123 :value-create 'widget-choice-value-create | |
| 1124 :value-delete 'widget-children-value-delete | |
| 1125 :value-get 'widget-choice-value-get | |
| 1126 :value-inline 'widget-choice-value-inline | |
| 1127 :action 'widget-choice-action | |
| 1128 :error "Make a choice" | |
| 1129 :validate 'widget-choice-validate | |
| 1130 :match 'widget-choice-match | |
| 1131 :match-inline 'widget-choice-match-inline) | |
| 1132 | |
| 1133 (defun widget-choice-value-create (widget) | |
| 1134 ;; Insert the first choice that matches the value. | |
| 1135 (let ((value (widget-get widget :value)) | |
| 1136 (args (widget-get widget :args)) | |
| 1137 current) | |
| 1138 (while args | |
| 1139 (setq current (car args) | |
| 1140 args (cdr args)) | |
| 1141 (when (widget-apply current :match value) | |
| 1142 (widget-put widget :children (list (widget-create-child-value | |
| 1143 widget current value))) | |
| 1144 (widget-put widget :choice current) | |
| 1145 (setq args nil | |
| 1146 current nil))) | |
| 1147 (when current | |
| 1148 (let ((void (widget-get widget :void))) | |
| 1149 (widget-put widget :children (list (widget-create-child-and-convert | |
| 1150 widget void :value value))) | |
| 1151 (widget-put widget :choice void))))) | |
| 1152 | |
| 1153 (defun widget-choice-value-get (widget) | |
| 1154 ;; Get value of the child widget. | |
| 1155 (widget-value (car (widget-get widget :children)))) | |
| 1156 | |
| 1157 (defun widget-choice-value-inline (widget) | |
| 1158 ;; Get value of the child widget. | |
| 1159 (widget-apply (car (widget-get widget :children)) :value-inline)) | |
| 1160 | |
| 1161 (defun widget-choice-action (widget &optional event) | |
| 1162 ;; Make a choice. | |
| 1163 (let ((args (widget-get widget :args)) | |
| 1164 (old (widget-get widget :choice)) | |
| 1165 (tag (widget-apply widget :menu-tag-get)) | |
| 1166 (completion-ignore-case (widget-get widget :case-fold)) | |
| 1167 current choices) | |
| 1168 ;; Remember old value. | |
| 1169 (if (and old (not (widget-apply widget :validate))) | |
| 1170 (let* ((external (widget-value widget)) | |
| 1171 (internal (widget-apply old :value-to-internal external))) | |
| 1172 (widget-put old :value internal))) | |
| 1173 ;; Find new choice. | |
| 1174 (setq current | |
| 1175 (cond ((= (length args) 0) | |
| 1176 nil) | |
| 1177 ((= (length args) 1) | |
| 1178 (nth 0 args)) | |
| 1179 ((and (= (length args) 2) | |
| 1180 (memq old args)) | |
| 1181 (if (eq old (nth 0 args)) | |
| 1182 (nth 1 args) | |
| 1183 (nth 0 args))) | |
| 1184 (t | |
| 1185 (while args | |
| 1186 (setq current (car args) | |
| 1187 args (cdr args)) | |
| 1188 (setq choices | |
| 1189 (cons (cons (widget-apply current :menu-tag-get) | |
| 1190 current) | |
| 1191 choices))) | |
| 1192 (widget-choose tag (reverse choices) event)))) | |
| 1193 (when current | |
| 1194 (widget-value-set widget | |
| 1195 (widget-apply current :value-to-external | |
| 1196 (widget-get current :value))) | |
| 1197 (widget-apply widget :notify widget event) | |
| 1198 (widget-setup))) | |
| 1199 ;; Notify parent. | |
| 1200 (widget-apply widget :notify widget event) | |
| 1201 (widget-clear-undo)) | |
| 1202 | |
| 1203 (defun widget-choice-validate (widget) | |
| 1204 ;; Valid if we have made a valid choice. | |
| 1205 (let ((void (widget-get widget :void)) | |
| 1206 (choice (widget-get widget :choice)) | |
| 1207 (child (car (widget-get widget :children)))) | |
| 1208 (if (eq void choice) | |
| 1209 widget | |
| 1210 (widget-apply child :validate)))) | |
| 1211 | |
| 1212 (defun widget-choice-match (widget value) | |
| 1213 ;; Matches if one of the choices matches. | |
| 1214 (let ((args (widget-get widget :args)) | |
| 1215 current found) | |
| 1216 (while (and args (not found)) | |
| 1217 (setq current (car args) | |
| 1218 args (cdr args) | |
| 1219 found (widget-apply current :match value))) | |
| 1220 found)) | |
| 1221 | |
| 1222 (defun widget-choice-match-inline (widget values) | |
| 1223 ;; Matches if one of the choices matches. | |
| 1224 (let ((args (widget-get widget :args)) | |
| 1225 current found) | |
| 1226 (while (and args (null found)) | |
| 1227 (setq current (car args) | |
| 1228 args (cdr args) | |
| 1229 found (widget-match-inline current values))) | |
| 1230 found)) | |
| 1231 | |
| 1232 ;;; The `toggle' Widget. | |
| 1233 | |
| 1234 (define-widget 'toggle 'menu-choice | |
| 1235 "Toggle between two states." | |
| 1236 :convert-widget 'widget-toggle-convert-widget | |
| 1237 :format "%v" | |
| 1238 :on "on" | |
| 1239 :off "off") | |
| 1240 | |
| 1241 (defun widget-toggle-convert-widget (widget) | |
| 1242 ;; Create the types representing the `on' and `off' states. | |
| 1243 (let ((on-type (widget-get widget :on-type)) | |
| 1244 (off-type (widget-get widget :off-type))) | |
| 1245 (unless on-type | |
| 1246 (setq on-type | |
| 1247 (list 'choice-item | |
| 1248 :value t | |
| 1249 :match (lambda (widget value) value) | |
| 1250 :tag (widget-get widget :on)))) | |
| 1251 (unless off-type | |
| 1252 (setq off-type | |
| 1253 (list 'choice-item :value nil :tag (widget-get widget :off)))) | |
| 1254 (widget-put widget :args (list on-type off-type))) | |
| 1255 widget) | |
| 1256 | |
| 1257 ;;; The `checkbox' Widget. | |
| 1258 | |
| 1259 (define-widget 'checkbox 'toggle | |
| 1260 "A checkbox toggle." | |
| 1261 :convert-widget 'widget-item-convert-widget | |
| 1262 :on-type '(choice-item :format "%[[X]%]" t) | |
| 1263 :off-type '(choice-item :format "%[[ ]%]" nil)) | |
| 1264 | |
| 1265 ;;; The `checklist' Widget. | |
| 1266 | |
| 1267 (define-widget 'checklist 'default | |
| 1268 "A multiple choice widget." | |
| 1269 :convert-widget 'widget-types-convert-widget | |
| 1270 :format "%v" | |
| 1271 :offset 4 | |
| 1272 :entry-format "%b %v" | |
| 1273 :menu-tag "checklist" | |
| 1274 :greedy nil | |
| 1275 :value-create 'widget-checklist-value-create | |
| 1276 :value-delete 'widget-children-value-delete | |
| 1277 :value-get 'widget-checklist-value-get | |
| 1278 :validate 'widget-checklist-validate | |
| 1279 :match 'widget-checklist-match | |
| 1280 :match-inline 'widget-checklist-match-inline) | |
| 1281 | |
| 1282 (defun widget-checklist-value-create (widget) | |
| 1283 ;; Insert all values | |
| 1284 (let ((alist (widget-checklist-match-find widget (widget-get widget :value))) | |
| 1285 (args (widget-get widget :args))) | |
| 1286 (while args | |
| 1287 (widget-checklist-add-item widget (car args) (assq (car args) alist)) | |
| 1288 (setq args (cdr args))) | |
| 1289 (widget-put widget :children (nreverse (widget-get widget :children))))) | |
| 1290 | |
| 1291 (defun widget-checklist-add-item (widget type chosen) | |
| 1292 ;; Create checklist item in WIDGET of type TYPE. | |
| 1293 ;; If the item is checked, CHOSEN is a cons whose cdr is the value. | |
| 1294 (and (eq (preceding-char) ?\n) | |
| 1295 (widget-get widget :indent) | |
| 1296 (insert-char ? (widget-get widget :indent))) | |
| 1297 (widget-specify-insert | |
| 1298 (let* ((children (widget-get widget :children)) | |
| 1299 (buttons (widget-get widget :buttons)) | |
| 1300 (from (point)) | |
| 1301 child button) | |
| 1302 (insert (widget-get widget :entry-format)) | |
| 1303 (goto-char from) | |
| 1304 ;; Parse % escapes in format. | |
| 1305 (while (re-search-forward "%\\([bv%]\\)" nil t) | |
| 1306 (let ((escape (aref (match-string 1) 0))) | |
| 1307 (replace-match "" t t) | |
| 1308 (cond ((eq escape ?%) | |
| 1309 (insert "%")) | |
| 1310 ((eq escape ?b) | |
| 1311 (setq button (widget-create-child-and-convert | |
| 1312 widget 'checkbox :value (not (null chosen))))) | |
| 1313 ((eq escape ?v) | |
| 1314 (setq child | |
| 1315 (cond ((not chosen) | |
| 1316 (widget-create-child widget type)) | |
| 1317 ((widget-get type :inline) | |
| 1318 (widget-create-child-value | |
| 1319 widget type (cdr chosen))) | |
| 1320 (t | |
| 1321 (widget-create-child-value | |
| 1322 widget type (car (cdr chosen))))))) | |
| 1323 (t | |
| 1324 (error "Unknown escape `%c'" escape))))) | |
| 1325 ;; Update properties. | |
| 1326 (and button child (widget-put child :button button)) | |
| 1327 (and button (widget-put widget :buttons (cons button buttons))) | |
| 1328 (and child (widget-put widget :children (cons child children)))))) | |
| 1329 | |
| 1330 (defun widget-checklist-match (widget values) | |
| 1331 ;; All values must match a type in the checklist. | |
| 1332 (and (listp values) | |
| 1333 (null (cdr (widget-checklist-match-inline widget values))))) | |
| 1334 | |
| 1335 (defun widget-checklist-match-inline (widget values) | |
| 1336 ;; Find the values which match a type in the checklist. | |
| 1337 (let ((greedy (widget-get widget :greedy)) | |
| 1338 (args (copy-list (widget-get widget :args))) | |
| 1339 found rest) | |
| 1340 (while values | |
| 1341 (let ((answer (widget-checklist-match-up args values))) | |
| 1342 (cond (answer | |
| 1343 (let ((vals (widget-match-inline answer values))) | |
| 1344 (setq found (append found (car vals)) | |
| 1345 values (cdr vals) | |
| 1346 args (delq answer args)))) | |
| 1347 (greedy | |
| 1348 (setq rest (append rest (list (car values))) | |
| 1349 values (cdr values))) | |
| 1350 (t | |
| 1351 (setq rest (append rest values) | |
| 1352 values nil))))) | |
| 1353 (cons found rest))) | |
| 1354 | |
| 1355 (defun widget-checklist-match-find (widget vals) | |
| 1356 ;; Find the vals which match a type in the checklist. | |
| 1357 ;; Return an alist of (TYPE MATCH). | |
| 1358 (let ((greedy (widget-get widget :greedy)) | |
| 1359 (args (copy-list (widget-get widget :args))) | |
| 1360 found) | |
| 1361 (while vals | |
| 1362 (let ((answer (widget-checklist-match-up args vals))) | |
| 1363 (cond (answer | |
| 1364 (let ((match (widget-match-inline answer vals))) | |
| 1365 (setq found (cons (cons answer (car match)) found) | |
| 1366 vals (cdr match) | |
| 1367 args (delq answer args)))) | |
| 1368 (greedy | |
| 1369 (setq vals (cdr vals))) | |
| 1370 (t | |
| 1371 (setq vals nil))))) | |
| 1372 found)) | |
| 1373 | |
| 1374 (defun widget-checklist-match-up (args vals) | |
| 1375 ;; Rerturn the first type from ARGS that matches VALS. | |
| 1376 (let (current found) | |
| 1377 (while (and args (null found)) | |
| 1378 (setq current (car args) | |
| 1379 args (cdr args) | |
| 1380 found (widget-match-inline current vals))) | |
| 1381 (if found | |
| 1382 current | |
| 1383 nil))) | |
| 1384 | |
| 1385 (defun widget-checklist-value-get (widget) | |
| 1386 ;; The values of all selected items. | |
| 1387 (let ((children (widget-get widget :children)) | |
| 1388 child result) | |
| 1389 (while children | |
| 1390 (setq child (car children) | |
| 1391 children (cdr children)) | |
| 1392 (if (widget-value (widget-get child :button)) | |
| 1393 (setq result (append result (widget-apply child :value-inline))))) | |
| 1394 result)) | |
| 1395 | |
| 1396 (defun widget-checklist-validate (widget) | |
| 1397 ;; Ticked chilren must be valid. | |
| 1398 (let ((children (widget-get widget :children)) | |
| 1399 child button found) | |
| 1400 (while (and children (not found)) | |
| 1401 (setq child (car children) | |
| 1402 children (cdr children) | |
| 1403 button (widget-get child :button) | |
| 1404 found (and (widget-value button) | |
| 1405 (widget-apply child :validate)))) | |
| 1406 found)) | |
| 1407 | |
| 1408 ;;; The `option' Widget | |
| 1409 | |
| 1410 (define-widget 'option 'checklist | |
| 1411 "An widget with an optional item." | |
| 1412 :inline t) | |
| 1413 | |
| 1414 ;;; The `choice-item' Widget. | |
| 1415 | |
| 1416 (define-widget 'choice-item 'item | |
| 1417 "Button items that delegate action events to their parents." | |
| 1418 :action 'widget-choice-item-action | |
| 1419 :format "%[%t%] \n") | |
| 1420 | |
| 1421 (defun widget-choice-item-action (widget &optional event) | |
| 1422 ;; Tell parent what happened. | |
| 1423 (widget-apply (widget-get widget :parent) :action event)) | |
| 1424 | |
| 1425 ;;; The `radio-button' Widget. | |
| 1426 | |
| 1427 (define-widget 'radio-button 'toggle | |
| 1428 "A radio button for use in the `radio' widget." | |
| 1429 :notify 'widget-radio-button-notify | |
| 1430 :on-type '(choice-item :format "%[(*)%]" t) | |
| 1431 :off-type '(choice-item :format "%[( )%]" nil)) | |
| 1432 | |
| 1433 (defun widget-radio-button-notify (widget child &optional event) | |
| 1434 ;; Notify the parent. | |
| 1435 (widget-apply (widget-get widget :parent) :action widget event)) | |
| 1436 | |
| 1437 ;;; The `radio-button-choice' Widget. | |
| 1438 | |
| 1439 (define-widget 'radio-button-choice 'default | |
| 1440 "Select one of multiple options." | |
| 1441 :convert-widget 'widget-types-convert-widget | |
| 1442 :offset 4 | |
| 1443 :format "%v" | |
| 1444 :entry-format "%b %v" | |
| 1445 :menu-tag "radio" | |
| 1446 :value-create 'widget-radio-value-create | |
| 1447 :value-delete 'widget-children-value-delete | |
| 1448 :value-get 'widget-radio-value-get | |
| 1449 :value-inline 'widget-radio-value-inline | |
| 1450 :value-set 'widget-radio-value-set | |
| 1451 :error "You must push one of the buttons" | |
| 1452 :validate 'widget-radio-validate | |
| 1453 :match 'widget-choice-match | |
| 1454 :match-inline 'widget-choice-match-inline | |
| 1455 :action 'widget-radio-action) | |
| 1456 | |
| 1457 (defun widget-radio-value-create (widget) | |
| 1458 ;; Insert all values | |
| 1459 (let ((args (widget-get widget :args)) | |
| 1460 arg) | |
| 1461 (while args | |
| 1462 (setq arg (car args) | |
| 1463 args (cdr args)) | |
| 1464 (widget-radio-add-item widget arg)))) | |
| 1465 | |
| 1466 (defun widget-radio-add-item (widget type) | |
| 1467 "Add to radio widget WIDGET a new radio button item of type TYPE." | |
| 1468 ;; (setq type (widget-convert type)) | |
| 1469 (and (eq (preceding-char) ?\n) | |
| 1470 (widget-get widget :indent) | |
| 1471 (insert-char ? (widget-get widget :indent))) | |
| 1472 (widget-specify-insert | |
| 1473 (let* ((value (widget-get widget :value)) | |
| 1474 (children (widget-get widget :children)) | |
| 1475 (buttons (widget-get widget :buttons)) | |
| 1476 (from (point)) | |
| 1477 (chosen (and (null (widget-get widget :choice)) | |
| 1478 (widget-apply type :match value))) | |
| 1479 child button) | |
| 1480 (insert (widget-get widget :entry-format)) | |
| 1481 (goto-char from) | |
| 1482 ;; Parse % escapes in format. | |
| 1483 (while (re-search-forward "%\\([bv%]\\)" nil t) | |
| 1484 (let ((escape (aref (match-string 1) 0))) | |
| 1485 (replace-match "" t t) | |
| 1486 (cond ((eq escape ?%) | |
| 1487 (insert "%")) | |
| 1488 ((eq escape ?b) | |
| 1489 (setq button (widget-create-child-and-convert | |
| 1490 widget 'radio-button | |
| 1491 :value (not (null chosen))))) | |
| 1492 ((eq escape ?v) | |
| 1493 (setq child (if chosen | |
| 1494 (widget-create-child-value | |
| 1495 widget type value) | |
| 1496 (widget-create-child widget type)))) | |
| 1497 (t | |
| 1498 (error "Unknown escape `%c'" escape))))) | |
| 1499 ;; Update properties. | |
| 1500 (when chosen | |
| 1501 (widget-put widget :choice type)) | |
| 1502 (when button | |
| 1503 (widget-put child :button button) | |
| 1504 (widget-put widget :buttons (nconc buttons (list button)))) | |
| 1505 (when child | |
| 1506 (widget-put widget :children (nconc children (list child)))) | |
| 1507 child))) | |
| 1508 | |
| 1509 (defun widget-radio-value-get (widget) | |
| 1510 ;; Get value of the child widget. | |
| 1511 (let ((chosen (widget-radio-chosen widget))) | |
| 1512 (and chosen (widget-value chosen)))) | |
| 1513 | |
| 1514 (defun widget-radio-chosen (widget) | |
| 1515 "Return the widget representing the chosen radio button." | |
| 1516 (let ((children (widget-get widget :children)) | |
| 1517 current found) | |
| 1518 (while children | |
| 1519 (setq current (car children) | |
| 1520 children (cdr children)) | |
| 1521 (let* ((button (widget-get current :button)) | |
| 1522 (value (widget-apply button :value-get))) | |
| 1523 (when value | |
| 1524 (setq found current | |
| 1525 children nil)))) | |
| 1526 found)) | |
| 1527 | |
| 1528 (defun widget-radio-value-inline (widget) | |
| 1529 ;; Get value of the child widget. | |
| 1530 (let ((children (widget-get widget :children)) | |
| 1531 current found) | |
| 1532 (while children | |
| 1533 (setq current (car children) | |
| 1534 children (cdr children)) | |
| 1535 (let* ((button (widget-get current :button)) | |
| 1536 (value (widget-apply button :value-get))) | |
| 1537 (when value | |
| 1538 (setq found (widget-apply current :value-inline) | |
| 1539 children nil)))) | |
| 1540 found)) | |
| 1541 | |
| 1542 (defun widget-radio-value-set (widget value) | |
| 1543 ;; We can't just delete and recreate a radio widget, since children | |
| 1544 ;; can be added after the original creation and won't be recreated | |
| 1545 ;; by `:create'. | |
| 1546 (let ((children (widget-get widget :children)) | |
| 1547 current found) | |
| 1548 (while children | |
| 1549 (setq current (car children) | |
| 1550 children (cdr children)) | |
| 1551 (let* ((button (widget-get current :button)) | |
| 1552 (match (and (not found) | |
| 1553 (widget-apply current :match value)))) | |
| 1554 (widget-value-set button match) | |
| 1555 (if match | |
| 1556 (widget-value-set current value)) | |
| 1557 (setq found (or found match)))))) | |
| 1558 | |
| 1559 (defun widget-radio-validate (widget) | |
| 1560 ;; Valid if we have made a valid choice. | |
| 1561 (let ((children (widget-get widget :children)) | |
| 1562 current found button) | |
| 1563 (while (and children (not found)) | |
| 1564 (setq current (car children) | |
| 1565 children (cdr children) | |
| 1566 button (widget-get current :button) | |
| 1567 found (widget-apply button :value-get))) | |
| 1568 (if found | |
| 1569 (widget-apply current :validate) | |
| 1570 widget))) | |
| 1571 | |
| 1572 (defun widget-radio-action (widget child event) | |
| 1573 ;; Check if a radio button was pressed. | |
| 1574 (let ((children (widget-get widget :children)) | |
| 1575 (buttons (widget-get widget :buttons)) | |
| 1576 current) | |
| 1577 (when (memq child buttons) | |
| 1578 (while children | |
| 1579 (setq current (car children) | |
| 1580 children (cdr children)) | |
| 1581 (let* ((button (widget-get current :button))) | |
| 1582 (cond ((eq child button) | |
| 1583 (widget-value-set button t)) | |
| 1584 ((widget-value button) | |
| 1585 (widget-value-set button nil))))))) | |
| 1586 ;; Pass notification to parent. | |
| 1587 (widget-apply widget :notify child event)) | |
| 1588 | |
| 1589 ;;; The `insert-button' Widget. | |
| 1590 | |
| 1591 (define-widget 'insert-button 'push-button | |
| 1592 "An insert button for the `editable-list' widget." | |
| 1593 :tag "INS" | |
| 1594 :action 'widget-insert-button-action) | |
| 1595 | |
| 1596 (defun widget-insert-button-action (widget &optional event) | |
| 1597 ;; Ask the parent to insert a new item. | |
| 1598 (widget-apply (widget-get widget :parent) | |
| 1599 :insert-before (widget-get widget :widget))) | |
| 1600 | |
| 1601 ;;; The `delete-button' Widget. | |
| 1602 | |
| 1603 (define-widget 'delete-button 'push-button | |
| 1604 "A delete button for the `editable-list' widget." | |
| 1605 :tag "DEL" | |
| 1606 :action 'widget-delete-button-action) | |
| 1607 | |
| 1608 (defun widget-delete-button-action (widget &optional event) | |
| 1609 ;; Ask the parent to insert a new item. | |
| 1610 (widget-apply (widget-get widget :parent) | |
| 1611 :delete-at (widget-get widget :widget))) | |
| 1612 | |
| 1613 ;;; The `editable-list' Widget. | |
| 1614 | |
| 1615 (define-widget 'editable-list 'default | |
| 1616 "A variable list of widgets of the same type." | |
| 1617 :convert-widget 'widget-types-convert-widget | |
| 1618 :offset 12 | |
| 1619 :format "%v%i\n" | |
| 1620 :format-handler 'widget-editable-list-format-handler | |
| 1621 :entry-format "%i %d %v" | |
| 1622 :menu-tag "editable-list" | |
| 1623 :value-create 'widget-editable-list-value-create | |
| 1624 :value-delete 'widget-children-value-delete | |
| 1625 :value-get 'widget-editable-list-value-get | |
| 1626 :validate 'widget-editable-list-validate | |
| 1627 :match 'widget-editable-list-match | |
| 1628 :match-inline 'widget-editable-list-match-inline | |
| 1629 :insert-before 'widget-editable-list-insert-before | |
| 1630 :delete-at 'widget-editable-list-delete-at) | |
| 1631 | |
| 1632 (defun widget-editable-list-format-handler (widget escape) | |
| 1633 ;; We recognize the insert button. | |
| 1634 (cond ((eq escape ?i) | |
| 1635 (and (widget-get widget :indent) | |
| 1636 (insert-char ? (widget-get widget :indent))) | |
| 1637 (widget-create-child-and-convert widget 'insert-button)) | |
| 1638 (t | |
| 1639 (widget-default-format-handler widget escape)))) | |
| 1640 | |
| 1641 (defun widget-editable-list-value-create (widget) | |
| 1642 ;; Insert all values | |
| 1643 (let* ((value (widget-get widget :value)) | |
| 1644 (type (nth 0 (widget-get widget :args))) | |
| 1645 (inlinep (widget-get type :inline)) | |
| 1646 children) | |
| 1647 (widget-put widget :value-pos (copy-marker (point))) | |
| 1648 (set-marker-insertion-type (widget-get widget :value-pos) t) | |
| 1649 (while value | |
| 1650 (let ((answer (widget-match-inline type value))) | |
| 1651 (if answer | |
| 1652 (setq children (cons (widget-editable-list-entry-create | |
| 1653 widget | |
| 1654 (if inlinep | |
| 1655 (car answer) | |
| 1656 (car (car answer))) | |
| 1657 t) | |
| 1658 children) | |
| 1659 value (cdr answer)) | |
| 1660 (setq value nil)))) | |
| 1661 (widget-put widget :children (nreverse children)))) | |
| 1662 | |
| 1663 (defun widget-editable-list-value-get (widget) | |
| 1664 ;; Get value of the child widget. | |
| 1665 (apply 'append (mapcar (lambda (child) (widget-apply child :value-inline)) | |
| 1666 (widget-get widget :children)))) | |
| 1667 | |
| 1668 (defun widget-editable-list-validate (widget) | |
| 1669 ;; All the chilren must be valid. | |
| 1670 (let ((children (widget-get widget :children)) | |
| 1671 child found) | |
| 1672 (while (and children (not found)) | |
| 1673 (setq child (car children) | |
| 1674 children (cdr children) | |
| 1675 found (widget-apply child :validate))) | |
| 1676 found)) | |
| 1677 | |
| 1678 (defun widget-editable-list-match (widget value) | |
| 1679 ;; Value must be a list and all the members must match the type. | |
| 1680 (and (listp value) | |
| 1681 (null (cdr (widget-editable-list-match-inline widget value))))) | |
| 1682 | |
| 1683 (defun widget-editable-list-match-inline (widget value) | |
| 1684 (let ((type (nth 0 (widget-get widget :args))) | |
| 1685 (ok t) | |
| 1686 found) | |
| 1687 (while (and value ok) | |
| 1688 (let ((answer (widget-match-inline type value))) | |
| 1689 (if answer | |
| 1690 (setq found (append found (car answer)) | |
| 1691 value (cdr answer)) | |
| 1692 (setq ok nil)))) | |
| 1693 (cons found value))) | |
| 1694 | |
| 1695 (defun widget-editable-list-insert-before (widget before) | |
| 1696 ;; Insert a new child in the list of children. | |
| 1697 (save-excursion | |
| 1698 (let ((children (widget-get widget :children)) | |
| 1699 (inhibit-read-only t) | |
| 1700 after-change-functions) | |
| 1701 (cond (before | |
| 1702 (goto-char (widget-get before :entry-from))) | |
| 1703 (t | |
| 1704 (goto-char (widget-get widget :value-pos)))) | |
| 1705 (let ((child (widget-editable-list-entry-create | |
| 1706 widget nil nil))) | |
| 1707 (when (< (widget-get child :entry-from) (widget-get widget :from)) | |
| 1708 (set-marker (widget-get widget :from) | |
| 1709 (widget-get child :entry-from))) | |
| 1710 (widget-specify-text (widget-get child :entry-from) | |
| 1711 (widget-get child :entry-to)) | |
| 1712 (if (eq (car children) before) | |
| 1713 (widget-put widget :children (cons child children)) | |
| 1714 (while (not (eq (car (cdr children)) before)) | |
| 1715 (setq children (cdr children))) | |
| 1716 (setcdr children (cons child (cdr children))))))) | |
| 1717 (widget-setup) | |
| 1718 (widget-apply widget :notify widget)) | |
| 1719 | |
| 1720 (defun widget-editable-list-delete-at (widget child) | |
| 1721 ;; Delete child from list of children. | |
| 1722 (save-excursion | |
| 1723 (let ((buttons (copy-list (widget-get widget :buttons))) | |
| 1724 button | |
| 1725 (inhibit-read-only t) | |
| 1726 after-change-functions) | |
| 1727 (while buttons | |
| 1728 (setq button (car buttons) | |
| 1729 buttons (cdr buttons)) | |
| 1730 (when (eq (widget-get button :widget) child) | |
| 1731 (widget-put widget | |
| 1732 :buttons (delq button (widget-get widget :buttons))) | |
| 1733 (widget-delete button)))) | |
| 1734 (let ((entry-from (widget-get child :entry-from)) | |
| 1735 (entry-to (widget-get child :entry-to)) | |
| 1736 (inhibit-read-only t) | |
| 1737 after-change-functions) | |
| 1738 (widget-delete child) | |
| 1739 (delete-region entry-from entry-to) | |
| 1740 (set-marker entry-from nil) | |
| 1741 (set-marker entry-to nil)) | |
| 1742 (widget-put widget :children (delq child (widget-get widget :children)))) | |
| 1743 (widget-setup) | |
| 1744 (widget-apply widget :notify widget)) | |
| 1745 | |
| 1746 (defun widget-editable-list-entry-create (widget value conv) | |
| 1747 ;; Create a new entry to the list. | |
| 1748 (let ((type (nth 0 (widget-get widget :args))) | |
| 1749 child delete insert) | |
| 1750 (widget-specify-insert | |
| 1751 (save-excursion | |
| 1752 (and (widget-get widget :indent) | |
| 1753 (insert-char ? (widget-get widget :indent))) | |
| 1754 (insert (widget-get widget :entry-format))) | |
| 1755 ;; Parse % escapes in format. | |
| 1756 (while (re-search-forward "%\\(.\\)" nil t) | |
| 1757 (let ((escape (aref (match-string 1) 0))) | |
| 1758 (replace-match "" t t) | |
| 1759 (cond ((eq escape ?%) | |
| 1760 (insert "%")) | |
| 1761 ((eq escape ?i) | |
| 1762 (setq insert (widget-create-child-and-convert | |
| 1763 widget 'insert-button))) | |
| 1764 ((eq escape ?d) | |
| 1765 (setq delete (widget-create-child-and-convert | |
| 1766 widget 'delete-button))) | |
| 1767 ((eq escape ?v) | |
| 1768 (if conv | |
| 1769 (setq child (widget-create-child-value | |
| 1770 widget type value)) | |
| 1771 (setq child (widget-create-child widget type)))) | |
| 1772 (t | |
| 1773 (error "Unknown escape `%c'" escape))))) | |
| 1774 (widget-put widget | |
| 1775 :buttons (cons delete | |
| 1776 (cons insert | |
| 1777 (widget-get widget :buttons)))) | |
| 1778 (let ((entry-from (copy-marker (point-min))) | |
| 1779 (entry-to (copy-marker (point-max)))) | |
| 1780 (widget-specify-text entry-from entry-to) | |
| 1781 (set-marker-insertion-type entry-from t) | |
| 1782 (set-marker-insertion-type entry-to nil) | |
| 1783 (widget-put child :entry-from entry-from) | |
| 1784 (widget-put child :entry-to entry-to))) | |
| 1785 (widget-put insert :widget child) | |
| 1786 (widget-put delete :widget child) | |
| 1787 child)) | |
| 1788 | |
| 1789 ;;; The `group' Widget. | |
| 1790 | |
| 1791 (define-widget 'group 'default | |
| 1792 "A widget which group other widgets inside." | |
| 1793 :convert-widget 'widget-types-convert-widget | |
| 1794 :format "%v" | |
| 1795 :value-create 'widget-group-value-create | |
| 1796 :value-delete 'widget-children-value-delete | |
| 1797 :value-get 'widget-editable-list-value-get | |
| 1798 :validate 'widget-editable-list-validate | |
| 1799 :match 'widget-group-match | |
| 1800 :match-inline 'widget-group-match-inline) | |
| 1801 | |
| 1802 (defun widget-group-value-create (widget) | |
| 1803 ;; Create each component. | |
| 1804 (let ((args (widget-get widget :args)) | |
| 1805 (value (widget-get widget :value)) | |
| 1806 arg answer children) | |
| 1807 (while args | |
| 1808 (setq arg (car args) | |
| 1809 args (cdr args) | |
| 1810 answer (widget-match-inline arg value) | |
| 1811 value (cdr answer)) | |
| 1812 (and (eq (preceding-char) ?\n) | |
| 1813 (widget-get widget :indent) | |
| 1814 (insert-char ? (widget-get widget :indent))) | |
| 1815 (push (cond ((null answer) | |
| 1816 (widget-create-child widget arg)) | |
| 1817 ((widget-get arg :inline) | |
| 1818 (widget-create-child-value widget arg (car answer))) | |
| 1819 (t | |
| 1820 (widget-create-child-value widget arg (car (car answer))))) | |
| 1821 children)) | |
| 1822 (widget-put widget :children (nreverse children)))) | |
| 1823 | |
| 1824 (defun widget-group-match (widget values) | |
| 1825 ;; Match if the components match. | |
| 1826 (and (listp values) | |
| 1827 (let ((match (widget-group-match-inline widget values))) | |
| 1828 (and match (null (cdr match)))))) | |
| 1829 | |
| 1830 (defun widget-group-match-inline (widget vals) | |
| 1831 ;; Match if the components match. | |
| 1832 (let ((args (widget-get widget :args)) | |
| 1833 argument answer found) | |
| 1834 (while args | |
| 1835 (setq argument (car args) | |
| 1836 args (cdr args) | |
| 1837 answer (widget-match-inline argument vals)) | |
| 1838 (if answer | |
| 1839 (setq vals (cdr answer) | |
| 1840 found (append found (car answer))) | |
| 1841 (setq vals nil | |
| 1842 args nil))) | |
| 1843 (if answer | |
| 1844 (cons found vals) | |
| 1845 nil))) | |
| 1846 | |
| 1847 ;;; The `widget-help' Widget. | |
| 1848 | |
| 1849 (define-widget 'widget-help 'push-button | |
| 1850 "The widget documentation button." | |
| 1851 :format "%[[%t]%] %d" | |
| 1852 :help-echo "Push me to toggle the documentation." | |
| 1853 :action 'widget-help-action) | |
| 1854 | |
| 1855 (defun widget-help-action (widget &optional event) | |
| 1856 "Toggle documentation for WIDGET." | |
| 1857 (let ((old (widget-get widget :doc)) | |
| 1858 (new (widget-get widget :widget-doc))) | |
| 1859 (widget-put widget :doc new) | |
| 1860 (widget-put widget :widget-doc old)) | |
| 1861 (widget-value-set widget (widget-value widget))) | |
| 1862 | |
| 1863 ;;; The Sexp Widgets. | |
| 1864 | |
| 1865 (define-widget 'const 'item | |
| 1866 "An immutable sexp." | |
| 1867 :format "%t\n%d") | |
| 1868 | |
| 1869 (define-widget 'function-item 'item | |
| 1870 "An immutable function name." | |
| 1871 :format "%v\n%h" | |
| 1872 :documentation-property (lambda (symbol) | |
| 1873 (condition-case nil | |
| 1874 (documentation symbol t) | |
| 1875 (error nil)))) | |
| 1876 | |
| 1877 (define-widget 'variable-item 'item | |
| 1878 "An immutable variable name." | |
| 1879 :format "%v\n%h" | |
| 1880 :documentation-property 'variable-documentation) | |
| 1881 | |
| 1882 (define-widget 'string 'editable-field | |
| 1883 "A string" | |
| 1884 :tag "String" | |
| 1885 :format "%[%t%]: %v") | |
| 1886 | |
| 1887 (define-widget 'regexp 'string | |
| 1888 "A regular expression." | |
| 1889 ;; Should do validation. | |
| 1890 :tag "Regexp") | |
| 1891 | |
| 1892 (define-widget 'file 'string | |
| 1893 "A file widget. | |
| 1894 It will read a file name from the minibuffer when activated." | |
| 1895 :format "%[%t%]: %v" | |
| 1896 :tag "File" | |
| 1897 :action 'widget-file-action) | |
| 1898 | |
| 1899 (defun widget-file-action (widget &optional event) | |
| 1900 ;; Read a file name from the minibuffer. | |
| 1901 (let* ((value (widget-value widget)) | |
| 1902 (dir (file-name-directory value)) | |
| 1903 (file (file-name-nondirectory value)) | |
| 1904 (menu-tag (widget-apply widget :menu-tag-get)) | |
| 1905 (must-match (widget-get widget :must-match)) | |
| 1906 (answer (read-file-name (concat menu-tag ": (defalt `" value "') ") | |
| 1907 dir nil must-match file))) | |
| 1908 (widget-value-set widget (abbreviate-file-name answer)) | |
| 1909 (widget-apply widget :notify widget event) | |
| 1910 (widget-setup))) | |
| 1911 | |
| 1912 (define-widget 'directory 'file | |
| 1913 "A directory widget. | |
| 1914 It will read a directory name from the minibuffer when activated." | |
| 1915 :tag "Directory") | |
| 1916 | |
| 1917 (define-widget 'symbol 'string | |
| 1918 "A lisp symbol." | |
| 1919 :value nil | |
| 1920 :tag "Symbol" | |
| 1921 :match (lambda (widget value) (symbolp value)) | |
| 1922 :value-to-internal (lambda (widget value) | |
| 1923 (if (symbolp value) | |
| 1924 (symbol-name value) | |
| 1925 value)) | |
| 1926 :value-to-external (lambda (widget value) | |
| 1927 (if (stringp value) | |
| 1928 (intern value) | |
| 1929 value))) | |
| 1930 | |
| 1931 (define-widget 'function 'sexp | |
| 1932 ;; Should complete on functions. | |
| 1933 "A lisp function." | |
| 1934 :tag "Function") | |
| 1935 | |
| 1936 (define-widget 'variable 'symbol | |
| 1937 ;; Should complete on variables. | |
| 1938 "A lisp variable." | |
| 1939 :tag "Variable") | |
| 1940 | |
| 1941 (define-widget 'sexp 'string | |
| 1942 "An arbitrary lisp expression." | |
| 1943 :tag "Lisp expression" | |
| 1944 :value nil | |
| 1945 :validate 'widget-sexp-validate | |
| 1946 :match (lambda (widget value) t) | |
| 1947 :value-to-internal 'widget-sexp-value-to-internal | |
| 1948 :value-to-external (lambda (widget value) (read value))) | |
| 1949 | |
| 1950 (defun widget-sexp-value-to-internal (widget value) | |
| 1951 ;; Use pp for printer representation. | |
| 1952 (let ((pp (pp-to-string value))) | |
| 1953 (while (string-match "\n\\'" pp) | |
| 1954 (setq pp (substring pp 0 -1))) | |
| 1955 (if (or (string-match "\n\\'" pp) | |
| 1956 (> (length pp) 40)) | |
| 1957 (concat "\n" pp) | |
| 1958 pp))) | |
| 1959 | |
| 1960 (defun widget-sexp-validate (widget) | |
| 1961 ;; Valid if we can read the string and there is no junk left after it. | |
| 1962 (save-excursion | |
| 1963 (let ((buffer (set-buffer (get-buffer-create " *Widget Scratch*")))) | |
| 1964 (erase-buffer) | |
| 1965 (insert (widget-apply widget :value-get)) | |
| 1966 (goto-char (point-min)) | |
| 1967 (condition-case data | |
| 1968 (let ((value (read buffer))) | |
| 1969 (if (eobp) | |
| 1970 (if (widget-apply widget :match value) | |
| 1971 nil | |
| 1972 (widget-put widget :error (widget-get widget :type-error)) | |
| 1973 widget) | |
| 1974 (widget-put widget | |
| 1975 :error (format "Junk at end of expression: %s" | |
| 1976 (buffer-substring (point) | |
| 1977 (point-max)))) | |
| 1978 widget)) | |
| 1979 (error (widget-put widget :error (error-message-string data)) | |
| 1980 widget))))) | |
| 1981 | |
| 1982 (define-widget 'integer 'sexp | |
| 1983 "An integer." | |
| 1984 :tag "Integer" | |
| 1985 :value 0 | |
| 1986 :type-error "This field should contain an integer" | |
| 1987 :value-to-internal (lambda (widget value) | |
| 1988 (if (integerp value) | |
| 1989 (prin1-to-string value) | |
| 1990 value)) | |
| 1991 :match (lambda (widget value) (integerp value))) | |
| 1992 | |
| 1993 (define-widget 'character 'string | |
| 1994 "An character." | |
| 1995 :tag "Character" | |
| 1996 :value 0 | |
| 1997 :size 1 | |
| 1998 :format "%{%t%}: %v\n" | |
| 1999 :type-error "This field should contain a character" | |
| 2000 :value-to-internal (lambda (widget value) | |
| 2001 (if (integerp value) | |
| 2002 (char-to-string value) | |
| 2003 value)) | |
| 2004 :value-to-external (lambda (widget value) | |
| 2005 (if (stringp value) | |
| 2006 (aref value 0) | |
| 2007 value)) | |
| 2008 :match (lambda (widget value) (integerp value))) | |
| 2009 | |
| 2010 (define-widget 'number 'sexp | |
| 2011 "A floating point number." | |
| 2012 :tag "Number" | |
| 2013 :value 0.0 | |
| 2014 :type-error "This field should contain a number" | |
| 2015 :value-to-internal (lambda (widget value) | |
| 2016 (if (numberp value) | |
| 2017 (prin1-to-string value) | |
| 2018 value)) | |
| 2019 :match (lambda (widget value) (numberp value))) | |
| 2020 | |
| 2021 (define-widget 'list 'group | |
| 2022 "A lisp list." | |
| 2023 :tag "List" | |
| 2024 :format "%{%t%}:\n%v") | |
| 2025 | |
| 2026 (define-widget 'vector 'group | |
| 2027 "A lisp vector." | |
| 2028 :tag "Vector" | |
| 2029 :format "%{%t%}:\n%v" | |
| 2030 :match 'widget-vector-match | |
| 2031 :value-to-internal (lambda (widget value) (append value nil)) | |
| 2032 :value-to-external (lambda (widget value) (apply 'vector value))) | |
| 2033 | |
| 2034 (defun widget-vector-match (widget value) | |
| 2035 (and (vectorp value) | |
| 2036 (widget-group-match widget | |
| 2037 (widget-apply :value-to-internal widget value)))) | |
| 2038 | |
| 2039 (define-widget 'cons 'group | |
| 2040 "A cons-cell." | |
| 2041 :tag "Cons-cell" | |
| 2042 :format "%{%t%}:\n%v" | |
| 2043 :match 'widget-cons-match | |
| 2044 :value-to-internal (lambda (widget value) | |
| 2045 (list (car value) (cdr value))) | |
| 2046 :value-to-external (lambda (widget value) | |
| 2047 (cons (nth 0 value) (nth 1 value)))) | |
| 2048 | |
| 2049 (defun widget-cons-match (widget value) | |
| 2050 (and (consp value) | |
| 2051 (widget-group-match widget | |
| 2052 (widget-apply widget :value-to-internal value)))) | |
| 2053 | |
| 2054 (define-widget 'choice 'menu-choice | |
| 2055 "A union of several sexp types." | |
| 2056 :tag "Choice" | |
| 2057 :format "%[%t%]: %v") | |
| 2058 | |
| 2059 (define-widget 'radio 'radio-button-choice | |
| 2060 "A union of several sexp types." | |
| 2061 :tag "Choice" | |
| 2062 :format "%{%t%}:\n%v") | |
| 2063 | |
| 2064 (define-widget 'repeat 'editable-list | |
| 2065 "A variable length homogeneous list." | |
| 2066 :tag "Repeat" | |
| 2067 :format "%{%t%}:\n%v%i\n") | |
| 2068 | |
| 2069 (define-widget 'set 'checklist | |
| 2070 "A list of members from a fixed set." | |
| 2071 :tag "Set" | |
| 2072 :format "%{%t%}:\n%v") | |
| 2073 | |
| 2074 (define-widget 'boolean 'toggle | |
| 2075 "To be nil or non-nil, that is the question." | |
| 2076 :tag "Boolean" | |
| 2077 :format "%{%t%}: %v") | |
| 2078 | |
| 2079 ;;; The `color' Widget. | |
| 2080 | |
| 2081 (define-widget 'color-item 'choice-item | |
| 2082 "A color name (with sample)." | |
| 2083 :format "%v (%[sample%])\n" | |
| 2084 :button-face-get 'widget-color-item-button-face-get) | |
| 2085 | |
| 2086 (defun widget-color-item-button-face-get (widget) | |
| 2087 ;; We create a face from the value. | |
| 2088 (require 'facemenu) | |
| 2089 (condition-case nil | |
| 2090 (facemenu-get-face (intern (concat "fg:" (widget-value widget)))) | |
| 2091 (error 'default))) | |
| 2092 | |
| 2093 (define-widget 'color 'push-button | |
| 2094 "Choose a color name (with sample)." | |
| 2095 :format "%[%t%]: %v" | |
| 2096 :tag "Color" | |
| 2097 :value "default" | |
| 2098 :value-create 'widget-color-value-create | |
| 2099 :value-delete 'widget-children-value-delete | |
| 2100 :value-get 'widget-color-value-get | |
| 2101 :value-set 'widget-color-value-set | |
| 2102 :action 'widget-color-action | |
| 2103 :match 'widget-field-match | |
| 2104 :tag "Color") | |
| 2105 | |
| 2106 (defvar widget-color-choice-list nil) | |
| 2107 ;; Variable holding the possible colors. | |
| 2108 | |
| 2109 (defun widget-color-choice-list () | |
| 2110 (unless widget-color-choice-list | |
| 2111 (setq widget-color-choice-list | |
| 2112 (mapcar '(lambda (color) (list color)) | |
| 2113 (x-defined-colors)))) | |
| 2114 widget-color-choice-list) | |
| 2115 | |
| 2116 (defun widget-color-value-create (widget) | |
| 2117 (let ((child (widget-create-child-and-convert | |
| 2118 widget 'color-item (widget-get widget :value)))) | |
| 2119 (widget-put widget :children (list child)))) | |
| 2120 | |
| 2121 (defun widget-color-value-get (widget) | |
| 2122 ;; Pass command to first child. | |
| 2123 (widget-apply (car (widget-get widget :children)) :value-get)) | |
| 2124 | |
| 2125 (defun widget-color-value-set (widget value) | |
| 2126 ;; Pass command to first child. | |
| 2127 (widget-apply (car (widget-get widget :children)) :value-set value)) | |
| 2128 | |
| 2129 (defvar widget-color-history nil | |
| 2130 "History of entered colors") | |
| 2131 | |
| 2132 (defun widget-color-action (widget &optional event) | |
| 2133 ;; Prompt for a color. | |
| 2134 (let* ((tag (widget-apply widget :menu-tag-get)) | |
| 2135 (prompt (concat tag ": ")) | |
| 2136 (answer (cond ((string-match "XEmacs" emacs-version) | |
| 2137 (read-color prompt)) | |
| 2138 ((fboundp 'x-defined-colors) | |
| 2139 (completing-read (concat tag ": ") | |
| 2140 (widget-color-choice-list) | |
| 2141 nil nil nil 'widget-color-history)) | |
| 2142 (t | |
| 2143 (read-string prompt (widget-value widget)))))) | |
| 2144 (unless (zerop (length answer)) | |
| 2145 (widget-value-set widget answer) | |
| 2146 (widget-apply widget :notify widget event) | |
| 2147 (widget-setup)))) | |
| 2148 | |
| 2149 ;;; The Help Echo | |
| 2150 | |
| 2151 (defun widget-echo-help-mouse () | |
| 2152 "Display the help message for the widget under the mouse. | |
| 2153 Enable with (run-with-idle-timer 1 t 'widget-echo-help-mouse)" | |
| 2154 (let* ((pos (mouse-position)) | |
| 2155 (frame (car pos)) | |
| 2156 (x (car (cdr pos))) | |
| 2157 (y (cdr (cdr pos))) | |
| 2158 (win (window-at x y frame)) | |
| 2159 (where (coordinates-in-window-p (cons x y) win))) | |
| 2160 (when (consp where) | |
| 2161 (save-window-excursion | |
| 2162 (progn ; save-excursion | |
| 2163 (select-window win) | |
| 2164 (let* ((result (compute-motion (window-start win) | |
| 2165 '(0 . 0) | |
| 2166 (window-end win) | |
| 2167 where | |
| 2168 (window-width win) | |
| 2169 (cons (window-hscroll) 0) | |
| 2170 win))) | |
| 2171 (when (and (eq (nth 1 result) x) | |
| 2172 (eq (nth 2 result) y)) | |
| 2173 (widget-echo-help (nth 0 result)))))))) | |
| 2174 (unless track-mouse | |
| 2175 (setq track-mouse t) | |
| 2176 (add-hook 'post-command-hook 'widget-stop-mouse-tracking))) | |
| 2177 | |
| 2178 (defun widget-stop-mouse-tracking (&rest args) | |
| 2179 "Stop the mouse tracking done while idle." | |
| 2180 (remove-hook 'post-command-hook 'widget-stop-mouse-tracking) | |
| 2181 (setq track-mouse nil)) | |
| 2182 | |
| 2183 (defun widget-at (pos) | |
| 2184 "The button or field at POS." | |
| 2185 (or (get-text-property pos 'button) | |
| 2186 (get-text-property pos 'field))) | |
| 2187 | |
| 2188 (defun widget-echo-help (pos) | |
| 2189 "Display the help echo for widget at POS." | |
| 2190 (let* ((widget (widget-at pos)) | |
| 2191 (help-echo (and widget (widget-get widget :help-echo)))) | |
| 2192 (cond ((stringp help-echo) | |
| 2193 (message "%s" help-echo)) | |
| 2194 ((and (symbolp help-echo) (fboundp help-echo) | |
| 2195 (stringp (setq help-echo (funcall help-echo widget)))) | |
| 2196 (message "%s" help-echo))))) | |
| 2197 | |
| 2198 ;;; The End: | |
| 2199 | |
| 2200 (provide 'widget-edit) | |
| 2201 | |
| 2202 ;; widget-edit.el ends here |