Add a couple more tests.
[commonqt:commonqt.git] / test / tests.lisp
1 (in-package :qt-tests)
2
3 (named-readtables:in-readtable :qt)
4
5 (defmacro with-qapp (&body body)
6   `(let ((qapp (ensure-qapplication)))
7      (declare (ignorable qapp))
8      ,@body))
9
10 ;; CommonQt reader macro works by defining some new macros.
11 ;; This is ok for ordinary compilation but with RT test
12 ;; cases the macroexpansion is done when tests are run,
13 ;; and the newly defined macros don't make it into fasls,
14 ;; so loading compiled tests fails. We have to put the
15 ;; test body into separate defun, sacrificing runtime
16 ;; macro expanding.
17
18 (defmacro deftest/qt (name form &rest values)
19   (alexandria:with-gensyms (func-name)
20     `(progn
21        (defun ,func-name () (with-qapp ,form))
22        (deftest ,name (,func-name) ,@values))))
23
24 (let ((bad (cons nil nil)))
25   (defun marshal-and-test (value type test-fun &optional (unmarshal-type type))
26     (cffi:with-foreign-object (stack-item 'qt::|union StackItem|)
27       (let ((result bad)
28             (<type> (or (qt::find-qtype type)
29                         (error "no such type ~s" type)))
30             (<unmarshal-type> (qt::find-qtype unmarshal-type)))
31         (assert (qt::can-marshal-p value <type>) ()
32                 "cannot marshal ~s as ~s" value type)
33         (qt::marshal value <type>
34                      stack-item
35                      #'(lambda ()
36                          (setf result
37                                (funcall test-fun
38                                         (qt::unmarshal
39                                          <unmarshal-type> stack-item)))))
40         (assert (not (eq bad result)) () "marshalling continuation not invoked")
41         result)))
42   
43   (defun remarshal (value type &optional with-const-p key)
44     (let ((result (marshal-and-test value type #'identity))) 
45       (when with-const-p
46         (let ((const-type (format nil "const ~A&" type)))
47           (marshal-and-test value
48                             const-type
49                             #'(lambda (v)
50                                 (when key
51                                   (setf result (funcall key result)
52                                         v (funcall key v)))
53                                 (assert (equal result v)
54                                         () "remarshal: got ~s instead of ~s when marshalling using const ~A&"
55                                         v result type))
56                             type)))
57       result)))
58
59 (defmacro define-marshalling-test (name type with-const-p &rest values)
60   `(deftest/qt ,name
61        (values ,@(iter (for val in values)
62                        (collect `(remarshal ',val ,type ,with-const-p))))
63      ,@values))
64
65 (defmacro define-marshalling-test/no-unmarshal
66     (name type key &rest values)
67   `(deftest/qt ,name
68        (values ,@(iter (for val in values)
69                        (collect `(marshal-and-test ',val ,type ,key))))
70      ,@values))
71
72 (define-marshalling-test/no-unmarshal test-qbytearray-marshalling
73     "QByteArray" (lambda (x) (#_data x))
74   "" "abc" "qwerty uiop" #.(make-string 3 :initial-element (code-char 1093)))
75
76 (define-marshalling-test test-qvariant-marshalling
77     "QVariant" t
78   "" 123 123.25d0 "zzz" #.(make-string 3 :initial-element (code-char 1093)))
79
80 (deftest/qt test-single-float-via-qvariant-marshalling
81     (values (remarshal 0.0 "QVariant" t)
82             (remarshal 123.25 "QVariant" t))
83   0.0d0 123.25d0)
84
85 (deftest/qt test-qcolor-via-qvariant-marshalling
86     (flet ((convert (c) (#_name c)))
87       (values (remarshal (#_new QColor "#000000") "QVariant" t #'convert)
88               (remarshal (#_new QColor "#ffffff") "QVariant" t #'convert)))
89   "#000000" "#ffffff")
90
91 (deftest/qt test-qpixmap-via-qvariant-marshalling
92     (flet ((convert (p) (cons (#_width p) (#_height p))))
93       (values (remarshal (#_new QPixmap 142 100) "QVariant" t #'convert)))
94   (142 . 100))
95
96 (deftest/qt test-qpixmap-via-qvariant-marshalling
97     (flet ((convert (p)
98              (assert (qtypep p "QPixmap"))
99              (cons (#_width p) (#_height p))))
100       (values (remarshal (#_new QPixmap 142 100) "QVariant" t #'convert)))
101   (142 . 100))
102
103 (deftest/qt test-qicon-via-qvariant-marshalling
104     (flet ((convert (icon)
105              (assert (qtypep icon "QIcon"))
106              (#_isNull icon)))
107       (values (remarshal (#_new QIcon) "QVariant" t #'convert)))
108   t)
109
110 (define-marshalling-test test-qstring-marshalling
111     "QString" t
112   "" "abc" "qwerty uiop" #.(make-string 3 :initial-element (code-char 1093)))
113
114 (define-marshalling-test test-qstringlist-marshalling
115     "QStringList" t
116   () ("abc") ("" "abcd" "qqqq" "rrr") ("abc" "Def" "ghi"))
117
118 (define-marshalling-test test-qlistint-marshalling
119     "QList<int>" t
120   () (42) (#x7fffffff 12345 678) (11 12))
121
122 (define-marshalling-test/no-unmarshal test-qlistbytearray-marshalling
123     "QList<QByteArray>" (lambda (x)
124                           (iter (for y in x)
125                                 (collect (#_data y))))
126   () ("abc") ("" "abcd" "qqqq" "rrr") ("abc" "Def" "ghi"))
127
128 (define-marshalling-test test-qlistqvariant-marshalling
129     "QList<QVariant>" t
130   () ("abc") ("" 123 "zzz" 456))
131
132 (deftest/qt test-qobjectlist-marshalling
133     (let ((a (#_new QObject))
134           (b (#_new QPushButton "Def"))
135           (c (#_new QLabel "zzz")))
136       (#_setObjectName a "Abc")
137       (flet ((extract (list)
138                (list
139                 (#_objectName (first list))
140                 (#_text (second list))
141                 (#_text (third list)))))
142         (extract (remarshal (list a b c) "QList<QObject*>" t))))
143   ("Abc" "Def" "zzz"))
144
145 (deftest/qt test-object-children
146     (let* ((a (#_new QObject))
147            (b (#_new QObject a))
148            (c (#_new QObject a)))
149       (set-difference (list b c) (#_children a)))
150   nil)
151
152 (deftest/qt test-item-model-stuff-marshalling
153     (let ((model (#_new QStandardItemModel)))
154       (#_appendRow model (list (#_new QStandardItem "01")
155                                (#_new QStandardItem "bca")))
156       (#_appendRow model (list (#_new QStandardItem "02")
157                                (#_new QStandardItem "abc")))
158       (#_appendRow model (list (#_new QStandardItem "03")
159                                (#_new QStandardItem "bcq")))
160       (values
161         (iter (for item in (remarshal (list (#_new QStandardItem "zz")
162                                             (#_new QStandardItem "rr"))
163                                       "QList<QStandardItem*>"))
164               (collect (#_text item)))
165         (iter (for i from 0 to 2)
166               (collect (cons (#_data model (#_index model i 0))
167                              (#_data model (#_index model i 1)))))
168         (iter (for index in (#_match model (#_index model 0 1)
169                                      (#_Qt::DisplayRole) "bc" -1))
170               (collect (cons (#_row index) (#_column index))))
171         (iter (for index in (remarshal (#_match model (#_index model 0 1)
172                                                 (#_Qt::DisplayRole) "bc" -1)
173                                        "QList<QModelIndex>"))
174               (collect (cons (#_row index) (#_column index))))))
175   ("zz" "rr") (("01" . "bca") ("02" . "abc") ("03" . "bcq"))
176   ((0 . 1) (2 . 1)) ((0 . 1) (2 . 1)))
177
178 (deftest/qt test-no-enum-confusion
179     (let ((action (#_new QAction (null-qobject (find-qclass "QAction"))))
180           (keys (list (#_new QKeySequence :|int| (#_Qt::Key_Backspace))
181                       (#_new QKeySequence (#_QKeySequence::Back)))))
182       (#_setShortcuts action keys)
183       (iter (for shortcut in (#_shortcuts action))
184             (collect (#_toString shortcut))))
185   ("Backspace" "Alt+Left"))
186
187 (defclass sig-emitter ()
188   ()
189   (:metaclass qt-class)
190   (:qt-superclass "QObject")
191   (:signals ("noArgs()")
192             ("oneArg(int)")
193             ("twoArgs(int, QString)")))
194
195 (defmethod initialize-instance :after ((instance sig-emitter) &key parent)
196   (if parent
197       (new instance parent)
198       (new instance)))
199
200 (defclass sig-receiver ()
201   ((handler :accessor handler :initarg :handler))
202   (:metaclass qt-class)
203   (:qt-superclass "QObject")
204   (:slots ("slotNoArgs()"
205            (lambda (this &rest args)
206              (apply (handler this) 'no-args args)))
207           ("slotOneArg(int)"
208            (lambda (this &rest args)
209              (apply (handler this) 'one-arg args)))
210           ("slotTwoArgs(int, QString)"
211            (lambda (this &rest args)
212              (apply (handler this) 'two-args args)))))
213
214 (defmethod initialize-instance :after ((instance sig-receiver) &key parent)
215   (if parent
216       (new instance parent)
217       (new instance)))
218
219 (deftest/qt test-connect
220     (let ((log '()))
221       (flet ((note (&rest args)
222                (push args log)))
223         (let ((sender (make-instance 'sig-emitter))
224               (receiver (make-instance 'sig-receiver :handler #'note)))
225           (connect sender "noArgs()" receiver "slotNoArgs()")
226           (connect sender (QSIGNAL "oneArg(int)") receiver "slotOneArg(int)")
227           (connect sender "twoArgs(int, QString)"
228                    receiver (QSLOT "slotTwoArgs(int, QString)"))
229           (emit-signal sender "noArgs()")
230           (emit-signal sender "oneArg(int)" 42)
231           (emit-signal sender "oneArg(int)" 4242)
232           (emit-signal sender "twoArgs(int, QString)" 42 "zzz")
233
234           (disconnect sender "noArgs()" receiver "slotNoArgs()")
235           (disconnect sender "twoArgs(int, QString)"
236                       receiver (QSLOT "slotTwoArgs(int, QString)"))
237           (emit-signal sender "noArgs()")
238           (emit-signal sender "oneArg(int)" 123)
239           (emit-signal sender "twoArgs(int, QString)" 12 "qqq")
240
241           (disconnect sender (QSIGNAL "oneArg(int)")
242                       receiver (QSLOT "slotOneArg(int)"))
243           (emit-signal sender "noArgs()")
244           (emit-signal sender "oneArg(int)" 456)
245           (emit-signal sender "twoArgs(int, QString)" 34 "qqq")
246           (reverse log))))
247   ((no-args)
248    (one-arg 42)
249    (one-arg 4242)
250    (two-args 42 "zzz")
251    (one-arg 123)))
252
253 (deftest/qt test-dynamic-connect
254     (let ((log '()))
255       (let ((sender (make-instance 'sig-emitter))
256             (receiver (#_new QObject)))
257         (labels ((note (&rest args)
258                    (push args log))
259                  (no-args (this)
260                    (assert (eq receiver this))
261                    (note 'no-args))
262                  (one-arg (n)
263                    (note 'one-arg n))
264                  (two-args (this n s)
265                    (assert (eq receiver this))
266                    (note 'two-args n s)))
267           ;; we don't use lambdas for connections because we
268           ;; want to break connections later
269           (connect sender "noArgs()" receiver #'no-args)
270           (connect sender (QSIGNAL "oneArg(int)") #'one-arg)
271           (connect sender "twoArgs(int, QString)" receiver #'two-args)
272           (emit-signal sender "noArgs()")
273           (emit-signal sender "oneArg(int)" 42)
274           (emit-signal sender "oneArg(int)" 4242)
275           (emit-signal sender "twoArgs(int, QString)" 42 "zzz")
276
277           (disconnect sender "noArgs()" receiver #'no-args)
278           (emit-signal sender "noArgs()")
279           (emit-signal sender "oneArg(int)" 123)
280           (emit-signal sender "twoArgs(int, QString)" 12 "qqq")
281
282           (#_delete receiver)
283           (emit-signal sender "noArgs()")
284           (emit-signal sender "oneArg(int)" 456)
285           (emit-signal sender "twoArgs(int, QString)" 34 "qqq")
286
287           (disconnect sender (QSIGNAL "oneArg(int)") #'one-arg)
288           (emit-signal sender "noArgs()")
289           (emit-signal sender "oneArg(int)" 789)
290           (emit-signal sender "twoArgs(int, QString)" 56 "qqq")
291           (reverse log))))
292   ((no-args)
293    (one-arg 42)
294    (one-arg 4242)
295    (two-args 42 "zzz")
296    (one-arg 123)
297    (two-args 12 "qqq")
298    (one-arg 456)))
299
300 ;; TBD: deconstify types when looking for marshaller/unmarshaller, remove (macro-generated) duplicate marshaller definitions
301
302 (deftest/qt window-geometry-using-qvariant-and-qbytarray
303     ;; regression test for issue with with qbytearrays unmarshalled as strings
304     (with-object (window (#_new QWidget))
305       (with-object (sx (#_new QSettings "CommonQt test" "CommonQt test"))
306         (#_setValue sx "geometry" (#_saveGeometry window))
307         (#_restoreGeometry window (#_value sx "geometry"))))
308   t)
309
310 (defclass override-object-name ()
311     ((name :initarg :name
312            :accessor test-name))
313   (:metaclass qt-class)
314   (:qt-superclass "QObject")
315   (:override ("objectName" override-object-name)))
316
317 (defmethod initialize-instance :after ((instance override-object-name) &key)
318   (new instance))
319
320 (defun override-object-name (x)
321   (if (slot-boundp x 'name)
322       (test-name x)
323       (call-next-qmethod)))
324
325 (deftest/qt override-object-name
326   (with-object (x (make-instance 'override-object-name))
327     (assert (equal (#_objectName x) ""))
328     (setf (test-name x) "test")
329     (assert (equal (#_objectName x) "test"))
330     t)
331   t)
332
333 (defmacro override/macroexpand (x)
334   `(lambda (y) (format nil ',x (test-name y))))
335
336 (defclass override/macroexpand (override-object-name)
337     ((name :initarg :name
338            :accessor test-name))
339   (:metaclass qt-class)
340   (:qt-superclass "QObject")
341   (:override ("objectName" (override/macroexpand "<<<~A>>>"))))
342
343 (deftest/qt override/macroexpand
344   (with-object (x (make-instance 'override/macroexpand :name "xyz"))
345     (assert (equal (#_objectName x) "<<<xyz>>>"))
346     t)
347   t)
348
349 (deftest/qt override/invalid-function-specification
350     (let* ((c (gentemp))                ;zzz gensym doesn't work
351            (m (gensym))
352            (form `(defclass ,c ()
353                     ()
354                     (:metaclass qt-class)
355                     (:qt-superclass "QObject")
356                     (:override ("objectName" (,m))))))
357       ;;
358       ;; assert that evaluation of the DEFCLASS form fails because M is
359       ;; not defined.
360       ;;
361       (handler-case
362           (eval form)
363         (:no-error (x)
364           (error "expected an error, but got ~A" x))
365         (error ()
366           ;;
367           ;; Now define M and check the same evaluation now works:
368           ;;
369           (setf (macro-function m)
370                 (lambda (whole env)
371                   (declare (ignore whole env))
372                   '(lambda (x) (declare (ignore x)) "dummy")))
373           (eval form)
374           (eval `(defmethod initialize-instance :after ((instance ,c) &key)
375                    (new instance)))
376           (with-object (instance (make-instance c))
377             (assert (equal (#_objectName instance) "dummy")))
378           t)))
379   t)
380
381 (deftest/qt new-qwebview
382     (progn
383       (ensure-smoke :qtwebkit)
384       (with-object (x (#_new QWebView)))
385       t)
386   t)
387
388 (deftest/qt qvariant-with-classes
389     (loop for class in '("QBitArray" "QBitmap" "QBrush" "QByteArray" "QChar" "QColor" "QCursor" "QDate"
390                          "QDateTime" "QEasingCurve" "QFont" "QVariantHash" "QIcon" "QImage"
391                          "QKeySequence" "QLine" "QLineF" "QVariantList" "QLocale" "QVariantMap"
392                          "QTransform" "QMatrix4x4" "QPalette" "QPen" "QPixmap" "QPoint" "QPointF"
393                          "QPolygon" "QQuaternion" "QRect" "QRectF" "QRegExp" "QRegion" "QSize" "QSizeF"
394                          "QSizePolicy" "QString" "QStringList" "QTextFormat" "QTextLength" "QTime"
395                          "QUrl" "QVector2D" "QVector3D" "QVector4D")
396           for object = (and (find-qclass class nil)
397                             (interpret-new class))
398           always (or (not object)
399                      (= (qt::qobject-class object)
400                         (qt::qobject-class
401                          (let ((item (#_new QStandardItem)))
402                            (#_setData item object)
403                            (#_data item))))))
404   t)
405
406 (deftest/qt qvariant-primitive
407     (loop for object in '(1 1.0 1d0 "string" t nil)
408           always (equalp object
409                          (let ((item (#_new QStandardItem)))
410                            (#_setData item object)
411                            (#_data item))))
412   t)
413
414 (deftest/qt superclass-cast
415     (let ((vbox (#_new QVBoxLayout))
416           (hbox (#_new QHBoxLayout)))
417       (#_addLayout vbox hbox)
418       (assert (not (null-qobject-p
419                     (#_layout (#_itemAt vbox 0)))))
420       (#_addWidget vbox (#_new QPushButton))
421       (assert (not (null-qobject-p
422                     (#_widget (#_itemAt vbox 1)))))
423       t)
424   t)
425
426 (deftest/qt indirect-deletion
427     (let* ((a (#_new QObject))
428            (b (#_new QObject a)))
429       (#_delete a)
430       (and (qt::qobject-deleted b)
431            (qt::qobject-deleted a)))
432   t)