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