Mercurial > hg > xemacs-beta

comparison lisp/widgets-gtk.el @ 738:5039859429c5

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2002-02-02 13:39:59 by wmperry] Support :callback-ex in GTK widgets
author wmperry
date Sat, 02 Feb 2002 13:39:59 +0000
parents cd662ad69f40
children 95fee4a1420e
comparison
equal deleted inserted replaced
737:6415e2b73e04 738:5039859429c5
37 gtk-vbox-new gtk-label-new gtk-adjustment-new 37 gtk-vbox-new gtk-label-new gtk-adjustment-new
38 gtk-progress-bar-new-with-adjustment gtk-adjustment-set-value 38 gtk-progress-bar-new-with-adjustment gtk-adjustment-set-value
39 gtk-entry-new gtk-entry-set-text gtk-widget-set-style 39 gtk-entry-new gtk-entry-set-text gtk-widget-set-style
40 gtk-widget-get-style)) 40 gtk-widget-get-style))
41 41
42 (defvar foo) 42 (defun gtk-widget-get-callback (widget plist instance)
43 (let ((cb (plist-get plist :callback))
44 (ex (plist-get plist :callback-ex))
45 (real-cb nil))
46 (cond
47 (ex
48 (gtk-signal-connect widget 'button-release-event
49 (lambda (widget event data)
50 (put widget 'last-event event)))
51 `(lambda (widget &rest ignored)
52 (funcall ,ex ,instance (get widget 'last-event))))
53 (cb
54 `(lambda (widget &rest ignored)
55 (if (functionp ,real-cb)
56 (funcall ,real-cb)
57 (eval ,real-cb))))
58 (t
59 nil))))
43 60
44 (defun gtk-widget-instantiate-button-internal (plist callback) 61 (defun gtk-widget-instantiate-button-internal (plist instance)
45 (let* ((type (or (plist-get plist :style) 'button)) 62 (let* ((type (or (plist-get plist :style) 'button))
46 (label (or (plist-get plist :descriptor) (symbol-name type))) 63 (label (or (plist-get plist :descriptor) (symbol-name type)))
47 (widget nil)) 64 (widget nil))
48 (case type 65 (case type
49 (button 66 (button
50 (setq widget (gtk-button-new-with-label label)) 67 (setq widget (gtk-button-new-with-label label))
51 (gtk-signal-connect widget 'clicked (lambda (wid real-cb) 68 (gtk-signal-connect widget 'clicked
52 (if (functionp real-cb) 69 (gtk-widget-get-callback widget plist instance)))
53 (funcall real-cb)
54 (eval real-cb)))
55 callback))
56 (radio 70 (radio
57 (let ((aux nil) 71 (let ((aux nil)
58 (selected-p (plist-get plist :selected))) 72 (selected-p (plist-get plist :selected)))
59 (setq widget (gtk-radio-button-new-with-label nil label) 73 (setq widget (gtk-radio-button-new-with-label nil label)
60 aux (gtk-radio-button-new-with-label 74 aux (gtk-radio-button-new-with-label
61 (gtk-radio-button-group widget) 75 (gtk-radio-button-group widget)
62 "bogus sibling")) 76 "bogus sibling"))
63 (gtk-toggle-button-set-active widget (eval selected-p)) 77 (gtk-toggle-button-set-active widget (eval selected-p))
64 (gtk-signal-connect widget 'toggled 78 (gtk-signal-connect widget 'toggled
65 (lambda (wid data) 79 (gtk-widget-get-callback widget plist instance) aux)))
66 ;; data is (real-cb . sibling)
67 )
68 (cons callback aux))))
69 (otherwise 80 (otherwise
70 ;; Check boxes 81 ;; Check boxes
71 (setq widget (gtk-check-button-new-with-label label)) 82 (setq widget (gtk-check-button-new-with-label label))
72 (gtk-toggle-button-set-active widget 83 (gtk-toggle-button-set-active widget
73 (eval (plist-get plist :selected))) 84 (eval (plist-get plist :selected)))
74 (gtk-signal-connect widget 'toggled 85 (gtk-signal-connect widget 'toggled
75 (lambda (wid real-cb) 86 (gtk-widget-get-callback widget plist instance))))
76 (if (functionp real-cb)
77 (funcall real-cb)
78 (eval real-cb)))
79 callback)))
80
81 (gtk-widget-show-all widget) 87 (gtk-widget-show-all widget)
82 widget)) 88 widget))
83 89
84 (defun gtk-widget-instantiate-notebook-internal (plist callback) 90 (defun gtk-widget-instantiate-notebook-internal (plist instance)
85 (let ((widget (gtk-notebook-new)) 91 (let ((widget (gtk-notebook-new))
86 (items (plist-get plist :items))) 92 (items (plist-get plist :items)))
87 (while items 93 (while items
88 (gtk-notebook-append-page widget 94 (gtk-notebook-append-page widget
89 (gtk-vbox-new nil 3) 95 (gtk-vbox-new nil 3)
90 (gtk-label-new (aref (car items) 0))) 96 (gtk-label-new (aref (car items) 0)))
91 (setq items (cdr items))) 97 (setq items (cdr items)))
92 widget)) 98 widget))
93 99
94 (defun gtk-widget-instantiate-progress-internal (plist callback) 100 (defun gtk-widget-instantiate-progress-internal (plist instance)
95 (let* ((adj (gtk-adjustment-new 0.0 0.0 100.0 1.0 5.0 5.0)) 101 (let* ((adj (gtk-adjustment-new 0.0 0.0 100.0 1.0 5.0 5.0))
96 (widget (gtk-progress-bar-new-with-adjustment adj))) 102 (widget (gtk-progress-bar-new-with-adjustment adj)))
97 (gtk-adjustment-set-value adj (or (plist-get plist :value) 0.0)) 103 (gtk-adjustment-set-value adj (or (plist-get plist :value) 0.0))
98 widget)) 104 widget))
99 105
100 (defun gtk-widget-instantiate-entry-internal (plist callback) 106 (defun gtk-widget-instantiate-entry-internal (plist instance)
101 (let* ((widget (gtk-entry-new)) 107 (let* ((widget (gtk-entry-new))
102 (default (plist-get plist :descriptor))) 108 (default (plist-get plist :descriptor)))
103 (cond 109 (cond
104 ((stringp default) 110 ((stringp default)
105 nil) 111 nil)
126 domain) 132 domain)
127 "The lisp side of widget/glyph instantiation code." 133 "The lisp side of widget/glyph instantiation code."
128 (let* ((type (aref instantiator 0)) 134 (let* ((type (aref instantiator 0))
129 (plist (cdr (map 'list 'identity instantiator))) 135 (plist (cdr (map 'list 'identity instantiator)))
130 (widget (funcall (or (get type 'instantiator) 'ignore) 136 (widget (funcall (or (get type 'instantiator) 'ignore)
131 plist (or (plist-get plist :callback) 'ignore)))) 137 plist instance)))
132 (add-timeout 0.1 (lambda (obj) 138 (add-timeout 0.1 (lambda (obj)
133 (gtk-widget-set-style obj 139 (gtk-widget-set-style obj
134 (gtk-widget-get-style 140 (gtk-widget-get-style
135 (frame-property nil 'text-widget)))) 141 (frame-property nil 'text-widget))))
136 widget) 142 widget)