+++ /dev/null
-# The tests in this file cover the procedures in tclCmdMZ.c.
-#
-# 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) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994 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 {[catch {package require tcltest 2.1}]} {
- puts stderr "Skipping tests in [info script]. tcltest 2.1 required."
- return
-}
-
-namespace eval ::tcl::test::cmdMZ {
- namespace import ::tcltest::cleanupTests
- namespace import ::tcltest::customMatch
- namespace import ::tcltest::makeFile
- namespace import ::tcltest::removeFile
- namespace import ::tcltest::temporaryDirectory
- namespace import ::tcltest::test
-
- proc ListGlobMatch {expected actual} {
- if {[llength $expected] != [llength $actual]} {
- return 0
- }
- foreach e $expected a $actual {
- if {![string match $e $a]} {
- return 0
- }
- }
- return 1
- }
- customMatch listGlob [namespace which ListGlobMatch]
-\f
-# Tcl_PwdObjCmd
-
-test cmdMZ-1.1 {Tcl_PwdObjCmd} -returnCodes error -body {
- pwd a
-} -result {wrong # args: should be "pwd"}
-test cmdMZ-1.2 {Tcl_PwdObjCmd: simple pwd} {
- catch pwd
-} 0
-test cmdMZ-1.3 {Tcl_PwdObjCmd: simple pwd} -body {
- pwd
-} -match glob -result {?*}
-test cmdMZ-1.4 {Tcl_PwdObjCmd: failure} -setup {
- set cwd [pwd]
- set foodir [file join [temporaryDirectory] foo]
- file delete -force $foodir
- file mkdir $foodir
- cd $foodir
-} -constraints {unix nonPortable} -body {
- # This test fails on various unix platforms (eg Linux) where permissions
- # caching causes this to fail. The caching is strictly incorrect, but we
- # have no control over that.
- file attr . -permissions 000
- pwd
-} -returnCodes error -cleanup {
- cd $cwd
- file delete -force $foodir
-} -result {error getting working directory name: permission denied}
-
-# The tests for Tcl_RegexpObjCmd, Tcl_RegsubObjCmd are in regexp.test
-
-# Tcl_RenameObjCmd
-
-test cmdMZ-2.1 {Tcl_RenameObjCmd: error conditions} -returnCodes error -body {
- rename r1
-} -result {wrong # args: should be "rename oldName newName"}
-test cmdMZ-2.2 {Tcl_RenameObjCmd: error conditions} -returnCodes error -body {
- rename r1 r2 r3
-} -result {wrong # args: should be "rename oldName newName"}
-test cmdMZ-2.3 {Tcl_RenameObjCmd: success} -setup {
- catch {rename r2 {}}
-} -body {
- proc r1 {} {return "r1"}
- rename r1 r2
- r2
-} -result {r1}
-test cmdMZ-2.4 {Tcl_RenameObjCmd: success} {
- proc r1 {} {return "r1"}
- rename r1 {}
- list [catch {r1} msg] $msg
-} {1 {invalid command name "r1"}}
-
-# Some tests for Tcl_ReturnObjCmd are in proc-old.test
-
-test cmdMZ-return-1.0 {return checks for bad option values} -body {
- return -options foo
-} -returnCodes error -match glob -result {bad -options value:*}
-test cmdMZ-return-1.1 {return checks for bad option values} -body {
- return -code err
-} -returnCodes error -match glob -result {bad completion code "err": must be ok, error, return, break, continue*, or an integer}
-test cmdMZ-return-1.2 {return checks for bad option values} -body {
- return -code 0x100000000
-} -returnCodes error -match glob -result {bad completion code "0x100000000": must be ok, error, return, break, continue*, or an integer}
-test cmdMZ-return-1.3 {return checks for bad option values} -body {
- return -level foo
-} -returnCodes error -match glob -result {bad -level value: *}
-test cmdMZ-return-1.4 {return checks for bad option values} -body {
- return -level -1
-} -returnCodes error -match glob -result {bad -level value: *}
-test cmdMZ-return-1.5 {return checks for bad option values} -body {
- return -level 3.1415926
-} -returnCodes error -match glob -result {bad -level value: *}
-
-proc dictSort {d} {
- set result {}
- foreach k [lsort [dict keys $d]] {
- dict set result $k [dict get $d $k]
- }
- return $result
-}
-
-test cmdMZ-return-2.0 {return option handling} {
- list [catch return -> foo] [dictSort $foo]
-} {2 {-code 0 -level 1}}
-test cmdMZ-return-2.1 {return option handling} {
- list [catch {return -bar soom} -> foo] [dictSort $foo]
-} {2 {-bar soom -code 0 -level 1}}
-test cmdMZ-return-2.2 {return option handling} {
- list [catch {return -code return} -> foo] [dictSort $foo]
-} {2 {-code 0 -level 2}}
-test cmdMZ-return-2.3 {return option handling} {
- list [catch {return -code return -level 10} -> foo] [dictSort $foo]
-} {2 {-code 0 -level 11}}
-test cmdMZ-return-2.4 {return option handling} -body {
- return -level 0 -code error
-} -returnCodes error -result {}
-test cmdMZ-return-2.5 {return option handling} -body {
- return -level 0 -code return
-} -returnCodes return -result {}
-test cmdMZ-return-2.6 {return option handling} -body {
- return -level 0 -code break
-} -returnCodes break -result {}
-test cmdMZ-return-2.7 {return option handling} -body {
- return -level 0 -code continue
-} -returnCodes continue -result {}
-test cmdMZ-return-2.8 {return option handling} -body {
- return -level 0 -code -1
-} -returnCodes -1 -result {}
-test cmdMZ-return-2.9 {return option handling} -body {
- return -level 0 -code 10
-} -returnCodes 10 -result {}
-test cmdMZ-return-2.10 {return option handling} -body {
- list [catch {return -level 0 -code error} -> foo] [dictSort $foo]
-} -match glob -result {1 {-code 1 -errorcode NONE -errorinfo {
- while executing
-"return -level 0 -code error"} -errorline 1 -errorstack * -level 0}}
-test cmdMZ-return-2.11 {return option handling} {
- list [catch {return -level 0 -code break} -> foo] [dictSort $foo]
-} {3 {-code 3 -level 0}}
-test cmdMZ-return-2.12 {return option handling} -body {
- return -level 0 -code error -options {-code ok}
-} -returnCodes ok -result {}
-test cmdMZ-return-2.13 {return option handling} -body {
- return -level 0 -code error -options {-code err}
-} -returnCodes error -match glob -result {bad completion code "err": must be ok, error, return, break, continue*, or an integer}
-test cmdMZ-return-2.14 {return option handling} -body {
- return -level 0 -code error -options {-code foo -options {-code break}}
-} -returnCodes break -result {}
-test cmdMZ-return-2.15 {return opton handling} {
- list [catch {
- apply {{} {
- return -code error -errorcode {a b} c
- }}
- } result] $result $::errorCode
-} {1 c {a b}}
-test cmdMZ-return-2.16 {return opton handling} {
- list [catch {
- apply {{} {
- return -code error -errorcode [list a b] c
- }}
- } result] $result $::errorCode
-} {1 c {a b}}
-test cmdMZ-return-2.17 {return opton handling} {
- list [catch {
- apply {{} {
- return -code error -errorcode a\ b c
- }}
- } result] $result $::errorCode
-} {1 c {a b}}
-test cmdMZ-return-2.18 {return option handling} {
- list [catch {
- return -code error -errorstack [list CALL a CALL b] yo
- } -> foo] [dictSort $foo] [info errorstack]
-} {2 {-code 1 -errorcode NONE -errorstack {CALL a CALL b} -level 1} {CALL a CALL b}}
-
-# Check that the result of a [return -options $opts $result] is
-# indistinguishable from that of the originally caught script, no matter what
-# the script is/does. (TIP 90)
-foreach {testid script} {
- cmdMZ-return-3.0 {}
- cmdMZ-return-3.1 {format x}
- cmdMZ-return-3.2 {set}
- cmdMZ-return-3.3 {set a 1}
- cmdMZ-return-3.4 {error}
- cmdMZ-return-3.5 {error foo}
- cmdMZ-return-3.6 {error foo bar}
- cmdMZ-return-3.7 {error foo bar baz}
- cmdMZ-return-3.8 {return -level 0}
- cmdMZ-return-3.9 {return -code error}
- cmdMZ-return-3.10 {return -code error -errorinfo foo}
- cmdMZ-return-3.11 {return -code error -errorinfo foo -errorcode bar}
- cmdMZ-return-3.12 {return -code error -errorinfo foo -errorcode bar -errorline 10}
- cmdMZ-return-3.12.1 {return -code error -errorinfo foo -errorcode bar -errorline 10 -errorstack baz}
- cmdMZ-return-3.13 {return -options {x y z 2}}
- cmdMZ-return-3.14 {return -level 3 -code break sdf}
-} {
- test $testid "check that return after a catch is same:\n$script" {
- set one [list [catch $script foo bar] $foo [dictSort $bar] \
- $::errorCode $::errorInfo]
- set two [list [catch {return -options $bar $foo} foo2 bar2] \
- $foo2 [dictSort $bar2] $::errorCode $::errorInfo]
- string equal $one $two
- } 1
-}
-
-# The tests for Tcl_ScanObjCmd are in scan.test
-
-# Tcl_SourceObjCmd
-# More tests of Tcl_SourceObjCmd are in source.test
-
-test cmdMZ-3.3 {Tcl_SourceObjCmd: error conditions} -constraints {
- unixOrPc
-} -returnCodes error -body {
- source
-} -match glob -result {wrong # args: should be "source*fileName"}
-test cmdMZ-3.4 {Tcl_SourceObjCmd: error conditions} -constraints {
- unixOrPc
-} -returnCodes error -body {
- source a b
-} -match glob -result {wrong # args: should be "source*fileName"}
-test cmdMZ-3.5 {Tcl_SourceObjCmd: error in script} -body {
- set file [makeFile {
- set x 146
- error "error in sourced file"
- set y $x
- } source.file]
- list [catch {source $file} msg] $msg $::errorInfo
-} -cleanup {
- removeFile source.file
-} -match listGlob -result {1 {error in sourced file} {error in sourced file
- while executing
-"error "error in sourced file""
- (file "*" line 3)
- invoked from within
-"source $file"}}
-test cmdMZ-3.6 {Tcl_SourceObjCmd: simple script} -body {
- set file [makeFile {list ok} source.file]
- source $file
-} -cleanup {
- removeFile source.file
-} -result ok
-
-# Tcl_SplitObjCmd
-
-test cmdMZ-4.1 {Tcl_SplitObjCmd: split errors} -returnCodes error -body {
- split
-} -result {wrong # args: should be "split string ?splitChars?"}
-test cmdMZ-4.2 {Tcl_SplitObjCmd: split errors} -returnCodes error -body {
- split a b c
-} -result {wrong # args: should be "split string ?splitChars?"}
-test cmdMZ-4.3 {Tcl_SplitObjCmd: basic split commands} {
- split "a\n b\t\r c\n "
-} {a {} b {} {} c {} {}}
-test cmdMZ-4.4 {Tcl_SplitObjCmd: basic split commands} {
- split "word 1xyzword 2zword 3" xyz
-} {{word 1} {} {} {word 2} {word 3}}
-test cmdMZ-4.5 {Tcl_SplitObjCmd: basic split commands} {
- split "12345" {}
-} {1 2 3 4 5}
-test cmdMZ-4.6 {Tcl_SplitObjCmd: basic split commands} {
- split "a\}b\[c\{\]\$"
-} "a\\\}b\\\[c\\\{\\\]\\\$"
-test cmdMZ-4.7 {Tcl_SplitObjCmd: basic split commands} {
- split {} {}
-} {}
-test cmdMZ-4.8 {Tcl_SplitObjCmd: basic split commands} {
- split {}
-} {}
-test cmdMZ-4.9 {Tcl_SplitObjCmd: basic split commands} {
- split { }
-} {{} {} {} {}}
-test cmdMZ-4.10 {Tcl_SplitObjCmd: basic split commands} {
- apply {{} {
- set x {}
- foreach f [split {]\n} {}] {
- append x $f
- }
- return $x
- }}
-} {]\n}
-test cmdMZ-4.11 {Tcl_SplitObjCmd: basic split commands} {
- apply {{} {
- set x ab\000c
- set y [split $x {}]
- binary scan $y c* z
- return $z
- }}
-} {97 32 98 32 0 32 99}
-test cmdMZ-4.12 {Tcl_SplitObjCmd: basic split commands} {
- split "a0ab1b2bbb3\000c4" ab\000c
-} {{} 0 {} 1 2 {} {} 3 {} 4}
-test cmdMZ-4.13 {Tcl_SplitObjCmd: basic split commands} {
- # if not UTF-8 aware, result is "a {} {} b qw\xe5 {} N wq"
- split "a\u4e4eb qw\u5e4e\x4e wq" " \u4e4e"
-} "a b qw\u5e4eN wq"
-
-# The tests for Tcl_StringObjCmd are in string.test
-# The tests for Tcl_SubstObjCmd are in subst.test
-# The tests for Tcl_SwitchObjCmd are in switch.test
-
-test cmdMZ-5.1 {Tcl_TimeObjCmd: basic format of command} -body {
- time
-} -returnCodes error -result {wrong # args: should be "time command ?count?"}
-test cmdMZ-5.2 {Tcl_TimeObjCmd: basic format of command} -body {
- time a b c
-} -returnCodes error -result {wrong # args: should be "time command ?count?"}
-test cmdMZ-5.3 {Tcl_TimeObjCmd: basic format of command} -body {
- time a b
-} -returnCodes error -result {expected integer but got "b"}
-test cmdMZ-5.4 {Tcl_TimeObjCmd: nothing happens with negative iteration counts} {
- time bogusCmd -12456
-} {0 microseconds per iteration}
-test cmdMZ-5.5 {Tcl_TimeObjCmd: result format} -body {
- time {format 1}
-} -match regexp -result {^\d+ microseconds per iteration}
-test cmdMZ-5.6 {Tcl_TimeObjCmd: slower commands take longer} {
- expr {[lindex [time {after 2}] 0] < [lindex [time {after 1000}] 0]}
-} 1
-test cmdMZ-5.7 {Tcl_TimeObjCmd: errors generate right trace} {
- list [catch {time {error foo}} msg] $msg $::errorInfo
-} {1 foo {foo
- while executing
-"error foo"
- invoked from within
-"time {error foo}"}}
-
-# The tests for Tcl_WhileObjCmd are in while.test
-\f
-# cleanup
-cleanupTests
-}
-namespace delete ::tcl::test::cmdMZ
-return
-
-# Local Variables:
-# mode: tcl
-# End:
OSDN Git Service
