Mercurial > hg > xemacs-beta

comparison lisp/custom/wid-edit.el @ 153:25f70ba0133c r20-3b3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-3b3
author cvs
date Mon, 13 Aug 2007 09:38:25 +0200
parents 538048ae2ab8
children 43dd3413c7c7
comparison
equal deleted inserted replaced
152:4c132ee2d62b 153:25f70ba0133c
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.98
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 activate 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, activating any of the glyphs will
562 cause the last created widget to be activated." 572 cause the last created widget to be activated."
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 (when (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 widget
609 (list image
610 (vector 'string ':data tag))))
573 (t 611 (t
574 ;; A string. Look it up in. 612 ;; Oh well.
575 (let ((file (concat widget-glyph-directory 613 (insert tag))))
576 (if (string-match "/\\'" widget-glyph-directory) 614
577 "" 615 (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." 616 "In WIDGET, with alternative text TAG, insert GLYPH."
588 (set-glyph-image glyph (cons 'tty tag))
589 (set-glyph-property glyph 'widget widget) 617 (set-glyph-property glyph 'widget widget)
590 (when down 618 (when down
591 (set-glyph-image down (cons 'tty tag))
592 (set-glyph-property down 'widget widget)) 619 (set-glyph-property down 'widget widget))
593 (when inactive 620 (when inactive
594 (set-glyph-image inactive (cons 'tty tag))
595 (set-glyph-property inactive 'widget widget)) 621 (set-glyph-property inactive 'widget widget))
596 (insert "*") 622 (insert "*")
597 (add-text-properties (1- (point)) (point) 623 (add-text-properties (1- (point)) (point)
598 (list 'invisible t 624 (list 'invisible t
599 'end-glyph glyph)) 625 'end-glyph glyph))
607 'balloon-help 633 'balloon-help
608 'help-echo))) 634 'help-echo)))
609 (set-extent-property extent help-property (if (stringp help-echo) 635 (set-extent-property extent help-property (if (stringp help-echo)
610 help-echo 636 help-echo
611 'widget-mouse-help)))))) 637 'widget-mouse-help))))))
638
639 ;;; Buttons.
640
641 (defgroup widget-button nil
642 "The look of various kinds of buttons."
643 :group 'widgets)
644
645 (defcustom widget-button-prefix ""
646 "String used as prefix for buttons."
647 :type 'string
648 :group 'widgets)
649
650 (defcustom widget-button-suffix ""
651 "String used as suffix for buttons."
652 :type 'string
653 :group 'widgets)
654
655 (defun widget-button-insert-indirect (widget key)
656 "Insert value of WIDGET's KEY property."
657 (let ((val (widget-get widget key)))
658 (while (and val (symbolp val))
659 (setq val (symbol-value val)))
660 (when val
661 (insert val))))
612 662
613 ;;; Creating Widgets. 663 ;;; Creating Widgets.
614 664
615 ;;;###autoload 665 ;;;###autoload
616 (defun widget-create (type &rest args) 666 (defun widget-create (type &rest args)
1134 1184
1135 (define-widget 'default nil 1185 (define-widget 'default nil
1136 "Basic widget other widgets are derived from." 1186 "Basic widget other widgets are derived from."
1137 :value-to-internal (lambda (widget value) value) 1187 :value-to-internal (lambda (widget value) value)
1138 :value-to-external (lambda (widget value) value) 1188 :value-to-external (lambda (widget value) value)
1189 :button-prefix 'widget-button-prefix
1190 :button-suffix 'widget-button-suffix
1139 :create 'widget-default-create 1191 :create 'widget-default-create
1140 :indent nil 1192 :indent nil
1141 :offset 0 1193 :offset 0
1142 :format-handler 'widget-default-format-handler 1194 :format-handler 'widget-default-format-handler
1143 :button-face-get 'widget-default-button-face-get 1195 :button-face-get 'widget-default-button-face-get
1157 1209
1158 (defun widget-default-create (widget) 1210 (defun widget-default-create (widget)
1159 "Create WIDGET at point in the current buffer." 1211 "Create WIDGET at point in the current buffer."
1160 (widget-specify-insert 1212 (widget-specify-insert
1161 (let ((from (point)) 1213 (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 1214 button-begin button-end
1166 sample-begin sample-end 1215 sample-begin sample-end
1167 doc-begin doc-end 1216 doc-begin doc-end
1168 value-pos) 1217 value-pos)
1169 (insert (widget-get widget :format)) 1218 (insert (widget-get widget :format))
1173 (let ((escape (aref (match-string 1) 0))) 1222 (let ((escape (aref (match-string 1) 0)))
1174 (replace-match "" t t) 1223 (replace-match "" t t)
1175 (cond ((eq escape ?%) 1224 (cond ((eq escape ?%)
1176 (insert "%")) 1225 (insert "%"))
1177 ((eq escape ?\[) 1226 ((eq escape ?\[)
1178 (setq button-begin (point))) 1227 (setq button-begin (point))
1228 (widget-button-insert-indirect widget :button-prefix))
1179 ((eq escape ?\]) 1229 ((eq escape ?\])
1230 (widget-button-insert-indirect widget :button-suffix)
1180 (setq button-end (point))) 1231 (setq button-end (point)))
1181 ((eq escape ?\{) 1232 ((eq escape ?\{)
1182 (setq sample-begin (point))) 1233 (setq sample-begin (point)))
1183 ((eq escape ?\}) 1234 ((eq escape ?\})
1184 (setq sample-end (point))) 1235 (setq sample-end (point)))
1185 ((eq escape ?n) 1236 ((eq escape ?n)
1186 (when (widget-get widget :indent) 1237 (when (widget-get widget :indent)
1187 (insert "\n") 1238 (insert "\n")
1188 (insert-char ? (widget-get widget :indent)))) 1239 (insert-char ? (widget-get widget :indent))))
1189 ((eq escape ?t) 1240 ((eq escape ?t)
1190 (cond (glyph 1241 (let ((glyph (widget-get widget :tag-glyph))
1191 (widget-glyph-insert widget (or tag "image") glyph)) 1242 (tag (widget-get widget :tag)))
1192 (tag 1243 (cond (glyph
1193 (insert tag)) 1244 (widget-glyph-insert widget (or tag "image") glyph))
1194 (t 1245 (tag
1195 (let ((standard-output (current-buffer))) 1246 (insert tag))
1196 (princ (widget-get widget :value)))))) 1247 (t
1248 (let ((standard-output (current-buffer)))
1249 (princ (widget-get widget :value)))))))
1197 ((eq escape ?d) 1250 ((eq escape ?d)
1198 (when doc 1251 (let ((doc (widget-get widget :doc)))
1199 (setq doc-begin (point)) 1252 (when doc
1200 (insert doc) 1253 (setq doc-begin (point))
1201 (while (eq (preceding-char) ?\n) 1254 (insert doc)
1202 (delete-backward-char 1)) 1255 (while (eq (preceding-char) ?\n)
1203 (insert "\n") 1256 (delete-backward-char 1))
1204 (setq doc-end (point)))) 1257 (insert "\n")
1258 (setq doc-end (point)))))
1205 ((eq escape ?v) 1259 ((eq escape ?v)
1206 (if (and button-begin (not button-end)) 1260 (if (and button-begin (not button-end))
1207 (widget-apply widget :value-create) 1261 (widget-apply widget :value-create)
1208 (setq value-pos (point)))) 1262 (setq value-pos (point))))
1209 (t 1263 (t
1384 :type 'boolean) 1438 :type 'boolean)
1385 1439
1386 ;; Cache already created GUI objects. 1440 ;; Cache already created GUI objects.
1387 (defvar widget-push-button-cache nil) 1441 (defvar widget-push-button-cache nil)
1388 1442
1443 (defcustom widget-push-button-prefix "["
1444 "String used as prefix for buttons."
1445 :type 'string
1446 :group 'widget-button)
1447
1448 (defcustom widget-push-button-suffix "]"
1449 "String used as suffix for buttons."
1450 :type 'string
1451 :group 'widget-button)
1452
1389 (define-widget 'push-button 'item 1453 (define-widget 'push-button 'item
1390 "A pushable button." 1454 "A pushable button."
1455 :button-prefix ""
1456 :button-suffix ""
1391 :value-create 'widget-push-button-value-create 1457 :value-create 'widget-push-button-value-create
1392 :text-format "[%s]"
1393 :format "%[%v%]") 1458 :format "%[%v%]")
1394 1459
1395 (defun widget-push-button-value-create (widget) 1460 (defun widget-push-button-value-create (widget)
1396 ;; Insert text representing the `on' and `off' states. 1461 ;; Insert text representing the `on' and `off' states.
1397 (let* ((tag (or (widget-get widget :tag) 1462 (let* ((tag (or (widget-get widget :tag)
1398 (widget-get widget :value))) 1463 (widget-get widget :value)))
1399 (text (format (widget-get widget :text-format) tag)) 1464 (text (concat widget-push-button-prefix
1465 tag widget-push-button-suffix))
1400 (gui (cdr (assoc tag widget-push-button-cache)))) 1466 (gui (cdr (assoc tag widget-push-button-cache))))
1401 (if (and (fboundp 'make-gui-button) 1467 (if (and (fboundp 'make-gui-button)
1402 (fboundp 'make-glyph) 1468 (fboundp 'make-glyph)
1403 widget-push-button-gui 1469 widget-push-button-gui
1404 (fboundp 'device-on-window-system-p) 1470 (fboundp 'device-on-window-system-p)
1406 (string-match "XEmacs" emacs-version)) 1472 (string-match "XEmacs" emacs-version))
1407 (progn 1473 (progn
1408 (unless gui 1474 (unless gui
1409 (setq gui (make-gui-button tag 'widget-gui-action widget)) 1475 (setq gui (make-gui-button tag 'widget-gui-action widget))
1410 (push (cons tag gui) widget-push-button-cache)) 1476 (push (cons tag gui) widget-push-button-cache))
1411 (widget-glyph-insert-glyph widget text 1477 (widget-glyph-insert-glyph widget
1412 (make-glyph (nth 0 (aref gui 1))) 1478 (make-glyph
1413 (make-glyph (nth 1 (aref gui 1))) 1479 (list (nth 0 (aref gui 1))
1414 (make-glyph (nth 2 (aref gui 1))))) 1480 (vector 'string ':data text)))
1481 (make-glyph
1482 (list (nth 1 (aref gui 1))
1483 (vector 'string ':data text)))
1484 (make-glyph
1485 (list (nth 2 (aref gui 1))
1486 (vector 'string ':data text)))))
1415 (insert text)))) 1487 (insert text))))
1416 1488
1417 (defun widget-gui-action (widget) 1489 (defun widget-gui-action (widget)
1418 "Apply :action for WIDGET." 1490 "Apply :action for WIDGET."
1419 (widget-apply-action widget (this-command-keys))) 1491 (widget-apply-action widget (this-command-keys)))
1420 1492
1421 ;;; The `link' Widget. 1493 ;;; The `link' Widget.
1422 1494
1495 (defcustom widget-link-prefix "_"
1496 "String used as prefix for links."
1497 :type 'string
1498 :group 'widget-button)
1499
1500 (defcustom widget-link-suffix "_"
1501 "String used as suffix for links."
1502 :type 'string
1503 :group 'widget-button)
1504
1423 (define-widget 'link 'item 1505 (define-widget 'link 'item
1424 "An embedded link." 1506 "An embedded link."
1507 :button-prefix 'widget-link-prefix
1508 :button-suffix 'widget-link-suffix
1425 :help-echo "Follow the link." 1509 :help-echo "Follow the link."
1426 :format "%[_%t_%]") 1510 :format "%[%t%]")
1427 1511
1428 ;;; The `info-link' Widget. 1512 ;;; The `info-link' Widget.
1429 1513
1430 (define-widget 'info-link 'link 1514 (define-widget 'info-link 'link
1431 "A link to an info file." 1515 "A link to an info file."
1754 1838
1755 ;;; The `checkbox' Widget. 1839 ;;; The `checkbox' Widget.
1756 1840
1757 (define-widget 'checkbox 'toggle 1841 (define-widget 'checkbox 'toggle
1758 "A checkbox toggle." 1842 "A checkbox toggle."
1843 :button-suffix ""
1844 :button-prefix ""
1759 :format "%[%v%]" 1845 :format "%[%v%]"
1760 :on "[X]" 1846 :on "[X]"
1761 :on-glyph "check1" 1847 :on-glyph "check1"
1762 :off "[ ]" 1848 :off "[ ]"
1763 :off-glyph "check0" 1849 :off-glyph "check0"
1938 2024
1939 (define-widget 'radio-button 'toggle 2025 (define-widget 'radio-button 'toggle
1940 "A radio button for use in the `radio' widget." 2026 "A radio button for use in the `radio' widget."
1941 :notify 'widget-radio-button-notify 2027 :notify 'widget-radio-button-notify
1942 :format "%[%v%]" 2028 :format "%[%v%]"
2029 :button-suffix ""
2030 :button-prefix ""
1943 :on "(*)" 2031 :on "(*)"
1944 :on-glyph "radio1" 2032 :on-glyph "radio1"
1945 :off "( )" 2033 :off "( )"
1946 :off-glyph "radio0") 2034 :off-glyph "radio0")
1947 2035
2374 2462
2375 ;;; The `widget-help' Widget. 2463 ;;; The `widget-help' Widget.
2376 2464
2377 (define-widget 'widget-help 'push-button 2465 (define-widget 'widget-help 'push-button
2378 "The widget documentation button." 2466 "The widget documentation button."
2379 :format "%[[%t]%] %d" 2467 :format "%[%t%] %d"
2380 :help-echo "Toggle display of documentation." 2468 :help-echo "Toggle display of documentation."
2381 :action 'widget-help-action) 2469 :action 'widget-help-action)
2382 2470
2383 (defun widget-help-action (widget &optional event) 2471 (defun widget-help-action (widget &optional event)
2384 "Toggle documentation for WIDGET." 2472 "Toggle documentation for WIDGET."