tk/tests/winfo.test

   1 # This file is a Tcl script to test out the "winfo" command.  It is
   2 # organized in the standard fashion for Tcl tests.
   3 #
   4 # Copyright (c) 1994 The Regents of the University of California.
   5 # Copyright (c) 1994-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 # RCS: @(#) $Id$
  11
  12 if {[info procs test] != "test"} {
  13     source defs
  14 }
  15
  16 foreach i [winfo children .] {
  17     catch {destroy $i}
  18 }
  19 wm geometry . {}
  20 raise .
  21
  22 # eatColors --
  23 # Creates a toplevel window and allocates enough colors in it to
  24 # use up all the slots in the colormap.
  25 #
  26 # Arguments:
  27 # w -           Name of toplevel window to create.
  28 # options -     Options for w, such as "-colormap new".
  29
  30 proc eatColors {w {options ""}} {
  31     catch {destroy $w}
  32     eval toplevel $w $options
  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 # XXX - This test file is woefully incomplete.  At present, only a
  48 # few of the winfo options are tested.
  49
  50 test winfo-1.1 {"winfo atom" command} {
  51     list [catch {winfo atom} msg] $msg
  52 } {1 {wrong # args: should be "winfo atom ?-displayof window? name"}}
  53 test winfo-1.2 {"winfo atom" command} {
  54     list [catch {winfo atom a b} msg] $msg
  55 } {1 {wrong # args: should be "winfo atom ?-displayof window? name"}}
  56 test winfo-1.3 {"winfo atom" command} {
  57     list [catch {winfo atom a b c d} msg] $msg
  58 } {1 {wrong # args: should be "winfo atom ?-displayof window? name"}}
  59 test winfo-1.4 {"winfo atom" command} {
  60     list [catch {winfo atom -displayof geek foo} msg] $msg
  61 } {1 {bad window path name "geek"}}
  62 test winfo-1.5 {"winfo atom" command} {
  63     winfo atom PRIMARY
  64 } 1
  65 test winfo-1.6 {"winfo atom" command} {
  66     winfo atom -displayof . PRIMARY
  67 } 1
  68
  69 test winfo-2.1 {"winfo atomname" command} {
  70     list [catch {winfo atomname} msg] $msg
  71 } {1 {wrong # args: should be "winfo atomname ?-displayof window? id"}}
  72 test winfo-2.2 {"winfo atomname" command} {
  73     list [catch {winfo atomname a b} msg] $msg
  74 } {1 {wrong # args: should be "winfo atomname ?-displayof window? id"}}
  75 test winfo-2.3 {"winfo atomname" command} {
  76     list [catch {winfo atomname a b c d} msg] $msg
  77 } {1 {wrong # args: should be "winfo atomname ?-displayof window? id"}}
  78 test winfo-2.4 {"winfo atomname" command} {
  79     list [catch {winfo atomname -displayof geek foo} msg] $msg
  80 } {1 {bad window path name "geek"}}
  81 test winfo-2.5 {"winfo atomname" command} {
  82     list [catch {winfo atomname 44215} msg] $msg
  83 } {1 {no atom exists with id "44215"}}
  84 test winfo-2.6 {"winfo atomname" command} {
  85     winfo atomname 2
  86 } SECONDARY
  87 test winfo-2.7 {"winfo atom" command} {
  88     winfo atomname -displayof . 2
  89 } SECONDARY
  90
  91 if {([winfo depth .] == 8) && ([winfo visual .] == "pseudocolor")} {
  92     test winfo-3.1 {"winfo colormapfull" command} {
  93         list [catch {winfo colormapfull} msg] $msg
  94     } {1 {wrong # args: should be "winfo colormapfull window"}}
  95     test winfo-3.2 {"winfo colormapfull" command} {
  96         list [catch {winfo colormapfull a b} msg] $msg
  97     } {1 {wrong # args: should be "winfo colormapfull window"}}
  98     test winfo-3.3 {"winfo colormapfull" command} {
  99         list [catch {winfo colormapfull foo} msg] $msg
 100     } {1 {bad window path name "foo"}}
 101     test winfo-3.4 {"winfo colormapfull" command} {macOrUnix} {
 102         eatColors .t {-colormap new}
 103         set result [list [winfo colormapfull .] [winfo colormapfull .t]]
 104         .t.c delete 34
 105         lappend result [winfo colormapfull .t]
 106         .t.c create rectangle 30 30 80 80 -fill #441739
 107         lappend result [winfo colormapfull .t]
 108         .t.c create rectangle 40 40 90 90 -fill #ffeedd
 109         lappend result [winfo colormapfull .t]
 110         destroy .t.c
 111         lappend result [winfo colormapfull .t]
 112     } {0 1 0 0 1 0}
 113     catch {destroy .t}
 114 }
 115
 116 catch {destroy .t}
 117 toplevel .t -width 550 -height 400
 118 frame .t.f -width 80 -height 60 -bd 2 -relief raised
 119 place .t.f -x 50 -y 50
 120 wm geom .t +0+0
 121 update
 122 test winfo-4.1 {"winfo containing" command} {
 123     list [catch {winfo containing 22} msg] $msg
 124 } {1 {wrong # args: should be "winfo containing ?-displayof window? rootX rootY"}}
 125 test winfo-4.2 {"winfo containing" command} {
 126     list [catch {winfo containing a b c} msg] $msg
 127 } {1 {wrong # args: should be "winfo containing ?-displayof window? rootX rootY"}}
 128 test winfo-4.3 {"winfo containing" command} {
 129     list [catch {winfo containing a b c d e} msg] $msg
 130 } {1 {wrong # args: should be "winfo containing ?-displayof window? rootX rootY"}}
 131 test winfo-4.4 {"winfo containing" command} {
 132     list [catch {winfo containing -displayof geek 25 30} msg] $msg
 133 } {1 {bad window path name "geek"}}
 134 test winfo-4.5 {"winfo containing" command} {
 135     winfo containing [winfo rootx .t.f] [winfo rooty .t.f]
 136 } .t.f
 137 test winfo-4.6 {"winfo containing" command} {nonPortable} {
 138     winfo containing [expr [winfo rootx .t.f]-1] [expr [winfo rooty .t.f]-1]
 139 } .t
 140 test winfo-4.7 {"winfo containing" command} {
 141     set x [winfo containing -display .t.f [expr [winfo rootx .t]+600] \
 142             [expr [winfo rooty .t.f]+450]]
 143     expr {($x == ".") || ($x == "")}
 144 } {1}
 145 destroy .t
 146
 147 test winfo-5.1 {"winfo interps" command} {
 148     list [catch {winfo interps a} msg] $msg
 149 } {1 {wrong # args: should be "winfo interps ?-displayof window?"}}
 150 test winfo-5.2 {"winfo interps" command} {
 151     list [catch {winfo interps a b c} msg] $msg
 152 } {1 {wrong # args: should be "winfo interps ?-displayof window?"}}
 153 test winfo-5.3 {"winfo interps" command} {
 154     list [catch {winfo interps -displayof geek} msg] $msg
 155 } {1 {bad window path name "geek"}}
 156 test winfo-5.4 {"winfo interps" command} {unixOnly} {
 157     expr [lsearch -exact [winfo interps] [tk appname]] >= 0
 158 } {1}
 159 test winfo-5.5 {"winfo interps" command} {unixOnly} {
 160     expr [lsearch -exact [winfo interps -displayof .] [tk appname]] >= 0
 161 } {1}
 162
 163 test winfo-6.1 {"winfo exists" command} {
 164     list [catch {winfo exists} msg] $msg
 165 } {1 {wrong # args: should be "winfo exists window"}}
 166 test winfo-6.2 {"winfo exists" command} {
 167     list [catch {winfo exists a b} msg] $msg
 168 } {1 {wrong # args: should be "winfo exists window"}}
 169 test winfo-6.3 {"winfo exists" command} {
 170     winfo exists gorp
 171 } {0}
 172 test winfo-6.4 {"winfo exists" command} {
 173     winfo exists .
 174 } {1}
 175 test winfo-6.5 {"winfo exists" command} {
 176     button .b -text "Test button"
 177     set x [winfo exists .b]
 178     pack .b
 179     update
 180     bind .b <Destroy> {lappend x [winfo exists .x]}
 181     destroy .b
 182     lappend x [winfo exists .x]
 183 } {1 0 0}
 184
 185 catch {destroy .b}
 186 button .b -text "Help"
 187 update
 188 test winfo-7.1 {"winfo pathname" command} {
 189     list [catch {winfo pathname} msg] $msg
 190 } {1 {wrong # args: should be "winfo pathname ?-displayof window? id"}}
 191 test winfo-7.2 {"winfo pathname" command} {
 192     list [catch {winfo pathname a b} msg] $msg
 193 } {1 {wrong # args: should be "winfo pathname ?-displayof window? id"}}
 194 test winfo-7.3 {"winfo pathname" command} {
 195     list [catch {winfo pathname a b c d} msg] $msg
 196 } {1 {wrong # args: should be "winfo pathname ?-displayof window? id"}}
 197 test winfo-7.4 {"winfo pathname" command} {
 198     list [catch {winfo pathname -displayof geek 25} msg] $msg
 199 } {1 {bad window path name "geek"}}
 200 test winfo-7.5 {"winfo pathname" command} {
 201     list [catch {winfo pathname xyz} msg] $msg
 202 } {1 {expected integer but got "xyz"}}
 203 test winfo-7.6 {"winfo pathname" command} {
 204     list [catch {winfo pathname 224} msg] $msg
 205 } {1 {window id "224" doesn't exist in this application}}
 206 test winfo-7.7 {"winfo pathname" command} {
 207     winfo pathname -displayof .b [winfo id .]
 208 } {.}
 209
 210 if {[string compare testwrapper [info commands testwrapper]] == 0} {
 211     puts "This application hasn't been compiled with the testwrapper command,"
 212     puts "therefore I am skipping all of these tests."
 213
 214     test winfo-7.8 {"winfo pathname" command} {unixOnly} {
 215         winfo pathname [testwrapper .]
 216     } {}
 217 }
 218
 219 test winfo-8.1 {"winfo pointerx" command} {
 220     catch [winfo pointerx .b]
 221 } 1
 222 test winfo-8.2 {"winfo pointery" command} {
 223     catch [winfo pointery .b]
 224 } 1
 225 test winfo-8.3 {"winfo pointerxy" command} {
 226     catch [winfo pointerxy .b]
 227 } 1
 228
 229 test winfo-9.1 {"winfo viewable" command} {
 230     list [catch {winfo viewable} msg] $msg
 231 } {1 {wrong # args: should be "winfo viewable window"}}
 232 test winfo-9.2 {"winfo viewable" command} {
 233     list [catch {winfo viewable foo} msg] $msg
 234 } {1 {bad window path name "foo"}}
 235 test winfo-9.3 {"winfo viewable" command} {
 236     winfo viewable .
 237 } {1}
 238 test winfo-9.4 {"winfo viewable" command} {
 239     wm iconify .
 240     winfo viewable .
 241 } {0}
 242 wm deiconify .
 243 test winfo-9.5 {"winfo viewable" command} {
 244     frame .f1 -width 100 -height 100 -relief raised -bd 2
 245     place .f1 -x 0 -y 0
 246     frame .f1.f2 -width 50 -height 50 -relief raised -bd 2
 247     place .f1.f2 -x 0 -y 0
 248     update
 249     list [winfo viewable .f1] [winfo viewable .f1.f2]
 250 } {1 1}
 251 test winfo-9.6 {"winfo viewable" command} {
 252     eval destroy [winfo child .]
 253     frame .f1 -width 100 -height 100 -relief raised -bd 2
 254     frame .f1.f2 -width 50 -height 50 -relief raised -bd 2
 255     place .f1.f2 -x 0 -y 0
 256     update
 257     list [winfo viewable .f1] [winfo viewable .f1.f2]
 258 } {0 0}
 259 test winfo-9.7 {"winfo viewable" command} {
 260     eval destroy [winfo child .]
 261     frame .f1 -width 100 -height 100 -relief raised -bd 2
 262     place .f1 -x 0 -y 0
 263     frame .f1.f2 -width 50 -height 50 -relief raised -bd 2
 264     place .f1.f2 -x 0 -y 0
 265     update
 266     wm iconify .
 267     list [winfo viewable .f1] [winfo viewable .f1.f2]
 268 } {0 0}
 269 wm deiconify .
 270 eval destroy [winfo child .]
 271
 272 test winfo-10.1 {"winfo visualid" command} {
 273     list [catch {winfo visualid} msg] $msg
 274 } {1 {wrong # args: should be "winfo visualid window"}}
 275 test winfo-10.2 {"winfo visualid" command} {
 276     list [catch {winfo visualid gorp} msg] $msg
 277 } {1 {bad window path name "gorp"}}
 278 test winfo-10.3 {"winfo visualid" command} {
 279     expr 2+[winfo visualid .]-[winfo visualid .]
 280 } {2}
 281
 282 test winfo-11.1 {"winfo visualid" command} {
 283     list [catch {winfo visualsavailable} msg] $msg
 284 } {1 {wrong # args: should be "winfo visualsavailable window ?includeids?"}}
 285 test winfo-11.2 {"winfo visualid" command} {
 286     list [catch {winfo visualsavailable gorp} msg] $msg
 287 } {1 {bad window path name "gorp"}}
 288 test winfo-11.3 {"winfo visualid" command} {
 289     list [catch {winfo visualsavailable . includeids foo} msg] $msg
 290 } {1 {wrong # args: should be "winfo visualsavailable window ?includeids?"}}
 291 test winfo-11.4 {"winfo visualid" command} {
 292     llength [lindex [winfo visualsa .] 0]
 293 } {2}
 294 test winfo-11.5 {"winfo visualid" command} {
 295     llength [lindex [winfo visualsa . includeids] 0]
 296 } {3}
 297 test winfo-11.6 {"winfo visualid" command} {
 298     set x [lindex [lindex [winfo visualsa . includeids] 0] 2]
 299     expr $x + 2 - $x
 300 } {2}
 301
 302 test winfo-12.1 {GetDisplayOf procedure} {
 303     list [catch {winfo atom - foo x} msg] $msg
 304 } {1 {wrong # args: should be "winfo atom ?-displayof window? name"}}
 305 test winfo-12.2 {GetDisplayOf procedure} {
 306     list [catch {winfo atom -d bad_window x} msg] $msg
 307 } {1 {bad window path name "bad_window"}}
 308
 309 # Some embedding tests
 310 #
 311
 312 proc MakeEmbed {} {
 313     frame .con -container 1
 314     pack .con -expand yes -fill both
 315     toplevel .emb -use [winfo id .con] -bd 0 -highlightthickness 0
 316     button .emb.b
 317     pack .emb.b -expand yes -fill both
 318     update
 319 }
 320 test winfo-13.1 {root coordinates of embedded toplevel} {macOrUnix} {
 321     MakeEmbed
 322     set z [expr [winfo rootx .emb] == [winfo rootx .con] && \
 323                 [winfo rooty .emb] == [winfo rooty .con]]
 324     destroy .emb
 325     destroy .con
 326     set z
 327 } {1}
 328 test winfo-13.2 {destroying embedded toplevel} {macOrUnix} {
 329     catch {destroy .emb}
 330     update
 331     expr [winfo exists .emb.b] || [winfo exists .con]
 332 } 0
 333
 334 foreach i [winfo children .] {
 335     destroy $i
 336 }
 337
 338 test winfo-13.3 {destroying container window} {macOrUnix} {
 339     MakeEmbed
 340     destroy .con
 341     update
 342     set z [expr [winfo exists .emb.b] || [winfo exists .emb]]
 343     catch {destroy .emb}
 344     catch {destroy .con}
 345     set z
 346 } 0
 347
 348 foreach i [winfo children .] {
 349     destroy $i
 350 }
 351
 352 test winfo-13.4 {[winfo containing] with embedded windows} {macOrUnix} {
 353     MakeEmbed
 354     button .b
 355     pack .b -expand yes -fill both
 356     update
 357
 358     set z [string compare \
 359         [winfo containing [winfo rootx .emb.b] [winfo rooty .emb.b]] .emb.b]
 360     catch {destroy .con}
 361     catch {destroy .emb}
 362     set z
 363 } 0
 364
 365 foreach i [winfo children .] {
 366     catch {destroy $i}
 367 }