1# This file is a Tcl script to test out Tk's selection management code, 2# especially the "selection" command. It is organized in the standard fashion 3# for Tcl tests. 4# 5# Copyright (c) 1994 Sun Microsystems, Inc. 6# Copyright (c) 1998-1999 by Scriptics Corporation. 7# All rights reserved. 8 9# 10# Note: Multiple display selection handling will only be tested if the 11# environment variable TK_ALT_DISPLAY is set to an alternate display. 12# 13 14package require tcltest 2.2 15namespace import ::tcltest::* 16namespace import ::tk::test:loadTkCommand 17eval tcltest::configure $argv 18tcltest::loadTestedCommands 19 20testConstraint cliboardManagerPresent 0 21if {![catch {selection get -selection CLIPBOARD_MANAGER -type TARGETS}]} { 22 if {"SAVE_TARGETS" in [selection get -selection CLIPBOARD_MANAGER -type TARGETS]} { 23 testConstraint cliboardManagerPresent 1 24 } 25} 26testConstraint failsOnUbuntu [expr {![info exists ::env(CI)] || ![string match Linux $::tcl_platform(os)]}] 27 28global longValue selValue selInfo 29 30set selValue {} 31set selInfo {} 32 33proc handler {type offset count} { 34 global selValue selInfo 35 lappend selInfo $type $offset $count 36 set numBytes [expr {[string length $selValue] - $offset}] 37 if {$numBytes <= 0} { 38 return "" 39 } 40 string range $selValue $offset [expr {$numBytes+$offset}] 41} 42 43proc errIncrHandler {type offset count} { 44 global selValue selInfo pass 45 if {$offset == 4000} { 46 if {$pass == 0} { 47 # Just sizing the selection; don't do anything here. 48 set pass 1 49 } else { 50 # Fetching the selection; wait long enough to cause a timeout. 51 after 6000 52 } 53 } 54 lappend selInfo $type $offset $count 55 set numBytes [expr {[string length $selValue] - $offset}] 56 if {$numBytes <= 0} { 57 return "" 58 } 59 string range $selValue $offset [expr {$numBytes+$offset}] 60} 61 62proc errHandler args { 63 error "selection handler aborted" 64} 65 66proc badHandler {path type offset count} { 67 global selValue selInfo 68 selection handle -type $type $path {} 69 lappend selInfo $path $type $offset $count 70 set numBytes [expr {[string length $selValue] - $offset}] 71 if {$numBytes <= 0} { 72 return "" 73 } 74 string range $selValue $offset [expr {$numBytes+$offset}] 75} 76proc reallyBadHandler {path type offset count} { 77 global selValue selInfo pass 78 if {$offset == 4000} { 79 if {$pass == 0} { 80 set pass 1 81 } else { 82 selection handle -type $type $path {} 83 } 84 } 85 lappend selInfo $path $type $offset $count 86 set numBytes [expr {[string length $selValue] - $offset}] 87 if {$numBytes <= 0} { 88 return "" 89 } 90 string range $selValue $offset [expr {$numBytes+$offset}] 91} 92 93# Eliminate any existing selection on the screen. This is needed in case 94# there is a selection in some other application, in order to prevent races 95# from causing false errors in the tests below. 96 97selection clear . 98after 1500 99 100# common setup code 101proc setup {{path .f1} {display {}}} { 102 catch {destroy $path} 103 if {$display == {}} { 104 frame $path 105 } else { 106 toplevel $path -screen $display 107 wm geom $path +0+0 108 } 109 selection own $path 110} 111 112# set up a very large buffer to test INCR retrievals 113set longValue "" 114foreach i {a b c d e f g j h i j k l m o p q r s t u v w x y z} { 115 set j $i.1$i.2$i.3$i.4$i.5$i.6$i.7$i.8$i.9$i.10$i.11$i.12$i.13$i.14 116 append longValue A$j B$j C$j D$j E$j F$j G$j H$j I$j K$j L$j M$j N$j 117} 118 119# Now we start the main body of the test code 120 121test select-1.1 {Tk_CreateSelHandler procedure} -setup { 122 setup 123} -body { 124 lsort [selection get TARGETS] 125} -result {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW} 126test select-1.2 {Tk_CreateSelHandler procedure} -setup { 127 setup 128} -body { 129 selection handle .f1 {handler TEST} TEST 130 lsort [selection get TARGETS] 131} -result {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW} 132test select-1.3 {Tk_CreateSelHandler procedure} -setup { 133 global selValue selInfo 134 setup 135} -body { 136 selection handle .f1 {handler TEST} TEST 137 set selValue "Test value" 138 set selInfo "" 139 list [selection get TEST] $selInfo 140} -result {{Test value} {TEST 0 4000}} 141test select-1.4.1 {Tk_CreateSelHandler procedure} -constraints unix -setup { 142 setup 143} -body { 144 selection handle .f1 {handler TEST} TEST 145 selection handle .f1 {handler STRING} 146 lsort [selection get TARGETS] 147} -result {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW UTF8_STRING} 148test select-1.4.2 {Tk_CreateSelHandler procedure} -constraints win -setup { 149 setup 150} -body { 151 selection handle .f1 {handler TEST} TEST 152 selection handle .f1 {handler STRING} 153 lsort [selection get TARGETS] 154} -result {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW} 155test select-1.5 {Tk_CreateSelHandler procedure} -setup { 156 global selValue selInfo 157 setup 158} -body { 159 selection handle .f1 {handler TEST} TEST 160 selection handle .f1 {handler STRING} 161 set selValue "" 162 set selInfo "" 163 list [selection get] $selInfo 164} -result {{} {STRING 0 4000}} 165test select-1.6.1 {Tk_CreateSelHandler procedure} -constraints unix -setup { 166 global selValue selInfo 167 setup 168} -body { 169 selection handle .f1 {handler TEST} TEST 170 selection handle .f1 {handler STRING} 171 set selValue "" 172 set selInfo "" 173 selection get 174 selection get -type TEST 175 selection handle .f1 {handler TEST2} TEST 176 selection get -type TEST 177 list $selInfo [lsort [selection get TARGETS]] 178} -result {{STRING 0 4000 TEST 0 4000 TEST2 0 4000} {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW UTF8_STRING}} 179test select-1.6.2 {Tk_CreateSelHandler procedure} -constraints win -setup { 180 global selValue selInfo 181 setup 182} -body { 183 selection handle .f1 {handler TEST} TEST 184 selection handle .f1 {handler STRING} 185 set selValue "" 186 set selInfo "" 187 selection get 188 selection get -type TEST 189 selection handle .f1 {handler TEST2} TEST 190 selection get -type TEST 191 list $selInfo [lsort [selection get TARGETS]] 192} -result {{STRING 0 4000 TEST 0 4000 TEST2 0 4000} {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}} 193test select-1.7.1 {Tk_CreateSelHandler procedure} -constraints unix -setup { 194 setup 195} -body { 196 selection own -selection CLIPBOARD .f1 197 selection handle -selection CLIPBOARD .f1 {handler TEST} TEST 198 selection handle -selection PRIMARY .f1 {handler TEST2} STRING 199 list [lsort [selection get -selection PRIMARY TARGETS]] \ 200 [lsort [selection get -selection CLIPBOARD TARGETS]] 201} -result {{MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW UTF8_STRING} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}} 202test select-1.7.2 {Tk_CreateSelHandler procedure} -constraints win -setup { 203 setup 204} -body { 205 selection own -selection CLIPBOARD .f1 206 selection handle -selection CLIPBOARD .f1 {handler TEST} TEST 207 selection handle -selection PRIMARY .f1 {handler TEST2} STRING 208 list [lsort [selection get -selection PRIMARY TARGETS]] \ 209 [lsort [selection get -selection CLIPBOARD TARGETS]] 210} -result {{MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}} 211test select-1.8 {Tk_CreateSelHandler procedure} -setup { 212 setup 213} -body { 214 selection handle -format INTEGER -type TEST .f1 {handler TEST} 215 lsort [selection get TARGETS] 216} -result {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW} 217 218############################################################################## 219 220test select-2.1 {Tk_DeleteSelHandler procedure} -constraints unix -setup { 221 setup 222} -body { 223 selection handle .f1 {handler STRING} 224 selection handle -type TEST .f1 {handler TEST} 225 selection handle -type USER .f1 {handler USER} 226 set result [list [lsort [selection get TARGETS]]] 227 selection handle -type TEST .f1 {} 228 lappend result [lsort [selection get TARGETS]] 229} -result {{MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW USER UTF8_STRING} {MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW USER UTF8_STRING}} 230test select-2.2 {Tk_DeleteSelHandler procedure} -constraints unix -setup { 231 setup 232} -body { 233 selection handle .f1 {handler STRING} 234 selection handle -type TEST .f1 {handler TEST} 235 selection handle -type USER .f1 {handler USER} 236 set result [list [lsort [selection get TARGETS]]] 237 selection handle -type USER .f1 {} 238 lappend result [lsort [selection get TARGETS]] 239} -result {{MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW USER UTF8_STRING} {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW UTF8_STRING}} 240test select-2.3 {Tk_DeleteSelHandler procedure} -constraints unix -setup { 241 setup 242} -body { 243 selection own -selection CLIPBOARD .f1 244 selection handle -selection PRIMARY .f1 {handler STRING} 245 selection handle -selection CLIPBOARD .f1 {handler STRING} 246 selection handle -selection CLIPBOARD .f1 {} 247 list [lsort [selection get TARGETS]] \ 248 [lsort [selection get -selection CLIPBOARD TARGETS]] 249} -result {{MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW UTF8_STRING} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}} 250test select-2.4 {Tk_DeleteSelHandler procedure} -constraints win -setup { 251 setup 252} -body { 253 selection handle .f1 {handler STRING} 254 selection handle -type TEST .f1 {handler TEST} 255 selection handle -type USER .f1 {handler USER} 256 set result [list [lsort [selection get TARGETS]]] 257 selection handle -type TEST .f1 {} 258 lappend result [lsort [selection get TARGETS]] 259} -result {{MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW USER} {MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW USER}} 260test select-2.5 {Tk_DeleteSelHandler procedure} -constraints win -setup { 261 setup 262} -body { 263 selection handle .f1 {handler STRING} 264 selection handle -type TEST .f1 {handler TEST} 265 selection handle -type USER .f1 {handler USER} 266 set result [list [lsort [selection get TARGETS]]] 267 selection handle -type USER .f1 {} 268 lappend result [lsort [selection get TARGETS]] 269} -result {{MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW USER} {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}} 270test select-2.6 {Tk_DeleteSelHandler procedure} -constraints win -setup { 271 setup 272} -body { 273 selection own -selection CLIPBOARD .f1 274 selection handle -selection PRIMARY .f1 {handler STRING} 275 selection handle -selection CLIPBOARD .f1 {handler STRING} 276 selection handle -selection CLIPBOARD .f1 {} 277 list [lsort [selection get TARGETS]] \ 278 [lsort [selection get -selection CLIPBOARD TARGETS]] 279} -result {{MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}} 280test select-2.7 {Tk_DeleteSelHandler procedure} -setup { 281 setup 282} -body { 283 selection handle .f1 {handler STRING} 284 list [selection handle .f1 {}] [selection handle .f1 {}] 285} -result {{} {}} 286 287############################################################################## 288 289test select-3.1 {Tk_OwnSelection procedure} -setup { 290 setup 291} -body { 292 selection own 293} -result {.f1} 294test select-3.2 {Tk_OwnSelection procedure} -body { 295 setup .f1 296 set result [selection own] 297 setup .f2 298 lappend result [selection own] 299} -result {.f1 .f2} 300test select-3.3 {Tk_OwnSelection procedure} -setup { 301 setup .f1 302 setup .f2 303} -body { 304 selection own -selection CLIPBOARD .f1 305 list [selection own] [selection own -selection CLIPBOARD] 306} -result {.f2 .f1} 307test select-3.4 {Tk_OwnSelection procedure} -setup { 308 global lostSel 309 setup 310} -body { 311 set lostSel {owned} 312 selection own -command { set lostSel {lost} } .f1 313 selection clear .f1 314 set lostSel 315} -result {lost} 316test select-3.5 {Tk_OwnSelection procedure} -setup { 317 global lostSel 318 setup .f1 319 setup .f2 320} -body { 321 set lostSel {owned} 322 selection own -command { set lostSel {lost1} } .f1 323 selection own -command { set lostSel {lost2} } .f2 324 list $lostSel [selection own] 325} -result {lost1 .f2} 326test select-3.6 {Tk_OwnSelection procedure} -setup { 327 global lostSel 328 setup 329} -body { 330 set lostSel {owned} 331 selection own -command { set lostSel {lost1} } .f1 332 selection own -command { set lostSel {lost2} } .f1 333 set result $lostSel 334 selection clear .f1 335 lappend result $lostSel 336} -result {owned lost2} 337test select-3.7 {Tk_OwnSelection procedure} -constraints x11 -setup { 338 global lostSel 339 setup 340 setupbg 341} -body { 342 set lostSel {owned} 343 selection own -command { set lostSel {lost1} } .f1 344 update 345 set result {} 346 lappend result [dobg { selection own . }] 347 lappend result [dobg {selection own}] 348 update 349 cleanupbg 350 lappend result $lostSel 351} -result {{} . lost1} 352# check reentrancy on selection replacement 353test select-3.8 {Tk_OwnSelection procedure} -setup { 354 setup 355} -body { 356 selection own -selection CLIPBOARD -command { destroy .f1 } .f1 357 selection own -selection CLIPBOARD . 358} -result {} 359test select-3.9 {Tk_OwnSelection procedure} -setup { 360 setup .f2 361 setup .f1 362} -body { 363 selection own -selection CLIPBOARD -command { destroy .f2 } .f1 364 selection own -selection CLIPBOARD .f2 365} -result {} 366# multiple display tests 367test select-3.10 {Tk_OwnSelection procedure} -constraints { 368 altDisplay 369} -body { 370 setup .f1 371 setup .f2 $env(TK_ALT_DISPLAY) 372 list [selection own -displayof .f1] [selection own -displayof .f2] 373} -result {.f1 .f2} 374test select-3.11 {Tk_OwnSelection procedure} -constraints { 375 altDisplay 376} -setup { 377 setup .f1 378 setup .f2 $env(TK_ALT_DISPLAY) 379 setupbg 380 update 381 set result "" 382} -body { 383 lappend result [dobg "toplevel .t -screen $env(TK_ALT_DISPLAY); wm geom .t +0+0; selection own .t; update"] 384 lappend result [selection own -displayof .f1] \ 385 [selection own -displayof .f2] 386} -cleanup { 387 cleanupbg 388} -result {{} .f1 {}} 389 390############################################################################## 391 392test select-4.1 {Tk_ClearSelection procedure} -setup { 393 setup 394} -body { 395 set result [selection own] 396 selection clear .f1 397 lappend result [selection own] 398} -result {.f1 {}} 399test select-4.2 {Tk_ClearSelection procedure} -setup { 400 setup 401} -body { 402 selection own -selection CLIPBOARD .f1 403 selection clear .f1 404 selection own -selection CLIPBOARD 405} -result {.f1} 406test select-4.3 {Tk_ClearSelection procedure} -setup { 407 setup 408} -body { 409 list [selection clear .f1] [selection clear .f1] 410} -result {{} {}} 411test select-4.4 {Tk_ClearSelection procedure} -constraints x11 -setup { 412 global lostSel 413 setup 414 setupbg 415} -body { 416 set lostSel {owned} 417 selection own -command { set lostSel {lost1} } .f1 418 update 419 set result {} 420 lappend result [dobg {selection clear; update}] 421 update 422 cleanupbg 423 lappend result [selection own] 424} -result {{} {}} 425# multiple display tests 426test select-4.5 {Tk_ClearSelection procedure} -constraints { 427 altDisplay 428} -setup { 429 global lostSel lostSel2 430 setup .f1 431 setup .f2 $env(TK_ALT_DISPLAY) 432} -body { 433 set lostSel {owned} 434 set lostSel2 {owned2} 435 selection own -command { set lostSel {lost1} } .f1 436 selection own -command { set lostSel2 {lost2} } .f2 437 update 438 selection clear -displayof .f2 439 update 440 list $lostSel $lostSel2 441} -result {owned lost2} 442test select-4.6 {Tk_ClearSelection procedure} -constraints { 443 x11 altDisplay 444} -setup { 445 setup .f1 446 setup .f2 $env(TK_ALT_DISPLAY) 447 setupbg 448} -body { 449 set lostSel {owned} 450 set lostSel2 {owned2} 451 selection own -command { set lostSel {lost1} } .f1 452 selection own -command { set lostSel2 {lost2} } .f2 453 update 454 set result "" 455 lappend result [dobg "toplevel .t -screen $env(TK_ALT_DISPLAY); wm geom .t +0+0; selection own .t; update"] 456 lappend result [selection own -displayof .f1] \ 457 [selection own -displayof .f2] $lostSel $lostSel2 458 cleanupbg 459 set result 460} -result {{} .f1 {} owned lost2} 461 462############################################################################## 463 464test select-5.1 {Tk_GetSelection procedure} -returnCodes error -setup { 465 setup 466} -body { 467 selection get TEST 468} -result {PRIMARY selection doesn't exist or form "TEST" not defined} 469test select-5.2 {Tk_GetSelection procedure} -setup { 470 setup 471} -body { 472 selection get TK_WINDOW 473} -result {.f1} 474test select-5.3 {Tk_GetSelection procedure} -setup { 475 setup 476} -body { 477 selection handle -selection PRIMARY .f1 {handler TEST} TEST 478 set selValue "Test value" 479 set selInfo "" 480 list [selection get TEST] $selInfo 481} -result {{Test value} {TEST 0 4000}} 482test select-5.4 {Tk_GetSelection procedure} -setup { 483 setup 484} -returnCodes error -body { 485 selection handle .f1 ERROR errHandler 486 selection get ERROR 487} -result {PRIMARY selection doesn't exist or form "ERROR" not defined} 488test select-5.5 {Tk_GetSelection procedure} -setup { 489 setup 490} -body { 491 set selValue $longValue 492 set selInfo "" 493 selection handle .f1 {handler STRING} 494 list [selection get] $selInfo 495} -result "$longValue {STRING 0 4000 STRING 4000 4000 STRING 8000 4000 STRING 12000 4000 STRING 16000 4000}" 496test select-5.6 {Tk_GetSelection procedure} -setup { 497 setup 498} -returnCodes error -body { 499 set selValue $longValue 500 set selInfo "" 501 selection handle .f1 {apply {{type offset count} { 502 selection handle .f1 {} 503 handler $type $offset $count 504 }} STRING} 505 selection get 506} -result {PRIMARY selection doesn't exist or form "STRING" not defined} 507test select-5.7 {Tk_GetSelection procedure} -setup { 508 setup 509} -returnCodes error -body { 510 set selValue "Test Value" 511 set selInfo "" 512 selection handle .f1 {apply {{type offset count} { 513 destroy .f1 514 handler $type $offset $count 515 }} STRING} 516 selection get 517} -result {PRIMARY selection doesn't exist or form "STRING" not defined} 518test select-5.8 {Tk_GetSelection procedure} -setup { 519 setup 520} -body { 521 set selValue $longValue 522 set selInfo "" 523 selection handle .f1 {apply {{type offset count} { 524 selection clear 525 handler $type $offset $count 526 }} STRING} 527 list [selection get] $selInfo [catch {selection get} msg] $msg 528} -result "$longValue {STRING 0 4000 STRING 4000 4000 STRING 8000 4000 STRING 12000 4000 STRING 16000 4000} 1 {PRIMARY selection doesn't exist or form \"STRING\" not defined}" 529test select-5.9 {Tk_GetSelection procedure} -constraints x11 -setup { 530 setup 531 setupbg 532} -body { 533 selection handle -selection PRIMARY .f1 {handler TEST} TEST 534 update 535 set selValue "Test value" 536 set selInfo "" 537 set result "" 538 lappend result [dobg {selection get TEST}] 539 cleanupbg 540 lappend result $selInfo 541} -result {{Test value} {TEST 0 4000}} 542test select-5.10 {Tk_GetSelection procedure} -constraints x11 -setup { 543 setup 544 setupbg 545} -body { 546 selection handle -selection PRIMARY .f1 {handler TEST} TEST 547 update 548 set selValue "Test value" 549 set selInfo "" 550 selection own .f1 551 set result "" 552 lappend result [dobg {selection get TEST} 1] 553 cleanupbg 554 lappend result $selInfo 555} -result {{selection owner didn't respond} {}} 556# multiple display tests 557test select-5.11 {Tk_GetSelection procedure} -constraints { 558 altDisplay 559} -setup { 560 setup .f1 561 setup .f2 $env(TK_ALT_DISPLAY) 562} -body { 563 selection handle -selection PRIMARY .f1 {handler TEST} TEST 564 selection handle -selection PRIMARY .f2 {handler TEST2} TEST 565 set selValue "Test value" 566 set selInfo "" 567 set result [list [selection get TEST] $selInfo] 568 set selValue "Test value2" 569 set selInfo "" 570 lappend result [selection get -displayof .f2 TEST] $selInfo 571} -result {{Test value} {TEST 0 4000} {Test value2} {TEST2 0 4000}} 572test select-5.12 {Tk_GetSelection procedure} -constraints { 573 altDisplay 574} -setup { 575 global lostSel lostSel2 576 setup .f1 577 setup .f2 $env(TK_ALT_DISPLAY) 578} -body { 579 selection handle -selection PRIMARY .f1 {handler TEST} TEST 580 selection handle -selection PRIMARY .f2 {} TEST 581 set selValue "Test value" 582 set selInfo "" 583 set result [list [catch {selection get TEST} msg] $msg $selInfo] 584 set selValue "Test value2" 585 set selInfo "" 586 lappend result [catch {selection get -displayof .f2 TEST} msg] $msg \ 587 $selInfo 588} -result {0 {Test value} {TEST 0 4000} 1 {PRIMARY selection doesn't exist or form "TEST" not defined} {}} 589test select-5.13 {Tk_GetSelection procedure} -constraints { 590 x11 altDisplay 591} -setup { 592 setup .f1 593 setup .f2 $env(TK_ALT_DISPLAY) 594 setupbg 595} -body { 596 selection handle -selection PRIMARY .f1 {handler TEST} TEST 597 selection own .f1 598 selection handle -selection PRIMARY .f2 {handler TEST2} TEST 599 selection own .f2 600 set selValue "Test value" 601 set selInfo "" 602 update 603 set result "" 604 lappend result [dobg "toplevel .t -screen $env(TK_ALT_DISPLAY); wm geom .t +0+0; selection get -displayof .t TEST"] 605 set selValue "Test value2" 606 lappend result [dobg "selection get TEST"] 607 cleanupbg 608 lappend result $selInfo 609} -result {{Test value} {Test value2} {TEST2 0 4000 TEST 0 4000}} 610test select-5.14 {Tk_GetSelection procedure} -constraints { 611 x11 altDisplay 612} -setup { 613 setup .f1 614 setup .f2 $env(TK_ALT_DISPLAY) 615 setupbg 616} -body { 617 selection handle -selection PRIMARY .f1 {handler TEST} TEST 618 selection own .f1 619 selection handle -selection PRIMARY .f2 {} TEST 620 selection own .f2 621 set selValue "Test value" 622 set selInfo "" 623 update 624 set result "" 625 lappend result [dobg "toplevel .t -screen $env(TK_ALT_DISPLAY); wm geom .t +0+0; selection get -displayof .t TEST"] 626 set selValue "Test value2" 627 lappend result [dobg "selection get TEST"] 628 cleanupbg 629 lappend result $selInfo 630} -result {{PRIMARY selection doesn't exist or form "TEST" not defined} {Test value2} {TEST 0 4000}} 631test select-5.15 {Tk_GetSelection procedure} -setup { 632 setup 633 if {[llength [info command ::bgerror]]} { 634 rename ::bgerror ::TMPbgerror 635 } 636 set ::bgerrors {} 637} -body { 638 proc ::bgerror msg {lappend ::bgerrors $msg} 639 selection handle -type ERROR .f1 errHandler 640 list [catch {selection get ERROR} msg] $msg [update] {*}$::bgerrors 641} -cleanup { 642 rename ::bgerror {} 643 if {[llength [info command ::TMPbgerror]]} { 644 rename ::TMPbgerror ::bgerror 645 } 646} -result {1 {PRIMARY selection doesn't exist or form "ERROR" not defined} {} {selection handler aborted}} 647 648############################################################################## 649 650test select-6.1 {Tk_SelectionCmd procedure} -returnCodes error -body { 651 selection 652} -result {wrong # args: should be "selection option ?arg ...?"} 653# selection clear 654test select-6.2 {Tk_SelectionCmd procedure} -body { 655 selection clear -selection 656} -returnCodes error -result {value for "-selection" missing} 657test select-6.3 {Tk_SelectionCmd procedure} -setup { 658 setup 659} -body { 660 selection own . 661 set result [selection own] 662 selection clear -displayof .f1 663 lappend result [selection own] 664} -result {. {}} 665test select-6.4 {Tk_SelectionCmd procedure} -setup { 666 setup 667} -body { 668 selection own -selection CLIPBOARD .f1 669 set result [list [selection own] [selection own -selection CLIPBOARD]] 670 selection clear -selection CLIPBOARD .f1 671 lappend result [selection own] [selection own -selection CLIPBOARD] 672} -result {.f1 .f1 .f1 {}} 673test select-6.5 {Tk_SelectionCmd procedure} -setup { 674 setup 675} -body { 676 selection own -selection CLIPBOARD . 677 set result [list [selection own] [selection own -selection CLIPBOARD]] 678 selection clear -selection CLIPBOARD -displayof .f1 679 lappend result [selection own] [selection own -selection CLIPBOARD] 680} -result {.f1 . .f1 {}} 681test select-6.6 {Tk_SelectionCmd procedure} -returnCodes error -body { 682 selection clear -badopt foo 683} -result {bad option "-badopt": must be -displayof or -selection} 684test select-6.7 {Tk_SelectionCmd procedure} -returnCodes error -body { 685 selection clear -selectionfoo foo 686} -result {bad option "-selectionfoo": must be -displayof or -selection} 687test select-6.8 {Tk_SelectionCmd procedure} -body { 688 destroy .f2 689 selection clear -displayof .f2 690} -returnCodes error -result {bad window path name ".f2"} 691test select-6.9 {Tk_SelectionCmd procedure} -body { 692 destroy .f2 693 selection clear .f2 694} -returnCodes error -result {bad window path name ".f2"} 695test select-6.10 {Tk_SelectionCmd procedure} -setup { 696 setup 697} -body { 698 set result [selection own -selection PRIMARY] 699 selection clear 700 lappend result [selection own -selection PRIMARY] 701} -result {.f1 {}} 702test select-6.11 {Tk_SelectionCmd procedure} -setup { 703 setup 704} -body { 705 selection own -selection CLIPBOARD .f1 706 set result [selection own -selection CLIPBOARD] 707 selection clear -selection CLIPBOARD 708 lappend result [selection own -selection CLIPBOARD] 709} -result {.f1 {}} 710test select-6.12 {Tk_SelectionCmd procedure} -returnCodes error -body { 711 selection clear foo bar 712} -result {wrong # args: should be "selection clear ?-option value ...?"} 713# selection get 714test select-6.13 {Tk_SelectionCmd procedure} -body { 715 selection get -selection 716} -returnCodes error -result {value for "-selection" missing} 717test select-6.14 {Tk_SelectionCmd procedure} -setup { 718 global selValue selInfo 719 setup 720} -body { 721 selection handle .f1 {handler TEST} 722 set selValue "Test value" 723 set selInfo "" 724 list [selection get -displayof .f1] $selInfo 725} -result {{Test value} {TEST 0 4000}} 726test select-6.15 {Tk_SelectionCmd procedure} -setup { 727 global selValue selInfo 728 setup 729} -body { 730 selection handle .f1 {handler STRING} 731 selection handle -selection CLIPBOARD .f1 {handler TEST} 732 selection own -selection CLIPBOARD .f1 733 set selValue "Test value" 734 set selInfo "" 735 list [selection get -selection CLIPBOARD] $selInfo 736} -result {{Test value} {TEST 0 4000}} 737test select-6.16 {Tk_SelectionCmd procedure} -setup { 738 global selValue selInfo 739 setup 740} -body { 741 selection handle -type TEST .f1 {handler TEST} 742 selection handle -type STRING .f1 {handler STRING} 743 set selValue "Test value" 744 set selInfo "" 745 list [selection get -type TEST] $selInfo 746} -result {{Test value} {TEST 0 4000}} 747test select-6.17 {Tk_SelectionCmd procedure} -returnCodes error -body { 748 selection get -badopt foo 749} -result {bad option "-badopt": must be -displayof, -selection, or -type} 750test select-6.18 {Tk_SelectionCmd procedure} -returnCodes error -body { 751 selection get -selectionfoo foo 752} -result {bad option "-selectionfoo": must be -displayof, -selection, or -type} 753test select-6.19 {Tk_SelectionCmd procedure} -body { 754 catch { destroy .f2 } 755 selection get -displayof .f2 756} -returnCodes error -result {bad window path name ".f2"} 757test select-6.20 {Tk_SelectionCmd procedure} -returnCodes error -body { 758 selection get foo bar 759} -result {wrong # args: should be "selection get ?-option value ...?"} 760test select-6.21 {Tk_SelectionCmd procedure} -setup { 761 global selValue selInfo 762 setup 763} -body { 764 selection handle -type TEST .f1 {handler TEST} 765 selection handle -type STRING .f1 {handler STRING} 766 set selValue "Test value" 767 set selInfo "" 768 list [selection get TEST] $selInfo 769} -result {{Test value} {TEST 0 4000}} 770# selection handle 771# most of the handle section has been covered earlier 772test select-6.22 {Tk_SelectionCmd procedure} -body { 773 selection handle -selection 774} -returnCodes error -result {value for "-selection" missing} 775test select-6.23 {Tk_SelectionCmd procedure} -setup { 776 global selValue selInfo 777 setup 778} -body { 779 set selValue "Test value" 780 set selInfo "" 781 list [selection handle -format INTEGER .f1 {handler TEST}] [selection get -displayof .f1] $selInfo 782} -result {{} {Test value} {TEST 0 4000}} 783test select-6.24 {Tk_SelectionCmd procedure} -returnCodes error -body { 784 selection handle -badopt foo 785} -result {bad option "-badopt": must be -format, -selection, or -type} 786test select-6.25 {Tk_SelectionCmd procedure} -returnCodes error -body { 787 selection handle -selectionfoo foo 788} -result {bad option "-selectionfoo": must be -format, -selection, or -type} 789test select-6.26 {Tk_SelectionCmd procedure} -returnCodes error -body { 790 selection handle 791} -result {wrong # args: should be "selection handle ?-option value ...? window command"} 792test select-6.27 {Tk_SelectionCmd procedure} -returnCodes error -body { 793 selection handle . 794} -result {wrong # args: should be "selection handle ?-option value ...? window command"} 795test select-6.28 {Tk_SelectionCmd procedure} -returnCodes error -body { 796 selection handle . foo bar baz blat 797} -result {wrong # args: should be "selection handle ?-option value ...? window command"} 798test select-6.29 {Tk_SelectionCmd procedure} -body { 799 catch { destroy .f2 } 800 selection handle .f2 dummy 801} -returnCodes error -result {bad window path name ".f2"} 802# selection own 803test select-6.30 {Tk_SelectionCmd procedure} -body { 804 selection own -selection 805} -returnCodes error -result {value for "-selection" missing} 806test select-6.31 {Tk_SelectionCmd procedure} -setup { 807 setup 808} -body { 809 selection own . 810 selection own -displayof .f1 811} -result {.} 812test select-6.32 {Tk_SelectionCmd procedure} -setup { 813 setup 814} -body { 815 selection own . 816 selection own -selection CLIPBOARD .f1 817 list [selection own] [selection own -selection CLIPBOARD] 818} -result {. .f1} 819test select-6.33 {Tk_SelectionCmd procedure} -setup { 820 global lostSel 821 setup 822} -body { 823 set lostSel owned 824 selection own -command { set lostSel lost } . 825 selection own -selection CLIPBOARD .f1 826 set result $lostSel 827 selection own .f1 828 lappend result $lostSel 829} -result {owned lost} 830test select-6.34 {Tk_SelectionCmd procedure} -returnCodes error -body { 831 selection own -badopt foo 832} -result {bad option "-badopt": must be -command, -displayof, or -selection} 833test select-6.35 {Tk_SelectionCmd procedure} -returnCodes error -body { 834 selection own -selectionfoo foo 835} -result {bad option "-selectionfoo": must be -command, -displayof, or -selection} 836test select-6.36 {Tk_SelectionCmd procedure} -body { 837 destroy .f2 838 selection own -displayof .f2 839} -returnCodes error -result {bad window path name ".f2"} 840test select-6.37 {Tk_SelectionCmd procedure} -body { 841 destroy .f2 842 selection own .f2 843} -returnCodes error -result {bad window path name ".f2"} 844test select-6.38 {Tk_SelectionCmd procedure} -returnCodes error -body { 845 selection own foo bar baz 846} -result {wrong # args: should be "selection own ?-option value ...? ?window?"} 847test select-6.39 {Tk_SelectionCmd procedure} -returnCodes error -body { 848 selection foo 849} -result {bad option "foo": must be clear, get, handle, or own} 850 851############################################################################## 852 853# This test is non-portable because some old X11/News servers ignore a 854# selection request when the window doesn't exist, which causes a different 855# error message. 856test select-7.1 {TkSelDeadWindow procedure} -constraints nonPortable -setup { 857 setup 858} -body { 859 selection handle .f1 { handler TEST } 860 set result [selection own] 861 destroy .f1 862 lappend result [selection own] [catch {selection get} msg] $msg 863} -result {.f1 {} 1 {PRIMARY selection doesn't exist or form "STRING" not defined}} 864 865############################################################################## 866 867# Check reentrancy on losing selection 868test select-8.1 {TkSelEventProc procedure} -constraints x11 -setup { 869 setup 870 setupbg 871} -body { 872 selection own -selection CLIPBOARD -command {destroy .f1} .f1 873 update 874 dobg {selection own -selection CLIPBOARD .} 875 winfo children . 876} -cleanup { 877 cleanupbg 878} -result {} 879 880############################################################################## 881 882test select-9.1 {SelCvtToX and SelCvtFromX procedures} -setup { 883 setup 884 setupbg 885} -constraints x11 -body { 886 set selValue "1024" 887 set selInfo "" 888 selection handle -selection PRIMARY -format INTEGER -type TEST \ 889 .f1 {handler TEST} 890 update 891 set result "" 892 lappend result [dobg {selection get TEST}] 893 cleanupbg 894 lappend result $selInfo 895} -result {{0x400 } {TEST 0 4000}} 896test select-9.2 {SelCvtToX and SelCvtFromX procedures} -setup { 897 setup 898 setupbg 899} -constraints {x11 failsOnUbuntu} -body { 900 set selValue "1024 0xffff 2048 -2 " 901 set selInfo "" 902 selection handle -selection PRIMARY -format INTEGER -type TEST \ 903 .f1 {handler TEST} 904 set result "" 905 lappend result [dobg {selection get TEST}] 906 cleanupbg 907 lappend result $selInfo 908} -result {{0x400 0xffff 0x800 0xfffffffe } {TEST 0 4000}} 909test select-9.3 {SelCvtToX and SelCvtFromX procedures} -setup { 910 setup 911 setupbg 912} -constraints {x11 failsOnUbuntu} -body { 913 set selValue " " 914 set selInfo "" 915 selection handle -selection PRIMARY -format INTEGER -type TEST \ 916 .f1 {handler TEST} 917 set result "" 918 lappend result [dobg {selection get TEST}] 919 cleanupbg 920 lappend result $selInfo 921} -result {{ } {TEST 0 4000}} 922test select-9.4 {SelCvtToX and SelCvtFromX procedures} -setup { 923 setup 924 setupbg 925} -constraints {x11 failsOnUbuntu} -body { 926 set selValue "16 foobar 32" 927 set selInfo "" 928 selection handle -selection PRIMARY -format INTEGER -type TEST \ 929 .f1 {handler TEST} 930 set result "" 931 lappend result [dobg {selection get TEST}] 932 cleanupbg 933 lappend result $selInfo 934} -result {{0x10 0x0 0x20 } {TEST 0 4000}} 935test select-9.5 {SelCvtToX and SelCvtFromX procedures} -setup { 936 setup 937 setupbg 938} -constraints x11 -body { 939 # Ensure that lists of atoms are constructed correctly, even when the 940 # atom names have spaces in. [Bug 1353414] 941 set selValue "foo bar" 942 set selInfo "" 943 set selType {text/x-tk-test;detail="foo bar"} 944 selection handle -selection PRIMARY -format STRING -type $selType \ 945 .f1 [list handler $selType] 946 lsort [dobg {selection get TARGETS}] 947} -cleanup { 948 cleanupbg 949} -result {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW {text/x-tk-test;detail="foo bar"}} 950 951############################################################################## 952# note, we are not testing MULTIPLE style selections 953 954# most control paths have been exercised above 955test select-10.1 {ConvertSelection procedure, race with selection clear} -constraints { 956 x11 957} -setup { 958 setup 959} -body { 960 proc Ready {fd} { 961 variable x 962 lappend x [gets $fd] 963 } 964 set fd [open "|[list [interpreter] -geometry +0+0 -name tktest]" r+] 965 puts $fd "puts foo; [loadTkCommand]; flush stdout" 966 flush $fd 967 gets $fd 968 fileevent $fd readable [list Ready $fd] 969 set selValue "Just a simple test" 970 set selInfo "" 971 selection handle .f1 {handler STRING} 972 update 973 puts $fd {puts "[catch {selection get} msg]:$msg"; puts **DONE**; flush stdout} 974 flush $fd 975 after 200 976 selection own . 977 set x {} 978 vwait [namespace which -variable x] 979 puts $fd {exit} 980 flush $fd 981 # Don't understand why, but the [loadTkCommand] above causes 982 # a "broken pipe" error when Tk was actually [load]ed in the child. 983 catch {close $fd} 984 lappend x $selInfo 985} -result {{1:PRIMARY selection doesn't exist or form "STRING" not defined} {}} 986test select-10.2 {ConvertSelection procedure} -constraints x11 -setup { 987 setup 988 setupbg 989} -body { 990 set selValue [string range $longValue 0 3999] 991 set selInfo "" 992 selection handle .f1 {handler STRING} 993 set result "" 994 lappend result [dobg {selection get}] 995 cleanupbg 996 lappend result $selInfo 997} -result [list [string range $longValue 0 3999] {STRING 0 4000 STRING 4000 4000 STRING 0 4000 STRING 4000 4000}] 998test select-10.3 {ConvertSelection procedure} -constraints x11 -setup { 999 setup 1000 setupbg 1001} -body { 1002 selection handle .f1 ERROR errHandler 1003 dobg {selection get ERROR} 1004} -cleanup { 1005 cleanupbg 1006} -result {PRIMARY selection doesn't exist or form "ERROR" not defined} 1007# testing timers 1008# This one hangs in Exceed 1009test select-10.4 {ConvertSelection procedure} -constraints { 1010 x11 noExceed failsOnUbuntu 1011} -setup { 1012 setup 1013 setupbg 1014} -body { 1015 set selValue $longValue 1016 set selInfo "" 1017 selection handle .f1 {errIncrHandler STRING} 1018 set result "" 1019 set pass 0 1020 lappend result [dobg {selection get}] 1021 cleanupbg 1022 lappend result $selInfo 1023} -result {{selection owner didn't respond} {STRING 0 4000 STRING 4000 4000 STRING 8000 4000 STRING 12000 4000 STRING 16000 4000 STRING 0 4000 STRING 4000 4000}} 1024test select-10.5 {ConvertSelection procedure, reentrancy issues} -constraints { 1025 x11 failsOnUbuntu 1026} -setup { 1027 setup 1028 setupbg 1029} -body { 1030 set selValue "Test value" 1031 set selInfo "" 1032 selection handle -type TEST .f1 { handler TEST } 1033 selection handle -type STRING .f1 { badHandler .f1 STRING } 1034 set result "" 1035 lappend result [dobg {selection get}] 1036 cleanupbg 1037 lappend result $selInfo 1038} -result {{PRIMARY selection doesn't exist or form "STRING" not defined} {.f1 STRING 0 4000}} 1039test select-10.6 {ConvertSelection procedure, reentrancy issues} -constraints { 1040 x11 failsOnUbuntu 1041} -setup { 1042 setup 1043 setupbg 1044} -body { 1045 proc weirdHandler {type offset count} { 1046 destroy .f1 1047 handler $type $offset $count 1048 } 1049 set selValue $longValue 1050 set selInfo "" 1051 selection handle .f1 {weirdHandler STRING} 1052 set result "" 1053 lappend result [dobg {selection get}] 1054 cleanupbg 1055 lappend result $selInfo 1056} -cleanup { 1057 rename weirdHandler {} 1058} -result {{PRIMARY selection doesn't exist or form "STRING" not defined} {STRING 0 4000}} 1059 1060############################################################################## 1061 1062# testing reentrancy 1063test select-11.1 {TkSelPropProc procedure} -constraints {x11 failsOnUbuntu} -setup { 1064 setup 1065 setupbg 1066} -body { 1067 set selValue $longValue 1068 set selInfo "" 1069 selection handle -type TEST .f1 { handler TEST } 1070 selection handle -type STRING .f1 { reallyBadHandler .f1 STRING } 1071 set result "" 1072 set pass 0 1073 lappend result [dobg {selection get}] 1074 cleanupbg 1075 lappend result $selInfo 1076} -result {{selection owner didn't respond} {.f1 STRING 0 4000 .f1 STRING 4000 4000 .f1 STRING 8000 4000 .f1 STRING 12000 4000 .f1 STRING 16000 4000 .f1 STRING 0 4000 .f1 STRING 4000 4000}} 1077 1078############################################################################## 1079 1080# Note, this assumes we are using CurrentTtime 1081test select-12.1 {DefaultSelection procedure} -constraints x11 -body { 1082 setup 1083 set result [selection get -type TIMESTAMP] 1084 setupbg 1085 lappend result [dobg {selection get -type TIMESTAMP}] 1086 cleanupbg 1087 set result 1088} -result {0x0 {0x0 }} 1089test select-12.2 {DefaultSelection procedure} -constraints x11 -body { 1090 setup 1091 set result [lsort [list [selection get -type TARGETS]]] 1092 setupbg 1093 lappend result [dobg {lsort [selection get -type TARGETS]}] 1094 cleanupbg 1095 set result 1096} -result {{MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}} 1097test select-12.3 {DefaultSelection procedure} -constraints x11 -body { 1098 setup 1099 selection handle .f1 {handler TEST} TEST 1100 set result [list [lsort [selection get -type TARGETS]]] 1101 setupbg 1102 lappend result [dobg {lsort [selection get -type TARGETS]}] 1103 cleanupbg 1104 set result 1105} -result {{MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}} 1106test select-12.4 {DefaultSelection procedure} -constraints x11 -setup { 1107 setup 1108 set result "" 1109} -body { 1110 lappend result [selection get -type TK_APPLICATION] 1111 setupbg 1112 lappend result [dobg {selection get -type TK_APPLICATION}] 1113 cleanupbg 1114 set result 1115} -result [list [winfo name .] [winfo name .]] 1116test select-12.5 {DefaultSelection procedure} -constraints x11 -body { 1117 setup 1118 set result [selection get -type TK_WINDOW] 1119 setupbg 1120 lappend result [dobg {selection get -type TK_WINDOW}] 1121 cleanupbg 1122 set result 1123} -result {.f1 .f1} 1124test select-12.6 {DefaultSelection procedure} -body { 1125 setup 1126 selection handle .f1 {handler TARGETS.f1} TARGETS 1127 set selValue "Targets value" 1128 set selInfo "" 1129 set result [list [selection get TARGETS] $selInfo] 1130 selection handle .f1 {} TARGETS 1131 lappend result [selection get TARGETS] 1132} -result {{Targets value} {TARGETS.f1 0 4000} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}} 1133 1134test select-13.1 {SelectionSize procedure, handler deleted} -constraints { 1135 x11 failsOnUbuntu 1136} -setup { 1137 setup 1138 setupbg 1139} -body { 1140 proc badHandler {path type offset count} { 1141 global selValue selInfo abortCount 1142 incr abortCount -1 1143 if {$abortCount == 0} { 1144 selection handle -type $type $path {} 1145 } 1146 lappend selInfo $path $type $offset $count 1147 set numBytes [expr {[string length $selValue] - $offset}] 1148 if {$numBytes <= 0} { 1149 return "" 1150 } 1151 string range $selValue $offset [expr {$numBytes+$offset}] 1152 } 1153 set selValue $longValue 1154 set selInfo "" 1155 selection handle .f1 {badHandler .f1 STRING} 1156 set result "" 1157 set abortCount 2 1158 lappend result [dobg {selection get}] 1159 cleanupbg 1160 lappend result $selInfo 1161} -result {{PRIMARY selection doesn't exist or form "STRING" not defined} {.f1 STRING 0 4000 .f1 STRING 4000 4000}} 1162 1163test select-14.1 {Bug [73ba07efcd]: Use correct property type when handling MULTIPLE conversion requests} -constraints { 1164 cliboardManagerPresent 1165} -setup { 1166 proc get_clip {offset maxChars} {return abcd} 1167} -body { 1168 selection handle -selection CLIPBOARD . get_clip 1169 selection own -selection CLIPBOARD . 1170 selection get -selection CLIPBOARD_MANAGER -type SAVE_TARGETS 1171 clipboard get 1172} -cleanup { 1173 rename get_clip {} 1174} -result {abcd} 1175 1176 1177# cleanup 1178cleanupTests 1179return 1180 1181# Local Variables: 1182# mode: tcl 1183# End: 1184