tcltest.test

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

	set ::tcltest::outputChannel stdout
    }
    -body {
	outputChannel
    }
    -result {stdout}
    -cleanup {
	set tcltest::outputChannel $of
    }
}

test tcltest-6.8 {tcltest::outputFile (implicit outputFile)} {
    -setup {
	set ef [makeFile {} efile]
	set of [outputFile]
	set ::tcltest::outputChannel stdout
	set ::tcltest::outputFile stdout
    }
    -body {
	set f0 [outputChannel]
	set f1 [outputFile]
	set f2 [outputFile $ef]
	set f3 [outputChannel]
	set f4 [outputFile]
	subst {$f0;$f1;$f2;$f3;$f4} 
    }
    -result {stdout;stdout;.*efile;file[0-9a-f]+;.*efile}
    -match regexp
    -cleanup {
	outputFile $of
	removeFile efile
    }
}

# -debug, [debug]
# Must use child processes to test -debug because it always writes
# messages to stdout, and we have no way to capture stdout of a
# slave interp
test tcltest-7.1 {tcltest test.tcl -debug 0} {unixOrPc} {
    catch {exec [interpreter] test.tcl -debug 0} msg
    regexp "Flags passed into tcltest" $msg
} {0}
test tcltest-7.2 {tcltest test.tcl -debug 1} {unixOrPc} {
    catch {exec [interpreter] test.tcl -debug 1 -skip b*} msg
    list [regexp userSpecifiedSkip $msg] \
	    [regexp "Flags passed into tcltest" $msg]
} {1 0}
test tcltest-7.3 {tcltest test.tcl -debug 1} {unixOrPc} {
    catch {exec [interpreter] test.tcl -debug 1 -match b*} msg
    list [regexp userSpecifiedNonMatch $msg] \
	    [regexp "Flags passed into tcltest" $msg]
} {1 0}
test tcltest-7.4 {tcltest test.tcl -debug 2} {unixOrPc} {
    catch {exec [interpreter] test.tcl -debug 2} msg
    list [regexp "Flags passed into tcltest" $msg] [regexp "Running" $msg]
} {1 0}
test tcltest-7.5 {tcltest test.tcl -debug 3} {unixOrPc} {
    catch {exec [interpreter] test.tcl -debug 3} msg
    list [regexp "Flags passed into tcltest" $msg] [regexp "Running" $msg]
} {1 1}

test tcltest-7.6 {tcltest::debug} {
    -setup {
	set old $::tcltest::debug
	set ::tcltest::debug 0
    }
    -body {
	set f1 [debug]
	set f2 [debug 1]
	set f3 [debug]
	set f4 [debug 2]
	set f5 [debug]
	list $f1 $f2 $f3 $f4 $f5
    }
    -result {0 1 1 2 2}
    -cleanup {
	set ::tcltest::debug $old
    }
}
removeFile test.tcl

# directory tests

set a [makeFile {
    package require tcltest
    tcltest::makeFile {} a.tmp
    puts [tcltest::outputChannel] "testdir: [tcltest::testsDirectory]"
    exit
} a.tcl]

set tdiaf [makeFile {} thisdirectoryisafile]

set normaldirectory [makeDirectory normaldirectory]
if {$::tcl_platform(platform) == "macintosh"} {
set normaldirectory [file normalize $normaldirectory]
}

# -tmpdir, [temporaryDirectory]
test tcltest-8.1 {tcltest a.tcl -tmpdir a} {unixOrPc} {
    file delete -force thisdirectorydoesnotexist
    slave msg $a -tmpdir thisdirectorydoesnotexist
    list [file exists [file join thisdirectorydoesnotexist a.tmp]] \
	    [file delete -force thisdirectorydoesnotexist] 
} {1 {}}
test tcltest-8.2 {tcltest a.tcl -tmpdir thisdirectoryisafile} {
    -constraints unixOrPc
    -body {
	slave msg $a -tmpdir $tdiaf
	set msg
    }
    -result {*not a directory*}
    -match glob
}

# Test non-writeable directories, non-readable directories with directory flags
set notReadableDir [file join [temporaryDirectory] notreadable]
set notWriteableDir [file join [temporaryDirectory] notwriteable]

makeDirectory notreadable
makeDirectory notwriteable

switch $tcl_platform(platform) {
    "unix" {
	file attributes $notReadableDir -permissions 00333
	file attributes $notWriteableDir -permissions 00555
    }
    default {
	catch {file attributes $notWriteableDir -readonly 1}
    }
}

test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} {unixOnly nonRoot} {
    slave msg $a -tmpdir $notReadableDir 
    string match {*not readable*} $msg
} {1}

test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} {unixOrPc nonRoot} {
    slave msg $a -tmpdir $notWriteableDir
    string match {*not writeable*} $msg
} {1}

test tcltest-8.5 {tcltest a.tcl -tmpdir normaldirectory} {unixOrPc} {
    slave msg $a -tmpdir $normaldirectory
    # The join is necessary because the message can be split on multiple lines
    list [file exists [file join $normaldirectory a.tmp]] \
	    [file delete [file join $normaldirectory a.tmp]] 
} {1 {}}   
cd [workingDirectory]

test tcltest-8.6 {temporaryDirectory}  {
    -setup {
	set old $::tcltest::temporaryDirectory
	set ::tcltest::temporaryDirectory $normaldirectory
    }
    -body {
	set f1 [temporaryDirectory]
	set f2 [temporaryDirectory [workingDirectory]]
	set f3 [temporaryDirectory]
	list $f1 $f2 $f3
    }
    -result "[list $normaldirectory [workingDirectory] [workingDirectory]]"
    -cleanup {
	set ::tcltest::temporaryDirectory $old
    }
}

test tcltest-8.6a {temporaryDirectory - test format 2} -setup {
    set old $::tcltest::temporaryDirectory
    set ::tcltest::temporaryDirectory $normaldirectory
} -body {
    set f1 [temporaryDirectory]
    set f2 [temporaryDirectory [workingDirectory]]
    set f3 [temporaryDirectory]
    list $f1 $f2 $f3
} -cleanup {
    set ::tcltest::temporaryDirectory $old
} -result [list $normaldirectory [workingDirectory] [workingDirectory]]

cd [temporaryDirectory]
# -testdir, [testsDirectory]
test tcltest-8.10 {tcltest a.tcl -testdir thisdirectorydoesnotexist} {unixOrPc} {
    file delete -force thisdirectorydoesnotexist
    slave msg $a -testdir thisdirectorydoesnotexist
    string match "*does not exist*" $msg
} {1}

test tcltest-8.11 {tcltest a.tcl -testdir thisdirectoryisafile} {unixOrPc} {
    slave msg $a -testdir $tdiaf
    string match "*not a directory*" $msg 
} {1}

test tcltest-8.12 {tcltest a.tcl -testdir notReadableDir} {unixOnly nonRoot} {
    slave msg $a -testdir $notReadableDir 
    string match {*not readable*} $msg
} {1}


test tcltest-8.13 {tcltest a.tcl -testdir normaldirectory} {unixOrPc} {
    slave msg $a -testdir $normaldirectory
    # The join is necessary because the message can be split on multiple lines
    list [string first "testdir: $normaldirectory" [join $msg]] \
	    [file exists [file join [temporaryDirectory] a.tmp]] \
	    [file delete [file join [temporaryDirectory] a.tmp]] 
} {0 1 {}} 
cd [workingDirectory]

set current [pwd]
test tcltest-8.14 {testsDirectory} {
    -setup {
	set old $::tcltest::testsDirectory
	set ::tcltest::testsDirectory $normaldirectory
    }
    -body {
	set f1 [testsDirectory]
	set f2 [testsDirectory $current]
	set f3 [testsDirectory]
	list $f1 $f2 $f3
    }
    -result "[list $normaldirectory $current $current]"
    -cleanup {
	set ::tcltest::testsDirectory $old
    }
}

# [workingDirectory]
test tcltest-8.60 {::workingDirectory}  {
    -setup {
	set old $::tcltest::workingDirectory
	set current [pwd]
	set ::tcltest::workingDirectory $normaldirectory
	cd $normaldirectory
    }
    -body {
	set f1 [workingDirectory]
	set f2 [pwd]
	set f3 [workingDirectory $current]
	set f4 [pwd] 
	set f5 [workingDirectory]
	list $f1 $f2 $f3 $f4 $f5
    }
    -result "[list $normaldirectory \
                   $normaldirectory \
                   $current \
                   $current \
                   $current]"
    -cleanup {
	set ::tcltest::workingDirectory $old
	cd $current
    }
}

# clean up from directory testing

switch $tcl_platform(platform) {
    "unix" {
	file attributes $notReadableDir -permissions 777
	file attributes $notWriteableDir -permissions 777
    }
    default {
	catch {file attributes $notWriteableDir -readonly 0}
    }
}

file delete -force $notReadableDir $notWriteableDir
removeFile a.tcl
removeFile thisdirectoryisafile
removeDirectory normaldirectory

# -file, -notfile, [matchFiles], [skipFiles]
test tcltest-9.1 {-file a*.tcl} {unixOrPc} {
    slave msg [file join [testsDirectory] all.tcl] -file a*.test
    list [regexp assocd\.test $msg]
} {1}
test tcltest-9.2 {-file a*.tcl} {unixOrPc} {
    slave msg [file join [testsDirectory] all.tcl] \
	    -file a*.test -notfile assocd*
    list [regexp assocd\.test $msg]
} {0}

test tcltest-9.3 {matchFiles}  {
    -body {
	set old [matchFiles]
	matchFiles foo
	set current [matchFiles]
	matchFiles bar
	set new [matchFiles]
	matchFiles $old
	list $current $new
    } 
    -result {foo bar}
}

test tcltest-9.4 {skipFiles} {
    -body {
	set old [skipFiles]
	skipFiles foo
	set current [skipFiles]
	skipFiles bar
	set new [skipFiles]
	skipFiles $old
	list $current $new
    } 
    -result {foo bar}
}

# -preservecore, [preserveCore]
set mc [makeFile {
    package require tcltest
    namespace import ::tcltest::test
    test makecore {make a core file} {
	set f [open core w]
	close $f
    } {}
    ::tcltest::cleanupTests
    return
} makecore.tcl]

cd [temporaryDirectory]
test tcltest-10.1 {-preservecore 0} {unixOrPc} {
    slave msg $mc -preservecore 0
    file delete core
    regexp "Core file produced" $msg
} {0}
test tcltest-10.2 {-preservecore 1} {unixOrPc} {
    slave msg $mc -preservecore 1
    file delete core
    regexp "Core file produced" $msg
} {1}
test tcltest-10.3 {-preservecore 2} {unixOrPc} {
    slave msg $mc -preservecore 2
    file delete core
    list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \
	    [regexp "core-" $msg] [file delete core-makecore]
} {1 1 1 {}}
test tcltest-10.4 {-preservecore 3} {unixOrPc} {
    slave msg $mc -preservecore 3
    file delete core
    list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \
	    [regexp "core-" $msg] [file delete core-makecore]
} {1 1 1 {}}

# Removing this test.  It makes no sense to test the ability of
# [preserveCore] to accept an invalid value that will cause errors
# in other parts of tcltest's operation.
#test tcltest-10.5 {preserveCore} {
#    -body {
#	set old [preserveCore]
#	set result [preserveCore foo]
#	set result2 [preserveCore]
#	preserveCore $old
#	list $result $result2
#    }
#    -result {foo foo}
#}
removeFile makecore.tcl

# -load, -loadfile, [loadScript], [loadFile]
set contents { 
    package require tcltest
    namespace import tcltest::*
    puts [outputChannel] $::tcltest::loadScript
    exit
} 
set loadfile [makeFile $contents load.tcl]

test tcltest-12.1 {-load xxx} {unixOrPc} {
    slave msg $loadfile -load xxx
    set msg
} {xxx}

# Using child process because of -debug usage.
test tcltest-12.2 {-loadfile load.tcl} {unixOrPc} {
    catch {exec [interpreter] $loadfile -debug 2 -loadfile $loadfile} msg
    list \
	    [regexp {tcltest} [join [list $msg] [split $msg \n]]] \
	    [regexp {loadScript} [join [list $msg] [split $msg \n]]]
} {1 1}

test tcltest-12.3 {loadScript} {
    -setup {
	set old $::tcltest::loadScript
    }
    -body {
	set f1 [loadScript]
	set f2 [loadScript xxx]
	set f3 [loadScript]
	list $f1 $f2 $f3
    }
    -result {{} xxx xxx}
    -cleanup {
	set ::tcltest::loadScript $old
    }
}

test tcltest-12.4 {loadFile} {
    -setup {
	set olds $::tcltest::loadScript
	set oldf $::tcltest::loadFile
	set ::tcltest::loadFile {}
    }
    -body {
	set f1 [loadScript]
	set f2 [loadFile]
	set f3 [loadFile $loadfile]
	set f4 [loadScript]
	set f5 [loadFile]
	list $f1 $f2 $f3 $f4 $f5
    }
    -result "[list {} {} $loadfile $contents $loadfile]\n"
    -cleanup {
	set ::tcltest::loadScript $olds
	set ::tcltest::loadFile $oldf
    }
}
removeFile load.tcl

# [interpreter]
test tcltest-13.1 {interpreter} {
    -setup {
	set old $::tcltest::tcltest
	set ::tcltest::tcltest tcltest
    }
    -body {
	set f1 [interpreter]
	set f2 [interpreter tclsh]
	set f3 [interpreter]
	list $f1 $f2 $f3
    }
    -result {tcltest tclsh tclsh}
    -cleanup {
	set ::tcltest::tcltest $old
    }
}