Mercurial > hg > xemacs-beta
comparison lisp/w3/widget-edit.el @ 0:376386a54a3c r19-14
Import from CVS: tag r19-14
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 08:45:50 +0200 |
| parents | |
| children | ac2d302a0011 |
comparison
equal
deleted
inserted
replaced
| -1:000000000000 | 0:376386a54a3c |
|---|---|
| 1 ;;; widget-edit.el --- Functions for creating and using widgets. | |
| 2 ;; | |
| 3 ;; Copyright (C) 1996 Free Software Foundation, Inc. | |
| 4 ;; | |
| 5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> | |
| 6 ;; Keywords: help, extensions, faces, hypermedia | |
| 7 ;; Version: 0.4 | |
| 8 | |
| 9 ;;; Commentary: | |
| 10 ;; | |
| 11 ;; See `widget.el'. | |
| 12 | |
| 13 ;;; Code: | |
| 14 | |
| 15 (require 'widget) | |
| 16 (require 'cl) | |
| 17 | |
| 18 ;;; Compatibility. | |
| 19 | |
| 20 (or (fboundp 'event-point) | |
| 21 ;; XEmacs function missing in Emacs. | |
| 22 (defun event-point (event) | |
| 23 "Return the character position of the given mouse-motion, button-press, | |
| 24 or button-release event. If the event did not occur over a window, or did | |
| 25 not occur over text, then this returns nil. Otherwise, it returns an index | |
| 26 into the buffer visible in the event's window." | |
| 27 (posn-point (event-start event)))) | |
| 28 | |
| 29 (or (fboundp 'set-keymap-parent) | |
| 30 ;; Xemacs function missing in Emacs. | |
| 31 ;; Definition stolen from `lucid.el'. | |
| 32 (defun set-keymap-parent (keymap new-parent) | |
| 33 (let ((tail keymap)) | |
| 34 (while (and tail (cdr tail) (not (eq (car (cdr tail)) 'keymap))) | |
| 35 (setq tail (cdr tail))) | |
| 36 (if tail | |
| 37 (setcdr tail new-parent))))) | |
| 38 | |
| 39 ;;; Customization. | |
| 40 ;; | |
| 41 ;; These should be specified with the custom package. | |
| 42 | |
| 43 (defvar widget-button-face 'bold) | |
| 44 (defvar widget-mouse-face 'highlight) | |
| 45 (defvar widget-field-face 'italic) | |
| 46 | |
| 47 ;;; Utility functions. | |
| 48 ;; | |
| 49 ;; These are not really widget specific. | |
| 50 | |
| 51 (defun widget-plist-member (plist prop) | |
| 52 ;; Return non-nil if PLIST has the property PROP. | |
| 53 ;; PLIST is a property list, which is a list of the form | |
| 54 ;; (PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol. | |
| 55 ;; Unlike `plist-get', this allows you to distinguish between a missing | |
| 56 ;; property and a property with the value nil. | |
| 57 ;; The value is actually the tail of PLIST whose car is PROP. | |
| 58 (while (and plist (not (eq (car plist) prop))) | |
| 59 (setq plist (cdr (cdr plist)))) | |
| 60 plist) | |
| 61 | |
| 62 (defun widget-princ-to-string (object) | |
| 63 ;; Return string representation of OBJECT, any Lisp object. | |
| 64 ;; No quoting characters are used; no delimiters are printed around | |
| 65 ;; the contents of strings. | |
| 66 (save-excursion | |
| 67 (set-buffer (get-buffer-create " *widget-tmp*")) | |
| 68 (erase-buffer) | |
| 69 (let ((standard-output (current-buffer))) | |
| 70 (princ object)) | |
| 71 (buffer-string))) | |
| 72 | |
| 73 (defun widget-clear-undo () | |
| 74 "Clear all undo information." | |
| 75 (buffer-disable-undo (current-buffer)) | |
| 76 (buffer-enable-undo)) | |
| 77 | |
| 78 ;;; Widget text specifications. | |
| 79 ;; | |
| 80 ;; These functions are for specifying text properties. | |
| 81 | |
| 82 (defun widget-specify-none (from to) | |
| 83 ;; Clear all text properties between FROM and TO. | |
| 84 (set-text-properties from to nil)) | |
| 85 | |
| 86 (defun widget-specify-text (from to) | |
| 87 ;; Default properties. | |
| 88 (add-text-properties from to (list 'read-only t | |
| 89 'front-sticky t | |
| 90 'rear-nonsticky nil))) | |
| 91 | |
| 92 (defun widget-specify-field (widget from to) | |
| 93 ;; Specify editable button for WIDGET between FROM and TO. | |
| 94 (widget-specify-field-update widget from to) | |
| 95 ;; Make it possible to edit both end of the field. | |
| 96 (add-text-properties (1- from) from (list 'rear-nonsticky t | |
| 97 'end-open t | |
| 98 'invisible t)) | |
| 99 (add-text-properties to (1+ to) (list 'font-sticky nil | |
| 100 'start-open t))) | |
| 101 | |
| 102 (defun widget-specify-field-update (widget from to) | |
| 103 ;; Specify editable button for WIDGET between FROM and TO. | |
| 104 (let ((map (widget-get widget :keymap)) | |
| 105 (face (or (widget-get widget :value-face) | |
| 106 widget-field-face))) | |
| 107 (add-text-properties from to (list 'field widget | |
| 108 'read-only nil | |
| 109 'local-map map | |
| 110 'keymap map | |
| 111 'face widget-field-face)))) | |
| 112 | |
| 113 (defun widget-specify-button (widget from to) | |
| 114 ;; Specify button for WIDGET between FROM and TO. | |
| 115 (let ((face (or (widget-get widget :button-face) | |
| 116 widget-button-face))) | |
| 117 (add-text-properties from to (list 'button widget | |
| 118 'mouse-face widget-mouse-face | |
| 119 'face face)))) | |
| 120 | |
| 121 (defun widget-specify-doc (widget from to) | |
| 122 ;; Specify documentation for WIDGET between FROM and TO. | |
| 123 (put-text-property from to 'widget-doc widget)) | |
| 124 | |
| 125 | |
| 126 (defmacro widget-specify-insert (&rest form) | |
| 127 ;; Execute FORM without inheriting any text properties. | |
| 128 `(save-restriction | |
| 129 (let ((inhibit-read-only t) | |
| 130 result | |
| 131 after-change-functions) | |
| 132 (insert "<>") | |
| 133 (narrow-to-region (- (point) 2) (point)) | |
| 134 (widget-specify-none (point-min) (point-max)) | |
| 135 (goto-char (1+ (point-min))) | |
| 136 (setq result (progn ,@form)) | |
| 137 (delete-region (point-min) (1+ (point-min))) | |
| 138 (delete-region (1- (point-max)) (point-max)) | |
| 139 (goto-char (point-max)) | |
| 140 result))) | |
| 141 | |
| 142 ;;; Widget Properties. | |
| 143 | |
| 144 (defun widget-put (widget property value) | |
| 145 "In WIDGET set PROPERTY to VALUE. | |
| 146 The value can later be retrived with `widget-get'." | |
| 147 (setcdr widget (plist-put (cdr widget) property value))) | |
| 148 | |
| 149 (defun widget-get (widget property) | |
| 150 "In WIDGET, get the value of PROPERTY. | |
| 151 The value could either be specified when the widget was created, or | |
| 152 later with `widget-put'." | |
| 153 (cond ((widget-plist-member (cdr widget) property) | |
| 154 (plist-get (cdr widget) property)) | |
| 155 ((car widget) | |
| 156 (widget-get (get (car widget) 'widget-type) property)) | |
| 157 (t nil))) | |
| 158 | |
| 159 (defun widget-member (widget property) | |
| 160 "Non-nil iff there is a definition in WIDGET for PROPERTY." | |
| 161 (cond ((widget-plist-member (cdr widget) property) | |
| 162 t) | |
| 163 ((car widget) | |
| 164 (widget-member (get (car widget) 'widget-type) property)) | |
| 165 (t nil))) | |
| 166 | |
| 167 (defun widget-apply (widget property &rest args) | |
| 168 "Apply the value of WIDGET's PROPERTY to the widget itself. | |
| 169 ARGS are passed as extra argments to the function." | |
| 170 (apply (widget-get widget property) widget args)) | |
| 171 | |
| 172 (defun widget-value (widget) | |
| 173 "Extract the current value of WIDGET." | |
| 174 (widget-apply widget | |
| 175 :value-to-external (widget-apply widget :value-get))) | |
| 176 | |
| 177 (defun widget-value-set (widget value) | |
| 178 "Set the current value of WIDGET to VALUE." | |
| 179 (widget-apply widget | |
| 180 :value-set (widget-apply widget | |
| 181 :value-to-internal value))) | |
| 182 | |
| 183 (defun widget-match-inline (widget values) | |
| 184 ;; Match the head of values. | |
| 185 (cond ((widget-get widget :inline) | |
| 186 (widget-apply widget :match-inline values)) | |
| 187 ((widget-apply widget :match (car values)) | |
| 188 (cons (list (car values)) (cdr values))) | |
| 189 (t nil))) | |
| 190 | |
| 191 ;;; Creating Widgets. | |
| 192 | |
| 193 (defun widget-create (type &rest args) | |
| 194 "Create widget of TYPE. | |
| 195 The optional ARGS are additional keyword arguments." | |
| 196 (let ((widget (apply 'widget-convert type args))) | |
| 197 (widget-apply widget :create) | |
| 198 widget)) | |
| 199 | |
| 200 (defun widget-delete (widget) | |
| 201 "Delete WIDGET." | |
| 202 (widget-apply widget :delete)) | |
| 203 | |
| 204 (defun widget-convert (type &rest args) | |
| 205 "Convert TYPE to a widget without inserting it in the buffer. | |
| 206 The optional ARGS are additional keyword arguments." | |
| 207 ;; Don't touch the type. | |
| 208 (let* ((widget (if (symbolp type) | |
| 209 (list type) | |
| 210 (copy-list type))) | |
| 211 (current widget) | |
| 212 (keys args)) | |
| 213 ;; First set the :args keyword. | |
| 214 (while (cdr current) ;Look in the type. | |
| 215 (let ((next (car (cdr current)))) | |
| 216 (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:)) | |
| 217 (setq current (cdr (cdr current))) | |
| 218 (setcdr current (list :args (cdr current))) | |
| 219 (setq current nil)))) | |
| 220 (while args ;Look in the args. | |
| 221 (let ((next (nth 0 args))) | |
| 222 (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:)) | |
| 223 (setq args (nthcdr 2 args)) | |
| 224 (widget-put widget :args args) | |
| 225 (setq args nil)))) | |
| 226 ;; Then Convert the widget. | |
| 227 (setq type widget) | |
| 228 (while type | |
| 229 (let ((convert-widget (widget-get type :convert-widget))) | |
| 230 (if convert-widget | |
| 231 (setq widget (funcall convert-widget widget)))) | |
| 232 (setq type (get (car type) 'widget-type))) | |
| 233 ;; Finally set the keyword args. | |
| 234 (while keys | |
| 235 (let ((next (nth 0 keys))) | |
| 236 (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:)) | |
| 237 (progn | |
| 238 (widget-put widget next (nth 1 keys)) | |
| 239 (setq keys (nthcdr 2 keys))) | |
| 240 (setq keys nil)))) | |
| 241 ;; Return the newly create widget. | |
| 242 widget)) | |
| 243 | |
| 244 (defun widget-insert (&rest args) | |
| 245 "Call `insert' with ARGS and make the text read only." | |
| 246 (let ((inhibit-read-only t) | |
| 247 after-change-functions | |
| 248 (from (point))) | |
| 249 (apply 'insert args) | |
| 250 (widget-specify-text from (point)))) | |
| 251 | |
| 252 ;;; Keymap and Comands. | |
| 253 | |
| 254 (defvar widget-keymap nil | |
| 255 "Keymap containing useful binding for buffers containing widgets. | |
| 256 Recommended as a parent keymap for modes using widgets.") | |
| 257 | |
| 258 (if widget-keymap | |
| 259 () | |
| 260 (setq widget-keymap (make-sparse-keymap)) | |
| 261 (set-keymap-parent widget-keymap global-map) | |
| 262 (define-key widget-keymap "\t" 'widget-forward) | |
| 263 (define-key widget-keymap "\M-\t" 'widget-backward) | |
| 264 (define-key widget-keymap [(shift tab)] 'widget-backward) | |
| 265 (if (string-match "XEmacs" (emacs-version)) | |
| 266 (define-key widget-keymap [button2] 'widget-button-click) | |
| 267 (define-key widget-keymap [mouse-2] 'widget-button-click)) | |
| 268 (define-key widget-keymap "\C-m" 'widget-button-press)) | |
| 269 | |
| 270 (defvar widget-global-map global-map | |
| 271 "Keymap used for events the widget does not handle themselves.") | |
| 272 (make-variable-buffer-local 'widget-global-map) | |
| 273 | |
| 274 (defun widget-button-click (event) | |
| 275 "Activate button below mouse pointer." | |
| 276 (interactive "@e") | |
| 277 (widget-button-press (event-point event) event)) | |
| 278 | |
| 279 (defun widget-button-press (pos &optional event) | |
| 280 "Activate button at POS." | |
| 281 (interactive "@d") | |
| 282 (let* ((button (get-text-property pos 'button))) | |
| 283 (if button | |
| 284 (widget-apply button :action event) | |
| 285 (call-interactively | |
| 286 (lookup-key widget-global-map (this-command-keys)))))) | |
| 287 | |
| 288 (defun widget-forward (arg) | |
| 289 "Move point to the next field or button. | |
| 290 With optional ARG, move across that many fields." | |
| 291 (interactive "p") | |
| 292 (while (> arg 0) | |
| 293 (setq arg (1- arg)) | |
| 294 (let ((next (cond ((get-text-property (point) 'button) | |
| 295 (next-single-property-change (point) 'button)) | |
| 296 ((get-text-property (point) 'field) | |
| 297 (next-single-property-change (point) 'field)) | |
| 298 (t | |
| 299 (point))))) | |
| 300 (if (null next) ; Widget extends to end. of buffer | |
| 301 (setq next (point-min))) | |
| 302 (let ((button (next-single-property-change next 'button)) | |
| 303 (field (next-single-property-change next 'field))) | |
| 304 (cond ((or (get-text-property next 'button) | |
| 305 (get-text-property next 'field)) | |
| 306 (goto-char next)) | |
| 307 ((and button field) | |
| 308 (goto-char (min button field))) | |
| 309 (button (goto-char button)) | |
| 310 (field (goto-char field)) | |
| 311 (t | |
| 312 (let ((button (next-single-property-change (point-min) 'button)) | |
| 313 (field (next-single-property-change (point-min) 'field))) | |
| 314 (cond ((and button field) (goto-char (min button field))) | |
| 315 (button (goto-char button)) | |
| 316 (field (goto-char field)) | |
| 317 (t | |
| 318 (error "No buttons or fields found"))))))))) | |
| 319 (while (< arg 0) | |
| 320 (if (= (point-min) (point)) | |
| 321 (forward-char 1)) | |
| 322 (setq arg (1+ arg)) | |
| 323 (let ((previous (cond ((get-text-property (1- (point)) 'button) | |
| 324 (previous-single-property-change (point) 'button)) | |
| 325 ((get-text-property (1- (point)) 'field) | |
| 326 (previous-single-property-change (point) 'field)) | |
| 327 (t | |
| 328 (point))))) | |
| 329 (if (null previous) ; Widget extends to beg. of buffer | |
| 330 (setq previous (point-max))) | |
| 331 (let ((button (previous-single-property-change previous 'button)) | |
| 332 (field (previous-single-property-change previous 'field))) | |
| 333 (cond ((and button field) | |
| 334 (goto-char (max button field))) | |
| 335 (button (goto-char button)) | |
| 336 (field (goto-char field)) | |
| 337 (t | |
| 338 (let ((button (previous-single-property-change | |
| 339 (point-max) 'button)) | |
| 340 (field (previous-single-property-change | |
| 341 (point-max) 'field))) | |
| 342 (cond ((and button field) (goto-char (max button field))) | |
| 343 (button (goto-char button)) | |
| 344 (field (goto-char field)) | |
| 345 (t | |
| 346 (error "No buttons or fields found")))))))) | |
| 347 (let ((button (previous-single-property-change (point) 'button)) | |
| 348 (field (previous-single-property-change (point) 'field))) | |
| 349 (cond ((and button field) | |
| 350 (goto-char (max button field))) | |
| 351 (button (goto-char button)) | |
| 352 (field (goto-char field))))) | |
| 353 (let ((help-echo (or (get-text-property (point) 'button) | |
| 354 (get-text-property (point) 'field)))) | |
| 355 (if (and help-echo (setq help-echo (widget-get help-echo :help-echo))) | |
| 356 (message "%s" help-echo)))) | |
| 357 | |
| 358 (defun widget-backward (arg) | |
| 359 "Move point to the previous field or button. | |
| 360 With optional ARG, move across that many fields." | |
| 361 (interactive "p") | |
| 362 (widget-forward (- arg))) | |
| 363 | |
| 364 ;;; Setting up the buffer. | |
| 365 | |
| 366 (defvar widget-field-new nil) | |
| 367 ;; List of all newly created editable fields in the buffer. | |
| 368 (make-variable-buffer-local 'widget-field-new) | |
| 369 | |
| 370 (defvar widget-field-list nil) | |
| 371 ;; List of all editable fields in the buffer. | |
| 372 (make-variable-buffer-local 'widget-field-list) | |
| 373 | |
| 374 (defun widget-setup () | |
| 375 "Setup current buffer so editing string widgets works." | |
| 376 (let ((inhibit-read-only t) | |
| 377 field) | |
| 378 (while widget-field-new | |
| 379 (setq field (car widget-field-new) | |
| 380 widget-field-new (cdr widget-field-new) | |
| 381 widget-field-list (cons field widget-field-list)) | |
| 382 (let ((from (widget-get field :value-from)) | |
| 383 (to (widget-get field :value-to))) | |
| 384 (widget-specify-field field from to) | |
| 385 (move-marker from (1- from)) | |
| 386 (move-marker to (1+ to))))) | |
| 387 (widget-clear-undo) | |
| 388 ;; We need to maintain text properties and size of the editing fields. | |
| 389 (make-local-variable 'after-change-functions) | |
| 390 (if widget-field-list | |
| 391 (setq after-change-functions '(widget-after-change)) | |
| 392 (setq after-change-functions nil))) | |
| 393 | |
| 394 (defvar widget-field-last nil) | |
| 395 ;; Last field containing point. | |
| 396 (make-variable-buffer-local 'widget-field-last) | |
| 397 | |
| 398 (defvar widget-field-was nil) | |
| 399 ;; The widget data before the change. | |
| 400 (make-variable-buffer-local 'widget-field-was) | |
| 401 | |
| 402 (defun widget-field-find (pos) | |
| 403 ;; Find widget whose editing field is located at POS. | |
| 404 ;; Return nil if POS is not inside and editing field. | |
| 405 ;; | |
| 406 ;; This is only used in `widget-field-modified', since ordinarily | |
| 407 ;; you would just test the field property. | |
| 408 (let ((fields widget-field-list) | |
| 409 field found) | |
| 410 (while fields | |
| 411 (setq field (car fields) | |
| 412 fields (cdr fields)) | |
| 413 (let ((from (widget-get field :value-from)) | |
| 414 (to (widget-get field :value-to))) | |
| 415 (if (and from to (< from pos) (> to pos)) | |
| 416 (setq fields nil | |
| 417 found field)))) | |
| 418 found)) | |
| 419 | |
| 420 (defun widget-after-change (from to old) | |
| 421 ;; Adjust field size and text properties. | |
| 422 (condition-case nil | |
| 423 (let ((field (widget-field-find from)) | |
| 424 (inhibit-read-only t)) | |
| 425 (cond ((null field)) | |
| 426 ((not (eq field (widget-field-find to))) | |
| 427 (message "Error: `widget-after-change' called on two fields")) | |
| 428 (t | |
| 429 (let ((size (widget-get field :size))) | |
| 430 (if size | |
| 431 (let ((begin (1+ (widget-get field :value-from))) | |
| 432 (end (1- (widget-get field :value-to)))) | |
| 433 (widget-specify-field-update field begin end) | |
| 434 (cond ((< (- end begin) size) | |
| 435 ;; Field too small. | |
| 436 (save-excursion | |
| 437 (goto-char end) | |
| 438 (insert-char ?\ (- (+ begin size) end)))) | |
| 439 ((> (- end begin) size) | |
| 440 ;; Field too large and | |
| 441 (if (or (< (point) (+ begin size)) | |
| 442 (> (point) end)) | |
| 443 ;; Point is outside extra space. | |
| 444 (setq begin (+ begin size)) | |
| 445 ;; Point is within the extra space. | |
| 446 (setq begin (point))) | |
| 447 (save-excursion | |
| 448 (goto-char end) | |
| 449 (while (and (eq (preceding-char) ?\ ) | |
| 450 (> (point) begin)) | |
| 451 (delete-backward-char 1)))))) | |
| 452 (widget-specify-field-update field from to))) | |
| 453 (widget-apply field :notify field)))) | |
| 454 (error (debug)))) | |
| 455 | |
| 456 ;;; The `default' Widget. | |
| 457 | |
| 458 (define-widget 'default nil | |
| 459 "Basic widget other widgets are derived from." | |
| 460 :value-to-internal (lambda (widget value) value) | |
| 461 :value-to-external (lambda (widget value) value) | |
| 462 :create 'widget-default-create | |
| 463 :format-handler 'widget-default-format-handler | |
| 464 :delete 'widget-default-delete | |
| 465 :value-set 'widget-default-value-set | |
| 466 :value-inline 'widget-default-value-inline | |
| 467 :menu-tag-get 'widget-default-menu-tag-get | |
| 468 :validate (lambda (widget) t) | |
| 469 :action 'widget-default-action | |
| 470 :notify 'widget-default-notify) | |
| 471 | |
| 472 (defun widget-default-create (widget) | |
| 473 "Create WIDGET at point in the current buffer." | |
| 474 (widget-specify-insert | |
| 475 (let ((from (point)) | |
| 476 (tag (widget-get widget :tag)) | |
| 477 (doc (widget-get widget :doc)) | |
| 478 button-begin button-end | |
| 479 doc-begin doc-end | |
| 480 value-pos) | |
| 481 (insert (widget-get widget :format)) | |
| 482 (goto-char from) | |
| 483 ;; Parse % escapes in format. | |
| 484 (while (re-search-forward "%\\(.\\)" nil t) | |
| 485 (let ((escape (aref (match-string 1) 0))) | |
| 486 (replace-match "" t t) | |
| 487 (cond ((eq escape ?%) | |
| 488 (insert "%")) | |
| 489 ((eq escape ?\[) | |
| 490 (setq button-begin (point))) | |
| 491 ((eq escape ?\]) | |
| 492 (setq button-end (point))) | |
| 493 ((eq escape ?t) | |
| 494 (if tag | |
| 495 (insert tag) | |
| 496 (let ((standard-output (current-buffer))) | |
| 497 (princ (widget-get widget :value))))) | |
| 498 ((eq escape ?d) | |
| 499 (when doc | |
| 500 (setq doc-begin (point)) | |
| 501 (insert doc) | |
| 502 (while (eq (preceding-char) ?\n) | |
| 503 (delete-backward-char 1)) | |
| 504 (insert "\n") | |
| 505 (setq doc-end (point)))) | |
| 506 ((eq escape ?v) | |
| 507 (if (and button-begin (not button-end)) | |
| 508 (widget-apply widget :value-create) | |
| 509 (setq value-pos (point)))) | |
| 510 (t | |
| 511 (widget-apply widget :format-handler escape))))) | |
| 512 ;; Specify button and doc, and insert value. | |
| 513 (and button-begin button-end | |
| 514 (widget-specify-button widget button-begin button-end)) | |
| 515 (and doc-begin doc-end | |
| 516 (widget-specify-doc widget doc-begin doc-end)) | |
| 517 (when value-pos | |
| 518 (goto-char value-pos) | |
| 519 (widget-apply widget :value-create))) | |
| 520 (let ((from (copy-marker (point-min))) | |
| 521 (to (copy-marker (point-max)))) | |
| 522 (widget-specify-text from to) | |
| 523 (set-marker-insertion-type from t) | |
| 524 (set-marker-insertion-type to nil) | |
| 525 (widget-put widget :from from) | |
| 526 (widget-put widget :to to)))) | |
| 527 | |
| 528 (defun widget-default-format-handler (widget escape) | |
| 529 ;; By default unknown escapes are errors. | |
| 530 (error "Unknown escape `%c'" escape)) | |
| 531 | |
| 532 (defun widget-default-delete (widget) | |
| 533 ;; Remove widget from the buffer. | |
| 534 (let ((from (widget-get widget :from)) | |
| 535 (to (widget-get widget :to)) | |
| 536 (inhibit-read-only t) | |
| 537 after-change-functions) | |
| 538 (widget-apply widget :value-delete) | |
| 539 (delete-region from to) | |
| 540 (set-marker from nil) | |
| 541 (set-marker to nil))) | |
| 542 | |
| 543 (defun widget-default-value-set (widget value) | |
| 544 ;; Recreate widget with new value. | |
| 545 (save-excursion | |
| 546 (goto-char (widget-get widget :from)) | |
| 547 (widget-apply widget :delete) | |
| 548 (widget-put widget :value value) | |
| 549 (widget-apply widget :create))) | |
| 550 | |
| 551 (defun widget-default-value-inline (widget) | |
| 552 ;; Wrap value in a list unless it is inline. | |
| 553 (if (widget-get widget :inline) | |
| 554 (widget-value widget) | |
| 555 (list (widget-value widget)))) | |
| 556 | |
| 557 (defun widget-default-menu-tag-get (widget) | |
| 558 ;; Use tag or value for menus. | |
| 559 (or (widget-get widget :menu-tag) | |
| 560 (widget-get widget :tag) | |
| 561 (widget-princ-to-string (widget-get widget :value)))) | |
| 562 | |
| 563 (defun widget-default-action (widget &optional event) | |
| 564 ;; Notify the parent when a widget change | |
| 565 (let ((parent (widget-get widget :parent))) | |
| 566 (when parent | |
| 567 (widget-apply parent :notify widget event)))) | |
| 568 | |
| 569 (defun widget-default-notify (widget child &optional event) | |
| 570 ;; Pass notification to parent. | |
| 571 (widget-default-action widget event)) | |
| 572 | |
| 573 ;;; The `item' Widget. | |
| 574 | |
| 575 (define-widget 'item 'default | |
| 576 "Constant items for inclusion in other widgets." | |
| 577 :convert-widget 'widget-item-convert-widget | |
| 578 :value-create 'widget-item-value-create | |
| 579 :value-delete 'ignore | |
| 580 :value-get 'widget-item-value-get | |
| 581 :match 'widget-item-match | |
| 582 :match-inline 'widget-item-match-inline | |
| 583 :action 'widget-item-action | |
| 584 :format "%t\n") | |
| 585 | |
| 586 (defun widget-item-convert-widget (widget) | |
| 587 ;; Initialize :value and :tag from :args in WIDGET. | |
| 588 (let ((args (widget-get widget :args))) | |
| 589 (when args | |
| 590 (widget-put widget :value (car args)) | |
| 591 (widget-put widget :args nil))) | |
| 592 widget) | |
| 593 | |
| 594 (defun widget-item-value-create (widget) | |
| 595 ;; Insert the printed representation of the value. | |
| 596 (let ((standard-output (current-buffer))) | |
| 597 (princ (widget-get widget :value)))) | |
| 598 | |
| 599 (defun widget-item-match (widget value) | |
| 600 ;; Match if the value is the same. | |
| 601 (equal (widget-get widget :value) value)) | |
| 602 | |
| 603 (defun widget-item-match-inline (widget values) | |
| 604 ;; Match if the value is the same. | |
| 605 (let ((value (widget-get widget :value))) | |
| 606 (and (listp value) | |
| 607 (<= (length value) (length values)) | |
| 608 (let ((head (subseq values 0 (length value)))) | |
| 609 (and (equal head value) | |
| 610 (cons head (subseq values (length value)))))))) | |
| 611 | |
| 612 (defun widget-item-action (widget &optional event) | |
| 613 ;; Just notify itself. | |
| 614 (widget-apply widget :notify widget event)) | |
| 615 | |
| 616 (defun widget-item-value-get (widget) | |
| 617 ;; Items are simple. | |
| 618 (widget-get widget :value)) | |
| 619 | |
| 620 ;;; The `push' Widget. | |
| 621 | |
| 622 (define-widget 'push 'item | |
| 623 "A pushable button." | |
| 624 :format "%[[%t]%]") | |
| 625 | |
| 626 ;;; The `link' Widget. | |
| 627 | |
| 628 (define-widget 'link 'item | |
| 629 "An embedded link." | |
| 630 :format "%[_%t_%]") | |
| 631 | |
| 632 ;;; The `field' Widget. | |
| 633 | |
| 634 (define-widget 'field 'default | |
| 635 "An editable text field." | |
| 636 :convert-widget 'widget-item-convert-widget | |
| 637 :format "%v" | |
| 638 :value "" | |
| 639 :tag "field" | |
| 640 :value-create 'widget-field-value-create | |
| 641 :value-delete 'widget-field-value-delete | |
| 642 :value-get 'widget-field-value-get | |
| 643 :match 'widget-field-match) | |
| 644 | |
| 645 (defun widget-field-value-create (widget) | |
| 646 ;; Create an editable text field. | |
| 647 (insert " ") | |
| 648 (let ((size (widget-get widget :size)) | |
| 649 (value (widget-get widget :value)) | |
| 650 (from (point))) | |
| 651 (if (null size) | |
| 652 (insert value) | |
| 653 (insert value) | |
| 654 (if (< (length value) size) | |
| 655 (insert-char ?\ (- size (length value))))) | |
| 656 (unless (memq widget widget-field-list) | |
| 657 (setq widget-field-new (cons widget widget-field-new))) | |
| 658 (widget-put widget :value-from (copy-marker from)) | |
| 659 (set-marker-insertion-type (widget-get widget :value-from) t) | |
| 660 (widget-put widget :value-to (copy-marker (point))) | |
| 661 (set-marker-insertion-type (widget-get widget :value-to) nil) | |
| 662 (if (null size) | |
| 663 (insert ?\n) | |
| 664 (insert ?\ )))) | |
| 665 | |
| 666 (defun widget-field-value-delete (widget) | |
| 667 ;; Remove the widget from the list of active editing fields. | |
| 668 (setq widget-field-list (delq widget widget-field-list)) | |
| 669 (set-marker (widget-get widget :value-from) nil) | |
| 670 (set-marker (widget-get widget :value-to) nil)) | |
| 671 | |
| 672 (defun widget-field-value-get (widget) | |
| 673 ;; Return current text in editing field. | |
| 674 (let ((from (widget-get widget :value-from)) | |
| 675 (to (widget-get widget :value-to))) | |
| 676 (if (and from to) | |
| 677 (progn | |
| 678 (setq from (1+ from) | |
| 679 to (1- to)) | |
| 680 (while (and (> to from) | |
| 681 (eq (char-after (1- to)) ?\ )) | |
| 682 (setq to (1- to))) | |
| 683 (buffer-substring-no-properties from to)) | |
| 684 (widget-get widget :value)))) | |
| 685 | |
| 686 (defun widget-field-match (widget value) | |
| 687 ;; Match any string. | |
| 688 (stringp value)) | |
| 689 | |
| 690 ;;; The `choice' Widget. | |
| 691 | |
| 692 (define-widget 'choice 'default | |
| 693 "A menu of options." | |
| 694 :convert-widget 'widget-choice-convert-widget | |
| 695 :format "%[%t%]: %v" | |
| 696 :tag "choice" | |
| 697 :inline t | |
| 698 :void '(item "void") | |
| 699 :value-create 'widget-choice-value-create | |
| 700 :value-delete 'widget-radio-value-delete | |
| 701 :value-get 'widget-choice-value-get | |
| 702 :value-inline 'widget-choice-value-inline | |
| 703 :action 'widget-choice-action | |
| 704 :error "Make a choice" | |
| 705 :validate 'widget-choice-validate | |
| 706 :match 'widget-choice-match | |
| 707 :match-inline 'widget-choice-match-inline) | |
| 708 | |
| 709 (defun widget-choice-convert-widget (widget) | |
| 710 ;; Expand type args into widget objects. | |
| 711 (widget-put widget :args (mapcar 'widget-convert (widget-get widget :args))) | |
| 712 widget) | |
| 713 | |
| 714 (defun widget-choice-value-create (widget) | |
| 715 ;; Insert the first choice that matches the value. | |
| 716 (let ((value (widget-get widget :value)) | |
| 717 (args (widget-get widget :args)) | |
| 718 current) | |
| 719 (while args | |
| 720 (setq current (car args) | |
| 721 args (cdr args)) | |
| 722 (when (widget-apply current :match value) | |
| 723 (widget-put widget :children (list (widget-create current | |
| 724 :parent widget | |
| 725 :value value))) | |
| 726 (widget-put widget :choice current) | |
| 727 (setq args nil | |
| 728 current nil))) | |
| 729 (when current | |
| 730 (let ((void (widget-get widget :void))) | |
| 731 (widget-put widget :children (list (widget-create void | |
| 732 :parent widget | |
| 733 :value value))) | |
| 734 (widget-put widget :choice void))))) | |
| 735 | |
| 736 (defun widget-choice-value-get (widget) | |
| 737 ;; Get value of the child widget. | |
| 738 (widget-value (car (widget-get widget :children)))) | |
| 739 | |
| 740 (defun widget-choice-value-inline (widget) | |
| 741 ;; Get value of the child widget. | |
| 742 (widget-apply (car (widget-get widget :children)) :value-inline)) | |
| 743 | |
| 744 (defun widget-choice-action (widget &optional event) | |
| 745 ;; Make a choice. | |
| 746 (let ((args (widget-get widget :args)) | |
| 747 (old (widget-get widget :choice)) | |
| 748 (tag (widget-apply widget :menu-tag-get)) | |
| 749 current choices) | |
| 750 (setq current | |
| 751 (cond ((= (length args) 0) | |
| 752 nil) | |
| 753 ((= (length args) 1) | |
| 754 (nth 0 args)) | |
| 755 ((and (= (length args) 2) | |
| 756 (memq old args)) | |
| 757 (if (eq old (nth 0 args)) | |
| 758 (nth 1 args) | |
| 759 (nth 0 args))) | |
| 760 (t | |
| 761 (while args | |
| 762 (setq current (car args) | |
| 763 args (cdr args)) | |
| 764 (setq choices | |
| 765 (cons (cons (widget-apply current :menu-tag-get) | |
| 766 current) | |
| 767 choices))) | |
| 768 (cond | |
| 769 ((and event (fboundp 'x-popup-menu) window-system) | |
| 770 ;; We are in Emacs-19, pressed by the mouse | |
| 771 (x-popup-menu event | |
| 772 (list tag (cons "" (reverse choices))))) | |
| 773 ((and event (fboundp 'popup-menu) window-system) | |
| 774 ;; We are in XEmacs, pressed by the mouse | |
| 775 (let ((val (get-popup-menu-response | |
| 776 (cons "" | |
| 777 (mapcar | |
| 778 (function | |
| 779 (lambda (x) | |
| 780 (vector (car x) (list (car x)) t))) | |
| 781 (reverse choices)))))) | |
| 782 (setq val (and val | |
| 783 (listp (event-object val)) | |
| 784 (stringp (car-safe (event-object val))) | |
| 785 (car (event-object val)))) | |
| 786 (cdr (assoc val choices)))) | |
| 787 (t | |
| 788 (cdr (assoc (completing-read (concat tag ": ") | |
| 789 choices nil t) | |
| 790 choices))))))) | |
| 791 (when current | |
| 792 (widget-value-set widget (widget-value current)) | |
| 793 (widget-setup))) | |
| 794 ;; Notify parent. | |
| 795 (widget-apply widget :notify widget event) | |
| 796 (widget-clear-undo)) | |
| 797 | |
| 798 (defun widget-choice-validate (widget) | |
| 799 ;; Valid if we have made a valid choice. | |
| 800 (let ((void (widget-get widget :void)) | |
| 801 (choice (widget-get widget :choice)) | |
| 802 (child (car (widget-get widget :children)))) | |
| 803 (if (eq void choice) | |
| 804 widget | |
| 805 (widget-apply child :validate)))) | |
| 806 | |
| 807 (defun widget-choice-match (widget value) | |
| 808 ;; Matches if one of the choices matches. | |
| 809 (let ((args (widget-get widget :args)) | |
| 810 current found) | |
| 811 (while (and args (not found)) | |
| 812 (setq current (car args) | |
| 813 args (cdr args) | |
| 814 found (widget-apply current :match value))) | |
| 815 found)) | |
| 816 | |
| 817 (defun widget-choice-match-inline (widget values) | |
| 818 ;; Matches if one of the choices matches. | |
| 819 (let ((args (widget-get widget :args)) | |
| 820 current found) | |
| 821 (while (and args (null found)) | |
| 822 (setq current (car args) | |
| 823 args (cdr args) | |
| 824 found (widget-match-inline current values))) | |
| 825 found)) | |
| 826 | |
| 827 ;;; The `toggle' Widget. | |
| 828 | |
| 829 (define-widget 'toggle 'choice | |
| 830 "Toggle between two states." | |
| 831 :convert-widget 'widget-toggle-convert-widget | |
| 832 :format "%[%v%]" | |
| 833 :on "on" | |
| 834 :off "off") | |
| 835 | |
| 836 (defun widget-toggle-convert-widget (widget) | |
| 837 ;; Create the types representing the `on' and `off' states. | |
| 838 (let ((args (widget-get widget :args)) | |
| 839 (on-type (widget-get widget :on-type)) | |
| 840 (off-type (widget-get widget :off-type))) | |
| 841 (unless on-type | |
| 842 (setq on-type (list 'item :value t :tag (widget-get widget :on)))) | |
| 843 (unless off-type | |
| 844 (setq off-type (list 'item :value nil :tag (widget-get widget :off)))) | |
| 845 (widget-put widget :args (list on-type off-type))) | |
| 846 widget) | |
| 847 | |
| 848 ;;; The `checkbox' Widget. | |
| 849 | |
| 850 (define-widget 'checkbox 'toggle | |
| 851 "A checkbox toggle." | |
| 852 :convert-widget 'widget-item-convert-widget | |
| 853 :on-type '(item :format "[X]" t) | |
| 854 :off-type '(item :format "[ ]" nil)) | |
| 855 | |
| 856 ;;; The `checklist' Widget. | |
| 857 | |
| 858 (define-widget 'checklist 'default | |
| 859 "A multiple choice widget." | |
| 860 :convert-widget 'widget-choice-convert-widget | |
| 861 :format "%v" | |
| 862 :entry-format "%b %v" | |
| 863 :menu-tag "checklist" | |
| 864 :value-create 'widget-checklist-value-create | |
| 865 :value-delete 'widget-radio-value-delete | |
| 866 :value-get 'widget-checklist-value-get | |
| 867 :validate 'widget-checklist-validate | |
| 868 :match 'widget-checklist-match | |
| 869 :match-inline 'widget-checklist-match-inline) | |
| 870 | |
| 871 (defun widget-checklist-value-create (widget) | |
| 872 ;; Insert all values | |
| 873 (let ((alist (widget-checklist-match-find widget (widget-get widget :value))) | |
| 874 (args (widget-get widget :args))) | |
| 875 (while args | |
| 876 (widget-checklist-add-item widget (car args) (assq (car args) alist)) | |
| 877 (setq args (cdr args))) | |
| 878 (widget-put widget :children (nreverse (widget-get widget :children))))) | |
| 879 | |
| 880 (defun widget-checklist-add-item (widget type chosen) | |
| 881 ;; Create checklist item in WIDGET of type TYPE. | |
| 882 ;; If the item is checked, CHOSEN is a cons whose cdr is the value. | |
| 883 (widget-specify-insert | |
| 884 (let* ((children (widget-get widget :children)) | |
| 885 (buttons (widget-get widget :buttons)) | |
| 886 (from (point)) | |
| 887 child button) | |
| 888 (insert (widget-get widget :entry-format)) | |
| 889 (goto-char from) | |
| 890 ;; Parse % escapes in format. | |
| 891 (while (re-search-forward "%\\([bv%]\\)" nil t) | |
| 892 (let ((escape (aref (match-string 1) 0))) | |
| 893 (replace-match "" t t) | |
| 894 (cond ((eq escape ?%) | |
| 895 (insert "%")) | |
| 896 ((eq escape ?b) | |
| 897 (setq button (widget-create 'checkbox | |
| 898 :parent widget | |
| 899 :value (not (null chosen))))) | |
| 900 ((eq escape ?v) | |
| 901 (setq child | |
| 902 (cond ((not chosen) | |
| 903 (widget-create type :parent widget)) | |
| 904 ((widget-get type :inline) | |
| 905 (widget-create type | |
| 906 :parent widget | |
| 907 :value (cdr chosen))) | |
| 908 (t | |
| 909 (widget-create type | |
| 910 :parent widget | |
| 911 :value (car (cdr chosen))))))) | |
| 912 (t | |
| 913 (error "Unknown escape `%c'" escape))))) | |
| 914 ;; Update properties. | |
| 915 (and button child (widget-put child :button button)) | |
| 916 (and button (widget-put widget :buttons (cons button buttons))) | |
| 917 (and child (widget-put widget :children (cons child children)))))) | |
| 918 | |
| 919 (defun widget-checklist-match (widget values) | |
| 920 ;; All values must match a type in the checklist. | |
| 921 (and (listp values) | |
| 922 (null (cdr (widget-checklist-match-inline widget values))))) | |
| 923 | |
| 924 (defun widget-checklist-match-inline (widget values) | |
| 925 ;; Find the values which match a type in the checklist. | |
| 926 (let ((greedy (widget-get widget :greedy)) | |
| 927 (args (copy-list (widget-get widget :args))) | |
| 928 found rest) | |
| 929 (while values | |
| 930 (let ((answer (widget-checklist-match-up args values))) | |
| 931 (cond (answer | |
| 932 (let ((vals (widget-match-inline answer values))) | |
| 933 (setq found (append found (car vals)) | |
| 934 values (cdr vals) | |
| 935 args (delq answer args)))) | |
| 936 (greedy | |
| 937 (setq rest (append rest (list (car values))) | |
| 938 values (cdr values))) | |
| 939 (t | |
| 940 (setq rest (append rest values) | |
| 941 values nil))))) | |
| 942 (cons found rest))) | |
| 943 | |
| 944 (defun widget-checklist-match-find (widget values) | |
| 945 ;; Find the values which match a type in the checklist. | |
| 946 ;; Return an alist of (TYPE MATCH). | |
| 947 (let ((greedy (widget-get widget :greedy)) | |
| 948 (args (copy-list (widget-get widget :args))) | |
| 949 found) | |
| 950 (while values | |
| 951 (let ((answer (widget-checklist-match-up args values))) | |
| 952 (cond (answer | |
| 953 (let ((vals (widget-match-inline answer values))) | |
| 954 (setq found (cons (cons answer (car vals)) found) | |
| 955 values (cdr vals) | |
| 956 args (delq answer args)))) | |
| 957 (greedy | |
| 958 (setq values (cdr values))) | |
| 959 (t | |
| 960 (setq values nil))))) | |
| 961 found)) | |
| 962 | |
| 963 (defun widget-checklist-match-up (args values) | |
| 964 ;; Rerturn the first type from ARGS that matches VALUES. | |
| 965 (let (current found) | |
| 966 (while (and args (null found)) | |
| 967 (setq current (car args) | |
| 968 args (cdr args) | |
| 969 found (widget-match-inline current values))) | |
| 970 (and found current))) | |
| 971 | |
| 972 (defun widget-checklist-value-get (widget) | |
| 973 ;; The values of all selected items. | |
| 974 (let ((children (widget-get widget :children)) | |
| 975 child result) | |
| 976 (while children | |
| 977 (setq child (car children) | |
| 978 children (cdr children)) | |
| 979 (if (widget-value (widget-get child :button)) | |
| 980 (setq result (append result (widget-apply child :value-inline))))) | |
| 981 result)) | |
| 982 | |
| 983 (defun widget-checklist-validate (widget) | |
| 984 ;; Ticked chilren must be valid. | |
| 985 (let ((children (widget-get widget :children)) | |
| 986 child button found) | |
| 987 (while (and children (not found)) | |
| 988 (setq child (car children) | |
| 989 children (cdr children) | |
| 990 button (widget-get child :button) | |
| 991 found (and (widget-value button) | |
| 992 (widget-apply child :validate)))) | |
| 993 found)) | |
| 994 | |
| 995 ;;; The `option' Widget | |
| 996 | |
| 997 (define-widget 'option 'checklist | |
| 998 "An widget with an optional item." | |
| 999 :inline t) | |
| 1000 | |
| 1001 ;;; The `choice-item' Widget. | |
| 1002 | |
| 1003 (define-widget 'choice-item 'item | |
| 1004 "Button items that delegate action events to their parents." | |
| 1005 :action 'widget-choice-item-action | |
| 1006 :format "%[%t%]\n") | |
| 1007 | |
| 1008 (defun widget-choice-item-action (widget &optional event) | |
| 1009 ;; Tell parent what happened. | |
| 1010 (widget-apply (widget-get widget :parent) :action event)) | |
| 1011 | |
| 1012 ;;; The `radio-button' Widget. | |
| 1013 | |
| 1014 (define-widget 'radio-button 'toggle | |
| 1015 "A radio button for use in the `radio' widget." | |
| 1016 :format "%v" | |
| 1017 :notify 'widget-radio-button-notify | |
| 1018 :on-type '(choice-item :format "%[(*)%]" t) | |
| 1019 :off-type '(choice-item :format "%[( )%]" nil)) | |
| 1020 | |
| 1021 (defun widget-radio-button-notify (widget child &optional event) | |
| 1022 ;; Notify the parent. | |
| 1023 (widget-apply (widget-get widget :parent) :action widget event)) | |
| 1024 | |
| 1025 ;;; The `radio' Widget. | |
| 1026 | |
| 1027 (define-widget 'radio 'default | |
| 1028 "Select one of multiple options." | |
| 1029 :convert-widget 'widget-choice-convert-widget | |
| 1030 :format "%v" | |
| 1031 :entry-format "%b %v" | |
| 1032 :menu-tag "radio" | |
| 1033 :value-create 'widget-radio-value-create | |
| 1034 :value-delete 'widget-radio-value-delete | |
| 1035 :value-get 'widget-radio-value-get | |
| 1036 :value-inline 'widget-radio-value-inline | |
| 1037 :value-set 'widget-radio-value-set | |
| 1038 :error "You must push one of the buttons" | |
| 1039 :validate 'widget-radio-validate | |
| 1040 :match 'widget-choice-match | |
| 1041 :match-inline 'widget-choice-match-inline | |
| 1042 :action 'widget-radio-action) | |
| 1043 | |
| 1044 (defun widget-radio-value-create (widget) | |
| 1045 ;; Insert all values | |
| 1046 (let ((args (widget-get widget :args)) | |
| 1047 (indent (widget-get widget :indent)) | |
| 1048 arg) | |
| 1049 (while args | |
| 1050 (setq arg (car args) | |
| 1051 args (cdr args)) | |
| 1052 (widget-radio-add-item widget arg) | |
| 1053 (and indent args (insert-char ?\ indent))))) | |
| 1054 | |
| 1055 (defun widget-radio-add-item (widget type) | |
| 1056 "Add to radio widget WIDGET a new radio button item of type TYPE." | |
| 1057 (setq type (widget-convert type)) | |
| 1058 (widget-specify-insert | |
| 1059 (let* ((value (widget-get widget :value)) | |
| 1060 (children (widget-get widget :children)) | |
| 1061 (buttons (widget-get widget :buttons)) | |
| 1062 (from (point)) | |
| 1063 (chosen (and (null (widget-get widget :choice)) | |
| 1064 (widget-apply type :match value))) | |
| 1065 child button) | |
| 1066 (insert (widget-get widget :entry-format)) | |
| 1067 (goto-char from) | |
| 1068 ;; Parse % escapes in format. | |
| 1069 (while (re-search-forward "%\\([bv%]\\)" nil t) | |
| 1070 (let ((escape (aref (match-string 1) 0))) | |
| 1071 (replace-match "" t t) | |
| 1072 (cond ((eq escape ?%) | |
| 1073 (insert "%")) | |
| 1074 ((eq escape ?b) | |
| 1075 (setq button (widget-create 'radio-button | |
| 1076 :parent widget | |
| 1077 :value (not (null chosen))))) | |
| 1078 ((eq escape ?v) | |
| 1079 (setq child (if chosen | |
| 1080 (widget-create type | |
| 1081 :parent widget | |
| 1082 :value value) | |
| 1083 (widget-create type :parent widget)))) | |
| 1084 (t | |
| 1085 (error "Unknown escape `%c'" escape))))) | |
| 1086 ;; Update properties. | |
| 1087 (when chosen | |
| 1088 (widget-put widget :choice type)) | |
| 1089 (when button | |
| 1090 (widget-put child :button button) | |
| 1091 (widget-put widget :buttons (nconc buttons (list button)))) | |
| 1092 (when child | |
| 1093 (widget-put widget :children (nconc children (list child)))) | |
| 1094 child))) | |
| 1095 | |
| 1096 (defun widget-radio-value-delete (widget) | |
| 1097 ;; Delete the child widgets. | |
| 1098 (mapcar 'widget-delete (widget-get widget :children)) | |
| 1099 (widget-put widget :children nil) | |
| 1100 (mapcar 'widget-delete (widget-get widget :buttons)) | |
| 1101 (widget-put widget :buttons nil)) | |
| 1102 | |
| 1103 (defun widget-radio-value-get (widget) | |
| 1104 ;; Get value of the child widget. | |
| 1105 (let ((chosen (widget-radio-chosen widget))) | |
| 1106 (and chosen (widget-value chosen)))) | |
| 1107 | |
| 1108 (defun widget-radio-chosen (widget) | |
| 1109 "Return the widget representing the chosen radio button." | |
| 1110 (let ((children (widget-get widget :children)) | |
| 1111 current found) | |
| 1112 (while children | |
| 1113 (setq current (car children) | |
| 1114 children (cdr children)) | |
| 1115 (let* ((button (widget-get current :button)) | |
| 1116 (value (widget-apply button :value-get))) | |
| 1117 (when value | |
| 1118 (setq found current | |
| 1119 children nil)))) | |
| 1120 found)) | |
| 1121 | |
| 1122 (defun widget-radio-value-inline (widget) | |
| 1123 ;; Get value of the child widget. | |
| 1124 (let ((children (widget-get widget :children)) | |
| 1125 current found) | |
| 1126 (while children | |
| 1127 (setq current (car children) | |
| 1128 children (cdr children)) | |
| 1129 (let* ((button (widget-get current :button)) | |
| 1130 (value (widget-apply button :value-get))) | |
| 1131 (when value | |
| 1132 (setq found (widget-apply current :value-inline) | |
| 1133 children nil)))) | |
| 1134 found)) | |
| 1135 | |
| 1136 (defun widget-radio-value-set (widget value) | |
| 1137 ;; We can't just delete and recreate a radio widget, since children | |
| 1138 ;; can be added after the original creation and won't be recreated | |
| 1139 ;; by `:create'. | |
| 1140 (let ((children (widget-get widget :children)) | |
| 1141 current found) | |
| 1142 (while children | |
| 1143 (setq current (car children) | |
| 1144 children (cdr children)) | |
| 1145 (let* ((button (widget-get current :button)) | |
| 1146 (match (and (not found) | |
| 1147 (widget-apply current :match value)))) | |
| 1148 (widget-value-set button match) | |
| 1149 (if match | |
| 1150 (widget-value-set current value)) | |
| 1151 (setq found (or found match)))))) | |
| 1152 | |
| 1153 (defun widget-radio-validate (widget) | |
| 1154 ;; Valid if we have made a valid choice. | |
| 1155 (let ((children (widget-get widget :children)) | |
| 1156 current found button) | |
| 1157 (while (and children (not found)) | |
| 1158 (setq current (car children) | |
| 1159 children (cdr children) | |
| 1160 button (widget-get current :button) | |
| 1161 found (widget-apply button :value-get))) | |
| 1162 (if found | |
| 1163 (widget-apply current :validate) | |
| 1164 widget))) | |
| 1165 | |
| 1166 (defun widget-radio-action (widget child event) | |
| 1167 ;; Check if a radio button was pressed. | |
| 1168 (let ((children (widget-get widget :children)) | |
| 1169 (buttons (widget-get widget :buttons)) | |
| 1170 current) | |
| 1171 (when (memq child buttons) | |
| 1172 (while children | |
| 1173 (setq current (car children) | |
| 1174 children (cdr children)) | |
| 1175 (let* ((button (widget-get current :button))) | |
| 1176 (cond ((eq child button) | |
| 1177 (widget-value-set button t)) | |
| 1178 ((widget-value button) | |
| 1179 (widget-value-set button nil))))))) | |
| 1180 ;; Pass notification to parent. | |
| 1181 (widget-apply widget :notify child event)) | |
| 1182 | |
| 1183 ;;; The `insert-button' Widget. | |
| 1184 | |
| 1185 (define-widget 'insert-button 'push | |
| 1186 "An insert button for the `repeat' widget." | |
| 1187 :tag "INS" | |
| 1188 :action 'widget-insert-button-action) | |
| 1189 | |
| 1190 (defun widget-insert-button-action (widget &optional event) | |
| 1191 ;; Ask the parent to insert a new item. | |
| 1192 (widget-apply (widget-get widget :parent) | |
| 1193 :insert-before (widget-get widget :widget))) | |
| 1194 | |
| 1195 ;;; The `delete-button' Widget. | |
| 1196 | |
| 1197 (define-widget 'delete-button 'push | |
| 1198 "A delete button for the `repeat' widget." | |
| 1199 :tag "DEL" | |
| 1200 :action 'widget-delete-button-action) | |
| 1201 | |
| 1202 (defun widget-delete-button-action (widget &optional event) | |
| 1203 ;; Ask the parent to insert a new item. | |
| 1204 (widget-apply (widget-get widget :parent) | |
| 1205 :delete-at (widget-get widget :widget))) | |
| 1206 | |
| 1207 ;;; The `repeat' Widget. | |
| 1208 | |
| 1209 (define-widget 'repeat 'default | |
| 1210 "A variable list of widgets of the same type." | |
| 1211 :convert-widget 'widget-choice-convert-widget | |
| 1212 :format "%v%i\n" | |
| 1213 :format-handler 'widget-repeat-format-handler | |
| 1214 :entry-format "%i %d %v" | |
| 1215 :menu-tag "repeat" | |
| 1216 :value-create 'widget-repeat-value-create | |
| 1217 :value-delete 'widget-radio-value-delete | |
| 1218 :value-get 'widget-repeat-value-get | |
| 1219 :validate 'widget-repeat-validate | |
| 1220 :match 'widget-repeat-match | |
| 1221 :match-inline 'widget-repeat-match-inline | |
| 1222 :insert-before 'widget-repeat-insert-before | |
| 1223 :delete-at 'widget-repeat-delete-at) | |
| 1224 | |
| 1225 (defun widget-repeat-format-handler (widget escape) | |
| 1226 ;; We recognize the insert button. | |
| 1227 (cond ((eq escape ?i) | |
| 1228 (insert " ") | |
| 1229 (backward-char 1) | |
| 1230 (let* ((from (point)) | |
| 1231 (button (widget-create (list 'insert-button | |
| 1232 :parent widget)))) | |
| 1233 (widget-specify-button button from (point))) | |
| 1234 (forward-char 1)) | |
| 1235 (t | |
| 1236 (widget-default-format-handler widget escape)))) | |
| 1237 | |
| 1238 (defun widget-repeat-value-create (widget) | |
| 1239 ;; Insert all values | |
| 1240 (let* ((value (widget-get widget :value)) | |
| 1241 (type (nth 0 (widget-get widget :args))) | |
| 1242 (inlinep (widget-get type :inline)) | |
| 1243 children) | |
| 1244 (widget-put widget :value-pos (copy-marker (point))) | |
| 1245 (set-marker-insertion-type (widget-get widget :value-pos) t) | |
| 1246 (while value | |
| 1247 (let ((answer (widget-match-inline type value))) | |
| 1248 (if answer | |
| 1249 (setq children (cons (widget-repeat-entry-create | |
| 1250 widget (if inlinep | |
| 1251 (car answer) | |
| 1252 (car (car answer)))) | |
| 1253 children) | |
| 1254 value (cdr answer)) | |
| 1255 (setq value nil)))) | |
| 1256 (widget-put widget :children (nreverse children)))) | |
| 1257 | |
| 1258 (defun widget-repeat-value-get (widget) | |
| 1259 ;; Get value of the child widget. | |
| 1260 (apply 'append (mapcar (lambda (child) (widget-apply child :value-inline)) | |
| 1261 (widget-get widget :children)))) | |
| 1262 | |
| 1263 (defun widget-repeat-validate (widget) | |
| 1264 ;; All the chilren must be valid. | |
| 1265 (let ((children (widget-get widget :children)) | |
| 1266 child found) | |
| 1267 (while (and children (not found)) | |
| 1268 (setq child (car children) | |
| 1269 children (cdr children) | |
| 1270 found (widget-apply child :validate))) | |
| 1271 found)) | |
| 1272 | |
| 1273 (defun widget-repeat-match (widget value) | |
| 1274 ;; Value must be a list and all the members must match the repeat type. | |
| 1275 (and (listp value) | |
| 1276 (null (cdr (widget-repeat-match-inline widget value))))) | |
| 1277 | |
| 1278 (defun widget-repeat-match-inline (widget value) | |
| 1279 (let ((type (nth 0 (widget-get widget :args))) | |
| 1280 (ok t) | |
| 1281 found) | |
| 1282 (while (and value ok) | |
| 1283 (let ((answer (widget-match-inline type value))) | |
| 1284 (if answer | |
| 1285 (setq found (append found (car answer)) | |
| 1286 value (cdr answer)) | |
| 1287 (setq ok nil)))) | |
| 1288 (cons found value))) | |
| 1289 | |
| 1290 (defun widget-repeat-insert-before (widget before) | |
| 1291 ;; Insert a new child in the list of children. | |
| 1292 (save-excursion | |
| 1293 (let ((children (widget-get widget :children)) | |
| 1294 (inhibit-read-only t) | |
| 1295 after-change-functions) | |
| 1296 (cond (before | |
| 1297 (goto-char (widget-get before :from))) | |
| 1298 (t | |
| 1299 (goto-char (widget-get widget :value-pos)))) | |
| 1300 (let ((child (widget-repeat-entry-create | |
| 1301 widget (widget-get (nth 0 (widget-get widget :args)) | |
| 1302 :value)))) | |
| 1303 (widget-specify-text (widget-get child :from) | |
| 1304 (widget-get child :to)) | |
| 1305 (if (eq (car children) before) | |
| 1306 (widget-put widget :children (cons child children)) | |
| 1307 (while (not (eq (car (cdr children)) before)) | |
| 1308 (setq children (cdr children))) | |
| 1309 (setcdr children (cons child (cdr children))))))) | |
| 1310 (widget-setup) | |
| 1311 (widget-apply widget :notify widget)) | |
| 1312 | |
| 1313 (defun widget-repeat-delete-at (widget child) | |
| 1314 ;; Delete child from list of children. | |
| 1315 (save-excursion | |
| 1316 (let ((buttons (copy-list (widget-get widget :buttons))) | |
| 1317 button | |
| 1318 (inhibit-read-only t) | |
| 1319 after-change-functions) | |
| 1320 (while buttons | |
| 1321 (setq button (car buttons) | |
| 1322 buttons (cdr buttons)) | |
| 1323 (when (eq (widget-get button :widget) child) | |
| 1324 (widget-put widget | |
| 1325 :buttons (delq button (widget-get widget :buttons))) | |
| 1326 (widget-delete button)))) | |
| 1327 (widget-delete child) | |
| 1328 (widget-put widget :children (delq child (widget-get widget :children)))) | |
| 1329 (widget-setup) | |
| 1330 (widget-apply widget :notify widget)) | |
| 1331 | |
| 1332 (defun widget-repeat-entry-create (widget value) | |
| 1333 ;; Create a new entry to the list. | |
| 1334 (let ((type (nth 0 (widget-get widget :args))) | |
| 1335 (indent (widget-get widget :indent)) | |
| 1336 child delete insert) | |
| 1337 (widget-specify-insert | |
| 1338 (save-excursion | |
| 1339 (insert (widget-get widget :entry-format)) | |
| 1340 (if indent | |
| 1341 (insert-char ?\ indent))) | |
| 1342 ;; Parse % escapes in format. | |
| 1343 (while (re-search-forward "%\\(.\\)" nil t) | |
| 1344 (let ((escape (aref (match-string 1) 0))) | |
| 1345 (replace-match "" t t) | |
| 1346 (cond ((eq escape ?%) | |
| 1347 (insert "%")) | |
| 1348 ((eq escape ?i) | |
| 1349 (setq insert (widget-create 'insert-button | |
| 1350 :parent widget))) | |
| 1351 ((eq escape ?d) | |
| 1352 (setq delete (widget-create 'delete-button | |
| 1353 :parent widget))) | |
| 1354 ((eq escape ?v) | |
| 1355 (setq child (widget-create type | |
| 1356 :parent widget | |
| 1357 :value value))) | |
| 1358 (t | |
| 1359 (error "Unknown escape `%c'" escape))))) | |
| 1360 (widget-put widget | |
| 1361 :buttons (cons delete | |
| 1362 (cons insert | |
| 1363 (widget-get widget :buttons)))) | |
| 1364 (move-marker (widget-get child :from) (point-min)) | |
| 1365 (move-marker (widget-get child :to) (point-max))) | |
| 1366 (widget-put insert :widget child) | |
| 1367 (widget-put delete :widget child) | |
| 1368 child)) | |
| 1369 | |
| 1370 ;;; The `group' Widget. | |
| 1371 | |
| 1372 (define-widget 'group 'default | |
| 1373 "A widget which group other widgets inside." | |
| 1374 :convert-widget 'widget-choice-convert-widget | |
| 1375 :format "%v" | |
| 1376 :value-create 'widget-group-value-create | |
| 1377 :value-delete 'widget-radio-value-delete | |
| 1378 :value-get 'widget-repeat-value-get | |
| 1379 :validate 'widget-repeat-validate | |
| 1380 :match 'widget-group-match | |
| 1381 :match-inline 'widget-group-match-inline) | |
| 1382 | |
| 1383 (defun widget-group-value-create (widget) | |
| 1384 ;; Create each component. | |
| 1385 (let ((args (widget-get widget :args)) | |
| 1386 (value (widget-get widget :value)) | |
| 1387 (indent (widget-get widget :indent)) | |
| 1388 arg answer children) | |
| 1389 (while args | |
| 1390 (setq arg (car args) | |
| 1391 args (cdr args) | |
| 1392 answer (widget-match-inline arg value) | |
| 1393 value (cdr answer) | |
| 1394 children (cons (cond ((null answer) | |
| 1395 (widget-create arg :parent widget)) | |
| 1396 ((widget-get arg :inline) | |
| 1397 (widget-create arg | |
| 1398 :parent widget | |
| 1399 :value (car answer))) | |
| 1400 (t | |
| 1401 (widget-create arg | |
| 1402 :parent widget | |
| 1403 :value (car (car answer))))) | |
| 1404 children)) | |
| 1405 (and args indent (insert-char ?\ indent))) | |
| 1406 (widget-put widget :children (nreverse children)))) | |
| 1407 | |
| 1408 (defun widget-group-match (widget values) | |
| 1409 ;; Match if the components match. | |
| 1410 (and (listp values) | |
| 1411 (null (cdr (widget-group-match-inline widget values))))) | |
| 1412 | |
| 1413 (defun widget-group-match-inline (widget values) | |
| 1414 ;; Match if the components match. | |
| 1415 (let ((args (widget-get widget :args)) | |
| 1416 (match t) | |
| 1417 arg answer found) | |
| 1418 (while args | |
| 1419 (setq arg (car args) | |
| 1420 args (cdr args) | |
| 1421 answer (widget-match-inline arg values)) | |
| 1422 (if answer | |
| 1423 (setq values (cdr answer) | |
| 1424 found (append found (car answer))) | |
| 1425 (setq values nil))) | |
| 1426 (if answer | |
| 1427 (cons found values) | |
| 1428 nil))) | |
| 1429 | |
| 1430 ;;; The Sexp Widgets. | |
| 1431 | |
| 1432 (define-widget 'const 'item | |
| 1433 nil | |
| 1434 :format "%t\n") | |
| 1435 | |
| 1436 (define-widget 'string 'field | |
| 1437 nil) | |
| 1438 | |
| 1439 (define-widget 'file 'string | |
| 1440 nil | |
| 1441 :format "%[%t%]:%v" | |
| 1442 :tag "File" | |
| 1443 :action 'widget-file-action) | |
| 1444 | |
| 1445 (defun widget-file-action (widget &optional event) | |
| 1446 nil | |
| 1447 ;; Read a file name from the minibuffer. | |
| 1448 (widget-value-set widget | |
| 1449 (read-file-name (widget-apply widget :menu-tag-get) | |
| 1450 (widget-get widget :directory) | |
| 1451 (widget-value widget) | |
| 1452 (widget-get widget :must-match) | |
| 1453 (widget-get widget :initial)))) | |
| 1454 | |
| 1455 (define-widget 'directory 'file | |
| 1456 nil | |
| 1457 :tag "Directory") | |
| 1458 | |
| 1459 (define-widget 'symbol 'string | |
| 1460 nil | |
| 1461 :match (lambda (widget value) (symbolp value)) | |
| 1462 :value-to-internal (lambda (widget value) (symbol-name value)) | |
| 1463 :value-to-external (lambda (widget value) (intern value))) | |
| 1464 | |
| 1465 (define-widget 'sexp 'string | |
| 1466 nil | |
| 1467 :validate 'widget-sexp-validate | |
| 1468 :match (lambda (widget value) t) | |
| 1469 :value-to-internal (lambda (widget value) (pp-to-string value)) | |
| 1470 :value-to-external (lambda (widget value) (read value))) | |
| 1471 | |
| 1472 (defun widget-sexp-validate (widget) | |
| 1473 ;; Valid if we can read the string and there is no junk left after it. | |
| 1474 (save-excursion | |
| 1475 (set-buffer (get-buffer-create " *Widget Scratch*")) | |
| 1476 (erase-buffer) | |
| 1477 (insert (widget-apply :value-get widget)) | |
| 1478 (goto-char (point-min)) | |
| 1479 (condition-case data | |
| 1480 (let ((value (read (current-buffer)))) | |
| 1481 (if (eobp) | |
| 1482 (if (widget-apply widget :match value) | |
| 1483 t | |
| 1484 (widget-put widget :error (widget-get widget :type-error)) | |
| 1485 nil) | |
| 1486 (widget-put widget | |
| 1487 :error (format "Junk at end of expression: %s" | |
| 1488 (buffer-substring (point) (point-max)))) | |
| 1489 nil)) | |
| 1490 (error (widget-put widget :error (error-message-string data)) | |
| 1491 nil)))) | |
| 1492 | |
| 1493 (define-widget 'integer 'sexp | |
| 1494 nil | |
| 1495 :type-error "This field should contain an integer" | |
| 1496 :match (lambda (widget value) (integerp value))) | |
| 1497 | |
| 1498 (define-widget 'number 'sexp | |
| 1499 nil | |
| 1500 :type-error "This field should contain a number" | |
| 1501 :match (lambda (widget value) (numberp value))) | |
| 1502 | |
| 1503 (define-widget 'list 'group | |
| 1504 nil) | |
| 1505 | |
| 1506 (define-widget 'vector 'group | |
| 1507 nil | |
| 1508 :match 'widget-vector-match | |
| 1509 :value-to-internal (lambda (widget value) (append value nil)) | |
| 1510 :value-to-external (lambda (widget value) (apply 'vector value))) | |
| 1511 | |
| 1512 (defun widget-vector-match (widget value) | |
| 1513 (and (vectorp value) | |
| 1514 (widget-group-match widget | |
| 1515 (widget-apply :value-to-internal widget value)))) | |
| 1516 | |
| 1517 (define-widget 'cons 'group | |
| 1518 nil | |
| 1519 :match 'widget-cons-match | |
| 1520 :value-to-internal (lambda (widget value) | |
| 1521 (list (car value) (cdr value))) | |
| 1522 :value-to-external (lambda (widget value) | |
| 1523 (cons (nth 0 value) (nth 1 value)))) | |
| 1524 | |
| 1525 (defun widget-cons-match (widget value) | |
| 1526 (and (consp value) | |
| 1527 (widget-group-match widget | |
| 1528 (widget-apply :value-to-internal widget value)))) | |
| 1529 | |
| 1530 ;;; The End: | |
| 1531 | |
| 1532 (provide 'widget-edit) | |
| 1533 | |
| 1534 ;; widget-edit.el ends here |