mm-test.lisp

   1 (eval-when (:load-toplevel :compile-toplevel :execute)
   2   (require :fiveam))
   3
   4 (defpackage :mm-test
   5   (:use :cl :gtk :glib :gobject :iter :tg :5am))
   6
   7 (in-package :mm-test)
   8
   9 (defun get-object (ptr)
  10   (when (cffi:pointerp ptr) (setf ptr (cffi:pointer-address ptr)))
  11   (or (gethash ptr gobject::*foreign-gobjects-strong*)
  12       (gethash ptr gobject::*foreign-gobjects-weak*)))
  13
  14 (defun do-gc ()
  15   (gc :full t)
  16   (gobject::activate-gc-hooks)
  17   (gethash 0 gobject::*foreign-gobjects-strong*)
  18   (gobject::activate-gc-hooks)
  19   (gc :full t)
  20   (gethash 0 gobject::*foreign-gobjects-weak*)
  21   (gobject::activate-gc-hooks)
  22   (gc :full t))
  23
  24 (defun object-handlers (object)
  25   (when object
  26     (remove nil (gobject::g-object-signal-handlers object))))
  27
  28 (defun print-refs-table (table &optional (stream *standard-output*))
  29   (iter (for (ptr object) in-hashtable table)
  30         (format stream "~A => ~A (~A refs~@[~*, floating~])~@[ handlers: ~A~]~%"
  31                 ptr object (gobject::ref-count object)
  32                 (gobject.ffi:g-object-is-floating (cffi:make-pointer ptr))
  33                 (object-handlers object))))
  34
  35 (defun print-refs (&optional (stream *standard-output*))
  36   (format stream "Strong:~%")
  37   (print-refs-table gobject::*foreign-gobjects-strong*)
  38   (format stream "Weak:~%")
  39   (print-refs-table gobject::*foreign-gobjects-weak*))
  40
  41 (defun count-refs ()
  42   (+ (hash-table-count gobject::*foreign-gobjects-strong*)
  43      (hash-table-count gobject::*foreign-gobjects-weak*)))
  44
  45 (defun print-sps (&optional (stream *standard-output*))
  46   (iter (initially (format stream "Stable pointers:~%"))
  47         (for v in-vector gobject::*registered-stable-pointers*)
  48         (for i from 0)
  49         (when v
  50           (format stream "~A => ~A~%" i v))
  51         (finally (format stream "~%"))))
  52
  53 (defun print-hooks (&optional (stream *standard-output*))
  54   (format stream "~A~%" gobject::*gobject-gc-hooks*))
  55
  56 (defun delete-refs ()
  57   (maphash (lambda (key value)
  58              (declare (ignore value))
  59              (remhash key gobject::*foreign-gobjects-strong*))
  60            gobject::*foreign-gobjects-strong*)
  61   (maphash (lambda (key value)
  62              (declare (ignore value))
  63              (remhash key gobject::*foreign-gobjects-weak*))
  64            gobject::*foreign-gobjects-weak*))
  65
  66 (when nil (defvar *builder* (make-instance 'builder :from-string
  67                                   "
  68 <interface>
  69   <object class=\"GtkDialog\" id=\"dialog1\">
  70   </object>
  71 </interface>
  72 ")))
  73
  74 (setf gobject::*debug-stream* *standard-output*
  75       gobject::*debug-gc* t
  76       gobject::*debug-subclass* t)
  77
  78 (defclass my-button (gtk:button) () (:metaclass gobject-class))
  79
  80 (def-suite mm-tests)
  81
  82 (defun run-all-tests ()
  83   (run! 'mm-tests))
  84
  85 (in-suite mm-tests)
  86
  87 (defmacro with-gc-same-counting (&body body)
  88   (let ((count (gensym)))
  89     (multiple-value-bind (body gc-count)
  90         (if (integerp (first body))
  91             (values (rest body) (first body))
  92             (values body 1))
  93       `(progn
  94          (gc :full t)
  95          (gobject::activate-gc-hooks)
  96          (count-refs)
  97          (let ((,count (count-refs)))
  98            (funcall (lambda () ,@body))
  99            (iter (repeat ,gc-count)
 100                  (format t "gc'ing~%")
 101                  (gc :full t)
 102                  (gobject::activate-gc-hooks)
 103                  (count-refs))
 104            (is (= ,count (count-refs))))))))
 105
 106 (test test-1
 107   (with-gc-same-counting
 108     2
 109     (make-instance 'my-button)))
 110
 111 (test test-with-signal
 112   (with-gc-same-counting
 113     2
 114     (let ((b (make-instance 'my-button)))
 115       (connect-signal b "clicked" (lambda (bb) (declare (ignore bb)) (print b)))
 116       nil)))
 117
 118 (test test-repassing
 119   (with-gc-same-counting
 120     2
 121     (let ((b (make-instance 'my-button)))
 122       (cffi:convert-from-foreign (pointer b) 'g-object)
 123       nil)))
 124
 125 (test test-builder
 126   (with-gc-same-counting
 127     5
 128     (let ((b (make-instance 'builder :from-string "<interface>
 129   <object class=\"GtkButton\" id=\"button1\">
 130   </object>
 131 </interface>")))
 132       (builder-get-object b "button1")
 133       (gc :full t)
 134       (gobject::activate-gc-hooks))
 135     nil))
 136
 137 (test test-builder-with-signals
 138   (with-gc-same-counting
 139     6
 140     (let ((b (make-instance 'builder :from-string "<interface>
 141   <object class=\"GtkButton\" id=\"button1\">
 142   </object>
 143 </interface>")))
 144       (let ((btn (builder-get-object b "button1")))
 145         (connect-signal btn "clicked" (lambda (bb) (declare (ignore bb)) (print btn))))
 146       (gc :full t)
 147       (gobject::activate-gc-hooks))
 148     nil))
 149
 150 (defun make-builder (&optional return)
 151   (let* ((builder (make-instance 'gtk:builder
 152                                  :from-file (namestring (merge-pathnames "demo/demo1.ui" gtk-demo::*src-location*))))
 153          (text-view (builder-get-object builder "textview1"))
 154          (window (builder-get-object builder "window1")))
 155     (builder-connect-signals-simple
 156      builder
 157      `(("quit_cb"
 158         ,(lambda (&rest args)
 159                  (print args)
 160                  (object-destroy window)))))
 161     (when return builder)))