home *** CD-ROM | disk | FTP | other *** search
/ Ultra Pack / UltraComputing Partner Applications.iso / SunLabs / tclTK / src / tk4.0 / tests / image.test < prev    next >
Encoding:
Text File  |  1995-05-17  |  10.6 KB  |  333 lines
  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. #
  8. # See the file "license.terms" for information on usage and redistribution
  9. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  10. #
  11. # @(#) image.test 1.7 95/03/10 16:49:10
  12.  
  13. if {[lsearch [image types] test] < 0} {
  14.     puts "This application hasn't been compiled with the \"test\" image"
  15.     puts "type, so I can't run this test.  Are you sure you're using"
  16.     puts "tktest instead of wish?"
  17.     return
  18. }
  19.  
  20. if {[info procs test] != "test"} {
  21.     source defs
  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
  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.  
  209. test image-10.1 {Tk_FreeImage procedure} {
  210.     .c delete all
  211.     eval image delete [image names]
  212.     image create test foo -variable x
  213.     .c create image 50 50 -image foo -tags i1
  214.     .c create image 90 100 -image foo -tags i2
  215.     pack forget .c
  216.     update
  217.     set x {}
  218.     .c delete i1
  219.     pack .c
  220.     update
  221.     list [image names] $x
  222. } {foo {{foo free} {foo display 0 0 30 15 103 121}}}
  223. test image-10.2 {Tk_FreeImage procedure} {
  224.     .c delete all
  225.     eval image delete [image names]
  226.     image create test foo -variable x
  227.     .c create image 50 50 -image foo -tags i1
  228.     image delete foo
  229.     update
  230.     set names [image names]
  231.     set x {}
  232.     .c delete i1
  233.     pack forget .c
  234.     pack .c
  235.     update
  236.     list $names [image names] $x
  237. } {foo {} {}}
  238.  
  239. # Non-portable, apparently due to differences in rounding:
  240.  
  241. if $doNonPortableTests {
  242.     test image-11.1 {Tk_RedrawImage procedure, redisplay area clipping} {
  243.     .c delete all
  244.     eval image delete [image names]
  245.     image create test foo -variable x
  246.     .c create image 50 60 -image foo -tags i1 -anchor nw
  247.     update
  248.     .c create rectangle 30 40 55 65 -width 0 -fill black -outline {}
  249.     set x {}
  250.     update
  251.     set x
  252.     } {{foo display 0 0 6 6 50 50}}
  253.     test image-11.2 {Tk_RedrawImage procedure, redisplay area clipping} {
  254.     .c delete all
  255.     eval image delete [image names]
  256.     image create test foo -variable x
  257.     .c create image 50 60 -image foo -tags i1 -anchor nw
  258.     update
  259.     .c create rectangle 60 40 100 65 -width 0 -fill black -outline {}
  260.     set x {}
  261.     update
  262.     set x
  263.     } {{foo display 10 0 20 6 30 50}}
  264.     test image-11.3 {Tk_RedrawImage procedure, redisplay area clipping} {
  265.     .c delete all
  266.     eval image delete [image names]
  267.     image create test foo -variable x
  268.     .c create image 50 60 -image foo -tags i1 -anchor nw
  269.     update
  270.     .c create rectangle 60 70 100 200 -width 0 -fill black -outline {}
  271.     set x {}
  272.     update
  273.     set x
  274.     } {{foo display 10 10 20 5 30 30}}
  275.     test image-11.4 {Tk_RedrawImage procedure, redisplay area clipping} {
  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 30 70 55 200 -width 0 -fill black -outline {}
  282.     set x {}
  283.     update
  284.     set x
  285.     } {{foo display 0 10 6 5 50 30}}
  286.     test image-11.5 {Tk_RedrawImage procedure, redisplay area clipping} {
  287.     .c delete all
  288.     eval image delete [image names]
  289.     image create test foo -variable x
  290.     .c create image 50 60 -image foo -tags i1 -anchor nw
  291.     update
  292.     .c create rectangle 10 20 120 130 -width 0 -fill black -outline {}
  293.     set x {}
  294.     update
  295.     set x
  296.     } {{foo display 0 0 30 15 70 70}}
  297.     test image-11.6 {Tk_RedrawImage procedure, redisplay area clipping} {
  298.     .c delete all
  299.     eval image delete [image names]
  300.     image create test foo -variable x
  301.     .c create image 50 60 -image foo -tags i1 -anchor nw
  302.     update
  303.     .c create rectangle 55 65 75 70 -width 0 -fill black -outline {}
  304.     set x {}
  305.     update
  306.     set x
  307.     } {{foo display 5 5 21 6 30 30}}
  308. }
  309.  
  310. test image-12.1 {Tk_SizeOfImage procedure} {
  311.     eval image delete [image names]
  312.     image create test foo -variable x
  313.     set result [list [image width foo] [image height foo]]
  314.     foo changed 0 0 0 0 85 60
  315.     lappend result [image width foo] [image height foo]
  316. } {30 15 85 60}
  317.  
  318. test image-12.1 {DeleteImage procedure} {
  319.     .c delete all
  320.     eval image delete [image names]
  321.     image create test foo -variable x
  322.     .c create image 50 50 -image foo -tags i1
  323.     .c create image 90 100 -image foo -tags i2
  324.     set x {}
  325.     image delete foo
  326.     lappend x | [image names] |
  327.     image delete foo
  328.     lappend x | [image names] |
  329. } {{foo free} {foo free} {foo delete} | foo | | foo |}
  330.  
  331. destroy .c
  332. eval image delete [image names]
  333.