[cells-cvs] CVS cells-gtk3/cells-gtk

[phildebrandt]

Update of /project/cells/cvsroot/cells-gtk3/cells-gtk
In directory clnet:/tmp/cvs-serv26095/cells-gtk

Modified Files:
	buttons.lisp gtk-app.lisp tree-view.lisp widgets.lisp 
Log Message:
Testing with-widget.


--- /project/cells/cvsroot/cells-gtk3/cells-gtk/buttons.lisp	2008/04/14 16:43:41	1.2
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/buttons.lisp	2008/04/16 14:41:28	1.3
@@ -54,12 +54,16 @@
   (toggled)
   :active (c-in nil)
   :on-toggled (callback (widget event data)
-                ;;(print (list :toggle-button :on-toggled-cb widget))
+                (trc "toggle-button toggled" widget)
                 (with-integrity (:change 'tggle-button-on-toggled-cb)
                   (let ((state (gtk-toggle-button-get-active widget)))
-                    ;;(print (list :toggledstate state))
                     (setf (value self) state)))))
 
+(defobserver .value ((self toggle-button))
+  (trc "observing toggle-button .value" self (value self))
+  (with-integrity (:change 'toggle-button-value)
+    (trc "with integrity")))
+
 #+test
 (DEF-GTK WIDGET TOGGLE-BUTTON (BUTTON) ((INIT :ACCESSOR INIT :INITARG :INIT :INITFORM NIL))
          (MODE ACTIVE) (TOGGLED) :ACTIVE (C-IN NIL) :ON-TOGGLED
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/gtk-app.lisp	2008/04/14 16:43:42	1.3
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/gtk-app.lisp	2008/04/16 14:41:28	1.4
@@ -111,7 +111,8 @@
 
 
 (cffi:defcallback cb-quit :unsigned-int ((data :pointer))
-  (when-bind (self (with-trc (gtk-object-find data)))
+  (trc "cb quit" data (gtk-object-find data))
+  (bwhen (self (gtk-object-find data))
     (setf *system* (delete self *system*))
     (not-to-be self))
   0)
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/tree-view.lisp	2008/04/13 10:59:17	1.1
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/tree-view.lisp	2008/04/16 14:41:28	1.2
@@ -53,6 +53,7 @@
  				 (when (fourth col-def)
  				   (list pos (fourth col-def))))))
    (columns :accessor columns
+	    :owning t
      :initform (c? (mapcar #'(lambda (col-init)
                                (apply #'make-be 'tree-view-column
                                       :container self
@@ -478,7 +479,7 @@
 	     (progn #+msg(print (list "CALCULATE KIDS for family observer" self "on" (^value) "-- parent" (upper self)))
 		    (bwhen (val (^value)) ;; not sure why not
 		      (unless (deadp val)
-			(trcx "creating kids" val (slot-value val 'cells::.md-state) (kids val))
+			(trcx nil "creating kids" val (slot-value val 'cells::.md-state) (kids val))
 			(mapcar #'(lambda (src) (mk-observer self src)) (kids val))))))))
 
 ;;; here do cleanup work, children get called before parents
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/widgets.lisp	2008/04/14 16:43:44	1.2
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/widgets.lisp	2008/04/16 14:41:28	1.3
@@ -36,7 +36,7 @@
 		       (let ((id (apply (symbol-function (new-function-name self))
 					(new-args self))))
 			 (gtk-object-store id self)
-			 (gtk-signal-connect-swap id "configure-event" (cffi:get-callback 'reshape-widget-handler) :data id)
+			 #+libcellsgtk (gtk-signal-connect-swap id "configure-event" (cffi:get-callback 'reshape-widget-handler) :data id)
 			 id))))
    
    (callbacks :cell nil :accessor callbacks
@@ -75,13 +75,16 @@
 
 
 (defun gtk-object-forget (gtk-id gtk-object)
-  (remhash (md-name gtk-object) *widgets*)
-  (when gtk-id
-    (assert *gtk-objects*)
-    (remhash (cffi:pointer-address gtk-id) *gtk-objects*)
-    (mapc (lambda (k)
-            (gtk-object-forget (slot-value k 'id) k))
-      (slot-value gtk-object '.kids))))
+  (when (and gtk-id gtk-object)
+    (trc nil "    forgetting id/obj" gtk-id gtk-object)
+    (let ((ptr (cffi:pointer-address gtk-id)))
+      (assert *widgets*)
+      (when (eql (gethash (md-name gtk-object) *widgets*) gtk-object)
+	(remhash (md-name gtk-object) *widgets*))
+      (assert *gtk-objects*)
+      (remhash ptr *gtk-objects*)
+      (mapc (lambda (k) (gtk-object-forget (slot-value k 'id) k))
+	    (slot-value gtk-object '.kids)))))
 
 (defun gtk-object-find (gtk-id &optional must-find-p &aux (hash-id (cffi:pointer-address gtk-id)))
   (when *gtk-objects*
@@ -101,7 +104,9 @@
 
 (defmacro with-widget ((widget name &optional alternative) &body body)
   `(bif (,widget (find-widget ,name))
-	(progn , at body)
+	(progn
+	  (trc "with widget" ,widget ',body)
+	  , at body)
 	,alternative))
 
 (defmacro with-widget-value ((val name &key (accessor '(quote value)) (alternative nil)) &body body)
@@ -333,15 +338,12 @@
   ()
   (focus show hide delete-event destroy-event)
   ;; this is called unless the user overwrites this routine
-  :on-delete-event (c-in #'(lambda (self widget event data)
-			     (declare (ignore widget event data))
-			     (trc "on-delete")
-			     (gtk-object-forget (id self) self)
-			     0)))
+  )
 
 #+libcellsgtk
 (cffi:defcallback reshape-widget-handler :int ((widget :pointer) (event :pointer) (data :pointer))
   (declare (ignore data event))
+  (trc "reshape" widget)
   (bwhen (self (gtk-object-find widget))
     (let ((new-width (gtk-adds-widget-width widget))
 	  (new-height (gtk-adds-widget-height widget)))
@@ -351,10 +353,6 @@
 	      (allocated-height self) new-height))))
   0)
 
-(defmethod initialize-instance :after ((self widget) &rest initargs)
-  (declare (ignore initargs))
-  #+libcellsgtk-
-  )
 
 (defmethod focus ((self widget))
   (gtk-widget-grab-focus (id self)))
@@ -389,7 +387,9 @@
     (trc "WIDGET DESTROY" (md-name self) (type-of self) self)
     (force-output))
   (gtk-object-forget (slot-value self 'id) self)
-  (gtk-widget-destroy (slot-value self 'id)))
+  (trc nil "not-to-be destroys" self (slot-value self 'id))
+  (gtk-widget-destroy (slot-value self 'id))
+  (trc nil "  done"))
 
 (defun assert-bin (container)
   (assert (null (rest (kids container)))