Mercurial > hg > xemacs-beta

comparison lisp/wid-edit.el @ 454:d7a9135ec789 r21-2-42

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-42
author cvs
date Mon, 13 Aug 2007 11:40:54 +0200
parents 1ccc32a20af4
children 2cf5d151eeb9
comparison
equal deleted inserted replaced
453:270b05afd845 454:d7a9135ec789
478 (and (not activate-p) 478 (and (not activate-p)
479 (not (zerop (extent-property extent :inactive-count))))) 479 (not (zerop (extent-property extent :inactive-count)))))
480 (let* ((glyph-widget (extent-property extent 'glyph-widget)) 480 (let* ((glyph-widget (extent-property extent 'glyph-widget))
481 (up-glyph (widget-get glyph-widget :glyph-up)) 481 (up-glyph (widget-get glyph-widget :glyph-up))
482 (inactive-glyph (widget-get glyph-widget :glyph-inactive)) 482 (inactive-glyph (widget-get glyph-widget :glyph-inactive))
483 (instantiator (widget-get glyph-widget :glyph-instantiator))
483 (new-glyph (if activate-p up-glyph inactive-glyph))) 484 (new-glyph (if activate-p up-glyph inactive-glyph)))
485 (cond
486 ;; Assume that an instantiator means a native widget.
487 (instantiator
488 (setq instantiator
489 (set-instantiator-property instantiator :active activate-p))
490 (widget-put glyph-widget :glyph-instantiator instantiator)
491 (set-glyph-image up-glyph instantiator))
484 ;; Check that the new glyph exists, and differs from the 492 ;; Check that the new glyph exists, and differs from the
485 ;; default one. 493 ;; default one.
486 (and up-glyph inactive-glyph (not (eq up-glyph inactive-glyph)) 494 ((and up-glyph inactive-glyph (not (eq up-glyph inactive-glyph))
487 ;; Check if the glyph is already installed. 495 ;; Check if the glyph is already installed.
488 (not (eq (extent-end-glyph extent) new-glyph)) 496 (not (eq (extent-end-glyph extent) new-glyph)))
489 ;; Change it. 497 ;; Change it.
490 (set-extent-end-glyph extent new-glyph))))) 498 (set-extent-end-glyph extent new-glyph))))))
491 nil) 499 nil)
492 500
493 (defun widget-specify-inactive (widget from to) 501 (defun widget-specify-inactive (widget from to)
494 "Make WIDGET inactive for user modifications." 502 "Make WIDGET inactive for user modifications."
495 (unless (widget-get widget :inactive) 503 (unless (widget-get widget :inactive)
783 (widget-glyph-find down tag) 791 (widget-glyph-find down tag)
784 (widget-glyph-find inactive tag)) 792 (widget-glyph-find inactive tag))
785 (insert tag)) 793 (insert tag))
786 glyph)) 794 glyph))
787 795
788 (defun widget-glyph-insert-glyph (widget glyph &optional down inactive) 796 (defun widget-glyph-insert-glyph (widget glyph &optional down inactive
797 instantiator)
789 "In WIDGET, insert GLYPH. 798 "In WIDGET, insert GLYPH.
790 If optional arguments DOWN and INACTIVE are given, they should be 799 If optional arguments DOWN and INACTIVE are given, they should be
791 glyphs used when the widget is pushed and inactive, respectively." 800 glyphs used when the widget is pushed and inactive, respectively.
801 INSTANTIATOR is the vector used to create the glyph."
792 (insert "*") 802 (insert "*")
793 (let ((extent (make-extent (point) (1- (point)))) 803 (let ((extent (make-extent (point) (1- (point))))
794 (help-echo (and widget (widget-get widget :help-echo))) 804 (help-echo (and widget (widget-get widget :help-echo)))
795 (map (and widget (widget-get widget :button-keymap)))) 805 (map (and widget (widget-get widget :button-keymap))))
796 (set-extent-property extent 'glyph-widget widget) 806 (set-extent-property extent 'glyph-widget widget)
808 (when help-echo 818 (when help-echo
809 (widget-handle-help-echo extent help-echo))) 819 (widget-handle-help-echo extent help-echo)))
810 (when widget 820 (when widget
811 (widget-put widget :glyph-up glyph) 821 (widget-put widget :glyph-up glyph)
812 (when down (widget-put widget :glyph-down down)) 822 (when down (widget-put widget :glyph-down down))
823 (when instantiator (widget-put widget :glyph-instantiator instantiator))
813 (when inactive (widget-put widget :glyph-inactive inactive)))) 824 (when inactive (widget-put widget :glyph-inactive inactive))))
814 825
815 826
816 ;;; Buttons. 827 ;;; Buttons.
817 828
1922 (let* ((tag (or (widget-get widget :tag) 1933 (let* ((tag (or (widget-get widget :tag)
1923 (widget-get widget :value))) 1934 (widget-get widget :value)))
1924 (tag-glyph (widget-get widget :tag-glyph)) 1935 (tag-glyph (widget-get widget :tag-glyph))
1925 (text (concat widget-push-button-prefix 1936 (text (concat widget-push-button-prefix
1926 tag widget-push-button-suffix)) 1937 tag widget-push-button-suffix))
1927 gui) 1938 gui inst)
1928 (cond (tag-glyph 1939 (cond (tag-glyph
1929 (widget-glyph-insert widget text tag-glyph)) 1940 (widget-glyph-insert widget text tag-glyph))
1930 ;; We must check for console-on-window-system-p here, 1941 ;; We must check for console-on-window-system-p here,
1931 ;; because GUI will not work otherwise (it needs RGB 1942 ;; because GUI will not work otherwise (it needs RGB
1932 ;; components for colors, and they are not known on TTYs). 1943 ;; components for colors, and they are not known on TTYs).
1933 ((and widget-push-button-gui 1944 ((and widget-push-button-gui
1934 (console-on-window-system-p)) 1945 (console-on-window-system-p))
1935 (let* ((gui-button-shadow-thickness 1)) 1946 (let* ((gui-button-shadow-thickness 1))
1936 (setq gui (make-glyph 1947 (setq inst (make-gui-button tag 'widget-gui-action widget))
1937 (make-gui-button tag 'widget-gui-action widget)))) 1948 (setq gui (make-glyph inst)))
1938 (widget-glyph-insert-glyph widget gui)) 1949 (widget-glyph-insert-glyph widget gui nil nil inst))
1939 (t 1950 (t
1940 (insert text))))) 1951 (insert text)))))
1941 1952
1942 (defun widget-gui-action (widget) 1953 (defun widget-gui-action (widget)
1943 "Apply :action for WIDGET." 1954 "Apply :action for WIDGET."