diff options
| -rw-r--r-- | examples/pipe.tcl | 16 | ||||
| -rw-r--r-- | tests/concat.test | 4 | ||||
| -rw-r--r-- | tests/exec.test | 9 | ||||
| -rw-r--r-- | tests/regexp.test | 2 | ||||
| -rw-r--r-- | tests/testing.tcl | 36 | ||||
| -rw-r--r-- | tests/uplevel.test | 8 |
6 files changed, 51 insertions, 24 deletions
diff --git a/examples/pipe.tcl b/examples/pipe.tcl new file mode 100644 index 0000000..6b10dbd --- /dev/null +++ b/examples/pipe.tcl @@ -0,0 +1,16 @@ +lassign [socket pipe] r w + +# Note, once the exec has the fh (via dup), close it +# so that the pipe data is accessible +exec ps aux >@$w & +$w close + +$r readable { + puts [$r gets] + if {[eof $r]} { + $r close + set done 1 + } +} + +vwait done diff --git a/tests/concat.test b/tests/concat.test index 333b634..65d6e1b 100644 --- a/tests/concat.test +++ b/tests/concat.test @@ -13,11 +13,11 @@ test concat-1.4 {special characters} { concat a\{ {b \{c d} \{d } "a{ b \\{c d {d" -test concat-2.1 {error: one empty argument} { +test concat-2.1 {error check: one empty argument} { concat {} } {} -test concat-3.1 {error: no arguments} { +test concat-3.1 {error check: no arguments} { list [catch concat msg] $msg } {0 {}} diff --git a/tests/exec.test b/tests/exec.test index 47b246f..e1b6e36 100644 --- a/tests/exec.test +++ b/tests/exec.test @@ -313,10 +313,11 @@ test exec-9.6 {commands returning errors} { list [catch {exec sh -c "echo error msg 1>&2"} msg] $msg } {0 {error msg}} test exec-9.7 {commands returning errors} { - list [catch {exec sh -c "echo error msg 1>&2" \ - | sh -c "echo error msg 1>&2"} msg] $msg -} {0 {error msg -error msg}} + # Note: Use sleep here to ensure the order + list [catch {exec sh -c "echo error msg 1 1>&2" \ + | sh -c "sleep 1; echo error msg 2 1>&2"} msg] $msg +} {0 {error msg 1 +error msg 2}} # Errors in executing the Tcl command, as opposed to errors in the # processes that are invoked. diff --git a/tests/regexp.test b/tests/regexp.test index 037fc8e..41d0620 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -28,8 +28,6 @@ test regexp-1.1 {effect of caching} { set t1 [lindex $t1 0] set t2 [lindex $t2 0] - puts "t1=$t1, t2=$t2" - # If these two times are within 20% of each other, caching isn't working expr {$t2 * 1.0 / $t1 < 1.2 && $t1 * 1.0 / $t2 < 1.2} } {0} diff --git a/tests/testing.tcl b/tests/testing.tcl index 3142c72..9c0b4ec 100644 --- a/tests/testing.tcl +++ b/tests/testing.tcl @@ -20,7 +20,9 @@ catch { } proc section {name} { - puts "-- $name ----------------" + if {!$::testquiet} { + puts "-- $name ----------------" + } } set testresults(numfail) 0 @@ -52,22 +54,32 @@ proc test {id descr script expected} { } proc testreport {} { - puts "----------------------------------------------------------------------" - puts "FAILED: $::testresults(numfail)" - foreach failed $::testresults(failed) { - foreach {id descr script expected result} $failed {} - puts "\t[info_source $script]\t$id" + if {!$::testquiet || $::testresults(numfail)} { + puts "----------------------------------------------------------------------" + puts "FAILED: $::testresults(numfail)" + foreach failed $::testresults(failed) { + foreach {id descr script expected result} $failed {} + puts "\t[info_source $script]\t$id" + } + puts "PASSED: $::testresults(numpass)" + puts "----------------------------------------------------------------------\n" + } + if {$::testresults(numfail)} { + exit 1 } - puts "PASSED: $::testresults(numpass)" - puts "----------------------------------------------------------------------\n" } proc testerror {} { error "deliberate error" } -puts [string repeat = 40] -puts $argv0 -puts [string repeat = 40] +incr testquiet [info exists ::env(testquiet)] +if {[lindex $argv 0] eq "-quiet"} { + incr testquiet +} -set ::testquiet [info exists ::env(testquiet)] +if {!$testquiet} { + puts [string repeat = 40] + puts $argv0 + puts [string repeat = 40] +} diff --git a/tests/uplevel.test b/tests/uplevel.test index b3a7714..0d38c13 100644 --- a/tests/uplevel.test +++ b/tests/uplevel.test @@ -82,17 +82,17 @@ test uplevel-3.4 {uplevel to same level} { a1 } 55 -test uplevel-4.1 {error: non-existent level} { +test uplevel-4.1 {error check: non-existent level} { list [catch c1 msg] $msg } {1 {bad level "#2"}} -test uplevel-4.2 {error: non-existent level} { +test uplevel-4.2 {error check: non-existent level} { proc c2 {} {uplevel 3 {set a b}} list [catch c2 msg] $msg } {1 {bad level "3"}} -test uplevel-4.3 {error: not enough args} { +test uplevel-4.3 {error check: not enough args} { list [catch uplevel msg] $msg } {1 {wrong # args: should be "uplevel ?level? command ?arg ...?"}} -test uplevel-4.4 {error: not enough args} { +test uplevel-4.4 {error check: not enough args} { proc upBug {} {uplevel 1} list [catch upBug msg] $msg } {1 {wrong # args: should be "uplevel ?level? command ?arg ...?"}} |