Tcl Source Code

'\"
'\" Copyright (c) 1990-1994 The Regents of the University of California
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\" Copyright (c) 1998-1999 Scriptics Corporation
'\" Copyright (c) 2000 Ajuba Solutions
'\" Contributions from Don Porter, NIST, 2002. (not subject to US copyright)
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH "tcltest" n 2.3 tcltest "Tcl Bundled Packages"
.TH "tcltest" n 2.5 tcltest "Tcl Bundled Packages"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
tcltest \- Test harness support code and utilities
.SH SYNOPSIS
.nf
\fBpackage require tcltest\fR ?\fB2.3\fR?
\fBpackage require tcltest\fR ?\fB2.5\fR?

\fBtcltest::test \fIname description\fR ?\fI\-option value ...\fR?
\fBtcltest::test \fIname description\fR ?\fIconstraints\fR? \fIbody result\fR

\fBtcltest::loadTestedCommands\fR
\fBtcltest::makeDirectory \fIname\fR ?\fIdirectory\fR?
\fBtcltest::removeDirectory \fIname\fR ?\fIdirectory\fR?

        ?\fB\-setup \fIsetupScript\fR?
        ?\fB\-body \fItestScript\fR?
        ?\fB\-cleanup \fIcleanupScript\fR?
        ?\fB\-result \fIexpectedAnswer\fR?
        ?\fB\-output \fIexpectedOutput\fR?
        ?\fB\-errorOutput \fIexpectedError\fR?
        ?\fB\-returnCodes \fIcodeList\fR?
        ?\fB\-errorCode \fIexpectedErrorCode\fR?
        ?\fB\-match \fImode\fR?
.CE
.PP
The \fIname\fR may be any string.  It is conventional to choose
a \fIname\fR according to the pattern:
.PP
.CS

a list of return codes that may be accepted from evaluation of the
\fB\-body\fR script.  If evaluation of the \fB\-body\fR script returns
a code not in the \fIexpectedCodeList\fR, the test fails.  All
return codes known to \fBreturn\fR, in both numeric and symbolic
form, including extended return codes, are acceptable elements in
the \fIexpectedCodeList\fR.  Default value is
.QW "\fBok return\fR" .
.TP
\fB\-errorCode \fIexpectedErrorCode\fR
.
The optional \fB\-errorCode\fR attribute supplies \fIexpectedErrorCode\fR,
a glob pattern that should match the error code reported from evaluation of the
\fB\-body\fR script.  If evaluation of the \fB\-body\fR script returns
a code not matching \fIexpectedErrorCode\fR, the test fails.  Default value is
.QW "\fB*\fR" .
If \fB\-returnCodes\fR does not include \fBerror\fR it is set to \fBerror\fR.
.PP
To pass, a test must successfully evaluate its \fB\-setup\fR, \fB\-body\fR,
and \fB\-cleanup\fR scripts.  The return code of the \fB\-body\fR script and
its result must match expected values, and if specified, output and error
data from the test must match expected \fB\-output\fR and \fB\-errorOutput\fR
values.  If any of these conditions are not met, then the test fails.
Note that all scripts are evaluated in the context of the caller

set dir [file dirname [info script]]
foreach {safe package version file} {
  0 http            2.9.0 {http http.tcl}
  1 msgcat          1.7.0  {msgcat msgcat.tcl}
  1 opt             0.4.7  {opt optparse.tcl}
  0 platform        1.0.14 {platform platform.tcl}
  0 platform::shell 1.1.4  {platform shell.tcl}
  1 tcltest         2.4.1  {tcltest tcltest.tcl}
  1 tcltest         2.5.0  {tcltest tcltest.tcl}
} {
  if {$isafe && !$safe} continue
  package ifneeded $package $version  [list source [file join $dir {*}$file]]
}

# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex -direct" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if {![package vsatisfies [package provide Tcl] 8.5-]} {return}
package ifneeded tcltest 2.4.1 [list source [file join $dir tcltest.tcl]]
package ifneeded tcltest 2.5.0 [list source [file join $dir tcltest.tcl]]

package require Tcl 8.5-		;# -verbose line uses [info frame]
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.4.1
    variable Version 2.5.0

    # Compatibility support for dumb variables defined in tcltest 1
    # Do not use these.  Call [package provide Tcl] and [info patchlevel]
    # yourself.  You don't need tcltest to wrap it for you.
    variable version [package provide Tcl]
    variable patchLevel [info patchlevel]

#                       optional; default is {}.
#   output -            Expected output sent to stdout.  This attribute
#                       is optional; default is {}.
#   errorOutput -       Expected output sent to stderr.  This attribute
#                       is optional; default is {}.
#   returnCodes -       Expected return codes.  This attribute is
#                       optional; default is {0 2}.
#   errorCode -         Expected error code.  This attribute is
#                       optional; default is {*}. It is a glob pattern.
#                       If given, returnCodes defaults to {1}.
#   setup -             Code to run before $script (above).  This
#                       attribute is optional; default is {}.
#   cleanup -           Code to run after $script (above).  This
#                       attribute is optional; default is {}.
#   match -             specifies type of matching to do on result,
#                       output, errorOutput; this must be a string
#			previously registered by a call to [customMatch].

    FillFilesExisted
    incr testLevel

    # Pre-define everything to null except output and errorOutput.  We
    # determine whether or not to trap output based on whether or not
    # these variables (output & errorOutput) are defined.
    lassign {} constraints setup cleanup body result returnCodes match
    lassign {} constraints setup cleanup body result returnCodes errorCode match

    # Set the default match mode
    set match exact

    # Set the default match values for return codes (0 is the standard
    # expected return value if everything went well; 2 represents
    # 'return' being used in the test script).
    set returnCodes [list 0 2]

    # Set the default error code pattern
    set errorCode "*"

    # The old test format can't have a 3rd argument (constraints or
    # script) that starts with '-'.
    if {[string match -* [lindex $args 0]] || ([llength $args] <= 1)} {
	if {[llength $args] == 1} {
	    set list [SubstArguments [lindex $args 0]]
	    foreach {element value} $list {
		set testAttributes($element) $value
	    }
	    foreach item {constraints match setup body cleanup \
		    result returnCodes output errorOutput} {
		    result returnCodes errorCode output errorOutput} {
		if {[info exists testAttributes(-$item)]} {
		    set testAttributes(-$item) [uplevel 1 \
			    ::concat $testAttributes(-$item)]
		}
	    }
	} else {
	    array set testAttributes $args
	}

	set validFlags {-setup -cleanup -body -result -returnCodes \
		-match -output -errorOutput -constraints}
		-errorCode -match -output -errorOutput -constraints}

	foreach flag [array names testAttributes] {
	    if {$flag ni $validFlags} {
		incr testLevel -1
		set sorted [lsort $validFlags]
		set options [join [lrange $sorted 0 end-1] ", "]
		append options ", or [lindex $sorted end]"

		    must be $values"
	}

	# Replace symbolic valies supplied for -returnCodes
	foreach {strcode numcode} {ok 0 normal 0 error 1 return 2 break 3 continue 4} {
	    set returnCodes [string map -nocase [list $strcode $numcode] $returnCodes]
	}
        # errorCode without returnCode 1 is meaningless
        if {$errorCode ne "*" && 1 ni $returnCodes} {
            set returnCodes 1
        }
    } else {
	# This is parsing for the old test command format; it is here
	# for backward compatibility.
	set result [lindex $args end]
	if {[llength $args] == 2} {
	    set body [lindex $args 0]
	} elseif {[llength $args] == 3} {

	}
    }

    # First, run the setup script
    set code [catch {uplevel 1 $setup} setupMsg]
    if {$code == 1} {
	set errorInfo(setup) $::errorInfo
	set errorCode(setup) $::errorCode
	set errorCodeRes(setup) $::errorCode
    }
    set setupFailure [expr {$code != 0}]

    # Only run the test body if the setup was successful
    if {!$setupFailure} {

	# Register startup time

	    set testResult [uplevel 1 [list [namespace origin Eval] $command 0]]
	} else {
	    set testResult [uplevel 1 [list [namespace origin Eval] $command 1]]
	}
	lassign $testResult actualAnswer returnCode
	if {$returnCode == 1} {
	    set errorInfo(body) $::errorInfo
	    set errorCode(body) $::errorCode
	    set errorCodeRes(body) $::errorCode
	}
    }

    # check if the return code matched the expected return code
    set codeFailure 0
    if {!$setupFailure && ($returnCode ni $returnCodes)} {
	set codeFailure 1
    }
    set errorCodeFailure 0
    if {!$setupFailure && !$codeFailure && $returnCode == 1 && \
                ![string match $errorCode $errorCodeRes(body)]} {
	set errorCodeFailure 1
    }

    # If expected output/error strings exist, we have to compare
    # them.  If the comparison fails, then so did the test.
    set outputFailure 0
    variable outData
    if {[info exists output] && !$codeFailure} {

	set scriptFailure 1
    }

    # Always run the cleanup script
    set code [catch {uplevel 1 $cleanup} cleanupMsg]
    if {$code == 1} {
	set errorInfo(cleanup) $::errorInfo
	set errorCode(cleanup) $::errorCode
	set errorCodeRes(cleanup) $::errorCode
    }
    set cleanupFailure [expr {$code != 0}]

    set coreFailure 0
    set coreMsg ""
    # check for a core file first - if one was created by the test,
    # then the test failed

	}
    }

    # if we didn't experience any failures, then we passed
    variable numTests
    if {!($setupFailure || $cleanupFailure || $coreFailure
	    || $outputFailure || $errorFailure || $codeFailure
	    || $scriptFailure)} {
	    || $errorCodeFailure || $scriptFailure)} {
	if {$testLevel == 1} {
	    incr numTests(Passed)
	    if {[IsVerbose pass]} {
		puts [outputChannel] "++++ $name PASSED"
	    }
	}
	incr testLevel -1

	puts [outputChannel] $body
    }
    if {$setupFailure} {
	puts [outputChannel] "---- Test setup\
		failed:\n$setupMsg"
	if {[info exists errorInfo(setup)]} {
	    puts [outputChannel] "---- errorInfo(setup): $errorInfo(setup)"
	    puts [outputChannel] "---- errorCode(setup): $errorCode(setup)"
	    puts [outputChannel] "---- errorCode(setup): $errorCodeRes(setup)"
	}
    }
    if {$scriptFailure} {
	if {$scriptCompare} {
	    puts [outputChannel] "---- Error testing result: $scriptMatch"
	} else {
	    puts [outputChannel] "---- Result was:\n$actualAnswer"
	    puts [outputChannel] "---- Result should have been\
		    ($match matching):\n$result"
	}
    }
    if {$errorCodeFailure} {
	puts [outputChannel] "---- Error code was: '$errorCodeRes(body)'"
	puts [outputChannel] "---- Error code should have been: '$errorCode'"
    }
    if {$codeFailure} {
	switch -- $returnCode {
	    0 { set msg "Test completed normally" }
	    1 { set msg "Test generated error" }
	    2 { set msg "Test generated return exception" }
	    3 { set msg "Test generated break exception" }
	    4 { set msg "Test generated continue exception" }
	    default { set msg "Test generated exception" }
	}
	puts [outputChannel] "---- $msg; Return code was: $returnCode"
	puts [outputChannel] "---- Return code should have been\
		one of: $returnCodes"
	if {[IsVerbose error]} {
	    if {[info exists errorInfo(body)] && (1 ni $returnCodes)} {
		puts [outputChannel] "---- errorInfo: $errorInfo(body)"
		puts [outputChannel] "---- errorCode: $errorCode(body)"
		puts [outputChannel] "---- errorCode: $errorCodeRes(body)"
	    }
	}
    }
    if {$outputFailure} {
	if {$outputCompare} {
	    puts [outputChannel] "---- Error testing output: $outputMatch"
	} else {

		    been ($match matching):\n$errorOutput"
	}
    }
    if {$cleanupFailure} {
	puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg"
	if {[info exists errorInfo(cleanup)]} {
	    puts [outputChannel] "---- errorInfo(cleanup): $errorInfo(cleanup)"
	    puts [outputChannel] "---- errorCode(cleanup): $errorCode(cleanup)"
	    puts [outputChannel] "---- errorCode(cleanup): $errorCodeRes(cleanup)"
	}
    }
    if {$coreFailure} {
	puts [outputChannel] "---- Core file produced while running\
		test!  $coreMsg"
    }
    puts [outputChannel] "==== $name FAILED\n"

# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#-----------------------------------------------------------------------------

# Commands covered: assemble

if {"::tcltest" ni [namespace children]} {
    package require tcltest 2.2
    package require tcltest 2.5
    namespace import -force ::tcltest::*
}
namespace eval tcl::unsupported {namespace export assemble}
namespace import tcl::unsupported::assemble

# Procedure to make code that fills the literal and local variable tables, to
# force instructions to spill to four bytes.

    -result {1 {cannot use this instruction to create a variable in a non-proc context} {TCL ASSEM LVT}}
    -cleanup {unset result}
}
test assemble-8.5 {bad context} {
    -body {
	namespace eval assem {
	    set x 1
	    list [catch {assemble {load x}} result opts] $result [dict get $opts -errorcode]
	    assemble {load x}
	}
    }
    -result {1 {cannot use this instruction to create a variable in a non-proc context} {TCL ASSEM LVT}}
    -result {cannot use this instruction to create a variable in a non-proc context}
    -errorCode {TCL ASSEM LVT}
    -cleanup {namespace delete assem}
}
test assemble-8.6 {load1} {
    -body {
	proc x {a} {
	    assemble {
		load a

    -body {
	assemble {push h; push e; push l; push l; push o; concat 5}
    }
    -result hello
}
test assemble-9.7 {concat} {
    -body {
	list [catch {assemble {concat 0}} result] $result $::errorCode
	assemble {concat 0}
    }
    -result {1 {operand must be positive} {TCL ASSEM POSITIVE}}
    -cleanup {unset result}
    -result {operand must be positive}
    -errorCode {TCL ASSEM POSITIVE}
}

# assemble-10 -- eval and expr

test assemble-10.1 {eval - wrong # args} {
    -body {
	assemble {eval}

# This test file covers the dictionary object type and the dict command used
# to work with values of that type.
#
# 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 generates output
# for errors.  No output means no errors were found.
#
# Copyright (c) 2003-2009 Donal K. Fellows
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    package require tcltest 2.5
    namespace import -force ::tcltest::*
}

# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
    proc memtest script {

    dict replace { a b  c d }
} {a b c d}
test dict-4.12 {dict replace command: canonicality is forced} {
    dict replace {a b c d a e}
} {a e c d}
test dict-4.13 {dict replace command: type check is mandatory} -body {
    dict replace { a b c d e }
} -returnCodes error -result {missing value to go with key}
} -errorCode {TCL VALUE DICTIONARY} -result {missing value to go with key}
test dict-4.13a {dict replace command: type check is mandatory} {
    catch {dict replace { a b c d e }} -> opt
    dict get $opt -errorcode
} {TCL VALUE DICTIONARY}
test dict-4.14 {dict replace command: type check is mandatory} -body {
    dict replace { a b {}c d }
} -returnCodes error -result {dict element in braces followed by "c" instead of space}
test dict-4.14a {dict replace command: type check is mandatory} {
    catch {dict replace { a b {}c d }} -> opt
    dict get $opt -errorcode
} {TCL VALUE DICTIONARY JUNK}

} -returnCodes error -result {unmatched open quote in dict}
test dict-4.16a {dict replace command: type check is mandatory} {
    catch {dict replace " a b \"c d "} -> opt
    dict get $opt -errorcode
} {TCL VALUE DICTIONARY QUOTE}
test dict-4.17 {dict replace command: type check is mandatory} -body {
    dict replace " a b \{c d "
} -returnCodes error -result {unmatched open brace in dict}
} -errorCode {TCL VALUE DICTIONARY BRACE} -result {unmatched open brace in dict}
test dict-4.17a {dict replace command: type check is mandatory} {
    catch {dict replace " a b \{c d "} -> opt
    dict get $opt -errorcode
} {TCL VALUE DICTIONARY BRACE}
test dict-4.18 {dict replace command: canonicality forcing doesn't leak} {
    set example { a b  c d }
    list $example [dict replace $example]
} {{ a b  c d } {a b c d}}

test dict-5.1 {dict remove command} {dict remove {a b c d} a} {c d}
test dict-5.2 {dict remove command} {dict remove {a b c d} c} {a b}

# Copyright (c) 1994-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.

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    package require tcltest 2.5
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

package require tcltests

    close $f
    string compare [string tolower $x] \
	[list 1 [format "channel \"%s\" wasn't opened for reading" $f] none]
} 0
test iocmd-4.12 {read command} -setup {
    set f [open $path(test1)]
} -body {
    list [catch {read $f 12z} msg] $msg $::errorCode
    read $f 12z
} -cleanup {
    close $f
} -result {1 {expected non-negative integer but got "12z"} {TCL VALUE NUMBER}}
} -result {expected non-negative integer but got "12z"} -errorCode {TCL VALUE NUMBER}

test iocmd-5.1 {seek command} -returnCodes error -body {
    seek
} -result {wrong # args: should be "seek channelId offset ?origin?"}
test iocmd-5.2 {seek command} -returnCodes error -body {
    seek a b c d e f g
} -result {wrong # args: should be "seek channelId offset ?origin?"}

# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 by Scriptics Corporation.
# Contributions from Don Porter, NIST, 2003.  (not subject to US copyright)
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

if {[catch {package require tcltest 2.1}]} {
    puts stderr "Skipping tests in [info script]. tcltest 2.1 required."
if {[catch {package require tcltest 2.5}]} {
    puts stderr "Skipping tests in [info script]. tcltest 2.5 required."
    return
}

namespace eval ::tcl::test::source {
    namespace import ::tcltest::*

test source-1.1 {source command} -setup {

} -cleanup {
    removeFile source.file
} -returnCodes continue
test source-2.6 {source error conditions} -setup {
    set sourcefile [makeFile {} _non_existent_]
    removeFile _non_existent_
} -body {
    list [catch {source $sourcefile} msg] $msg $::errorCode
    source $sourcefile
} -match listGlob -result [list 1 \
	{couldn't read file "*_non_existent_": no such file or directory} \
	{POSIX ENOENT {no such file or directory}}]
} -match glob -result {couldn't read file "*_non_existent_": no such file or directory} \
	-errorCode {POSIX ENOENT {no such file or directory}}
test source-2.7 {utf-8 with BOM} -setup {
    set sourcefile [makeFile {} source.file]
} -body {
    set out [open $sourcefile w]
    fconfigure $out -encoding utf-8
    puts $out "\ufeffset y new-y"
    close $out

test tcltest-21.2 {force a test command failure} {
    -body {
	test tcltest-21.2.0 {
	    return 2
	} {1}
    }
    -returnCodes 1
    -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
    -result {bad option "1": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
}

test tcltest-21.3 {test command with setup} {
    -setup {
	set foo 1
    }
    -body {

    -cleanup {set ::tcltest::currentFailure $fail}
    -body {
	test tcltest-21.7.0 {foo-4} {
	    -foobar {}
	}
    }
    -returnCodes 1
    -result {bad option "-foobar": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
    -result {bad option "-foobar": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
}

# alternate test command format (these are the same as 21.1-21.6, with the
# exception of being in the all-inline format)

test tcltest-21.7a {expect with glob} \
	-body {list a b c d e} \
	-result {[ab] b c d e} \
	-match glob

test tcltest-21.8 {force a test command failure} \
    -setup {set fail $::tcltest::currentFailure} \
    -body {
        test tcltest-21.8.0 {
            return 2
        } {1}
    } \
    -returnCodes 1 \
    -cleanup {set ::tcltest::currentFailure $fail} \
    -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
    -result {bad option "1": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup}

test tcltest-21.9 {test command with setup} \
	-setup {set foo 1} \
	-body {set foo} \
	-cleanup {unset foo} \
	-result {1}

	@echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/"
	@for i in $(TOP_DIR)/library/opt/*.tcl ; do \
	    $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \
	done
	@echo "Installing package msgcat 1.7.0 as a Tcl Module"
	@$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl \
		"$(MODULE_INSTALL_DIR)"/tcl8/8.7/msgcat-1.7.0.tm
	@echo "Installing package tcltest 2.4.1 as a Tcl Module"
	@echo "Installing package tcltest 2.5.0 as a Tcl Module"
	@$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl \
		"$(MODULE_INSTALL_DIR)"/tcl8/8.5/tcltest-2.4.1.tm
		"$(MODULE_INSTALL_DIR)"/tcl8/8.5/tcltest-2.5.0.tm
	@echo "Installing package platform 1.0.14 as a Tcl Module"
	@$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl \
		"$(MODULE_INSTALL_DIR)"/tcl8/8.4/platform-1.0.14.tm
	@echo "Installing package platform::shell 1.1.4 as a Tcl Module"
	@$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl \
		"$(MODULE_INSTALL_DIR)"/tcl8/8.4/platform/shell-1.1.4.tm
	@echo "Installing encoding files to $(SCRIPT_INSTALL_DIR)/encoding/"