# 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: @(#) $Id: cmdMZ.test,v 1.13.2.3 2004/02/25 23:38:16 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 namespace import -force ::tcltest::* } # 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 nonPortable} { # 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. 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"}} 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 ListGlobMatch test cmdMZ-3.5 {Tcl_SourceObjCmd: error in script} -setup { set file [makeFile { set x 146 error "error in sourced file" set y $x } source.file] } -body { 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} { 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