1#!/bin/sh
2exec ${srcdir:-.}/guile-test-env guile -s "$0" "$@"
3!#
4
5;; guile-gnome
6;; Copyright (C) 2001 Martin Baulig
7;;               2003,2004 Andreas Rottmann
8
9;; This program is free software; you can redistribute it and/or
10;; modify it under the terms of the GNU General Public License as
11;; published by the Free Software Foundation; either version 2 of
12;; the License, or (at your option) any later version.
13;;
14;; This program is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
17;; GNU General Public License for more details.
18;;
19;; You should have received a copy of the GNU General Public License
20;; along with this program; if not, contact:
21;;
22;; Free Software Foundation           Voice:  +1-617-542-5942
23;; 59 Temple Place - Suite 330        Fax:    +1-617-542-2652
24;; Boston, MA  02111-1307,  USA       gnu@gnu.org
25
26(define-module (test-suite test-gobject)
27  #:use-module (oop goops)
28  #:use-module (gnome gobject)
29  #:use-module (gnome gobject gtype)
30  #:use-module (test-suite lib)
31  #:use-module (test-suite exceptions))
32
33(with-test-prefix "basic values"
34  (define (test class value)
35    (equal? (gvalue->scm (make class #:value value)) value))
36  (define exception:value-out-of-range
37    (cons 'out-of-range "^Value .*out of range"))
38
39  (pass-if-exception "#:value arg missing"
40                     exception:value-arg-missing
41                     (make <guchar>))
42
43  (pass-if "creating gchar"
44           (test <gchar> #\space))
45
46  (pass-if "creating guchar"
47           (test <guchar> #\space))
48
49  (pass-if "creating gboolean #f"
50           (test <gboolean> #f))
51
52  (pass-if "creating gboolean #t"
53           (test <gboolean> #t))
54
55  (pass-if "creating gint"
56           (test <gint> 511))
57
58  (pass-if "creating guint"
59           (test <guint> 511))
60
61  (pass-if-exception "creating guint"
62                     exception:value-out-of-range
63                     (make <guint> #:value -1))
64
65  (pass-if "creating glong"
66           (test <glong> 511))
67
68  (pass-if "creating gulong"
69           (test <gulong> 511))
70
71  (pass-if-exception "creating gulong"
72                     exception:value-out-of-range
73                     (make <gulong> #:value -1))
74
75  (pass-if "creating gfloat"
76           (test <gfloat> 4.5))
77
78  (pass-if "creating gdouble"
79           (test <gdouble> 4.1234))
80
81  (pass-if "creating gchararray"
82           (test <gchararray> "This is a test"))
83
84  (pass-if "creating empty gchararray"
85           (test <gchararray> #f))
86
87  (pass-if "creating gvalue array"
88           (test <gvalue-array> '(1 2 3)))
89  )
90
91(with-test-prefix "creating genum and gflags types"
92
93  (pass-if "creating genum type"
94           (let ((class (make-class (list <genum>) '()
95                          #:name '<enum-test>
96                          #:vtable #((a "Foo" 1) (b "Hello" 2)))))
97             (eq? class (gtype-name->class "EnumTest"))))
98
99  (pass-if "creating gflags type"
100           (let ((class (make-class (list <gflags>) '()
101                          #:name '<flags-test>
102                          #:vtable #((c "AAAA" 4) (d "BBBB" 8)))))
103             (eq? class (gtype-name->class "FlagsTest"))))
104  )
105
106(define (gvalue? x) (is-a? x <gvalue>))
107
108(with-test-prefix "genum values"
109
110  (define enum-class (gtype-name->class "EnumTest"))
111
112  (pass-if "getting enum type class"
113           (is-a? enum-class <gtype-class>))
114
115  (pass-if "creating enum by nick"
116           (gvalue? (make enum-class #:value 'a)))
117
118  (pass-if "creating enum by name"
119           (gvalue? (make enum-class #:value "Foo")))
120
121  (pass-if "creating enum by value"
122           (gvalue? (make enum-class #:value 1)))
123
124  (pass-if "gvalue->scm on an enum is a <gvalue>"
125           (gvalue? (gvalue->scm (make enum-class #:value 'a))))
126
127  (pass-if "getting enum nick"
128           (eq? (genum->symbol (make enum-class #:value 'a)) 'a))
129
130  (pass-if "getting enum name"
131           (equal? (genum->name (make enum-class #:value 'a)) "Foo"))
132
133  (pass-if "getting enum value"
134           (equal? (genum->value (make enum-class #:value 'a)) 1))
135
136  )
137
138(with-test-prefix "gflags values"
139
140  (define flags-class (gtype-name->class "FlagsTest"))
141
142  (pass-if "getting flags type class"
143           (is-a? flags-class <gtype-class>))
144
145  (pass-if "creating flags by nick"
146           (gvalue? (make flags-class #:value '(c d))))
147
148  (pass-if "creating flags by name"
149           (gvalue? (make flags-class #:value '("AAAA" "BBBB"))))
150
151  (pass-if "creating flags by value"
152           (gvalue? (make flags-class #:value '(4 8))))
153
154  (pass-if "creating flags by or'd value"
155           (gvalue? (make flags-class #:value 12)))
156
157  (pass-if "creating flags by mixed list"
158           (gvalue? (make flags-class #:value '(c "BBBB"))))
159
160  (pass-if "creating flags by single symbol"
161           (gvalue? (make flags-class #:value 'c)))
162
163  (pass-if "gvalue->scm on a flags is a <gvalue>"
164           (gvalue? (gvalue->scm (make flags-class #:value '(4 8)))))
165
166  (pass-if "getting flags as one int value"
167           (equal? (gflags->value (make flags-class #:value '(4 8)))
168                   12))
169
170  (pass-if "getting flags nicks"
171           (equal? (gflags->symbol-list
172                    (make flags-class #:value '(4 8))) '(c d)))
173
174  (pass-if "getting flags names"
175           (equal? (gflags->name-list (make flags-class #:value '(4 8)))
176                   '("AAAA" "BBBB")))
177
178  (pass-if "getting flags values"
179           (equal? (gflags->value-list (make flags-class #:value '(4 8)))
180                   '(4 8)))
181  )
182
183(with-test-prefix "creating gclosure"
184
185  (define func-without-args (lambda () "Hello World"))
186  (define my-closure? (lambda (x) (is-a? x <gclosure>)))
187  (define long-arg (list->vector (list (make <glong> #:value 82))))
188
189  (pass-if "creating gclosure"
190           (my-closure? (make <gclosure> #:func func-without-args)))
191
192  (pass-if "creating gclosure with return type"
193           (my-closure? (make <gclosure> #:func func-without-args
194                              #:return-type <gchararray>)))
195
196  (pass-if "creating gclosure with arg"
197           (my-closure? (make <gclosure> #:func func-without-args
198                              #:return-type <gchararray>
199                              #:param-types (list <glong>))))
200  )
201
202(with-test-prefix "invoking gclosure"
203  (define long-arg (make <glong> #:value 82))
204
205  (define closure-without-args
206    (make <gclosure> #:func (lambda () "Hello World")))
207
208  (define closure-with-retval
209    (make <gclosure> #:func (lambda () "Hello World")
210          #:return-type <gchararray>))
211
212  (define closure-with-boxed-retval
213    (make <gclosure> #:func (lambda () (make <gclosure> #:func (lambda () #t)))
214          #:return-type <gclosure>))
215
216  (pass-if "invoking gclosure"
217           (unspecified? (gclosure-invoke closure-without-args #f)))
218
219  ;; crosses a with/without barrier, not possible to get an exception...
220  ;;(pass-if-exception "invoking gclosure with incorrect arguments"
221  ;;                   exception:wrong-number-of-args
222  ;;                   (gclosure-invoke closure-without-args #f long-arg))
223
224  (pass-if "invoking gclosure with retval"
225           (string? (gclosure-invoke closure-with-retval <gchararray>)))
226
227  (pass-if "invoking gclosure checking retval"
228           (equal? (gclosure-invoke closure-with-retval <gchararray>)
229                   "Hello World"))
230
231  (pass-if "invoking gclosure with boxed retval"
232           (gvalue? (gclosure-invoke closure-with-boxed-retval <gclosure>)))
233  )
234
235(define-class <my-object> (<gobject>)
236  (int #:gparam `(,<gparam-int> #:minimum 2 #:maximum 100 #:default-value 3
237                                #:flags (read write construct)))
238  (float #:gparam `(,<gparam-float> #:minimum 2.0 #:maximum 100.0 #:default-value 3.0
239                                    #:flags (read write construct)))
240  scm)
241(define-method (gobject:set-property (object <my-object>) key val)
242  (next-method)
243  (case key
244    ((int) (slot-set! object 'scm val))
245    ((float) #t) ; pass
246    (else (error "unknown property" key))))
247
248(with-test-prefix "defining custom gobject type"
249 (pass-if "construction succeeds"
250          (is-a? (make <my-object>) <my-object>))
251
252 (pass-if "construct arg set correctly"
253          (let ((o (make <my-object>)))
254            (= (gobject-get-property o 'int) 3)))
255
256 (pass-if "construct arg overridable"
257          (let ((o (make <my-object> #:int 4)))
258            (= (gobject-get-property o 'int) 4)))
259
260 (pass-if "arg settable"
261          (let ((o (make <my-object>)))
262            (gobject-set-property o 'int 10)
263            (= (gobject-get-property o 'int) 10)))
264
265 (pass-if "the same object is seen in construct gobject:set-property and afterwards"
266          (let ((o (make <my-object>)))
267            (= (slot-ref o 'scm) 3)))
268
269 (pass-if "notify works, with the detail argument"
270          (let* ((o (make <my-object>))
271                 (got-notify 0)
272                 (notify (lambda (obj pspec) (set! got-notify (1+ got-notify))))
273                 (id (gtype-instance-signal-connect o 'notify notify #t 'int)))
274            (gobject-set-property o 'int 40)
275            (gobject-set-property o 'float 42)
276            (= got-notify 1))))
277
278;; Local Variables:
279;; mode: scheme
280;; End:
281