diff options
Diffstat (limited to 'library/tcltest/tcltest.tcl')
| -rw-r--r-- | library/tcltest/tcltest.tcl | 51 |
1 files changed, 45 insertions, 6 deletions
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 1bfbaa9..83ec9d3 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -15,8 +15,6 @@ # Copyright (c) 2000 by Ajuba Solutions # Contributions from Don Porter, NIST, 2002. (not subject to US copyright) # All rights reserved. -# -# RCS: @(#) $Id: tcltest.tcl,v 1.106 2009/09/01 14:13:23 dgp Exp $ package require Tcl 8.5 ;# -verbose line uses [info frame] namespace eval tcltest { @@ -24,7 +22,7 @@ namespace eval tcltest { # When the version number changes, be sure to update the pkgIndex.tcl file, # and the install directory in the Makefiles. When the minor version # changes (new feature) be sure to update the man page as well. - variable Version 2.3.2 + variable Version 2.3.5 # Compatibility support for dumb variables defined in tcltest 1 # Do not use these. Call [package provide Tcl] and [info patchlevel] @@ -485,8 +483,10 @@ namespace eval tcltest { variable Verify variable Usage variable OptionControlledVariables + variable DefaultValue set Usage($option) $usage set Verify($option) $verify + set DefaultValue($option) $value if {[catch {$verify $value} msg]} { return -code error $msg } else { @@ -601,7 +601,9 @@ namespace eval tcltest { } } proc configure args { - RemoveAutoConfigureTraces + if {[llength $args] > 1} { + RemoveAutoConfigureTraces + } set code [catch {Configure {*}$args} msg] return -code $code $msg } @@ -710,7 +712,7 @@ namespace eval tcltest { } } } - Option -limitconstraints false { + Option -limitconstraints 0 { whether to run only tests with the constraints } AcceptBoolean limitConstraints trace variable Option(-limitconstraints) w \ @@ -797,6 +799,29 @@ namespace eval tcltest { trace variable Option(-errfile) w \ [namespace code {errorChannel $Option(-errfile) ;#}] + proc loadIntoSlaveInterpreter {slave args} { + variable Version + interp eval $slave [package ifneeded tcltest $Version] + interp eval $slave "tcltest::configure {*}{$args}" + interp alias $slave ::tcltest::ReportToMaster \ + {} ::tcltest::ReportedFromSlave + } + proc ReportedFromSlave {total passed skipped failed because newfiles} { + variable numTests + variable skippedBecause + variable createdNewFiles + incr numTests(Total) $total + incr numTests(Passed) $passed + incr numTests(Skipped) $skipped + incr numTests(Failed) $failed + foreach {constraint count} $because { + incr skippedBecause($constraint) $count + } + foreach {testfile created} $newfiles { + lappend createdNewFiles($testfile) {*}$created + } + return + } } ##################################################################### @@ -2356,6 +2381,14 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} { FillFilesExisted set testFileName [file tail [info script]] + # Hook to handle reporting to a parent interpreter + if {[llength [info commands [namespace current]::ReportToMaster]]} { + ReportToMaster $numTests(Total) $numTests(Passed) $numTests(Skipped) \ + $numTests(Failed) [array get skippedBecause] \ + [array get createdNewFiles] + set testSingleFile false + } + # Call the cleanup hook cleanupTestsHook @@ -2687,6 +2720,7 @@ proc tcltest::runAllTests { {shell ""} } { variable numTestFiles variable numTests variable failFiles + variable DefaultValue FillFilesExisted if {[llength [info level 0]] == 1} { @@ -2751,7 +2785,12 @@ proc tcltest::runAllTests { {shell ""} } { set childargv [list] foreach opt [Configure] { if {[string equal $opt -outfile]} {continue} - lappend childargv $opt [Configure $opt] + set value [Configure $opt] + # Don't bother passing default configuration options + if {[string equal $value $DefaultValue($opt)]} { + continue + } + lappend childargv $opt $value } set cmd [linsert $childargv 0 | $shell $file] if {[catch { |