Mercurial > emacs
comparison lisp/wid-edit.el @ 18033:bccd356a3b7c
Synched with version 1.9900.
author | Per Abrahamsen <abraham@dina.kvl.dk> |
---|---|
date | Fri, 30 May 1997 00:39:40 +0000 |
parents | 0df9495348e7 |
children | 9e0c7dffc231 |
comparison
equal
deleted
inserted
replaced
18032:fd3f0a7e79b9 | 18033:bccd356a3b7c |
---|---|
2 ;; | 2 ;; |
3 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. | 3 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. |
4 ;; | 4 ;; |
5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> | 5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> |
6 ;; Keywords: extensions | 6 ;; Keywords: extensions |
7 ;; Version: 1.97 | 7 ;; Version: 1.9900 |
8 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ | 8 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ |
9 | 9 |
10 ;; This file is part of GNU Emacs. | 10 ;; This file is part of GNU Emacs. |
11 | 11 |
12 ;; GNU Emacs is free software; you can redistribute it and/or modify | 12 ;; GNU Emacs is free software; you can redistribute it and/or modify |
29 ;; See `widget.el'. | 29 ;; See `widget.el'. |
30 | 30 |
31 ;;; Code: | 31 ;;; Code: |
32 | 32 |
33 (require 'widget) | 33 (require 'widget) |
34 | 34 (require 'cl) |
35 (eval-when-compile (require 'cl)) | |
36 | 35 |
37 ;;; Compatibility. | 36 ;;; Compatibility. |
38 | 37 |
39 (eval-and-compile | 38 (eval-and-compile |
40 (autoload 'pp-to-string "pp") | 39 (autoload 'pp-to-string "pp") |
144 (defface widget-field-face '((((class grayscale color) | 143 (defface widget-field-face '((((class grayscale color) |
145 (background light)) | 144 (background light)) |
146 (:background "gray85")) | 145 (:background "gray85")) |
147 (((class grayscale color) | 146 (((class grayscale color) |
148 (background dark)) | 147 (background dark)) |
149 (:background "dark gray")) | 148 (:background "dim gray")) |
150 (t | 149 (t |
151 (:italic t))) | 150 (:italic t))) |
152 "Face used for editable fields." | 151 "Face used for editable fields." |
153 :group 'widgets) | 152 :group 'widgets) |
154 | 153 |
540 ;;; Glyphs. | 539 ;;; Glyphs. |
541 | 540 |
542 (defcustom widget-glyph-directory (concat data-directory "custom/") | 541 (defcustom widget-glyph-directory (concat data-directory "custom/") |
543 "Where widget glyphs are located. | 542 "Where widget glyphs are located. |
544 If this variable is nil, widget will try to locate the directory | 543 If this variable is nil, widget will try to locate the directory |
545 automatically. This does not work yet." | 544 automatically." |
546 :group 'widgets | 545 :group 'widgets |
547 :type 'directory) | 546 :type 'directory) |
548 | 547 |
549 (defcustom widget-glyph-enable t | 548 (defcustom widget-glyph-enable t |
550 "If non nil, use glyphs in images when available." | 549 "If non nil, use glyphs in images when available." |
551 :group 'widgets | 550 :group 'widgets |
552 :type 'boolean) | 551 :type 'boolean) |
553 | 552 |
553 (defcustom widget-image-conversion | |
554 '((xpm ".xpm") (gif ".gif") (png ".png") (jpeg ".jpg" ".jpeg") | |
555 (xbm ".xbm")) | |
556 "Conversion alist from image formats to file name suffixes." | |
557 :group 'widgets | |
558 :type '(repeat (cons :format "%v" | |
559 (symbol :tag "Image Format" unknown) | |
560 (repeat :tag "Suffixes" | |
561 (string :format "%v"))))) | |
562 | |
554 (defun widget-glyph-insert (widget tag image) | 563 (defun widget-glyph-insert (widget tag image) |
555 "In WIDGET, insert the text TAG or, if supported, IMAGE. | 564 "In WIDGET, insert the text TAG or, if supported, IMAGE. |
556 IMAGE should either be a glyph, or a name sans extension of an xpm or | 565 IMAGE should either be a glyph, an image instantiator, or an image file |
557 xbm file located in `widget-glyph-directory'. | 566 name sans extension (xpm, xbm, gif, jpg, or png) located in |
567 `widget-glyph-directory'. | |
558 | 568 |
559 WARNING: If you call this with a glyph, and you want the user to be | 569 WARNING: If you call this with a glyph, and you want the user to be |
560 able to activate the glyph, make sure it is unique. If you use the | 570 able to invoke the glyph, make sure it is unique. If you use the |
561 same glyph for multiple widgets, activating any of the glyphs will | 571 same glyph for multiple widgets, invoking any of the glyphs will |
562 cause the last created widget to be activated." | 572 cause the last created widget to be invoked." |
563 (cond ((not (and (string-match "XEmacs" emacs-version) | 573 (cond ((not (and (string-match "XEmacs" emacs-version) |
564 widget-glyph-enable | 574 widget-glyph-enable |
565 (fboundp 'make-glyph) | 575 (fboundp 'make-glyph) |
576 (fboundp 'locate-file) | |
566 image)) | 577 image)) |
567 ;; We don't want or can't use glyphs. | 578 ;; We don't want or can't use glyphs. |
568 (insert tag)) | 579 (insert tag)) |
569 ((and (fboundp 'glyphp) | 580 ((and (fboundp 'glyphp) |
570 (glyphp image)) | 581 (glyphp image)) |
571 ;; Already a glyph. Insert it. | 582 ;; Already a glyph. Insert it. |
572 (widget-glyph-insert-glyph widget tag image)) | 583 (widget-glyph-insert-glyph widget image)) |
584 ((stringp image) | |
585 ;; A string. Look it up in relevant directories. | |
586 (let* ((dirlist (list (or widget-glyph-directory | |
587 (concat data-directory | |
588 "custom/")) | |
589 data-directory)) | |
590 (formats widget-image-conversion) | |
591 file) | |
592 (while (and formats (not file)) | |
593 (if (valid-image-instantiator-format-p (car (car formats))) | |
594 (setq file (locate-file image dirlist | |
595 (mapconcat 'identity (cdr (car formats)) | |
596 ":"))) | |
597 (setq formats (cdr formats)))) | |
598 ;; We create a glyph with the file as the default image | |
599 ;; instantiator, and the TAG fallback | |
600 (widget-glyph-insert-glyph | |
601 widget | |
602 (make-glyph (if file | |
603 (list (vector (car (car formats)) ':file file) | |
604 (vector 'string ':data tag)) | |
605 (vector 'string ':data tag)))))) | |
606 ((valid-instantiator-p image 'image) | |
607 ;; A valid image instantiator (e.g. [gif :file "somefile"] etc.) | |
608 (widget-glyph-insert-glyph | |
609 widget | |
610 (make-glyph (list image | |
611 (vector 'string ':data tag))))) | |
573 (t | 612 (t |
574 ;; A string. Look it up in. | 613 ;; Oh well. |
575 (let ((file (concat widget-glyph-directory | 614 (insert tag)))) |
576 (if (string-match "/\\'" widget-glyph-directory) | 615 |
577 "" | 616 (defun widget-glyph-insert-glyph (widget glyph &optional down inactive) |
578 "/") | |
579 image | |
580 (if (featurep 'xpm) ".xpm" ".xbm")))) | |
581 (if (file-readable-p file) | |
582 (widget-glyph-insert-glyph widget tag (make-glyph file)) | |
583 ;; File not readable, give up. | |
584 (insert tag)))))) | |
585 | |
586 (defun widget-glyph-insert-glyph (widget tag glyph &optional down inactive) | |
587 "In WIDGET, with alternative text TAG, insert GLYPH." | 617 "In WIDGET, with alternative text TAG, insert GLYPH." |
588 (set-glyph-image glyph (cons 'tty tag)) | |
589 (set-glyph-property glyph 'widget widget) | 618 (set-glyph-property glyph 'widget widget) |
590 (when down | 619 (when down |
591 (set-glyph-image down (cons 'tty tag)) | |
592 (set-glyph-property down 'widget widget)) | 620 (set-glyph-property down 'widget widget)) |
593 (when inactive | 621 (when inactive |
594 (set-glyph-image inactive (cons 'tty tag)) | |
595 (set-glyph-property inactive 'widget widget)) | 622 (set-glyph-property inactive 'widget widget)) |
596 (insert "*") | 623 (insert "*") |
597 (add-text-properties (1- (point)) (point) | 624 (add-text-properties (1- (point)) (point) |
598 (list 'invisible t | 625 (list 'invisible t |
599 'end-glyph glyph)) | 626 'end-glyph glyph)) |
607 'balloon-help | 634 'balloon-help |
608 'help-echo))) | 635 'help-echo))) |
609 (set-extent-property extent help-property (if (stringp help-echo) | 636 (set-extent-property extent help-property (if (stringp help-echo) |
610 help-echo | 637 help-echo |
611 'widget-mouse-help)))))) | 638 'widget-mouse-help)))))) |
639 | |
640 ;;; Buttons. | |
641 | |
642 (defgroup widget-button nil | |
643 "The look of various kinds of buttons." | |
644 :group 'widgets) | |
645 | |
646 (defcustom widget-button-prefix "" | |
647 "String used as prefix for buttons." | |
648 :type 'string | |
649 :group 'widgets) | |
650 | |
651 (defcustom widget-button-suffix "" | |
652 "String used as suffix for buttons." | |
653 :type 'string | |
654 :group 'widgets) | |
655 | |
656 (defun widget-button-insert-indirect (widget key) | |
657 "Insert value of WIDGET's KEY property." | |
658 (let ((val (widget-get widget key))) | |
659 (while (and val (symbolp val)) | |
660 (setq val (symbol-value val))) | |
661 (when val | |
662 (insert val)))) | |
612 | 663 |
613 ;;; Creating Widgets. | 664 ;;; Creating Widgets. |
614 | 665 |
615 ;;;###autoload | 666 ;;;###autoload |
616 (defun widget-create (type &rest args) | 667 (defun widget-create (type &rest args) |
760 (define-key widget-text-keymap "\C-a" 'widget-beginning-of-line) | 811 (define-key widget-text-keymap "\C-a" 'widget-beginning-of-line) |
761 (define-key widget-text-keymap "\C-e" 'widget-end-of-line) | 812 (define-key widget-text-keymap "\C-e" 'widget-end-of-line) |
762 (set-keymap-parent widget-text-keymap global-map)) | 813 (set-keymap-parent widget-text-keymap global-map)) |
763 | 814 |
764 (defun widget-field-activate (pos &optional event) | 815 (defun widget-field-activate (pos &optional event) |
765 "Activate the ediable field at point." | 816 "Invoke the ediable field at point." |
766 (interactive "@d") | 817 (interactive "@d") |
767 (let ((field (get-text-property pos 'field))) | 818 (let ((field (get-text-property pos 'field))) |
768 (if field | 819 (if field |
769 (widget-apply-action field event) | 820 (widget-apply-action field event) |
770 (call-interactively | 821 (call-interactively |
777 (:bold t :underline t))) | 828 (:bold t :underline t))) |
778 "Face used for pressed buttons." | 829 "Face used for pressed buttons." |
779 :group 'widgets) | 830 :group 'widgets) |
780 | 831 |
781 (defun widget-button-click (event) | 832 (defun widget-button-click (event) |
782 "Activate button below mouse pointer." | 833 "Invoke button below mouse pointer." |
783 (interactive "@e") | 834 (interactive "@e") |
784 (cond ((and (fboundp 'event-glyph) | 835 (cond ((and (fboundp 'event-glyph) |
785 (event-glyph event)) | 836 (event-glyph event)) |
786 (widget-glyph-click event)) | 837 (widget-glyph-click event)) |
787 ((widget-event-point event) | 838 ((widget-event-point event) |
826 (lookup-key widget-global-map [ mouse-2])))))) | 877 (lookup-key widget-global-map [ mouse-2])))))) |
827 (t | 878 (t |
828 (message "You clicked somewhere weird.")))) | 879 (message "You clicked somewhere weird.")))) |
829 | 880 |
830 (defun widget-button1-click (event) | 881 (defun widget-button1-click (event) |
831 "Activate glyph below mouse pointer." | 882 "Invoke glyph below mouse pointer." |
832 (interactive "@e") | 883 (interactive "@e") |
833 (if (and (fboundp 'event-glyph) | 884 (if (and (fboundp 'event-glyph) |
834 (event-glyph event)) | 885 (event-glyph event)) |
835 (widget-glyph-click event) | 886 (widget-glyph-click event) |
836 (call-interactively (lookup-key widget-global-map (this-command-keys))))) | 887 (call-interactively (lookup-key widget-global-map (this-command-keys))))) |
861 (message "This glyph is inactive.")) | 912 (message "This glyph is inactive.")) |
862 (t | 913 (t |
863 (widget-apply-action widget event))))))) | 914 (widget-apply-action widget event))))))) |
864 | 915 |
865 (defun widget-button-press (pos &optional event) | 916 (defun widget-button-press (pos &optional event) |
866 "Activate button at POS." | 917 "Invoke button at POS." |
867 (interactive "@d") | 918 (interactive "@d") |
868 (let ((button (get-text-property pos 'button))) | 919 (let ((button (get-text-property pos 'button))) |
869 (if button | 920 (if button |
870 (widget-apply-action button event) | 921 (widget-apply-action button event) |
871 (let ((command (lookup-key widget-global-map (this-command-keys)))) | 922 (let ((command (lookup-key widget-global-map (this-command-keys)))) |
1134 | 1185 |
1135 (define-widget 'default nil | 1186 (define-widget 'default nil |
1136 "Basic widget other widgets are derived from." | 1187 "Basic widget other widgets are derived from." |
1137 :value-to-internal (lambda (widget value) value) | 1188 :value-to-internal (lambda (widget value) value) |
1138 :value-to-external (lambda (widget value) value) | 1189 :value-to-external (lambda (widget value) value) |
1190 :button-prefix 'widget-button-prefix | |
1191 :button-suffix 'widget-button-suffix | |
1139 :create 'widget-default-create | 1192 :create 'widget-default-create |
1140 :indent nil | 1193 :indent nil |
1141 :offset 0 | 1194 :offset 0 |
1142 :format-handler 'widget-default-format-handler | 1195 :format-handler 'widget-default-format-handler |
1143 :button-face-get 'widget-default-button-face-get | 1196 :button-face-get 'widget-default-button-face-get |
1157 | 1210 |
1158 (defun widget-default-create (widget) | 1211 (defun widget-default-create (widget) |
1159 "Create WIDGET at point in the current buffer." | 1212 "Create WIDGET at point in the current buffer." |
1160 (widget-specify-insert | 1213 (widget-specify-insert |
1161 (let ((from (point)) | 1214 (let ((from (point)) |
1162 (tag (widget-get widget :tag)) | |
1163 (glyph (widget-get widget :tag-glyph)) | |
1164 (doc (widget-get widget :doc)) | |
1165 button-begin button-end | 1215 button-begin button-end |
1166 sample-begin sample-end | 1216 sample-begin sample-end |
1167 doc-begin doc-end | 1217 doc-begin doc-end |
1168 value-pos) | 1218 value-pos) |
1169 (insert (widget-get widget :format)) | 1219 (insert (widget-get widget :format)) |
1173 (let ((escape (aref (match-string 1) 0))) | 1223 (let ((escape (aref (match-string 1) 0))) |
1174 (replace-match "" t t) | 1224 (replace-match "" t t) |
1175 (cond ((eq escape ?%) | 1225 (cond ((eq escape ?%) |
1176 (insert "%")) | 1226 (insert "%")) |
1177 ((eq escape ?\[) | 1227 ((eq escape ?\[) |
1178 (setq button-begin (point))) | 1228 (setq button-begin (point)) |
1229 (widget-button-insert-indirect widget :button-prefix)) | |
1179 ((eq escape ?\]) | 1230 ((eq escape ?\]) |
1231 (widget-button-insert-indirect widget :button-suffix) | |
1180 (setq button-end (point))) | 1232 (setq button-end (point))) |
1181 ((eq escape ?\{) | 1233 ((eq escape ?\{) |
1182 (setq sample-begin (point))) | 1234 (setq sample-begin (point))) |
1183 ((eq escape ?\}) | 1235 ((eq escape ?\}) |
1184 (setq sample-end (point))) | 1236 (setq sample-end (point))) |
1185 ((eq escape ?n) | 1237 ((eq escape ?n) |
1186 (when (widget-get widget :indent) | 1238 (when (widget-get widget :indent) |
1187 (insert "\n") | 1239 (insert "\n") |
1188 (insert-char ? (widget-get widget :indent)))) | 1240 (insert-char ? (widget-get widget :indent)))) |
1189 ((eq escape ?t) | 1241 ((eq escape ?t) |
1190 (cond (glyph | 1242 (let ((glyph (widget-get widget :tag-glyph)) |
1191 (widget-glyph-insert widget (or tag "image") glyph)) | 1243 (tag (widget-get widget :tag))) |
1192 (tag | 1244 (cond (glyph |
1193 (insert tag)) | 1245 (widget-glyph-insert widget (or tag "image") glyph)) |
1194 (t | 1246 (tag |
1195 (let ((standard-output (current-buffer))) | 1247 (insert tag)) |
1196 (princ (widget-get widget :value)))))) | 1248 (t |
1249 (let ((standard-output (current-buffer))) | |
1250 (princ (widget-get widget :value))))))) | |
1197 ((eq escape ?d) | 1251 ((eq escape ?d) |
1198 (when doc | 1252 (let ((doc (widget-get widget :doc))) |
1199 (setq doc-begin (point)) | 1253 (when doc |
1200 (insert doc) | 1254 (setq doc-begin (point)) |
1201 (while (eq (preceding-char) ?\n) | 1255 (insert doc) |
1202 (delete-backward-char 1)) | 1256 (while (eq (preceding-char) ?\n) |
1203 (insert "\n") | 1257 (delete-backward-char 1)) |
1204 (setq doc-end (point)))) | 1258 (insert "\n") |
1259 (setq doc-end (point))))) | |
1205 ((eq escape ?v) | 1260 ((eq escape ?v) |
1206 (if (and button-begin (not button-end)) | 1261 (if (and button-begin (not button-end)) |
1207 (widget-apply widget :value-create) | 1262 (widget-apply widget :value-create) |
1208 (setq value-pos (point)))) | 1263 (setq value-pos (point)))) |
1209 (t | 1264 (t |
1384 :type 'boolean) | 1439 :type 'boolean) |
1385 | 1440 |
1386 ;; Cache already created GUI objects. | 1441 ;; Cache already created GUI objects. |
1387 (defvar widget-push-button-cache nil) | 1442 (defvar widget-push-button-cache nil) |
1388 | 1443 |
1444 (defcustom widget-push-button-prefix "[" | |
1445 "String used as prefix for buttons." | |
1446 :type 'string | |
1447 :group 'widget-button) | |
1448 | |
1449 (defcustom widget-push-button-suffix "]" | |
1450 "String used as suffix for buttons." | |
1451 :type 'string | |
1452 :group 'widget-button) | |
1453 | |
1389 (define-widget 'push-button 'item | 1454 (define-widget 'push-button 'item |
1390 "A pushable button." | 1455 "A pushable button." |
1456 :button-prefix "" | |
1457 :button-suffix "" | |
1391 :value-create 'widget-push-button-value-create | 1458 :value-create 'widget-push-button-value-create |
1392 :text-format "[%s]" | |
1393 :format "%[%v%]") | 1459 :format "%[%v%]") |
1394 | 1460 |
1395 (defun widget-push-button-value-create (widget) | 1461 (defun widget-push-button-value-create (widget) |
1396 ;; Insert text representing the `on' and `off' states. | 1462 ;; Insert text representing the `on' and `off' states. |
1397 (let* ((tag (or (widget-get widget :tag) | 1463 (let* ((tag (or (widget-get widget :tag) |
1398 (widget-get widget :value))) | 1464 (widget-get widget :value))) |
1399 (text (format (widget-get widget :text-format) tag)) | 1465 (text (concat widget-push-button-prefix |
1466 tag widget-push-button-suffix)) | |
1400 (gui (cdr (assoc tag widget-push-button-cache)))) | 1467 (gui (cdr (assoc tag widget-push-button-cache)))) |
1401 (if (and (fboundp 'make-gui-button) | 1468 (if (and (fboundp 'make-gui-button) |
1402 (fboundp 'make-glyph) | 1469 (fboundp 'make-glyph) |
1403 widget-push-button-gui | 1470 widget-push-button-gui |
1404 (fboundp 'device-on-window-system-p) | 1471 (fboundp 'device-on-window-system-p) |
1406 (string-match "XEmacs" emacs-version)) | 1473 (string-match "XEmacs" emacs-version)) |
1407 (progn | 1474 (progn |
1408 (unless gui | 1475 (unless gui |
1409 (setq gui (make-gui-button tag 'widget-gui-action widget)) | 1476 (setq gui (make-gui-button tag 'widget-gui-action widget)) |
1410 (push (cons tag gui) widget-push-button-cache)) | 1477 (push (cons tag gui) widget-push-button-cache)) |
1411 (widget-glyph-insert-glyph widget text | 1478 (widget-glyph-insert-glyph widget |
1412 (make-glyph (nth 0 (aref gui 1))) | 1479 (make-glyph |
1413 (make-glyph (nth 1 (aref gui 1))) | 1480 (list (nth 0 (aref gui 1)) |
1414 (make-glyph (nth 2 (aref gui 1))))) | 1481 (vector 'string ':data text))) |
1482 (make-glyph | |
1483 (list (nth 1 (aref gui 1)) | |
1484 (vector 'string ':data text))) | |
1485 (make-glyph | |
1486 (list (nth 2 (aref gui 1)) | |
1487 (vector 'string ':data text))))) | |
1415 (insert text)))) | 1488 (insert text)))) |
1416 | 1489 |
1417 (defun widget-gui-action (widget) | 1490 (defun widget-gui-action (widget) |
1418 "Apply :action for WIDGET." | 1491 "Apply :action for WIDGET." |
1419 (widget-apply-action widget (this-command-keys))) | 1492 (widget-apply-action widget (this-command-keys))) |
1420 | 1493 |
1421 ;;; The `link' Widget. | 1494 ;;; The `link' Widget. |
1422 | 1495 |
1496 (defcustom widget-link-prefix "[" | |
1497 "String used as prefix for links." | |
1498 :type 'string | |
1499 :group 'widget-button) | |
1500 | |
1501 (defcustom widget-link-suffix "]" | |
1502 "String used as suffix for links." | |
1503 :type 'string | |
1504 :group 'widget-button) | |
1505 | |
1423 (define-widget 'link 'item | 1506 (define-widget 'link 'item |
1424 "An embedded link." | 1507 "An embedded link." |
1508 :button-prefix 'widget-link-prefix | |
1509 :button-suffix 'widget-link-suffix | |
1425 :help-echo "Follow the link." | 1510 :help-echo "Follow the link." |
1426 :format "%[_%t_%]") | 1511 :format "%[%t%]") |
1427 | 1512 |
1428 ;;; The `info-link' Widget. | 1513 ;;; The `info-link' Widget. |
1429 | 1514 |
1430 (define-widget 'info-link 'link | 1515 (define-widget 'info-link 'link |
1431 "A link to an info file." | 1516 "A link to an info file." |
1625 (widget-apply (car (widget-get widget :children)) :value-inline)) | 1710 (widget-apply (car (widget-get widget :children)) :value-inline)) |
1626 | 1711 |
1627 (defcustom widget-choice-toggle nil | 1712 (defcustom widget-choice-toggle nil |
1628 "If non-nil, a binary choice will just toggle between the values. | 1713 "If non-nil, a binary choice will just toggle between the values. |
1629 Otherwise, the user will explicitly have to choose between the values | 1714 Otherwise, the user will explicitly have to choose between the values |
1630 when he activate the menu." | 1715 when he invoked the menu." |
1631 :type 'boolean | 1716 :type 'boolean |
1632 :group 'widgets) | 1717 :group 'widgets) |
1633 | 1718 |
1634 (defun widget-choice-mouse-down-action (widget &optional event) | 1719 (defun widget-choice-mouse-down-action (widget &optional event) |
1635 ;; Return non-nil if we need a menu. | 1720 ;; Return non-nil if we need a menu. |
1754 | 1839 |
1755 ;;; The `checkbox' Widget. | 1840 ;;; The `checkbox' Widget. |
1756 | 1841 |
1757 (define-widget 'checkbox 'toggle | 1842 (define-widget 'checkbox 'toggle |
1758 "A checkbox toggle." | 1843 "A checkbox toggle." |
1844 :button-suffix "" | |
1845 :button-prefix "" | |
1759 :format "%[%v%]" | 1846 :format "%[%v%]" |
1760 :on "[X]" | 1847 :on "[X]" |
1761 :on-glyph "check1" | 1848 :on-glyph "check1" |
1762 :off "[ ]" | 1849 :off "[ ]" |
1763 :off-glyph "check0" | 1850 :off-glyph "check0" |
1938 | 2025 |
1939 (define-widget 'radio-button 'toggle | 2026 (define-widget 'radio-button 'toggle |
1940 "A radio button for use in the `radio' widget." | 2027 "A radio button for use in the `radio' widget." |
1941 :notify 'widget-radio-button-notify | 2028 :notify 'widget-radio-button-notify |
1942 :format "%[%v%]" | 2029 :format "%[%v%]" |
2030 :button-suffix "" | |
2031 :button-prefix "" | |
1943 :on "(*)" | 2032 :on "(*)" |
1944 :on-glyph "radio1" | 2033 :on-glyph "radio1" |
1945 :off "( )" | 2034 :off "( )" |
1946 :off-glyph "radio0") | 2035 :off-glyph "radio0") |
1947 | 2036 |
2374 | 2463 |
2375 ;;; The `widget-help' Widget. | 2464 ;;; The `widget-help' Widget. |
2376 | 2465 |
2377 (define-widget 'widget-help 'push-button | 2466 (define-widget 'widget-help 'push-button |
2378 "The widget documentation button." | 2467 "The widget documentation button." |
2379 :format "%[[%t]%] %d" | 2468 :format "%[%v%] %d" |
2380 :help-echo "Toggle display of documentation." | 2469 :help-echo "Toggle display of documentation." |
2381 :action 'widget-help-action) | 2470 :action 'widget-help-action) |
2382 | 2471 |
2383 (defun widget-help-action (widget &optional event) | 2472 (defun widget-help-action (widget &optional event) |
2384 "Toggle documentation for WIDGET." | 2473 "Toggle documentation for WIDGET." |
2444 (error (widget-put widget :error (error-message-string data)) | 2533 (error (widget-put widget :error (error-message-string data)) |
2445 widget)))) | 2534 widget)))) |
2446 | 2535 |
2447 (define-widget 'file 'string | 2536 (define-widget 'file 'string |
2448 "A file widget. | 2537 "A file widget. |
2449 It will read a file name from the minibuffer when activated." | 2538 It will read a file name from the minibuffer when invoked." |
2450 :prompt-value 'widget-file-prompt-value | 2539 :prompt-value 'widget-file-prompt-value |
2451 :format "%{%t%}: %v" | 2540 :format "%{%t%}: %v" |
2452 :tag "File" | 2541 :tag "File" |
2453 :action 'widget-file-action) | 2542 :action 'widget-file-action) |
2454 | 2543 |
2476 (widget-apply widget :notify widget event) | 2565 (widget-apply widget :notify widget event) |
2477 (widget-setup))) | 2566 (widget-setup))) |
2478 | 2567 |
2479 (define-widget 'directory 'file | 2568 (define-widget 'directory 'file |
2480 "A directory widget. | 2569 "A directory widget. |
2481 It will read a directory name from the minibuffer when activated." | 2570 It will read a directory name from the minibuffer when invoked." |
2482 :tag "Directory") | 2571 :tag "Directory") |
2483 | 2572 |
2484 (defvar widget-symbol-prompt-value-history nil | 2573 (defvar widget-symbol-prompt-value-history nil |
2485 "History of input to `widget-symbol-prompt-value'.") | 2574 "History of input to `widget-symbol-prompt-value'.") |
2486 | 2575 |
2753 "A color name (with sample)." | 2842 "A color name (with sample)." |
2754 :format "%v (%{sample%})\n" | 2843 :format "%v (%{sample%})\n" |
2755 :sample-face-get 'widget-color-item-button-face-get) | 2844 :sample-face-get 'widget-color-item-button-face-get) |
2756 | 2845 |
2757 (defun widget-color-item-button-face-get (widget) | 2846 (defun widget-color-item-button-face-get (widget) |
2758 ;; We create a face from the value. | 2847 (let ((symbol (intern (concat "fg:" (widget-value widget))))) |
2759 (require 'facemenu) | 2848 (if (string-match "XEmacs" emacs-version) |
2760 (condition-case nil | 2849 (prog1 symbol |
2761 (facemenu-get-face (intern (concat "fg:" (widget-value widget)))) | 2850 (or (find-face symbol) |
2762 (error 'default))) | 2851 (set-face-foreground (make-face symbol) (widget-value widget)))) |
2852 (condition-case nil | |
2853 (facemenu-get-face symbol) | |
2854 (error 'default))))) | |
2763 | 2855 |
2764 (define-widget 'color 'push-button | 2856 (define-widget 'color 'push-button |
2765 "Choose a color name (with sample)." | 2857 "Choose a color name (with sample)." |
2766 :format "%[%t%]: %v" | 2858 :format "%[%t%]: %v" |
2767 :tag "Color" | 2859 :tag "Color" |