summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/cmdAH.test98
-rw-r--r--tests/ioCmd.test43
-rw-r--r--tests/join.test17
-rw-r--r--tests/mathop.test12
-rw-r--r--tests/rename.test79
-rw-r--r--tests/split.test24
6 files changed, 126 insertions, 147 deletions
diff --git a/tests/cmdAH.test b/tests/cmdAH.test
index da554ce..c179eb6 100644
--- a/tests/cmdAH.test
+++ b/tests/cmdAH.test
@@ -1,16 +1,16 @@
# The file tests the tclCmdAH.c file.
#
-# 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.
+# 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) 1996-1998 by 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.
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: cmdAH.test,v 1.65 2008/12/01 15:22:55 dkf Exp $
+# RCS: @(#) $Id: cmdAH.test,v 1.66 2009/01/08 16:41:34 dkf Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.1
@@ -30,6 +30,27 @@ global env
set cmdAHwd [pwd]
catch {set platform [testgetplatform]}
+proc waitForEvenSecondForFAT {} {
+ # Windows 9x uses filesystems (the FAT* family of FSes) without enough
+ # data in its timestamps for even per-second-accurate timings. :^(
+ # This procedure based on work by Helmut Giese
+ if {
+ [testConstraint win] &&
+ [lindex [file system [temporaryDirectory]] 1] ne "NTFS"
+ } then {
+ # Assume non-NTFS means FAT{12,16,32} and hence in need of special
+ # help...
+ set start [clock seconds]
+ while {1} {
+ set now [clock seconds]
+ if {$now!=$start && !($now & 1)} {
+ break
+ }
+ after 50
+ }
+ }
+}
+
test cmdAH-0.1 {Tcl_BreakObjCmd, errors} -body {
break foo
} -returnCodes error -result {wrong # args: should be "break"}
@@ -113,7 +134,6 @@ test cmdAH-2.6.2 {cd} -constraints {unix nonPortable} -setup {
} -cleanup {
cd $dir
} -result {/}
-
test cmdAH-2.7 {Tcl_ConcatObjCmd} {
concat
} {}
@@ -382,7 +402,6 @@ test cmdAH-8.46 {Tcl_FileObjCmd: dirname} {
} {ok}
# tail
-
test cmdAH-9.1 {Tcl_FileObjCmd: tail} -returnCodes error -body {
file tail a b
} -result {wrong # args: should be "file tail name"}
@@ -531,7 +550,6 @@ test cmdAH-9.51 {Tcl_FileObjCmd: tail} testsetplatform {
} bar
# rootname
-
test cmdAH-10.1 {Tcl_FileObjCmd: rootname} -returnCodes error -body {
file rootname a b
} -result {wrong # args: should be "file rootname name"}
@@ -632,7 +650,6 @@ foreach outer { {} a .a a. a.a } {
}
# extension
-
test cmdAH-11.1 {Tcl_FileObjCmd: extension} -returnCodes error -body {
file extension a b
} -result {wrong # args: should be "file extension name"}
@@ -737,7 +754,6 @@ foreach {test onPlatform value result} {
}
# pathtype
-
test cmdAH-12.1 {Tcl_FileObjCmd: pathtype} -returnCodes error -body {
file pathtype a b
} -result {wrong # args: should be "file pathtype name"}
@@ -755,7 +771,6 @@ test cmdAH-12.4 {Tcl_FileObjCmd: pathtype} testsetplatform {
} volumerelative
# split
-
test cmdAH-13.1 {Tcl_FileObjCmd: split} -returnCodes error -body {
file split a b
} -result {wrong # args: should be "file split name"}
@@ -769,7 +784,6 @@ test cmdAH-13.3 {Tcl_FileObjCmd: split} testsetplatform {
} {a b}
# join
-
test cmdAH-14.1 {Tcl_FileObjCmd: join} testsetplatform {
testsetplatform unix
file join a
@@ -784,7 +798,6 @@ test cmdAH-14.3 {Tcl_FileObjCmd: join} testsetplatform {
} a/b/c/d
# error handling of Tcl_TranslateFileName
-
test cmdAH-15.1 {Tcl_FileObjCmd} -constraints testsetplatform -body {
testsetplatform unix
file atime ~_bad_user
@@ -793,10 +806,8 @@ test cmdAH-15.1 {Tcl_FileObjCmd} -constraints testsetplatform -body {
catch {testsetplatform $platform}
# readable
-
set gorpfile [makeFile abcde gorp.file]
set dirfile [makeDirectory dir.file]
-
test cmdAH-16.1 {Tcl_FileObjCmd: readable} {
-returnCodes error
-body {file readable a b}
@@ -816,7 +827,6 @@ test cmdAH-16.3 {Tcl_FileObjCmd: readable} {
}
# writable
-
test cmdAH-17.1 {Tcl_FileObjCmd: writable} {
-returnCodes error
-body {file writable a b}
@@ -836,12 +846,10 @@ test cmdAH-17.3 {Tcl_FileObjCmd: writable} {
}
# executable
-
removeFile $gorpfile
removeDirectory $dirfile
set dirfile [makeDirectory dir.file]
set gorpfile [makeFile abcde gorp.file]
-
test cmdAH-18.1 {Tcl_FileObjCmd: executable} -returnCodes error -body {
file executable a b
} -result {wrong # args: should be "file executable name"}
@@ -881,7 +889,6 @@ set linkfile [file join [temporaryDirectory] link.file]
file delete $linkfile
# exists
-
test cmdAH-19.1 {Tcl_FileObjCmd: exists} -returnCodes error -body {
file exists a b
} -result {wrong # args: should be "file exists name"}
@@ -900,7 +907,6 @@ test cmdAH-19.4 {Tcl_FileObjCmd: exists} {
test cmdAH-19.5 {Tcl_FileObjCmd: exists} {
file exists $subgorp
} 1
-
# nativename
test cmdAH-19.6 {Tcl_FileObjCmd: nativename} -body {
testsetplatform unix
@@ -914,7 +920,6 @@ test cmdAH-19.7 {Tcl_FileObjCmd: nativename} -body {
} -constraints testsetplatform -cleanup {
testsetplatform $platform
} -result {a\b}
-
test cmdAH-19.9 {Tcl_FileObjCmd: ~ : exists} {
file exists ~nOsUcHuSeR
} 0
@@ -922,11 +927,9 @@ test cmdAH-19.10 {Tcl_FileObjCmd: ~ : nativename} {
# should probably be 0 in fact...
catch {file nativename ~nOsUcHuSeR}
} 1
-
# The test below has to be done in /tmp rather than the current directory in
# order to guarantee (?) a local file system: some NFS file systems won't do
# the stuff below correctly.
-
test cmdAH-19.11 {Tcl_FileObjCmd: exists} -constraints {unix notRoot} -setup {
file delete -force /tmp/tcl.foo.dir/file
file delete -force /tmp/tcl.foo.dir
@@ -948,8 +951,6 @@ removeFile $gorpfile
set gorpfile [makeFile "Test string" gorp.file]
catch {file attributes $gorpfile -permissions 0765}
-# atime
-
# avoid problems with non-local filesystems
if {[testConstraint unix] && [file exists /tmp]} {
set file [makeFile "data" touch.me /tmp]
@@ -957,6 +958,7 @@ if {[testConstraint unix] && [file exists /tmp]} {
set file [makeFile "data" touch.me]
}
+# atime
test cmdAH-20.1 {Tcl_FileObjCmd: atime} -returnCodes error -body {
file atime a b c
} -result {wrong # args: should be "file atime name ?time?"}
@@ -1006,7 +1008,6 @@ if {[testConstraint unix] && [file exists /tmp]} {
}
# isdirectory
-
test cmdAH-21.1 {Tcl_FileObjCmd: isdirectory} -returnCodes error -body {
file isdirectory a b
} -result {wrong # args: should be "file isdirectory name"}
@@ -1014,7 +1015,6 @@ test cmdAH-21.2 {Tcl_FileObjCmd: isdirectory} {file isdirectory $gorpfile} 0
test cmdAH-21.3 {Tcl_FileObjCmd: isdirectory} {file isdirectory $dirfile} 1
# isfile
-
test cmdAH-22.1 {Tcl_FileObjCmd: isfile} -returnCodes error -body {
file isfile a b
} -result {wrong # args: should be "file isfile name"}
@@ -1023,7 +1023,6 @@ test cmdAH-22.3 {Tcl_FileObjCmd: isfile} {file isfile $dirfile} 0
# lstat and readlink: don't run these tests everywhere, since not all sites
# will have symbolic links
-
catch {file link -symbolic $linkfile $gorpfile}
test cmdAH-23.1 {Tcl_FileObjCmd: lstat} -returnCodes error -body {
file lstat a
@@ -1052,11 +1051,9 @@ test cmdAH-23.6 {Tcl_FileObjCmd: lstat errors} -setup {
} -body {
set x 44
list [catch {file lstat $gorpfile x} msg] $msg $errorCode
-} -result {1 {can't set "x(dev)": variable isn't array} NONE}
+} -result {1 {can't set "x(dev)": variable isn't array} {TCL LOOKUP VARNAME}}
catch {unset stat}
-
# mkdir
-
set dirA [file join [temporaryDirectory] a]
set dirB [file join [temporaryDirectory] a]
test cmdAH-23.7 {Tcl_FileObjCmd: mkdir} -setup {
@@ -1098,30 +1095,8 @@ test cmdAH-23.11 {Tcl_FileObjCmd: mkdir} {
file mkdir
} {}
-# mtime
-
-proc waitForEvenSecondForFAT {} {
- # Windows 9x uses filesystems (the FAT* family of FSes) without enough
- # data in its timestamps for even per-second-accurate timings. :^(
- # This procedure based on work by Helmut Giese
- if {
- [testConstraint win]
- && [lindex [file system [temporaryDirectory]] 1] ne "NTFS"
- } then {
- # Assume non-NTFS means FAT{12,16,32} and hence in need of special
- # help...
- set start [clock seconds]
- while {1} {
- set now [clock seconds]
- if {$now!=$start && !($now & 1)} {
- break
- }
- after 50
- }
- }
-}
set file [makeFile "data" touch.me]
-
+# mtime
test cmdAH-24.1 {Tcl_FileObjCmd: mtime} -returnCodes error -body {
file mtime a b c
} -result {wrong # args: should be "file mtime name ?time?"}
@@ -1160,8 +1135,7 @@ test cmdAH-24.3 {Tcl_FileObjCmd: mtime} -setup {
[expr {[file atime $gorpfile] == $stat(atime)}]
} -result {1 1}
test cmdAH-24.4 {Tcl_FileObjCmd: mtime} {
- list [catch {file mtime _bogus_} msg] [string tolower $msg] \
- $errorCode
+ list [catch {file mtime _bogus_} msg] [string tolower $msg] $errorCode
} {1 {could not read "_bogus_": no such file or directory} {POSIX ENOENT {no such file or directory}}}
test cmdAH-24.5 {Tcl_FileObjCmd: mtime} -setup {
# Under Unix, use a file in /tmp to avoid clock skew due to NFS. On other
@@ -1259,7 +1233,6 @@ test cmdAH-24.13 {Tcl_FileObjCmd: directory mtime} -setup {
} -result {0 1}
# owned
-
test cmdAH-25.1 {Tcl_FileObjCmd: owned} -returnCodes error -body {
file owned a b
} -result {wrong # args: should be "file owned name"}
@@ -1279,7 +1252,6 @@ test cmdAH-25.3 {Tcl_FileObjCmd: owned} {unix notRoot} {
} 0
# readlink
-
test cmdAH-26.1 {Tcl_FileObjCmd: readlink} -returnCodes error -body {
file readlink a b
} -result {wrong # args: should be "file readlink name"}
@@ -1294,7 +1266,6 @@ test cmdAH-26.5 {Tcl_FileObjCmd: readlink errors} {win nonPortable} {
} {1 {could not readlink "_bogus_": invalid argument} {POSIX EINVAL {invalid argument}}}
# size
-
test cmdAH-27.1 {Tcl_FileObjCmd: size} -returnCodes error -body {
file size a b
} -result {wrong # args: should be "file size name"}
@@ -1310,13 +1281,12 @@ test cmdAH-27.3 {Tcl_FileObjCmd: size} {
list [catch {file size _bogus_} msg] [string tolower $msg] $errorCode
} {1 {could not read "_bogus_": no such file or directory} {POSIX ENOENT {no such file or directory}}}
-# stat
-
catch {testsetplatform $platform}
removeFile $gorpfile
set gorpfile [makeFile "Test string" gorp.file]
catch {file attributes $gorpfile -permissions 0765}
+# stat
test cmdAH-28.1 {Tcl_FileObjCmd: stat} -returnCodes error -body {
file stat _bogus_
} -result {wrong # args: should be "file stat name varName"}
@@ -1402,7 +1372,6 @@ test cmdAH-28.12 {Tcl_FileObjCmd: stat} -setup {
catch {unset stat}
# type
-
test cmdAH-29.1 {Tcl_FileObjCmd: type} -returnCodes error -body {
file size a b
} -result {wrong # args: should be "file size name"}
@@ -1442,7 +1411,6 @@ test cmdAH-29.5 {Tcl_FileObjCmd: type} {
} {1 {could not read "_bogus_": no such file or directory} {POSIX ENOENT {no such file or directory}}}
# Error conditions
-
test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} -returnCodes error -body {
file gorp x
} -result {bad option "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempfile, type, volumes, or writable}
@@ -1577,7 +1545,7 @@ test cmdAH-32.6 {file tempfile - templates} -body {
} -constraints {unix nonPortable} -cleanup {
catch {file delete $name}
} -result ok
-
+
# This shouldn't work, but just in case a test above failed...
catch {close $newFileId}
diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index 0018f83..1754dcd 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -13,7 +13,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: ioCmd.test,v 1.48 2008/12/18 01:14:17 ferrieux Exp $
+# RCS: @(#) $Id: ioCmd.test,v 1.49 2009/01/08 16:41:35 dkf Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
@@ -135,7 +135,7 @@ test iocmd-4.8 {read command with incorrect combination of arguments} {
set x [list [catch {read -nonewline $f 20 z} msg] $msg $::errorCode]
close $f
set x
-} {1 {wrong # args: should be "read channelId ?numChars?" or "read ?-nonewline? channelId"} NONE}
+} {1 {wrong # args: should be "read channelId ?numChars?" or "read ?-nonewline? channelId"} {TCL WRONGARGS}}
test iocmd-4.9 {read command} {
list [catch {read stdin foo} msg] $msg $::errorCode
} {1 {bad argument "foo": should be "nonewline"} NONE}
@@ -150,25 +150,26 @@ test iocmd-4.11 {read command} {
string compare [string tolower $x] \
[list 1 [format "channel \"%s\" wasn't opened for reading" $f] none]
} 0
-test iocmd-4.12 {read command} {
+test iocmd-4.12 {read command} -setup {
set f [open $path(test1)]
- set x [list [catch {read $f 12z} msg] $msg $::errorCode]
+} -body {
+ list [catch {read $f 12z} msg] $msg $::errorCode
+} -cleanup {
close $f
- set x
-} {1 {expected integer but got "12z"} NONE}
-
-test iocmd-5.1 {seek command} {
- list [catch {seek} msg] $msg
-} {1 {wrong # args: should be "seek channelId offset ?origin?"}}
-test iocmd-5.2 {seek command} {
- list [catch {seek a b c d e f g} msg] $msg
-} {1 {wrong # args: should be "seek channelId offset ?origin?"}}
-test iocmd-5.3 {seek command} {
- list [catch {seek stdin gugu} msg] $msg
-} {1 {expected integer but got "gugu"}}
-test iocmd-5.4 {seek command} {
- list [catch {seek stdin 100 gugu} msg] $msg
-} {1 {bad origin "gugu": must be start, current, or end}}
+} -result {1 {expected integer but got "12z"} {TCL VALUE NUMBER}}
+
+test iocmd-5.1 {seek command} -returnCodes error -body {
+ seek
+} -result {wrong # args: should be "seek channelId offset ?origin?"}
+test iocmd-5.2 {seek command} -returnCodes error -body {
+ seek a b c d e f g
+} -result {wrong # args: should be "seek channelId offset ?origin?"}
+test iocmd-5.3 {seek command} -returnCodes error -body {
+ seek stdin gugu
+} -result {expected integer but got "gugu"}
+test iocmd-5.4 {seek command} -returnCodes error -body {
+ seek stdin 100 gugu
+} -result {bad origin "gugu": must be start, current, or end}
test iocmd-6.1 {tell command} {
list [catch {tell} msg] $msg
@@ -352,10 +353,10 @@ test iocmd-8.19 {fconfigure command / win tty channel} -constraints {nonPortable
test iocmd-9.1 {eof command} {
list [catch {eof} msg] $msg $::errorCode
-} {1 {wrong # args: should be "eof channelId"} NONE}
+} {1 {wrong # args: should be "eof channelId"} {TCL WRONGARGS}}
test iocmd-9.2 {eof command} {
list [catch {eof a b} msg] $msg $::errorCode
-} {1 {wrong # args: should be "eof channelId"} NONE}
+} {1 {wrong # args: should be "eof channelId"} {TCL WRONGARGS}}
test iocmd-9.3 {eof command} {
catch {close file100}
list [catch {eof file100} msg] $msg $::errorCode
diff --git a/tests/join.test b/tests/join.test
index 562c3e0..0a6da27 100644
--- a/tests/join.test
+++ b/tests/join.test
@@ -11,13 +11,13 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: join.test,v 1.6 2004/05/19 10:51:06 dkf Exp $
+# RCS: @(#) $Id: join.test,v 1.7 2009/01/08 16:41:35 dkf Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
-
+
test join-1.1 {basic join commands} {
join {a b c} xyz
} axyzbxyzc
@@ -33,22 +33,25 @@ test join-1.4 {basic join commands} {
test join-2.1 {join errors} {
list [catch join msg] $msg $errorCode
-} {1 {wrong # args: should be "join list ?joinString?"} NONE}
+} {1 {wrong # args: should be "join list ?joinString?"} {TCL WRONGARGS}}
test join-2.2 {join errors} {
list [catch {join a b c} msg] $msg $errorCode
-} {1 {wrong # args: should be "join list ?joinString?"} NONE}
+} {1 {wrong # args: should be "join list ?joinString?"} {TCL WRONGARGS}}
test join-2.3 {join errors} {
list [catch {join "a \{ c" 111} msg] $msg $errorCode
-} {1 {unmatched open brace in list} NONE}
+} {1 {unmatched open brace in list} {TCL VALUE LIST}}
test join-3.1 {joinString is binary ok} {
string length [join {a b c} a\0b]
} 9
-
test join-3.2 {join is binary ok} {
string length [join "a\0b a\0b a\0b"]
} 11
-
+
# cleanup
::tcltest::cleanupTests
return
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/tests/mathop.test b/tests/mathop.test
index 8374a98..3ec37fc 100644
--- a/tests/mathop.test
+++ b/tests/mathop.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: mathop.test,v 1.12 2008/03/30 03:23:39 kennykb Exp $
+# RCS: @(#) $Id: mathop.test,v 1.13 2009/01/08 16:41:35 dkf Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.1
@@ -731,7 +731,7 @@ test mathop-20.2 { zero args, not allowed } {
set exp {}
foreach op {~ ! << >> % != ne in ni - /} {
set res [TestOp $op]
- if {[string match "wrong # args* NONE" $res]} {
+ if {[string match "wrong # args: should be * TCL WRONGARGS" $res]} {
lappend exp 0
} else {
lappend exp $res
@@ -762,7 +762,7 @@ test mathop-20.5 { one arg, not allowed } {
set exp {}
foreach op {% != ne in ni << >>} {
set res [TestOp $op 1]
- if {[string match "wrong # args* NONE" $res]} {
+ if {[string match "wrong # args: should be * TCL WRONGARGS" $res]} {
lappend exp 0
} else {
lappend exp $res
@@ -861,7 +861,7 @@ test mathop-21.6 { unary ops, too many } {
set exp {}
foreach op {~ !} {
set res [TestOp $op 7 8]
- if {[string match "wrong # args* NONE" $res]} {
+ if {[string match "wrong # args: should be * TCL WRONGARGS" $res]} {
lappend exp 0
} else {
lappend exp $res
@@ -1088,7 +1088,7 @@ test mathop-24.3 { binary ops, bad values } {
}
foreach op {in ni} {
lappend res [TestOp $op 5 "a b \{ c"]
- lappend exp "unmatched open brace in list NONE"
+ lappend exp "unmatched open brace in list TCL VALUE LIST"
}
lappend res [TestOp % 5 0]
lappend exp "divide by zero ARITH DIVZERO {divide by zero}"
@@ -1185,7 +1185,7 @@ test mathop-24.8 { binary ops, too many } {
set exp {}
foreach op {<< >> % != ne in ni ~ !} {
set res [TestOp $op 7 8 9]
- if {[string match "wrong # args* NONE" $res]} {
+ if {[string match "wrong # args: should be * TCL WRONGARGS" $res]} {
lappend exp 0
} else {
lappend exp $res
diff --git a/tests/rename.test b/tests/rename.test
index 45d6847..3a3a47f 100644
--- a/tests/rename.test
+++ b/tests/rename.test
@@ -1,34 +1,34 @@
# Commands covered: rename
#
-# 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.
+# 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.
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: rename.test,v 1.12 2004/05/19 20:15:32 dkf Exp $
+# RCS: @(#) $Id: rename.test,v 1.13 2009/01/08 16:41:35 dkf Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
+ package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint testdel [llength [info commands testdel]]
-# Must eliminate the "unknown" command while the test is running,
-# especially if the test is being run in a program with its
-# own special-purpose unknown command.
-
+# Must eliminate the "unknown" command while the test is running, especially
+# if the test is being run in a program with its own special-purpose unknown
+# command.
catch {rename unknown unknown.old}
-
+
catch {rename r2 {}}
proc r1 {} {return "procedure r1"}
rename r1 r2
+
test rename-1.1 {simple renaming} {
r2
} {procedure r1}
@@ -40,10 +40,9 @@ test rename-1.3 {simple renaming} {
list [catch r2 msg] $msg
} {1 {invalid command name "r2"}}
-# The test below is tricky because it renames a built-in command.
-# It's possible that the test procedure uses this command, so must
-# restore the command before calling test again.
-
+# The test below is tricky because it renames a built-in command. It's
+# possible that the test procedure uses this command, so must restore the
+# command before calling test again.
rename list l.new
set a [catch list msg1]
set b [l.new a b c]
@@ -56,24 +55,27 @@ test rename-2.1 {renaming built-in command} {
test rename-3.1 {error conditions} {
list [catch {rename r1} msg] $msg $errorCode
-} {1 {wrong # args: should be "rename oldName newName"} NONE}
+} {1 {wrong # args: should be "rename oldName newName"} {TCL WRONGARGS}}
test rename-3.2 {error conditions} {
list [catch {rename r1 r2 r3} msg] $msg $errorCode
-} {1 {wrong # args: should be "rename oldName newName"} NONE}
-test rename-3.3 {error conditions} {
+} {1 {wrong # args: should be "rename oldName newName"} {TCL WRONGARGS}}
+test rename-3.3 {error conditions} -setup {
proc r1 {} {}
proc r2 {} {}
- list [catch {rename r1 r2} msg] $msg
-} {1 {can't rename to "r2": command already exists}}
-test rename-3.4 {error conditions} {
+} -returnCodes error -body {
+ rename r1 r2
+} -result {can't rename to "r2": command already exists}
+test rename-3.4 {error conditions} -setup {
catch {rename r1 {}}
catch {rename r2 {}}
- list [catch {rename r1 r2} msg] $msg
-} {1 {can't rename "r1": command doesn't exist}}
-test rename-3.5 {error conditions} {
+} -returnCodes error -body {
+ rename r1 r2
+} -result {can't rename "r1": command doesn't exist}
+test rename-3.5 {error conditions} -setup {
catch {rename _non_existent_command {}}
- list [catch {rename _non_existent_command {}} msg] $msg
-} {1 {can't delete "_non_existent_command": command doesn't exist}}
+} -returnCodes error -body {
+ rename _non_existent_command {}
+} -result {can't delete "_non_existent_command": command doesn't exist}
catch {rename unknown {}}
catch {rename unknown.old unknown}
@@ -142,11 +144,9 @@ if {[info exists env(value)]} {
catch {rename unknown unknown.old}
+set SAVED_UNKNOWN "proc unknown "
+append SAVED_UNKNOWN [list [info args unknown.old] [info body unknown.old]]
test rename-5.1 {repeated rename deletion and redefinition of same command} {
- set SAVED_UNKNOWN "proc unknown "
- append SAVED_UNKNOWN "\{[info args unknown.old]\} "
- append SAVED_UNKNOWN "\{[info body unknown.old]\}"
-
for {set i 0} {$i < 10} {incr i} {
eval $SAVED_UNKNOWN
tcl_wordBreakBefore "" 0
@@ -158,24 +158,27 @@ test rename-5.1 {repeated rename deletion and redefinition of same command} {
catch {rename unknown {}}
catch {rename unknown.old unknown}
-
-test rename-6.1 {old code invalidated (epoch incremented) when cmd with compile proc is renamed } {
- proc x {} {
+test rename-6.1 {old code invalidated (epoch incremented) when cmd with compile proc is renamed} -body {
+ proc x {} {
set a 123
set b [incr a]
}
x
rename incr incr.old
proc incr {} {puts "new incr called!"}
- catch {x} msg
+ x
+} -cleanup {
rename incr {}
rename incr.old incr
- set msg
-} {wrong # args: should be "incr"}
-
+} -returnCodes error -result {wrong # args: should be "incr"}
+
if {[info commands incr.old] != {}} {
catch {rename incr {}}
catch {rename incr.old incr}
}
::tcltest::cleanupTests
return
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/tests/split.test b/tests/split.test
index 93b0cc4..1cc13b7 100644
--- a/tests/split.test
+++ b/tests/split.test
@@ -1,23 +1,23 @@
# Commands covered: split
#
-# 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.
+# 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-1996 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.
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: split.test,v 1.9 2004/05/19 10:50:30 dkf Exp $
+# RCS: @(#) $Id: split.test,v 1.10 2009/01/08 16:41:35 dkf Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
-
+
test split-1.1 {basic split commands} {
split "a\n b\t\r c\n "
} {a {} b {} {} c {} {}}
@@ -75,12 +75,16 @@ test split-1.14 {basic split commands} {
test split-2.1 {split errors} {
list [catch split msg] $msg $errorCode
-} {1 {wrong # args: should be "split string ?splitChars?"} NONE}
+} {1 {wrong # args: should be "split string ?splitChars?"} {TCL WRONGARGS}}
test split-2.2 {split errors} {
list [catch {split a b c} msg] $msg $errorCode
-} {1 {wrong # args: should be "split string ?splitChars?"} NONE}
-
+} {1 {wrong # args: should be "split string ?splitChars?"} {TCL WRONGARGS}}
+
# cleanup
catch {rename foo {}}
::tcltest::cleanupTests
return
+
+# Local Variables:
+# mode: tcl
+# End:
generated by cgit v0.12 at 2024-11-18 10:41:07 (GMT)