home *** CD-ROM | disk | FTP | other *** search
/ Ultra Pack / UltraComputing Partner Applications.iso / SunLabs / tclTK / src / tk4.0 / tests / visual.test < prev    next >
Encoding:
Text File  |  1995-05-09  |  8.5 KB  |  297 lines
  1. # This file is a Tcl script to test the visual- and colormap-handling
  2. # procedures in the file tkVisual.c.  It is organized in the standard
  3. # 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. # @(#) visual.test 1.6 95/05/09 13:47:18
  12.  
  13. if {[info procs test] != "test"} {
  14.     source defs
  15. }
  16.  
  17. foreach i [winfo children .] {
  18.     destroy $i
  19. }
  20. wm geometry . {}
  21. raise .
  22. update
  23.  
  24. # eatColors --
  25. # Creates a toplevel window and allocates enough colors in it to
  26. # use up all the slots in the colormap.
  27. #
  28. # Arguments:
  29. # w -        Name of toplevel window to create.
  30.  
  31. proc eatColors {w} {
  32.     catch {destroy $w}
  33.     toplevel $w
  34.     wm geom $w +0+0
  35.     canvas $w.c -width 400 -height 200 -bd 0
  36.     pack $w.c
  37.     for {set y 0} {$y < 8} {incr y} {
  38.     for {set x 0} {$x < 40} {incr x} {
  39.         set color [format #%02x%02x%02x [expr $x*6] [expr $y*30] 0]
  40.         $w.c create rectangle [expr 10*$x] [expr 20*$y] \
  41.             [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \
  42.             -fill $color
  43.     }
  44.     }
  45.     update
  46. }
  47.  
  48. # colorsFree --
  49. #
  50. # Returns 1 if there appear to be free colormap entries in a window,
  51. # 0 otherwise.
  52. #
  53. # Arguments:
  54. # w -            Name of window in which to check.
  55. # red, green, blue -    Intensities to use in a trial color allocation
  56. #            to see if there are colormap entries free.
  57.  
  58. proc colorsFree {w {red 31} {green 245} {blue 192}} {
  59.     set vals [winfo rgb $w [format #%02x%02x%02x $red $green $blue]]
  60.     expr ([lindex $vals 0]/256 == $red) && ([lindex $vals 1]/256 == $green) \
  61.         && ([lindex $vals 2]/256 == $blue)
  62. }
  63.  
  64. # If more than one visual type is available for the screen, pick one
  65. # that is *not* the default.
  66.  
  67. set default "[winfo visual .] [winfo depth .]"
  68. set avail [winfo visualsavailable .]
  69. if {[llength $avail] > 1} {
  70.     foreach visual $avail {
  71.     if {$visual != $default} {
  72.         set other $visual
  73.         break
  74.     }
  75.     }
  76. } else {
  77.     set other {}
  78. }
  79.  
  80. test visual-1.1 {Tk_GetVisual, copying from other window} {
  81.     list [catch {toplevel .t -visual .foo.bar} msg] $msg
  82. } {1 {bad window path name ".foo.bar"}}
  83. if {$other != ""} {
  84.     if $doNonPortableTests {
  85.     test visual-1.2 {Tk_GetVisual, copying from other window} {
  86.         catch {destroy .t1}
  87.         catch {destroy .t2}
  88.         toplevel .t1 -width 250 -height 100 -visual $other
  89.         wm geom .t1 +0+0
  90.         toplevel .t2 -width 200 -height 80 -visual .t1
  91.         wm geom .t2 +5+5
  92.         concat "[winfo visual .t2] [winfo depth .t2]"
  93.     } $other
  94.     }
  95.     test visual-1.3 {Tk_GetVisual, copying from other window} {
  96.     catch {destroy .t1}
  97.     catch {destroy .t2}
  98.     toplevel .t1 -width 250 -height 100 -visual $other
  99.     wm geom .t1 +0+0
  100.     toplevel .t2 -width 200 -height 80 -visual .
  101.     wm geom .t2 +5+5
  102.     concat "[winfo visual .t2] [winfo depth .t2]"
  103.     } $default
  104.  
  105.     # Make sure reference count is incremented when copying visual (the
  106.     # following test will cause the colormap to be freed prematurely if
  107.     # the reference count isn't incremented).
  108.     test visual-1.4 {Tk_GetVisual, colormap reference count} {
  109.     catch {destroy .t1}
  110.     catch {destroy .t2}
  111.     toplevel .t1 -width 250 -height 100 -visual $other
  112.     wm geom .t1 +0+0
  113.     set result [list [catch {toplevel .t2 -gorp 80 -visual .t1} msg] $msg]
  114.     update
  115.     set result
  116.     } {1 {unknown option "-gorp"}}
  117. }
  118. test visual-1.5 {Tk_GetVisual, default colormap} {
  119.     catch {destroy .t1}
  120.     toplevel .t1 -width 250 -height 100 -visual default
  121.     wm geometry .t1 +0+0
  122.     update
  123.     concat "[winfo visual .t1] [winfo depth .t1]"
  124. } $default
  125.  
  126. if $doNonPortableTests {
  127.     set i 1
  128.     foreach visual $avail {
  129.     test visual-2.$i {Tk_GetVisual, different visual types} {
  130.         catch {destroy .t1}
  131.         toplevel .t1 -width 250 -height 100 -visual $visual
  132.         wm geometry .t1 +0+0
  133.         update
  134.         concat "[winfo visual .t1] [winfo depth .t1]"
  135.     } $visual
  136.     incr i
  137.     }
  138. }
  139.  
  140. test visual-3.1 {Tk_GetVisual, parsing visual string} {
  141.     catch {destroy .t1}
  142.     toplevel .t1 -width 250 -height 100 \
  143.         -visual "[winfo visual .][winfo depth .]"
  144.     wm geometry .t1 +0+0
  145.     update
  146.     concat "[winfo visual .t1] [winfo depth .t1]"
  147. } $default
  148. test visual-3.2 {Tk_GetVisual, parsing visual string} {
  149.     catch {destroy .t1}
  150.     list [catch {
  151.     toplevel .t1 -width 250 -height 100 -visual goop20
  152.     wm geometry .t1 +0+0
  153.     } msg] $msg
  154. } {1 {unknown or ambiguous visual name "goop20": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default}}
  155. test visual-3.3 {Tk_GetVisual, parsing visual string} {
  156.     catch {destroy .t1}
  157.     list [catch {
  158.     toplevel .t1 -width 250 -height 100 -visual d
  159.     wm geometry .t1 +0+0
  160.     } msg] $msg
  161. } {1 {unknown or ambiguous visual name "d": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default}}
  162. test visual-3.4 {Tk_GetVisual, parsing visual string} {
  163.     catch {destroy .t1}
  164.     list [catch {
  165.     toplevel .t1 -width 250 -height 100 -visual static
  166.     wm geometry .t1 +0+0
  167.     } msg] $msg
  168. } {1 {unknown or ambiguous visual name "static": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default}}
  169. test visual-3.5 {Tk_GetVisual, parsing visual string} {
  170.     catch {destroy .t1}
  171.     list [catch {
  172.     toplevel .t1 -width 250 -height 100 -visual "pseudocolor 48x"
  173.     wm geometry .t1 +0+0
  174.     } msg] $msg
  175. } {1 {expected integer but got "48x"}}
  176.  
  177. if ![string match *pseudocolor* $avail] {
  178.     test visual-4.1 {Tk_GetVisual, no matching visual} {
  179.     catch {destroy .t1}
  180.     list [catch {
  181.         toplevel .t1 -width 250 -height 100 -visual "pseudocolor 8"
  182.         wm geometry .t1 +0+0
  183.     } msg] $msg
  184.     } {1 {couldn't find an appropriate visual}}
  185. }
  186.  
  187. if {[string match *pseudocolor* $avail] && ([llength $avail] > 1)
  188.     && $doNonPortableTests} {
  189.     test visual-5.1 {Tk_GetVisual, no matching visual} {
  190.     catch {destroy .t1}
  191.     toplevel .t1 -width 250 -height 100 -visual "best"
  192.     wm geometry .t1 +0+0
  193.     update
  194.     winfo visual .t1
  195.     } {pseudocolor}
  196. }
  197.  
  198. if $doNonPortableTests {
  199.     # These tests are non-portable due to variations in how many colors
  200.     # are already in use on the screen.
  201.  
  202.     if {([winfo visual .] == "pseudocolor") && ([winfo depth .] == 8)} {
  203.     eatColors .t1
  204.     test visual-6.1 {Tk_GetColormap, "new"} {
  205.         toplevel .t2 -width 30 -height 20
  206.         wm geom .t2 +0+0
  207.         update
  208.         colorsFree .t2
  209.     } {0}
  210.     test visual-6.2 {Tk_GetColormap, "new"} {
  211.         catch {destroy .t2}
  212.         toplevel .t2 -width 30 -height 20 -colormap new
  213.         wm geom .t2 +0+0
  214.         update
  215.         colorsFree .t2
  216.     } {1}
  217.     test visual-6.3 {Tk_GetColormap, copy from other window} {
  218.         catch {destroy .t2}
  219.         toplevel .t3 -width 400 -height 50 -colormap new
  220.         wm geom .t3 +0+0
  221.         catch {destroy .t2}
  222.         toplevel .t2 -width 30 -height 20 -colormap .t3
  223.         wm geom .t2 +0+0
  224.         update
  225.         destroy .t3
  226.         colorsFree .t2
  227.     } {1}
  228.     test visual-6.4 {Tk_GetColormap, copy from other window} {
  229.         catch {destroy .t2}
  230.         toplevel .t3 -width 400 -height 50 -colormap new
  231.         wm geom .t3 +0+0
  232.         catch {destroy .t2}
  233.         toplevel .t2 -width 30 -height 20 -colormap .
  234.         wm geom .t2 +0+0
  235.         update
  236.         destroy .t3
  237.         colorsFree .t2
  238.     } {0}
  239.     test visual-6.5 {Tk_GetColormap, copy from other window} {
  240.         catch {destroy .t1}
  241.         list [catch {toplevel .t1 -width 400 -height 50 \
  242.             -colormap .choke.lots} msg] $msg
  243.     } {1 {bad window path name ".choke.lots"}}
  244.     if {$other != {}} {
  245.         test visual-6.6 {Tk_GetColormap, copy from other window} {
  246.         catch {destroy .t1}
  247.         catch {destroy .t2}
  248.         toplevel .t1 -width 300 -height 150 -visual $other
  249.         wm geometry .t1 +0+0
  250.         list [catch {toplevel .t2 -width 400 -height 50 \
  251.             -colormap .t1} msg] $msg
  252.         } {1 {can't use colormap for .t1: incompatible visuals}}
  253.     }
  254.     catch {destroy .t1}
  255.     catch {destroy .t2}
  256.     }
  257. }
  258.  
  259. test visual-7.1 {Tk_FreeColormap procedure} {
  260.     foreach w [winfo child .] {
  261.     destroy $w
  262.     }
  263.     toplevel .t1 -width 300 -height 180 -colormap new
  264.     wm geometry .t1 +0+0
  265.     foreach i {.t2 .t3 .t4} {
  266.     toplevel $i -width 250 -height 150 -colormap .t1
  267.     wm geometry $i +0+0
  268.     }
  269.     destroy .t1
  270.     destroy .t3
  271.     destroy .t4
  272.     update
  273. } {}
  274. if {$other != {}} {
  275.     test visual-7.2 {Tk_FreeColormap procedure} {
  276.     foreach w [winfo child .] {
  277.         destroy $w
  278.     }
  279.     toplevel .t1 -width 300 -height 180 -visual $other
  280.     wm geometry .t1 +0+0
  281.     foreach i {.t2 .t3 .t4} {
  282.         toplevel $i -width 250 -height 150 -visual $other
  283.         wm geometry $i +0+0
  284.     }
  285.     destroy .t2
  286.     destroy .t3
  287.     destroy .t4
  288.     update
  289.     } {}
  290. }
  291.  
  292. foreach w [winfo child .] {
  293.     destroy $w
  294. }
  295. rename eatColors {}
  296. rename colorsFree {}
  297.