Mercurial > hg > xemacs-beta

comparison lisp/wid-edit.el @ 280:7df0dd720c89 r21-0b38

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-0b38
author cvs
date Mon, 13 Aug 2007 10:32:22 +0200
parents 90d73dddcdc4
children c9fe270a4101
comparison
equal deleted inserted replaced
279:c20b2fb5bb0a 280:7df0dd720c89
570 "Set the current value of WIDGET to VALUE." 570 "Set the current value of WIDGET to VALUE."
571 (widget-apply widget 571 (widget-apply widget
572 :value-set (widget-apply widget 572 :value-set (widget-apply widget
573 :value-to-internal value))) 573 :value-to-internal value)))
574 574
575 (defun widget-default-get (widget)
576 "Extract the defaylt value of WIDGET."
577 (or (widget-get widget :value)
578 (widget-apply widget :default-get)))
579
575 (defun widget-match-inline (widget vals) 580 (defun widget-match-inline (widget vals)
576 ;; In WIDGET, match the start of VALS. 581 ;; In WIDGET, match the start of VALS.
577 (cond ((widget-get widget :inline) 582 (cond ((widget-get widget :inline)
578 (widget-apply widget :match-inline vals)) 583 (widget-apply widget :match-inline vals))
579 ((and vals 584 ((and vals
1579 :sample-face-get 'widget-default-sample-face-get 1584 :sample-face-get 'widget-default-sample-face-get
1580 :button-keymap widget-button-keymap 1585 :button-keymap widget-button-keymap
1581 :delete 'widget-default-delete 1586 :delete 'widget-default-delete
1582 :value-set 'widget-default-value-set 1587 :value-set 'widget-default-value-set
1583 :value-inline 'widget-default-value-inline 1588 :value-inline 'widget-default-value-inline
1589 :default-get 'widget-default-default-get
1584 :menu-tag-get 'widget-default-menu-tag-get 1590 :menu-tag-get 'widget-default-menu-tag-get
1585 :validate (lambda (widget) nil) 1591 :validate (lambda (widget) nil)
1586 :active 'widget-default-active 1592 :active 'widget-default-active
1587 :activate 'widget-specify-active 1593 :activate 'widget-specify-active
1588 :deactivate 'widget-default-deactivate 1594 :deactivate 'widget-default-deactivate
1787 ;; Wrap value in a list unless it is inline. 1793 ;; Wrap value in a list unless it is inline.
1788 (if (widget-get widget :inline) 1794 (if (widget-get widget :inline)
1789 (widget-value widget) 1795 (widget-value widget)
1790 (list (widget-value widget)))) 1796 (list (widget-value widget))))
1791 1797
1798 (defun widget-default-default-get (widget)
1799 ;; Get `:value'.
1800 (widget-get widget :value))
1801
1792 (defun widget-default-menu-tag-get (widget) 1802 (defun widget-default-menu-tag-get (widget)
1793 ;; Use tag or value for menus. 1803 ;; Use tag or value for menus.
1794 (or (widget-get widget :menu-tag) 1804 (or (widget-get widget :menu-tag)
1795 (widget-get widget :tag) 1805 (widget-get widget :tag)
1796 (widget-princ-to-string (widget-get widget :value)))) 1806 (widget-princ-to-string (widget-get widget :value))))
2198 :void '(item :format "invalid (%t)\n") 2208 :void '(item :format "invalid (%t)\n")
2199 :value-create 'widget-choice-value-create 2209 :value-create 'widget-choice-value-create
2200 :value-delete 'widget-children-value-delete 2210 :value-delete 'widget-children-value-delete
2201 :value-get 'widget-choice-value-get 2211 :value-get 'widget-choice-value-get
2202 :value-inline 'widget-choice-value-inline 2212 :value-inline 'widget-choice-value-inline
2213 :default-get 'widget-choice-default-get
2203 :mouse-down-action 'widget-choice-mouse-down-action 2214 :mouse-down-action 'widget-choice-mouse-down-action
2204 :action 'widget-choice-action 2215 :action 'widget-choice-action
2205 :error "Make a choice" 2216 :error "Make a choice"
2206 :validate 'widget-choice-validate 2217 :validate 'widget-choice-validate
2207 :match 'widget-choice-match 2218 :match 'widget-choice-match
2238 (widget-value (car (widget-get widget :children)))) 2249 (widget-value (car (widget-get widget :children))))
2239 2250
2240 (defun widget-choice-value-inline (widget) 2251 (defun widget-choice-value-inline (widget)
2241 ;; Get value of the child widget. 2252 ;; Get value of the child widget.
2242 (widget-apply (car (widget-get widget :children)) :value-inline)) 2253 (widget-apply (car (widget-get widget :children)) :value-inline))
2254
2255 (defun widget-choice-default-get (widget)
2256 ;; Get default for the first choice.
2257 (widget-default-get (car (widget-get widget :args))))
2243 2258
2244 (defcustom widget-choice-toggle nil 2259 (defcustom widget-choice-toggle nil
2245 "If non-nil, a binary choice will just toggle between the values. 2260 "If non-nil, a binary choice will just toggle between the values.
2246 Otherwise, the user will explicitly have to choose between the values 2261 Otherwise, the user will explicitly have to choose between the values
2247 when he invoked the menu." 2262 when he invoked the menu."
2306 (let ((choice 2321 (let ((choice
2307 (widget-choose tag (reverse choices) event))) 2322 (widget-choose tag (reverse choices) event)))
2308 (widget-put widget :explicit-choice choice) 2323 (widget-put widget :explicit-choice choice)
2309 choice)))) 2324 choice))))
2310 (when current 2325 (when current
2311 (widget-value-set widget 2326 (let ((value (widget-default-get current)))
2312 (widget-apply current :value-to-external 2327 (widget-value-set widget
2313 (widget-get current :value))) 2328 (widget-apply current :value-to-external value)))
2314 (widget-setup) 2329 (widget-setup)
2315 (widget-apply widget :notify widget event))) 2330 (widget-apply widget :notify widget event)))
2316 (run-hook-with-args 'widget-edit-functions widget)) 2331 (run-hook-with-args 'widget-edit-functions widget))
2317 2332
2318 (defun widget-choice-validate (widget) 2333 (defun widget-choice-validate (widget)
2918 (widget-get widget :delete-button-args)))) 2933 (widget-get widget :delete-button-args))))
2919 ((eq escape ?v) 2934 ((eq escape ?v)
2920 (if conv 2935 (if conv
2921 (setq child (widget-create-child-value 2936 (setq child (widget-create-child-value
2922 widget type value)) 2937 widget type value))
2923 (setq child (widget-create-child widget type)))) 2938 (setq child (widget-create-child-value
2939 widget type (widget-default-get type)))))
2924 (t 2940 (t
2925 (signal 'error (list "Unknown escape" escape)))))) 2941 (signal 'error (list "Unknown escape" escape))))))
2926 (widget-put widget 2942 (widget-put widget
2927 :buttons (cons delete 2943 :buttons (cons delete
2928 (cons insert 2944 (cons insert
2944 :convert-widget 'widget-types-convert-widget 2960 :convert-widget 'widget-types-convert-widget
2945 :format "%v" 2961 :format "%v"
2946 :value-create 'widget-group-value-create 2962 :value-create 'widget-group-value-create
2947 :value-delete 'widget-children-value-delete 2963 :value-delete 'widget-children-value-delete
2948 :value-get 'widget-editable-list-value-get 2964 :value-get 'widget-editable-list-value-get
2965 :default-get 'widget-group-default-get
2949 :validate 'widget-children-validate 2966 :validate 'widget-children-validate
2950 :match 'widget-group-match 2967 :match 'widget-group-match
2951 :match-inline 'widget-group-match-inline) 2968 :match-inline 'widget-group-match-inline)
2952 2969
2953 (defun widget-group-value-create (widget) 2970 (defun widget-group-value-create (widget)
2969 (widget-create-child-value widget arg (car answer))) 2986 (widget-create-child-value widget arg (car answer)))
2970 (t 2987 (t
2971 (widget-create-child-value widget arg (car (car answer))))) 2988 (widget-create-child-value widget arg (car (car answer)))))
2972 children)) 2989 children))
2973 (widget-put widget :children (nreverse children)))) 2990 (widget-put widget :children (nreverse children))))
2991
2992 (defun widget-group-default-get (widget)
2993 ;; Get the default of the components.
2994 (mapcar 'widget-default-get (widget-get widget :args)))
2974 2995
2975 (defun widget-group-match (widget values) 2996 (defun widget-group-match (widget values)
2976 ;; Match if the components match. 2997 ;; Match if the components match.
2977 (and (listp values) 2998 (and (listp values)
2978 (let ((match (widget-group-match-inline widget values))) 2999 (let ((match (widget-group-match-inline widget values)))