tcltest.test

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

	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}
} -result {^$} -output {foo is 2} -match regexp

# test all.tcl usage (runAllTests); simulate .test file failure, as well as
# crashes to determine whether or not these errors are logged.

set atd [makeDirectory alltestdir]
makeFile {
    package require tcltest
    namespace import -force tcltest::*
    testsDirectory [file join [temporaryDirectory] alltestdir]
    runAllTests
} all.tcl $atd
makeFile {
    exit 1
} exit.test $atd
makeFile {
    error "throw an error"
} error.test $atd
makeFile {
    package require tcltest
    namespace import -force tcltest::*
    test foo-1.1 {foo} {
	-body { return 1 }
	-result {1}
    }
    cleanupTests
} test.test $atd

# Must use a child process because stdout/stderr parsing can't be
# duplicated in slave interp.
test tcltest-22.1 {runAllTests} {
    -constraints {unixOrPc}
    -body {
	exec [interpreter] \
		[file join $atd all.tcl] \
		-verbose t -tmpdir [temporaryDirectory]
    }
    -match regexp
    -result "Test files exiting with errors:.*error.test.*exit.test"
}
removeDirectory alltestdir

# makeFile, removeFile, makeDirectory, removeDirectory, viewFile
test tcltest-23.1 {makeFile} {
    -setup {
	set mfdir [file join [temporaryDirectory] mfdir]
	file mkdir $mfdir
    }
    -body {
	makeFile {} t1.tmp
	makeFile {} et1.tmp $mfdir
	list [file exists [file join [temporaryDirectory] t1.tmp]] \
		[file exists [file join $mfdir et1.tmp]]
    }
    -cleanup {
	file delete -force $mfdir \
		[file join [temporaryDirectory] t1.tmp] 
    }
    -result {1 1}
}
test tcltest-23.2 {removeFile} {
    -setup {
	set mfdir [file join [temporaryDirectory] mfdir]
	file mkdir $mfdir
	makeFile {} t1.tmp
	makeFile {} et1.tmp $mfdir
	if  {![file exists [file join [temporaryDirectory] t1.tmp]] || \
		![file exists [file join $mfdir et1.tmp]]} {
	    error "file creation didn't work"
	}
    }
    -body {
	removeFile t1.tmp
	removeFile et1.tmp $mfdir
	list [file exists [file join [temporaryDirectory] t1.tmp]] \
		[file exists [file join $mfdir et1.tmp]]
    }
    -cleanup {
	file delete -force $mfdir \
		[file join [temporaryDirectory] t1.tmp] 
    }
    -result {0 0}
}
test tcltest-23.3 {makeDirectory} {
    -body {
	set mfdir [file join [temporaryDirectory] mfdir]
	file mkdir $mfdir
	makeDirectory d1
	makeDirectory d2 $mfdir
	list [file exists [file join [temporaryDirectory] d1]] \
		[file exists [file join $mfdir d2]]
    }
    -cleanup {
	file delete -force [file join [temporaryDirectory] d1] $mfdir
    }
    -result {1 1}
}
test tcltest-23.4 {removeDirectory} {
    -setup {
	set mfdir [makeDirectory mfdir]
	makeDirectory t1
	makeDirectory t2 $mfdir
	if {![file exists $mfdir] || \
		![file exists [file join [temporaryDirectory] $mfdir t2]]} {
	    error "setup failed - directory not created"
	}
    }
    -body {
	removeDirectory t1
	removeDirectory t2 $mfdir
	list [file exists [file join [temporaryDirectory] t1]] \
		[file exists [file join $mfdir t2]]
    }
    -result {0 0}
}
test tcltest-23.5 {viewFile} {
    -body {
	set mfdir [file join [temporaryDirectory] mfdir]
	file mkdir $mfdir
	makeFile {foobar} t1.tmp
	makeFile {foobarbaz} t2.tmp $mfdir
	list [viewFile t1.tmp] [viewFile t2.tmp $mfdir]
    }
    -result {foobar foobarbaz}
    -cleanup {
	file delete -force $mfdir
	removeFile t1.tmp
    }
}

# customMatch
proc matchNegative { expected actual } {
   set match 0
   foreach a $actual e $expected {
      if { $a != $e } {
         set match 1
        break
      }
   }
   return $match
}

test tcltest-24.0 {
	customMatch: syntax
} -body {
	list [catch {customMatch} result] $result
} -result [list 1 "wrong # args: should be \"customMatch mode script\""]

test tcltest-24.1 {
	customMatch: syntax
} -body {
	list [catch {customMatch foo} result] $result
} -result [list 1 "wrong # args: should be \"customMatch mode script\""]

test tcltest-24.2 {
	customMatch: syntax
} -body {
	list [catch {customMatch foo bar baz} result] $result
} -result [list 1 "wrong # args: should be \"customMatch mode script\""]

test tcltest-24.3 {
	customMatch: argument checking
} -body {
	list [catch {customMatch bad "a \{ b"} result] $result
} -result [list 1 "invalid customMatch script; can't evaluate after completion"]

test tcltest-24.4 {
	test: valid -match values
} -body {
	list [catch {
		test tcltest-24.4.0 {} \
			-match [namespace current]::noSuchMode
	} result] $result
} -match glob -result {1 *bad -match value*}

test tcltest-24.5 {
	test: valid -match values
} -setup {
	customMatch [namespace current]::alwaysMatch "format 1 ;#"
} -body {
	list [catch {
		test tcltest-24.5.0 {} \
			-match [namespace current]::noSuchMode
	} result] $result
} -match glob -result {1 *bad -match value*: must be *alwaysMatch,*}

test tcltest-24.6 {
	customMatch: -match script that always matches
} -setup {
	customMatch [namespace current]::alwaysMatch "format 1 ;#"
	set v [verbose]
} -body {
	verbose {}
	test tcltest-24.6.0 {} -match [namespace current]::alwaysMatch \
		-body {format 1} -result 0
} -cleanup {
	verbose $v
} -result {} -output {} -errorOutput {}

test tcltest-24.7 {
	customMatch: replace default -exact matching
} -setup {
	set saveExactMatchScript $::tcltest::CustomMatch(exact)
	customMatch exact "format 1 ;#"
	set v [verbose]
} -body {
	verbose {}
	test tcltest-24.7.0 {} -body {format 1} -result 0
} -cleanup {
	verbose $v
	customMatch exact $saveExactMatchScript
	unset saveExactMatchScript
} -result {} -output {}

test tcltest-24.9 {
	customMatch: error during match
} -setup {
	proc errorDuringMatch args {return -code error "match returned error"}
	customMatch [namespace current]::errorDuringMatch \
		[namespace code errorDuringMatch]
	set v [verbose]
	set fail $::tcltest::currentFailure
} -body {
	verbose {}
	test tcltest-24.9.0 {} -match [namespace current]::errorDuringMatch
} -cleanup {
	verbose $v
	set ::tcltest::currentFailure $fail
} -match glob -result {} -output {*FAILED*match returned error*}

test tcltest-24.10 {
	customMatch: bad return from match command
} -setup {
	proc nonBooleanReturn args {return foo}
	customMatch nonBooleanReturn [namespace code nonBooleanReturn]
	set v [verbose]
	set fail $::tcltest::currentFailure
} -body {
	verbose {}
	test tcltest-24.10.0 {} -match nonBooleanReturn
} -cleanup {
	verbose $v
	set ::tcltest::currentFailure $fail
} -match glob -result {} -output {*FAILED*expected boolean value*}

test tcltest-24.11 {
	test: -match exact
} -body {
	set result {A B C}
} -match exact -result {A B C}

test tcltest-24.12 {
	test: -match exact	match command eval in ::, not caller namespace
} -setup {
	set saveExactMatchScript $::tcltest::CustomMatch(exact)
	customMatch exact [list string equal]
	set v [verbose]
	proc string args {error {called [string] in caller namespace}}
} -body {
	verbose {}
	test tcltest-24.12.0 {} -body {format 1} -result 1
} -cleanup {
	rename string {}
	verbose $v
	customMatch exact $saveExactMatchScript
	unset saveExactMatchScript
} -match exact -result {} -output {}

test tcltest-24.13 {
	test: -match exact	failure
} -setup {
	set saveExactMatchScript $::tcltest::CustomMatch(exact)
	customMatch exact [list string equal]
	set v [verbose]
	set fail $::tcltest::currentFailure
} -body {
	verbose {}
	test tcltest-24.13.0 {} -body {format 1} -result 0
} -cleanup {
	set ::tcltest::currentFailure $fail
	verbose $v
	customMatch exact $saveExactMatchScript
	unset saveExactMatchScript
} -match glob -result {} -output {*FAILED*Result was:
1*(exact matching):
0*}

test tcltest-24.14 {
	test: -match glob
} -body {
	set result {A B C}
} -match glob -result {A B*}

test tcltest-24.15 {
	test: -match glob	failure
} -setup {
	set v [verbose]
	set fail $::tcltest::currentFailure
} -body {
	verbose {}
	test tcltest-24.15.0 {} -match glob -body {format {A B C}} \
		-result {A B* }
} -cleanup {
	set ::tcltest::currentFailure $fail
	verbose $v
} -match glob -result {} -output {*FAILED*Result was:
*(glob matching):
*}

test tcltest-24.16 {
	test: -match regexp
} -body {
	set result {A B C}
} -match regexp -result {A B.*}

test tcltest-24.17 {
	test: -match regexp	failure
} -setup {
	set fail $::tcltest::currentFailure
	set v [verbose]
} -body {
	verbose {}
	test tcltest-24.17.0 {} -match regexp -body {format {A B C}} \
		-result {A B.* X}
} -cleanup {
	set ::tcltest::currentFailure $fail
	verbose $v
} -match glob -result {} -output {*FAILED*Result was:
*(regexp matching):
*}

test tcltest-24.18 {
	test: -match custom	forget namespace qualification
} -setup {
	set fail $::tcltest::currentFailure
	set v [verbose]
	customMatch negative matchNegative
} -body {
	verbose {}
	test tcltest-24.18.0 {} -match negative -body {format {A B C}} \
		-result {A B X}
} -cleanup {
	set ::tcltest::currentFailure $fail
	verbose $v
} -match glob -result {} -output {*FAILED*Error testing result:*}

test tcltest-24.19 {
	test: -match custom
} -setup {
	set v [verbose]
	customMatch negative [namespace code matchNegative]
} -body {
	verbose {}
	test tcltest-24.19.0 {} -match negative -body {format {A B C}} \
		-result {A B X}
} -cleanup {
	verbose $v
} -match exact -result {} -output {}

test tcltest-24.20 {
	test: -match custom	failure
} -setup {
	set fail $::tcltest::currentFailure
	set v [verbose]
	customMatch negative [namespace code matchNegative]
} -body {
	verbose {}
	test tcltest-24.20.0 {} -match negative -body {format {A B C}} \
		-result {A B C}
} -cleanup {
	set ::tcltest::currentFailure $fail
	verbose $v
} -match glob -result {} -output {*FAILED*Result was:
*(negative matching):
*}

test tcltest-25.1 {
	constraint of setup/cleanup (Bug 589859)
} -setup {
	set foo 0
} -body {
	# Buggy tcltest will generate result of 2
	test tcltest-25.1.0 {} -constraints knownBug -setup {
	    incr foo
	} -body {
	    incr foo
	} -cleanup {
	    incr foo
	} -match glob -result *
	set foo
} -cleanup {
	unset foo
} -result 0

test tcltest-25.2 {
	puts -nonewline (Bug 612786)
} -body {
	puts -nonewline stdout bla
	puts -nonewline stdout bla
} -output {blabla}

test tcltest-25.3 {
	reported return code (Bug 611922)
} -body {
	# Buggy tcltest will generate result of 2
	test tcltest-25.3.0 {} -body {
	    error foo
	}
} -match glob -output {*generated error; Return code was: 1*}


cleanupTests
}

namespace delete ::tcltest::test
return