428
+ − 1 ;;; wid-edit.el --- Functions for creating and using widgets.
+ − 2 ;;
440
+ − 3 ;; Copyright (C) 1996, 1997, 2000 Free Software Foundation, Inc.
428
+ − 4 ;;
+ − 5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
+ − 6 ;; Maintainer: Hrvoje Niksic <hniksic@xemacs.org>
+ − 7 ;; Keywords: extensions
+ − 8 ;; Version: 1.9960-x
+ − 9 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
+ − 10
+ − 11 ;; This file is part of XEmacs.
+ − 12
+ − 13 ;; XEmacs is free software; you can redistribute it and/or modify
+ − 14 ;; it under the terms of the GNU General Public License as published by
+ − 15 ;; the Free Software Foundation; either version 2, or (at your option)
+ − 16 ;; any later version.
+ − 17
+ − 18 ;; XEmacs is distributed in the hope that it will be useful,
+ − 19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ − 20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ − 21 ;; GNU General Public License for more details.
+ − 22
+ − 23 ;; You should have received a copy of the GNU General Public License
+ − 24 ;; along with XEmacs; see the file COPYING. If not, write to the
+ − 25 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+ − 26 ;; Boston, MA 02111-1307, USA.
+ − 27
+ − 28 ;;; Commentary:
+ − 29 ;;
+ − 30 ;; See `widget.el'.
+ − 31
+ − 32
+ − 33 ;;; Code:
+ − 34
+ − 35 (require 'widget)
+ − 36
+ − 37 (autoload 'finder-commentary "finder" nil t)
+ − 38
+ − 39 ;;; Customization.
+ − 40
+ − 41 (defgroup widgets nil
+ − 42 "Customization support for the Widget Library."
+ − 43 :link '(custom-manual "(widget)Top")
+ − 44 :link '(url-link :tag "Development Page"
+ − 45 "http://www.dina.kvl.dk/~abraham/custom/")
+ − 46 :link '(emacs-library-link :tag "Lisp File" "widget.el")
+ − 47 :prefix "widget-"
+ − 48 :group 'extensions
+ − 49 :group 'hypermedia)
+ − 50
+ − 51 (defgroup widget-documentation nil
+ − 52 "Options controlling the display of documentation strings."
+ − 53 :group 'widgets)
+ − 54
+ − 55 (defgroup widget-faces nil
+ − 56 "Faces used by the widget library."
+ − 57 :group 'widgets
+ − 58 :group 'faces)
+ − 59
+ − 60 (defvar widget-documentation-face 'widget-documentation-face
+ − 61 "Face used for documentation strings in widges.
+ − 62 This exists as a variable so it can be set locally in certain buffers.")
+ − 63
+ − 64 (defface widget-documentation-face '((((class color)
+ − 65 (background dark))
+ − 66 (:foreground "lime green"))
+ − 67 (((class color)
+ − 68 (background light))
+ − 69 (:foreground "dark green"))
+ − 70 (t nil))
+ − 71 "Face used for documentation text."
+ − 72 :group 'widget-documentation
+ − 73 :group 'widget-faces)
+ − 74
+ − 75 (defvar widget-button-face 'widget-button-face
+ − 76 "Face used for buttons in widges.
+ − 77 This exists as a variable so it can be set locally in certain buffers.")
+ − 78
+ − 79 (defface widget-button-face '((t (:bold t)))
+ − 80 "Face used for widget buttons."
+ − 81 :group 'widget-faces)
+ − 82
+ − 83 (defcustom widget-mouse-face 'highlight
+ − 84 "Face used for widget buttons when the mouse is above them."
+ − 85 :type 'face
+ − 86 :group 'widget-faces)
+ − 87
+ − 88 (defface widget-field-face '((((class grayscale color)
+ − 89 (background light))
+ − 90 (:background "gray85"))
+ − 91 (((class grayscale color)
+ − 92 (background dark))
+ − 93 (:background "dim gray"))
+ − 94 (t
+ − 95 (:italic t)))
+ − 96 "Face used for editable fields."
+ − 97 :group 'widget-faces)
+ − 98
+ − 99 ;; Currently unused
+ − 100 ;(defface widget-single-line-field-face '((((class grayscale color)
+ − 101 ; (background light))
+ − 102 ; (:background "gray85"))
+ − 103 ; (((class grayscale color)
+ − 104 ; (background dark))
+ − 105 ; (:background "dim gray"))
+ − 106 ; (t
+ − 107 ; (:italic t)))
+ − 108 ; "Face used for editable fields spanning only a single line."
+ − 109 ; :group 'widget-faces)
+ − 110 ;
+ − 111 ;(defvar widget-single-line-display-table
+ − 112 ; (let ((table (make-display-table)))
+ − 113 ; (aset table 9 "^I")
+ − 114 ; (aset table 10 "^J")
+ − 115 ; table)
+ − 116 ; "Display table used for single-line editable fields.")
+ − 117 ;
+ − 118 ;(set-face-display-table 'widget-single-line-field-face
+ − 119 ; widget-single-line-display-table)
+ − 120
+ − 121
+ − 122 ;; Some functions from this file have been ported to C for speed.
+ − 123 ;; Setting this to t (*before* loading wid-edit.el) will make them
+ − 124 ;; shadow the subrs. It should be used only for debugging purposes.
+ − 125 (defvar widget-shadow-subrs nil)
+ − 126
+ − 127
+ − 128 ;;; Utility functions.
+ − 129 ;;
+ − 130 ;; These are not really widget specific.
+ − 131
+ − 132 (when (or (not (fboundp 'widget-plist-member))
+ − 133 widget-shadow-subrs)
+ − 134 ;; Recoded in C, for efficiency. It used to be a defsubst, but old
+ − 135 ;; compiled code won't fail -- it will just be slower.
+ − 136 (defun widget-plist-member (plist prop)
+ − 137 ;; Return non-nil if PLIST has the property PROP.
+ − 138 ;; PLIST is a property list, which is a list of the form
+ − 139 ;; (PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol.
+ − 140 ;; Unlike `plist-get', this allows you to distinguish between a missing
+ − 141 ;; property and a property with the value nil.
+ − 142 ;; The value is actually the tail of PLIST whose car is PROP.
+ − 143 (while (and plist (not (eq (car plist) prop)))
+ − 144 (setq plist (cddr plist)))
+ − 145 plist))
+ − 146
+ − 147 (defun widget-princ-to-string (object)
+ − 148 ;; Return string representation of OBJECT, any Lisp object.
+ − 149 ;; No quoting characters are used; no delimiters are printed around
+ − 150 ;; the contents of strings.
+ − 151 (with-current-buffer (get-buffer-create " *widget-tmp*")
+ − 152 (erase-buffer)
+ − 153 (princ object (current-buffer))
+ − 154 (buffer-string)))
+ − 155
+ − 156 (defun widget-prettyprint-to-string (object)
+ − 157 ;; Like pp-to-string, but uses `cl-prettyprint'
+ − 158 (with-current-buffer (get-buffer-create " *widget-tmp*")
+ − 159 (erase-buffer)
+ − 160 (cl-prettyprint object)
+ − 161 ;; `cl-prettyprint' always surrounds the text with newlines.
+ − 162 (when (eq (char-after (point-min)) ?\n)
+ − 163 (delete-region (point-min) (1+ (point-min))))
+ − 164 (when (eq (char-before (point-max)) ?\n)
+ − 165 (delete-region (1- (point-max)) (point-max)))
+ − 166 (buffer-string)))
+ − 167
+ − 168 (defun widget-clear-undo ()
+ − 169 "Clear all undo information."
+ − 170 (buffer-disable-undo)
+ − 171 (buffer-enable-undo))
+ − 172
+ − 173 (defcustom widget-menu-max-size 40
+ − 174 "Largest number of items allowed in a popup-menu.
+ − 175 Larger menus are read through the minibuffer."
+ − 176 :group 'widgets
+ − 177 :type 'integer)
+ − 178
+ − 179 (defcustom widget-menu-minibuffer-flag nil
+ − 180 "*Control how to ask for a choice from the keyboard.
+ − 181 Non-nil means use the minibuffer;
+ − 182 nil means read a single character."
+ − 183 :group 'widgets
+ − 184 :type 'boolean)
+ − 185
+ − 186 (defun widget-choose (title items &optional event)
+ − 187 "Choose an item from a list.
+ − 188
+ − 189 First argument TITLE is the name of the list.
+ − 190 Second argument ITEMS is an list whose members are either
+ − 191 (NAME . VALUE), to indicate selectable items, or just strings to
+ − 192 indicate unselectable items.
+ − 193 Optional third argument EVENT is an input event.
+ − 194
+ − 195 The user is asked to choose between each NAME from the items alist,
+ − 196 and the VALUE of the chosen element will be returned. If EVENT is a
+ − 197 mouse event, and the number of elements in items is less than
+ − 198 `widget-menu-max-size', a popup menu will be used, otherwise the
+ − 199 minibuffer."
+ − 200 (cond ((and (< (length items) widget-menu-max-size)
+ − 201 event
+ − 202 (console-on-window-system-p))
+ − 203 ;; Pressed by the mouse.
+ − 204 (let ((val (get-popup-menu-response
+ − 205 (cons title
+ − 206 (mapcar (lambda (x)
+ − 207 (if (stringp x)
+ − 208 (vector x nil nil)
+ − 209 (vector (car x) (list (car x)) t)))
+ − 210 items)))))
+ − 211 (setq val (and val
+ − 212 (listp (event-object val))
+ − 213 (stringp (car-safe (event-object val)))
+ − 214 (car (event-object val))))
+ − 215 (cdr (assoc val items))))
+ − 216 ((and (not widget-menu-minibuffer-flag)
+ − 217 ;; Can't handle more than 10 items (as many digits)
+ − 218 (<= (length items) 10))
+ − 219 ;; Construct a menu of the choices
+ − 220 ;; and then use it for prompting for a single character.
+ − 221 (let* ((overriding-terminal-local-map (make-sparse-keymap))
+ − 222 (map (make-sparse-keymap title))
+ − 223 (next-digit ?0)
+ − 224 some-choice-enabled value)
+ − 225 ;; Define SPC as a prefix char to get to this menu.
+ − 226 (define-key overriding-terminal-local-map " " map)
+ − 227 (with-current-buffer (get-buffer-create " widget-choose")
+ − 228 (erase-buffer)
+ − 229 (insert "Available choices:\n\n")
+ − 230 (dolist (choice items)
+ − 231 (when (consp choice)
+ − 232 (let* ((name (car choice))
+ − 233 (function (cdr choice)))
+ − 234 (insert (format "%c = %s\n" next-digit name))
+ − 235 (define-key map (vector next-digit) function)
+ − 236 (setq some-choice-enabled t)))
+ − 237 ;; Allocate digits to disabled alternatives
+ − 238 ;; so that the digit of a given alternative never varies.
+ − 239 (incf next-digit))
+ − 240 (insert "\nC-g = Quit"))
+ − 241 (or some-choice-enabled
+ − 242 (error "None of the choices is currently meaningful"))
+ − 243 (define-key map [?\C-g] 'keyboard-quit)
+ − 244 (define-key map [t] 'keyboard-quit)
+ − 245 ;(setcdr map (nreverse (cdr map)))
+ − 246 ;; Unread a SPC to lead to our new menu.
+ − 247 (push (character-to-event ?\ ) unread-command-events)
+ − 248 ;; Read a char with the menu, and return the result
+ − 249 ;; that corresponds to it.
+ − 250 (save-window-excursion
+ − 251 (display-buffer (get-buffer " widget-choose"))
+ − 252 (let ((cursor-in-echo-area t))
+ − 253 (setq value
+ − 254 (lookup-key overriding-terminal-local-map
+ − 255 (read-key-sequence (concat title ": ") t)))))
+ − 256 (message "")
+ − 257 (when (or (eq value 'keyboard-quit)
+ − 258 (null value))
+ − 259 (error "Canceled"))
+ − 260 value))
+ − 261 (t
+ − 262 ;; Read the choice of name from the minibuffer.
+ − 263 (setq items (remove-if 'stringp items))
+ − 264 (let ((val (completing-read (concat title ": ") items nil t)))
+ − 265 (if (stringp val)
+ − 266 (let ((try (try-completion val items)))
+ − 267 (when (stringp try)
+ − 268 (setq val try))
+ − 269 (cdr (assoc val items)))
+ − 270 nil)))))
+ − 271
+ − 272
+ − 273 ;;; Widget text specifications.
+ − 274 ;;
+ − 275 ;; These functions are for specifying text properties.
+ − 276
+ − 277 (defcustom widget-field-add-space t
+ − 278 ;; Setting this to nil might be available, once some problems are resolved.
+ − 279 "Non-nil means add extra space at the end of editable text fields.
+ − 280
+ − 281 This is needed on all versions of Emacs. If you don't add the space,
+ − 282 it will become impossible to edit a zero size field."
+ − 283 :type 'boolean
+ − 284 :group 'widgets)
+ − 285
+ − 286 (defcustom widget-field-use-before-change
+ − 287 (and (or (> emacs-minor-version 34)
+ − 288 (> emacs-major-version 19))
+ − 289 (not (string-match "XEmacs" emacs-version)))
+ − 290 "Non-nil means use `before-change-functions' to track editable fields.
+ − 291 This enables the use of undo, but doesn't work on Emacs 19.34 and earlier.
+ − 292 Using before hooks also means that the :notify function can't know the
+ − 293 new value."
+ − 294 :type 'boolean
+ − 295 :group 'widgets)
+ − 296
+ − 297 (defun widget-echo-this-extent (extent)
+ − 298 (let* ((widget (or (extent-property extent 'button)
+ − 299 (extent-property extent 'field)
+ − 300 (extent-property extent 'glyph-widget)))
+ − 301 (help-echo (and widget (widget-get widget :help-echo))))
+ − 302 (and (functionp help-echo)
+ − 303 (setq help-echo (funcall help-echo widget)))
+ − 304 (when (stringp help-echo)
+ − 305 (setq help-echo-owns-message t)
+ − 306 (display-message 'help-echo help-echo))))
+ − 307
+ − 308 (defsubst widget-handle-help-echo (extent help-echo)
+ − 309 (set-extent-property extent 'balloon-help help-echo)
+ − 310 (set-extent-property extent 'help-echo help-echo)
+ − 311 (when (functionp help-echo)
+ − 312 (set-extent-property extent 'balloon-help 'widget-echo-this-extent)
+ − 313 (set-extent-property extent 'help-echo 'widget-echo-this-extent)))
+ − 314
+ − 315 (defun widget-specify-field (widget from to)
+ − 316 "Specify editable button for WIDGET between FROM and TO."
+ − 317 (save-excursion
+ − 318 (goto-char to)
+ − 319 (cond ((null (widget-get widget :size))
+ − 320 (forward-char 1))
+ − 321 ;; Terminating space is not part of the field, but necessary in
+ − 322 ;; order for local-map to work. Remove next sexp if local-map works
+ − 323 ;; at the end of the extent.
+ − 324 (widget-field-add-space
+ − 325 (insert-and-inherit " ")))
+ − 326 (setq to (point)))
+ − 327 (let ((map (widget-get widget :keymap))
+ − 328 (face (or (widget-get widget :value-face) 'widget-field-face))
+ − 329 (help-echo (widget-get widget :help-echo))
+ − 330 (extent (make-extent from to)))
+ − 331 (unless (or (stringp help-echo) (null help-echo))
+ − 332 (setq help-echo 'widget-mouse-help))
+ − 333 (widget-put widget :field-extent extent)
+ − 334 (and (or (not widget-field-add-space)
+ − 335 (widget-get widget :size))
+ − 336 (set-extent-property extent 'end-closed nil))
+ − 337 (set-extent-property extent 'detachable nil)
+ − 338 (set-extent-property extent 'field widget)
+ − 339 (set-extent-property extent 'button-or-field t)
+ − 340 (set-extent-property extent 'keymap map)
+ − 341 (set-extent-property extent 'face face)
+ − 342 (widget-handle-help-echo extent help-echo))
+ − 343 (widget-specify-secret widget))
+ − 344
+ − 345 (defun widget-specify-secret (field)
+ − 346 "Replace text in FIELD with value of `:secret', if non-nil."
+ − 347 (let ((secret (widget-get field :secret))
+ − 348 (size (widget-get field :size)))
+ − 349 (when secret
+ − 350 (let ((begin (widget-field-start field))
+ − 351 (end (widget-field-end field)))
+ − 352 (when size
+ − 353 (while (and (> end begin)
+ − 354 (eq (char-after (1- end)) ?\ ))
+ − 355 (setq end (1- end))))
+ − 356 (while (< begin end)
+ − 357 (let ((old (char-after begin)))
+ − 358 (unless (eq old secret)
+ − 359 (subst-char-in-region begin (1+ begin) old secret)
+ − 360 (put-text-property begin (1+ begin) 'secret old))
+ − 361 (setq begin (1+ begin))))))))
+ − 362
+ − 363 (defun widget-specify-button (widget from to)
+ − 364 "Specify button for WIDGET between FROM and TO."
+ − 365 (let ((face (widget-apply widget :button-face-get))
+ − 366 (help-echo (widget-get widget :help-echo))
+ − 367 (extent (make-extent from to))
+ − 368 (map (widget-get widget :button-keymap)))
+ − 369 (widget-put widget :button-extent extent)
+ − 370 (unless (or (null help-echo) (stringp help-echo))
+ − 371 (setq help-echo 'widget-mouse-help))
+ − 372 (set-extent-property extent 'start-open t)
+ − 373 (set-extent-property extent 'button widget)
+ − 374 (set-extent-property extent 'button-or-field t)
+ − 375 (set-extent-property extent 'mouse-face widget-mouse-face)
+ − 376 (widget-handle-help-echo extent help-echo)
+ − 377 (set-extent-property extent 'face face)
+ − 378 (set-extent-property extent 'keymap map)))
+ − 379
+ − 380 (defun widget-mouse-help (extent)
+ − 381 "Find mouse help string for button in extent."
+ − 382 (let* ((widget (widget-at (extent-start-position extent)))
+ − 383 (help-echo (and widget (widget-get widget :help-echo))))
+ − 384 (cond ((stringp help-echo)
+ − 385 help-echo)
+ − 386 ((and (functionp help-echo)
+ − 387 (stringp (setq help-echo (funcall help-echo widget))))
+ − 388 help-echo)
+ − 389 (t
+ − 390 (format "(widget %S :help-echo %S)" widget help-echo)))))
+ − 391
+ − 392 (defun widget-specify-sample (widget from to)
+ − 393 ;; Specify sample for WIDGET between FROM and TO.
+ − 394 (let ((face (widget-apply widget :sample-face-get))
+ − 395 (extent (make-extent from to nil)))
+ − 396 (set-extent-property extent 'start-open t)
+ − 397 (set-extent-property extent 'face face)
+ − 398 (widget-put widget :sample-extent extent)))
+ − 399
+ − 400 (defun widget-specify-doc (widget from to)
+ − 401 ;; Specify documentation for WIDGET between FROM and TO.
+ − 402 (let ((extent (make-extent from to)))
+ − 403 (set-extent-property extent 'start-open t)
+ − 404 (set-extent-property extent 'widget-doc widget)
+ − 405 (set-extent-property extent 'face widget-documentation-face)
+ − 406 (widget-put widget :doc-extent extent)))
+ − 407
+ − 408 (defmacro widget-specify-insert (&rest form)
+ − 409 ;; Execute FORM without inheriting any text properties.
+ − 410 `(save-restriction
+ − 411 (let ((inhibit-read-only t)
+ − 412 before-change-functions
+ − 413 after-change-functions)
+ − 414 (insert "<>")
+ − 415 (narrow-to-region (- (point) 2) (point))
+ − 416 (goto-char (1+ (point-min)))
+ − 417 ;; We use `prog1' instead of a `result' variable, as the latter
+ − 418 ;; confuses the byte-compiler in some cases (a warning).
+ − 419 (prog1 (progn ,@form)
+ − 420 (delete-region (point-min) (1+ (point-min)))
+ − 421 (delete-region (1- (point-max)) (point-max))
+ − 422 (goto-char (point-max))))))
+ − 423
+ − 424 (put 'widget-specify-insert 'edebug-form-spec '(&rest form))
+ − 425
+ − 426
+ − 427 ;;; Inactive Widgets.
+ − 428
+ − 429 (defface widget-inactive-face '((((class grayscale color)
+ − 430 (background dark))
+ − 431 (:foreground "light gray"))
+ − 432 (((class grayscale color)
+ − 433 (background light))
+ − 434 (:foreground "dim gray"))
+ − 435 (t
+ − 436 (:italic t)))
+ − 437 "Face used for inactive widgets."
+ − 438 :group 'widget-faces)
+ − 439
+ − 440 ;; For inactiveness to work on complex structures, it is not
+ − 441 ;; sufficient to keep track of whether a button/field/glyph is
+ − 442 ;; inactive or not -- we must know how many time it was deactivated
+ − 443 ;; (inactiveness level). Successive deactivations of the same button
+ − 444 ;; increment its inactive-count, and activations decrement it. When
+ − 445 ;; inactive-count reaches 0, the button/field/glyph is reactivated.
+ − 446
+ − 447 (defun widget-activation-widget-mapper (extent action)
+ − 448 "Activate or deactivate EXTENT's widget (button or field).
+ − 449 Suitable for use with `map-extents'."
+ − 450 (ecase action
+ − 451 (:activate
+ − 452 (decf (extent-property extent :inactive-count))
+ − 453 (when (zerop (extent-property extent :inactive-count))
+ − 454 (set-extent-properties
+ − 455 extent (extent-property extent :inactive-plist))
+ − 456 (set-extent-property extent :inactive-plist nil)))
+ − 457 (:deactivate
+ − 458 (incf (extent-property extent :inactive-count 0))
+ − 459 ;; Store a plist of old properties, which will be fed to
+ − 460 ;; `set-extent-properties'.
+ − 461 (unless (extent-property extent :inactive-plist)
+ − 462 (set-extent-property
+ − 463 extent :inactive-plist
+ − 464 (list 'mouse-face (extent-property extent 'mouse-face)
+ − 465 'help-echo (extent-property extent 'help-echo)
+ − 466 'keymap (extent-property extent 'keymap)))
+ − 467 (set-extent-properties
+ − 468 extent '(mouse-face nil help-echo nil keymap nil)))))
+ − 469 nil)
+ − 470
+ − 471 (defun widget-activation-glyph-mapper (extent action)
+ − 472 (let ((activate-p (if (eq action :activate) t nil)))
+ − 473 (if activate-p
+ − 474 (decf (extent-property extent :inactive-count))
+ − 475 (incf (extent-property extent :inactive-count 0)))
+ − 476 (when (or (and activate-p
+ − 477 (zerop (extent-property extent :inactive-count)))
+ − 478 (and (not activate-p)
+ − 479 (not (zerop (extent-property extent :inactive-count)))))
+ − 480 (let* ((glyph-widget (extent-property extent 'glyph-widget))
+ − 481 (up-glyph (widget-get glyph-widget :glyph-up))
+ − 482 (inactive-glyph (widget-get glyph-widget :glyph-inactive))
454
+ − 483 (instantiator (widget-get glyph-widget :glyph-instantiator))
428
+ − 484 (new-glyph (if activate-p up-glyph inactive-glyph)))
454
+ − 485 (cond
+ − 486 ;; Assume that an instantiator means a native widget.
+ − 487 (instantiator
+ − 488 (setq instantiator
+ − 489 (set-instantiator-property instantiator :active activate-p))
+ − 490 (widget-put glyph-widget :glyph-instantiator instantiator)
+ − 491 (set-glyph-image up-glyph instantiator))
428
+ − 492 ;; Check that the new glyph exists, and differs from the
+ − 493 ;; default one.
454
+ − 494 ((and up-glyph inactive-glyph (not (eq up-glyph inactive-glyph))
+ − 495 ;; Check if the glyph is already installed.
+ − 496 (not (eq (extent-end-glyph extent) new-glyph)))
+ − 497 ;; Change it.
+ − 498 (set-extent-end-glyph extent new-glyph))))))
428
+ − 499 nil)
+ − 500
+ − 501 (defun widget-specify-inactive (widget from to)
+ − 502 "Make WIDGET inactive for user modifications."
+ − 503 (unless (widget-get widget :inactive)
+ − 504 (let ((extent (make-extent from to)))
+ − 505 ;; It is no longer necessary for the extent to be read-only, as
+ − 506 ;; the inactive editable fields now lose their keymaps.
+ − 507 (set-extent-properties
+ − 508 extent '(start-open t face widget-inactive-face
+ − 509 detachable t priority 2001 widget-inactive t))
+ − 510 (widget-put widget :inactive extent))
+ − 511 ;; Deactivate the buttons and fields within the range. In some
+ − 512 ;; cases, the fields are not yet setup at the time this function
+ − 513 ;; is called. Those fields are deactivated explicitly by
+ − 514 ;; `widget-setup'.
+ − 515 (map-extents 'widget-activation-widget-mapper
+ − 516 nil from to :deactivate nil 'button-or-field)
+ − 517 ;; Deactivate glyphs.
+ − 518 (map-extents 'widget-activation-glyph-mapper
+ − 519 nil from to :deactivate nil 'glyph-widget)))
+ − 520
+ − 521 (defun widget-specify-active (widget)
+ − 522 "Make WIDGET active for user modifications."
444
+ − 523 (let ((inactive (widget-get widget :inactive))
+ − 524 (from (widget-get widget :from))
+ − 525 (to (widget-get widget :to)))
428
+ − 526 (when (and inactive (not (extent-detached-p inactive)))
+ − 527 ;; Reactivate the buttons and fields covered by the extent.
+ − 528 (map-extents 'widget-activation-widget-mapper
444
+ − 529 nil from to :activate nil 'button-or-field)
428
+ − 530 ;; Reactivate the glyphs.
+ − 531 (map-extents 'widget-activation-glyph-mapper
444
+ − 532 nil from to :activate nil 'end-glyph)
428
+ − 533 (delete-extent inactive)
+ − 534 (widget-put widget :inactive nil))))
+ − 535
+ − 536
+ − 537 ;;; Widget Properties.
+ − 538
+ − 539 (defsubst widget-type (widget)
+ − 540 "Return the type of WIDGET, a symbol."
+ − 541 (car widget))
+ − 542
+ − 543 (when (or (not (fboundp 'widget-put))
+ − 544 widget-shadow-subrs)
+ − 545 (defun widget-put (widget property value)
+ − 546 "In WIDGET set PROPERTY to VALUE.
+ − 547 The value can later be retrieved with `widget-get'."
+ − 548 (setcdr widget (plist-put (cdr widget) property value))))
+ − 549
+ − 550 ;; Recoded in C, for efficiency:
+ − 551 (when (or (not (fboundp 'widget-get))
+ − 552 widget-shadow-subrs)
+ − 553 (defun widget-get (widget property)
+ − 554 "In WIDGET, get the value of PROPERTY.
+ − 555 The value could either be specified when the widget was created, or
+ − 556 later with `widget-put'."
+ − 557 (let ((missing t)
+ − 558 value tmp)
+ − 559 (while missing
+ − 560 (cond ((setq tmp (widget-plist-member (cdr widget) property))
+ − 561 (setq value (car (cdr tmp))
+ − 562 missing nil))
+ − 563 ((setq tmp (car widget))
+ − 564 (setq widget (get tmp 'widget-type)))
+ − 565 (t
+ − 566 (setq missing nil))))
+ − 567 value)))
+ − 568
+ − 569 (defun widget-get-indirect (widget property)
+ − 570 "In WIDGET, get the value of PROPERTY.
+ − 571 If the value is a symbol, return its binding.
+ − 572 Otherwise, just return the value."
+ − 573 (let ((value (widget-get widget property)))
+ − 574 (if (symbolp value)
+ − 575 (symbol-value value)
+ − 576 value)))
+ − 577
+ − 578 (defun widget-member (widget property)
444
+ − 579 "Return t if there is a definition in WIDGET for PROPERTY."
428
+ − 580 (cond ((widget-plist-member (cdr widget) property)
+ − 581 t)
+ − 582 ((car widget)
+ − 583 (widget-member (get (car widget) 'widget-type) property))
+ − 584 (t nil)))
+ − 585
+ − 586 (when (or (not (fboundp 'widget-apply))
+ − 587 widget-shadow-subrs)
+ − 588 ;;This is in C, so don't ###utoload
+ − 589 (defun widget-apply (widget property &rest args)
+ − 590 "Apply the value of WIDGET's PROPERTY to the widget itself.
+ − 591 ARGS are passed as extra arguments to the function."
+ − 592 (apply (widget-get widget property) widget args)))
+ − 593
+ − 594 (defun widget-value (widget)
+ − 595 "Extract the current value of WIDGET."
+ − 596 (widget-apply widget
+ − 597 :value-to-external (widget-apply widget :value-get)))
+ − 598
+ − 599 (defun widget-value-set (widget value)
+ − 600 "Set the current value of WIDGET to VALUE."
+ − 601 (widget-apply widget
+ − 602 :value-set (widget-apply widget
+ − 603 :value-to-internal value)))
+ − 604
+ − 605 (defun widget-default-get (widget)
+ − 606 "Extract the defaylt value of WIDGET."
+ − 607 (or (widget-get widget :value)
+ − 608 (widget-apply widget :default-get)))
+ − 609
+ − 610 (defun widget-match-inline (widget vals)
+ − 611 ;; In WIDGET, match the start of VALS.
+ − 612 (cond ((widget-get widget :inline)
+ − 613 (widget-apply widget :match-inline vals))
440
+ − 614 ((and (listp vals)
428
+ − 615 (widget-apply widget :match (car vals)))
+ − 616 (cons (list (car vals)) (cdr vals)))
+ − 617 (t nil)))
+ − 618
+ − 619 (defun widget-apply-action (widget &optional event)
+ − 620 "Apply :action in WIDGET in response to EVENT."
+ − 621 (if (widget-apply widget :active)
+ − 622 (widget-apply widget :action event)
+ − 623 (error "Attempt to perform action on inactive widget")))
+ − 624
+ − 625
+ − 626 ;;; Helper functions.
+ − 627 ;;
+ − 628 ;; These are widget specific.
+ − 629
+ − 630 ;;;###autoload
+ − 631 (defun widget-prompt-value (widget prompt &optional value unbound)
+ − 632 "Prompt for a value matching WIDGET, using PROMPT.
+ − 633 The current value is assumed to be VALUE, unless UNBOUND is non-nil."
+ − 634 (unless (listp widget)
+ − 635 (setq widget (list widget)))
+ − 636 (setq prompt (format "[%s] %s" (widget-type widget) prompt))
+ − 637 (setq widget (widget-convert widget))
+ − 638 (let ((answer (widget-apply widget :prompt-value prompt value unbound)))
+ − 639 (while (not (widget-apply widget :match answer))
+ − 640 (setq answer (signal 'error (list "Answer does not match type"
+ − 641 answer (widget-type widget)))))
+ − 642 answer))
+ − 643
+ − 644 (defun widget-get-sibling (widget)
+ − 645 "Get the item WIDGET is assumed to toggle.
+ − 646 This is only meaningful for radio buttons or checkboxes in a list."
+ − 647 (let* ((parent (widget-get widget :parent))
+ − 648 (children (widget-get parent :children))
+ − 649 child)
+ − 650 (catch 'child
+ − 651 (while children
+ − 652 (setq child (car children)
+ − 653 children (cdr children))
+ − 654 (when (eq (widget-get child :button) widget)
+ − 655 (throw 'child child)))
+ − 656 nil)))
+ − 657
+ − 658 (defun widget-map-buttons (function &optional buffer maparg)
+ − 659 "Map FUNCTION over the buttons in BUFFER.
+ − 660 FUNCTION is called with the arguments WIDGET and MAPARG.
+ − 661
+ − 662 If FUNCTION returns non-nil, the walk is cancelled.
+ − 663
+ − 664 The arguments MAPARG, and BUFFER default to nil and (current-buffer),
+ − 665 respectively."
+ − 666 (map-extents (lambda (extent ignore)
+ − 667 ;; If FUNCTION returns non-nil, we bail out
+ − 668 (funcall function (extent-property extent 'button) maparg))
+ − 669 nil nil nil nil nil
+ − 670 'button))
+ − 671
+ − 672
+ − 673 ;;; Glyphs.
+ − 674
+ − 675 (defcustom widget-glyph-directory (locate-data-directory "custom")
+ − 676 "Where widget glyphs are located.
+ − 677 If this variable is nil, widget will try to locate the directory
+ − 678 automatically."
+ − 679 :group 'widgets
+ − 680 :type 'directory)
+ − 681
+ − 682 (defcustom widget-glyph-enable t
+ − 683 "If non nil, use glyphs in images when available."
+ − 684 :group 'widgets
+ − 685 :type 'boolean)
+ − 686
+ − 687 (defcustom widget-image-file-name-suffixes
+ − 688 '((xpm ".xpm") (gif ".gif") (png ".png") (jpeg ".jpg" ".jpeg")
+ − 689 (xbm ".xbm"))
+ − 690 "Conversion alist from image formats to file name suffixes."
+ − 691 :group 'widgets
+ − 692 :type '(repeat (cons :format "%v"
+ − 693 (symbol :tag "Image Format" unknown)
+ − 694 (repeat :tag "Suffixes"
+ − 695 (string :format "%v")))))
+ − 696
+ − 697 ;; Don't use this, because we cannot yet distinguish between widget
+ − 698 ;; glyphs associated with user action, and actionless ones.
+ − 699 ;(defvar widget-glyph-pointer-glyph
+ − 700 ; (make-pointer-glyph [cursor-font :data "hand2"])
+ − 701 ; "Glyph to be used as the mouse pointer shape over glyphs.
+ − 702 ;Use `set-glyph-image' to change this.")
+ − 703
+ − 704 (defvar widget-glyph-cache nil
+ − 705 "Cache of glyphs associated with strings (files).")
+ − 706
+ − 707 (defun widget-glyph-find (image tag)
+ − 708 "Create a glyph corresponding to IMAGE with string TAG as fallback.
+ − 709 IMAGE can already be a glyph, or a file name sans extension (xpm,
+ − 710 xbm, gif, jpg, or png) located in `widget-glyph-directory', or
+ − 711 in one of the data directories.
+ − 712 It can also be a valid image instantiator, in which case it will be
+ − 713 used to make the glyph, with an additional TAG string fallback."
+ − 714 (cond ((not (and image widget-glyph-enable))
+ − 715 ;; We don't want to use glyphs.
+ − 716 nil)
+ − 717 ((and (not (console-on-window-system-p))
+ − 718 ;; We don't use glyphs on TTY consoles, although we
+ − 719 ;; could. However, glyph faces aren't yet working
+ − 720 ;; properly, and movement through glyphs is unintuitive.
+ − 721 ;; As an exception, when TAG is nil, we assume that the
+ − 722 ;; caller knows what he is doing, and that the tag is
+ − 723 ;; encoded within the glyph.
+ − 724 (not (glyphp image)))
+ − 725 nil)
+ − 726 ((glyphp image)
+ − 727 ;; Already a glyph. Use it.
+ − 728 image)
+ − 729 ((stringp image)
+ − 730 ;; A string. Look it up in the cache first...
+ − 731 (or (lax-plist-get widget-glyph-cache image)
+ − 732 ;; ...and then in the relevant directories
+ − 733 (let* ((dirlist (cons (or widget-glyph-directory
+ − 734 (locate-data-directory "custom"))
+ − 735 data-directory-list))
+ − 736 (all-suffixes
+ − 737 (apply #'append
+ − 738 (mapcar
+ − 739 (lambda (el)
+ − 740 (and (valid-image-instantiator-format-p (car el))
+ − 741 (cdr el)))
+ − 742 widget-image-file-name-suffixes)))
+ − 743 (file (locate-file image dirlist all-suffixes)))
+ − 744 (when file
+ − 745 (let* ((extension (concat "." (file-name-extension file)))
+ − 746 (format (car (rassoc* extension
+ − 747 widget-image-file-name-suffixes
+ − 748 :test #'member))))
+ − 749 ;; We create a glyph with the file as the default image
+ − 750 ;; instantiator, and the TAG fallback
+ − 751 (let ((glyph (make-glyph `([,format :file ,file]
+ − 752 [string :data ,tag]))))
+ − 753 ;; Cache the glyph
+ − 754 (laxputf widget-glyph-cache image glyph)
+ − 755 ;; ...and return it
+ − 756 glyph))))))
+ − 757 ((valid-instantiator-p image 'image)
+ − 758 ;; A valid image instantiator (e.g. [gif :file "somefile"] etc.)
+ − 759 (make-glyph `(,image [string :data ,tag])))
+ − 760 (t
+ − 761 ;; Oh well.
+ − 762 nil)))
+ − 763
+ − 764 (defun widget-glyph-insert (widget tag image &optional down inactive)
+ − 765 "In WIDGET, insert the text TAG or, if supported, IMAGE.
+ − 766 IMAGE should either be a glyph, an image instantiator, an image file
+ − 767 name sans extension (xpm, xbm, gif, jpg, or png) located in
+ − 768 `widget-glyph-directory', or anything else allowed by
+ − 769 `widget-glyph-find'.
+ − 770
+ − 771 If IMAGE is a list, it will be taken as a list of (UP DOWN INACTIVE)
+ − 772 glyphs. The down and inactive glyphs are shown when glyph is pressed
+ − 773 or inactive, respectively.
+ − 774
+ − 775 The optional DOWN and INACTIVE arguments are deprecated, and exist
+ − 776 only because of compatibility."
+ − 777 ;; Convert between IMAGE being a list, etc. Must use `psetq',
+ − 778 ;; because otherwise change to `image' screws up the rest.
+ − 779 (psetq image (or (and (consp image)
+ − 780 (car image))
+ − 781 image)
+ − 782 down (or (and (consp image)
+ − 783 (nth 1 image))
+ − 784 down)
+ − 785 inactive (or (and (consp image)
+ − 786 (nth 2 image))
+ − 787 inactive))
+ − 788 (let ((glyph (widget-glyph-find image tag)))
+ − 789 (if glyph
+ − 790 (widget-glyph-insert-glyph widget glyph
+ − 791 (widget-glyph-find down tag)
+ − 792 (widget-glyph-find inactive tag))
+ − 793 (insert tag))
+ − 794 glyph))
+ − 795
454
+ − 796 (defun widget-glyph-insert-glyph (widget glyph &optional down inactive
+ − 797 instantiator)
428
+ − 798 "In WIDGET, insert GLYPH.
+ − 799 If optional arguments DOWN and INACTIVE are given, they should be
454
+ − 800 glyphs used when the widget is pushed and inactive, respectively.
+ − 801 INSTANTIATOR is the vector used to create the glyph."
428
+ − 802 (insert "*")
+ − 803 (let ((extent (make-extent (point) (1- (point))))
+ − 804 (help-echo (and widget (widget-get widget :help-echo)))
+ − 805 (map (and widget (widget-get widget :button-keymap))))
+ − 806 (set-extent-property extent 'glyph-widget widget)
+ − 807 ;; It would be fun if we could make this extent atomic, so it
+ − 808 ;; doesn't mess with cursor motion. But atomic-extents library is
+ − 809 ;; currently a mess, so I'd rather not use it.
+ − 810 (set-extent-property extent 'invisible t)
+ − 811 (set-extent-property extent 'start-open t)
+ − 812 (set-extent-property extent 'end-open t)
+ − 813 (set-extent-property extent 'keymap map)
+ − 814 ;;(set-extent-property extent 'pointer widget-glyph-pointer-glyph)
+ − 815 (set-extent-end-glyph extent glyph)
+ − 816 (unless (or (stringp help-echo) (null help-echo))
+ − 817 (setq help-echo 'widget-mouse-help))
+ − 818 (when help-echo
+ − 819 (widget-handle-help-echo extent help-echo)))
+ − 820 (when widget
+ − 821 (widget-put widget :glyph-up glyph)
+ − 822 (when down (widget-put widget :glyph-down down))
454
+ − 823 (when instantiator (widget-put widget :glyph-instantiator instantiator))
428
+ − 824 (when inactive (widget-put widget :glyph-inactive inactive))))
+ − 825
+ − 826
+ − 827 ;;; Buttons.
+ − 828
+ − 829 (defgroup widget-button nil
+ − 830 "The look of various kinds of buttons."
+ − 831 :group 'widgets)
+ − 832
+ − 833 (defcustom widget-button-prefix ""
+ − 834 "String used as prefix for buttons."
+ − 835 :type 'string
+ − 836 :group 'widget-button)
+ − 837
+ − 838 (defcustom widget-button-suffix ""
+ − 839 "String used as suffix for buttons."
+ − 840 :type 'string
+ − 841 :group 'widget-button)
+ − 842
+ − 843
+ − 844 ;;; Creating Widgets.
+ − 845
+ − 846 ;;;###autoload
+ − 847 (defun widget-create (type &rest args)
+ − 848 "Create widget of TYPE.
+ − 849 The optional ARGS are additional keyword arguments."
+ − 850 (let ((widget (apply 'widget-convert type args)))
+ − 851 (widget-apply widget :create)
+ − 852 widget))
+ − 853
+ − 854 (defun widget-create-child-and-convert (parent type &rest args)
+ − 855 "As part of the widget PARENT, create a child widget TYPE.
+ − 856 The child is converted, using the keyword arguments ARGS."
+ − 857 (let ((widget (apply 'widget-convert type args)))
+ − 858 (widget-put widget :parent parent)
+ − 859 (unless (widget-get widget :indent)
+ − 860 (widget-put widget :indent (+ (or (widget-get parent :indent) 0)
+ − 861 (or (widget-get widget :extra-offset) 0)
+ − 862 (widget-get parent :offset))))
+ − 863 (widget-apply widget :create)
+ − 864 widget))
+ − 865
+ − 866 (defun widget-create-child (parent type)
+ − 867 "Create widget of TYPE."
+ − 868 (let ((widget (copy-sequence type)))
+ − 869 (widget-put widget :parent parent)
+ − 870 (unless (widget-get widget :indent)
+ − 871 (widget-put widget :indent (+ (or (widget-get parent :indent) 0)
+ − 872 (or (widget-get widget :extra-offset) 0)
+ − 873 (widget-get parent :offset))))
+ − 874 (widget-apply widget :create)
+ − 875 widget))
+ − 876
+ − 877 (defun widget-create-child-value (parent type value)
+ − 878 "Create widget of TYPE with value VALUE."
+ − 879 (let ((widget (copy-sequence type)))
+ − 880 (widget-put widget :value (widget-apply widget :value-to-internal value))
+ − 881 (widget-put widget :parent parent)
+ − 882 (unless (widget-get widget :indent)
+ − 883 (widget-put widget :indent (+ (or (widget-get parent :indent) 0)
+ − 884 (or (widget-get widget :extra-offset) 0)
+ − 885 (widget-get parent :offset))))
+ − 886 (widget-apply widget :create)
+ − 887 widget))
+ − 888
+ − 889 ;;;###autoload
+ − 890 (defun widget-delete (widget)
+ − 891 "Delete WIDGET."
+ − 892 (widget-apply widget :delete))
+ − 893
+ − 894 (defun widget-convert (type &rest args)
+ − 895 "Convert TYPE to a widget without inserting it in the buffer.
+ − 896 The optional ARGS are additional keyword arguments."
+ − 897 ;; Don't touch the type.
+ − 898 (let* ((widget (if (symbolp type)
+ − 899 (list type)
+ − 900 (copy-sequence type)))
+ − 901 (current widget)
+ − 902 (keys args))
+ − 903 ;; First set the :args keyword.
+ − 904 (while (cdr current) ;Look in the type.
+ − 905 (let ((next (car (cdr current))))
+ − 906 (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:))
+ − 907 (setq current (cdr (cdr current)))
+ − 908 (setcdr current (list :args (cdr current)))
+ − 909 (setq current nil))))
+ − 910 (while args ;Look in the args.
+ − 911 (let ((next (nth 0 args)))
+ − 912 (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:))
+ − 913 (setq args (nthcdr 2 args))
+ − 914 (widget-put widget :args args)
+ − 915 (setq args nil))))
+ − 916 ;; Then Convert the widget.
+ − 917 (setq type widget)
+ − 918 (while type
+ − 919 (let ((convert-widget (plist-get (cdr type) :convert-widget)))
+ − 920 (if convert-widget
+ − 921 (setq widget (funcall convert-widget widget))))
+ − 922 (setq type (get (car type) 'widget-type)))
+ − 923 ;; Finally set the keyword args.
+ − 924 (while keys
+ − 925 (let ((next (nth 0 keys)))
+ − 926 (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:))
+ − 927 (progn
+ − 928 (widget-put widget next (nth 1 keys))
+ − 929 (setq keys (nthcdr 2 keys)))
+ − 930 (setq keys nil))))
+ − 931 ;; Convert the :value to internal format.
+ − 932 (if (widget-member widget :value)
+ − 933 (let ((value (widget-get widget :value)))
+ − 934 (widget-put widget
+ − 935 :value (widget-apply widget :value-to-internal value))))
+ − 936 ;; Return the newly created widget.
+ − 937 widget))
+ − 938
+ − 939 (defun widget-insert (&rest args)
+ − 940 "Call `insert' with ARGS and make the text read only."
+ − 941 (let ((inhibit-read-only t)
+ − 942 before-change-functions
+ − 943 after-change-functions)
+ − 944 (apply 'insert args)))
+ − 945
+ − 946 (defun widget-convert-text (type from to
+ − 947 &optional button-from button-to
+ − 948 &rest args)
+ − 949 "Return a widget of type TYPE with endpoint FROM TO.
+ − 950 Optional ARGS are extra keyword arguments for TYPE.
+ − 951 and TO will be used as the widgets end points. If optional arguments
+ − 952 BUTTON-FROM and BUTTON-TO are given, these will be used as the widgets
+ − 953 button end points.
+ − 954 Optional ARGS are extra keyword arguments for TYPE."
+ − 955 (let ((widget (apply 'widget-convert type :delete 'widget-leave-text args))
+ − 956 (from (copy-marker from))
+ − 957 (to (copy-marker to)))
+ − 958 (set-marker-insertion-type from t)
+ − 959 (set-marker-insertion-type to nil)
+ − 960 (widget-put widget :from from)
+ − 961 (widget-put widget :to to)
+ − 962 (when button-from
+ − 963 (widget-specify-button widget button-from button-to))
+ − 964 widget))
+ − 965
+ − 966 (defun widget-convert-button (type from to &rest args)
+ − 967 "Return a widget of type TYPE with endpoint FROM TO.
+ − 968 Optional ARGS are extra keyword arguments for TYPE.
+ − 969 No text will be inserted to the buffer, instead the text between FROM
+ − 970 and TO will be used as the widgets end points, as well as the widgets
+ − 971 button end points."
+ − 972 (apply 'widget-convert-text type from to from to args))
+ − 973
+ − 974 (defun widget-leave-text (widget)
+ − 975 "Remove markers and extents from WIDGET and its children."
+ − 976 (let ((from (widget-get widget :from))
+ − 977 (to (widget-get widget :to))
+ − 978 (button (widget-get widget :button-extent))
+ − 979 (sample (widget-get widget :sample-extent))
+ − 980 (doc (widget-get widget :doc-extent))
+ − 981 (field (widget-get widget :field-extent))
+ − 982 (children (widget-get widget :children)))
+ − 983 (set-marker from nil)
+ − 984 (set-marker to nil)
+ − 985 ;; Maybe we should delete the extents here? As this code doesn't
+ − 986 ;; remove them from widget structures, maybe it's safer to just
+ − 987 ;; detach them. That's what `delete-overlay' did.
+ − 988 (when button
+ − 989 (detach-extent button))
+ − 990 (when sample
+ − 991 (detach-extent sample))
+ − 992 (when doc
+ − 993 (detach-extent doc))
+ − 994 (when field
+ − 995 (detach-extent field))
+ − 996 (mapc 'widget-leave-text children)))
+ − 997
+ − 998
+ − 999 ;;; Keymap and Commands.
+ − 1000
+ − 1001 (defvar widget-keymap nil
+ − 1002 "Keymap containing useful binding for buffers containing widgets.
+ − 1003 Recommended as a parent keymap for modes using widgets.")
+ − 1004
+ − 1005 (unless widget-keymap
+ − 1006 (setq widget-keymap (make-sparse-keymap))
+ − 1007 (define-key widget-keymap [tab] 'widget-forward)
+ − 1008 (define-key widget-keymap [(shift tab)] 'widget-backward)
+ − 1009 (define-key widget-keymap [(meta tab)] 'widget-backward)
+ − 1010 (define-key widget-keymap [backtab] 'widget-backward))
+ − 1011
+ − 1012 (defvar widget-global-map global-map
+ − 1013 "Keymap used for events the widget does not handle themselves.")
+ − 1014 (make-variable-buffer-local 'widget-global-map)
+ − 1015
+ − 1016 (defvar widget-field-keymap nil
+ − 1017 "Keymap used inside an editable field.")
+ − 1018
+ − 1019 (unless widget-field-keymap
+ − 1020 (setq widget-field-keymap (make-sparse-keymap))
+ − 1021 (set-keymap-parents widget-field-keymap global-map)
+ − 1022 (define-key widget-field-keymap "\C-k" 'widget-kill-line)
+ − 1023 (define-key widget-field-keymap [(meta tab)] 'widget-complete)
+ − 1024 (define-key widget-field-keymap [tab] 'widget-forward)
+ − 1025 (define-key widget-field-keymap [(shift tab)] 'widget-backward)
+ − 1026 (define-key widget-field-keymap "\C-m" 'widget-field-activate)
+ − 1027 (define-key widget-field-keymap "\C-a" 'widget-beginning-of-line)
+ − 1028 (define-key widget-field-keymap "\C-e" 'widget-end-of-line)
+ − 1029 (define-key widget-field-keymap "\C-t" 'widget-transpose-chars))
+ − 1030
+ − 1031 (defvar widget-text-keymap nil
+ − 1032 "Keymap used inside a text field.")
+ − 1033
+ − 1034 (unless widget-text-keymap
+ − 1035 (setq widget-text-keymap (make-sparse-keymap))
+ − 1036 (set-keymap-parents widget-field-keymap global-map)
+ − 1037 (define-key widget-text-keymap "\C-a" 'widget-beginning-of-line)
+ − 1038 (define-key widget-text-keymap "\C-e" 'widget-end-of-line)
+ − 1039 (define-key widget-text-keymap "\C-t" 'widget-transpose-chars))
+ − 1040
+ − 1041 (defvar widget-button-keymap nil
+ − 1042 "Keymap used inside a button.")
+ − 1043
+ − 1044 (unless widget-button-keymap
+ − 1045 (setq widget-button-keymap (make-sparse-keymap))
+ − 1046 (set-keymap-parents widget-button-keymap widget-keymap)
+ − 1047 (define-key widget-button-keymap "\C-m" 'widget-button-press)
+ − 1048 (define-key widget-button-keymap [button2] 'widget-button-click)
+ − 1049 ;; Ideally, button3 within a button should invoke a button-specific
+ − 1050 ;; menu.
+ − 1051 (define-key widget-button-keymap [button3] 'widget-button-click)
+ − 1052 ;;Glyph support.
+ − 1053 (define-key widget-button-keymap [button1] 'widget-button1-click))
+ − 1054
+ − 1055
+ − 1056 (defun widget-field-activate (pos &optional event)
+ − 1057 "Invoke the ediable field at point."
+ − 1058 (interactive "@d")
+ − 1059 (let ((field (widget-field-find pos)))
+ − 1060 (if field
+ − 1061 (widget-apply-action field event)
+ − 1062 (call-interactively
+ − 1063 (lookup-key widget-global-map (this-command-keys))))))
+ − 1064
+ − 1065 (defface widget-button-pressed-face
+ − 1066 '((((class color))
+ − 1067 (:foreground "red"))
+ − 1068 (t
+ − 1069 (:bold t :underline t)))
+ − 1070 "Face used for pressed buttons."
+ − 1071 :group 'widget-faces)
+ − 1072
+ − 1073 (defun widget-event-point (event)
+ − 1074 "Character position of the mouse event, or nil."
+ − 1075 (and (mouse-event-p event)
+ − 1076 (event-point event)))
+ − 1077
+ − 1078 (defun widget-button-click (event)
+ − 1079 "Invoke button below mouse pointer."
+ − 1080 (interactive "e")
+ − 1081 (with-current-buffer (event-buffer event)
+ − 1082 (cond ((event-glyph event)
+ − 1083 (widget-glyph-click event))
+ − 1084 ((widget-event-point event)
+ − 1085 (let* ((pos (widget-event-point event))
+ − 1086 (button (get-char-property pos 'button)))
+ − 1087 (if button
+ − 1088 (let* ((extent (widget-get button :button-extent))
+ − 1089 (face (extent-property extent 'face))
+ − 1090 (mouse-face (extent-property extent 'mouse-face))
+ − 1091 (help-echo (extent-property extent 'help-echo)))
+ − 1092 (unwind-protect
+ − 1093 (progn
+ − 1094 ;; Merge relevant faces, and make the result mouse-face.
+ − 1095 (let ((merge `(widget-button-pressed-face ,mouse-face)))
+ − 1096 (nconc merge (if (listp face)
+ − 1097 face (list face)))
+ − 1098 (setq merge (delete-if-not 'find-face merge))
+ − 1099 (set-extent-property extent 'mouse-face merge))
+ − 1100 (unless (widget-apply button :mouse-down-action event)
+ − 1101 ;; Wait for button release.
+ − 1102 (while (not (button-release-event-p
+ − 1103 (setq event (next-event))))
+ − 1104 (dispatch-event event)))
+ − 1105 ;; Disallow mouse-face and help-echo.
+ − 1106 (set-extent-property extent 'mouse-face nil)
+ − 1107 (set-extent-property extent 'help-echo nil)
+ − 1108 (setq pos (widget-event-point event))
+ − 1109 (unless (eq (current-buffer) (extent-object extent))
+ − 1110 ;; Barf if dispatch-event tripped us by
+ − 1111 ;; changing buffer.
+ − 1112 (error "Buffer changed during mouse motion"))
+ − 1113 ;; Do the associated action.
+ − 1114 (when (and pos (extent-in-region-p extent pos pos))
+ − 1115 (widget-apply-action button event)))
+ − 1116 ;; Unwinding: fully release the button.
+ − 1117 (set-extent-property extent 'mouse-face mouse-face)
+ − 1118 (set-extent-property extent 'help-echo help-echo)))
+ − 1119 ;; This should not happen!
+ − 1120 (error "`widget-button-click' called outside button"))))
+ − 1121 (t
+ − 1122 (message "You clicked somewhere weird")))))
+ − 1123
+ − 1124 (defun widget-button1-click (event)
+ − 1125 "Invoke glyph below mouse pointer."
+ − 1126 (interactive "@e")
+ − 1127 (if (event-glyph event)
+ − 1128 (widget-glyph-click event)
+ − 1129 ;; Should somehow avoid this.
+ − 1130 (let ((command (lookup-key widget-global-map (this-command-keys))))
+ − 1131 (and (commandp command)
+ − 1132 (call-interactively command)))))
+ − 1133
+ − 1134 (defun widget-glyph-click (event)
+ − 1135 "Handle click on a glyph."
+ − 1136 (let* ((glyph (event-glyph event))
+ − 1137 (extent (event-glyph-extent event))
+ − 1138 (widget (extent-property extent 'glyph-widget))
+ − 1139 (down-glyph (or (and widget (widget-get widget :glyph-down)) glyph))
+ − 1140 (up-glyph (or (and widget (widget-get widget :glyph-up)) glyph))
+ − 1141 (last event))
+ − 1142 (unless (widget-apply widget :active)
+ − 1143 (error "This widget is inactive"))
+ − 1144 (let ((current-glyph 'down))
+ − 1145 ;; We always know what glyph is drawn currently, to avoid
+ − 1146 ;; unnecessary extent changes. Is this any noticeable gain?
+ − 1147 (unwind-protect
+ − 1148 (progn
+ − 1149 ;; Press the glyph.
+ − 1150 (set-extent-end-glyph extent down-glyph)
+ − 1151 ;; Redisplay (shouldn't be needed, but...)
+ − 1152 (sit-for 0)
+ − 1153 (unless (widget-apply widget :mouse-down-action event)
+ − 1154 ;; Wait for the release.
+ − 1155 (while (not (button-release-event-p last))
+ − 1156 (unless (button-press-event-p last)
+ − 1157 (dispatch-event last))
+ − 1158 (when (motion-event-p last)
+ − 1159 ;; Update glyphs on mouse motion.
+ − 1160 (if (eq extent (event-glyph-extent last))
+ − 1161 (unless (eq current-glyph 'down)
+ − 1162 (set-extent-end-glyph extent down-glyph)
+ − 1163 (setq current-glyph 'down))
+ − 1164 (unless (eq current-glyph 'up)
+ − 1165 (set-extent-end-glyph extent up-glyph)
+ − 1166 (setq current-glyph 'up))))
+ − 1167 (setq last (next-event event))))
+ − 1168 (unless (eq (current-buffer) (extent-object extent))
+ − 1169 ;; Barf if dispatch-event tripped us by changing buffer.
+ − 1170 (error "Buffer changed during mouse motion"))
+ − 1171 ;; Apply widget action.
+ − 1172 (when (eq extent (event-glyph-extent last))
+ − 1173 (let ((widget (extent-property (event-glyph-extent event)
+ − 1174 'glyph-widget)))
+ − 1175 (cond ((null widget)
+ − 1176 (message "You clicked on a glyph"))
+ − 1177 ((not (widget-apply widget :active))
+ − 1178 (error "This glyph is inactive"))
+ − 1179 (t
+ − 1180 (widget-apply-action widget event))))))
+ − 1181 ;; Release the glyph.
+ − 1182 (and (eq current-glyph 'down)
+ − 1183 ;; The extent might have been detached or deleted
+ − 1184 (extent-live-p extent)
+ − 1185 (not (extent-detached-p extent))
+ − 1186 (set-extent-end-glyph extent up-glyph))))))
+ − 1187
+ − 1188 (defun widget-button-press (pos &optional event)
+ − 1189 "Invoke button at POS."
+ − 1190 (interactive "@d")
+ − 1191 (let ((button (get-char-property pos 'button)))
+ − 1192 (if button
+ − 1193 (widget-apply-action button event)
+ − 1194 (let ((command (lookup-key widget-global-map (this-command-keys))))
+ − 1195 (when (commandp command)
+ − 1196 (call-interactively command))))))
+ − 1197
+ − 1198 (defun widget-tabable-at (&optional pos last-tab backwardp)
+ − 1199 "Return the tabable widget at POS, or nil.
+ − 1200 POS defaults to the value of (point)."
+ − 1201 (unless pos
+ − 1202 (setq pos (point)))
+ − 1203 (let ((widget (widget-at pos)))
+ − 1204 (if widget
+ − 1205 (let ((order (widget-get widget :tab-order)))
+ − 1206 (if order
+ − 1207 (if last-tab (and (= order (if backwardp
+ − 1208 (1- last-tab)
+ − 1209 (1+ last-tab)))
+ − 1210 widget)
+ − 1211 (and (> order 0) widget))
+ − 1212 widget))
+ − 1213 nil)))
+ − 1214
+ − 1215 ;; Return the button or field extent at point.
+ − 1216 (defun widget-button-or-field-extent (pos)
+ − 1217 (or (and (get-char-property pos 'button)
+ − 1218 (widget-get (get-char-property pos 'button)
+ − 1219 :button-extent))
+ − 1220 (and (get-char-property pos 'field)
+ − 1221 (widget-get (get-char-property pos 'field)
+ − 1222 :field-extent))))
+ − 1223
+ − 1224 (defun widget-next-button-or-field (pos)
+ − 1225 "Find the next button, or field, and return its start position, or nil.
+ − 1226 Internal function, don't use it outside `wid-edit'."
+ − 1227 (let* ((at-point (widget-button-or-field-extent pos))
+ − 1228 (extent (map-extents
+ − 1229 (lambda (ext ignore)
+ − 1230 ext)
+ − 1231 nil (if at-point (extent-end-position at-point) pos)
+ − 1232 nil nil 'start-open 'button-or-field)))
+ − 1233 (and extent
+ − 1234 (extent-start-position extent))))
+ − 1235
+ − 1236 ;; This is too slow in buffers with many buttons (W3).
+ − 1237 (defun widget-previous-button-or-field (pos)
+ − 1238 "Find the previous button, or field, and return its start position, or nil.
+ − 1239 Internal function, don't use it outside `wid-edit'."
+ − 1240 (let* ((at-point (widget-button-or-field-extent pos))
+ − 1241 previous-extent)
+ − 1242 (map-extents
+ − 1243 (lambda (ext ignore)
+ − 1244 (if (eq ext at-point)
+ − 1245 ;; We reached the extent we were on originally
+ − 1246 (if (= pos (extent-start-position at-point))
+ − 1247 previous-extent
+ − 1248 (setq previous-extent at-point))
+ − 1249 (setq previous-extent ext)
+ − 1250 nil))
+ − 1251 nil nil pos nil 'start-open 'button-or-field)
+ − 1252 (and previous-extent
+ − 1253 (extent-start-position previous-extent))))
+ − 1254
+ − 1255 (defun widget-move (arg)
+ − 1256 "Move point to the ARG next field or button.
+ − 1257 ARG may be negative to move backward."
+ − 1258 (let ((opoint (point)) (wrapped 0)
+ − 1259 (last-tab (widget-get (widget-at (point)) :tab-order))
+ − 1260 nextpos found)
+ − 1261 ;; Movement backward
+ − 1262 (while (< arg 0)
+ − 1263 (setq nextpos (widget-previous-button-or-field (point)))
+ − 1264 (if nextpos
+ − 1265 (progn
+ − 1266 (goto-char nextpos)
+ − 1267 (when (and (not (get-char-property nextpos 'widget-inactive))
+ − 1268 (widget-tabable-at nil last-tab t))
+ − 1269 (incf arg)
+ − 1270 (setq found t
+ − 1271 last-tab (widget-get (widget-at (point))
+ − 1272 :tab-order))))
+ − 1273 (if (and (not found) (> wrapped 1))
+ − 1274 (setq arg 0
+ − 1275 found nil)
+ − 1276 (goto-char (point-max))
+ − 1277 (incf wrapped))))
+ − 1278 ;; Movement forward
+ − 1279 (while (> arg 0)
+ − 1280 (setq nextpos (widget-next-button-or-field (point)))
+ − 1281 (if nextpos
+ − 1282 (progn
+ − 1283 (goto-char nextpos)
+ − 1284 (when (and (not (get-char-property nextpos 'widget-inactive))
+ − 1285 (widget-tabable-at nil last-tab))
+ − 1286 (decf arg)
+ − 1287 (setq found t
+ − 1288 last-tab (widget-get (widget-at (point))
+ − 1289 :tab-order))))
+ − 1290 (if (and (not found) (> wrapped 1))
+ − 1291 (setq arg 0
+ − 1292 found nil)
+ − 1293 (goto-char (point-min))
+ − 1294 (incf wrapped))))
+ − 1295 (if (not found)
+ − 1296 (goto-char opoint)
+ − 1297 (widget-echo-help (point))
+ − 1298 (run-hooks 'widget-move-hook))))
+ − 1299
+ − 1300 (defun widget-forward (arg)
+ − 1301 "Move point to the next field or button.
+ − 1302 With optional ARG, move across that many fields."
+ − 1303 (interactive "p")
+ − 1304 (run-hooks 'widget-forward-hook)
+ − 1305 (widget-move arg))
+ − 1306
+ − 1307 (defun widget-backward (arg)
+ − 1308 "Move point to the previous field or button.
+ − 1309 With optional ARG, move across that many fields."
+ − 1310 (interactive "p")
+ − 1311 (run-hooks 'widget-backward-hook)
+ − 1312 (widget-move (- arg)))
+ − 1313
+ − 1314 (defun widget-beginning-of-line ()
+ − 1315 "Go to beginning of field or beginning of line, whichever is first."
+ − 1316 (interactive "_")
+ − 1317 (let* ((field (widget-field-find (point)))
+ − 1318 (start (and field (widget-field-start field))))
+ − 1319 (if (and start (not (eq start (point))))
+ − 1320 (goto-char start)
+ − 1321 (call-interactively 'beginning-of-line))))
+ − 1322
+ − 1323 (defun widget-end-of-line ()
+ − 1324 "Go to end of field or end of line, whichever is first."
+ − 1325 (interactive "_")
+ − 1326 (let* ((field (widget-field-find (point)))
+ − 1327 (end (and field (widget-field-end field))))
+ − 1328 (if (and end (not (eq end (point))))
+ − 1329 (goto-char end)
+ − 1330 (call-interactively 'end-of-line))))
+ − 1331
+ − 1332 (defun widget-kill-line ()
+ − 1333 "Kill to end of field or end of line, whichever is first."
+ − 1334 (interactive)
+ − 1335 (let* ((field (widget-field-find (point)))
+ − 1336 (newline (save-excursion (forward-line 1) (point)))
+ − 1337 (end (and field (widget-field-end field))))
+ − 1338 (if (and field (> newline end))
+ − 1339 (kill-region (point) end)
+ − 1340 (call-interactively 'kill-line))))
+ − 1341
+ − 1342 (defun widget-transpose-chars (arg)
+ − 1343 "Like `transpose-chars', but works correctly at end of widget."
+ − 1344 (interactive "*P")
+ − 1345 (let* ((field (widget-field-find (point)))
+ − 1346 (start (and field (widget-field-start field)))
+ − 1347 (end (and field (widget-field-end field)))
+ − 1348 (last-non-space (and start end
+ − 1349 (save-excursion
+ − 1350 (goto-char end)
+ − 1351 (skip-chars-backward " \t\n" start)
+ − 1352 (point)))))
+ − 1353 (cond ((and last-non-space
+ − 1354 (or (= last-non-space start)
+ − 1355 (= last-non-space (1+ start))))
+ − 1356 ;; empty or one-character field
+ − 1357 nil)
+ − 1358 ((= (point) start)
+ − 1359 ;; at the beginning of the field -- we would get an error here.
+ − 1360 (error "Cannot transpose at beginning of field"))
+ − 1361 (t
+ − 1362 (when (and (null arg)
+ − 1363 (= last-non-space (point)))
446
+ − 1364 (backward-char 1))
428
+ − 1365 (transpose-chars arg)))))
+ − 1366
+ − 1367 (defcustom widget-complete-field (lookup-key global-map "\M-\t")
+ − 1368 "Default function to call for completion inside fields."
+ − 1369 :options '(ispell-complete-word complete-tag lisp-complete-symbol)
+ − 1370 :type 'function
+ − 1371 :group 'widgets)
+ − 1372
+ − 1373 (defun widget-complete ()
+ − 1374 "Complete content of editable field from point.
+ − 1375 When not inside a field, move to the previous button or field."
+ − 1376 (interactive)
+ − 1377 ;; Somehow, this should make pressing M-TAB twice scroll the
+ − 1378 ;; completions window.
+ − 1379 (let ((field (widget-field-find (point))))
+ − 1380 (if field
+ − 1381 (widget-apply field :complete)
+ − 1382 (error "Not in an editable field"))))
+ − 1383
+ − 1384
+ − 1385 ;;; Setting up the buffer.
+ − 1386
+ − 1387 (defvar widget-field-new nil)
+ − 1388 ;; List of all newly created editable fields in the buffer.
+ − 1389 (make-variable-buffer-local 'widget-field-new)
+ − 1390
+ − 1391 (defvar widget-field-list nil)
+ − 1392 ;; List of all editable fields in the buffer.
+ − 1393 (make-variable-buffer-local 'widget-field-list)
+ − 1394
+ − 1395 (defun widget-setup ()
+ − 1396 "Setup current buffer so editing string widgets works."
+ − 1397 (let ((inhibit-read-only t)
+ − 1398 (after-change-functions nil)
+ − 1399 before-change-functions
+ − 1400 field)
+ − 1401 (while widget-field-new
+ − 1402 (setq field (car widget-field-new)
+ − 1403 widget-field-new (cdr widget-field-new)
+ − 1404 widget-field-list (cons field widget-field-list))
+ − 1405 (let ((from (car (widget-get field :field-extent)))
+ − 1406 (to (cdr (widget-get field :field-extent))))
+ − 1407 (widget-specify-field field
+ − 1408 (marker-position from) (marker-position to))
+ − 1409 (set-marker from nil)
+ − 1410 (set-marker to nil))
+ − 1411 ;; If the field is placed within the inactive zone, deactivate it.
+ − 1412 (let ((extent (widget-get field :field-extent)))
+ − 1413 (when (get-char-property (extent-start-position extent)
+ − 1414 'widget-inactive)
+ − 1415 (widget-activation-widget-mapper extent :deactivate)))))
+ − 1416 (widget-clear-undo)
+ − 1417 (widget-add-change))
+ − 1418
+ − 1419 (defvar widget-field-last nil)
+ − 1420 ;; Last field containing point.
+ − 1421 (make-variable-buffer-local 'widget-field-last)
+ − 1422
+ − 1423 (defvar widget-field-was nil)
+ − 1424 ;; The widget data before the change.
+ − 1425 (make-variable-buffer-local 'widget-field-was)
+ − 1426
+ − 1427 (defun widget-field-buffer (widget)
+ − 1428 "Return the start of WIDGET's editing field."
+ − 1429 (let ((extent (widget-get widget :field-extent)))
+ − 1430 (and extent (extent-object extent))))
+ − 1431
+ − 1432 (defun widget-field-start (widget)
+ − 1433 "Return the start of WIDGET's editing field."
+ − 1434 (let ((extent (widget-get widget :field-extent)))
+ − 1435 (and extent (extent-start-position extent))))
+ − 1436
+ − 1437 (defun widget-field-end (widget)
+ − 1438 "Return the end of WIDGET's editing field."
+ − 1439 (let ((extent (widget-get widget :field-extent)))
+ − 1440 ;; Don't subtract one if local-map works at the end of the extent.
+ − 1441 (and extent (if (or widget-field-add-space
+ − 1442 (null (widget-get widget :size)))
+ − 1443 (1- (extent-end-position extent))
+ − 1444 (extent-end-position extent)))))
+ − 1445
+ − 1446 (defun widget-field-find (pos)
+ − 1447 "Return the field at POS.
+ − 1448 Unlike (get-char-property POS 'field) this, works with empty fields too."
+ − 1449 (let ((field-extent (map-extents (lambda (extent ignore)
+ − 1450 extent)
+ − 1451 nil pos pos nil nil 'field)))
+ − 1452 (and field-extent
+ − 1453 (extent-property field-extent 'field))))
+ − 1454
+ − 1455 ;; Old version, without `map-extents'.
+ − 1456 ;(defun widget-field-find (pos)
+ − 1457 ; (let ((fields widget-field-list)
+ − 1458 ; field found)
+ − 1459 ; (while fields
+ − 1460 ; (setq field (car fields)
+ − 1461 ; fields (cdr fields))
+ − 1462 ; (let ((start (widget-field-start field))
+ − 1463 ; (end (widget-field-end field)))
+ − 1464 ; (when (and (<= start pos) (<= pos end))
+ − 1465 ; (when found
+ − 1466 ; (debug "Overlapping fields"))
+ − 1467 ; (setq found field))))
+ − 1468 ; found))
+ − 1469
+ − 1470 (defun widget-before-change (from to)
+ − 1471 ;; Barf if the text changed is outside the editable fields.
+ − 1472 (unless inhibit-read-only
+ − 1473 (let ((from-field (widget-field-find from))
+ − 1474 (to-field (widget-field-find to)))
+ − 1475 (cond ((or (null from-field)
+ − 1476 (null to-field))
+ − 1477 ;; Either end of change is not within a field.
+ − 1478 (add-hook 'post-command-hook 'widget-add-change nil t)
+ − 1479 (error "Attempt to change text outside editable field"))
+ − 1480 ((not (eq from-field to-field))
+ − 1481 ;; The change begins in one fields, and ends in another one.
+ − 1482 (add-hook 'post-command-hook 'widget-add-change nil t)
+ − 1483 (error "Change should be restricted to a single field"))
+ − 1484 ((or (and from-field
+ − 1485 (get-char-property from 'widget-inactive))
+ − 1486 (and to-field
+ − 1487 (get-char-property to 'widget-inactive)))
+ − 1488 ;; Trying to change an inactive editable field.
+ − 1489 (add-hook 'post-command-hook 'widget-add-change nil t)
+ − 1490 (error "Attempt to change an inactive field"))
+ − 1491 (widget-field-use-before-change
+ − 1492 ;; #### Bletch! This loses because XEmacs get confused
+ − 1493 ;; if before-change-functions change the contents of
+ − 1494 ;; buffer before from/to.
+ − 1495 (condition-case nil
+ − 1496 (widget-apply from-field :notify from-field)
+ − 1497 (error (debug "Before Change"))))))))
+ − 1498
+ − 1499 (defun widget-add-change ()
+ − 1500 (make-local-hook 'post-command-hook)
+ − 1501 (remove-hook 'post-command-hook 'widget-add-change t)
+ − 1502 (make-local-hook 'before-change-functions)
+ − 1503 (add-hook 'before-change-functions 'widget-before-change nil t)
+ − 1504 (make-local-hook 'after-change-functions)
+ − 1505 (add-hook 'after-change-functions 'widget-after-change nil t))
+ − 1506
+ − 1507 (defun widget-after-change (from to old)
+ − 1508 ;; Adjust field size and text properties.
+ − 1509
+ − 1510 ;; Also, notify the widgets (so, for example, a variable changes its
+ − 1511 ;; state to `modified'. when it is being edited.)
+ − 1512 (condition-case nil
+ − 1513 (let ((field (widget-field-find from))
+ − 1514 (other (widget-field-find to)))
+ − 1515 (when field
+ − 1516 (unless (eq field other)
+ − 1517 (debug "Change in different fields"))
+ − 1518 (let ((size (widget-get field :size)))
+ − 1519 (when size
+ − 1520 (let ((begin (widget-field-start field))
+ − 1521 (end (widget-field-end field)))
+ − 1522 (cond ((< (- end begin) size)
+ − 1523 ;; Field too small.
+ − 1524 (save-excursion
+ − 1525 (goto-char end)
+ − 1526 (insert-char ?\ (- (+ begin size) end))))
+ − 1527 ((> (- end begin) size)
+ − 1528 ;; Field too large and
+ − 1529 (if (or (< (point) (+ begin size))
+ − 1530 (> (point) end))
+ − 1531 ;; Point is outside extra space.
+ − 1532 (setq begin (+ begin size))
+ − 1533 ;; Point is within the extra space.
+ − 1534 (setq begin (point)))
+ − 1535 (save-excursion
+ − 1536 (goto-char end)
+ − 1537 (while (and (eq (preceding-char) ?\ )
+ − 1538 (> (point) begin))
+ − 1539 (delete-backward-char 1)))))))
+ − 1540 (widget-specify-secret field))
+ − 1541 (widget-apply field :notify field)))
+ − 1542 (error (debug "After Change"))))
+ − 1543
+ − 1544
+ − 1545 ;;; Widget Functions
+ − 1546 ;;
+ − 1547 ;; These functions are used in the definition of multiple widgets.
+ − 1548
+ − 1549 (defun widget-parent-action (widget &optional event)
+ − 1550 "Tell :parent of WIDGET to handle the :action.
+ − 1551 Optional EVENT is the event that triggered the action."
+ − 1552 (widget-apply (widget-get widget :parent) :action event))
+ − 1553
+ − 1554 (defun widget-children-value-delete (widget)
+ − 1555 "Delete all :children and :buttons in WIDGET."
+ − 1556 (mapc 'widget-delete (widget-get widget :children))
+ − 1557 (widget-put widget :children nil)
+ − 1558 (mapc 'widget-delete (widget-get widget :buttons))
+ − 1559 (widget-put widget :buttons nil))
+ − 1560
+ − 1561 (defun widget-children-validate (widget)
+ − 1562 "All the :children must be valid."
+ − 1563 (let ((children (widget-get widget :children))
+ − 1564 child found)
+ − 1565 (while (and children (not found))
+ − 1566 (setq child (car children)
+ − 1567 children (cdr children)
+ − 1568 found (widget-apply child :validate)))
+ − 1569 found))
+ − 1570
+ − 1571 (defun widget-types-convert-widget (widget)
+ − 1572 "Convert :args as widget types in WIDGET."
+ − 1573 (widget-put widget :args (mapcar 'widget-convert (widget-get widget :args)))
+ − 1574 widget)
+ − 1575
+ − 1576 (defun widget-value-convert-widget (widget)
+ − 1577 "Initialize :value from :args in WIDGET."
+ − 1578 (let ((args (widget-get widget :args)))
+ − 1579 (when args
+ − 1580 (widget-put widget :value (car args))
+ − 1581 ;; Don't convert :value here, as this is done in `widget-convert'.
+ − 1582 ;; (widget-put widget :value (widget-apply widget
+ − 1583 ;; :value-to-internal (car args)))
+ − 1584 (widget-put widget :args nil)))
+ − 1585 widget)
+ − 1586
+ − 1587 (defun widget-value-value-get (widget)
+ − 1588 "Return the :value property of WIDGET."
+ − 1589 (widget-get widget :value))
+ − 1590
+ − 1591 ;;; The `default' Widget.
+ − 1592
+ − 1593 (define-widget 'default nil
+ − 1594 "Basic widget other widgets are derived from."
+ − 1595 :value-to-internal (lambda (widget value) value)
+ − 1596 :value-to-external (lambda (widget value) value)
+ − 1597 :button-prefix 'widget-button-prefix
+ − 1598 :button-suffix 'widget-button-suffix
+ − 1599 :complete 'widget-default-complete
+ − 1600 :create 'widget-default-create
+ − 1601 :indent nil
+ − 1602 :offset 0
+ − 1603 :format-handler 'widget-default-format-handler
+ − 1604 :button-face-get 'widget-default-button-face-get
+ − 1605 :sample-face-get 'widget-default-sample-face-get
+ − 1606 :button-keymap widget-button-keymap
+ − 1607 :delete 'widget-default-delete
+ − 1608 :value-set 'widget-default-value-set
+ − 1609 :value-inline 'widget-default-value-inline
+ − 1610 :default-get 'widget-default-default-get
+ − 1611 :menu-tag-get 'widget-default-menu-tag-get
+ − 1612 :validate (lambda (widget) nil)
+ − 1613 :active 'widget-default-active
+ − 1614 :activate 'widget-specify-active
+ − 1615 :deactivate 'widget-default-deactivate
+ − 1616 :mouse-down-action (lambda (widget event) nil)
+ − 1617 :action 'widget-default-action
+ − 1618 :notify 'widget-default-notify
+ − 1619 :prompt-value 'widget-default-prompt-value)
+ − 1620
+ − 1621 (defun widget-default-complete (widget)
+ − 1622 "Call the value of the :complete-function property of WIDGET.
+ − 1623 If that does not exists, call the value of `widget-complete-field'."
+ − 1624 (let ((fun (widget-get widget :complete-function)))
+ − 1625 (call-interactively (or fun widget-complete-field))))
+ − 1626
+ − 1627 (defun widget-default-create (widget)
+ − 1628 "Create WIDGET at point in the current buffer."
+ − 1629 (widget-specify-insert
+ − 1630 (let ((from (point))
+ − 1631 button-begin button-end button-glyph
+ − 1632 sample-begin sample-end
+ − 1633 doc-begin doc-end
+ − 1634 value-pos)
+ − 1635 (insert (widget-get widget :format))
+ − 1636 (goto-char from)
+ − 1637 ;; Parse escapes in format. Coding this in C would speed up
+ − 1638 ;; things *a lot*.
+ − 1639 (while (re-search-forward "%\\(.\\)" nil t)
+ − 1640 (let ((escape (aref (match-string 1) 0)))
+ − 1641 (replace-match "" t t)
+ − 1642 (cond ((eq escape ?%)
+ − 1643 (insert "%"))
+ − 1644 ((eq escape ?\[)
+ − 1645 (setq button-begin (point-marker))
+ − 1646 (set-marker-insertion-type button-begin nil))
+ − 1647 ((eq escape ?\])
+ − 1648 (setq button-end (point-marker))
+ − 1649 (set-marker-insertion-type button-end nil))
+ − 1650 ((eq escape ?\{)
+ − 1651 (setq sample-begin (point)))
+ − 1652 ((eq escape ?\})
+ − 1653 (setq sample-end (point)))
+ − 1654 ((eq escape ?n)
+ − 1655 (when (widget-get widget :indent)
+ − 1656 (insert "\n")
+ − 1657 (insert-char ?\ (widget-get widget :indent))))
+ − 1658 ((eq escape ?t)
+ − 1659 (let* ((tag (widget-get widget :tag))
+ − 1660 (glyph (widget-get widget :tag-glyph)))
+ − 1661 (cond (glyph
+ − 1662 (setq button-glyph
+ − 1663 (widget-glyph-insert
+ − 1664 widget (or tag "Image") glyph)))
+ − 1665 (tag
+ − 1666 (insert tag))
+ − 1667 (t
+ − 1668 (let ((standard-output (current-buffer)))
+ − 1669 (princ (widget-get widget :value)))))))
+ − 1670 ((eq escape ?d)
+ − 1671 (let ((doc (widget-get widget :doc)))
+ − 1672 (when doc
+ − 1673 (setq doc-begin (point))
+ − 1674 (insert doc)
+ − 1675 (while (eq (preceding-char) ?\n)
+ − 1676 (delete-backward-char 1))
+ − 1677 (insert "\n")
+ − 1678 (setq doc-end (point)))))
+ − 1679 ((eq escape ?v)
+ − 1680 (if (and button-begin (not button-end))
+ − 1681 (widget-apply widget :value-create)
+ − 1682 (setq value-pos (point-marker))))
+ − 1683 (t
+ − 1684 (widget-apply widget :format-handler escape)))))
+ − 1685 ;; Specify button, sample, and doc, and insert value.
+ − 1686 (when (and button-begin button-end)
+ − 1687 (unless button-glyph
+ − 1688 (goto-char button-begin)
+ − 1689 (insert (widget-get-indirect widget :button-prefix))
+ − 1690 (goto-char button-end)
+ − 1691 (set-marker-insertion-type button-end t)
+ − 1692 (insert (widget-get-indirect widget :button-suffix)))
+ − 1693 (widget-specify-button widget button-begin button-end)
+ − 1694 ;; Is this necessary?
+ − 1695 (set-marker button-begin nil)
+ − 1696 (set-marker button-end nil))
+ − 1697 (and sample-begin sample-end
+ − 1698 (widget-specify-sample widget sample-begin sample-end))
+ − 1699 (and doc-begin doc-end
+ − 1700 (widget-specify-doc widget doc-begin doc-end))
+ − 1701 (when value-pos
+ − 1702 (goto-char value-pos)
+ − 1703 (widget-apply widget :value-create)))
+ − 1704 (let ((from (point-min-marker))
+ − 1705 (to (point-max-marker)))
+ − 1706 (set-marker-insertion-type from t)
+ − 1707 (set-marker-insertion-type to nil)
+ − 1708 (widget-put widget :from from)
+ − 1709 (widget-put widget :to to)))
+ − 1710 (widget-clear-undo))
+ − 1711
+ − 1712 (defun widget-default-format-handler (widget escape)
+ − 1713 ;; We recognize the %h escape by default.
+ − 1714 (let* ((buttons (widget-get widget :buttons)))
+ − 1715 (cond ((eq escape ?h)
+ − 1716 (let* ((doc-property (widget-get widget :documentation-property))
+ − 1717 (doc-try (cond ((widget-get widget :doc))
+ − 1718 ((symbolp doc-property)
+ − 1719 (documentation-property
+ − 1720 (widget-get widget :value)
+ − 1721 doc-property))
+ − 1722 (t
+ − 1723 (funcall doc-property
+ − 1724 (widget-get widget :value)))))
+ − 1725 (doc-text (and (stringp doc-try)
+ − 1726 (> (length doc-try) 1)
+ − 1727 doc-try))
+ − 1728 (doc-indent (widget-get widget :documentation-indent)))
+ − 1729 (when doc-text
+ − 1730 (and (eq (preceding-char) ?\n)
+ − 1731 (widget-get widget :indent)
+ − 1732 (insert-char ?\ (widget-get widget :indent)))
+ − 1733 ;; The `*' in the beginning is redundant.
+ − 1734 (when (eq (aref doc-text 0) ?*)
+ − 1735 (setq doc-text (substring doc-text 1)))
+ − 1736 ;; Get rid of trailing newlines.
+ − 1737 (when (string-match "\n+\\'" doc-text)
+ − 1738 (setq doc-text (substring doc-text 0 (match-beginning 0))))
+ − 1739 (push (widget-create-child-and-convert
+ − 1740 widget 'documentation-string
+ − 1741 :indent (cond ((numberp doc-indent)
+ − 1742 doc-indent)
+ − 1743 ((null doc-indent)
+ − 1744 nil)
+ − 1745 (t 0))
+ − 1746 doc-text)
+ − 1747 buttons))))
+ − 1748 (t
+ − 1749 (signal 'error (list "Unknown escape" escape))))
+ − 1750 (widget-put widget :buttons buttons)))
+ − 1751
+ − 1752 (defun widget-default-button-face-get (widget)
+ − 1753 ;; Use :button-face or widget-button-face
+ − 1754 (or (widget-get widget :button-face)
+ − 1755 (let ((parent (widget-get widget :parent)))
+ − 1756 (if parent
+ − 1757 (widget-apply parent :button-face-get)
+ − 1758 widget-button-face))))
+ − 1759
+ − 1760 (defun widget-default-sample-face-get (widget)
+ − 1761 ;; Use :sample-face.
+ − 1762 (widget-get widget :sample-face))
+ − 1763
+ − 1764 (defun widget-default-delete (widget)
+ − 1765 ;; Remove widget from the buffer.
+ − 1766 (let ((from (widget-get widget :from))
+ − 1767 (to (widget-get widget :to))
+ − 1768 (inactive-extent (widget-get widget :inactive))
+ − 1769 (button-extent (widget-get widget :button-extent))
+ − 1770 (sample-extent (widget-get widget :sample-extent))
+ − 1771 (doc-extent (widget-get widget :doc-extent))
+ − 1772 before-change-functions
+ − 1773 after-change-functions
+ − 1774 (inhibit-read-only t))
+ − 1775 (widget-apply widget :value-delete)
+ − 1776 (when inactive-extent
+ − 1777 (detach-extent inactive-extent))
+ − 1778 (when button-extent
+ − 1779 (detach-extent button-extent))
+ − 1780 (when sample-extent
+ − 1781 (detach-extent sample-extent))
+ − 1782 (when doc-extent
+ − 1783 (detach-extent doc-extent))
+ − 1784 (when (< from to)
+ − 1785 ;; Kludge: this doesn't need to be true for empty formats.
+ − 1786 (delete-region from to))
+ − 1787 (set-marker from nil)
+ − 1788 (set-marker to nil))
+ − 1789 (widget-clear-undo))
+ − 1790
+ − 1791 (defun widget-default-value-set (widget value)
+ − 1792 ;; Recreate widget with new value.
+ − 1793 (let* ((old-pos (point))
+ − 1794 (from (copy-marker (widget-get widget :from)))
+ − 1795 (to (copy-marker (widget-get widget :to)))
+ − 1796 (offset (if (and (<= from old-pos) (<= old-pos to))
+ − 1797 (if (>= old-pos (1- to))
+ − 1798 (- old-pos to 1)
+ − 1799 (- old-pos from)))))
+ − 1800 ;;??? Bug: this ought to insert the new value before deleting the old one,
+ − 1801 ;; so that markers on either side of the value automatically
+ − 1802 ;; stay on the same side. -- rms.
+ − 1803 (save-excursion
+ − 1804 (goto-char (widget-get widget :from))
+ − 1805 (widget-apply widget :delete)
+ − 1806 (widget-put widget :value value)
+ − 1807 (widget-apply widget :create))
+ − 1808 (when offset
+ − 1809 (if (< offset 0)
+ − 1810 (goto-char (+ (widget-get widget :to) offset 1))
+ − 1811 (goto-char (min (+ from offset) (1- (widget-get widget :to))))))))
+ − 1812
+ − 1813 (defun widget-default-value-inline (widget)
+ − 1814 ;; Wrap value in a list unless it is inline.
+ − 1815 (if (widget-get widget :inline)
+ − 1816 (widget-value widget)
+ − 1817 (list (widget-value widget))))
+ − 1818
+ − 1819 (defun widget-default-default-get (widget)
+ − 1820 ;; Get `:value'.
+ − 1821 (widget-get widget :value))
+ − 1822
+ − 1823 (defun widget-default-menu-tag-get (widget)
+ − 1824 ;; Use tag or value for menus.
+ − 1825 (or (widget-get widget :menu-tag)
+ − 1826 (widget-get widget :tag)
+ − 1827 (widget-princ-to-string (widget-get widget :value))))
+ − 1828
+ − 1829 (defun widget-default-active (widget)
+ − 1830 "Return t iff this widget active (user modifiable)."
+ − 1831 (and (not (widget-get widget :inactive))
+ − 1832 (let ((parent (widget-get widget :parent)))
+ − 1833 (or (null parent)
+ − 1834 (widget-apply parent :active)))))
+ − 1835
+ − 1836 (defun widget-default-deactivate (widget)
+ − 1837 "Make WIDGET inactive for user modifications."
+ − 1838 (widget-specify-inactive widget
+ − 1839 (widget-get widget :from)
+ − 1840 (widget-get widget :to)))
+ − 1841
+ − 1842 (defun widget-default-action (widget &optional event)
+ − 1843 ;; Notify the parent when a widget change
+ − 1844 (let ((parent (widget-get widget :parent)))
+ − 1845 (when parent
+ − 1846 (widget-apply parent :notify widget event))))
+ − 1847
+ − 1848 (defun widget-default-notify (widget child &optional event)
+ − 1849 ;; Pass notification to parent.
+ − 1850 (widget-default-action widget event))
+ − 1851
+ − 1852 (defun widget-default-prompt-value (widget prompt value unbound)
+ − 1853 ;; Read an arbitrary value. Stolen from `set-variable'.
+ − 1854 ;; (let ((initial (if unbound
+ − 1855 ;; nil
+ − 1856 ;; ;; It would be nice if we could do a `(cons val 1)' here.
+ − 1857 ;; (prin1-to-string (custom-quote value))))))
+ − 1858 (eval-minibuffer prompt ))
+ − 1859
+ − 1860 ;;; The `item' Widget.
+ − 1861
+ − 1862 (define-widget 'item 'default
+ − 1863 "Constant items for inclusion in other widgets."
+ − 1864 :convert-widget 'widget-value-convert-widget
+ − 1865 :value-create 'widget-item-value-create
+ − 1866 :value-delete 'ignore
+ − 1867 :value-get 'widget-value-value-get
+ − 1868 :match 'widget-item-match
+ − 1869 :match-inline 'widget-item-match-inline
+ − 1870 :action 'widget-item-action
+ − 1871 :format "%t\n")
+ − 1872
+ − 1873 (defun widget-item-value-create (widget)
+ − 1874 ;; Insert the printed representation of the value.
+ − 1875 (let ((standard-output (current-buffer)))
+ − 1876 (princ (widget-get widget :value))))
+ − 1877
+ − 1878 (defun widget-item-match (widget value)
+ − 1879 ;; Match if the value is the same.
+ − 1880 (equal (widget-get widget :value) value))
+ − 1881
+ − 1882 (defun widget-item-match-inline (widget values)
+ − 1883 ;; Match if the value is the same.
+ − 1884 (let ((value (widget-get widget :value)))
+ − 1885 (and (listp value)
+ − 1886 (<= (length value) (length values))
+ − 1887 (let ((head (widget-sublist values 0 (length value))))
+ − 1888 (and (equal head value)
+ − 1889 (cons head (widget-sublist values (length value))))))))
+ − 1890
+ − 1891 (defun widget-sublist (list start &optional end)
+ − 1892 "Return the sublist of LIST from START to END.
+ − 1893 If END is omitted, it defaults to the length of LIST."
+ − 1894 (if (> start 0) (setq list (nthcdr start list)))
+ − 1895 (if end
+ − 1896 (if (<= end start)
+ − 1897 nil
+ − 1898 (setq list (copy-sequence list))
+ − 1899 (setcdr (nthcdr (- end start 1) list) nil)
+ − 1900 list)
+ − 1901 (copy-sequence list)))
+ − 1902
+ − 1903 (defun widget-item-action (widget &optional event)
+ − 1904 ;; Just notify itself.
+ − 1905 (widget-apply widget :notify widget event))
+ − 1906
+ − 1907 ;;; The `push-button' Widget.
+ − 1908
+ − 1909 (defcustom widget-push-button-gui widget-glyph-enable
+ − 1910 "If non nil, use GUI push buttons when available."
+ − 1911 :group 'widgets
+ − 1912 :type 'boolean)
+ − 1913
+ − 1914 (defcustom widget-push-button-prefix "["
+ − 1915 "String used as prefix for buttons."
+ − 1916 :type 'string
+ − 1917 :group 'widget-button)
+ − 1918
+ − 1919 (defcustom widget-push-button-suffix "]"
+ − 1920 "String used as suffix for buttons."
+ − 1921 :type 'string
+ − 1922 :group 'widget-button)
+ − 1923
+ − 1924 (define-widget 'push-button 'item
+ − 1925 "A pushable button."
+ − 1926 :button-prefix ""
+ − 1927 :button-suffix ""
+ − 1928 :value-create 'widget-push-button-value-create
+ − 1929 :format "%[%v%]")
+ − 1930
+ − 1931 (defun widget-push-button-value-create (widget)
+ − 1932 ;; Insert text representing the `on' and `off' states.
+ − 1933 (let* ((tag (or (widget-get widget :tag)
+ − 1934 (widget-get widget :value)))
+ − 1935 (tag-glyph (widget-get widget :tag-glyph))
+ − 1936 (text (concat widget-push-button-prefix
+ − 1937 tag widget-push-button-suffix))
454
+ − 1938 gui inst)
428
+ − 1939 (cond (tag-glyph
+ − 1940 (widget-glyph-insert widget text tag-glyph))
+ − 1941 ;; We must check for console-on-window-system-p here,
+ − 1942 ;; because GUI will not work otherwise (it needs RGB
+ − 1943 ;; components for colors, and they are not known on TTYs).
+ − 1944 ((and widget-push-button-gui
+ − 1945 (console-on-window-system-p))
436
+ − 1946 (let* ((gui-button-shadow-thickness 1))
454
+ − 1947 (setq inst (make-gui-button tag 'widget-gui-action widget))
+ − 1948 (setq gui (make-glyph inst)))
+ − 1949 (widget-glyph-insert-glyph widget gui nil nil inst))
428
+ − 1950 (t
+ − 1951 (insert text)))))
+ − 1952
+ − 1953 (defun widget-gui-action (widget)
+ − 1954 "Apply :action for WIDGET."
+ − 1955 (widget-apply-action widget (this-command-keys)))
+ − 1956
+ − 1957 ;;; The `link' Widget.
+ − 1958
+ − 1959 (defcustom widget-link-prefix "["
+ − 1960 "String used as prefix for links."
+ − 1961 :type 'string
+ − 1962 :group 'widget-button)
+ − 1963
+ − 1964 (defcustom widget-link-suffix "]"
+ − 1965 "String used as suffix for links."
+ − 1966 :type 'string
+ − 1967 :group 'widget-button)
+ − 1968
+ − 1969 (define-widget 'link 'item
+ − 1970 "An embedded link."
+ − 1971 :button-prefix 'widget-link-prefix
+ − 1972 :button-suffix 'widget-link-suffix
+ − 1973 :help-echo "Follow the link"
+ − 1974 :format "%[%t%]")
+ − 1975
+ − 1976 ;;; The `info-link' Widget.
+ − 1977
+ − 1978 (define-widget 'info-link 'link
+ − 1979 "A link to an info file."
+ − 1980 :help-echo 'widget-info-link-help-echo
+ − 1981 :action 'widget-info-link-action)
+ − 1982
+ − 1983 (defun widget-info-link-help-echo (widget)
+ − 1984 (concat "Read the manual entry `" (widget-value widget) "'"))
+ − 1985
+ − 1986 (defun widget-info-link-action (widget &optional event)
+ − 1987 "Open the info node specified by WIDGET."
+ − 1988 (Info-goto-node (widget-value widget)))
+ − 1989
+ − 1990 ;;; The `url-link' Widget.
+ − 1991
+ − 1992 (define-widget 'url-link 'link
+ − 1993 "A link to an www page."
+ − 1994 :help-echo 'widget-url-link-help-echo
+ − 1995 :action 'widget-url-link-action)
+ − 1996
+ − 1997 (defun widget-url-link-help-echo (widget)
+ − 1998 (concat "Visit <URL:" (widget-value widget) ">"))
+ − 1999
+ − 2000 (defun widget-url-link-action (widget &optional event)
+ − 2001 "Open the url specified by WIDGET."
442
+ − 2002 (if (fboundp 'browse-url)
+ − 2003 (browse-url (widget-value widget))
428
+ − 2004 (error "Cannot follow URLs in this XEmacs")))
+ − 2005
+ − 2006 ;;; The `function-link' Widget.
+ − 2007
+ − 2008 (define-widget 'function-link 'link
+ − 2009 "A link to an Emacs function."
+ − 2010 :action 'widget-function-link-action)
+ − 2011
+ − 2012 (defun widget-function-link-action (widget &optional event)
+ − 2013 "Show the function specified by WIDGET."
+ − 2014 (describe-function (widget-value widget)))
+ − 2015
+ − 2016 ;;; The `variable-link' Widget.
+ − 2017
+ − 2018 (define-widget 'variable-link 'link
+ − 2019 "A link to an Emacs variable."
+ − 2020 :action 'widget-variable-link-action)
+ − 2021
+ − 2022 (defun widget-variable-link-action (widget &optional event)
+ − 2023 "Show the variable specified by WIDGET."
+ − 2024 (describe-variable (widget-value widget)))
+ − 2025
+ − 2026 ;;; The `file-link' Widget.
+ − 2027
+ − 2028 (define-widget 'file-link 'link
+ − 2029 "A link to a file."
+ − 2030 :action 'widget-file-link-action)
+ − 2031
+ − 2032 (defun widget-file-link-action (widget &optional event)
+ − 2033 "Find the file specified by WIDGET."
+ − 2034 (find-file (widget-value widget)))
+ − 2035
+ − 2036 ;;; The `emacs-library-link' Widget.
+ − 2037
+ − 2038 (define-widget 'emacs-library-link 'link
+ − 2039 "A link to an Emacs Lisp library file."
+ − 2040 :help-echo 'widget-emacs-library-link-help-echo
+ − 2041 :action 'widget-emacs-library-link-action)
+ − 2042
+ − 2043 (defun widget-emacs-library-link-help-echo (widget)
+ − 2044 (concat "Visit " (widget-value widget)))
+ − 2045
+ − 2046 (defun widget-emacs-library-link-action (widget &optional event)
+ − 2047 "Find the Emacs Library file specified by WIDGET."
+ − 2048 (find-file (locate-library (widget-value widget))))
+ − 2049
+ − 2050 ;;; The `emacs-commentary-link' Widget.
+ − 2051
+ − 2052 (define-widget 'emacs-commentary-link 'link
+ − 2053 "A link to Commentary in an Emacs Lisp library file."
+ − 2054 :action 'widget-emacs-commentary-link-action)
+ − 2055
+ − 2056 (defun widget-emacs-commentary-link-action (widget &optional event)
+ − 2057 "Find the Commentary section of the Emacs file specified by WIDGET."
+ − 2058 (finder-commentary (widget-value widget)))
+ − 2059
+ − 2060 ;;; The `editable-field' Widget.
+ − 2061
+ − 2062 (define-widget 'editable-field 'default
+ − 2063 "An editable text field."
+ − 2064 :convert-widget 'widget-value-convert-widget
+ − 2065 :keymap widget-field-keymap
+ − 2066 :format "%v"
+ − 2067 :value ""
+ − 2068 :prompt-internal 'widget-field-prompt-internal
+ − 2069 :prompt-history 'widget-field-history
+ − 2070 :prompt-value 'widget-field-prompt-value
+ − 2071 :action 'widget-field-action
+ − 2072 :validate 'widget-field-validate
+ − 2073 :valid-regexp ""
+ − 2074 :error "No match"
+ − 2075 :value-create 'widget-field-value-create
+ − 2076 :value-delete 'widget-field-value-delete
+ − 2077 :value-get 'widget-field-value-get
+ − 2078 :match 'widget-field-match)
+ − 2079
+ − 2080 (defvar widget-field-history nil
+ − 2081 "History of field minibuffer edits.")
+ − 2082
+ − 2083 (defun widget-field-prompt-internal (widget prompt initial history)
+ − 2084 ;; Read string for WIDGET prompting with PROMPT.
+ − 2085 ;; INITIAL is the initial input and HISTORY is a symbol containing
+ − 2086 ;; the earlier input.
+ − 2087 (read-string prompt initial history))
+ − 2088
+ − 2089 (defun widget-field-prompt-value (widget prompt value unbound)
+ − 2090 ;; Prompt for a string.
+ − 2091 (let ((initial (if unbound
+ − 2092 nil
+ − 2093 (cons (widget-apply widget :value-to-internal
+ − 2094 value) 0)))
+ − 2095 (history (widget-get widget :prompt-history)))
+ − 2096 (let ((answer (widget-apply widget
+ − 2097 :prompt-internal prompt initial history)))
+ − 2098 (widget-apply widget :value-to-external answer))))
+ − 2099
+ − 2100 (defvar widget-edit-functions nil)
+ − 2101
+ − 2102 (defun widget-field-action (widget &optional event)
+ − 2103 ;; Edit the value in the minibuffer.
+ − 2104 (let* ((invalid (widget-apply widget :validate))
+ − 2105 (prompt (concat (widget-apply widget :menu-tag-get) ": "))
+ − 2106 (value (unless invalid
+ − 2107 (widget-value widget)))
+ − 2108 (answer (widget-apply widget :prompt-value prompt value invalid)))
+ − 2109 (unless (equal value answer)
+ − 2110 ;; This is a hack. We can't properly validate the widget
+ − 2111 ;; because validation requires the new value to be in the field.
+ − 2112 ;; However, widget-field-value-create will not function unless
+ − 2113 ;; the new value matches. So, we check whether the thing
+ − 2114 ;; matches, and if it does, use either the real or a dummy error
+ − 2115 ;; message.
+ − 2116 (unless (widget-apply widget :match answer)
+ − 2117 (let ((error-message (or (widget-get widget :type-error)
+ − 2118 "Invalid field contents")))
+ − 2119 (widget-put widget :error error-message)
+ − 2120 (error error-message)))
+ − 2121 (widget-value-set widget answer)
+ − 2122 (widget-apply widget :notify widget event)
+ − 2123 (widget-setup))
+ − 2124 (run-hook-with-args 'widget-edit-functions widget)))
+ − 2125
+ − 2126 ;(defun widget-field-action (widget &optional event)
+ − 2127 ; ;; Move to next field.
+ − 2128 ; (widget-forward 1)
+ − 2129 ; (run-hook-with-args 'widget-edit-functions widget))
+ − 2130
+ − 2131 (defun widget-field-validate (widget)
+ − 2132 ;; Valid if the content matches `:valid-regexp'.
+ − 2133 (save-excursion
+ − 2134 (let ((value (widget-apply widget :value-get))
+ − 2135 (regexp (widget-get widget :valid-regexp)))
+ − 2136 (if (string-match regexp value)
+ − 2137 nil
+ − 2138 widget))))
+ − 2139
+ − 2140 (defun widget-field-value-create (widget)
+ − 2141 ;; Create an editable text field.
+ − 2142 (let ((size (widget-get widget :size))
+ − 2143 (value (widget-get widget :value))
+ − 2144 (from (point))
+ − 2145 ;; This is changed to a real extent in `widget-setup'. We
+ − 2146 ;; need the end points to behave differently until
+ − 2147 ;; `widget-setup' is called. Should probably be replaced with
+ − 2148 ;; a genuine extent, but some things break, then.
+ − 2149 (extent (cons (make-marker) (make-marker))))
+ − 2150 (widget-put widget :field-extent extent)
+ − 2151 (insert value)
+ − 2152 (and size
+ − 2153 (< (length value) size)
+ − 2154 (insert-char ?\ (- size (length value))))
+ − 2155 (unless (memq widget widget-field-list)
+ − 2156 (push widget widget-field-new))
+ − 2157 (move-marker (cdr extent) (point))
+ − 2158 (set-marker-insertion-type (cdr extent) nil)
+ − 2159 (when (null size)
+ − 2160 (insert ?\n))
+ − 2161 (move-marker (car extent) from)
+ − 2162 (set-marker-insertion-type (car extent) t)))
+ − 2163
+ − 2164 (defun widget-field-value-delete (widget)
+ − 2165 ;; Remove the widget from the list of active editing fields.
+ − 2166 (setq widget-field-list (delq widget widget-field-list))
+ − 2167 ;; These are nil if the :format string doesn't contain `%v'.
+ − 2168 (let ((extent (widget-get widget :field-extent)))
+ − 2169 (when extent
+ − 2170 (detach-extent extent))))
+ − 2171
+ − 2172 (defun widget-field-value-get (widget)
+ − 2173 ;; Return current text in editing field.
+ − 2174 (let ((from (widget-field-start widget))
+ − 2175 (to (widget-field-end widget))
+ − 2176 (buffer (widget-field-buffer widget))
+ − 2177 (size (widget-get widget :size))
+ − 2178 (secret (widget-get widget :secret))
+ − 2179 (old (current-buffer)))
+ − 2180 (cond
+ − 2181 ((and from to)
+ − 2182 (set-buffer buffer)
+ − 2183 (while (and size
+ − 2184 (not (zerop size))
+ − 2185 (> to from)
+ − 2186 (eq (char-after (1- to)) ?\ ))
+ − 2187 (setq to (1- to)))
+ − 2188 (let ((result (buffer-substring-no-properties from to)))
+ − 2189 (when secret
+ − 2190 (let ((index 0))
+ − 2191 (while (< (+ from index) to)
+ − 2192 (aset result index
+ − 2193 (get-char-property (+ from index) 'secret))
+ − 2194 (incf index))))
+ − 2195 (set-buffer old)
+ − 2196 result))
+ − 2197 (t
+ − 2198 (widget-get widget :value)))))
+ − 2199
+ − 2200 (defun widget-field-match (widget value)
+ − 2201 ;; Match any string.
+ − 2202 (stringp value))
+ − 2203
+ − 2204 ;;; The `text' Widget.
+ − 2205
+ − 2206 (define-widget 'text 'editable-field
+ − 2207 :keymap widget-text-keymap
+ − 2208 "A multiline text area.")
+ − 2209
+ − 2210 ;;; The `menu-choice' Widget.
+ − 2211
+ − 2212 (define-widget 'menu-choice 'default
+ − 2213 "A menu of options."
+ − 2214 :convert-widget 'widget-types-convert-widget
+ − 2215 :format "%[%t%]: %v"
+ − 2216 :case-fold t
+ − 2217 :tag "choice"
+ − 2218 :void '(item :format "invalid (%t)\n")
+ − 2219 :value-create 'widget-choice-value-create
+ − 2220 :value-delete 'widget-children-value-delete
+ − 2221 :value-get 'widget-choice-value-get
+ − 2222 :value-inline 'widget-choice-value-inline
+ − 2223 :default-get 'widget-choice-default-get
+ − 2224 :mouse-down-action 'widget-choice-mouse-down-action
+ − 2225 :action 'widget-choice-action
+ − 2226 :error "Make a choice"
+ − 2227 :validate 'widget-choice-validate
+ − 2228 :match 'widget-choice-match
+ − 2229 :match-inline 'widget-choice-match-inline)
+ − 2230
+ − 2231 (defun widget-choice-value-create (widget)
+ − 2232 ;; Insert the first choice that matches the value.
+ − 2233 (let ((value (widget-get widget :value))
+ − 2234 (args (widget-get widget :args))
+ − 2235 (explicit (widget-get widget :explicit-choice))
+ − 2236 current)
+ − 2237 (if explicit
+ − 2238 (progn
+ − 2239 (widget-put widget :children (list (widget-create-child-value
+ − 2240 widget explicit value)))
+ − 2241 (widget-put widget :choice explicit))
+ − 2242 (while args
+ − 2243 (setq current (car args)
+ − 2244 args (cdr args))
+ − 2245 (when (widget-apply current :match value)
+ − 2246 (widget-put widget :children (list (widget-create-child-value
+ − 2247 widget current value)))
+ − 2248 (widget-put widget :choice current)
+ − 2249 (setq args nil
+ − 2250 current nil)))
+ − 2251 (when current
+ − 2252 (let ((void (widget-get widget :void)))
+ − 2253 (widget-put widget :children (list (widget-create-child-and-convert
+ − 2254 widget void :value value)))
+ − 2255 (widget-put widget :choice void))))))
+ − 2256
+ − 2257 (defun widget-choice-value-get (widget)
+ − 2258 ;; Get value of the child widget.
+ − 2259 (widget-value (car (widget-get widget :children))))
+ − 2260
+ − 2261 (defun widget-choice-value-inline (widget)
+ − 2262 ;; Get value of the child widget.
+ − 2263 (widget-apply (car (widget-get widget :children)) :value-inline))
+ − 2264
+ − 2265 (defun widget-choice-default-get (widget)
+ − 2266 ;; Get default for the first choice.
+ − 2267 (widget-default-get (car (widget-get widget :args))))
+ − 2268
+ − 2269 (defcustom widget-choice-toggle nil
+ − 2270 "If non-nil, a binary choice will just toggle between the values.
+ − 2271 Otherwise, the user will explicitly have to choose between the values
+ − 2272 when he invoked the menu."
+ − 2273 :type 'boolean
+ − 2274 :group 'widgets)
+ − 2275
+ − 2276 (defun widget-choice-mouse-down-action (widget &optional event)
+ − 2277 ;; Return non-nil if we need a menu.
+ − 2278 (let ((args (widget-get widget :args))
+ − 2279 (old (widget-get widget :choice)))
+ − 2280 (cond ((not (console-on-window-system-p))
+ − 2281 ;; No place to pop up a menu.
+ − 2282 nil)
+ − 2283 ((< (length args) 2)
+ − 2284 ;; Empty or singleton list, just return the value.
+ − 2285 nil)
+ − 2286 ((> (length args) widget-menu-max-size)
+ − 2287 ;; Too long, prompt.
+ − 2288 nil)
+ − 2289 ((> (length args) 2)
+ − 2290 ;; Reasonable sized list, use menu.
+ − 2291 t)
+ − 2292 ((and widget-choice-toggle (memq old args))
+ − 2293 ;; We toggle.
+ − 2294 nil)
+ − 2295 (t
+ − 2296 ;; Ask which of the two.
+ − 2297 t))))
+ − 2298
+ − 2299 (defun widget-choice-action (widget &optional event)
+ − 2300 ;; Make a choice.
+ − 2301 (let ((args (widget-get widget :args))
+ − 2302 (old (widget-get widget :choice))
+ − 2303 (tag (widget-apply widget :menu-tag-get))
+ − 2304 (completion-ignore-case (widget-get widget :case-fold))
+ − 2305 current choices)
+ − 2306 ;; Remember old value.
+ − 2307 (if (and old (not (widget-apply widget :validate)))
+ − 2308 (let* ((external (widget-value widget))
+ − 2309 (internal (widget-apply old :value-to-internal external)))
+ − 2310 (widget-put old :value internal)))
+ − 2311 ;; Find new choice.
+ − 2312 (setq current
+ − 2313 (cond ((= (length args) 0)
+ − 2314 nil)
+ − 2315 ((= (length args) 1)
+ − 2316 (nth 0 args))
+ − 2317 ((and widget-choice-toggle
+ − 2318 (= (length args) 2)
+ − 2319 (memq old args))
+ − 2320 (if (eq old (nth 0 args))
+ − 2321 (nth 1 args)
+ − 2322 (nth 0 args)))
+ − 2323 (t
+ − 2324 (while args
+ − 2325 (setq current (car args)
+ − 2326 args (cdr args))
+ − 2327 (setq choices
+ − 2328 (cons (cons (widget-apply current :menu-tag-get)
+ − 2329 current)
+ − 2330 choices)))
+ − 2331 (let ((choice
+ − 2332 (widget-choose tag (reverse choices) event)))
+ − 2333 (widget-put widget :explicit-choice choice)
+ − 2334 choice))))
+ − 2335 (when current
+ − 2336 (let ((value (widget-default-get current)))
+ − 2337 (widget-value-set widget
+ − 2338 (widget-apply current :value-to-external value)))
+ − 2339 (widget-setup)
+ − 2340 (widget-apply widget :notify widget event)))
+ − 2341 (run-hook-with-args 'widget-edit-functions widget))
+ − 2342
+ − 2343 (defun widget-choice-validate (widget)
+ − 2344 ;; Valid if we have made a valid choice.
+ − 2345 (let ((void (widget-get widget :void))
+ − 2346 (choice (widget-get widget :choice))
+ − 2347 (child (car (widget-get widget :children))))
+ − 2348 (if (eq void choice)
+ − 2349 widget
+ − 2350 (widget-apply child :validate))))
+ − 2351
+ − 2352 (defun widget-choice-match (widget value)
+ − 2353 ;; Matches if one of the choices matches.
+ − 2354 (let ((args (widget-get widget :args))
+ − 2355 current found)
+ − 2356 (while (and args (not found))
+ − 2357 (setq current (car args)
+ − 2358 args (cdr args)
+ − 2359 found (widget-apply current :match value)))
+ − 2360 found))
+ − 2361
+ − 2362 (defun widget-choice-match-inline (widget values)
+ − 2363 ;; Matches if one of the choices matches.
+ − 2364 (let ((args (widget-get widget :args))
+ − 2365 current found)
+ − 2366 (while (and args (null found))
+ − 2367 (setq current (car args)
+ − 2368 args (cdr args)
+ − 2369 found (widget-match-inline current values)))
+ − 2370 found))
+ − 2371
+ − 2372 ;;; The `toggle' Widget.
+ − 2373
+ − 2374 (define-widget 'toggle 'item
+ − 2375 "Toggle between two states."
+ − 2376 :format "%[%v%]\n"
+ − 2377 :value-create 'widget-toggle-value-create
+ − 2378 :action 'widget-toggle-action
+ − 2379 :match (lambda (widget value) t)
+ − 2380 :on "on"
+ − 2381 :off "off")
+ − 2382
+ − 2383 (defun widget-toggle-value-create (widget)
+ − 2384 ;; Insert text representing the `on' and `off' states.
+ − 2385 (if (widget-value widget)
+ − 2386 (widget-glyph-insert widget
+ − 2387 (widget-get widget :on)
+ − 2388 (widget-get widget :on-glyph))
+ − 2389 (widget-glyph-insert widget
+ − 2390 (widget-get widget :off)
+ − 2391 (widget-get widget :off-glyph))))
+ − 2392
+ − 2393 (defun widget-toggle-action (widget &optional event)
+ − 2394 ;; Toggle value.
+ − 2395 (widget-value-set widget (not (widget-value widget)))
+ − 2396 (widget-apply widget :notify widget event)
+ − 2397 (run-hook-with-args 'widget-edit-functions widget))
+ − 2398
+ − 2399 ;;; The `checkbox' Widget.
+ − 2400
+ − 2401 (define-widget 'checkbox 'toggle
+ − 2402 "A checkbox toggle."
+ − 2403 :button-suffix ""
+ − 2404 :button-prefix ""
+ − 2405 :format "%[%v%]"
+ − 2406 :on "[X]"
+ − 2407 :on-glyph "check1"
+ − 2408 :off "[ ]"
+ − 2409 :off-glyph "check0"
+ − 2410 :action 'widget-checkbox-action)
+ − 2411
+ − 2412 (defun widget-checkbox-action (widget &optional event)
+ − 2413 "Toggle checkbox, notify parent, and set active state of sibling."
+ − 2414 (widget-toggle-action widget event)
+ − 2415 (let ((sibling (widget-get-sibling widget)))
+ − 2416 (when sibling
+ − 2417 (if (widget-value widget)
+ − 2418 (widget-apply sibling :activate)
+ − 2419 (widget-apply sibling :deactivate)))))
+ − 2420
+ − 2421 ;;; The `checklist' Widget.
+ − 2422
+ − 2423 (define-widget 'checklist 'default
+ − 2424 "A multiple choice widget."
+ − 2425 :convert-widget 'widget-types-convert-widget
+ − 2426 :format "%v"
+ − 2427 :offset 4
+ − 2428 :entry-format "%b %v"
+ − 2429 :menu-tag "checklist"
+ − 2430 :greedy nil
+ − 2431 :value-create 'widget-checklist-value-create
+ − 2432 :value-delete 'widget-children-value-delete
+ − 2433 :value-get 'widget-checklist-value-get
+ − 2434 :validate 'widget-checklist-validate
+ − 2435 :match 'widget-checklist-match
+ − 2436 :match-inline 'widget-checklist-match-inline)
+ − 2437
+ − 2438 (defun widget-checklist-value-create (widget)
+ − 2439 ;; Insert all values
+ − 2440 (let ((alist (widget-checklist-match-find widget (widget-get widget :value)))
+ − 2441 (args (widget-get widget :args)))
+ − 2442 (while args
+ − 2443 (widget-checklist-add-item widget (car args) (assq (car args) alist))
+ − 2444 (setq args (cdr args)))
+ − 2445 (widget-put widget :children (nreverse (widget-get widget :children)))))
+ − 2446
+ − 2447 (defun widget-checklist-add-item (widget type chosen)
+ − 2448 ;; Create checklist item in WIDGET of type TYPE.
+ − 2449 ;; If the item is checked, CHOSEN is a cons whose cdr is the value.
+ − 2450 (and (eq (preceding-char) ?\n)
+ − 2451 (widget-get widget :indent)
+ − 2452 (insert-char ?\ (widget-get widget :indent)))
+ − 2453 (widget-specify-insert
+ − 2454 (let* ((children (widget-get widget :children))
+ − 2455 (buttons (widget-get widget :buttons))
+ − 2456 (button-args (or (widget-get type :sibling-args)
+ − 2457 (widget-get widget :button-args)))
+ − 2458 (from (point))
+ − 2459 child button)
+ − 2460 (insert (widget-get widget :entry-format))
+ − 2461 (goto-char from)
+ − 2462 ;; Parse % escapes in format.
+ − 2463 (while (re-search-forward "%\\([bv%]\\)" nil t)
+ − 2464 (let ((escape (aref (match-string 1) 0)))
+ − 2465 (replace-match "" t t)
+ − 2466 (cond ((eq escape ?%)
+ − 2467 (insert "%"))
+ − 2468 ((eq escape ?b)
+ − 2469 (setq button (apply 'widget-create-child-and-convert
+ − 2470 widget 'checkbox
+ − 2471 :value (not (null chosen))
+ − 2472 button-args)))
+ − 2473 ((eq escape ?v)
+ − 2474 (setq child
+ − 2475 (cond ((not chosen)
+ − 2476 (let ((child (widget-create-child widget type)))
+ − 2477 (widget-apply child :deactivate)
+ − 2478 child))
+ − 2479 ((widget-get type :inline)
+ − 2480 (widget-create-child-value
+ − 2481 widget type (cdr chosen)))
+ − 2482 (t
+ − 2483 (widget-create-child-value
+ − 2484 widget type (car (cdr chosen)))))))
+ − 2485 (t
+ − 2486 (signal 'error (list "Unknown escape" escape))))))
+ − 2487 ;; Update properties.
+ − 2488 (and button child (widget-put child :button button))
+ − 2489 (and button (widget-put widget :buttons (cons button buttons)))
+ − 2490 (and child (widget-put widget :children (cons child children))))))
+ − 2491
+ − 2492 (defun widget-checklist-match (widget values)
+ − 2493 ;; All values must match a type in the checklist.
+ − 2494 (and (listp values)
+ − 2495 (null (cdr (widget-checklist-match-inline widget values)))))
+ − 2496
+ − 2497 (defun widget-checklist-match-inline (widget values)
+ − 2498 ;; Find the values which match a type in the checklist.
+ − 2499 (let ((greedy (widget-get widget :greedy))
+ − 2500 (args (copy-sequence (widget-get widget :args)))
+ − 2501 found rest)
+ − 2502 (while values
+ − 2503 (let ((answer (widget-checklist-match-up args values)))
+ − 2504 (cond (answer
+ − 2505 (let ((vals (widget-match-inline answer values)))
+ − 2506 (setq found (append found (car vals))
+ − 2507 values (cdr vals)
+ − 2508 args (delq answer args))))
+ − 2509 (greedy
+ − 2510 (setq rest (append rest (list (car values)))
+ − 2511 values (cdr values)))
+ − 2512 (t
+ − 2513 (setq rest (append rest values)
+ − 2514 values nil)))))
+ − 2515 (cons found rest)))
+ − 2516
+ − 2517 (defun widget-checklist-match-find (widget vals)
+ − 2518 ;; Find the vals which match a type in the checklist.
+ − 2519 ;; Return an alist of (TYPE MATCH).
+ − 2520 (let ((greedy (widget-get widget :greedy))
+ − 2521 (args (copy-sequence (widget-get widget :args)))
+ − 2522 found)
+ − 2523 (while vals
+ − 2524 (let ((answer (widget-checklist-match-up args vals)))
+ − 2525 (cond (answer
+ − 2526 (let ((match (widget-match-inline answer vals)))
+ − 2527 (setq found (cons (cons answer (car match)) found)
+ − 2528 vals (cdr match)
+ − 2529 args (delq answer args))))
+ − 2530 (greedy
+ − 2531 (setq vals (cdr vals)))
+ − 2532 (t
+ − 2533 (setq vals nil)))))
+ − 2534 found))
+ − 2535
+ − 2536 (defun widget-checklist-match-up (args vals)
440
+ − 2537 ;; Return the first type from ARGS that matches VALS.
428
+ − 2538 (let (current found)
+ − 2539 (while (and args (null found))
+ − 2540 (setq current (car args)
+ − 2541 args (cdr args)
+ − 2542 found (widget-match-inline current vals)))
+ − 2543 (if found
+ − 2544 current
+ − 2545 nil)))
+ − 2546
+ − 2547 (defun widget-checklist-value-get (widget)
+ − 2548 ;; The values of all selected items.
+ − 2549 (let ((children (widget-get widget :children))
+ − 2550 child result)
+ − 2551 (while children
+ − 2552 (setq child (car children)
+ − 2553 children (cdr children))
+ − 2554 (if (widget-value (widget-get child :button))
+ − 2555 (setq result (append result (widget-apply child :value-inline)))))
+ − 2556 result))
+ − 2557
+ − 2558 (defun widget-checklist-validate (widget)
440
+ − 2559 ;; Ticked children must be valid.
428
+ − 2560 (let ((children (widget-get widget :children))
+ − 2561 child button found)
+ − 2562 (while (and children (not found))
+ − 2563 (setq child (car children)
+ − 2564 children (cdr children)
+ − 2565 button (widget-get child :button)
+ − 2566 found (and (widget-value button)
+ − 2567 (widget-apply child :validate))))
+ − 2568 found))
+ − 2569
+ − 2570 ;;; The `option' Widget
+ − 2571
+ − 2572 (define-widget 'option 'checklist
+ − 2573 "An widget with an optional item."
+ − 2574 :inline t)
+ − 2575
+ − 2576 ;;; The `choice-item' Widget.
+ − 2577
+ − 2578 (define-widget 'choice-item 'item
+ − 2579 "Button items that delegate action events to their parents."
+ − 2580 :action 'widget-parent-action
+ − 2581 :format "%[%t%] \n")
+ − 2582
+ − 2583 ;;; The `radio-button' Widget.
+ − 2584
+ − 2585 (define-widget 'radio-button 'toggle
+ − 2586 "A radio button for use in the `radio' widget."
+ − 2587 :notify 'widget-radio-button-notify
+ − 2588 :format "%[%v%]"
+ − 2589 :button-suffix ""
+ − 2590 :button-prefix ""
+ − 2591 :on "(*)"
+ − 2592 :on-glyph '("radio1" nil "radio0")
+ − 2593 :off "( )"
+ − 2594 :off-glyph "radio0")
+ − 2595
+ − 2596 (defun widget-radio-button-notify (widget child &optional event)
+ − 2597 ;; Tell daddy.
+ − 2598 (widget-apply (widget-get widget :parent) :action widget event))
+ − 2599
+ − 2600 ;;; The `radio-button-choice' Widget.
+ − 2601
+ − 2602 (define-widget 'radio-button-choice 'default
+ − 2603 "Select one of multiple options."
+ − 2604 :convert-widget 'widget-types-convert-widget
+ − 2605 :offset 4
+ − 2606 :format "%v"
+ − 2607 :entry-format "%b %v"
+ − 2608 :menu-tag "radio"
+ − 2609 :value-create 'widget-radio-value-create
+ − 2610 :value-delete 'widget-children-value-delete
+ − 2611 :value-get 'widget-radio-value-get
+ − 2612 :value-inline 'widget-radio-value-inline
+ − 2613 :value-set 'widget-radio-value-set
+ − 2614 :error "You must push one of the buttons"
+ − 2615 :validate 'widget-radio-validate
+ − 2616 :match 'widget-choice-match
+ − 2617 :match-inline 'widget-choice-match-inline
+ − 2618 :action 'widget-radio-action)
+ − 2619
+ − 2620 (defun widget-radio-value-create (widget)
+ − 2621 ;; Insert all values
+ − 2622 (let ((args (widget-get widget :args))
+ − 2623 arg)
+ − 2624 (while args
+ − 2625 (setq arg (car args)
+ − 2626 args (cdr args))
+ − 2627 (widget-radio-add-item widget arg))))
+ − 2628
+ − 2629 (defun widget-radio-add-item (widget type)
+ − 2630 "Add to radio widget WIDGET a new radio button item of type TYPE."
+ − 2631 ;; (setq type (widget-convert type))
+ − 2632 (and (eq (preceding-char) ?\n)
+ − 2633 (widget-get widget :indent)
+ − 2634 (insert-char ?\ (widget-get widget :indent)))
+ − 2635 (widget-specify-insert
+ − 2636 (let* ((value (widget-get widget :value))
+ − 2637 (children (widget-get widget :children))
+ − 2638 (buttons (widget-get widget :buttons))
+ − 2639 (button-args (or (widget-get type :sibling-args)
+ − 2640 (widget-get widget :button-args)))
+ − 2641 (from (point))
+ − 2642 (chosen (and (null (widget-get widget :choice))
+ − 2643 (widget-apply type :match value)))
+ − 2644 child button)
+ − 2645 (insert (widget-get widget :entry-format))
+ − 2646 (goto-char from)
+ − 2647 ;; Parse % escapes in format.
+ − 2648 (while (re-search-forward "%\\([bv%]\\)" nil t)
+ − 2649 (let ((escape (aref (match-string 1) 0)))
+ − 2650 (replace-match "" t t)
+ − 2651 (cond ((eq escape ?%)
+ − 2652 (insert "%"))
+ − 2653 ((eq escape ?b)
+ − 2654 (setq button (apply 'widget-create-child-and-convert
+ − 2655 widget 'radio-button
+ − 2656 :value (not (null chosen))
+ − 2657 button-args)))
+ − 2658 ((eq escape ?v)
+ − 2659 (setq child (if chosen
+ − 2660 (widget-create-child-value
+ − 2661 widget type value)
+ − 2662 (widget-create-child widget type)))
+ − 2663 (unless chosen
+ − 2664 (widget-apply child :deactivate)))
+ − 2665 (t
+ − 2666 (signal 'error (list "Unknown escape" escape))))))
+ − 2667 ;; Update properties.
+ − 2668 (when chosen
+ − 2669 (widget-put widget :choice type))
+ − 2670 (when button
+ − 2671 (widget-put child :button button)
+ − 2672 (widget-put widget :buttons (nconc buttons (list button))))
+ − 2673 (when child
+ − 2674 (widget-put widget :children (nconc children (list child))))
+ − 2675 child)))
+ − 2676
+ − 2677 (defun widget-radio-value-get (widget)
+ − 2678 ;; Get value of the child widget.
+ − 2679 (let ((chosen (widget-radio-chosen widget)))
+ − 2680 (and chosen (widget-value chosen))))
+ − 2681
+ − 2682 (defun widget-radio-chosen (widget)
+ − 2683 "Return the widget representing the chosen radio button."
+ − 2684 (let ((children (widget-get widget :children))
+ − 2685 current found)
+ − 2686 (while children
+ − 2687 (setq current (car children)
+ − 2688 children (cdr children))
+ − 2689 (let* ((button (widget-get current :button))
+ − 2690 (value (widget-apply button :value-get)))
+ − 2691 (when value
+ − 2692 (setq found current
+ − 2693 children nil))))
+ − 2694 found))
+ − 2695
+ − 2696 (defun widget-radio-value-inline (widget)
+ − 2697 ;; Get value of the child widget.
+ − 2698 (let ((children (widget-get widget :children))
+ − 2699 current found)
+ − 2700 (while children
+ − 2701 (setq current (car children)
+ − 2702 children (cdr children))
+ − 2703 (let* ((button (widget-get current :button))
+ − 2704 (value (widget-apply button :value-get)))
+ − 2705 (when value
+ − 2706 (setq found (widget-apply current :value-inline)
+ − 2707 children nil))))
+ − 2708 found))
+ − 2709
+ − 2710 (defun widget-radio-value-set (widget value)
+ − 2711 ;; We can't just delete and recreate a radio widget, since children
+ − 2712 ;; can be added after the original creation and won't be recreated
+ − 2713 ;; by `:create'.
+ − 2714 (let ((children (widget-get widget :children))
+ − 2715 current found)
+ − 2716 (while children
+ − 2717 (setq current (car children)
+ − 2718 children (cdr children))
+ − 2719 (let* ((button (widget-get current :button))
+ − 2720 (match (and (not found)
+ − 2721 (widget-apply current :match value))))
+ − 2722 (widget-value-set button match)
+ − 2723 (if match
+ − 2724 (progn
+ − 2725 (widget-value-set current value)
+ − 2726 (widget-apply current :activate))
+ − 2727 (widget-apply current :deactivate))
+ − 2728 (setq found (or found match))))))
+ − 2729
+ − 2730 (defun widget-radio-validate (widget)
+ − 2731 ;; Valid if we have made a valid choice.
+ − 2732 (let ((children (widget-get widget :children))
+ − 2733 current found button)
+ − 2734 (while (and children (not found))
+ − 2735 (setq current (car children)
+ − 2736 children (cdr children)
+ − 2737 button (widget-get current :button)
+ − 2738 found (widget-apply button :value-get)))
+ − 2739 (if found
+ − 2740 (widget-apply current :validate)
+ − 2741 widget)))
+ − 2742
+ − 2743 (defun widget-radio-action (widget child event)
+ − 2744 ;; Check if a radio button was pressed.
+ − 2745 (let ((children (widget-get widget :children))
+ − 2746 (buttons (widget-get widget :buttons))
+ − 2747 current)
+ − 2748 (when (memq child buttons)
+ − 2749 (while children
+ − 2750 (setq current (car children)
+ − 2751 children (cdr children))
+ − 2752 (let* ((button (widget-get current :button)))
+ − 2753 (cond ((eq child button)
+ − 2754 (widget-value-set button t)
+ − 2755 (widget-apply current :activate))
+ − 2756 ((widget-value button)
+ − 2757 (widget-value-set button nil)
+ − 2758 (widget-apply current :deactivate)))))))
+ − 2759 ;; Pass notification to parent.
+ − 2760 (widget-apply widget :notify child event))
+ − 2761
+ − 2762 ;;; The `insert-button' Widget.
+ − 2763
+ − 2764 (define-widget 'insert-button 'push-button
+ − 2765 "An insert button for the `editable-list' widget."
+ − 2766 :tag "INS"
+ − 2767 :help-echo "Insert a new item into the list at this position"
+ − 2768 :action 'widget-insert-button-action)
+ − 2769
+ − 2770 (defun widget-insert-button-action (widget &optional event)
+ − 2771 ;; Ask the parent to insert a new item.
+ − 2772 (widget-apply (widget-get widget :parent)
+ − 2773 :insert-before (widget-get widget :widget)))
+ − 2774
+ − 2775 ;;; The `delete-button' Widget.
+ − 2776
+ − 2777 (define-widget 'delete-button 'push-button
+ − 2778 "A delete button for the `editable-list' widget."
+ − 2779 :tag "DEL"
+ − 2780 :help-echo "Delete this item from the list"
+ − 2781 :action 'widget-delete-button-action)
+ − 2782
+ − 2783 (defun widget-delete-button-action (widget &optional event)
+ − 2784 ;; Ask the parent to insert a new item.
+ − 2785 (widget-apply (widget-get widget :parent)
+ − 2786 :delete-at (widget-get widget :widget)))
+ − 2787
+ − 2788 ;;; The `editable-list' Widget.
+ − 2789
+ − 2790 (defcustom widget-editable-list-gui nil
+ − 2791 "If non nil, use GUI push-buttons in editable list when available."
+ − 2792 :type 'boolean
+ − 2793 :group 'widgets)
+ − 2794
+ − 2795 (define-widget 'editable-list 'default
+ − 2796 "A variable list of widgets of the same type."
+ − 2797 :convert-widget 'widget-types-convert-widget
+ − 2798 :offset 12
+ − 2799 :format "%v%i\n"
+ − 2800 :format-handler 'widget-editable-list-format-handler
+ − 2801 :entry-format "%i %d %v"
+ − 2802 :menu-tag "editable-list"
+ − 2803 :value-create 'widget-editable-list-value-create
+ − 2804 :value-delete 'widget-children-value-delete
+ − 2805 :value-get 'widget-editable-list-value-get
+ − 2806 :validate 'widget-children-validate
+ − 2807 :match 'widget-editable-list-match
+ − 2808 :match-inline 'widget-editable-list-match-inline
+ − 2809 :insert-before 'widget-editable-list-insert-before
+ − 2810 :delete-at 'widget-editable-list-delete-at)
+ − 2811
+ − 2812 (defun widget-editable-list-format-handler (widget escape)
+ − 2813 ;; We recognize the insert button.
+ − 2814 (let ((widget-push-button-gui widget-editable-list-gui))
+ − 2815 (cond ((eq escape ?i)
+ − 2816 (and (widget-get widget :indent)
+ − 2817 (insert-char ?\ (widget-get widget :indent)))
+ − 2818 (apply 'widget-create-child-and-convert
+ − 2819 widget 'insert-button
+ − 2820 (widget-get widget :append-button-args)))
+ − 2821 (t
+ − 2822 (widget-default-format-handler widget escape)))))
+ − 2823
+ − 2824 (defun widget-editable-list-value-create (widget)
+ − 2825 ;; Insert all values
+ − 2826 (let* ((value (widget-get widget :value))
+ − 2827 (type (nth 0 (widget-get widget :args)))
+ − 2828 (inlinep (widget-get type :inline))
+ − 2829 children)
+ − 2830 (widget-put widget :value-pos (copy-marker (point)))
+ − 2831 (set-marker-insertion-type (widget-get widget :value-pos) t)
+ − 2832 (while value
+ − 2833 (let ((answer (widget-match-inline type value)))
+ − 2834 (if answer
+ − 2835 (setq children (cons (widget-editable-list-entry-create
+ − 2836 widget
+ − 2837 (if inlinep
+ − 2838 (car answer)
+ − 2839 (car (car answer)))
+ − 2840 t)
+ − 2841 children)
+ − 2842 value (cdr answer))
+ − 2843 (setq value nil))))
+ − 2844 (widget-put widget :children (nreverse children))))
+ − 2845
+ − 2846 (defun widget-editable-list-value-get (widget)
+ − 2847 ;; Get value of the child widget.
+ − 2848 (apply 'append (mapcar (lambda (child) (widget-apply child :value-inline))
+ − 2849 (widget-get widget :children))))
+ − 2850
+ − 2851 (defun widget-editable-list-match (widget value)
+ − 2852 ;; Value must be a list and all the members must match the type.
+ − 2853 (and (listp value)
+ − 2854 (null (cdr (widget-editable-list-match-inline widget value)))))
+ − 2855
+ − 2856 (defun widget-editable-list-match-inline (widget value)
+ − 2857 (let ((type (nth 0 (widget-get widget :args)))
+ − 2858 (ok t)
+ − 2859 found)
+ − 2860 (while (and value ok)
+ − 2861 (let ((answer (widget-match-inline type value)))
+ − 2862 (if answer
+ − 2863 (setq found (append found (car answer))
+ − 2864 value (cdr answer))
+ − 2865 (setq ok nil))))
+ − 2866 (cons found value)))
+ − 2867
+ − 2868 (defun widget-editable-list-insert-before (widget before)
+ − 2869 ;; Insert a new child in the list of children.
+ − 2870 (save-excursion
+ − 2871 (let ((children (widget-get widget :children))
+ − 2872 (inhibit-read-only t)
+ − 2873 before-change-functions
+ − 2874 after-change-functions)
+ − 2875 (cond (before
+ − 2876 (goto-char (widget-get before :entry-from)))
+ − 2877 (t
+ − 2878 (goto-char (widget-get widget :value-pos))))
+ − 2879 (let ((child (widget-editable-list-entry-create
+ − 2880 widget nil nil)))
+ − 2881 (when (< (widget-get child :entry-from) (widget-get widget :from))
+ − 2882 (set-marker (widget-get widget :from)
+ − 2883 (widget-get child :entry-from)))
+ − 2884 (if (eq (car children) before)
+ − 2885 (widget-put widget :children (cons child children))
+ − 2886 (while (not (eq (car (cdr children)) before))
+ − 2887 (setq children (cdr children)))
+ − 2888 (setcdr children (cons child (cdr children)))))))
+ − 2889 (widget-setup)
+ − 2890 (widget-apply widget :notify widget))
+ − 2891
+ − 2892 (defun widget-editable-list-delete-at (widget child)
+ − 2893 ;; Delete child from list of children.
+ − 2894 (save-excursion
+ − 2895 (let ((buttons (copy-sequence (widget-get widget :buttons)))
+ − 2896 button
+ − 2897 (inhibit-read-only t)
+ − 2898 before-change-functions
+ − 2899 after-change-functions)
+ − 2900 (while buttons
+ − 2901 (setq button (car buttons)
+ − 2902 buttons (cdr buttons))
+ − 2903 (when (eq (widget-get button :widget) child)
+ − 2904 (widget-put widget
+ − 2905 :buttons (delq button (widget-get widget :buttons)))
+ − 2906 (widget-delete button))))
+ − 2907 (let ((entry-from (widget-get child :entry-from))
+ − 2908 (entry-to (widget-get child :entry-to))
+ − 2909 (inhibit-read-only t)
+ − 2910 before-change-functions
+ − 2911 after-change-functions)
+ − 2912 (widget-delete child)
+ − 2913 (delete-region entry-from entry-to)
+ − 2914 (set-marker entry-from nil)
+ − 2915 (set-marker entry-to nil))
+ − 2916 (widget-put widget :children (delq child (widget-get widget :children))))
+ − 2917 (widget-setup)
+ − 2918 (widget-apply widget :notify widget))
+ − 2919
+ − 2920 (defun widget-editable-list-entry-create (widget value conv)
+ − 2921 ;; Create a new entry to the list.
+ − 2922 (let ((type (nth 0 (widget-get widget :args)))
+ − 2923 (widget-push-button-gui widget-editable-list-gui)
+ − 2924 child delete insert)
+ − 2925 (widget-specify-insert
+ − 2926 (save-excursion
+ − 2927 (and (widget-get widget :indent)
+ − 2928 (insert-char ?\ (widget-get widget :indent)))
+ − 2929 (insert (widget-get widget :entry-format)))
+ − 2930 ;; Parse % escapes in format.
+ − 2931 (while (re-search-forward "%\\(.\\)" nil t)
+ − 2932 (let ((escape (aref (match-string 1) 0)))
+ − 2933 (replace-match "" t t)
+ − 2934 (cond ((eq escape ?%)
+ − 2935 (insert "%"))
+ − 2936 ((eq escape ?i)
+ − 2937 (setq insert (apply 'widget-create-child-and-convert
+ − 2938 widget 'insert-button
+ − 2939 (widget-get widget :insert-button-args))))
+ − 2940 ((eq escape ?d)
+ − 2941 (setq delete (apply 'widget-create-child-and-convert
+ − 2942 widget 'delete-button
+ − 2943 (widget-get widget :delete-button-args))))
+ − 2944 ((eq escape ?v)
+ − 2945 (if conv
+ − 2946 (setq child (widget-create-child-value
+ − 2947 widget type value))
+ − 2948 (setq child (widget-create-child-value
+ − 2949 widget type (widget-default-get type)))))
+ − 2950 (t
+ − 2951 (signal 'error (list "Unknown escape" escape))))))
+ − 2952 (widget-put widget
+ − 2953 :buttons (cons delete
+ − 2954 (cons insert
+ − 2955 (widget-get widget :buttons))))
+ − 2956 (let ((entry-from (copy-marker (point-min)))
+ − 2957 (entry-to (copy-marker (point-max))))
+ − 2958 (set-marker-insertion-type entry-from t)
+ − 2959 (set-marker-insertion-type entry-to nil)
+ − 2960 (widget-put child :entry-from entry-from)
+ − 2961 (widget-put child :entry-to entry-to)))
+ − 2962 (widget-put insert :widget child)
+ − 2963 (widget-put delete :widget child)
+ − 2964 child))
+ − 2965
+ − 2966 ;;; The `group' Widget.
+ − 2967
+ − 2968 (define-widget 'group 'default
+ − 2969 "A widget which group other widgets inside."
+ − 2970 :convert-widget 'widget-types-convert-widget
+ − 2971 :format "%v"
+ − 2972 :value-create 'widget-group-value-create
+ − 2973 :value-delete 'widget-children-value-delete
+ − 2974 :value-get 'widget-editable-list-value-get
+ − 2975 :default-get 'widget-group-default-get
+ − 2976 :validate 'widget-children-validate
+ − 2977 :match 'widget-group-match
+ − 2978 :match-inline 'widget-group-match-inline)
+ − 2979
+ − 2980 (defun widget-group-value-create (widget)
+ − 2981 ;; Create each component.
+ − 2982 (let ((args (widget-get widget :args))
+ − 2983 (value (widget-get widget :value))
+ − 2984 arg answer children)
+ − 2985 (while args
+ − 2986 (setq arg (car args)
+ − 2987 args (cdr args)
+ − 2988 answer (widget-match-inline arg value)
+ − 2989 value (cdr answer))
+ − 2990 (and (eq (preceding-char) ?\n)
+ − 2991 (widget-get widget :indent)
+ − 2992 (insert-char ?\ (widget-get widget :indent)))
+ − 2993 (push (cond ((null answer)
+ − 2994 (widget-create-child widget arg))
+ − 2995 ((widget-get arg :inline)
+ − 2996 (widget-create-child-value widget arg (car answer)))
+ − 2997 (t
+ − 2998 (widget-create-child-value widget arg (car (car answer)))))
+ − 2999 children))
+ − 3000 (widget-put widget :children (nreverse children))))
+ − 3001
+ − 3002 (defun widget-group-default-get (widget)
+ − 3003 ;; Get the default of the components.
+ − 3004 (mapcar 'widget-default-get (widget-get widget :args)))
+ − 3005
+ − 3006 (defun widget-group-match (widget values)
+ − 3007 ;; Match if the components match.
+ − 3008 (and (listp values)
+ − 3009 (let ((match (widget-group-match-inline widget values)))
+ − 3010 (and match (null (cdr match))))))
+ − 3011
+ − 3012 (defun widget-group-match-inline (widget vals)
+ − 3013 ;; Match if the components match.
+ − 3014 (let ((args (widget-get widget :args))
+ − 3015 argument answer found)
+ − 3016 (while args
+ − 3017 (setq argument (car args)
+ − 3018 args (cdr args)
+ − 3019 answer (widget-match-inline argument vals))
+ − 3020 (if answer
+ − 3021 (setq vals (cdr answer)
+ − 3022 found (append found (car answer)))
+ − 3023 (setq vals nil
+ − 3024 args nil)))
+ − 3025 (if answer
+ − 3026 (cons found vals)
+ − 3027 nil)))
+ − 3028
+ − 3029 ;;; The `visibility' Widget.
+ − 3030
+ − 3031 (define-widget 'visibility 'item
+ − 3032 "An indicator and manipulator for hidden items."
+ − 3033 :format "%[%v%]"
+ − 3034 :button-prefix ""
+ − 3035 :button-suffix ""
+ − 3036 :on "Hide"
+ − 3037 :off "Show"
+ − 3038 :value-create 'widget-visibility-value-create
+ − 3039 :action 'widget-toggle-action
+ − 3040 :match (lambda (widget value) t))
+ − 3041
+ − 3042 (defun widget-visibility-value-create (widget)
+ − 3043 ;; Insert text representing the `on' and `off' states.
+ − 3044 (let ((on (widget-get widget :on))
+ − 3045 (off (widget-get widget :off)))
+ − 3046 (if on
+ − 3047 (setq on (concat widget-push-button-prefix
+ − 3048 on
+ − 3049 widget-push-button-suffix))
+ − 3050 (setq on ""))
+ − 3051 (if off
+ − 3052 (setq off (concat widget-push-button-prefix
+ − 3053 off
+ − 3054 widget-push-button-suffix))
+ − 3055 (setq off ""))
+ − 3056 (if (widget-value widget)
+ − 3057 (widget-glyph-insert widget on '("down" "down-pushed"))
+ − 3058 (widget-glyph-insert widget off '("right" "right-pushed")))))
+ − 3059
+ − 3060 ;;; The `documentation-link' Widget.
+ − 3061 ;;
+ − 3062 ;; This is a helper widget for `documentation-string'.
+ − 3063
+ − 3064 (define-widget 'documentation-link 'link
+ − 3065 "Link type used in documentation strings."
+ − 3066 :tab-order -1
+ − 3067 :help-echo 'widget-documentation-link-echo-help
+ − 3068 :action 'widget-documentation-link-action)
+ − 3069
+ − 3070 (defun widget-documentation-link-echo-help (widget)
+ − 3071 "Tell what this link will describe."
+ − 3072 (concat "Describe the `" (widget-get widget :value) "' symbol."))
+ − 3073
+ − 3074 (defun widget-documentation-link-action (widget &optional event)
+ − 3075 "Display documentation for WIDGET's value. Ignore optional argument EVENT."
+ − 3076 (let* ((string (widget-get widget :value))
+ − 3077 (symbol (intern string)))
+ − 3078 (if (and (fboundp symbol) (boundp symbol))
+ − 3079 ;; If there are two doc strings, give the user a way to pick one.
+ − 3080 (apropos (concat "\\`" (regexp-quote string) "\\'"))
+ − 3081 (if (fboundp symbol)
+ − 3082 (describe-function symbol)
+ − 3083 (describe-variable symbol)))))
+ − 3084
+ − 3085 (defcustom widget-documentation-links t
+ − 3086 "Add hyperlinks to documentation strings when non-nil."
+ − 3087 :type 'boolean
+ − 3088 :group 'widget-documentation)
+ − 3089
+ − 3090 (defcustom widget-documentation-link-regexp "`\\([^\n`' ]+\\)'"
+ − 3091 "Regexp for matching potential links in documentation strings.
+ − 3092 The first group should be the link itself."
+ − 3093 :type 'regexp
+ − 3094 :group 'widget-documentation)
+ − 3095
+ − 3096 (defcustom widget-documentation-link-p 'intern-soft
+ − 3097 "Predicate used to test if a string is useful as a link.
+ − 3098 The value should be a function. The function will be called one
+ − 3099 argument, a string, and should return non-nil if there should be a
+ − 3100 link for that string."
+ − 3101 :type 'function
+ − 3102 :options '(widget-documentation-link-p)
+ − 3103 :group 'widget-documentation)
+ − 3104
+ − 3105 (defcustom widget-documentation-link-type 'documentation-link
+ − 3106 "Widget type used for links in documentation strings."
+ − 3107 :type 'symbol
+ − 3108 :group 'widget-documentation)
+ − 3109
+ − 3110 (defun widget-documentation-link-add (widget from to)
+ − 3111 (widget-specify-doc widget from to)
+ − 3112 (when widget-documentation-links
+ − 3113 (let ((regexp widget-documentation-link-regexp)
+ − 3114 (predicate widget-documentation-link-p)
+ − 3115 (type widget-documentation-link-type)
+ − 3116 (buttons (widget-get widget :buttons)))
+ − 3117 (save-excursion
+ − 3118 (goto-char from)
+ − 3119 (while (re-search-forward regexp to t)
+ − 3120 (let ((name (match-string 1))
+ − 3121 (begin (match-beginning 1))
+ − 3122 (end (match-end 1)))
+ − 3123 (when (funcall predicate name)
+ − 3124 (push (widget-convert-button type begin end :value name)
+ − 3125 buttons)))))
+ − 3126 (widget-put widget :buttons buttons)))
+ − 3127 (let ((indent (widget-get widget :indent)))
+ − 3128 (when (and indent (not (zerop indent)))
+ − 3129 (save-excursion
+ − 3130 (save-restriction
+ − 3131 (narrow-to-region from to)
+ − 3132 (goto-char (point-min))
+ − 3133 (while (search-forward "\n" nil t)
+ − 3134 (insert-char ?\ indent)))))))
+ − 3135
+ − 3136 ;;; The `documentation-string' Widget.
+ − 3137
+ − 3138 (define-widget 'documentation-string 'item
+ − 3139 "A documentation string."
+ − 3140 :format "%v"
+ − 3141 :action 'widget-documentation-string-action
+ − 3142 :value-delete 'widget-children-value-delete
+ − 3143 :value-create 'widget-documentation-string-value-create)
+ − 3144
+ − 3145 (defun widget-documentation-string-value-create (widget)
+ − 3146 ;; Insert documentation string.
+ − 3147 (let ((doc (widget-value widget))
+ − 3148 (indent (widget-get widget :indent))
+ − 3149 (shown (widget-get (widget-get widget :parent) :documentation-shown))
+ − 3150 (start (point)))
+ − 3151 (if (string-match "\n" doc)
+ − 3152 (let ((before (substring doc 0 (match-beginning 0)))
+ − 3153 (after (substring doc (match-beginning 0)))
+ − 3154 buttons)
+ − 3155 (insert before " ")
+ − 3156 (widget-documentation-link-add widget start (point))
+ − 3157 (push (widget-create-child-and-convert
+ − 3158 widget 'visibility
+ − 3159 :help-echo (lambda (widget)
+ − 3160 (concat
+ − 3161 (if (widget-value widget)
+ − 3162 "Hide" "Show")
+ − 3163 " the rest of the documentation"))
+ − 3164 :off "More"
+ − 3165 :action 'widget-parent-action
+ − 3166 shown)
+ − 3167 buttons)
+ − 3168 (when shown
+ − 3169 (setq start (point))
+ − 3170 (when indent
+ − 3171 (insert-char ?\ indent))
+ − 3172 (insert after)
+ − 3173 (widget-documentation-link-add widget start (point)))
+ − 3174 (widget-put widget :buttons buttons))
+ − 3175 (insert doc)
+ − 3176 (widget-documentation-link-add widget start (point))))
+ − 3177 (insert "\n"))
+ − 3178
+ − 3179 (defun widget-documentation-string-action (widget &rest ignore)
+ − 3180 ;; Toggle documentation.
+ − 3181 (let ((parent (widget-get widget :parent)))
+ − 3182 (widget-put parent :documentation-shown
+ − 3183 (not (widget-get parent :documentation-shown))))
+ − 3184 ;; Redraw.
+ − 3185 (widget-value-set widget (widget-value widget)))
+ − 3186
+ − 3187 ;;; The Sexp Widgets.
+ − 3188
+ − 3189 (define-widget 'const 'item
+ − 3190 "An immutable sexp."
+ − 3191 :prompt-value 'widget-const-prompt-value
+ − 3192 :format "%t\n%d")
+ − 3193
+ − 3194 (defun widget-const-prompt-value (widget prompt value unbound)
+ − 3195 ;; Return the value of the const.
+ − 3196 (widget-value widget))
+ − 3197
+ − 3198 (define-widget 'function-item 'const
+ − 3199 "An immutable function name."
+ − 3200 :format "%v\n%h"
+ − 3201 :documentation-property (lambda (symbol)
+ − 3202 (condition-case nil
+ − 3203 (documentation symbol t)
+ − 3204 (error nil))))
+ − 3205
+ − 3206 (define-widget 'variable-item 'const
+ − 3207 "An immutable variable name."
+ − 3208 :format "%v\n%h"
+ − 3209 :documentation-property 'variable-documentation)
+ − 3210
+ − 3211 (defvar widget-string-prompt-value-history nil
+ − 3212 "History of input to `widget-string-prompt-value'.")
+ − 3213
+ − 3214 (define-widget 'string 'editable-field
+ − 3215 "A string"
+ − 3216 :tag "String"
+ − 3217 :format "%{%t%}: %v"
+ − 3218 :complete-function 'ispell-complete-word
+ − 3219 :prompt-history 'widget-string-prompt-value-history)
+ − 3220
+ − 3221 (define-widget 'regexp 'string
+ − 3222 "A regular expression."
+ − 3223 :match 'widget-regexp-match
+ − 3224 :validate 'widget-regexp-validate
+ − 3225 ;; Doesn't work well with terminating newline.
+ − 3226 ;; :value-face 'widget-single-line-field-face
+ − 3227 :tag "Regexp")
+ − 3228
+ − 3229 (defun widget-regexp-match (widget value)
+ − 3230 ;; Match valid regexps.
+ − 3231 (and (stringp value)
+ − 3232 (condition-case nil
+ − 3233 (prog1 t
+ − 3234 (string-match value ""))
+ − 3235 (error nil))))
+ − 3236
+ − 3237 (defun widget-regexp-validate (widget)
+ − 3238 "Check that the value of WIDGET is a valid regexp."
+ − 3239 (let ((value (widget-value widget)))
+ − 3240 (condition-case data
+ − 3241 (prog1 nil
+ − 3242 (string-match value ""))
+ − 3243 (error (widget-put widget :error (error-message-string data))
+ − 3244 widget))))
+ − 3245
+ − 3246 (define-widget 'file 'string
+ − 3247 "A file widget.
+ − 3248 It will read a file name from the minibuffer when invoked."
+ − 3249 :complete-function 'widget-file-complete
+ − 3250 :prompt-value 'widget-file-prompt-value
+ − 3251 :format "%{%t%}: %v"
+ − 3252 ;; Doesn't work well with terminating newline.
+ − 3253 ;; :value-face 'widget-single-line-field-face
+ − 3254 :tag "File")
+ − 3255
+ − 3256 (defun widget-file-complete ()
+ − 3257 "Perform completion on file name preceding point."
+ − 3258 (interactive)
+ − 3259 (let* ((end (point))
+ − 3260 (beg (save-excursion
+ − 3261 (skip-chars-backward "^ ")
+ − 3262 (point)))
+ − 3263 (pattern (buffer-substring beg end))
+ − 3264 (name-part (file-name-nondirectory pattern))
+ − 3265 (directory (file-name-directory pattern))
+ − 3266 (completion (file-name-completion name-part directory)))
+ − 3267 (cond ((eq completion t))
+ − 3268 ((null completion)
+ − 3269 (message "Can't find completion for \"%s\"" pattern)
+ − 3270 (ding))
+ − 3271 ((not (string= name-part completion))
+ − 3272 (delete-region beg end)
+ − 3273 (insert (expand-file-name completion directory)))
+ − 3274 (t
+ − 3275 (message "Making completion list...")
+ − 3276 (let ((list (file-name-all-completions name-part directory)))
+ − 3277 (setq list (sort list 'string<))
+ − 3278 (with-output-to-temp-buffer "*Completions*"
+ − 3279 (display-completion-list list)))
+ − 3280 (message "Making completion list...%s" "done")))))
+ − 3281
+ − 3282 (defun widget-file-prompt-value (widget prompt value unbound)
+ − 3283 ;; Read file from minibuffer.
+ − 3284 (abbreviate-file-name
+ − 3285 (if unbound
+ − 3286 (read-file-name prompt)
+ − 3287 (let ((prompt2 (format "%s (default %s) " prompt value))
+ − 3288 (dir (file-name-directory value))
+ − 3289 (file (file-name-nondirectory value))
+ − 3290 (must-match (widget-get widget :must-match)))
+ − 3291 (read-file-name prompt2 dir nil must-match file)))))
+ − 3292
+ − 3293 ;;;(defun widget-file-action (widget &optional event)
+ − 3294 ;;; ;; Read a file name from the minibuffer.
+ − 3295 ;;; (let* ((value (widget-value widget))
+ − 3296 ;;; (dir (file-name-directory value))
+ − 3297 ;;; (file (file-name-nondirectory value))
+ − 3298 ;;; (menu-tag (widget-apply widget :menu-tag-get))
+ − 3299 ;;; (must-match (widget-get widget :must-match))
+ − 3300 ;;; (answer (read-file-name (concat menu-tag ": (default `" value "') ")
+ − 3301 ;;; dir nil must-match file)))
+ − 3302 ;;; (widget-value-set widget (abbreviate-file-name answer))
+ − 3303 ;;; (widget-setup)
+ − 3304 ;;; (widget-apply widget :notify widget event)))
+ − 3305
+ − 3306 (define-widget 'directory 'file
+ − 3307 "A directory widget.
+ − 3308 It will read a directory name from the minibuffer when invoked."
+ − 3309 :tag "Directory")
+ − 3310
+ − 3311 (defvar widget-symbol-prompt-value-history nil
+ − 3312 "History of input to `widget-symbol-prompt-value'.")
+ − 3313
+ − 3314 (define-widget 'symbol 'editable-field
+ − 3315 "A lisp symbol."
+ − 3316 :value nil
+ − 3317 :tag "Symbol"
+ − 3318 :format "%{%t%}: %v"
+ − 3319 :match (lambda (widget value) (symbolp value))
+ − 3320 :complete-function 'lisp-complete-symbol
+ − 3321 :prompt-internal 'widget-symbol-prompt-internal
+ − 3322 :prompt-match 'symbolp
+ − 3323 :prompt-history 'widget-symbol-prompt-value-history
+ − 3324 :value-to-internal (lambda (widget value)
+ − 3325 (if (symbolp value)
+ − 3326 (symbol-name value)
+ − 3327 value))
+ − 3328 :value-to-external (lambda (widget value)
+ − 3329 (if (stringp value)
+ − 3330 (intern value)
+ − 3331 value)))
+ − 3332
+ − 3333 (defun widget-symbol-prompt-internal (widget prompt initial history)
+ − 3334 ;; Read file from minibuffer.
+ − 3335 (let ((answer (completing-read prompt obarray
+ − 3336 (widget-get widget :prompt-match)
+ − 3337 nil initial history)))
+ − 3338 (if (and (stringp answer)
+ − 3339 (not (zerop (length answer))))
+ − 3340 answer
+ − 3341 (error "No value"))))
+ − 3342
+ − 3343 (defvar widget-function-prompt-value-history nil
+ − 3344 "History of input to `widget-function-prompt-value'.")
+ − 3345
+ − 3346 (define-widget 'function 'sexp
+ − 3347 "A lisp function."
+ − 3348 :complete-function 'lisp-complete-symbol
+ − 3349 :prompt-value 'widget-field-prompt-value
+ − 3350 :prompt-internal 'widget-symbol-prompt-internal
+ − 3351 :prompt-match 'fboundp
+ − 3352 :prompt-history 'widget-function-prompt-value-history
+ − 3353 :action 'widget-field-action
+ − 3354 :tag "Function")
+ − 3355
+ − 3356 (defvar widget-variable-prompt-value-history nil
+ − 3357 "History of input to `widget-variable-prompt-value'.")
+ − 3358
+ − 3359 (define-widget 'variable 'symbol
+ − 3360 ;; Should complete on variables.
+ − 3361 "A lisp variable."
+ − 3362 :prompt-match 'boundp
+ − 3363 :prompt-history 'widget-variable-prompt-value-history
+ − 3364 :tag "Variable")
+ − 3365
+ − 3366 ;; This part issues a warning when compiling without Mule. Is there a
+ − 3367 ;; way of shutting it up?
+ − 3368 ;;
+ − 3369 ;; OK, I'll simply comment the whole thing out, until someone decides
+ − 3370 ;; to do something with it.
+ − 3371 ;(defvar widget-coding-system-prompt-value-history nil
+ − 3372 ; "History of input to `widget-coding-system-prompt-value'.")
+ − 3373
+ − 3374 ;(define-widget 'coding-system 'symbol
+ − 3375 ; "A MULE coding-system."
+ − 3376 ; :format "%{%t%}: %v"
+ − 3377 ; :tag "Coding system"
+ − 3378 ; :prompt-history 'widget-coding-system-prompt-value-history
+ − 3379 ; :prompt-value 'widget-coding-system-prompt-value
+ − 3380 ; :action 'widget-coding-system-action)
+ − 3381
+ − 3382 ;(defun widget-coding-system-prompt-value (widget prompt value unbound)
+ − 3383 ; ;; Read coding-system from minibuffer.
+ − 3384 ; (intern
+ − 3385 ; (completing-read (format "%s (default %s) " prompt value)
+ − 3386 ; (mapcar (lambda (sym)
+ − 3387 ; (list (symbol-name sym)))
+ − 3388 ; (coding-system-list)))))
+ − 3389
+ − 3390 ;(defun widget-coding-system-action (widget &optional event)
+ − 3391 ; ;; Read a file name from the minibuffer.
+ − 3392 ; (let ((answer
+ − 3393 ; (widget-coding-system-prompt-value
+ − 3394 ; widget
+ − 3395 ; (widget-apply widget :menu-tag-get)
+ − 3396 ; (widget-value widget)
+ − 3397 ; t)))
+ − 3398 ; (widget-value-set widget answer)
+ − 3399 ; (widget-apply widget :notify widget event)
+ − 3400 ; (widget-setup)))
+ − 3401
+ − 3402 (define-widget 'sexp 'editable-field
+ − 3403 "An arbitrary lisp expression."
+ − 3404 :tag "Lisp expression"
+ − 3405 :format "%{%t%}: %v"
+ − 3406 :value nil
+ − 3407 :validate 'widget-sexp-validate
+ − 3408 :match (lambda (widget value) t)
+ − 3409 :value-to-internal 'widget-sexp-value-to-internal
+ − 3410 :value-to-external (lambda (widget value) (read value))
+ − 3411 :prompt-history 'widget-sexp-prompt-value-history
+ − 3412 :prompt-value 'widget-sexp-prompt-value)
+ − 3413
+ − 3414 (defun widget-sexp-value-to-internal (widget value)
+ − 3415 ;; Use cl-prettyprint for printer representation.
+ − 3416 (let ((pp (if (symbolp value)
+ − 3417 (prin1-to-string value)
+ − 3418 (widget-prettyprint-to-string value))))
+ − 3419 (if (> (length pp) 40)
+ − 3420 (concat "\n" pp)
+ − 3421 pp)))
+ − 3422
+ − 3423 (defun widget-sexp-validate (widget)
+ − 3424 ;; Valid if we can read the string and there is no junk left after it.
+ − 3425 (save-excursion
+ − 3426 (let ((buffer (set-buffer (get-buffer-create " *Widget Scratch*"))))
+ − 3427 (erase-buffer)
+ − 3428 (insert (widget-apply widget :value-get))
+ − 3429 (goto-char (point-min))
+ − 3430 (condition-case data
+ − 3431 (let ((value (read buffer)))
+ − 3432 (if (eobp)
+ − 3433 (if (widget-apply widget :match value)
+ − 3434 nil
+ − 3435 (widget-put widget :error (widget-get widget :type-error))
+ − 3436 widget)
+ − 3437 (widget-put widget
+ − 3438 :error (format "Junk at end of expression: %s"
+ − 3439 (buffer-substring (point)
+ − 3440 (point-max))))
+ − 3441 widget))
+ − 3442 (error (widget-put widget :error (error-message-string data))
+ − 3443 widget)))))
+ − 3444
+ − 3445 (defvar widget-sexp-prompt-value-history nil
+ − 3446 "History of input to `widget-sexp-prompt-value'.")
+ − 3447
+ − 3448 (defun widget-sexp-prompt-value (widget prompt value unbound)
+ − 3449 ;; Read an arbitrary sexp.
+ − 3450 (let ((found (read-string prompt
+ − 3451 (if unbound nil (cons (prin1-to-string value) 0))
+ − 3452 (widget-get widget :prompt-history))))
+ − 3453 (save-excursion
+ − 3454 (let ((buffer (set-buffer (get-buffer-create " *Widget Scratch*"))))
+ − 3455 (erase-buffer)
+ − 3456 (insert found)
+ − 3457 (goto-char (point-min))
+ − 3458 (let ((answer (read buffer)))
+ − 3459 (unless (eobp)
+ − 3460 (signal 'error
+ − 3461 (list "Junk at end of expression"
+ − 3462 (buffer-substring (point) (point-max)))))
+ − 3463 answer)))))
+ − 3464
+ − 3465 (define-widget 'restricted-sexp 'sexp
+ − 3466 "A Lisp expression restricted to values that match.
+ − 3467 To use this type, you must define :match or :match-alternatives."
+ − 3468 :type-error "The specified value is not valid"
+ − 3469 :match 'widget-restricted-sexp-match
+ − 3470 :value-to-internal (lambda (widget value)
+ − 3471 (if (widget-apply widget :match value)
+ − 3472 (prin1-to-string value)
+ − 3473 value)))
+ − 3474
+ − 3475 (defun widget-restricted-sexp-match (widget value)
+ − 3476 (let ((alternatives (widget-get widget :match-alternatives))
+ − 3477 matched)
+ − 3478 (while (and alternatives (not matched))
+ − 3479 (if (cond ((functionp (car alternatives))
+ − 3480 (funcall (car alternatives) value))
+ − 3481 ((and (consp (car alternatives))
+ − 3482 (eq (car (car alternatives)) 'quote))
+ − 3483 (eq value (nth 1 (car alternatives)))))
+ − 3484 (setq matched t))
+ − 3485 (setq alternatives (cdr alternatives)))
+ − 3486 matched))
+ − 3487
+ − 3488 (define-widget 'integer 'restricted-sexp
+ − 3489 "An integer."
+ − 3490 :tag "Integer"
+ − 3491 :value 0
+ − 3492 :type-error "This field should contain an integer"
+ − 3493 :match-alternatives '(integerp))
+ − 3494
+ − 3495 (define-widget 'number 'restricted-sexp
+ − 3496 "A floating point number."
+ − 3497 :tag "Number"
+ − 3498 :value 0.0
+ − 3499 :type-error "This field should contain a number"
+ − 3500 :match-alternatives '(numberp))
+ − 3501
+ − 3502 (define-widget 'character 'editable-field
+ − 3503 "A character."
+ − 3504 :tag "Character"
+ − 3505 :value ?\0
+ − 3506 :format "%{%t%}: %v"
+ − 3507 :valid-regexp "\\`[\0-\377]\\'"
+ − 3508 :error "This field should contain a single character"
+ − 3509 :value-to-internal (lambda (widget value)
+ − 3510 (if (stringp value)
+ − 3511 value
+ − 3512 (char-to-string value)))
+ − 3513 :value-to-external (lambda (widget value)
+ − 3514 (if (stringp value)
+ − 3515 (aref value 0)
+ − 3516 value))
+ − 3517 :match (lambda (widget value)
+ − 3518 (characterp value)))
+ − 3519
+ − 3520 (define-widget 'list 'group
+ − 3521 "A lisp list."
+ − 3522 :tag "List"
+ − 3523 :format "%{%t%}:\n%v")
+ − 3524
+ − 3525 (define-widget 'vector 'group
+ − 3526 "A lisp vector."
+ − 3527 :tag "Vector"
+ − 3528 :format "%{%t%}:\n%v"
+ − 3529 :match 'widget-vector-match
+ − 3530 :value-to-internal (lambda (widget value) (append value nil))
+ − 3531 :value-to-external (lambda (widget value) (vconcat value)))
+ − 3532
+ − 3533 (defun widget-vector-match (widget value)
+ − 3534 (and (vectorp value)
+ − 3535 (widget-group-match widget
+ − 3536 (widget-apply widget :value-to-internal value))))
+ − 3537
+ − 3538 (define-widget 'cons 'group
+ − 3539 "A cons-cell."
+ − 3540 :tag "Cons-cell"
+ − 3541 :format "%{%t%}:\n%v"
+ − 3542 :match 'widget-cons-match
+ − 3543 :value-to-internal (lambda (widget value)
+ − 3544 (list (car value) (cdr value)))
+ − 3545 :value-to-external (lambda (widget value)
+ − 3546 (cons (car value) (cadr value))))
+ − 3547
+ − 3548 (defun widget-cons-match (widget value)
+ − 3549 (and (consp value)
+ − 3550 (widget-group-match widget
+ − 3551 (widget-apply widget :value-to-internal value))))
+ − 3552
+ − 3553 (define-widget 'choice 'menu-choice
+ − 3554 "A union of several sexp types."
+ − 3555 :tag "Choice"
+ − 3556 :format "%{%t%}: %[Value Menu%] %v"
+ − 3557 :button-prefix 'widget-push-button-prefix
+ − 3558 :button-suffix 'widget-push-button-suffix
+ − 3559 :prompt-value 'widget-choice-prompt-value)
+ − 3560
+ − 3561 (defun widget-choice-prompt-value (widget prompt value unbound)
+ − 3562 "Make a choice."
+ − 3563 (let ((args (widget-get widget :args))
+ − 3564 (completion-ignore-case (widget-get widget :case-fold))
+ − 3565 current choices old)
+ − 3566 ;; Find the first arg that match VALUE.
+ − 3567 (let ((look args))
+ − 3568 (while look
+ − 3569 (if (widget-apply (car look) :match value)
+ − 3570 (setq old (car look)
+ − 3571 look nil)
+ − 3572 (setq look (cdr look)))))
+ − 3573 ;; Find new choice.
+ − 3574 (setq current
+ − 3575 (cond ((= (length args) 0)
+ − 3576 nil)
+ − 3577 ((= (length args) 1)
+ − 3578 (nth 0 args))
+ − 3579 ((and (= (length args) 2)
+ − 3580 (memq old args))
+ − 3581 (if (eq old (nth 0 args))
+ − 3582 (nth 1 args)
+ − 3583 (nth 0 args)))
+ − 3584 (t
+ − 3585 (while args
+ − 3586 (setq current (car args)
+ − 3587 args (cdr args))
+ − 3588 (setq choices
+ − 3589 (cons (cons (widget-apply current :menu-tag-get)
+ − 3590 current)
+ − 3591 choices)))
+ − 3592 (let ((val (completing-read prompt choices nil t)))
+ − 3593 (if (stringp val)
+ − 3594 (let ((try (try-completion val choices)))
+ − 3595 (when (stringp try)
+ − 3596 (setq val try))
+ − 3597 (cdr (assoc val choices)))
+ − 3598 nil)))))
+ − 3599 (if current
+ − 3600 (widget-prompt-value current prompt nil t)
+ − 3601 value)))
+ − 3602
+ − 3603 (define-widget 'radio 'radio-button-choice
+ − 3604 "A union of several sexp types."
+ − 3605 :tag "Choice"
+ − 3606 :format "%{%t%}:\n%v"
+ − 3607 :prompt-value 'widget-choice-prompt-value)
+ − 3608
+ − 3609 (define-widget 'repeat 'editable-list
+ − 3610 "A variable length homogeneous list."
+ − 3611 :tag "Repeat"
+ − 3612 :format "%{%t%}:\n%v%i\n")
+ − 3613
+ − 3614 (define-widget 'set 'checklist
+ − 3615 "A list of members from a fixed set."
+ − 3616 :tag "Set"
+ − 3617 :format "%{%t%}:\n%v")
+ − 3618
+ − 3619 (define-widget 'boolean 'toggle
+ − 3620 "To be nil or non-nil, that is the question."
+ − 3621 :tag "Boolean"
+ − 3622 :prompt-value 'widget-boolean-prompt-value
+ − 3623 :button-prefix 'widget-push-button-prefix
+ − 3624 :button-suffix 'widget-push-button-suffix
+ − 3625 :format "%{%t%}: %[Toggle%] %v\n"
+ − 3626 :on "on (non-nil)"
+ − 3627 :off "off (nil)")
+ − 3628
+ − 3629 (defun widget-boolean-prompt-value (widget prompt value unbound)
+ − 3630 ;; Toggle a boolean.
+ − 3631 (y-or-n-p prompt))
+ − 3632
+ − 3633 ;;; The `color' Widget.
+ − 3634
+ − 3635 (define-widget 'color 'editable-field
+ − 3636 "Choose a color name (with sample)."
+ − 3637 :format "%[%t%]: %v (%{sample%})\n"
+ − 3638 :size 10
+ − 3639 :tag "Color"
+ − 3640 :value "black"
+ − 3641 :complete 'widget-color-complete
+ − 3642 :sample-face-get 'widget-color-sample-face-get
+ − 3643 :notify 'widget-color-notify
+ − 3644 :action 'widget-color-action)
+ − 3645
+ − 3646 (defun widget-color-complete (widget)
+ − 3647 "Complete the color in WIDGET."
+ − 3648 (let* ((prefix (buffer-substring-no-properties (widget-field-start widget)
+ − 3649 (point)))
+ − 3650 (list (read-color-completion-table))
+ − 3651 (completion (try-completion prefix list)))
+ − 3652 (cond ((eq completion t)
+ − 3653 (message "Exact match"))
+ − 3654 ((null completion)
+ − 3655 (error "Can't find completion for \"%s\"" prefix))
+ − 3656 ((not (string-equal prefix completion))
+ − 3657 (insert (substring completion (length prefix))))
+ − 3658 (t
+ − 3659 (message "Making completion list...")
+ − 3660 (let ((list (all-completions prefix list nil)))
+ − 3661 (with-output-to-temp-buffer "*Completions*"
+ − 3662 (display-completion-list list)))
+ − 3663 (message "Making completion list...done")))))
+ − 3664
+ − 3665 (defun widget-color-sample-face-get (widget)
+ − 3666 (or (widget-get widget :sample-face)
+ − 3667 (let ((color (widget-value widget))
+ − 3668 (face (make-face (gensym "sample-face-") nil t)))
+ − 3669 ;; Use the face object, not its name, to prevent lossage if gc
+ − 3670 ;; happens before applying the face.
+ − 3671 (widget-put widget :sample-face face)
+ − 3672 (and color
+ − 3673 (not (equal color ""))
+ − 3674 (valid-color-name-p color)
+ − 3675 (set-face-foreground face color))
+ − 3676 face)))
+ − 3677
+ − 3678 (defvar widget-color-history nil
+ − 3679 "History of entered colors.")
+ − 3680
+ − 3681 (defun widget-color-action (widget &optional event)
+ − 3682 ;; Prompt for a color.
+ − 3683 (let* ((tag (widget-apply widget :menu-tag-get))
+ − 3684 (answer (read-color (concat tag ": "))))
+ − 3685 (unless (zerop (length answer))
+ − 3686 (widget-value-set widget answer)
+ − 3687 (widget-setup)
+ − 3688 (widget-apply widget :notify widget event))))
+ − 3689
+ − 3690 (defun widget-color-notify (widget child &optional event)
+ − 3691 "Update the sample, and notify the parent."
+ − 3692 (let* ((face (widget-apply widget :sample-face-get))
+ − 3693 (color (widget-value widget)))
+ − 3694 (if (valid-color-name-p color)
+ − 3695 (set-face-foreground face color)
+ − 3696 (remove-face-property face 'foreground)))
+ − 3697 (widget-default-notify widget child event))
+ − 3698
+ − 3699 ;; Is this a misnomer?
+ − 3700 (defun widget-at (pos)
+ − 3701 "The button or field at POS."
+ − 3702 (or (get-char-property pos 'button)
+ − 3703 (get-char-property pos 'field)))
+ − 3704
+ − 3705 (defun widget-echo-help (pos)
+ − 3706 "Display the help echo for widget at POS."
+ − 3707 (let* ((widget (widget-at pos))
+ − 3708 (help-echo (and widget (widget-get widget :help-echo))))
+ − 3709 (and (functionp help-echo)
+ − 3710 (setq help-echo (funcall help-echo widget)))
+ − 3711 (when (stringp help-echo)
+ − 3712 (display-message 'help-echo help-echo))))
+ − 3713
+ − 3714 ;;; The End:
+ − 3715
+ − 3716 (provide 'wid-edit)
+ − 3717
+ − 3718 ;; wid-edit.el ends here
