Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
Comment: | Fix [1576528fff]: image read file with -from option. (and resolve merge conflicts) |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | trunk | main |
Files: | files | file ages | folders |
SHA3-256: |
bb6191ffbd629005c57ecf73e8d4651e |
User & Date: | fvogel 2024-06-11 03:34:15 |
Context
2024-06-14
| ||
07:29 | Fix [dacd18294b]: Undefined behavior in tkTextBTree.c (out of bounds access in array) check-in: cbefc8a1 user: jan.nijtmans tags: trunk, main | |
07:24 | Fix [1576528fff]: image read file with -from option check-in: 1d4d20df user: jan.nijtmans tags: core-8-branch | |
2024-06-11
| ||
03:53 | merge trunk check-in: da09dc79 user: fvogel tags: revised_text, tip-466 | |
03:34 | Fix [1576528fff]: image read file with -from option. (and resolve merge conflicts) check-in: bb6191ff user: fvogel tags: trunk, main | |
03:17 | Fix [1576528fff]: image read file with -from option. check-in: 82777e9f user: fvogel tags: core-8-6-branch | |
2024-06-10
| ||
07:40 | Merge 8.7 check-in: 086e7d0f user: jan.nijtmans tags: trunk, main | |
Changes
Changes to generic/tkImgGIF.c.
︙ | ︙ | |||
700 701 702 703 704 705 706 707 708 709 710 711 712 713 | srcY = 0; } if (height > imageHeight) { height = imageHeight; } if ((width > 0) && (height > 0)) { Tk_PhotoImageBlock block; int transparent = -1; if (gifGraphicControlExtensionBlock.blockPresent) { transparent = gifGraphicControlExtensionBlock.transparent; } /* * Read the data and put it into the photo buffer for display by the | > | 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 | srcY = 0; } if (height > imageHeight) { height = imageHeight; } if ((width > 0) && (height > 0)) { unsigned char* pixelPtr; Tk_PhotoImageBlock block; int transparent = -1; if (gifGraphicControlExtensionBlock.blockPresent) { transparent = gifGraphicControlExtensionBlock.transparent; } /* * Read the data and put it into the photo buffer for display by the |
︙ | ︙ | |||
725 726 727 728 729 730 731 | goto error; } block.pitch = block.pixelSize * imageWidth; if (imageHeight > (int)(UINT_MAX/block.pitch)) { goto error; } nBytes = block.pitch * imageHeight; | | | | > | > | | | 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 | goto error; } block.pitch = block.pixelSize * imageWidth; if (imageHeight > (int)(UINT_MAX/block.pitch)) { goto error; } nBytes = block.pitch * imageHeight; pixelPtr = (unsigned char*)ckalloc(nBytes); if (pixelPtr) { memset(pixelPtr, 0, nBytes); } block.pixelPtr = pixelPtr; if (ReadImage(gifConfPtr, interp, block.pixelPtr, chan, imageWidth, imageHeight, colorMap, srcX, srcY, BitSet(buf[8], INTERLACE), transparent) != TCL_OK) { ckfree(pixelPtr); goto error; } block.pixelPtr += srcX * block.pixelSize + srcY * block.pitch; if (Tk_PhotoPutBlock(interp, imageHandle, &block, destX, destY, width, height, TK_PHOTO_COMPOSITE_SET) != TCL_OK) { ckfree(pixelPtr); goto error; } ckfree(pixelPtr); } /* * Update the metadata dictionary with current image data */ if (NULL != metadataOutObj) { |
︙ | ︙ |
Changes to generic/tkImgPNG.c.
︙ | ︙ | |||
201 202 203 204 205 206 207 | static int CheckColor(Tcl_Interp *interp, PNGImage *pngPtr); static inline int CheckCRC(Tcl_Interp *interp, PNGImage *pngPtr, unsigned long calculated); static void CleanupPNGImage(PNGImage *pngPtr); static int DecodeLine(Tcl_Interp *interp, PNGImage *pngPtr); static int DecodePNG(Tcl_Interp *interp, PNGImage *pngPtr, Tcl_Obj *fmtObj, Tk_PhotoHandle imageHandle, | | > | 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 | static int CheckColor(Tcl_Interp *interp, PNGImage *pngPtr); static inline int CheckCRC(Tcl_Interp *interp, PNGImage *pngPtr, unsigned long calculated); static void CleanupPNGImage(PNGImage *pngPtr); static int DecodeLine(Tcl_Interp *interp, PNGImage *pngPtr); static int DecodePNG(Tcl_Interp *interp, PNGImage *pngPtr, Tcl_Obj *fmtObj, Tk_PhotoHandle imageHandle, int destX, int destY, int width, int height, int srcX, int srcY); static int EncodePNG(Tcl_Interp *interp, Tk_PhotoImageBlock *blockPtr, PNGImage *pngPtr, Tcl_Obj *metadataInObj); static int FileMatchPNG(Tcl_Interp *interp, Tcl_Channel chan, const char *fileName, Tcl_Obj *fmtObj, Tcl_Obj *metadataInObj, int *widthPtr, int *heightPtr, Tcl_Obj *metadataOut); |
︙ | ︙ | |||
2472 2473 2474 2475 2476 2477 2478 | * dimensions and contents may change. * *---------------------------------------------------------------------- */ static int DecodePNG( | | | | | | > > > > | > | 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 | * dimensions and contents may change. * *---------------------------------------------------------------------- */ static int DecodePNG( Tcl_Interp *interp, /* Interpreter to use for reporting errors. */ PNGImage *pngPtr, /* PNG image information record. */ Tcl_Obj *fmtObj, /* User-specified format object, or NULL. */ Tk_PhotoHandle imageHandle, /* The photo image to write into. */ int destX, int destY, /* Coordinates of top-left pixel in photo * image to be written to. */ int width, int height, /* Dimensions of block of photo image to be * written to. */ int srcX, int srcY) /* Coordinates of top-left pixel to be used in * image being read. */ { unsigned long chunkType; int result; Tcl_Size chunkSz; unsigned long crc; /* * Parse the PNG signature and IHDR (header) chunk. */ |
︙ | ︙ | |||
2627 2628 2629 2630 2631 2632 2633 | /* * Expand the photo size (if not set by the user) to provide enough space * for the image being parsed. It does not matter if width or height wrap * to negative here: Tk will not shrink the image. */ | | | | 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 | /* * Expand the photo size (if not set by the user) to provide enough space * for the image being parsed. It does not matter if width or height wrap * to negative here: Tk will not shrink the image. */ if (Tk_PhotoExpand(interp, imageHandle, destX + width, destY + height) == TCL_ERROR) { return TCL_ERROR; } /* * A scan line consists of one byte for a filter type, plus the number of * bits per color sample times the number of color samples per pixel. */ |
︙ | ︙ | |||
2782 2783 2784 2785 2786 2787 2788 | ApplyAlpha(pngPtr); /* * Copy the decoded image block into the Tk photo image. */ | > | < | | | < | | 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 | ApplyAlpha(pngPtr); /* * Copy the decoded image block into the Tk photo image. */ pngPtr->block.pixelPtr += srcX * pngPtr->block.pixelSize + srcY * pngPtr->block.pitch; result = Tk_PhotoPutBlock(interp, imageHandle, &pngPtr->block, destX, destY, width, height, TK_PHOTO_COMPOSITE_SET); pngPtr->block.pixelPtr -= srcX * pngPtr->block.pixelSize + srcY * pngPtr->block.pitch; return result; } /* *---------------------------------------------------------------------- * * FileMatchPNG -- * |
︙ | ︙ | |||
2858 2859 2860 2861 2862 2863 2864 | * image given by imageHandle. * *---------------------------------------------------------------------- */ static int FileReadPNG( | | | | | < | < | | | 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 | * image given by imageHandle. * *---------------------------------------------------------------------- */ static int FileReadPNG( Tcl_Interp* interp, /* Interpreter to use for reporting errors. */ Tcl_Channel chan, /* The image file, open for reading. */ TCL_UNUSED(const char*), /* The name of the image file. */ Tcl_Obj *fmtObj, /* User-specified format object, or NULL. */ TCL_UNUSED(Tcl_Obj*), /* metadata input, may be NULL */ Tk_PhotoHandle imageHandle, /* The photo image to write into. */ int destX, int destY, /* Coordinates of top-left pixel in photo * image to be written to. */ int width, int height, /* Dimensions of block of photo image to be * written to. */ int srcX, int srcY, /* Coordinates of top-left pixel to be used in * image being read. */ Tcl_Obj* metadataOutObj) /* metadata return dict, may be NULL */ { PNGImage png; int result = TCL_ERROR; result = InitPNGImage(interp, &png, chan, NULL, TCL_ZLIB_STREAM_INFLATE); if (TCL_OK == result) { result = DecodePNG(interp, &png, fmtObj, imageHandle, destX, destY, width, height, srcX, srcY); } if (TCL_OK == result && metadataOutObj != NULL && png.DPI != -1) { result = Tcl_DictObjPut(NULL, metadataOutObj, Tcl_NewStringObj("DPI",-1), Tcl_NewDoubleObj(png.DPI)); } |
︙ | ︙ | |||
2964 2965 2966 2967 2968 2969 2970 | * New data is added to the image given by imageHandle. * *---------------------------------------------------------------------- */ static int StringReadPNG( | | | | | | | | | | > | | | 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 | * New data is added to the image given by imageHandle. * *---------------------------------------------------------------------- */ static int StringReadPNG( Tcl_Interp* interp, /* Interpreter to use for reporting errors. */ Tcl_Obj *pObjData, Tcl_Obj *fmtObj, /* User-specified format object, or NULL. */ TCL_UNUSED(Tcl_Obj*), /* metadata input, may be NULL */ Tk_PhotoHandle imageHandle, /* The photo image to write into. */ int destX, int destY, /* Coordinates of top-left pixel in photo * image to be written to. */ int width, int height, /* Dimensions of block of photo image to be * written to. */ int srcX, int srcY, /* Coordinates of top-left pixel to be used in * image being read. */ Tcl_Obj *metadataOutObj) /* metadata return dict, may be NULL */ { PNGImage png; int result = TCL_ERROR; result = InitPNGImage(interp, &png, NULL, pObjData, TCL_ZLIB_STREAM_INFLATE); if (TCL_OK == result) { result = DecodePNG(interp, &png, fmtObj, imageHandle, destX, destY, width, height, srcX, srcY); } if (TCL_OK == result && metadataOutObj != NULL && png.DPI != -1) { result = Tcl_DictObjPut(NULL, metadataOutObj, Tcl_NewStringObj("DPI",-1), Tcl_NewDoubleObj(png.DPI)); } |
︙ | ︙ |
Changes to tests/imgListFormat.test.
︙ | ︙ | |||
10 11 12 13 14 15 16 | package require tcltest 2.2 namespace import ::tcltest::* tcltest::configure {*}$argv tcltest::loadTestedCommands imageInit | < < < < | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | package require tcltest 2.2 namespace import ::tcltest::* tcltest::configure {*}$argv tcltest::loadTestedCommands imageInit set teapotPhotoFile [file join [file dirname [info script]] teapot.ppm] set transpTeapotPhotoFile [file join [file dirname [info script]] teapotTransparent.png] # --------------------------------------------------------------------- test imgListFormat-1.1 {ParseFormatOptions: default values} -setup { image create photo photo1 } -body { |
︙ | ︙ | |||
171 172 173 174 175 176 177 | } -returnCodes error -result \ {bad format option "-bogus": no options allowed} test imgListFormat-4.3 {StringReadDef: erroneous non-option argument} -setup { image create photo photo1 } -body { photo1 put orange -format {default bogus} } -returnCodes error -result {bad format option "bogus": no options allowed} | | < < | < < | 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 | } -returnCodes error -result \ {bad format option "-bogus": no options allowed} test imgListFormat-4.3 {StringReadDef: erroneous non-option argument} -setup { image create photo photo1 } -body { photo1 put orange -format {default bogus} } -returnCodes error -result {bad format option "bogus": no options allowed} test imgListFormat-4.4 {StringReadDef: normal use case} -setup { image create photo photo1 -file $teapotPhotoFile image create photo photo2 } -body { set imgData [photo1 data] photo2 put $imgData string equal [photo1 data] [photo2 data] } -cleanup { imageCleanup unset imgData } -result 1 test imgListFormat-4.5 {StringReadDef: correct compositing rule} -setup { image create photo photo1 -file $transpTeapotPhotoFile image create photo photo2 } -body { photo2 put #FF0000 -to 0 0 50 50 photo2 put [photo1 data -format {default -colorformat rgba}] -to 10 10 40 40 list [photo2 get 0 0 -withalpha] [photo2 get 20 25 -withalpha] \ [photo2 get 49 49 -withalpha] |
︙ | ︙ | |||
237 238 239 240 241 242 243 | photo1 put blue -to 0 0 35 64 set imgData [photo1 data] list [llength [lindex $imgData 0]] [llength $imgData] } -cleanup { unset imgData imageCleanup } -result {35 64} | | < < | < < | < < | < < | < < | 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 | photo1 put blue -to 0 0 35 64 set imgData [photo1 data] list [llength [lindex $imgData 0]] [llength $imgData] } -cleanup { unset imgData imageCleanup } -result {35 64} test imgListFormat-5.6 {StringWriteDef: test some pixels #1} -setup { set result {} image create photo photo1 -file $teapotPhotoFile } -body { set imgData [photo1 data] # note: with [lindex], the coords are inverted (y x) lappend result [lindex $imgData 0 0] lappend result [lindex $imgData 3 2] lappend result [lindex $imgData 107 53] lappend result [lindex $imgData 203 157] lappend result [lindex $imgData 255 255] set result } -cleanup { unset result unset imgData imageCleanup } -result {{#135cc0} #135cc0 #a06d52 #e1c8ba #135cc0} test imgListFormat-5.7 {StringWriteDef: test some pixels #2} -setup { set result {} image create photo photo1 -file $teapotPhotoFile } -body { set imgData [photo1 data -format {default -colorformat rgba}] # note: with [lindex], the coords are inverted (y x) lappend result [lindex $imgData 0 0] lappend result [lindex $imgData 3 2] lappend result [lindex $imgData 107 53] lappend result [lindex $imgData 203 157] lappend result [lindex $imgData 255 255] set result } -cleanup { unset result unset imgData imageCleanup } -result {{#135cc0ff} #135cc0ff #a06d52ff #e1c8baff #135cc0ff} test imgListFormat-5.8 {StringWriteDef: test some pixels #3} -setup { image create photo photo1 -file $transpTeapotPhotoFile } -body { set imgData [photo1 data -format {default -colorformat rgb}] set result {} lappend result [lindex $imgData 3 2] lappend result [lindex $imgData 107 53] lappend result [lindex $imgData 203 157] set result } -cleanup { unset result unset imgData imageCleanup } -result {{#004eb9} #a14100 #ffca9f} test imgListFormat-5.9 {StringWriteDef: test some pixels #4} -setup { image create photo photo1 -file $transpTeapotPhotoFile } -body { set imgData [photo1 data -format {default -colorformat rgba}] set result [lindex $imgData 3 2] lappend result [lindex $imgData 107 53] lappend result [lindex $imgData 203 157] set result } -cleanup { unset result unset imgData imageCleanup } -result {{#004eb9e1} #a14100aa #ffca9faf} test imgListFormat-5.10 {StringWriteDef: test some pixels #5} -setup { image create photo photo1 -file $transpTeapotPhotoFile } -body { set imgData [photo1 data -format {default -colorformat list}] set result {} lappend result [lindex $imgData 3 2] lappend result [lindex $imgData 107 53] lappend result [lindex $imgData 203 157] |
︙ | ︙ |
Changes to tests/imgPhoto.test.
︙ | ︙ | |||
115 116 117 118 119 120 121 | } imageInit set README [makeFile { README -- Tk test suite design document. } README-imgPhoto] | < < < | | | | | 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 | } imageInit set README [makeFile { README -- Tk test suite design document. } README-imgPhoto] set teapotPhotoFile [file join [file dirname [info script]] teapot.ppm] set transpTeapotPhotoFile [file join [file dirname [info script]] teapotTransparent.png] testConstraint needsTcl867 [package vsatisfies [package provide Tcl] 8.6.7-] test imgPhoto-1.1 {options for photo images} -body { image create photo photo1 -width 79 -height 83 list [photo1 cget -width] [photo1 cget -height] \ [image width photo1] [image height photo1] } -cleanup { image delete photo1 } -result {79 83 79 83} test imgPhoto-1.2 {options for photo images} -body { list [catch {image create photo photo1 -file no.such.file} err] \ [string tolower $err] } -result {1 {couldn't open "no.such.file": no such file or directory}} test imgPhoto-1.3 {options for photo images} -body { image create photo photo1 -file $teapotPhotoFile -format no.such.format } -returnCodes error -result {image file format "no.such.format" is not supported} test imgPhoto-1.4 {options for photo images} -body { image create photo photo1 -file $teapotPhotoFile list [image width photo1] [image height photo1] } -cleanup { image delete photo1 } -result {256 256} test imgPhoto-1.5 {options for photo images} -body { image create photo photo1 -file $teapotPhotoFile \ -format ppm -width 79 -height 83 list [image width photo1] [image height photo1] [photo1 cget -file] [photo1 cget -format] } -cleanup { image delete photo1 } -result [list 79 83 $teapotPhotoFile ppm] test imgPhoto-1.6 {options for photo images} -body { |
︙ | ︙ | |||
215 216 217 218 219 220 221 | # image create photo photo1 # image create photo photo2 -width 10 -height 10 # catch {image create photo photo2 -file bogus.img} msg # photo1 copy photo2 # set msg # } {couldn't open "bogus.img": no such file or directory} | | < < | < < | < < | < < | | < < | 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 | # image create photo photo1 # image create photo photo2 -width 10 -height 10 # catch {image create photo photo2 -file bogus.img} msg # photo1 copy photo2 # set msg # } {couldn't open "bogus.img": no such file or directory} test imgPhoto-3.1 {ImgPhotoConfigureModel procedure} -body { image create photo photo1 -file $teapotPhotoFile photo1 configure -file $teapotPhotoFile } -cleanup { image delete photo1 } -result {} test imgPhoto-3.2 {ImgPhotoConfigureModel procedure} -body { image create photo photo1 -file $teapotPhotoFile list [catch {photo1 configure -file bogus} err] [string tolower $err] \ [image width photo1] [image height photo1] } -cleanup { image delete photo1 } -result {1 {couldn't open "bogus": no such file or directory} 256 256} test imgPhoto-3.3 {ImgPhotoConfigureModel procedure} -setup { destroy .c pack [canvas .c] update } -body { image create photo photo1 .c create image 10 10 -image photo1 -tags photo1.1 -anchor nw .c create image 300 10 -image photo1 -tags photo1.2 -anchor nw update photo1 configure -file $teapotPhotoFile update list [image width photo1] [image height photo1] [.c bbox photo1.1] [.c bbox photo1.2] } -cleanup { destroy .c image delete photo1 } -result {256 256 {10 10 266 266} {300 10 556 266}} test imgPhoto-3.4 {ImgPhotoConfigureModel: -data <ppm>} -setup { image create photo photo1 -file $teapotPhotoFile image create photo photo2 } -body { photo2 configure -data [photo1 data -format ppm -from 100 100 120 120] list [image width photo2] [image height photo2] } -cleanup { imageCleanup } -result {20 20} # This testcase fails with Tcl < 8.6.7, due to [25842c] test imgPhoto-3.5 {ImgPhotoConfigureModel: -data <png>} -constraints { needsTcl867 } -setup { image create photo photo1 -file $teapotPhotoFile image create photo photo2 } -body { photo2 configure -data [photo1 data -format png -from 120 120 140 140] list [image width photo2] [image height photo2] } -cleanup { imageCleanup } -result {20 20} test imgPhoto-3.6 {ImgPhotoConfigureModel: -data <default>} -setup { image create photo photo1 -file $teapotPhotoFile image create photo photo2 } -body { photo2 configure -data [photo1 data -from 80 90 100 110] list [image width photo2] [image height photo2] } -cleanup { imageCleanup |
︙ | ︙ | |||
350 351 352 353 354 355 356 | test imgPhoto-4.9 {ImgPhotoCmd procedure: configure option} -setup { image create photo photo1 } -body { photo1 configure -palette {} -gamma } -cleanup { image delete photo1 } -returnCodes error -result {value for "-gamma" missing} | | < < | 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 | test imgPhoto-4.9 {ImgPhotoCmd procedure: configure option} -setup { image create photo photo1 } -body { photo1 configure -palette {} -gamma } -cleanup { image delete photo1 } -returnCodes error -result {value for "-gamma" missing} test imgPhoto-4.10 {ImgPhotoCmd procedure: copy option} -setup { image create photo photo1 image create photo photo2 -width 25 -height 30 } -body { image create photo photo2 -file $teapotPhotoFile photo1 configure -width 0 -height 0 -palette {} -gamma 1 photo1 copy photo2 list [image width photo1] [image height photo1] [photo1 get 100 100] |
︙ | ︙ | |||
393 394 395 396 397 398 399 | image create photo photo1 image create photo photo2 } -body { photo1 copy photo2 -from -to } -returnCodes error -cleanup { image delete photo1 photo2 } -result {the "-from" option requires one to four integer values} | | < < | < < | < < | < < | < < | < < | < < | 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 | image create photo photo1 image create photo photo2 } -body { photo1 copy photo2 -from -to } -returnCodes error -cleanup { image delete photo1 photo2 } -result {the "-from" option requires one to four integer values} test imgPhoto-4.15 {ImgPhotoCmd procedure: copy option} -setup { image create photo photo1 image create photo photo2 -file $teapotPhotoFile } -body { photo1 copy photo2 photo1 copy photo2 -from 0 70 60 120 -shrink list [image width photo1] [image height photo1] [photo1 get 20 10] } -cleanup { image delete photo1 photo2 } -result {60 50 {215 154 120}} test imgPhoto-4.16 {ImgPhotoCmd procedure: copy option} -setup { image create photo photo1 image create photo photo2 -file $teapotPhotoFile } -body { photo1 copy photo2 -from 60 120 0 70 -to 20 50 list [image width photo1] [image height photo1] [photo1 get 40 80] } -cleanup { image delete photo1 photo2 } -result {80 100 {19 92 192}} test imgPhoto-4.17 {ImgPhotoCmd procedure: copy option} -setup { image create photo photo1 image create photo photo2 -file $teapotPhotoFile } -body { photo1 copy photo2 -from 0 120 60 70 -to 0 0 100 100 list [image width photo1] [image height photo1] [photo1 get 80 60] } -cleanup { image delete photo1 photo2 } -result {100 100 {215 154 120}} test imgPhoto-4.18 {ImgPhotoCmd procedure: copy option} -setup { image create photo photo1 image create photo photo2 -file $teapotPhotoFile } -body { photo1 copy photo2 -from 60 70 0 120 -zoom 2 list [image width photo1] [image height photo1] [photo1 get 100 50] } -cleanup { image delete photo1 photo2 } -result {120 100 {169 99 47}} test imgPhoto-4.19 {ImgPhotoCmd procedure: copy option} -setup { image create photo photo1 image create photo photo2 -file $teapotPhotoFile } -body { photo1 copy photo2 -from 0 70 60 120 -zoom 2 list [image width photo1] [image height photo1] [photo1 get 100 50] } -cleanup { image delete photo1 photo2 } -result {120 100 {169 99 47}} test imgPhoto-4.20 {ImgPhotoCmd procedure: copy option} -setup { image create photo photo1 image create photo photo2 -file $teapotPhotoFile } -body { photo1 copy photo2 -from 20 20 200 180 -subsample 2 -shrink list [image width photo1] [image height photo1] [photo1 get 50 30] } -cleanup { image delete photo1 photo2 } -result {90 80 {207 146 112}} test imgPhoto-4.21 {ImgPhotoCmd procedure: copy option} -setup { image create photo photo1 image create photo photo2 -file $teapotPhotoFile } -body { photo1 copy photo2 set result [list [image width photo1] [image height photo1]] photo1 conf -width 49 -height 51 lappend result [image width photo1] [image height photo1] |
︙ | ︙ | |||
484 485 486 487 488 489 490 | photo1 conf -height 0 photo1 copy photo2 -from 0 0 10 10 -shrink lappend result [image width photo1] [image height photo1] } -cleanup { image delete photo1 photo2 } -result {256 256 49 51 49 51 49 51 10 51 10 10} # tests for <imageName> data: imgPhoto-4. | | < < | 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 | photo1 conf -height 0 photo1 copy photo2 -from 0 0 10 10 -shrink lappend result [image width photo1] [image height photo1] } -cleanup { image delete photo1 photo2 } -result {256 256 49 51 49 51 49 51 10 51 10 10} # tests for <imageName> data: imgPhoto-4. test imgPhoto-4.22 {ImgPhotoCmd procedure: get option} -setup { image create photo photo1 } -body { photo1 read $transpTeapotPhotoFile list [photo1 get 100 100 -withalpha] \ [photo1 get 150 100 -withalpha] \ [photo1 get 100 150] [photo1 get 150 150] } -cleanup { |
︙ | ︙ | |||
561 562 563 564 565 566 567 | test imgPhoto-4.30 {ImgPhotoCmd procedure: read option} -setup { image create photo photo1 } -body { photo1 read } -returnCodes error -cleanup { image delete photo1 } -result {wrong # args: should be "photo1 read fileName ?-option value ...?"} | | < < | < < | < < | < < | 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 | test imgPhoto-4.30 {ImgPhotoCmd procedure: read option} -setup { image create photo photo1 } -body { photo1 read } -returnCodes error -cleanup { image delete photo1 } -result {wrong # args: should be "photo1 read fileName ?-option value ...?"} test imgPhoto-4.31 {ImgPhotoCmd procedure: read option} -setup { image create photo photo1 } -body { photo1 read $teapotPhotoFile -zoom 2 } -returnCodes error -cleanup { image delete photo1 } -result {unrecognized option "-zoom": must be -format, -from, -metadata, -shrink, or -to} test imgPhoto-4.32 {ImgPhotoCmd procedure: read option} -setup { image create photo photo1 } -body { list [catch {photo1 read bogus} err] [string tolower $err] } -cleanup { image delete photo1 } -result {1 {couldn't open "bogus": no such file or directory}} test imgPhoto-4.33 {ImgPhotoCmd procedure: read option} -setup { image create photo photo1 } -body { photo1 read $teapotPhotoFile -format bogus } -cleanup { image delete photo1 } -returnCodes error -result {image file format "bogus" is not supported} test imgPhoto-4.34 {ImgPhotoCmd procedure: read option} -setup { image create photo photo1 } -body { photo1 read $README } -returnCodes error -cleanup { image delete photo1 } -result [subst {couldn't recognize data in image file "$README"}] test imgPhoto-4.35 {ImgPhotoCmd procedure: read option} -setup { image create photo photo1 } -body { photo1 read $teapotPhotoFile list [image width photo1] [image height photo1] [photo1 get 120 120] } -cleanup { image delete photo1 } -result {256 256 {161 109 82}} test imgPhoto-4.36 {ImgPhotoCmd procedure: read option} -setup { image create photo photo1 } -body { photo1 read $teapotPhotoFile -from 0 70 60 120 -to 10 10 -shrink list [image width photo1] [image height photo1] [photo1 get 29 19] } -cleanup { image delete photo1 } -result {70 60 {244 180 144}} |
︙ | ︙ | |||
939 940 941 942 943 944 945 | test imgPhoto-4.74 {ImgPhotoCmd procedure: put option error handling} -setup { image create photo photo1 } -body { photo1 put {{white}} -to 10 10 20 20 {{white}} } -cleanup { image delete photo1 } -returnCodes 1 -result {wrong # args: should be "photo1 put data ?-option value ...?"} | | < < | < < | 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 | test imgPhoto-4.74 {ImgPhotoCmd procedure: put option error handling} -setup { image create photo photo1 } -body { photo1 put {{white}} -to 10 10 20 20 {{white}} } -cleanup { image delete photo1 } -returnCodes 1 -result {wrong # args: should be "photo1 put data ?-option value ...?"} test imgPhoto-4.75 {<photo> read command: filename starting with '-'} -body { file copy -force $teapotPhotoFile -teapotPhotoFile image create photo photo1 photo1 read -teapotPhotoFile } -cleanup { image delete photo1 file delete ./-teapotPhotoFile } -result {} test imgPhoto-4.75.1 {ImgPhotoCmd procedure: copy to same image} -setup { imageCleanup image create photo photo1 -file $teapotPhotoFile } -body { # non-regression test for bug [5239fd749b] - shall just not crash photo1 copy photo1 -to 0 0 2000 1000 photo1 copy photo1 -subsample 2 2 -shrink } -cleanup { |
︙ | ︙ | |||
988 989 990 991 992 993 994 | } -body { photo1 put white -to 0 0 1 1 set result [photo1 transparency get 0 0] lappend result [photo1 transparency get 0 0 -alpha] } -cleanup { imageCleanup } -result {0 255} | | < < | < < | 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 | } -body { photo1 put white -to 0 0 1 1 set result [photo1 transparency get 0 0] lappend result [photo1 transparency get 0 0 -alpha] } -cleanup { imageCleanup } -result {0 255} test imgPhoto-4.79 {ImgPhotoCmd, transparency get: no option} -setup { image create photo photo1 -file $transpTeapotPhotoFile set result {} } -body { set pixelCoords {{156 239} {76 207} {153 213} {139 43} {75 112}} foreach coord $pixelCoords { lappend result [photo1 transparency get {*}$coord] } set result } -cleanup { imageCleanup } -result {0 1 0 0 0} # test imgPhoto-4.80: deleted (was transparency get: -boolean) test imgPhoto-4.81 {ImgPhotoCmd, transparency get: -alpha} -setup { image create photo photo1 -file $transpTeapotPhotoFile set result {} } -body { set pixelCoords {{156 239} {76 207} {153 213} {139 43} {75 112}} foreach coord $pixelCoords { lappend result [photo1 transparency get {*}$coord -alpha] } |
︙ | ︙ | |||
1099 1100 1101 1102 1103 1104 1105 | {unrecognized option "-bogus": must be -format, -metadata, or -to} test imgPhoto-4.92 {ImgPhotocmd put: missing data} -setup { image create photo photo1 } -body { photo1 put -to 0 0 } -returnCodes error -result \ {wrong # args: should be "photo1 put data ?-option value ...?"} | | < < | 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 | {unrecognized option "-bogus": must be -format, -metadata, or -to} test imgPhoto-4.92 {ImgPhotocmd put: missing data} -setup { image create photo photo1 } -body { photo1 put -to 0 0 } -returnCodes error -result \ {wrong # args: should be "photo1 put data ?-option value ...?"} test imgPhoto-4.93 {ImgPhotoCmd put: data in ppm format} -setup { image create photo photo1 -file $teapotPhotoFile image create photo photo2 } -body { set imgdata [photo1 data -format ppm] photo2 put $imgdata -format ppm set result {} if {[image width photo1] != [image width photo2] \ |
︙ | ︙ | |||
1333 1334 1335 1336 1337 1338 1339 | image create photo photo1 -data {{red#a green} {blue#c white#d}} } -body { photo1 data -format {default -colorformat list} } -result {{{255 0 0 170} {0 128 0 255}} {{0 0 255 204} {255 255 255 221}}} # This testcase fails with Tcl < 8.6.7, due to [25842c] test imgPhoto-4.118 {ImgPhotoCmd data: using data for new image results in same image as orignial } -constraints { | | | 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 | image create photo photo1 -data {{red#a green} {blue#c white#d}} } -body { photo1 data -format {default -colorformat list} } -result {{{255 0 0 170} {0 128 0 255}} {{0 0 255 204} {255 255 255 221}}} # This testcase fails with Tcl < 8.6.7, due to [25842c] test imgPhoto-4.118 {ImgPhotoCmd data: using data for new image results in same image as orignial } -constraints { needsTcl867 } -setup { image create photo teapot -file $teapotPhotoFile teapot copy teapot -from 50 60 70 80 -shrink image create photo teapotTransp -file $transpTeapotPhotoFile teapotTransp copy teapotTransp -from 100 110 120 130 -shrink image create photo photo1 } -body { |
︙ | ︙ | |||
1366 1367 1368 1369 1370 1371 1372 | set result } -cleanup { unset imgData unset result imageCleanup } -result {} | | < < | 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 | set result } -cleanup { unset imgData unset result imageCleanup } -result {} test imgPhoto-5.1 {ImgPhotoGet/Free procedures, shared instances} -setup { destroy .c pack [canvas .c] imageCleanup } -body { image create photo photo1 -file $teapotPhotoFile .c create image 0 0 -image photo1 -tags photo1.1 .c create image 256 0 -image photo1 -tags photo1.2 |
︙ | ︙ | |||
1403 1404 1405 1406 1407 1408 1409 | .c create image 10 10 -image photo1 update } -cleanup { destroy .c image delete photo1 } -result {} | | < < | < < | 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 | .c create image 10 10 -image photo1 update } -cleanup { destroy .c image delete photo1 } -result {} test imgPhoto-7.1 {ImgPhotoFree procedure, resource freeing} -setup { destroy .c pack [canvas .c] imageCleanup } -body { image create photo photo1 -file $teapotPhotoFile .c create image 0 0 -image photo1 -anchor nw update .c delete all image delete photo1 } -cleanup { destroy .c } -result {} test imgPhoto-7.2 {ImgPhotoFree procedures, unlinking} -setup { deleteWindows imageCleanup } -body { image create photo photo1 -file $teapotPhotoFile pack [canvas .c] .c create image 10 10 -image photo1 -anchor nw button .b1 -image photo1 |
︙ | ︙ | |||
1443 1444 1445 1446 1447 1448 1449 | destroy .b1 update .c delete all } -cleanup { destroy .c image delete photo1 } -result {} | | < < | | < < | < < | < < | < < | 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 | destroy .b1 update .c delete all } -cleanup { destroy .c image delete photo1 } -result {} test imgPhoto-7.3 {ImgPhotoFree procedures, multiple visuals} -setup { deleteWindows imageCleanup } -body { image create photo photo1 -file $teapotPhotoFile button .b1 -image photo1 frame .f -visual best button .f.b2 -image photo1 pack .f.b2 pack .b1 .f update destroy .b1 update .f.b2 configure -image {} update destroy .f image delete photo1 } -result {} test imgPhoto-8.1 {ImgPhotoDelete procedure} -body { image create photo photo2 -file $teapotPhotoFile image delete photo2 } -result {} test imgPhoto-8.2 {ImgPhotoDelete procedure} -setup { set x {} } -body { image create photo photo2 -file $teapotPhotoFile rename photo2 newphoto2 lappend x [info command photo2] [info command new*] [newphoto2 cget -file] image delete photo2 lappend x [info command new*] } -result [list {} newphoto2 $teapotPhotoFile {}] test imgPhoto-8.3 {ImgPhotoDelete procedure, name cleanup} -body { image create photo photo1 image create photo photo2 -width 10 -height 10 image delete photo2 photo1 copy photo2 } -returnCodes error -cleanup { imageCleanup } -result {image "photo2" doesn't exist or is not a photo image} test imgPhoto-9.1 {ImgPhotoCmdDeletedProc procedure} -body { image create photo photo2 -file $teapotPhotoFile rename photo2 {} list [expr {"photo2" in [imageNames]}] [catch {photo2 foo} msg] $msg } -result {0 1 {invalid command name "photo2"}} test imgPhoto-10.1 {Tk_ImgPhotoPutBlock procedure} -setup { imageCleanup } -body { image create photo photo1 photo1 put "{#ff0000 #ff0000 #ff0000 #ff0000 #ff0000 #ff0000 #ff0000 #ff0000}" -to 0 0 photo1 put "{#00ff00 #00ff00}" -to 2 0 list [photo1 get 2 0] [photo1 get 3 0] [photo1 get 4 0] } -result {{0 255 0} {0 255 0} {255 0 0}} test imgPhoto-10.2 {Tk_ImgPhotoPutBlock, same source and dest img} -setup { imageCleanup } -body { # Test for bug e4336bef5d image create photo photo1 -file $teapotPhotoFile image create photo photo2 -file $teapotPhotoFile photo2 copy photo1 -to 1 2 photo1 copy photo1 -to 1 2 string equal [photo1 data] [photo2 data] } -cleanup { imageCleanup } -result 1 test imgPhoto-10.3 {Tk_ImgPhotoPutBlock, same source and dest img} -setup { imageCleanup } -body { # Test for bug e4336bef5d image create photo photo1 -file $teapotPhotoFile image create photo photo2 -file $teapotPhotoFile photo2 copy photo1 -from 2 1 -to 4 5 300 300 photo1 copy photo1 -from 2 1 -to 4 5 300 300 |
︙ | ︙ | |||
1551 1552 1553 1554 1555 1556 1557 | image create bitmap i1 image create photo photo1 photo1 copy i1 } -cleanup { imageCleanup } -returnCodes error -result {image "i1" doesn't exist or is not a photo image} | | | < < | 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 | image create bitmap i1 image create photo photo1 photo1 copy i1 } -cleanup { imageCleanup } -returnCodes error -result {image "i1" doesn't exist or is not a photo image} test imgPhoto-12.1 {Tk_PhotoPutZoomedBlock} -body { image create photo p3 -file $teapotPhotoFile set result [list [p3 get 50 50] [p3 get 100 100]] p3 copy p3 -zoom 2 lappend result [image width p3] [image height p3] [p3 get 100 100] } -cleanup { image delete p3 } -result {{19 92 192} {169 117 90} 512 512 {19 92 192}} test imgPhoto-12.2 {Tk_ImgPhotoPutZoomedBlock, same source and dest img} -setup { imageCleanup } -body { # Test for bug e4336bef5d image create photo photo1 -file $teapotPhotoFile image create photo photo2 -file $teapotPhotoFile photo2 copy photo1 -to 0 1 200 200 -zoom 2 3 photo1 copy photo1 -to 0 1 200 200 -zoom 2 3 |
︙ | ︙ | |||
1906 1907 1908 1909 1910 1911 1912 | } -body { photo1 put $imgData -format ppm list [image width photo1] [image height photo1] } -cleanup { unset imgData imageCleanup } -result {1 2} | | < < | 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 | } -body { photo1 put $imgData -format ppm list [image width photo1] [image height photo1] } -cleanup { unset imgData imageCleanup } -result {1 2} test imgPhoto-19.4 {MatchStringFormat: ppm fmt, without opt} -setup { image create photo photo1 -file $teapotPhotoFile image create photo photo2 } -body { set imgData [photo1 data -format ppm] photo2 put $imgData list [image width photo2] [image height photo2] } -cleanup { |
︙ | ︙ | |||
2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 | gif1 cget -metadata } -cleanup { catch {image delete gif1} } -result {{update region} {0 0 16 16} {delay time} 4096 {disposal method} {do not dispose} {user interaction} 1} unset -nocomplain gifstart gifdata gifend catch {rename foreachPixel {}} catch {rename checkImgTrans {}} catch {rename checkImgTransLoop {}} imageFinish # cleanup | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 | gif1 cget -metadata } -cleanup { catch {image delete gif1} } -result {{update region} {0 0 16 16} {delay time} 4096 {disposal method} {do not dispose} {user interaction} 1} unset -nocomplain gifstart gifdata gifend set earthPhotoFile [file join [file dirname [info script]] earth.gif] test imgPhoto-24.1 {Read GIF file with -from option - Bug [1576528]} -body { set earthPhotoFile [file join [file dirname [info script]] earth.gif] image create photo gif1 gif1 read $earthPhotoFile -from 152 62 185 97 list [lindex [lindex [gif1 data] 0] 0] [image width gif1] [image height gif1] } -cleanup { catch {image delete gif1} } -result {{#d8c8b8} 33 35} test imgPhoto-24.2 {Read GIF file, copy with -from option} -body { set earthPhotoFile [file join [file dirname [info script]] earth.gif] image create photo gif1 -file $earthPhotoFile image create photo gif2 gif2 copy gif1 -from 152 62 185 97 list [lindex [lindex [gif2 data] 0] 0] [image width gif2] [image height gif2] } -cleanup { catch {image delete gif1 ; image delete gif2} } -result {{#d8c8b8} 33 35} test imgPhoto-24.3 {Read GIF file with -to option} -body { image create photo gif1 gif1 read $earthPhotoFile -to 100 200 list [lindex [lindex [gif1 data] 262] 252] [image width gif1] [image height gif1] } -cleanup { catch {image delete gif1} } -result {{#d8c8b8} 420 400} test imgPhoto-24.4 {Read GIF file with -from and -to options} -body { set earthPhotoFile [file join [file dirname [info script]] earth.gif] image create photo gif1 gif1 read $earthPhotoFile -from 152 62 185 97 -to 100 200 list [lindex [lindex [gif1 data] 200] 100] [image width gif1] [image height gif1] } -cleanup { catch {image delete gif1} } -result {{#d8c8b8} 133 235} test imgPhoto-24.5 {Read GIF file with -from, -to and -shrink options} -body { set earthPhotoFile [file join [file dirname [info script]] earth.gif] image create photo gif1 -file $teapotPhotoFile gif1 read $earthPhotoFile -from 152 62 185 97 -to 80 120 -shrink list [lindex [lindex [gif1 data] 120] 80] [image width gif1] [image height gif1] } -cleanup { catch {image delete gif1} } -result {{#d8c8b8} 113 155} test imgPhoto-24.6 {Read GIF file with -from option, read large region from small file} -body { set earthPhotoFile [file join [file dirname [info script]] earth.gif] image create photo gif1 catch {gif1 read $earthPhotoFile -from 152 62 2000 1000} msg list $msg [image width gif1] [image height gif1] } -cleanup { catch {image delete gif1} } -result {{coordinates for -from option extend outside source image} 0 0} unset earthPhotoFile set ousterPhotoFile [file join [file dirname [info script]] ouster.png] test imgPhoto-25.1 {Read PNG file with -from option - Bug [1576528]} -body { image create photo png1 png1 read $ousterPhotoFile -from 102 62 135 97 list [lindex [lindex [png1 data] 0] 0] [image width png1] [image height png1] } -cleanup { catch {image delete png1} } -result {{#c97962} 33 35} test imgPhoto-25.2 {Read PNG file, copy with -from option} -body { image create photo png1 -file $ousterPhotoFile image create photo png2 png2 copy png1 -from 102 62 135 97 list [lindex [lindex [png2 data] 0] 0] [image width png2] [image height png2] } -cleanup { catch {image delete png1 ; image delete png2} } -result {{#c97962} 33 35} test imgPhoto-25.3 {Read PNG file with -to option} -body { image create photo png1 png1 read $ousterPhotoFile -to 100 200 list [lindex [lindex [png1 data] 262] 202] [image width png1] [image height png1] } -cleanup { catch {image delete png1} } -result {{#c97962} 242 381} test imgPhoto-25.4 {Read PNG file with -from and -to options} -body { image create photo png1 png1 read $ousterPhotoFile -from 102 62 135 97 -to 100 200 list [lindex [lindex [png1 data] 200] 100] [image width png1] [image height png1] } -cleanup { catch {image delete png1} } -result {{#c97962} 133 235} test imgPhoto-25.5 {Read PNG file with -from, -to and -shrink options} -body { image create photo png1 -file $teapotPhotoFile png1 read $ousterPhotoFile -from 102 62 135 97 -to 80 120 -shrink list [lindex [lindex [png1 data] 120] 80] [image width png1] [image height png1] } -cleanup { catch {image delete png1} } -result {{#c97962} 113 155} test imgPhoto-25.6 {Read PNG file with -from option, read large region from small file} -body { image create photo png1 catch {png1 read $ousterPhotoFile -from 102 62 2000 1000} msg list $msg [image width png1] [image height png1] } -cleanup { catch {image delete png1} } -result {{coordinates for -from option extend outside source image} 0 0} unset ousterPhotoFile catch {rename foreachPixel {}} catch {rename checkImgTrans {}} catch {rename checkImgTransLoop {}} imageFinish # cleanup |
︙ | ︙ |
Changes to tests/menu.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # This file is a Tcl script to test menus in Tk. It is # organized in the standard fashion for Tcl tests. # # Copyright © 1995-1997 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands imageInit | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | # This file is a Tcl script to test menus in Tk. It is # organized in the standard fashion for Tcl tests. # # Copyright © 1995-1997 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands imageInit testConstraint pressbutton [llength [info commands pressbutton]] testConstraint movemouse [llength [info commands movemouse]] test menu-1.1 {Tk_MenuCmd procedure} -body { menu } -returnCodes error -result {wrong # args: should be "menu pathName ?-option value ...?"} test menu-1.2 {Tk_MenuCmd procedure} -body { |
︙ | ︙ | |||
294 295 296 297 298 299 300 | menu .m2 -tearoff 1 .m2 add command -label "test" .m1 add cascade -label "cascade" -menu .m2 .m1 add separator .m1 add checkbutton -label "checkbutton" -variable check -onvalue on -offvalue off .m1 add radiobutton -label "radiobutton" -variable radio | | | < | 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 | menu .m2 -tearoff 1 .m2 add command -label "test" .m1 add cascade -label "cascade" -menu .m2 .m1 add separator .m1 add checkbutton -label "checkbutton" -variable check -onvalue on -offvalue off .m1 add radiobutton -label "radiobutton" -variable radio set earthPhotoFile [file join [file dirname [info script]] earth.gif] image create photo image1 -file $earthPhotoFile test menu-2.31 {entry configuration options 0 -activebackground #012345 tearoff} -body { .m1 entryconfigure 0 -activebackground #012345 } -returnCodes error -result {unknown option "-activebackground"} test menu-2.32 {entry configuration options 1 -activebackground #012345 command} -body { .m1 entryconfigure 1 -activebackground #012345 |
︙ | ︙ | |||
696 697 698 699 700 701 702 | .m1 entryconfigure 4 -foreground non-existent } -returnCodes error -result {unknown color name "non-existent"} test menu-2.120 {entry configuration options 5 -foreground non-existent radiobutton} -body { .m1 entryconfigure 5 -foreground non-existent } -returnCodes error -result {unknown color name "non-existent"} | | < < | < < | < < | < < | < < | < < | 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 | .m1 entryconfigure 4 -foreground non-existent } -returnCodes error -result {unknown color name "non-existent"} test menu-2.120 {entry configuration options 5 -foreground non-existent radiobutton} -body { .m1 entryconfigure 5 -foreground non-existent } -returnCodes error -result {unknown color name "non-existent"} test menu-2.121 {entry configuration options 0 -image image1 tearoff} -body { .m1 entryconfigure 0 -image image1 } -returnCodes error -result {unknown option "-image"} test menu-2.122 {entry configuration options 1 -image image1 command} -setup { .m1 entryconfigure 1 -image {} } -body { .m1 entryconfigure 1 -image image1 lindex [.m1 entryconfigure 1 -image] 4 } -cleanup { .m1 entryconfigure 1 -image {} } -result {image1} test menu-2.123 {entry configuration options 2 -image image1 cascade} -setup { .m1 entryconfigure 2 -image {} } -body { .m1 entryconfigure 2 -image image1 lindex [.m1 entryconfigure 2 -image] 4 } -cleanup { .m1 entryconfigure 2 -image {} } -result {image1} test menu-2.124 {entry configuration options 3 -image image1 separator} -body { .m1 entryconfigure 3 -image image1 } -returnCodes error -result {unknown option "-image"} test menu-2.125 {entry configuration options 4 -image image1 checkbutton} -setup { .m1 entryconfigure 4 -image {} } -body { .m1 entryconfigure 4 -image image1 lindex [.m1 entryconfigure 4 -image] 4 } -cleanup { .m1 entryconfigure 4 -image {} } -result {image1} test menu-2.126 {entry configuration options 5 -image image1 radiobutton} -setup { .m1 entryconfigure 5 -image {} } -body { .m1 entryconfigure 5 -image image1 lindex [.m1 entryconfigure 5 -image] 4 } -cleanup { .m1 entryconfigure 5 -image {} } -result {image1} |
︙ | ︙ | |||
987 988 989 990 991 992 993 | .m1 entryconfigure 4 -selectcolor non-existent } -returnCodes error -result {unknown color name "non-existent"} test menu-2.180 {entry configuration options 5 -selectcolor non-existent radiobutton} -body { .m1 entryconfigure 5 -selectcolor non-existent } -returnCodes error -result {unknown color name "non-existent"} | | < < | < < | < < | < < | < < | < < | 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 | .m1 entryconfigure 4 -selectcolor non-existent } -returnCodes error -result {unknown color name "non-existent"} test menu-2.180 {entry configuration options 5 -selectcolor non-existent radiobutton} -body { .m1 entryconfigure 5 -selectcolor non-existent } -returnCodes error -result {unknown color name "non-existent"} test menu-2.181 {entry configuration options 0 -selectimage image1 tearoff} -body { .m1 entryconfigure 0 -selectimage image1 } -returnCodes error -result {unknown option "-selectimage"} test menu-2.182 {entry configuration options 1 -selectimage image1 command} -body { .m1 entryconfigure 1 -selectimage image1 } -returnCodes error -result {unknown option "-selectimage"} test menu-2.183 {entry configuration options 2 -selectimage image1 cascade} -body { .m1 entryconfigure 2 -selectimage image1 } -returnCodes error -result {unknown option "-selectimage"} test menu-2.184 {entry configuration options 3 -selectimage image1 separator} -body { .m1 entryconfigure 3 -selectimage image1 } -returnCodes error -result {unknown option "-selectimage"} test menu-2.185 {entry configuration options 4 -selectimage image1 checkbutton} -setup { .m1 entryconfigure 4 -selectimage {} } -body { .m1 entryconfigure 4 -selectimage image1 lindex [.m1 entryconfigure 4 -selectimage] 4 } -cleanup { .m1 entryconfigure 4 -selectimage {} } -result {image1} test menu-2.186 {entry configuration options 5 -selectimage image1 radiobutton} -setup { .m1 entryconfigure 5 -selectimage {} } -body { .m1 entryconfigure 5 -selectimage image1 lindex [.m1 entryconfigure 5 -selectimage] 4 } -cleanup { .m1 entryconfigure 5 -selectimage {} } -result {image1} |
︙ | ︙ | |||
1216 1217 1218 1219 1220 1221 1222 | } -returnCodes error -result {bad index "3p": must be integer?[+-]integer?, end?[+-]integer?, or ""} test menu-2.228 {entry configuration options 5 -underline 3p radiobutton} -body { .m1 entryconfigure 5 -underline 3p } -returnCodes error -result {bad index "3p": must be integer?[+-]integer?, end?[+-]integer?, or ""} deleteWindows | < | < < | 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 | } -returnCodes error -result {bad index "3p": must be integer?[+-]integer?, end?[+-]integer?, or ""} test menu-2.228 {entry configuration options 5 -underline 3p radiobutton} -body { .m1 entryconfigure 5 -underline 3p } -returnCodes error -result {bad index "3p": must be integer?[+-]integer?, end?[+-]integer?, or ""} deleteWindows image delete image1 test menu-3.1 {MenuWidgetCmd procedure} -setup { destroy .m1 } -body { menu .m1 .m1 |
︙ | ︙ | |||
2343 2344 2345 2346 2347 2348 2349 | deleteWindows } -body { menu .m1 menu .m2 .m1 add cascade -menu .m2 list [.m1 delete 1] [destroy .m1 .m2] } -result {{} {}} | | | 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 | deleteWindows } -body { menu .m1 menu .m2 .m1 add cascade -menu .m2 list [.m1 delete 1] [destroy .m1 .m2] } -result {{} {}} test menu-8.2 {DestroyMenuEntry} -setup { deleteWindows catch {image delete image1a} } -body { image create photo image1a -file $earthPhotoFile menu .m1 .m1 add command -image image1a list [.m1 delete 1] [destroy .m1] [image delete image1a] |
︙ | ︙ | |||
2684 2685 2686 2687 2688 2689 2690 | image create test image1 .m1 entryconfigure 1 -image image1 } -cleanup { deleteWindows imageCleanup } -result {} test menu-11.19 {ConfigureMenuEntry} -constraints { | | | | > > | 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 | image create test image1 .m1 entryconfigure 1 -image image1 } -cleanup { deleteWindows imageCleanup } -result {} test menu-11.19 {ConfigureMenuEntry} -constraints { testImageType } -setup { deleteWindows imageCleanup } -body { image create test image1 image create photo image2 -file $earthPhotoFile menu .m1 .m1 add command -image image1 .m1 entryconfigure 1 -image image2 } -cleanup { deleteWindows imageCleanup } -result {} test menu-11.20 {ConfigureMenuEntry} -constraints { testImageType } -setup { deleteWindows imageCleanup } -body { image create photo image1 -file $earthPhotoFile image create test image2 menu .m1 .m1 add checkbutton -image image1 .m1 entryconfigure 1 -selectimage image2 } -cleanup { deleteWindows imageCleanup } -result {} test menu-11.21 {ConfigureMenuEntry} -constraints { testImageType } -setup { deleteWindows imageCleanup } -body { image create photo image1 -file $earthPhotoFile image create test image2 image create test image3 menu .m1 .m1 add checkbutton -image image1 -selectimage image2 .m1 entryconfigure 1 -selectimage image3 } -cleanup { deleteWindows imageCleanup } -result {} unset earthPhotoFile test menu-12.1 {ConfigureMenuCloneEntries} -setup { deleteWindows } -body { menu .m1 .m1 clone .m2 |
︙ | ︙ |
Added tests/ouster.png.
cannot compute difference between binary files