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