path: root/tests/tcltest.test

# Command line options covered:
#  -help, -verbose, -match, -skip, -file, -notfile, -constraints,
#  -limitconstraints, -preservecore, -tmpdir, -debug, -outfile, 
#  -errfile, -args
#
# 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) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
# RCS: @(#) $Id: tcltest.test,v 1.10 2000/04/10 17:19:05 ericm Exp $

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

makeFile {
    package require tcltest
    namespace import -force ::tcltest::*
    test a-1.0 {test a} {
	list 0
    } {0}
    test b-1.0 {test b} {
	list 1
    } {0}
    test c-1.0 {test c} {knownBug} {
    } {}
    ::tcltest::cleanupTests
    exit
} test.tcl

# test -help
test tcltest-1.1 {tcltest -help} {unixOrPc} {
    set result [catch {exec $::tcltest::tcltest test.tcl -help} msg]
    set result [catch {runCmd $cmd}]
    list $result [regexp Usage $msg]
} {1 1} 
test tcltest-1.2 {tcltest -help -something} {unixOrPc} {
    set result [catch {exec $::tcltest::tcltest test.tcl -help -something} msg]
    list $result [regexp Usage $msg]
} {1 1}
test tcltest-1.3 {tcltest -h} {unixOrPc} {
    set result [catch {exec $::tcltest::tcltest test.tcl -h} msg]
    list $result [regexp Usage $msg]
} {1 1} 

# -verbose
test tcltest-2.0 {tcltest (verbose default - 'b')} {unixOrPc} {
    set result [catch {exec $::tcltest::tcltest test.tcl} msg]
    list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
	    [regexp c-1.0 $msg] \
	    [regexp "Total.+3.+Passed.+1.+Skipped.+1.+Failed.+1" $msg]
} {0 1 0 0 1}
test tcltest-2.1 {tcltest -v 'b'} {unixOrPc} {
    set result [catch {exec $::tcltest::tcltest test.tcl -v 'b'} msg]
    list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
	    [regexp c-1.0 $msg] \
	    [regexp "Total.+3.+Passed.+1.+Skipped.+1.+Failed.+1" $msg]
} {0 1 0 0 1}
test tcltest-2.2 {tcltest -v 'p'} {unixOrPc} {
    set result [catch {exec $::tcltest::tcltest test.tcl -v 'p'} msg]
    list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
	    [regexp c-1.0 $msg] \
	    [regexp "Total.+3.+Passed.+1.+Skipped.+1.+Failed.+1" $msg]
} {0 0 1 0 1}
test tcltest-2.3 {tcltest -v 's'} {unixOrPc} {
    set result [catch {exec $::tcltest::tcltest test.tcl -v 's'} msg]
    list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
	    [regexp c-1.0 $msg] \
	    [regexp "Total.+3.+Passed.+1.+Skipped.+1.+Failed.+1" $msg]
} {0 0 0 1 1}
test tcltest-2.4 {tcltest -v 'ps'} {unixOrPc} {
    set result [catch {exec $::tcltest::tcltest test.tcl -verbose 'ps'} msg]
    list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
	    [regexp c-1.0 $msg] \
	    [regexp "Total.+3.+Passed.+1.+Skipped.+1.+Failed.+1" $msg]
} {0 0 1 1 1}
test tcltest-2.5 {tcltest -v 'psb'} {unixOrPc} {
    set result [catch {exec $::tcltest::tcltest test.tcl -v 'psb'} msg]
    list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
	    [regexp c-1.0 $msg] \
	    [regexp "Total.+3.+Passed.+1.+Skipped.+1.+Failed.+1" $msg]
} {0 1 1 1 1}

# -match
test tcltest-3.1 {tcltest -match 'a*'} {unixOrPc} {
    set result [catch {exec $::tcltest::tcltest test.tcl -match a* -v 'ps'} msg]
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+3.+Passed.+1.+Skipped.+2.+Failed.+0" $msg]
} {0 1 0 0 1}
test tcltest-3.2 {tcltest -match 'b*'} {unixOrPc} {
    set result [catch {exec $::tcltest::tcltest test.tcl -m b* -v 'ps'} msg]
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+3.+Passed.+0.+Skipped.+2.+Failed.+1" $msg]
} {0 0 1 0 1}
test tcltest-3.3 {tcltest -match 'c*'} {unixOrPc} {
    set result [catch {exec $::tcltest::tcltest test.tcl -match c* -v 'ps'} msg]
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+3.+Passed.+0.+Skipped.+3.+Failed.+0" $msg]
} {0 0 0 1 1}
test tcltest-3.4 {tcltest -match 'a* b*'} {unixOrPc} {
    set result [catch {exec $::tcltest::tcltest test.tcl -match {a* b*} -v 'ps'} msg]
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+3.+Passed.+1.+Skipped.+1.+Failed.+1" $msg]
} {0 1 1 0 1}

# -skip
test tcltest-4.1 {tcltest -skip 'a*'} {unixOrPc} {
    set result [catch {exec $::tcltest::tcltest test.tcl -skip a* -v 'ps'} msg]
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+3.+Passed.+0.+Skipped.+2.+Failed.+1" $msg]
} {0 0 1 1 1}
test tcltest-4.2 {tcltest -skip 'b*'} {unixOrPc} {
    set result [catch {exec $::tcltest::tcltest test.tcl -s b* -v 'ps'} msg]
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+3.+Passed.+1.+Skipped.+2.+Failed.+0" $msg]
} {0 1 0 1 1}
test tcltest-4.3 {tcltest -skip 'c*'} {unixOrPc} {
    set result [catch {exec $::tcltest::tcltest test.tcl -skip c* -v 'ps'} msg]
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+3.+Passed.+1.+Skipped.+1.+Failed.+1" $msg]
} {0 1 1 0 1}
test tcltest-4.4 {tcltest -skip 'a* b*'} {unixOrPc} {
    set result [catch {exec $::tcltest::tcltest test.tcl -skip {a* b*} -v 'ps'} msg]
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+3.+Passed.+0.+Skipped.+3.+Failed.+0" $msg]
} {0 0 0 1 1}
test tcltest-4.5 {tcltest -match 'a* b*' -skip 'b*'} {unixOrPc} {
    set result [catch {exec $::tcltest::tcltest test.tcl -match {a* b*} -skip b* -v 'ps'} msg]
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+3.+Passed.+1.+Skipped.+2.+Failed.+0" $msg]
} {0 1 0 0 1}

# -constraints, -limitconstraints
test tcltest-5.1 {tcltest -constraints 'knownBug'} {unixOrPc} {
    set result [catch {exec $::tcltest::tcltest test.tcl -constraints knownBug -v 'ps'} msg]
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+3.+Passed.+2.+Skipped.+0.+Failed.+1" $msg]
} {0 1 1 1 1}
test tcltest-5.1 {tcltest -constraints 'knownBug'} {unixOrPc} {
    set result [catch {exec $::tcltest::tcltest test.tcl -constraints knownBug -v 'p' -limitconstraints 1} msg]
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+3.+Passed.+1.+Skipped.+2.+Failed.+0" $msg]
} {0 0 0 1 1}

makeFile {
    package require tcltest
    namespace import -force ::tcltest::*
    puts $::tcltest::outputChannel "a test"
    ::tcltest::PrintError "a really short string"
    ::tcltest::PrintError "a really really really really really really long \
	    string containing \"quotes\" and other bad bad stuff"
    ::tcltest::PrintError "a really really long string containing a \
	    \"Path/that/is/really/long/and/contains/no/spaces\""
    ::tcltest::PrintError "a really really long string containing a \
	    \"Really/Long/Path/that/contains/no/spaces/and/is/longer/than/eighty/characters/to/see/what/happens\"" 
    ::tcltest::PrintError "Problem renaming file: error renaming \"Z:/ws/tcl8.2/win32-ix86/tests/core\" to \"Z:/ws/tcl8.2/win32-ix86/tests/movecore-core\""
    exit
} printerror.tcl

# -outfile, -errfile
test tcltest-6.1 {tcltest -outfile, -errfile defaults} {unixOrPc} {
    catch {exec $::tcltest::tcltest printerror.tcl} msg
    list [regexp "a test" $msg] [regexp "a really" $msg]
} {1 1}
test tcltest-6.2 {tcltest -outfile a.tmp} {unixOrPc} {
    catch {exec $::tcltest::tcltest printerror.tcl -outfile a.tmp} msg
    set result1 [catch {exec grep "a test" a.tmp}]
    set result2 [catch {exec grep "a really" a.tmp}]
    list [regexp "a test" $msg] [regexp "a really" $msg] \
	    $result1 $result2 [file exists a.tmp] [file delete a.tmp] 
} {0 1 0 1 1 {}}
test tcltest-6.3 {tcltest -errfile a.tmp} {unixOrPc} {
    catch {exec $::tcltest::tcltest printerror.tcl -errfile a.tmp} msg
    set result1 [catch {exec grep "a test" a.tmp}]
    set result2 [catch {exec grep "a really" a.tmp}]
    list [regexp "a test" $msg] [regexp "a really" $msg] \
	    $result1 $result2 [file exists a.tmp] [file delete a.tmp]
} {1 0 1 0 1 {}}
test tcltest-6.4 {tcltest -outfile a.tmp -errfile b.tmp} {unixOrPc} {
    catch {exec $::tcltest::tcltest printerror.tcl -o a.tmp -e b.tmp} msg
    set result1 [catch {exec grep "a test" a.tmp}]
    set result2 [catch {exec grep "a really" b.tmp}]
    list [regexp "a test" $msg] [regexp "a really" $msg] \
	    $result1 $result2 \
	    [file exists a.tmp] [file delete a.tmp] \
	    [file exists b.tmp] [file delete b.tmp]
} {0 0 0 0 1 {} 1 {}}

# -debug
test tcltest-7.1 {tcltest test.tcl -d 0} {unixOrPc} {
    catch {exec $::tcltest::tcltest test.tcl -d 0} msg
    regexp "Flags passed into tcltest" $msg
} {0}
test tcltest-7.2 {tcltest test.tcl -d 1} {unixOrPc} {
    catch {exec $::tcltest::tcltest test.tcl -d 1 -s b*} msg
    list [regexp userSpecifiedSkip $msg] \
	    [regexp "Flags passed into tcltest" $msg]
} {1 0}
test tcltest-7.3 {tcltest test.tcl -d 1} {unixOrPc} {
    catch {exec $::tcltest::tcltest test.tcl -d 1 -m b*} msg
    list [regexp userSpecifiedNonMatch $msg] \
	    [regexp "Flags passed into tcltest" $msg]
} {1 0}
test tcltest-7.4 {tcltest test.tcl -d 2} {unixOrPc} {
    catch {exec $::tcltest::tcltest test.tcl -d 2} msg
    list [regexp "Flags passed into tcltest" $msg] [regexp "Running" $msg]
} {1 0}
test tcltest-7.5 {tcltest test.tcl -d 3} {unixOrPc} {
    catch {exec $::tcltest::tcltest test.tcl -d 3} msg
    list [regexp "Flags passed into tcltest" $msg] [regexp "Running" $msg]
} {1 1}

makeFile {
    package require tcltest
    namespace import -force ::tcltest::*
    makeFile {} a.tmp
    exit
} a.tcl

makeFile {} thisdirectoryisafile

# -tmpdir
test tcltest-8.1 {tcltest a.tcl -tmpdir a} {unixOrPc} {
    file delete -force thisdirectorydoesnotexist
    exec $::tcltest::tcltest a.tcl -tmpdir thisdirectorydoesnotexist
    list [file exists [file join thisdirectorydoesnotexist a.tmp]] \
	    [file delete -force thisdirectorydoesnotexist] 
} {1 {}}
test tcltest-8.2 {tcltest a.tcl -tmpdir thisdirectoryisafile} {unixOrPc} {
    catch {exec $::tcltest::tcltest a.tcl -tmpdir thisdirectoryisafile} msg
    # The join is necessary because the message can be split on multiple lines
    list [regexp "not a directory" [join $msg]]
} {1}

# Test non-writeable directories, non-readable directories with tmpdir
set notReadableDir [file join $::tcltest::temporaryDirectory notreadable]
set notWriteableDir [file join $::tcltest::temporaryDirectory notwriteable]

::tcltest::makeDirectory notreadable
::tcltest::makeDirectory notwriteable

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

test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} {unixOnly} {
    catch {exec $::tcltest::tcltest a.tcl -tmpdir $notReadableDir} msg 
    # The join is necessary because the message can be split on multiple lines
    list [regexp {not readable} [join $msg]]
} {1}

test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} {unixOrPc} {
    catch {exec $::tcltest::tcltest a.tcl -tmpdir $notWriteableDir} msg
    # The join is necessary because the message can be split on multiple lines
    list [regexp {not writeable} [join $msg]]
} {1}

# -testdir
test tcltest-8.5 {tcltest a.tcl -testdir thisdirectorydoesnotexist} {
    file delete -force thisdirectorydoesnotexist
    catch {exec $::tcltest::tcltest a.tcl -testdir thisdirectorydoesnotexist}  msg
    list [regexp "does not exist" [join $msg]]
} {1}

test tcltest-8.6 {tcltest a.tcl -testdir thisdirectoryisafile} {
    catch {exec $::tcltest::tcltest a.tcl -testdir thisdirectoryisafile} msg
    # The join is necessary because the message can be split on multiple lines
    list [regexp "not a directory" [join $msg]] 
} {1}

test tcltest-8.7 {tcltest a.tcl -testdir notReadableDir} {unixOnly} {
    catch {exec $::tcltest::tcltest a.tcl -testdir $notReadableDir} msg 
    # The join is necessary because the message can be split on multiple lines
    list [regexp {not readable} [join $msg]]
} {1}


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

file delete -force $notReadableDir $notWriteableDir

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



makeFile {
    package require tcltest
    namespace import -force ::tcltest::*

    test makecore {make a core file} {
	set f [open core w]
	close $f
    } {}
    ::tcltest::cleanupTests
    return
} makecore.tcl

# -preservecore 
test tcltest-10.1 {-preservecore 0} {unixOrPc} {
    catch {exec $::tcltest::tcltest makecore.tcl -preservecore 0} msg
    file delete core
    regexp "produced core file" $msg
} {0}
test tcltest-10.2 {-preservecore 1} {unixOrPc} {
    catch {exec $::tcltest::tcltest makecore.tcl -preservecore 1} msg
    file delete core
    regexp "produced core file" $msg
} {1}
test tcltest-10.3 {-preservecore 2} {unixOrPc} {
    catch {exec $::tcltest::tcltest makecore.tcl -preservecore 2} msg
    file delete core
    list [regexp "==== makecore produced core file" $msg] [regexp "Moving file to" $msg] \
	    [regexp "core-" $msg] [file delete core-makecore]
} {1 1 1 {}}
test tcltest-10.4 {-preservecore 3} {unixOrPc} {
    catch {exec $::tcltest::tcltest makecore.tcl -preservecore 3} msg
    file delete core
    list [regexp "produced core file" $msg] [regexp "Moving file to" $msg] \
	    [regexp "core-" $msg] [file delete core-makecore]
} {1 1 1 {}}

makeFile {
    package require tcltest
    namespace import -force ::tcltest::*
    puts "=$::tcltest::parameters="
    exit
} args.tcl

# -args
test tcltest-11.1 {-args foo} {unixOrPc} {
    catch {exec $::tcltest::tcltest args.tcl -args foo} msg
    list $msg
} {=foo=}

test tcltest-11.2 {-args {}} {unixOrPc} {
    catch {exec $::tcltest::tcltest args.tcl -args {}} msg
    list $msg
} {==}

test tcltest-11.3 {-args {-foo bar -baz}} {unixOrPc} {
    catch {exec $::tcltest::tcltest args.tcl -args {-foo bar -baz}} msg
    list $msg
} {{=-foo bar -baz=}}

# -load -loadfile
makeFile {
    package require tcltest
    namespace import -force ::tcltest::*
    puts $::tcltest::loadScript
    exit
} load.tcl

test tcltest-12.1 {-load xxx} {
    catch {exec $::tcltest::tcltest load.tcl -load xxx} msg
    set msg
} {xxx}

test tcltest-12.1 {-loadfile load.tcl} {
    catch {exec $::tcltest::tcltest load.tcl -d 2 -loadfile load.tcl} msg
    list \
	    [regexp {tcltest} [join $msg [split $msg \n]]] \
	    [regexp {loadScript} [join $msg [split $msg \n]]]
} {1 1}

# Begin testing of tcltest procs ...

# PrintError
test tcltest-20.1 {PrintError} {unixOrPc} {
    set result [catch {exec $::tcltest::tcltest printerror.tcl} msg]
    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}

# cleanup
::tcltest::cleanupTests
return