Tcl Source Code

README -- Tcl test suite design document.

RCS: @(#) $Id: README,v 1.1.2.7 1999/04/02 18:57:06 hershey Exp $

Contents:
---------

    1. Introduction
    2. Definitions file
    3. Writing a new test
................................................................................
			     constraints.

    (c) start up tcltest in this directory, then "source" the test
        file (for example, type "source parse.test").  To run all
	of the tests, type "source all.tcl".  To use the options in
	interactive mode, you can set their corresponding tcltest
	namespace variables after sourcing the defs.tcl file.
		  ::tcltest::matchingTests
		  ::tcltest::skippingTests
		  ::tcltest::testConfig(nonPortable)
		  ::tcltest::testConfig(knownBug)
		  ::tcltest::testConfig(userInteractive)

In all cases, no output will be generated if all goes well, except for
a listing of the test files and a statistical summary.  If there are
errors, then additional messages will appear in the format described
................................................................................
-----------------------------------------------

Normally, all the tests in a file are run whenever the file is
sourced.  An individual test will be skipped if one of the following
conditions is met:

    1) the "name" of the tests does not match (using glob style
       matching) one or more elements in the ::tcltest::matchingTests
       variable

    2) the "name" of the tests matches (using glob style matching) one
       or more elements in the ::tcltest::skippingTests variable

    3) the "constraints" argument to the "test" call, if given,
       contains one or more false elements.

You can set ::tcltest::matchingTests and/or ::tcltest::skippingTests
either interactively (after the defs.tcl file has been sourced), or by
the command line arguments -match and -skip, for example:

       tcltest info.test -match '*-5.* *-7.*' -skip '*-7.1*'

Be sure to use the proper quoting convention so that your shell does
not perform the glob substitution on the match or skip patterns you
................................................................................

1) Global variables such as VERBOSE, TESTS, and testConfig are now
   renamed to use the new "tcltest" namespace.

   old name   new name
   --------   --------
   VERBOSE    ::tcltest::verbose
   TESTS      ::tcltest::matchingTests
   testConfig ::tcltest::testConfig

   The introduction of the "tcltest" namespace is a precursor to using
   a "tcltest" package.  This next step will be part of a future Tcl
   version.

2) VERBOSE values are no longer numeric.  Please see the section above

README -- Tcl test suite design document.

RCS: @(#) $Id: README,v 1.1.2.8 1999/04/07 01:59:27 hershey Exp $

Contents:
---------

    1. Introduction
    2. Definitions file
    3. Writing a new test
................................................................................
			     constraints.

    (c) start up tcltest in this directory, then "source" the test
        file (for example, type "source parse.test").  To run all
	of the tests, type "source all.tcl".  To use the options in
	interactive mode, you can set their corresponding tcltest
	namespace variables after sourcing the defs.tcl file.
		  ::tcltest::match
		  ::tcltest::skip
		  ::tcltest::testConfig(nonPortable)
		  ::tcltest::testConfig(knownBug)
		  ::tcltest::testConfig(userInteractive)

In all cases, no output will be generated if all goes well, except for
a listing of the test files and a statistical summary.  If there are
errors, then additional messages will appear in the format described
................................................................................
-----------------------------------------------

Normally, all the tests in a file are run whenever the file is
sourced.  An individual test will be skipped if one of the following
conditions is met:

    1) the "name" of the tests does not match (using glob style
       matching) one or more elements in the ::tcltest::match
       variable

    2) the "name" of the tests matches (using glob style matching) one
       or more elements in the ::tcltest::skip variable

    3) the "constraints" argument to the "test" call, if given,
       contains one or more false elements.

You can set ::tcltest::match and/or ::tcltest::skip
either interactively (after the defs.tcl file has been sourced), or by
the command line arguments -match and -skip, for example:

       tcltest info.test -match '*-5.* *-7.*' -skip '*-7.1*'

Be sure to use the proper quoting convention so that your shell does
not perform the glob substitution on the match or skip patterns you
................................................................................

1) Global variables such as VERBOSE, TESTS, and testConfig are now
   renamed to use the new "tcltest" namespace.

   old name   new name
   --------   --------
   VERBOSE    ::tcltest::verbose
   TESTS      ::tcltest::match
   testConfig ::tcltest::testConfig

   The introduction of the "tcltest" namespace is a precursor to using
   a "tcltest" package.  This next step will be part of a future Tcl
   version.

2) VERBOSE values are no longer numeric.  Please see the section above

# This file contains a top-level script to run all of the Tcl
# tests.  Execute it by invoking "source all.test" when running tcltest
# in this directory.
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
# 
# RCS: @(#) $Id: all.tcl,v 1.1.2.5 1999/03/24 02:48:54 hershey Exp $

if {[lsearch ::tcltest [namespace children]] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}
set ::tcltest::testSingleFile false

puts stdout "Tcl $tcl_patchLevel tests running in interp:  [info nameofexecutable]"
puts stdout "Tests running in working dir:  $::tcltest::workingDir"
if {[llength $::tcltest::skippingTests] > 0} {
    puts stdout "Skipping tests that match:  $::tcltest::skippingTests"
}
if {[llength $::tcltest::matchingTests] > 0} {
    puts stdout "Only running tests that match:  $::tcltest::matchingTests"
}

# Use command line specified glob pattern (specified by -file or -f)
# if one exists.  Otherwise use *.test.  If given, the file pattern
# should be specified relative to the dir containing this file.  If no
# files are found to match the pattern, print an error message and exit.
set fileIndex [expr {[lsearch $argv "-file"] + 1}]

# This file contains a top-level script to run all of the Tcl
# tests.  Execute it by invoking "source all.test" when running tcltest
# in this directory.
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
# 
# RCS: @(#) $Id: all.tcl,v 1.1.2.6 1999/04/07 01:59:27 hershey Exp $

if {[lsearch ::tcltest [namespace children]] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}
set ::tcltest::testSingleFile false

puts stdout "Tcl $tcl_patchLevel tests running in interp:  [info nameofexecutable]"
puts stdout "Tests running in working dir:  $::tcltest::workingDir"
if {[llength $::tcltest::skip] > 0} {
    puts stdout "Skipping tests that match:  $::tcltest::skip"
}
if {[llength $::tcltest::match] > 0} {
    puts stdout "Only running tests that match:  $::tcltest::match"
}

# Use command line specified glob pattern (specified by -file or -f)
# if one exists.  Otherwise use *.test.  If given, the file pattern
# should be specified relative to the dir containing this file.  If no
# files are found to match the pattern, print an error message and exit.
set fileIndex [expr {[lsearch $argv "-file"] + 1}]

#	of Sun Microsystems.
#
# Copyright (c) 1990-1994 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
# 
# RCS: @(#) $Id: defs.tcl,v 1.1.2.10 1999/04/03 03:02:47 hershey Exp $

# Initialize wish shell
if {[info exists tk_version]} {
    tk appname tktest
    wm title . tktest
} else {
    # Ensure that we have a minimal auto_path so we don't pick up extra junk.
................................................................................
    foreach proc $procList {
	namespace export $proc
    }

    # ::tcltest::verbose defaults to "b"
    variable verbose "b"

    # matchingTests defaults to the empty list
    variable matchingTests {}

    # skippingTests defaults to the empty list
    variable skippingTests {}

    # Tests should not rely on the current working directory.
    # Files that are part of the test suite should be accessed relative to
    # ::tcltest::testsDir.

    set originalDir [pwd]
    set tDir [file join $originalDir [file dirname [info script]]]
................................................................................
}

::tcltest::initConfig


# ::tcltest::processCmdLineArgs --
#
#	Use command line args to set the verbose, skippingTests, and
#	matchingTests variables.  This procedure must be run after
#	constraints are initialized, because some constraints can be
#	overridden.
#
# Arguments:
#	none
#
# Results:
................................................................................
    }

    # Set ::tcltest::verbose to the arg of the -verbose flag, if given
    if {[info exists flag(-verbose)]} {
	set ::tcltest::verbose $flag(-verbose)
    }

    # Set ::tcltest::matchingTests to the arg of the -match flag, if given
    if {[info exists flag(-match)]} {
	set ::tcltest::matchingTests $flag(-match)
    }

    # Set ::tcltest::skippingTests to the arg of the -skip flag, if given
    if {[info exists flag(-skip)]} {
	set ::tcltest::skippingTests $flag(-skip)
    }

    # Use the -constraints flag, if given, to turn on constraints that are
    # turned off by default: userInteractive knownBug nonPortable.  This
    # code fragment must be run after constraints are initialized.
    if {[info exists flag(-constraints)]} {
	foreach elt $flag(-constraints) {
................................................................................


# test --
#
# This procedure runs a test and prints an error message if the test fails.
# If ::tcltest::verbose has been set, it also prints a message even if the
# test succeeds.  The test will be skipped if it doesn't match the
# ::tcltest::matchingTests variable, if it matches an element in
# ::tcltest::skippingTests, or if one of the elements of "constraints" turns
# out not to be true.
#
# Arguments:
# name -		Name of test, in the form foo-1.2.
# description -		Short textual description of the test, to
#			help humans understand what it does.
# constraints -		A list of one or more keywords, each of
................................................................................
#			return a result that can be checked for
#			correctness.
# expectedAnswer -	Expected result from script.

proc ::tcltest::test {name description script expectedAnswer args} {
    incr ::tcltest::numTests(Total)

    # skip the test if it's name matches an element of skippingTests
    foreach pattern $::tcltest::skippingTests {
	if {[string match $pattern $name]} {
	    incr ::tcltest::numTests(Skipped)
	    return
	}
    }
    # skip the test if it's name doesn't match any element of matchingTests
    if {[llength $::tcltest::matchingTests] > 0} {
	set ok 0
	foreach pattern $::tcltest::matchingTests {
	    if {[string match $pattern $name]} {
		set ok 1
		break
	    }
        }
	if {!$ok} {
	    incr ::tcltest::numTests(Skipped)
................................................................................
#	file    name of tests file to source
#	args    pattern selecting the tests you want to execute
#
# Results:
#	none

proc ::tcltest::dotests {file args} {
    set savedTests $::tcltest::matchingTests
    set ::tcltest::matchingTests $args
    source $file
    set ::tcltest::matchingTests $savedTests
}

proc ::tcltest::openfiles {} {
    if {[catch {testchannel open} result]} {
	return {}
    }
    return $result

#	of Sun Microsystems.
#
# Copyright (c) 1990-1994 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
# 
# RCS: @(#) $Id: defs.tcl,v 1.1.2.11 1999/04/07 01:59:27 hershey Exp $

# Initialize wish shell
if {[info exists tk_version]} {
    tk appname tktest
    wm title . tktest
} else {
    # Ensure that we have a minimal auto_path so we don't pick up extra junk.
................................................................................
    foreach proc $procList {
	namespace export $proc
    }

    # ::tcltest::verbose defaults to "b"
    variable verbose "b"

    # match defaults to the empty list
    variable match {}

    # skip defaults to the empty list
    variable skip {}

    # Tests should not rely on the current working directory.
    # Files that are part of the test suite should be accessed relative to
    # ::tcltest::testsDir.

    set originalDir [pwd]
    set tDir [file join $originalDir [file dirname [info script]]]
................................................................................
}

::tcltest::initConfig


# ::tcltest::processCmdLineArgs --
#
#	Use command line args to set the verbose, skip, and
#	match variables.  This procedure must be run after
#	constraints are initialized, because some constraints can be
#	overridden.
#
# Arguments:
#	none
#
# Results:
................................................................................
    }

    # Set ::tcltest::verbose to the arg of the -verbose flag, if given
    if {[info exists flag(-verbose)]} {
	set ::tcltest::verbose $flag(-verbose)
    }

    # Set ::tcltest::match to the arg of the -match flag, if given
    if {[info exists flag(-match)]} {
	set ::tcltest::match $flag(-match)
    }

    # Set ::tcltest::skip to the arg of the -skip flag, if given
    if {[info exists flag(-skip)]} {
	set ::tcltest::skip $flag(-skip)
    }

    # Use the -constraints flag, if given, to turn on constraints that are
    # turned off by default: userInteractive knownBug nonPortable.  This
    # code fragment must be run after constraints are initialized.
    if {[info exists flag(-constraints)]} {
	foreach elt $flag(-constraints) {
................................................................................


# test --
#
# This procedure runs a test and prints an error message if the test fails.
# If ::tcltest::verbose has been set, it also prints a message even if the
# test succeeds.  The test will be skipped if it doesn't match the
# ::tcltest::match variable, if it matches an element in
# ::tcltest::skip, or if one of the elements of "constraints" turns
# out not to be true.
#
# Arguments:
# name -		Name of test, in the form foo-1.2.
# description -		Short textual description of the test, to
#			help humans understand what it does.
# constraints -		A list of one or more keywords, each of
................................................................................
#			return a result that can be checked for
#			correctness.
# expectedAnswer -	Expected result from script.

proc ::tcltest::test {name description script expectedAnswer args} {
    incr ::tcltest::numTests(Total)

    # skip the test if it's name matches an element of skip
    foreach pattern $::tcltest::skip {
	if {[string match $pattern $name]} {
	    incr ::tcltest::numTests(Skipped)
	    return
	}
    }
    # skip the test if it's name doesn't match any element of match
    if {[llength $::tcltest::match] > 0} {
	set ok 0
	foreach pattern $::tcltest::match {
	    if {[string match $pattern $name]} {
		set ok 1
		break
	    }
        }
	if {!$ok} {
	    incr ::tcltest::numTests(Skipped)
................................................................................
#	file    name of tests file to source
#	args    pattern selecting the tests you want to execute
#
# Results:
#	none

proc ::tcltest::dotests {file args} {
    set savedTests $::tcltest::match
    set ::tcltest::match $args
    source $file
    set ::tcltest::match $savedTests
}

proc ::tcltest::openfiles {} {
    if {[catch {testchannel open} result]} {
	return {}
    }
    return $result

#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: interp.test,v 1.1.2.12 1999/04/06 04:51:22 rjohnson Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# The set of hidden commands is platform dependent:

................................................................................
    for {set code -1} {$code<=5} {incr code} {
	lappend res [interp eval a [list catch [list Test $code] msg]]
    }
    interp delete a
    set res
} {-1 0 1 2 3 4 5}

test interp-26.4 {result code transmission : invoke hidden direct} {knownBug} {
    # The known bug is that code 2 is returned, not the -code argument
    catch {interp delete a}
    interp create a
    set res {}
    interp hide a return
    for {set code -1} {$code<=5} {incr code} {
	lappend res [catch {interp invokehidden a return -code $code ret$code}]
    }
    interp delete a
    set res
} {-1 0 1 2 3 4 5}

test interp-26.5 {result code transmission : invoke hidden indirect} {knownBug} {
    # The known bug is that the break and continue should raise errors
    # that they are used outside a loop.
    catch {interp delete a}
    interp create a
    set res {}
    interp eval a {proc retcode {code} {return -code $code ret$code}}
    interp hide a retcode
................................................................................
    for {set code -1} {$code<=5} {incr code} {
	lappend res [catch {interp invokehidden a retcode $code} msg] $msg
    }
    interp delete a
    set res
} {-1 ret-1 0 ret0 1 ret1 0 ret2 3 ret3 4 ret4 5 ret5}

test interp-26.6 {result code transmission : all combined} {knownBug} {
    # Test that all the possibles error codes from Tcl get passed
    # In both directions.  This doesn't work.
    set interp [interp create];
    proc MyTestAlias {interp args} {
	global aliasTrace;
	lappend aliasTrace $args;
	eval interp invokehidden [list $interp] $args
................................................................................
} {-1 ret-1 0 ret0 1 ret1 0 ret2 3 ret3 4 ret4 5 ret5}

# Some tests might need to be added to check for difference between
# toplevel and non toplevel evals.

# End of return code transmission section

test interp-26.5 {errorInfo transmission : regular interps} {
    set interp [interp create];
    proc MyError {secret} {
	return -code error "msg"
    }
    proc MyTestAlias {interp args} {
	MyError "some secret"
    }
................................................................................
} {msg
    while executing
"MyError "some secret""
    (procedure "MyTestAlias" line 2)
    invoked from within
"test"}

test interp-26.6 {errorInfo transmission : safe interps} {knownBug tasteIssue} {
    # this test fails because the errorInfo is fully transmitted
    # whether the interp is safe or not. this is maybe a feature
    # and not a bug.
    set interp [interp create -safe];
    proc MyError {secret} {
	return -code error "msg"
    }

#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: interp.test,v 1.1.2.13 1999/04/07 01:59:28 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# The set of hidden commands is platform dependent:

................................................................................
    for {set code -1} {$code<=5} {incr code} {
	lappend res [interp eval a [list catch [list Test $code] msg]]
    }
    interp delete a
    set res
} {-1 0 1 2 3 4 5}

test interp-26.4 {result code transmission: invoke hidden direct} {knownBug} {
    # The known bug is that code 2 is returned, not the -code argument
    catch {interp delete a}
    interp create a
    set res {}
    interp hide a return
    for {set code -1} {$code<=5} {incr code} {
	lappend res [catch {interp invokehidden a return -code $code ret$code}]
    }
    interp delete a
    set res
} {-1 0 1 2 3 4 5}

test interp-26.5 {result code transmission: invoke hidden indirect} {knownBug} {
    # The known bug is that the break and continue should raise errors
    # that they are used outside a loop.
    catch {interp delete a}
    interp create a
    set res {}
    interp eval a {proc retcode {code} {return -code $code ret$code}}
    interp hide a retcode
................................................................................
    for {set code -1} {$code<=5} {incr code} {
	lappend res [catch {interp invokehidden a retcode $code} msg] $msg
    }
    interp delete a
    set res
} {-1 ret-1 0 ret0 1 ret1 0 ret2 3 ret3 4 ret4 5 ret5}

test interp-26.6 {result code transmission: all combined} {knownBug} {
    # Test that all the possibles error codes from Tcl get passed
    # In both directions.  This doesn't work.
    set interp [interp create];
    proc MyTestAlias {interp args} {
	global aliasTrace;
	lappend aliasTrace $args;
	eval interp invokehidden [list $interp] $args
................................................................................
} {-1 ret-1 0 ret0 1 ret1 0 ret2 3 ret3 4 ret4 5 ret5}

# Some tests might need to be added to check for difference between
# toplevel and non toplevel evals.

# End of return code transmission section

test interp-26.7 {errorInfo transmission: regular interps} {
    set interp [interp create];
    proc MyError {secret} {
	return -code error "msg"
    }
    proc MyTestAlias {interp args} {
	MyError "some secret"
    }
................................................................................
} {msg
    while executing
"MyError "some secret""
    (procedure "MyTestAlias" line 2)
    invoked from within
"test"}

test interp-26.8 {errorInfo transmission: safe interps} {knownBug} {
    # this test fails because the errorInfo is fully transmitted
    # whether the interp is safe or not. this is maybe a feature
    # and not a bug.
    set interp [interp create -safe];
    proc MyError {secret} {
	return -code error "msg"
    }