diff options
-rw-r--r-- | examples/client-server.tcl (renamed from tcltests/test_clientserver.tcl) | 28 | ||||
-rw-r--r-- | examples/timedread.tcl | 19 | ||||
-rw-r--r-- | tcltests/Makefile | 5 | ||||
-rwxr-xr-x | tcltests/runtests | 48 | ||||
-rw-r--r-- | tcltests/test.bin | bin | 256 -> 0 bytes | |||
-rw-r--r-- | tcltests/test_bio.tcl | 89 | ||||
-rw-r--r-- | tcltests/test_eventloop.tcl | 47 | ||||
-rw-r--r-- | tcltests/test_exec.tcl | 17 | ||||
-rw-r--r-- | tcltests/test_lsort_cmd.tcl | 16 | ||||
-rw-r--r-- | tcltests/test_package.tcl | 7 | ||||
-rw-r--r-- | tcltests/test_read.tcl | 23 | ||||
-rw-r--r-- | tcltests/test_signal.tcl | 32 | ||||
-rw-r--r-- | tcltests/test_signal2.tcl | 40 | ||||
-rw-r--r-- | tcltests/test_stdio.tcl | 31 | ||||
-rw-r--r-- | tcltests/test_trysignal.tcl | 16 | ||||
-rw-r--r-- | tcltests/test_upvararray.tcl | 23 | ||||
-rw-r--r-- | tcltests/testmod.tcl | 5 | ||||
-rw-r--r-- | tests/signal.test | 97 |
18 files changed, 124 insertions, 419 deletions
diff --git a/tcltests/test_clientserver.tcl b/examples/client-server.tcl index c4d025a..4856e47 100644 --- a/tcltests/test_clientserver.tcl +++ b/examples/client-server.tcl @@ -1,16 +1,10 @@ -if {[info commands vwait] eq ""} { - return "noimpl" -} - proc bgerror {msg} { - #puts "bgerror: $msg" + puts "bgerror: $msg" #exit 0 } -if {[info commands verbose] == ""} { - proc verbose {msg} { - puts $msg - } +proc verbose {msg} { + puts $msg } if {[os.fork] == 0} { @@ -29,18 +23,10 @@ if {[os.fork] == 0} { verbose "child: read response '$buf'" } else { verbose "child: read got eof" - close $f set ::done 1 - $f readable {} } } - proc oneof {f} { - $f close - verbose "child: eof so closing" - set ::done 1 - } - proc onwrite {f} { verbose "child: sending request" $f puts -nonewline "GET / HTTP/1.0\r\n\r\n" @@ -48,8 +34,8 @@ if {[os.fork] == 0} { $f writable {} } - $f readable {onread $f} {oneof $f} - $f writable {onwrite $f} + $f readable [list onread $f] + $f writable [list onwrite $f] alarm 10 catch -signal { @@ -58,6 +44,7 @@ if {[os.fork] == 0} { verbose "child: done event loop" } alarm 0 + $f close exit 0 } @@ -82,13 +69,14 @@ proc server_onread {f} { incr ::done } -$f readable {server_onread $f} +$f readable [list server_onread $f] alarm 10 catch -signal { vwait done } alarm 0 +$f close sleep .5 diff --git a/examples/timedread.tcl b/examples/timedread.tcl new file mode 100644 index 0000000..cb4c9aa --- /dev/null +++ b/examples/timedread.tcl @@ -0,0 +1,19 @@ +# Tests that SIGALRM can interrupt read +set f [open "/dev/urandom" r] + +set count 0 +set error NONE + +signal handle SIGALRM +catch -signal { + alarm 0.5 + while {1} { + incr count [string bytelength [read $f 100]] + } + alarm 0 + signal default SIGALRM +} error + +puts "Read $count bytes in 0.5 seconds: Got $error" + +$f close diff --git a/tcltests/Makefile b/tcltests/Makefile deleted file mode 100644 index 6fc1e54..0000000 --- a/tcltests/Makefile +++ /dev/null @@ -1,5 +0,0 @@ -test: - ../jimsh runtests - -verbose: - ../jimsh runtests -v diff --git a/tcltests/runtests b/tcltests/runtests deleted file mode 100755 index e93ab02..0000000 --- a/tcltests/runtests +++ /dev/null @@ -1,48 +0,0 @@ -#!/bin/sh - -# \ -exec ../tclsh $0 - -#package require tcl6 - -proc check {test got exp} { - if {$got != $exp} { - error "Failed: $test\nExp: {$exp}\nGot: {$got}" - } -} -proc verbose {msg} { - if {$::verbose} { - puts $msg - } -} - -set verbose [string equal [lindex $argv 0] "-v"] - -foreach i [glob test_*.tcl] { - if {$verbose} { - puts "======= $i =======" - } else { - puts -nonewline "$i..." - flush stdout - } - set rc [catch {source $i} result] - if {$rc == 7} { - exit 0 - } - if {$verbose} { - puts -nonewline "$i..." - } - if {$rc} { - puts "failed($rc) $result" - if {$verbose} { - puts $result - } - } elseif {$result ne ""} { - puts $result - } else { - puts "ok" - } - if {$verbose} { - puts "" - } -} diff --git a/tcltests/test.bin b/tcltests/test.bin Binary files differdeleted file mode 100644 index c866266..0000000 --- a/tcltests/test.bin +++ /dev/null diff --git a/tcltests/test_bio.tcl b/tcltests/test_bio.tcl deleted file mode 100644 index c35977d..0000000 --- a/tcltests/test_bio.tcl +++ /dev/null @@ -1,89 +0,0 @@ -if {[info commands bio] eq ""} { - return "noimpl" -} -if {[info commands verbose] eq ""} { - proc verbose {msg} {puts $msg} -} - -proc copy_binary_file {infile outfile} { - set in [open $infile r] - set out [open $outfile w] - while {[bio read $in buf 200] > 0} { - bio write $out $buf - } - close $in - close $out -} - -proc copy_binary_file_direct {infile outfile} { - set in [open $infile r] - set out [open $outfile w] - bio copy $in $out - close $in - close $out -} - -proc copy_file {infile outfile} { - set in [open $infile r] - set out [open $outfile w] - while {1} { - set buf [read $in 200] - if {[string length $buf] == 0} { - break - } - puts -nonewline $out $buf - } - close $in - close $out -} - -proc copy_binary_file_hex {infile outfile} { - set in [open $infile r] - set out [open $outfile w] - while {[bio read -hex $in buf 200] > 0} { - bio write -hex $out $buf - } - close $in - close $out -} - -proc check_file {message filename} { - # Does it look OK? - set rc [catch {exec cmp -s $filename test.bin} error] - if {$rc != 0} { - puts "$message ($error)" - puts "==========================================" - puts "Did not match: $filename test.bin" - error failed - } - verbose "$message -- ok" -} - -# First create a binary file with the chars 0 - 255 -set f [open bio.test w] -for {set i 0} {$i < 256} {incr i} { - puts -nonewline $f [format %c $i] -} -close $f -check_file "Create binary file from std encoding" bio.test - -# Now the same using hex mode -set hex "" -for {set i 0} {$i < 256} {incr i} { - append hex [format %02x $i] -} -set f [open bio.test w] -bio write -hex $f $hex -close $f -check_file "Create binary file from hex encoding" bio.test - -copy_binary_file bio.test bio.copy -check_file "Copy binary file with std encoding" bio.copy -copy_binary_file_direct bio.test bio.copy -check_file "Copy binary file with bio copy" bio.copy -copy_binary_file_hex bio.test bio.copy -check_file "Copy binary file with hex encoding" bio.copy -copy_file bio.test bio.copy -check_file "Copy file with stdio" bio.copy -file delete bio.test -file delete bio.copy diff --git a/tcltests/test_eventloop.tcl b/tcltests/test_eventloop.tcl deleted file mode 100644 index 13e4ab2..0000000 --- a/tcltests/test_eventloop.tcl +++ /dev/null @@ -1,47 +0,0 @@ -if {[info commands vwait] eq ""} { - return "noimpl" -} - -set f [socket stream localhost:80] - -set count 0 -set done 0 - -proc onread {f} { - #puts "[$f gets]" - incr ::count [string length [$f gets]] -} - -proc oneof {f} { - $f close - verbose "Read $::count bytes from server" - incr ::done -} - -proc onwrite {f} { - $f puts -nonewline "GET / HTTP/1.0\r\n\r\n" - $f flush - $f writable {} -} - -proc bgerror {msg} { - puts stderr "bgerror: $msg" - incr ::done -} - -$f readable {onread $f} {oneof $f} -$f writable {onwrite $f} - -alarm 10 -catch -signal { - vwait done -} -alarm 0 -catch {close $f} - -rename bgerror "" -rename onread "" -rename oneof "" -rename onwrite "" - -return diff --git a/tcltests/test_exec.tcl b/tcltests/test_exec.tcl deleted file mode 100644 index bb9dbc8..0000000 --- a/tcltests/test_exec.tcl +++ /dev/null @@ -1,17 +0,0 @@ -if {[info commands exec] eq ""} { - return "noimpl" -} -if {[info commands verbose] eq ""} { - proc verbose {msg} {puts $msg} -} - -set infile [open Makefile] -set outfile [open exec.out w] - -exec cat <@$infile >@$outfile -close $infile -close $outfile - -exec cmp -s Makefile exec.out - -file delete exec.out diff --git a/tcltests/test_lsort_cmd.tcl b/tcltests/test_lsort_cmd.tcl deleted file mode 100644 index cf20ed7..0000000 --- a/tcltests/test_lsort_cmd.tcl +++ /dev/null @@ -1,16 +0,0 @@ -set list {b d a c z} - -proc sorter {a v1 v2} { - set ::arg $a - return [string compare $v1 $v2] -} - -proc test_lsort_cmd {test cmd list exp} { - lsort -command $cmd $list - if {$::arg != $exp} { - error "$test: Failed" - } -} -test_lsort_cmd lsort.cmd.1 "sorter arg1" $list "arg1" -test_lsort_cmd lsort.cmd.2 {sorter "arg with space"} $list "arg with space" -test_lsort_cmd lsort.cmd.3 [list sorter [list arg with list "last with spaces"]] $list [list arg with list "last with spaces"] diff --git a/tcltests/test_package.tcl b/tcltests/test_package.tcl deleted file mode 100644 index 439bfa3..0000000 --- a/tcltests/test_package.tcl +++ /dev/null @@ -1,7 +0,0 @@ -lappend ::auto_path [pwd] - -set v [package require testmod] - -check "package version" $v 2.0 -check "testmod #1" [testmod 1] 1 -check "testmod #2" [testmod 2] 2 diff --git a/tcltests/test_read.tcl b/tcltests/test_read.tcl deleted file mode 100644 index f7d4c29..0000000 --- a/tcltests/test_read.tcl +++ /dev/null @@ -1,23 +0,0 @@ -set f [open "/dev/urandom" r] - -set count 0 -set error NONE - -signal handle SIGALRM -catch -signal { - alarm 0.5 - while {1} { - incr count [string length [read $f 100]] - #incr count [bio read -hex $f buf 1] - } - alarm 0 - signal default SIGALRM -} error - -verbose "Read $count bytes in 0.5 seconds: Got $error" - -# Kill it off -#kill -TERM [pid $f] -catch {close $f} - -return diff --git a/tcltests/test_signal.tcl b/tcltests/test_signal.tcl deleted file mode 100644 index e04b7fb..0000000 --- a/tcltests/test_signal.tcl +++ /dev/null @@ -1,32 +0,0 @@ -set ret2 "" -set res2 "" - -set progress "" - -set ret1 [catch -signal { - append progress a - set ret2 [catch { - append progress b - signal handle TERM - signal throw -TERM - append progress c - } res2] - append progress d -} res1] - -check signal.1 $progress ab -check signal.2 $ret1 5 -check signal.3 $ret2 "" -check signal.4 $res1 SIGTERM -check signal.5 $res2 "" - -set result 0 -catch -signal { - signal handle ALRM - alarm 1 - sleep 2 - set result 1 -} ret - -check signal.7 $result 0 -check signal.6 $ret SIGALRM diff --git a/tcltests/test_signal2.tcl b/tcltests/test_signal2.tcl deleted file mode 100644 index ecbb88b..0000000 --- a/tcltests/test_signal2.tcl +++ /dev/null @@ -1,40 +0,0 @@ -signal ignore HUP TERM -signal handle ALRM INT - -# Send both the handled signals. -# Should not exit here -alarm 1 -kill -INT [pid] -sleep 2 -set x 0 -set signals {} -try -signal { - # This should not execute - incr x -} on signal {signals} { -} -check signal.1 $x 0 -check signal.2 [lsort $signals] "SIGALRM SIGINT" - -# Now no signals should be pending -set x 0 -set signals {} -alarm 1 -try -signal { - kill -HUP [pid] - signal throw TERM - # Should get here - incr x - sleep 10 - # But not get here - incr x -} on signal {signals} { -} - -check signal.3 $x 1 -check signal.4 [lsort $signals] "SIGALRM" -check signal.5 [lsort [signal check]] "SIGHUP SIGTERM" -check signal.6 [lsort [signal check SIGTERM]] "SIGTERM" -check signal.7 [lsort [signal check -clear SIGTERM]] "SIGTERM" -check signal.8 [lsort [signal check -clear]] "SIGHUP" -check signal.9 [lsort [signal check]] "" diff --git a/tcltests/test_stdio.tcl b/tcltests/test_stdio.tcl deleted file mode 100644 index 1e2e3fb..0000000 --- a/tcltests/test_stdio.tcl +++ /dev/null @@ -1,31 +0,0 @@ -proc copy_file {infile outfile} { - set in [open $infile r] - set out [open $outfile w] - while {1} { - set buf [read $in 200] - if {[string length $buf] == 0} { - break - } - puts -nonewline $out $buf - } - close $in - close $out -} - -proc check_file {message filename} { - # Does it look OK? - set line 0 - if {[catch {exec cmp -s test.bin $filename} err]} { - puts "$message" - puts "==========================================" - puts "$filename did not match test.bin" - error failed - } - verbose "$message -- ok" -} - -check_file "Initial test.bin" test.bin - -copy_file test.bin stdio.copy -check_file "Copy file with stdio" stdio.copy -file delete stdio.copy diff --git a/tcltests/test_trysignal.tcl b/tcltests/test_trysignal.tcl deleted file mode 100644 index 5a87045..0000000 --- a/tcltests/test_trysignal.tcl +++ /dev/null @@ -1,16 +0,0 @@ -signal handle ALRM - -alarm 1 -try -signal { - foreach i {1 2 3 4 5} { - sleep 0.4 - } - set msg "" -} on signal {msg} { - # Just set msg here -} finally { - alarm 0 -} - -check trysignal.1 $msg SIGALRM -check trysignal.2 [expr {$i in {2 3}}] 1 diff --git a/tcltests/test_upvararray.tcl b/tcltests/test_upvararray.tcl deleted file mode 100644 index a83b484..0000000 --- a/tcltests/test_upvararray.tcl +++ /dev/null @@ -1,23 +0,0 @@ -proc t {an v} { - upvar $an a - return $a($v) -} - -proc t2 {anv} { - upvar $anv av - return $av -} - -array set a {b B c C} - -set res [t a b] -check upvar.array.1 $res B - -set res [t a c] -check upvar.array.2 $res C - -set res [t2 a(b)] -check upvar.array.3 $res B - -set res [t2 a(c)] -check upvar.array.4 $res C diff --git a/tcltests/testmod.tcl b/tcltests/testmod.tcl deleted file mode 100644 index dbc469b..0000000 --- a/tcltests/testmod.tcl +++ /dev/null @@ -1,5 +0,0 @@ -package provide testmod 2.0 - -proc testmod {msg} { - return $msg -} diff --git a/tests/signal.test b/tests/signal.test new file mode 100644 index 0000000..4c08a96 --- /dev/null +++ b/tests/signal.test @@ -0,0 +1,97 @@ +source [file dirname [info script]]/testing.tcl + +needs cmd signal +needs cmd pid + +test signal-1.1 "catch/throw" { + signal handle TERM + set x 1 + set rc [catch -signal { + signal throw -TERM + incr x + } result] + signal default TERM + list [info returncode $rc] $result $x +} {signal SIGTERM 1} + +test signal-1.2 "catch/kill" { + signal handle TERM + set x 1 + set rc [catch -signal { + kill -TERM [pid] + incr x + } result] + signal default TERM + list [info returncode $rc] $result $x +} {signal SIGTERM 1} + +test signal-1.3 "catch/alarm" { + signal handle ALRM + set x 1 + set rc [catch -signal { + alarm .2 + sleep 1 + incr x + } result] + signal default ALRM + list [info returncode $rc] $result $x +} {signal SIGALRM 1} + +test signal-1.4 "multiple signals before catch" { + signal handle ALRM INT + kill -INT [pid] + alarm .2 + sleep 1 + set x 1 + set rc [catch -signal { + # Doesn't not execute because signals already active + incr x + } result] + signal default ALRM INT + list [info returncode $rc] [lsort $result] $x +} {signal {SIGALRM SIGINT} 1} + +test signal-1.5 "ignored signals" { + signal handle INT + signal ignore HUP + + set x 1 + catch -signal { + # Send an ignored signal + kill -HUP [pid] + incr x + # Now a caught signal + kill -INT [pid] + incr x + } result + signal default INT TERM + list [lsort $result] $x +} {SIGINT 2} + +test signal-1.6 "check ignored signals" { + list [signal check SIGINT] [signal check] +} {{} SIGHUP} + +test signal-1.7 "clearing ignored signals" { + signal check -clear + signal check +} {} + +test signal-1.8 "try/signal" { + signal handle ALRM + try -signal { + alarm 0.4 + foreach i [range 10] { + sleep 0.1 + } + set msg "" + } on signal {msg} { + # Just set msg here + } finally { + alarm 0 + } + signal default ALRM + list [expr {$i in {3 4 5}}] $msg +} {1 SIGALRM} + +testreport |