# 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.
#
# RCS: @(#) cmdMZ.test,v 1.5 2003/01/21 19:40:14 hunt Exp
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
set tcltest::testConstraints(nonLinuxOnly) \
[expr {![string equal Linux $tcl_platform(os)]}]
# Tcl_PwdObjCmd
test cmdMZ-1.1 {Tcl_PwdObjCmd} {
list [catch {pwd a} msg] $msg
} {1 {wrong # args: should be "pwd"}}
test cmdMZ-1.2 {Tcl_PwdObjCmd: simple pwd} {
catch pwd
} 0
test cmdMZ-1.3 {Tcl_PwdObjCmd: simple pwd} {
expr [string length pwd]>0
} 1
test cmdMZ-1.4 {Tcl_PwdObjCmd: failure} {unixOnly nonLinuxOnly} {
# We don't want this test to run on Linux because they do a
# permissions caching trick which causes this to fail. The
# caching is incorrect, but we have no control over that.
set foodir [file join [temporaryDirectory] foo]
file delete -force $foodir
file mkdir $foodir
set cwd [pwd]
cd $foodir
file attr . -permissions 000
set result [list [catch {pwd} msg] $msg]
cd $cwd
file delete -force $foodir
set result
} {1 {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} {
list [catch {rename r1} msg] $msg $errorCode
} {1 {wrong # args: should be "rename oldName newName"} NONE}
test cmdMZ-2.2 {Tcl_RenameObjCmd: error conditions} {
list [catch {rename r1 r2 r3} msg] $msg $errorCode
} {1 {wrong # args: should be "rename oldName newName"} NONE}
test cmdMZ-2.3 {Tcl_RenameObjCmd: success} {
catch {rename r2 {}}
proc r1 {} {return "r1"}
rename r1 r2
r2
} {r1}
test cmdMZ-2.4 {Tcl_RenameObjCmd: success} {
proc r1 {} {return "r1"}
rename r1 {}
list [catch {r1} msg] $msg
} {1 {invalid command name "r1"}}
# The tests for Tcl_ReturnObjCmd are in proc-old.test
# The tests for Tcl_ScanObjCmd are in scan.test
# Tcl_SourceObjCmd
test cmdMZ-3.1 {Tcl_SourceObjCmd: error conditions} {macOnly} {
list [catch {source} msg] $msg
} {1 {wrong # args: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?"}}
test cmdMZ-3.2 {Tcl_SourceObjCmd: error conditions} {macOnly} {
list [catch {source a b} msg] $msg
} {1 {bad argument: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?"}}
test cmdMZ-3.3 {Tcl_SourceObjCmd: error conditions} {unixOrPc} {
list [catch {source} msg] $msg
} {1 {wrong # args: should be "source fileName"}}
test cmdMZ-3.4 {Tcl_SourceObjCmd: error conditions} {unixOrPc} {
list [catch {source a b} msg] $msg
} {1 {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]
set result [list [catch {source $file} msg] $msg $errorInfo]
removeFile source.file
set result
} -match glob -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} {
set file [makeFile {list result} source.file]
set result [source $file]
removeFile source.file
set result
} result
# Tcl_SplitObjCmd
test cmdMZ-4.1 {Tcl_SplitObjCmd: split errors} {
list [catch split msg] $msg $errorCode
} {1 {wrong # args: should be "split string ?splitChars?"} NONE}
test cmdMZ-4.2 {Tcl_SplitObjCmd: split errors} {
list [catch {split a b c} msg] $msg $errorCode
} {1 {wrong # args: should be "split string ?splitChars?"} NONE}
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} {
proc foo {} {
set x {}
foreach f [split {]\n} {}] {
append x $f
}
return $x
}
foo
} {]\n}
test cmdMZ-4.11 {Tcl_SplitObjCmd: basic split commands} {
proc foo {} {
set x ab\000c
set y [split $x {}]
return $y
}
foo
} "a b \000 c"
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} {
list [catch {time} msg] $msg
} {1 {wrong # args: should be "time command ?count?"}}
test cmdMZ-5.2 {Tcl_TimeObjCmd: basic format of command} {
list [catch {time a b c} msg] $msg
} {1 {wrong # args: should be "time command ?count?"}}
test cmdMZ-5.3 {Tcl_TimeObjCmd: basic format of command} {
list [catch {time a b} msg] $msg
} {1 {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} {
regexp {^\d+ microseconds per iteration} [time {format 1}]
} 1
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_TraceObjCmd and TraceVarProc are in trace.test
# The tests for Tcl_WhileObjCmd are in while.test
# cleanup
::tcltest::cleanupTests
return