diff options
Diffstat (limited to 'tcl/tests/image.test')
| -rw-r--r-- | tcl/tests/image.test | 379 |
1 files changed, 0 insertions, 379 deletions
diff --git a/tcl/tests/image.test b/tcl/tests/image.test deleted file mode 100644 index 4ef07e0b03e..00000000000 --- a/tcl/tests/image.test +++ /dev/null @@ -1,379 +0,0 @@ -# This file is a Tcl script to test out the "image" command and the -# other procedures in the file tkImage.c. It is organized in the -# standard fashion for Tcl tests. -# -# Copyright (c) 1994 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# All rights reserved. -# -# RCS: @(#) $Id$ - -package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] -tcltest::loadTestedCommands - -namespace import -force tcltest::interpreter -namespace import -force tcltest::makeFile -namespace import -force tcltest::removeFile - -eval image delete [image names] -canvas .c -highlightthickness 2 -pack .c -update -test image-1.1 {Tk_ImageCmd procedure, "create" option} { - list [catch image msg] $msg -} {1 {wrong # args: should be "image option ?args?"}} -test image-1.2 {Tk_ImageCmd procedure, "create" option} { - list [catch {image gorp} msg] $msg -} {1 {bad option "gorp": must be create, delete, height, inuse, names, type, types, or width}} -test image-1.3 {Tk_ImageCmd procedure, "create" option} { - list [catch {image create} msg] $msg -} {1 {wrong # args: should be "image create type ?name? ?options?"}} -test image-1.4 {Tk_ImageCmd procedure, "create" option} { - list [catch {image c bad_type} msg] $msg -} {1 {image type "bad_type" doesn't exist}} -test image-1.5 {Tk_ImageCmd procedure, "create" option} testImageType { - list [image create test myimage] [image names] -} {myimage myimage} -test image-1.6 {Tk_ImageCmd procedure, "create" option} testImageType { - scan [image create test] image%d first - image create test myimage - scan [image create test -variable x] image%d second - expr $second-$first -} {1} -test image-1.7 {Tk_ImageCmd procedure, "create" option} testImageType { - image delete myimage - image create test myimage -variable x - .c create image 100 50 -image myimage - .c create image 100 150 -image myimage - update - set x {} - image create test myimage -variable x - update - set x -} {{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}} -test image-1.8 {Tk_ImageCmd procedure, "create" option} testImageType { - .c delete all - image create test myimage -variable x - .c create image 100 50 -image myimage - .c create image 100 150 -image myimage - image delete myimage - update - set x {} - image create test myimage -variable x - update - set x -} {{myimage get} {myimage get} {myimage display 0 0 30 15 30 30} {myimage display 0 0 30 15 30 130}} -test image-1.9 {Tk_ImageCmd procedure, "create" option} testImageType { - .c delete all - eval image delete [image names] - list [catch {image create test -badName foo} msg] $msg [image names] -} {1 {bad option name "-badName"} {}} -test image-1.10 {Tk_ImageCmd procedure, "create" option with "." as name} { - set script [makeFile { - update - puts [list [catch {image create photo .} msg] $msg] - exit - } script] - set x [list [catch {exec [interpreter] <$script} msg] $msg] - removeFile script - set x -} {0 {1 {this isn't a Tk applicationNULL main window}}} -# I don't like the error message! - -test image-2.1 {Tk_ImageCmd procedure, "delete" option} { - list [catch {image delete} msg] $msg -} {0 {}} -test image-2.2 {Tk_ImageCmd procedure, "delete" option} testImageType { - .c delete all - eval image delete [image names] - image create test myimage - image create test img2 - set result {} - lappend result [lsort [image names]] - image d myimage img2 - lappend result [image names] -} {{img2 myimage} {}} -test image-2.3 {Tk_ImageCmd procedure, "delete" option} testImageType { - .c delete all - eval image delete [image names] - image create test myimage - image create test img2 - list [catch {image delete myimage gorp img2} msg] $msg [image names] -} {1 {image "gorp" doesn't exist} img2} - -test image-3.1 {Tk_ImageCmd procedure, "height" option} { - list [catch {image height} msg] $msg -} {1 {wrong # args: should be "image height name"}} -test image-3.2 {Tk_ImageCmd procedure, "height" option} { - list [catch {image height a b} msg] $msg -} {1 {wrong # args: should be "image height name"}} -test image-3.3 {Tk_ImageCmd procedure, "height" option} { - list [catch {image height foo} msg] $msg -} {1 {image "foo" doesn't exist}} -test image-3.4 {Tk_ImageCmd procedure, "height" option} testImageType { - image create test myimage - set x [image h myimage] - myimage changed 0 0 0 0 60 50 - list $x [image height myimage] -} {15 50} - -test image-4.1 {Tk_ImageCmd procedure, "names" option} { - list [catch {image names x} msg] $msg -} {1 {wrong # args: should be "image names"}} -test image-4.2 {Tk_ImageCmd procedure, "names" option} testImageType { - .c delete all - eval image delete [image names] - image create test myimage - image create test img2 - image create test 24613 - lsort [image names] -} {24613 img2 myimage} -test image-4.3 {Tk_ImageCmd procedure, "names" option} { - .c delete all - eval image delete [image names] - lsort [image names] -} {} - -test image-5.1 {Tk_ImageCmd procedure, "type" option} { - list [catch {image type} msg] $msg -} {1 {wrong # args: should be "image type name"}} -test image-5.2 {Tk_ImageCmd procedure, "type" option} { - list [catch {image type a b} msg] $msg -} {1 {wrong # args: should be "image type name"}} -test image-5.3 {Tk_ImageCmd procedure, "type" option} { - list [catch {image type foo} msg] $msg -} {1 {image "foo" doesn't exist}} -test image-5.4 {Tk_ImageCmd procedure, "type" option} testImageType { - image create test myimage - image type myimage -} {test} -test image-5.5 {Tk_ImageCmd procedure, "type" option} testImageType { - image create test myimage - .c create image 50 50 -image myimage - image delete myimage - image type myimage -} {} - -test image-6.1 {Tk_ImageCmd procedure, "types" option} { - list [catch {image types x} msg] $msg -} {1 {wrong # args: should be "image types"}} -test image-6.2 {Tk_ImageCmd procedure, "types" option} testImageType { - lsort [image types] -} {bitmap photo test} - -test image-7.1 {Tk_ImageCmd procedure, "width" option} { - list [catch {image width} msg] $msg -} {1 {wrong # args: should be "image width name"}} -test image-7.2 {Tk_ImageCmd procedure, "width" option} { - list [catch {image width a b} msg] $msg -} {1 {wrong # args: should be "image width name"}} -test image-7.3 {Tk_ImageCmd procedure, "width" option} { - list [catch {image width foo} msg] $msg -} {1 {image "foo" doesn't exist}} -test image-7.4 {Tk_ImageCmd procedure, "width" option} testImageType { - image create test myimage - set x [image w myimage] - myimage changed 0 0 0 0 60 50 - list $x [image width myimage] -} {30 60} - -test image-8.1 {Tk_ImageCmd procedure, "inuse" option} testImageType { - catch {image delete myimage2} - image create test myimage2 - set res {} - lappend res [image inuse myimage2] - catch {destroy .b} - button .b -image myimage2 - lappend res [image inuse myimage2] - catch {destroy .b} - image delete myimage2 - set res -} [list 0 1] - - -test image-9.1 {Tk_ImageChanged procedure} testImageType { - .c delete all - eval image delete [image names] - image create test foo -variable x - .c create image 50 50 -image foo - update - set x {} - foo changed 5 6 7 8 30 15 - update - set x -} {{foo display 5 6 7 8 30 30}} -test image-9.2 {Tk_ImageChanged procedure} testImageType { - .c delete all - eval image delete [image names] - image create test foo -variable x - .c create image 50 50 -image foo - .c create image 90 100 -image foo - update - set x {} - foo changed 5 6 7 8 30 15 - update - set x -} {{foo display 5 6 25 9 30 30} {foo display 0 0 12 14 65 74}} - -test image-10.1 {Tk_GetImage procedure} { - list [catch {.c create image 100 10 -image bad_name} msg] $msg -} {1 {image "bad_name" doesn't exist}} -test image-10.2 {Tk_GetImage procedure} testImageType { - image create test mytest - catch {destroy .l} - label .l -image mytest - image delete mytest - set result [list [catch {label .l2 -image mytest} msg] $msg] - destroy .l - set result -} {1 {image "mytest" doesn't exist}} - -test image-11.1 {Tk_FreeImage procedure} testImageType { - .c delete all - eval image delete [image names] - image create test foo -variable x - .c create image 50 50 -image foo -tags i1 - .c create image 90 100 -image foo -tags i2 - pack forget .c - update - set x {} - .c delete i1 - pack .c - update - list [image names] $x -} {foo {{foo free} {foo display 0 0 30 15 103 121}}} -test image-11.2 {Tk_FreeImage procedure} testImageType { - .c delete all - eval image delete [image names] - image create test foo -variable x - .c create image 50 50 -image foo -tags i1 - image delete foo - update - set names [image names] - set x {} - .c delete i1 - pack forget .c - pack .c - update - list $names [image names] $x -} {foo {} {}} - -# Non-portable, apparently due to differences in rounding: - -test image-12.1 {Tk_RedrawImage procedure, redisplay area clipping} \ - {testImageType nonPortable} { - .c delete all - eval image delete [image names] - image create test foo -variable x - .c create image 50 60 -image foo -tags i1 -anchor nw - update - .c create rectangle 30 40 55 65 -width 0 -fill black -outline {} - set x {} - update - set x -} {{foo display 0 0 5 5 50 50}} -test image-12.2 {Tk_RedrawImage procedure, redisplay area clipping} \ - {testImageType nonPortable} { - .c delete all - eval image delete [image names] - image create test foo -variable x - .c create image 50 60 -image foo -tags i1 -anchor nw - update - .c create rectangle 60 40 100 65 -width 0 -fill black -outline {} - set x {} - update - set x -} {{foo display 10 0 20 5 30 50}} -test image-12.3 {Tk_RedrawImage procedure, redisplay area clipping} \ - {testImageType nonPortable} { - .c delete all - eval image delete [image names] - image create test foo -variable x - .c create image 50 60 -image foo -tags i1 -anchor nw - update - .c create rectangle 60 70 100 200 -width 0 -fill black -outline {} - set x {} - update - set x -} {{foo display 10 10 20 5 30 30}} -test image-12.4 {Tk_RedrawImage procedure, redisplay area clipping} \ - {testImageType nonPortable} { - .c delete all - eval image delete [image names] - image create test foo -variable x - .c create image 50 60 -image foo -tags i1 -anchor nw - update - .c create rectangle 30 70 55 200 -width 0 -fill black -outline {} - set x {} - update - set x -} {{foo display 0 10 5 5 50 30}} -test image-12.5 {Tk_RedrawImage procedure, redisplay area clipping} \ - {testImageType nonPortable} { - .c delete all - eval image delete [image names] - image create test foo -variable x - .c create image 50 60 -image foo -tags i1 -anchor nw - update - .c create rectangle 10 20 120 130 -width 0 -fill black -outline {} - set x {} - update - set x -} {{foo display 0 0 30 15 70 70}} -test image-12.6 {Tk_RedrawImage procedure, redisplay area clipping} \ - {testImageType nonPortable} { - .c delete all - eval image delete [image names] - image create test foo -variable x - .c create image 50 60 -image foo -tags i1 -anchor nw - update - .c create rectangle 55 65 75 70 -width 0 -fill black -outline {} - set x {} - update - set x -} {{foo display 5 5 20 5 30 30}} - -test image-13.1 {Tk_SizeOfImage procedure} testImageType { - eval image delete [image names] - image create test foo -variable x - set result [list [image width foo] [image height foo]] - foo changed 0 0 0 0 85 60 - lappend result [image width foo] [image height foo] -} {30 15 85 60} - -test image-13.2 {DeleteImage procedure} testImageType { - .c delete all - eval image delete [image names] - image create test foo -variable x - .c create image 50 50 -image foo -tags i1 - .c create image 90 100 -image foo -tags i2 - set x {} - image delete foo - lappend x | [image names] | - image delete foo - lappend x | [image names] | -} {{foo free} {foo free} {foo delete} | foo | | foo |} - -catch {image delete hidden} -set l [image names] -set h [interp hidden] - -test image-14.1 {image command vs hidden commands} { - catch {image delete hidden} - image create photo hidden - interp hide {} hidden - image delete hidden - list [image names] [interp hidden] -} [list $l $h] - -destroy .c -eval image delete [image names] - -# cleanup -::tcltest::cleanupTests -return |