home *** CD-ROM | disk | FTP | other *** search
/ Ultra Pack / UltraComputing Partner Applications.iso / SunLabs / tclTK / src / tk4.0 / tests / frame.test < prev    next >
Encoding:
Text File  |  1995-05-09  |  16.0 KB  |  492 lines
  1. # This file is a Tcl script to test out the "frame" and "toplevel"
  2. # commands of Tk.  It is organized in the standard fashion for Tcl
  3. # tests.
  4. #
  5. # Copyright (c) 1994 The Regents of the University of California.
  6. # Copyright (c) 1994-1995 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. # @(#) frame.test 1.13 95/05/09 13:47:16
  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.  
  23. # eatColors --
  24. # Creates a toplevel window and allocates enough colors in it to
  25. # use up all the slots in the colormap.
  26. #
  27. # Arguments:
  28. # w -        Name of toplevel window to create.
  29.  
  30. proc eatColors {w} {
  31.     catch {destroy $w}
  32.     toplevel $w
  33.     wm geom $w +0+0
  34.     canvas $w.c -width 400 -height 200 -bd 0
  35.     pack $w.c
  36.     for {set y 0} {$y < 8} {incr y} {
  37.     for {set x 0} {$x < 40} {incr x} {
  38.         set color [format #%02x%02x%02x [expr $x*6] [expr $y*30] 0]
  39.         $w.c create rectangle [expr 10*$x] [expr 20*$y] \
  40.             [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \
  41.             -fill $color
  42.     }
  43.     }
  44.     update
  45. }
  46.  
  47. # colorsFree --
  48. #
  49. # Returns 1 if there appear to be free colormap entries in a window,
  50. # 0 otherwise.
  51. #
  52. # Arguments:
  53. # w -            Name of window in which to check.
  54. # red, green, blue -    Intensities to use in a trial color allocation
  55. #            to see if there are colormap entries free.
  56.  
  57. proc colorsFree {w {red 31} {green 245} {blue 192}} {
  58.     set vals [winfo rgb $w [format #%02x%02x%02x $red $green $blue]]
  59.     expr ([lindex $vals 0]/256 == $red) && ([lindex $vals 1]/256 == $green) \
  60.         && ([lindex $vals 2]/256 == $blue)
  61. }
  62.  
  63. test frame-1.1 {frame configuration options} {
  64.     frame .f -class NewFrame
  65.     list [.f configure -class] [catch {.f configure -class Different} msg] $msg
  66. } {{-class class Class Frame NewFrame} 1 {can't modify -class option after widget is created}}
  67. catch {destroy .f}
  68. test frame-1.2 {frame configuration options} {
  69.     list [catch {frame .f -colormap new} msg] $msg
  70. } {0 .f}
  71. catch {destroy .f}
  72. test frame-1.3 {frame configuration options} {
  73.     list [catch {frame .f -visual default} msg] $msg
  74. } {0 .f}
  75. catch {destroy .f}
  76. test frame-1.4 {frame configuration options} {
  77.     list [catch {frame .f -screen bogus} msg] $msg
  78. } {1 {unknown option "-screen"}}
  79. frame .f
  80. set i 5
  81. foreach test {
  82.     {-background #ff0000 #ff0000 non-existent
  83.         {unknown color name "non-existent"}}
  84.     {-bd 4 4 badValue {bad screen distance "badValue"}}
  85.     {-bg #00ff00 #00ff00 non-existent
  86.         {unknown color name "non-existent"}}
  87.     {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}}
  88.     {-cursor arrow arrow badValue {bad cursor spec "badValue"}}
  89.     {-height 100 100 not_a_number {bad screen distance "not_a_number"}}
  90.     {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}}
  91.     {-highlightcolor #123456 #123456 non-existent
  92.         {unknown color name "non-existent"}}
  93.     {-highlightthickness 6 6 badValue {bad screen distance "badValue"}}
  94.     {-relief ridge ridge badValue {bad relief type "badValue":  must be flat, groove, raised, ridge, or sunken}}
  95.     {-takefocus "any string" "any string" {} {}}
  96.     {-width 32 32 badValue {bad screen distance "badValue"}}
  97. } {
  98.     set name [lindex $test 0]
  99.     test frame-1.$i {frame configuration options} {
  100.     .f configure $name [lindex $test 1]
  101.     lindex [.f configure $name] 4
  102.     } [lindex $test 2]
  103.     incr i
  104.     if {[lindex $test 3] != ""} {
  105.     test frame-1.$i {frame configuration options} {
  106.         list [catch {.f configure $name [lindex $test 3]} msg] $msg
  107.     } [list 1 [lindex $test 4]]
  108.     }
  109.     .f configure $name [lindex [.f configure $name] 3]
  110.     incr i
  111. }
  112. destroy .f
  113.  
  114. set i 1
  115. test frame-2.1 {toplevel configuration options} {
  116.     catch {destroy .t}
  117.     toplevel .t -width 200 -height 100 -class NewClass
  118.     wm geometry .t +0+0
  119.     list [.t configure -class] [catch {.t configure -class Another} msg] $msg
  120. } {{-class class Class Toplevel NewClass} 1 {can't modify -class option after widget is created}}
  121. test frame-2.2 {toplevel configuration options} {
  122.     catch {destroy .t}
  123.     toplevel .t -width 200 -height 100 -colormap new
  124.     wm geometry .t +0+0
  125.     list [.t configure -colormap] [catch {.t configure -colormap .} msg] $msg
  126. } {{-colormap colormap Colormap {} new} 1 {can't modify -colormap option after widget is created}}
  127. test frame-2.3 {toplevel configuration options} {
  128.     catch {destroy .t}
  129.     list [catch {toplevel .t -width 200 -height 100 -colormap bogus} msg] $msg
  130. } {1 {bad window path name "bogus"}}
  131. set default "[winfo visual .] [winfo depth .]"
  132. test frame-2.4 {toplevel configuration options} {
  133.     catch {destroy .t}
  134.     toplevel .t -width 200 -height 100 -visual default
  135.     wm geometry .t +0+0
  136.     list [.t configure -visual] [catch {.t configure -visual best} msg] $msg
  137. } {{-visual visual Visual {} default} 1 {can't modify -visual option after widget is created}}
  138. test frame-2.5 {toplevel configuration options} {
  139.     catch {destroy .t}
  140.     list [catch {toplevel .t -width 200 -height 100 -visual who_knows?} msg] $msg
  141. } {1 {unknown or ambiguous visual name "who_knows?": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default}}
  142. if [info exists env(DISPLAY)] {
  143.     test frame-2.6 {toplevel configuration options} {
  144.     catch {destroy .t}
  145.     toplevel .t -width 200 -height 100 -screen $env(DISPLAY)
  146.     wm geometry .t +0+0
  147.     list [.t configure -screen] \
  148.         [catch {.t configure -screen another} msg] $msg
  149.     } [list [list -screen screen Screen {} $env(DISPLAY)] 1 {can't modify -screen option after widget is created}]
  150. }
  151. test frame-2.7 {toplevel configuration options} {
  152.     catch {destroy .t}
  153.     list [catch {toplevel .t -width 200 -height 100 -screen bogus} msg] $msg
  154. } {1 {couldn't connect to display "bogus"}}
  155. catch {destroy .t}
  156. toplevel .t -width 300 -height 150
  157. wm geometry .t +0+0
  158. update
  159. set i 8
  160. foreach test {
  161.     {-background #ff0000 #ff0000 non-existent
  162.         {unknown color name "non-existent"}}
  163.     {-bd 4 4 badValue {bad screen distance "badValue"}}
  164.     {-bg #00ff00 #00ff00 non-existent
  165.         {unknown color name "non-existent"}}
  166.     {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}}
  167.     {-cursor arrow arrow badValue {bad cursor spec "badValue"}}
  168.     {-height 100 100 not_a_number {bad screen distance "not_a_number"}}
  169.     {-highlightcolor #123456 #123456 non-existent
  170.         {unknown color name "non-existent"}}
  171.     {-highlightthickness 3 3 badValue {bad screen distance "badValue"}}
  172.     {-relief ridge ridge badValue {bad relief type "badValue":  must be flat, groove, raised, ridge, or sunken}}
  173.     {-width 32 32 badValue {bad screen distance "badValue"}}
  174. } {
  175.     set name [lindex $test 0]
  176.     test frame-2.$i {frame configuration options} {
  177.     .t configure $name [lindex $test 1]
  178.     lindex [.t configure $name] 4
  179.     } [lindex $test 2]
  180.     incr i
  181.     if {[lindex $test 3] != ""} {
  182.     test frame-2.$i {frame configuration options} {
  183.         list [catch {.t configure $name [lindex $test 3]} msg] $msg
  184.     } [list 1 [lindex $test 4]]
  185.     }
  186.     .t configure $name [lindex [.t configure $name] 3]
  187.     incr i
  188. }
  189.  
  190. test frame-3.1 {Tk_FrameCmd procedure} {
  191.     list [catch frame msg] $msg
  192. } {1 {wrong # args: should be "frame pathName ?options?"}}
  193. test frame-3.2 {Tk_FrameCmd procedure} {
  194.     catch {destroy .f}
  195.     frame .f
  196.     set result [.f configure -class]
  197.     destroy .f
  198.     set result
  199. } {-class class Class Frame Frame}
  200. test frame-3.3 {Tk_FrameCmd procedure} {
  201.     catch {destroy .t}
  202.     toplevel .t
  203.     wm geometry .t +0+0
  204.     set result [.t configure -class]
  205.     destroy .t
  206.     set result
  207. } {-class class Class Toplevel Toplevel}
  208. test frame-3.4 {Tk_FrameCmd procedure} {
  209.     catch {destroy .t}
  210.     toplevel .t -width 350 -class NewClass -bg black -visual default -height 90
  211.     wm geometry .t +0+0
  212.     update
  213.     list [lindex [.t configure -width] 4] \
  214.         [lindex [.t configure -background] 4] \
  215.         [lindex [.t configure -height] 4]
  216. } {350 black 90}
  217.  
  218. # Be sure that the -class, -colormap, and -visual options are processed
  219. # before configuring the widget.
  220.  
  221. test frame-3.5 {Tk_FrameCmd procedure} {
  222.     catch {destroy .f}
  223.     option add *NewFrame.background #123456
  224.     frame .f -class NewFrame
  225.     option clear
  226.     lindex [.f configure -background] 4
  227. } {#123456}
  228. test frame-3.6 {Tk_FrameCmd procedure} {
  229.     catch {destroy .f}
  230.     option add *NewFrame.background #123456
  231.     frame .f -class NewFrame
  232.     option clear
  233.     lindex [.f configure -background] 4
  234. } {#123456}
  235. test frame-3.7 {Tk_FrameCmd procedure} {
  236.     catch {destroy .f}
  237.     option add *NewFrame.background #332211
  238.     option add *f.class NewFrame
  239.     frame .f
  240.     option clear
  241.     list [lindex [.f configure -class] 4] [lindex [.f configure -background] 4]
  242. } {NewFrame #332211}
  243. test frame-3.8 {Tk_FrameCmd procedure} {
  244.     catch {destroy .f}
  245.     option add *Silly.background #122334
  246.     option add *f.Class Silly
  247.     frame .f
  248.     option clear
  249.     list [lindex [.f configure -class] 4] [lindex [.f configure -background] 4]
  250. } {Silly #122334}
  251.  
  252. # The tests below require specific display characteristics.  Even so,
  253. # they are non-portable:  some machines don't seem to ever run out of
  254. # colors.
  255.  
  256. if {([winfo visual .] == "pseudocolor") && ([winfo depth .] == 8)
  257.     && $doNonPortableTests} {
  258.     eatColors .t1
  259.     test frame-3.9 {Tk_FrameCmd procedure} {
  260.     catch {destroy .t}
  261.     toplevel .t -width 300 -height 200 -bg #475601
  262.     wm geometry .t +0+0
  263.     update
  264.     colorsFree .t
  265.     } {0}
  266.     test frame-3.10 {Tk_FrameCmd procedure} {
  267.     catch {destroy .t}
  268.     toplevel .t -width 300 -height 200 -bg #475601 -colormap new
  269.     wm geometry .t +0+0
  270.     update
  271.     colorsFree .t
  272.     } {1}
  273.     test frame-3.11 {Tk_FrameCmd procedure} {
  274.     catch {destroy .t}
  275.     option add *t.class Toplevel2
  276.     option add *Toplevel2.colormap new
  277.     toplevel .t -width 300 -height 200 -bg #475601
  278.     wm geometry .t +0+0
  279.     update
  280.     option clear
  281.     colorsFree .t
  282.     } {1}
  283.     test frame-3.12 {Tk_FrameCmd procedure} {
  284.     catch {destroy .t}
  285.     option add *t.class Toplevel3
  286.     option add *Toplevel3.Colormap new
  287.     toplevel .t -width 300 -height 200 -bg #475601 -colormap new
  288.     wm geometry .t +0+0
  289.     update
  290.     option clear
  291.     colorsFree .t
  292.     } {1}
  293.     test frame-3.13 {Tk_FrameCmd procedure} {
  294.     catch {destroy .t}
  295.     toplevel .t -width 300 -height 200 -bg #475601 -visual default
  296.     wm geometry .t +0+0
  297.     update
  298.     colorsFree .t
  299.     } {0}
  300.     test frame-3.14 {Tk_FrameCmd procedure} {
  301.     catch {destroy .t}
  302.     toplevel .t -width 300 -height 200 -bg #475601 -visual default \
  303.         -colormap new
  304.     wm geometry .t +0+0
  305.     update
  306.     colorsFree .t
  307.     } {1}
  308.     if {[lsearch -exact [winfo visualsavailable .] {grayscale 8}] >= 0} {
  309.         test frame-3.15 {Tk_FrameCmd procedure} {
  310.         catch {destroy .t}
  311.         toplevel .t -visual {grayscale 8} -width 300 -height 200 \
  312.             -bg #434343 
  313.         wm geometry .t +0+0
  314.         update
  315.         colorsFree .t 131 131 131
  316.     } {1}
  317.         test frame-3.16 {Tk_FrameCmd procedure} {
  318.         catch {destroy .t}
  319.         option add *t.class T4
  320.         option add *T4.visual {grayscale 8}
  321.         toplevel .t -width 300 -height 200 -bg #434343
  322.         wm geometry .t +0+0
  323.         update
  324.         option clear
  325.         list [colorsFree .t 131 131 131] [lindex [.t configure -visual] 4]
  326.     } {1 {grayscale 8}}
  327.         test frame-3.17 {Tk_FrameCmd procedure} {
  328.         catch {destroy .t}
  329.         set x ok
  330.         option add *t.class T5
  331.         option add *T5.Visual {grayscale 8}
  332.         toplevel .t -width 300 -height 200 -bg #434343
  333.         wm geometry .t +0+0
  334.         update
  335.         option clear
  336.         list [colorsFree .t 131 131 131] [lindex [.t configure -visual] 4]
  337.     } {1 {grayscale 8}}
  338.         test frame-3.18 {Tk_FrameCmd procedure} {
  339.         catch {destroy .t}
  340.         set x ok
  341.         toplevel .t -visual {grayscale 8} -width 300 -height 200 \
  342.             -bg #434343 
  343.         wm geometry .t +0+0
  344.         update
  345.         colorsFree .t 131 131 131
  346.     } {1}
  347.     }
  348.     destroy .t1
  349. }
  350. test frame-3.19 {Tk_FrameCmd procedure} {
  351.     catch {destroy .f}
  352.     list [catch {frame .f -gorp glob} msg] $msg
  353. } {1 {unknown option "-gorp"}}
  354. test frame-3.20 {Tk_FrameCmd procedure} {
  355.     catch {destroy .t}
  356.     list [catch {
  357.     toplevel .t -width 300 -height 200 -colormap new -bogus option
  358.     wm geometry .t +0+0
  359.     } msg] $msg
  360. } {1 {unknown option "-bogus"}}
  361.  
  362. test frame-4.1 {TkInitFrame procedure} {
  363.     catch {destroy .f}
  364.     catch {frame .f -gorp glob}
  365.     winfo exists .f
  366. } 0
  367. test frame-4.2 {TkInitFrame procedure} {
  368.     catch {destroy .f}
  369.     list [frame .f -width 200 -height 100] [winfo exists .f]
  370. } {.f 1}
  371.  
  372. catch {destroy .f}
  373. frame .f -highlightcolor black
  374. test frame-5.1 {FrameWidgetCommand procedure} {
  375.     list [catch .f msg] $msg
  376. } {1 {wrong # args: should be ".f option ?arg arg ...?"}}
  377. test scale-5.2 {FrameWidgetCommand procedure, cget option} {
  378.     list [catch {.f cget} msg] $msg
  379. } {1 {wrong # args: should be ".f cget option"}}
  380. test scale-5.3 {FrameWidgetCommand procedure, cget option} {
  381.     list [catch {.f cget a b} msg] $msg
  382. } {1 {wrong # args: should be ".f cget option"}}
  383. test scale-5.4 {FrameWidgetCommand procedure, cget option} {
  384.     list [catch {.f cget -gorp} msg] $msg
  385. } {1 {unknown option "-gorp"}}
  386. test scale-5.5 {FrameWidgetCommand procedure, cget option} {
  387.     .f cget -highlightcolor
  388. } {black}
  389. test scale-5.6 {FrameWidgetCommand procedure, cget option} {
  390.     list [catch {.f cget -screen} msg] $msg
  391. } {1 {unknown option "-screen"}}
  392. test scale-5.7 {FrameWidgetCommand procedure, cget option} {
  393.     catch {destroy .t}
  394.     toplevel .t
  395.     catch {.t cget -screen}
  396. } {0}
  397. catch {destroy .t}
  398. test frame-5.8 {FrameWidgetCommand procedure, configure option} {
  399.     llength [.f configure]
  400. } {15}
  401. test frame-5.9 {FrameWidgetCommand procedure, configure option} {
  402.     list [catch {.f configure -gorp} msg] $msg
  403. } {1 {unknown option "-gorp"}}
  404. test frame-5.10 {FrameWidgetCommand procedure, configure option} {
  405.     list [catch {.f configure -gorp bogus} msg] $msg
  406. } {1 {unknown option "-gorp"}}
  407. test frame-5.11 {FrameWidgetCommand procedure, configure option} {
  408.     list [catch {.f configure -width 200 -height} msg] $msg
  409. } {1 {value for "-height" missing}}
  410. test frame-5.12 {FrameWidgetCommand procedure} {
  411.     list [catch {.f swizzle} msg] $msg
  412. } {1 {bad option "swizzle":  must be cget or configure}}
  413.  
  414. test frame-6.1 {ConfigureFrame procedure} {
  415.     catch {destroy .f}
  416.     frame .f -width 150
  417.     list [winfo reqwidth .f] [winfo reqheight .f]
  418. } {150 1}
  419. test frame-6.2 {ConfigureFrame procedure} {
  420.     catch {destroy .f}
  421.     frame .f -height 97
  422.     list [winfo reqwidth .f] [winfo reqheight .f]
  423. } {1 97}
  424. test frame-6.3 {ConfigureFrame procedure} {
  425.     catch {destroy .f}
  426.     frame .f
  427.     set result {}
  428.     lappend result [winfo reqwidth .f] [winfo reqheight .f]
  429.     .f configure -width 200 -height 180
  430.     lappend result [winfo reqwidth .f] [winfo reqheight .f]
  431.     .f configure -width 0 -height 0
  432.     lappend result [winfo reqwidth .f] [winfo reqheight .f]
  433. } {1 1 200 180 200 180}
  434.  
  435. test frame-7.1 {FrameEventProc procedure} {
  436.     frame .frame2
  437.     set result [info commands .frame2]
  438.     destroy .frame2
  439.     lappend result [info commands .frame2]
  440. } {.frame2 {}}
  441. test button-7.2 {FrameEventProc procedure} {
  442.     eval destroy [winfo children .]
  443.     frame .f1 -bg #543210
  444.     rename .f1 .f2
  445.     set x {}
  446.     lappend x [winfo children .]
  447.     lappend x [.f2 cget -bg]
  448.     destroy .f1
  449.     lappend x [info command .f*] [winfo children .]
  450. } {.f1 #543210 {} {}}
  451.  
  452. test button-8.1 {FrameCmdDeletedProc procedure} {
  453.     eval destroy [winfo children .]
  454.     frame .f1
  455.     rename .f1 {}
  456.     list [info command .f*] [winfo children .]
  457. } {{} {}}
  458.  
  459. test frame-9.1 {MapFrame procedure} {
  460.     catch {destroy .t}
  461.     toplevel .t -width 100 -height 400
  462.     wm geometry .t +0+0
  463.     set result [winfo ismapped .t]
  464.     update idletasks
  465.     lappend result [winfo ismapped .t]
  466. } {0 1}
  467. test frame-9.2 {MapFrame procedure} {
  468.     catch {destroy .t}
  469.     toplevel .t -width 100 -height 400
  470.     wm geometry .t +0+0
  471.     destroy .t
  472.     update
  473.     winfo exists .t
  474. } {0}
  475. test frame-9.3 {MapFrame procedure, window deleted while mapping} {
  476.     toplevel .t2 -width 200 -height 200
  477.     wm geometry .t2 +0+0
  478.     tkwait visibility .t2
  479.     catch {destroy .t}
  480.     toplevel .t -width 100 -height 400
  481.     wm geometry .t +0+0
  482.     frame .t2.f -width 50 -height 50
  483.     bind .t2.f <Configure> {destroy .t}
  484.     pack .t2.f -side top
  485.     update idletasks
  486.     winfo exists .t
  487. } {0}
  488.  
  489. catch {destroy .f}
  490. rename eatColors {}
  491. rename colorsFree {}
  492.