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