Mercurial > hg > xemacs-beta

comparison lisp/wid-edit.el @ 398:74fd4e045ea6 r21-2-29

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-29
author cvs
date Mon, 13 Aug 2007 11:13:30 +0200
parents 064ab7fed2e0
children 697ef44129c6
comparison
equal deleted inserted replaced
397:f4aeb21a5bad 398:74fd4e045ea6
1 ;;; wid-edit.el --- Functions for creating and using widgets. 1 ;;; wid-edit.el --- Functions for creating and using widgets.
2 ;; 2 ;;
3 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. 3 ;; Copyright (C) 1996, 1997, 2000 Free Software Foundation, Inc.
4 ;; 4 ;;
5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> 5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
6 ;; Maintainer: Hrvoje Niksic <hniksic@srce.hr> 6 ;; Maintainer: Hrvoje Niksic <hniksic@xemacs.org>
7 ;; Keywords: extensions 7 ;; Keywords: extensions
8 ;; Version: 1.9960-x 8 ;; Version: 1.9960-x
9 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ 9 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
10 10
11 ;; This file is part of XEmacs. 11 ;; This file is part of XEmacs.
47 :prefix "widget-" 47 :prefix "widget-"
48 :group 'extensions 48 :group 'extensions
49 :group 'hypermedia) 49 :group 'hypermedia)
50 50
51 (defgroup widget-documentation nil 51 (defgroup widget-documentation nil
52 "Options controling the display of documentation strings." 52 "Options controlling the display of documentation strings."
53 :group 'widgets) 53 :group 'widgets)
54 54
55 (defgroup widget-faces nil 55 (defgroup widget-faces nil
56 "Faces used by the widget library." 56 "Faces used by the widget library."
57 :group 'widgets 57 :group 'widgets
599 599
600 (defun widget-match-inline (widget vals) 600 (defun widget-match-inline (widget vals)
601 ;; In WIDGET, match the start of VALS. 601 ;; In WIDGET, match the start of VALS.
602 (cond ((widget-get widget :inline) 602 (cond ((widget-get widget :inline)
603 (widget-apply widget :match-inline vals)) 603 (widget-apply widget :match-inline vals))
604 ((and vals 604 ((and (listp vals)
605 (widget-apply widget :match (car vals))) 605 (widget-apply widget :match (car vals)))
606 (cons (list (car vals)) (cdr vals))) 606 (cons (list (car vals)) (cdr vals)))
607 (t nil))) 607 (t nil)))
608 608
609 (defun widget-apply-action (widget &optional event) 609 (defun widget-apply-action (widget &optional event)
672 (defcustom widget-glyph-enable t 672 (defcustom widget-glyph-enable t
673 "If non nil, use glyphs in images when available." 673 "If non nil, use glyphs in images when available."
674 :group 'widgets 674 :group 'widgets
675 :type 'boolean) 675 :type 'boolean)
676 676
677 (defcustom widget-image-conversion 677 (defcustom widget-image-file-name-suffixes
678 '((xpm ".xpm") (gif ".gif") (png ".png") (jpeg ".jpg" ".jpeg") 678 '((xpm ".xpm") (gif ".gif") (png ".png") (jpeg ".jpg" ".jpeg")
679 (xbm ".xbm")) 679 (xbm ".xbm"))
680 "Conversion alist from image formats to file name suffixes." 680 "Conversion alist from image formats to file name suffixes."
681 :group 'widgets 681 :group 'widgets
682 :type '(repeat (cons :format "%v" 682 :type '(repeat (cons :format "%v"
721 (or (lax-plist-get widget-glyph-cache image) 721 (or (lax-plist-get widget-glyph-cache image)
722 ;; ...and then in the relevant directories 722 ;; ...and then in the relevant directories
723 (let* ((dirlist (cons (or widget-glyph-directory 723 (let* ((dirlist (cons (or widget-glyph-directory
724 (locate-data-directory "custom")) 724 (locate-data-directory "custom"))
725 data-directory-list)) 725 data-directory-list))
726 (formats widget-image-conversion) 726 (all-suffixes
727 file) 727 (apply #'append
728 (while (and formats (not file)) 728 (mapcar
729 ;; This dance is necessary, because XEmacs signals an 729 (lambda (el)
730 ;; error when it encounters an unrecognized image 730 (and (valid-image-instantiator-format-p (car el))
731 ;; format. 731 (cdr el)))
732 (when (valid-image-instantiator-format-p (caar formats)) 732 widget-image-file-name-suffixes)))
733 (setq file (locate-file image dirlist 733 (file (locate-file image dirlist all-suffixes)))
734 (mapconcat #'identity (cdar formats)
735 ":"))))
736 (unless file
737 (pop formats)))
738 (when file 734 (when file
739 ;; We create a glyph with the file as the default image 735 (let* ((extension (concat "." (file-name-extension file)))
740 ;; instantiator, and the TAG fallback 736 (format (car (rassoc* extension
741 (let ((glyph (make-glyph `([,(caar formats) :file ,file] 737 widget-image-file-name-suffixes
742 [string :data ,tag])))) 738 :test #'member))))
743 ;; Cache the glyph 739 ;; We create a glyph with the file as the default image
744 (laxputf widget-glyph-cache image glyph) 740 ;; instantiator, and the TAG fallback
745 ;; ...and return it 741 (let ((glyph (make-glyph `([,format :file ,file]
746 glyph))))) 742 [string :data ,tag]))))
743 ;; Cache the glyph
744 (laxputf widget-glyph-cache image glyph)
745 ;; ...and return it
746 glyph))))))
747 ((valid-instantiator-p image 'image) 747 ((valid-instantiator-p image 'image)
748 ;; A valid image instantiator (e.g. [gif :file "somefile"] etc.) 748 ;; A valid image instantiator (e.g. [gif :file "somefile"] etc.)
749 (make-glyph `(,image [string :data ,tag]))) 749 (make-glyph `(,image [string :data ,tag])))
750 (t 750 (t
751 ;; Oh well. 751 ;; Oh well.
1896 (defcustom widget-push-button-gui widget-glyph-enable 1896 (defcustom widget-push-button-gui widget-glyph-enable
1897 "If non nil, use GUI push buttons when available." 1897 "If non nil, use GUI push buttons when available."
1898 :group 'widgets 1898 :group 'widgets
1899 :type 'boolean) 1899 :type 'boolean)
1900 1900
1901 ;; Cache already created GUI objects.
1902 (defvar widget-push-button-cache nil)
1903
1904 (defcustom widget-push-button-prefix "[" 1901 (defcustom widget-push-button-prefix "["
1905 "String used as prefix for buttons." 1902 "String used as prefix for buttons."
1906 :type 'string 1903 :type 'string
1907 :group 'widget-button) 1904 :group 'widget-button)
1908 1905
1923 (let* ((tag (or (widget-get widget :tag) 1920 (let* ((tag (or (widget-get widget :tag)
1924 (widget-get widget :value))) 1921 (widget-get widget :value)))
1925 (tag-glyph (widget-get widget :tag-glyph)) 1922 (tag-glyph (widget-get widget :tag-glyph))
1926 (text (concat widget-push-button-prefix 1923 (text (concat widget-push-button-prefix
1927 tag widget-push-button-suffix)) 1924 tag widget-push-button-suffix))
1928 (gui-glyphs (lax-plist-get widget-push-button-cache tag))) 1925 gui)
1929 (cond (tag-glyph 1926 (cond (tag-glyph
1930 (widget-glyph-insert widget text tag-glyph)) 1927 (widget-glyph-insert widget text tag-glyph))
1931 ;; We must check for console-on-window-system-p here, 1928 ;; We must check for console-on-window-system-p here,
1932 ;; because GUI will not work otherwise (it needs RGB 1929 ;; because GUI will not work otherwise (it needs RGB
1933 ;; components for colors, and they are not known on TTYs). 1930 ;; components for colors, and they are not known on TTYs).
1934 ((and widget-push-button-gui 1931 ((and widget-push-button-gui
1935 (console-on-window-system-p)) 1932 (console-on-window-system-p))
1936 (unless gui-glyphs 1933 (let* ((gui-button-shadow-thickness 1))
1937 (let* ((gui-button-shadow-thickness 1) 1934 (setq gui (make-glyph
1938 (gui (make-gui-button tag 'widget-gui-action widget))) 1935 (make-gui-button tag 'widget-gui-action widget))))
1939 (setq 1936 (widget-glyph-insert-glyph widget gui))
1940 gui-glyphs
1941 (list
1942 (make-glyph `(,(nth 0 (aref gui 1)) [string :data ,text]))
1943 (make-glyph `(,(nth 1 (aref gui 1)) [string :data ,text]))
1944 (make-glyph `(,(nth 2 (aref gui 1)) [string :data ,text]))))
1945 (laxputf widget-push-button-cache tag gui-glyphs)))
1946 (widget-glyph-insert-glyph
1947 widget (nth 0 gui-glyphs) (nth 1 gui-glyphs) (nth 2 gui-glyphs)))
1948 (t 1937 (t
1949 (insert text))))) 1938 (insert text)))))
1950 1939
1951 (defun widget-gui-action (widget) 1940 (defun widget-gui-action (widget)
1952 "Apply :action for WIDGET." 1941 "Apply :action for WIDGET."
2530 (t 2519 (t
2531 (setq vals nil))))) 2520 (setq vals nil)))))
2532 found)) 2521 found))
2533 2522
2534 (defun widget-checklist-match-up (args vals) 2523 (defun widget-checklist-match-up (args vals)
2535 ;; Rerturn the first type from ARGS that matches VALS. 2524 ;; Return the first type from ARGS that matches VALS.
2536 (let (current found) 2525 (let (current found)
2537 (while (and args (null found)) 2526 (while (and args (null found))
2538 (setq current (car args) 2527 (setq current (car args)
2539 args (cdr args) 2528 args (cdr args)
2540 found (widget-match-inline current vals))) 2529 found (widget-match-inline current vals)))
2552 (if (widget-value (widget-get child :button)) 2541 (if (widget-value (widget-get child :button))
2553 (setq result (append result (widget-apply child :value-inline))))) 2542 (setq result (append result (widget-apply child :value-inline)))))
2554 result)) 2543 result))
2555 2544
2556 (defun widget-checklist-validate (widget) 2545 (defun widget-checklist-validate (widget)
2557 ;; Ticked chilren must be valid. 2546 ;; Ticked children must be valid.
2558 (let ((children (widget-get widget :children)) 2547 (let ((children (widget-get widget :children))
2559 child button found) 2548 child button found)
2560 (while (and children (not found)) 2549 (while (and children (not found))
2561 (setq child (car children) 2550 (setq child (car children)
2562 children (cdr children) 2551 children (cdr children)