tk/tests/image.test

   1 # This file is a Tcl script to test out the "image" command and the
   2 # other procedures in the file tkImage.c.  It is organized in the
   3 # standard fashion for Tcl tests.
   4 #
   5 # Copyright (c) 1994 The Regents of the University of California.
   6 # Copyright (c) 1994 Sun Microsystems, Inc.
   7 # Copyright (c) 1998-1999 by Scriptics Corporation.
   8 # All rights reserved.
   9 #
  10 # RCS: @(#) $Id$
  11
  12 if {[lsearch [namespace children] ::tcltest] == -1} {
  13     source [file join [pwd] [file dirname [info script]] defs.tcl]
  14 }
  15
  16 if {[lsearch [image types] test] < 0} {
  17     puts "This application hasn't been compiled with the \"test\" image"
  18     puts "type, so I can't run this test.  Are you sure you're using"
  19     puts "tktest instead of wish?"
  20     ::tcltest::cleanupTests
  21     return
  22 }
  23
  24 foreach i [winfo children .] {
  25     destroy $i
  26 }
  27 wm geometry . {}
  28 raise .
  29
  30 eval image delete [image names]
  31 canvas .c -highlightthickness 2
  32 pack .c
  33 update
  34 test image-1.1 {Tk_ImageCmd procedure, "create" option} {
  35     list [catch image msg] $msg
  36 } {1 {wrong # args: should be "image option ?args?"}}
  37 test image-1.2 {Tk_ImageCmd procedure, "create" option} {
  38     list [catch {image gorp} msg] $msg
  39 } {1 {bad option "gorp": must be create, delete, height, names, type, types, or width}}
  40 test image-1.3 {Tk_ImageCmd procedure, "create" option} {
  41     list [catch {image create} msg] $msg
  42 } {1 {wrong # args: should be "image create type ?name? ?options?"}}
  43 test image-1.4 {Tk_ImageCmd procedure, "create" option} {
  44     list [catch {image c bad_type} msg] $msg
  45 } {1 {image type "bad_type" doesn't exist}}
  46 test image-1.5 {Tk_ImageCmd procedure, "create" option} {
  47     list [image create test myimage] [image names]
  48 } {myimage myimage}
  49 test image-1.6 {Tk_ImageCmd procedure, "create" option} {
  50     scan [image create test] image%d first
  51     image create test myimage
  52     scan [image create test -variable x] image%d second
  53     expr $second-$first
  54 } {1}
  55 test image-1.7 {Tk_ImageCmd procedure, "create" option} {
  56     image delete myimage
  57     image create test myimage -variable x
  58     .c create image 100 50 -image myimage
  59     .c create image 100 150 -image myimage
  60     update
  61     set x {}
  62     image create test myimage -variable x
  63     update
  64     set x
  65 } {{myimage free} {myimage free} {myimage delete} {myimage get} {myimage get} {myimage display 0 0 30 15 30 30} {myimage display 0 0 30 15 30 130}}
  66 test image-1.8 {Tk_ImageCmd procedure, "create" option} {
  67     .c delete all
  68     image create test myimage -variable x
  69     .c create image 100 50 -image myimage
  70     .c create image 100 150 -image myimage
  71     image delete myimage
  72     update
  73     set x {}
  74     image create test myimage -variable x
  75     update
  76     set x
  77 } {{myimage get} {myimage get} {myimage display 0 0 30 15 30 30} {myimage display 0 0 30 15 30 130}}
  78 test image-1.9 {Tk_ImageCmd procedure, "create" option} {
  79     .c delete all
  80     eval image delete [image names]
  81     list [catch {image create test -badName foo} msg] $msg [image names]
  82 } {1 {bad option name "-badName"} {}}
  83
  84 test image-2.1 {Tk_ImageCmd procedure, "delete" option} {
  85     list [catch {image delete} msg] $msg
  86 } {0 {}}
  87 test image-2.2 {Tk_ImageCmd procedure, "delete" option} {
  88     .c delete all
  89     eval image delete [image names]
  90     image create test myimage
  91     image create test img2
  92     set result {}
  93     lappend result [lsort [image names]]
  94     image d myimage img2
  95     lappend result [image names]
  96 } {{img2 myimage} {}}
  97 test image-2.3 {Tk_ImageCmd procedure, "delete" option} {
  98     .c delete all
  99     eval image delete [image names]
 100     image create test myimage
 101     image create test img2
 102     list [catch {image delete myimage gorp img2} msg] $msg [image names]
 103 } {1 {image "gorp" doesn't exist} img2}
 104
 105 test image-3.1 {Tk_ImageCmd procedure, "height" option} {
 106     list [catch {image height} msg] $msg
 107 } {1 {wrong # args: should be "image height name"}}
 108 test image-3.2 {Tk_ImageCmd procedure, "height" option} {
 109     list [catch {image height a b} msg] $msg
 110 } {1 {wrong # args: should be "image height name"}}
 111 test image-3.3 {Tk_ImageCmd procedure, "height" option} {
 112     list [catch {image height foo} msg] $msg
 113 } {1 {image "foo" doesn't exist}}
 114 test image-3.4 {Tk_ImageCmd procedure, "height" option} {
 115     image create test myimage
 116     set x [image h myimage]
 117     myimage changed 0 0 0 0 60 50
 118     list $x [image height myimage]
 119 } {15 50}
 120
 121 test image-4.1 {Tk_ImageCmd procedure, "names" option} {
 122     list [catch {image names x} msg] $msg
 123 } {1 {wrong # args: should be "image names"}}
 124 test image-4.2 {Tk_ImageCmd procedure, "names" option} {
 125     .c delete all
 126     eval image delete [image names]
 127     image create test myimage
 128     image create test img2
 129     image create test 24613
 130     lsort [image names]
 131 } {24613 img2 myimage}
 132 test image-4.3 {Tk_ImageCmd procedure, "names" option} {
 133     .c delete all
 134     eval image delete [image names]
 135     lsort [image names]
 136 } {}
 137
 138 test image-5.1 {Tk_ImageCmd procedure, "type" option} {
 139     list [catch {image type} msg] $msg
 140 } {1 {wrong # args: should be "image type name"}}
 141 test image-5.2 {Tk_ImageCmd procedure, "type" option} {
 142     list [catch {image type a b} msg] $msg
 143 } {1 {wrong # args: should be "image type name"}}
 144 test image-5.3 {Tk_ImageCmd procedure, "type" option} {
 145     list [catch {image type foo} msg] $msg
 146 } {1 {image "foo" doesn't exist}}
 147 test image-5.4 {Tk_ImageCmd procedure, "type" option} {
 148     image create test myimage
 149     image type myimage
 150 } {test}
 151 test image-5.5 {Tk_ImageCmd procedure, "type" option} {
 152     image create test myimage
 153     .c create image 50 50 -image myimage
 154     image delete myimage
 155     image type myimage
 156 } {}
 157
 158 test image-6.1 {Tk_ImageCmd procedure, "types" option} {
 159     list [catch {image types x} msg] $msg
 160 } {1 {wrong # args: should be "image types"}}
 161 test image-6.2 {Tk_ImageCmd procedure, "types" option} {
 162     lsort [image types]
 163 } {bitmap photo test}
 164
 165 test image-7.1 {Tk_ImageCmd procedure, "width" option} {
 166     list [catch {image width} msg] $msg
 167 } {1 {wrong # args: should be "image width name"}}
 168 test image-7.2 {Tk_ImageCmd procedure, "width" option} {
 169     list [catch {image width a b} msg] $msg
 170 } {1 {wrong # args: should be "image width name"}}
 171 test image-7.3 {Tk_ImageCmd procedure, "width" option} {
 172     list [catch {image width foo} msg] $msg
 173 } {1 {image "foo" doesn't exist}}
 174 test image-7.4 {Tk_ImageCmd procedure, "width" option} {
 175     image create test myimage
 176     set x [image w myimage]
 177     myimage changed 0 0 0 0 60 50
 178     list $x [image width myimage]
 179 } {30 60}
 180
 181 test image-8.1 {Tk_ImageChanged procedure} {
 182     .c delete all
 183     eval image delete [image names]
 184     image create test foo -variable x
 185     .c create image 50 50 -image foo
 186     update
 187     set x {}
 188     foo changed 5 6 7 8 30 15
 189     update
 190     set x
 191 } {{foo display 5 6 7 8 30 30}}
 192 test image-8.2 {Tk_ImageChanged procedure} {
 193     .c delete all
 194     eval image delete [image names]
 195     image create test foo -variable x
 196     .c create image 50 50 -image foo
 197     .c create image 90 100 -image foo
 198     update
 199     set x {}
 200     foo changed 5 6 7 8 30 15
 201     update
 202     set x
 203 } {{foo display 5 6 25 9 30 30} {foo display 0 0 12 14 65 74}}
 204
 205 test image-9.1 {Tk_GetImage procedure} {
 206     list [catch {.c create image 100 10 -image bad_name} msg] $msg
 207 } {1 {image "bad_name" doesn't exist}}
 208 test image-9.2 {Tk_GetImage procedure} {
 209     image create test mytest
 210     catch {destroy .l}
 211     label .l -image mytest
 212     image delete  mytest
 213     set result [list [catch {label .l2 -image mytest} msg] $msg]
 214     destroy .l
 215     set result
 216 } {1 {image "mytest" doesn't exist}}
 217
 218 test image-10.1 {Tk_FreeImage procedure} {
 219     .c delete all
 220     eval image delete [image names]
 221     image create test foo -variable x
 222     .c create image 50 50 -image foo -tags i1
 223     .c create image 90 100 -image foo -tags i2
 224     pack forget .c
 225     update
 226     set x {}
 227     .c delete i1
 228     pack .c
 229     update
 230     list [image names] $x
 231 } {foo {{foo free} {foo display 0 0 30 15 103 121}}}
 232 test image-10.2 {Tk_FreeImage procedure} {
 233     .c delete all
 234     eval image delete [image names]
 235     image create test foo -variable x
 236     .c create image 50 50 -image foo -tags i1
 237     image delete foo
 238     update
 239     set names [image names]
 240     set x {}
 241     .c delete i1
 242     pack forget .c
 243     pack .c
 244     update
 245     list $names [image names] $x
 246 } {foo {} {}}
 247
 248 # Non-portable, apparently due to differences in rounding:
 249
 250 test image-11.1 {Tk_RedrawImage procedure, redisplay area clipping} \
 251         {nonPortable} {
 252     .c delete all
 253     eval image delete [image names]
 254     image create test foo -variable x
 255     .c create image 50 60 -image foo -tags i1 -anchor nw
 256     update
 257     .c create rectangle 30 40 55 65 -width 0 -fill black -outline {}
 258     set x {}
 259     update
 260     set x
 261 } {{foo display 0 0 5 5 50 50}}
 262 test image-11.2 {Tk_RedrawImage procedure, redisplay area clipping} \
 263         {nonPortable} {
 264     .c delete all
 265     eval image delete [image names]
 266     image create test foo -variable x
 267     .c create image 50 60 -image foo -tags i1 -anchor nw
 268     update
 269     .c create rectangle 60 40 100 65 -width 0 -fill black -outline {}
 270     set x {}
 271     update
 272     set x
 273 } {{foo display 10 0 20 5 30 50}}
 274 test image-11.3 {Tk_RedrawImage procedure, redisplay area clipping} \
 275         {nonPortable} {
 276     .c delete all
 277     eval image delete [image names]
 278     image create test foo -variable x
 279     .c create image 50 60 -image foo -tags i1 -anchor nw
 280     update
 281     .c create rectangle 60 70 100 200 -width 0 -fill black -outline {}
 282     set x {}
 283     update
 284     set x
 285 } {{foo display 10 10 20 5 30 30}}
 286 test image-11.4 {Tk_RedrawImage procedure, redisplay area clipping} \
 287         {nonPortable} {
 288     .c delete all
 289     eval image delete [image names]
 290     image create test foo -variable x
 291     .c create image 50 60 -image foo -tags i1 -anchor nw
 292     update
 293     .c create rectangle 30 70 55 200 -width 0 -fill black -outline {}
 294     set x {}
 295     update
 296     set x
 297 } {{foo display 0 10 5 5 50 30}}
 298 test image-11.5 {Tk_RedrawImage procedure, redisplay area clipping} \
 299         {nonPortable} {
 300     .c delete all
 301     eval image delete [image names]
 302     image create test foo -variable x
 303     .c create image 50 60 -image foo -tags i1 -anchor nw
 304     update
 305     .c create rectangle 10 20 120 130 -width 0 -fill black -outline {}
 306     set x {}
 307     update
 308     set x
 309 } {{foo display 0 0 30 15 70 70}}
 310 test image-11.6 {Tk_RedrawImage procedure, redisplay area clipping} \
 311         {nonPortable} {
 312     .c delete all
 313     eval image delete [image names]
 314     image create test foo -variable x
 315     .c create image 50 60 -image foo -tags i1 -anchor nw
 316     update
 317     .c create rectangle 55 65 75 70 -width 0 -fill black -outline {}
 318     set x {}
 319     update
 320     set x
 321 } {{foo display 5 5 20 5 30 30}}
 322
 323 test image-12.1 {Tk_SizeOfImage procedure} {
 324     eval image delete [image names]
 325     image create test foo -variable x
 326     set result [list [image width foo] [image height foo]]
 327     foo changed 0 0 0 0 85 60
 328     lappend result [image width foo] [image height foo]
 329 } {30 15 85 60}
 330
 331 test image-12.2 {DeleteImage procedure} {
 332     .c delete all
 333     eval image delete [image names]
 334     image create test foo -variable x
 335     .c create image 50 50 -image foo -tags i1
 336     .c create image 90 100 -image foo -tags i2
 337     set x {}
 338     image delete foo
 339     lappend x | [image names] |
 340     image delete foo
 341     lappend x | [image names] |
 342 } {{foo free} {foo free} {foo delete} | foo | | foo |}
 343
 344 catch {image delete hidden}
 345 set l [image names]
 346 set h [interp hidden]
 347
 348 test image-13.1 {image command vs hidden commands} {
 349     catch {image delete hidden}
 350     image create photo hidden
 351     interp hide {} hidden
 352     image delete hidden
 353     list [image names] [interp hidden]
 354 } [list $l $h]
 355
 356 destroy .c
 357 eval image delete [image names]
 358
 359 # cleanup
 360 ::tcltest::cleanupTests
 361 return
 362
 363
 364
 365
 366
 367
 368
 369
 370
 371
 372
 373
 374