XEmacs 21.4.17 "Jumbo Shrimp".

[chise/xemacs-chise.git.1] / lisp / widgets-gtk.el

diff --git a/lisp/widgets-gtk.el b/lisp/widgets-gtk.el
index 38a151a..06b74d7 100644 (file)
--- a/lisp/widgets-gtk.el
+++ b/lisp/widgets-gtk.el
@@ -30,18 +30,34 @@
 
 (defvar foo)
 
-(defun gtk-widget-instantiate-button-internal (plist callback)
+(defun gtk-widget-get-callback (widget plist instance)
+  (let ((cb (plist-get plist :callback))
+       (ex (plist-get plist :callback-ex))
+       (real-cb nil))
+    (cond
+     (ex
+      (gtk-signal-connect widget 'button-release-event
+                         (lambda (widget event data)
+                           (put widget 'last-event event)))
+      `(lambda (widget &rest ignored)
+        (funcall ,ex ,instance (get widget 'last-event))))
+     (cb
+      `(lambda (widget &rest ignored)
+        (if (functionp ,real-cb)
+            (funcall ,real-cb)
+          (eval ,real-cb))))
+     (t
+      nil))))
+
+(defun gtk-widget-instantiate-button-internal (plist instance)
   (let* ((type (or (plist-get plist :style) 'button))
         (label (or (plist-get plist :descriptor) (symbol-name type)))
         (widget nil))
     (case type
       (button
        (setq widget (gtk-button-new-with-label label))
-       (gtk-signal-connect widget 'clicked (lambda (wid real-cb)
-                                            (if (functionp real-cb)
-                                                (funcall real-cb)
-                                              (eval real-cb)))
-                          callback))
+       (gtk-signal-connect widget 'clicked
+                          (gtk-widget-get-callback widget plist instance)))
       (radio
        (let ((aux nil)
             (selected-p (plist-get plist :selected)))
@@ -51,33 +67,25 @@
                    "bogus sibling"))
         (gtk-toggle-button-set-active widget (eval selected-p))
         (gtk-signal-connect widget 'toggled
-                            (lambda (wid data)
-                              ;; data is (real-cb . sibling)
-                              )
-                            (cons callback aux))))
+                            (gtk-widget-get-callback widget plist instance) aux)))
       (otherwise
        ;; Check boxes
        (setq widget (gtk-check-button-new-with-label label))
        (gtk-toggle-button-set-active widget
                                     (eval (plist-get plist :selected)))
        (gtk-signal-connect widget 'toggled
-                          (lambda (wid real-cb)
-                            (if (functionp real-cb)
-                                (funcall real-cb)
-                              (eval real-cb)))
-                          callback)))
-
+                          (gtk-widget-get-callback widget plist instance))))
     (gtk-widget-show-all widget)
     widget))
 
 (defun gtk-widget-instantiate-notebook-internal (plist callback)
   (let ((widget (gtk-notebook-new))
        (items (plist-get plist :items)))
-    (while items
-      (gtk-notebook-append-page widget
-                               (gtk-vbox-new nil 3)
-                               (gtk-label-new (aref (car items) 0)))
-      (setq items (cdr items)))
+;     (while items
+;       (gtk-notebook-append-page widget
+;                              (gtk-vbox-new nil 3)
+;                              (gtk-label-new (aref (car items) 0)))
+;       (setq items (cdr items)))
     widget))
 
 (defun gtk-widget-instantiate-progress-internal (plist callback)
@@ -117,12 +125,12 @@
   (let* ((type (aref instantiator 0))
         (plist (cdr (map 'list 'identity instantiator)))
         (widget (funcall (or (get type 'instantiator) 'ignore)
-                         plist (or (plist-get plist :callback) 'ignore))))
-    (add-timeout 0.1 (lambda (obj)
-                      (gtk-widget-set-style obj
-                                            (gtk-widget-get-style
-                                             (frame-property nil 'text-widget))))
-                widget)
+                         plist instance)))
+;     (add-timeout 0.1 (lambda (obj)
+;                     (gtk-widget-set-style obj
+;                                           (gtk-widget-get-style
+;                                            (frame-property nil 'text-widget))))
+;               widget)
     (setq x widget)
     widget))