tcltest.test

来自「tcl是工具命令语言」· TEST 代码 · 共 1,734 行 · 第 1/4 页

# -singleproc, [singleProcess]
set spd [makeDirectory singleprocdir]
makeFile {
    set foo 1
} single1.test $spd

makeFile {
    unset foo
} single2.test $spd

set allfile [makeFile {
    package require tcltest
    namespace import tcltest::*
    testsDirectory [file join [temporaryDirectory] singleprocdir]
    runAllTests
} all-single.tcl $spd]
cd [workingDirectory]

test tcltest-14.1 {-singleproc - single process} {
    -constraints {unixOrPc}
    -body {
	slave msg $allfile -singleproc 0 -tmpdir [temporaryDirectory]
	set msg
    }
    -result {Test file error: can't unset .foo.: no such variable}
    -match regexp
}

test tcltest-14.2 {-singleproc - multiple process} {
    -constraints {unixOrPc}
    -body {
	slave msg $allfile -singleproc 1 -tmpdir [temporaryDirectory]
	set msg
    }
    -result {single1.test.*single2.test.*all\-single.tcl:.*Total.*0.*Passed.*0.*Skipped.*0.*Failed.*0}
    -match regexp
}

test tcltest-14.3 {singleProcess} {
    -setup {
	set old $::tcltest::singleProcess
	set ::tcltest::singleProcess 0
    }
    -body {
	set f1 [singleProcess]
	set f2 [singleProcess 1]
	set f3 [singleProcess]
	list $f1 $f2 $f3
    }
    -result {0 1 1}
    -cleanup {
	set ::tcltest::singleProcess $old
    }
}
removeFile single1.test $spd
removeFile single2.test $spd
removeDirectory singleprocdir

# -asidefromdir, -relateddir, [matchDirectories], [skipDirectories]

# Before running these tests, need to set up test subdirectories with their own
# all.tcl files.

set dtd [makeDirectory dirtestdir]
set dtd1 [makeDirectory dirtestdir2.1 $dtd]
set dtd2 [makeDirectory dirtestdir2.2 $dtd]
set dtd3 [makeDirectory dirtestdir2.3 $dtd]
makeFile {
    package require tcltest
    namespace import -force tcltest::*
    testsDirectory [file join [temporaryDirectory] dirtestdir]
    runAllTests
} all.tcl $dtd
makeFile {
    package require tcltest
    namespace import -force tcltest::*
    testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.1]
    runAllTests
} all.tcl $dtd1
makeFile {
    package require tcltest
    namespace import -force tcltest::*
    testsDirectory [file join [temporaryDirectory]  dirtestdir dirtestdir2.2]
    runAllTests
} all.tcl $dtd2
makeFile {
    package require tcltest
    namespace import -force tcltest::*
    testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.3]
    runAllTests
} all.tcl $dtd3

test tcltest-15.1 {basic directory walking} {
    -constraints {unixOrPc}
    -body {
	if {[slave msg \
		[file join $dtd all.tcl] \
		-tmpdir [temporaryDirectory]] == 1} {
	    error $msg
	}
    }
    -match regexp
    -returnCodes 1
    -result {Tests located in:.*dirtestdir.*Tests located in:.*dirtestdir2.1.*Tests located in:.*dirtestdir2.2.*Tests located in:.*dirtestdir2.3}
}

test tcltest-15.2 {-asidefromdir} {
    -constraints {unixOrPc}
    -body {
	if {[slave msg \
		[file join $dtd all.tcl] \
		-asidefromdir dirtestdir2.3 \
		-tmpdir [temporaryDirectory]] == 1} {
	    error $msg
	}
    }
    -match regexp
    -returnCodes 1
    -result {Tests located in:.*dirtestdir.*Tests located in:.*dirtestdir2.1.*Tests located in:.*dirtestdir2.2.*dirtestdir2.2 test ended at .*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Error:  No test files remain after applying your match and skip patterns!
Error:  No test files remain after applying your match and skip patterns!
Error:  No test files remain after applying your match and skip patterns!$}
}

test tcltest-15.3 {-relateddir, non-existent dir} {
    -constraints {unixOrPc}
    -body {
	if {[slave msg \
		[file join $dtd all.tcl] \
		-relateddir [file join [temporaryDirectory] dirtestdir0] \
		-tmpdir [temporaryDirectory]] == 1} {
	    error $msg
	}
    }
    -returnCodes 1
    -match regexp
    -result {[^~]|dirtestdir[^2]}
}

test tcltest-15.4 {-relateddir, subdir} {
    -constraints {unixOrPc}
    -body {
	if {[slave msg \
		[file join $dtd all.tcl] \
		-relateddir dirtestdir2.1 -tmpdir [temporaryDirectory]] == 1} {
	    error $msg
	}
    }
    -returnCodes 1
    -match regexp
    -result {Tests located in:.*dirtestdir2.[^23]}
}
test tcltest-15.5 {-relateddir, -asidefromdir} {
    -constraints {unixOrPc}
    -body {
	if {[slave msg \
		[file join $dtd all.tcl] \
		-relateddir "dirtestdir2.1 dirtestdir2.2" \
		-asidefromdir dirtestdir2.2 \
		-tmpdir [temporaryDirectory]] == 1} {
	    error $msg
	}
    }
    -match regexp
    -returnCodes 1
    -result {Tests located in:.*dirtestdir2.[^23]}
}

test tcltest-15.6 {matchDirectories} {
    -setup {
	set old [matchDirectories]
	set ::tcltest::matchDirectories {}
    }
    -body {
	set r1 [matchDirectories]
	set r2 [matchDirectories foo]
	set r3 [matchDirectories]
	list $r1 $r2 $r3
    }
    -cleanup {
	set ::tcltest::matchDirectories $old
    }
    -result {{} foo foo}
}

test tcltest-15.7 {skipDirectories} {
    -setup {
	set old [skipDirectories]
	set ::tcltest::skipDirectories {}
    }
    -body {
	set r1 [skipDirectories]
	set r2 [skipDirectories foo]
	set r3 [skipDirectories]
	list $r1 $r2 $r3
    }
    -cleanup {
	set ::tcltest::skipDirectories $old
    }
    -result {{} foo foo}
}
removeDirectory dirtestdir2.3 $dtd
removeDirectory dirtestdir2.2 $dtd
removeDirectory dirtestdir2.1 $dtd
removeDirectory dirtestdir

# TCLTEST_OPTIONS
test tcltest-19.1 {TCLTEST_OPTIONS default} {
    -constraints {unixOrPc singleTestInterp}
    -setup {
	if {[info exists ::env(TCLTEST_OPTIONS)]} {
	    set oldoptions $::env(TCLTEST_OPTIONS)
	    unset ::env(TCLTEST_OPTIONS)
	} else {
	    set oldoptions none
	}
	# set this to { } instead of just {} to get around quirk in
	# Windows env handling that removes empty elements from env array.
	set ::env(TCLTEST_OPTIONS) { }
	set olddebug [debug]
	debug 2
    }
    -cleanup {
	if {$oldoptions == "none"} {
	    unset ::env(TCLTEST_OPTIONS) 
	} else {
	    set ::env(TCLTEST_OPTIONS) $oldoptions
	}
	debug $olddebug
    }
    -body {
	::tcltest::ProcessCmdLineArgs
	set ::env(TCLTEST_OPTIONS) "-debug 3"
	::tcltest::ProcessCmdLineArgs
    }
    -result {^$}
    -match regexp
    -output {tcltest::debug\s+= 2.*tcltest::debug\s+= 3}
}

# Begin testing of tcltest procs ...

cd [temporaryDirectory]
# PrintError
test tcltest-20.1 {PrintError} {unixOrPc} {
    set result [slave msg $printerror]
    list $result [regexp "Error:  a really short string" $msg] \
	    [regexp "     \"quotes\"" $msg] [regexp "    \"Path" $msg] \
	    [regexp "    \"Really" $msg] [regexp Problem $msg]
} {1 1 1 1 1 1}
cd [workingDirectory]
removeFile printerror.tcl

# test::test
test tcltest-21.0 {name and desc but no args specified} -setup {
    set v [verbose]
} -cleanup {
    verbose $v
} -body {
   verbose {}
   test tcltest-21.0.0 bar
} -result {}

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

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}
}

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

test tcltest-21.4 {test command with cleanup failure} {
    -setup {
	if {[info exists foo]} {
	    unset foo
	}
	set fail $::tcltest::currentFailure
	set v [verbose]
    }
    -body {
	verbose {}
	test tcltest-21.4.0 {foo-1} {
	    -cleanup {unset foo}
	}
    }
    -result {^$}
    -match regexp
    -cleanup {verbose $v; set ::tcltest::currentFailure $fail}
    -output "Test cleanup failed:.*can't unset \"foo\": no such variable"
}

test tcltest-21.5 {test command with setup failure} {
    -setup {
	if {[info exists foo]} {
	    unset foo
	}
	set fail $::tcltest::currentFailure
    }
    -body {
	test tcltest-21.5.0 {foo-2} {
	    -setup {unset foo}
	}
    }
    -result {^$}
    -match regexp
    -cleanup {set ::tcltest::currentFailure $fail}
    -output "Test setup failed:.*can't unset \"foo\": no such variable"
}

test tcltest-21.6 {test command - setup occurs before cleanup & before script} {
    -setup {set v [verbose]; set fail $::tcltest::currentFailure}
    -body {
	verbose {}
	test tcltest-21.6.0 {foo-3} {
	    -setup {
		if {[info exists foo]} {
		    unset foo
		}
		set foo 1
		set expected 2
	    } 
	    -body {
		incr foo
		set foo
	    }
	    -cleanup {
		if {$foo != 2} {
		    puts [outputChannel] "foo is wrong"
		} else {
		    puts [outputChannel] "foo is 2"
		}
	    }
	    -result {$expected}
	}
    }
    -cleanup {verbose $v; set ::tcltest::currentFailure $fail}
    -result {^$}
    -match regexp
    -output "foo is 2"
}

test tcltest-21.7 {test command - bad flag} {
    -setup {set fail $::tcltest::currentFailure}
    -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}
}

# 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}

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

test tcltest-21.10 {test command with cleanup failure} -setup {
    if {[info exists foo]} {
	unset foo
    }
    set fail $::tcltest::currentFailure
    set v [verbose]
} -cleanup {
    verbose $v
    set ::tcltest::currentFailure $fail
} -body {
    verbose {}
    test tcltest-21.10.0 {foo-1} -cleanup {unset foo}
} -result {^$} -match regexp \
	-output {Test cleanup failed:.*can't unset \"foo\": no such variable}

test tcltest-21.11 {test command with setup failure} -setup {
    if {[info exists foo]} {
	unset foo
    }
    set fail $::tcltest::currentFailure
} -cleanup {set ::tcltest::currentFailure $fail} -body {
    test tcltest-21.11.0 {foo-2} -setup {unset foo}
} -result {^$} -output {Test setup failed:.*can't unset \"foo\": no such variable} -match regexp

test tcltest-21.12 {
	test command - setup occurs before cleanup & before script
} -setup {
	set fail $::tcltest::currentFailure
	set v [verbose]
} -cleanup {
	verbose $v
	set ::tcltest::currentFailure $fail
} -body {
    verbose {}
    test tcltest-21.12.0 {foo-3} -setup {