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
  66 (defclass my-button (gtk:button) () (:metaclass gobject-class))
  67
  68 (def-suite mm-tests)
  69
  70 (defun run-all-tests ()
  71   (run! 'mm-tests))
  72
  73 (in-suite mm-tests)
  74
  75 (defmacro with-gc-same-counting (&body body)
  76   (let ((count (gensym)))
  77     (multiple-value-bind (body gc-count)
  78         (if (integerp (first body))
  79             (values (rest body) (first body))
  80             (values body 1))
  81       `(progn
  82          (gc :full t)
  83          (gobject::activate-gc-hooks)
  84          (count-refs)
  85          (let ((,count (count-refs)))
  86            (funcall (lambda () ,@body))
  87            (iter (repeat ,gc-count)
  88                  (format t "gc'ing~%")
  89                  (gc :full t)
  90                  (gobject::activate-gc-hooks)
  91                  (count-refs))
  92            (is (= ,count (count-refs))))))))
  93
  94 (test test-1
  95   (with-gc-same-counting
  96     2
  97     (make-instance 'my-button)))
  98
  99 (test test-with-signal
 100   (with-gc-same-counting
 101     2
 102     (let ((b (make-instance 'my-button)))
 103       (connect-signal b "clicked" (lambda (bb) (declare (ignore bb)) (print b)))
 104       nil)))
 105
 106 (test test-repassing
 107   (with-gc-same-counting
 108     2
 109     (let ((b (make-instance 'my-button)))
 110       (cffi:convert-from-foreign (pointer b) 'g-object)
 111       nil)))
 112
 113 (test test-builder
 114   (with-gc-same-counting
 115     5
 116     (let ((b (make-instance 'builder :from-string "<interface>
 117   <object class=\"GtkButton\" id=\"button1\">
 118   </object>
 119 </interface>")))
 120       (builder-get-object b "button1")
 121       (gc :full t)
 122       (gobject::activate-gc-hooks))
 123     nil))
 124
 125 (test test-builder-with-signals
 126   (with-gc-same-counting
 127     6
 128     (let ((b (make-instance 'builder :from-string "<interface>
 129   <object class=\"GtkButton\" id=\"button1\">
 130   </object>
 131 </interface>")))
 132       (let ((btn (builder-get-object b "button1")))
 133         (connect-signal btn "clicked" (lambda (bb) (declare (ignore bb)) (print btn))))
 134       (gc :full t)
 135       (gobject::activate-gc-hooks))
 136     nil))