home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tk8.0 / tests / unixEmbed.test < prev    next >
Encoding:
Text File  |  1997-08-15  |  15.2 KB  |  621 lines  |  [TEXT/ALFA]
  1. # This file is a Tcl script to test out the procedures in the file 
  2. # tkUnixEmbed.c.  It is organized in the standard fashion for Tcl
  3. # tests.
  4. #
  5. # Copyright (c) 1996-1997 Sun Microsystems, Inc.
  6. #
  7. # See the file "license.terms" for information on usage and redistribution
  8. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  9. #
  10. # SCCS: @(#) unixEmbed.test 1.7 97/08/13 11:13:21
  11.  
  12. if {$tcl_platform(platform) != "unix"} {
  13.     return
  14. }
  15.  
  16. if {[info procs test] != "test"} {
  17.     source defs
  18. }
  19.  
  20. eval destroy [winfo children .]
  21. wm geometry . {}
  22. raise .
  23.  
  24. setupbg
  25. dobg {wm withdraw .}
  26.  
  27. # eatColors --
  28. # Creates a toplevel window and allocates enough colors in it to
  29. # use up all the slots in the colormap.
  30. #
  31. # Arguments:
  32. # w -        Name of toplevel window to create.
  33.  
  34. proc eatColors {w} {
  35.     catch {destroy $w}
  36.     toplevel $w
  37.     wm geom $w +0+0
  38.     canvas $w.c -width 400 -height 200 -bd 0
  39.     pack $w.c
  40.     for {set y 0} {$y < 8} {incr y} {
  41.     for {set x 0} {$x < 40} {incr x} {
  42.         set color [format #%02x%02x%02x [expr $x*6] [expr $y*30] 0]
  43.         $w.c create rectangle [expr 10*$x] [expr 20*$y] \
  44.             [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \
  45.             -fill $color
  46.     }
  47.     }
  48.     update
  49. }
  50.  
  51. # colorsFree --
  52. #
  53. # Returns 1 if there appear to be free colormap entries in a window,
  54. # 0 otherwise.
  55. #
  56. # Arguments:
  57. # w -            Name of window in which to check.
  58. # red, green, blue -    Intensities to use in a trial color allocation
  59. #            to see if there are colormap entries free.
  60.  
  61. proc colorsFree {w {red 31} {green 245} {blue 192}} {
  62.     set vals [winfo rgb $w [format #%02x%02x%02x $red $green $blue]]
  63.     expr ([lindex $vals 0]/256 == $red) && ([lindex $vals 1]/256 == $green) \
  64.         && ([lindex $vals 2]/256 == $blue)
  65. }
  66.  
  67. test unixEmbed-1.1 {TkpUseWindow procedure, bad window identifier} {
  68.     catch {destroy .t}
  69.     list [catch {toplevel .t -use xyz} msg] $msg
  70. } {1 {expected integer but got "xyz"}}
  71. test unixEmbed-1.2 {TkpUseWindow procedure, bad window identifier} {
  72.     catch {destroy .t}
  73.     list [catch {toplevel .t -use 47} msg] $msg
  74. } {1 {couldn't create child of window "47"}}
  75. test unixEmbed-1.3 {TkpUseWindow procedure, inheriting colormap} {
  76.     catch {destroy .t}
  77.     catch {destroy .x}
  78.     toplevel .t -colormap new
  79.     wm geometry .t +0+0
  80.     eatColors .t.t
  81.     frame .t.f -container 1
  82.     toplevel .x -use [winfo id .t.f]
  83.     set result [colorsFree .x]
  84.     destroy .t
  85.     set result
  86. } {0}
  87. test unixEmbed-1.4 {TkpUseWindow procedure, inheriting colormap} {
  88.     catch {destroy .t}
  89.     catch {destroy .t2}
  90.     catch {destroy .x}
  91.     toplevel .t -container 1 -colormap new
  92.     wm geometry .t +0+0
  93.     eatColors .t2
  94.     toplevel .x -use [winfo id .t]
  95.     set result [colorsFree .x]
  96.     destroy .t
  97.     set result
  98. } {1}
  99. test unixEmbed-1.5 {TkpUseWindow procedure, creating Container records} {
  100.     eval destroy [winfo child .]
  101.     frame .f1 -container 1 -width 200 -height 50
  102.     frame .f2 -container 1 -width 200 -height 50
  103.     pack .f1 .f2
  104.     dobg "set w [winfo id .f1]"
  105.     dobg {
  106.     eval destroy [winfo child .]
  107.     toplevel .t -use $w
  108.     list [testembed] [expr [lindex [lindex [testembed all] 0] 0] - $w]
  109.     }
  110. } {{{XXX {} {} .t}} 0}
  111. test unixEmbed-1.6 {TkpUseWindow procedure, creating Container records} {
  112.     eval destroy [winfo child .]
  113.     frame .f1 -container 1 -width 200 -height 50
  114.     frame .f2 -container 1 -width 200 -height 50
  115.     pack .f1 .f2
  116.     dobg "set w1 [winfo id .f1]"
  117.     dobg "set w2 [winfo id .f2]"
  118.     dobg {
  119.     eval destroy [winfo child .]
  120.     toplevel .t1 -use $w1
  121.     toplevel .t2 -use $w2
  122.     testembed
  123.     }
  124. } {{XXX {} {} .t2} {XXX {} {} .t1}}
  125. test unixEmbed-1.7 {TkpUseWindow procedure, container and embedded in same app} {
  126.     eval destroy [winfo child .]
  127.     frame .f1 -container 1 -width 200 -height 50
  128.     frame .f2 -container 1 -width 200 -height 50
  129.     pack .f1 .f2
  130.     toplevel .t1 -use [winfo id .f1]
  131.     toplevel .t2 -use [winfo id .f2]
  132.     testembed
  133. } {{XXX .f2 {} .t2} {XXX .f1 {} .t1}}
  134.  
  135. # Can't think of any way to test the procedures TkpMakeWindow,
  136. # TkpMakeContainer, or EmbedErrorProc.
  137.  
  138. test unixEmbed-2.1 {EmbeddedEventProc procedure} {
  139.     foreach w [winfo child .] {
  140.     catch {destroy $w}
  141.     }
  142.     frame .f1 -container 1 -width 200 -height 50
  143.     pack .f1
  144.     dobg "set w1 [winfo id .f1]"
  145.     dobg {
  146.     eval destroy [winfo child .]
  147.     toplevel .t1 -use $w1
  148.     testembed
  149.     }
  150.     destroy .f1
  151.     update
  152.     dobg {
  153.     testembed
  154.     }
  155. } {}
  156. test unixEmbed-2.2 {EmbeddedEventProc procedure} {
  157.     foreach w [winfo child .] {
  158.     catch {destroy $w}
  159.     }
  160.     frame .f1 -container 1 -width 200 -height 50
  161.     pack .f1
  162.     dobg "set w1 [winfo id .f1]"
  163.     dobg {
  164.     eval destroy [winfo child .]
  165.     toplevel .t1 -use $w1
  166.     testembed
  167.     destroy .t1
  168.     testembed
  169.     }
  170. } {}
  171. test unixEmbed-2.3 {EmbeddedEventProc procedure} {
  172.     foreach w [winfo child .] {
  173.     catch {destroy $w}
  174.     }
  175.     frame .f1 -container 1 -width 200 -height 50
  176.     pack .f1
  177.     toplevel .t1 -use [winfo id .f1]
  178.     update
  179.     destroy .f1
  180.     testembed
  181. } {}
  182. test unixEmbed-2.4 {EmbeddedEventProc procedure} {
  183.     foreach w [winfo child .] {
  184.     catch {destroy $w}
  185.     }
  186.     frame .f1 -container 1 -width 200 -height 50
  187.     pack .f1
  188.     toplevel .t1 -use [winfo id .f1]
  189.     update
  190.     destroy .t1
  191.     set x [testembed]
  192.     update
  193.     list $x [testembed]
  194. } {{{XXX .f1 {} {}}} {}}
  195.  
  196. test unixEmbed-3.1 {ContainerEventProc procedure, detect creation} {
  197.     foreach w [winfo child .] {
  198.     catch {destroy $w}
  199.     }
  200.     frame .f1 -container 1 -width 200 -height 50
  201.     pack .f1
  202.     dobg "set w1 [winfo id .f1]"
  203.     set x [testembed]
  204.     dobg {
  205.     eval destroy [winfo child .]
  206.     toplevel .t1 -use $w1
  207.     wm withdraw .t1
  208.     }
  209.     list $x [testembed]
  210. } {{{XXX .f1 {} {}}} {{XXX .f1 XXX {}}}}
  211. test unixEmbed-3.2 {ContainerEventProc procedure, set size on creation} {
  212.     foreach w [winfo child .] {
  213.     catch {destroy $w}
  214.     }
  215.     toplevel .t1 -container 1
  216.     wm geometry .t1 +0+0
  217.     toplevel .t2 -use [winfo id .t1] -bg red
  218.     update
  219.     wm geometry .t2
  220. } {200x200+0+0}
  221. test unixEmbed-3.2 {ContainerEventProc procedure, disallow position changes} {
  222.     foreach w [winfo child .] {
  223.     catch {destroy $w}
  224.     }
  225.     frame .f1 -container 1 -width 200 -height 50
  226.     pack .f1
  227.     dobg "set w1 [winfo id .f1]"
  228.     dobg {
  229.     eval destroy [winfo child .]
  230.     toplevel .t1 -use $w1 -bd 2 -relief raised
  231.     update
  232.     wm geometry .t1 +30+40
  233.     }
  234.     update
  235.     dobg {
  236.     wm geometry .t1
  237.     }
  238. } {200x200+0+0}
  239. test unixEmbed-3.3 {ContainerEventProc procedure, disallow position changes} {
  240.     foreach w [winfo child .] {
  241.     catch {destroy $w}
  242.     }
  243.     frame .f1 -container 1 -width 200 -height 50
  244.     pack .f1
  245.     dobg "set w1 [winfo id .f1]"
  246.     dobg {
  247.     eval destroy [winfo child .]
  248.     toplevel .t1 -use $w1
  249.     update
  250.     wm geometry .t1 300x100+30+40
  251.     }
  252.     update
  253.     dobg {
  254.     wm geometry .t1
  255.     }
  256. } {300x100+0+0}
  257. test unixEmbed-3.4 {ContainerEventProc procedure, geometry requests} {
  258.     foreach w [winfo child .] {
  259.     catch {destroy $w}
  260.     }
  261.     frame .f1 -container 1 -width 200 -height 50
  262.     pack .f1
  263.     dobg "set w1 [winfo id .f1]"
  264.     dobg {
  265.     eval destroy [winfo child .]
  266.     toplevel .t1 -use $w1
  267.     }
  268.     update
  269.     dobg {
  270.     .t1 configure -width 300 -height 80
  271.     }
  272.     update
  273.     list [winfo width .f1] [winfo height .f1] [dobg {wm geometry .t1}]
  274. } {300 80 300x80+0+0}
  275. test unixEmbed-3.5 {ContainerEventProc procedure, map requests} {
  276.     foreach w [winfo child .] {
  277.     catch {destroy $w}
  278.     }
  279.     frame .f1 -container 1 -width 200 -height 50
  280.     pack .f1
  281.     dobg "set w1 [winfo id .f1]"
  282.     dobg {
  283.     eval destroy [winfo child .]
  284.     toplevel .t1 -use $w1
  285.     set x unmapped
  286.     bind .t1 <Map> {set x mapped}
  287.     }
  288.     update
  289.     dobg {
  290.     after 100
  291.     update
  292.     set x
  293.     }
  294. } {mapped}
  295. test unixEmbed-3.6 {ContainerEventProc procedure, destroy events} {
  296.     foreach w [winfo child .] {
  297.     catch {destroy $w}
  298.     }
  299.     frame .f1 -container 1 -width 200 -height 50
  300.     pack .f1
  301.     dobg "set w1 [winfo id .f1]"
  302.     bind .f1 <Destroy> {set x dead}
  303.     set x alive
  304.     dobg {
  305.     eval destroy [winfo child .]
  306.     toplevel .t1 -use $w1
  307.     }
  308.     update
  309.     dobg {
  310.     destroy .t1
  311.     }
  312.     update
  313.     list $x [winfo exists .f1]
  314. } {dead 0}
  315.  
  316. test unixEmbed-4.1 {EmbedStructureProc procedure, configure events} {
  317.     foreach w [winfo child .] {
  318.     catch {destroy $w}
  319.     }
  320.     frame .f1 -container 1 -width 200 -height 50
  321.     pack .f1
  322.     dobg "set w1 [winfo id .f1]"
  323.     dobg {
  324.     eval destroy [winfo child .]
  325.     toplevel .t1 -use $w1
  326.     }
  327.     update
  328.     dobg {
  329.     .t1 configure -width 180 -height 100
  330.     }
  331.     update
  332.     dobg {
  333.     winfo geometry .t1
  334.     }
  335. } {180x100+0+0}
  336. test unixEmbed-4.2 {EmbedStructureProc procedure, destroy events} {
  337.     foreach w [winfo child .] {
  338.     catch {destroy $w}
  339.     }
  340.     frame .f1 -container 1 -width 200 -height 50
  341.     pack .f1
  342.     dobg "set w1 [winfo id .f1]"
  343.     dobg {
  344.     eval destroy [winfo child .]
  345.     toplevel .t1 -use $w1
  346.     }
  347.     update
  348.     set x [testembed]
  349.     destroy .f1
  350.     list $x [testembed]
  351. } {{{XXX .f1 XXX {}}} {}}
  352.  
  353. test unixEmbed-5.1 {EmbedFocusProc procedure, FocusIn events} {
  354.     foreach w [winfo child .] {
  355.     catch {destroy $w}
  356.     }
  357.     frame .f1 -container 1 -width 200 -height 50
  358.     pack .f1
  359.     dobg "set w1 [winfo id .f1]"
  360.     dobg {
  361.     eval destroy [winfo child .]
  362.     toplevel .t1 -use $w1
  363.     bind .t1 <FocusIn> {lappend x "focus in %W"}
  364.     bind .t1 <FocusOut> {lappend x "focus out %W"}
  365.     set x {}
  366.     }
  367.     focus -force .f1
  368.     update
  369.     dobg {set x}
  370. } {{focus in .t1}}
  371. test unixEmbed-5.2 {EmbedFocusProc procedure, focusing on dead window} {
  372.     foreach w [winfo child .] {
  373.     catch {destroy $w}
  374.     }
  375.     frame .f1 -container 1 -width 200 -height 50
  376.     pack .f1
  377.     dobg "set w1 [winfo id .f1]"
  378.     dobg {
  379.     eval destroy [winfo child .]
  380.     toplevel .t1 -use $w1
  381.     }
  382.     update
  383.     dobg {
  384.     after 200 {destroy .t1}
  385.     }
  386.     after 400
  387.     focus -force .f1
  388.     update
  389. } {}
  390. test unixEmbed-5.3 {EmbedFocusProc procedure, FocusOut events} {
  391.     foreach w [winfo child .] {
  392.     catch {destroy $w}
  393.     }
  394.     frame .f1 -container 1 -width 200 -height 50
  395.     pack .f1
  396.     dobg "set w1 [winfo id .f1]"
  397.     dobg {
  398.     eval destroy [winfo child .]
  399.     toplevel .t1 -use $w1
  400.     bind .t1 <FocusIn> {lappend x "focus in %W"}
  401.     bind .t1 <FocusOut> {lappend x "focus out %W"}
  402.     set x {}
  403.     }
  404.     focus -force .f1
  405.     update
  406.     set x [dobg {update; set x}]
  407.     focus .
  408.     update
  409.     list $x [dobg {update; set x}]
  410. } {{{focus in .t1}} {{focus in .t1} {focus out .t1}}}
  411.  
  412. test unixEmbed-6.1 {EmbedGeometryRequest procedure, window changes size} {
  413.     foreach w [winfo child .] {
  414.     catch {destroy $w}
  415.     }
  416.     frame .f1 -container 1 -width 200 -height 50
  417.     pack .f1
  418.     dobg "set w1 [winfo id .f1]"
  419.     dobg {
  420.     eval destroy [winfo child .]
  421.     toplevel .t1 -use $w1
  422.     }
  423.     update
  424.     dobg {
  425.     bind .t1 <Configure> {lappend x {configure .t1 %w %h}}
  426.     set x {}
  427.     .t1 configure -width 300 -height 120
  428.     update
  429.     list $x [winfo geom .t1]
  430.     }
  431. } {{{configure .t1 300 120}} 300x120+0+0}
  432. test unixEmbed-6.2 {EmbedGeometryRequest procedure, window changes size} {
  433.     foreach w [winfo child .] {
  434.     catch {destroy $w}
  435.     }
  436.     frame .f1 -container 1 -width 200 -height 50
  437.     place .f1 -width 200 -height 200
  438.     dobg "set w1 [winfo id .f1]"
  439.     dobg {
  440.     eval destroy [winfo child .]
  441.     toplevel .t1 -use $w1
  442.     }
  443.     after 300 {set x done}
  444.     vwait x
  445.     dobg {
  446.     bind .t1 <Configure> {lappend x {configure .t1 %w %h}}
  447.     set x {}
  448.     .t1 configure -width 300 -height 120
  449.     update
  450.     list $x [winfo geom .t1]
  451.     }
  452. } {{{configure .t1 200 200}} 200x200+0+0}
  453.  
  454. # Can't think up any tests for TkpGetOtherWindow procedure.
  455.  
  456. test unixEmbed-7.1 {TkpRedirectKeyEvent procedure, forward keystroke} {
  457.     foreach w [winfo child .] {
  458.     catch {destroy $w}
  459.     }
  460.     frame .f1 -container 1 -width 200 -height 50
  461.     pack .f1
  462.     dobg "set w1 [winfo id .f1]"
  463.     dobg {
  464.     eval destroy [winfo child .]
  465.     toplevel .t1 -use $w1
  466.     }
  467.     focus -force .
  468.     bind . <KeyPress> {lappend x {key %A %E}}
  469.     set x {}
  470.     set y [dobg {
  471.     update
  472.     bind .t1 <KeyPress> {lappend y {key %A}}
  473.     set y {}
  474.     event generate .t1 <KeyPress> -keysym a
  475.     set y
  476.     }]
  477.     update
  478.     bind . <KeyPress> {}
  479.     list $x $y
  480. } {{{key a 1}} {}}
  481. test unixEmbed-7.2 {TkpRedirectKeyEvent procedure, don't forward keystroke width} {
  482.     foreach w [winfo child .] {
  483.     catch {destroy $w}
  484.     }
  485.     frame .f1 -container 1 -width 200 -height 50
  486.     pack .f1
  487.     dobg "set w1 [winfo id .f1]"
  488.     dobg {
  489.     eval destroy [winfo child .]
  490.     toplevel .t1 -use $w1
  491.     }
  492.     update
  493.     focus -force .f1
  494.     update
  495.     bind . <KeyPress> {lappend x {key %A}}
  496.     set x {}
  497.     set y [dobg {
  498.     update
  499.     bind .t1 <KeyPress> {lappend y {key %A}}
  500.     set y {}
  501.     event generate .t1 <KeyPress> -keysym b
  502.     set y
  503.     }]
  504.     update
  505.     bind . <KeyPress> {}
  506.     list $x $y
  507. } {{} {{key b}}}
  508.  
  509. test unixEmbed-8.1 {TkpClaimFocus procedure} {
  510.     foreach w [winfo child .] {
  511.     catch {destroy $w}
  512.     }
  513.     frame .f1 -container 1 -width 200 -height 50
  514.     frame .f2 -width 200 -height 50
  515.     pack .f1 .f2
  516.     dobg "set w1 [winfo id .f1]"
  517.     dobg {
  518.     eval destroy [winfo child .]
  519.     toplevel .t1 -use $w1 -highlightthickness 2 -bd 2 -relief sunken
  520.     }
  521.     focus -force .f2
  522.     update
  523.     list [dobg {
  524.     focus .t1
  525.     set x [list [focus]]
  526.     update
  527.     after 500
  528.     update
  529.     lappend x [focus]
  530.     }] [focus]
  531. } {{{} .t1} .f1}
  532. test unixEmbed-8.2 {TkpClaimFocus procedure} {
  533.     catch {interp delete child}
  534.     foreach w [winfo child .] {
  535.     catch {destroy $w}
  536.     }
  537.     frame .f1 -container 1 -width 200 -height 50
  538.     frame .f2 -width 200 -height 50
  539.     pack .f1 .f2
  540.     interp create child
  541.     child eval "set argv {-use [winfo id .f1]}"
  542.     load {} tk child
  543.     child eval {
  544.     . configure -bd 2 -highlightthickness 2 -relief sunken
  545.     }
  546.     focus -force .f2
  547.     update
  548.     list [child eval {
  549.     focus .
  550.     set x [list [focus]]
  551.     update
  552.     lappend x [focus]
  553.     }] [focus]
  554. } {{{} .} .f1}
  555. catch {interp delete child}
  556.  
  557. test unixEmbed-9.1 {EmbedWindowDeleted procedure, check parentPtr} {
  558.     foreach w [winfo child .] {
  559.     catch {destroy $w}
  560.     }
  561.     frame .f1 -container 1 -width 200 -height 50
  562.     frame .f2 -container 1 -width 200 -height 50
  563.     frame .f3 -container 1 -width 200 -height 50
  564.     frame .f4 -container 1 -width 200 -height 50
  565.     pack .f1 .f2 .f3 .f4
  566.     set x {}
  567.     lappend x [testembed]
  568.     foreach w {.f3 .f4 .f1 .f2} {
  569.     destroy $w
  570.     lappend x [testembed]
  571.     }
  572.     set x
  573. } {{{XXX .f4 {} {}} {XXX .f3 {} {}} {XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f4 {} {}} {XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f2 {} {}}} {}}
  574. test unixEmbed-9.2 {EmbedWindowDeleted procedure, check embeddedPtr} {
  575.     foreach w [winfo child .] {
  576.     catch {destroy $w}
  577.     }
  578.     frame .f1 -container 1 -width 200 -height 50
  579.     pack .f1
  580.     dobg "set w1 [winfo id .f1]"
  581.     dobg {
  582.     eval destroy [winfo child .]
  583.     toplevel .t1 -use $w1 -highlightthickness 2 -bd 2 -relief sunken
  584.     set x {}
  585.     lappend x [testembed]
  586.     destroy .t1
  587.     lappend x [testembed]
  588.     }
  589. } {{{XXX {} {} .t1}} {}}
  590.  
  591. test unixEmbed-10.1 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} {
  592.     foreach w [winfo child .] {
  593.     catch {destroy $w}
  594.     }
  595.     frame .f1 -container 1 -width 200 -height 50
  596.     pack .f1
  597.     toplevel .t1 -use [winfo id .f1] -width 150 -height 80
  598.     update
  599.     wm geometry .t1 +40+50
  600.     update
  601.     wm geometry .t1
  602. } {150x80+0+0}
  603. test unixEmbed-10.2 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} {
  604.     foreach w [winfo child .] {
  605.     catch {destroy $w}
  606.     }
  607.     frame .f1 -container 1 -width 200 -height 50
  608.     pack .f1
  609.     toplevel .t1 -use [winfo id .f1] -width 150 -height 80
  610.     update
  611.     wm geometry .t1 70x300+10+20
  612.     update
  613.     wm geometry .t1
  614. } {70x300+0+0}
  615.  
  616.  
  617. foreach w [winfo child .] {
  618.     catch {destroy $w}
  619. }
  620. cleanupbg
  621.