1# -*- tcl -*- 2# Functionality covered: operation of the reflected transformation 3# 4# This file contains a collection of tests for one or more of the Tcl 5# built-in commands. Sourcing this file into Tcl runs the tests and 6# generates output for errors. No output means no errors were found. 7# 8# Copyright © 2007 Andreas Kupries <andreask@activestate.com> 9# <akupries@shaw.ca> 10# 11# See the file "license.terms" for information on usage and redistribution 12# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 13 14if {"::tcltest" ni [namespace children]} { 15 package require tcltest 2.5 16 namespace import -force ::tcltest::* 17} 18 19::tcltest::loadTestedCommands 20catch [list package require -exact tcl::test [info patchlevel]] 21 22# Custom constraints used in this file 23testConstraint testchannel [llength [info commands testchannel]] 24testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] 25 26# testchannel cut|splice Both needed to test the reflection in threads. 27# thread::send 28 29#---------------------------------------------------------------------- 30 31# ### ### ### ######### ######### ######### 32## Testing the reflected transformation. 33 34# Helper commands to record the arguments to handler methods. Stored in a 35# script so that the tests needing this code do not need their own copy but 36# can access this variable. 37 38set helperscript { 39 if {"::tcltest" ni [namespace children]} { 40 package require tcltest 2.5 41 namespace import -force ::tcltest::* 42 } 43 44 # This forces the return options to be in the order that the test expects! 45 variable optorder { 46 -code !?! -level !?! -errorcode !?! -errorline !?! -errorinfo !?! 47 -errorstack !?! 48 } 49 proc noteOpts opts { 50 variable optorder 51 lappend ::res [dict merge $optorder $opts] 52 } 53 54 # Helper command, canned result for 'initialize' method. Gets the 55 # optional methods as arguments. Use return features to post the result 56 # higher up. 57 58 proc handle.initialize {args} { 59 upvar args hargs 60 if {[lindex $hargs 0] eq "initialize"} { 61 return -code return [list {*}$args initialize finalize read write] 62 } 63 } 64 proc handle.finalize {} { 65 upvar args hargs 66 if {[lindex $hargs 0] eq "finalize"} { 67 return -code return "" 68 } 69 } 70 proc handle.read {} { 71 upvar args hargs 72 if {[lindex $hargs 0] eq "read"} { 73 return -code return "@" 74 } 75 } 76 proc handle.drain {} { 77 upvar args hargs 78 if {[lindex $hargs 0] eq "drain"} { 79 return -code return "<>" 80 } 81 } 82 proc handle.clear {} { 83 upvar args hargs 84 if {[lindex $hargs 0] eq "clear"} { 85 return -code return "" 86 } 87 } 88 89 proc tempchan {{mode r+}} { 90 global tempchan 91 return [set tempchan [open [makeFile {test data} tempchanfile] $mode]] 92 } 93 proc tempdone {} { 94 global tempchan 95 catch {close $tempchan} 96 removeFile tempchanfile 97 return 98 } 99 proc tempview {} { viewFile tempchanfile } 100} 101 102# Set everything up in the main thread. 103eval $helperscript 104 105#puts <<[file channels]>> 106 107# ### ### ### ######### ######### ######### 108 109test iortrans-1.0 {chan, wrong#args} -returnCodes error -body { 110 chan 111} -result {wrong # args: should be "chan subcommand ?arg ...?"} 112test iortrans-1.1 {chan, unknown method} -returnCodes error -body { 113 chan foo 114} -match glob -result {unknown or ambiguous subcommand "foo": must be*} 115 116# --- --- --- --------- --------- --------- 117# chan push, and method "initalize" 118 119test iortrans-2.0 {chan push, wrong#args, not enough} -returnCodes error -body { 120 chan push 121} -result {wrong # args: should be "chan push channel cmdprefix"} 122test iortrans-2.1 {chan push, wrong#args, too many} -returnCodes error -body { 123 chan push a b c 124} -result {wrong # args: should be "chan push channel cmdprefix"} 125test iortrans-2.2 {chan push, invalid channel} -setup { 126 proc foo {} {} 127} -returnCodes error -body { 128 chan push {} foo 129} -cleanup { 130 rename foo {} 131} -result {can not find channel named ""} 132test iortrans-2.3 {chan push, bad handler, not a list} -body { 133 chan push [tempchan] "foo \{" 134} -returnCodes error -cleanup { 135 tempdone 136} -result {unmatched open brace in list} 137test iortrans-2.4 {chan push, bad handler, not a command} -body { 138 chan push [tempchan] foo 139} -returnCodes error -cleanup { 140 tempdone 141} -result {invalid command name "foo"} 142test iortrans-2.5 {chan push, initialize failed, bad signature} -body { 143 proc foo {} {} 144 chan push [tempchan] foo 145} -returnCodes error -cleanup { 146 tempdone 147 rename foo {} 148} -result {wrong # args: should be "foo"} 149test iortrans-2.6 {chan push, initialize failed, bad signature} -body { 150 proc foo {} {} 151 chan push [tempchan] ::foo 152} -returnCodes error -cleanup { 153 tempdone 154 rename foo {} 155} -result {wrong # args: should be "::foo"} 156test iortrans-2.7 {chan push, initialize failed, bad result, not a list} -body { 157 proc foo {args} {return "\{"} 158 catch {chan push [tempchan] foo} 159 return $::errorInfo 160} -cleanup { 161 tempdone 162 rename foo {} 163} -match glob -result {chan handler "foo initialize" returned non-list: *} 164test iortrans-2.8 {chan push, initialize failed, bad result, not a list} -body { 165 proc foo {args} {return \{\{\}} 166 chan push [tempchan] foo 167} -returnCodes error -cleanup { 168 tempdone 169 rename foo {} 170} -match glob -result {chan handler "foo initialize" returned non-list: *} 171test iortrans-2.9 {chan push, initialize failed, bad result, empty list} -body { 172 proc foo {args} {} 173 chan push [tempchan] foo 174} -returnCodes error -cleanup { 175 tempdone 176 rename foo {} 177} -match glob -result {*all required methods*} 178test iortrans-2.10 {chan push, initialize failed, bad result, bogus method name} -body { 179 proc foo {args} {return 1} 180 chan push [tempchan] foo 181} -returnCodes error -cleanup { 182 tempdone 183 rename foo {} 184} -match glob -result {*bad method "1": must be *} 185test iortrans-2.11 {chan push, initialize failed, bad result, bogus method name} -body { 186 proc foo {args} {return {a b c}} 187 chan push [tempchan] foo 188} -returnCodes error -cleanup { 189 tempdone 190 rename foo {} 191} -match glob -result {*bad method "c": must be *} 192test iortrans-2.12 {chan push, initialize failed, bad result, required methods missing} -body { 193 # Required: initialize, and finalize. 194 proc foo {args} {return {initialize}} 195 chan push [tempchan] foo 196} -returnCodes error -cleanup { 197 tempdone 198 rename foo {} 199} -match glob -result {*all required methods*} 200test iortrans-2.13 {chan push, initialize failed, bad result, illegal method name} -body { 201 proc foo {args} {return {initialize finalize BOGUS}} 202 chan push [tempchan] foo 203} -returnCodes error -cleanup { 204 tempdone 205 rename foo {} 206} -match glob -result {*returned bad method "BOGUS": must be clear, drain, finalize, flush, initialize, limit?, read, or write} 207test iortrans-2.14 {chan push, initialize failed, bad result, mode/handler mismatch} -body { 208 proc foo {args} {return {initialize finalize}} 209 chan push [tempchan] foo 210} -returnCodes error -cleanup { 211 tempdone 212 rename foo {} 213} -match glob -result {*makes the channel inaccessible} 214# iortrans-2.15 event/watch methods elimimated, removed these tests. 215# iortrans-2.16 216test iortrans-2.17 {chan push, initialize failed, bad result, drain/read mismatch} -body { 217 proc foo {args} {return {initialize finalize drain write}} 218 chan push [tempchan] foo 219} -returnCodes error -cleanup { 220 tempdone 221 rename foo {} 222} -match glob -result {*supports "drain" but not "read"} 223test iortrans-2.18 {chan push, initialize failed, bad result, flush/write mismatch} -body { 224 proc foo {args} {return {initialize finalize flush read}} 225 chan push [tempchan] foo 226} -returnCodes error -cleanup { 227 tempdone 228 rename foo {} 229} -match glob -result {*supports "flush" but not "write"} 230test iortrans-2.19 {chan push, initialize ok, creates channel} -setup { 231 set res {} 232} -match glob -body { 233 proc foo {args} { 234 global res 235 lappend res $args 236 if {[lindex $args 0] ne "initialize"} {return} 237 return {initialize finalize drain flush read write} 238 } 239 lappend res [file channel rt*] 240 lappend res [chan push [tempchan] foo] 241 lappend res [close [lindex $res end]] 242 lappend res [file channel rt*] 243} -cleanup { 244 tempdone 245 rename foo {} 246} -result {{} {initialize rt* {read write}} file* {drain rt*} {flush rt*} {finalize rt*} {} {}} 247test iortrans-2.20 {chan push, init failure -> no channel, no finalize} -setup { 248 set res {} 249} -match glob -body { 250 proc foo {args} { 251 global res 252 lappend res $args 253 return 254 } 255 lappend res [file channel rt*] 256 lappend res [catch {chan push [tempchan] foo} msg] $msg 257 lappend res [file channel rt*] 258} -cleanup { 259 tempdone 260 rename foo {} 261} -result {{} {initialize rt* {read write}} 1 {*all required methods*} {}} 262 263# --- --- --- --------- --------- --------- 264# method finalize (via close) 265 266# General note: file channels rt* finds the transform channel, however the 267# name reported will be that of the underlying base driver, fileXX here. This 268# actually allows us to see if the whole channel is gone, or only the 269# transformation, but not the base. 270 271test iortrans-3.1 {chan finalize, handler destruction has no effect on channel} -setup { 272 set res {} 273} -match glob -body { 274 proc foo {args} { 275 lappend ::res $args 276 handle.initialize 277 return 278 } 279 lappend res [set c [chan push [tempchan] foo]] 280 rename foo {} 281 lappend res [file channels file*] 282 lappend res [file channels rt*] 283 lappend res [catch {close $c} msg] $msg 284 lappend res [file channels file*] 285 lappend res [file channels rt*] 286} -cleanup { 287 tempdone 288} -result {{initialize rt* {read write}} file* file* {} 1 {invalid command name "foo"} {} {}} 289test iortrans-3.2 {chan finalize, for close} -setup { 290 set res {} 291} -match glob -body { 292 proc foo {args} { 293 lappend ::res $args 294 handle.initialize 295 return 296 } 297 lappend res [set c [chan push [tempchan] foo]] 298 close $c 299 # Close deleted the channel. 300 lappend res [file channels rt*] 301 # Channel destruction does not kill handler command! 302 lappend res [info command foo] 303} -cleanup { 304 rename foo {} 305 tempdone 306} -result {{initialize rt* {read write}} file* {finalize rt*} {} foo} 307test iortrans-3.3 {chan finalize, for close, error, close error} -setup { 308 set res {} 309} -match glob -body { 310 proc foo {args} { 311 lappend ::res $args 312 handle.initialize 313 return -code error 5 314 } 315 lappend res [set c [chan push [tempchan] foo]] 316 lappend res [catch {close $c} msg] $msg 317 # Channel is gone despite error. 318 lappend res [file channels rt*] 319} -cleanup { 320 rename foo {} 321 tempdone 322} -result {{initialize rt* {read write}} file* {finalize rt*} 1 5 {}} 323test iortrans-3.4 {chan finalize, for close, error, close error} -setup { 324 set res {} 325} -match glob -body { 326 proc foo {args} { 327 lappend ::res $args 328 handle.initialize 329 error FOO 330 } 331 lappend res [set c [chan push [tempchan] foo]] 332 lappend res [catch {close $c} msg] $msg $::errorInfo 333} -cleanup { 334 rename foo {} 335 tempdone 336} -result {{initialize rt* {read write}} file* {finalize rt*} 1 FOO {FOO 337*"close $c"}} 338test iortrans-3.5 {chan finalize, for close, arbitrary result, ignored} -setup { 339 set res {} 340} -match glob -body { 341 proc foo {args} { 342 lappend ::res $args 343 handle.initialize 344 return SOMETHING 345 } 346 lappend res [set c [chan push [tempchan] foo]] 347 lappend res [catch {close $c} msg] $msg 348} -cleanup { 349 rename foo {} 350 tempdone 351} -result {{initialize rt* {read write}} file* {finalize rt*} 0 {}} 352test iortrans-3.6 {chan finalize, for close, break, close error} -setup { 353 set res {} 354} -match glob -body { 355 proc foo {args} { 356 lappend ::res $args 357 handle.initialize 358 return -code 3 359 } 360 lappend res [set c [chan push [tempchan] foo]] 361 lappend res [catch {close $c} msg] $msg 362} -cleanup { 363 rename foo {} 364 tempdone 365} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} 366test iortrans-3.7 {chan finalize, for close, continue, close error} -setup { 367 set res {} 368} -match glob -body { 369 proc foo {args} { 370 lappend ::res $args 371 handle.initialize 372 return -code 4 373 } 374 lappend res [set c [chan push [tempchan] foo]] 375 lappend res [catch {close $c} msg] $msg 376} -cleanup { 377 rename foo {} 378 tempdone 379} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} 380test iortrans-3.8 {chan finalize, for close, custom code, close error} -setup { 381 set res {} 382} -match glob -body { 383 proc foo {args} { 384 lappend ::res $args 385 handle.initialize 386 return -code 777 BANG 387 } 388 lappend res [set c [chan push [tempchan] foo]] 389 lappend res [catch {close $c} msg] $msg 390} -cleanup { 391 rename foo {} 392 tempdone 393} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} 394test iortrans-3.9 {chan finalize, for close, ignore level, close error} -setup { 395 set res {} 396} -body { 397 proc foo {args} { 398 lappend ::res $args 399 handle.initialize 400 return -level 5 -code 777 BANG 401 } 402 lappend res [set c [chan push [tempchan] foo]] 403 lappend res [catch {close $c} msg opt] $msg 404 noteOpts $opt 405} -match glob -cleanup { 406 rename foo {} 407 tempdone 408} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "finalize"*}} 409 410# --- === *** ########################### 411# method read (via read) 412 413test iortrans-4.1 {chan read, transform call and return} -setup { 414 set res {} 415} -match glob -body { 416 proc foo {args} { 417 handle.initialize 418 handle.finalize 419 lappend ::res $args 420 return snarf 421 } 422 set c [chan push [tempchan] foo] 423 lappend res [read $c 10] 424} -cleanup { 425 tempdone 426 rename foo {} 427} -result {{read rt* {test data 428}} snarf} 429test iortrans-4.2 {chan read, for non-readable channel} -setup { 430 set res {} 431} -match glob -body { 432 proc foo {args} { 433 handle.initialize 434 handle.finalize 435 lappend ::res $args MUST_NOT_HAPPEN 436 } 437 set c [chan push [tempchan w] foo] 438 lappend res [catch {read $c 2} msg] $msg 439} -cleanup { 440 tempdone 441 rename foo {} 442} -result {1 {channel "file*" wasn't opened for reading}} 443test iortrans-4.3 {chan read, error return} -setup { 444 set res {} 445} -match glob -body { 446 proc foo {args} { 447 handle.initialize 448 handle.finalize 449 lappend ::res $args 450 return -code error BOOM! 451 } 452 set c [chan push [tempchan] foo] 453 lappend res [catch {read $c 2} msg] $msg 454} -cleanup { 455 tempdone 456 rename foo {} 457} -result {{read rt* {test data 458}} 1 BOOM!} 459test iortrans-4.4 {chan read, break return is error} -setup { 460 set res {} 461} -match glob -body { 462 proc foo {args} { 463 handle.initialize 464 handle.finalize 465 lappend ::res $args 466 return -code break BOOM! 467 } 468 set c [chan push [tempchan] foo] 469 lappend res [catch {read $c 2} msg] $msg 470} -cleanup { 471 tempdone 472 rename foo {} 473} -result {{read rt* {test data 474}} 1 *bad code*} 475test iortrans-4.5 {chan read, continue return is error} -setup { 476 set res {} 477} -match glob -body { 478 proc foo {args} { 479 handle.initialize 480 handle.finalize 481 lappend ::res $args 482 return -code continue BOOM! 483 } 484 set c [chan push [tempchan] foo] 485 lappend res [catch {read $c 2} msg] $msg 486} -cleanup { 487 tempdone 488 rename foo {} 489} -result {{read rt* {test data 490}} 1 *bad code*} 491test iortrans-4.6 {chan read, custom return is error} -setup { 492 set res {} 493} -match glob -body { 494 proc foo {args} { 495 handle.initialize 496 handle.finalize 497 lappend ::res $args 498 return -code 777 BOOM! 499 } 500 set c [chan push [tempchan] foo] 501 lappend res [catch {read $c 2} msg] $msg 502} -cleanup { 503 tempdone 504 rename foo {} 505} -result {{read rt* {test data 506}} 1 *bad code*} 507test iortrans-4.7 {chan read, level is squashed} -setup { 508 set res {} 509} -match glob -body { 510 proc foo {args} { 511 handle.initialize 512 handle.finalize 513 lappend ::res $args 514 return -level 55 -code 777 BOOM! 515 } 516 set c [chan push [tempchan] foo] 517 lappend res [catch {read $c 2} msg opt] $msg 518 noteOpts $opt 519} -cleanup { 520 tempdone 521 rename foo {} 522} -result {{read rt* {test data 523}} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}} 524test iortrans-4.8 {chan read, read, bug 2921116} -setup { 525 set res {} 526} -match glob -body { 527 proc foo {fd args} { 528 handle.initialize 529 handle.finalize 530 lappend ::res $args 531 # Kill and recreate transform while it is operating 532 chan pop $fd 533 chan push $fd [list foo $fd] 534 } 535 set c [chan push [set c [tempchan]] [list foo $c]] 536 lappend res [read $c] 537 #lappend res [gets $c] 538} -cleanup { 539 tempdone 540 rename foo {} 541} -result {{read rt* {test data 542}} {}} 543test iortrans-4.8.1 {chan read, bug 721ec69271} -setup { 544 set res {} 545} -match glob -body { 546 proc foo {fd args} { 547 handle.initialize 548 handle.finalize 549 lappend ::res $args 550 # Kill and recreate transform while it is operating 551 chan pop $fd 552 chan push $fd [list foo $fd] 553 } 554 set c [chan push [set c [tempchan]] [list foo $c]] 555 chan configure $c -buffersize 2 556 lappend res [read $c] 557} -cleanup { 558 tempdone 559 rename foo {} 560} -result {{read rt* te} {read rt* st} {read rt* { d}} {read rt* at} {read rt* {a 561}} {}} 562test iortrans-4.8.2 {chan read, bug 721ec69271} -setup { 563 set res {} 564} -match glob -body { 565 proc foo {fd args} { 566 handle.initialize 567 handle.finalize 568 lappend ::res $args 569 # Kill and recreate transform while it is operating 570 chan pop $fd 571 chan push $fd [list foo $fd] 572 return x 573 } 574 set c [chan push [set c [tempchan]] [list foo $c]] 575 chan configure $c -buffersize 1 576 lappend res [read $c] 577} -cleanup { 578 tempdone 579 rename foo {} 580} -result {{read rt* t} {read rt* e} {read rt* s} {read rt* t} {read rt* { }} {read rt* d} {read rt* a} {read rt* t} {read rt* a} {read rt* { 581}} {}} 582test iortrans-4.9 {chan read, gets, bug 2921116} -setup { 583 set res {} 584} -match glob -body { 585 proc foo {fd args} { 586 handle.initialize 587 handle.finalize 588 lappend ::res $args 589 # Kill and recreate transform while it is operating 590 chan pop $fd 591 chan push $fd [list foo $fd] 592 } 593 set c [chan push [set c [tempchan]] [list foo $c]] 594 lappend res [gets $c] 595} -cleanup { 596 tempdone 597 rename foo {} 598} -result {{read rt* {test data 599}} {}} 600 601# Driver for a base channel that emits several short "files" 602# with each terminated by a fleeting EOF 603 proc driver {cmd args} { 604 variable ::tcl::buffer 605 variable ::tcl::index 606 set chan [lindex $args 0] 607 switch -- $cmd { 608 initialize { 609 set index($chan) 0 610 set buffer($chan) ..... 611 return {initialize finalize watch read} 612 } 613 finalize { 614 if {![info exists index($chan)]} {return} 615 unset index($chan) buffer($chan) 616 array unset index 617 array unset buffer 618 return 619 } 620 watch {} 621 read { 622 set n [lindex $args 1] 623 if {![info exists index($chan)]} { 624 driver initialize $chan 625 } 626 set new [expr {$index($chan) + $n}] 627 set result [string range $buffer($chan) $index($chan) $new-1] 628 set index($chan) $new 629 if {[string length $result] == 0} { 630 driver finalize $chan 631 } 632 return $result 633 } 634 } 635 } 636 637# Channel read transform that is just the identity - pass all through 638 proc idxform {cmd handle args} { 639 switch -- $cmd { 640 initialize { 641 return {initialize finalize read} 642 } 643 finalize { 644 return 645 } 646 read { 647 lassign $args buffer 648 return $buffer 649 } 650 } 651 } 652 653# Test that all EOFs pass through full xform stack. Proper data boundaries. 654# Check robustness against buffer sizes. 655test iortrans-4.10 {[5adbc350683] chan read, handle fleeting EOF} -body { 656 set chan [chan push [chan create read driver] idxform] 657 list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \ 658 [read $chan] [eof $chan] 659} -cleanup { 660 close $chan 661} -result {0 ..... 1 {} 0 ..... 1} 662test iortrans-4.10.1 {[5adbc350683] chan read, handle fleeting EOF} -body { 663 set chan [chan push [chan create read driver] idxform] 664 chan configure $chan -buffersize 3 665 list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \ 666 [read $chan] [eof $chan] 667} -cleanup { 668 close $chan 669} -result {0 ..... 1 {} 0 ..... 1} 670test iortrans-4.10.2 {[5adbc350683] chan read, handle fleeting EOF} -body { 671 set chan [chan push [chan create read driver] idxform] 672 chan configure $chan -buffersize 5 673 list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \ 674 [read $chan] [eof $chan] 675} -cleanup { 676 close $chan 677} -result {0 ..... 1 {} 0 ..... 1} 678 679rename idxform {} 680 681# Channel read transform that delays the data and always returns something 682 proc delayxform {cmd handle args} { 683 variable store 684 switch -- $cmd { 685 initialize { 686 set store($handle) {} 687 return {initialize finalize read drain} 688 } 689 finalize { 690 unset store($handle) 691 return 692 } 693 read { 694 lassign $args buffer 695 if {$store($handle) eq {}} { 696 set reply [string index $buffer 0] 697 set store($handle) [string range $buffer 1 end] 698 } else { 699 set reply $store($handle) 700 set store($handle) $buffer 701 } 702 return $reply 703 } 704 drain { 705 delayxform read $handle {} 706 } 707 } 708 } 709 710# Test that all EOFs pass through full xform stack. Proper data boundaries. 711# Check robustness against buffer sizes. 712test iortrans-4.11 {[5adbc350683] chan read, handle fleeting EOF} -body { 713 set chan [chan push [chan create read driver] delayxform] 714 list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \ 715 [read $chan] [eof $chan] 716} -cleanup { 717 close $chan 718} -result {0 ..... 1 {} 0 ..... 1} 719test iortrans-4.11.1 {[5adbc350683] chan read, handle fleeting EOF} -body { 720 set chan [chan push [chan create read driver] delayxform] 721 chan configure $chan -buffersize 3 722 list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \ 723 [read $chan] [eof $chan] 724} -cleanup { 725 close $chan 726} -result {0 ..... 1 {} 0 ..... 1} 727test iortrans-4.11.2 {[5adbc350683] chan read, handle fleeting EOF} -body { 728 set chan [chan push [chan create read driver] delayxform] 729 chan configure $chan -buffersize 5 730 list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \ 731 [read $chan] [eof $chan] 732} -cleanup { 733 close $chan 734} -result {0 ..... 1 {} 0 ..... 1} 735 736 rename delayxform {} 737 738# Channel read transform that delays the data and may return {} 739 proc delay2xform {cmd handle args} { 740 variable store 741 switch -- $cmd { 742 initialize { 743 set store($handle) {} 744 return {initialize finalize read drain} 745 } 746 finalize { 747 unset store($handle) 748 return 749 } 750 read { 751 lassign $args buffer 752 set reply $store($handle) 753 set store($handle) $buffer 754 return $reply 755 } 756 drain { 757 delay2xform read $handle {} 758 } 759 } 760 } 761 762test iortrans-4.12 {[5adbc350683] chan read, handle fleeting EOF} -body { 763 set chan [chan push [chan create read driver] delay2xform] 764 list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \ 765 [read $chan] [eof $chan] 766} -cleanup { 767 close $chan 768} -result {0 ..... 1 {} 0 ..... 1} 769 770 rename delay2xform {} 771 rename driver {} 772 773 774# --- === *** ########################### 775# method write (via puts) 776 777test iortrans-5.1 {chan write, regular write} -setup { 778 set res {} 779} -match glob -body { 780 proc foo {args} { 781 handle.initialize 782 handle.finalize 783 lappend ::res $args 784 return transformresult 785 } 786 set c [chan push [tempchan] foo] 787 puts -nonewline $c snarf 788 flush $c 789 close $c 790 lappend res [tempview] 791} -cleanup { 792 tempdone 793 rename foo {} 794} -result {{write rt* snarf} transformresult} 795test iortrans-5.2 {chan write, no write is ok, no change to file} -setup { 796 set res {} 797} -match glob -body { 798 proc foo {args} { 799 handle.initialize 800 handle.finalize 801 lappend ::res $args 802 return 803 } 804 set c [chan push [tempchan] foo] 805 puts -nonewline $c snarfsnarfsnarf 806 flush $c 807 close $c 808 lappend res [tempview]; # This has to show the original data, as nothing was written 809} -cleanup { 810 tempdone 811 rename foo {} 812} -result {{write rt* snarfsnarfsnarf} {test data}} 813test iortrans-5.3 {chan write, failed write} -setup { 814 set res {} 815} -match glob -body { 816 proc foo {args} { 817 handle.initialize 818 handle.finalize 819 lappend ::res $args 820 return -code error FAIL! 821 } 822 set c [chan push [tempchan] foo] 823 puts -nonewline $c snarfsnarfsnarf 824 lappend res [catch {flush $c} msg] $msg 825} -cleanup { 826 tempdone 827 rename foo {} 828} -result {{write rt* snarfsnarfsnarf} 1 FAIL!} 829test iortrans-5.4 {chan write, non-writable channel} -setup { 830 set res {} 831} -match glob -body { 832 proc foo {args} { 833 handle.initialize 834 handle.finalize 835 lappend ::res $args MUST_NOT_HAPPEN 836 return 837 } 838 set c [chan push [tempchan r] foo] 839 lappend res [catch { 840 puts -nonewline $c snarfsnarfsnarf 841 flush $c 842 } msg] $msg 843} -cleanup { 844 close $c 845 tempdone 846 rename foo {} 847} -result {1 {channel "file*" wasn't opened for writing}} 848test iortrans-5.5 {chan write, failed write, error return} -setup { 849 set res {} 850} -match glob -body { 851 proc foo {args} { 852 handle.initialize 853 handle.finalize 854 lappend ::res $args 855 return -code error BOOM! 856 } 857 set c [chan push [tempchan] foo] 858 lappend res [catch { 859 puts -nonewline $c snarfsnarfsnarf 860 flush $c 861 } msg] $msg 862} -cleanup { 863 tempdone 864 rename foo {} 865} -result {{write rt* snarfsnarfsnarf} 1 BOOM!} 866test iortrans-5.6 {chan write, failed write, error return} -setup { 867 set res {} 868} -match glob -body { 869 proc foo {args} { 870 handle.initialize 871 handle.finalize 872 lappend ::res $args 873 error BOOM! 874 } 875 set c [chan push [tempchan] foo] 876 lappend res {*}[catch { 877 puts -nonewline $c snarfsnarfsnarf 878 flush $c 879 } msg] $msg 880} -cleanup { 881 tempdone 882 rename foo {} 883} -result {{write rt* snarfsnarfsnarf} 1 BOOM!} 884test iortrans-5.7 {chan write, failed write, break return is error} -setup { 885 set res {} 886} -match glob -body { 887 proc foo {args} { 888 handle.initialize 889 handle.finalize 890 lappend ::res $args 891 return -code break BOOM! 892 } 893 set c [chan push [tempchan] foo] 894 lappend res [catch { 895 puts -nonewline $c snarfsnarfsnarf 896 flush $c 897 } msg] $msg 898} -cleanup { 899 tempdone 900 rename foo {} 901} -result {{write rt* snarfsnarfsnarf} 1 *bad code*} 902test iortrans-5.8 {chan write, failed write, continue return is error} -setup { 903 set res {} 904} -match glob -body { 905 proc foo {args} { 906 handle.initialize 907 handle.finalize 908 lappend ::res $args 909 return -code continue BOOM! 910 } 911 set c [chan push [tempchan] foo] 912 lappend res [catch { 913 puts -nonewline $c snarfsnarfsnarf 914 flush $c 915 } msg] $msg 916} -cleanup { 917 tempdone 918 rename foo {} 919} -result {{write rt* snarfsnarfsnarf} 1 *bad code*} 920test iortrans-5.9 {chan write, failed write, custom return is error} -setup { 921 set res {} 922} -match glob -body { 923 proc foo {args} { 924 handle.initialize 925 handle.finalize 926 lappend ::res $args 927 return -code 777 BOOM! 928 } 929 set c [chan push [tempchan] foo] 930 lappend res [catch { 931 puts -nonewline $c snarfsnarfsnarf 932 flush $c 933 } msg] $msg 934} -cleanup { 935 tempdone 936 rename foo {} 937} -result {{write rt* snarfsnarfsnarf} 1 *bad code*} 938test iortrans-5.10 {chan write, failed write, level is ignored} -setup { 939 set res {} 940} -match glob -body { 941 proc foo {args} { 942 handle.initialize 943 handle.finalize 944 lappend ::res $args 945 return -level 55 -code 777 BOOM! 946 } 947 set c [chan push [tempchan] foo] 948 lappend res [catch { 949 puts -nonewline $c snarfsnarfsnarf 950 flush $c 951 } msg opt] $msg 952 noteOpts $opt 953} -cleanup { 954 tempdone 955 rename foo {} 956} -result {{write rt* snarfsnarfsnarf} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline * -errorinfo *bad code*subcommand "write"*}} 957test iortrans-5.11 {chan write, bug 2921116} -match glob -setup { 958 set res {} 959 set level 0 960} -body { 961 proc foo {fd args} { 962 handle.initialize 963 handle.finalize 964 lappend ::res $args 965 # pop - invokes flush - invokes 'foo write' - infinite recursion - stop it 966 global level 967 if {$level} { 968 return 969 } 970 incr level 971 # Kill and recreate transform while it is operating 972 chan pop $fd 973 chan push $fd [list foo $fd] 974 } 975 set c [chan push [set c [tempchan]] [list foo $c]] 976 lappend res [puts -nonewline $c abcdef] 977 lappend res [flush $c] 978} -cleanup { 979 tempdone 980 rename foo {} 981} -result {{} {write rt* abcdef} {write rt* abcdef} {}} 982 983# --- === *** ########################### 984# method limit?, drain (via read) 985 986test iortrans-6.1 {chan read, read limits} -setup { 987 set res {} 988} -match glob -body { 989 proc foo {args} { 990 handle.initialize limit? 991 handle.finalize 992 lappend ::res $args 993 handle.read 994 return 6 995 } 996 set c [chan push [tempchan] foo] 997 lappend res [read $c 10] 998} -cleanup { 999 tempdone 1000 rename foo {} 1001} -result {{limit? rt*} {read rt* {test d}} {limit? rt*} {read rt* {ata 1002}} {limit? rt*} @@} 1003test iortrans-6.2 {chan read, read transform drain on eof} -setup { 1004 set res {} 1005} -match glob -body { 1006 proc foo {args} { 1007 handle.initialize drain 1008 handle.finalize 1009 lappend ::res $args 1010 handle.read 1011 handle.drain 1012 return 1013 } 1014 set c [chan push [tempchan] foo] 1015 lappend res [read $c] 1016 lappend res [close $c] 1017} -cleanup { 1018 tempdone 1019 rename foo {} 1020} -result {{read rt* {test data 1021}} {drain rt*} @<> {}} 1022 1023# --- === *** ########################### 1024# method clear (via puts, seek) 1025 1026test iortrans-7.1 {chan write, write clears read buffers} -setup { 1027 set res {} 1028} -match glob -body { 1029 proc foo {args} { 1030 handle.initialize clear 1031 handle.finalize 1032 lappend ::res $args 1033 handle.clear 1034 return transformresult 1035 } 1036 set c [chan push [tempchan] foo] 1037 puts -nonewline $c snarf 1038 flush $c 1039 return $res 1040} -cleanup { 1041 tempdone 1042 rename foo {} 1043} -result {{clear rt*} {write rt* snarf}} 1044test iortrans-7.2 {seek clears read buffers} -setup { 1045 set res {} 1046} -match glob -body { 1047 proc foo {args} { 1048 handle.initialize clear 1049 handle.finalize 1050 lappend ::res $args 1051 return 1052 } 1053 set c [chan push [tempchan] foo] 1054 seek $c 2 1055 return $res 1056} -cleanup { 1057 tempdone 1058 rename foo {} 1059} -result {{clear rt*}} 1060test iortrans-7.3 {clear, any result is ignored} -setup { 1061 set res {} 1062} -match glob -body { 1063 proc foo {args} { 1064 handle.initialize clear 1065 handle.finalize 1066 lappend ::res $args 1067 return -code error "X" 1068 } 1069 set c [chan push [tempchan] foo] 1070 seek $c 2 1071 return $res 1072} -cleanup { 1073 tempdone 1074 rename foo {} 1075} -result {{clear rt*}} 1076test iortrans-7.4 {chan clear, bug 2921116} -match glob -setup { 1077 set res {} 1078} -body { 1079 proc foo {fd args} { 1080 handle.initialize clear 1081 handle.finalize 1082 lappend ::res $args 1083 # Kill and recreate transform while it is operating 1084 chan pop $fd 1085 chan push $fd [list foo $fd] 1086 } 1087 set c [chan push [set c [tempchan]] [list foo $c]] 1088 seek $c 2 1089 return $res 1090} -cleanup { 1091 tempdone 1092 rename foo {} 1093} -result {{clear rt*}} 1094 1095# --- === *** ########################### 1096# method flush (via seek, close) 1097 1098test iortrans-8.1 {seek flushes write buffers, ignores data} -setup { 1099 set res {} 1100} -match glob -body { 1101 proc foo {args} { 1102 handle.initialize flush 1103 handle.finalize 1104 lappend ::res $args 1105 return X 1106 } 1107 set c [chan push [tempchan] foo] 1108 # Flush, no writing 1109 seek $c 2 1110 # The close flushes again, this modifies the file! 1111 lappend res | 1112 lappend res [close $c] | [tempview] 1113} -cleanup { 1114 tempdone 1115 rename foo {} 1116} -result {{flush rt*} | {flush rt*} {} | {teXt data}} 1117test iortrans-8.2 {close flushes write buffers, writes data} -setup { 1118 set res {} 1119} -match glob -body { 1120 proc foo {args} { 1121 handle.initialize flush 1122 lappend ::res $args 1123 handle.finalize 1124 return .flushed. 1125 } 1126 set c [chan push [tempchan] foo] 1127 close $c 1128 lappend res [tempview] 1129} -cleanup { 1130 tempdone 1131 rename foo {} 1132} -result {{flush rt*} {finalize rt*} .flushed.} 1133test iortrans-8.3 {chan flush, bug 2921116} -match glob -setup { 1134 set res {} 1135} -body { 1136 proc foo {fd args} { 1137 handle.initialize flush 1138 handle.finalize 1139 lappend ::res $args 1140 # Kill and recreate transform while it is operating 1141 chan pop $fd 1142 chan push $fd [list foo $fd] 1143 } 1144 set c [chan push [set c [tempchan]] [list foo $c]] 1145 seek $c 2 1146 set res 1147} -cleanup { 1148 tempdone 1149 rename foo {} 1150} -result {{flush rt*}} 1151 1152# --- === *** ########################### 1153# method watch - removed from TIP (rev 1.12+) 1154 1155# --- === *** ########################### 1156# method event - removed from TIP (rev 1.12+) 1157 1158# --- === *** ########################### 1159# 'Pull the rug' tests. Create channel in a interpreter A, move to other 1160# interpreter B, destroy the origin interpreter (A) before or during access 1161# from B. Must not crash, must return proper errors. 1162test iortrans-11.0 {origin interpreter of moved transform gone} -setup { 1163 set ida [interp create]; #puts <<$ida>> 1164 set idb [interp create]; #puts <<$idb>> 1165 # Magic to get the test* commands in the children 1166 load {} Tcltest $ida 1167 load {} Tcltest $idb 1168} -constraints {testchannel} -match glob -body { 1169 # Set up channel and transform in interpreter 1170 interp eval $ida $helperscript 1171 interp eval $ida [list ::variable tempchan [tempchan]] 1172 interp transfer {} $::tempchan $ida 1173 set chan [interp eval $ida { 1174 variable tempchan 1175 proc foo {args} { 1176 handle.initialize clear drain flush limit? read write 1177 handle.finalize 1178 lappend ::res $args 1179 return 1180 } 1181 set chan [chan push $tempchan foo] 1182 fconfigure $chan -buffering none 1183 set chan 1184 }] 1185 # Move channel to 2nd interpreter, transform goes with it. 1186 interp eval $ida [list testchannel cut $chan] 1187 interp eval $idb [list testchannel splice $chan] 1188 # Kill origin interpreter, then access channel from 2nd interpreter. 1189 interp delete $ida 1190 set res {} 1191 lappend res \ 1192 [catch {interp eval $idb [list puts $chan shoo]} msg] $msg \ 1193 [catch {interp eval $idb [list tell $chan]} msg] $msg \ 1194 [catch {interp eval $idb [list seek $chan 1]} msg] $msg \ 1195 [catch {interp eval $idb [list gets $chan]} msg] $msg \ 1196 [catch {interp eval $idb [list close $chan]} msg] $msg 1197 #lappend res [interp eval $ida {set res}] 1198 # actions: clear|write|clear|write|clear|flush|limit?|drain|flush 1199 # The 'tell' is ok, as it passed through the transform to the base channel 1200 # without invoking the transform handler. 1201} -cleanup { 1202 tempdone 1203 interp delete $idb 1204} -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}} 1205test iortrans-11.1 {origin interpreter of moved transform destroyed during access} -setup { 1206 set ida [interp create]; #puts <<$ida>> 1207 set idb [interp create]; #puts <<$idb>> 1208 # Magic to get the test* commands in the children 1209 load {} Tcltest $ida 1210 load {} Tcltest $idb 1211} -constraints {testchannel} -match glob -body { 1212 # Set up channel in thread 1213 set chan [interp eval $ida $helperscript] 1214 interp eval $ida [list ::variable tempchan [tempchan]] 1215 interp transfer {} $::tempchan $ida 1216 set chan [interp eval $ida { 1217 proc foo {args} { 1218 handle.initialize clear drain flush limit? read write 1219 handle.finalize 1220 lappend ::res $args 1221 # Destroy interpreter during channel access. 1222 suicide 1223 } 1224 set chan [chan push $tempchan foo] 1225 fconfigure $chan -buffering none 1226 set chan 1227 }] 1228 interp alias $ida suicide {} interp delete $ida 1229 # Move channel to 2nd thread, transform goes with it. 1230 interp eval $ida [list testchannel cut $chan] 1231 interp eval $idb [list testchannel splice $chan] 1232 # Run access from interpreter B, this will give us a synchronous response. 1233 interp eval $idb [list set chan $chan] 1234 interp eval $idb [list set mid $tcltest::mainThread] 1235 set res [interp eval $idb { 1236 # Wait a bit, give the main thread the time to start its event loop to 1237 # wait for the response from B 1238 after 50 1239 catch { puts $chan shoo } res 1240 set res 1241 }] 1242} -cleanup { 1243 interp delete $idb 1244 tempdone 1245} -result {Owner lost} 1246test iortrans-11.2 {delete interp of reflected transform} -setup { 1247 interp create child 1248 # Magic to get the test* commands into the child 1249 load {} Tcltest child 1250} -constraints {testchannel} -body { 1251 # Get base channel into the child 1252 set c [tempchan] 1253 testchannel cut $c 1254 interp eval child [list testchannel splice $c] 1255 interp eval child [list set c $c] 1256 child eval { 1257 proc no-op args {} 1258 proc driver {c sub args} { 1259 return {initialize finalize read write} 1260 } 1261 set t [chan push $c [list driver $c]] 1262 chan event $c readable no-op 1263 } 1264 interp delete child 1265} -cleanup { 1266 tempdone 1267} -result {} 1268 1269# ### ### ### ######### ######### ######### 1270## Same tests as above, but exercising the code forwarding and receiving 1271## driver operations to the originator thread. 1272 1273# ### ### ### ######### ######### ######### 1274## Testing the reflected channel (Thread forwarding). 1275# 1276## The id numbers refer to the original test without thread forwarding, and 1277## gaps due to tests not applicable to forwarding are left to keep this 1278## association. 1279 1280# ### ### ### ######### ######### ######### 1281## Helper command. Runs a script in a separate thread and returns the result. 1282## A channel is transfered into the thread as well, and a list of configuation 1283## variables 1284 1285proc inthread {chan script args} { 1286 # Test thread. 1287 set tid [thread::create -preserved] 1288 thread::send $tid {load {} Tcltest} 1289 1290 # Init thread configuration. 1291 # - Listed variables 1292 # - Id of main thread 1293 # - A number of helper commands 1294 1295 foreach v $args { 1296 upvar 1 $v x 1297 thread::send $tid [list set $v $x] 1298 } 1299 thread::send $tid [list set mid [thread::id]] 1300 thread::send $tid { 1301 proc notes {} { 1302 return $::notes 1303 } 1304 proc noteOpts opts { 1305 lappend ::notes [dict merge { 1306 -code !?! -level !?! -errorcode !?! -errorline !?! 1307 -errorinfo !?! -errorstack !?! 1308 } $opts] 1309 } 1310 } 1311 thread::send $tid [list proc s {} [list uplevel 1 $script]]; # (*) 1312 1313 # Transfer channel (cut/splice aka detach/attach) 1314 1315 testchannel cut $chan 1316 thread::send $tid [list testchannel splice $chan] 1317 1318 # Run test script, also run local event loop! The local event loop waits 1319 # for the result to come back. It is also necessary for the execution of 1320 # forwarded channel operations. 1321 1322 set ::tres "" 1323 thread::send -async $tid { 1324 after 50 1325 catch {s} res; # This runs the script, 's' was defined at (*) 1326 thread::send -async $mid [list set ::tres $res] 1327 } 1328 vwait ::tres 1329 # Remove test thread, and return the captured result. 1330 1331 thread::release $tid 1332 return $::tres 1333} 1334 1335# ### ### ### ######### ######### ######### 1336 1337test iortrans.tf-3.2 {chan finalize, for close} -setup { 1338 set res {} 1339} -constraints {testchannel thread} -match glob -body { 1340 proc foo {args} { 1341 lappend ::res $args 1342 handle.initialize 1343 return {} 1344 } 1345 lappend res [set c [chan push [tempchan] foo]] 1346 lappend res [inthread $c { 1347 close $c 1348 # Close the deleted the channel. 1349 file channels rt* 1350 } c] 1351 # Channel destruction does not kill handler command! 1352 lappend res [info command foo] 1353} -cleanup { 1354 rename foo {} 1355} -result {{initialize rt* {read write}} file* {finalize rt*} {} foo} 1356test iortrans.tf-3.3 {chan finalize, for close, error, close error} -setup { 1357 set res {} 1358} -constraints {testchannel thread} -match glob -body { 1359 proc foo {args} { 1360 lappend ::res $args 1361 handle.initialize 1362 return -code error 5 1363 } 1364 lappend res [set c [chan push [tempchan] foo]] 1365 lappend res {*}[inthread $c { 1366 lappend notes [catch {close $c} msg] $msg 1367 # Channel is gone despite error. 1368 lappend notes [file channels rt*] 1369 notes 1370 } c] 1371} -cleanup { 1372 rename foo {} 1373} -result {{initialize rt* {read write}} file* {finalize rt*} 1 5 {}} 1374test iortrans.tf-3.4 {chan finalize, for close, error, close errror} -setup { 1375 set res {} 1376} -constraints {testchannel thread} -body { 1377 proc foo {args} { 1378 lappend ::res $args 1379 handle.initialize 1380 error FOO 1381 } 1382 lappend res [set c [chan push [tempchan] foo]] 1383 lappend res {*}[inthread $c { 1384 lappend notes [catch {close $c} msg] $msg 1385 notes 1386 } c] 1387} -match glob -cleanup { 1388 rename foo {} 1389} -result {{initialize rt* {read write}} file* {finalize rt*} 1 FOO} 1390test iortrans.tf-3.5 {chan finalize, for close, arbitrary result} -setup { 1391 set res {} 1392} -constraints {testchannel thread} -match glob -body { 1393 proc foo {args} { 1394 lappend ::res $args 1395 handle.initialize 1396 return SOMETHING 1397 } 1398 lappend res [set c [chan push [tempchan] foo]] 1399 lappend res {*}[inthread $c { 1400 lappend notes [catch {close $c} msg] $msg 1401 notes 1402 } c] 1403} -cleanup { 1404 rename foo {} 1405} -result {{initialize rt* {read write}} file* {finalize rt*} 0 {}} 1406test iortrans.tf-3.6 {chan finalize, for close, break, close error} -setup { 1407 set res {} 1408} -constraints {testchannel thread} -match glob -body { 1409 proc foo {args} { 1410 lappend ::res $args 1411 handle.initialize 1412 return -code 3 1413 } 1414 lappend res [set c [chan push [tempchan] foo]] 1415 lappend res {*}[inthread $c { 1416 lappend notes [catch {close $c} msg] $msg 1417 notes 1418 } c] 1419} -cleanup { 1420 rename foo {} 1421} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} 1422test iortrans.tf-3.7 {chan finalize, for close, continue, close error} -setup { 1423 set res {} 1424} -constraints {testchannel thread} -match glob -body { 1425 proc foo {args} { 1426 lappend ::res $args 1427 handle.initialize 1428 return -code 4 1429 } 1430 lappend res [set c [chan push [tempchan] foo]] 1431 lappend res {*}[inthread $c { 1432 lappend notes [catch {close $c} msg] $msg 1433 notes 1434 } c] 1435} -cleanup { 1436 rename foo {} 1437} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} 1438test iortrans.tf-3.8 {chan finalize, for close, custom code, close error} -setup { 1439 set res {} 1440} -constraints {testchannel thread} -match glob -body { 1441 proc foo {args} { 1442 lappend ::res $args 1443 handle.initialize 1444 return -code 777 BANG 1445 } 1446 lappend res [set c [chan push [tempchan] foo]] 1447 lappend res {*}[inthread $c { 1448 lappend notes [catch {close $c} msg] $msg 1449 notes 1450 } c] 1451} -cleanup { 1452 rename foo {} 1453} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} 1454test iortrans.tf-3.9 {chan finalize, for close, ignore level, close error} -setup { 1455 set res {} 1456} -constraints {testchannel thread} -match glob -body { 1457 proc foo {args} { 1458 lappend ::res $args 1459 handle.initialize 1460 return -level 5 -code 777 BANG 1461 } 1462 lappend res [set c [chan push [tempchan] foo]] 1463 lappend res {*}[inthread $c { 1464 lappend notes [catch {close $c} msg opt] $msg 1465 noteOpts $opt 1466 notes 1467 } c] 1468} -cleanup { 1469 rename foo {} 1470} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "finalize"*}} 1471 1472# --- === *** ########################### 1473# method read 1474 1475test iortrans.tf-4.1 {chan read, transform call and return} -setup { 1476 set res {} 1477} -constraints {testchannel thread} -body { 1478 proc foo {args} { 1479 handle.initialize 1480 handle.finalize 1481 lappend ::res $args 1482 return snarf 1483 } 1484 set c [chan push [tempchan] foo] 1485 lappend res {*}[inthread $c { 1486 lappend notes [read $c 10] 1487 close $c 1488 notes 1489 } c] 1490} -cleanup { 1491 tempdone 1492 rename foo {} 1493} -match glob -result {{read rt* {test data 1494}} snarf} 1495test iortrans.tf-4.2 {chan read, for non-readable channel} -setup { 1496 set res {} 1497} -constraints {testchannel thread} -body { 1498 proc foo {args} { 1499 handle.initialize 1500 handle.finalize 1501 lappend ::res $args MUST_NOT_HAPPEN 1502 } 1503 set c [chan push [tempchan w] foo] 1504 lappend res {*}[inthread $c { 1505 lappend notes [catch {[read $c 2]} msg] $msg 1506 close $c 1507 notes 1508 } c] 1509} -cleanup { 1510 tempdone 1511 rename foo {} 1512} -match glob -result {1 {channel "file*" wasn't opened for reading}} 1513test iortrans.tf-4.3 {chan read, error return} -setup { 1514 set res {} 1515} -constraints {testchannel thread} -body { 1516 proc foo {args} { 1517 handle.initialize 1518 handle.finalize 1519 lappend ::res $args 1520 return -code error BOOM! 1521 } 1522 set c [chan push [tempchan] foo] 1523 lappend res {*}[inthread $c { 1524 lappend notes [catch {read $c 2} msg] $msg 1525 close $c 1526 notes 1527 } c] 1528} -cleanup { 1529 tempdone 1530 rename foo {} 1531} -match glob -result {{read rt* {test data 1532}} 1 BOOM!} 1533test iortrans.tf-4.4 {chan read, break return is error} -setup { 1534 set res {} 1535} -constraints {testchannel thread} -body { 1536 proc foo {args} { 1537 handle.initialize 1538 handle.finalize 1539 lappend ::res $args 1540 return -code break BOOM! 1541 } 1542 set c [chan push [tempchan] foo] 1543 lappend res {*}[inthread $c { 1544 lappend notes [catch {read $c 2} msg] $msg 1545 close $c 1546 notes 1547 } c] 1548} -cleanup { 1549 tempdone 1550 rename foo {} 1551} -match glob -result {{read rt* {test data 1552}} 1 *bad code*} 1553test iortrans.tf-4.5 {chan read, continue return is error} -setup { 1554 set res {} 1555} -constraints {testchannel thread} -body { 1556 proc foo {args} { 1557 handle.initialize 1558 handle.finalize 1559 lappend ::res $args 1560 return -code continue BOOM! 1561 } 1562 set c [chan push [tempchan] foo] 1563 lappend res {*}[inthread $c { 1564 lappend notes [catch {read $c 2} msg] $msg 1565 close $c 1566 notes 1567 } c] 1568} -cleanup { 1569 tempdone 1570 rename foo {} 1571} -match glob -result {{read rt* {test data 1572}} 1 *bad code*} 1573test iortrans.tf-4.6 {chan read, custom return is error} -setup { 1574 set res {} 1575} -constraints {testchannel thread} -body { 1576 proc foo {args} { 1577 handle.initialize 1578 handle.finalize 1579 lappend ::res $args 1580 return -code 777 BOOM! 1581 } 1582 set c [chan push [tempchan] foo] 1583 lappend res {*}[inthread $c { 1584 lappend notes [catch {read $c 2} msg] $msg 1585 close $c 1586 notes 1587 } c] 1588} -cleanup { 1589 tempdone 1590 rename foo {} 1591} -match glob -result {{read rt* {test data 1592}} 1 *bad code*} 1593test iortrans.tf-4.7 {chan read, level is squashed} -setup { 1594 set res {} 1595} -constraints {testchannel thread} -body { 1596 proc foo {args} { 1597 handle.initialize 1598 handle.finalize 1599 lappend ::res $args 1600 return -level 55 -code 777 BOOM! 1601 } 1602 set c [chan push [tempchan] foo] 1603 lappend res {*}[inthread $c { 1604 lappend notes [catch {read $c 2} msg opt] $msg 1605 noteOpts $opt 1606 close $c 1607 notes 1608 } c] 1609} -cleanup { 1610 tempdone 1611 rename foo {} 1612} -match glob -result {{read rt* {test data 1613}} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}} 1614 1615# --- === *** ########################### 1616# method write 1617 1618test iortrans.tf-5.1 {chan write, regular write} -setup { 1619 set res {} 1620} -constraints {testchannel thread} -match glob -body { 1621 proc foo {args} { 1622 handle.initialize 1623 handle.finalize 1624 lappend ::res $args 1625 return transformresult 1626 } 1627 set c [chan push [tempchan] foo] 1628 inthread $c { 1629 puts -nonewline $c snarf 1630 flush $c 1631 close $c 1632 } c 1633 lappend res [tempview] 1634} -cleanup { 1635 tempdone 1636 rename foo {} 1637} -result {{write rt* snarf} transformresult} 1638test iortrans.tf-5.2 {chan write, no write is ok, no change to file} -setup { 1639 set res {} 1640} -constraints {testchannel thread} -match glob -body { 1641 proc foo {args} { 1642 handle.initialize 1643 handle.finalize 1644 lappend ::res $args 1645 return 1646 } 1647 set c [chan push [tempchan] foo] 1648 inthread $c { 1649 puts -nonewline $c snarfsnarfsnarf 1650 flush $c 1651 close $c 1652 } c 1653 lappend res [tempview]; # This has to show the original data, as nothing was written 1654} -cleanup { 1655 tempdone 1656 rename foo {} 1657} -result {{write rt* snarfsnarfsnarf} {test data}} 1658test iortrans.tf-5.3 {chan write, failed write} -setup { 1659 set res {} 1660} -constraints {testchannel thread} -match glob -body { 1661 proc foo {args} { 1662 handle.initialize 1663 handle.finalize 1664 lappend ::res $args 1665 return -code error FAIL! 1666 } 1667 set c [chan push [tempchan] foo] 1668 lappend res {*}[inthread $c { 1669 puts -nonewline $c snarfsnarfsnarf 1670 lappend notes [catch {flush $c} msg] $msg 1671 close $c 1672 notes 1673 } c] 1674} -cleanup { 1675 tempdone 1676 rename foo {} 1677} -result {{write rt* snarfsnarfsnarf} 1 FAIL!} 1678test iortrans.tf-5.4 {chan write, non-writable channel} -setup { 1679 set res {} 1680} -constraints {testchannel thread} -match glob -body { 1681 proc foo {args} { 1682 handle.initialize 1683 handle.finalize 1684 lappend ::res $args MUST_NOT_HAPPEN 1685 return 1686 } 1687 set c [chan push [tempchan r] foo] 1688 lappend res {*}[inthread $c { 1689 lappend notes [catch { 1690 puts -nonewline $c snarfsnarfsnarf 1691 flush $c 1692 } msg] $msg 1693 close $c 1694 notes 1695 } c] 1696} -cleanup { 1697 tempdone 1698 rename foo {} 1699} -result {1 {channel "file*" wasn't opened for writing}} 1700test iortrans.tf-5.5 {chan write, failed write, error return} -setup { 1701 set res {} 1702} -constraints {testchannel thread} -match glob -body { 1703 proc foo {args} { 1704 handle.initialize 1705 handle.finalize 1706 lappend ::res $args 1707 return -code error BOOM! 1708 } 1709 set c [chan push [tempchan] foo] 1710 lappend res {*}[inthread $c { 1711 lappend notes [catch { 1712 puts -nonewline $c snarfsnarfsnarf 1713 flush $c 1714 } msg] $msg 1715 close $c 1716 notes 1717 } c] 1718} -cleanup { 1719 tempdone 1720 rename foo {} 1721} -result {{write rt* snarfsnarfsnarf} 1 BOOM!} 1722test iortrans.tf-5.6 {chan write, failed write, error return} -setup { 1723 set res {} 1724} -constraints {testchannel thread} -match glob -body { 1725 proc foo {args} { 1726 handle.initialize 1727 handle.finalize 1728 lappend ::res $args 1729 error BOOM! 1730 } 1731 set c [chan push [tempchan] foo] 1732 lappend res {*}[inthread $c { 1733 lappend notes [catch { 1734 puts -nonewline $c snarfsnarfsnarf 1735 flush $c 1736 } msg] $msg 1737 close $c 1738 notes 1739 } c] 1740} -cleanup { 1741 tempdone 1742 rename foo {} 1743} -result {{write rt* snarfsnarfsnarf} 1 BOOM!} 1744test iortrans.tf-5.7 {chan write, failed write, break return is error} -setup { 1745 set res {} 1746} -constraints {testchannel thread} -match glob -body { 1747 proc foo {args} { 1748 handle.initialize 1749 handle.finalize 1750 lappend ::res $args 1751 return -code break BOOM! 1752 } 1753 set c [chan push [tempchan] foo] 1754 lappend res {*}[inthread $c { 1755 lappend notes [catch { 1756 puts -nonewline $c snarfsnarfsnarf 1757 flush $c 1758 } msg] $msg 1759 close $c 1760 notes 1761 } c] 1762} -cleanup { 1763 tempdone 1764 rename foo {} 1765} -result {{write rt* snarfsnarfsnarf} 1 *bad code*} 1766test iortrans.tf-5.8 {chan write, failed write, continue return is error} -setup { 1767 set res {} 1768} -constraints {testchannel thread} -match glob -body { 1769 proc foo {args} { 1770 handle.initialize 1771 handle.finalize 1772 lappend ::res $args 1773 return -code continue BOOM! 1774 } 1775 set c [chan push [tempchan] foo] 1776 lappend res {*}[inthread $c { 1777 lappend notes [catch { 1778 puts -nonewline $c snarfsnarfsnarf 1779 flush $c 1780 } msg] $msg 1781 close $c 1782 notes 1783 } c] 1784} -cleanup { 1785 rename foo {} 1786} -result {{write rt* snarfsnarfsnarf} 1 *bad code*} 1787test iortrans.tf-5.9 {chan write, failed write, custom return is error} -setup { 1788 set res {} 1789} -constraints {testchannel thread} -body { 1790 proc foo {args} { 1791 handle.initialize 1792 handle.finalize 1793 lappend ::res $args 1794 return -code 777 BOOM! 1795 } 1796 set c [chan push [tempchan] foo] 1797 lappend res {*}[inthread $c { 1798 lappend notes [catch { 1799 puts -nonewline $c snarfsnarfsnarf 1800 flush $c 1801 } msg] $msg 1802 close $c 1803 notes 1804 } c] 1805} -cleanup { 1806 tempdone 1807 rename foo {} 1808} -match glob -result {{write rt* snarfsnarfsnarf} 1 *bad code*} 1809test iortrans.tf-5.10 {chan write, failed write, level is ignored} -setup { 1810 set res {} 1811} -constraints {testchannel thread} -match glob -body { 1812 proc foo {args} { 1813 handle.initialize 1814 handle.finalize 1815 lappend ::res $args 1816 return -level 55 -code 777 BOOM! 1817 } 1818 set c [chan push [tempchan] foo] 1819 lappend res {*}[inthread $c { 1820 lappend notes [catch { 1821 puts -nonewline $c snarfsnarfsnarf 1822 flush $c 1823 } msg opt] $msg 1824 noteOpts $opt 1825 close $c 1826 notes 1827 } c] 1828} -cleanup { 1829 tempdone 1830 rename foo {} 1831} -result {{write rt* snarfsnarfsnarf} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline * -errorinfo *bad code*subcommand "write"*}} 1832 1833# --- === *** ########################### 1834# method limit?, drain (via read) 1835 1836test iortrans.tf-6.1 {chan read, read limits} -setup { 1837 set res {} 1838} -constraints {testchannel thread} -match glob -body { 1839 proc foo {args} { 1840 handle.initialize limit? 1841 handle.finalize 1842 lappend ::res $args 1843 handle.read 1844 return 6 1845 } 1846 set c [chan push [tempchan] foo] 1847 lappend res {*}[inthread $c { 1848 lappend notes [read $c 10] 1849 close $c 1850 notes 1851 } c] 1852} -cleanup { 1853 tempdone 1854 rename foo {} 1855} -result {{limit? rt*} {read rt* {test d}} {limit? rt*} {read rt* {ata 1856}} {limit? rt*} @@} 1857test iortrans.tf-6.2 {chan read, read transform drain on eof} -setup { 1858 set res {} 1859} -constraints {testchannel thread} -match glob -body { 1860 proc foo {args} { 1861 handle.initialize drain 1862 handle.finalize 1863 lappend ::res $args 1864 handle.read 1865 handle.drain 1866 return 1867 } 1868 set c [chan push [tempchan] foo] 1869 lappend res {*}[inthread $c { 1870 lappend notes [read $c] 1871 lappend notes [close $c] 1872 } c] 1873} -cleanup { 1874 tempdone 1875 rename foo {} 1876} -result {{read rt* {test data 1877}} {drain rt*} @<> {}} 1878 1879# --- === *** ########################### 1880# method clear (via puts, seek) 1881 1882test iortrans.tf-7.1 {chan write, write clears read buffers} -setup { 1883 set res {} 1884} -constraints {testchannel thread} -match glob -body { 1885 proc foo {args} { 1886 handle.initialize clear 1887 handle.finalize 1888 lappend ::res $args 1889 handle.clear 1890 return transformresult 1891 } 1892 set c [chan push [tempchan] foo] 1893 inthread $c { 1894 puts -nonewline $c snarf 1895 flush $c 1896 close $c 1897 } c 1898 return $res 1899} -cleanup { 1900 tempdone 1901 rename foo {} 1902} -result {{clear rt*} {write rt* snarf}} 1903test iortrans.tf-7.2 {seek clears read buffers} -setup { 1904 set res {} 1905} -constraints {testchannel thread} -match glob -body { 1906 proc foo {args} { 1907 handle.initialize clear 1908 handle.finalize 1909 lappend ::res $args 1910 return 1911 } 1912 set c [chan push [tempchan] foo] 1913 inthread $c { 1914 seek $c 2 1915 close $c 1916 } c 1917 return $res 1918} -cleanup { 1919 tempdone 1920 rename foo {} 1921} -result {{clear rt*}} 1922test iortrans.tf-7.3 {clear, any result is ignored} -setup { 1923 set res {} 1924} -constraints {testchannel thread} -match glob -body { 1925 proc foo {args} { 1926 handle.initialize clear 1927 handle.finalize 1928 lappend ::res $args 1929 return -code error "X" 1930 } 1931 set c [chan push [tempchan] foo] 1932 inthread $c { 1933 seek $c 2 1934 close $c 1935 } c 1936 return $res 1937} -cleanup { 1938 tempdone 1939 rename foo {} 1940} -result {{clear rt*}} 1941 1942# --- === *** ########################### 1943# method flush (via seek, close) 1944 1945test iortrans.tf-8.1 {seek flushes write buffers, ignores data} -setup { 1946 set res {} 1947} -constraints {testchannel thread} -match glob -body { 1948 proc foo {args} { 1949 handle.initialize flush 1950 handle.finalize 1951 lappend ::res $args 1952 return X 1953 } 1954 set c [chan push [tempchan] foo] 1955 lappend res {*}[inthread $c { 1956 # Flush, no writing 1957 seek $c 2 1958 # The close flushes again, this modifies the file! 1959 lappend notes | [close $c] | 1960 # NOTE: The flush generated by the close is recorded immediately, the 1961 # other note's here are defered until after the thread is done. This 1962 # changes the order of the result a bit from the non-threaded case 1963 # (The first | moves one to the right). This is an artifact of the 1964 # 'inthread' framework, not of the transformation itself. 1965 notes 1966 } c] 1967 lappend res [tempview] 1968} -cleanup { 1969 tempdone 1970 rename foo {} 1971} -result {{flush rt*} {flush rt*} | {} | {teXt data}} 1972test iortrans.tf-8.2 {close flushes write buffers, writes data} -setup { 1973 set res {} 1974} -constraints {testchannel thread} -match glob -body { 1975 proc foo {args} { 1976 handle.initialize flush 1977 lappend ::res $args 1978 handle.finalize 1979 return .flushed. 1980 } 1981 set c [chan push [tempchan] foo] 1982 inthread $c { 1983 close $c 1984 } c 1985 lappend res [tempview] 1986} -cleanup { 1987 tempdone 1988 rename foo {} 1989} -result {{flush rt*} {finalize rt*} .flushed.} 1990 1991# --- === *** ########################### 1992# method watch - removed from TIP (rev 1.12+) 1993 1994# --- === *** ########################### 1995# method event - removed from TIP (rev 1.12+) 1996 1997# --- === *** ########################### 1998# 'Pull the rug' tests. Create channel in a thread A, move to other thread B, 1999# destroy the origin thread (A) before or during access from B. Must not 2000# crash, must return proper errors. 2001 2002test iortrans.tf-11.0 {origin thread of moved transform gone} -setup { 2003 #puts <<$tcltest::mainThread>>main 2004 set tida [thread::create -preserved]; #puts <<$tida>> 2005 thread::send $tida {load {} Tcltest} 2006 set tidb [thread::create -preserved]; #puts <<$tida>> 2007 thread::send $tidb {load {} Tcltest} 2008} -constraints {testchannel thread} -match glob -body { 2009 # Set up channel in thread 2010 thread::send $tida $helperscript 2011 thread::send $tidb $helperscript 2012 set chan [thread::send $tida { 2013 proc foo {args} { 2014 handle.initialize clear drain flush limit? read write 2015 handle.finalize 2016 lappend ::res $args 2017 return 2018 } 2019 set chan [chan push [tempchan] foo] 2020 fconfigure $chan -buffering none 2021 set chan 2022 }] 2023 2024 # Move channel to 2nd thread, transform goes with it. 2025 thread::send $tida [list testchannel cut $chan] 2026 thread::send $tidb [list testchannel splice $chan] 2027 2028 # Kill origin thread, then access channel from 2nd thread. 2029 thread::release -wait $tida 2030 2031 set res {} 2032 lappend res [catch {thread::send $tidb [list puts $chan shoo]} msg] $msg 2033 lappend res [catch {thread::send $tidb [list tell $chan]} msg] $msg 2034 lappend res [catch {thread::send $tidb [list seek $chan 1]} msg] $msg 2035 lappend res [catch {thread::send $tidb [list gets $chan]} msg] $msg 2036 lappend res [catch {thread::send $tidb [list close $chan]} msg] $msg 2037 # The 'tell' is ok, as it passed through the transform to the base 2038 # channel without invoking the transform handler. 2039} -cleanup { 2040 thread::send $tidb tempdone 2041 thread::release $tidb 2042} -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}} 2043 2044testConstraint notValgrind [expr {![testConstraint valgrind]}] 2045 2046test iortrans.tf-11.1 {origin thread of moved transform destroyed during access} -setup { 2047 #puts <<$tcltest::mainThread>>main 2048 set tida [thread::create -preserved]; #puts <<$tida>> 2049 thread::send $tida {load {} Tcltest} 2050 set tidb [thread::create -preserved]; #puts <<$tidb>> 2051 thread::send $tidb {load {} Tcltest} 2052} -constraints {testchannel thread notValgrind} -match glob -body { 2053 # Set up channel in thread 2054 thread::send $tida $helperscript 2055 thread::send $tidb $helperscript 2056 set chan [thread::send $tida { 2057 proc foo {args} { 2058 handle.initialize clear drain flush limit? read write 2059 handle.finalize 2060 lappend ::res $args 2061 # destroy thread during channel access 2062 thread::exit 2063 } 2064 set chan [chan push [tempchan] foo] 2065 fconfigure $chan -buffering none 2066 set chan 2067 }] 2068 2069 # Move channel to 2nd thread, transform goes with it. 2070 thread::send $tida [list testchannel cut $chan] 2071 thread::send $tidb [list testchannel splice $chan] 2072 2073 # Run access from thread B, wait for response from A (A is not using event 2074 # loop at this point, so the event pile up in the queue. 2075 thread::send $tidb [list set chan $chan] 2076 thread::send $tidb [list set mid [thread::id]] 2077 thread::send -async $tidb { 2078 # Wait a bit, give the main thread the time to start its event loop to 2079 # wait for the response from B 2080 after 50 2081 catch { puts $chan shoo } res 2082 catch { close $chan } 2083 thread::send -async $mid [list set ::res $res] 2084 } 2085 vwait ::res 2086 set res 2087} -cleanup { 2088 thread::send $tidb tempdone 2089 thread::release $tidb 2090} -result {Owner lost} 2091 2092# ### ### ### ######### ######### ######### 2093 2094cleanupTests 2095return 2096