diff options
| -rw-r--r-- | ChangeLog | 7 | ||||
| -rw-r--r-- | library/tcltest/tcltest.tcl | 17 | ||||
| -rw-r--r-- | library/tcltest1.0/tcltest.tcl | 17 | ||||
| -rw-r--r-- | tests/event.test | 17 | ||||
| -rw-r--r-- | tests/io.test | 32 | ||||
| -rwxr-xr-x | tests/tcltest.test | 29 |
6 files changed, 89 insertions, 30 deletions
@@ -1,3 +1,10 @@ +1999-08-26 Jennifer Hom <jenn@scriptics.com> + + * tests/tcltest.test: + * library/tcltest1.0/tcltest.tcl: Added a -args flag that sets a + variable named ::tcltest::parameters based on whatever's being + sent in as the argument to the -args flag. + 1999-08-23 Jennifer Hom <jenn@scriptics.com> * tests/tcltest.test: Added additional tests for -tmpdir, marked diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 039c560..9d7bccc 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -12,7 +12,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: tcltest.tcl,v 1.9 1999/07/30 01:35:27 jenn Exp $ +# RCS: @(#) $Id: tcltest.tcl,v 1.10 1999/08/27 01:17:04 jenn Exp $ package provide tcltest 1.0 @@ -64,6 +64,10 @@ namespace eval tcltest { variable debug 0 + # Save any arguments that we might want to pass through to other programs. + # This is used by the -args flag. + variable parameters {} + # Count the number of files tested (0 if all.tcl wasn't called). # The all.tcl file will set testSingleFile to false, so stats will # not be printed until all.tcl calls the cleanupTests proc. @@ -672,7 +676,7 @@ proc ::tcltest::processCmdLineArgs {} { # -help is not listed since it has already been processed lappend defaultFlags -verbose -match -skip -constraints \ -outfile -errfile -debug -tmpdir -file -notfile \ - -preservecore -limitconstraints + -preservecore -limitconstraints -args set defaultFlags [concat $defaultFlags \ [ ::tcltest::processCmdLineArgsAddFlagsHook ]] @@ -685,6 +689,11 @@ proc ::tcltest::processCmdLineArgs {} { } } + # Set ::tcltest::parameters to the arg of the -args flag, if given + if {[info exists flag(-args)]} { + set ::tcltest::parameters $flag(-args) + } + # Set ::tcltest::verbose to the arg of the -verbose flag, if given if {[info exists flag(-verbose)]} { @@ -1135,16 +1144,14 @@ proc ::tcltest::test {name description script expectedAnswer args} { if {[string match {*[$\[]*} $constraints] != 0} { # full expression, e.g. {$foo > [info tclversion]} catch {set doTest [uplevel #0 expr $constraints]} - } elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} { # something like {a || b} should be turned into # $::tcltest::testConstraints(a) || $::tcltest::testConstraints(b). - regsub -all {[.a-zA-Z0-9]+} $constraints \ + regsub -all {[.\w]+} $constraints \ {$::tcltest::testConstraints(&)} c catch {set doTest [eval expr $c]} } else { # just simple constraints such as {unixOnly fonts}. - set doTest 1 foreach constraint $constraints { if {(![info exists ::tcltest::testConstraints($constraint)]) \ diff --git a/library/tcltest1.0/tcltest.tcl b/library/tcltest1.0/tcltest.tcl index 039c560..9d7bccc 100644 --- a/library/tcltest1.0/tcltest.tcl +++ b/library/tcltest1.0/tcltest.tcl @@ -12,7 +12,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: tcltest.tcl,v 1.9 1999/07/30 01:35:27 jenn Exp $ +# RCS: @(#) $Id: tcltest.tcl,v 1.10 1999/08/27 01:17:04 jenn Exp $ package provide tcltest 1.0 @@ -64,6 +64,10 @@ namespace eval tcltest { variable debug 0 + # Save any arguments that we might want to pass through to other programs. + # This is used by the -args flag. + variable parameters {} + # Count the number of files tested (0 if all.tcl wasn't called). # The all.tcl file will set testSingleFile to false, so stats will # not be printed until all.tcl calls the cleanupTests proc. @@ -672,7 +676,7 @@ proc ::tcltest::processCmdLineArgs {} { # -help is not listed since it has already been processed lappend defaultFlags -verbose -match -skip -constraints \ -outfile -errfile -debug -tmpdir -file -notfile \ - -preservecore -limitconstraints + -preservecore -limitconstraints -args set defaultFlags [concat $defaultFlags \ [ ::tcltest::processCmdLineArgsAddFlagsHook ]] @@ -685,6 +689,11 @@ proc ::tcltest::processCmdLineArgs {} { } } + # Set ::tcltest::parameters to the arg of the -args flag, if given + if {[info exists flag(-args)]} { + set ::tcltest::parameters $flag(-args) + } + # Set ::tcltest::verbose to the arg of the -verbose flag, if given if {[info exists flag(-verbose)]} { @@ -1135,16 +1144,14 @@ proc ::tcltest::test {name description script expectedAnswer args} { if {[string match {*[$\[]*} $constraints] != 0} { # full expression, e.g. {$foo > [info tclversion]} catch {set doTest [uplevel #0 expr $constraints]} - } elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} { # something like {a || b} should be turned into # $::tcltest::testConstraints(a) || $::tcltest::testConstraints(b). - regsub -all {[.a-zA-Z0-9]+} $constraints \ + regsub -all {[.\w]+} $constraints \ {$::tcltest::testConstraints(&)} c catch {set doTest [eval expr $c]} } else { # just simple constraints such as {unixOnly fonts}. - set doTest 1 foreach constraint $constraints { if {(![info exists ::tcltest::testConstraints($constraint)]) \ diff --git a/tests/event.test b/tests/event.test index 073d96d..d237a86 100644 --- a/tests/event.test +++ b/tests/event.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: event.test,v 1.8 1999/07/01 17:36:17 jenn Exp $ +# RCS: @(#) $Id: event.test,v 1.9 1999/08/27 01:17:05 jenn Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -23,8 +23,15 @@ set ::tcltest::testConstraints(testexithandler) \ set ::tcltest::testConstraints(testfilewait) \ [expr {[info commands testfilewait] != {}}] +set ::tcltest::testConstraints(knownBugThreadedLinux) [expr \ + {($tcl_platform(os) != "Linux") \ + && ([info commands testthread] != {})}] -test event-1.1 {Tcl_CreateFileHandler, reading} {testfilehandler} { +set ::tcltest::testConstraints(knownBugThreadedSolaris) [expr \ + {($tcl_platform(os) != "SunOS") \ + && ([info commands testthread] != {})}] + +test event-1.1 {Tcl_CreateFileHandler, reading} {testfilehandler knownBugThreadedLinux knownBugThreadedSolaris} { testfilehandler close testfilehandler create 0 readable off testfilehandler clear 0 @@ -368,7 +375,7 @@ test event-11.3 {Tcl_VwaitCmd procedure} { set x 1 list [catch {vwait x(1)} msg] $msg } {1 {can't trace "x(1)": variable isn't array}} -test event-11.4 {Tcl_VwaitCmd procedure} { +test event-11.4 {Tcl_VwaitCmd procedure} {knownBugThreadedLinux} { foreach i [after info] { after cancel $i } @@ -394,9 +401,9 @@ test event-11.5 {Tcl_VwaitCmd procedure: round robin scheduling, 2 sources} {soc puts $s foobar close $s } - set s1 [socket -server accept 5001] + catch {set s1 [socket -server accept 5001]} after 1000 - set s2 [socket 127.0.0.1 5001] + catch {set s2 [socket 127.0.0.1 5001]} close $s1 set x 0 set y 0 diff --git a/tests/io.test b/tests/io.test index b2716de..1e82b26 100644 --- a/tests/io.test +++ b/tests/io.test @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: io.test,v 1.10 1999/07/01 17:36:18 jenn Exp $ +# RCS: @(#) $Id: io.test,v 1.11 1999/08/27 01:17:05 jenn Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -27,6 +27,14 @@ if {"[info commands testchannel]" != "testchannel"} { ::tcltest::saveState +set ::tcltest::testConstraints(knownBugThreadedLinux) [expr \ + {($tcl_platform(os) != "Linux") \ + && ([info commands testthread] != {})}] + +set ::tcltest::testConstraints(knownBugThreadedSolaris) [expr \ + {($tcl_platform(os) != "SunOS") \ + && ([info commands testthread] != {})}] + removeFile test1 removeFile pipe @@ -1025,7 +1033,7 @@ test io-6.55 {Tcl_GetsObj: overconverted} { close $f set x } [list 8 "there\u4e00ok" 11 "\u4e01more bytes" 4 "here"] -test io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} {stdio} { +test io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} {stdio knownBugThreadedSolaris knownBugThreadedLinux} { update set f [open "|[list $::tcltest::tcltest cat]" w+] fconfigure $f -buffering none @@ -1419,7 +1427,7 @@ test io-12.5 {ReadChars: fileevents on partial characters} {stdio} { set x } "{} timeout {} timeout \u7266 {} eof 0 {}" -test io-13.1 {TranslateInputEOL: cr mode} { +test io-13.1 {TranslateInputEOL: cr mode} {knownBugThreadedLinux} { set f [open test1 w] fconfigure $f -translation lf puts -nonewline $f "abcd\rdef\r" @@ -1480,7 +1488,7 @@ test io-13.5 {TranslateInputEOL: crlf mode: naked lf} { close $f set x } "abcd\ndef\nfgh" -test io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} {stdio} { +test io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} {stdio knownBugThreadedSolaris knownBugThreadedLinux} { # (chanPtr->flags & INPUT_SAW_CR) # This test may fail on slower machines. @@ -2040,7 +2048,7 @@ test io-27.5 {FlushChannel, implicit flush when buffer fills and on close} \ set l } {0 60 72} test io-27.6 {FlushChannel, async flushing, async close} \ - {stdio asyncPipeClose} { + {stdio asyncPipeClose knownBugThreadedLinux} { removeFile pipe removeFile output set f [open pipe w] @@ -5455,7 +5463,7 @@ test io-45.3 {DeleteFileEvent, cleanup on close} { if {[info commands testfevent] == "testfevent"} { -test io-46.1 {Tcl event loop vs multiple interpreters} { + test io-46.1 {Tcl event loop vs multiple interpreters} {knownBugThreadedLinux} { testfevent create testfevent cmd { set f [open foo r] @@ -6110,7 +6118,7 @@ test io-49.5 {testing crlf reading, leftover cr disgorgment} { set l } [list 7 a\rb\rc 7 {} 7 1] -test io-50.1 {testing handler deletion} { +test io-50.1 {testing handler deletion} {knownBugThreadedSolaris knownBugThreadedLinux} { removeFile test1 set f [open test1 w] close $f @@ -6126,7 +6134,7 @@ test io-50.1 {testing handler deletion} { close $f set z } called -test io-50.2 {testing handler deletion with multiple handlers} { +test io-50.2 {testing handler deletion with multiple handlers} {knownBugThreadedSolaris knownBugThreadedLinux} { removeFile test1 set f [open test1 w] close $f @@ -6144,7 +6152,7 @@ test io-50.2 {testing handler deletion with multiple handlers} { string compare [string tolower $z] \ [list [list called delhandler $f 0] [list called delhandler $f 1]] } 0 -test io-50.3 {testing handler deletion with multiple handlers} { +test io-50.3 {testing handler deletion with multiple handlers} {knownBugThreadedSolaris knownBugThreadedLinux} { removeFile test1 set f [open test1 w] close $f @@ -6170,7 +6178,7 @@ test io-50.3 {testing handler deletion with multiple handlers} { [list [list delhandler $f 0 called] \ [list delhandler $f 0 deleted myself]] } 0 -test io-50.4 {testing handler deletion vs reentrant calls} { +test io-50.4 {testing handler deletion vs reentrant calls} {knownBugThreadedSolaris knownBugThreadedLinux} { removeFile test1 set f [open test1 w] close $f @@ -6194,7 +6202,7 @@ test io-50.4 {testing handler deletion vs reentrant calls} { string compare [string tolower $z] \ {{delrecursive calling recursive} {delrecursive deleting recursive}} } 0 -test io-50.5 {testing handler deletion vs reentrant calls} { +test io-50.5 {testing handler deletion vs reentrant calls} {knownBugThreadedSolaris knownBugThreadedLinux} { removeFile test1 set f [open test1 w] close $f @@ -6227,7 +6235,7 @@ test io-50.5 {testing handler deletion vs reentrant calls} { [list {del calling recursive} {del deleted notcalled} \ {del deleted myself} {del after update}] } 0 -test io-50.6 {testing handler deletion vs reentrant calls} { +test io-50.6 {testing handler deletion vs reentrant calls} {knownBugThreadedSolaris knownBugThreadedLinux} { removeFile test1 set f [open test1 w] close $f diff --git a/tests/tcltest.test b/tests/tcltest.test index 855e433..b87b830 100755 --- a/tests/tcltest.test +++ b/tests/tcltest.test @@ -1,7 +1,7 @@ # Command line options covered: # -help, -verbose, -match, -skip, -file, -notfile, -constraints, # -limitconstraints, -preservecore, -tmpdir, -debug, -outfile, -# -errfile +# -errfile, -args # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and @@ -10,7 +10,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: tcltest.test,v 1.6 1999/08/23 17:54:59 jenn Exp $ +# RCS: @(#) $Id: tcltest.test,v 1.7 1999/08/27 01:17:06 jenn Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -323,10 +323,33 @@ test tcltest-10.4 {-preservecore 3} {unixOrPc} { [regexp "core-" $msg] [file delete core-makecore] } {1 1 1 {}} +makeFile { + package require tcltest + namespace import ::tcltest::* + puts "=$::tcltest::parameters=" + return +} args.tcl + +# -args +test tcltest-11.1 {-args foo} {unixOrPc} { + catch {exec $::tcltest::tcltest args.tcl -args foo} msg + list $msg +} {=foo=} + +test tcltest-11.2 {-args {}} {unixOrPc} { + catch {exec $::tcltest::tcltest args.tcl -args {}} msg + list $msg +} {==} + +test tcltest-11.3 {-args {-foo bar -baz}} {unixOrPc} { + catch {exec $::tcltest::tcltest args.tcl -args {-foo bar -baz}} msg + list $msg +} {{=-foo bar -baz=}} + # Begin testing of tcltest procs ... # PrintError -test tcltest-11.1 {PrintError} {unixOrPc} { +test tcltest-20.1 {PrintError} {unixOrPc} { set result [catch {exec $::tcltest::tcltest printerror.tcl} msg] list $result [regexp "Error: a really short string" $msg] \ [regexp " \"quotes\"" $msg] [regexp " \"Path" $msg] \ |