Add GtkScaleButton documentation

[cl-gtk2.git] / mm-test.lisp

diff --git a/mm-test.lisp b/mm-test.lisp
index 9d44ef1..d152bc5 100644 (file)
--- a/mm-test.lisp
+++ b/mm-test.lisp
@@ -6,6 +6,11 @@
 
 (in-package :mm-test)
 
+(defun get-object (ptr)
+  (when (cffi:pointerp ptr) (setf ptr (cffi:pointer-address ptr)))
+  (or (gethash ptr gobject::*foreign-gobjects-strong*)
+      (gethash ptr gobject::*foreign-gobjects-weak*)))
+
 (defun do-gc ()
   (gc :full t)
   (gobject::activate-gc-hooks)
@@ -16,10 +21,16 @@
   (gobject::activate-gc-hooks)
   (gc :full t))
 
+(defun object-handlers (object)
+  (when object
+    (remove nil (gobject::g-object-signal-handlers object))))
+
 (defun print-refs-table (table &optional (stream *standard-output*))
   (iter (for (ptr object) in-hashtable table)
-        (format stream "~A => ~A (~A refs)~%"
-                ptr object (gobject::ref-count object))))
+        (format stream "~A => ~A (~A refs~@[~*, floating~])~@[ handlers: ~A~]~%"
+                ptr object (gobject::ref-count object)
+                (gobject.ffi:g-object-is-floating (cffi:make-pointer ptr))
+                (object-handlers object))))
 
 (defun print-refs (&optional (stream *standard-output*))
   (format stream "Strong:~%")
@@ -61,7 +72,8 @@
 ")))
 
 (setf gobject::*debug-stream* *standard-output*
-      gobject::*debug-gc* t)
+      gobject::*debug-gc* t
+      gobject::*debug-subclass* t)
 
 (defclass my-button (gtk:button) () (:metaclass gobject-class))
 
@@ -134,3 +146,16 @@
       (gc :full t)
       (gobject::activate-gc-hooks))
     nil))
+
+(defun make-builder (&optional return)
+  (let* ((builder (make-instance 'gtk:builder
+                                 :from-file (namestring (merge-pathnames "demo/demo1.ui" gtk-demo::*src-location*))))
+         (text-view (builder-get-object builder "textview1"))
+         (window (builder-get-object builder "window1")))
+    (builder-connect-signals-simple
+     builder
+     `(("quit_cb"
+        ,(lambda (&rest args)
+                 (print args)
+                 (object-destroy window)))))
+    (when return builder)))