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