Intial commit
This commit is contained in:
Mario Fetka
93
tcl7.3/tests/README
Normal file
93
tcl7.3/tests/README
Normal file
@@ -0,0 +1,93 @@
|
||||
Tcl Test Suite
|
||||
--------------
|
||||
|
||||
This directory contains a set of validation tests for the Tcl
|
||||
commands. Each of the files whose name ends in ".test" is
|
||||
intended to fully exercise one or a few Tcl commands. The
|
||||
commands tested by a given file are listed in the first line
|
||||
of the file.
|
||||
|
||||
You can run the tests in two ways:
|
||||
(a) type "make test" in the parent directory to this one; this
|
||||
will run all of the tests.
|
||||
(b) start up tcltest in this directory, then "source" the test
|
||||
file (for example, type "source parse.test"). To run all
|
||||
of the tests, type "source all".
|
||||
In either case no output will be generated if all goes well, except
|
||||
for a listing of the tests.. If there are errors then additional
|
||||
messages will appear in the format described below.
|
||||
|
||||
The rest of this file provides additional information on the
|
||||
features of the testing environment.
|
||||
|
||||
This approach to testing was designed and initially implemented
|
||||
by Mary Ann May-Pumphrey of Sun Microsystems. Many thanks to
|
||||
her for donating her work back to the public Tcl release.
|
||||
|
||||
Definitions file:
|
||||
-----------------
|
||||
|
||||
The file "defs" defines a collection of procedures and variables
|
||||
used to run the tests. It is read in automatically by each of the
|
||||
.test files if needed, but once it has been read once it will not
|
||||
be read again by the .test files. If you change defs while running
|
||||
tests you'll have to "source" it by hand to load its new contents.
|
||||
|
||||
Test output:
|
||||
------------
|
||||
|
||||
Normally, output only appears when there are errors. However, if
|
||||
the variable VERBOSE is set to 1 then tests will be run in "verbose"
|
||||
mode and output will be generated for each test regardless of
|
||||
whether it succeeded or failed. Test output consists of the
|
||||
following information:
|
||||
|
||||
- the test identifier (which can be used to locate the test code
|
||||
in the .test file)
|
||||
- a brief description of the test
|
||||
- the contents of the test code
|
||||
- the actual results produced by the tests
|
||||
- a "PASSED" or "FAILED" message
|
||||
- the expected results (if the test failed)
|
||||
|
||||
You can set VERBOSE either interactively (after the defs file has been
|
||||
read in), or you can change the default value in "defs".
|
||||
|
||||
Selecting tests for execution:
|
||||
------------------------------
|
||||
|
||||
Normally, all the tests in a file are run whenever the file is
|
||||
"source"d. However, you can select a specific set of tests using
|
||||
the global variable TESTS. This variable contains a pattern; any
|
||||
test whose identifier matches TESTS will be run. For example,
|
||||
the following interactive command causes all of the "for" tests in
|
||||
groups 2 and 4 to be executed:
|
||||
|
||||
set TESTS {for-[24]*}
|
||||
|
||||
TESTS defaults to *, but you can change the default in "defs" if
|
||||
you wish.
|
||||
|
||||
Saving keystrokes:
|
||||
------------------
|
||||
|
||||
A convenience procedure named "dotests" is included in file
|
||||
"defs". It takes two arguments--the name of the test file (such
|
||||
as "parse.test"), and a pattern selecting the tests you want to
|
||||
execute. It sets TESTS to the second argument, calls "source" on
|
||||
the file specified in the first argument, and restores TESTS to
|
||||
its pre-call value at the end.
|
||||
|
||||
Batch vs. interactive execution:
|
||||
--------------------------------
|
||||
|
||||
The tests can be run in either batch or interactive mode. Batch
|
||||
mode refers to using I/O redirection from a UNIX shell. For example,
|
||||
the following command causes the tests in the file named "parse.test"
|
||||
to be executed:
|
||||
|
||||
tclTest < parse.test > parse.test.results
|
||||
|
||||
Users who want to execute the tests in this fashion need to first
|
||||
ensure that the file "defs" has proper values for the global
|
||||
variables that control the testing environment (VERBOSE and TESTS).
|
||||
10
tcl7.3/tests/all
Normal file
10
tcl7.3/tests/all
Normal file
@@ -0,0 +1,10 @@
|
||||
# This file contains a top-level script to run all of the Tcl
|
||||
# tests. Execute it by invoking "source all" when running tclTest
|
||||
# in this directory.
|
||||
#
|
||||
# $Header: /sprite/src/lib/tcl/tests/RCS/all,v 1.4 91/09/08 13:43:07 ouster Exp $ (Berkeley)
|
||||
|
||||
foreach i [lsort [glob *.test]] {
|
||||
puts stdout $i
|
||||
source $i
|
||||
}
|
||||
122
tcl7.3/tests/append.test
Normal file
122
tcl7.3/tests/append.test
Normal file
@@ -0,0 +1,122 @@
|
||||
# Commands covered: append lappend
|
||||
#
|
||||
# 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.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/append.test,v 1.6 93/06/19 14:28:25 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
catch {unset x}
|
||||
test append-1.1 {append command} {
|
||||
catch {unset x}
|
||||
list [append x 1 2 abc "long string"] $x
|
||||
} {{12abclong string} {12abclong string}}
|
||||
test append-1.2 {append command} {
|
||||
set x ""
|
||||
list [append x first] [append x second] [append x third] $x
|
||||
} {first firstsecond firstsecondthird firstsecondthird}
|
||||
|
||||
test append-2.1 {long appends} {
|
||||
set x ""
|
||||
for {set i 0} {$i < 1000} {set i [expr $i+1]} {
|
||||
append x "foobar "
|
||||
}
|
||||
set y "foobar"
|
||||
set y "$y $y $y $y $y $y $y $y $y $y"
|
||||
set y "$y $y $y $y $y $y $y $y $y $y"
|
||||
set y "$y $y $y $y $y $y $y $y $y $y "
|
||||
expr {$x == $y}
|
||||
} 1
|
||||
|
||||
test append-3.1 {append errors} {
|
||||
list [catch {append} msg] $msg
|
||||
} {1 {wrong # args: should be "append varName value ?value ...?"}}
|
||||
test append-3.2 {append errors} {
|
||||
list [catch {append x} msg] $msg
|
||||
} {1 {wrong # args: should be "append varName value ?value ...?"}}
|
||||
test append-3.3 {append errors} {
|
||||
set x ""
|
||||
list [catch {append x(0) 44} msg] $msg
|
||||
} {1 {can't set "x(0)": variable isn't array}}
|
||||
|
||||
test append-4.1 {lappend command} {
|
||||
catch {unset x}
|
||||
list [lappend x 1 2 abc "long string"] $x
|
||||
} {{1 2 abc {long string}} {1 2 abc {long string}}}
|
||||
test append-4.2 {lappend command} {
|
||||
set x ""
|
||||
list [lappend x first] [lappend x second] [lappend x third] $x
|
||||
} {first {first second} {first second third} {first second third}}
|
||||
test append-4.3 {lappend command} {
|
||||
proc foo {} {
|
||||
global x
|
||||
set x old
|
||||
unset x
|
||||
lappend x new
|
||||
}
|
||||
set result [foo]
|
||||
rename foo {}
|
||||
set result
|
||||
} {new}
|
||||
test append-4.3 {lappend command} {
|
||||
set x {}
|
||||
lappend x \{\ abc
|
||||
} {\{\ abc}
|
||||
test append-4.3 {lappend command} {
|
||||
set x {}
|
||||
lappend x \{ abc
|
||||
} {\{ abc}
|
||||
|
||||
proc check {var size} {
|
||||
set l [llength $var]
|
||||
if {$l != $size} {
|
||||
return "length mismatch: should have been $size, was $l"
|
||||
}
|
||||
for {set i 0} {$i < $size} {set i [expr $i+1]} {
|
||||
set j [lindex $var $i]
|
||||
if {$j != "item $i"} {
|
||||
return "element $i should have been \"item $i\", was \"$j\"
|
||||
}
|
||||
}
|
||||
return ok
|
||||
}
|
||||
test append-5.1 {long lappends} {
|
||||
set x ""
|
||||
for {set i 0} {$i < 300} {set i [expr $i+1]} {
|
||||
lappend x "item $i"
|
||||
}
|
||||
check $x 300
|
||||
} ok
|
||||
|
||||
test append-6.1 {lappend errors} {
|
||||
list [catch {lappend} msg] $msg
|
||||
} {1 {wrong # args: should be "lappend varName value ?value ...?"}}
|
||||
test append-6.2 {lappend errors} {
|
||||
list [catch {lappend x} msg] $msg
|
||||
} {1 {wrong # args: should be "lappend varName value ?value ...?"}}
|
||||
test append-6.3 {lappend errors} {
|
||||
set x ""
|
||||
list [catch {lappend x(0) 44} msg] $msg
|
||||
} {1 {can't set "x(0)": variable isn't array}}
|
||||
145
tcl7.3/tests/async.test
Normal file
145
tcl7.3/tests/async.test
Normal file
@@ -0,0 +1,145 @@
|
||||
# Commands covered: none
|
||||
#
|
||||
# This file contains a collection of tests for Tcl_AsyncCreate and related
|
||||
# library procedures. Sourcing this file into Tcl runs the tests and
|
||||
# generates output for errors. No output means no errors were found.
|
||||
#
|
||||
# Copyright (c) 1993 The Regents of the University of California.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/async.test,v 1.2 93/08/14 17:07:43 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[info commands testasync] == {}} {
|
||||
puts "This application hasn't been compiled with the \"testasync\""
|
||||
puts "command, so I can't test Tcl_AsyncCreate et al."
|
||||
return
|
||||
}
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
proc async1 {result code} {
|
||||
global aresult acode
|
||||
set aresult $result
|
||||
set acode $code
|
||||
return "new result"
|
||||
}
|
||||
proc async2 {result code} {
|
||||
global aresult acode
|
||||
set aresult $result
|
||||
set acode $code
|
||||
return -code error "xyzzy"
|
||||
}
|
||||
proc async3 {result code} {
|
||||
global aresult
|
||||
set aresult "test pattern"
|
||||
return -code $code $result
|
||||
}
|
||||
|
||||
set handler1 [testasync create async1]
|
||||
set handler2 [testasync create async2]
|
||||
set handler3 [testasync create async3]
|
||||
test async-1.1 {basic async handlers} {
|
||||
set aresult xxx
|
||||
set acode yyy
|
||||
list [catch {testasync mark $handler1 "original" 0} msg] $msg \
|
||||
$acode $aresult
|
||||
} {0 {new result} 0 original}
|
||||
test async-1.2 {basic async handlers} {
|
||||
set aresult xxx
|
||||
set acode yyy
|
||||
list [catch {testasync mark $handler1 "original" 1} msg] $msg \
|
||||
$acode $aresult
|
||||
} {0 {new result} 1 original}
|
||||
test async-1.3 {basic async handlers} {
|
||||
set aresult xxx
|
||||
set acode yyy
|
||||
list [catch {testasync mark $handler2 "old" 0} msg] $msg \
|
||||
$acode $aresult
|
||||
} {1 xyzzy 0 old}
|
||||
test async-1.4 {basic async handlers} {
|
||||
set aresult xxx
|
||||
set acode yyy
|
||||
list [catch {testasync mark $handler2 "old" 3} msg] $msg \
|
||||
$acode $aresult
|
||||
} {1 xyzzy 3 old}
|
||||
test async-1.5 {basic async handlers} {
|
||||
set aresult xxx
|
||||
list [catch {testasync mark $handler3 "foobar" 0} msg] $msg $aresult
|
||||
} {0 foobar {test pattern}}
|
||||
test async-1.6 {basic async handlers} {
|
||||
set aresult xxx
|
||||
list [catch {testasync mark $handler3 "foobar" 1} msg] $msg $aresult
|
||||
} {1 foobar {test pattern}}
|
||||
|
||||
proc mult1 {result code} {
|
||||
global x
|
||||
lappend x mult1
|
||||
return -code 7 mult1
|
||||
}
|
||||
set hm1 [testasync create mult1]
|
||||
proc mult2 {result code} {
|
||||
global x
|
||||
lappend x mult2
|
||||
return -code 9 mult2
|
||||
}
|
||||
set hm2 [testasync create mult2]
|
||||
proc mult3 {result code} {
|
||||
global x hm1 hm2
|
||||
lappend x [catch {testasync mark $hm2 serial2 0}]
|
||||
lappend x [catch {testasync mark $hm1 serial1 0}]
|
||||
lappend x mult3
|
||||
return -code 11 mult3
|
||||
}
|
||||
set hm3 [testasync create mult3]
|
||||
|
||||
test async-2.1 {multiple handlers} {
|
||||
set x {}
|
||||
list [catch {testasync mark $hm3 "foobar" 5} msg] $msg $x
|
||||
} {9 mult2 {0 0 mult3 mult1 mult2}}
|
||||
|
||||
proc del1 {result code} {
|
||||
global x hm1 hm2 hm3 hm4
|
||||
lappend x [catch {testasync mark $hm3 serial2 0}]
|
||||
lappend x [catch {testasync mark $hm1 serial1 0}]
|
||||
lappend x [catch {testasync mark $hm4 serial1 0}]
|
||||
testasync delete $hm1
|
||||
testasync delete $hm2
|
||||
testasync delete $hm3
|
||||
lappend x del1
|
||||
return -code 13 del1
|
||||
}
|
||||
proc del2 {result code} {
|
||||
global x
|
||||
lappend x del2
|
||||
return -code 3 del2
|
||||
}
|
||||
testasync delete $handler1
|
||||
testasync delete $hm2
|
||||
testasync delete $hm3
|
||||
set hm2 [testasync create del1]
|
||||
set hm3 [testasync create mult2]
|
||||
set hm4 [testasync create del2]
|
||||
|
||||
test async-3.1 {deleting handlers} {
|
||||
set x {}
|
||||
list [catch {testasync mark $hm2 "foobar" 5} msg] $msg $x
|
||||
} {3 del2 {0 0 0 del1 del2}}
|
||||
|
||||
testasync delete
|
||||
126
tcl7.3/tests/case.test
Normal file
126
tcl7.3/tests/case.test
Normal file
@@ -0,0 +1,126 @@
|
||||
# Commands covered: case
|
||||
#
|
||||
# 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.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/case.test,v 1.11 93/06/17 11:22:41 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
# Commands covered: case
|
||||
#
|
||||
# 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.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/case.test,v 1.11 93/06/17 11:22:41 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
test case-1.1 {simple pattern} {
|
||||
case a in a {format 1} b {format 2} c {format 3} default {format 4}
|
||||
} 1
|
||||
test case-1.2 {simple pattern} {
|
||||
case b a {format 1} b {format 2} c {format 3} default {format 4}
|
||||
} 2
|
||||
test case-1.3 {simple pattern} {
|
||||
case x in a {format 1} b {format 2} c {format 3} default {format 4}
|
||||
} 4
|
||||
test case-1.4 {simple pattern} {
|
||||
case x a {format 1} b {format 2} c {format 3}
|
||||
} {}
|
||||
test case-1.5 {simple pattern matches many times} {
|
||||
case b a {format 1} b {format 2} b {format 3} b {format 4}
|
||||
} 2
|
||||
test case-1.6 {fancier pattern} {
|
||||
case cx a {format 1} *c {format 2} *x {format 3} default {format 4}
|
||||
} 3
|
||||
test case-1.7 {list of patterns} {
|
||||
case abc in {a b c} {format 1} {def abc ghi} {format 2}
|
||||
} 2
|
||||
|
||||
test case-2.1 {error in executed command} {
|
||||
list [catch {case a in a {error "Just a test"} default {format 1}} msg] \
|
||||
$msg $errorInfo
|
||||
} {1 {Just a test} {Just a test
|
||||
while executing
|
||||
"error "Just a test""
|
||||
("a" arm line 1)
|
||||
invoked from within
|
||||
"case a in a {error "Just a test"} default {format 1}"}}
|
||||
test case-2.2 {error: not enough args} {
|
||||
list [catch {case} msg] $msg
|
||||
} {1 {wrong # args: should be "case string ?in? patList body ... ?default body?"}}
|
||||
test case-2.3 {error: pattern with no body} {
|
||||
list [catch {case a b} msg] $msg
|
||||
} {1 {extra case pattern with no body}}
|
||||
test case-2.4 {error: pattern with no body} {
|
||||
list [catch {case a in b {format 1} c} msg] $msg
|
||||
} {1 {extra case pattern with no body}}
|
||||
test case-2.5 {error in default command} {
|
||||
list [catch {case foo in a {error case1} default {error case2} \
|
||||
b {error case 3}} msg] $msg $errorInfo
|
||||
} {1 case2 {case2
|
||||
while executing
|
||||
"error case2"
|
||||
("default" arm line 1)
|
||||
invoked from within
|
||||
"case foo in a {error case1} default {error case2} b {error case 3}"}}
|
||||
|
||||
test case-3.1 {single-argument form for pattern/command pairs} {
|
||||
case b in {
|
||||
a {format 1}
|
||||
b {format 2}
|
||||
default {format 6}
|
||||
}
|
||||
} {2}
|
||||
test case-3.2 {single-argument form for pattern/command pairs} {
|
||||
case b {
|
||||
a {format 1}
|
||||
b {format 2}
|
||||
default {format 6}
|
||||
}
|
||||
} {2}
|
||||
test case-3.3 {single-argument form for pattern/command pairs} {
|
||||
list [catch {case z in {a 2 b}} msg] $msg
|
||||
} {1 {extra case pattern with no body}}
|
||||
121
tcl7.3/tests/cd.test
Normal file
121
tcl7.3/tests/cd.test
Normal file
@@ -0,0 +1,121 @@
|
||||
# Commands covered: cd, pwd
|
||||
#
|
||||
# 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.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/cd.test,v 1.21 93/10/07 17:21:21 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
catch {exec rm -rf cd.dir}
|
||||
exec mkdir cd.dir
|
||||
exec cat << "Sample text" > cd.dir/test.file
|
||||
set cwd [exec pwd]
|
||||
|
||||
test cd-1.1 {simple pwd check} {
|
||||
pwd
|
||||
} $cwd
|
||||
|
||||
cd cd.dir
|
||||
if $atBerkeley {
|
||||
test cd-2.1 {changing directories} {
|
||||
list [exec pwd]
|
||||
} $cwd/cd.dir
|
||||
test cd-2.2 {changing directories} {
|
||||
pwd
|
||||
} $cwd/cd.dir
|
||||
}
|
||||
test cd-2.3 {changing directories} {
|
||||
exec cat test.file
|
||||
} "Sample text"
|
||||
cd ..
|
||||
test cd-2.4 {changing directories} {
|
||||
exec pwd
|
||||
} $cwd
|
||||
test cd-2.5 {changing directories} {
|
||||
pwd
|
||||
} $cwd
|
||||
test cd-2.6 {changing directories} {
|
||||
exec cat cd.dir/test.file
|
||||
} "Sample text"
|
||||
|
||||
# The tests below seem to fail on lots of machines for a variety
|
||||
# of reasons, such as the auto-mounter, home directories that are
|
||||
# symbolic links, etc.
|
||||
|
||||
if $atBerkeley {
|
||||
set home [exec sh -c "cd; pwd"]
|
||||
test cd-2.7 {changing directories} {
|
||||
cd ~
|
||||
set x [list [exec pwd] [pwd]]
|
||||
cd $cwd
|
||||
set x
|
||||
} "$home $home"
|
||||
test cd-2.8 {changing directories} {
|
||||
cd
|
||||
set x [list [exec pwd] [pwd]]
|
||||
cd $cwd
|
||||
set x
|
||||
} "$home $home"
|
||||
}
|
||||
|
||||
test cd-3.1 {cd return value} {
|
||||
cd .
|
||||
} {}
|
||||
|
||||
test cd-4.1 {errors in cd command} {
|
||||
list [catch {cd 1 2} msg] $msg $errorCode
|
||||
} {1 {wrong # args: should be "cd dirName"} NONE}
|
||||
test cd-4.2 {errors in cd command} {
|
||||
string tolower [list [catch {cd _bad_dir} msg] $msg $errorCode]
|
||||
} {1 {couldn't change working directory to "_bad_dir": no such file or directory} {posix enoent {no such file or directory}}}
|
||||
test cd-4.3 {errors in cd command} {
|
||||
string tolower [list [catch {cd cd.dir/test.file} msg] $msg $errorCode]
|
||||
} {1 {couldn't change working directory to "cd.dir/test.file": not a directory} {posix enotdir {not a directory}}}
|
||||
test cd-4.4 {errors in cd command} {
|
||||
set home $env(HOME)
|
||||
unset env(HOME)
|
||||
set x [list [catch cd msg] $msg]
|
||||
set env(HOME) $home
|
||||
set x
|
||||
} {1 {couldn't find HOME environment variable to expand "~"}}
|
||||
|
||||
test cd-5.1 {errors in pwd command} {
|
||||
list [catch {pwd a} msg] $msg
|
||||
} {1 {wrong # args: should be "pwd"}}
|
||||
if $atBerkeley {
|
||||
exec mkdir cd.dir/child
|
||||
cd cd.dir/child
|
||||
exec chmod 111 ..
|
||||
if {$user != "root"} {
|
||||
test cd-5.2 {errors in pwd command} {
|
||||
catch pwd msg
|
||||
} 1
|
||||
}
|
||||
cd $cwd
|
||||
exec chmod 775 cd.dir
|
||||
}
|
||||
|
||||
catch {exec rm -rf cd.dir}
|
||||
format ""
|
||||
79
tcl7.3/tests/cmdinfo.test
Normal file
79
tcl7.3/tests/cmdinfo.test
Normal file
@@ -0,0 +1,79 @@
|
||||
# Commands covered: none
|
||||
#
|
||||
# This file contains a collection of tests for Tcl_GetCommandInfo,
|
||||
# Tcl_SetCommandInfo, Tcl_CreateCommand, and Tcl_DeleteCommand.
|
||||
# Sourcing this file into Tcl runs the tests and generates output for
|
||||
# errors. No output means no errors were found.
|
||||
#
|
||||
# Copyright (c) 1993 The Regents of the University of California.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/cmdinfo.test,v 1.1 93/07/01 16:23:09 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[info commands testcmdinfo] == {}} {
|
||||
puts "This application hasn't been compiled with the \"testcmdinfo\""
|
||||
puts "command, so I can't test Tcl_GetCommandInfo etc."
|
||||
return
|
||||
}
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
test cmdinfo-1.1 {command procedure and clientData} {
|
||||
testcmdinfo create x1
|
||||
testcmdinfo get x1
|
||||
} {CmdProc1 original CmdDelProc1 original}
|
||||
test cmdinfo-1.2 {command procedure and clientData} {
|
||||
testcmdinfo create x1
|
||||
x1
|
||||
} {CmdProc1 original}
|
||||
test cmdinfo-1.3 {command procedure and clientData} {
|
||||
testcmdinfo create x1
|
||||
testcmdinfo modify x1
|
||||
testcmdinfo get x1
|
||||
} {CmdProc2 new_command_data CmdDelProc2 new_delete_data}
|
||||
test cmdinfo-1.4 {command procedure and clientData} {
|
||||
testcmdinfo create x1
|
||||
testcmdinfo modify x1
|
||||
x1
|
||||
} {CmdProc2 new_command_data}
|
||||
|
||||
test cmdinfo-2.1 {command deletion callbacks} {
|
||||
testcmdinfo create x1
|
||||
testcmdinfo delete x1
|
||||
} {CmdDelProc1 original}
|
||||
test cmdinfo-2.2 {command deletion callbacks} {
|
||||
testcmdinfo create x1
|
||||
testcmdinfo modify x1
|
||||
testcmdinfo delete x1
|
||||
} {CmdDelProc2 new_delete_data}
|
||||
|
||||
test cmdinfo-3.1 {Tcl_Get/SetCommandInfo return values} {
|
||||
testcmdinfo get non_existent
|
||||
} {??}
|
||||
test cmdinfo-3.2 {Tcl_Get/SetCommandInfo return values} {
|
||||
testcmdinfo create x1
|
||||
testcmdinfo modify x1
|
||||
} 1
|
||||
test cmdinfo-3.3 {Tcl_Get/SetCommandInfo return values} {
|
||||
testcmdinfo modify non_existent
|
||||
} 0
|
||||
|
||||
catch {rename x1 ""}
|
||||
concat {}
|
||||
53
tcl7.3/tests/concat.test
Normal file
53
tcl7.3/tests/concat.test
Normal file
@@ -0,0 +1,53 @@
|
||||
# Commands covered: concat
|
||||
#
|
||||
# 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.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/concat.test,v 1.6 93/10/28 16:13:57 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
test concat-1.1 {simple concatenation} {
|
||||
concat a b c d e f g
|
||||
} {a b c d e f g}
|
||||
test concat-1.2 {merging lists together} {
|
||||
concat a {b c d} {e f g h}
|
||||
} {a b c d e f g h}
|
||||
test concat-1.3 {merge lists, retain sub-lists} {
|
||||
concat a {b {c d}} {{e f}} g h
|
||||
} {a b {c d} {e f} g h}
|
||||
test concat-1.4 {special characters} {
|
||||
concat a\{ {b \{c d} \{d
|
||||
} "a{ b \\{c d {d"
|
||||
|
||||
test concat-2.1 {error: no arguments} {
|
||||
list [catch concat msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
test concat-3.1 {pruning off extra white space} {
|
||||
concat {} {a b c}
|
||||
} {a b c}
|
||||
test concat-3.2 {pruning off extra white space} {
|
||||
concat x y " a b c \n\t " " " " def "
|
||||
} {x y a b c def}
|
||||
54
tcl7.3/tests/dcall.test
Normal file
54
tcl7.3/tests/dcall.test
Normal file
@@ -0,0 +1,54 @@
|
||||
# Commands covered: none
|
||||
#
|
||||
# This file contains a collection of tests for Tcl_CallWhenDeleted.
|
||||
# Sourcing this file into Tcl runs the tests and generates output for
|
||||
# errors. No output means no errors were found.
|
||||
#
|
||||
# Copyright (c) 1993 The Regents of the University of California.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/dcall.test,v 1.3 93/09/09 16:43:05 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[info commands testdcall] == {}} {
|
||||
puts "This application hasn't been compiled with the \"testdcall\""
|
||||
puts "command, so I can't test Tcl_CallWhenDeleted."
|
||||
return
|
||||
}
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
test dcall-1.1 {deletion callbacks} {
|
||||
testdcall 1 2 3
|
||||
} {1 2 3}
|
||||
test dcall-1.2 {deletion callbacks} {
|
||||
testdcall
|
||||
} {}
|
||||
test dcall-1.3 {deletion callbacks} {
|
||||
testdcall 20 21 22 -22
|
||||
} {20 21}
|
||||
test dcall-1.4 {deletion callbacks} {
|
||||
testdcall 20 21 22 -20
|
||||
} {21 22}
|
||||
test dcall-1.5 {deletion callbacks} {
|
||||
testdcall 20 21 22 -21
|
||||
} {20 22}
|
||||
test dcall-1.6 {deletion callbacks} {
|
||||
testdcall 20 21 22 -21 -22 -20
|
||||
} {}
|
||||
94
tcl7.3/tests/defs
Normal file
94
tcl7.3/tests/defs
Normal file
@@ -0,0 +1,94 @@
|
||||
# This file contains support code for the Tcl test suite. It is
|
||||
# normally sourced by the individual files in the test suite before
|
||||
# they run their tests. This improved approach to testing was designed
|
||||
# and initially implemented by Mary Ann May-Pumphrey of Sun Microsystems.
|
||||
|
||||
set VERBOSE 0
|
||||
set TESTS {}
|
||||
set auto_noexec 1
|
||||
set auto_noload 1
|
||||
catch {rename unknown ""}
|
||||
|
||||
# If tests are being run as root, issue a warning message and set a
|
||||
# variable to prevent some tests from running at all.
|
||||
|
||||
set user {}
|
||||
catch {set user [exec whoami]}
|
||||
if {$user == "root"} {
|
||||
puts stdout "Warning: you're executing as root. I'll have to"
|
||||
puts stdout "skip some of the tests, since they'll fail as root."
|
||||
}
|
||||
|
||||
# Some of the tests don't work on some system configurations due to
|
||||
# configuration quirks, not due to Tcl problems; in order to prevent
|
||||
# false alarms, these tests are only run in the master source directory
|
||||
# at Berkeley. The presence of a file "Berkeley" in this directory is
|
||||
# used to indicate that these tests should be run.
|
||||
|
||||
set atBerkeley [file exists Berkeley]
|
||||
|
||||
proc print_verbose {test_name test_description contents_of_test code answer} {
|
||||
puts stdout "\n"
|
||||
puts stdout "==== $test_name $test_description"
|
||||
puts stdout "==== Contents of test case:"
|
||||
puts stdout "$contents_of_test"
|
||||
if {$code != 0} {
|
||||
if {$code == 1} {
|
||||
puts stdout "==== Test generated error:"
|
||||
puts stdout $answer
|
||||
} elseif {$code == 2} {
|
||||
puts stdout "==== Test generated return exception; result was:"
|
||||
puts stdout $answer
|
||||
} elseif {$code == 3} {
|
||||
puts stdout "==== Test generated break exception"
|
||||
} elseif {$code == 4} {
|
||||
puts stdout "==== Test generated continue exception"
|
||||
} else {
|
||||
puts stdout "==== Test generated exception $code; message was:"
|
||||
puts stdout $answer
|
||||
}
|
||||
} else {
|
||||
puts stdout "==== Result was:"
|
||||
puts stdout "$answer"
|
||||
}
|
||||
}
|
||||
|
||||
proc test {test_name test_description contents_of_test passing_results} {
|
||||
global VERBOSE
|
||||
global TESTS
|
||||
if {[string compare $TESTS ""] != 0} then {
|
||||
set ok 0
|
||||
foreach test $TESTS {
|
||||
if [string match $test $test_name] then {
|
||||
set ok 1
|
||||
break
|
||||
}
|
||||
}
|
||||
if !$ok then return
|
||||
}
|
||||
set code [catch {uplevel $contents_of_test} answer]
|
||||
if {$code != 0} {
|
||||
print_verbose $test_name $test_description $contents_of_test \
|
||||
$code $answer
|
||||
} elseif {[string compare $answer $passing_results] == 0} then {
|
||||
if $VERBOSE then {
|
||||
print_verbose $test_name $test_description $contents_of_test \
|
||||
$code $answer
|
||||
puts stdout "++++ $test_name PASSED"
|
||||
}
|
||||
} else {
|
||||
print_verbose $test_name $test_description $contents_of_test $code \
|
||||
$answer
|
||||
puts stdout "---- Result should have been:"
|
||||
puts stdout "$passing_results"
|
||||
puts stdout "---- $test_name FAILED"
|
||||
}
|
||||
}
|
||||
|
||||
proc dotests {file args} {
|
||||
global TESTS
|
||||
set savedTests $TESTS
|
||||
set TESTS $args
|
||||
source $file
|
||||
set TESTS $savedTests
|
||||
}
|
||||
192
tcl7.3/tests/dstring.test
Normal file
192
tcl7.3/tests/dstring.test
Normal file
@@ -0,0 +1,192 @@
|
||||
# Commands covered: none
|
||||
#
|
||||
# This file contains a collection of tests for Tcl's dynamic string
|
||||
# library procedures. Sourcing this file into Tcl runs the tests and
|
||||
# generates output for errors. No output means no errors were found.
|
||||
#
|
||||
# Copyright (c) 1993 The Regents of the University of California.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/dstring.test,v 1.3 93/10/11 09:06:01 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[info commands testdstring] == {}} {
|
||||
puts "This application hasn't been compiled with the \"testdstring\""
|
||||
puts "command, so I can't test Tcl_DStringAppend et al."
|
||||
return
|
||||
}
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
test dstring-1.1 {appending and retrieving} {
|
||||
testdstring free
|
||||
testdstring append "abc" -1
|
||||
list [testdstring get] [testdstring length]
|
||||
} {abc 3}
|
||||
test dstring-1.2 {appending and retrieving} {
|
||||
testdstring free
|
||||
testdstring append "abc" -1
|
||||
testdstring append " xyzzy" 3
|
||||
testdstring append " 12345" -1
|
||||
list [testdstring get] [testdstring length]
|
||||
} {{abc xy 12345} 12}
|
||||
test dstring-1.3 {appending and retrieving} {
|
||||
testdstring free
|
||||
foreach l {a b c d e f g h i j k l m n o p} {
|
||||
testdstring append $l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l\n -1
|
||||
}
|
||||
list [testdstring get] [testdstring length]
|
||||
} {{aaaaaaaaaaaaaaaaaaaaa
|
||||
bbbbbbbbbbbbbbbbbbbbb
|
||||
ccccccccccccccccccccc
|
||||
ddddddddddddddddddddd
|
||||
eeeeeeeeeeeeeeeeeeeee
|
||||
fffffffffffffffffffff
|
||||
ggggggggggggggggggggg
|
||||
hhhhhhhhhhhhhhhhhhhhh
|
||||
iiiiiiiiiiiiiiiiiiiii
|
||||
jjjjjjjjjjjjjjjjjjjjj
|
||||
kkkkkkkkkkkkkkkkkkkkk
|
||||
lllllllllllllllllllll
|
||||
mmmmmmmmmmmmmmmmmmmmm
|
||||
nnnnnnnnnnnnnnnnnnnnn
|
||||
ooooooooooooooooooooo
|
||||
ppppppppppppppppppppp
|
||||
} 352}
|
||||
|
||||
test dstring-2.1 {appending list elements} {
|
||||
testdstring free
|
||||
testdstring element "abc"
|
||||
testdstring element "d e f"
|
||||
list [testdstring get] [testdstring length]
|
||||
} {{abc {d e f}} 11}
|
||||
test dstring-2.2 {appending list elements} {
|
||||
testdstring free
|
||||
testdstring element "x"
|
||||
testdstring element "\{"
|
||||
testdstring element "ab\}"
|
||||
testdstring get
|
||||
} {x \{ ab\}}
|
||||
test dstring-2.3 {appending list elements} {
|
||||
testdstring free
|
||||
foreach l {a b c d e f g h i j k l m n o p} {
|
||||
testdstring element $l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l
|
||||
}
|
||||
testdstring get
|
||||
} {aaaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbb ccccccccccccccccccccc ddddddddddddddddddddd eeeeeeeeeeeeeeeeeeeee fffffffffffffffffffff ggggggggggggggggggggg hhhhhhhhhhhhhhhhhhhhh iiiiiiiiiiiiiiiiiiiii jjjjjjjjjjjjjjjjjjjjj kkkkkkkkkkkkkkkkkkkkk lllllllllllllllllllll mmmmmmmmmmmmmmmmmmmmm nnnnnnnnnnnnnnnnnnnnn ooooooooooooooooooooo ppppppppppppppppppppp}
|
||||
|
||||
test dstring-3.1 {nested sublists} {
|
||||
testdstring free
|
||||
testdstring start
|
||||
testdstring element foo
|
||||
testdstring element bar
|
||||
testdstring end
|
||||
testdstring element another
|
||||
testdstring get
|
||||
} {{foo bar} another}
|
||||
test dstring-3.2 {nested sublists} {
|
||||
testdstring free
|
||||
testdstring start
|
||||
testdstring start
|
||||
testdstring element abc
|
||||
testdstring element def
|
||||
testdstring end
|
||||
testdstring end
|
||||
testdstring element ghi
|
||||
testdstring get
|
||||
} {{{abc def}} ghi}
|
||||
test dstring-3.3 {nested sublists} {
|
||||
testdstring free
|
||||
testdstring start
|
||||
testdstring start
|
||||
testdstring start
|
||||
testdstring element foo
|
||||
testdstring element foo2
|
||||
testdstring end
|
||||
testdstring end
|
||||
testdstring element foo3
|
||||
testdstring end
|
||||
testdstring element foo4
|
||||
testdstring get
|
||||
} {{{{foo foo2}} foo3} foo4}
|
||||
test dstring-3.4 {nested sublists} {
|
||||
testdstring free
|
||||
testdstring element before
|
||||
testdstring start
|
||||
testdstring element during
|
||||
testdstring element more
|
||||
testdstring end
|
||||
testdstring element last
|
||||
testdstring get
|
||||
} {before {during more} last}
|
||||
test dstring-3.4 {nested sublists} {
|
||||
testdstring free
|
||||
testdstring element "\{"
|
||||
testdstring start
|
||||
testdstring element first
|
||||
testdstring element second
|
||||
testdstring end
|
||||
testdstring get
|
||||
} {\{ {first second}}
|
||||
|
||||
test dstring-4.1 {truncation} {
|
||||
testdstring free
|
||||
testdstring append "abcdefg" -1
|
||||
testdstring trunc 3
|
||||
list [testdstring get] [testdstring length]
|
||||
} {abc 3}
|
||||
test dstring-4.2 {truncation} {
|
||||
testdstring free
|
||||
testdstring append "xyzzy" -1
|
||||
testdstring trunc 0
|
||||
list [testdstring get] [testdstring length]
|
||||
} {{} 0}
|
||||
|
||||
test dstring-5.1 {copying to result} {
|
||||
testdstring free
|
||||
testdstring append xyz -1
|
||||
testdstring result
|
||||
} xyz
|
||||
test dstring-5.2 {copying to result} {
|
||||
testdstring free
|
||||
foreach l {a b c d e f g h i j k l m n o p} {
|
||||
testdstring append $l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l\n -1
|
||||
}
|
||||
set a [testdstring result]
|
||||
testdstring append abc -1
|
||||
list $a [testdstring get]
|
||||
} {{aaaaaaaaaaaaaaaaaaaaa
|
||||
bbbbbbbbbbbbbbbbbbbbb
|
||||
ccccccccccccccccccccc
|
||||
ddddddddddddddddddddd
|
||||
eeeeeeeeeeeeeeeeeeeee
|
||||
fffffffffffffffffffff
|
||||
ggggggggggggggggggggg
|
||||
hhhhhhhhhhhhhhhhhhhhh
|
||||
iiiiiiiiiiiiiiiiiiiii
|
||||
jjjjjjjjjjjjjjjjjjjjj
|
||||
kkkkkkkkkkkkkkkkkkkkk
|
||||
lllllllllllllllllllll
|
||||
mmmmmmmmmmmmmmmmmmmmm
|
||||
nnnnnnnnnnnnnnnnnnnnn
|
||||
ooooooooooooooooooooo
|
||||
ppppppppppppppppppppp
|
||||
} abc}
|
||||
|
||||
testdstring free
|
||||
122
tcl7.3/tests/env.test
Normal file
122
tcl7.3/tests/env.test
Normal file
@@ -0,0 +1,122 @@
|
||||
# Commands covered: none (tests environment variable implementation)
|
||||
#
|
||||
# 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.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/env.test,v 1.7 93/10/14 14:59:14 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
# If there is no "printenv" program on this system, then it's just too
|
||||
# much trouble to run this test (can't necessarily run csh to get the
|
||||
# environment: on some systems it barfs if there isn't a minimum set
|
||||
# predefined environment variables. Also, printenv returns a non-zero
|
||||
# status on some systems, so read the environment using a procedure
|
||||
# that catches errors.
|
||||
|
||||
set printenv {}
|
||||
if [info exists env(PATH)] {
|
||||
set dirs [split $env(PATH) :]
|
||||
} else {
|
||||
set dirs {/bin /usr/bin /usr/ucb /usr/local /usr/public /usr/etc}
|
||||
}
|
||||
foreach i $dirs {
|
||||
if [file executable $i/printenv] {
|
||||
# The following hack is needed because of weirdness with
|
||||
# environment variables in symbolic lines on Apollos (?!#?).
|
||||
if ![catch {exec sh -c "cd $i; pwd"} x] {
|
||||
set printenv $x/printenv
|
||||
} else {
|
||||
set printenv $i/printenv
|
||||
}
|
||||
break
|
||||
}
|
||||
}
|
||||
if {$printenv == ""} {
|
||||
puts stdout "Skipping env tests: need \"printenv\" to read environment."
|
||||
return ""
|
||||
}
|
||||
proc getenv {} {
|
||||
global printenv
|
||||
catch {exec $printenv} out
|
||||
if {$out == "child process exited abnormally"} {
|
||||
set out {}
|
||||
}
|
||||
return $out
|
||||
}
|
||||
|
||||
# Save the current environment variables at the start of the test.
|
||||
|
||||
foreach name [array names env] {
|
||||
set env2($name) $env($name)
|
||||
unset env($name)
|
||||
}
|
||||
|
||||
test env-1.1 {adding environment variables} {
|
||||
getenv
|
||||
} {}
|
||||
|
||||
set env(NAME1) "test string"
|
||||
test env-1.2 {adding environment variables} {
|
||||
getenv
|
||||
} {NAME1=test string}
|
||||
|
||||
set env(NAME2) "more"
|
||||
test env-1.3 {adding environment variables} {
|
||||
getenv
|
||||
} {NAME1=test string
|
||||
NAME2=more}
|
||||
|
||||
set env(XYZZY) "garbage"
|
||||
test env-1.4 {adding environment variables} {
|
||||
getenv
|
||||
} {NAME1=test string
|
||||
NAME2=more
|
||||
XYZZY=garbage}
|
||||
|
||||
set env(NAME2) "new value"
|
||||
test env-2.1 {changing environment variables} {
|
||||
getenv
|
||||
} {NAME1=test string
|
||||
NAME2=new value
|
||||
XYZZY=garbage}
|
||||
|
||||
unset env(NAME2)
|
||||
test env-3.1 {unsetting environment variables} {
|
||||
getenv
|
||||
} {NAME1=test string
|
||||
XYZZY=garbage}
|
||||
unset env(NAME1)
|
||||
test env-3.2 {unsetting environment variables} {
|
||||
getenv
|
||||
} {XYZZY=garbage}
|
||||
|
||||
# Restore the environment variables at the end of the test.
|
||||
|
||||
foreach name [array names env] {
|
||||
unset env($name)
|
||||
}
|
||||
foreach name [array names env2] {
|
||||
set env($name) $env2($name)
|
||||
}
|
||||
185
tcl7.3/tests/error.test
Normal file
185
tcl7.3/tests/error.test
Normal file
@@ -0,0 +1,185 @@
|
||||
# Commands covered: error, catch
|
||||
#
|
||||
# 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.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/error.test,v 1.12 93/02/06 15:54:01 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
proc foo {} {
|
||||
global errorInfo
|
||||
set a [catch {format [error glorp2]} b]
|
||||
error {Human-generated}
|
||||
}
|
||||
|
||||
proc foo2 {} {
|
||||
global errorInfo
|
||||
set a [catch {format [error glorp2]} b]
|
||||
error {Human-generated} $errorInfo
|
||||
}
|
||||
|
||||
# Catch errors occurring in commands and errors from "error" command
|
||||
|
||||
test error-1.1 {simple errors from commands} {
|
||||
catch {format [string compare]} b
|
||||
} 1
|
||||
|
||||
test error-1.2 {simple errors from commands} {
|
||||
catch {format [string compare]} b
|
||||
set b
|
||||
} {wrong # args: should be "string compare string1 string2"}
|
||||
|
||||
test error-1.3 {simple errors from commands} {
|
||||
catch {format [string compare]} b
|
||||
set errorInfo
|
||||
} {wrong # args: should be "string compare string1 string2"
|
||||
while executing
|
||||
"string compare"
|
||||
invoked from within
|
||||
"format [string compare]..."}
|
||||
|
||||
test error-1.4 {simple errors from commands} {
|
||||
catch {error glorp} b
|
||||
} 1
|
||||
|
||||
test error-1.5 {simple errors from commands} {
|
||||
catch {error glorp} b
|
||||
set b
|
||||
} glorp
|
||||
|
||||
test error-1.6 {simple errors from commands} {
|
||||
catch {catch a b c} b
|
||||
} 1
|
||||
|
||||
test error-1.7 {simple errors from commands} {
|
||||
catch {catch a b c} b
|
||||
set b
|
||||
} {wrong # args: should be "catch command ?varName?"}
|
||||
|
||||
test error-2.1 {simple errors from commands} {
|
||||
catch catch
|
||||
} 1
|
||||
|
||||
# Check errors nested in procedures. Also check the optional argument
|
||||
# to "error" to generate a new error trace.
|
||||
|
||||
test error-2.1 {errors in nested procedures} {
|
||||
catch foo b
|
||||
} 1
|
||||
|
||||
test error-2.2 {errors in nested procedures} {
|
||||
catch foo b
|
||||
set b
|
||||
} {Human-generated}
|
||||
|
||||
test error-2.3 {errors in nested procedures} {
|
||||
catch foo b
|
||||
set errorInfo
|
||||
} {Human-generated
|
||||
while executing
|
||||
"error {Human-generated}"
|
||||
(procedure "foo" line 4)
|
||||
invoked from within
|
||||
"foo"}
|
||||
|
||||
test error-2.4 {errors in nested procedures} {
|
||||
catch foo2 b
|
||||
} 1
|
||||
|
||||
test error-2.5 {errors in nested procedures} {
|
||||
catch foo2 b
|
||||
set b
|
||||
} {Human-generated}
|
||||
|
||||
test error-2.6 {errors in nested procedures} {
|
||||
catch foo2 b
|
||||
set errorInfo
|
||||
} {glorp2
|
||||
while executing
|
||||
"error glorp2"
|
||||
invoked from within
|
||||
"format [error glorp2]..."
|
||||
(procedure "foo2" line 1)
|
||||
invoked from within
|
||||
"foo2"}
|
||||
|
||||
# Error conditions related to "catch".
|
||||
|
||||
test error-3.1 {errors in catch command} {
|
||||
list [catch {catch} msg] $msg
|
||||
} {1 {wrong # args: should be "catch command ?varName?"}}
|
||||
test error-3.2 {errors in catch command} {
|
||||
list [catch {catch a b c} msg] $msg
|
||||
} {1 {wrong # args: should be "catch command ?varName?"}}
|
||||
test error-3.3 {errors in catch command} {
|
||||
catch {unset a}
|
||||
set a(0) 22
|
||||
list [catch {catch {format 44} a} msg] $msg
|
||||
} {1 {couldn't save command result in variable}}
|
||||
catch {unset a}
|
||||
|
||||
# More tests related to errorInfo and errorCode
|
||||
|
||||
test error-4.1 {errorInfo and errorCode variables} {
|
||||
list [catch {error msg1 msg2 msg3} msg] $msg $errorInfo $errorCode
|
||||
} {1 msg1 msg2 msg3}
|
||||
test error-4.2 {errorInfo and errorCode variables} {
|
||||
list [catch {error msg1 {} msg3} msg] $msg $errorInfo $errorCode
|
||||
} {1 msg1 {msg1
|
||||
while executing
|
||||
"error msg1 {} msg3"} msg3}
|
||||
test error-4.3 {errorInfo and errorCode variables} {
|
||||
list [catch {error msg1 {}} msg] $msg $errorInfo $errorCode
|
||||
} {1 msg1 {msg1
|
||||
while executing
|
||||
"error msg1 {}"} NONE}
|
||||
test error-4.4 {errorInfo and errorCode variables} {
|
||||
set errorCode bogus
|
||||
list [catch {error msg1} msg] $msg $errorInfo $errorCode
|
||||
} {1 msg1 {msg1
|
||||
while executing
|
||||
"error msg1"} NONE}
|
||||
test error-4.5 {errorInfo and errorCode variables} {
|
||||
set errorCode bogus
|
||||
list [catch {error msg1 msg2 {}} msg] $msg $errorInfo $errorCode
|
||||
} {1 msg1 msg2 {}}
|
||||
|
||||
# Errors in error command itself
|
||||
|
||||
test error-5.1 {errors in error command} {
|
||||
list [catch {error} msg] $msg
|
||||
} {1 {wrong # args: should be "error message ?errorInfo? ?errorCode?"}}
|
||||
test error-5.2 {errors in error command} {
|
||||
list [catch {error a b c d} msg] $msg
|
||||
} {1 {wrong # args: should be "error message ?errorInfo? ?errorCode?"}}
|
||||
|
||||
# Make sure that catch resets error information
|
||||
|
||||
test error-6.1 {catch must reset error state} {
|
||||
catch {error outer [catch {error inner inner.errorInfo inner.errorCode}]}
|
||||
list $errorCode $errorInfo
|
||||
} {NONE 1}
|
||||
|
||||
return ""
|
||||
69
tcl7.3/tests/eval.test
Normal file
69
tcl7.3/tests/eval.test
Normal file
@@ -0,0 +1,69 @@
|
||||
# Commands covered: eval
|
||||
#
|
||||
# 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.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/eval.test,v 1.5 93/02/06 15:54:14 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
test eval-1.1 {single argument} {
|
||||
eval {format 22}
|
||||
} 22
|
||||
test eval-1.2 {multiple arguments} {
|
||||
set a {$b}
|
||||
set b xyzzy
|
||||
eval format $a
|
||||
} xyzzy
|
||||
test eval-1.3 {single argument} {
|
||||
eval concat a b c d e f g
|
||||
} {a b c d e f g}
|
||||
|
||||
test eval-2.1 {error: not enough arguments} {catch eval} 1
|
||||
test eval-2.2 {error: not enough arguments} {
|
||||
catch eval msg
|
||||
set msg
|
||||
} {wrong # args: should be "eval arg ?arg ...?"}
|
||||
test eval-2.3 {error in eval'ed command} {
|
||||
catch {eval {error "test error"}}
|
||||
} 1
|
||||
test eval-2.4 {error in eval'ed command} {
|
||||
catch {eval {error "test error"}} msg
|
||||
set msg
|
||||
} {test error}
|
||||
test eval-2.5 {error in eval'ed command: setting errorInfo} {
|
||||
catch {eval {
|
||||
set a 1
|
||||
error "test error"
|
||||
}} msg
|
||||
set errorInfo
|
||||
} "test error
|
||||
while executing
|
||||
\"error \"test error\"\"
|
||||
(\"eval\" body line 3)
|
||||
invoked from within
|
||||
\"eval {
|
||||
set a 1
|
||||
error \"test error\"
|
||||
}\""
|
||||
435
tcl7.3/tests/exec.test
Normal file
435
tcl7.3/tests/exec.test
Normal file
@@ -0,0 +1,435 @@
|
||||
# Commands covered: exec
|
||||
#
|
||||
# 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.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/exec.test,v 1.30 93/09/16 16:57:43 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
# Basic operations.
|
||||
|
||||
test exec-1.1 {basic exec operation} {
|
||||
exec echo a b c
|
||||
} "a b c"
|
||||
test exec-1.2 {pipelining} {
|
||||
exec echo a b c d | cat | cat
|
||||
} "a b c d"
|
||||
test exec-1.3 {pipelining} {
|
||||
set a [exec echo a b c d | cat | wc]
|
||||
list [scan $a "%d %d %d" b c d] $b $c $d
|
||||
} {3 1 4 8}
|
||||
|
||||
# I/O redirection: input from Tcl command.
|
||||
|
||||
test exec-2.1 {redirecting input from immediate source} {
|
||||
exec cat << "Sample text"
|
||||
} {Sample text}
|
||||
test exec-2.2 {redirecting input from immediate source} {
|
||||
exec << "Sample text" cat | cat
|
||||
} {Sample text}
|
||||
test exec-2.3 {redirecting input from immediate source} {
|
||||
exec cat << "Sample text" | cat
|
||||
} {Sample text}
|
||||
test exec-2.4 {redirecting input from immediate source} {
|
||||
exec cat | cat << "Sample text"
|
||||
} {Sample text}
|
||||
test exec-2.5 {redirecting input from immediate source} {
|
||||
exec cat "<<Joined to arrows"
|
||||
} {Joined to arrows}
|
||||
|
||||
# I/O redirection: output to file.
|
||||
|
||||
catch {exec rm -f gorp.file}
|
||||
test exec-3.1 {redirecting output to file} {
|
||||
exec echo "Some simple words" > gorp.file
|
||||
exec cat gorp.file
|
||||
} "Some simple words"
|
||||
test exec-3.2 {redirecting output to file} {
|
||||
exec echo "More simple words" | >gorp.file cat | cat
|
||||
exec cat gorp.file
|
||||
} "More simple words"
|
||||
test exec-3.3 {redirecting output to file} {
|
||||
exec > gorp.file echo "Different simple words" | cat | cat
|
||||
exec cat gorp.file
|
||||
} "Different simple words"
|
||||
test exec-3.4 {redirecting output to file} {
|
||||
exec echo "Some simple words" >gorp.file
|
||||
exec cat gorp.file
|
||||
} "Some simple words"
|
||||
test exec-3.5 {redirecting output to file} {
|
||||
exec echo "First line" >gorp.file
|
||||
exec echo "Second line" >> gorp.file
|
||||
exec cat gorp.file
|
||||
} "First line\nSecond line"
|
||||
test exec-3.6 {redirecting output to file} {
|
||||
exec echo "First line" >gorp.file
|
||||
exec echo "Second line" >>gorp.file
|
||||
exec cat gorp.file
|
||||
} "First line\nSecond line"
|
||||
test exec-3.7 {redirecting output to file} {
|
||||
set f [open gorp.file w]
|
||||
puts $f "Line 1"
|
||||
flush $f
|
||||
exec echo "More text" >@ $f
|
||||
exec echo >@$f "Even more"
|
||||
puts $f "Line 3"
|
||||
close $f
|
||||
exec cat gorp.file
|
||||
} "Line 1\nMore text\nEven more\nLine 3"
|
||||
|
||||
# I/O redirection: output and stderr to file.
|
||||
|
||||
catch {exec rm -f gorp.file}
|
||||
test exec-4.1 {redirecting output and stderr to file} {
|
||||
exec echo "test output" >& gorp.file
|
||||
exec cat gorp.file
|
||||
} "test output"
|
||||
test exec-4.2 {redirecting output and stderr to file} {
|
||||
list [exec sh -c "echo foo bar 1>&2" >&gorp.file] \
|
||||
[exec cat gorp.file]
|
||||
} {{} {foo bar}}
|
||||
test exec-4.3 {redirecting output and stderr to file} {
|
||||
exec echo "first line" > gorp.file
|
||||
list [exec sh -c "echo foo bar 1>&2" >>&gorp.file] \
|
||||
[exec cat gorp.file]
|
||||
} "{} {first line\nfoo bar}"
|
||||
test exec-4.4 {redirecting output and stderr to file} {
|
||||
set f [open gorp.file w]
|
||||
puts $f "Line 1"
|
||||
flush $f
|
||||
exec echo "More text" >&@ $f
|
||||
exec echo >&@$f "Even more"
|
||||
puts $f "Line 3"
|
||||
close $f
|
||||
exec cat gorp.file
|
||||
} "Line 1\nMore text\nEven more\nLine 3"
|
||||
test exec-4.5 {redirecting output and stderr to file} {
|
||||
set f [open gorp.file w]
|
||||
puts $f "Line 1"
|
||||
flush $f
|
||||
exec >&@ $f sh -c "echo foo bar 1>&2"
|
||||
exec >&@$f sh -c "echo xyzzy 1>&2"
|
||||
puts $f "Line 3"
|
||||
close $f
|
||||
exec cat gorp.file
|
||||
} "Line 1\nfoo bar\nxyzzy\nLine 3"
|
||||
|
||||
# I/O redirection: input from file.
|
||||
|
||||
exec echo "Just a few thoughts" > gorp.file
|
||||
test exec-5.1 {redirecting input from file} {
|
||||
exec cat < gorp.file
|
||||
} {Just a few thoughts}
|
||||
test exec-5.2 {redirecting input from file} {
|
||||
exec cat | cat < gorp.file
|
||||
} {Just a few thoughts}
|
||||
test exec-5.3 {redirecting input from file} {
|
||||
exec cat < gorp.file | cat
|
||||
} {Just a few thoughts}
|
||||
test exec-5.4 {redirecting input from file} {
|
||||
exec < gorp.file cat | cat
|
||||
} {Just a few thoughts}
|
||||
test exec-5.5 {redirecting input from file} {
|
||||
exec cat <gorp.file
|
||||
} {Just a few thoughts}
|
||||
test exec-5.6 {redirecting input from file} {
|
||||
set f [open gorp.file r]
|
||||
set result [exec cat <@ $f]
|
||||
close $f
|
||||
set result
|
||||
} {Just a few thoughts}
|
||||
test exec-5.7 {redirecting input from file} {
|
||||
set f [open gorp.file r]
|
||||
set result [exec <@$f cat]
|
||||
close $f
|
||||
set result
|
||||
} {Just a few thoughts}
|
||||
|
||||
# I/O redirection: standard error through a pipeline.
|
||||
|
||||
test exec-6.1 {redirecting stderr through a pipeline} {
|
||||
exec sh -c "echo foo bar" |& cat
|
||||
} "foo bar"
|
||||
test exec-6.2 {redirecting stderr through a pipeline} {
|
||||
exec sh -c "echo foo bar 1>&2" |& cat
|
||||
} "foo bar"
|
||||
test exec-6.3 {redirecting stderr through a pipeline} {
|
||||
exec sh -c "echo foo bar 1>&2" |& sh -c "echo second msg 1>& 2; cat" |& cat
|
||||
} "second msg\nfoo bar"
|
||||
|
||||
# I/O redirection: combinations.
|
||||
|
||||
catch {exec rm -f gorp.file2}
|
||||
test exec-7.1 {multiple I/O redirections} {
|
||||
exec << "command input" > gorp.file2 cat < gorp.file
|
||||
exec cat gorp.file2
|
||||
} {Just a few thoughts}
|
||||
test exec-7.2 {multiple I/O redirections} {
|
||||
exec < gorp.file << "command input" cat
|
||||
} {command input}
|
||||
|
||||
# Long input to command and output from command.
|
||||
|
||||
set a "0123456789 xxxxxxxxx abcdefghi ABCDEFGHIJK\n"
|
||||
set a [concat $a $a $a $a]
|
||||
set a [concat $a $a $a $a]
|
||||
set a [concat $a $a $a $a]
|
||||
set a [concat $a $a $a $a]
|
||||
test exec-8.1 {long input and output} {
|
||||
exec cat << $a
|
||||
} $a
|
||||
|
||||
# Commands that return errors.
|
||||
|
||||
test exec-9.1 {commands returning errors} {
|
||||
set x [catch {exec gorp456} msg]
|
||||
list $x $msg [lindex $errorCode 0] [lrange $errorCode 2 end]
|
||||
} {1 {couldn't find "gorp456" to execute} CHILDSTATUS 1}
|
||||
test exec-9.2 {commands returning errors} {
|
||||
set x [catch {exec foo123 | gorp456} msg]
|
||||
set x1 {couldn't find "foo123" to execute
|
||||
couldn't find "gorp456" to execute}
|
||||
set x2 {couldn't find "gorp456" to execute
|
||||
couldn't find "foo123" to execute}
|
||||
set y [expr {($msg == $x1) || ($msg == $x2)}]
|
||||
list $x $y [lindex $errorCode 0] [lrange $errorCode 2 end]
|
||||
} {1 1 CHILDSTATUS 1}
|
||||
test exec-9.3 {commands returning errors} {
|
||||
list [catch {exec sleep 1 | sh -c "exit 43" | sleep 1} msg] $msg
|
||||
} {1 {child process exited abnormally}}
|
||||
test exec-9.4 {commands returning errors} {
|
||||
list [catch {exec gorp456 | echo a b c} msg] $msg
|
||||
} {1 {a b c
|
||||
couldn't find "gorp456" to execute}}
|
||||
test exec-9.5 {commands returning errors} {
|
||||
list [catch {exec sh -c "echo error msg 1>&2"} msg] $msg
|
||||
} {1 {error msg}}
|
||||
test exec-9.6 {commands returning errors} {
|
||||
list [catch {exec sh -c "echo error msg 1>&2" | sh -c "echo error msg 1>&2"} msg] $msg
|
||||
} {1 {error msg
|
||||
error msg}}
|
||||
|
||||
# Errors in executing the Tcl command, as opposed to errors in the
|
||||
# processes that are invoked.
|
||||
|
||||
test exec-10.1 {errors in exec invocation} {
|
||||
list [catch {exec} msg] $msg
|
||||
} {1 {wrong # args: should be "exec ?switches? arg ?arg ...?"}}
|
||||
test exec-10.2 {errors in exec invocation} {
|
||||
list [catch {exec | cat} msg] $msg
|
||||
} {1 {illegal use of | or |& in command}}
|
||||
test exec-10.3 {errors in exec invocation} {
|
||||
list [catch {exec cat |} msg] $msg
|
||||
} {1 {illegal use of | or |& in command}}
|
||||
test exec-10.4 {errors in exec invocation} {
|
||||
list [catch {exec cat | | cat} msg] $msg
|
||||
} {1 {illegal use of | or |& in command}}
|
||||
test exec-10.5 {errors in exec invocation} {
|
||||
list [catch {exec cat | |& cat} msg] $msg
|
||||
} {1 {illegal use of | or |& in command}}
|
||||
test exec-10.6 {errors in exec invocation} {
|
||||
list [catch {exec cat |&} msg] $msg
|
||||
} {1 {illegal use of | or |& in command}}
|
||||
test exec-10.7 {errors in exec invocation} {
|
||||
list [catch {exec cat <} msg] $msg
|
||||
} {1 {can't specify "<" as last word in command}}
|
||||
test exec-10.8 {errors in exec invocation} {
|
||||
list [catch {exec cat >} msg] $msg
|
||||
} {1 {can't specify ">" as last word in command}}
|
||||
test exec-10.9 {errors in exec invocation} {
|
||||
list [catch {exec cat <<} msg] $msg
|
||||
} {1 {can't specify "<<" as last word in command}}
|
||||
test exec-10.10 {errors in exec invocation} {
|
||||
list [catch {exec cat >>} msg] $msg
|
||||
} {1 {can't specify ">>" as last word in command}}
|
||||
test exec-10.11 {errors in exec invocation} {
|
||||
list [catch {exec cat >&} msg] $msg
|
||||
} {1 {can't specify ">&" as last word in command}}
|
||||
test exec-10.12 {errors in exec invocation} {
|
||||
list [catch {exec cat >>&} msg] $msg
|
||||
} {1 {can't specify ">>&" as last word in command}}
|
||||
test exec-10.13 {errors in exec invocation} {
|
||||
list [catch {exec cat >@} msg] $msg
|
||||
} {1 {can't specify ">@" as last word in command}}
|
||||
test exec-10.14 {errors in exec invocation} {
|
||||
list [catch {exec cat <@} msg] $msg
|
||||
} {1 {can't specify "<@" as last word in command}}
|
||||
test exec-10.15 {errors in exec invocation} {
|
||||
list [catch {exec cat < a/b/c} msg] [string tolower $msg]
|
||||
} {1 {couldn't read file "a/b/c": no such file or directory}}
|
||||
test exec-10.16 {errors in exec invocation} {
|
||||
list [catch {exec cat << foo > a/b/c} msg] [string tolower $msg]
|
||||
} {1 {couldn't write file "a/b/c": no such file or directory}}
|
||||
test exec-10.17 {errors in exec invocation} {
|
||||
list [catch {exec cat << foo > a/b/c} msg] [string tolower $msg]
|
||||
} {1 {couldn't write file "a/b/c": no such file or directory}}
|
||||
set f [open gorp.file w]
|
||||
test exec-10.18 {errors in exec invocation} {
|
||||
list [catch {exec cat <@ $f} msg] $msg
|
||||
} "1 {\"$f\" wasn't opened for reading}"
|
||||
close $f
|
||||
set f [open gorp.file r]
|
||||
test exec-10.19 {errors in exec invocation} {
|
||||
list [catch {exec cat >@ $f} msg] $msg
|
||||
} "1 {\"$f\" wasn't opened for writing}"
|
||||
close $f
|
||||
|
||||
# Commands in background.
|
||||
|
||||
test exec-11.1 {commands in background} {
|
||||
set x [lindex [time {exec sleep 2 &}] 0]
|
||||
expr $x<1000000
|
||||
} 1
|
||||
test exec-11.2 {commands in background} {
|
||||
list [catch {exec echo a &b} msg] $msg
|
||||
} {0 {a &b}}
|
||||
test exec-11.3 {commands in background} {
|
||||
llength [exec sleep 1 &]
|
||||
} 1
|
||||
test exec-11.4 {commands in background} {
|
||||
llength [exec sleep 1 | sleep 1 | sleep 1 &]
|
||||
} 3
|
||||
|
||||
# Make sure that background commands are properly reaped when
|
||||
# they eventually die.
|
||||
|
||||
exec sleep 3
|
||||
if $atBerkeley {
|
||||
test exec-12.1 {reaping background processes} {
|
||||
for {set i 0} {$i < 20} {incr i} {
|
||||
exec echo foo > /dev/null &
|
||||
}
|
||||
exec sleep 1
|
||||
catch {exec ps | fgrep "echo foo" | fgrep -v fgrep | wc} msg
|
||||
lindex $msg 0
|
||||
} 0
|
||||
test exec-12.2 {reaping background processes} {
|
||||
exec sleep 2 | sleep 2 | sleep 2 &
|
||||
catch {exec ps | fgrep "sleep 2" | fgrep -v fgrep | wc} msg
|
||||
set x [lindex $msg 0]
|
||||
exec sleep 3
|
||||
catch {exec ps | fgrep "sleep 2" | fgrep -v fgrep | wc} msg
|
||||
list $x [lindex $msg 0]
|
||||
} {3 0}
|
||||
test exec-12.3 {reaping background processes} {
|
||||
exec sleep 1000 &
|
||||
exec sleep 1000 &
|
||||
set x [exec ps | fgrep "sleep 1000" | fgrep -v fgrep]
|
||||
set pids {}
|
||||
foreach i [split $x \n] {
|
||||
lappend pids [lindex $i 0]
|
||||
}
|
||||
foreach i $pids {
|
||||
catch {exec kill -STOP $i}
|
||||
}
|
||||
catch {exec ps | fgrep "sleep 1000" | fgrep -v fgrep | wc} msg
|
||||
set x [lindex $msg 0]
|
||||
|
||||
foreach i $pids {
|
||||
catch {exec kill -KILL $i}
|
||||
}
|
||||
catch {exec ps | fgrep "sleep 1000" | fgrep -v fgrep | wc} msg
|
||||
list $x [lindex $msg 0]
|
||||
} {2 0}
|
||||
}
|
||||
|
||||
# Make sure "errorCode" is set correctly.
|
||||
|
||||
test exec-13.1 {setting errorCode variable} {
|
||||
list [catch {exec cat < a/b/c} msg] [string tolower $errorCode]
|
||||
} {1 {posix enoent {no such file or directory}}}
|
||||
test exec-13.2 {setting errorCode variable} {
|
||||
list [catch {exec cat > a/b/c} msg] [string tolower $errorCode]
|
||||
} {1 {posix enoent {no such file or directory}}}
|
||||
test exec-13.3 {setting errorCode variable} {
|
||||
set x [catch {exec _weirdo_command_} msg]
|
||||
list $x $msg [lindex $errorCode 0] [lrange $errorCode 2 end]
|
||||
} {1 {couldn't find "_weirdo_command_" to execute} CHILDSTATUS 1}
|
||||
|
||||
# Switches before the first argument
|
||||
|
||||
test exec-14.1 {-keepnewline switch} {
|
||||
exec -keepnewline echo foo
|
||||
} "foo\n"
|
||||
test exec-14.2 {-keepnewline switch} {
|
||||
list [catch {exec -keepnewline} msg] $msg
|
||||
} {1 {wrong # args: should be "exec ?switches? arg ?arg ...?"}}
|
||||
test exec-14.3 {unknown switch} {
|
||||
list [catch {exec -gorp} msg] $msg
|
||||
} {1 {bad switch "-gorp": must be -keepnewline or --}}
|
||||
test exec-14.4 {-- switch} {
|
||||
list [catch {exec -- -gorp} msg] $msg
|
||||
} {1 {couldn't find "-gorp" to execute}}
|
||||
|
||||
# Redirecting standard error separately from standard output
|
||||
|
||||
test exec-15.1 {standard error redirection} {
|
||||
exec echo "First line" > gorp.file
|
||||
list [exec sh -c "echo foo bar 1>&2" 2> gorp.file] \
|
||||
[exec cat gorp.file]
|
||||
} {{} {foo bar}}
|
||||
test exec-15.2 {standard error redirection} {
|
||||
list [exec sh -c "echo foo bar 1>&2" | echo biz baz >gorp.file \
|
||||
2> gorp.file2] [exec cat gorp.file] \
|
||||
[exec cat gorp.file2]
|
||||
} {{} {biz baz} {foo bar}}
|
||||
test exec-15.3 {standard error redirection} {
|
||||
list [exec sh -c "echo foo bar 1>&2" | echo biz baz 2>gorp.file \
|
||||
> gorp.file2] [exec cat gorp.file] \
|
||||
[exec cat gorp.file2]
|
||||
} {{} {foo bar} {biz baz}}
|
||||
test exec-15.4 {standard error redirection} {
|
||||
set f [open gorp.file w]
|
||||
puts $f "Line 1"
|
||||
flush $f
|
||||
exec sh -c "echo foo bar 1>&2" 2>@ $f
|
||||
puts $f "Line 3"
|
||||
close $f
|
||||
exec cat gorp.file
|
||||
} {Line 1
|
||||
foo bar
|
||||
Line 3}
|
||||
test exec-15.5 {standard error redirection} {
|
||||
exec echo "First line" > gorp.file
|
||||
exec sh -c "echo foo bar 1>&2" 2>> gorp.file
|
||||
exec cat gorp.file
|
||||
} {First line
|
||||
foo bar}
|
||||
test exec-15.6 {standard error redirection} {
|
||||
exec sh -c "echo foo bar 1>&2" > gorp.file2 2> gorp.file \
|
||||
>& gorp.file 2> gorp.file2 | echo biz baz
|
||||
list [exec cat gorp.file] [exec cat gorp.file2]
|
||||
} {{biz baz} {foo bar}}
|
||||
|
||||
if $atBerkeley {
|
||||
test exec-16.1 {restore signal settings before exec} {
|
||||
set f [open {|cat exec.test} r]
|
||||
list [catch {close $f} msg] [string tolower $msg]
|
||||
} {1 {child killed: write on pipe with no readers}}
|
||||
}
|
||||
|
||||
catch {exec rm -f gorp.file}
|
||||
catch {exec rm -f gorp.file2}
|
||||
return {}
|
||||
822
tcl7.3/tests/expr.test
Normal file
822
tcl7.3/tests/expr.test
Normal file
@@ -0,0 +1,822 @@
|
||||
# Commands covered: expr
|
||||
#
|
||||
# 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.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/expr.test,v 1.30 93/09/08 16:46:45 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} {
|
||||
set gotT1 0
|
||||
puts "This application hasn't been compiled with the \"T1\" and"
|
||||
puts "\"T2\" math functions, so I'll skip some of the expr tests."
|
||||
} else {
|
||||
set gotT1 1
|
||||
}
|
||||
|
||||
# First, test all of the integer operators individually.
|
||||
|
||||
test expr-1.1 {integer operators} {expr -4} -4
|
||||
test expr-1.2 {integer operators} {expr -(1+4)} -5
|
||||
test expr-1.3 {integer operators} {expr ~3} -4
|
||||
test expr-1.4 {integer operators} {expr !2} 0
|
||||
test expr-1.5 {integer operators} {expr !0} 1
|
||||
test expr-1.6 {integer operators} {expr 4*6} 24
|
||||
test expr-1.7 {integer operators} {expr 36/12} 3
|
||||
test expr-1.8 {integer operators} {expr 27/4} 6
|
||||
test expr-1.9 {integer operators} {expr 27%4} 3
|
||||
test expr-1.10 {integer operators} {expr 2+2} 4
|
||||
test expr-1.11 {integer operators} {expr 2-6} -4
|
||||
test expr-1.12 {integer operators} {expr 1<<3} 8
|
||||
test expr-1.13 {integer operators} {expr 0xff>>2} 63
|
||||
test expr-1.14 {integer operators} {expr -1>>2} -1
|
||||
test expr-1.15 {integer operators} {expr 3>2} 1
|
||||
test expr-1.16 {integer operators} {expr 2>2} 0
|
||||
test expr-1.17 {integer operators} {expr 1>2} 0
|
||||
test expr-1.18 {integer operators} {expr 3<2} 0
|
||||
test expr-1.19 {integer operators} {expr 2<2} 0
|
||||
test expr-1.20 {integer operators} {expr 1<2} 1
|
||||
test expr-1.21 {integer operators} {expr 3>=2} 1
|
||||
test expr-1.22 {integer operators} {expr 2>=2} 1
|
||||
test expr-1.23 {integer operators} {expr 1>=2} 0
|
||||
test expr-1.24 {integer operators} {expr 3<=2} 0
|
||||
test expr-1.25 {integer operators} {expr 2<=2} 1
|
||||
test expr-1.26 {integer operators} {expr 1<=2} 1
|
||||
test expr-1.27 {integer operators} {expr 3==2} 0
|
||||
test expr-1.28 {integer operators} {expr 2==2} 1
|
||||
test expr-1.29 {integer operators} {expr 3!=2} 1
|
||||
test expr-1.30 {integer operators} {expr 2!=2} 0
|
||||
test expr-1.31 {integer operators} {expr 7&0x13} 3
|
||||
test expr-1.32 {integer operators} {expr 7^0x13} 20
|
||||
test expr-1.33 {integer operators} {expr 7|0x13} 23
|
||||
test expr-1.34 {integer operators} {expr 0&&1} 0
|
||||
test expr-1.35 {integer operators} {expr 0&&0} 0
|
||||
test expr-1.36 {integer operators} {expr 1&&3} 1
|
||||
test expr-1.37 {integer operators} {expr 0||1} 1
|
||||
test expr-1.38 {integer operators} {expr 3||0} 1
|
||||
test expr-1.39 {integer operators} {expr 0||0} 0
|
||||
test expr-1.40 {integer operators} {expr 3>2?44:66} 44
|
||||
test expr-1.41 {integer operators} {expr 2>3?44:66} 66
|
||||
test expr-1.42 {integer operators} {expr 36/5} 7
|
||||
test expr-1.43 {integer operators} {expr 36%5} 1
|
||||
test expr-1.44 {integer operators} {expr -36/5} -8
|
||||
test expr-1.45 {integer operators} {expr -36%5} 4
|
||||
test expr-1.46 {integer operators} {expr 36/-5} -8
|
||||
test expr-1.47 {integer operators} {expr 36%-5} -4
|
||||
test expr-1.48 {integer operators} {expr -36/-5} 7
|
||||
test expr-1.49 {integer operators} {expr -36%-5} -1
|
||||
|
||||
# Check the floating-point operators individually, along with
|
||||
# automatic conversion to integers where needed.
|
||||
|
||||
test expr-2.1 {floating-point operators} {expr -4.2} -4.2
|
||||
test expr-2.2 {floating-point operators} {expr -(1.1+4.2)} -5.3
|
||||
test expr-2.3 {floating-point operators} {expr !2.1} 0
|
||||
test expr-2.4 {floating-point operators} {expr !0.0} 1
|
||||
test expr-2.5 {floating-point operators} {expr 4.2*6.3} 26.46
|
||||
test expr-2.6 {floating-point operators} {expr 36.0/12.0} 3.0
|
||||
test expr-2.7 {floating-point operators} {expr 27/4.0} 6.75
|
||||
test expr-2.8 {floating-point operators} {expr 2.3+2.1} 4.4
|
||||
test expr-2.9 {floating-point operators} {expr 2.3-6.5} -4.2
|
||||
test expr-2.10 {floating-point operators} {expr 3.1>2.1} 1
|
||||
test expr-2.11 {floating-point operators} {expr {2.1 > 2.1}} 0
|
||||
test expr-2.12 {floating-point operators} {expr 1.23>2.34e+1} 0
|
||||
test expr-2.13 {floating-point operators} {expr 3.45<2.34} 0
|
||||
test expr-2.14 {floating-point operators} {expr 0.002e3<--200e-2} 0
|
||||
test expr-2.15 {floating-point operators} {expr 1.1<2.1} 1
|
||||
test expr-2.16 {floating-point operators} {expr 3.1>=2.2} 1
|
||||
test expr-2.17 {floating-point operators} {expr 2.345>=2.345} 1
|
||||
test expr-2.18 {floating-point operators} {expr 1.1>=2.2} 0
|
||||
test expr-2.19 {floating-point operators} {expr 3.0<=2.0} 0
|
||||
test expr-2.20 {floating-point operators} {expr 2.2<=2.2} 1
|
||||
test expr-2.21 {floating-point operators} {expr 2.2<=2.2001} 1
|
||||
test expr-2.22 {floating-point operators} {expr 3.2==2.2} 0
|
||||
test expr-2.23 {floating-point operators} {expr 2.2==2.2} 1
|
||||
test expr-2.24 {floating-point operators} {expr 3.2!=2.2} 1
|
||||
test expr-2.25 {floating-point operators} {expr 2.2!=2.2} 0
|
||||
test expr-2.26 {floating-point operators} {expr 0.0&&0.0} 0
|
||||
test expr-2.27 {floating-point operators} {expr 0.0&&1.3} 0
|
||||
test expr-2.28 {floating-point operators} {expr 1.3&&0.0} 0
|
||||
test expr-2.29 {floating-point operators} {expr 1.3&&3.3} 1
|
||||
test expr-2.30 {floating-point operators} {expr 0.0||0.0} 0
|
||||
test expr-2.31 {floating-point operators} {expr 0.0||1.3} 1
|
||||
test expr-2.32 {floating-point operators} {expr 1.3||0.0} 1
|
||||
test expr-2.33 {floating-point operators} {expr 3.3||0.0} 1
|
||||
test expr-2.34 {floating-point operators} {expr 3.3>2.3?44.3:66.3} 44.3
|
||||
test expr-2.35 {floating-point operators} {expr 2.3>3.3?44.3:66.3} 66.3
|
||||
test expr-2.36 {floating-point operators} {
|
||||
list [catch {expr 028.1 + 09.2} msg] $msg
|
||||
} {0 37.3}
|
||||
|
||||
# Operators that aren't legal on floating-point numbers
|
||||
|
||||
test expr-3.1 {illegal floating-point operations} {
|
||||
list [catch {expr ~4.0} msg] $msg
|
||||
} {1 {can't use floating-point value as operand of "~"}}
|
||||
test expr-3.2 {illegal floating-point operations} {
|
||||
list [catch {expr 27%4.0} msg] $msg
|
||||
} {1 {can't use floating-point value as operand of "%"}}
|
||||
test expr-3.3 {illegal floating-point operations} {
|
||||
list [catch {expr 27.0%4} msg] $msg
|
||||
} {1 {can't use floating-point value as operand of "%"}}
|
||||
test expr-3.4 {illegal floating-point operations} {
|
||||
list [catch {expr 1.0<<3} msg] $msg
|
||||
} {1 {can't use floating-point value as operand of "<<"}}
|
||||
test expr-3.5 {illegal floating-point operations} {
|
||||
list [catch {expr 3<<1.0} msg] $msg
|
||||
} {1 {can't use floating-point value as operand of "<<"}}
|
||||
test expr-3.6 {illegal floating-point operations} {
|
||||
list [catch {expr 24.0>>3} msg] $msg
|
||||
} {1 {can't use floating-point value as operand of ">>"}}
|
||||
test expr-3.7 {illegal floating-point operations} {
|
||||
list [catch {expr 24>>3.0} msg] $msg
|
||||
} {1 {can't use floating-point value as operand of ">>"}}
|
||||
test expr-3.8 {illegal floating-point operations} {
|
||||
list [catch {expr 24&3.0} msg] $msg
|
||||
} {1 {can't use floating-point value as operand of "&"}}
|
||||
test expr-3.9 {illegal floating-point operations} {
|
||||
list [catch {expr 24.0|3} msg] $msg
|
||||
} {1 {can't use floating-point value as operand of "|"}}
|
||||
test expr-3.10 {illegal floating-point operations} {
|
||||
list [catch {expr 24.0^3} msg] $msg
|
||||
} {1 {can't use floating-point value as operand of "^"}}
|
||||
|
||||
# Check the string operators individually.
|
||||
|
||||
test expr-4.1 {string operators} {expr {"abc" > "def"}} 0
|
||||
test expr-4.2 {string operators} {expr {"def" > "def"}} 0
|
||||
test expr-4.3 {string operators} {expr {"g" > "def"}} 1
|
||||
test expr-4.4 {string operators} {expr {"abc" < "abd"}} 1
|
||||
test expr-4.5 {string operators} {expr {"abd" < "abd"}} 0
|
||||
test expr-4.6 {string operators} {expr {"abe" < "abd"}} 0
|
||||
test expr-4.7 {string operators} {expr {"abc" >= "def"}} 0
|
||||
test expr-4.8 {string operators} {expr {"def" >= "def"}} 1
|
||||
test expr-4.9 {string operators} {expr {"g" >= "def"}} 1
|
||||
test expr-4.10 {string operators} {expr {"abc" <= "abd"}} 1
|
||||
test expr-4.11 {string operators} {expr {"abd" <= "abd"}} 1
|
||||
test expr-4.12 {string operators} {expr {"abe" <= "abd"}} 0
|
||||
test expr-4.13 {string operators} {expr {"abc" == "abd"}} 0
|
||||
test expr-4.14 {string operators} {expr {"abd" == "abd"}} 1
|
||||
test expr-4.15 {string operators} {expr {"abc" != "abd"}} 1
|
||||
test expr-4.16 {string operators} {expr {"abd" != "abd"}} 0
|
||||
test expr-4.17 {string operators} {expr {"0y" < "0x12"}} 1
|
||||
test expr-4.18 {string operators} {expr {"." < " "}} 0
|
||||
test expr-4.19 {string operators} {expr {"0" == "+"}} 0
|
||||
test expr-4.20 {string operators} {expr {"0" == "-"}} 0
|
||||
test expr-4.21 {string operators} {expr {1?"foo":"bar"}} foo
|
||||
test expr-4.22 {string operators} {expr {0?"foo":"bar"}} bar
|
||||
|
||||
# Operators that aren't legal on string operands.
|
||||
|
||||
test expr-5.1 {illegal string operations} {
|
||||
list [catch {expr {-"a"}} msg] $msg
|
||||
} {1 {can't use non-numeric string as operand of "-"}}
|
||||
test expr-5.2 {illegal string operations} {
|
||||
list [catch {expr {~"a"}} msg] $msg
|
||||
} {1 {can't use non-numeric string as operand of "~"}}
|
||||
test expr-5.3 {illegal string operations} {
|
||||
list [catch {expr {!"a"}} msg] $msg
|
||||
} {1 {can't use non-numeric string as operand of "!"}}
|
||||
test expr-5.4 {illegal string operations} {
|
||||
list [catch {expr {"a"*"b"}} msg] $msg
|
||||
} {1 {can't use non-numeric string as operand of "*"}}
|
||||
test expr-5.5 {illegal string operations} {
|
||||
list [catch {expr {"a"/"b"}} msg] $msg
|
||||
} {1 {can't use non-numeric string as operand of "/"}}
|
||||
test expr-5.6 {illegal string operations} {
|
||||
list [catch {expr {"a"%"b"}} msg] $msg
|
||||
} {1 {can't use non-numeric string as operand of "%"}}
|
||||
test expr-5.7 {illegal string operations} {
|
||||
list [catch {expr {"a"+"b"}} msg] $msg
|
||||
} {1 {can't use non-numeric string as operand of "+"}}
|
||||
test expr-5.8 {illegal string operations} {
|
||||
list [catch {expr {"a"-"b"}} msg] $msg
|
||||
} {1 {can't use non-numeric string as operand of "-"}}
|
||||
test expr-5.9 {illegal string operations} {
|
||||
list [catch {expr {"a"<<"b"}} msg] $msg
|
||||
} {1 {can't use non-numeric string as operand of "<<"}}
|
||||
test expr-5.10 {illegal string operations} {
|
||||
list [catch {expr {"a">>"b"}} msg] $msg
|
||||
} {1 {can't use non-numeric string as operand of ">>"}}
|
||||
test expr-5.11 {illegal string operations} {
|
||||
list [catch {expr {"a"&"b"}} msg] $msg
|
||||
} {1 {can't use non-numeric string as operand of "&"}}
|
||||
test expr-5.12 {illegal string operations} {
|
||||
list [catch {expr {"a"^"b"}} msg] $msg
|
||||
} {1 {can't use non-numeric string as operand of "^"}}
|
||||
test expr-5.13 {illegal string operations} {
|
||||
list [catch {expr {"a"|"b"}} msg] $msg
|
||||
} {1 {can't use non-numeric string as operand of "|"}}
|
||||
test expr-5.14 {illegal string operations} {
|
||||
list [catch {expr {"a"&&"b"}} msg] $msg
|
||||
} {1 {can't use non-numeric string as operand of "&&"}}
|
||||
test expr-5.15 {illegal string operations} {
|
||||
list [catch {expr {"a"||"b"}} msg] $msg
|
||||
} {1 {can't use non-numeric string as operand of "||"}}
|
||||
test expr-5.16 {illegal string operations} {
|
||||
list [catch {expr {"a"?4:2}} msg] $msg
|
||||
} {1 {can't use non-numeric string as operand of "?"}}
|
||||
|
||||
# Check precedence pairwise.
|
||||
|
||||
test expr-6.1 {precedence checks} {expr -~3} 4
|
||||
test expr-6.2 {precedence checks} {expr -!3} 0
|
||||
test expr-6.3 {precedence checks} {expr -~0} 1
|
||||
|
||||
test expr-7.1 {precedence checks} {expr 2*4/6} 1
|
||||
test expr-7.2 {precedence checks} {expr 24/6*3} 12
|
||||
test expr-7.3 {precedence checks} {expr 24/6/2} 2
|
||||
|
||||
test expr-8.1 {precedence checks} {expr -2+4} 2
|
||||
test expr-8.2 {precedence checks} {expr -2-4} -6
|
||||
|
||||
test expr-9.1 {precedence checks} {expr 2*3+4} 10
|
||||
test expr-9.2 {precedence checks} {expr 8/2+4} 8
|
||||
test expr-9.3 {precedence checks} {expr 8%3+4} 6
|
||||
test expr-9.4 {precedence checks} {expr 2*3-1} 5
|
||||
test expr-9.5 {precedence checks} {expr 8/2-1} 3
|
||||
test expr-9.6 {precedence checks} {expr 8%3-1} 1
|
||||
|
||||
test expr-10.1 {precedence checks} {expr 6-3-2} 1
|
||||
|
||||
test expr-11.1 {precedence checks} {expr 7+1>>2} 2
|
||||
test expr-11.2 {precedence checks} {expr 7+1<<2} 32
|
||||
test expr-11.3 {precedence checks} {expr 7>>3-2} 3
|
||||
test expr-11.4 {precedence checks} {expr 7<<3-2} 14
|
||||
|
||||
test expr-12.1 {precedence checks} {expr 6>>1>4} 0
|
||||
test expr-12.2 {precedence checks} {expr 6>>1<2} 0
|
||||
test expr-12.3 {precedence checks} {expr 6>>1>=3} 1
|
||||
test expr-12.4 {precedence checks} {expr 6>>1<=2} 0
|
||||
test expr-12.5 {precedence checks} {expr 6<<1>5} 1
|
||||
test expr-12.6 {precedence checks} {expr 6<<1<5} 0
|
||||
test expr-12.7 {precedence checks} {expr 5<=6<<1} 1
|
||||
test expr-12.8 {precedence checks} {expr 5>=6<<1} 0
|
||||
|
||||
test expr-13.1 {precedence checks} {expr 2<3<4} 1
|
||||
test expr-13.2 {precedence checks} {expr 0<4>2} 0
|
||||
test expr-13.3 {precedence checks} {expr 4>2<1} 0
|
||||
test expr-13.4 {precedence checks} {expr 4>3>2} 0
|
||||
test expr-13.5 {precedence checks} {expr 4>3>=2} 0
|
||||
test expr-13.6 {precedence checks} {expr 4>=3>2} 0
|
||||
test expr-13.7 {precedence checks} {expr 4>=3>=2} 0
|
||||
test expr-13.8 {precedence checks} {expr 0<=4>=2} 0
|
||||
test expr-13.9 {precedence checks} {expr 4>=2<=0} 0
|
||||
test expr-10.10 {precedence checks} {expr 2<=3<=4} 1
|
||||
|
||||
test expr-14.1 {precedence checks} {expr 1==4>3} 1
|
||||
test expr-14.2 {precedence checks} {expr 0!=4>3} 1
|
||||
test expr-14.3 {precedence checks} {expr 1==3<4} 1
|
||||
test expr-14.4 {precedence checks} {expr 0!=3<4} 1
|
||||
test expr-14.5 {precedence checks} {expr 1==4>=3} 1
|
||||
test expr-14.6 {precedence checks} {expr 0!=4>=3} 1
|
||||
test expr-14.7 {precedence checks} {expr 1==3<=4} 1
|
||||
test expr-14.8 {precedence checks} {expr 0!=3<=4} 1
|
||||
|
||||
test expr-15.1 {precedence checks} {expr 1==3==3} 0
|
||||
test expr-15.2 {precedence checks} {expr 3==3!=2} 1
|
||||
test expr-15.3 {precedence checks} {expr 2!=3==3} 0
|
||||
test expr-15.4 {precedence checks} {expr 2!=1!=1} 0
|
||||
|
||||
test expr-16.1 {precedence checks} {expr 2&3==2} 0
|
||||
test expr-16.2 {precedence checks} {expr 1&3!=3} 0
|
||||
|
||||
test expr-17.1 {precedence checks} {expr 7&3^0x10} 19
|
||||
test expr-17.2 {precedence checks} {expr 7^0x10&3} 7
|
||||
|
||||
test expr-18.1 {precedence checks} {expr 7^0x10|3} 23
|
||||
test expr-18.2 {precedence checks} {expr 7|0x10^3} 23
|
||||
|
||||
test expr-19.1 {precedence checks} {expr 7|3&&1} 1
|
||||
test expr-19.2 {precedence checks} {expr 1&&3|7} 1
|
||||
test expr-19.3 {precedence checks} {expr 0&&1||1} 1
|
||||
test expr-19.4 {precedence checks} {expr 1||1&&0} 1
|
||||
|
||||
test expr-20.1 {precedence checks} {expr 1||0?3:4} 3
|
||||
test expr-20.2 {precedence checks} {expr 1?0:4||1} 0
|
||||
|
||||
# Parentheses.
|
||||
|
||||
test expr-21.1 {parenthesization} {expr (2+4)*6} 36
|
||||
test expr-21.2 {parenthesization} {expr (1?0:4)||1} 1
|
||||
|
||||
# Embedded commands and variable names.
|
||||
|
||||
set a 16
|
||||
test expr-22.1 {embedded variables} {expr {2*$a}} 32
|
||||
test expr-22.2 {embedded variables} {
|
||||
set x -5
|
||||
set y 10
|
||||
expr {$x + $y}
|
||||
} {5}
|
||||
test expr-22.3 {embedded variables} {
|
||||
set x " -5"
|
||||
set y " +10"
|
||||
expr {$x + $y}
|
||||
} {5}
|
||||
test expr-22.4 {embedded commands and variables} {expr {[set a] - 14}} 2
|
||||
test expr-22.5 {embedded commands and variables} {
|
||||
list [catch {expr {12 - [bad_command_name]}} msg] $msg
|
||||
} {1 {invalid command name: "bad_command_name"}}
|
||||
|
||||
# Double-quotes and things inside them.
|
||||
|
||||
test expr-23.1 {double-quotes} {expr {"abc"}} abc
|
||||
test expr-23.2 {double-quotes} {
|
||||
set a 189
|
||||
expr {"$a.bc"}
|
||||
} 189.bc
|
||||
test expr-23.3 {double-quotes} {
|
||||
set b2 xyx
|
||||
expr {"$b2$b2$b2.[set b2].[set b2]"}
|
||||
} xyxxyxxyx.xyx.xyx
|
||||
test expr-23.4 {double-quotes} {expr {"11\}\}22"}} 11}}22
|
||||
test expr-23.5 {double-quotes} {expr {"\*bc"}} {*bc}
|
||||
test expr-23.6 {double-quotes} {
|
||||
catch {unset bogus__}
|
||||
list [catch {expr {"$bogus__"}} msg] $msg
|
||||
} {1 {can't read "bogus__": no such variable}}
|
||||
test expr-23.7 {double-quotes} {
|
||||
list [catch {expr {"a[error Testing]bc"}} msg] $msg
|
||||
} {1 Testing}
|
||||
|
||||
# Numbers in various bases.
|
||||
|
||||
test expr-24.1 {numbers in different bases} {expr 0x20} 32
|
||||
test expr-24.2 {numbers in different bases} {expr 015} 13
|
||||
|
||||
# Conversions between various data types.
|
||||
|
||||
test expr-25.1 {type conversions} {expr 2+2.5} 4.5
|
||||
test expr-25.2 {type conversions} {expr 2.5+2} 4.5
|
||||
test expr-25.3 {type conversions} {expr 2-2.5} -0.5
|
||||
test expr-25.4 {type conversions} {expr 2/2.5} 0.8
|
||||
test expr-25.5 {type conversions} {expr 2>2.5} 0
|
||||
test expr-25.6 {type conversions} {expr 2.5>2} 1
|
||||
test expr-25.7 {type conversions} {expr 2<2.5} 1
|
||||
test expr-25.8 {type conversions} {expr 2>=2.5} 0
|
||||
test expr-25.9 {type conversions} {expr 2<=2.5} 1
|
||||
test expr-25.10 {type conversions} {expr 2==2.5} 0
|
||||
test expr-25.11 {type conversions} {expr 2!=2.5} 1
|
||||
test expr-25.12 {type conversions} {expr 2>"ab"} 0
|
||||
test expr-25.13 {type conversions} {expr {2>" "}} 1
|
||||
test expr-25.14 {type conversions} {expr {"24.1a" > 24.1}} 1
|
||||
test expr-25.15 {type conversions} {expr {24.1 > "24.1a"}} 0
|
||||
test expr-25.16 {type conversions} {expr 2+2.5} 4.5
|
||||
test expr-25.17 {type conversions} {expr 2+2.5} 4.5
|
||||
test expr-25.18 {type conversions} {expr 2.0e2} 200.0
|
||||
test expr-25.19 {type conversions} {expr 2.0e15} 2e+15
|
||||
test expr-25.20 {type conversions} {expr 10.0} 10.0
|
||||
|
||||
# Various error conditions.
|
||||
|
||||
test expr-26.1 {error conditions} {
|
||||
list [catch {expr 2+"a"} msg] $msg
|
||||
} {1 {can't use non-numeric string as operand of "+"}}
|
||||
test expr-26.2 {error conditions} {
|
||||
list [catch {expr 2+4*} msg] $msg
|
||||
} {1 {syntax error in expression "2+4*"}}
|
||||
test expr-26.3 {error conditions} {
|
||||
list [catch {expr 2+4*(} msg] $msg
|
||||
} {1 {syntax error in expression "2+4*("}}
|
||||
catch {unset _non_existent_}
|
||||
test expr-26.4 {error conditions} {
|
||||
list [catch {expr 2+$_non_existent_} msg] $msg
|
||||
} {1 {can't read "_non_existent_": no such variable}}
|
||||
set a xx
|
||||
test expr-26.5 {error conditions} {
|
||||
list [catch {expr {2+$a}} msg] $msg
|
||||
} {1 {can't use non-numeric string as operand of "+"}}
|
||||
test expr-26.6 {error conditions} {
|
||||
list [catch {expr {2+[set a]}} msg] $msg
|
||||
} {1 {can't use non-numeric string as operand of "+"}}
|
||||
test expr-26.7 {error conditions} {
|
||||
list [catch {expr {2+(4}} msg] $msg
|
||||
} {1 {unmatched parentheses in expression "2+(4"}}
|
||||
test expr-26.8 {error conditions} {
|
||||
list [catch {expr 2/0} msg] $msg $errorCode
|
||||
} {1 {divide by zero} {ARITH DIVZERO {divide by zero}}}
|
||||
test expr-26.9 {error conditions} {
|
||||
list [catch {expr 2%0} msg] $msg $errorCode
|
||||
} {1 {divide by zero} {ARITH DIVZERO {divide by zero}}}
|
||||
test expr-26.10 {error conditions} {
|
||||
list [catch {expr 2.0/0.0} msg] $msg $errorCode
|
||||
} {1 {divide by zero} {ARITH DIVZERO {divide by zero}}}
|
||||
test expr-26.11 {error conditions} {
|
||||
list [catch {expr 2#} msg] $msg
|
||||
} {1 {syntax error in expression "2#"}}
|
||||
test expr-26.12 {error conditions} {
|
||||
list [catch {expr a.b} msg] $msg
|
||||
} {1 {syntax error in expression "a.b"}}
|
||||
test expr-26.13 {error conditions} {
|
||||
list [catch {expr {"a"/"b"}} msg] $msg
|
||||
} {1 {can't use non-numeric string as operand of "/"}}
|
||||
test expr-26.14 {error conditions} {
|
||||
list [catch {expr 2:3} msg] $msg
|
||||
} {1 {can't have : operator without ? first}}
|
||||
test expr-26.15 {error conditions} {
|
||||
list [catch {expr a@b} msg] $msg
|
||||
} {1 {syntax error in expression "a@b"}}
|
||||
test expr-26.16 {error conditions} {
|
||||
list [catch {expr a[b} msg] $msg
|
||||
} {1 {missing close-bracket}}
|
||||
test expr-26.17 {error conditions} {
|
||||
list [catch {expr a`b} msg] $msg
|
||||
} {1 {syntax error in expression "a`b"}}
|
||||
test expr-26.18 {error conditions} {
|
||||
list [catch {expr \"a\"\{b} msg] $msg
|
||||
} {1 {missing close-brace}}
|
||||
test expr-26.19 {error conditions} {
|
||||
list [catch {expr a} msg] $msg
|
||||
} {1 {syntax error in expression "a"}}
|
||||
test expr-26.20 {error conditions} {
|
||||
list [catch expr msg] $msg
|
||||
} {1 {wrong # args: should be "expr arg ?arg ...?"}}
|
||||
|
||||
# Cancelled evaluation.
|
||||
|
||||
test expr-27.1 {cancelled evaluation} {
|
||||
set a 1
|
||||
expr {0&&[set a 2]}
|
||||
set a
|
||||
} 1
|
||||
test expr-27.2 {cancelled evaluation} {
|
||||
set a 1
|
||||
expr {1||[set a 2]}
|
||||
set a
|
||||
} 1
|
||||
test expr-27.3 {cancelled evaluation} {
|
||||
set a 1
|
||||
expr {0?[set a 2]:1}
|
||||
set a
|
||||
} 1
|
||||
test expr-27.4 {cancelled evaluation} {
|
||||
set a 1
|
||||
expr {1?2:[set a 2]}
|
||||
set a
|
||||
} 1
|
||||
catch {unset x}
|
||||
test expr-27.5 {cancelled evaluation} {
|
||||
list [catch {expr {[info exists x] && $x}} msg] $msg
|
||||
} {0 0}
|
||||
test expr-27.6 {cancelled evaluation} {
|
||||
list [catch {expr {0 && [concat $x]}} msg] $msg
|
||||
} {0 0}
|
||||
|
||||
# Tcl_ExprBool as used in "if" statements
|
||||
|
||||
test expr-28.1 {Tcl_ExprBoolean usage} {
|
||||
set a 1
|
||||
if {2} {set a 2}
|
||||
set a
|
||||
} 2
|
||||
test expr-28.2 {Tcl_ExprBoolean usage} {
|
||||
set a 1
|
||||
if {0} {set a 2}
|
||||
set a
|
||||
} 1
|
||||
test expr-28.3 {Tcl_ExprBoolean usage} {
|
||||
set a 1
|
||||
if {1.2} {set a 2}
|
||||
set a
|
||||
} 2
|
||||
test expr-28.4 {Tcl_ExprBoolean usage} {
|
||||
set a 1
|
||||
if {-1.1} {set a 2}
|
||||
set a
|
||||
} 2
|
||||
test expr-28.5 {Tcl_ExprBoolean usage} {
|
||||
set a 1
|
||||
if {0.0} {set a 2}
|
||||
set a
|
||||
} 1
|
||||
test expr-28.6 {Tcl_ExprBoolean usage} {
|
||||
set a 1
|
||||
if {"YES"} {set a 2}
|
||||
set a
|
||||
} 2
|
||||
test expr-28.7 {Tcl_ExprBoolean usage} {
|
||||
set a 1
|
||||
if {"no"} {set a 2}
|
||||
set a
|
||||
} 1
|
||||
test expr-28.8 {Tcl_ExprBoolean usage} {
|
||||
set a 1
|
||||
if {"true"} {set a 2}
|
||||
set a
|
||||
} 2
|
||||
test expr-28.9 {Tcl_ExprBoolean usage} {
|
||||
set a 1
|
||||
if {"fAlse"} {set a 2}
|
||||
set a
|
||||
} 1
|
||||
test expr-28.10 {Tcl_ExprBoolean usage} {
|
||||
set a 1
|
||||
if {"on"} {set a 2}
|
||||
set a
|
||||
} 2
|
||||
test expr-28.11 {Tcl_ExprBoolean usage} {
|
||||
set a 1
|
||||
if {"Off"} {set a 2}
|
||||
set a
|
||||
} 1
|
||||
test expr-28.12 {Tcl_ExprBool usage} {
|
||||
list [catch {if {"abc"} {}} msg] $msg
|
||||
} {1 {expected boolean value but got "abc"}}
|
||||
|
||||
# Operands enclosed in braces
|
||||
|
||||
test expr-29.1 {braces} {expr {{abc}}} abc
|
||||
test expr-29.2 {braces} {expr {{00010}}} 8
|
||||
test expr-29.3 {braces} {expr {{3.1200000}}} 3.12
|
||||
test expr-29.4 {braces} {expr {{a{b}{1 {2 3}}c}}} "a{b}{1 {2 3}}c"
|
||||
test expr-29.5 {braces} {
|
||||
list [catch {expr "\{abc"} msg] $msg
|
||||
} {1 {missing close-brace}}
|
||||
|
||||
# Very long values
|
||||
|
||||
test expr-30.1 {long values} {
|
||||
set a "0000 1111 2222 3333 4444"
|
||||
set a "$a | $a | $a | $a | $a"
|
||||
set a "$a || $a || $a || $a || $a"
|
||||
expr {$a}
|
||||
} {0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 || 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 || 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 || 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 || 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444}
|
||||
test expr-30.2 {long values} {
|
||||
set a "000000000000000000000000000000"
|
||||
set a "$a$a$a$a$a$a$a$a$a$a$a$a$a$a$a$a${a}5"
|
||||
expr $a
|
||||
} 5
|
||||
|
||||
# Expressions spanning multiple arguments
|
||||
|
||||
test expr-31.1 {multiple arguments to expr command} {
|
||||
expr 4 + ( 6 *12) -3
|
||||
} 73
|
||||
test expr-31.2 {multiple arguments to expr command} {
|
||||
list [catch {expr 2 + (3 + 4} msg] $msg
|
||||
} {1 {unmatched parentheses in expression "2 + (3 + 4"}}
|
||||
test expr-31.3 {multiple arguments to expr command} {
|
||||
list [catch {expr 2 + 3 +} msg] $msg
|
||||
} {1 {syntax error in expression "2 + 3 +"}}
|
||||
test expr-31.4 {multiple arguments to expr command} {
|
||||
list [catch {expr 2 + 3 )} msg] $msg
|
||||
} {1 {syntax error in expression "2 + 3 )"}}
|
||||
|
||||
# Math functions
|
||||
|
||||
test expr-32.1 {math functions in expressions} {
|
||||
expr acos(0.5)
|
||||
} {1.0472}
|
||||
test expr-32.2 {math functions in expressions} {
|
||||
expr asin(0.5)
|
||||
} {0.523599}
|
||||
test expr-32.3 {math functions in expressions} {
|
||||
expr atan(1.0)
|
||||
} {0.785398}
|
||||
test expr-32.4 {math functions in expressions} {
|
||||
expr atan2(2.0, 2.0)
|
||||
} {0.785398}
|
||||
test expr-32.5 {math functions in expressions} {
|
||||
expr ceil(1.999)
|
||||
} {2.0}
|
||||
test expr-32.6 {math functions in expressions} {
|
||||
expr cos(.1)
|
||||
} {0.995004}
|
||||
test expr-32.7 {math functions in expressions} {
|
||||
expr cosh(.1)
|
||||
} {1.005}
|
||||
test expr-32.8 {math functions in expressions} {
|
||||
expr exp(1.0)
|
||||
} {2.71828}
|
||||
test expr-32.9 {math functions in expressions} {
|
||||
expr floor(2.000)
|
||||
} {2.0}
|
||||
test expr-32.10 {math functions in expressions} {
|
||||
expr floor(2.001)
|
||||
} {2.0}
|
||||
test expr-32.11 {math functions in expressions} {
|
||||
expr fmod(7.3, 3.2)
|
||||
} {0.9}
|
||||
test expr-32.12 {math functions in expressions} {
|
||||
expr hypot(3.0, 4.0)
|
||||
} {5.0}
|
||||
test expr-32.13 {math functions in expressions} {
|
||||
expr log(2.8)
|
||||
} {1.02962}
|
||||
test expr-32.14 {math functions in expressions} {
|
||||
expr log10(2.8)
|
||||
} {0.447158}
|
||||
test expr-32.15 {math functions in expressions} {
|
||||
expr pow(2.1, 3.1)
|
||||
} {9.97424}
|
||||
test expr-32.16 {math functions in expressions} {
|
||||
expr sin(.1)
|
||||
} {0.0998334}
|
||||
test expr-32.17 {math functions in expressions} {
|
||||
expr sinh(.1)
|
||||
} {0.100167}
|
||||
test expr-32.18 {math functions in expressions} {
|
||||
expr sqrt(2.0)
|
||||
} {1.41421}
|
||||
test expr-32.19 {math functions in expressions} {
|
||||
expr tan(0.8)
|
||||
} {1.02964}
|
||||
test expr-32.20 {math functions in expressions} {
|
||||
expr tanh(0.8)
|
||||
} {0.664037}
|
||||
test expr-32.21 {math functions in expressions} {
|
||||
expr abs(-1.8)
|
||||
} {1.8}
|
||||
test expr-32.22 {math functions in expressions} {
|
||||
expr abs(10.0)
|
||||
} {10.0}
|
||||
test expr-32.23 {math functions in expressions} {
|
||||
expr abs(-4)
|
||||
} {4}
|
||||
test expr-32.24 {math functions in expressions} {
|
||||
expr abs(66)
|
||||
} {66}
|
||||
if ($atBerkeley) {
|
||||
test expr-32.25 {math functions in expressions} {
|
||||
list [catch {expr abs(0x80000000)} msg] $msg
|
||||
} {1 {integer value too large to represent}}
|
||||
}
|
||||
test expr-32.26 {math functions in expressions} {
|
||||
expr double(1)
|
||||
} {1.0}
|
||||
test expr-32.27 {math functions in expressions} {
|
||||
expr double(1.1)
|
||||
} {1.1}
|
||||
test expr-32.28 {math functions in expressions} {
|
||||
expr int(1)
|
||||
} {1}
|
||||
test expr-32.29 {math functions in expressions} {
|
||||
expr int(1.4)
|
||||
} {1}
|
||||
test expr-32.30 {math functions in expressions} {
|
||||
expr int(1.6)
|
||||
} {1}
|
||||
test expr-32.31 {math functions in expressions} {
|
||||
expr int(-1.4)
|
||||
} {-1}
|
||||
test expr-32.32 {math functions in expressions} {
|
||||
expr int(-1.6)
|
||||
} {-1}
|
||||
test expr-32.33 {math functions in expressions} {
|
||||
list [catch {expr int(1e60)} msg] $msg
|
||||
} {1 {integer value too large to represent}}
|
||||
test expr-32.34 {math functions in expressions} {
|
||||
list [catch {expr int(-1e60)} msg] $msg
|
||||
} {1 {integer value too large to represent}}
|
||||
test expr-32.35 {math functions in expressions} {
|
||||
expr round(1.49)
|
||||
} {1}
|
||||
test expr-32.36 {math functions in expressions} {
|
||||
expr round(1.51)
|
||||
} {2}
|
||||
test expr-32.37 {math functions in expressions} {
|
||||
expr round(-1.49)
|
||||
} {-1}
|
||||
test expr-32.38 {math functions in expressions} {
|
||||
expr round(-1.51)
|
||||
} {-2}
|
||||
test expr-32.39 {math functions in expressions} {
|
||||
list [catch {expr round(1e60)} msg] $msg
|
||||
} {1 {integer value too large to represent}}
|
||||
test expr-32.40 {math functions in expressions} {
|
||||
list [catch {expr round(-1e60)} msg] $msg
|
||||
} {1 {integer value too large to represent}}
|
||||
test expr-32.41 {math functions in expressions} {
|
||||
list [catch {expr pow(1.0 + 3.0 - 2, .8 * 5)} msg] $msg
|
||||
} {0 16.0}
|
||||
test expr-32.42 {math functions in expressions} {
|
||||
list [catch {expr hypot(5*.8,3)} msg] $msg
|
||||
} {0 5.0}
|
||||
if $gotT1 {
|
||||
test expr-32.43 {math functions in expressions} {
|
||||
expr 2*T1()
|
||||
} 246
|
||||
test expr-32.44 {math functions in expressions} {
|
||||
expr T2()*3
|
||||
} 1035
|
||||
}
|
||||
|
||||
test expr-33.1 {conversions and fancy args to math functions} {
|
||||
expr hypot ( 3 , 4 )
|
||||
} 5.0
|
||||
test expr-33.2 {conversions and fancy args to math functions} {
|
||||
expr hypot ( (2.0+1.0) , 4 )
|
||||
} 5.0
|
||||
test expr-33.3 {conversions and fancy args to math functions} {
|
||||
expr hypot ( 3 , (3.0 + 1.0) )
|
||||
} 5.0
|
||||
test expr-33.4 {conversions and fancy args to math functions} {
|
||||
expr cos(acos(0.1))
|
||||
} 0.1
|
||||
|
||||
test expr-34.1 {errors in math functions} {
|
||||
list [catch {expr func_2(1.0)} msg] $msg
|
||||
} {1 {unknown math function "func_2"}}
|
||||
test expr-34.2 {errors in math functions} {
|
||||
list [catch {expr func|(1.0)} msg] $msg
|
||||
} {1 {syntax error in expression "func|(1.0)"}}
|
||||
test expr-34.3 {errors in math functions} {
|
||||
list [catch {expr {hypot("a b", 2.0)}} msg] $msg
|
||||
} {1 {argument to math function didn't have numeric value}}
|
||||
test expr-34.4 {errors in math functions} {
|
||||
list [catch {expr hypot(1.0 2.0)} msg] $msg
|
||||
} {1 {syntax error in expression "hypot(1.0 2.0)"}}
|
||||
test expr-34.5 {errors in math functions} {
|
||||
list [catch {expr hypot(1.0, 2.0} msg] $msg
|
||||
} {1 {syntax error in expression "hypot(1.0, 2.0"}}
|
||||
test expr-34.6 {errors in math functions} {
|
||||
list [catch {expr hypot(1.0 ,} msg] $msg
|
||||
} {1 {syntax error in expression "hypot(1.0 ,"}}
|
||||
test expr-34.7 {errors in math functions} {
|
||||
list [catch {expr hypot(1.0)} msg] $msg
|
||||
} {1 {too few arguments for math function}}
|
||||
test expr-34.8 {errors in math functions} {
|
||||
list [catch {expr hypot(1.0, 2.0, 3.0)} msg] $msg
|
||||
} {1 {too many arguments for math function}}
|
||||
test expr-34.9 {errors in math functions} {
|
||||
list [catch {expr acos(-2.0)} msg] $msg $errorCode
|
||||
} {1 {domain error: argument not in valid range} {ARITH DOMAIN {domain error: argument not in valid range}}}
|
||||
if $atBerkeley {
|
||||
test expr-34.10 {errors in math functions} {
|
||||
list [catch {expr pow(-3, 1000001)} msg] $msg $errorCode
|
||||
} {1 {floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}}
|
||||
}
|
||||
test expr-34.11 {errors in math functions} {
|
||||
list [catch {expr pow(3, 1000001)} msg] $msg $errorCode
|
||||
} {1 {floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}}
|
||||
test expr-34.12 {errors in math functions} {
|
||||
list [catch {expr -14.0*exp(100000)} msg] $msg $errorCode
|
||||
} {1 {floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}}
|
||||
test expr-34.13 {errors in math functions} {
|
||||
list [catch {expr int(1.0e30)} msg] $msg $errorCode
|
||||
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
|
||||
test expr-34.14 {errors in math functions} {
|
||||
list [catch {expr int(-1.0e30)} msg] $msg $errorCode
|
||||
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
|
||||
test expr-34.15 {errors in math functions} {
|
||||
list [catch {expr round(1.0e30)} msg] $msg $errorCode
|
||||
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
|
||||
test expr-34.16 {errors in math functions} {
|
||||
list [catch {expr round(-1.0e30)} msg] $msg $errorCode
|
||||
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
|
||||
if $gotT1 {
|
||||
test expr-34.17 {errors in math functions} {
|
||||
list [catch {expr T1(4)} msg] $msg
|
||||
} {1 {syntax error in expression "T1(4)"}}
|
||||
}
|
||||
|
||||
catch {unset tcl_precision}
|
||||
test expr-35.1 {tcl_precision variable} {
|
||||
expr 2.0/3
|
||||
} 0.666667
|
||||
set tcl_precision 1
|
||||
test expr-35.2 {tcl_precision variable} {
|
||||
expr 2.0/3
|
||||
} 0.7
|
||||
test expr-35.3 {tcl_precision variable} {
|
||||
expr 2.0/3
|
||||
} 0.7
|
||||
test expr-35.4 {tcl_precision variable} {
|
||||
list [catch {set tcl_precision 0} msg] $msg [expr 2.0/3]
|
||||
} {1 {can't set "tcl_precision": improper value for precision} 0.7}
|
||||
test expr-35.5 {tcl_precision variable} {
|
||||
list [catch {set tcl_precision 101} msg] $msg [expr 2.0/3]
|
||||
} {1 {can't set "tcl_precision": improper value for precision} 0.7}
|
||||
test expr-35.6 {tcl_precision variable} {
|
||||
list [catch {set tcl_precision {}} msg] $msg [expr 2.0/3]
|
||||
} {1 {can't set "tcl_precision": improper value for precision} 0.7}
|
||||
test expr-35.7 {tcl_precision variable} {
|
||||
list [catch {set tcl_precision {1 2 3}} msg] $msg [expr 2.0/3]
|
||||
} {1 {can't set "tcl_precision": improper value for precision} 0.7}
|
||||
catch {unset tcl_precision}
|
||||
test expr-35.8 {tcl_precision variable} {
|
||||
expr 2.0/3
|
||||
} 0.666667
|
||||
326
tcl7.3/tests/file.test
Normal file
326
tcl7.3/tests/file.test
Normal file
@@ -0,0 +1,326 @@
|
||||
# Commands covered: 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.
|
||||
#
|
||||
# Copyright (c) 1991-1993 The Regents of the University of California.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/file.test,v 1.22 93/04/16 16:46:42 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
# rootname and ext
|
||||
|
||||
test file-1.1 {rootname and extension options} {file ext abc.def} .def
|
||||
test file-1.2 {rootname and extension options} {file ro abc.def} abc
|
||||
test file-1.3 {rootname and extension options} {file extension a/b/c.d} .d
|
||||
test file-1.4 {rootname and extension options} {file rootname a/b/c.d} a/b/c
|
||||
test file-1.5 {rootname and extension options} {file extension a/b.c/d} {}
|
||||
test file-1.6 {rootname and extension options} {file rootname a/b.c/d} a/b.c/d
|
||||
set num 7
|
||||
foreach outer { {} a .a a. a.a } {
|
||||
foreach inner { {} a .a a. a.a } {
|
||||
set thing [format %s/%s $outer $inner]
|
||||
test file-1.$num {rootname and extension options} {
|
||||
format %s%s [file rootname $thing] [file ext $thing]
|
||||
} $thing
|
||||
set num [expr $num+1]
|
||||
}
|
||||
}
|
||||
|
||||
# dirname and tail
|
||||
|
||||
test file-2.1 {dirname and tail options} {file dirname .def} .
|
||||
test file-2.2 {dirname and tail options} {file tail abc.def} abc.def
|
||||
test file-2.3 {dirname and tail options} {file d a/b/c.d} a/b
|
||||
test file-2.4 {dirname and tail options} {file ta a/b/c.d} c.d
|
||||
test file-2.5 {dirname and tail options} {file dirname a/b.c/d} a/b.c
|
||||
test file-2.6 {dirname and tail options} {file tail a/b.c/d} d
|
||||
set num 7
|
||||
foreach outer { a .a a. a.a } {
|
||||
foreach inner { {} a .a a. a.a } {
|
||||
set thing [format %s/%s $outer $inner]
|
||||
test file-2.$num {dirname and tail options} {
|
||||
format %s/%s [file dirname $thing] [file tail $thing]
|
||||
} $thing
|
||||
set num [expr $num+1]
|
||||
}
|
||||
}
|
||||
|
||||
# exists
|
||||
|
||||
catch {exec chmod 777 dir.file}
|
||||
catch {exec rm -f dir.file/gorp.file}
|
||||
catch {exec rm -f gorp.file}
|
||||
catch {exec rmdir dir.file}
|
||||
catch {exec rm -f link.file}
|
||||
test file-3.1 {exists option} {file exists gorp.file} 0
|
||||
test file-3.2 {exists option} {file exists dir.file/gorp.file} 0
|
||||
exec cat > gorp.file << abcde
|
||||
exec mkdir dir.file
|
||||
exec cat > dir.file/gorp.file << 12345
|
||||
test file-3.3 {exists option} {file exists gorp.file} 1
|
||||
test file-3.4 {exists option} {file exi dir.file/gorp.file} 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.
|
||||
|
||||
catch {exec rm /tmp/tcl.foo.dir/file}
|
||||
catch {exec rmdir /tmp/tcl.foo.dir}
|
||||
exec mkdir /tmp/tcl.foo.dir
|
||||
exec cat > /tmp/tcl.foo.dir/file << 12345
|
||||
exec chmod 000 /tmp/tcl.foo.dir
|
||||
if {$user != "root"} {
|
||||
test file-3.5 {exists option} {file exists /tmp/tcl.foo.dir/file} 0
|
||||
}
|
||||
exec chmod 775 /tmp/tcl.foo.dir
|
||||
exec rm /tmp/tcl.foo.dir/file
|
||||
exec rmdir /tmp/tcl.foo.dir
|
||||
|
||||
# executable
|
||||
|
||||
exec chmod 000 dir.file
|
||||
if {$user != "root"} {
|
||||
test file-4.1 {executable option} {file executable gorp.file} 0
|
||||
}
|
||||
exec chmod 775 gorp.file
|
||||
test file-4.2 {executable option} {file exe gorp.file} 1
|
||||
|
||||
# isdirectory
|
||||
|
||||
test file-5.1 {isdirectory option} {file isdirectory gorp.file} 0
|
||||
test file-5.2 {isdirectory option} {file isd dir.file} 1
|
||||
|
||||
# isfile
|
||||
|
||||
test file-6.1 {isfile option} {file isfile gorp.file} 1
|
||||
test file-6.2 {isfile option} {file isfile dir.file} 0
|
||||
|
||||
# isowned
|
||||
|
||||
test file-7.1 {owned option} {file owned gorp.file} 1
|
||||
if {$user != "root"} {
|
||||
test file-7.2 {owned option} {file owned /} 0
|
||||
}
|
||||
|
||||
# readable
|
||||
|
||||
exec chmod 444 gorp.file
|
||||
test file-8.1 {readable option} {file readable gorp.file} 1
|
||||
exec chmod 333 gorp.file
|
||||
if {$user != "root"} {
|
||||
test file-8.2 {readable option} {file reada gorp.file} 0
|
||||
}
|
||||
|
||||
# writable
|
||||
|
||||
exec chmod 555 gorp.file
|
||||
if {$user != "root"} {
|
||||
test file-9.1 {writable option} {file writable gorp.file} 0
|
||||
}
|
||||
exec chmod 222 gorp.file
|
||||
test file-9.2 {writable option} {file w gorp.file} 1
|
||||
|
||||
# stat
|
||||
|
||||
exec cat > gorp.file << "Test string"
|
||||
exec chmod 765 gorp.file
|
||||
test file-10.1 {stat option} {
|
||||
catch {unset stat}
|
||||
file stat gorp.file stat
|
||||
lsort [array names stat]
|
||||
} {atime ctime dev gid ino mode mtime nlink size type uid}
|
||||
test file-10.2 {stat option} {
|
||||
catch {unset stat}
|
||||
file stat gorp.file stat
|
||||
list $stat(nlink) $stat(size) [expr $stat(mode)&0777] $stat(type)
|
||||
} {1 11 501 file}
|
||||
test file-10.3 {stat option} {
|
||||
string tolower [list [catch {file stat _bogus_ stat} msg] \
|
||||
$msg $errorCode]
|
||||
} {1 {couldn't stat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
|
||||
test file-10.4 {stat option} {
|
||||
list [catch {file stat _bogus_} msg] $msg $errorCode
|
||||
} {1 {wrong # args: should be "file stat name varName"} NONE}
|
||||
test file-10.5 {stat option} {
|
||||
list [catch {file stat _bogus_ a b} msg] $msg $errorCode
|
||||
} {1 {wrong # args: should be "file stat name varName"} NONE}
|
||||
test file-10.6 {stat option} {
|
||||
catch {unset x}
|
||||
set x 44
|
||||
list [catch {file stat gorp.file x} msg] $msg $errorCode
|
||||
} {1 {can't set "x(dev)": variable isn't array} NONE}
|
||||
catch {unset stat}
|
||||
|
||||
# mtime, and size (I've given up trying to find a test for "atime": there
|
||||
# seem to be too many quirks in the way file systems handle this to come
|
||||
# up with a reproducible test).
|
||||
|
||||
test file-11.1 {mtime and atime and size options} {
|
||||
catch {unset stat}
|
||||
file stat gorp.file stat
|
||||
list [expr {[file mtime gorp.file] == $stat(mtime)}] \
|
||||
[expr {[file atime gorp.file] == $stat(atime)}] \
|
||||
[file size gorp.file]
|
||||
} {1 1 11}
|
||||
test file-11.2 {mtime option} {
|
||||
set old [file mtime gorp.file]
|
||||
exec sleep 2
|
||||
set f [open gorp.file w]
|
||||
puts $f "More text"
|
||||
close $f
|
||||
set new [file mtime gorp.file]
|
||||
expr {($new > $old) && ($new <= ($old+5))}
|
||||
} {1}
|
||||
test file-11.3 {size option} {
|
||||
set oldsize [file size gorp.file]
|
||||
set f [open gorp.file a]
|
||||
puts $f "More text"
|
||||
close $f
|
||||
expr {[file size gorp.file] - $oldsize}
|
||||
} {10}
|
||||
test file-11.4 {errors in atime option} {
|
||||
list [catch {file atime _bogus_ x} msg] $msg $errorCode
|
||||
} {1 {wrong # args: should be "file atime name"} NONE}
|
||||
test file-11.5 {errors in atime option} {
|
||||
string tolower [list [catch {file atime _bogus_} msg] \
|
||||
$msg $errorCode]
|
||||
} {1 {couldn't stat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
|
||||
test file-11.6 {errors in mtime option} {
|
||||
list [catch {file mtime _bogus_ x} msg] $msg $errorCode
|
||||
} {1 {wrong # args: should be "file mtime name"} NONE}
|
||||
test file-11.7 {errors in mtime option} {
|
||||
string tolower [list [catch {file mtime _bogus_} msg] $msg \
|
||||
$errorCode]
|
||||
} {1 {couldn't stat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
|
||||
test file-11.8 {errors in size option} {
|
||||
list [catch {file size _bogus_ x} msg] $msg $errorCode
|
||||
} {1 {wrong # args: should be "file size name"} NONE}
|
||||
test file-11.9 {errors in size option} {
|
||||
string tolower [list [catch {file size _bogus_} msg] $msg \
|
||||
$errorCode]
|
||||
} {1 {couldn't stat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
|
||||
|
||||
# type
|
||||
|
||||
test file-12.1 {type option} {
|
||||
file type dir.file
|
||||
} directory
|
||||
test file-12.2 {type option} {
|
||||
file type gorp.file
|
||||
} file
|
||||
if $atBerkeley {
|
||||
exec ln -s a/b/c link.file
|
||||
test file-12.3 {type option} {
|
||||
file type link.file
|
||||
} link
|
||||
exec rm link.file
|
||||
}
|
||||
test file-12.4 {errors in type option} {
|
||||
list [catch {file type a b} msg] $msg $errorCode
|
||||
} {1 {wrong # args: should be "file type name"} NONE}
|
||||
test file-12.5 {errors in type option} {
|
||||
string tolower [list [catch {file type _bogus_} msg] $msg $errorCode]
|
||||
} {1 {couldn't stat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
|
||||
|
||||
# lstat and readlink: run these tests only at Berkeley, since not all
|
||||
# sites will have symbolic links
|
||||
|
||||
if $atBerkeley {
|
||||
exec ln -s gorp.file link.file
|
||||
test file-13.1 {lstat option} {
|
||||
catch {unset stat}
|
||||
file lstat link.file stat
|
||||
lsort [array names stat]
|
||||
} {atime ctime dev gid ino mode mtime nlink size type uid}
|
||||
test file-13.1 {lstat option} {
|
||||
catch {unset stat}
|
||||
file lstat link.file stat
|
||||
list $stat(nlink) [expr $stat(mode)&0777] $stat(type)
|
||||
} {1 511 link}
|
||||
test file-13.3 {errors in lstat option} {
|
||||
string tolower [list [catch {file lstat _bogus_ stat} msg] \
|
||||
$msg $errorCode]
|
||||
} {1 {couldn't lstat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
|
||||
test file-13.4 {errors in lstat option} {
|
||||
list [catch {file lstat _bogus_} msg] $msg $errorCode
|
||||
} {1 {wrong # args: should be "file lstat name varName"} NONE}
|
||||
test file-13.5 {errors in lstat option} {
|
||||
list [catch {file lstat _bogus_ a b} msg] $msg $errorCode
|
||||
} {1 {wrong # args: should be "file lstat name varName"} NONE}
|
||||
test file-13.6 {errors in lstat option} {
|
||||
catch {unset x}
|
||||
set x 44
|
||||
list [catch {file lstat gorp.file x} msg] $msg $errorCode
|
||||
} {1 {can't set "x(dev)": variable isn't array} NONE}
|
||||
catch {unset stat}
|
||||
|
||||
test file-14.1 {readlink option} {
|
||||
file readlink link.file
|
||||
} gorp.file
|
||||
test file-14.2 {errors in readlink option} {
|
||||
list [catch {file readlink a b} msg] $msg $errorCode
|
||||
} {1 {wrong # args: should be "file readlink name"} NONE}
|
||||
test file-14.3 {errors in readlink option} {
|
||||
list [catch {file readlink _bogus_} msg] $msg $errorCode
|
||||
} {1 {couldn't readlink "_bogus_": no such file or directory} {POSIX ENOENT {no such file or directory}}}
|
||||
|
||||
exec rm link.file
|
||||
}
|
||||
|
||||
# Error conditions
|
||||
|
||||
test file-15.1 {error conditions} {
|
||||
list [catch file msg] $msg
|
||||
} {1 {wrong # args: should be "file option name ?arg ...?"}}
|
||||
test file-15.2 {error conditions} {
|
||||
list [catch {file x} msg] $msg
|
||||
} {1 {wrong # args: should be "file option name ?arg ...?"}}
|
||||
test file-15.3 {error conditions} {
|
||||
list [catch {file exists x too} msg] $msg
|
||||
} {1 {wrong # args: should be "file exists name"}}
|
||||
test file-15.4 {error conditions} {
|
||||
list [catch {file gorp x} msg] $msg
|
||||
} {1 {bad option "gorp": should be atime, dirname, executable, exists, extension, isdirectory, isfile, lstat, mtime, owned, readable, readlink, root, size, stat, tail, type, or writable}}
|
||||
test file-15.5 {error conditions} {
|
||||
list [catch {file ex x} msg] $msg
|
||||
} {1 {bad option "ex": should be atime, dirname, executable, exists, extension, isdirectory, isfile, lstat, mtime, owned, readable, readlink, root, size, stat, tail, type, or writable}}
|
||||
test file-15.6 {error conditions} {
|
||||
list [catch {file is x} msg] $msg
|
||||
} {1 {bad option "is": should be atime, dirname, executable, exists, extension, isdirectory, isfile, lstat, mtime, owned, readable, readlink, root, size, stat, tail, type, or writable}}
|
||||
test file-15.7 {error conditions} {
|
||||
list [catch {file read x} msg] $msg
|
||||
} {1 {bad option "read": should be atime, dirname, executable, exists, extension, isdirectory, isfile, lstat, mtime, owned, readable, readlink, root, size, stat, tail, type, or writable}}
|
||||
test file-15.8 {error conditions} {
|
||||
list [catch {file s x} msg] $msg
|
||||
} {1 {bad option "s": should be atime, dirname, executable, exists, extension, isdirectory, isfile, lstat, mtime, owned, readable, readlink, root, size, stat, tail, type, or writable}}
|
||||
test file-15.9 {error conditions} {
|
||||
list [catch {file t x} msg] $msg
|
||||
} {1 {bad option "t": should be atime, dirname, executable, exists, extension, isdirectory, isfile, lstat, mtime, owned, readable, readlink, root, size, stat, tail, type, or writable}}
|
||||
test file-15.10 {error conditions} {
|
||||
list [catch {file rootname ~woohgy} msg] $msg
|
||||
} {1 {user "woohgy" doesn't exist}}
|
||||
|
||||
exec chmod 777 dir.file
|
||||
exec rm dir.file/gorp.file gorp.file
|
||||
exec rmdir dir.file
|
||||
169
tcl7.3/tests/for.test
Normal file
169
tcl7.3/tests/for.test
Normal file
@@ -0,0 +1,169 @@
|
||||
# Commands covered: foreach, for, continue, break
|
||||
#
|
||||
# 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.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/for.test,v 1.8 93/02/06 15:54:05 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
# Basic "foreach" operation.
|
||||
|
||||
test for-1.1 {basic foreach tests} {
|
||||
set a {}
|
||||
foreach i {a b c d} {
|
||||
set a [concat $a $i]
|
||||
}
|
||||
set a
|
||||
} {a b c d}
|
||||
test for-1.2 {basic foreach tests} {
|
||||
set a {}
|
||||
foreach i {a b {{c d} e} {123 {{x}}}} {
|
||||
set a [concat $a $i]
|
||||
}
|
||||
set a
|
||||
} {a b {c d} e 123 {{x}}}
|
||||
test for-1.3 {basic foreach tests} {catch {foreach} msg} 1
|
||||
test for-1.4 {basic foreach tests} {
|
||||
catch {foreach} msg
|
||||
set msg
|
||||
} {wrong # args: should be "foreach varName list command"}
|
||||
test for-1.5 {basic foreach tests} {catch {foreach i} msg} 1
|
||||
test for-1.6 {basic foreach tests} {
|
||||
catch {foreach i} msg
|
||||
set msg
|
||||
} {wrong # args: should be "foreach varName list command"}
|
||||
test for-1.7 {basic foreach tests} {catch {foreach i j} msg} 1
|
||||
test for-1.8 {basic foreach tests} {
|
||||
catch {foreach i j} msg
|
||||
set msg
|
||||
} {wrong # args: should be "foreach varName list command"}
|
||||
test for-1.9 {basic foreach tests} {catch {foreach i j k l} msg} 1
|
||||
test for-1.10 {basic foreach tests} {
|
||||
catch {foreach i j k l} msg
|
||||
set msg
|
||||
} {wrong # args: should be "foreach varName list command"}
|
||||
test for-1.11 {basic foreach tests} {
|
||||
set a {}
|
||||
foreach i {} {
|
||||
set a [concat $a $i]
|
||||
}
|
||||
set a
|
||||
} {}
|
||||
test for-1.11 {foreach errors} {
|
||||
catch {unset a}
|
||||
set a(0) 44
|
||||
list [catch {foreach a {1 2 3} {}} msg] $msg
|
||||
} {1 {couldn't set loop variable}}
|
||||
catch {unset a}
|
||||
|
||||
# Check "continue".
|
||||
|
||||
test for-2.1 {continue tests} {catch continue} 4
|
||||
test for-2.2 {continue tests} {
|
||||
set a {}
|
||||
foreach i {a b c d} {
|
||||
if {[string compare $i "b"] == 0} continue
|
||||
set a [concat $a $i]
|
||||
}
|
||||
set a
|
||||
} {a c d}
|
||||
test for-2.3 {continue tests} {
|
||||
set a {}
|
||||
foreach i {a b c d} {
|
||||
if {[string compare $i "b"] != 0} continue
|
||||
set a [concat $a $i]
|
||||
}
|
||||
set a
|
||||
} {b}
|
||||
test for-2.4 {continue tests} {catch {continue foo} msg} 1
|
||||
test for-2.5 {continue tests} {
|
||||
catch {continue foo} msg
|
||||
set msg
|
||||
} {wrong # args: should be "continue"}
|
||||
|
||||
# Check "break".
|
||||
|
||||
test for-3.1 {break tests} {catch break} 3
|
||||
test for-3.2 {break tests} {
|
||||
set a {}
|
||||
foreach i {a b c d} {
|
||||
if {[string compare $i "c"] == 0} break
|
||||
set a [concat $a $i]
|
||||
}
|
||||
set a
|
||||
} {a b}
|
||||
test for-3.3 {break tests} {catch {break foo} msg} 1
|
||||
test for-3.4 {break tests} {
|
||||
catch {break foo} msg
|
||||
set msg
|
||||
} {wrong # args: should be "break"}
|
||||
|
||||
# Check "for" and its use of continue and break.
|
||||
|
||||
test for-4.1 {for tests} {
|
||||
set a {}
|
||||
for {set i 1} {$i<6} {set i [expr $i+1]} {
|
||||
set a [concat $a $i]
|
||||
}
|
||||
set a
|
||||
} {1 2 3 4 5}
|
||||
test for-4.2 {for tests} {
|
||||
set a {}
|
||||
for {set i 1} {$i<6} {set i [expr $i+1]} {
|
||||
if $i==4 continue
|
||||
set a [concat $a $i]
|
||||
}
|
||||
set a
|
||||
} {1 2 3 5}
|
||||
test for-4.3 {for tests} {
|
||||
set a {}
|
||||
for {set i 1} {$i<6} {set i [expr $i+1]} {
|
||||
if $i==4 break
|
||||
set a [concat $a $i]
|
||||
}
|
||||
set a
|
||||
} {1 2 3}
|
||||
test for-4.4 {for tests} {catch {for 1 2 3} msg} 1
|
||||
test for-4.5 {for tests} {
|
||||
catch {for 1 2 3} msg
|
||||
set msg
|
||||
} {wrong # args: should be "for start test next command"}
|
||||
test for-4.6 {for tests} {catch {for 1 2 3 4 5} msg} 1
|
||||
test for-4.7 {for tests} {
|
||||
catch {for 1 2 3 4 5} msg
|
||||
set msg
|
||||
} {wrong # args: should be "for start test next command"}
|
||||
test for-4.8 {for tests} {
|
||||
set a {xyz}
|
||||
for {set i 1} {$i<6} {set i [expr $i+1]} {}
|
||||
set a
|
||||
} xyz
|
||||
test for-4.9 {for tests} {
|
||||
set a {}
|
||||
for {set i 1} {$i<6} {set i [expr $i+1]; if $i==4 break} {
|
||||
set a [concat $a $i]
|
||||
}
|
||||
set a
|
||||
} {1 2 3}
|
||||
379
tcl7.3/tests/format.test
Normal file
379
tcl7.3/tests/format.test
Normal file
@@ -0,0 +1,379 @@
|
||||
# Commands covered: format
|
||||
#
|
||||
# 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.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/format.test,v 1.16 93/07/17 15:25:01 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
# The following code is needed because some versions of SCO Unix have
|
||||
# a round-off error in sprintf which would cause some of the tests to
|
||||
# fail. Someday I hope this code shouldn't be necessary (code added
|
||||
# 9/9/91).
|
||||
|
||||
set roundOffBug 0
|
||||
if {"[format %7.1e 68.514]" == "6.8e+01"} {
|
||||
puts stdout "Note: this system has a sprintf round-off bug, some tests skipped\n"
|
||||
set roundOffBug 1
|
||||
}
|
||||
|
||||
test format-1.1 {integer formatting} {
|
||||
format "%*d %d %d %d" 6 34 16923 -12 -1
|
||||
} { 34 16923 -12 -1}
|
||||
if $atBerkeley {
|
||||
test format-1.2 {integer formatting} {
|
||||
format "%4d %4d %4d %4d %d %#x %#X" 6 34 16923 -12 -1 0 0
|
||||
} { 6 34 16923 -12 -1 0 0}
|
||||
}
|
||||
|
||||
# %u output depends on word length, so don't run these tests except
|
||||
# at Berkeley, where word length is known.
|
||||
|
||||
if $atBerkeley {
|
||||
test format-1.3 {integer formatting} {
|
||||
format "%4u %4u %4u %4u %d %#o" 6 34 16923 -12 -1 0
|
||||
} { 6 34 16923 4294967284 -1 0}
|
||||
}
|
||||
test format-1.4 {integer formatting} {
|
||||
format "%-4d %-4i %-4d %-4ld" 6 34 16923 -12 -1
|
||||
} {6 34 16923 -12 }
|
||||
test format-1.5 {integer formatting} {
|
||||
format "%04d %04d %04d %04i" 6 34 16923 -12 -1
|
||||
} {0006 0034 16923 -012}
|
||||
test format-1.6 {integer formatting} {
|
||||
format "%00*d" 6 34
|
||||
} {000034}
|
||||
|
||||
# Printing negative numbers in hex or octal format depends on word
|
||||
# length; only run at Berkeley where word length is known.
|
||||
|
||||
if $atBerkeley {
|
||||
test format-1.7 {integer formatting} {
|
||||
format "%4x %4x %4x %4x" 6 34 16923 -12 -1
|
||||
} { 6 22 421b fffffff4}
|
||||
test format-1.8 {integer formatting} {
|
||||
format "%#x %#X %#X %#x" 6 34 16923 -12 -1
|
||||
} {0x6 0X22 0X421B 0xfffffff4}
|
||||
test format-1.9 {integer formatting} {
|
||||
format "%#20x %#20x %#20x %#20x" 6 34 16923 -12 -1
|
||||
} { 0x6 0x22 0x421b 0xfffffff4}
|
||||
test format-1.10 {integer formatting} {
|
||||
format "%-#20x %-#20x %-#20x %-#20x" 6 34 16923 -12 -1
|
||||
} {0x6 0x22 0x421b 0xfffffff4 }
|
||||
test format-1.11 {integer formatting} {
|
||||
format "%-#20o %#-20o %#-20o %#-20o" 6 34 16923 -12 -1
|
||||
} {06 042 041033 037777777764 }
|
||||
}
|
||||
|
||||
test format-2.1 {string formatting} {
|
||||
format "%s %s %c %s" abcd {This is a very long test string.} 120 x
|
||||
} {abcd This is a very long test string. x x}
|
||||
test format-2.2 {string formatting} {
|
||||
format "%20s %20s %20c %20s" abcd {This is a very long test string.} 120 x
|
||||
} { abcd This is a very long test string. x x}
|
||||
test format-2.3 {string formatting} {
|
||||
format "%.10s %.10s %c %.10s" abcd {This is a very long test string.} 120 x
|
||||
} {abcd This is a x x}
|
||||
test format-2.4 {string formatting} {
|
||||
format "%s %s %% %c %s" abcd {This is a very long test string.} 120 x
|
||||
} {abcd This is a very long test string. % x x}
|
||||
|
||||
test format-3.1 {e and f formats} {
|
||||
format "%e %e %e %e" 34.2e12 68.514 -.125 -16000. .000053
|
||||
} {3.420000e+13 6.851400e+01 -1.250000e-01 -1.600000e+04}
|
||||
test format-3.2 {e and f formats} {
|
||||
format "%20e %20e %20e %20e" 34.2e12 68.514 -.125 -16000. .000053
|
||||
} { 3.420000e+13 6.851400e+01 -1.250000e-01 -1.600000e+04}
|
||||
if {!$roundOffBug} {
|
||||
test format-3.3 {e and f formats} {
|
||||
format "%.1e %.1e %.1e %.1e" 34.2e12 68.514 -.126 -16000. .000053
|
||||
} {3.4e+13 6.9e+01 -1.3e-01 -1.6e+04}
|
||||
test format-3.4 {e and f formats} {
|
||||
format "%020e %020e %020e %020e" 34.2e12 68.514 -.126 -16000. .000053
|
||||
} {000000003.420000e+13 000000006.851400e+01 -00000001.260000e-01 -00000001.600000e+04}
|
||||
test format-3.5 {e and f formats} {
|
||||
format "%7.1e %7.1e %7.1e %7.1e" 34.2e12 68.514 -.126 -16000. .000053
|
||||
} {3.4e+13 6.9e+01 -1.3e-01 -1.6e+04}
|
||||
test format-3.6 {e and f formats} {
|
||||
format "%f %f %f %f" 34.2e12 68.514 -.125 -16000. .000053
|
||||
} {34200000000000.000000 68.514000 -0.125000 -16000.000000}
|
||||
}
|
||||
test format-3.7 {e and f formats} {
|
||||
format "%.4f %.4f %.4f %.4f %.4f" 34.2e12 68.514 -.125 -16000. .000053
|
||||
} {34200000000000.0000 68.5140 -0.1250 -16000.0000 0.0001}
|
||||
test format-3.8 {e and f formats} {
|
||||
format "%.4e %.5e %.6e" -9.99996 -9.99996 9.99996
|
||||
} {-1.0000e+01 -9.99996e+00 9.999960e+00}
|
||||
test format-3.9 {e and f formats} {
|
||||
format "%.4f %.5f %.6f" -9.99996 -9.99996 9.99996
|
||||
} {-10.0000 -9.99996 9.999960}
|
||||
test format-3.10 {e and f formats} {
|
||||
format "%20f %-20f %020f" -9.99996 -9.99996 9.99996
|
||||
} { -9.999960 -9.999960 0000000000009.999960}
|
||||
test format-3.11 {e and f formats} {
|
||||
format "%-020f %020f" -9.99996 -9.99996 9.99996
|
||||
} {-9.999960 -000000000009.999960}
|
||||
test format-3.12 {e and f formats} {
|
||||
format "%.0e %#.0e" -9.99996 -9.99996 9.99996
|
||||
} {-1e+01 -1.e+01}
|
||||
test format-3.13 {e and f formats} {
|
||||
format "%.0f %#.0f" -9.99996 -9.99996 9.99996
|
||||
} {-10 -10.}
|
||||
test format-3.14 {e and f formats} {
|
||||
format "%.4f %.5f %.6f" -9.99996 -9.99996 9.99996
|
||||
} {-10.0000 -9.99996 9.999960}
|
||||
test format-3.15 {e and f formats} {
|
||||
format "%3.0f %3.0f %3.0f %3.0f" 1.0 1.1 1.01 1.001
|
||||
} { 1 1 1 1}
|
||||
test format-3.16 {e and f formats} {
|
||||
format "%3.1f %3.1f %3.1f %3.1f" 0.0 0.1 0.01 0.001
|
||||
} {0.0 0.1 0.0 0.0}
|
||||
|
||||
test format-4.1 {g-format} {
|
||||
format "%.3g" 12341.0
|
||||
} {1.23e+04}
|
||||
test format-4.2 {g-format} {
|
||||
format "%.3G" 1234.12345
|
||||
} {1.23E+03}
|
||||
test format-4.3 {g-format} {
|
||||
format "%.3g" 123.412345
|
||||
} {123}
|
||||
test format-4.4 {g-format} {
|
||||
format "%.3g" 12.3412345
|
||||
} {12.3}
|
||||
test format-4.5 {g-format} {
|
||||
format "%.3g" 1.23412345
|
||||
} {1.23}
|
||||
test format-4.6 {g-format} {
|
||||
format "%.3g" 1.23412345
|
||||
} {1.23}
|
||||
test format-4.7 {g-format} {
|
||||
format "%.3g" .123412345
|
||||
} {0.123}
|
||||
test format-4.8 {g-format} {
|
||||
format "%.3g" .012341
|
||||
} {0.0123}
|
||||
test format-4.9 {g-format} {
|
||||
format "%.3g" .0012341
|
||||
} {0.00123}
|
||||
test format-4.10 {g-format} {
|
||||
format "%.3g" .00012341
|
||||
} {0.000123}
|
||||
test format-4.11 {g-format} {
|
||||
format "%.3g" .00001234
|
||||
} {1.23e-05}
|
||||
test format-4.12 {g-format} {
|
||||
format "%.4g" 9999.6
|
||||
} {1e+04}
|
||||
test format-4.13 {g-format} {
|
||||
format "%.4g" 999.96
|
||||
} {1000}
|
||||
test format-4.14 {g-format} {
|
||||
format "%.3g" 1.0
|
||||
} {1}
|
||||
test format-4.15 {g-format} {
|
||||
format "%.3g" .1
|
||||
} {0.1}
|
||||
test format-4.16 {g-format} {
|
||||
format "%.3g" .01
|
||||
} {0.01}
|
||||
test format-4.17 {g-format} {
|
||||
format "%.3g" .001
|
||||
} {0.001}
|
||||
test format-4.19 {g-format} {
|
||||
format "%.3g" .00001
|
||||
} {1e-05}
|
||||
test format-4.20 {g-format} {
|
||||
format "%#.3g" 1234.0
|
||||
} {1.23e+03}
|
||||
test format-4.21 {g-format} {
|
||||
format "%#.3G" 9999.5
|
||||
} {1.00E+04}
|
||||
|
||||
test format-5.1 {floating-point zeroes} {
|
||||
format "%e %f %g" 0.0 0.0 0.0 0.0
|
||||
} {0.000000e+00 0.000000 0}
|
||||
test format-5.2 {floating-point zeroes} {
|
||||
format "%.4e %.4f %.4g" 0.0 0.0 0.0 0.0
|
||||
} {0.0000e+00 0.0000 0}
|
||||
test format-5.3 {floating-point zeroes} {
|
||||
format "%#.4e %#.4f %#.4g" 0.0 0.0 0.0 0.0
|
||||
} {0.0000e+00 0.0000 0.000}
|
||||
test format-5.4 {floating-point zeroes} {
|
||||
format "%.0e %.0f %.0g" 0.0 0.0 0.0 0.0
|
||||
} {0e+00 0 0}
|
||||
test format-5.5 {floating-point zeroes} {
|
||||
format "%#.0e %#.0f %#.0g" 0.0 0.0 0.0 0.0
|
||||
} {0.e+00 0. 0.}
|
||||
test format-5.6 {floating-point zeroes} {
|
||||
format "%3.0f %3.0f %3.0f %3.0f" 0.0 0.0 0.0 0.0
|
||||
} { 0 0 0 0}
|
||||
test format-5.7 {floating-point zeroes} {
|
||||
format "%3.0f %3.0f %3.0f %3.0f" 1.0 1.1 1.01 1.001
|
||||
} { 1 1 1 1}
|
||||
test format-5.8 {floating-point zeroes} {
|
||||
format "%3.1f %3.1f %3.1f %3.1f" 0.0 0.1 0.01 0.001
|
||||
} {0.0 0.1 0.0 0.0}
|
||||
|
||||
test format-6.1 {various syntax features} {
|
||||
format "%*.*f" 12 3 12.345678901
|
||||
} { 12.346}
|
||||
test format-6.2 {various syntax features} {
|
||||
format "%0*.*f" 12 3 12.345678901
|
||||
} {00000012.346}
|
||||
test format-6.3 {various syntax features} {
|
||||
format "\*\t\\n"
|
||||
} {* \n}
|
||||
|
||||
test format-7.1 {error conditions} {
|
||||
catch format
|
||||
} 1
|
||||
test format-7.2 {error conditions} {
|
||||
catch format msg
|
||||
set msg
|
||||
} {wrong # args: should be "format formatString ?arg arg ...?"}
|
||||
test format-7.3 {error conditions} {
|
||||
catch {format %*d}
|
||||
} 1
|
||||
test format-7.4 {error conditions} {
|
||||
catch {format %*d} msg
|
||||
set msg
|
||||
} {not enough arguments for all format specifiers}
|
||||
test format-7.5 {error conditions} {
|
||||
catch {format %*.*f 12}
|
||||
} 1
|
||||
test format-7.6 {error conditions} {
|
||||
catch {format %*.*f 12} msg
|
||||
set msg
|
||||
} {not enough arguments for all format specifiers}
|
||||
test format-7.7 {error conditions} {
|
||||
catch {format %*.*f 12 3}
|
||||
} 1
|
||||
test format-7.8 {error conditions} {
|
||||
catch {format %*.*f 12 3} msg
|
||||
set msg
|
||||
} {not enough arguments for all format specifiers}
|
||||
test format-7.9 {error conditions} {
|
||||
list [catch {format %*d x 3} msg] $msg
|
||||
} {1 {expected integer but got "x"}}
|
||||
test format-7.10 {error conditions} {
|
||||
list [catch {format %*.*f 2 xyz 3} msg] $msg
|
||||
} {1 {expected integer but got "xyz"}}
|
||||
test format-7.11 {error conditions} {
|
||||
catch {format %d 2a}
|
||||
} 1
|
||||
test format-7.12 {error conditions} {
|
||||
catch {format %d 2a} msg
|
||||
set msg
|
||||
} {expected integer but got "2a"}
|
||||
test format-7.13 {error conditions} {
|
||||
catch {format %c 2x}
|
||||
} 1
|
||||
test format-7.14 {error conditions} {
|
||||
catch {format %c 2x} msg
|
||||
set msg
|
||||
} {expected integer but got "2x"}
|
||||
test format-7.15 {error conditions} {
|
||||
catch {format %f 2.1z}
|
||||
} 1
|
||||
test format-7.16 {error conditions} {
|
||||
catch {format %f 2.1z} msg
|
||||
set msg
|
||||
} {expected floating-point number but got "2.1z"}
|
||||
test format-7.17 {error conditions} {
|
||||
catch {format ab%}
|
||||
} 1
|
||||
test format-7.18 {error conditions} {
|
||||
catch {format ab% 12} msg
|
||||
set msg
|
||||
} {format string ended in middle of field specifier}
|
||||
test format-7.19 {error conditions} {
|
||||
catch {format %q x}
|
||||
} 1
|
||||
test format-7.20 {error conditions} {
|
||||
catch {format %q x} msg
|
||||
set msg
|
||||
} {bad field specifier "q"}
|
||||
test format-7.21 {error conditions} {
|
||||
catch {format %d}
|
||||
} 1
|
||||
test format-7.22 {error conditions} {
|
||||
catch {format %d} msg
|
||||
set msg
|
||||
} {not enough arguments for all format specifiers}
|
||||
|
||||
test format-8.1 {long result} {
|
||||
set a {1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z}
|
||||
format {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG %s %s %s} $a $a $a
|
||||
} {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z}
|
||||
|
||||
if $atBerkeley {
|
||||
test format-9.1 {"h" format specifier} {
|
||||
format %hd 0xffff
|
||||
} -1
|
||||
test format-9.2 {"h" format specifier} {
|
||||
format %hx 0x10fff
|
||||
} fff
|
||||
test format-9.3 {"h" format specifier} {
|
||||
format %hd 0x10000
|
||||
} 0
|
||||
}
|
||||
|
||||
test format-10.1 {XPG3 %$n specifiers} {
|
||||
format {%2$d %1$d} 4 5
|
||||
} {5 4}
|
||||
test format-10.2 {XPG3 %$n specifiers} {
|
||||
format {%2$d %1$d %1$d %3$d} 4 5 6
|
||||
} {5 4 4 6}
|
||||
test format-10.3 {XPG3 %$n specifiers} {
|
||||
list [catch {format {%2$d %3$d} 4 5} msg] $msg
|
||||
} {1 {"%n$" argument index out of range}}
|
||||
test format-10.4 {XPG3 %$n specifiers} {
|
||||
list [catch {format {%2$d %0$d} 4 5 6} msg] $msg
|
||||
} {1 {"%n$" argument index out of range}}
|
||||
test format-10.5 {XPG3 %$n specifiers} {
|
||||
list [catch {format {%d %1$d} 4 5 6} msg] $msg
|
||||
} {1 {cannot mix "%" and "%n$" conversion specifiers}}
|
||||
test format-10.6 {XPG3 %$n specifiers} {
|
||||
list [catch {format {%2$d %d} 4 5 6} msg] $msg
|
||||
} {1 {cannot mix "%" and "%n$" conversion specifiers}}
|
||||
test format-10.7 {XPG3 %$n specifiers} {
|
||||
list [catch {format {%2$d %3d} 4 5 6} msg] $msg
|
||||
} {1 {cannot mix "%" and "%n$" conversion specifiers}}
|
||||
test format-10.8 {XPG3 %$n specifiers} {
|
||||
format {%2$*d %3$d} 1 10 4
|
||||
} { 4 4}
|
||||
test format-10.9 {XPG3 %$n specifiers} {
|
||||
format {%2$.*s %4$d} 1 5 abcdefghijklmnop 44
|
||||
} {abcde 44}
|
||||
test format-10.10 {XPG3 %$n specifiers} {
|
||||
list [catch {format {%2$*d} 4} msg] $msg
|
||||
} {1 {"%n$" argument index out of range}}
|
||||
test format-10.11 {XPG3 %$n specifiers} {
|
||||
list [catch {format {%2$*d} 4 5} msg] $msg
|
||||
} {1 {"%n$" argument index out of range}}
|
||||
test format-10.12 {XPG3 %$n specifiers} {
|
||||
list [catch {format {%2$*d} 4 5 6} msg] $msg
|
||||
} {0 { 6}}
|
||||
153
tcl7.3/tests/glob.test
Normal file
153
tcl7.3/tests/glob.test
Normal file
@@ -0,0 +1,153 @@
|
||||
# Commands covered: glob
|
||||
#
|
||||
# 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.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/glob.test,v 1.23 93/08/28 15:57:40 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
# First, create some subdirectories to use for testing.
|
||||
|
||||
exec rm -rf globTest
|
||||
exec mkdir globTest globTest/a1 globTest/a2 globTest/a3
|
||||
exec mkdir globTest/a1/b1 globTest/a1/b2 globTest/a2/b3
|
||||
exec cat << abc > globTest/x1.c
|
||||
exec cat << abc > globTest/y1.c
|
||||
exec cat << abc > globTest/z1.c
|
||||
exec cat << abc > "globTest/weird name.c"
|
||||
exec cat << abc > globTest/.1
|
||||
exec cat << abc > globTest/a1/b1/x2.c
|
||||
exec cat << abc > globTest/a1/b2/y2.c
|
||||
|
||||
test glob-1.1 {simple globbing} {
|
||||
lsort [glob globTest/x1.c globTest/y1.c globTest/foo]
|
||||
} {globTest/x1.c globTest/y1.c}
|
||||
test glob-1.2 {simple globbing} {
|
||||
glob {}
|
||||
} .
|
||||
|
||||
test glob-2.1 {globbing with braces} {
|
||||
glob -nocomplain "{a1,a2}"
|
||||
} {}
|
||||
test glob-2.2 {globbing with braces} {
|
||||
lsort [glob globTest/{a,b,x,y}1.c]
|
||||
} {globTest/x1.c globTest/y1.c}
|
||||
test glob-2.3 {globbing with braces} {
|
||||
lsort [glob {globTest/{x1,y2,weird name}.c}]
|
||||
} {{globTest/weird name.c} globTest/x1.c}
|
||||
test glob-2.4 {globbing with braces} {
|
||||
lsort [glob globTest/{x1.c,a1/*}]
|
||||
} {globTest/a1/b1 globTest/a1/b2 globTest/x1.c}
|
||||
|
||||
test glob-3.1 {asterisks, question marks, and brackets} {
|
||||
lsort [glob g*/*.c]
|
||||
} {{globTest/weird name.c} globTest/x1.c globTest/y1.c globTest/z1.c}
|
||||
test glob-3.2 {asterisks, question marks, and brackets} {
|
||||
lsort [glob globTest/?1.c]
|
||||
} {globTest/x1.c globTest/y1.c globTest/z1.c}
|
||||
test glob-3.3 {asterisks, question marks, and brackets} {
|
||||
lsort [glob */*/*/*.c]
|
||||
} {globTest/a1/b1/x2.c globTest/a1/b2/y2.c}
|
||||
test glob-3.4 {asterisks, question marks, and brackets} {
|
||||
lsort [glob globTest/*]
|
||||
} {globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x1.c globTest/y1.c globTest/z1.c}
|
||||
test glob-3.5 {asterisks, question marks, and brackets} {
|
||||
lsort [glob globTest/.*]
|
||||
} {globTest/. globTest/.. globTest/.1}
|
||||
test glob-3.6 {asterisks, question marks, and brackets} {
|
||||
lsort [glob globTest/*/*]
|
||||
} {globTest/a1/b1 globTest/a1/b2 globTest/a2/b3}
|
||||
test glob-3.7 {asterisks, question marks, and brackets} {
|
||||
lsort [glob {globTest/[xyab]1.*}]
|
||||
} {globTest/x1.c globTest/y1.c}
|
||||
test glob-3.8 {asterisks, question marks, and brackets} {
|
||||
lsort [glob globTest/*/]
|
||||
} {globTest/a1/ globTest/a2/ globTest/a3/}
|
||||
|
||||
# The tests immediately below can only be run at Berkeley, where
|
||||
# the file-system structure is well-known.
|
||||
|
||||
if $atBerkeley {
|
||||
test glob-4.1 {tildes} {glob ~/.csh*} "/users/ouster/.cshrc"
|
||||
test glob-4.2 {tildes} {glob ~ouster/.csh*} "/users/ouster/.cshrc"
|
||||
}
|
||||
|
||||
test glob-5.1 {error conditions} {
|
||||
list [catch {glob} msg] $msg
|
||||
} {1 {wrong # args: should be "glob ?switches? name ?name ...?"}}
|
||||
test glob-5.2 {error conditions} {
|
||||
list [catch {glob globTest/\{} msg] $msg
|
||||
} {1 {unmatched open-brace in file name}}
|
||||
test glob-5.3 {error conditions} {
|
||||
list [catch {glob globTest/*/gorp} msg] $msg
|
||||
} {1 {no files matched glob pattern "globTest/*/gorp"}}
|
||||
test glob-5.4 {error conditions} {
|
||||
list [catch {glob goo/* x*z foo?q} msg] $msg
|
||||
} {1 {no files matched glob patterns "goo/* x*z foo?q"}}
|
||||
test glob-5.5 {error conditions} {
|
||||
list [catch {lsort [glob globTest/*.c goo/*]} msg] $msg
|
||||
} {0 {{globTest/weird name.c} globTest/x1.c globTest/y1.c globTest/z1.c}}
|
||||
test glob-5.6 {error conditions} {
|
||||
list [catch {glob ~no-one} msg] $msg
|
||||
} {1 {user "no-one" doesn't exist}}
|
||||
test glob-5.7 {error conditions} {
|
||||
set home $env(HOME)
|
||||
unset env(HOME)
|
||||
set x [list [catch {glob ~/*} msg] $msg]
|
||||
set env(HOME) $home
|
||||
set x
|
||||
} {1 {couldn't find HOME environment variable to expand "~/*"}}
|
||||
test glob-5.8 {error conditions} {
|
||||
list [catch {glob globTest/{a1,a2}/\{} msg] $msg
|
||||
} {1 {unmatched open-brace in file name}}
|
||||
test glob-5.9 {error conditions} {
|
||||
list [catch {glob globTest/*/\{} msg] $msg
|
||||
} {1 {unmatched open-brace in file name}}
|
||||
|
||||
exec chmod 000 globTest
|
||||
if {$user != "root"} {
|
||||
test glob-6.1 {setting errorCode variable} {
|
||||
string tolower [list [catch {glob globTest/*} msg] $msg $errorCode]
|
||||
} {1 {couldn't read directory "globtest": permission denied} {posix eacces {permission denied}}}
|
||||
}
|
||||
exec chmod 755 globTest
|
||||
|
||||
test glob-7.1 {-nocomplain switch} {
|
||||
list [catch {glob -nocomplai} msg] $msg
|
||||
} {1 {bad switch "-nocomplai": must be -nocomplain or --}}
|
||||
test glob-7.2 {-nocomplain switch} {
|
||||
list [catch {glob -nocomplain} msg] $msg
|
||||
} {1 {wrong # args: should be "glob ?switches? name ?name ...?"}}
|
||||
test glob-7.3 {-nocomplain switch} {
|
||||
list [catch {glob -nocomplain goo/*} msg] $msg
|
||||
} {0 {}}
|
||||
test glob-7.4 {-- switch} {
|
||||
list [catch {glob -- -nocomplain} msg] $msg
|
||||
} {1 {no files matched glob patterns "-nocomplain"}}
|
||||
test glob-7.5 {bogus switch} {
|
||||
list [catch {glob -gorp} msg] $msg
|
||||
} {1 {bad switch "-gorp": must be -nocomplain or --}}
|
||||
|
||||
exec rm -rf globTest
|
||||
400
tcl7.3/tests/history.test
Normal file
400
tcl7.3/tests/history.test
Normal file
@@ -0,0 +1,400 @@
|
||||
# Commands covered: history
|
||||
#
|
||||
# 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.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/history.test,v 1.8 93/02/06 15:53:54 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[info commands history] == ""} {
|
||||
puts stdout "This version of Tcl was built without the history command;\n"
|
||||
puts stdout "history tests will be skipped.\n"
|
||||
return
|
||||
}
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
set num [history nextid]
|
||||
history keep 3
|
||||
history add {set a 12345}
|
||||
history add {set b [format {A test %s} string]}
|
||||
history add {Another test}
|
||||
|
||||
# "history event"
|
||||
|
||||
test history-1.1 {event option} {history event -1} \
|
||||
{set b [format {A test %s} string]}
|
||||
test history-1.2 {event option} {history event $num} \
|
||||
{set a 12345}
|
||||
test history-1.3 {event option} {history event [expr $num+2]} \
|
||||
{Another test}
|
||||
test history-1.4 {event option} {history event set} \
|
||||
{set b [format {A test %s} string]}
|
||||
test history-1.5 {event option} {history e "* a*"} \
|
||||
{set a 12345}
|
||||
test history-1.6 {event option} {catch {history event *gorp} msg} 1
|
||||
test history-1.7 {event option} {
|
||||
catch {history event *gorp} msg
|
||||
set msg
|
||||
} {no event matches "*gorp"}
|
||||
test history-1.8 {event option} {history event} \
|
||||
{set b [format {A test %s} string]}
|
||||
test history-1.9 {event option} {catch {history event 123 456} msg} 1
|
||||
test history-1.10 {event option} {
|
||||
catch {history event 123 456} msg
|
||||
set msg
|
||||
} {wrong # args: should be "history event ?event?"}
|
||||
|
||||
# "history redo"
|
||||
|
||||
set a 0
|
||||
history redo -2
|
||||
test history-2.1 {redo option} {set a} 12345
|
||||
set b 0
|
||||
history redo
|
||||
test history-2.2 {redo option} {set b} {A test string}
|
||||
test history-2.3 {redo option} {catch {history redo -3 -4}} 1
|
||||
test history-2.4 {redo option} {
|
||||
catch {history redo -3 -4} msg
|
||||
set msg
|
||||
} {wrong # args: should be "history redo ?event?"}
|
||||
|
||||
# "history add"
|
||||
|
||||
history add "set a 444" exec
|
||||
test history-3.1 {add option} {set a} 444
|
||||
test history-3.2 {add option} {catch {history add "set a 444" execGorp}} 1
|
||||
test history-3.3 {add option} {
|
||||
catch {history add "set a 444" execGorp} msg
|
||||
set msg
|
||||
} {bad argument "execGorp": should be "exec"}
|
||||
test history-3.4 {add option} {catch {history add "set a 444" a} msg} 1
|
||||
test history-3.5 {add option} {
|
||||
catch {history add "set a 444" a} msg
|
||||
set msg
|
||||
} {bad argument "a": should be "exec"}
|
||||
history add "set a 555" e
|
||||
test history-3.6 {add option} {set a} 555
|
||||
history add "set a 666"
|
||||
test history-3.7 {add option} {set a} 555
|
||||
test history-3.8 {add option} {catch {history add "set a 666" e f} msg} 1
|
||||
test history-3.9 {add option} {
|
||||
catch {history add "set a 666" e f} msg
|
||||
set msg
|
||||
} {wrong # args: should be "history add event ?exec?"}
|
||||
|
||||
# "history change"
|
||||
|
||||
history change "A test value"
|
||||
test history-4.1 {change option} {history event [expr {[history n]-1}]} \
|
||||
"A test value"
|
||||
history c "Another test" -1
|
||||
test history-4.2 {change option} {history e} "Another test"
|
||||
test history-4.3 {change option} {history event [expr {[history n]-1}]} \
|
||||
"A test value"
|
||||
test history-4.4 {change option} {catch {history change Foo 4 10}} 1
|
||||
test history-4.5 {change option} {
|
||||
catch {history change Foo 4 10} msg
|
||||
set msg
|
||||
} {wrong # args: should be "history change newValue ?event?"}
|
||||
test history-4.6 {change option} {
|
||||
catch {history change Foo [expr {[history n]-4}]}
|
||||
} 1
|
||||
test history-4.7 {change option} {
|
||||
catch {history change Foo [expr {[history n]-4}]}
|
||||
set msg
|
||||
} {wrong # args: should be "history change newValue ?event?"}
|
||||
|
||||
# "history info"
|
||||
|
||||
set num [history n]
|
||||
history add set\ a\ {b\nc\ d\ e}
|
||||
history add {set b 1234}
|
||||
history add set\ c\ {a\nb\nc}
|
||||
test history-5.1 {info option} {history info} [format {%6d set a {b
|
||||
c d e}
|
||||
%6d set b 1234
|
||||
%6d set c {a
|
||||
b
|
||||
c}} $num [expr $num+1] [expr $num+2]]
|
||||
test history-5.2 {info option} {history i 2} [format {%6d set b 1234
|
||||
%6d set c {a
|
||||
b
|
||||
c}} [expr $num+1] [expr $num+2]]
|
||||
test history-5.3 {info option} {catch {history i 2 3}} 1
|
||||
test history-5.4 {info option} {
|
||||
catch {history i 2 3} msg
|
||||
set msg
|
||||
} {wrong # args: should be "history info ?count?"}
|
||||
test history-5.5 {info option} {history} [format {%6d set a {b
|
||||
c d e}
|
||||
%6d set b 1234
|
||||
%6d set c {a
|
||||
b
|
||||
c}} $num [expr $num+1] [expr $num+2]]
|
||||
|
||||
# "history keep"
|
||||
|
||||
history add "foo1"
|
||||
history add "foo2"
|
||||
history add "foo3"
|
||||
history keep 2
|
||||
test history-6.1 {keep option} {history event [expr [history n]-1]} foo3
|
||||
test history-6.2 {keep option} {history event -1} foo2
|
||||
test history-6.3 {keep option} {catch {history event -3}} 1
|
||||
test history-6.4 {keep option} {
|
||||
catch {history event -3} msg
|
||||
set msg
|
||||
} {event "-3" is too far in the past}
|
||||
history k 5
|
||||
test history-6.5 {keep option} {history event -1} foo2
|
||||
test history-6.6 {keep option} {history event -2} {}
|
||||
test history-6.7 {keep option} {history event -3} {}
|
||||
test history-6.8 {keep option} {history event -4} {}
|
||||
test history-6.9 {keep option} {catch {history event -5}} 1
|
||||
test history-6.10 {keep option} {catch {history keep 4 6}} 1
|
||||
test history-6.11 {keep option} {
|
||||
catch {history keep 4 6} msg
|
||||
set msg
|
||||
} {wrong # args: should be "history keep number"}
|
||||
test history-6.12 {keep option} {catch {history keep}} 1
|
||||
test history-6.13 {keep option} {
|
||||
catch {history keep} msg
|
||||
set msg
|
||||
} {wrong # args: should be "history keep number"}
|
||||
test history-6.14 {keep option} {catch {history keep -3}} 1
|
||||
test history-6.15 {keep option} {
|
||||
catch {history keep -3} msg
|
||||
set msg
|
||||
} {illegal keep count "-3"}
|
||||
|
||||
# "history nextid"
|
||||
|
||||
set num [history n]
|
||||
history add "Testing"
|
||||
history add "Testing2"
|
||||
test history-7.1 {nextid option} {history event} "Testing"
|
||||
test history-7.2 {nextid option} {history next} [expr $num+2]
|
||||
test history-7.3 {nextid option} {catch {history nextid garbage}} 1
|
||||
test history-7.4 {nextid option} {
|
||||
catch {history nextid garbage} msg
|
||||
set msg
|
||||
} {wrong # args: should be "history nextid"}
|
||||
|
||||
# "history substitute"
|
||||
|
||||
test history-8.1 {substitute option} {
|
||||
history add "set a {test foo test b c test}"
|
||||
history add "Test command 2"
|
||||
set a 0
|
||||
history substitute foo bar -1
|
||||
set a
|
||||
} {test bar test b c test}
|
||||
test history-8.2 {substitute option} {
|
||||
history add "set a {test foo test b c test}"
|
||||
history add "Test command 2"
|
||||
set a 0
|
||||
history substitute test gorp
|
||||
set a
|
||||
} {gorp foo gorp b c gorp}
|
||||
test history-8.3 {substitute option} {
|
||||
history add "set a {test foo test b c test}"
|
||||
history add "Test command 2"
|
||||
set a 0
|
||||
history sub " te" to
|
||||
set a
|
||||
} {test footost b ctost}
|
||||
test history-8.4 {substitute option} {catch {history sub xxx yyy}} 1
|
||||
test history-8.5 {substitute option} {
|
||||
catch {history sub xxx yyy} msg
|
||||
set msg
|
||||
} {"xxx" doesn't appear in event}
|
||||
test history-8.6 {substitute option} {catch {history s a b -10}} 1
|
||||
test history-8.7 {substitute option} {
|
||||
catch {history s a b -10} msg
|
||||
set msg
|
||||
} {event "-10" is too far in the past}
|
||||
test history-8.8 {substitute option} {catch {history s a b -1 20}} 1
|
||||
test history-8.9 {substitute option} {
|
||||
catch {history s a b -1 20} msg
|
||||
set msg
|
||||
} {wrong # args: should be "history substitute old new ?event?"}
|
||||
|
||||
# "history words"
|
||||
|
||||
test history-9.1 {words option} {
|
||||
history add {word0 word1 word2 a b c word6}
|
||||
history add foo
|
||||
history words 0-$
|
||||
} {word0 word1 word2 a b c word6}
|
||||
test history-9.2 {words option} {
|
||||
history add {word0 word1 word2 a b c word6}
|
||||
history add foo
|
||||
history w 2 -1
|
||||
} word2
|
||||
test history-9.3 {words option} {
|
||||
history add {word0 word1 word2 a b c word6}
|
||||
history add foo
|
||||
history wo $
|
||||
} word6
|
||||
test history-9.4 {words option} {catch {history w 1--1} msg} 1
|
||||
test history-9.5 {words option} {
|
||||
catch {history w 1--1} msg
|
||||
set msg
|
||||
} {bad word selector "1--1": should be num-num or pattern}
|
||||
test history-9.6 {words option} {
|
||||
history add {word0 word1 word2 a b c word6}
|
||||
history add foo
|
||||
history w w
|
||||
} {}
|
||||
test history-9.7 {words option} {
|
||||
history add {word0 word1 word2 a b c word6}
|
||||
history add foo
|
||||
history w *2
|
||||
} word2
|
||||
test history-9.8 {words option} {
|
||||
history add {word0 word1 word2 a b c word6}
|
||||
history add foo
|
||||
history w *or*
|
||||
} {word0 word1 word2 word6}
|
||||
test history-9.9 {words option} {catch {history words 10}} 1
|
||||
test history-9.10 {words option} {
|
||||
catch {history words 10} msg
|
||||
set msg
|
||||
} {word selector "10" specified non-existent words}
|
||||
test history-9.11 {words option} {catch {history words 1 -1 20}} 1
|
||||
test history-9.12 {words option} {
|
||||
catch {history words 1 -1 20} msg
|
||||
set msg
|
||||
} {wrong # args: should be "history words num-num/pat ?event?"}
|
||||
|
||||
# history revision
|
||||
|
||||
test history-10.1 {history revision} {
|
||||
set a 0
|
||||
history a {set a 12345}
|
||||
history a {set a [history e]} exec
|
||||
set a
|
||||
} {set a 12345}
|
||||
test history-10.2 {history revision} {
|
||||
set a 0
|
||||
history a {set a 12345}
|
||||
history a {set a [history e]} exec
|
||||
history a foo
|
||||
history ev -1
|
||||
} {set a {set a 12345}}
|
||||
test history-10.3 {history revision} {
|
||||
set a 0
|
||||
history a {set a 12345}
|
||||
history a {set a [history e]} exec
|
||||
history a foo
|
||||
history a {history r -2} exec
|
||||
history a {set a 12345}
|
||||
history ev -1
|
||||
} {set a {set a 12345}}
|
||||
test history-10.4 {history revision} {
|
||||
history a {set a 12345}
|
||||
history a {history s 123 999} exec
|
||||
history a foo
|
||||
history ev -1
|
||||
} {set a 99945}
|
||||
test history-10.5 {history revision} {
|
||||
history add {word0 word1 word2 a b c word6}
|
||||
history add {set [history w 3] [list [history w 0] [history w {[ab]}]]} exec
|
||||
set a
|
||||
} {word0 {a b}}
|
||||
test history-10.6 {history revision} {
|
||||
history add {word0 word1 word2 a b c word6}
|
||||
history add {set [history w 3] [list [history w 0] [history w {[ab]}]]} exec
|
||||
history add foo
|
||||
history ev
|
||||
} {set a [list word0 {a b}]}
|
||||
test history-10.7 {history revision} {
|
||||
history add {word0 word1 word2 a b c word6}
|
||||
history add {set [history w 3] [list [history w 0] [history w {[ab]}]]} exec
|
||||
history add {format b}
|
||||
history add {word0 word1 word2 a b c word6}
|
||||
set a 0
|
||||
history add {set [history subs b a -2] [list abc [history r -2] [history w 1-3]]} exec
|
||||
history add foo
|
||||
history ev
|
||||
} {set [format a] [list abc [format b] {word1 word2 a}]}
|
||||
test history-10.8 {history revision} {
|
||||
history add {set a 12345}
|
||||
concat a b c
|
||||
history add {history redo; set b 44} exec
|
||||
history add foo
|
||||
history ev
|
||||
} {set a 12345; set b 44}
|
||||
test history-10.9 {history revision} {
|
||||
history add {set a 12345}
|
||||
history add {history redo; history change "A simple test"; history subs 45 xx} exec
|
||||
set a
|
||||
} 123xx
|
||||
test history-10.10 {history revision} {
|
||||
history add {set a 12345}
|
||||
history add {history redo; history change "A simple test"; history subs 45 xx} exec
|
||||
history add foo
|
||||
history e
|
||||
} {A simple test}
|
||||
test history-10.11 {history revision} {
|
||||
history add {word0 word1 $ a b c word6}
|
||||
history add {set a [history w 4-[history word 2]]} exec
|
||||
set a
|
||||
} {b c word6}
|
||||
test history-10.12 {history revision} {
|
||||
history add {word0 word1 $ a b c word6}
|
||||
history add {set a [history w 4-[history word 2]]} exec
|
||||
history add foo
|
||||
history e
|
||||
} {set a {b c word6}}
|
||||
test history-10.13 {history revision} {
|
||||
history add {history word 0} exec
|
||||
history add foo
|
||||
history e
|
||||
} {history word 0}
|
||||
test history-10.14 {history revision} {
|
||||
history add {set a [history word 0; format c]} exec
|
||||
history add foo
|
||||
history e
|
||||
} {set a [history word 0; format c]}
|
||||
test history-10.15 {history revision even when nested} {
|
||||
proc x {a b} {history word $a $b}
|
||||
history add {word1 word2 word3 word4}
|
||||
history add {set a [x 1-3 -1]} exec
|
||||
history add foo
|
||||
history e
|
||||
} {set a {word2 word3 word4}}
|
||||
test history-10.16 {disable history revision in nested history evals} {
|
||||
history add {word1 word2 word3 word4}
|
||||
history add {set a [history words 0]; history add foo; set a [history words 0]} exec
|
||||
history e
|
||||
} {set a word1; history add foo; set a [history words 0]}
|
||||
|
||||
# miscellaneous
|
||||
|
||||
test history-11.1 {miscellaneous} {catch {history gorp} msg} 1
|
||||
test history-11.2 {miscellaneous} {
|
||||
catch {history gorp} msg
|
||||
set msg
|
||||
} {bad option "gorp": must be add, change, event, info, keep, nextid, redo, substitute, or words}
|
||||
162
tcl7.3/tests/if.test
Normal file
162
tcl7.3/tests/if.test
Normal file
@@ -0,0 +1,162 @@
|
||||
# Commands covered: if
|
||||
#
|
||||
# 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.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/if.test,v 1.5 93/02/06 15:54:17 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
test if-1.1 {taking proper branch} {
|
||||
set a {}
|
||||
if 0 {set a 1} else {set a 2}
|
||||
set a
|
||||
} 2
|
||||
test if-1.2 {taking proper branch} {
|
||||
set a {}
|
||||
if 1 {set a 1} else {set a 2}
|
||||
set a
|
||||
} 1
|
||||
test if-1.3 {taking proper branch} {
|
||||
set a {}
|
||||
if 1<2 {set a 1}
|
||||
set a
|
||||
} 1
|
||||
test if-1.4 {taking proper branch} {
|
||||
set a {}
|
||||
if 1>2 {set a 1}
|
||||
set a
|
||||
} {}
|
||||
test if-1.5 {taking proper branch} {
|
||||
set a {}
|
||||
if 0 {set a 1} else {}
|
||||
set a
|
||||
} {}
|
||||
test if-1.5 {taking proper branch} {
|
||||
set a {}
|
||||
if 0 {set a 1} elseif 1 {set a 2} elseif 1 {set a 3} else {set a 4}
|
||||
set a
|
||||
} {2}
|
||||
test if-1.6 {taking proper branch} {
|
||||
set a {}
|
||||
if 0 {set a 1} elseif 0 {set a 2} elseif 1 {set a 3} else {set a 4}
|
||||
set a
|
||||
} {3}
|
||||
test if-1.7 {taking proper branch} {
|
||||
set a {}
|
||||
if 0 {set a 1} elseif 0 {set a 2} elseif 0 {set a 3} else {set a 4}
|
||||
set a
|
||||
} {4}
|
||||
|
||||
|
||||
test if-2.1 {optional then-else args} {
|
||||
set a 44
|
||||
if 0 then {set a 1} elseif 0 then {set a 3} else {set a 2}
|
||||
set a
|
||||
} 2
|
||||
test if-2.2 {optional then-else args} {
|
||||
set a 44
|
||||
if 1 then {set a 1} else {set a 2}
|
||||
set a
|
||||
} 1
|
||||
test if-2.3 {optional then-else args} {
|
||||
set a 44
|
||||
if 0 {set a 1} else {set a 2}
|
||||
set a
|
||||
} 2
|
||||
test if-2.4 {optional then-else args} {
|
||||
set a 44
|
||||
if 1 {set a 1} else {set a 2}
|
||||
set a
|
||||
} 1
|
||||
test if-2.5 {optional then-else args} {
|
||||
set a 44
|
||||
if 0 then {set a 1} {set a 2}
|
||||
set a
|
||||
} 2
|
||||
test if-2.6 {optional then-else args} {
|
||||
set a 44
|
||||
if 1 then {set a 1} {set a 2}
|
||||
set a
|
||||
} 1
|
||||
test if-2.7 {optional then-else args} {
|
||||
set a 44
|
||||
if 0 then {set a 1} else {set a 2}
|
||||
set a
|
||||
} 2
|
||||
test if-2.8 {optional then-else args} {
|
||||
set a 44
|
||||
if 0 then {set a 1} elseif 0 {set a 2} elseif 0 {set a 3} {set a 4}
|
||||
set a
|
||||
} 4
|
||||
|
||||
test if-3.1 {return value} {
|
||||
if 1 then {set a 22; concat abc}
|
||||
} abc
|
||||
test if-3.2 {return value} {
|
||||
if 0 then {set a 22; concat abc} elseif 1 {concat def} {concat ghi}
|
||||
} def
|
||||
test if-3.3 {return value} {
|
||||
if 0 then {set a 22; concat abc} else {concat def}
|
||||
} def
|
||||
test if-3.4 {return value} {
|
||||
if 0 then {set a 22; concat abc}
|
||||
} {}
|
||||
test if-3.5 {return value} {
|
||||
if 0 then {set a 22; concat abc} elseif 0 {concat def}
|
||||
} {}
|
||||
|
||||
test if-4.1 {error conditions} {
|
||||
list [catch {if} msg] $msg
|
||||
} {1 {wrong # args: no expression after "if" argument}}
|
||||
test if-4.2 {error conditions} {
|
||||
list [catch {if {[error "error in condition"]}} msg] $msg
|
||||
} {1 {error in condition}}
|
||||
test if-4.3 {error conditions} {
|
||||
list [catch {if 2} msg] $msg
|
||||
} {1 {wrong # args: no script following "2" argument}}
|
||||
test if-4.4 {error conditions} {
|
||||
list [catch {if 2 then} msg] $msg
|
||||
} {1 {wrong # args: no script following "then" argument}}
|
||||
test if-4.5 {error conditions} {
|
||||
list [catch {if 2 the} msg] $msg
|
||||
} {1 {invalid command name: "the"}}
|
||||
test if-4.6 {error conditions} {
|
||||
list [catch {if 2 then {[error "error in then clause"]}} msg] $msg
|
||||
} {1 {error in then clause}}
|
||||
test if-4.7 {error conditions} {
|
||||
list [catch {if 0 then foo elseif} msg] $msg
|
||||
} {1 {wrong # args: no expression after "elseif" argument}}
|
||||
test if-4.8 {error conditions} {
|
||||
list [catch {if 0 then foo elsei} msg] $msg
|
||||
} {1 {invalid command name: "elsei"}}
|
||||
test if-4.9 {error conditions} {
|
||||
list [catch {if 0 then foo elseif 0 bar else} msg] $msg
|
||||
} {1 {wrong # args: no script following "else" argument}}
|
||||
test if-4.10 {error conditions} {
|
||||
list [catch {if 0 then foo elseif 0 bar els} msg] $msg
|
||||
} {1 {invalid command name: "els"}}
|
||||
test if-4.11 {error conditions} {
|
||||
list [catch {if 0 then foo elseif 0 bar else {[error "error in else clause"]}} msg] $msg
|
||||
} {1 {error in else clause}}
|
||||
86
tcl7.3/tests/incr.test
Normal file
86
tcl7.3/tests/incr.test
Normal file
@@ -0,0 +1,86 @@
|
||||
# Commands covered: lreplace
|
||||
#
|
||||
# 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.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/incr.test,v 1.5 93/07/12 11:34:43 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
catch {unset x}
|
||||
|
||||
test incr-1.1 {basic incr operation} {
|
||||
set x 23
|
||||
list [incr x] $x
|
||||
} {24 24}
|
||||
test incr-1.2 {basic incr operation} {
|
||||
set x 106
|
||||
list [incr x -5] $x
|
||||
} {101 101}
|
||||
test incr-1.3 {basic incr operation} {
|
||||
set x " -106"
|
||||
list [incr x 1] $x
|
||||
} {-105 -105}
|
||||
test incr-1.3 {basic incr operation} {
|
||||
set x " +106"
|
||||
list [incr x 1] $x
|
||||
} {107 107}
|
||||
|
||||
test incr-2.1 {incr errors} {
|
||||
list [catch incr msg] $msg
|
||||
} {1 {wrong # args: should be "incr varName ?increment?"}}
|
||||
test incr-2.2 {incr errors} {
|
||||
list [catch {incr a b c} msg] $msg
|
||||
} {1 {wrong # args: should be "incr varName ?increment?"}}
|
||||
test incr-2.3 {incr errors} {
|
||||
catch {unset x}
|
||||
list [catch {incr x} msg] $msg $errorInfo
|
||||
} {1 {can't read "x": no such variable} {can't read "x": no such variable
|
||||
while executing
|
||||
"incr x"}}
|
||||
test incr-2.4 {incr errors} {
|
||||
set x abc
|
||||
list [catch {incr x} msg] $msg $errorInfo
|
||||
} {1 {expected integer but got "abc"} {expected integer but got "abc"
|
||||
(reading value of variable to increment)
|
||||
invoked from within
|
||||
"incr x"}}
|
||||
test incr-2.5 {incr errors} {
|
||||
set x 123
|
||||
list [catch {incr x 1a} msg] $msg $errorInfo
|
||||
} {1 {expected integer but got "1a"} {expected integer but got "1a"
|
||||
(reading increment)
|
||||
invoked from within
|
||||
"incr x 1a"}}
|
||||
test incr-2.6 {incr errors} {
|
||||
proc readonly args {error "variable is read-only"}
|
||||
set x 123
|
||||
trace var x w readonly
|
||||
list [catch {incr x 1} msg] $msg $errorInfo
|
||||
} {1 {can't set "x": variable is read-only} {can't set "x": variable is read-only
|
||||
while executing
|
||||
"incr x 1"}}
|
||||
|
||||
catch {unset x}
|
||||
concat {}
|
||||
524
tcl7.3/tests/info.test
Normal file
524
tcl7.3/tests/info.test
Normal file
@@ -0,0 +1,524 @@
|
||||
# Commands covered: info
|
||||
#
|
||||
# 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.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/info.test,v 1.17 93/10/13 13:02:02 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
test info-1.1 {info args option} {
|
||||
proc t1 {a bbb c} {return foo}
|
||||
info args t1
|
||||
} {a bbb c}
|
||||
test info-1.2 {info args option} {
|
||||
proc t1 {{a default1} {bbb default2} {c default3} args} {return foo}
|
||||
info a t1
|
||||
} {a bbb c args}
|
||||
test info-1.3 {info args option} {
|
||||
proc t1 "" {return foo}
|
||||
info args t1
|
||||
} {}
|
||||
test info-1.4 {info args option} {
|
||||
catch {rename t1 {}}
|
||||
list [catch {info args t1} msg] $msg
|
||||
} {1 {"t1" isn't a procedure}}
|
||||
test info-1.5 {info args option} {
|
||||
list [catch {info args set} msg] $msg
|
||||
} {1 {"set" isn't a procedure}}
|
||||
|
||||
test info-2.1 {info body option} {
|
||||
proc t1 {} {body of t1}
|
||||
info body t1
|
||||
} {body of t1}
|
||||
test info-2.2 {info body option} {
|
||||
list [catch {info body set} msg] $msg
|
||||
} {1 {"set" isn't a procedure}}
|
||||
test info-2.3 {info body option} {
|
||||
list [catch {info args set 1} msg] $msg
|
||||
} {1 {wrong # args: should be "info args procname"}}
|
||||
|
||||
test info-3.1 {info cmdcount option} {
|
||||
set x [info cmdcount]
|
||||
set y 12345
|
||||
set z [info cm]
|
||||
expr $z-$x
|
||||
} 3
|
||||
test info-3.2 {info body option} {
|
||||
list [catch {info cmdcount 1} msg] $msg
|
||||
} {1 {wrong # args: should be "info cmdcount"}}
|
||||
|
||||
test info-4.1 {info commands option} {
|
||||
proc t1 {} {}
|
||||
proc t2 {} {}
|
||||
set x " [info commands] "
|
||||
list [string match {* t1 *} $x] [string match {* t2 *} $x] \
|
||||
[string match {* set *} $x] [string match {* list *} $x]
|
||||
} {1 1 1 1}
|
||||
test info-4.2 {info commands option} {
|
||||
proc t1 {} {}
|
||||
rename t1 {}
|
||||
set x [info comm]
|
||||
string match {* t1 *} $x
|
||||
} 0
|
||||
test info-4.3 {info commands option} {
|
||||
proc _t1_ {} {}
|
||||
proc _t2_ {} {}
|
||||
info commands _t1_
|
||||
} _t1_
|
||||
test info-4.4 {info commands option} {
|
||||
proc _t1_ {} {}
|
||||
proc _t2_ {} {}
|
||||
lsort [info commands _t*]
|
||||
} {_t1_ _t2_}
|
||||
catch {rename _t1_ {}}
|
||||
catch {rename _t2_ {}}
|
||||
test info-4.5 {info commands option} {
|
||||
list [catch {info commands a b} msg] $msg
|
||||
} {1 {wrong # args: should be "info commands [pattern]"}}
|
||||
|
||||
test info-5.1 {info complete option} {
|
||||
info complete ""
|
||||
} 1
|
||||
test info-5.2 {info complete option} {
|
||||
info complete " \n"
|
||||
} 1
|
||||
test info-5.3 {info complete option} {
|
||||
info complete "abc def"
|
||||
} 1
|
||||
test info-5.4 {info complete option} {
|
||||
info complete "a b c d e f \t\n"
|
||||
} 1
|
||||
test info-5.5 {info complete option} {
|
||||
info complete {a b c"d}
|
||||
} 1
|
||||
test info-5.6 {info complete option} {
|
||||
info complete {a b "c d" e}
|
||||
} 1
|
||||
test info-5.7 {info complete option} {
|
||||
info complete {a b "c d"}
|
||||
} 1
|
||||
test info-5.8 {info complete option} {
|
||||
info complete {a b "c d"}
|
||||
} 1
|
||||
test info-5.9 {info complete option} {
|
||||
info complete {a b "c d}
|
||||
} 0
|
||||
test info-5.10 {info complete option} {
|
||||
info complete {a b "}
|
||||
} 0
|
||||
test info-5.11 {info complete option} {
|
||||
info complete {a b "cd"xyz}
|
||||
} 1
|
||||
test info-5.12 {info complete option} {
|
||||
info complete {a b "c $d() d"}
|
||||
} 1
|
||||
test info-5.13 {info complete option} {
|
||||
info complete {a b "c $dd("}
|
||||
} 0
|
||||
test info-5.14 {info complete option} {
|
||||
info complete {a b "c \"}
|
||||
} 0
|
||||
test info-5.15 {info complete option} {
|
||||
info complete {a b "c [d e f]"}
|
||||
} 1
|
||||
test info-5.16 {info complete option} {
|
||||
info complete {a b "c [d e f] g"}
|
||||
} 1
|
||||
test info-5.17 {info complete option} {
|
||||
info complete {a b "c [d e f"}
|
||||
} 0
|
||||
test info-5.18 {info complete option} {
|
||||
info complete {a {b c d} e}
|
||||
} 1
|
||||
test info-5.19 {info complete option} {
|
||||
info complete {a {b c d}}
|
||||
} 1
|
||||
test info-5.20 {info complete option} {
|
||||
info complete "a b\{c d"
|
||||
} 1
|
||||
test info-5.21 {info complete option} {
|
||||
info complete "a b \{c"
|
||||
} 0
|
||||
test info-5.22 {info complete option} {
|
||||
info complete "a b \{c{ }"
|
||||
} 0
|
||||
test info-5.23 {info complete option} {
|
||||
info complete "a b {c d e}xxx"
|
||||
} 1
|
||||
test info-5.24 {info complete option} {
|
||||
info complete "a b {c \\\{d e}xxx"
|
||||
} 1
|
||||
test info-5.25 {info complete option} {
|
||||
info complete {a b [ab cd ef]}
|
||||
} 1
|
||||
test info-5.26 {info complete option} {
|
||||
info complete {a b x[ab][cd][ef] gh}
|
||||
} 1
|
||||
test info-5.27 {info complete option} {
|
||||
info complete {a b x[ab][cd[ef] gh}
|
||||
} 0
|
||||
test info-5.28 {info complete option} {
|
||||
info complete {a b x[ gh}
|
||||
} 0
|
||||
test info-5.29 {info complete option} {
|
||||
info complete {[]]]}
|
||||
} 1
|
||||
test info-5.30 {info complete option} {
|
||||
info complete {abc x$yyy}
|
||||
} 1
|
||||
test info-5.31 {info complete option} {
|
||||
info complete "abc x\${abc\[\\d} xyz"
|
||||
} 1
|
||||
test info-5.32 {info complete option} {
|
||||
info complete "abc x\$\{ xyz"
|
||||
} 0
|
||||
test info-5.33 {info complete option} {
|
||||
info complete {word $a(xyz)}
|
||||
} 1
|
||||
test info-5.34 {info complete option} {
|
||||
info complete {word $a(}
|
||||
} 0
|
||||
test info-5.35 {info complete option} {
|
||||
info complete "set a \\\n"
|
||||
} 0
|
||||
test info-5.36 {info complete option} {
|
||||
info complete "set a \\n "
|
||||
} 1
|
||||
test info-5.37 {info complete option} {
|
||||
info complete "set a \\"
|
||||
} 1
|
||||
test info-5.38 {info complete option} {
|
||||
info complete "foo \\\n\{"
|
||||
} 0
|
||||
test info-5.39 {info complete option} {
|
||||
info complete " # \{"
|
||||
} 1
|
||||
test info-5.40 {info complete option} {
|
||||
info complete "foo bar;# \{"
|
||||
} 1
|
||||
test info-5.41 {info complete option} {
|
||||
info complete "a\nb\n# \{\n# \{\nc\n"
|
||||
} 1
|
||||
|
||||
test info-6.1 {info default option} {
|
||||
proc t1 {a b {c d} {e "long default value"}} {}
|
||||
info default t1 a value
|
||||
} 0
|
||||
test info-6.2 {info default option} {
|
||||
proc t1 {a b {c d} {e "long default value"}} {}
|
||||
set value 12345
|
||||
info d t1 a value
|
||||
set value
|
||||
} {}
|
||||
test info-6.3 {info default option} {
|
||||
proc t1 {a b {c d} {e "long default value"}} {}
|
||||
info default t1 c value
|
||||
} 1
|
||||
test info-6.4 {info default option} {
|
||||
proc t1 {a b {c d} {e "long default value"}} {}
|
||||
set value 12345
|
||||
info default t1 c value
|
||||
set value
|
||||
} d
|
||||
test info-6.5 {info default option} {
|
||||
proc t1 {a b {c d} {e "long default value"}} {}
|
||||
set value 12345
|
||||
set x [info default t1 e value]
|
||||
list $x $value
|
||||
} {1 {long default value}}
|
||||
test info-6.6 {info default option} {
|
||||
list [catch {info default a b} msg] $msg
|
||||
} {1 {wrong # args: should be "info default procname arg varname"}}
|
||||
test info-6.7 {info default option} {
|
||||
list [catch {info default _nonexistent_ a b} msg] $msg
|
||||
} {1 {"_nonexistent_" isn't a procedure}}
|
||||
test info-6.8 {info default option} {
|
||||
proc t1 {a b} {}
|
||||
list [catch {info default t1 x value} msg] $msg
|
||||
} {1 {procedure "t1" doesn't have an argument "x"}}
|
||||
test info-6.9 {info default option} {
|
||||
catch {unset a}
|
||||
set a(0) 88
|
||||
proc t1 {a b} {}
|
||||
list [catch {info default t1 a a} msg] $msg
|
||||
} {1 {couldn't store default value in variable "a"}}
|
||||
test info-6.10 {info default option} {
|
||||
catch {unset a}
|
||||
set a(0) 88
|
||||
proc t1 {{a 18} b} {}
|
||||
list [catch {info default t1 a a} msg] $msg
|
||||
} {1 {couldn't store default value in variable "a"}}
|
||||
catch {unset a}
|
||||
|
||||
test info-7.1 {info exists option} {
|
||||
set value foo
|
||||
info exists value
|
||||
} 1
|
||||
catch {unset _nonexistent_}
|
||||
test info-7.2 {info exists option} {
|
||||
info exists _nonexistent_
|
||||
} 0
|
||||
test info-7.3 {info exists option} {
|
||||
proc t1 {x} {return [info exists x]}
|
||||
t1 2
|
||||
} 1
|
||||
test info-7.4 {info exists option} {
|
||||
proc t1 {x} {
|
||||
global _nonexistent_
|
||||
return [info exists _nonexistent_]
|
||||
}
|
||||
t1 2
|
||||
} 0
|
||||
test info-7.5 {info exists option} {
|
||||
proc t1 {x} {
|
||||
set y 47
|
||||
return [info exists y]
|
||||
}
|
||||
t1 2
|
||||
} 1
|
||||
test info-7.6 {info exists option} {
|
||||
proc t1 {x} {return [info exists value]}
|
||||
t1 2
|
||||
} 0
|
||||
test info-7.7 {info exists option} {
|
||||
catch {unset x}
|
||||
set x(2) 44
|
||||
list [info exists x] [info exists x(1)] [info exists x(2)]
|
||||
} {1 0 1}
|
||||
catch {unset x}
|
||||
test info-7.8 {info exists option} {
|
||||
list [catch {info exists} msg] $msg
|
||||
} {1 {wrong # args: should be "info exists varName"}}
|
||||
test info-7.9 {info exists option} {
|
||||
list [catch {info exists 1 2} msg] $msg
|
||||
} {1 {wrong # args: should be "info exists varName"}}
|
||||
|
||||
test info-8.1 {info globals option} {
|
||||
set x 1
|
||||
set y 2
|
||||
set value 23
|
||||
set a " [info globals] "
|
||||
list [string match {* x *} $a] [string match {* y *} $a] \
|
||||
[string match {* value *} $a] [string match {* _foobar_ *} $a]
|
||||
} {1 1 1 0}
|
||||
test info-8.2 {info globals option} {
|
||||
set _xxx1 1
|
||||
set _xxx2 2
|
||||
lsort [info g _xxx*]
|
||||
} {_xxx1 _xxx2}
|
||||
test info-8.3 {info globals option} {
|
||||
list [catch {info globals 1 2} msg] $msg
|
||||
} {1 {wrong # args: should be "info globals [pattern]"}}
|
||||
|
||||
test info-9.1 {info level option} {
|
||||
info level
|
||||
} 0
|
||||
test info-9.2 {info level option} {
|
||||
proc t1 {a b} {
|
||||
set x [info le]
|
||||
set y [info level 1]
|
||||
list $x $y
|
||||
}
|
||||
t1 146 testString
|
||||
} {1 {t1 146 testString}}
|
||||
test info-9.3 {info level option} {
|
||||
proc t1 {a b} {
|
||||
t2 [expr $a*2] $b
|
||||
}
|
||||
proc t2 {x y} {
|
||||
list [info level] [info level 1] [info level 2] [info level -1] \
|
||||
[info level 0]
|
||||
}
|
||||
t1 146 {a {b c} {{{c}}}}
|
||||
} {2 {t1 146 {a {b c} {{{c}}}}} {t2 292 {a {b c} {{{c}}}}} {t1 146 {a {b c} {{{c}}}}} {t2 292 {a {b c} {{{c}}}}}}
|
||||
test info-9.4 {info level option} {
|
||||
proc t1 {} {
|
||||
set x [info level]
|
||||
set y [info level 1]
|
||||
list $x $y
|
||||
}
|
||||
t1
|
||||
} {1 t1}
|
||||
test info-9.5 {info level option} {
|
||||
list [catch {info level 1 2} msg] $msg
|
||||
} {1 {wrong # args: should be "info level [number]"}}
|
||||
test info-9.6 {info level option} {
|
||||
list [catch {info level 123a} msg] $msg
|
||||
} {1 {expected integer but got "123a"}}
|
||||
test info-9.7 {info level option} {
|
||||
list [catch {info level 0} msg] $msg
|
||||
} {1 {bad level "0"}}
|
||||
test info-9.8 {info level option} {
|
||||
proc t1 {} {info level -1}
|
||||
list [catch {t1} msg] $msg
|
||||
} {1 {bad level "-1"}}
|
||||
test info-9.9 {info level option} {
|
||||
proc t1 {x} {info level $x}
|
||||
list [catch {t1 -3} msg] $msg
|
||||
} {1 {bad level "-3"}}
|
||||
|
||||
test info-10.1 {info library option} {
|
||||
list [catch {info library x} msg] $msg
|
||||
} {1 {wrong # args: should be "info library"}}
|
||||
# The following check can only be done at Berkeley, where the exact
|
||||
# location of the library is known.
|
||||
|
||||
if $atBerkeley {
|
||||
test info-10.2 {info library option} {
|
||||
info li
|
||||
} /users/ouster/tcl/library
|
||||
test info-10.3 {info library option} {
|
||||
set env(TCL_LIBRARY) test_value
|
||||
set result [info library]
|
||||
unset env(TCL_LIBRARY)
|
||||
list $result [info library]
|
||||
} {test_value /users/ouster/tcl/library}
|
||||
}
|
||||
|
||||
test info-11.1 {info locals option} {
|
||||
set a 22
|
||||
proc t1 {x y} {
|
||||
set b 13
|
||||
set c testing
|
||||
global a
|
||||
return [info locals]
|
||||
}
|
||||
lsort [t1 23 24]
|
||||
} {b c x y}
|
||||
test info-11.2 {info locals option} {
|
||||
proc t1 {x y} {
|
||||
set xx1 2
|
||||
set xx2 3
|
||||
set y 4
|
||||
return [info lo x*]
|
||||
}
|
||||
lsort [t1 2 3]
|
||||
} {x xx1 xx2}
|
||||
test info-11.3 {info locals option} {
|
||||
list [catch {info locals 1 2} msg] $msg
|
||||
} {1 {wrong # args: should be "info locals [pattern]"}}
|
||||
test info-11.4 {info locals option} {
|
||||
info locals
|
||||
} {}
|
||||
test info-11.5 {info locals option} {
|
||||
proc t1 {} {return [info locals]}
|
||||
t1
|
||||
} {}
|
||||
|
||||
test info-12.1 {info patchlevel option} {
|
||||
set a [info patchlevel]
|
||||
incr a 2
|
||||
expr $a-[info patchlevel]
|
||||
} 2
|
||||
test info-12.2 {info patchlevel option} {
|
||||
list [catch {info patchlevel a} msg] $msg
|
||||
} {1 {wrong # args: should be "info patchlevel"}}
|
||||
|
||||
test info-13.1 {info procs option} {
|
||||
proc t1 {} {}
|
||||
proc t2 {} {}
|
||||
set x " [info procs] "
|
||||
list [string match {* t1 *} $x] [string match {* t2 *} $x] \
|
||||
[string match {* _undefined_ *} $x]
|
||||
} {1 1 0}
|
||||
test info-13.2 {info procs option} {
|
||||
proc _tt1 {} {}
|
||||
proc _tt2 {} {}
|
||||
lsort [info pr _tt*]
|
||||
} {_tt1 _tt2}
|
||||
catch {rename _tt1 {}}
|
||||
catch {rename _tt2 {}}
|
||||
test info-13.3 {info procs option} {
|
||||
list [catch {info procs 2 3} msg] $msg
|
||||
} {1 {wrong # args: should be "info procs [pattern]"}}
|
||||
|
||||
test info-14.1 {info script option} {
|
||||
list [catch {info script x} msg] $msg
|
||||
} {1 {wrong # args: should be "info script"}}
|
||||
test info-14.2 {info script option} {
|
||||
file tail [info s]
|
||||
} info.test
|
||||
catch {exec rm -f gorp.info}
|
||||
exec cat > gorp.info << "info script\n"
|
||||
test info-14.3 {info script option} {
|
||||
list [source gorp.info] [file tail [info script]]
|
||||
} {gorp.info info.test}
|
||||
test info-14.4 {resetting "info script" after errors} {
|
||||
catch {source ~_nobody_/foo}
|
||||
file tail [info script]
|
||||
} {info.test}
|
||||
test info-14.5 {resetting "info script" after errors} {
|
||||
catch {source _nonexistent_}
|
||||
file tail [info script]
|
||||
} {info.test}
|
||||
exec rm -f gorp.info
|
||||
|
||||
test info-15.1 {info tclversion option} {
|
||||
set x [info tclversion]
|
||||
scan $x "%d.%d%c" a b c
|
||||
} 2
|
||||
test info-15.2 {info tclversion option} {
|
||||
list [catch {info t 2} msg] $msg
|
||||
} {1 {wrong # args: should be "info tclversion"}}
|
||||
|
||||
test info-16.1 {info vars option} {
|
||||
set a 1
|
||||
set b 2
|
||||
proc t1 {x y} {
|
||||
global a b
|
||||
set c 33
|
||||
return [info vars]
|
||||
}
|
||||
lsort [t1 18 19]
|
||||
} {a b c x y}
|
||||
test info-16.2 {info vars option} {
|
||||
set xxx1 1
|
||||
set xxx2 2
|
||||
proc t1 {xxa y} {
|
||||
global xxx1 xxx2
|
||||
set c 33
|
||||
return [info vars x*]
|
||||
}
|
||||
lsort [t1 18 19]
|
||||
} {xxa xxx1 xxx2}
|
||||
test info-16.3 {info vars option} {
|
||||
lsort [info vars]
|
||||
} [lsort [info globals]]
|
||||
test info-16.4 {info vars option} {
|
||||
list [catch {info vars a b} msg] $msg
|
||||
} {1 {wrong # args: should be "info vars [pattern]"}}
|
||||
|
||||
test info-17.1 {miscellaneous error conditions} {
|
||||
list [catch {info} msg] $msg
|
||||
} {1 {wrong # args: should be "info option ?arg arg ...?"}}
|
||||
test info-17.2 {miscellaneous error conditions} {
|
||||
list [catch {info gorp} msg] $msg
|
||||
} {1 {bad option "gorp": should be args, body, cmdcount, commands, complete, default, exists, globals, level, library, locals, patchlevel, procs, script, tclversion, or vars}}
|
||||
test info-17.3 {miscellaneous error conditions} {
|
||||
list [catch {info c} msg] $msg
|
||||
} {1 {bad option "c": should be args, body, cmdcount, commands, complete, default, exists, globals, level, library, locals, patchlevel, procs, script, tclversion, or vars}}
|
||||
test info-17.4 {miscellaneous error conditions} {
|
||||
list [catch {info l} msg] $msg
|
||||
} {1 {bad option "l": should be args, body, cmdcount, commands, complete, default, exists, globals, level, library, locals, patchlevel, procs, script, tclversion, or vars}}
|
||||
52
tcl7.3/tests/join.test
Normal file
52
tcl7.3/tests/join.test
Normal file
@@ -0,0 +1,52 @@
|
||||
# Commands covered: join
|
||||
#
|
||||
# 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.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/join.test,v 1.4 93/02/06 16:01:33 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
test join-1.1 {basic join commands} {
|
||||
join {a b c} xyz
|
||||
} axyzbxyzc
|
||||
test join-1.2 {basic join commands} {
|
||||
join {a b c} {}
|
||||
} abc
|
||||
test join-1.3 {basic join commands} {
|
||||
join {} xyz
|
||||
} {}
|
||||
test join-1.4 {basic join commands} {
|
||||
join {12 34 56}
|
||||
} {12 34 56}
|
||||
|
||||
test join-2.1 {join errors} {
|
||||
list [catch join msg] $msg $errorCode
|
||||
} {1 {wrong # args: should be "join list ?joinString?"} NONE}
|
||||
test join-2.2 {join errors} {
|
||||
list [catch {join a b c} msg] $msg $errorCode
|
||||
} {1 {wrong # args: should be "join list ?joinString?"} NONE}
|
||||
test join-2.3 {join errors} {
|
||||
list [catch {join "a \{ c" 111} msg] $msg $errorCode
|
||||
} {1 {unmatched open brace in list} NONE}
|
||||
73
tcl7.3/tests/lindex.test
Normal file
73
tcl7.3/tests/lindex.test
Normal file
@@ -0,0 +1,73 @@
|
||||
# Commands covered: lindex
|
||||
#
|
||||
# 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.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/lindex.test,v 1.2 93/02/06 16:01:45 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
test lindex-1.1 {basic tests} {
|
||||
lindex {a b c} 0} a
|
||||
test lindex-1.2 {basic tests} {
|
||||
lindex {a {b c d} x} 1} {b c d}
|
||||
test lindex-1.3 {basic tests} {
|
||||
lindex {a b\ c\ d x} 1} {b c d}
|
||||
test lindex-1.4 {basic tests} {
|
||||
lindex {a b c} 3} {}
|
||||
test lindex-1.5 {basic tests} {
|
||||
list [catch {lindex {a b c} -1} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
test lindex-2.1 {error conditions} {
|
||||
list [catch {lindex msg} msg] $msg
|
||||
} {1 {wrong # args: should be "lindex list index"}}
|
||||
test lindex-2.2 {error conditions} {
|
||||
list [catch {lindex 1 2 3 4} msg] $msg
|
||||
} {1 {wrong # args: should be "lindex list index"}}
|
||||
test lindex-2.3 {error conditions} {
|
||||
list [catch {lindex 1 2a2} msg] $msg
|
||||
} {1 {expected integer but got "2a2"}}
|
||||
test lindex-2.4 {error conditions} {
|
||||
list [catch {lindex "a \{" 2} msg] $msg
|
||||
} {1 {unmatched open brace in list}}
|
||||
test lindex-2.5 {error conditions} {
|
||||
list [catch {lindex {a {b c}d e} 2} msg] $msg
|
||||
} {1 {list element in braces followed by "d" instead of space}}
|
||||
test lindex-2.6 {error conditions} {
|
||||
list [catch {lindex {a "b c"def ghi} 2} msg] $msg
|
||||
} {1 {list element in quotes followed by "def" instead of space}}
|
||||
|
||||
test lindex-3.1 {quoted elements} {
|
||||
lindex {a "b c" d} 1
|
||||
} {b c}
|
||||
test lindex-3.2 {quoted elements} {
|
||||
lindex {"{}" b c} 0
|
||||
} {{}}
|
||||
test lindex-3.3 {quoted elements} {
|
||||
lindex {ab "c d \" x" y} 1
|
||||
} {c d " x}
|
||||
test lindex-3.4 {quoted elements} {
|
||||
lindex {a b {c d "e} {f g"}} 2
|
||||
} {c d "e}
|
||||
148
tcl7.3/tests/link.test
Normal file
148
tcl7.3/tests/link.test
Normal file
@@ -0,0 +1,148 @@
|
||||
# Commands covered: none
|
||||
#
|
||||
# This file contains a collection of tests for Tcl_LinkVar and related
|
||||
# library procedures. Sourcing this file into Tcl runs the tests and
|
||||
# generates output for errors. No output means no errors were found.
|
||||
#
|
||||
# Copyright (c) 1993 The Regents of the University of California.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/link.test,v 1.5 93/07/28 15:05:32 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[info commands testlink] == {}} {
|
||||
puts "This application hasn't been compiled with the \"testlink\""
|
||||
puts "command, so I can't test Tcl_LinkVar et al."
|
||||
return
|
||||
}
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
foreach i {int real bool string} {
|
||||
catch {unset $i}
|
||||
}
|
||||
test link-1.1 {reading C variables from Tcl} {
|
||||
testlink delete
|
||||
testlink set 43 1.23 4 -
|
||||
testlink create 1 1 1 1
|
||||
list $int $real $bool $string
|
||||
} {43 1.23 1 NULL}
|
||||
test link-1.2 {reading C variables from Tcl} {
|
||||
testlink delete
|
||||
testlink create 1 1 1 1
|
||||
testlink set -3 2 0 "A long string with spaces"
|
||||
list $int $real $bool $string $int $real $bool $string
|
||||
} {-3 2.0 0 {A long string with spaces} -3 2.0 0 {A long string with spaces}}
|
||||
|
||||
test link-2.1 {writing C variables from Tcl} {
|
||||
testlink delete
|
||||
testlink set 43 1.23 4 -
|
||||
testlink create 1 1 1 1
|
||||
set int "00721"
|
||||
set real -8e13
|
||||
set bool true
|
||||
set string abcdef
|
||||
concat [testlink get] $int $real $bool $string
|
||||
} {465 -8e+13 1 abcdef 00721 -8e13 true abcdef}
|
||||
test link-2.2 {writing bad values into variables} {
|
||||
testlink delete
|
||||
testlink set 43 1.23 4 -
|
||||
testlink create 1 1 1 1
|
||||
list [catch {set int 09a} msg] $msg $int
|
||||
} {1 {can't set "int": variable must have integer value} 43}
|
||||
test link-2.3 {writing bad values into variables} {
|
||||
testlink delete
|
||||
testlink set 43 1.23 4 -
|
||||
testlink create 1 1 1 1
|
||||
list [catch {set real 1.x3} msg] $msg $real
|
||||
} {1 {can't set "real": variable must have real value} 1.23}
|
||||
test link-2.4 {writing bad values into variables} {
|
||||
testlink delete
|
||||
testlink set 43 1.23 4 -
|
||||
testlink create 1 1 1 1
|
||||
list [catch {set bool gorp} msg] $msg $bool
|
||||
} {1 {can't set "bool": variable must have boolean value} 1}
|
||||
|
||||
test link-3.1 {read-only variables} {
|
||||
testlink delete
|
||||
testlink set 43 1.23 4 -
|
||||
testlink create 0 1 1 0
|
||||
list [catch {set int 4} msg] $msg $int \
|
||||
[catch {set real 10.6} msg] $msg $real \
|
||||
[catch {set bool no} msg] $msg $bool \
|
||||
[catch {set string "new value"} msg] $msg $string
|
||||
} {1 {can't set "int": linked variable is read-only} 43 0 10.6 10.6 0 no no 1 {can't set "string": linked variable is read-only} NULL}
|
||||
test link-3.2 {read-only variables} {
|
||||
testlink delete
|
||||
testlink set 43 1.23 4 -
|
||||
testlink create 1 0 0 1
|
||||
list [catch {set int 4} msg] $msg $int \
|
||||
[catch {set real 10.6} msg] $msg $real \
|
||||
[catch {set bool no} msg] $msg $bool \
|
||||
[catch {set string "new value"} msg] $msg $string
|
||||
} {0 4 4 1 {can't set "real": linked variable is read-only} 1.23 1 {can't set "bool": linked variable is read-only} 1 0 {new value} {new value}}
|
||||
|
||||
test link-4.1 {unsetting linked variables} {
|
||||
testlink delete
|
||||
testlink set -6 -2.1 0 stringValue
|
||||
testlink create 1 1 1 1
|
||||
unset int real bool string
|
||||
list [catch {set int} msg] $msg [catch {set real} msg] $msg \
|
||||
[catch {set bool} msg] $msg [catch {set string} msg] $msg
|
||||
} {0 -6 0 -2.1 0 0 0 stringValue}
|
||||
test link-4.2 {unsetting linked variables} {
|
||||
testlink delete
|
||||
testlink set -6 -2.1 0 stringValue
|
||||
testlink create 1 1 1 1
|
||||
unset int real bool string
|
||||
set int 102
|
||||
set real 16
|
||||
set bool true
|
||||
set string newValue
|
||||
testlink get
|
||||
} {102 16.0 1 newValue}
|
||||
|
||||
test link-5.1 {unlinking variables} {
|
||||
testlink delete
|
||||
testlink set -6 -2.1 0 stringValue
|
||||
testlink delete
|
||||
set int xx1
|
||||
set real qrst
|
||||
set bool bogus
|
||||
set string 12345
|
||||
testlink get
|
||||
} {-6 -2.1 0 stringValue}
|
||||
test link-5.2 {unlinking variables} {
|
||||
testlink delete
|
||||
testlink set -6 -2.1 0 stringValue
|
||||
testlink create 1 1 1 1
|
||||
testlink delete
|
||||
testlink set 25 14.7 7 -
|
||||
list $int $real $bool $string
|
||||
} {-6 -2.1 0 stringValue}
|
||||
|
||||
test link-6.1 {errors in setting up link} {
|
||||
testlink delete
|
||||
catch {unset int}
|
||||
set int(44) 1
|
||||
list [catch {testlink create 1 1 1 1} msg] $msg
|
||||
} {1 {can't set "int": variable is array}}
|
||||
|
||||
testlink delete
|
||||
unset int real bool string
|
||||
91
tcl7.3/tests/linsert.test
Normal file
91
tcl7.3/tests/linsert.test
Normal file
@@ -0,0 +1,91 @@
|
||||
# Commands covered: linsert
|
||||
#
|
||||
# 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.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/linsert.test,v 1.5 93/06/19 14:31:26 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
test linsert-1.1 {linsert command} {
|
||||
linsert {1 2 3 4 5} 0 a
|
||||
} {a 1 2 3 4 5}
|
||||
test linsert-1.2 {linsert command} {
|
||||
linsert {1 2 3 4 5} 1 a
|
||||
} {1 a 2 3 4 5}
|
||||
test linsert-1.3 {linsert command} {
|
||||
linsert {1 2 3 4 5} 2 a
|
||||
} {1 2 a 3 4 5}
|
||||
test linsert-1.4 {linsert command} {
|
||||
linsert {1 2 3 4 5} 3 a
|
||||
} {1 2 3 a 4 5}
|
||||
test linsert-1.5 {linsert command} {
|
||||
linsert {1 2 3 4 5} 4 a
|
||||
} {1 2 3 4 a 5}
|
||||
test linsert-1.6 {linsert command} {
|
||||
linsert {1 2 3 4 5} 5 a
|
||||
} {1 2 3 4 5 a}
|
||||
test linsert-1.7 {linsert command} {
|
||||
linsert {1 2 3 4 5} 2 one two \{three \$four
|
||||
} {1 2 one two \{three {$four} 3 4 5}
|
||||
test linsert-1.8 {linsert command} {
|
||||
linsert {\{one \$two \{three \ four \ five} 2 a b c
|
||||
} {\{one \$two a b c \{three \ four \ five}
|
||||
test linsert-1.9 {linsert command} {
|
||||
linsert {{1 2} {3 4} {5 6} {7 8}} 2 {x y} {a b}
|
||||
} {{1 2} {3 4} {x y} {a b} {5 6} {7 8}}
|
||||
test linsert-1.10 {linsert command} {
|
||||
linsert {} 2 a b c
|
||||
} {a b c}
|
||||
test linsert-1.11 {linsert command} {
|
||||
linsert {} 2 {}
|
||||
} {{}}
|
||||
test linsert-1.12 {linsert command} {
|
||||
linsert {a b "c c" d e} 3 1
|
||||
} {a b "c c" 1 d e}
|
||||
test linsert-1.13 {linsert command} {
|
||||
linsert { a b c d} 0 1 2
|
||||
} {1 2 a b c d}
|
||||
test linsert-1.14 {linsert command} {
|
||||
linsert {a b c {d e f}} 4 1 2
|
||||
} {a b c {d e f} 1 2}
|
||||
test linsert-1.15 {linsert command} {
|
||||
linsert {a b c \{\ abc} 4 q r
|
||||
} {a b c \{\ q r abc}
|
||||
test linsert-1.16 {linsert command} {
|
||||
linsert {a b c \{ abc} 4 q r
|
||||
} {a b c \{ q r abc}
|
||||
|
||||
test linsert-2.1 {linsert errors} {
|
||||
list [catch linsert msg] $msg
|
||||
} {1 {wrong # args: should be "linsert list index element ?element ...?"}}
|
||||
test linsert-2.2 {linsert errors} {
|
||||
list [catch {linsert a b} msg] $msg
|
||||
} {1 {wrong # args: should be "linsert list index element ?element ...?"}}
|
||||
test linsert-2.3 {linsert errors} {
|
||||
list [catch {linsert a 12x 2} msg] $msg
|
||||
} {1 {expected integer but got "12x"}}
|
||||
test linsert-2.4 {linsert errors} {
|
||||
list [catch {linsert \{ 12 2} msg] $msg
|
||||
} {1 {unmatched open brace in list}}
|
||||
87
tcl7.3/tests/list.test
Normal file
87
tcl7.3/tests/list.test
Normal file
@@ -0,0 +1,87 @@
|
||||
# Commands covered: list
|
||||
#
|
||||
# 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.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/list.test,v 1.18 93/10/28 16:14:10 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
# First, a bunch of individual tests
|
||||
|
||||
test list-1.1 {basic tests} {list a b c} {a b c}
|
||||
test list-1.2 {basic tests} {list {a b} c} {{a b} c}
|
||||
test list-1.3 {basic tests} {list \{a b c} {\{a b c}
|
||||
test list-1.4 {basic tests} "list a{}} b{} c}" "a\\{\\}\\} b{} c\\}"
|
||||
test list-1.5 {basic tests} {list a\[ b\] } "{a\[} b\\]"
|
||||
test list-1.6 {basic tests} {list c\ d\t } "{c } {d\t}"
|
||||
test list-1.7 {basic tests} {list e\n f\$ } "{e\n} {f\$}"
|
||||
test list-1.8 {basic tests} {list g\; h\\} {{g;} h\\}
|
||||
test list-1.9 {basic tests} "list a\\\[} b\\\]} " "a\\\[\\\} b\\\]\\\}"
|
||||
test list-1.10 {basic tests} "list c\\\} d\\t} " "c\\} d\\t\\}"
|
||||
test list-1.11 {basic tests} "list e\\n} f\\$} " "e\\n\\} f\\$\\}"
|
||||
test list-1.12 {basic tests} "list g\\;} h\\\\} " "g\\;\\} {h\\}}"
|
||||
test list-1.13 {basic tests} {list a {{}} b} {a {{}} b}
|
||||
test list-1.14 {basic tests} {list a b xy\\} "a b xy\\\\"
|
||||
test list-1.15 {basic tests} "list a b\} e\\" "a b\\} e\\\\"
|
||||
test list-1.16 {basic tests} "list a b\}\\\$ e\\\$\\" "a b\\}\\\$ e\\\$\\\\"
|
||||
test list-1.17 {basic tests} {list a\f \{\f} "{a\f} \\\{\\f"
|
||||
test list-1.18 {basic tests} {list a\r \{\r} "{a\r} \\\{\\r"
|
||||
test list-1.19 {basic tests} {list a\v \{\v} "{a\v} \\\{\\v"
|
||||
test list-1.20 {basic tests} {list \"\}\{} "\\\"\\}\\{"
|
||||
test list-1.21 {basic tests} {list a b c\\\nd} "a b c\\\\\\nd"
|
||||
test list-1.22 {basic tests} {list "{ab}\\"} \\{ab\\}\\\\
|
||||
test list-1.23 {basic tests} {list \{} "\\{"
|
||||
test list-1.24 {basic tests} {list} {}
|
||||
|
||||
# For the next round of tests create a list and then pick it apart
|
||||
# with "index" to make sure that we get back exactly what went in.
|
||||
|
||||
set num 1
|
||||
proc lcheck {a b c} {
|
||||
global num d
|
||||
set d [list $a $b $c]
|
||||
test list-2.$num {what goes in must come out} {lindex $d 0} $a
|
||||
set num [expr $num+1]
|
||||
test list-2.$num {what goes in must come out} {lindex $d 1} $b
|
||||
set num [expr $num+1]
|
||||
test list-2.$num {what goes in must come out} {lindex $d 2} $c
|
||||
set num [expr $num+1]
|
||||
}
|
||||
lcheck a b c
|
||||
lcheck "a b" c\td e\nf
|
||||
lcheck {{a b}} {} { }
|
||||
lcheck \$ \$ab ab\$
|
||||
lcheck \; \;ab ab\;
|
||||
lcheck \[ \[ab ab\[
|
||||
lcheck \\ \\ab ab\\
|
||||
lcheck {"} {"ab} {ab"}
|
||||
lcheck {a b} { ab} {ab }
|
||||
lcheck a{ a{b \{ab
|
||||
lcheck a} a}b }ab
|
||||
lcheck a\\} {a \}b} {a \{c}
|
||||
lcheck xyz \\ 1\\\n2
|
||||
lcheck "{ab}\\" "{ab}xy" abc
|
||||
|
||||
concat {}
|
||||
49
tcl7.3/tests/llength.test
Normal file
49
tcl7.3/tests/llength.test
Normal file
@@ -0,0 +1,49 @@
|
||||
# Commands covered: llength
|
||||
#
|
||||
# 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.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/llength.test,v 1.2 93/02/06 16:01:45 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
test llength-1.1 {length of list} {
|
||||
llength {a b c d}
|
||||
} 4
|
||||
test llength-1.2 {length of list} {
|
||||
llength {a b c {a b {c d}} d}
|
||||
} 5
|
||||
test llength-1.3 {length of list} {
|
||||
llength {}
|
||||
} 0
|
||||
|
||||
test llength-2.1 {error conditions} {
|
||||
list [catch {llength} msg] $msg
|
||||
} {1 {wrong # args: should be "llength list"}}
|
||||
test llength-2.2 {error conditions} {
|
||||
list [catch {llength 123 2} msg] $msg
|
||||
} {1 {wrong # args: should be "llength list"}}
|
||||
test llength-2.3 {error conditions} {
|
||||
list [catch {llength "a b c \{"} msg] $msg
|
||||
} {1 {unmatched open brace in list}}
|
||||
79
tcl7.3/tests/lrange.test
Normal file
79
tcl7.3/tests/lrange.test
Normal file
@@ -0,0 +1,79 @@
|
||||
# Commands covered: lrange
|
||||
#
|
||||
# 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.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/lrange.test,v 1.2 93/02/06 16:01:44 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
test lrange-1.1 {range of list elements} {
|
||||
lrange {a b c d} 1 2
|
||||
} {b c}
|
||||
test lrange-1.2 {range of list elements} {
|
||||
lrange {a {bcd e {f g {}}} l14 l15 d} 1 1
|
||||
} {{bcd e {f g {}}}}
|
||||
test lrange-1.3 {range of list elements} {
|
||||
lrange {a {bcd e {f g {}}} l14 l15 d} 3 end
|
||||
} {l15 d}
|
||||
test lrange-1.4 {range of list elements} {
|
||||
lrange {a {bcd e {f g {}}} l14 l15 d} 4 10000
|
||||
} {d}
|
||||
test lrange-1.5 {range of list elements} {
|
||||
lrange {a {bcd e {f g {}}} l14 l15 d} 4 3
|
||||
} {}
|
||||
test lrange-1.6 {range of list elements} {
|
||||
lrange {a {bcd e {f g {}}} l14 l15 d} 10 11
|
||||
} {}
|
||||
test lrange-1.7 {range of list elements} {
|
||||
lrange {a b c d e} -1 2
|
||||
} {a b c}
|
||||
test lrange-1.8 {range of list elements} {
|
||||
lrange {a b c d e} -2 -1
|
||||
} {}
|
||||
test lrange-1.9 {range of list elements} {
|
||||
lrange {a b c d e} -2 e
|
||||
} {a b c d e}
|
||||
test lrange-1.10 {range of list elements} {
|
||||
lrange "a b\{c d" 1 2
|
||||
} "b\{c d"
|
||||
|
||||
test lrange-2.1 {error conditions} {
|
||||
list [catch {lrange a b} msg] $msg
|
||||
} {1 {wrong # args: should be "lrange list first last"}}
|
||||
test lrange-2.2 {error conditions} {
|
||||
list [catch {lrange a b 6 7} msg] $msg
|
||||
} {1 {wrong # args: should be "lrange list first last"}}
|
||||
test lrange-2.3 {error conditions} {
|
||||
list [catch {lrange a b 6} msg] $msg
|
||||
} {1 {expected integer but got "b"}}
|
||||
test lrange-2.4 {error conditions} {
|
||||
list [catch {lrange a 0 enigma} msg] $msg
|
||||
} {1 {expected integer or "end" but got "enigma"}}
|
||||
test lrange-2.5 {error conditions} {
|
||||
list [catch {lrange "a \{b c" 3 4} msg] $msg
|
||||
} {1 {unmatched open brace in list}}
|
||||
test lrange-2.6 {error conditions} {
|
||||
list [catch {lrange "a b c \{ d e" 1 4} msg] $msg
|
||||
} {1 {unmatched open brace in list}}
|
||||
106
tcl7.3/tests/lreplace.test
Normal file
106
tcl7.3/tests/lreplace.test
Normal file
@@ -0,0 +1,106 @@
|
||||
# Commands covered: lreplace
|
||||
#
|
||||
# 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.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/lreplace.test,v 1.5 93/02/06 16:01:39 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
test lreplace-1.1 {lreplace command} {
|
||||
lreplace {1 2 3 4 5} 0 0 a
|
||||
} {a 2 3 4 5}
|
||||
test lreplace-1.2 {lreplace command} {
|
||||
lreplace {1 2 3 4 5} 1 1 a
|
||||
} {1 a 3 4 5}
|
||||
test lreplace-1.3 {lreplace command} {
|
||||
lreplace {1 2 3 4 5} 2 2 a
|
||||
} {1 2 a 4 5}
|
||||
test lreplace-1.4 {lreplace command} {
|
||||
lreplace {1 2 3 4 5} 3 3 a
|
||||
} {1 2 3 a 5}
|
||||
test lreplace-1.5 {lreplace command} {
|
||||
lreplace {1 2 3 4 5} 4 4 a
|
||||
} {1 2 3 4 a}
|
||||
test lreplace-1.6 {lreplace command} {
|
||||
lreplace {1 2 3 4 5} 4 5 a
|
||||
} {1 2 3 4 a}
|
||||
test lreplace-1.7 {lreplace command} {
|
||||
lreplace {1 2 3 4 5} -1 -1 a
|
||||
} {a 2 3 4 5}
|
||||
test lreplace-1.8 {lreplace command} {
|
||||
lreplace {1 2 3 4 5} 2 end a b c d
|
||||
} {1 2 a b c d}
|
||||
test lreplace-1.9 {lreplace command} {
|
||||
lreplace {1 2 3 4 5} 0 3
|
||||
} {5}
|
||||
test lreplace-1.10 {lreplace command} {
|
||||
lreplace {1 2 3 4 5} 0 4
|
||||
} {}
|
||||
test lreplace-1.11 {lreplace command} {
|
||||
lreplace {1 2 3 4 5} 0 1
|
||||
} {3 4 5}
|
||||
test lreplace-1.12 {lreplace command} {
|
||||
lreplace {1 2 3 4 5} 2 3
|
||||
} {1 2 5}
|
||||
test lreplace-1.13 {lreplace command} {
|
||||
lreplace {1 2 3 4 5} 3 end
|
||||
} {1 2 3}
|
||||
test lreplace-1.14 {lreplace command} {
|
||||
lreplace {1 2 3 4 5} -1 4 a b c
|
||||
} {a b c}
|
||||
test lreplace-1.15 {lreplace command} {
|
||||
lreplace {a b "c c" d e f} 3 3
|
||||
} {a b "c c" e f}
|
||||
test lreplace-1.16 {lreplace command} {
|
||||
lreplace { 1 2 3 4 5} 0 0 a
|
||||
} {a 2 3 4 5}
|
||||
test lreplace-1.17 {lreplace command} {
|
||||
lreplace {1 2 3 4 "5 6"} 4 4 a
|
||||
} {1 2 3 4 a}
|
||||
test lreplace-1.18 {lreplace command} {
|
||||
lreplace {1 2 3 4 {5 6}} 4 4 a
|
||||
} {1 2 3 4 a}
|
||||
|
||||
test lreplace-2.1 {lreplace errors} {
|
||||
list [catch lreplace msg] $msg
|
||||
} {1 {wrong # args: should be "lreplace list first last ?element element ...?"}}
|
||||
test lreplace-2.2 {lreplace errors} {
|
||||
list [catch {lreplace a b} msg] $msg
|
||||
} {1 {wrong # args: should be "lreplace list first last ?element element ...?"}}
|
||||
test lreplace-2.3 {lreplace errors} {
|
||||
list [catch {lreplace x a 10} msg] $msg
|
||||
} {1 {expected integer but got "a"}}
|
||||
test lreplace-2.4 {lreplace errors} {
|
||||
list [catch {lreplace x 10 x} msg] $msg
|
||||
} {1 {bad index "x": must be integer or "end"}}
|
||||
test lreplace-2.5 {lreplace errors} {
|
||||
list [catch {lreplace x 10 1x} msg] $msg
|
||||
} {1 {expected integer but got "1x"}}
|
||||
test lreplace-2.6 {lreplace errors} {
|
||||
list [catch {lreplace x 3 2} msg] $msg
|
||||
} {1 {first index must not be greater than second}}
|
||||
test lreplace-2.7 {lreplace errors} {
|
||||
list [catch {lreplace x 1 1} msg] $msg
|
||||
} {1 {list doesn't contain element 1}}
|
||||
81
tcl7.3/tests/lsearch.test
Normal file
81
tcl7.3/tests/lsearch.test
Normal file
@@ -0,0 +1,81 @@
|
||||
# Commands covered: lsearch
|
||||
#
|
||||
# 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.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/lsearch.test,v 1.3 93/05/06 16:18:04 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
set x {abcd bbcd 123 234 345}
|
||||
test lsearch-1.1 {lsearch command} {
|
||||
lsearch $x 123
|
||||
} 2
|
||||
test lsearch-1.2 {lsearch command} {
|
||||
lsearch $x 3456
|
||||
} -1
|
||||
test lsearch-1.3 {lsearch command} {
|
||||
lsearch $x *5
|
||||
} 4
|
||||
test lsearch-1.4 {lsearch command} {
|
||||
lsearch $x *bc*
|
||||
} 0
|
||||
|
||||
test lsearch-2.1 {search modes} {
|
||||
lsearch -exact {xyz bbcc *bc*} *bc*
|
||||
} 2
|
||||
test lsearch-2.2 {search modes} {
|
||||
lsearch -exact {b.x ^bc xy bcx} ^bc
|
||||
} 1
|
||||
test lsearch-2.3 {search modes} {
|
||||
list [catch {lsearch -regexp {xyz bbcc *bc*} *bc*} msg] $msg
|
||||
} {1 {couldn't compile regular expression pattern: ?+* follows nothing}}
|
||||
test lsearch-2.4 {search modes} {
|
||||
lsearch -regexp {b.x ^bc xy bcx} ^bc
|
||||
} 3
|
||||
test lsearch-2.5 {search modes} {
|
||||
lsearch -glob {xyz bbcc *bc*} *bc*
|
||||
} 1
|
||||
test lsearch-2.6 {search modes} {
|
||||
lsearch -glob {b.x ^bc xy bcx} ^bc
|
||||
} 1
|
||||
test lsearch-2.7 {search modes} {
|
||||
list [catch {lsearch -glib {b.x bx xy bcx} b.x} msg] $msg
|
||||
} {1 {bad search mode "-glib": must be -exact, -glob, or -regexp}}
|
||||
|
||||
test lsearch-3.1 {lsearch errors} {
|
||||
list [catch lsearch msg] $msg
|
||||
} {1 {wrong # args: should be "lsearch ?mode? list pattern"}}
|
||||
test lsearch-3.2 {lsearch errors} {
|
||||
list [catch {lsearch a} msg] $msg
|
||||
} {1 {wrong # args: should be "lsearch ?mode? list pattern"}}
|
||||
test lsearch-3.3 {lsearch errors} {
|
||||
list [catch {lsearch a b c} msg] $msg
|
||||
} {1 {bad search mode "a": must be -exact, -glob, or -regexp}}
|
||||
test lsearch-3.4 {lsearch errors} {
|
||||
list [catch {lsearch a b c d} msg] $msg
|
||||
} {1 {wrong # args: should be "lsearch ?mode? list pattern"}}
|
||||
test lsearch-3.5 {lsearch errors} {
|
||||
list [catch {lsearch "\{" b} msg] $msg
|
||||
} {1 {unmatched open brace in list}}
|
||||
136
tcl7.3/tests/lsort.test
Normal file
136
tcl7.3/tests/lsort.test
Normal file
@@ -0,0 +1,136 @@
|
||||
# Commands covered: lsort
|
||||
#
|
||||
# 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.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/lsort.test,v 1.4 93/10/22 14:25:01 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
test lsort-1.1 {lsort command} {
|
||||
lsort {abdeq ab 1 ac a}
|
||||
} {1 a ab abdeq ac}
|
||||
test lsort-1.2 {lsort command} {
|
||||
lsort -decreasing {abdeq ab 1 ac a}
|
||||
} {ac abdeq ab a 1}
|
||||
test lsort-1.3 {lsort command} {
|
||||
lsort -increasing {abdeq ab 1 ac a}
|
||||
} {1 a ab abdeq ac}
|
||||
test lsort-1.4 {lsort command} {
|
||||
lsort {{one long element}}
|
||||
} {{one long element}}
|
||||
test lsort-1.5 {lsort command} {
|
||||
lsort {}
|
||||
} {}
|
||||
test lsort-1.6 {lsort with characters needing backslashes} {
|
||||
lsort {$ \\ [] \{}
|
||||
} {{$} {[]} \\ \{}
|
||||
|
||||
test lsort-2.1 {lsort -integer} {
|
||||
lsort -integer -inc {1 180 62 040 180 -42 33 0x40}
|
||||
} {-42 1 040 33 62 0x40 180 180}
|
||||
test lsort-2.2 {lsort -integer} {
|
||||
lsort -int -dec {1 180 62 040 180 -42 33 0x40}
|
||||
} {180 180 0x40 62 33 040 1 -42}
|
||||
test lsort-2.3 {lsort -integer} {
|
||||
list [catch {lsort -integer {xxx 180.2 62 040 180 -42 33 0x40}} msg] $msg $errorInfo
|
||||
} {1 {expected integer but got "xxx"} {expected integer but got "xxx"
|
||||
(converting list element from string to integer)
|
||||
invoked from within
|
||||
"lsort -integer {xxx 180.2 62 040 180 -42 33 0x40}"}}
|
||||
test lsort-2.4 {lsort -integer} {
|
||||
list [catch {lsort -integer {1 180.2 62 040 180 -42 33 0x40}} msg] $msg $errorInfo
|
||||
} {1 {expected integer but got "180.2"} {expected integer but got "180.2"
|
||||
(converting list element from string to integer)
|
||||
invoked from within
|
||||
"lsort -integer {1 180.2 62 040 180 -42 33 0x40}"}}
|
||||
|
||||
test lsort-3.1 {lsort -real} {
|
||||
lsort -real {1 180.1 62 040 180 -42.7 33}
|
||||
} {-42.7 1 33 040 62 180 180.1}
|
||||
test lsort-3.2 {lsort -real} {
|
||||
lsort -r -d {1 180.1 62 040 180 -42.7 33}
|
||||
} {180.1 180 62 040 33 1 -42.7}
|
||||
test lsort-3.3 {lsort -real} {
|
||||
list [catch {lsort -real -inc {xxx 20 62 180 -42.7 33}} msg] $msg $errorInfo
|
||||
} {1 {expected floating-point number but got "xxx"} {expected floating-point number but got "xxx"
|
||||
(converting list element from string to real)
|
||||
invoked from within
|
||||
"lsort -real -inc {xxx 20 62 180 -42.7 33}"}}
|
||||
test lsort-3.4 {lsort -real} {
|
||||
list [catch {lsort -real -inc {1 0x40 62 180 -42.7 33}} msg] $msg $errorInfo
|
||||
} {1 {expected floating-point number but got "0x40"} {expected floating-point number but got "0x40"
|
||||
(converting list element from string to real)
|
||||
invoked from within
|
||||
"lsort -real -inc {1 0x40 62 180 -42.7 33}"}}
|
||||
|
||||
proc lsort1 {a b} {
|
||||
expr {2*([string match x* $a] - [string match x* $b])
|
||||
+ [string match *y $a] - [string match *y $b]}
|
||||
}
|
||||
proc lsort2 {a b} {
|
||||
error "comparison error"
|
||||
}
|
||||
proc lsort3 {a b} {
|
||||
concat "foobar"
|
||||
}
|
||||
|
||||
test lsort-4.1 {lsort -command} {
|
||||
lsort -command lsort1 {xxx yyy abc {xx y}}
|
||||
} {abc yyy xxx {xx y}}
|
||||
test lsort-4.2 {lsort -command} {
|
||||
lsort -command lsort1 -dec {xxx yyy abc {xx y}}
|
||||
} {{xx y} xxx yyy abc}
|
||||
test lsort-4.3 {lsort -command} {
|
||||
list [catch {lsort -command lsort2 -dec {1 1 1 1}} msg] $msg $errorInfo
|
||||
} {1 {comparison error} {comparison error
|
||||
while executing
|
||||
"error "comparison error""
|
||||
(procedure "lsort2" line 2)
|
||||
invoked from within
|
||||
"lsort2 1 1"
|
||||
(user-defined comparison command)
|
||||
invoked from within
|
||||
"lsort -command lsort2 -dec {1 1 1 1}"}}
|
||||
test lsort-4.4 {lsort -command} {
|
||||
list [catch {lsort -command lsort3 -dec {1 2 3 4}} msg] $msg $errorInfo
|
||||
} {1 {comparison command returned non-numeric result} {comparison command returned non-numeric result
|
||||
while executing
|
||||
"lsort -command lsort3 -dec {1 2 3 4}"}}
|
||||
test lsort-4.5 {lsort -command} {
|
||||
list [catch {lsort -command {xxx yyy xxy abc}} msg] $msg
|
||||
} {1 {"-command" must be followed by comparison command}}
|
||||
|
||||
test lsort-5.1 {lsort errors} {
|
||||
list [catch lsort msg] $msg
|
||||
} {1 {wrong # args: should be "lsort ?-ascii? ?-integer? ?-real? ?-increasing? ?-decreasing? ?-command string? list"}}
|
||||
test lsort-5.2 {lsort errors} {
|
||||
list [catch {lsort a b} msg] $msg
|
||||
} {1 {bad switch "a": must be -ascii, -integer, -real, -increasing -decreasing, or -command}}
|
||||
test lsort-5.3 {lsort errors} {
|
||||
list [catch {lsort "\{"} msg] $msg
|
||||
} {1 {unmatched open brace in list}}
|
||||
test lsort-5.4 {lsort errors} {
|
||||
list [catch {lsort -in {1 180.0 040 62 180 -42.7 33}} msg] $msg
|
||||
} {1 {bad switch "-in": must be -ascii, -integer, -real, -increasing -decreasing, or -command}}
|
||||
84
tcl7.3/tests/misc.test
Normal file
84
tcl7.3/tests/misc.test
Normal file
@@ -0,0 +1,84 @@
|
||||
# Commands covered: various
|
||||
#
|
||||
# This file contains a collection of miscellaneous Tcl tests that
|
||||
# don't fit naturally in any of the other test files. Many of these
|
||||
# tests are pathological cases that caused bugs in earlier Tcl
|
||||
# releases.
|
||||
#
|
||||
# Copyright (c) 1992-1993 The Regents of the University of California.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/misc.test,v 1.3 93/10/07 11:41:23 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
test misc-1.1 {error in variable ref. in command in array reference} {
|
||||
proc tstProc {} {
|
||||
global a
|
||||
|
||||
set tst $a([winfo name $zz])
|
||||
# this is a bogus comment
|
||||
# this is a bogus comment
|
||||
# this is a bogus comment
|
||||
# this is a bogus comment
|
||||
# this is a bogus comment
|
||||
# this is a bogus comment
|
||||
# this is a bogus comment
|
||||
# this is a bogus comment
|
||||
}
|
||||
set msg {}
|
||||
list [catch tstProc msg] $msg
|
||||
} {1 {can't read "zz": no such variable}}
|
||||
test misc-1.2 {error in variable ref. in command in array reference} {
|
||||
proc tstProc {} "
|
||||
global a
|
||||
|
||||
set tst \$a(\[winfo name \$\{zz)
|
||||
# this is a bogus comment
|
||||
# this is a bogus comment
|
||||
# this is a bogus comment
|
||||
# this is a bogus comment
|
||||
# this is a bogus comment
|
||||
# this is a bogus comment
|
||||
# this is a bogus comment
|
||||
# this is a bogus comment
|
||||
"
|
||||
set msg {}
|
||||
list [catch tstProc msg] $msg $errorInfo
|
||||
} [list 1 {missing close-brace for variable name} \
|
||||
[format {missing close-brace for variable name
|
||||
while executing
|
||||
"winfo name $%szz)
|
||||
# this is a bogus comment
|
||||
# this is a bogus comment
|
||||
# this is a bogus comment
|
||||
# this is a bogus comment
|
||||
# this is a bogus commen ..."
|
||||
(parsing index for array "a")
|
||||
invoked from within
|
||||
"set tst $a([winfo name $%szz)
|
||||
# this is a bogus comment
|
||||
# this is a bogus comment
|
||||
# this is a bogus comment
|
||||
# this is a bogus comment
|
||||
# this is a ..."
|
||||
(procedure "tstProc" line 4)
|
||||
invoked from within
|
||||
"tstProc"} \{ \{]]
|
||||
662
tcl7.3/tests/open.test
Normal file
662
tcl7.3/tests/open.test
Normal file
@@ -0,0 +1,662 @@
|
||||
# Commands covered: open, close, gets, puts, read, seek, tell, eof, flush
|
||||
#
|
||||
# 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.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/open.test,v 1.19 93/10/18 08:52:24 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
catch {exec rm -f test1 test2 test3}
|
||||
exec cat > test1 << "Two lines: this one\nand this one\n"
|
||||
exec cat > test2 << "line1\nline2\nline3\nline4\nline5\n"
|
||||
|
||||
test open-1.1 {open command (files only)} {
|
||||
set f [open test1]
|
||||
set x [gets $f]
|
||||
close $f
|
||||
set x
|
||||
} {Two lines: this one}
|
||||
test open-1.2 {open command (files only)} {
|
||||
set f [open test1]
|
||||
set f2 [open test2]
|
||||
set f3 [open test1]
|
||||
set f4 [open test1]
|
||||
set x [list [gets $f] [gets $f2] [gets $f3] [gets $f4] \
|
||||
[gets $f] [gets $f2]]
|
||||
close $f
|
||||
close $f2
|
||||
close $f3
|
||||
close $f4
|
||||
set x
|
||||
} {{Two lines: this one} line1 {Two lines: this one} {Two lines: this one} {and this one} line2}
|
||||
test open-1.3 {open command (files only)} {
|
||||
set f [open test3 w]
|
||||
puts $f xyz
|
||||
close $f
|
||||
exec cat test3
|
||||
} "xyz"
|
||||
test open-1.4 {open command (files only)} {
|
||||
set f [open test3 w]
|
||||
puts $f xyz
|
||||
close $f
|
||||
set f [open test3 a]
|
||||
puts $f 123
|
||||
close $f
|
||||
exec cat test3
|
||||
} "xyz\n123"
|
||||
test open-1.5 {open command (files only)} {
|
||||
set f [open test3 w]
|
||||
puts $f xyz\n123
|
||||
close $f
|
||||
set f [open test3 r+]
|
||||
set x [gets $f]
|
||||
seek $f 0 current
|
||||
puts $f 456
|
||||
close $f
|
||||
list $x [exec cat test3]
|
||||
} "xyz {xyz
|
||||
456}"
|
||||
test open-1.6 {open command (files only)} {
|
||||
set f [open test3 w]
|
||||
puts $f xyz\n123
|
||||
close $f
|
||||
set f [open test3 w+]
|
||||
puts $f xyzzy
|
||||
seek $f 2
|
||||
set x [gets $f]
|
||||
close $f
|
||||
list $x [exec cat test3]
|
||||
} "zzy xyzzy"
|
||||
test open-1.7 {open command (files only)} {
|
||||
set f [open test3 w]
|
||||
puts $f xyz\n123
|
||||
close $f
|
||||
set f [open test3 a+]
|
||||
puts $f xyzzy
|
||||
flush $f
|
||||
set x [tell $f]
|
||||
seek $f -4 cur
|
||||
set y [gets $f]
|
||||
close $f
|
||||
list $x [exec cat test3] $y
|
||||
} {14 {xyz
|
||||
123
|
||||
xyzzy} zzy}
|
||||
|
||||
test open-2.1 {errors in open command} {
|
||||
list [catch {open} msg] $msg
|
||||
} {1 {wrong # args: should be "open filename ?access? ?permissions?"}}
|
||||
test open-2.2 {errors in open command} {
|
||||
list [catch {open a b c d} msg] $msg
|
||||
} {1 {wrong # args: should be "open filename ?access? ?permissions?"}}
|
||||
test open-2.3 {errors in open command} {
|
||||
list [catch {open test1 x} msg] $msg
|
||||
} {1 {illegal access mode "x"}}
|
||||
test open-2.4 {errors in open command} {
|
||||
list [catch {open test1 rw} msg] $msg
|
||||
} {1 {illegal access mode "rw"}}
|
||||
test open-2.5 {errors in open command} {
|
||||
list [catch {open test1 r+1} msg] $msg
|
||||
} {1 {illegal access mode "r+1"}}
|
||||
test open-2.6 {errors in open command} {
|
||||
string tolower [list [catch {open _non_existent_} msg] $msg $errorCode]
|
||||
} {1 {couldn't open "_non_existent_": no such file or directory} {posix enoent {no such file or directory}}}
|
||||
|
||||
if {![file exists ~/_test_] && [file writable ~]} {
|
||||
test open-3.1 {tilde substitution in open} {
|
||||
set f [open ~/_test_ w]
|
||||
puts $f "Some text"
|
||||
close $f
|
||||
set x [file exists $env(HOME)/_test_]
|
||||
exec rm -f $env(HOME)/_test_
|
||||
set x
|
||||
} 1
|
||||
}
|
||||
test open-3.2 {tilde substitution in open} {
|
||||
set home $env(HOME)
|
||||
unset env(HOME)
|
||||
set x [list [catch {open ~/foo} msg] $msg]
|
||||
set env(HOME) $home
|
||||
set x
|
||||
} {1 {couldn't find HOME environment variable to expand "~/foo"}}
|
||||
|
||||
test open-4.1 {file id parsing errors} {
|
||||
list [catch {eof gorp} msg] $msg $errorCode
|
||||
} {1 {bad file identifier "gorp"} NONE}
|
||||
test open-4.2 {file id parsing errors} {
|
||||
list [catch {eof filex} msg] $msg
|
||||
} {1 {bad file identifier "filex"}}
|
||||
test open-4.3 {file id parsing errors} {
|
||||
list [catch {eof file12a} msg] $msg
|
||||
} {1 {bad file identifier "file12a"}}
|
||||
test open-4.4 {file id parsing errors} {
|
||||
list [catch {eof file123} msg] $msg
|
||||
} {1 {file "file123" isn't open}}
|
||||
test open-4.5 {file id parsing errors} {
|
||||
list [catch {eof file1} msg] $msg
|
||||
} {0 0}
|
||||
test open-4.5 {file id parsing errors} {
|
||||
list [catch {eof stdin} msg] $msg
|
||||
} {0 0}
|
||||
test open-4.6 {file id parsing errors} {
|
||||
list [catch {eof stdout} msg] $msg
|
||||
} {0 0}
|
||||
test open-4.7 {file id parsing errors} {
|
||||
list [catch {eof stderr} msg] $msg
|
||||
} {0 0}
|
||||
test open-4.8 {file id parsing errors} {
|
||||
list [catch {eof stderr1} msg] $msg
|
||||
} {1 {bad file identifier "stderr1"}}
|
||||
set f [open test1]
|
||||
close $f
|
||||
set expect "1 {file \"$f\" isn't open}"
|
||||
test open-4.9 {file id parsing errors} {
|
||||
list [catch {eof $f} msg] $msg
|
||||
} $expect
|
||||
|
||||
test open-5.1 {close command (files only)} {
|
||||
list [catch {close} msg] $msg $errorCode
|
||||
} {1 {wrong # args: should be "close fileId"} NONE}
|
||||
test open-5.2 {close command (files only)} {
|
||||
list [catch {close a b} msg] $msg $errorCode
|
||||
} {1 {wrong # args: should be "close fileId"} NONE}
|
||||
test open-5.3 {close command (files only)} {
|
||||
list [catch {close gorp} msg] $msg $errorCode
|
||||
} {1 {bad file identifier "gorp"} NONE}
|
||||
test open-5.4 {close command (files only)} {
|
||||
list [catch {close file4} msg] \
|
||||
[string range $msg [string first {" } $msg] end] $errorCode
|
||||
} {1 {" isn't open} NONE}
|
||||
|
||||
test open-6.1 {puts command} {
|
||||
list [catch {puts} msg] $msg $errorCode
|
||||
} {1 {wrong # args: should be "puts" ?-nonewline? ?fileId? string} NONE}
|
||||
test open-6.2 {puts command} {
|
||||
list [catch {puts a b c d} msg] $msg $errorCode
|
||||
} {1 {wrong # args: should be "puts" ?-nonewline? ?fileId? string} NONE}
|
||||
test open-6.3 {puts command} {
|
||||
list [catch {puts a b nonewlinx} msg] $msg $errorCode
|
||||
} {1 {bad argument "nonewlinx": should be "nonewline"} NONE}
|
||||
test open-6.4 {puts command} {
|
||||
list [catch {puts gorp "New text"} msg] $msg $errorCode
|
||||
} {1 {bad file identifier "gorp"} NONE}
|
||||
test open-6.5 {puts command} {
|
||||
set f [open test3]
|
||||
set x [list [catch {puts $f "New text"} msg] \
|
||||
[string range $msg [string first " " $msg] end] $errorCode]
|
||||
close $f
|
||||
set x
|
||||
} {1 { wasn't opened for writing} NONE}
|
||||
test open-6.6 {puts command} {
|
||||
set f [open test3 w]
|
||||
puts -nonewline $f "Text1"
|
||||
puts -nonewline $f " Text 2"
|
||||
puts $f " Text 3"
|
||||
close $f
|
||||
exec cat test3
|
||||
} {Text1 Text 2 Text 3}
|
||||
|
||||
test open-7.1 {gets command} {
|
||||
list [catch {gets} msg] $msg $errorCode
|
||||
} {1 {wrong # args: should be "gets fileId ?varName?"} NONE}
|
||||
test open-7.2 {gets command} {
|
||||
list [catch {gets a b c} msg] $msg $errorCode
|
||||
} {1 {wrong # args: should be "gets fileId ?varName?"} NONE}
|
||||
test open-7.3 {gets command} {
|
||||
list [catch {gets a} msg] $msg $errorCode
|
||||
} {1 {bad file identifier "a"} NONE}
|
||||
test open-7.4 {gets command} {
|
||||
set f [open test3 w]
|
||||
set x [list [catch {gets $f} msg] \
|
||||
[string range $msg [string first " " $msg] end] $errorCode]
|
||||
close $f
|
||||
set x
|
||||
} {1 { wasn't opened for reading} NONE}
|
||||
set f [open test3 w]
|
||||
puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
|
||||
puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
|
||||
puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
|
||||
puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
|
||||
puts $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
|
||||
close $f
|
||||
test open-7.5 {gets command with long line} {
|
||||
set f [open test3]
|
||||
set x [gets $f]
|
||||
close $f
|
||||
set x
|
||||
} {abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ}
|
||||
test open-7.6 {gets command with long line} {
|
||||
set f [open test3]
|
||||
set x [gets $f y]
|
||||
close $f
|
||||
list $x $y
|
||||
} {260 abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ}
|
||||
test open-7.7 {gets command and end of file} {
|
||||
set f [open test3 w]
|
||||
puts -nonewline $f "Test1\nTest2"
|
||||
close $f
|
||||
set f [open test3]
|
||||
set x {}
|
||||
set y {}
|
||||
lappend x [gets $f y] $y
|
||||
set y {}
|
||||
lappend x [gets $f y] $y
|
||||
set y {}
|
||||
lappend x [gets $f y] $y
|
||||
close $f
|
||||
set x
|
||||
} {5 Test1 5 Test2 -1 {}}
|
||||
set f [open test3 w]
|
||||
puts $f "Line 1"
|
||||
puts $f "Line 2"
|
||||
close $f
|
||||
test open-7.8 {gets command and bad variable} {
|
||||
catch {unset x}
|
||||
set x 24
|
||||
set f [open test3 r]
|
||||
set result [list [catch {gets $f x(0)} msg] $msg]
|
||||
close $f
|
||||
set result
|
||||
} {1 {can't set "x(0)": variable isn't array}}
|
||||
|
||||
test open-8.1 {read command} {
|
||||
list [catch {read} msg] $msg $errorCode
|
||||
} {1 {wrong # args: should be "read fileId ?numBytes?" or "read ?-nonewline? fileId"} NONE}
|
||||
test open-8.2 {read command} {
|
||||
list [catch {read -nonewline} msg] $msg $errorCode
|
||||
} {1 {bad file identifier "-nonewline"} NONE}
|
||||
test open-8.3 {read command} {
|
||||
list [catch {read a b c} msg] $msg $errorCode
|
||||
} {1 {wrong # args: should be "read fileId ?numBytes?" or "read ?-nonewline? fileId"} NONE}
|
||||
test open-8.4 {read command} {
|
||||
list [catch {read -nonew file4} msg] $msg $errorCode
|
||||
} {1 {bad file identifier "-nonew"} NONE}
|
||||
test open-8.5 {read command} {
|
||||
list [catch {read stdin foo} msg] $msg $errorCode
|
||||
} {1 {bad argument "foo": should be "nonewline"} NONE}
|
||||
test open-8.6 {read command} {
|
||||
list [catch {read file10} msg] $msg $errorCode
|
||||
} {1 {file "file10" isn't open} NONE}
|
||||
test open-8.7 {read command} {
|
||||
set f [open test3 w]
|
||||
set x [list [catch {read $f} msg] \
|
||||
[string range $msg [string first " " $msg] end] $errorCode]
|
||||
close $f
|
||||
set x
|
||||
} {1 { wasn't opened for reading} NONE}
|
||||
test open-8.8 {read command} {
|
||||
set f [open test1]
|
||||
set x [list [catch {read $f 12z} msg] $msg $errorCode]
|
||||
close $f
|
||||
set x
|
||||
} {1 {expected integer but got "12z"} NONE}
|
||||
test open-898 {read command} {
|
||||
set f [open test1]
|
||||
set x [list [catch {read $f z} msg] $msg $errorCode]
|
||||
close $f
|
||||
set x
|
||||
} {1 {bad argument "z": should be "nonewline"} NONE}
|
||||
test open-8.10 {read command} {
|
||||
set f [open test1]
|
||||
set x [list [read $f 1] [read $f 2] [read $f]]
|
||||
close $f
|
||||
set x
|
||||
} {T wo { lines: this one
|
||||
and this one
|
||||
}}
|
||||
test open-8.11 {read command, with over-large count} {
|
||||
set f [open test1]
|
||||
set x [read $f 100]
|
||||
close $f
|
||||
set x
|
||||
} {Two lines: this one
|
||||
and this one
|
||||
}
|
||||
test open-8.12 {read command, -nonewline switch} {
|
||||
set f [open test1]
|
||||
set x [read -nonewline $f]
|
||||
close $f
|
||||
set x
|
||||
} {Two lines: this one
|
||||
and this one}
|
||||
|
||||
test open-9.1 {seek command} {
|
||||
list [catch {seek foo} msg] $msg $errorCode
|
||||
} {1 {wrong # args: should be "seek fileId offset ?origin?"} NONE}
|
||||
test open-9.2 {seek command} {
|
||||
list [catch {seek foo a b c} msg] $msg $errorCode
|
||||
} {1 {wrong # args: should be "seek fileId offset ?origin?"} NONE}
|
||||
test open-9.3 {seek command} {
|
||||
list [catch {seek foo 0} msg] $msg $errorCode
|
||||
} {1 {bad file identifier "foo"} NONE}
|
||||
test open-9.4 {seek command} {
|
||||
set f [open test2]
|
||||
set x [list [catch {seek $f xyz} msg] $msg $errorCode]
|
||||
close $f
|
||||
set x
|
||||
} {1 {expected integer but got "xyz"} NONE}
|
||||
test open-9.5 {seek command} {
|
||||
set f [open test2]
|
||||
set x [list [catch {seek $f 100 gorp} msg] $msg $errorCode]
|
||||
close $f
|
||||
set x
|
||||
} {1 {bad origin "gorp": should be start, current, or end} NONE}
|
||||
set f [open test3 w]
|
||||
puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
|
||||
close $f
|
||||
test open-9.6 {seek command} {
|
||||
set f [open test3]
|
||||
set x [read $f 1]
|
||||
seek $f 3
|
||||
lappend x [read $f 1]
|
||||
seek $f 0 start
|
||||
lappend x [read $f 1]
|
||||
seek $f 10 current
|
||||
lappend x [read $f 1]
|
||||
seek $f -2 end
|
||||
lappend x [read $f 1]
|
||||
seek $f 50 end
|
||||
lappend x [read $f 1]
|
||||
seek $f 1
|
||||
lappend x [read $f 1]
|
||||
close $f
|
||||
set x
|
||||
} {a d a l Y {} b}
|
||||
|
||||
test open-10.1 {tell command} {
|
||||
list [catch {tell} msg] $msg $errorCode
|
||||
} {1 {wrong # args: should be "tell fileId"} NONE}
|
||||
test open-10.2 {tell command} {
|
||||
list [catch {tell a b} msg] $msg $errorCode
|
||||
} {1 {wrong # args: should be "tell fileId"} NONE}
|
||||
test open-10.3 {tell command} {
|
||||
list [catch {tell a} msg] $msg $errorCode
|
||||
} {1 {bad file identifier "a"} NONE}
|
||||
test open-10.4 {tell command} {
|
||||
set f [open test2]
|
||||
set x [tell $f]
|
||||
read $f 3
|
||||
lappend x [tell $f]
|
||||
seek $f 2
|
||||
lappend x [tell $f]
|
||||
seek $f 10 current
|
||||
lappend x [tell $f]
|
||||
seek $f 0 end
|
||||
lappend x [tell $f]
|
||||
close $f
|
||||
set x
|
||||
} {0 3 2 12 30}
|
||||
|
||||
test open-11.1 {eof command} {
|
||||
list [catch {eof} msg] $msg $errorCode
|
||||
} {1 {wrong # args: should be "eof fileId"} NONE}
|
||||
test open-11.2 {eof command} {
|
||||
list [catch {eof a b} msg] $msg $errorCode
|
||||
} {1 {wrong # args: should be "eof fileId"} NONE}
|
||||
test open-11.3 {eof command} {
|
||||
list [catch {eof file100} msg] $msg $errorCode
|
||||
} {1 {file "file100" isn't open} NONE}
|
||||
test open-11.4 {eof command} {
|
||||
set f [open test1]
|
||||
set x [eof $f]
|
||||
lappend x [eof $f]
|
||||
gets $f
|
||||
lappend x [eof $f]
|
||||
gets $f
|
||||
lappend x [eof $f]
|
||||
gets $f
|
||||
lappend x [eof $f]
|
||||
lappend x [eof $f]
|
||||
close $f
|
||||
set x
|
||||
} {0 0 0 0 1 1}
|
||||
|
||||
test open-12.1 {flush command} {
|
||||
list [catch {flush} msg] $msg $errorCode
|
||||
} {1 {wrong # args: should be "flush fileId"} NONE}
|
||||
test open-12.2 {flush command} {
|
||||
list [catch {flush a b} msg] $msg $errorCode
|
||||
} {1 {wrong # args: should be "flush fileId"} NONE}
|
||||
test open-12.3 {flush command} {
|
||||
list [catch {flush a} msg] $msg $errorCode
|
||||
} {1 {bad file identifier "a"} NONE}
|
||||
test open-12.4 {flush command} {
|
||||
set f [open test3]
|
||||
set x [list [catch {flush $f} msg] \
|
||||
[string range $msg [string first " " $msg] end] $errorCode]
|
||||
close $f
|
||||
set x
|
||||
} {1 { wasn't opened for writing} NONE}
|
||||
test open-12.5 {flush command} {
|
||||
set f [open test3 w]
|
||||
puts $f "Line 1"
|
||||
puts $f "Line 2"
|
||||
set f2 [open test3]
|
||||
set x {}
|
||||
lappend x [read -nonewline $f2]
|
||||
close $f2
|
||||
flush $f
|
||||
set f2 [open test3]
|
||||
lappend x [read -nonewline $f2]
|
||||
close $f2
|
||||
close $f
|
||||
set x
|
||||
} {{} {Line 1
|
||||
Line 2}}
|
||||
|
||||
test open-13.1 {I/O to command pipelines} {
|
||||
list [catch {open "| cat < test1 > test3" w} msg] $msg $errorCode
|
||||
} {1 {can't write input to command: standard input was redirected} NONE}
|
||||
test open-13.2 {I/O to command pipelines} {
|
||||
list [catch {open "| echo > test3" r} msg] $msg $errorCode
|
||||
} {1 {can't read output from command: standard output was redirected} NONE}
|
||||
test open-13.3 {I/O to command pipelines} {
|
||||
list [catch {open "| echo > test3" r+} msg] $msg $errorCode
|
||||
} {1 {can't read output from command: standard output was redirected} NONE}
|
||||
test open-13.4 {writing to command pipelines} {
|
||||
exec rm test3
|
||||
set f [open "| cat | cat > test3" w]
|
||||
puts $f "Line 1"
|
||||
puts $f "Line 2"
|
||||
close $f
|
||||
exec cat test3
|
||||
} {Line 1
|
||||
Line 2}
|
||||
test open-13.5 {reading from command pipelines} {
|
||||
set f [open "| cat test2" r]
|
||||
set x [list [gets $f] [gets $f] [gets $f]]
|
||||
close $f
|
||||
set x
|
||||
} {line1 line2 line3}
|
||||
test open-13.6 {both reading and writing from/to command pipelines} {
|
||||
set f [open "| cat -u" r+]
|
||||
puts $f "Line1"
|
||||
flush $f
|
||||
set x [gets $f]
|
||||
close $f
|
||||
set x
|
||||
} {Line1}
|
||||
test open-13.7 {errors in command pipelines} {
|
||||
set f [open "|gorp"]
|
||||
list [catch {close $f} msg] $msg [lindex $errorCode 0] [lindex $errorCode 2]
|
||||
} {1 {couldn't find "gorp" to execute} CHILDSTATUS 1}
|
||||
test open-13.8 {errors in command pipelines} {
|
||||
set f [open "|gorp" w]
|
||||
exec sleep 1
|
||||
puts $f output
|
||||
set x [list [catch {flush $f} msg] [concat \
|
||||
[string range $msg 0 [string first {"} $msg]] \
|
||||
[string range $msg [string first : $msg] end]] $errorCode]
|
||||
catch {close $f}
|
||||
string tolower $x
|
||||
} {1 {error flushing " : broken pipe} {posix epipe {broken pipe}}}
|
||||
test open-13.9 {errors in command pipelines} {
|
||||
set f [open "|gorp" w]
|
||||
list [catch {close $f} msg] $msg \
|
||||
[lindex $errorCode 0] [lindex $errorCode 2]
|
||||
} {1 {couldn't find "gorp" to execute} CHILDSTATUS 1}
|
||||
test open-13.10 {errors in command pipelines} {
|
||||
set f [open "|gorp" w]
|
||||
exec sleep 1
|
||||
puts $f output
|
||||
string tolower [list [catch {close $f} msg] [concat \
|
||||
[string range $msg 0 [string first {"} $msg]] \
|
||||
[string range $msg [string first : $msg] end]] \
|
||||
[lindex $errorCode 0] [lindex $errorCode 2]]
|
||||
} {1 {error closing " : broken pipe
|
||||
couldn't find "gorp" to execute} childstatus 1}
|
||||
|
||||
test open-14.1 {POSIX open access modes: RDONLY} {
|
||||
set f [open test1 RDONLY]
|
||||
set x [list [gets $f] [catch {puts $f Test} msg] $msg]
|
||||
close $f
|
||||
|
||||
# The regsub is needed to avoid false errors if the file
|
||||
# number varies from system to system.
|
||||
|
||||
regsub {"file."} $x {"file"} x
|
||||
set x
|
||||
} {{Two lines: this one} 1 {"file" wasn't opened for writing}}
|
||||
test open-14.2 {POSIX open access modes: RDONLY} {
|
||||
catch {exec rm -f test3}
|
||||
string tolower [list [catch {open test3 RDONLY} msg] $msg]
|
||||
} {1 {couldn't open "test3": no such file or directory}}
|
||||
test open-14.3 {POSIX open access modes: WRONLY} {
|
||||
catch {exec rm -f test3}
|
||||
string tolower [list [catch {open test3 WRONLY} msg] $msg]
|
||||
} {1 {couldn't open "test3": no such file or directory}}
|
||||
test open-14.4 {POSIX open access modes: WRONLY} {
|
||||
exec echo xyzzy > test3
|
||||
set f [open test3 WRONLY]
|
||||
puts -nonewline $f "ab"
|
||||
seek $f 0 current
|
||||
set x [list [catch {gets $f} msg] $msg]
|
||||
close $f
|
||||
lappend x [exec cat test3]
|
||||
|
||||
# The regsub is needed to avoid false errors if the file
|
||||
# number varies from system to system.
|
||||
|
||||
regsub {"file."} $x {"file"} x
|
||||
set x
|
||||
} {1 {"file" wasn't opened for reading} abzzy}
|
||||
test open-14.5 {POSIX open access modes: RDWR} {
|
||||
catch {exec rm -f test3}
|
||||
string tolower [list [catch {open test3 RDWR} msg] $msg]
|
||||
} {1 {couldn't open "test3": no such file or directory}}
|
||||
test open-14.6 {POSIX open access modes: RDWR} {
|
||||
exec echo xyzzy > test3
|
||||
set f [open test3 RDWR]
|
||||
puts -nonewline $f "ab"
|
||||
seek $f 0 current
|
||||
set x [gets $f]
|
||||
close $f
|
||||
lappend x [exec cat test3]
|
||||
} {zzy abzzy}
|
||||
test open-14.7 {POSIX open access modes: CREAT} {
|
||||
catch {exec rm -f test3}
|
||||
set f [open test3 {WRONLY CREAT} 0600]
|
||||
file stat test3 stats
|
||||
set x [format "0%o" [expr $stats(mode)&0777]]
|
||||
puts $f "line 1"
|
||||
close $f
|
||||
lappend x [exec cat test3]
|
||||
} {0600 {line 1}}
|
||||
if $atBerkeley {
|
||||
test open-14.8 {POSIX open access modes: CREAT} {
|
||||
catch {exec rm -f test3}
|
||||
set f [open test3 {WRONLY CREAT}]
|
||||
close $f
|
||||
file stat test3 stats
|
||||
format "0%o" [expr $stats(mode)&0777]
|
||||
} 0664
|
||||
}
|
||||
test open-14.9 {POSIX open access modes: CREAT} {
|
||||
exec echo xyzzy > test3
|
||||
set f [open test3 {WRONLY CREAT}]
|
||||
puts -nonewline $f "ab"
|
||||
close $f
|
||||
exec cat test3
|
||||
} abzzy
|
||||
test open-14.10 {POSIX open access modes: APPEND} {
|
||||
exec echo xyzzy > test3
|
||||
set f [open test3 {WRONLY APPEND}]
|
||||
puts $f "new line"
|
||||
seek $f 0
|
||||
puts $f "abc"
|
||||
close $f
|
||||
exec cat test3
|
||||
} {xyzzy
|
||||
new line
|
||||
abc}
|
||||
test open-14.11 {POSIX open access modes: EXCL} {
|
||||
exec echo xyzzy > test3
|
||||
set msg [list [catch {open test3 {WRONLY CREAT EXCL}} msg] $msg]
|
||||
regsub " already " $msg " " msg
|
||||
string tolower $msg
|
||||
} {1 {couldn't open "test3": file exists}}
|
||||
test open-14.12 {POSIX open access modes: EXCL} {
|
||||
catch {exec rm -f test3}
|
||||
set x [catch {set f [open test3 {WRONLY CREAT EXCL}]}]
|
||||
puts $f "A test line"
|
||||
close $f
|
||||
lappend x [exec cat test3]
|
||||
} {0 {A test line}}
|
||||
test open-14.13 {POSIX open access modes: TRUNC} {
|
||||
exec echo xyzzy > test3
|
||||
set f [open test3 {WRONLY TRUNC}]
|
||||
puts $f abc
|
||||
close $f
|
||||
exec cat test3
|
||||
} {abc}
|
||||
if $atBerkeley {
|
||||
test open-14.14 {POSIX open access modes: NOCTTY} {
|
||||
catch {exec rm -f test3}
|
||||
list [catch {open test3 {WRONLY NOCTTY CREAT}} msg] $msg
|
||||
} {1 {access mode "NOCTTY" not supported by this system}}
|
||||
test open-14.15 {POSIX open access modes: NONBLOCK} {
|
||||
catch {exec rm -f test3}
|
||||
set f [open test3 {WRONLY NONBLOCK CREAT}]
|
||||
puts $f "NONBLOCK test"
|
||||
close $f
|
||||
exec cat test3
|
||||
} {NONBLOCK test}
|
||||
}
|
||||
test open-14.16 {POSIX open access modes: errors} {
|
||||
concat [catch {open test3 "FOO \{BAR BAZ"} msg] $msg\n$errorInfo
|
||||
} "1 unmatched open brace in list
|
||||
unmatched open brace in list
|
||||
while processing open access modes \"FOO {BAR BAZ\"
|
||||
invoked from within
|
||||
\"open test3 \"FOO \\{BAR BAZ\"\""
|
||||
test open-14.17 {POSIX open access modes: errors} {
|
||||
list [catch {open test3 {FOO BAR BAZ}} msg] $msg
|
||||
} {1 {invalid access mode "FOO": must be RDONLY, WRONLY, RDWR, APPEND, CREAT EXCL, NOCTTY, NONBLOCK, or TRUNC}}
|
||||
test open-14.18 {POSIX open access modes: errors} {
|
||||
list [catch {open test3 {TRUNC CREAT}} msg] $msg
|
||||
} {1 {access mode must include either RDONLY, WRONLY, or RDWR}}
|
||||
|
||||
catch {exec rm -f test1 test2 test3}
|
||||
concat {}
|
||||
429
tcl7.3/tests/parse.test
Normal file
429
tcl7.3/tests/parse.test
Normal file
@@ -0,0 +1,429 @@
|
||||
# Commands covered: set (plus basic command syntax)
|
||||
#
|
||||
# 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.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/parse.test,v 1.24 93/07/28 13:07:14 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
proc fourArgs {a b c d} {
|
||||
global arg1 arg2 arg3 arg4
|
||||
set arg1 $a
|
||||
set arg2 $b
|
||||
set arg3 $c
|
||||
set arg4 $d
|
||||
}
|
||||
|
||||
proc getArgs args {
|
||||
global argv
|
||||
set argv $args
|
||||
}
|
||||
|
||||
# Basic argument parsing.
|
||||
|
||||
test parse-1.1 {basic argument parsing} {
|
||||
set arg1 {}
|
||||
fourArgs a b c d
|
||||
list $arg1 $arg2 $arg3 $arg4
|
||||
} {a b c d}
|
||||
test parse-1.2 {basic argument parsing} {
|
||||
set arg1 {}
|
||||
eval "fourArgs 123\v4\f56\r7890"
|
||||
list $arg1 $arg2 $arg3 $arg4
|
||||
} {123 4 56 7890}
|
||||
|
||||
# Quotes.
|
||||
|
||||
test parse-2.1 {quotes and variable-substitution} {
|
||||
getArgs "a b c" d
|
||||
set argv
|
||||
} {{a b c} d}
|
||||
test parse-2.2 {quotes and variable-substitution} {
|
||||
set a 101
|
||||
getArgs "a$a b c"
|
||||
set argv
|
||||
} {{a101 b c}}
|
||||
test parse-2.3 {quotes and variable-substitution} {
|
||||
set argv "xy[format xabc]"
|
||||
set argv
|
||||
} {xyxabc}
|
||||
test parse-2.4 {quotes and variable-substitution} {
|
||||
set argv "xy\t"
|
||||
set argv
|
||||
} xy\t
|
||||
test parse-2.5 {quotes and variable-substitution} {
|
||||
set argv "a b c
|
||||
d e f"
|
||||
set argv
|
||||
} a\ b\tc\nd\ e\ f
|
||||
test parse-2.6 {quotes and variable-substitution} {
|
||||
set argv a"bcd"e
|
||||
set argv
|
||||
} {a"bcd"e}
|
||||
|
||||
# Braces.
|
||||
|
||||
test parse-3.1 {braces} {
|
||||
getArgs {a b c} d
|
||||
set argv
|
||||
} "{a b c} d"
|
||||
test parse-3.2 {braces} {
|
||||
set a 101
|
||||
set argv {a$a b c}
|
||||
set b [string index $argv 1]
|
||||
set b
|
||||
} {$}
|
||||
test parse-3.3 {braces} {
|
||||
set argv {a[format xyz] b}
|
||||
string length $argv
|
||||
} 15
|
||||
test parse-3.4 {braces} {
|
||||
set argv {a\nb\}}
|
||||
string length $argv
|
||||
} 6
|
||||
test parse-3.5 {braces} {
|
||||
set argv {{{{}}}}
|
||||
set argv
|
||||
} "{{{}}}"
|
||||
test parse-3.6 {braces} {
|
||||
set argv a{{}}b
|
||||
set argv
|
||||
} "a{{}}b"
|
||||
test parse-3.7 {braces} {
|
||||
set a [format "last]"]
|
||||
set a
|
||||
} {last]}
|
||||
|
||||
# Command substitution.
|
||||
|
||||
test parse-4.1 {command substitution} {
|
||||
set a [format xyz]
|
||||
set a
|
||||
} xyz
|
||||
test parse-4.2 {command substitution} {
|
||||
set a a[format xyz]b[format q]
|
||||
set a
|
||||
} axyzbq
|
||||
test parse-4.3 {command substitution} {
|
||||
set a a[
|
||||
set b 22;
|
||||
format %s $b
|
||||
|
||||
]b
|
||||
set a
|
||||
} a22b
|
||||
|
||||
# Variable substitution.
|
||||
|
||||
test parse-5.1 {variable substitution} {
|
||||
set a 123
|
||||
set b $a
|
||||
set b
|
||||
} 123
|
||||
test parse-5.2 {variable substitution} {
|
||||
set a 345
|
||||
set b x$a.b
|
||||
set b
|
||||
} x345.b
|
||||
test parse-5.3 {variable substitution} {
|
||||
set _123z xx
|
||||
set b $_123z^
|
||||
set b
|
||||
} xx^
|
||||
test parse-5.4 {variable substitution} {
|
||||
set a 78
|
||||
set b a${a}b
|
||||
set b
|
||||
} a78b
|
||||
test parse-5.5 {variable substitution} {catch {$_non_existent_} msg} 1
|
||||
test parse-5.6 {variable substitution} {
|
||||
catch {$_non_existent_} msg
|
||||
set msg
|
||||
} {can't read "_non_existent_": no such variable}
|
||||
test parse-5.7 {array variable substitution} {
|
||||
catch {unset a}
|
||||
set a(xyz) 123
|
||||
set b $a(xyz)foo
|
||||
set b
|
||||
} 123foo
|
||||
test parse-5.8 {array variable substitution} {
|
||||
catch {unset a}
|
||||
set "a(x y z)" 123
|
||||
set b $a(x y z)foo
|
||||
set b
|
||||
} 123foo
|
||||
test parse-5.9 {array variable substitution} {
|
||||
catch {unset a}; catch {unset qqq}
|
||||
set "a(x y z)" qqq
|
||||
set $a([format x]\ y [format z]) foo
|
||||
set qqq
|
||||
} foo
|
||||
test parse-5.10 {array variable substitution} {
|
||||
catch {unset a}
|
||||
list [catch {set b $a(22)} msg] $msg
|
||||
} {1 {can't read "a(22)": no such variable}}
|
||||
test parse-5.11 {array variable substitution} {
|
||||
set b a$!
|
||||
set b
|
||||
} {a$!}
|
||||
test parse-5.12 {array variable substitution} {
|
||||
set b a$()
|
||||
set b
|
||||
} {a$()}
|
||||
catch {unset a}
|
||||
test parse-5.13 {array variable substitution} {
|
||||
catch {unset a}
|
||||
set long {This is a very long variable, long enough to cause storage \
|
||||
allocation to occur in Tcl_ParseVar. If that storage isn't getting \
|
||||
freed up correctly, then a core leak will occur when this test is \
|
||||
run. This text is probably beginning to sound like drivel, but I've \
|
||||
run out of things to say and I need more characters still.}
|
||||
set a($long) 777
|
||||
set b $a($long)
|
||||
list $b [array names a]
|
||||
} {777 {{This is a very long variable, long enough to cause storage \
|
||||
allocation to occur in Tcl_ParseVar. If that storage isn't getting \
|
||||
freed up correctly, then a core leak will occur when this test is \
|
||||
run. This text is probably beginning to sound like drivel, but I've \
|
||||
run out of things to say and I need more characters still.}}}
|
||||
test parse-5.14 {array variable substitution} {
|
||||
catch {unset a}; catch {unset b}; catch {unset a1}
|
||||
set a1(22) foo
|
||||
set a(foo) bar
|
||||
set b $a($a1(22))
|
||||
set b
|
||||
} bar
|
||||
catch {unset a}; catch {unset a1}
|
||||
|
||||
# Backslash substitution.
|
||||
|
||||
set errNum 1
|
||||
proc bsCheck {char num} {
|
||||
global errNum
|
||||
test parse-6.$errNum {backslash substitution} {
|
||||
scan $char %c value
|
||||
set value
|
||||
} $num
|
||||
set errNum [expr $errNum+1]
|
||||
}
|
||||
|
||||
bsCheck \b 8
|
||||
bsCheck \e 101
|
||||
bsCheck \f 12
|
||||
bsCheck \n 10
|
||||
bsCheck \r 13
|
||||
bsCheck \t 9
|
||||
bsCheck \v 11
|
||||
bsCheck \{ 123
|
||||
bsCheck \} 125
|
||||
bsCheck \[ 91
|
||||
bsCheck \] 93
|
||||
bsCheck \$ 36
|
||||
bsCheck \ 32
|
||||
bsCheck \; 59
|
||||
bsCheck \\ 92
|
||||
bsCheck \Ca 67
|
||||
bsCheck \Ma 77
|
||||
bsCheck \CMa 67
|
||||
bsCheck \8a 8
|
||||
bsCheck \14 12
|
||||
bsCheck \141 97
|
||||
bsCheck \340 224
|
||||
bsCheck b\0 98
|
||||
bsCheck \x 120
|
||||
bsCheck \xa 10
|
||||
bsCheck \x41 65
|
||||
bsCheck \x541 65
|
||||
|
||||
test parse-7.1 {backslash substitution} {
|
||||
set a "\a\c\n\]\}"
|
||||
string length $a
|
||||
} 5
|
||||
test parse-7.2 {backslash substitution} {
|
||||
set a {\a\c\n\]\}}
|
||||
string length $a
|
||||
} 10
|
||||
test parse-7.3 {backslash substitution} {
|
||||
set a "abc\
|
||||
def"
|
||||
set a
|
||||
} {abc def}
|
||||
test parse-7.4 {backslash substitution} {
|
||||
set a {abc\
|
||||
def}
|
||||
set a
|
||||
} {abc def}
|
||||
test parse-7.5 {backslash substitution} {
|
||||
set msg {}
|
||||
set a xxx
|
||||
set error [catch {if {24 < \
|
||||
35} {set a 22} {set \
|
||||
a 33}} msg]
|
||||
list $error $msg $a
|
||||
} {0 22 22}
|
||||
test parse-7.6 {backslash substitution} {
|
||||
eval "concat abc\\"
|
||||
} "abc\\"
|
||||
test parse-7.7 {backslash substitution} {
|
||||
eval "concat \\\na"
|
||||
} "a"
|
||||
test parse-7.8 {backslash substitution} {
|
||||
eval "concat x\\\n \na"
|
||||
} "x a"
|
||||
test parse-7.9 {backslash substitution} {
|
||||
eval "concat \\x"
|
||||
} "x"
|
||||
test parse-7.10 {backslash substitution} {
|
||||
eval "list a b\\\nc d"
|
||||
} {a b c d}
|
||||
|
||||
# Semi-colon.
|
||||
|
||||
test parse-8.1 {semi-colons} {
|
||||
set b 0
|
||||
getArgs a;set b 2
|
||||
set argv
|
||||
} a
|
||||
test parse-8.2 {semi-colons} {
|
||||
set b 0
|
||||
getArgs a;set b 2
|
||||
set b
|
||||
} 2
|
||||
test parse-8.3 {semi-colons} {
|
||||
getArgs a b ; set b 1
|
||||
set argv
|
||||
} {a b}
|
||||
test parse-8.4 {semi-colons} {
|
||||
getArgs a b ; set b 1
|
||||
set b
|
||||
} 1
|
||||
|
||||
# The following checks are to ensure that the interpreter's result
|
||||
# gets re-initialized by Tcl_Eval in all the right places.
|
||||
|
||||
test parse-9.1 {result initialization} {concat abc} abc
|
||||
test parse-9.2 {result initialization} {concat abc; proc foo {} {}} {}
|
||||
test parse-9.3 {result initialization} {concat abc; proc foo {} $a} {}
|
||||
test parse-9.4 {result initialization} {proc foo {} [concat abc]} {}
|
||||
test parse-9.5 {result initialization} {concat abc; } abc
|
||||
test parse-9.6 {result initialization} {
|
||||
eval {
|
||||
concat abc
|
||||
}} abc
|
||||
test parse-9.7 {result initialization} {} {}
|
||||
test parse-9.8 {result initialization} {concat abc; ; ;} abc
|
||||
|
||||
# Syntax errors.
|
||||
|
||||
test parse-10.1 {syntax errors} {catch "set a \{bcd" msg} 1
|
||||
test parse-10.2 {syntax errors} {
|
||||
catch "set a \{bcd" msg
|
||||
set msg
|
||||
} {missing close-brace}
|
||||
test parse-10.3 {syntax errors} {catch {set a "bcd} msg} 1
|
||||
test parse-10.4 {syntax errors} {
|
||||
catch {set a "bcd} msg
|
||||
set msg
|
||||
} {missing "}
|
||||
test parse-10.5 {syntax errors} {catch {set a "bcd"xy} msg} 1
|
||||
test parse-10.6 {syntax errors} {
|
||||
catch {set a "bcd"xy} msg
|
||||
set msg
|
||||
} {extra characters after close-quote}
|
||||
test parse-10.7 {syntax errors} {catch "set a {bcd}xy" msg} 1
|
||||
test parse-10.8 {syntax errors} {
|
||||
catch "set a {bcd}xy" msg
|
||||
set msg
|
||||
} {extra characters after close-brace}
|
||||
test parse-10.9 {syntax errors} {catch {set a [format abc} msg} 1
|
||||
test parse-10.10 {syntax errors} {
|
||||
catch {set a [format abc} msg
|
||||
set msg
|
||||
} {missing close-bracket}
|
||||
test parse-10.11 {syntax errors} {catch gorp-a-lot msg} 1
|
||||
test parse-10.12 {syntax errors} {
|
||||
catch gorp-a-lot msg
|
||||
set msg
|
||||
} {invalid command name: "gorp-a-lot"}
|
||||
test parse-10.13 {syntax errors} {
|
||||
set a [concat {a}\
|
||||
{b}]
|
||||
set a
|
||||
} {a b}
|
||||
test parse-10.14 {syntax errors} {catch "concat \{a\}\\\n{b}" msg} 1
|
||||
test parse-10.15 {syntax errors} {
|
||||
catch "concat \{a\}\\\n{b}" msg
|
||||
set msg
|
||||
} {extra characters after close-brace}
|
||||
|
||||
# Long values (stressing storage management)
|
||||
|
||||
set a {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH}
|
||||
|
||||
test parse-11.1 {long values} {
|
||||
string length $a
|
||||
} 214
|
||||
test parse-11.2 {long values} {
|
||||
llength $a
|
||||
} 43
|
||||
test parse-1a1.3 {long values} {
|
||||
set b "1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH"
|
||||
set b
|
||||
} $a
|
||||
test parse-11.4 {long values} {
|
||||
set b "$a"
|
||||
set b
|
||||
} $a
|
||||
test parse-11.5 {long values} {
|
||||
set b [set a]
|
||||
set b
|
||||
} $a
|
||||
test parse-11.6 {long values} {
|
||||
set b [concat 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH]
|
||||
string length $b
|
||||
} 214
|
||||
test parse-11.7 {long values} {
|
||||
set b [concat 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH]
|
||||
llength $b
|
||||
} 43
|
||||
test parse-11.8 {long values} {
|
||||
set b
|
||||
} $a
|
||||
test parse-11.9 {long values} {
|
||||
set a [concat 0000 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ KKKK LLLL MMMM NNNN OOOO PPPP QQQQ RRRR SSSS TTTT UUUU VVVV WWWW XXXX YYYY ZZZZ]
|
||||
llength $a
|
||||
} 62
|
||||
set i 0
|
||||
foreach j [concat 0000 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ KKKK LLLL MMMM NNNN OOOO PPPP QQQQ RRRR SSSS TTTT UUUU VVVV WWWW XXXX YYYY ZZZZ] {
|
||||
set test [string index 0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ $i]
|
||||
set test $test$test$test$test
|
||||
set i [expr $i+1]
|
||||
test parse-11.10 {long values} {
|
||||
set j
|
||||
} $test
|
||||
}
|
||||
test parse-11.10 {test buffer overflow in backslashes in braces} {
|
||||
expr {"a" == {xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyy\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101}}
|
||||
} 0
|
||||
58
tcl7.3/tests/pid.test
Normal file
58
tcl7.3/tests/pid.test
Normal file
@@ -0,0 +1,58 @@
|
||||
# Commands covered: pid
|
||||
#
|
||||
# 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.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/pid.test,v 1.1 93/05/15 16:06:39 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
catch {exec rm -f test1}
|
||||
|
||||
test open-1.1 {pid command} {
|
||||
regexp {^[0-9]+$} [pid]
|
||||
} 1
|
||||
test open-1.2 {pid command} {
|
||||
set f [open {| echo foo | cat > /dev/null} w]
|
||||
set pids [pid $f]
|
||||
close $f
|
||||
list [llength $pids] [regexp {^[0-9]+$} [lindex $pids 0]] \
|
||||
[regexp {^[0-9]+$} [lindex $pids 1]] \
|
||||
[expr {[lindex $pids 0] == [lindex $pids 1]}]
|
||||
} {2 1 1 0}
|
||||
test open-1.3 {pid command} {
|
||||
set f [open test1 w]
|
||||
set pids [pid $f]
|
||||
close $f
|
||||
set pids
|
||||
} {}
|
||||
test open-1.4 {pid command} {
|
||||
list [catch {pid a b} msg] $msg
|
||||
} {1 {wrong # args: should be "pid ?fileId?"}}
|
||||
test open-1.5 {pid command} {
|
||||
list [catch {pid gorp} msg] $msg
|
||||
} {1 {bad file identifier "gorp"}}
|
||||
|
||||
catch {exec rm -f test1}
|
||||
concat {}
|
||||
450
tcl7.3/tests/proc.test
Normal file
450
tcl7.3/tests/proc.test
Normal file
@@ -0,0 +1,450 @@
|
||||
# Commands covered: proc, return, global
|
||||
#
|
||||
# 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.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/proc.test,v 1.15 93/08/03 16:10:28 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
proc tproc {} {return a; return b}
|
||||
test proc-1.1 {simple procedure call and return} {tproc} a
|
||||
proc tproc x {
|
||||
set x [expr $x+1]
|
||||
return $x
|
||||
}
|
||||
test proc-1.2 {simple procedure call and return} {tproc 2} 3
|
||||
test proc-1.3 {simple procedure call and return} {
|
||||
proc tproc {} {return foo}
|
||||
} {}
|
||||
test proc-1.4 {simple procedure call and return} {
|
||||
proc tproc {} {return}
|
||||
tproc
|
||||
} {}
|
||||
|
||||
test proc-2.1 {local and global variables} {
|
||||
proc tproc x {
|
||||
set x [expr $x+1]
|
||||
return $x
|
||||
}
|
||||
set x 42
|
||||
list [tproc 6] $x
|
||||
} {7 42}
|
||||
test proc-2.2 {local and global variables} {
|
||||
proc tproc x {
|
||||
set y [expr $x+1]
|
||||
return $y
|
||||
}
|
||||
set y 18
|
||||
list [tproc 6] $y
|
||||
} {7 18}
|
||||
test proc-2.3 {local and global variables} {
|
||||
proc tproc x {
|
||||
global y
|
||||
set y [expr $x+1]
|
||||
return $y
|
||||
}
|
||||
set y 189
|
||||
list [tproc 6] $y
|
||||
} {7 7}
|
||||
test proc-2.4 {local and global variables} {
|
||||
proc tproc x {
|
||||
global y
|
||||
return [expr $x+$y]
|
||||
}
|
||||
set y 189
|
||||
list [tproc 6] $y
|
||||
} {195 189}
|
||||
catch {unset _undefined_}
|
||||
test proc-2.5 {local and global variables} {
|
||||
proc tproc x {
|
||||
global _undefined_
|
||||
return $_undefined_
|
||||
}
|
||||
list [catch {tproc xxx} msg] $msg
|
||||
} {1 {can't read "_undefined_": no such variable}}
|
||||
test proc-2.6 {local and global variables} {
|
||||
set a 114
|
||||
set b 115
|
||||
global a b
|
||||
list $a $b
|
||||
} {114 115}
|
||||
|
||||
proc do {cmd} {eval $cmd}
|
||||
test proc-3.1 {local and global arrays} {
|
||||
catch {unset a}
|
||||
set a(0) 22
|
||||
list [catch {do {global a; set a(0)}} msg] $msg
|
||||
} {0 22}
|
||||
test proc-3.2 {local and global arrays} {
|
||||
catch {unset a}
|
||||
set a(x) 22
|
||||
list [catch {do {global a; set a(x) newValue}} msg] $msg $a(x)
|
||||
} {0 newValue newValue}
|
||||
test proc-3.3 {local and global arrays} {
|
||||
catch {unset a}
|
||||
set a(x) 22
|
||||
set a(y) 33
|
||||
list [catch {do {global a; unset a(y)}; array names a} msg] $msg
|
||||
} {0 x}
|
||||
test proc-3.4 {local and global arrays} {
|
||||
catch {unset a}
|
||||
set a(x) 22
|
||||
set a(y) 33
|
||||
list [catch {do {global a; unset a; info exists a}} msg] $msg \
|
||||
[info exists a]
|
||||
} {0 0 0}
|
||||
test proc-3.5 {local and global arrays} {
|
||||
catch {unset a}
|
||||
set a(x) 22
|
||||
set a(y) 33
|
||||
list [catch {do {global a; unset a(y); array names a}} msg] $msg
|
||||
} {0 x}
|
||||
catch {unset a}
|
||||
test proc-3.6 {local and global arrays} {
|
||||
catch {unset a}
|
||||
set a(x) 22
|
||||
set a(y) 33
|
||||
do {global a; do {global a; unset a}; set a(z) 22}
|
||||
list [catch {array names a} msg] $msg
|
||||
} {0 z}
|
||||
test proc-3.7 {local and global arrays} {
|
||||
proc t1 {args} {global info; set info 1}
|
||||
catch {unset a}
|
||||
set info {}
|
||||
do {global a; trace var a(1) w t1}
|
||||
set a(1) 44
|
||||
set info
|
||||
} 1
|
||||
test proc-3.8 {local and global arrays} {
|
||||
proc t1 {args} {global info; set info 1}
|
||||
catch {unset a}
|
||||
trace var a(1) w t1
|
||||
set info {}
|
||||
do {global a; trace vdelete a(1) w t1}
|
||||
set a(1) 44
|
||||
set info
|
||||
} {}
|
||||
test proc-3.9 {local and global arrays} {
|
||||
proc t1 {args} {global info; set info 1}
|
||||
catch {unset a}
|
||||
trace var a(1) w t1
|
||||
do {global a; trace vinfo a(1)}
|
||||
} {{w t1}}
|
||||
catch {unset a}
|
||||
|
||||
test proc-3.1 {arguments and defaults} {
|
||||
proc tproc {x y z} {
|
||||
return [list $x $y $z]
|
||||
}
|
||||
tproc 11 12 13
|
||||
} {11 12 13}
|
||||
test proc-3.2 {arguments and defaults} {
|
||||
proc tproc {x y z} {
|
||||
return [list $x $y $z]
|
||||
}
|
||||
list [catch {tproc 11 12} msg] $msg
|
||||
} {1 {no value given for parameter "z" to "tproc"}}
|
||||
test proc-3.3 {arguments and defaults} {
|
||||
proc tproc {x y z} {
|
||||
return [list $x $y $z]
|
||||
}
|
||||
list [catch {tproc 11 12 13 14} msg] $msg
|
||||
} {1 {called "tproc" with too many arguments}}
|
||||
test proc-3.4 {arguments and defaults} {
|
||||
proc tproc {x {y y-default} {z z-default}} {
|
||||
return [list $x $y $z]
|
||||
}
|
||||
tproc 11 12 13
|
||||
} {11 12 13}
|
||||
test proc-3.5 {arguments and defaults} {
|
||||
proc tproc {x {y y-default} {z z-default}} {
|
||||
return [list $x $y $z]
|
||||
}
|
||||
tproc 11 12
|
||||
} {11 12 z-default}
|
||||
test proc-3.6 {arguments and defaults} {
|
||||
proc tproc {x {y y-default} {z z-default}} {
|
||||
return [list $x $y $z]
|
||||
}
|
||||
tproc 11
|
||||
} {11 y-default z-default}
|
||||
test proc-3.7 {arguments and defaults} {
|
||||
proc tproc {x {y y-default} {z z-default}} {
|
||||
return [list $x $y $z]
|
||||
}
|
||||
list [catch {tproc} msg] $msg
|
||||
} {1 {no value given for parameter "x" to "tproc"}}
|
||||
test proc-3.8 {arguments and defaults} {
|
||||
list [catch {
|
||||
proc tproc {x {y y-default} z} {
|
||||
return [list $x $y $z]
|
||||
}
|
||||
tproc 2 3
|
||||
} msg] $msg
|
||||
} {1 {no value given for parameter "z" to "tproc"}}
|
||||
test proc-3.9 {arguments and defaults} {
|
||||
proc tproc {x {y y-default} args} {
|
||||
return [list $x $y $args]
|
||||
}
|
||||
tproc 2 3 4 5
|
||||
} {2 3 {4 5}}
|
||||
test proc-3.10 {arguments and defaults} {
|
||||
proc tproc {x {y y-default} args} {
|
||||
return [list $x $y $args]
|
||||
}
|
||||
tproc 2 3
|
||||
} {2 3 {}}
|
||||
test proc-3.11 {arguments and defaults} {
|
||||
proc tproc {x {y y-default} args} {
|
||||
return [list $x $y $args]
|
||||
}
|
||||
tproc 2
|
||||
} {2 y-default {}}
|
||||
test proc-3.12 {arguments and defaults} {
|
||||
proc tproc {x {y y-default} args} {
|
||||
return [list $x $y $args]
|
||||
}
|
||||
list [catch {tproc} msg] $msg
|
||||
} {1 {no value given for parameter "x" to "tproc"}}
|
||||
|
||||
test proc-4.1 {variable numbers of arguments} {
|
||||
proc tproc args {return $args}
|
||||
tproc
|
||||
} {}
|
||||
test proc-4.2 {variable numbers of arguments} {
|
||||
proc tproc args {return $args}
|
||||
tproc 1 2 3 4 5 6 7 8
|
||||
} {1 2 3 4 5 6 7 8}
|
||||
test proc-4.3 {variable numbers of arguments} {
|
||||
proc tproc args {return $args}
|
||||
tproc 1 {2 3} {4 {5 6} {{{7}}}} 8
|
||||
} {1 {2 3} {4 {5 6} {{{7}}}} 8}
|
||||
test proc-4.4 {variable numbers of arguments} {
|
||||
proc tproc {x y args} {return $args}
|
||||
tproc 1 2 3 4 5 6 7
|
||||
} {3 4 5 6 7}
|
||||
test proc-4.5 {variable numbers of arguments} {
|
||||
proc tproc {x y args} {return $args}
|
||||
tproc 1 2
|
||||
} {}
|
||||
test proc-4.6 {variable numbers of arguments} {
|
||||
proc tproc {x missing args} {return $args}
|
||||
list [catch {tproc 1} msg] $msg
|
||||
} {1 {no value given for parameter "missing" to "tproc"}}
|
||||
|
||||
test proc-5.1 {error conditions} {
|
||||
list [catch {proc} msg] $msg
|
||||
} {1 {wrong # args: should be "proc name args body"}}
|
||||
test proc-5.2 {error conditions} {
|
||||
list [catch {proc tproc b} msg] $msg
|
||||
} {1 {wrong # args: should be "proc name args body"}}
|
||||
test proc-5.3 {error conditions} {
|
||||
list [catch {proc tproc b c d e} msg] $msg
|
||||
} {1 {wrong # args: should be "proc name args body"}}
|
||||
test proc-5.4 {error conditions} {
|
||||
list [catch {proc tproc \{xyz {return foo}} msg] $msg
|
||||
} {1 {unmatched open brace in list}}
|
||||
test proc-5.5 {error conditions} {
|
||||
list [catch {proc tproc {{} y} {return foo}} msg] $msg
|
||||
} {1 {procedure "tproc" has argument with no name}}
|
||||
test proc-5.6 {error conditions} {
|
||||
list [catch {proc tproc {{} y} {return foo}} msg] $msg
|
||||
} {1 {procedure "tproc" has argument with no name}}
|
||||
test proc-5.7 {error conditions} {
|
||||
list [catch {proc tproc {{x 1 2} y} {return foo}} msg] $msg
|
||||
} {1 {too many fields in argument specifier "x 1 2"}}
|
||||
test proc-5.8 {error conditions} {
|
||||
catch {return}
|
||||
} 2
|
||||
test proc-5.9 {error conditions} {
|
||||
list [catch {global} msg] $msg
|
||||
} {1 {wrong # args: should be "global varName ?varName ...?"}}
|
||||
proc tproc {} {
|
||||
set a 22
|
||||
global a
|
||||
}
|
||||
test proc-5.10 {error conditions} {
|
||||
list [catch {tproc} msg] $msg
|
||||
} {1 {variable "a" already exists}}
|
||||
test proc-5.11 {error conditions} {
|
||||
catch {rename tproc {}}
|
||||
catch {
|
||||
proc tproc {x {} z} {return foo}
|
||||
}
|
||||
list [catch {tproc 1} msg] $msg
|
||||
} {1 {invalid command name: "tproc"}}
|
||||
test proc-5.12 {error conditions} {
|
||||
proc tproc {} {
|
||||
set a 22
|
||||
error "error in procedure"
|
||||
return
|
||||
}
|
||||
list [catch tproc msg] $msg
|
||||
} {1 {error in procedure}}
|
||||
test proc-5.13 {error conditions} {
|
||||
proc tproc {} {
|
||||
set a 22
|
||||
error "error in procedure"
|
||||
return
|
||||
}
|
||||
catch tproc msg
|
||||
set errorInfo
|
||||
} {error in procedure
|
||||
while executing
|
||||
"error "error in procedure""
|
||||
(procedure "tproc" line 3)
|
||||
invoked from within
|
||||
"tproc"}
|
||||
test proc-5.14 {error conditions} {
|
||||
proc tproc {} {
|
||||
set a 22
|
||||
break
|
||||
return
|
||||
}
|
||||
catch tproc msg
|
||||
set errorInfo
|
||||
} {invoked "break" outside of a loop
|
||||
while executing
|
||||
"tproc"}
|
||||
test proc-5.15 {error conditions} {
|
||||
proc tproc {} {
|
||||
set a 22
|
||||
continue
|
||||
return
|
||||
}
|
||||
catch tproc msg
|
||||
set errorInfo
|
||||
} {invoked "continue" outside of a loop
|
||||
while executing
|
||||
"tproc"}
|
||||
|
||||
# The tests below will really only be useful when run under Purify or
|
||||
# some other system that can detect accesses to freed memory...
|
||||
|
||||
test proc-6.1 {procedure that redefines itself} {
|
||||
proc tproc {} {
|
||||
proc tproc {} {
|
||||
return 44
|
||||
}
|
||||
return 45
|
||||
}
|
||||
tproc
|
||||
} 45
|
||||
test proc-6.2 {procedure that deletes itself} {
|
||||
proc tproc {} {
|
||||
rename tproc {}
|
||||
return 45
|
||||
}
|
||||
tproc
|
||||
} 45
|
||||
|
||||
proc tproc code {
|
||||
return -code $code abc
|
||||
}
|
||||
test proc-7.1 {return with special completion code} {
|
||||
list [catch {tproc ok} msg] $msg
|
||||
} {0 abc}
|
||||
test proc-7.2 {return with special completion code} {
|
||||
list [catch {tproc error} msg] $msg $errorInfo $errorCode
|
||||
} {1 abc {abc
|
||||
while executing
|
||||
"tproc error"} NONE}
|
||||
test proc-7.3 {return with special completion code} {
|
||||
list [catch {tproc return} msg] $msg
|
||||
} {2 abc}
|
||||
test proc-7.4 {return with special completion code} {
|
||||
list [catch {tproc break} msg] $msg
|
||||
} {3 abc}
|
||||
test proc-7.5 {return with special completion code} {
|
||||
list [catch {tproc continue} msg] $msg
|
||||
} {4 abc}
|
||||
test proc-7.6 {return with special completion code} {
|
||||
list [catch {tproc -14} msg] $msg
|
||||
} {-14 abc}
|
||||
test proc-7.7 {return with special completion code} {
|
||||
list [catch {tproc gorp} msg] $msg
|
||||
} {1 {bad completion code "gorp": must be ok, error, return, break, continue, or an integer}}
|
||||
test proc-7.8 {return with special completion code} {
|
||||
list [catch {tproc 10b} msg] $msg
|
||||
} {1 {bad completion code "10b": must be ok, error, return, break, continue, or an integer}}
|
||||
test proc-7.9 {return with special completion code} {
|
||||
proc tproc2 {} {
|
||||
tproc return
|
||||
}
|
||||
list [catch tproc2 msg] $msg
|
||||
} {0 abc}
|
||||
test proc-7.10 {return with special completion code} {
|
||||
proc tproc2 {} {
|
||||
return -code error
|
||||
}
|
||||
list [catch tproc2 msg] $msg
|
||||
} {1 {}}
|
||||
test proc-7.11 {return with special completion code} {
|
||||
proc tproc2 {} {
|
||||
global errorCode errorInfo
|
||||
catch {open _bad_file_name r} msg
|
||||
return -code error -errorinfo $errorInfo -errorcode $errorCode $msg
|
||||
}
|
||||
string tolower [list [catch tproc2 msg] $msg $errorInfo $errorCode]
|
||||
} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
|
||||
while executing
|
||||
"open _bad_file_name r"
|
||||
invoked from within
|
||||
"tproc2"} {posix enoent {no such file or directory}}}
|
||||
test proc-7.12 {return with special completion code} {
|
||||
proc tproc2 {} {
|
||||
global errorCode errorInfo
|
||||
catch {open _bad_file_name r} msg
|
||||
return -code error -errorcode $errorCode $msg
|
||||
}
|
||||
string tolower [list [catch tproc2 msg] $msg $errorInfo $errorCode]
|
||||
} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
|
||||
while executing
|
||||
"tproc2"} {posix enoent {no such file or directory}}}
|
||||
test proc-7.13 {return with special completion code} {
|
||||
proc tproc2 {} {
|
||||
global errorCode errorInfo
|
||||
catch {open _bad_file_name r} msg
|
||||
return -code error -errorinfo $errorInfo $msg
|
||||
}
|
||||
string tolower [list [catch tproc2 msg] $msg $errorInfo $errorCode]
|
||||
} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
|
||||
while executing
|
||||
"open _bad_file_name r"
|
||||
invoked from within
|
||||
"tproc2"} none}
|
||||
test proc-7.14 {return with special completion code} {
|
||||
proc tproc2 {} {
|
||||
global errorCode errorInfo
|
||||
catch {open _bad_file_name r} msg
|
||||
return -code error $msg
|
||||
}
|
||||
string tolower [list [catch tproc2 msg] $msg $errorInfo $errorCode]
|
||||
} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
|
||||
while executing
|
||||
"tproc2"} none}
|
||||
test proc-7.14 {return with special completion code} {
|
||||
list [catch {return -badOption foo message} msg] $msg
|
||||
} {1 {bad option "-badOption: must be -code, -errorcode, or -errorinfo}}
|
||||
324
tcl7.3/tests/regexp.test
Normal file
324
tcl7.3/tests/regexp.test
Normal file
@@ -0,0 +1,324 @@
|
||||
# Commands covered: regexp, regsub
|
||||
#
|
||||
# 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.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/regexp.test,v 1.13 93/10/14 14:53:21 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
catch {unset foo}
|
||||
test regexp-1.1 {basic regexp operation} {
|
||||
regexp ab*c abbbc
|
||||
} 1
|
||||
test regexp-1.2 {basic regexp operation} {
|
||||
regexp ab*c ac
|
||||
} 1
|
||||
test regexp-1.3 {basic regexp operation} {
|
||||
regexp ab*c ab
|
||||
} 0
|
||||
test regexp-1.4 {basic regexp operation} {
|
||||
regexp -- -gorp abc-gorpxxx
|
||||
} 1
|
||||
|
||||
test regexp-2.1 {getting substrings back from regexp} {
|
||||
set foo {}
|
||||
list [regexp ab*c abbbbc foo] $foo
|
||||
} {1 abbbbc}
|
||||
test regexp-2.2 {getting substrings back from regexp} {
|
||||
set foo {}
|
||||
set f2 {}
|
||||
list [regexp a(b*)c abbbbc foo f2] $foo $f2
|
||||
} {1 abbbbc bbbb}
|
||||
test regexp-2.3 {getting substrings back from regexp} {
|
||||
set foo {}
|
||||
set f2 {}
|
||||
list [regexp a(b*)(c) abbbbc foo f2] $foo $f2
|
||||
} {1 abbbbc bbbb}
|
||||
test regexp-2.4 {getting substrings back from regexp} {
|
||||
set foo {}
|
||||
set f2 {}
|
||||
set f3 {}
|
||||
list [regexp a(b*)(c) abbbbc foo f2 f3] $foo $f2 $f3
|
||||
} {1 abbbbc bbbb c}
|
||||
test regexp-2.5 {getting substrings back from regexp} {
|
||||
set foo {}; set f1 {}; set f2 {}; set f3 {}; set f4 {}; set f5 {};
|
||||
set f6 {}; set f7 {}; set f8 {}; set f9 {}
|
||||
list [regexp (1*)(2*)(3*)(4*)(5*)(6*)(7*)(8*)(9*) 12223345556789999 \
|
||||
foo f1 f2 f3 f4 f5 f6 f7 f8 f9] $foo $f1 $f2 $f3 $f4 $f5 \
|
||||
$f6 $f7 $f8 $f9
|
||||
} {1 12223345556789999 1 222 33 4 555 6 7 8 9999}
|
||||
test regexp-2.6 {getting substrings back from regexp} {
|
||||
set foo 2; set f2 2; set f3 2; set f4 2
|
||||
list [regexp (a)(b)? xay foo f2 f3 f4] $foo $f2 $f3 $f4
|
||||
} {1 a a {} {}}
|
||||
test regexp-2.7 {getting substrings back from regexp} {
|
||||
set foo 1; set f2 1; set f3 1; set f4 1
|
||||
list [regexp (a)(b)?(c) xacy foo f2 f3 f4] $foo $f2 $f3 $f4
|
||||
} {1 ac a {} c}
|
||||
|
||||
test regexp-3.1 {-indices option to regexp} {
|
||||
set foo {}
|
||||
list [regexp -indices ab*c abbbbc foo] $foo
|
||||
} {1 {0 5}}
|
||||
test regexp-3.2 {-indices option to regexp} {
|
||||
set foo {}
|
||||
set f2 {}
|
||||
list [regexp -indices a(b*)c abbbbc foo f2] $foo $f2
|
||||
} {1 {0 5} {1 4}}
|
||||
test regexp-3.3 {-indices option to regexp} {
|
||||
set foo {}
|
||||
set f2 {}
|
||||
list [regexp -indices a(b*)(c) abbbbc foo f2] $foo $f2
|
||||
} {1 {0 5} {1 4}}
|
||||
test regexp-3.4 {-indices option to regexp} {
|
||||
set foo {}
|
||||
set f2 {}
|
||||
set f3 {}
|
||||
list [regexp -indices a(b*)(c) abbbbc foo f2 f3] $foo $f2 $f3
|
||||
} {1 {0 5} {1 4} {5 5}}
|
||||
test regexp-3.5 {-indices option to regexp} {
|
||||
set foo {}; set f1 {}; set f2 {}; set f3 {}; set f4 {}; set f5 {};
|
||||
set f6 {}; set f7 {}; set f8 {}; set f9 {}
|
||||
list [regexp -indices (1*)(2*)(3*)(4*)(5*)(6*)(7*)(8*)(9*) \
|
||||
12223345556789999 \
|
||||
foo f1 f2 f3 f4 f5 f6 f7 f8 f9] $foo $f1 $f2 $f3 $f4 $f5 \
|
||||
$f6 $f7 $f8 $f9
|
||||
} {1 {0 16} {0 0} {1 3} {4 5} {6 6} {7 9} {10 10} {11 11} {12 12} {13 16}}
|
||||
test regexp-3.6 {getting substrings back from regexp} {
|
||||
set foo 2; set f2 2; set f3 2; set f4 2
|
||||
list [regexp -indices (a)(b)? xay foo f2 f3 f4] $foo $f2 $f3 $f4
|
||||
} {1 {1 1} {1 1} {-1 -1} {-1 -1}}
|
||||
test regexp-3.7 {getting substrings back from regexp} {
|
||||
set foo 1; set f2 1; set f3 1; set f4 1
|
||||
list [regexp -indices (a)(b)?(c) xacy foo f2 f3 f4] $foo $f2 $f3 $f4
|
||||
} {1 {1 2} {1 1} {-1 -1} {2 2}}
|
||||
|
||||
test regexp-4.1 {-nocase option to regexp} {
|
||||
regexp -nocase foo abcFOo
|
||||
} 1
|
||||
test regexp-4.2 {-nocase option to regexp} {
|
||||
set f1 22
|
||||
set f2 33
|
||||
set f3 44
|
||||
list [regexp -nocase {a(b*)([xy]*)z} aBbbxYXxxZ22 f1 f2 f3] $f1 $f2 $f3
|
||||
} {1 aBbbxYXxxZ Bbb xYXxx}
|
||||
test regexp-4.3 {-nocase option to regexp} {
|
||||
regexp -nocase FOo abcFOo
|
||||
} 1
|
||||
set x abcdefghijklmnopqrstuvwxyz1234567890
|
||||
set x $x$x$x$x$x$x$x$x$x$x$x$x
|
||||
test regexp-4.4 {case conversion in regsub} {
|
||||
list [regexp -nocase $x $x foo] $foo
|
||||
} "1 $x"
|
||||
unset x
|
||||
|
||||
test regexp-5.1 {exercise cache of compiled expressions} {
|
||||
regexp .*a b
|
||||
regexp .*b c
|
||||
regexp .*c d
|
||||
regexp .*d e
|
||||
regexp .*e f
|
||||
regexp .*a bbba
|
||||
} 1
|
||||
test regexp-5.2 {exercise cache of compiled expressions} {
|
||||
regexp .*a b
|
||||
regexp .*b c
|
||||
regexp .*c d
|
||||
regexp .*d e
|
||||
regexp .*e f
|
||||
regexp .*b xxxb
|
||||
} 1
|
||||
test regexp-5.3 {exercise cache of compiled expressions} {
|
||||
regexp .*a b
|
||||
regexp .*b c
|
||||
regexp .*c d
|
||||
regexp .*d e
|
||||
regexp .*e f
|
||||
regexp .*c yyyc
|
||||
} 1
|
||||
test regexp-5.4 {exercise cache of compiled expressions} {
|
||||
regexp .*a b
|
||||
regexp .*b c
|
||||
regexp .*c d
|
||||
regexp .*d e
|
||||
regexp .*e f
|
||||
regexp .*d 1d
|
||||
} 1
|
||||
test regexp-5.5 {exercise cache of compiled expressions} {
|
||||
regexp .*a b
|
||||
regexp .*b c
|
||||
regexp .*c d
|
||||
regexp .*d e
|
||||
regexp .*e f
|
||||
regexp .*e xe
|
||||
} 1
|
||||
|
||||
test regexp-6.1 {regexp errors} {
|
||||
list [catch {regexp a} msg] $msg
|
||||
} {1 {wrong # args: should be "regexp ?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"}}
|
||||
test regexp-6.2 {regexp errors} {
|
||||
list [catch {regexp -nocase a} msg] $msg
|
||||
} {1 {wrong # args: should be "regexp ?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"}}
|
||||
test regexp-6.3 {regexp errors} {
|
||||
list [catch {regexp -gorp a} msg] $msg
|
||||
} {1 {bad switch "-gorp": must be -indices, -nocase, or --}}
|
||||
test regexp-6.4 {regexp errors} {
|
||||
list [catch {regexp a( b} msg] $msg
|
||||
} {1 {couldn't compile regular expression pattern: unmatched ()}}
|
||||
test regexp-6.5 {regexp errors} {
|
||||
list [catch {regexp a( b} msg] $msg
|
||||
} {1 {couldn't compile regular expression pattern: unmatched ()}}
|
||||
test regexp-6.6 {regexp errors} {
|
||||
list [catch {regexp a a f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1} msg] $msg
|
||||
} {1 {too many substring variables}}
|
||||
test regexp-6.7 {regexp errors} {
|
||||
set f1 44
|
||||
list [catch {regexp abc abc f1(f2)} msg] $msg
|
||||
} {1 {couldn't set variable "f1(f2)"}}
|
||||
|
||||
test regexp-7.1 {basic regsub operation} {
|
||||
list [regsub aa+ xaxaaaxaa 111&222 foo] $foo
|
||||
} {1 xax111aaa222xaa}
|
||||
test regexp-7.2 {basic regsub operation} {
|
||||
list [regsub aa+ aaaxaa &111 foo] $foo
|
||||
} {1 aaa111xaa}
|
||||
test regexp-7.3 {basic regsub operation} {
|
||||
list [regsub aa+ xaxaaa 111& foo] $foo
|
||||
} {1 xax111aaa}
|
||||
test regexp-7.4 {basic regsub operation} {
|
||||
list [regsub aa+ aaa 11&2&333 foo] $foo
|
||||
} {1 11aaa2aaa333}
|
||||
test regexp-7.5 {basic regsub operation} {
|
||||
list [regsub aa+ xaxaaaxaa &2&333 foo] $foo
|
||||
} {1 xaxaaa2aaa333xaa}
|
||||
test regexp-7.6 {basic regsub operation} {
|
||||
list [regsub aa+ xaxaaaxaa 1&22& foo] $foo
|
||||
} {1 xax1aaa22aaaxaa}
|
||||
test regexp-7.7 {basic regsub operation} {
|
||||
list [regsub a(a+) xaxaaaxaa {1\122\1} foo] $foo
|
||||
} {1 xax1aa22aaxaa}
|
||||
test regexp-7.8 {basic regsub operation} {
|
||||
list [regsub a(a+) xaxaaaxaa {1\\\122\1} foo] $foo
|
||||
} "1 {xax1\\aa22aaxaa}"
|
||||
test regexp-7.9 {basic regsub operation} {
|
||||
list [regsub a(a+) xaxaaaxaa {1\\122\1} foo] $foo
|
||||
} "1 {xax1\\122aaxaa}"
|
||||
test regexp-7.10 {basic regsub operation} {
|
||||
list [regsub a(a+) xaxaaaxaa {1\\&\1} foo] $foo
|
||||
} "1 {xax1\\aaaaaxaa}"
|
||||
test regexp-7.11 {basic regsub operation} {
|
||||
list [regsub a(a+) xaxaaaxaa {1\&\1} foo] $foo
|
||||
} {1 xax1&aaxaa}
|
||||
test regexp-7.12 {basic regsub operation} {
|
||||
list [regsub a(a+) xaxaaaxaa {\1\1\1\1&&} foo] $foo
|
||||
} {1 xaxaaaaaaaaaaaaaaxaa}
|
||||
test regexp-7.13 {basic regsub operation} {
|
||||
set foo xxx
|
||||
list [regsub abc xyz 111 foo] $foo
|
||||
} {0 xyz}
|
||||
test regexp-7.14 {basic regsub operation} {
|
||||
set foo xxx
|
||||
list [regsub ^ xyz "111 " foo] $foo
|
||||
} {1 {111 xyz}}
|
||||
test regexp-7.15 {basic regsub operation} {
|
||||
set foo xxx
|
||||
list [regsub -- -foo abc-foodef "111 " foo] $foo
|
||||
} {1 {abc111 def}}
|
||||
test regexp-7.16 {basic regsub operation} {
|
||||
set foo xxx
|
||||
list [regsub x "" y foo] $foo
|
||||
} {0 {}}
|
||||
|
||||
test regexp-8.1 {case conversion in regsub} {
|
||||
list [regsub -nocase a(a+) xaAAaAAay & foo] $foo
|
||||
} {1 xaAAaAAay}
|
||||
test regexp-8.2 {case conversion in regsub} {
|
||||
list [regsub -nocase a(a+) xaAAaAAay & foo] $foo
|
||||
} {1 xaAAaAAay}
|
||||
test regexp-8.3 {case conversion in regsub} {
|
||||
set foo 123
|
||||
list [regsub a(a+) xaAAaAAay & foo] $foo
|
||||
} {0 xaAAaAAay}
|
||||
test regexp-8.4 {case conversion in regsub} {
|
||||
set foo 123
|
||||
list [regsub -nocase a CaDE b foo] $foo
|
||||
} {1 CbDE}
|
||||
test regexp-8.5 {case conversion in regsub} {
|
||||
set foo 123
|
||||
list [regsub -nocase XYZ CxYzD b foo] $foo
|
||||
} {1 CbD}
|
||||
test regexp-8.6 {case conversion in regsub} {
|
||||
set x abcdefghijklmnopqrstuvwxyz1234567890
|
||||
set x $x$x$x$x$x$x$x$x$x$x$x$x
|
||||
set foo 123
|
||||
list [regsub -nocase $x $x b foo] $foo
|
||||
} {1 b}
|
||||
|
||||
test regexp-9.1 {-all option to regsub} {
|
||||
set foo 86
|
||||
list [regsub -all x+ axxxbxxcxdx |&| foo] $foo
|
||||
} {1 a|xxx|b|xx|c|x|d|x|}
|
||||
test regexp-9.2 {-all option to regsub} {
|
||||
set foo 86
|
||||
list [regsub -nocase -all x+ aXxXbxxcXdx |&| foo] $foo
|
||||
} {1 a|XxX|b|xx|c|X|d|x|}
|
||||
test regexp-9.3 {-all option to regsub} {
|
||||
set foo 86
|
||||
list [regsub x+ axxxbxxcxdx |&| foo] $foo
|
||||
} {1 a|xxx|bxxcxdx}
|
||||
test regexp-9.4 {-all option to regsub} {
|
||||
set foo 86
|
||||
list [regsub -all bc axxxbxxcxdx |&| foo] $foo
|
||||
} {0 axxxbxxcxdx}
|
||||
test regexp-9.5 {-all option to regsub} {
|
||||
set foo xxx
|
||||
list [regsub -all node "node node more" yy foo] $foo
|
||||
} {1 {yy yy more}}
|
||||
test regexp-9.6 {-all option to regsub} {
|
||||
set foo xxx
|
||||
list [regsub -all ^ xxx 123 foo] $foo
|
||||
} {1 123xxx}
|
||||
|
||||
test regexp-10.1 {regsub errors} {
|
||||
list [catch {regsub a b c} msg] $msg
|
||||
} {1 {wrong # args: should be "regsub ?switches? exp string subSpec varName"}}
|
||||
test regexp-10.2 {regsub errors} {
|
||||
list [catch {regsub -nocase a b c} msg] $msg
|
||||
} {1 {wrong # args: should be "regsub ?switches? exp string subSpec varName"}}
|
||||
test regexp-10.3 {regsub errors} {
|
||||
list [catch {regsub -nocase -all a b c} msg] $msg
|
||||
} {1 {wrong # args: should be "regsub ?switches? exp string subSpec varName"}}
|
||||
test regexp-10.4 {regsub errors} {
|
||||
list [catch {regsub a b c d e f} msg] $msg
|
||||
} {1 {wrong # args: should be "regsub ?switches? exp string subSpec varName"}}
|
||||
test regexp-10.5 {regsub errors} {
|
||||
list [catch {regsub -gorp a b c} msg] $msg
|
||||
} {1 {bad switch "-gorp": must be -all, -nocase, or --}}
|
||||
test regexp-10.6 {regsub errors} {
|
||||
list [catch {regsub -nocase a( b c d} msg] $msg
|
||||
} {1 {couldn't compile regular expression pattern: unmatched ()}}
|
||||
test regexp-10.7 {regsub errors} {
|
||||
list [catch {regsub -nocase aaa aaa xxx f1(f2)} msg] $msg
|
||||
} {1 {couldn't set variable "f1(f2)"}}
|
||||
78
tcl7.3/tests/rename.test
Normal file
78
tcl7.3/tests/rename.test
Normal file
@@ -0,0 +1,78 @@
|
||||
# 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.
|
||||
#
|
||||
# Copyright (c) 1991-1993 The Regents of the University of California.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/rename.test,v 1.5 93/02/06 15:54:23 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
catch {rename r2 {}}
|
||||
proc r1 {} {return "procedure r1"}
|
||||
rename r1 r2
|
||||
test rename-1.1 {simple renaming} {
|
||||
r2
|
||||
} {procedure r1}
|
||||
test rename-1.2 {simple renaming} {
|
||||
list [catch r1 msg] $msg
|
||||
} {1 {invalid command name: "r1"}}
|
||||
rename r2 {}
|
||||
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.
|
||||
|
||||
rename list l.new
|
||||
set a [catch list msg1]
|
||||
set b [l.new a b c]
|
||||
rename l.new list
|
||||
set c [catch l.new msg2]
|
||||
set d [list 111 222]
|
||||
test 2.1 {renaming built-in command} {
|
||||
list $a $msg1 $b $c $msg2 $d
|
||||
} {1 {invalid command name: "list"} {a b c} 1 {invalid command name: "l.new"} {111 222}}
|
||||
|
||||
test rename-3.1 {error conditions} {
|
||||
list [catch {rename r1} msg] $msg $errorCode
|
||||
} {1 {wrong # args: should be "rename oldName newName"} NONE}
|
||||
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} {
|
||||
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} {
|
||||
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} {
|
||||
catch {rename _non_existent_command {}}
|
||||
list [catch {rename _non_existent_command {}} msg] $msg
|
||||
} {1 {can't delete "_non_existent_command": command doesn't exist}}
|
||||
276
tcl7.3/tests/scan.test
Normal file
276
tcl7.3/tests/scan.test
Normal file
@@ -0,0 +1,276 @@
|
||||
# Commands covered: scan
|
||||
#
|
||||
# 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.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/scan.test,v 1.17 93/10/07 10:39:35 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
test scan-1.1 {integer scanning} {
|
||||
set a {}; set b {}; set c {}; set d {}
|
||||
list [scan "-20 1476 \n33 0" "%d %d %d %d" a b c d] $a $b $c $d
|
||||
} {4 -20 1476 33 0}
|
||||
test scan-1.2 {integer scanning} {
|
||||
set a {}; set b {}; set c {}
|
||||
list [scan "-45 16 7890 +10" "%2d %*d %10d %d" a b c] $a $b $c
|
||||
} {3 -4 16 7890}
|
||||
test scan-1.3 {integer scanning} {
|
||||
set a {}; set b {}; set c {}; set d {}
|
||||
list [scan "-45 16 +10 987" "%ld %d %ld %d" a b c d] $a $b $c $d
|
||||
} {4 -45 16 10 987}
|
||||
test scan-1.4 {integer scanning} {
|
||||
set a {}; set b {}; set c {}; set d {}
|
||||
list [scan "14 1ab 62 10" "%d %x %lo %x" a b c d] $a $b $c $d
|
||||
} {4 14 427 50 16}
|
||||
test scan-1.5 {integer scanning} {
|
||||
set a {}; set b {}; set c {}; set d {}
|
||||
list [scan "12345670 1234567890ab cdefg" "%o %o %x %lx" a b c d] \
|
||||
$a $b $c $d
|
||||
} {4 2739128 342391 561323 52719}
|
||||
test scan-1.6 {integer scanning} {
|
||||
set a {}; set b {}; set c {}; set d {}
|
||||
list [scan "ab123-24642" "%2x %3x %3o %2o" a b c d] $a $b $c $d
|
||||
} {4 171 291 -20 52}
|
||||
test scan-1.7 {integer scanning} {
|
||||
set a {}; set b {}
|
||||
list [scan "1234567 234 567 " "%*3x %x %*o %4o" a b] $a $b
|
||||
} {2 17767 375}
|
||||
test scan-1.8 {integer scanning} {
|
||||
set a {}; set b {}
|
||||
list [scan "a 1234" "%d %d" a b] $a $b
|
||||
} {0 {} {}}
|
||||
test scan-1.9 {integer scanning} {
|
||||
set a {}; set b {}; set c {}; set d {};
|
||||
list [scan "12345678" "%2d %2d %2ld %2d" a b c d] $a $b $c $d
|
||||
} {4 12 34 56 78}
|
||||
test scan-1.10 {integer scanning} {
|
||||
set a {}; set b {}; set c {}; set d {}
|
||||
list [scan "1 2 " "%hd %d %d %d" a b c d] $a $b $c $d
|
||||
} {2 1 2 {} {}}
|
||||
if $atBerkeley {
|
||||
test scan-1.11 {integer scanning} {
|
||||
set a {}; set b {};
|
||||
list [scan "4294967280 4294967280" "%u %d" a b] $a $b
|
||||
} {2 4294967280 -16}
|
||||
}
|
||||
|
||||
test scan-2.1 {floating-point scanning} {
|
||||
set a {}; set b {}; set c {}; set d {}
|
||||
list [scan "2.1 -3.0e8 .99962 a" "%f%g%e%f" a b c d] $a $b $c $d
|
||||
} {3 2.1 -3e+08 0.99962 {}}
|
||||
test scan-2.2 {floating-point scanning} {
|
||||
set a {}; set b {}; set c {}; set d {}
|
||||
list [scan "-1.2345 +8.2 9" "%3e %3lf %f %f" a b c d] $a $b $c $d
|
||||
} {4 -1.0 234.0 5.0 8.2}
|
||||
test scan-2.3 {floating-point scanning} {
|
||||
set a {}; set b {}; set c {}
|
||||
list [scan "1e00004 332E-4 3e+4" "%Lf %*2e %f %f" a b c] $a $c
|
||||
} {3 10000.0 30000.0}
|
||||
if $atBerkeley {
|
||||
test scan-2.4 {floating-point scanning} {
|
||||
set a {}; set b {}; set c {}
|
||||
list [scan "1. 47.6 2.e2 3.e-" "%f %*f %f %f" a b c] $a $b $c
|
||||
} {3 1.0 200.0 3.0}
|
||||
test scan-2.5 {floating-point scanning} {
|
||||
set a {}; set b {}
|
||||
list [scan "1.eabc" "%f %x" a b] $a $b
|
||||
} {2 1.0 2748}
|
||||
}
|
||||
test scan-2.6 {floating-point scanning} {
|
||||
set a {}; set b {}; set c {}; set d {}
|
||||
list [scan "4.6 99999.7 876.43e-1 118" "%f %f %f %e" a b c d] $a $b $c $d
|
||||
} {4 4.6 99999.7 87.643 118.0}
|
||||
test scan-2.7 {floating-point scanning} {
|
||||
set a {}; set b {}; set c {}; set d {}
|
||||
list [scan "1.2345 697.0e-3 124 .00005" "%f %e %f %e" a b c d] $a $b $c $d
|
||||
} {4 1.2345 0.697 124.0 5e-05}
|
||||
test scan-2.8 {floating-point scanning} {
|
||||
set a {}; set b {}; set c {}; set d {}
|
||||
list [scan "4.6abc" "%f %f %f %f" a b c d] $a $b $c $d
|
||||
} {1 4.6 {} {} {}}
|
||||
test scan-2.9 {floating-point scanning} {
|
||||
set a {}; set b {}; set c {}; set d {}
|
||||
list [scan "4.6 5.2" "%f %f %f %f" a b c d] $a $b $c $d
|
||||
} {2 4.6 5.2 {} {}}
|
||||
|
||||
test scan-3.1 {string and character scanning} {
|
||||
set a {}; set b {}; set c {}; set d {}
|
||||
list [scan "abc defghijk dum " "%s %3s %20s %s" a b c d] $a $b $c $d
|
||||
} {4 abc def ghijk dum}
|
||||
test scan-3.2 {string and character scanning} {
|
||||
set a {}; set b {}; set c {}; set d {}
|
||||
list [scan "a bcdef" "%c%c%1s %s" a b c d] $a $b $c $d
|
||||
} {4 97 32 b cdef}
|
||||
test scan-3.3 {string and character scanning} {
|
||||
set a {}; set b {}; set c {}
|
||||
list [scan "123456 test " "%*c%*s %s %s %s" a b c] $a $b $c
|
||||
} {1 test {} {}}
|
||||
test scan-3.4 {string and character scanning} {
|
||||
set a {}; set b {}; set c {}; set d
|
||||
list [scan "ababcd01234 f 123450" {%4[abcd] %4[abcd] %[^abcdef] %[^0]} a b c d] $a $b $c $d
|
||||
} {4 abab cd {01234 } {f 12345}}
|
||||
test scan-3.5 {string and character scanning} {
|
||||
set a {}; set b {}; set c {}
|
||||
list [scan "aaaaaabc aaabcdefg + + XYZQR" {%*4[a] %s %*4[a]%s%*4[ +]%c} a b c] $a $b $c
|
||||
} {3 aabc bcdefg 43}
|
||||
|
||||
test scan-4.1 {error conditions} {
|
||||
catch {scan a}
|
||||
} 1
|
||||
test scan-4.2 {error conditions} {
|
||||
catch {scan a} msg
|
||||
set msg
|
||||
} {wrong # args: should be "scan string format ?varName varName ...?"}
|
||||
test scan-4.3 {error conditions} {
|
||||
catch {scan "1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21" "%d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d" a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21}
|
||||
} 1
|
||||
test scan-4.4 {error conditions} {
|
||||
catch {scan "1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21" "%d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d" a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21} msg
|
||||
set msg
|
||||
} {too many fields to scan}
|
||||
test scan-4.5 {error conditions} {
|
||||
list [catch {scan a %D} msg] $msg
|
||||
} {1 {bad scan conversion character "D"}}
|
||||
test scan-4.6 {error conditions} {
|
||||
list [catch {scan a %O} msg] $msg
|
||||
} {1 {bad scan conversion character "O"}}
|
||||
test scan-4.7 {error conditions} {
|
||||
list [catch {scan a %X} msg] $msg
|
||||
} {1 {bad scan conversion character "X"}}
|
||||
test scan-4.8 {error conditions} {
|
||||
list [catch {scan a %F} msg] $msg
|
||||
} {1 {bad scan conversion character "F"}}
|
||||
test scan-4.9 {error conditions} {
|
||||
list [catch {scan a %E} msg] $msg
|
||||
} {1 {bad scan conversion character "E"}}
|
||||
test scan-4.10 {error conditions} {
|
||||
list [catch {scan a "%d %d" a} msg] $msg
|
||||
} {1 {different numbers of variable names and field specifiers}}
|
||||
test scan-4.11 {error conditions} {
|
||||
list [catch {scan a "%d %d" a b c} msg] $msg
|
||||
} {1 {different numbers of variable names and field specifiers}}
|
||||
test scan-4.12 {error conditions} {
|
||||
set a {}; set b {}; set c {}; set d {}
|
||||
list [expr {[scan " a" " a %d %d %d %d" a b c d] <= 0}] $a $b $c $d
|
||||
} {1 {} {} {} {}}
|
||||
test scan-4.13 {error conditions} {
|
||||
set a {}; set b {}; set c {}; set d {}
|
||||
list [scan "1 2" "%d %d %d %d" a b c d] $a $b $c $d
|
||||
} {2 1 2 {} {}}
|
||||
test scan-4.14 {error conditions} {
|
||||
catch {unset a}
|
||||
set a(0) 44
|
||||
list [catch {scan 44 %d a} msg] $msg
|
||||
} {1 {couldn't set variable "a"}}
|
||||
test scan-4.15 {error conditions} {
|
||||
catch {unset a}
|
||||
set a(0) 44
|
||||
list [catch {scan 44 %c a} msg] $msg
|
||||
} {1 {couldn't set variable "a"}}
|
||||
test scan-4.16 {error conditions} {
|
||||
catch {unset a}
|
||||
set a(0) 44
|
||||
list [catch {scan 44 %s a} msg] $msg
|
||||
} {1 {couldn't set variable "a"}}
|
||||
test scan-4.17 {error conditions} {
|
||||
catch {unset a}
|
||||
set a(0) 44
|
||||
list [catch {scan 44 %f a} msg] $msg
|
||||
} {1 {couldn't set variable "a"}}
|
||||
test scan-4.18 {error conditions} {
|
||||
catch {unset a}
|
||||
set a(0) 44
|
||||
list [catch {scan 44 %f a} msg] $msg
|
||||
} {1 {couldn't set variable "a"}}
|
||||
catch {unset a}
|
||||
test scan-4.19 {error conditions} {
|
||||
list [catch {scan 44 %2c a} msg] $msg
|
||||
} {1 {field width may not be specified in %c conversion}}
|
||||
|
||||
test scan-5.1 {lots of arguments} {
|
||||
scan "10 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 200" "%d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d" a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20
|
||||
} 20
|
||||
test scan-5.2 {lots of arguments} {
|
||||
scan "10 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 200" "%d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d" a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20
|
||||
set a20
|
||||
} 200
|
||||
|
||||
test scan-6.1 {miscellaneous tests} {
|
||||
set a {}
|
||||
list [scan ab16c ab%dc a] $a
|
||||
} {1 16}
|
||||
test scan-6.2 {miscellaneous tests} {
|
||||
set a {}
|
||||
list [scan ax16c ab%dc a] $a
|
||||
} {0 {}}
|
||||
test scan-6.3 {miscellaneous tests} {
|
||||
set a {}
|
||||
list [catch {scan ab%c114 ab%%c%d a} msg] $msg $a
|
||||
} {0 1 114}
|
||||
test scan-6.4 {miscellaneous tests} {
|
||||
set a {}
|
||||
list [catch {scan ab%c14 ab%%c%d a} msg] $msg $a
|
||||
} {0 1 14}
|
||||
test scan-6.5 {miscellaneous tests} {
|
||||
catch {unset tcl_precision}
|
||||
set a {}
|
||||
scan 1.111122223333 %f a
|
||||
set a
|
||||
} {1.11112}
|
||||
test scan-6.6 {miscellaneous tests} {
|
||||
set tcl_precision 10
|
||||
set a {}
|
||||
scan 1.111122223333 %lf a
|
||||
unset tcl_precision
|
||||
set a
|
||||
} {1.111122223}
|
||||
test scan-6.7 {miscellaneous tests} {
|
||||
set tcl_precision 10
|
||||
set a {}
|
||||
scan 1.111122223333 %f a
|
||||
unset tcl_precision
|
||||
set a
|
||||
} {1.111122223}
|
||||
|
||||
test scan-7.1 {alignment in results array (TCL_ALIGN)} {
|
||||
scan "123 13.6" "%s %f" a b
|
||||
set b
|
||||
} 13.6
|
||||
test scan-7.2 {alignment in results array (TCL_ALIGN)} {
|
||||
scan "1234567 13.6" "%s %f" a b
|
||||
set b
|
||||
} 13.6
|
||||
test scan-7.3 {alignment in results array (TCL_ALIGN)} {
|
||||
scan "12345678901 13.6" "%s %f" a b
|
||||
set b
|
||||
} 13.6
|
||||
test scan-7.4 {alignment in results array (TCL_ALIGN)} {
|
||||
scan "123456789012345 13.6" "%s %f" a b
|
||||
set b
|
||||
} 13.6
|
||||
test scan-7.5 {alignment in results array (TCL_ALIGN)} {
|
||||
scan "1234567890123456789 13.6" "%s %f" a b
|
||||
set b
|
||||
} 13.6
|
||||
584
tcl7.3/tests/set.test
Normal file
584
tcl7.3/tests/set.test
Normal file
@@ -0,0 +1,584 @@
|
||||
# Commands covered: set, unset, array
|
||||
#
|
||||
# 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.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/set.test,v 1.12 93/07/21 09:18:48 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
proc ignore args {}
|
||||
|
||||
# Simple variable operations.
|
||||
|
||||
catch {unset a}
|
||||
test set-1.1 {basic variable setting and unsetting} {
|
||||
set a 22
|
||||
} 22
|
||||
test set-1.2 {basic variable setting and unsetting} {
|
||||
set a 123
|
||||
set a
|
||||
} 123
|
||||
test set-1.3 {basic variable setting and unsetting} {
|
||||
set a xxx
|
||||
format %s $a
|
||||
} xxx
|
||||
test set-1.4 {basic variable setting and unsetting} {
|
||||
set a 44
|
||||
unset a
|
||||
list [catch {set a} msg] $msg
|
||||
} {1 {can't read "a": no such variable}}
|
||||
|
||||
# Basic array operations.
|
||||
|
||||
catch {unset a}
|
||||
set a(xyz) 2
|
||||
set a(44) 3
|
||||
set {a(a long name)} test
|
||||
test set-2.1 {basic array operations} {
|
||||
lsort [array names a]
|
||||
} {44 {a long name} xyz}
|
||||
test set-2.2 {basic array operations} {
|
||||
set a(44)
|
||||
} 3
|
||||
test set-2.3 {basic array operations} {
|
||||
set a(xyz)
|
||||
} 2
|
||||
test set-2.4 {basic array operations} {
|
||||
set "a(a long name)"
|
||||
} test
|
||||
test set-2.5 {basic array operations} {
|
||||
list [catch {set a(other)} msg] $msg
|
||||
} {1 {can't read "a(other)": no such element in array}}
|
||||
test set-2.6 {basic array operations} {
|
||||
list [catch {set a} msg] $msg
|
||||
} {1 {can't read "a": no such variable}}
|
||||
test set-2.7 {basic array operations} {
|
||||
format %s $a(44)
|
||||
} 3
|
||||
test set-2.8 {basic array operations} {
|
||||
format %s $a(a long name)
|
||||
} test
|
||||
unset a(44)
|
||||
test set-2.9 {basic array operations} {
|
||||
lsort [array names a]
|
||||
} {{a long name} xyz}
|
||||
test set-2.10 {basic array operations} {
|
||||
catch {unset b}
|
||||
list [catch {set b(123)} msg] $msg
|
||||
} {1 {can't read "b(123)": no such variable}}
|
||||
test set-2.11 {basic array operations} {
|
||||
catch {unset b}
|
||||
set b 44
|
||||
list [catch {set b(123)} msg] $msg
|
||||
} {1 {can't read "b(123)": variable isn't array}}
|
||||
test set-2.12 {basic array operations} {
|
||||
list [catch {set a} msg] $msg
|
||||
} {1 {can't read "a": no such variable}}
|
||||
test set-2.13 {basic array operations} {
|
||||
list [catch {set a 14} msg] $msg
|
||||
} {1 {can't set "a": variable is array}}
|
||||
unset a
|
||||
test set-2.14 {basic array operations} {
|
||||
list [catch {set a(xyz)} msg] $msg
|
||||
} {1 {can't read "a(xyz)": no such variable}}
|
||||
|
||||
# Test the set commands, and exercise the corner cases of the code
|
||||
# that parses array references into two parts.
|
||||
|
||||
test set-3.1 {set command} {
|
||||
list [catch {set} msg] $msg
|
||||
} {1 {wrong # args: should be "set varName ?newValue?"}}
|
||||
test set-3.2 {set command} {
|
||||
list [catch {set x y z} msg] $msg
|
||||
} {1 {wrong # args: should be "set varName ?newValue?"}}
|
||||
test set-3.3 {set command} {
|
||||
catch {unset a}
|
||||
list [catch {set a} msg] $msg
|
||||
} {1 {can't read "a": no such variable}}
|
||||
test set-3.4 {set command} {
|
||||
catch {unset a}
|
||||
set a(14) 83
|
||||
list [catch {set a 22} msg] $msg
|
||||
} {1 {can't set "a": variable is array}}
|
||||
|
||||
# Test the corner-cases of parsing array names, using set and unset.
|
||||
|
||||
test set-4.1 {parsing array names} {
|
||||
catch {unset a}
|
||||
set a(()) 44
|
||||
list [catch {array names a} msg] $msg
|
||||
} {0 ()}
|
||||
test set-4.2 {parsing array names} {
|
||||
catch {unset a a(abcd}
|
||||
set a(abcd 33
|
||||
info exists a(abcd
|
||||
} 1
|
||||
test set-4.3 {parsing array names} {
|
||||
catch {unset a a(abcd}
|
||||
set a(abcd 33
|
||||
list [catch {array names a} msg] $msg
|
||||
} {1 {"a" isn't an array}}
|
||||
test set-4.4 {parsing array names} {
|
||||
catch {unset a abcd)}
|
||||
set abcd) 33
|
||||
info exists abcd)
|
||||
} 1
|
||||
test set-4.5 {parsing array names} {
|
||||
set a(bcd yyy
|
||||
catch {unset a}
|
||||
list [catch {set a(bcd} msg] $msg
|
||||
} {0 yyy}
|
||||
test set-4.6 {parsing array names} {
|
||||
catch {unset a}
|
||||
set a 44
|
||||
list [catch {set a(bcd test} msg] $msg
|
||||
} {0 test}
|
||||
|
||||
# Errors in reading variables
|
||||
|
||||
test set-5.1 {errors in reading variables} {
|
||||
catch {unset a}
|
||||
list [catch {set a} msg] $msg
|
||||
} {1 {can't read "a": no such variable}}
|
||||
test set-5.2 {errors in reading variables} {
|
||||
catch {unset a}
|
||||
set a 44
|
||||
list [catch {set a(18)} msg] $msg
|
||||
} {1 {can't read "a(18)": variable isn't array}}
|
||||
test set-5.3 {errors in reading variables} {
|
||||
catch {unset a}
|
||||
set a(6) 44
|
||||
list [catch {set a(18)} msg] $msg
|
||||
} {1 {can't read "a(18)": no such element in array}}
|
||||
test set-5.4 {errors in reading variables} {
|
||||
catch {unset a}
|
||||
set a(6) 44
|
||||
list [catch {set a} msg] $msg
|
||||
} {1 {can't read "a": no such variable}}
|
||||
|
||||
# Errors and other special cases in writing variables
|
||||
|
||||
test set-6.1 {creating array during write} {
|
||||
catch {unset a}
|
||||
trace var a rwu ignore
|
||||
list [catch {set a(14) 186} msg] $msg [array names a]
|
||||
} {0 186 14}
|
||||
test set-6.2 {errors in writing variables} {
|
||||
catch {unset a}
|
||||
set a xxx
|
||||
list [catch {set a(14) 186} msg] $msg
|
||||
} {1 {can't set "a(14)": variable isn't array}}
|
||||
test set-6.3 {errors in writing variables} {
|
||||
catch {unset a}
|
||||
set a(100) yyy
|
||||
list [catch {set a 2} msg] $msg
|
||||
} {1 {can't set "a": variable is array}}
|
||||
test set-6.4 {expanding variable size} {
|
||||
catch {unset a}
|
||||
list [set a short] [set a "longer name"] [set a "even longer name"] \
|
||||
[set a "a much much truly longer name"]
|
||||
} {short {longer name} {even longer name} {a much much truly longer name}}
|
||||
|
||||
# Unset command, Tcl_UnsetVar procedures
|
||||
|
||||
test set-7.1 {unset command} {
|
||||
catch {unset a}; catch {unset b}; catch {unset c}; catch {unset d}
|
||||
set a 44
|
||||
set b 55
|
||||
set c 66
|
||||
set d 77
|
||||
unset a b c
|
||||
list [catch {set a(0) 0}] [catch {set b(0) 0}] [catch {set c(0) 0}] \
|
||||
[catch {set d(0) 0}]
|
||||
} {0 0 0 1}
|
||||
test set-7.2 {unset command} {
|
||||
list [catch {unset} msg] $msg
|
||||
} {1 {wrong # args: should be "unset varName ?varName ...?"}}
|
||||
test set-7.3 {unset command} {
|
||||
catch {unset a}
|
||||
list [catch {unset a} msg] $msg
|
||||
} {1 {can't unset "a": no such variable}}
|
||||
test set-7.4 {unset command} {
|
||||
catch {unset a}
|
||||
set a 44
|
||||
list [catch {unset a(14)} msg] $msg
|
||||
} {1 {can't unset "a(14)": variable isn't array}}
|
||||
test set-7.5 {unset command} {
|
||||
catch {unset a}
|
||||
set a(0) xx
|
||||
list [catch {unset a(14)} msg] $msg
|
||||
} {1 {can't unset "a(14)": no such element in array}}
|
||||
test set-7.6 {unset command} {
|
||||
catch {unset a}; catch {unset b}; catch {unset c}
|
||||
set a foo
|
||||
set c gorp
|
||||
list [catch {unset a a a(14)} msg] $msg [info exists c]
|
||||
} {1 {can't unset "a": no such variable} 1}
|
||||
test set-7.7 {unsetting globals from within procedures} {
|
||||
set y 0
|
||||
proc p1 {} {
|
||||
global y
|
||||
set z [p2]
|
||||
return [list $z [catch {set y} msg] $msg]
|
||||
}
|
||||
proc p2 {} {global y; unset y; list [catch {set y} msg] $msg}
|
||||
p1
|
||||
} {{1 {can't read "y": no such variable}} 1 {can't read "y": no such variable}}
|
||||
test set-7.8 {unsetting globals from within procedures} {
|
||||
set y 0
|
||||
proc p1 {} {
|
||||
global y
|
||||
p2
|
||||
return [list [catch {set y 44} msg] $msg]
|
||||
}
|
||||
proc p2 {} {global y; unset y}
|
||||
concat [p1] [list [catch {set y} msg] $msg]
|
||||
} {0 44 0 44}
|
||||
test set-7.9 {unsetting globals from within procedures} {
|
||||
set y 0
|
||||
proc p1 {} {
|
||||
global y
|
||||
unset y
|
||||
return [list [catch {set y 55} msg] $msg]
|
||||
}
|
||||
concat [p1] [list [catch {set y} msg] $msg]
|
||||
} {0 55 0 55}
|
||||
test set-7.10 {unset command} {
|
||||
catch {unset a}
|
||||
set a(14) 22
|
||||
unset a(14)
|
||||
list [catch {set a(14)} msg] $msg [catch {array names a} msg2] $msg2
|
||||
} {1 {can't read "a(14)": no such element in array} 0 {}}
|
||||
test set-7.11 {unset command} {
|
||||
catch {unset a}
|
||||
set a(14) 22
|
||||
unset a
|
||||
list [catch {set a(14)} msg] $msg [catch {array names a} msg2] $msg2
|
||||
} {1 {can't read "a(14)": no such variable} 1 {"a" isn't an array}}
|
||||
|
||||
# Array command.
|
||||
|
||||
test set-8.1 {array command} {
|
||||
list [catch {array} msg] $msg
|
||||
} {1 {wrong # args: should be "array option arrayName ?arg ...?"}}
|
||||
test set-8.2 {array command} {
|
||||
catch {unset a}
|
||||
list [catch {array names a} msg] $msg
|
||||
} {1 {"a" isn't an array}}
|
||||
test set-8.3 {array command} {
|
||||
catch {unset a}
|
||||
set a 44
|
||||
list [catch {array names a} msg] $msg
|
||||
} {1 {"a" isn't an array}}
|
||||
test set-8.4 {array command} {
|
||||
catch {unset a}
|
||||
set a(22) 3
|
||||
list [catch {array gorp a} msg] $msg
|
||||
} {1 {bad option "gorp": should be anymore, donesearch, names, nextelement, size, or startsearch}}
|
||||
test set-8.5 {array command, names option} {
|
||||
catch {unset a}
|
||||
set a(22) 3
|
||||
list [catch {array names a 4} msg] $msg
|
||||
} {1 {wrong # args: should be "array names arrayName"}}
|
||||
test set-8.6 {array command, names option} {
|
||||
catch {unset a}
|
||||
set a(22) 3; set a(Textual_name) 44; set "a(name with spaces)" xxx
|
||||
list [catch {lsort [array names a]} msg] $msg
|
||||
} {0 {22 Textual_name {name with spaces}}}
|
||||
test set-8.7 {array command, names option} {
|
||||
catch {unset a}
|
||||
set a(22) 3; set a(33) 44;
|
||||
trace var a(xxx) w ignore
|
||||
list [catch {lsort [array names a]} msg] $msg
|
||||
} {0 {22 33}}
|
||||
test set-8.8 {array command, names option} {
|
||||
catch {unset a}
|
||||
set a(22) 3; set a(33) 44;
|
||||
trace var a(xxx) w ignore
|
||||
set a(xxx) value
|
||||
list [catch {lsort [array names a]} msg] $msg
|
||||
} {0 {22 33 xxx}}
|
||||
test set-8.9 {array command, size option} {
|
||||
catch {unset a}
|
||||
set a(22) 3
|
||||
list [catch {array size a 4} msg] $msg
|
||||
} {1 {wrong # args: should be "array size arrayName"}}
|
||||
test set-8.10 {array command, size option} {
|
||||
catch {unset a}
|
||||
set a(22) 3; set a(Textual_name) 44; set "a(name with spaces)" xxx
|
||||
list [catch {array size a} msg] $msg
|
||||
} {0 3}
|
||||
test set-8.10 {array command, size option} {
|
||||
catch {unset a}
|
||||
set a(22) 3; set a(xx) 44; set a(y) xxx
|
||||
unset a(22) a(y) a(xx)
|
||||
list [catch {array size a} msg] $msg
|
||||
} {0 0}
|
||||
test set-8.11 {array command, size option} {
|
||||
catch {unset a}
|
||||
set a(22) 3;
|
||||
trace var a(33) rwu ignore
|
||||
list [catch {array size a} msg] $msg
|
||||
} {0 1}
|
||||
|
||||
test set-9.1 {ids for array enumeration} {
|
||||
catch {unset a}
|
||||
set a(a) 1
|
||||
list [array st a] [array st a] [array done a s-1-a; array st a] \
|
||||
[array done a s-2-a; array d a s-3-a; array start a]
|
||||
} {s-1-a s-2-a s-3-a s-1-a}
|
||||
test set-9.2 {array enumeration} {
|
||||
catch {unset a}
|
||||
set a(a) 1
|
||||
set a(b) 1
|
||||
set a(c) 1
|
||||
set x [array startsearch a]
|
||||
list [array nextelement a $x] [array ne a $x] [array next a $x] \
|
||||
[array next a $x] [array next a $x]
|
||||
} {a b c {} {}}
|
||||
test set-9.3 {array enumeration} {
|
||||
catch {unset a}
|
||||
set a(a) 1
|
||||
set a(b) 1
|
||||
set a(c) 1
|
||||
set x [array startsearch a]
|
||||
set y [array startsearch a]
|
||||
set z [array startsearch a]
|
||||
list [array nextelement a $x] [array ne a $x] \
|
||||
[array next a $y] [array next a $z] [array next a $y] \
|
||||
[array next a $z] [array next a $y] [array next a $z] \
|
||||
[array next a $y] [array next a $z] [array next a $x] \
|
||||
[array next a $x]
|
||||
} {a b a a b b c c {} {} c {}}
|
||||
test set-9.4 {array enumeration: stopping searches} {
|
||||
catch {unset a}
|
||||
set a(a) 1
|
||||
set a(b) 1
|
||||
set a(c) 1
|
||||
set x [array startsearch a]
|
||||
set y [array startsearch a]
|
||||
set z [array startsearch a]
|
||||
list [array next a $x] [array next a $x] [array next a $y] \
|
||||
[array done a $z; array next a $x] \
|
||||
[array done a $x; array next a $y] [array next a $y]
|
||||
} {a b a c b c}
|
||||
test set-9.5 {array enumeration: stopping searches} {
|
||||
catch {unset a}
|
||||
set a(a) 1
|
||||
set x [array startsearch a]
|
||||
array done a $x
|
||||
list [catch {array next a $x} msg] $msg
|
||||
} {1 {couldn't find search "s-1-a"}}
|
||||
test set-9.6 {array enumeration: searches automatically stopped} {
|
||||
catch {unset a}
|
||||
set a(a) 1
|
||||
set x [array startsearch a]
|
||||
set y [array startsearch a]
|
||||
set a(b) 1
|
||||
list [catch {array next a $x} msg] $msg \
|
||||
[catch {array next a $y} msg2] $msg2
|
||||
} {1 {couldn't find search "s-1-a"} 1 {couldn't find search "s-2-a"}}
|
||||
test set-9.7 {array enumeration: searches automatically stopped} {
|
||||
catch {unset a}
|
||||
set a(a) 1
|
||||
set x [array startsearch a]
|
||||
set y [array startsearch a]
|
||||
set a(a) 2
|
||||
list [catch {array next a $x} msg] $msg \
|
||||
[catch {array next a $y} msg2] $msg2
|
||||
} {0 a 0 a}
|
||||
test set-9.8 {array enumeration: searches automatically stopped} {
|
||||
catch {unset a}
|
||||
set a(a) 1
|
||||
set a(c) 2
|
||||
set x [array startsearch a]
|
||||
set y [array startsearch a]
|
||||
catch {unset a(c)}
|
||||
list [catch {array next a $x} msg] $msg \
|
||||
[catch {array next a $y} msg2] $msg2
|
||||
} {1 {couldn't find search "s-1-a"} 1 {couldn't find search "s-2-a"}}
|
||||
test set-9.9 {array enumeration: searches automatically stopped} {
|
||||
catch {unset a}
|
||||
set a(a) 1
|
||||
set x [array startsearch a]
|
||||
set y [array startsearch a]
|
||||
catch {unset a(c)}
|
||||
list [catch {array next a $x} msg] $msg \
|
||||
[catch {array next a $y} msg2] $msg2
|
||||
} {0 a 0 a}
|
||||
test set-9.10 {array enumeration: searches automatically stopped} {
|
||||
catch {unset a}
|
||||
set a(a) 1
|
||||
set x [array startsearch a]
|
||||
set y [array startsearch a]
|
||||
trace var a(b) r {}
|
||||
list [catch {array next a $x} msg] $msg \
|
||||
[catch {array next a $y} msg2] $msg2
|
||||
} {1 {couldn't find search "s-1-a"} 1 {couldn't find search "s-2-a"}}
|
||||
test set-9.11 {array enumeration: searches automatically stopped} {
|
||||
catch {unset a}
|
||||
set a(a) 1
|
||||
set x [array startsearch a]
|
||||
set y [array startsearch a]
|
||||
trace var a(a) r {}
|
||||
list [catch {array next a $x} msg] $msg \
|
||||
[catch {array next a $y} msg2] $msg2
|
||||
} {0 a 0 a}
|
||||
test set-9.12 {array enumeration with traced undefined elements} {
|
||||
catch {unset a}
|
||||
set a(a) 1
|
||||
trace var a(b) r {}
|
||||
set x [array startsearch a]
|
||||
list [array next a $x] [array next a $x]
|
||||
} {a {}}
|
||||
|
||||
test set-10.1 {array enumeration errors} {
|
||||
list [catch {array start} msg] $msg
|
||||
} {1 {wrong # args: should be "array option arrayName ?arg ...?"}}
|
||||
test set-10.2 {array enumeration errors} {
|
||||
list [catch {array start a b} msg] $msg
|
||||
} {1 {wrong # args: should be "array startsearch arrayName"}}
|
||||
test set-10.3 {array enumeration errors} {
|
||||
catch {unset a}
|
||||
list [catch {array start a} msg] $msg
|
||||
} {1 {"a" isn't an array}}
|
||||
test set-10.4 {array enumeration errors} {
|
||||
catch {unset a}
|
||||
set a(a) 1
|
||||
set x [array startsearch a]
|
||||
list [catch {array next a} msg] $msg
|
||||
} {1 {wrong # args: should be "array nextelement arrayName searchId"}}
|
||||
test set-10.5 {array enumeration errors} {
|
||||
catch {unset a}
|
||||
set a(a) 1
|
||||
set x [array startsearch a]
|
||||
list [catch {array next a b c} msg] $msg
|
||||
} {1 {wrong # args: should be "array nextelement arrayName searchId"}}
|
||||
test set-10.6 {array enumeration errors} {
|
||||
catch {unset a}
|
||||
set a(a) 1
|
||||
set x [array startsearch a]
|
||||
list [catch {array next a a-1-a} msg] $msg
|
||||
} {1 {illegal search identifier "a-1-a"}}
|
||||
test set-10.7 {array enumeration errors} {
|
||||
catch {unset a}
|
||||
set a(a) 1
|
||||
set x [array startsearch a]
|
||||
list [catch {array next a sx1-a} msg] $msg
|
||||
} {1 {illegal search identifier "sx1-a"}}
|
||||
test set-10.8 {array enumeration errors} {
|
||||
catch {unset a}
|
||||
set a(a) 1
|
||||
set x [array startsearch a]
|
||||
list [catch {array next a s--a} msg] $msg
|
||||
} {1 {illegal search identifier "s--a"}}
|
||||
test set-10.9 {array enumeration errors} {
|
||||
catch {unset a}
|
||||
set a(a) 1
|
||||
set x [array startsearch a]
|
||||
list [catch {array next a s-1-b} msg] $msg
|
||||
} {1 {search identifier "s-1-b" isn't for variable "a"}}
|
||||
test set-10.10 {array enumeration errors} {
|
||||
catch {unset a}
|
||||
set a(a) 1
|
||||
set x [array startsearch a]
|
||||
list [catch {array next a s-1ba} msg] $msg
|
||||
} {1 {illegal search identifier "s-1ba"}}
|
||||
test set-10.11 {array enumeration errors} {
|
||||
catch {unset a}
|
||||
set a(a) 1
|
||||
set x [array startsearch a]
|
||||
list [catch {array next a s-2-a} msg] $msg
|
||||
} {1 {couldn't find search "s-2-a"}}
|
||||
test set-10.12 {array enumeration errors} {
|
||||
list [catch {array done a} msg] $msg
|
||||
} {1 {wrong # args: should be "array donesearch arrayName searchId"}}
|
||||
test set-10.13 {array enumeration errors} {
|
||||
list [catch {array done a b c} msg] $msg
|
||||
} {1 {wrong # args: should be "array donesearch arrayName searchId"}}
|
||||
test set-10.14 {array enumeration errors} {
|
||||
list [catch {array done a b} msg] $msg
|
||||
} {1 {illegal search identifier "b"}}
|
||||
test set-10.15 {array enumeration errors} {
|
||||
list [catch {array anymore a} msg] $msg
|
||||
} {1 {wrong # args: should be "array anymore arrayName searchId"}}
|
||||
test set-10.16 {array enumeration errors} {
|
||||
list [catch {array any a b c} msg] $msg
|
||||
} {1 {wrong # args: should be "array anymore arrayName searchId"}}
|
||||
test set-10.17 {array enumeration errors} {
|
||||
catch {unset a}
|
||||
set a(0) 44
|
||||
list [catch {array any a bogus} msg] $msg
|
||||
} {1 {illegal search identifier "bogus"}}
|
||||
|
||||
# Array enumeration with "anymore" option
|
||||
|
||||
test set-11.1 {array anymore option} {
|
||||
catch {unset a}
|
||||
set a(a) 1
|
||||
set a(b) 2
|
||||
set a(c) 3
|
||||
array startsearch a
|
||||
list [array anymore a s-1-a] [array next a s-1-a] \
|
||||
[array anymore a s-1-a] [array next a s-1-a] \
|
||||
[array anymore a s-1-a] [array next a s-1-a] \
|
||||
[array anymore a s-1-a] [array next a s-1-a]
|
||||
} {1 a 1 b 1 c 0 {}}
|
||||
test set-11.2 {array anymore option} {
|
||||
catch {unset a}
|
||||
set a(a) 1
|
||||
set a(b) 2
|
||||
set a(c) 3
|
||||
array startsearch a
|
||||
list [array next a s-1-a] [array next a s-1-a] \
|
||||
[array anymore a s-1-a] [array next a s-1-a] \
|
||||
[array next a s-1-a] [array anymore a s-1-a]
|
||||
} {a b 1 c {} 0}
|
||||
|
||||
# Special check to see that the value of a variable is handled correctly
|
||||
# if it is returned as the result of a procedure (must not free the variable
|
||||
# string while deleting the call frame). Errors will only be detected if
|
||||
# a memory consistency checker such as Purify is being used.
|
||||
|
||||
test set-12.1 {cleanup on procedure return} {
|
||||
proc foo {} {
|
||||
set x 12345
|
||||
}
|
||||
foo
|
||||
} 12345
|
||||
test set-12.2 {cleanup on procedure return} {
|
||||
proc foo {} {
|
||||
set x(1) 23456
|
||||
}
|
||||
foo
|
||||
} 23456
|
||||
|
||||
# Must delete variables when done, since these arrays get used as
|
||||
# scalars by other tests.
|
||||
|
||||
catch {unset a}
|
||||
catch {unset b}
|
||||
catch {unset c}
|
||||
return ""
|
||||
95
tcl7.3/tests/source.test
Normal file
95
tcl7.3/tests/source.test
Normal file
@@ -0,0 +1,95 @@
|
||||
# Commands covered: source
|
||||
#
|
||||
# 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.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/source.test,v 1.8 93/02/17 13:22:56 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
test source-1.1 {source command} {
|
||||
set x "old x value"
|
||||
set y "old y value"
|
||||
set z "old z value"
|
||||
exec cat << {
|
||||
set x 22
|
||||
set y 33
|
||||
set z 44
|
||||
} > source.file
|
||||
source source.file
|
||||
list $x $y $z
|
||||
} {22 33 44}
|
||||
test source-1.2 {source command} {
|
||||
exec cat << {list result} > source.file
|
||||
source source.file
|
||||
} result
|
||||
|
||||
test source-2.1 {source error conditions} {
|
||||
list [catch {source} msg] $msg
|
||||
} {1 {wrong # args: should be "source fileName"}}
|
||||
test source-2.2 {source error conditions} {
|
||||
list [catch {source a b} msg] $msg
|
||||
} {1 {wrong # args: should be "source fileName"}}
|
||||
test source-2.3 {source error conditions} {
|
||||
exec cat << {
|
||||
set x 146
|
||||
error "error in sourced file"
|
||||
set y $x
|
||||
} > source.file
|
||||
list [catch {source source.file} msg] $msg $errorInfo
|
||||
} {1 {error in sourced file} {error in sourced file
|
||||
while executing
|
||||
"error "error in sourced file""
|
||||
(file "source.file" line 3)
|
||||
invoked from within
|
||||
"source source.file"}}
|
||||
test source-2.4 {source error conditions} {
|
||||
exec cat << {break} > source.file
|
||||
catch {source source.file}
|
||||
} 3
|
||||
test source-2.5 {source error conditions} {
|
||||
exec cat << {continue} > source.file
|
||||
catch {source source.file}
|
||||
} 4
|
||||
test source-2.6 {source error conditions} {
|
||||
string tolower [list [catch {source _non_existent_} msg] $msg $errorCode]
|
||||
} {1 {couldn't read file "_non_existent_": no such file or directory} {posix enoent {no such file or directory}}}
|
||||
|
||||
test source-3.1 {return in middle of source file} {
|
||||
exec cat << {
|
||||
set x new-x
|
||||
return allDone
|
||||
set y new-y
|
||||
} > source.file
|
||||
set x old-x
|
||||
set y old-y
|
||||
set z [source source.file]
|
||||
list $x $y $z
|
||||
} {new-x old-y allDone}
|
||||
|
||||
catch {exec rm source.file}
|
||||
|
||||
# Generate null final value
|
||||
|
||||
concat {}
|
||||
58
tcl7.3/tests/split.test
Normal file
58
tcl7.3/tests/split.test
Normal file
@@ -0,0 +1,58 @@
|
||||
# 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.
|
||||
#
|
||||
# Copyright (c) 1991-1993 The Regents of the University of California.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/split.test,v 1.6 93/10/11 09:05:58 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
test split-1.1 {basic split commands} {
|
||||
split "a\n b\t\r c\n "
|
||||
} {a {} b {} {} c {} {}}
|
||||
test split-1.2 {basic split commands} {
|
||||
split "word 1xyzword 2zword 3" xyz
|
||||
} {{word 1} {} {} {word 2} {word 3}}
|
||||
test split-1.3 {basic split commands} {
|
||||
split "12345" {}
|
||||
} {1 2 3 4 5}
|
||||
test split-1.4 {basic split commands} {
|
||||
split "a\}b\[c\{\]\$"
|
||||
} "a\\}b\\\[c\\{\\\]\\\$"
|
||||
test split-1.5 {basic split commands} {
|
||||
split {} {}
|
||||
} {}
|
||||
test split-1.6 {basic split commands} {
|
||||
split {}
|
||||
} {}
|
||||
test split-1.7 {basic split commands} {
|
||||
split { }
|
||||
} {{} {} {} {}}
|
||||
|
||||
test split-2.1 {split errors} {
|
||||
list [catch split msg] $msg $errorCode
|
||||
} {1 {wrong # args: should be "split string ?splitChars?"} NONE}
|
||||
test split-2.2 {split errors} {
|
||||
list [catch {split a b c} msg] $msg $errorCode
|
||||
} {1 {wrong # args: should be "split string ?splitChars?"} NONE}
|
||||
333
tcl7.3/tests/string.test
Normal file
333
tcl7.3/tests/string.test
Normal file
@@ -0,0 +1,333 @@
|
||||
# Commands covered: string
|
||||
#
|
||||
# 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.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/string.test,v 1.7 93/02/06 15:54:24 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
test string-1.1 {string compare} {
|
||||
string compare abcde abdef
|
||||
} -1
|
||||
test string-1.2 {string compare} {
|
||||
string c abcde ABCDE
|
||||
} 1
|
||||
test string-1.3 {string compare} {
|
||||
string compare abcde abcde
|
||||
} 0
|
||||
test string-1.4 {string compare} {
|
||||
list [catch {string compare a} msg] $msg
|
||||
} {1 {wrong # args: should be "string compare string1 string2"}}
|
||||
test string-1.5 {string compare} {
|
||||
list [catch {string compare a b c} msg] $msg
|
||||
} {1 {wrong # args: should be "string compare string1 string2"}}
|
||||
|
||||
test string-2.1 {string first} {
|
||||
string first bq abcdefgbcefgbqrs
|
||||
} 12
|
||||
test string-2.2 {string first} {
|
||||
string fir bcd abcdefgbcefgbqrs
|
||||
} 1
|
||||
test string-2.3 {string first} {
|
||||
string f b abcdefgbcefgbqrs
|
||||
} 1
|
||||
test string-2.4 {string first} {
|
||||
string first xxx x123xx345xxx789xxx012
|
||||
} 9
|
||||
test string-2.5 {string first} {
|
||||
list [catch {string first a} msg] $msg
|
||||
} {1 {wrong # args: should be "string first string1 string2"}}
|
||||
test string-2.6 {string first} {
|
||||
list [catch {string first a b c} msg] $msg
|
||||
} {1 {wrong # args: should be "string first string1 string2"}}
|
||||
|
||||
test string-3.1 {string index} {
|
||||
string index abcde 0
|
||||
} a
|
||||
test string-3.2 {string index} {
|
||||
string i abcde 4
|
||||
} e
|
||||
test string-3.3 {string index} {
|
||||
string index abcde 5
|
||||
} {}
|
||||
test string-3.4 {string index} {
|
||||
list [catch {string index abcde -10} msg] $msg
|
||||
} {0 {}}
|
||||
test string-3.5 {string index} {
|
||||
list [catch {string index} msg] $msg
|
||||
} {1 {wrong # args: should be "string index string charIndex"}}
|
||||
test string-3.6 {string index} {
|
||||
list [catch {string index a b c} msg] $msg
|
||||
} {1 {wrong # args: should be "string index string charIndex"}}
|
||||
test string-3.7 {string index} {
|
||||
list [catch {string index a xyz} msg] $msg
|
||||
} {1 {expected integer but got "xyz"}}
|
||||
|
||||
test string-4.1 {string last} {
|
||||
string la xxx xxxx123xx345x678
|
||||
} 1
|
||||
test string-4.2 {string last} {
|
||||
string last xx xxxx123xx345x678
|
||||
} 7
|
||||
test string-4.3 {string last} {
|
||||
string las x xxxx123xx345x678
|
||||
} 12
|
||||
test string-4.4 {string last} {
|
||||
list [catch {string last a} msg] $msg
|
||||
} {1 {wrong # args: should be "string last string1 string2"}}
|
||||
test string-4.5 {string last} {
|
||||
list [catch {string last a b c} msg] $msg
|
||||
} {1 {wrong # args: should be "string last string1 string2"}}
|
||||
|
||||
test string-5.1 {string length} {
|
||||
string length "a little string"
|
||||
} 15
|
||||
test string-5.2 {string length} {
|
||||
string le ""
|
||||
} 0
|
||||
test string-5.3 {string length} {
|
||||
list [catch {string length} msg] $msg
|
||||
} {1 {wrong # args: should be "string length string"}}
|
||||
test string-5.4 {string length} {
|
||||
list [catch {string length a b} msg] $msg
|
||||
} {1 {wrong # args: should be "string length string"}}
|
||||
|
||||
test string-6.1 {string match} {
|
||||
string match abc abc
|
||||
} 1
|
||||
test string-6.2 {string match} {
|
||||
string m abc abd
|
||||
} 0
|
||||
test string-6.3 {string match} {
|
||||
string match ab*c abc
|
||||
} 1
|
||||
test string-6.4 {string match} {
|
||||
string match ab**c abc
|
||||
} 1
|
||||
test string-6.5 {string match} {
|
||||
string match ab* abcdef
|
||||
} 1
|
||||
test string-6.6 {string match} {
|
||||
string match *c abc
|
||||
} 1
|
||||
test string-6.7 {string match} {
|
||||
string match *3*6*9 0123456789
|
||||
} 1
|
||||
test string-6.8 {string match} {
|
||||
string match *3*6*9 01234567890
|
||||
} 0
|
||||
test string-6.9 {string match} {
|
||||
string match a?c abc
|
||||
} 1
|
||||
test string-6.10 {string match} {
|
||||
string match a??c abc
|
||||
} 0
|
||||
test string-6.11 {string match} {
|
||||
string match ?1??4???8? 0123456789
|
||||
} 1
|
||||
test string-6.12 {string match} {
|
||||
string match {[abc]bc} abc
|
||||
} 1
|
||||
test string-6.13 {string match} {
|
||||
string match {a[abc]c} abc
|
||||
} 1
|
||||
test string-6.14 {string match} {
|
||||
string match {a[xyz]c} abc
|
||||
} 0
|
||||
test string-6.15 {string match} {
|
||||
string match {12[2-7]45} 12345
|
||||
} 1
|
||||
test string-6.16 {string match} {
|
||||
string match {12[ab2-4cd]45} 12345
|
||||
} 1
|
||||
test string-6.17 {string match} {
|
||||
string match {12[ab2-4cd]45} 12b45
|
||||
} 1
|
||||
test string-6.18 {string match} {
|
||||
string match {12[ab2-4cd]45} 12d45
|
||||
} 1
|
||||
test string-6.19 {string match} {
|
||||
string match {12[ab2-4cd]45} 12145
|
||||
} 0
|
||||
test string-6.20 {string match} {
|
||||
string match {12[ab2-4cd]45} 12545
|
||||
} 0
|
||||
test string-6.21 {string match} {
|
||||
string match {a\*b} a*b
|
||||
} 1
|
||||
test string-6.22 {string match} {
|
||||
string match {a\*b} ab
|
||||
} 0
|
||||
test string-6.23 {string match} {
|
||||
string match {a\*\?\[\]\\\x} "a*?\[\]\\x"
|
||||
} 1
|
||||
test string-6.24 {string match} {
|
||||
string match ** ""
|
||||
} 1
|
||||
test string-6.25 {string match} {
|
||||
string match *. ""
|
||||
} 0
|
||||
test string-6.26 {string match} {
|
||||
string match "" ""
|
||||
} 1
|
||||
test string-6.27 {string match} {
|
||||
list [catch {string match a} msg] $msg
|
||||
} {1 {wrong # args: should be "string match pattern string"}}
|
||||
test string-6.28 {string match} {
|
||||
list [catch {string match a b c} msg] $msg
|
||||
} {1 {wrong # args: should be "string match pattern string"}}
|
||||
|
||||
test string-7.1 {string range} {
|
||||
string range abcdefghijklmnop 2 14
|
||||
} {cdefghijklmno}
|
||||
test string-7.2 {string range} {
|
||||
string range abcdefghijklmnop 7 1000
|
||||
} {hijklmnop}
|
||||
test string-7.3 {string range} {
|
||||
string range abcdefghijklmnop 10 e
|
||||
} {klmnop}
|
||||
test string-7.4 {string range} {
|
||||
string range abcdefghijklmnop 10 9
|
||||
} {}
|
||||
test string-7.5 {string range} {
|
||||
string range abcdefghijklmnop -3 2
|
||||
} {abc}
|
||||
test string-7.6 {string range} {
|
||||
string range abcdefghijklmnop -3 -2
|
||||
} {}
|
||||
test string-7.7 {string range} {
|
||||
string range abcdefghijklmnop 1000 1010
|
||||
} {}
|
||||
test string-7.8 {string range} {
|
||||
string range abcdefghijklmnop -100 end
|
||||
} {abcdefghijklmnop}
|
||||
test string-7.9 {string range} {
|
||||
list [catch {string range} msg] $msg
|
||||
} {1 {wrong # args: should be "string range string first last"}}
|
||||
test string-7.10 {string range} {
|
||||
list [catch {string range a 1} msg] $msg
|
||||
} {1 {wrong # args: should be "string range string first last"}}
|
||||
test string-7.11 {string range} {
|
||||
list [catch {string range a 1 2 3} msg] $msg
|
||||
} {1 {wrong # args: should be "string range string first last"}}
|
||||
test string-7.12 {string range} {
|
||||
list [catch {string range abc abc 1} msg] $msg
|
||||
} {1 {expected integer but got "abc"}}
|
||||
test string-7.13 {string range} {
|
||||
list [catch {string range abc 1 eof} msg] $msg
|
||||
} {1 {expected integer or "end" but got "eof"}}
|
||||
|
||||
test string-8.1 {string trim} {
|
||||
string trim " XYZ "
|
||||
} {XYZ}
|
||||
test string-8.2 {string trim} {
|
||||
string trim "\t\nXYZ\t\n\r\n"
|
||||
} {XYZ}
|
||||
test string-8.3 {string trim} {
|
||||
string trim " A XYZ A "
|
||||
} {A XYZ A}
|
||||
test string-8.4 {string trim} {
|
||||
string trim "XXYYZZABC XXYYZZ" ZYX
|
||||
} {ABC }
|
||||
test string-8.5 {string trim} {
|
||||
string trim " \t\r "
|
||||
} {}
|
||||
test string-8.6 {string trim} {
|
||||
string trim {abcdefg} {}
|
||||
} {abcdefg}
|
||||
test string-8.7 {string trim} {
|
||||
string trim {}
|
||||
} {}
|
||||
test string-8.8 {string trim} {
|
||||
string trim ABC DEF
|
||||
} {ABC}
|
||||
test string-8.9 {string trim} {
|
||||
list [catch {string trim} msg] $msg
|
||||
} {1 {wrong # args: should be "string trim string ?chars?"}}
|
||||
test string-8.10 {string trim} {
|
||||
list [catch {string trim a b c} msg] $msg
|
||||
} {1 {wrong # args: should be "string trim string ?chars?"}}
|
||||
|
||||
test string-9.1 {string trimleft} {
|
||||
string trimleft " XYZ "
|
||||
} {XYZ }
|
||||
test string-9.2 {string trimleft} {
|
||||
list [catch {string triml} msg] $msg
|
||||
} {1 {wrong # args: should be "string trimleft string ?chars?"}}
|
||||
|
||||
test string-10.1 {string trimright} {
|
||||
string trimright " XYZ "
|
||||
} { XYZ}
|
||||
test string-10.2 {string trimright} {
|
||||
string trimright " "
|
||||
} {}
|
||||
test string-10.3 {string trimright} {
|
||||
string trimright ""
|
||||
} {}
|
||||
test string-10.4 {string trimright errors} {
|
||||
list [catch {string trimr} msg] $msg
|
||||
} {1 {wrong # args: should be "string trimright string ?chars?"}}
|
||||
test string-10.5 {string trimright errors} {
|
||||
list [catch {string trimg a} msg] $msg
|
||||
} {1 {bad option "trimg": should be compare, first, index, last, length, match, range, tolower, toupper, trim, trimleft, or trimright}}
|
||||
|
||||
test string-11.1 {string tolower} {
|
||||
string tolower ABCDeF
|
||||
} {abcdef}
|
||||
test string-11.2 {string tolower} {
|
||||
string tolower "ABC XyZ"
|
||||
} {abc xyz}
|
||||
test string-11.3 {string tolower} {
|
||||
string tolower {123#$&*()}
|
||||
} {123#$&*()}
|
||||
test string-11.4 {string tolower} {
|
||||
list [catch {string tolower} msg] $msg
|
||||
} {1 {wrong # args: should be "string tolower string"}}
|
||||
test string-11.5 {string tolower} {
|
||||
list [catch {string tolower a b} msg] $msg
|
||||
} {1 {wrong # args: should be "string tolower string"}}
|
||||
|
||||
test string-12.1 {string toupper} {
|
||||
string toupper abCDEf
|
||||
} {ABCDEF}
|
||||
test string-12.2 {string toupper} {
|
||||
string toupper "abc xYz"
|
||||
} {ABC XYZ}
|
||||
test string-12.3 {string toupper} {
|
||||
string toupper {123#$&*()}
|
||||
} {123#$&*()}
|
||||
test string-12.4 {string toupper} {
|
||||
list [catch {string toupper} msg] $msg
|
||||
} {1 {wrong # args: should be "string toupper string"}}
|
||||
test string-12.5 {string toupper} {
|
||||
list [catch {string toupper a b} msg] $msg
|
||||
} {1 {wrong # args: should be "string toupper string"}}
|
||||
|
||||
test string-13.1 {error conditions} {
|
||||
list [catch {string gorp a b} msg] $msg
|
||||
} {1 {bad option "gorp": should be compare, first, index, last, length, match, range, tolower, toupper, trim, trimleft, or trimright}}
|
||||
test string-13.2 {error conditions} {
|
||||
list [catch {string} msg] $msg
|
||||
} {1 {wrong # args: should be "string option arg ?arg ...?"}}
|
||||
184
tcl7.3/tests/switch.test
Normal file
184
tcl7.3/tests/switch.test
Normal file
@@ -0,0 +1,184 @@
|
||||
# Commands covered: switch
|
||||
#
|
||||
# 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) 1993 The Regents of the University of California.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/switch.test,v 1.2 93/06/17 11:53:58 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
test switch-1.1 {simple patterns} {
|
||||
switch a a {format 1} b {format 2} c {format 3} default {format 4}
|
||||
} 1
|
||||
test switch-1.2 {simple patterns} {
|
||||
switch b a {format 1} b {format 2} c {format 3} default {format 4}
|
||||
} 2
|
||||
test switch-1.3 {simple patterns} {
|
||||
switch x a {format 1} b {format 2} c {format 3} default {format 4}
|
||||
} 4
|
||||
test switch-1.4 {simple patterns} {
|
||||
switch x a {format 1} b {format 2} c {format 3}
|
||||
} {}
|
||||
test switch-1.5 {simple pattern matches many times} {
|
||||
switch b a {format 1} b {format 2} b {format 3} b {format 4}
|
||||
} 2
|
||||
test switch-1.6 {simple patterns} {
|
||||
switch default a {format 1} default {format 2} c {format 3} default {format 4}
|
||||
} 2
|
||||
test switch-1.7 {simple patterns} {
|
||||
switch x a {format 1} default {format 2} c {format 3} default {format 4}
|
||||
} 4
|
||||
|
||||
test switch-2.1 {single-argument form for pattern/command pairs} {
|
||||
switch b {
|
||||
a {format 1}
|
||||
b {format 2}
|
||||
default {format 6}
|
||||
}
|
||||
} {2}
|
||||
test switch-2.2 {single-argument form for pattern/command pairs} {
|
||||
list [catch {switch z {a 2 b}} msg] $msg
|
||||
} {1 {extra switch pattern with no body}}
|
||||
|
||||
test switch-3.1 {-exact vs. -glob vs. -regexp} {
|
||||
switch -exact aaaab {
|
||||
^a*b$ {concat regexp}
|
||||
*b {concat glob}
|
||||
aaaab {concat exact}
|
||||
default {concat none}
|
||||
}
|
||||
} exact
|
||||
test switch-3.2 {-exact vs. -glob vs. -regexp} {
|
||||
switch -exact -regexp aaaab {
|
||||
^a*b$ {concat regexp}
|
||||
*b {concat glob}
|
||||
aaaab {concat exact}
|
||||
default {concat none}
|
||||
}
|
||||
} regexp
|
||||
test switch-3.3 {-exact vs. -glob vs. -regexp} {
|
||||
switch -glob aaaab {
|
||||
^a*b$ {concat regexp}
|
||||
*b {concat glob}
|
||||
aaaab {concat exact}
|
||||
default {concat none}
|
||||
}
|
||||
} glob
|
||||
test switch-3.4 {-exact vs. -glob vs. -regexp} {
|
||||
switch aaaab {^a*b$} {concat regexp} *b {concat glob} \
|
||||
aaaab {concat exact} default {concat none}
|
||||
} exact
|
||||
test switch-3.5 {-exact vs. -glob vs. -regexp} {
|
||||
switch -- -glob {
|
||||
^g.*b$ {concat regexp}
|
||||
-* {concat glob}
|
||||
-glob {concat exact}
|
||||
default {concat none}
|
||||
}
|
||||
} exact
|
||||
test switch-3.6 {-exact vs. -glob vs. -regexp} {
|
||||
list [catch {switch -foo a b c} msg] $msg
|
||||
} {1 {bad option "-foo": should be -exact, -glob, -regexp, or --}}
|
||||
|
||||
test switch-4.1 {error in executed command} {
|
||||
list [catch {switch a a {error "Just a test"} default {format 1}} msg] \
|
||||
$msg $errorInfo
|
||||
} {1 {Just a test} {Just a test
|
||||
while executing
|
||||
"error "Just a test""
|
||||
("a" arm line 1)
|
||||
invoked from within
|
||||
"switch a a {error "Just a test"} default {format 1}"}}
|
||||
test switch-4.2 {error: not enough args} {
|
||||
list [catch {switch} msg] $msg
|
||||
} {1 {wrong # args: should be "switch ?switches? string pattern body ... ?default body?"}}
|
||||
test switch-4.3 {error: pattern with no body} {
|
||||
list [catch {switch a b} msg] $msg
|
||||
} {1 {extra switch pattern with no body}}
|
||||
test switch-4.4 {error: pattern with no body} {
|
||||
list [catch {switch a b {format 1} c} msg] $msg
|
||||
} {1 {extra switch pattern with no body}}
|
||||
test switch-4.5 {error in default command} {
|
||||
list [catch {switch foo a {error switch1} b {error switch 3} \
|
||||
default {error switch2}} msg] $msg $errorInfo
|
||||
} {1 switch2 {switch2
|
||||
while executing
|
||||
"error switch2"
|
||||
("default" arm line 1)
|
||||
invoked from within
|
||||
"switch foo a {error switch1} b {error switch 3} default {error switch2}"}}
|
||||
|
||||
test switch-5.1 {errors in -regexp matching} {
|
||||
list [catch {switch -regexp aaaab {
|
||||
*b {concat glob}
|
||||
aaaab {concat exact}
|
||||
default {concat none}
|
||||
}} msg] $msg
|
||||
} {1 {couldn't compile regular expression pattern: ?+* follows nothing}}
|
||||
|
||||
test switch-6.1 {backslashes in patterns} {
|
||||
switch -exact {\a\$\.\[} {
|
||||
\a\$\.\[ {concat first}
|
||||
\a\\$\.\\[ {concat second}
|
||||
\\a\\$\\.\\[ {concat third}
|
||||
{\a\\$\.\\[} {concat fourth}
|
||||
{\\a\\$\\.\\[} {concat fifth}
|
||||
default {concat none}
|
||||
}
|
||||
} third
|
||||
test switch-6.2 {backslashes in patterns} {
|
||||
switch -exact {\a\$\.\[} {
|
||||
\a\$\.\[ {concat first}
|
||||
{\a\$\.\[} {concat second}
|
||||
{{\a\$\.\[}} {concat third}
|
||||
default {concat none}
|
||||
}
|
||||
} second
|
||||
|
||||
test switch-7.1 {"-" bodies} {
|
||||
switch a {
|
||||
a -
|
||||
b -
|
||||
c {concat 1}
|
||||
default {concat 2}
|
||||
}
|
||||
} 1
|
||||
test switch-7.2 {"-" bodies} {
|
||||
list [catch {
|
||||
switch a {
|
||||
a -
|
||||
b -
|
||||
c -
|
||||
}
|
||||
} msg] $msg
|
||||
} {1 {no body specified for pattern "a"}}
|
||||
test switch-7.3 {"-" bodies} {
|
||||
list [catch {
|
||||
switch a {
|
||||
a -
|
||||
b -foo
|
||||
c -
|
||||
}
|
||||
} msg] $msg
|
||||
} {1 {invalid command name: "-foo"}}
|
||||
914
tcl7.3/tests/trace.test
Normal file
914
tcl7.3/tests/trace.test
Normal file
@@ -0,0 +1,914 @@
|
||||
# Commands covered: trace
|
||||
#
|
||||
# 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.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/trace.test,v 1.20 93/10/11 09:05:38 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
proc traceScalar {name1 name2 op} {
|
||||
global info
|
||||
set info [list $name1 $name2 $op [catch {uplevel set $name1} msg] $msg]
|
||||
}
|
||||
proc traceArray {name1 name2 op} {
|
||||
global info
|
||||
set info [list $name1 $name2 $op [catch {uplevel set [set name1]($name2)} msg] $msg]
|
||||
}
|
||||
proc traceProc {name1 name2 op} {
|
||||
global info
|
||||
set info [concat $info [list $name1 $name2 $op]]
|
||||
}
|
||||
proc traceTag {tag args} {
|
||||
global info
|
||||
set info [concat $info $tag]
|
||||
}
|
||||
proc traceError {args} {
|
||||
error "trace returned error"
|
||||
}
|
||||
proc traceCheck {cmd args} {
|
||||
global info
|
||||
set info [list [catch $cmd msg] $msg]
|
||||
}
|
||||
proc traceCrtElement {value name1 name2 op} {
|
||||
uplevel set ${name1}($name2) $value
|
||||
}
|
||||
|
||||
# Read-tracing on variables
|
||||
|
||||
test trace-1.1 {trace variable reads} {
|
||||
catch {unset x}
|
||||
set info {}
|
||||
trace var x r traceScalar
|
||||
list [catch {set x} msg] $msg $info
|
||||
} {1 {can't read "x": no such variable} {x {} r 1 {can't read "x": no such variable}}}
|
||||
test trace-1.2 {trace variable reads} {
|
||||
catch {unset x}
|
||||
set x 123
|
||||
set info {}
|
||||
trace var x r traceScalar
|
||||
list [catch {set x} msg] $msg $info
|
||||
} {0 123 {x {} r 0 123}}
|
||||
test trace-1.3 {trace variable reads} {
|
||||
catch {unset x}
|
||||
set info {}
|
||||
trace var x r traceScalar
|
||||
set x 123
|
||||
set info
|
||||
} {}
|
||||
test trace-1.4 {trace array element reads} {
|
||||
catch {unset x}
|
||||
set info {}
|
||||
trace var x(2) r traceArray
|
||||
list [catch {set x(2)} msg] $msg $info
|
||||
} {1 {can't read "x(2)": no such element in array} {x 2 r 1 {can't read "x(2)": no such element in array}}}
|
||||
test trace-1.5 {trace array element reads} {
|
||||
catch {unset x}
|
||||
set x(2) zzz
|
||||
set info {}
|
||||
trace var x(2) r traceArray
|
||||
list [catch {set x(2)} msg] $msg $info
|
||||
} {0 zzz {x 2 r 0 zzz}}
|
||||
test trace-1.6 {trace reads on whole arrays} {
|
||||
catch {unset x}
|
||||
set info {}
|
||||
trace var x r traceArray
|
||||
list [catch {set x(2)} msg] $msg $info
|
||||
} {1 {can't read "x(2)": no such variable} {}}
|
||||
test trace-1.7 {trace reads on whole arrays} {
|
||||
catch {unset x}
|
||||
set x(2) zzz
|
||||
set info {}
|
||||
trace var x r traceArray
|
||||
list [catch {set x(2)} msg] $msg $info
|
||||
} {0 zzz {x 2 r 0 zzz}}
|
||||
test trace-1.8 {trace variable reads} {
|
||||
catch {unset x}
|
||||
set x 444
|
||||
set info {}
|
||||
trace var x r traceScalar
|
||||
unset x
|
||||
set info
|
||||
} {}
|
||||
|
||||
# Basic write-tracing on variables
|
||||
|
||||
test trace-2.1 {trace variable writes} {
|
||||
catch {unset x}
|
||||
set info {}
|
||||
trace var x w traceScalar
|
||||
set x 123
|
||||
set info
|
||||
} {x {} w 0 123}
|
||||
test trace-2.2 {trace writes to array elements} {
|
||||
catch {unset x}
|
||||
set info {}
|
||||
trace var x(33) w traceArray
|
||||
set x(33) 444
|
||||
set info
|
||||
} {x 33 w 0 444}
|
||||
test trace-2.3 {trace writes on whole arrays} {
|
||||
catch {unset x}
|
||||
set info {}
|
||||
trace var x w traceArray
|
||||
set x(abc) qq
|
||||
set info
|
||||
} {x abc w 0 qq}
|
||||
test trace-2.4 {trace variable writes} {
|
||||
catch {unset x}
|
||||
set x 1234
|
||||
set info {}
|
||||
trace var x w traceScalar
|
||||
set x
|
||||
set info
|
||||
} {}
|
||||
test trace-2.5 {trace variable writes} {
|
||||
catch {unset x}
|
||||
set x 1234
|
||||
set info {}
|
||||
trace var x w traceScalar
|
||||
unset x
|
||||
set info
|
||||
} {}
|
||||
|
||||
# Basic unset-tracing on variables
|
||||
|
||||
test trace-3.1 {trace variable unsets} {
|
||||
catch {unset x}
|
||||
set info {}
|
||||
trace var x u traceScalar
|
||||
catch {unset x}
|
||||
set info
|
||||
} {x {} u 1 {can't read "x": no such variable}}
|
||||
test trace-3.2 {variable mustn't exist during unset trace} {
|
||||
catch {unset x}
|
||||
set x 1234
|
||||
set info {}
|
||||
trace var x u traceScalar
|
||||
unset x
|
||||
set info
|
||||
} {x {} u 1 {can't read "x": no such variable}}
|
||||
test trace-3.3 {unset traces mustn't be called during reads and writes} {
|
||||
catch {unset x}
|
||||
set info {}
|
||||
trace var x u traceScalar
|
||||
set x 44
|
||||
set x
|
||||
set info
|
||||
} {}
|
||||
test trace-3.4 {trace unsets on array elements} {
|
||||
catch {unset x}
|
||||
set x(0) 18
|
||||
set info {}
|
||||
trace var x(1) u traceArray
|
||||
catch {unset x(1)}
|
||||
set info
|
||||
} {x 1 u 1 {can't read "x(1)": no such element in array}}
|
||||
test trace-3.5 {trace unsets on array elements} {
|
||||
catch {unset x}
|
||||
set x(1) 18
|
||||
set info {}
|
||||
trace var x(1) u traceArray
|
||||
unset x(1)
|
||||
set info
|
||||
} {x 1 u 1 {can't read "x(1)": no such element in array}}
|
||||
test trace-3.6 {trace unsets on array elements} {
|
||||
catch {unset x}
|
||||
set x(1) 18
|
||||
set info {}
|
||||
trace var x(1) u traceArray
|
||||
unset x
|
||||
set info
|
||||
} {x 1 u 1 {can't read "x(1)": no such variable}}
|
||||
test trace-3.7 {trace unsets on whole arrays} {
|
||||
catch {unset x}
|
||||
set x(1) 18
|
||||
set info {}
|
||||
trace var x u traceProc
|
||||
catch {unset x(0)}
|
||||
set info
|
||||
} {}
|
||||
test trace-3.8 {trace unsets on whole arrays} {
|
||||
catch {unset x}
|
||||
set x(1) 18
|
||||
set x(2) 144
|
||||
set x(3) 14
|
||||
set info {}
|
||||
trace var x u traceProc
|
||||
unset x(1)
|
||||
set info
|
||||
} {x 1 u}
|
||||
test trace-3.9 {trace unsets on whole arrays} {
|
||||
catch {unset x}
|
||||
set x(1) 18
|
||||
set x(2) 144
|
||||
set x(3) 14
|
||||
set info {}
|
||||
trace var x u traceProc
|
||||
unset x
|
||||
set info
|
||||
} {x {} u}
|
||||
|
||||
# Trace multiple trace types at once.
|
||||
|
||||
test trace-4.1 {multiple ops traced at once} {
|
||||
catch {unset x}
|
||||
set info {}
|
||||
trace var x rwu traceProc
|
||||
catch {set x}
|
||||
set x 22
|
||||
set x
|
||||
set x 33
|
||||
unset x
|
||||
set info
|
||||
} {x {} r x {} w x {} r x {} w x {} u}
|
||||
test trace-4.2 {multiple ops traced on array element} {
|
||||
catch {unset x}
|
||||
set info {}
|
||||
trace var x(0) rwu traceProc
|
||||
catch {set x(0)}
|
||||
set x(0) 22
|
||||
set x(0)
|
||||
set x(0) 33
|
||||
unset x(0)
|
||||
unset x
|
||||
set info
|
||||
} {x 0 r x 0 w x 0 r x 0 w x 0 u}
|
||||
test trace-4.3 {multiple ops traced on whole array} {
|
||||
catch {unset x}
|
||||
set info {}
|
||||
trace var x rwu traceProc
|
||||
catch {set x(0)}
|
||||
set x(0) 22
|
||||
set x(0)
|
||||
set x(0) 33
|
||||
unset x(0)
|
||||
unset x
|
||||
set info
|
||||
} {x 0 w x 0 r x 0 w x 0 u x {} u}
|
||||
|
||||
# Check order of invocation of traces
|
||||
|
||||
test trace-5.1 {order of invocation of traces} {
|
||||
catch {unset x}
|
||||
set info {}
|
||||
trace var x r "traceTag 1"
|
||||
trace var x r "traceTag 2"
|
||||
trace var x r "traceTag 3"
|
||||
catch {set x}
|
||||
set x 22
|
||||
set x
|
||||
set info
|
||||
} {3 2 1 3 2 1}
|
||||
test trace-5.2 {order of invocation of traces} {
|
||||
catch {unset x}
|
||||
set x(0) 44
|
||||
set info {}
|
||||
trace var x(0) r "traceTag 1"
|
||||
trace var x(0) r "traceTag 2"
|
||||
trace var x(0) r "traceTag 3"
|
||||
set x(0)
|
||||
set info
|
||||
} {3 2 1}
|
||||
test trace-5.3 {order of invocation of traces} {
|
||||
catch {unset x}
|
||||
set x(0) 44
|
||||
set info {}
|
||||
trace var x(0) r "traceTag 1"
|
||||
trace var x r "traceTag A1"
|
||||
trace var x(0) r "traceTag 2"
|
||||
trace var x r "traceTag A2"
|
||||
trace var x(0) r "traceTag 3"
|
||||
trace var x r "traceTag A3"
|
||||
set x(0)
|
||||
set info
|
||||
} {A3 A2 A1 3 2 1}
|
||||
|
||||
# Check effects of errors in trace procedures
|
||||
|
||||
test trace-6.1 {error returns from traces} {
|
||||
catch {unset x}
|
||||
set x 123
|
||||
set info {}
|
||||
trace var x r "traceTag 1"
|
||||
trace var x r traceError
|
||||
list [catch {set x} msg] $msg $info
|
||||
} {1 {can't read "x": trace returned error} {}}
|
||||
test trace-6.2 {error returns from traces} {
|
||||
catch {unset x}
|
||||
set x 123
|
||||
set info {}
|
||||
trace var x w "traceTag 1"
|
||||
trace var x w traceError
|
||||
list [catch {set x 44} msg] $msg $info
|
||||
} {1 {can't set "x": trace returned error} {}}
|
||||
test trace-6.3 {error returns from traces} {
|
||||
catch {unset x}
|
||||
set x 123
|
||||
set info {}
|
||||
trace var x u "traceTag 1"
|
||||
trace var x u traceError
|
||||
list [catch {unset x} msg] $msg $info
|
||||
} {0 {} 1}
|
||||
test trace-6.4 {error returns from traces} {
|
||||
catch {unset x}
|
||||
set x(0) 123
|
||||
set info {}
|
||||
trace var x(0) r "traceTag 1"
|
||||
trace var x r "traceTag 2"
|
||||
trace var x r traceError
|
||||
trace var x r "traceTag 3"
|
||||
list [catch {set x(0)} msg] $msg $info
|
||||
} {1 {can't read "x(0)": trace returned error} 3}
|
||||
test trace-6.5 {error returns from traces} {
|
||||
catch {unset x}
|
||||
set x 123
|
||||
trace var x u traceError
|
||||
list [catch {unset x} msg] $msg
|
||||
} {0 {}}
|
||||
test trace-6.6 {error returns from traces} {
|
||||
# This test just makes sure that the memory for the error message
|
||||
# gets deallocated correctly when the trace is invoked again or
|
||||
# when the trace is deleted.
|
||||
catch {unset x}
|
||||
set x 123
|
||||
trace var x r traceError
|
||||
catch {set x}
|
||||
catch {set x}
|
||||
trace vdelete x r traceError
|
||||
} {}
|
||||
|
||||
# Check to see that variables are expunged before trace
|
||||
# procedures are invoked, so trace procedure can even manipulate
|
||||
# a new copy of the variables.
|
||||
|
||||
test trace-7.1 {be sure variable is unset before trace is called} {
|
||||
catch {unset x}
|
||||
set x 33
|
||||
set info {}
|
||||
trace var x u {traceCheck {uplevel set x}}
|
||||
unset x
|
||||
set info
|
||||
} {1 {can't read "x": no such variable}}
|
||||
test trace-7.2 {be sure variable is unset before trace is called} {
|
||||
catch {unset x}
|
||||
set x 33
|
||||
set info {}
|
||||
trace var x u {traceCheck {uplevel set x 22}}
|
||||
unset x
|
||||
concat $info [list [catch {set x} msg] $msg]
|
||||
} {0 22 0 22}
|
||||
test trace-7.3 {be sure traces are cleared before unset trace called} {
|
||||
catch {unset x}
|
||||
set x 33
|
||||
set info {}
|
||||
trace var x u {traceCheck {uplevel trace vinfo x}}
|
||||
unset x
|
||||
set info
|
||||
} {0 {}}
|
||||
test trace-7.4 {set new trace during unset trace} {
|
||||
catch {unset x}
|
||||
set x 33
|
||||
set info {}
|
||||
trace var x u {traceCheck {global x; trace var x u traceProc}}
|
||||
unset x
|
||||
concat $info [trace vinfo x]
|
||||
} {0 {} {u traceProc}}
|
||||
|
||||
test trace-8.1 {make sure array elements are unset before traces are called} {
|
||||
catch {unset x}
|
||||
set x(0) 33
|
||||
set info {}
|
||||
trace var x(0) u {traceCheck {uplevel set x(0)}}
|
||||
unset x(0)
|
||||
set info
|
||||
} {1 {can't read "x(0)": no such element in array}}
|
||||
test trace-8.2 {make sure array elements are unset before traces are called} {
|
||||
catch {unset x}
|
||||
set x(0) 33
|
||||
set info {}
|
||||
trace var x(0) u {traceCheck {uplevel set x(0) zzz}}
|
||||
unset x(0)
|
||||
concat $info [list [catch {set x(0)} msg] $msg]
|
||||
} {0 zzz 0 zzz}
|
||||
test trace-8.3 {array elements are unset before traces are called} {
|
||||
catch {unset x}
|
||||
set x(0) 33
|
||||
set info {}
|
||||
trace var x(0) u {traceCheck {global x; trace vinfo x(0)}}
|
||||
unset x(0)
|
||||
set info
|
||||
} {0 {}}
|
||||
test trace-8.4 {set new array element trace during unset trace} {
|
||||
catch {unset x}
|
||||
set x(0) 33
|
||||
set info {}
|
||||
trace var x(0) u {traceCheck {uplevel {trace variable x(0) r {}}}}
|
||||
catch {unset x(0)}
|
||||
concat $info [trace vinfo x(0)]
|
||||
} {0 {} {r {}}}
|
||||
|
||||
test trace-9.1 {make sure arrays are unset before traces are called} {
|
||||
catch {unset x}
|
||||
set x(0) 33
|
||||
set info {}
|
||||
trace var x u {traceCheck {uplevel set x(0)}}
|
||||
unset x
|
||||
set info
|
||||
} {1 {can't read "x(0)": no such variable}}
|
||||
test trace-9.2 {make sure arrays are unset before traces are called} {
|
||||
catch {unset x}
|
||||
set x(y) 33
|
||||
set info {}
|
||||
trace var x u {traceCheck {uplevel set x(y) 22}}
|
||||
unset x
|
||||
concat $info [list [catch {set x(y)} msg] $msg]
|
||||
} {0 22 0 22}
|
||||
test trace-9.3 {make sure arrays are unset before traces are called} {
|
||||
catch {unset x}
|
||||
set x(y) 33
|
||||
set info {}
|
||||
trace var x u {traceCheck {uplevel array names x}}
|
||||
unset x
|
||||
set info
|
||||
} {1 {"x" isn't an array}}
|
||||
test trace-9.4 {make sure arrays are unset before traces are called} {
|
||||
catch {unset x}
|
||||
set x(y) 33
|
||||
set info {}
|
||||
set cmd {traceCheck {uplevel {trace vinfo x}}}
|
||||
trace var x u $cmd
|
||||
unset x
|
||||
set info
|
||||
} {0 {}}
|
||||
test trace-9.5 {set new array trace during unset trace} {
|
||||
catch {unset x}
|
||||
set x(y) 33
|
||||
set info {}
|
||||
trace var x u {traceCheck {global x; trace var x r {}}}
|
||||
unset x
|
||||
concat $info [trace vinfo x]
|
||||
} {0 {} {r {}}}
|
||||
test trace-9.6 {create scalar during array unset trace} {
|
||||
catch {unset x}
|
||||
set x(y) 33
|
||||
set info {}
|
||||
trace var x u {traceCheck {global x; set x 44}}
|
||||
unset x
|
||||
concat $info [list [catch {set x} msg] $msg]
|
||||
} {0 44 0 44}
|
||||
|
||||
# Check special conditions (e.g. errors) in Tcl_TraceVar2.
|
||||
|
||||
test trace-10.1 {creating array when setting variable traces} {
|
||||
catch {unset x}
|
||||
set info {}
|
||||
trace var x(0) w traceProc
|
||||
list [catch {set x 22} msg] $msg
|
||||
} {1 {can't set "x": variable is array}}
|
||||
test trace-10.2 {creating array when setting variable traces} {
|
||||
catch {unset x}
|
||||
set info {}
|
||||
trace var x(0) w traceProc
|
||||
list [catch {set x(0)} msg] $msg
|
||||
} {1 {can't read "x(0)": no such element in array}}
|
||||
test trace-10.3 {creating array when setting variable traces} {
|
||||
catch {unset x}
|
||||
set info {}
|
||||
trace var x(0) w traceProc
|
||||
set x(0) 22
|
||||
set info
|
||||
} {x 0 w}
|
||||
test trace-10.4 {creating variable when setting variable traces} {
|
||||
catch {unset x}
|
||||
set info {}
|
||||
trace var x w traceProc
|
||||
list [catch {set x} msg] $msg
|
||||
} {1 {can't read "x": no such variable}}
|
||||
test trace-10.5 {creating variable when setting variable traces} {
|
||||
catch {unset x}
|
||||
set info {}
|
||||
trace var x w traceProc
|
||||
set x 22
|
||||
set info
|
||||
} {x {} w}
|
||||
test trace-10.6 {creating variable when setting variable traces} {
|
||||
catch {unset x}
|
||||
set info {}
|
||||
trace var x w traceProc
|
||||
set x(0) 22
|
||||
set info
|
||||
} {x 0 w}
|
||||
test trace-10.7 {create array element during read trace} {
|
||||
catch {unset x}
|
||||
set x(2) zzz
|
||||
trace var x r {traceCrtElement xyzzy}
|
||||
list [catch {set x(3)} msg] $msg
|
||||
} {0 xyzzy}
|
||||
test trace-10.8 {errors when setting variable traces} {
|
||||
catch {unset x}
|
||||
set x 44
|
||||
list [catch {trace var x(0) w traceProc} msg] $msg
|
||||
} {1 {can't trace "x(0)": variable isn't array}}
|
||||
|
||||
# Check deleting one trace from another.
|
||||
|
||||
test trace-11.1 {delete one trace from another} {
|
||||
proc delTraces {args} {
|
||||
global x
|
||||
trace vdel x r {traceTag 2}
|
||||
trace vdel x r {traceTag 3}
|
||||
trace vdel x r {traceTag 4}
|
||||
}
|
||||
catch {unset x}
|
||||
set x 44
|
||||
set info {}
|
||||
trace var x r {traceTag 1}
|
||||
trace var x r {traceTag 2}
|
||||
trace var x r {traceTag 3}
|
||||
trace var x r {traceTag 4}
|
||||
trace var x r delTraces
|
||||
trace var x r {traceTag 5}
|
||||
set x
|
||||
set info
|
||||
} {5 1}
|
||||
|
||||
# Check operation and syntax of "trace" command.
|
||||
|
||||
test trace-12.1 {trace command (overall)} {
|
||||
list [catch {trace} msg] $msg
|
||||
} {1 {too few args: should be "trace option [arg arg ...]"}}
|
||||
test trace-12.2 {trace command (overall)} {
|
||||
list [catch {trace gorp} msg] $msg
|
||||
} {1 {bad option "gorp": should be variable, vdelete, or vinfo}}
|
||||
test trace-12.3 {trace command ("variable" option)} {
|
||||
list [catch {trace variable x y} msg] $msg
|
||||
} {1 {wrong # args: should be "trace variable name ops command"}}
|
||||
test trace-12.4 {trace command ("variable" option)} {
|
||||
list [catch {trace var x y z z2} msg] $msg
|
||||
} {1 {wrong # args: should be "trace variable name ops command"}}
|
||||
test trace-12.5 {trace command ("variable" option)} {
|
||||
list [catch {trace var x y z} msg] $msg
|
||||
} {1 {bad operations "y": should be one or more of rwu}}
|
||||
test trace-12.6 {trace command ("vdelete" option)} {
|
||||
list [catch {trace vdelete x y} msg] $msg
|
||||
} {1 {wrong # args: should be "trace vdelete name ops command"}}
|
||||
test trace-12.7 {trace command ("vdelete" option)} {
|
||||
list [catch {trace vdelete x y z foo} msg] $msg
|
||||
} {1 {wrong # args: should be "trace vdelete name ops command"}}
|
||||
test trace-12.8 {trace command ("vdelete" option)} {
|
||||
list [catch {trace vdelete x y z} msg] $msg
|
||||
} {1 {bad operations "y": should be one or more of rwu}}
|
||||
test trace-12.9 {trace command ("vdelete" option)} {
|
||||
catch {unset x}
|
||||
set info {}
|
||||
trace var x w traceProc
|
||||
trace vdelete x w traceProc
|
||||
} {}
|
||||
test trace-12.10 {trace command ("vdelete" option)} {
|
||||
catch {unset x}
|
||||
set info {}
|
||||
trace var x w traceProc
|
||||
trace vdelete x w traceProc
|
||||
set x 12345
|
||||
set info
|
||||
} {}
|
||||
test trace-12.11 {trace command ("vdelete" option)} {
|
||||
catch {unset x}
|
||||
set info {}
|
||||
trace var x w {traceTag 1}
|
||||
trace var x w traceProc
|
||||
trace var x w {traceTag 2}
|
||||
set x yy
|
||||
trace vdelete x w traceProc
|
||||
set x 12345
|
||||
trace vdelete x w {traceTag 1}
|
||||
set x foo
|
||||
trace vdelete x w {traceTag 2}
|
||||
set x gorp
|
||||
set info
|
||||
} {2 x {} w 1 2 1 2}
|
||||
test trace-12.12 {trace command ("vdelete" option)} {
|
||||
catch {unset x}
|
||||
set info {}
|
||||
trace var x w {traceTag 1}
|
||||
trace vdelete x w non_existent
|
||||
set x 12345
|
||||
set info
|
||||
} {1}
|
||||
test trace-12.13 {trace command ("vinfo" option)} {
|
||||
list [catch {trace vinfo} msg] $msg]
|
||||
} {1 {wrong # args: should be "trace vinfo name"]}}
|
||||
test trace-12.14 {trace command ("vinfo" option)} {
|
||||
list [catch {trace vinfo x y} msg] $msg]
|
||||
} {1 {wrong # args: should be "trace vinfo name"]}}
|
||||
test trace-12.15 {trace command ("vinfo" option)} {
|
||||
catch {unset x}
|
||||
trace var x w {traceTag 1}
|
||||
trace var x w traceProc
|
||||
trace var x w {traceTag 2}
|
||||
trace vinfo x
|
||||
} {{w {traceTag 2}} {w traceProc} {w {traceTag 1}}}
|
||||
test trace-12.16 {trace command ("vinfo" option)} {
|
||||
catch {unset x}
|
||||
trace vinfo x
|
||||
} {}
|
||||
test trace-12.17 {trace command ("vinfo" option)} {
|
||||
catch {unset x}
|
||||
trace vinfo x(0)
|
||||
} {}
|
||||
test trace-12.18 {trace command ("vinfo" option)} {
|
||||
catch {unset x}
|
||||
set x 44
|
||||
trace vinfo x(0)
|
||||
} {}
|
||||
test trace-12.19 {trace command ("vinfo" option)} {
|
||||
catch {unset x}
|
||||
set x 44
|
||||
trace var x w {traceTag 1}
|
||||
proc check {} {global x; trace vinfo x}
|
||||
check
|
||||
} {{w {traceTag 1}}}
|
||||
|
||||
# Check fancy trace commands (long ones, weird arguments, etc.)
|
||||
|
||||
test trace-13.1 {long trace command} {
|
||||
catch {unset x}
|
||||
set info {}
|
||||
trace var x w {traceTag {This is a very very long argument. It's \
|
||||
designed to test out the facilities of TraceVarProc for dealing \
|
||||
with such long arguments by malloc-ing space. One possibility \
|
||||
is that space doesn't get freed properly. If this happens, then \
|
||||
invoking this test over and over again will eventually leak memory.}}
|
||||
set x 44
|
||||
set info
|
||||
} {This is a very very long argument. It's \
|
||||
designed to test out the facilities of TraceVarProc for dealing \
|
||||
with such long arguments by malloc-ing space. One possibility \
|
||||
is that space doesn't get freed properly. If this happens, then \
|
||||
invoking this test over and over again will eventually leak memory.}
|
||||
test trace-13.2 {long trace command result to ignore} {
|
||||
proc longResult {args} {return "quite a bit of text, designed to
|
||||
generate a core leak if this command file is invoked over and over again
|
||||
and memory isn't being recycled correctly"}
|
||||
catch {unset x}
|
||||
trace var x w longResult
|
||||
set x 44
|
||||
set x 5
|
||||
set x abcde
|
||||
} abcde
|
||||
test trace-13.3 {special list-handling in trace commands} {
|
||||
catch {unset "x y z"}
|
||||
set "x y z(a\n\{)" 44
|
||||
set info {}
|
||||
trace var "x y z(a\n\{)" w traceProc
|
||||
set "x y z(a\n\{)" 33
|
||||
set info
|
||||
} "{x y z} a\\n\\{ w"
|
||||
|
||||
# Check for proper handling of unsets during traces.
|
||||
|
||||
proc traceUnset {unsetName args} {
|
||||
global info
|
||||
upvar $unsetName x
|
||||
lappend info [catch {unset x} msg] $msg [catch {set x} msg] $msg
|
||||
}
|
||||
proc traceReset {unsetName resetName args} {
|
||||
global info
|
||||
upvar $unsetName x $resetName y
|
||||
lappend info [catch {unset x} msg] $msg [catch {set y xyzzy} msg] $msg
|
||||
}
|
||||
proc traceReset2 {unsetName resetName args} {
|
||||
global info
|
||||
lappend info [catch {uplevel unset $unsetName} msg] $msg \
|
||||
[catch {uplevel set $resetName xyzzy} msg] $msg
|
||||
}
|
||||
proc traceAppend {string name1 name2 op} {
|
||||
global info
|
||||
lappend info $string
|
||||
}
|
||||
|
||||
test trace-14.1 {unsets during read traces} {
|
||||
catch {unset y}
|
||||
set y 1234
|
||||
set info {}
|
||||
trace var y r {traceUnset y}
|
||||
trace var y u {traceAppend unset}
|
||||
lappend info [catch {set y} msg] $msg
|
||||
} {unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}}
|
||||
test trace-14.2 {unsets during read traces} {
|
||||
catch {unset y}
|
||||
set y(0) 1234
|
||||
set info {}
|
||||
trace var y(0) r {traceUnset y(0)}
|
||||
lappend info [catch {set y(0)} msg] $msg
|
||||
} {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such element in array}}
|
||||
test trace-14.3 {unsets during read traces} {
|
||||
catch {unset y}
|
||||
set y(0) 1234
|
||||
set info {}
|
||||
trace var y(0) r {traceUnset y}
|
||||
lappend info [catch {set y(0)} msg] $msg
|
||||
} {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such variable}}
|
||||
test trace-14.4 {unsets during read traces} {
|
||||
catch {unset y}
|
||||
set y 1234
|
||||
set info {}
|
||||
trace var y r {traceReset y y}
|
||||
lappend info [catch {set y} msg] $msg
|
||||
} {0 {} 0 xyzzy 0 xyzzy}
|
||||
test trace-14.5 {unsets during read traces} {
|
||||
catch {unset y}
|
||||
set y(0) 1234
|
||||
set info {}
|
||||
trace var y(0) r {traceReset y(0) y(0)}
|
||||
lappend info [catch {set y(0)} msg] $msg
|
||||
} {0 {} 0 xyzzy 0 xyzzy}
|
||||
test trace-14.6 {unsets during read traces} {
|
||||
catch {unset y}
|
||||
set y(0) 1234
|
||||
set info {}
|
||||
trace var y(0) r {traceReset y y(0)}
|
||||
lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg
|
||||
} {0 {} 1 {can't set "y": upvar refers to element in deleted array} 1 {can't read "y(0)": no such variable} 1 {can't read "y(0)": no such variable}}
|
||||
test trace-14.7 {unsets during read traces} {
|
||||
catch {unset y}
|
||||
set y(0) 1234
|
||||
set info {}
|
||||
trace var y(0) r {traceReset2 y y(0)}
|
||||
lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg
|
||||
} {0 {} 0 xyzzy 1 {can't read "y(0)": no such element in array} 0 xyzzy}
|
||||
test trace-14.8 {unsets during write traces} {
|
||||
catch {unset y}
|
||||
set y 1234
|
||||
set info {}
|
||||
trace var y w {traceUnset y}
|
||||
trace var y u {traceAppend unset}
|
||||
lappend info [catch {set y xxx} msg] $msg
|
||||
} {unset 0 {} 1 {can't read "x": no such variable} 0 {}}
|
||||
test trace-14.9 {unsets during write traces} {
|
||||
catch {unset y}
|
||||
set y(0) 1234
|
||||
set info {}
|
||||
trace var y(0) w {traceUnset y(0)}
|
||||
lappend info [catch {set y(0) xxx} msg] $msg
|
||||
} {0 {} 1 {can't read "x": no such variable} 0 {}}
|
||||
test trace-14.10 {unsets during write traces} {
|
||||
catch {unset y}
|
||||
set y(0) 1234
|
||||
set info {}
|
||||
trace var y(0) w {traceUnset y}
|
||||
lappend info [catch {set y(0) xxx} msg] $msg
|
||||
} {0 {} 1 {can't read "x": no such variable} 0 {}}
|
||||
test trace-14.11 {unsets during write traces} {
|
||||
catch {unset y}
|
||||
set y 1234
|
||||
set info {}
|
||||
trace var y w {traceReset y y}
|
||||
lappend info [catch {set y xxx} msg] $msg
|
||||
} {0 {} 0 xyzzy 0 xyzzy}
|
||||
test trace-14.12 {unsets during write traces} {
|
||||
catch {unset y}
|
||||
set y(0) 1234
|
||||
set info {}
|
||||
trace var y(0) w {traceReset y(0) y(0)}
|
||||
lappend info [catch {set y(0) xxx} msg] $msg
|
||||
} {0 {} 0 xyzzy 0 xyzzy}
|
||||
test trace-14.13 {unsets during write traces} {
|
||||
catch {unset y}
|
||||
set y(0) 1234
|
||||
set info {}
|
||||
trace var y(0) w {traceReset y y(0)}
|
||||
lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg
|
||||
} {0 {} 1 {can't set "y": upvar refers to element in deleted array} 0 {} 1 {can't read "y(0)": no such variable}}
|
||||
test trace-14.14 {unsets during write traces} {
|
||||
catch {unset y}
|
||||
set y(0) 1234
|
||||
set info {}
|
||||
trace var y(0) w {traceReset2 y y(0)}
|
||||
lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg
|
||||
} {0 {} 0 xyzzy 0 {} 0 xyzzy}
|
||||
test trace-14.15 {unsets during unset traces} {
|
||||
catch {unset y}
|
||||
set y 1234
|
||||
set info {}
|
||||
trace var y u {traceUnset y}
|
||||
lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg
|
||||
} {1 {can't unset "x": no such variable} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y": no such variable}}
|
||||
test trace-14.16 {unsets during unset traces} {
|
||||
catch {unset y}
|
||||
set y(0) 1234
|
||||
set info {}
|
||||
trace var y(0) u {traceUnset y(0)}
|
||||
lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg
|
||||
} {1 {can't unset "x": no such variable} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y(0)": no such element in array}}
|
||||
test trace-14.17 {unsets during unset traces} {
|
||||
catch {unset y}
|
||||
set y(0) 1234
|
||||
set info {}
|
||||
trace var y(0) u {traceUnset y}
|
||||
lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg
|
||||
} {0 {} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y(0)": no such variable}}
|
||||
test trace-14.18 {unsets during unset traces} {
|
||||
catch {unset y}
|
||||
set y 1234
|
||||
set info {}
|
||||
trace var y u {traceReset2 y y}
|
||||
lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg
|
||||
} {1 {can't unset "y": no such variable} 0 xyzzy 0 {} 0 xyzzy}
|
||||
test trace-14.19 {unsets during unset traces} {
|
||||
catch {unset y}
|
||||
set y(0) 1234
|
||||
set info {}
|
||||
trace var y(0) u {traceReset2 y(0) y(0)}
|
||||
lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg
|
||||
} {1 {can't unset "y(0)": no such element in array} 0 xyzzy 0 {} 0 xyzzy}
|
||||
test trace-14.20 {unsets during unset traces} {
|
||||
catch {unset y}
|
||||
set y(0) 1234
|
||||
set info {}
|
||||
trace var y(0) u {traceReset2 y y(0)}
|
||||
lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg
|
||||
} {0 {} 0 xyzzy 0 {} 0 xyzzy}
|
||||
test trace-14.21 {unsets cancelling traces} {
|
||||
catch {unset y}
|
||||
set y 1234
|
||||
set info {}
|
||||
trace var y r {traceAppend first}
|
||||
trace var y r {traceUnset y}
|
||||
trace var y r {traceAppend third}
|
||||
trace var y u {traceAppend unset}
|
||||
lappend info [catch {set y} msg] $msg
|
||||
} {third unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}}
|
||||
test trace-14.22 {unsets cancelling traces} {
|
||||
catch {unset y}
|
||||
set y(0) 1234
|
||||
set info {}
|
||||
trace var y(0) r {traceAppend first}
|
||||
trace var y(0) r {traceUnset y}
|
||||
trace var y(0) r {traceAppend third}
|
||||
trace var y(0) u {traceAppend unset}
|
||||
lappend info [catch {set y(0)} msg] $msg
|
||||
} {third unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such variable}}
|
||||
|
||||
# Check various non-interference between traces and other things.
|
||||
|
||||
test trace-15.1 {trace doesn't prevent unset errors} {
|
||||
catch {unset x}
|
||||
set info {}
|
||||
trace var x u {traceProc}
|
||||
list [catch {unset x} msg] $msg $info
|
||||
} {1 {can't unset "x": no such variable} {x {} u}}
|
||||
test trace-15.2 {traced variables must survive procedure exits} {
|
||||
catch {unset x}
|
||||
proc p1 {} {global x; trace var x w traceProc}
|
||||
p1
|
||||
trace vinfo x
|
||||
} {{w traceProc}}
|
||||
test trace-15.3 {traced variables must survive procedure exits} {
|
||||
catch {unset x}
|
||||
set info {}
|
||||
proc p1 {} {global x; trace var x w traceProc}
|
||||
p1
|
||||
set x 44
|
||||
set info
|
||||
} {x {} w}
|
||||
|
||||
# Be sure that procedure frames are released before unset traces
|
||||
# are invoked.
|
||||
|
||||
test trace-16.1 {unset traces on procedure returns} {
|
||||
proc p1 {x y} {set a 44; p2 14}
|
||||
proc p2 {z} {trace var z u {traceCheck {lsort [uplevel {info vars}]}}}
|
||||
set info {}
|
||||
p1 foo bar
|
||||
set info
|
||||
} {0 {a x y}}
|
||||
|
||||
# Delete arrays when done, so they can be re-used as scalars
|
||||
# elsewhere.
|
||||
|
||||
catch {unset x}
|
||||
catch {unset y}
|
||||
concat {}
|
||||
73
tcl7.3/tests/unknown.test
Normal file
73
tcl7.3/tests/unknown.test
Normal file
@@ -0,0 +1,73 @@
|
||||
# Commands covered: unknown
|
||||
#
|
||||
# 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.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/unknown.test,v 1.7 93/10/11 09:06:00 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
catch {rename unknown {}}
|
||||
|
||||
test unknown-1.1 {non-existent "unknown" command} {
|
||||
list [catch {_non-existent_ foo bar} msg] $msg
|
||||
} {1 {invalid command name: "_non-existent_"}}
|
||||
|
||||
proc unknown {args} {
|
||||
global x
|
||||
set x $args
|
||||
}
|
||||
|
||||
test unknown-2.1 {calling "unknown" command} {
|
||||
foobar x y z
|
||||
set x
|
||||
} {foobar x y z}
|
||||
test unknown-2.2 {calling "unknown" command with lots of args} {
|
||||
foobar 1 2 3 4 5 6 7
|
||||
set x
|
||||
} {foobar 1 2 3 4 5 6 7}
|
||||
test unknown-2.3 {calling "unknown" command with lots of args} {
|
||||
foobar 1 2 3 4 5 6 7 8
|
||||
set x
|
||||
} {foobar 1 2 3 4 5 6 7 8}
|
||||
test unknown-2.4 {calling "unknown" command with lots of args} {
|
||||
foobar 1 2 3 4 5 6 7 8 9
|
||||
set x
|
||||
} {foobar 1 2 3 4 5 6 7 8 9}
|
||||
|
||||
test unknown-3.1 {argument quoting in calls to "unknown"} {
|
||||
foobar \{ \} a\{b \; "\\" \$a a\[b \]
|
||||
set x
|
||||
} "foobar \\{ \\} a\\{b {;} \\\\ {\$a} {a\[b} \\]"
|
||||
|
||||
proc unknown args {
|
||||
error "unknown failed"
|
||||
}
|
||||
|
||||
test unknown-4.1 {errors in "unknown" procedure} {
|
||||
list [catch {non-existent a b} msg] $msg $errorCode
|
||||
} {1 {unknown failed} NONE}
|
||||
|
||||
catch {rename unknown {}}
|
||||
return {}
|
||||
123
tcl7.3/tests/uplevel.test
Normal file
123
tcl7.3/tests/uplevel.test
Normal file
@@ -0,0 +1,123 @@
|
||||
# Commands covered: uplevel
|
||||
#
|
||||
# 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.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/uplevel.test,v 1.11 93/07/17 14:38:22 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
proc a {x y} {
|
||||
newset z [expr $x+$y]
|
||||
return $z
|
||||
}
|
||||
proc newset {name value} {
|
||||
uplevel set $name $value
|
||||
uplevel 1 {uplevel 1 {set xyz 22}}
|
||||
}
|
||||
|
||||
test uplevel-1.1 {simple operation} {
|
||||
set xyz 0
|
||||
a 22 33
|
||||
} 55
|
||||
test uplevel-1.2 {command is another uplevel command} {
|
||||
set xyz 0
|
||||
a 22 33
|
||||
set xyz
|
||||
} 22
|
||||
|
||||
proc a1 {} {
|
||||
b1
|
||||
global a a1
|
||||
set a $x
|
||||
set a1 $y
|
||||
}
|
||||
proc b1 {} {
|
||||
c1
|
||||
global b b1
|
||||
set b $x
|
||||
set b1 $y
|
||||
}
|
||||
proc c1 {} {
|
||||
uplevel 1 set x 111
|
||||
uplevel #2 set y 222
|
||||
uplevel 2 set x 333
|
||||
uplevel #1 set y 444
|
||||
uplevel 3 set x 555
|
||||
uplevel #0 set y 666
|
||||
}
|
||||
a1
|
||||
test uplevel-2.1 {relative and absolute uplevel} {set a} 333
|
||||
test uplevel-2.2 {relative and absolute uplevel} {set a1} 444
|
||||
test uplevel-2.3 {relative and absolute uplevel} {set b} 111
|
||||
test uplevel-2.4 {relative and absolute uplevel} {set b1} 222
|
||||
test uplevel-2.5 {relative and absolute uplevel} {set x} 555
|
||||
test uplevel-2.6 {relative and absolute uplevel} {set y} 666
|
||||
|
||||
test uplevel-3.1 {uplevel to same level} {
|
||||
set x 33
|
||||
uplevel #0 set x 44
|
||||
set x
|
||||
} 44
|
||||
test uplevel-3.2 {uplevel to same level} {
|
||||
set x 33
|
||||
uplevel 0 set x
|
||||
} 33
|
||||
test uplevel-3.3 {uplevel to same level} {
|
||||
set y xxx
|
||||
proc a1 {} {set y 55; uplevel 0 set y 66; return $y}
|
||||
a1
|
||||
} 66
|
||||
test uplevel-3.4 {uplevel to same level} {
|
||||
set y zzz
|
||||
proc a1 {} {set y 55; uplevel #1 set y}
|
||||
a1
|
||||
} 55
|
||||
|
||||
test uplevel-4.1 {error: non-existent level} {
|
||||
list [catch c1 msg] $msg
|
||||
} {1 {bad level "#2"}}
|
||||
test uplevel-4.2 {error: non-existent level} {
|
||||
proc c2 {} {uplevel 3 {set a b}}
|
||||
list [catch c2 msg] $msg
|
||||
} {1 {bad level "3"}}
|
||||
test uplevel-4.3 {error: not enough args} {
|
||||
list [catch uplevel msg] $msg
|
||||
} {1 {wrong # args: should be "uplevel ?level? command ?arg ...?"}}
|
||||
test uplevel-4.4 {error: not enough args} {
|
||||
proc upBug {} {uplevel 1}
|
||||
list [catch upBug msg] $msg
|
||||
} {1 {wrong # args: should be "uplevel ?level? command ?arg ...?"}}
|
||||
|
||||
proc a2 {} {
|
||||
uplevel a3
|
||||
}
|
||||
proc a3 {} {
|
||||
global x y
|
||||
set x [info level]
|
||||
set y [info level 1]
|
||||
}
|
||||
a2
|
||||
test uplevel-5.1 {info level} {set x} 1
|
||||
test uplevel-5.2 {info level} {set y} a3
|
||||
303
tcl7.3/tests/upvar.test
Normal file
303
tcl7.3/tests/upvar.test
Normal file
@@ -0,0 +1,303 @@
|
||||
# Commands covered: upvar
|
||||
#
|
||||
# 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.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/upvar.test,v 1.4 93/07/17 14:38:10 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
test upvar-1.1 {reading variables with upvar} {
|
||||
proc p1 {a b} {set c 22; set d 33; p2}
|
||||
proc p2 {} {upvar a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a}
|
||||
p1 foo bar
|
||||
} {foo bar 22 33 abc}
|
||||
test upvar-1.2 {reading variables with upvar} {
|
||||
proc p1 {a b} {set c 22; set d 33; p2}
|
||||
proc p2 {} {p3}
|
||||
proc p3 {} {upvar 2 a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a}
|
||||
p1 foo bar
|
||||
} {foo bar 22 33 abc}
|
||||
test upvar-1.3 {reading variables with upvar} {
|
||||
proc p1 {a b} {set c 22; set d 33; p2}
|
||||
proc p2 {} {p3}
|
||||
proc p3 {} {
|
||||
upvar #1 a x1 b x2 c x3 d x4
|
||||
set a abc
|
||||
list $x1 $x2 $x3 $x4 $a
|
||||
}
|
||||
p1 foo bar
|
||||
} {foo bar 22 33 abc}
|
||||
test upvar-1.4 {reading variables with upvar} {
|
||||
set x1 44
|
||||
set x2 55
|
||||
proc p1 {} {p2}
|
||||
proc p2 {} {
|
||||
upvar 2 x1 x1 x2 a
|
||||
upvar #0 x1 b
|
||||
set c $b
|
||||
incr b 3
|
||||
list $x1 $a $b
|
||||
}
|
||||
p1
|
||||
} {47 55 47}
|
||||
test upvar-1.4 {reading array elements with upvar} {
|
||||
proc p1 {} {set a(0) zeroth; set a(1) first; p2}
|
||||
proc p2 {} {upvar a(0) x; set x}
|
||||
p1
|
||||
} {zeroth}
|
||||
|
||||
test upvar-2.1 {writing variables with upvar} {
|
||||
proc p1 {a b} {set c 22; set d 33; p2; list $a $b $c $d}
|
||||
proc p2 {} {
|
||||
upvar a x1 b x2 c x3 d x4
|
||||
set x1 14
|
||||
set x4 88
|
||||
}
|
||||
p1 foo bar
|
||||
} {14 bar 22 88}
|
||||
test upvar-2.2 {writing variables with upvar} {
|
||||
set x1 44
|
||||
set x2 55
|
||||
proc p1 {x1 x2} {
|
||||
upvar #0 x1 a
|
||||
upvar x2 b
|
||||
set a $x1
|
||||
set b $x2
|
||||
}
|
||||
p1 newbits morebits
|
||||
list $x1 $x2
|
||||
} {newbits morebits}
|
||||
test upvar-2.3 {writing variables with upvar} {
|
||||
catch {unset x1}
|
||||
catch {unset x2}
|
||||
proc p1 {x1 x2} {
|
||||
upvar #0 x1 a
|
||||
upvar x2 b
|
||||
set a $x1
|
||||
set b $x2
|
||||
}
|
||||
p1 newbits morebits
|
||||
list [catch {set x1} msg] $msg [catch {set x2} msg] $msg
|
||||
} {0 newbits 0 morebits}
|
||||
test upvar-2.4 {writing array elements with upvar} {
|
||||
proc p1 {} {set a(0) zeroth; set a(1) first; list [p2] $a(0)}
|
||||
proc p2 {} {upvar a(0) x; set x xyzzy}
|
||||
p1
|
||||
} {xyzzy xyzzy}
|
||||
|
||||
test upvar-3.1 {unsetting variables with upvar} {
|
||||
proc p1 {a b} {set c 22; set d 33; p2; lsort [info vars]}
|
||||
proc p2 {} {
|
||||
upvar 1 a x1 d x2
|
||||
unset x1 x2
|
||||
}
|
||||
p1 foo bar
|
||||
} {b c}
|
||||
test upvar-3.2 {unsetting variables with upvar} {
|
||||
proc p1 {a b} {set c 22; set d 33; p2; lsort [info vars]}
|
||||
proc p2 {} {
|
||||
upvar 1 a x1 d x2
|
||||
unset x1 x2
|
||||
set x2 28
|
||||
}
|
||||
p1 foo bar
|
||||
} {b c d}
|
||||
test upvar-3.3 {unsetting variables with upvar} {
|
||||
set x1 44
|
||||
set x2 55
|
||||
proc p1 {} {p2}
|
||||
proc p2 {} {
|
||||
upvar 2 x1 a
|
||||
upvar #0 x2 b
|
||||
unset a b
|
||||
}
|
||||
p1
|
||||
list [info exists x1] [info exists x2]
|
||||
} {0 0}
|
||||
test upvar-3.4 {unsetting variables with upvar} {
|
||||
set x1 44
|
||||
set x2 55
|
||||
proc p1 {} {
|
||||
upvar x1 a x2 b
|
||||
unset a b
|
||||
set b 118
|
||||
}
|
||||
p1
|
||||
list [info exists x1] [catch {set x2} msg] $msg
|
||||
} {0 0 118}
|
||||
test upvar-3.5 {unsetting array elements with upvar} {
|
||||
proc p1 {} {
|
||||
set a(0) zeroth
|
||||
set a(1) first
|
||||
set a(2) second
|
||||
p2
|
||||
array names a
|
||||
}
|
||||
proc p2 {} {upvar a(0) x; unset x}
|
||||
p1
|
||||
} {1 2}
|
||||
test upvar-3.6 {unsetting then resetting array elements with upvar} {
|
||||
proc p1 {} {
|
||||
set a(0) zeroth
|
||||
set a(1) first
|
||||
set a(2) second
|
||||
p2
|
||||
list [array names a] [catch {set a(0)} msg] $msg
|
||||
}
|
||||
proc p2 {} {upvar a(0) x; unset x; set x 12345}
|
||||
p1
|
||||
} {{0 1 2} 0 12345}
|
||||
|
||||
test upvar-4.1 {nested upvars} {
|
||||
set x1 88
|
||||
proc p1 {a b} {set c 22; set d 33; p2}
|
||||
proc p2 {} {global x1; upvar c x2; p3}
|
||||
proc p3 {} {
|
||||
upvar x1 a x2 b
|
||||
list $a $b
|
||||
}
|
||||
p1 14 15
|
||||
} {88 22}
|
||||
test upvar-4.2 {nested upvars} {
|
||||
set x1 88
|
||||
proc p1 {a b} {set c 22; set d 33; p2; list $a $b $c $d}
|
||||
proc p2 {} {global x1; upvar c x2; p3}
|
||||
proc p3 {} {
|
||||
upvar x1 a x2 b
|
||||
set a foo
|
||||
set b bar
|
||||
}
|
||||
list [p1 14 15] $x1
|
||||
} {{14 15 bar 33} foo}
|
||||
|
||||
proc tproc {args} {global x; set x [list $args [uplevel info vars]]}
|
||||
test upvar-5.1 {traces involving upvars} {
|
||||
proc p1 {a b} {set c 22; set d 33; trace var c rw tproc; p2}
|
||||
proc p2 {} {upvar c x1; set x1 22}
|
||||
set x ---
|
||||
p1 foo bar
|
||||
set x
|
||||
} {{x1 {} w} x1}
|
||||
test upvar-5.2 {traces involving upvars} {
|
||||
proc p1 {a b} {set c 22; set d 33; trace var c rw tproc; p2}
|
||||
proc p2 {} {upvar c x1; set x1}
|
||||
set x ---
|
||||
p1 foo bar
|
||||
set x
|
||||
} {{x1 {} r} x1}
|
||||
test upvar-5.3 {traces involving upvars} {
|
||||
proc p1 {a b} {set c 22; set d 33; trace var c rwu tproc; p2}
|
||||
proc p2 {} {upvar c x1; unset x1}
|
||||
set x ---
|
||||
p1 foo bar
|
||||
set x
|
||||
} {{x1 {} u} x1}
|
||||
|
||||
test upvar-6.1 {retargeting an upvar} {
|
||||
proc p1 {} {
|
||||
set a(0) zeroth
|
||||
set a(1) first
|
||||
set a(2) second
|
||||
p2
|
||||
}
|
||||
proc p2 {} {
|
||||
upvar a x
|
||||
set result {}
|
||||
foreach i [array names x] {
|
||||
upvar a($i) x
|
||||
lappend result $x
|
||||
}
|
||||
lsort $result
|
||||
}
|
||||
p1
|
||||
} {first second zeroth}
|
||||
test upvar-6.2 {retargeting an upvar} {
|
||||
set x 44
|
||||
set y abcde
|
||||
proc p1 {} {
|
||||
global x
|
||||
set result $x
|
||||
upvar y x
|
||||
lappend result $x
|
||||
}
|
||||
p1
|
||||
} {44 abcde}
|
||||
test upvar-6.3 {retargeting an upvar} {
|
||||
set x 44
|
||||
set y abcde
|
||||
proc p1 {} {
|
||||
upvar y x
|
||||
lappend result $x
|
||||
global x
|
||||
lappend result $x
|
||||
}
|
||||
p1
|
||||
} {abcde 44}
|
||||
|
||||
test upvar-7.1 {upvar to same level} {
|
||||
set x 44
|
||||
set y 55
|
||||
catch {unset uv}
|
||||
upvar #0 x uv
|
||||
set uv abc
|
||||
upvar 0 y uv
|
||||
set uv xyzzy
|
||||
list $x $y
|
||||
} {abc xyzzy}
|
||||
test upvar-7.2 {upvar to same level} {
|
||||
set x 1234
|
||||
set y 4567
|
||||
proc p1 {x y} {
|
||||
upvar 0 x uv
|
||||
set uv $y
|
||||
return "$x $y"
|
||||
}
|
||||
p1 44 89
|
||||
} {89 89}
|
||||
test upvar-7.3 {upvar to same level} {
|
||||
set x 1234
|
||||
set y 4567
|
||||
proc p1 {x y} {
|
||||
upvar #1 x uv
|
||||
set uv $y
|
||||
return "$x $y"
|
||||
}
|
||||
p1 xyz abc
|
||||
} {abc abc}
|
||||
|
||||
test upvar-8.1 {errors in upvar command} {
|
||||
list [catch upvar msg] $msg
|
||||
} {1 {wrong # args: should be "upvar ?level? otherVar localVar ?otherVar localVar ...?"}}
|
||||
test upvar-8.2 {errors in upvar command} {
|
||||
list [catch {upvar 1} msg] $msg
|
||||
} {1 {wrong # args: should be "upvar ?level? otherVar localVar ?otherVar localVar ...?"}}
|
||||
test upvar-8.3 {errors in upvar command} {
|
||||
proc p1 {} {upvar a b c}
|
||||
list [catch p1 msg] $msg
|
||||
} {1 {wrong # args: should be "upvar ?level? otherVar localVar ?otherVar localVar ...?"}}
|
||||
test upvar-8.4 {errors in upvar command} {
|
||||
proc p1 {} {set a 33; upvar b a}
|
||||
list [catch p1 msg] $msg
|
||||
} {1 {variable "a" already exists}}
|
||||
113
tcl7.3/tests/while.test
Normal file
113
tcl7.3/tests/while.test
Normal file
@@ -0,0 +1,113 @@
|
||||
# Commands covered: while
|
||||
#
|
||||
# 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.
|
||||
# All rights reserved.
|
||||
#
|
||||
# Permission is hereby granted, without written agreement and without
|
||||
# license or royalty fees, to use, copy, modify, and distribute this
|
||||
# software and its documentation for any purpose, provided that the
|
||||
# above copyright notice and the following two paragraphs appear in
|
||||
# all copies of this software.
|
||||
#
|
||||
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||||
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||||
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||||
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
#
|
||||
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||||
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
#
|
||||
# $Header: /user6/ouster/tcl/tests/RCS/while.test,v 1.7 93/04/21 11:18:58 ouster Exp $ (Berkeley)
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source defs}
|
||||
|
||||
test while-1.1 {basic while loops} {
|
||||
set count 0
|
||||
while {$count < 10} {set count [expr $count+1]}
|
||||
set count
|
||||
} 10
|
||||
test while-1.2 {basic while loops} {
|
||||
set value xxx
|
||||
while {2 > 3} {set value yyy}
|
||||
set value
|
||||
} xxx
|
||||
test while-1.3 {basic while loops} {
|
||||
set value 1
|
||||
while {"true"} {
|
||||
incr value;
|
||||
if {$value > 5} {
|
||||
break;
|
||||
}
|
||||
}
|
||||
set value
|
||||
} 6
|
||||
|
||||
test while-2.1 {continue in while loop} {
|
||||
set list {1 2 3 4 5}
|
||||
set index 0
|
||||
set result {}
|
||||
while {$index < 5} {
|
||||
if {$index == 2} {set index [expr $index+1]; continue}
|
||||
set result [concat $result [lindex $list $index]]
|
||||
set index [expr $index+1]
|
||||
}
|
||||
set result
|
||||
} {1 2 4 5}
|
||||
|
||||
test while-3.1 {break in while loop} {
|
||||
set list {1 2 3 4 5}
|
||||
set index 0
|
||||
set result {}
|
||||
while {$index < 5} {
|
||||
if {$index == 3} break
|
||||
set result [concat $result [lindex $list $index]]
|
||||
set index [expr $index+1]
|
||||
}
|
||||
set result
|
||||
} {1 2 3}
|
||||
|
||||
test while-4.1 {errors in while loops} {
|
||||
set err [catch {while} msg]
|
||||
list $err $msg
|
||||
} {1 {wrong # args: should be "while test command"}}
|
||||
test while-4.2 {errors in while loops} {
|
||||
set err [catch {while 1} msg]
|
||||
list $err $msg
|
||||
} {1 {wrong # args: should be "while test command"}}
|
||||
test while-4.3 {errors in while loops} {
|
||||
set err [catch {while 1 2 3} msg]
|
||||
list $err $msg
|
||||
} {1 {wrong # args: should be "while test command"}}
|
||||
test while-4.4 {errors in while loops} {
|
||||
set err [catch {while {"a"+"b"} {error "loop aborted"}} msg]
|
||||
list $err $msg
|
||||
} {1 {can't use non-numeric string as operand of "+"}}
|
||||
test while-4.5 {errors in while loops} {
|
||||
set x 1
|
||||
set err [catch {while {$x} {set x foo}} msg]
|
||||
list $err $msg
|
||||
} {1 {expected boolean value but got "foo"}}
|
||||
test while-4.6 {errors in while loops} {
|
||||
set err [catch {while {1} {error "loop aborted"}} msg]
|
||||
list $err $msg $errorInfo
|
||||
} {1 {loop aborted} {loop aborted
|
||||
while executing
|
||||
"error "loop aborted""
|
||||
("while" body line 1)
|
||||
invoked from within
|
||||
"while {1} {error "loop aborted"}"}}
|
||||
|
||||
test while-5.1 {while return result} {
|
||||
while {0} {set a 400}
|
||||
} {}
|
||||
test while-5.2 {while return result} {
|
||||
set x 1
|
||||
while {$x} {set x 0}
|
||||
} {}
|
||||
Reference in New Issue
Block a user