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 do-gc ()
  10   (gc :full t)
  11   (gobject::activate-gc-hooks)
  12   (gethash 0 gobject::*foreign-gobjects-strong*)
  13   (gobject::activate-gc-hooks)
  14   (gc :full t)
  15   (gethash 0 gobject::*foreign-gobjects-weak*)
  16   (gobject::activate-gc-hooks)
  17   (gc :full t))
  18
  19 (defun print-refs-table (table &optional (stream *standard-output*))
  20   (iter (for (ptr object) in-hashtable table)
  21         (format stream "~A => ~A (~A refs)~%"
  22                 ptr object (gobject::ref-count object))))
  23
  24 (defun print-refs (&optional (stream *standard-output*))
  25   (format stream "Strong:~%")
  26   (print-refs-table gobject::*foreign-gobjects-strong*)
  27   (format stream "Weak:~%")
  28   (print-refs-table gobject::*foreign-gobjects-weak*))
  29
  30 (defun count-refs ()
  31   (+ (hash-table-count gobject::*foreign-gobjects-strong*)
  32      (hash-table-count gobject::*foreign-gobjects-weak*)))
  33
  34 (defun print-sps (&optional (stream *standard-output*))
  35   (iter (initially (format stream "Stable pointers:~%"))
  36         (for v in-vector gobject::*registered-stable-pointers*)
  37         (for i from 0)
  38         (when v
  39           (format stream "~A => ~A~%" i v))
  40         (finally (format stream "~%"))))
  41
  42 (defun print-hooks (&optional (stream *standard-output*))
  43   (format stream "~A~%" gobject::*gobject-gc-hooks*))
  44
  45 (defun delete-refs ()
  46   (maphash (lambda (key value)
  47              (declare (ignore value))
  48              (remhash key gobject::*foreign-gobjects-strong*))
  49            gobject::*foreign-gobjects-strong*)
  50   (maphash (lambda (key value)
  51              (declare (ignore value))
  52              (remhash key gobject::*foreign-gobjects-weak*))
  53            gobject::*foreign-gobjects-weak*))
  54
  55 (when nil (defvar *builder* (make-instance 'builder :from-string
  56                                   "
  57 <interface>
  58   <object class=\"GtkDialog\" id=\"dialog1\">
  59   </object>
  60 </interface>
  61 ")))
  62
  63 (setf gobject::*debug-stream* *standard-output*
  64       gobject::*debug-gc* t
  65       gobject::*debug-subclass* t)
  66
  67 (defclass my-button (gtk:button) () (:metaclass gobject-class))
  68
  69 (def-suite mm-tests)
  70
  71 (defun run-all-tests ()
  72   (run! 'mm-tests))
  73
  74 (in-suite mm-tests)
  75
  76 (defmacro with-gc-same-counting (&body body)
  77   (let ((count (gensym)))
  78     (multiple-value-bind (body gc-count)
  79         (if (integerp (first body))
  80             (values (rest body) (first body))
  81             (values body 1))
  82       `(progn
  83          (gc :full t)
  84          (gobject::activate-gc-hooks)
  85          (count-refs)
  86          (let ((,count (count-refs)))
  87            (funcall (lambda () ,@body))
  88            (iter (repeat ,gc-count)
  89                  (format t "gc'ing~%")
  90                  (gc :full t)
  91                  (gobject::activate-gc-hooks)
  92                  (count-refs))
  93            (is (= ,count (count-refs))))))))
  94
  95 (test test-1
  96   (with-gc-same-counting
  97     2
  98     (make-instance 'my-button)))
  99
 100 (test test-with-signal
 101   (with-gc-same-counting
 102     2
 103     (let ((b (make-instance 'my-button)))
 104       (connect-signal b "clicked" (lambda (bb) (declare (ignore bb)) (print b)))
 105       nil)))
 106
 107 (test test-repassing
 108   (with-gc-same-counting
 109     2
 110     (let ((b (make-instance 'my-button)))
 111       (cffi:convert-from-foreign (pointer b) 'g-object)
 112       nil)))
 113
 114 (test test-builder
 115   (with-gc-same-counting
 116     5
 117     (let ((b (make-instance 'builder :from-string "<interface>
 118   <object class=\"GtkButton\" id=\"button1\">
 119   </object>
 120 </interface>")))
 121       (builder-get-object b "button1")
 122       (gc :full t)
 123       (gobject::activate-gc-hooks))
 124     nil))
 125
 126 (test test-builder-with-signals
 127   (with-gc-same-counting
 128     6
 129     (let ((b (make-instance 'builder :from-string "<interface>
 130   <object class=\"GtkButton\" id=\"button1\">
 131   </object>
 132 </interface>")))
 133       (let ((btn (builder-get-object b "button1")))
 134         (connect-signal btn "clicked" (lambda (bb) (declare (ignore bb)) (print btn))))
 135       (gc :full t)
 136       (gobject::activate-gc-hooks))
 137     nil))