Mercurial > hg > xemacs-beta

comparison lisp/wid-edit.el @ 412:697ef44129c6 r21-2-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-14
author cvs
date Mon, 13 Aug 2007 11:20:41 +0200
parents 74fd4e045ea6
children 41dbb7a9d5f2
comparison
equal deleted inserted replaced
411:12e008d41344 412:697ef44129c6
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, 2000 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 ;; Maintainer: Hrvoje Niksic <hniksic@xemacs.org> 6 ;; Maintainer: Hrvoje Niksic <hniksic@srce.hr>
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 controlling the display of documentation strings." 52 "Options controling 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 (listp vals) 604 ((and 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)
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
1901 (defcustom widget-push-button-prefix "[" 1904 (defcustom widget-push-button-prefix "["
1902 "String used as prefix for buttons." 1905 "String used as prefix for buttons."
1903 :type 'string 1906 :type 'string
1904 :group 'widget-button) 1907 :group 'widget-button)
1905 1908
1920 (let* ((tag (or (widget-get widget :tag) 1923 (let* ((tag (or (widget-get widget :tag)
1921 (widget-get widget :value))) 1924 (widget-get widget :value)))
1922 (tag-glyph (widget-get widget :tag-glyph)) 1925 (tag-glyph (widget-get widget :tag-glyph))
1923 (text (concat widget-push-button-prefix 1926 (text (concat widget-push-button-prefix
1924 tag widget-push-button-suffix)) 1927 tag widget-push-button-suffix))
1925 gui) 1928 (gui-glyphs (lax-plist-get widget-push-button-cache tag)))
1926 (cond (tag-glyph 1929 (cond (tag-glyph
1927 (widget-glyph-insert widget text tag-glyph)) 1930 (widget-glyph-insert widget text tag-glyph))
1928 ;; We must check for console-on-window-system-p here, 1931 ;; We must check for console-on-window-system-p here,
1929 ;; because GUI will not work otherwise (it needs RGB 1932 ;; because GUI will not work otherwise (it needs RGB
1930 ;; components for colors, and they are not known on TTYs). 1933 ;; components for colors, and they are not known on TTYs).
1931 ((and widget-push-button-gui 1934 ((and widget-push-button-gui
1932 (console-on-window-system-p)) 1935 (console-on-window-system-p))
1933 (let* ((gui-button-shadow-thickness 1)) 1936 (unless gui-glyphs
1934 (setq gui (make-glyph 1937 (let* ((gui-button-shadow-thickness 1)
1935 (make-gui-button tag 'widget-gui-action widget)))) 1938 (gui (make-gui-button tag 'widget-gui-action widget)))
1936 (widget-glyph-insert-glyph widget gui)) 1939 (setq
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)))
1937 (t 1948 (t
1938 (insert text))))) 1949 (insert text)))))
1939 1950
1940 (defun widget-gui-action (widget) 1951 (defun widget-gui-action (widget)
1941 "Apply :action for WIDGET." 1952 "Apply :action for WIDGET."
2519 (t 2530 (t
2520 (setq vals nil))))) 2531 (setq vals nil)))))
2521 found)) 2532 found))
2522 2533
2523 (defun widget-checklist-match-up (args vals) 2534 (defun widget-checklist-match-up (args vals)
2524 ;; Return the first type from ARGS that matches VALS. 2535 ;; Rerturn the first type from ARGS that matches VALS.
2525 (let (current found) 2536 (let (current found)
2526 (while (and args (null found)) 2537 (while (and args (null found))
2527 (setq current (car args) 2538 (setq current (car args)
2528 args (cdr args) 2539 args (cdr args)
2529 found (widget-match-inline current vals))) 2540 found (widget-match-inline current vals)))
2541 (if (widget-value (widget-get child :button)) 2552 (if (widget-value (widget-get child :button))
2542 (setq result (append result (widget-apply child :value-inline))))) 2553 (setq result (append result (widget-apply child :value-inline)))))
2543 result)) 2554 result))
2544 2555
2545 (defun widget-checklist-validate (widget) 2556 (defun widget-checklist-validate (widget)
2546 ;; Ticked children must be valid. 2557 ;; Ticked chilren must be valid.
2547 (let ((children (widget-get widget :children)) 2558 (let ((children (widget-get widget :children))
2548 child button found) 2559 child button found)
2549 (while (and children (not found)) 2560 (while (and children (not found))
2550 (setq child (car children) 2561 (setq child (car children)
2551 children (cdr children) 2562 children (cdr children)