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