Import Tcl 8.5.15 (as of svn r89086)
This commit is contained in:
Zachary Ware
107
tests/README
Normal file
107
tests/README
Normal file
@@ -0,0 +1,107 @@
|
||||
README -- Tcl test suite design document.
|
||||
|
||||
Contents:
|
||||
---------
|
||||
|
||||
1. Introduction
|
||||
2. Running tests
|
||||
3. Adding tests
|
||||
4. Incompatibilities with prior Tcl versions
|
||||
|
||||
1. Introduction:
|
||||
----------------
|
||||
|
||||
This directory contains a set of validation tests for the Tcl commands
|
||||
and C Library procedures for Tcl. Each of the files whose name ends
|
||||
in ".test" is intended to fully exercise the functions in the C source
|
||||
file that corresponds to the file prefix. The C functions and/or Tcl
|
||||
commands tested by a given file are listed in the first line of the
|
||||
file.
|
||||
|
||||
2. Running tests:
|
||||
-----------------
|
||||
|
||||
We recommend that you use the "test" target of Tcl's Makefile to run
|
||||
the test suite. From the directory in which you build Tcl, simply
|
||||
type "make test". This will create a special executable named
|
||||
tcltest in which the testing scripts will be evaluated. To create
|
||||
the tcltest executable without running the test suite, simple type
|
||||
"make tcltest".
|
||||
|
||||
All the configuration options of the tcltest package are available
|
||||
during a "make test" by defining the TESTFLAGS environment variable.
|
||||
For example,if you wish to run only those tests in the file append.test,
|
||||
you can type:
|
||||
|
||||
make test TESTFLAGS="-file append.test"
|
||||
|
||||
For interactive testing, the Tcl Makefile provides the "runtest" target.
|
||||
Type "make runtest" in your build directory, and the tcltest executable
|
||||
will be created, if necessary, then it will run interactively. At the
|
||||
command prompt, you may type any Tcl commands. If you type
|
||||
"source ../tests/all.tcl", the test suite will run. You may use the
|
||||
tcltest::configure command to configure the test suite run as an
|
||||
alternative to command line options via TESTFLAGS. You might also
|
||||
wish to use the tcltest::testConstraint command to select the constraints
|
||||
that govern which tests are run. See the documentation for the tcltest
|
||||
package for details.
|
||||
|
||||
3. Adding tests:
|
||||
----------------
|
||||
|
||||
Please see the tcltest man page for more information regarding how to
|
||||
write and run tests.
|
||||
|
||||
Please note that the all.tcl file will source your new test file if
|
||||
the filename matches the tests/*.test pattern (as it should). The
|
||||
names of test files that contain regression (or glass-box) tests
|
||||
should correspond to the Tcl or C code file that they are testing.
|
||||
For example, the test file for the C file "tclCmdAH.c" is
|
||||
"cmdAH.test". Test files that contain black-box tests may not
|
||||
correspond to any Tcl or C code file so they should match the pattern
|
||||
"*_bb.test".
|
||||
|
||||
Be sure your new test file can be run from any working directory.
|
||||
|
||||
Be sure no temporary files are left behind by your test file.
|
||||
Use [tcltest::makeFile], [tcltest::removeFile], and [tcltest::cleanupTests]
|
||||
properly to be sure of this.
|
||||
|
||||
Be sure your tests can run cross-platform in both a build environment
|
||||
as well as an installation environment. If your test file contains
|
||||
tests that should not be run in one or more of those cases, please use
|
||||
the constraints mechanism to skip those tests.
|
||||
|
||||
4. Incompatibilities of package tcltest 2.1 with
|
||||
testing machinery of very old versions of Tcl:
|
||||
------------------------------------------------
|
||||
|
||||
1) Global variables such as VERBOSE, TESTS, and testConfig of the
|
||||
old machinery correspond to the [configure -verbose],
|
||||
[configure -match], and [testConstraint] commands of tcltest 2.1,
|
||||
respectively.
|
||||
|
||||
2) VERBOSE values were longer numeric. [configure -verbose] values
|
||||
are lists of keywords.
|
||||
|
||||
3) When you run "make test", the working dir for the test suite is now
|
||||
the one from which you called "make test", rather than the "tests"
|
||||
directory. This change allows for both unix and windows test
|
||||
suites to be run simultaneously without interference with each
|
||||
other or with existing files. All tests must now run independently
|
||||
of their working directory.
|
||||
|
||||
4) The "all" file is now called "all.tcl"
|
||||
|
||||
5) The "defs" and "defs.tcl" files no longer exist.
|
||||
|
||||
6) Instead of creating a doAllTests file in the tests directory, to
|
||||
run all nonPortable tests, just use the "-constraints nonPortable"
|
||||
command line flag. If you are running interactively, you can run
|
||||
[tcltest::testConstraint nonPortable 1] (after loading the tcltest
|
||||
package).
|
||||
|
||||
7) Direct evaluation of the *.test files by the "source" command is no
|
||||
longer recommended. Instead, "source all.tcl" and use the "-file" and
|
||||
"-notfile" options of tcltest::configure to control which *.test files
|
||||
are evaluated.
|
||||
17
tests/all.tcl
Normal file
17
tests/all.tcl
Normal file
@@ -0,0 +1,17 @@
|
||||
# all.tcl --
|
||||
#
|
||||
# This file contains a top-level script to run all of the Tcl
|
||||
# tests. Execute it by invoking "source all.test" when running tcltest
|
||||
# in this directory.
|
||||
#
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
# Copyright (c) 2000 by Ajuba Solutions
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
package require Tcl 8.5
|
||||
package require tcltest 2.2
|
||||
namespace import tcltest::*
|
||||
configure {*}$argv -testdir [file dir [info script]]
|
||||
runAllTests
|
||||
289
tests/append.test
Normal file
289
tests/append.test
Normal file
@@ -0,0 +1,289 @@
|
||||
# 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.
|
||||
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
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-1.3 {append command} {
|
||||
set x "abcd"
|
||||
append x
|
||||
} abcd
|
||||
|
||||
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} {
|
||||
set x ""
|
||||
list [catch {append x(0) 44} msg] $msg
|
||||
} {1 {can't set "x(0)": variable isn't array}}
|
||||
test append-3.3 {append errors} {
|
||||
catch {unset x}
|
||||
list [catch {append x} msg] $msg
|
||||
} {1 {can't read "x": no such variable}}
|
||||
|
||||
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.4 {lappend command} {
|
||||
set x {}
|
||||
lappend x \{\ abc
|
||||
} {\{\ abc}
|
||||
test append-4.5 {lappend command} {
|
||||
set x {}
|
||||
lappend x \{ abc
|
||||
} {\{ abc}
|
||||
test append-4.6 {lappend command} {
|
||||
set x {1 2 3}
|
||||
lappend x
|
||||
} {1 2 3}
|
||||
test append-4.7 {lappend command} {
|
||||
set x "a\{"
|
||||
lappend x abc
|
||||
} "a\\\{ abc"
|
||||
test append-4.8 {lappend command} {
|
||||
set x "\\\{"
|
||||
lappend x abc
|
||||
} "\\{ abc"
|
||||
test append-4.9 {lappend command} {
|
||||
set x " \{"
|
||||
list [catch {lappend x abc} msg] $msg
|
||||
} {1 {unmatched open brace in list}}
|
||||
test append-4.10 {lappend command} {
|
||||
set x " \{"
|
||||
list [catch {lappend x abc} msg] $msg
|
||||
} {1 {unmatched open brace in list}}
|
||||
test append-4.11 {lappend command} {
|
||||
set x "\{\{\{"
|
||||
list [catch {lappend x abc} msg] $msg
|
||||
} {1 {unmatched open brace in list}}
|
||||
test append-4.12 {lappend command} {
|
||||
set x "x \{\{\{"
|
||||
list [catch {lappend x abc} msg] $msg
|
||||
} {1 {unmatched open brace in list}}
|
||||
test append-4.13 {lappend command} {
|
||||
set x "x\{\{\{"
|
||||
lappend x abc
|
||||
} "x\\\{\\\{\\\{ abc"
|
||||
test append-4.14 {lappend command} {
|
||||
set x " "
|
||||
lappend x abc
|
||||
} "abc"
|
||||
test append-4.15 {lappend command} {
|
||||
set x "\\ "
|
||||
lappend x abc
|
||||
} "{ } abc"
|
||||
test append-4.16 {lappend command} {
|
||||
set x "x "
|
||||
lappend x abc
|
||||
} "x abc"
|
||||
test append-4.17 {lappend command} {
|
||||
catch {unset x}
|
||||
lappend x
|
||||
} {}
|
||||
test append-4.18 {lappend command} {
|
||||
catch {unset x}
|
||||
lappend x {}
|
||||
} {{}}
|
||||
test append-4.19 {lappend command} {
|
||||
catch {unset x}
|
||||
lappend x(0)
|
||||
} {}
|
||||
test append-4.20 {lappend command} {
|
||||
catch {unset x}
|
||||
lappend x(0) abc
|
||||
} {abc}
|
||||
unset -nocomplain x
|
||||
test append-4.21 {lappend command} {
|
||||
set x \"
|
||||
list [catch {lappend x} msg] $msg
|
||||
} {1 {unmatched open quote in list}}
|
||||
test append-4.22 {lappend command} {
|
||||
set x \"
|
||||
list [catch {lappend x abc} msg] $msg
|
||||
} {1 {unmatched open quote in list}}
|
||||
|
||||
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} {
|
||||
catch {unset x}
|
||||
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} {
|
||||
set x ""
|
||||
list [catch {lappend x(0) 44} msg] $msg
|
||||
} {1 {can't set "x(0)": variable isn't array}}
|
||||
|
||||
test append-7.1 {lappend-created var and error in trace on that var} {
|
||||
catch {rename foo ""}
|
||||
catch {unset x}
|
||||
trace variable x w foo
|
||||
proc foo {} {global x; unset x}
|
||||
catch {lappend x 1}
|
||||
proc foo {args} {global x; unset x}
|
||||
info exists x
|
||||
set x
|
||||
lappend x 1
|
||||
list [info exists x] [catch {set x} msg] $msg
|
||||
} {0 1 {can't read "x": no such variable}}
|
||||
test append-7.2 {lappend var triggers read trace} {
|
||||
catch {unset myvar}
|
||||
catch {unset ::result}
|
||||
trace variable myvar r foo
|
||||
proc foo {args} {append ::result $args}
|
||||
lappend myvar a
|
||||
list [catch {set ::result} msg] $msg
|
||||
} {0 {myvar {} r}}
|
||||
test append-7.3 {lappend var triggers read trace, array var} {
|
||||
# The behavior of read triggers on lappend changed in 8.0 to
|
||||
# not trigger them, and was changed back in 8.4.
|
||||
catch {unset myvar}
|
||||
catch {unset ::result}
|
||||
trace variable myvar r foo
|
||||
proc foo {args} {append ::result $args}
|
||||
lappend myvar(b) a
|
||||
list [catch {set ::result} msg] $msg
|
||||
} {0 {myvar b r}}
|
||||
test append-7.4 {lappend var triggers read trace, array var exists} {
|
||||
catch {unset myvar}
|
||||
catch {unset ::result}
|
||||
set myvar(0) 1
|
||||
trace variable myvar r foo
|
||||
proc foo {args} {append ::result $args}
|
||||
lappend myvar(b) a
|
||||
list [catch {set ::result} msg] $msg
|
||||
} {0 {myvar b r}}
|
||||
test append-7.5 {append var does not trigger read trace} {
|
||||
catch {unset myvar}
|
||||
catch {unset ::result}
|
||||
trace variable myvar r foo
|
||||
proc foo {args} {append ::result $args}
|
||||
append myvar a
|
||||
info exists ::result
|
||||
} {0}
|
||||
|
||||
# New tests for bug 3057639 to show off the more consistent behaviour
|
||||
# of lappend in both direct-eval and bytecompiled code paths (see
|
||||
# appendComp.test for the compiled variants). lappend now behaves like
|
||||
# append. 9.0/1 lappend - 9.2/3 append
|
||||
|
||||
test append-9.0 {bug 3057639, lappend direct eval, read trace on non-existing array variable element} {
|
||||
catch {unset myvar}
|
||||
array set myvar {}
|
||||
proc nonull {var key val} {
|
||||
upvar 1 $var lvar
|
||||
if {![info exists lvar($key)]} {
|
||||
return -code error "no such variable"
|
||||
}
|
||||
}
|
||||
trace add variable myvar read nonull
|
||||
list [catch {
|
||||
lappend myvar(key) "new value"
|
||||
} msg] $msg
|
||||
} {0 {{new value}}}
|
||||
|
||||
test append-9.1 {bug 3057639, lappend direct eval, read trace on non-existing env element} {
|
||||
catch {unset ::env(__DUMMY__)}
|
||||
list [catch {
|
||||
lappend ::env(__DUMMY__) "new value"
|
||||
} msg] $msg
|
||||
} {0 {{new value}}}
|
||||
|
||||
test append-9.2 {bug 3057639, append direct eval, read trace on non-existing array variable element} {
|
||||
catch {unset myvar}
|
||||
array set myvar {}
|
||||
proc nonull {var key val} {
|
||||
upvar 1 $var lvar
|
||||
if {![info exists lvar($key)]} {
|
||||
return -code error "no such variable"
|
||||
}
|
||||
}
|
||||
trace add variable myvar read nonull
|
||||
list [catch {
|
||||
append myvar(key) "new value"
|
||||
} msg] $msg
|
||||
} {0 {new value}}
|
||||
|
||||
test append-9.3 {bug 3057639, append direct eval, read trace on non-existing env element} {
|
||||
catch {unset ::env(__DUMMY__)}
|
||||
list [catch {
|
||||
append ::env(__DUMMY__) "new value"
|
||||
} msg] $msg
|
||||
} {0 {new value}}
|
||||
|
||||
|
||||
|
||||
catch {unset i x result y}
|
||||
catch {rename foo ""}
|
||||
catch {rename check ""}
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
446
tests/appendComp.test
Normal file
446
tests/appendComp.test
Normal file
@@ -0,0 +1,446 @@
|
||||
# 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.
|
||||
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest 2
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
catch {unset x}
|
||||
|
||||
test appendComp-1.1 {append command} {
|
||||
catch {unset x}
|
||||
proc foo {} {append ::x 1 2 abc "long string"}
|
||||
list [foo] $x
|
||||
} {{12abclong string} {12abclong string}}
|
||||
test appendComp-1.2 {append command} {
|
||||
proc foo {} {
|
||||
set x ""
|
||||
list [append x first] [append x second] [append x third] $x
|
||||
}
|
||||
foo
|
||||
} {first firstsecond firstsecondthird firstsecondthird}
|
||||
test appendComp-1.3 {append command} {
|
||||
proc foo {} {
|
||||
set x "abcd"
|
||||
append x
|
||||
}
|
||||
foo
|
||||
} abcd
|
||||
|
||||
test appendComp-2.1 {long appends} {
|
||||
proc foo {} {
|
||||
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}
|
||||
}
|
||||
foo
|
||||
} 1
|
||||
|
||||
test appendComp-3.1 {append errors} {
|
||||
proc foo {} {append}
|
||||
list [catch {foo} msg] $msg
|
||||
} {1 {wrong # args: should be "append varName ?value value ...?"}}
|
||||
test appendComp-3.2 {append errors} {
|
||||
proc foo {} {
|
||||
set x ""
|
||||
append x(0) 44
|
||||
}
|
||||
list [catch {foo} msg] $msg
|
||||
} {1 {can't set "x(0)": variable isn't array}}
|
||||
test appendComp-3.3 {append errors} {
|
||||
proc foo {} {
|
||||
catch {unset x}
|
||||
append x
|
||||
}
|
||||
list [catch {foo} msg] $msg
|
||||
} {1 {can't read "x": no such variable}}
|
||||
|
||||
test appendComp-4.1 {lappend command} {
|
||||
proc foo {} {
|
||||
global x
|
||||
catch {unset x}
|
||||
lappend x 1 2 abc "long string"
|
||||
}
|
||||
list [foo] $x
|
||||
} {{1 2 abc {long string}} {1 2 abc {long string}}}
|
||||
test appendComp-4.2 {lappend command} {
|
||||
proc foo {} {
|
||||
set x ""
|
||||
list [lappend x first] [lappend x second] [lappend x third] $x
|
||||
}
|
||||
foo
|
||||
} {first {first second} {first second third} {first second third}}
|
||||
test appendComp-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 appendComp-4.4 {lappend command} {
|
||||
proc foo {} {
|
||||
set x {}
|
||||
lappend x \{\ abc
|
||||
}
|
||||
foo
|
||||
} {\{\ abc}
|
||||
test appendComp-4.5 {lappend command} {
|
||||
proc foo {} {
|
||||
set x {}
|
||||
lappend x \{ abc
|
||||
}
|
||||
foo
|
||||
} {\{ abc}
|
||||
test appendComp-4.6 {lappend command} {
|
||||
proc foo {} {
|
||||
set x {1 2 3}
|
||||
lappend x
|
||||
}
|
||||
foo
|
||||
} {1 2 3}
|
||||
test appendComp-4.7 {lappend command} {
|
||||
proc foo {} {
|
||||
set x "a\{"
|
||||
lappend x abc
|
||||
}
|
||||
foo
|
||||
} "a\\\{ abc"
|
||||
test appendComp-4.8 {lappend command} {
|
||||
proc foo {} {
|
||||
set x "\\\{"
|
||||
lappend x abc
|
||||
}
|
||||
foo
|
||||
} "\\{ abc"
|
||||
test appendComp-4.9 {lappend command} {
|
||||
proc foo {} {
|
||||
set x " \{"
|
||||
list [catch {lappend x abc} msg] $msg
|
||||
}
|
||||
foo
|
||||
} {1 {unmatched open brace in list}}
|
||||
test appendComp-4.10 {lappend command} {
|
||||
proc foo {} {
|
||||
set x " \{"
|
||||
list [catch {lappend x abc} msg] $msg
|
||||
}
|
||||
foo
|
||||
} {1 {unmatched open brace in list}}
|
||||
test appendComp-4.11 {lappend command} {
|
||||
proc foo {} {
|
||||
set x "\{\{\{"
|
||||
list [catch {lappend x abc} msg] $msg
|
||||
}
|
||||
foo
|
||||
} {1 {unmatched open brace in list}}
|
||||
test appendComp-4.12 {lappend command} {
|
||||
proc foo {} {
|
||||
set x "x \{\{\{"
|
||||
list [catch {lappend x abc} msg] $msg
|
||||
}
|
||||
foo
|
||||
} {1 {unmatched open brace in list}}
|
||||
test appendComp-4.13 {lappend command} {
|
||||
proc foo {} {
|
||||
set x "x\{\{\{"
|
||||
lappend x abc
|
||||
}
|
||||
foo
|
||||
} "x\\\{\\\{\\\{ abc"
|
||||
test appendComp-4.14 {lappend command} {
|
||||
proc foo {} {
|
||||
set x " "
|
||||
lappend x abc
|
||||
}
|
||||
foo
|
||||
} "abc"
|
||||
test appendComp-4.15 {lappend command} {
|
||||
proc foo {} {
|
||||
set x "\\ "
|
||||
lappend x abc
|
||||
}
|
||||
foo
|
||||
} "{ } abc"
|
||||
test appendComp-4.16 {lappend command} {
|
||||
proc foo {} {
|
||||
set x "x "
|
||||
lappend x abc
|
||||
}
|
||||
foo
|
||||
} "x abc"
|
||||
test appendComp-4.17 {lappend command} {
|
||||
proc foo {} { lappend x }
|
||||
foo
|
||||
} {}
|
||||
test appendComp-4.18 {lappend command} {
|
||||
proc foo {} { lappend x {} }
|
||||
foo
|
||||
} {{}}
|
||||
test appendComp-4.19 {lappend command} {
|
||||
proc foo {} { lappend x(0) }
|
||||
foo
|
||||
} {}
|
||||
test appendComp-4.20 {lappend command} {
|
||||
proc foo {} { lappend x(0) abc }
|
||||
foo
|
||||
} {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 appendComp-5.1 {long lappends} {
|
||||
catch {unset x}
|
||||
set x ""
|
||||
for {set i 0} {$i < 300} {set i [expr $i+1]} {
|
||||
lappend x "item $i"
|
||||
}
|
||||
check $x 300
|
||||
} ok
|
||||
|
||||
test appendComp-6.1 {lappend errors} {
|
||||
proc foo {} {lappend}
|
||||
list [catch {foo} msg] $msg
|
||||
} {1 {wrong # args: should be "lappend varName ?value value ...?"}}
|
||||
test appendComp-6.2 {lappend errors} {
|
||||
proc foo {} {
|
||||
set x ""
|
||||
lappend x(0) 44
|
||||
}
|
||||
list [catch {foo} msg] $msg
|
||||
} {1 {can't set "x(0)": variable isn't array}}
|
||||
|
||||
test appendComp-7.1 {lappendComp-created var and error in trace on that var} {
|
||||
proc bar {} {
|
||||
global x
|
||||
catch {rename foo ""}
|
||||
catch {unset x}
|
||||
trace variable x w foo
|
||||
proc foo {} {global x; unset x}
|
||||
catch {lappend x 1}
|
||||
proc foo {args} {global x; unset x}
|
||||
info exists x
|
||||
set x
|
||||
lappend x 1
|
||||
list [info exists x] [catch {set x} msg] $msg
|
||||
}
|
||||
bar
|
||||
} {0 1 {can't read "x": no such variable}}
|
||||
test appendComp-7.2 {lappend var triggers read trace, index var} {bug-3057639} {
|
||||
proc bar {} {
|
||||
catch {unset myvar}
|
||||
catch {unset ::result}
|
||||
trace variable myvar r foo
|
||||
proc foo {args} {append ::result $args}
|
||||
lappend myvar a
|
||||
list [catch {set ::result} msg] $msg
|
||||
}
|
||||
bar
|
||||
} {0 {myvar {} r}}
|
||||
test appendComp-7.3 {lappend var triggers read trace, stack var} {bug-3057639} {
|
||||
proc bar {} {
|
||||
catch {unset ::myvar}
|
||||
catch {unset ::result}
|
||||
trace variable ::myvar r foo
|
||||
proc foo {args} {append ::result $args}
|
||||
lappend ::myvar a
|
||||
list [catch {set ::result} msg] $msg
|
||||
}
|
||||
bar
|
||||
} {0 {::myvar {} r}}
|
||||
test appendComp-7.4 {lappend var triggers read trace, array var} {bug-3057639} {
|
||||
# The behavior of read triggers on lappend changed in 8.0 to
|
||||
# not trigger them. Maybe not correct, but been there a while.
|
||||
proc bar {} {
|
||||
catch {unset myvar}
|
||||
catch {unset ::result}
|
||||
trace variable myvar r foo
|
||||
proc foo {args} {append ::result $args}
|
||||
lappend myvar(b) a
|
||||
list [catch {set ::result} msg] $msg
|
||||
}
|
||||
bar
|
||||
} {0 {myvar b r}}
|
||||
test appendComp-7.5 {lappend var triggers read trace, array var} {
|
||||
# The behavior of read triggers on lappend changed in 8.0 to
|
||||
# not trigger them. Maybe not correct, but been there a while.
|
||||
proc bar {} {
|
||||
catch {unset myvar}
|
||||
catch {unset ::result}
|
||||
trace variable myvar r foo
|
||||
proc foo {args} {append ::result $args}
|
||||
lappend myvar(b) a b
|
||||
list [catch {set ::result} msg] $msg
|
||||
}
|
||||
bar
|
||||
} {0 {myvar b r}}
|
||||
test appendComp-7.6 {lappend var triggers read trace, array var exists} {bug-3057639} {
|
||||
proc bar {} {
|
||||
catch {unset myvar}
|
||||
catch {unset ::result}
|
||||
set myvar(0) 1
|
||||
trace variable myvar r foo
|
||||
proc foo {args} {append ::result $args}
|
||||
lappend myvar(b) a
|
||||
list [catch {set ::result} msg] $msg
|
||||
}
|
||||
bar
|
||||
} {0 {myvar b r}}
|
||||
test appendComp-7.7 {lappend var triggers read trace, array stack var} {bug-3057639} {
|
||||
proc bar {} {
|
||||
catch {unset ::myvar}
|
||||
catch {unset ::result}
|
||||
trace variable ::myvar r foo
|
||||
proc foo {args} {append ::result $args}
|
||||
lappend ::myvar(b) a
|
||||
list [catch {set ::result} msg] $msg
|
||||
}
|
||||
bar
|
||||
} {0 {::myvar b r}}
|
||||
test appendComp-7.8 {lappend var triggers read trace, array stack var} {
|
||||
proc bar {} {
|
||||
catch {unset ::myvar}
|
||||
catch {unset ::result}
|
||||
trace variable ::myvar r foo
|
||||
proc foo {args} {append ::result $args}
|
||||
lappend ::myvar(b) a b
|
||||
list [catch {set ::result} msg] $msg
|
||||
}
|
||||
bar
|
||||
} {0 {::myvar b r}}
|
||||
test appendComp-7.9 {append var does not trigger read trace} {
|
||||
proc bar {} {
|
||||
catch {unset myvar}
|
||||
catch {unset ::result}
|
||||
trace variable myvar r foo
|
||||
proc foo {args} {append ::result $args}
|
||||
append myvar a
|
||||
info exists ::result
|
||||
}
|
||||
bar
|
||||
} {0}
|
||||
|
||||
test appendComp-8.1 {defer error to runtime} -setup {
|
||||
interp create slave
|
||||
} -body {
|
||||
slave eval {
|
||||
proc foo {} {
|
||||
proc append args {}
|
||||
append
|
||||
}
|
||||
foo
|
||||
}
|
||||
} -cleanup {
|
||||
interp delete slave
|
||||
} -result {}
|
||||
|
||||
|
||||
# New tests for bug 3057639 to show off the more consistent behaviour
|
||||
# of lappend in both direct-eval and bytecompiled code paths (see
|
||||
# append.test for the direct-eval variants). lappend now behaves like
|
||||
# append. 9.0/1 lappend - 9.2/3 append.
|
||||
|
||||
# Note also the tests above now constrained by bug-3057639, these
|
||||
# changed behaviour with the triggering of read traces in bc mode
|
||||
# gone.
|
||||
|
||||
# Going back to the tests below. The direct-eval tests are ok before
|
||||
# and after patch (no read traces run for lappend, append). The
|
||||
# compiled tests are failing for lappend (9.0/1) before the patch,
|
||||
# showing how it invokes read traces in the compiled path. The append
|
||||
# tests are good (9.2/3). After the patch the failues are gone.
|
||||
|
||||
test appendComp-9.0 {bug 3057639, lappend compiled, read trace on non-existing array variable element} {
|
||||
catch {unset myvar}
|
||||
array set myvar {}
|
||||
proc nonull {var key val} {
|
||||
upvar 1 $var lvar
|
||||
if {![info exists lvar($key)]} {
|
||||
return -code error "BOOM. no such variable"
|
||||
}
|
||||
}
|
||||
trace add variable myvar read nonull
|
||||
proc foo {} {
|
||||
lappend ::myvar(key) "new value"
|
||||
}
|
||||
list [catch { foo } msg] $msg
|
||||
} {0 {{new value}}}
|
||||
|
||||
|
||||
test appendComp-9.1 {bug 3057639, lappend direct eval, read trace on non-existing env element} {
|
||||
catch {unset ::env(__DUMMY__)}
|
||||
proc foo {} {
|
||||
lappend ::env(__DUMMY__) "new value"
|
||||
}
|
||||
list [catch { foo } msg] $msg
|
||||
} {0 {{new value}}}
|
||||
|
||||
|
||||
|
||||
test appendComp-9.2 {bug 3057639, append compiled, read trace on non-existing array variable element} {
|
||||
catch {unset myvar}
|
||||
array set myvar {}
|
||||
proc nonull {var key val} {
|
||||
upvar 1 $var lvar
|
||||
if {![info exists lvar($key)]} {
|
||||
return -code error "BOOM. no such variable"
|
||||
}
|
||||
}
|
||||
trace add variable myvar read nonull
|
||||
proc foo {} {
|
||||
append ::myvar(key) "new value"
|
||||
}
|
||||
list [catch { foo } msg] $msg
|
||||
} {0 {new value}}
|
||||
|
||||
|
||||
test appendComp-9.3 {bug 3057639, append direct eval, read trace on non-existing env element} {
|
||||
catch {unset ::env(__DUMMY__)}
|
||||
proc foo {} {
|
||||
append ::env(__DUMMY__) "new value"
|
||||
}
|
||||
list [catch { foo } msg] $msg
|
||||
} {0 {new value}}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
catch {unset i x result y}
|
||||
catch {rename foo ""}
|
||||
catch {rename bar ""}
|
||||
catch {rename check ""}
|
||||
catch {rename bar {}}
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
324
tests/apply.test
Normal file
324
tests/apply.test
Normal file
@@ -0,0 +1,324 @@
|
||||
# Commands covered: apply
|
||||
#
|
||||
# This file contains a collection of tests for one or more of the Tcl
|
||||
# built-in commands. Sourcing this file into Tcl runs the tests and
|
||||
# generates output for errors. No output means no errors were found.
|
||||
#
|
||||
# Copyright (c) 1991-1993 The Regents of the University of California.
|
||||
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
# Copyright (c) 2005-2006 Miguel Sofer
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest 2.2
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
if {[info commands ::apply] eq {}} {
|
||||
return
|
||||
}
|
||||
|
||||
testConstraint memory [llength [info commands memory]]
|
||||
|
||||
# Tests for wrong number of arguments
|
||||
|
||||
test apply-1.1 {too few arguments} {
|
||||
set res [catch apply msg]
|
||||
list $res $msg
|
||||
} {1 {wrong # args: should be "apply lambdaExpr ?arg1 arg2 ...?"}}
|
||||
|
||||
# Tests for malformed lambda
|
||||
|
||||
test apply-2.0 {malformed lambda} {
|
||||
set lambda a
|
||||
set res [catch {apply $lambda} msg]
|
||||
list $res $msg
|
||||
} {1 {can't interpret "a" as a lambda expression}}
|
||||
test apply-2.1 {malformed lambda} {
|
||||
set lambda [list a b c d]
|
||||
set res [catch {apply $lambda} msg]
|
||||
list $res $msg
|
||||
} {1 {can't interpret "a b c d" as a lambda expression}}
|
||||
test apply-2.2 {malformed lambda} {
|
||||
set lambda [list {{}} boo]
|
||||
set res [catch {apply $lambda} msg]
|
||||
list $res $msg $::errorInfo
|
||||
} {1 {argument with no name} {argument with no name
|
||||
(parsing lambda expression "{{}} boo")
|
||||
invoked from within
|
||||
"apply $lambda"}}
|
||||
test apply-2.3 {malformed lambda} {
|
||||
set lambda [list {{a b c}} boo]
|
||||
set res [catch {apply $lambda} msg]
|
||||
list $res $msg $::errorInfo
|
||||
} {1 {too many fields in argument specifier "a b c"} {too many fields in argument specifier "a b c"
|
||||
(parsing lambda expression "{{a b c}} boo")
|
||||
invoked from within
|
||||
"apply $lambda"}}
|
||||
test apply-2.4 {malformed lambda} {
|
||||
set lambda [list a(1) boo]
|
||||
set res [catch {apply $lambda} msg]
|
||||
list $res $msg $::errorInfo
|
||||
} {1 {formal parameter "a(1)" is an array element} {formal parameter "a(1)" is an array element
|
||||
(parsing lambda expression "a(1) boo")
|
||||
invoked from within
|
||||
"apply $lambda"}}
|
||||
test apply-2.5 {malformed lambda} {
|
||||
set lambda [list a::b boo]
|
||||
set res [catch {apply $lambda} msg]
|
||||
list $res $msg $::errorInfo
|
||||
} {1 {formal parameter "a::b" is not a simple name} {formal parameter "a::b" is not a simple name
|
||||
(parsing lambda expression "a::b boo")
|
||||
invoked from within
|
||||
"apply $lambda"}}
|
||||
|
||||
# Tests for runtime errors in the lambda expression
|
||||
|
||||
test apply-3.1 {non-existing namespace} -body {
|
||||
apply [list x {set x 1} ::NONEXIST::FOR::SURE] x
|
||||
} -returnCodes error -result {namespace "::NONEXIST::FOR::SURE" not found}
|
||||
test apply-3.2 {non-existing namespace} -body {
|
||||
namespace eval ::NONEXIST::FOR::SURE {}
|
||||
set lambda [list x {set x 1} ::NONEXIST::FOR::SURE]
|
||||
apply $lambda x
|
||||
namespace delete ::NONEXIST
|
||||
apply $lambda x
|
||||
} -returnCodes error -result {namespace "::NONEXIST::FOR::SURE" not found}
|
||||
test apply-3.3 {non-existing namespace} -body {
|
||||
apply [list x {set x 1} NONEXIST::FOR::SURE] x
|
||||
} -returnCodes error -result {namespace "::NONEXIST::FOR::SURE" not found}
|
||||
test apply-3.4 {non-existing namespace} -body {
|
||||
namespace eval ::NONEXIST::FOR::SURE {}
|
||||
set lambda [list x {set x 1} NONEXIST::FOR::SURE]
|
||||
apply $lambda x
|
||||
namespace delete ::NONEXIST
|
||||
apply $lambda x
|
||||
} -returnCodes error -result {namespace "::NONEXIST::FOR::SURE" not found}
|
||||
|
||||
test apply-4.1 {error in arguments to lambda expression} {
|
||||
set lambda [list x {set x 1}]
|
||||
set res [catch {apply $lambda} msg]
|
||||
list $res $msg
|
||||
} {1 {wrong # args: should be "apply lambdaExpr x"}}
|
||||
test apply-4.2 {error in arguments to lambda expression} {
|
||||
set lambda [list x {set x 1}]
|
||||
set res [catch {apply $lambda a b} msg]
|
||||
list $res $msg
|
||||
} {1 {wrong # args: should be "apply lambdaExpr x"}}
|
||||
test apply-4.3 {error in arguments to lambda expression} {
|
||||
set lambda [list x {set x 1}]
|
||||
interp alias {} foo {} ::apply $lambda
|
||||
set res [catch {foo a b} msg]
|
||||
list $res $msg [rename foo {}]
|
||||
} {1 {wrong # args: should be "foo x"} {}}
|
||||
test apply-4.4 {error in arguments to lambda expression} {
|
||||
set lambda [list x {set x 1}]
|
||||
interp alias {} foo {} ::apply $lambda a
|
||||
set res [catch {foo b} msg]
|
||||
list $res $msg [rename foo {}]
|
||||
} {1 {wrong # args: should be "foo"} {}}
|
||||
test apply-4.5 {error in arguments to lambda expression} {
|
||||
set lambda [list x {set x 1}]
|
||||
namespace eval a {
|
||||
namespace ensemble create -command ::bar -map {id {::a::const foo}}
|
||||
proc const val { return $val }
|
||||
proc alias {object slot = command args} {
|
||||
set map [namespace ensemble configure $object -map]
|
||||
dict set map $slot [linsert $args 0 $command]
|
||||
namespace ensemble configure $object -map $map
|
||||
}
|
||||
proc method {object name params body} {
|
||||
set params [linsert $params 0 self]
|
||||
alias $object $name = ::apply [list $params $body] $object
|
||||
}
|
||||
method ::bar boo x {return "[expr {$x*$x}] - $self"}
|
||||
}
|
||||
set res [catch {bar boo} msg]
|
||||
list $res $msg [namespace delete ::a]
|
||||
} {1 {wrong # args: should be "bar boo x"} {}}
|
||||
|
||||
test apply-5.1 {runtime error in lambda expression} {
|
||||
set lambda [list {} {error foo}]
|
||||
set res [catch {apply $lambda}]
|
||||
list $res $::errorInfo
|
||||
} {1 {foo
|
||||
while executing
|
||||
"error foo"
|
||||
(lambda term "{} {error foo}" line 1)
|
||||
invoked from within
|
||||
"apply $lambda"}}
|
||||
|
||||
# Tests for correct execution; as the implementation is the same as that for
|
||||
# procs, the general functionality is mostly tested elsewhere
|
||||
|
||||
test apply-6.1 {info level} {
|
||||
set lev [info level]
|
||||
set lambda [list {} {info level}]
|
||||
expr {[apply $lambda] - $lev}
|
||||
} 1
|
||||
test apply-6.2 {info level} {
|
||||
set lambda [list {} {info level 0}]
|
||||
apply $lambda
|
||||
} {apply {{} {info level 0}}}
|
||||
test apply-6.3 {info level} {
|
||||
set lambda [list args {info level 0}]
|
||||
apply $lambda x y
|
||||
} {apply {args {info level 0}} x y}
|
||||
|
||||
# Tests for correct namespace scope
|
||||
|
||||
namespace eval ::testApply {
|
||||
proc testApply args {return testApply}
|
||||
}
|
||||
|
||||
test apply-7.1 {namespace access} {
|
||||
set ::testApply::x 0
|
||||
set body {set x 1; set x}
|
||||
list [apply [list args $body ::testApply]] $::testApply::x
|
||||
} {1 0}
|
||||
test apply-7.2 {namespace access} {
|
||||
set ::testApply::x 0
|
||||
set body {variable x; set x}
|
||||
list [apply [list args $body ::testApply]] $::testApply::x
|
||||
} {0 0}
|
||||
test apply-7.3 {namespace access} {
|
||||
set ::testApply::x 0
|
||||
set body {variable x; set x 1}
|
||||
list [apply [list args $body ::testApply]] $::testApply::x
|
||||
} {1 1}
|
||||
test apply-7.4 {namespace access} {
|
||||
set ::testApply::x 0
|
||||
set body {testApply}
|
||||
apply [list args $body ::testApply]
|
||||
} testApply
|
||||
test apply-7.5 {namespace access} {
|
||||
set ::testApply::x 0
|
||||
set body {set x 1; set x}
|
||||
list [apply [list args $body testApply]] $::testApply::x
|
||||
} {1 0}
|
||||
test apply-7.6 {namespace access} {
|
||||
set ::testApply::x 0
|
||||
set body {variable x; set x}
|
||||
list [apply [list args $body testApply]] $::testApply::x
|
||||
} {0 0}
|
||||
test apply-7.7 {namespace access} {
|
||||
set ::testApply::x 0
|
||||
set body {variable x; set x 1}
|
||||
list [apply [list args $body testApply]] $::testApply::x
|
||||
} {1 1}
|
||||
test apply-7.8 {namespace access} {
|
||||
set ::testApply::x 0
|
||||
set body {testApply}
|
||||
apply [list args $body testApply]
|
||||
} testApply
|
||||
|
||||
# Tests for correct argument treatment
|
||||
|
||||
set applyBody {
|
||||
set res {}
|
||||
foreach v [info locals] {
|
||||
if {$v eq "res"} continue
|
||||
lappend res [list $v [set $v]]
|
||||
}
|
||||
set res
|
||||
}
|
||||
|
||||
test apply-8.1 {args treatment} {
|
||||
apply [list args $applyBody] 1 2 3
|
||||
} {{args {1 2 3}}}
|
||||
test apply-8.2 {args treatment} {
|
||||
apply [list {x args} $applyBody] 1 2
|
||||
} {{x 1} {args 2}}
|
||||
test apply-8.3 {args treatment} {
|
||||
apply [list {x args} $applyBody] 1 2 3
|
||||
} {{x 1} {args {2 3}}}
|
||||
test apply-8.4 {default values} {
|
||||
apply [list {{x 1} {y 2}} $applyBody]
|
||||
} {{x 1} {y 2}}
|
||||
test apply-8.5 {default values} {
|
||||
apply [list {{x 1} {y 2}} $applyBody] 3 4
|
||||
} {{x 3} {y 4}}
|
||||
test apply-8.6 {default values} {
|
||||
apply [list {{x 1} {y 2}} $applyBody] 3
|
||||
} {{x 3} {y 2}}
|
||||
test apply-8.7 {default values} {
|
||||
apply [list {x {y 2}} $applyBody] 1
|
||||
} {{x 1} {y 2}}
|
||||
test apply-8.8 {default values} {
|
||||
apply [list {x {y 2}} $applyBody] 1 3
|
||||
} {{x 1} {y 3}}
|
||||
test apply-8.9 {default values} {
|
||||
apply [list {x {y 2} args} $applyBody] 1
|
||||
} {{x 1} {y 2} {args {}}}
|
||||
test apply-8.10 {default values} {
|
||||
apply [list {x {y 2} args} $applyBody] 1 3
|
||||
} {{x 1} {y 3} {args {}}}
|
||||
|
||||
# Tests for leaks
|
||||
|
||||
test apply-9.1 {leaking internal rep} -setup {
|
||||
proc getbytes {} {
|
||||
set lines [split [memory info] "\n"]
|
||||
lindex $lines 3 3
|
||||
}
|
||||
set lam [list {} {set a 1}]
|
||||
} -constraints memory -body {
|
||||
set end [getbytes]
|
||||
for {set i 0} {$i < 5} {incr i} {
|
||||
::apply [lrange $lam 0 end]
|
||||
set tmp $end
|
||||
set end [getbytes]
|
||||
}
|
||||
set leakedBytes [expr {$end - $tmp}]
|
||||
} -cleanup {
|
||||
rename getbytes {}
|
||||
unset -nocomplain lam end i tmp leakedBytes
|
||||
} -result 0
|
||||
test apply-9.2 {leaking internal rep} -setup {
|
||||
proc getbytes {} {
|
||||
set lines [split [memory info] "\n"]
|
||||
lindex $lines 3 3
|
||||
}
|
||||
} -constraints memory -body {
|
||||
set end [getbytes]
|
||||
for {set i 0} {$i < 5} {incr i} {
|
||||
::apply [list {} {set a 1}]
|
||||
set tmp $end
|
||||
set end [getbytes]
|
||||
}
|
||||
set leakedBytes [expr {$end - $tmp}]
|
||||
} -cleanup {
|
||||
rename getbytes {}
|
||||
unset -nocomplain end i tmp leakedBytes
|
||||
} -result 0
|
||||
test apply-9.3 {leaking internal rep} -setup {
|
||||
proc getbytes {} {
|
||||
set lines [split [memory info] "\n"]
|
||||
lindex $lines 3 3
|
||||
}
|
||||
} -constraints memory -body {
|
||||
set end [getbytes]
|
||||
for {set i 0} {$i < 5} {incr i} {
|
||||
set x [list {} {set a 1} ::NS::THAT::DOES::NOT::EXIST]
|
||||
catch {::apply $x}
|
||||
set x {}
|
||||
set tmp $end
|
||||
set end [getbytes]
|
||||
}
|
||||
set leakedBytes [expr {$end - $tmp}]
|
||||
} -cleanup {
|
||||
rename getbytes {}
|
||||
unset -nocomplain end i x tmp leakedBytes
|
||||
} -result 0
|
||||
|
||||
# Tests for the avoidance of recompilation
|
||||
|
||||
# cleanup
|
||||
|
||||
namespace delete testApply
|
||||
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
65
tests/assocd.test
Normal file
65
tests/assocd.test
Normal file
@@ -0,0 +1,65 @@
|
||||
# This file tests the AssocData facility of Tcl
|
||||
#
|
||||
# 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-1994 The Regents of the University of California.
|
||||
# Copyright (c) 1994 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
package require tcltest 2
|
||||
namespace import ::tcltest::*
|
||||
|
||||
testConstraint testgetassocdata [llength [info commands testgetassocdata]]
|
||||
testConstraint testsetassocdata [llength [info commands testsetassocdata]]
|
||||
testConstraint testdelassocdata [llength [info commands testdelassocdata]]
|
||||
|
||||
test assocd-1.1 {testing setting assoc data} testsetassocdata {
|
||||
testsetassocdata a 1
|
||||
} ""
|
||||
test assocd-1.2 {testing setting assoc data} testsetassocdata {
|
||||
testsetassocdata a 2
|
||||
} ""
|
||||
test assocd-1.3 {testing setting assoc data} testsetassocdata {
|
||||
testsetassocdata 123 456
|
||||
} ""
|
||||
test assocd-1.4 {testing setting assoc data} testsetassocdata {
|
||||
testsetassocdata abc "abc d e f"
|
||||
} ""
|
||||
|
||||
test assocd-2.1 {testing getting assoc data} -setup {
|
||||
testsetassocdata a 2
|
||||
} -constraints {testgetassocdata} -body {
|
||||
testgetassocdata a
|
||||
} -result 2
|
||||
test assocd-2.2 {testing getting assoc data} -setup {
|
||||
testsetassocdata 123 456
|
||||
} -constraints {testgetassocdata} -body {
|
||||
testgetassocdata 123
|
||||
} -result 456
|
||||
test assocd-2.3 {testing getting assoc data} -setup {
|
||||
testsetassocdata abc "abc d e f"
|
||||
} -constraints {testgetassocdata} -body {
|
||||
testgetassocdata abc
|
||||
} -result "abc d e f"
|
||||
test assocd-2.4 {testing getting assoc data} testgetassocdata {
|
||||
testgetassocdata xxx
|
||||
} ""
|
||||
|
||||
test assocd-3.1 {testing deleting assoc data} testdelassocdata {
|
||||
testdelassocdata a
|
||||
} ""
|
||||
test assocd-3.2 {testing deleting assoc data} testdelassocdata {
|
||||
testdelassocdata 123
|
||||
} ""
|
||||
test assocd-3.3 {testing deleting assoc data} testdelassocdata {
|
||||
list [catch {testdelassocdata nonexistent} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
# cleanup
|
||||
cleanupTests
|
||||
return
|
||||
219
tests/async.test
Normal file
219
tests/async.test
Normal file
@@ -0,0 +1,219 @@
|
||||
# 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.
|
||||
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
testConstraint testasync [llength [info commands testasync]]
|
||||
testConstraint threaded [expr {
|
||||
[info exists ::tcl_platform(threaded)] && $::tcl_platform(threaded)
|
||||
}]
|
||||
|
||||
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
|
||||
}
|
||||
proc \# {result code} {
|
||||
global aresult acode
|
||||
set aresult $result
|
||||
set acode $code
|
||||
return "comment quoting"
|
||||
}
|
||||
|
||||
if {[testConstraint testasync]} {
|
||||
set handler1 [testasync create async1]
|
||||
set handler2 [testasync create async2]
|
||||
set handler3 [testasync create async3]
|
||||
set handler4 [testasync create \#]
|
||||
}
|
||||
test async-1.1 {basic async handlers} testasync {
|
||||
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} testasync {
|
||||
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} testasync {
|
||||
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} testasync {
|
||||
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} testasync {
|
||||
set aresult xxx
|
||||
list [catch {testasync mark $handler3 "foobar" 0} msg] $msg $aresult
|
||||
} {0 foobar {test pattern}}
|
||||
test async-1.6 {basic async handlers} testasync {
|
||||
set aresult xxx
|
||||
list [catch {testasync mark $handler3 "foobar" 1} msg] $msg $aresult
|
||||
} {1 foobar {test pattern}}
|
||||
test async-1.7 {basic async handlers} testasync {
|
||||
set aresult xxx
|
||||
set acode yyy
|
||||
list [catch {testasync mark $handler4 "original" 0} msg] $msg \
|
||||
$acode $aresult
|
||||
} {0 {comment quoting} 0 original}
|
||||
|
||||
proc mult1 {result code} {
|
||||
global x
|
||||
lappend x mult1
|
||||
return -code 7 mult1
|
||||
}
|
||||
proc mult2 {result code} {
|
||||
global x
|
||||
lappend x mult2
|
||||
return -code 9 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
|
||||
}
|
||||
if {[testConstraint testasync]} {
|
||||
set hm1 [testasync create mult1]
|
||||
set hm2 [testasync create mult2]
|
||||
set hm3 [testasync create mult3]
|
||||
}
|
||||
test async-2.1 {multiple handlers} testasync {
|
||||
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
|
||||
}
|
||||
if {[testConstraint testasync]} {
|
||||
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} testasync {
|
||||
set x {}
|
||||
list [catch {testasync mark $hm2 "foobar" 5} msg] $msg $x
|
||||
} {3 del2 {0 0 0 del1 del2}}
|
||||
|
||||
proc nothing {} {
|
||||
# empty proc
|
||||
}
|
||||
proc hang1 {handle} {
|
||||
global aresult
|
||||
set aresult {Async event not delivered}
|
||||
testasync marklater $handle
|
||||
for {set i 0} {
|
||||
$i < 2500000 && $aresult eq "Async event not delivered"
|
||||
} {incr i} {
|
||||
nothing
|
||||
}
|
||||
return $aresult
|
||||
}
|
||||
proc hang2 {handle} {
|
||||
global aresult
|
||||
set aresult {Async event not delivered}
|
||||
testasync marklater $handle
|
||||
for {set i 0} {
|
||||
$i < 2500000 && $aresult eq "Async event not delivered"
|
||||
} {incr i} {}
|
||||
return $aresult
|
||||
}
|
||||
proc hang3 {handle} [concat {
|
||||
global aresult
|
||||
set aresult {Async event not delivered}
|
||||
testasync marklater $handle
|
||||
set i 0
|
||||
} "[string repeat {;incr i;} 1500000]after 10;" {
|
||||
return $aresult
|
||||
}]
|
||||
|
||||
test async-4.1 {async interrupting bytecode sequence} -constraints {
|
||||
testasync threaded
|
||||
} -setup {
|
||||
set hm [testasync create async3]
|
||||
} -body {
|
||||
hang1 $hm
|
||||
} -result {test pattern} -cleanup {
|
||||
testasync delete $hm
|
||||
}
|
||||
test async-4.2 {async interrupting straight bytecode sequence} -constraints {
|
||||
testasync threaded
|
||||
} -setup {
|
||||
set hm [testasync create async3]
|
||||
} -body {
|
||||
hang2 $hm
|
||||
} -result {test pattern} -cleanup {
|
||||
testasync delete $hm
|
||||
}
|
||||
test async-4.3 {async interrupting loop-less bytecode sequence} -constraints {
|
||||
testasync threaded
|
||||
} -setup {
|
||||
set hm [testasync create async3]
|
||||
} -body {
|
||||
hang3 $hm
|
||||
} -result {test pattern} -cleanup {
|
||||
testasync delete $hm
|
||||
}
|
||||
|
||||
# cleanup
|
||||
if {[testConstraint testasync]} {
|
||||
testasync delete
|
||||
}
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# End:
|
||||
389
tests/autoMkindex.test
Normal file
389
tests/autoMkindex.test
Normal file
@@ -0,0 +1,389 @@
|
||||
# Commands covered: auto_mkindex auto_import
|
||||
#
|
||||
# This file contains tests related to autoloading and generating
|
||||
# the autoloading index.
|
||||
#
|
||||
# Copyright (c) 1998 Lucent Technologies, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest 2
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
makeFile {# Test file for:
|
||||
# auto_mkindex
|
||||
#
|
||||
# This file provides example cases for testing the Tcl autoloading
|
||||
# facility. Things are much more complicated with namespaces and classes.
|
||||
# The "auto_mkindex" facility can no longer be built on top of a simple
|
||||
# regular expression parser. It must recognize constructs like this:
|
||||
#
|
||||
# namespace eval foo {
|
||||
# proc test {x y} { ... }
|
||||
# namespace eval bar {
|
||||
# proc another {args} { ... }
|
||||
# }
|
||||
# }
|
||||
#
|
||||
# Note that procedures and itcl class definitions can be nested inside
|
||||
# of namespaces.
|
||||
#
|
||||
# Copyright (c) 1993-1998 Lucent Technologies, Inc.
|
||||
|
||||
# This shouldn't cause any problems
|
||||
namespace import -force blt::*
|
||||
|
||||
# Should be able to handle "proc" definitions, even if they are
|
||||
# preceded by white space.
|
||||
|
||||
proc normal {x y} {return [expr $x+$y]}
|
||||
proc indented {x y} {return [expr $x+$y]}
|
||||
|
||||
#
|
||||
# Should be able to handle proc declarations within namespaces,
|
||||
# even if they have explicit namespace paths.
|
||||
#
|
||||
namespace eval buried {
|
||||
proc inside {args} {return "inside: $args"}
|
||||
|
||||
namespace export pub_*
|
||||
proc pub_one {args} {return "one: $args"}
|
||||
proc pub_two {args} {return "two: $args"}
|
||||
}
|
||||
proc buried::within {args} {return "within: $args"}
|
||||
|
||||
namespace eval buried {
|
||||
namespace eval under {
|
||||
proc neath {args} {return "neath: $args"}
|
||||
}
|
||||
namespace eval ::buried {
|
||||
proc relative {args} {return "relative: $args"}
|
||||
proc ::top {args} {return "top: $args"}
|
||||
proc ::buried::explicit {args} {return "explicit: $args"}
|
||||
}
|
||||
}
|
||||
|
||||
# With proper hooks, we should be able to support other commands
|
||||
# that create procedures
|
||||
|
||||
proc buried::myproc {name body args} {
|
||||
::proc $name $body $args
|
||||
}
|
||||
namespace eval ::buried {
|
||||
proc mycmd1 args {return "mycmd"}
|
||||
myproc mycmd2 args {return "mycmd"}
|
||||
}
|
||||
::buried::myproc mycmd3 args {return "another"}
|
||||
|
||||
proc {buried::my proc} {name body args} {
|
||||
::proc $name $body $args
|
||||
}
|
||||
namespace eval ::buried {
|
||||
proc mycmd4 args {return "mycmd"}
|
||||
{my proc} mycmd5 args {return "mycmd"}
|
||||
}
|
||||
{::buried::my proc} mycmd6 args {return "another"}
|
||||
|
||||
# A correctly functioning [auto_import] won't choke when a child
|
||||
# namespace [namespace import]s from its parent.
|
||||
#
|
||||
namespace eval ::parent::child {
|
||||
namespace import ::parent::*
|
||||
}
|
||||
proc ::parent::child::test {} {}
|
||||
|
||||
} autoMkindex.tcl
|
||||
|
||||
|
||||
# Save initial state of auto_mkindex_parser
|
||||
|
||||
auto_load auto_mkindex
|
||||
if {[info exists auto_mkindex_parser::initCommands]} {
|
||||
set saveCommands $auto_mkindex_parser::initCommands
|
||||
}
|
||||
proc AutoMkindexTestReset {} {
|
||||
global saveCommands
|
||||
if {[info exists saveCommands]} {
|
||||
set auto_mkindex_parser::initCommands $saveCommands
|
||||
} elseif {[info exists auto_mkindex_parser::initCommands]} {
|
||||
unset auto_mkindex_parser::initCommands
|
||||
}
|
||||
}
|
||||
|
||||
set result ""
|
||||
|
||||
set origDir [pwd]
|
||||
cd $::tcltest::temporaryDirectory
|
||||
|
||||
test autoMkindex-1.1 {remove any existing tclIndex file} {
|
||||
file delete tclIndex
|
||||
file exists tclIndex
|
||||
} {0}
|
||||
|
||||
test autoMkindex-1.2 {build tclIndex based on a test file} {
|
||||
auto_mkindex . autoMkindex.tcl
|
||||
file exists tclIndex
|
||||
} {1}
|
||||
|
||||
set element "{source [file join . autoMkindex.tcl]}"
|
||||
|
||||
test autoMkindex-1.3 {examine tclIndex} {
|
||||
file delete tclIndex
|
||||
auto_mkindex . autoMkindex.tcl
|
||||
namespace eval tcl_autoMkindex_tmp {
|
||||
set dir "."
|
||||
variable auto_index
|
||||
source tclIndex
|
||||
set ::result ""
|
||||
foreach elem [lsort [array names auto_index]] {
|
||||
lappend ::result [list $elem $auto_index($elem)]
|
||||
}
|
||||
}
|
||||
namespace delete tcl_autoMkindex_tmp
|
||||
set ::result
|
||||
} "{::buried::explicit $element} {::buried::inside $element} {{::buried::my proc} $element} {::buried::mycmd1 $element} {::buried::mycmd4 $element} {::buried::myproc $element} {::buried::pub_one $element} {::buried::pub_two $element} {::buried::relative $element} {::buried::under::neath $element} {::buried::within $element} {::parent::child::test $element} {indented $element} {normal $element} {top $element}"
|
||||
|
||||
|
||||
test autoMkindex-2.1 {commands on the autoload path can be imported} {
|
||||
file delete tclIndex
|
||||
auto_mkindex . autoMkindex.tcl
|
||||
set interp [interp create]
|
||||
set final [$interp eval {
|
||||
namespace eval blt {}
|
||||
set auto_path [linsert $auto_path 0 .]
|
||||
set info [list [catch {namespace import buried::*} result] $result]
|
||||
foreach name [lsort [info commands pub_*]] {
|
||||
lappend info $name [namespace origin $name]
|
||||
}
|
||||
set info
|
||||
}]
|
||||
interp delete $interp
|
||||
set final
|
||||
} "0 {} pub_one ::buried::pub_one pub_two ::buried::pub_two"
|
||||
|
||||
# Test auto_mkindex hooks
|
||||
|
||||
# Slave hook executes interesting code in the interp used to watch code.
|
||||
|
||||
test autoMkindex-3.1 {slaveHook} {
|
||||
auto_mkindex_parser::slavehook {
|
||||
_%@namespace eval ::blt {
|
||||
proc foo {} {}
|
||||
_%@namespace export foo
|
||||
}
|
||||
}
|
||||
auto_mkindex_parser::slavehook { _%@namespace import -force ::blt::* }
|
||||
file delete tclIndex
|
||||
auto_mkindex . autoMkindex.tcl
|
||||
|
||||
# Reset initCommands to avoid trashing other tests
|
||||
|
||||
AutoMkindexTestReset
|
||||
file exists tclIndex
|
||||
} 1
|
||||
|
||||
# The auto_mkindex_parser::command is used to register commands
|
||||
# that create new commands.
|
||||
|
||||
test autoMkindex-3.2 {auto_mkindex_parser::command} {
|
||||
auto_mkindex_parser::command buried::myproc {name args} {
|
||||
variable index
|
||||
variable scriptFile
|
||||
append index [list set auto_index([fullname $name])] \
|
||||
" \[list source \[file join \$dir [list $scriptFile]\]\]\n"
|
||||
}
|
||||
file delete tclIndex
|
||||
auto_mkindex . autoMkindex.tcl
|
||||
namespace eval tcl_autoMkindex_tmp {
|
||||
set dir "."
|
||||
variable auto_index
|
||||
source tclIndex
|
||||
set ::result ""
|
||||
foreach elem [lsort [array names auto_index]] {
|
||||
lappend ::result [list $elem $auto_index($elem)]
|
||||
}
|
||||
}
|
||||
namespace delete tcl_autoMkindex_tmp
|
||||
|
||||
# Reset initCommands to avoid trashing other tests
|
||||
|
||||
AutoMkindexTestReset
|
||||
set ::result
|
||||
} "{::buried::explicit $element} {::buried::inside $element} {{::buried::my proc} $element} {::buried::mycmd1 $element} {::buried::mycmd2 $element} {::buried::mycmd4 $element} {::buried::myproc $element} {::buried::pub_one $element} {::buried::pub_two $element} {::buried::relative $element} {::buried::under::neath $element} {::buried::within $element} {::parent::child::test $element} {indented $element} {mycmd3 $element} {normal $element} {top $element}"
|
||||
|
||||
|
||||
test autoMkindex-3.3 {auto_mkindex_parser::command} {knownBug} {
|
||||
auto_mkindex_parser::command {buried::my proc} {name args} {
|
||||
variable index
|
||||
variable scriptFile
|
||||
puts "my proc $name"
|
||||
append index [list set auto_index([fullname $name])] \
|
||||
" \[list source \[file join \$dir [list $scriptFile]\]\]\n"
|
||||
}
|
||||
file delete tclIndex
|
||||
auto_mkindex . autoMkindex.tcl
|
||||
namespace eval tcl_autoMkindex_tmp {
|
||||
set dir "."
|
||||
variable auto_index
|
||||
source tclIndex
|
||||
set ::result ""
|
||||
foreach elem [lsort [array names auto_index]] {
|
||||
lappend ::result [list $elem $auto_index($elem)]
|
||||
}
|
||||
}
|
||||
namespace delete tcl_autoMkindex_tmp
|
||||
|
||||
# Reset initCommands to avoid trashing other tests
|
||||
|
||||
AutoMkindexTestReset
|
||||
proc lvalue {list pattern} {
|
||||
set ix [lsearch $list $pattern]
|
||||
if {$ix >= 0} {
|
||||
return [lindex $list $ix]
|
||||
} else {
|
||||
return {}
|
||||
}
|
||||
}
|
||||
list [lvalue $::result *mycmd4*] [lvalue $::result *mycmd5*] [lvalue $::result *mycmd6*]
|
||||
} "{::buried::mycmd4 $element} {::buried::mycmd5 $element} {mycmd6 $element}"
|
||||
|
||||
makeFile {
|
||||
|
||||
namespace eval wok {
|
||||
namespace ensemble create -subcommands {commands vars}
|
||||
|
||||
proc commands {{pattern *}} {
|
||||
puts [join [lsort -dictionary [info commands $pattern]] \n]
|
||||
}
|
||||
|
||||
proc vars {{pattern *}} {
|
||||
puts [join [lsort -dictionary [info vars $pattern]] \n]
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
} ensemblecommands.tcl
|
||||
|
||||
test autoMkindex-3.4 {ensemble commands in tclIndex} {
|
||||
file delete tclIndex
|
||||
auto_mkindex . ensemblecommands.tcl
|
||||
set f [open tclIndex r]
|
||||
set dat [list]
|
||||
foreach r [split [string trim [read $f]] "\n"] {
|
||||
if {[string match {set auto_index*} $r]} {
|
||||
lappend dat $r
|
||||
}
|
||||
}
|
||||
set result [lsort $dat]
|
||||
close $f
|
||||
set result
|
||||
} {{set auto_index(::wok::commands) [list source [file join $dir ensemblecommands.tcl]]} {set auto_index(::wok::vars) [list source [file join $dir ensemblecommands.tcl]]} {set auto_index(wok) [list source [file join $dir ensemblecommands.tcl]]}}
|
||||
removeFile ensemblecommands.tcl
|
||||
|
||||
makeDirectory pkg
|
||||
makeFile {
|
||||
package provide football 1.0
|
||||
|
||||
namespace eval ::pro:: {
|
||||
#
|
||||
# export only public functions.
|
||||
#
|
||||
namespace export {[a-z]*}
|
||||
}
|
||||
namespace eval ::college:: {
|
||||
#
|
||||
# export only public functions.
|
||||
#
|
||||
namespace export {[a-z]*}
|
||||
}
|
||||
|
||||
proc ::pro::team {} {
|
||||
puts "go packers!"
|
||||
return true
|
||||
}
|
||||
|
||||
proc ::college::team {} {
|
||||
puts "go badgers!"
|
||||
return true
|
||||
}
|
||||
|
||||
} [file join pkg samename.tcl]
|
||||
|
||||
|
||||
test autoMkindex-4.1 {platform indenpendant source commands} {
|
||||
file delete tclIndex
|
||||
auto_mkindex . pkg/samename.tcl
|
||||
set f [open tclIndex r]
|
||||
set dat [split [string trim [read $f]] "\n"]
|
||||
set len [llength $dat]
|
||||
set result [lsort [lrange $dat [expr {$len-2}] [expr {$len-1}]]]
|
||||
close $f
|
||||
set result
|
||||
} {{set auto_index(::college::team) [list source [file join $dir pkg samename.tcl]]} {set auto_index(::pro::team) [list source [file join $dir pkg samename.tcl]]}}
|
||||
|
||||
removeFile [file join pkg samename.tcl]
|
||||
|
||||
makeFile {
|
||||
set dollar1 "this string contains an unescaped dollar sign -> \\$foo"
|
||||
set dollar2 "this string contains an escaped dollar sign -> \$foo \\\$foo"
|
||||
set bracket1 "this contains an unescaped bracket [NoSuchProc]"
|
||||
set bracket2 "this contains an escaped bracket \[NoSuchProc\]"
|
||||
set bracket3 "this contains nested unescaped brackets [[NoSuchProc]]"
|
||||
proc testProc {} {}
|
||||
} [file join pkg magicchar.tcl]
|
||||
|
||||
test autoMkindex-5.1 {escape magic tcl chars in general code} {
|
||||
file delete tclIndex
|
||||
set result {}
|
||||
if { ![catch {auto_mkindex . pkg/magicchar.tcl}] } {
|
||||
set f [open tclIndex r]
|
||||
set dat [split [string trim [read $f]] "\n"]
|
||||
set result [lindex $dat end]
|
||||
close $f
|
||||
}
|
||||
set result
|
||||
} {set auto_index(testProc) [list source [file join $dir pkg magicchar.tcl]]}
|
||||
|
||||
removeFile [file join pkg magicchar.tcl]
|
||||
|
||||
makeFile {
|
||||
proc {[magic mojo proc]} {} {}
|
||||
} [file join pkg magicchar2.tcl]
|
||||
|
||||
test autoMkindex-5.2 {correctly locate auto loaded procs with []} {
|
||||
file delete tclIndex
|
||||
set result {}
|
||||
if { ![catch {auto_mkindex . pkg/magicchar2.tcl}] } {
|
||||
# Make a slave interp to test the autoloading
|
||||
set c [interp create]
|
||||
$c eval {lappend auto_path [pwd]}
|
||||
set result [$c eval {catch {{[magic mojo proc]}}}]
|
||||
interp delete $c
|
||||
}
|
||||
set result
|
||||
} 0
|
||||
|
||||
removeFile [file join pkg magicchar2.tcl]
|
||||
removeDirectory pkg
|
||||
|
||||
# Clean up.
|
||||
|
||||
unset result
|
||||
AutoMkindexTestReset
|
||||
if {[info exists saveCommands]} {
|
||||
unset saveCommands
|
||||
}
|
||||
rename AutoMkindexTestReset ""
|
||||
|
||||
removeFile autoMkindex.tcl
|
||||
if {[file exists tclIndex]} {
|
||||
file delete -force tclIndex
|
||||
}
|
||||
|
||||
cd $origDir
|
||||
|
||||
::tcltest::cleanupTests
|
||||
982
tests/basic.test
Normal file
982
tests/basic.test
Normal file
@@ -0,0 +1,982 @@
|
||||
# This file contains tests for the tclBasic.c source file. Tests appear in
|
||||
# the same order as the C code that they test. The set of tests is
|
||||
# currently incomplete since it currently includes only new tests for
|
||||
# code changed for the addition of Tcl namespaces. Other variable-
|
||||
# related tests appear in several other test files including
|
||||
# assocd.test, cmdInfo.test, eval.test, expr.test, interp.test,
|
||||
# and trace.test.
|
||||
#
|
||||
# Sourcing this file into Tcl runs the tests and generates output for
|
||||
# errors. No output means no errors were found.
|
||||
#
|
||||
# Copyright (c) 1997 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
package require tcltest 2
|
||||
namespace import ::tcltest::*
|
||||
|
||||
testConstraint testevalex [llength [info commands testevalex]]
|
||||
testConstraint testcmdtoken [llength [info commands testcmdtoken]]
|
||||
testConstraint testcreatecommand [llength [info commands testcreatecommand]]
|
||||
testConstraint exec [llength [info commands exec]]
|
||||
|
||||
catch {namespace delete test_ns_basic}
|
||||
catch {interp delete test_interp}
|
||||
catch {rename p ""}
|
||||
catch {rename q ""}
|
||||
catch {rename cmd ""}
|
||||
unset -nocomplain x
|
||||
|
||||
test basic-1.1 {Tcl_CreateInterp, creates interp's global namespace} {
|
||||
catch {interp delete test_interp}
|
||||
interp create test_interp
|
||||
interp eval test_interp {
|
||||
namespace eval test_ns_basic {
|
||||
proc p {} {
|
||||
return [namespace current]
|
||||
}
|
||||
}
|
||||
}
|
||||
list [interp eval test_interp {test_ns_basic::p}] \
|
||||
[interp delete test_interp]
|
||||
} {::test_ns_basic {}}
|
||||
|
||||
test basic-2.1 {TclHideUnsafeCommands} {emptyTest} {
|
||||
} {}
|
||||
|
||||
test basic-3.1 {Tcl_CallWhenDeleted: see dcall.test} {emptyTest} {
|
||||
} {}
|
||||
|
||||
test basic-4.1 {Tcl_DontCallWhenDeleted: see dcall.test} {emptyTest} {
|
||||
} {}
|
||||
|
||||
test basic-5.1 {Tcl_SetAssocData: see assoc.test} {emptyTest} {
|
||||
} {}
|
||||
|
||||
test basic-6.1 {Tcl_DeleteAssocData: see assoc.test} {emptyTest} {
|
||||
} {}
|
||||
|
||||
test basic-7.1 {Tcl_GetAssocData: see assoc.test} {emptyTest} {
|
||||
} {}
|
||||
|
||||
test basic-8.1 {Tcl_InterpDeleted} {emptyTest} {
|
||||
} {}
|
||||
|
||||
test basic-9.1 {Tcl_DeleteInterp: see interp.test} {emptyTest} {
|
||||
} {}
|
||||
|
||||
test basic-10.1 {DeleteInterpProc, destroys interp's global namespace} {
|
||||
catch {interp delete test_interp}
|
||||
interp create test_interp
|
||||
interp eval test_interp {
|
||||
namespace eval test_ns_basic {
|
||||
namespace export p
|
||||
proc p {} {
|
||||
return [namespace current]
|
||||
}
|
||||
}
|
||||
namespace eval test_ns_2 {
|
||||
namespace import ::test_ns_basic::p
|
||||
variable v 27
|
||||
proc q {} {
|
||||
variable v
|
||||
return "[p] $v"
|
||||
}
|
||||
}
|
||||
}
|
||||
list [interp eval test_interp {test_ns_2::q}] \
|
||||
[interp eval test_interp {namespace delete ::}] \
|
||||
[catch {interp eval test_interp {set a 123}} msg] $msg \
|
||||
[interp delete test_interp]
|
||||
} {{::test_ns_basic 27} {} 1 {invalid command name "set"} {}}
|
||||
|
||||
test basic-11.1 {HiddenCmdsDeleteProc, invalidate cached refs to deleted hidden cmd} {
|
||||
catch {interp delete test_interp}
|
||||
interp create test_interp
|
||||
interp eval test_interp {
|
||||
proc p {} {
|
||||
return 27
|
||||
}
|
||||
}
|
||||
interp alias {} localP test_interp p
|
||||
list [interp eval test_interp {p}] \
|
||||
[localP] \
|
||||
[test_interp hide p] \
|
||||
[catch {localP} msg] $msg \
|
||||
[interp delete test_interp] \
|
||||
[catch {localP} msg] $msg
|
||||
} {27 27 {} 1 {invalid command name "p"} {} 1 {invalid command name "localP"}}
|
||||
|
||||
# NB: More tests about hide/expose are found in interp.test
|
||||
|
||||
test basic-12.1 {Tcl_HideCommand, names of hidden cmds can't have namespace qualifiers} {
|
||||
catch {interp delete test_interp}
|
||||
interp create test_interp
|
||||
interp eval test_interp {
|
||||
namespace eval test_ns_basic {
|
||||
proc p {} {
|
||||
return [namespace current]
|
||||
}
|
||||
}
|
||||
}
|
||||
list [catch {test_interp hide test_ns_basic::p x} msg] $msg \
|
||||
[catch {test_interp hide x test_ns_basic::p} msg1] $msg1 \
|
||||
[interp delete test_interp]
|
||||
} {1 {can only hide global namespace commands (use rename then hide)} 1 {cannot use namespace qualifiers in hidden command token (rename)} {}}
|
||||
|
||||
test basic-12.2 {Tcl_HideCommand, a hidden cmd remembers its containing namespace} {
|
||||
catch {namespace delete test_ns_basic}
|
||||
catch {rename cmd ""}
|
||||
proc cmd {} { ;# note that this is global
|
||||
return [namespace current]
|
||||
}
|
||||
namespace eval test_ns_basic {
|
||||
proc hideCmd {} {
|
||||
interp hide {} cmd
|
||||
}
|
||||
proc exposeCmd {} {
|
||||
interp expose {} cmd
|
||||
}
|
||||
proc callCmd {} {
|
||||
cmd
|
||||
}
|
||||
}
|
||||
list [test_ns_basic::callCmd] \
|
||||
[test_ns_basic::hideCmd] \
|
||||
[catch {cmd} msg] $msg \
|
||||
[test_ns_basic::exposeCmd] \
|
||||
[test_ns_basic::callCmd] \
|
||||
[namespace delete test_ns_basic]
|
||||
} {:: {} 1 {invalid command name "cmd"} {} :: {}}
|
||||
|
||||
test basic-13.1 {Tcl_ExposeCommand, a command stays in the global namespace and cannot go to another namespace} {
|
||||
catch {namespace delete test_ns_basic}
|
||||
catch {rename cmd ""}
|
||||
proc cmd {} { ;# note that this is global
|
||||
return [namespace current]
|
||||
}
|
||||
namespace eval test_ns_basic {
|
||||
proc hideCmd {} {
|
||||
interp hide {} cmd
|
||||
}
|
||||
proc exposeCmdFailing {} {
|
||||
interp expose {} cmd ::test_ns_basic::newCmd
|
||||
}
|
||||
proc exposeCmdWorkAround {} {
|
||||
interp expose {} cmd;
|
||||
rename cmd ::test_ns_basic::newCmd;
|
||||
}
|
||||
proc callCmd {} {
|
||||
cmd
|
||||
}
|
||||
}
|
||||
list [test_ns_basic::callCmd] \
|
||||
[test_ns_basic::hideCmd] \
|
||||
[catch {test_ns_basic::exposeCmdFailing} msg] $msg \
|
||||
[test_ns_basic::exposeCmdWorkAround] \
|
||||
[test_ns_basic::newCmd] \
|
||||
[namespace delete test_ns_basic]
|
||||
} {:: {} 1 {cannot expose to a namespace (use expose to toplevel, then rename)} {} ::test_ns_basic {}}
|
||||
test basic-13.2 {Tcl_ExposeCommand, invalidate cached refs to cmd now being exposed} {
|
||||
catch {rename p ""}
|
||||
catch {rename cmd ""}
|
||||
proc p {} {
|
||||
cmd
|
||||
}
|
||||
proc cmd {} {
|
||||
return 42
|
||||
}
|
||||
list [p] \
|
||||
[interp hide {} cmd] \
|
||||
[proc cmd {} {return Hello}] \
|
||||
[cmd] \
|
||||
[rename cmd ""] \
|
||||
[interp expose {} cmd] \
|
||||
[p]
|
||||
} {42 {} {} Hello {} {} 42}
|
||||
|
||||
test basic-14.1 {Tcl_CreateCommand, new cmd goes into a namespace specified in its name, if any} {testcreatecommand} {
|
||||
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
||||
list [testcreatecommand create] \
|
||||
[test_ns_basic::createdcommand] \
|
||||
[testcreatecommand delete]
|
||||
} {{} {CreatedCommandProc in ::test_ns_basic} {}}
|
||||
test basic-14.2 {Tcl_CreateCommand, namespace code ignore single ":"s in middle or end of names} {testcreatecommand} {
|
||||
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
||||
catch {rename value:at: ""}
|
||||
list [testcreatecommand create2] \
|
||||
[value:at:] \
|
||||
[testcreatecommand delete2]
|
||||
} {{} {CreatedCommandProc2 in ::} {}}
|
||||
|
||||
test basic-15.1 {Tcl_CreateObjCommand, new cmd goes into a namespace specified in its name, if any} {
|
||||
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
||||
namespace eval test_ns_basic {}
|
||||
proc test_ns_basic::cmd {} { ;# proc requires that ns already exist
|
||||
return [namespace current]
|
||||
}
|
||||
list [test_ns_basic::cmd] \
|
||||
[namespace delete test_ns_basic]
|
||||
} {::test_ns_basic {}}
|
||||
|
||||
test basic-16.1 {TclInvokeStringCommand} {emptyTest} {
|
||||
} {}
|
||||
|
||||
test basic-17.1 {TclInvokeObjCommand} {emptyTest} {
|
||||
} {}
|
||||
|
||||
test basic-18.1 {TclRenameCommand, name of existing cmd can have namespace qualifiers} {
|
||||
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
||||
catch {rename cmd ""}
|
||||
namespace eval test_ns_basic {
|
||||
proc p {} {
|
||||
return "p in [namespace current]"
|
||||
}
|
||||
}
|
||||
list [test_ns_basic::p] \
|
||||
[rename test_ns_basic::p test_ns_basic::q] \
|
||||
[test_ns_basic::q]
|
||||
} {{p in ::test_ns_basic} {} {p in ::test_ns_basic}}
|
||||
test basic-18.2 {TclRenameCommand, existing cmd must be found} {
|
||||
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
||||
list [catch {rename test_ns_basic::p test_ns_basic::q} msg] $msg
|
||||
} {1 {can't rename "test_ns_basic::p": command doesn't exist}}
|
||||
test basic-18.3 {TclRenameCommand, delete cmd if new name is empty} {
|
||||
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
||||
namespace eval test_ns_basic {
|
||||
proc p {} {
|
||||
return "p in [namespace current]"
|
||||
}
|
||||
}
|
||||
list [info commands test_ns_basic::*] \
|
||||
[rename test_ns_basic::p ""] \
|
||||
[info commands test_ns_basic::*]
|
||||
} {::test_ns_basic::p {} {}}
|
||||
test basic-18.4 {TclRenameCommand, bad new name} {
|
||||
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
||||
namespace eval test_ns_basic {
|
||||
proc p {} {
|
||||
return "p in [namespace current]"
|
||||
}
|
||||
}
|
||||
rename test_ns_basic::p :::george::martha
|
||||
} {}
|
||||
test basic-18.5 {TclRenameCommand, new name must not already exist} -setup {
|
||||
if {![llength [info commands :::george::martha]]} {
|
||||
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
||||
namespace eval test_ns_basic {
|
||||
proc p {} {
|
||||
return "p in [namespace current]"
|
||||
}
|
||||
}
|
||||
rename test_ns_basic::p :::george::martha
|
||||
}
|
||||
} -body {
|
||||
namespace eval test_ns_basic {
|
||||
proc q {} {
|
||||
return 42
|
||||
}
|
||||
}
|
||||
list [catch {rename test_ns_basic::q :::george::martha} msg] $msg
|
||||
} -result {1 {can't rename to ":::george::martha": command already exists}}
|
||||
test basic-18.6 {TclRenameCommand, check for command shadowing by newly renamed cmd} {
|
||||
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
||||
catch {rename p ""}
|
||||
catch {rename q ""}
|
||||
proc p {} {
|
||||
return "p in [namespace current]"
|
||||
}
|
||||
proc q {} {
|
||||
return "q in [namespace current]"
|
||||
}
|
||||
namespace eval test_ns_basic {
|
||||
proc callP {} {
|
||||
p
|
||||
}
|
||||
}
|
||||
list [test_ns_basic::callP] \
|
||||
[rename q test_ns_basic::p] \
|
||||
[test_ns_basic::callP]
|
||||
} {{p in ::} {} {q in ::test_ns_basic}}
|
||||
|
||||
test basic-19.1 {Tcl_SetCommandInfo} {emptyTest} {
|
||||
} {}
|
||||
|
||||
test basic-20.1 {Tcl_GetCommandInfo, names for commands created inside namespaces} {testcmdtoken} {
|
||||
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
||||
catch {rename p ""}
|
||||
catch {rename q ""}
|
||||
unset -nocomplain x
|
||||
set x [namespace eval test_ns_basic::test_ns_basic2 {
|
||||
# the following creates a cmd in the global namespace
|
||||
testcmdtoken create p
|
||||
}]
|
||||
list [testcmdtoken name $x] \
|
||||
[rename ::p q] \
|
||||
[testcmdtoken name $x]
|
||||
} {{p ::p} {} {q ::q}}
|
||||
test basic-20.2 {Tcl_GetCommandInfo, names for commands created outside namespaces} {testcmdtoken} {
|
||||
catch {rename q ""}
|
||||
set x [testcmdtoken create test_ns_basic::test_ns_basic2::p]
|
||||
list [testcmdtoken name $x] \
|
||||
[rename test_ns_basic::test_ns_basic2::p q] \
|
||||
[testcmdtoken name $x]
|
||||
} {{p ::test_ns_basic::test_ns_basic2::p} {} {q ::q}}
|
||||
test basic-20.3 {Tcl_GetCommandInfo, #-quoting} testcmdtoken {
|
||||
catch {rename \# ""}
|
||||
set x [testcmdtoken create \#]
|
||||
testcmdtoken name $x
|
||||
} {{#} ::#}
|
||||
|
||||
test basic-21.1 {Tcl_GetCommandName} {emptyTest} {
|
||||
} {}
|
||||
|
||||
test basic-22.1 {Tcl_GetCommandFullName} {
|
||||
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
||||
namespace eval test_ns_basic1 {
|
||||
namespace export cmd*
|
||||
proc cmd1 {} {}
|
||||
proc cmd2 {} {}
|
||||
}
|
||||
namespace eval test_ns_basic2 {
|
||||
namespace export *
|
||||
namespace import ::test_ns_basic1::*
|
||||
proc p {} {}
|
||||
}
|
||||
namespace eval test_ns_basic3 {
|
||||
namespace import ::test_ns_basic2::*
|
||||
proc q {} {}
|
||||
list [namespace which -command foreach] \
|
||||
[namespace which -command q] \
|
||||
[namespace which -command p] \
|
||||
[namespace which -command cmd1] \
|
||||
[namespace which -command ::test_ns_basic2::cmd2]
|
||||
}
|
||||
} {::foreach ::test_ns_basic3::q ::test_ns_basic3::p ::test_ns_basic3::cmd1 ::test_ns_basic2::cmd2}
|
||||
|
||||
test basic-23.1 {Tcl_DeleteCommand} {emptyTest} {
|
||||
} {}
|
||||
|
||||
test basic-24.1 {Tcl_DeleteCommandFromToken, invalidate all compiled code if cmd has compile proc} {
|
||||
catch {interp delete test_interp}
|
||||
unset -nocomplain x
|
||||
interp create test_interp
|
||||
interp eval test_interp {
|
||||
proc useSet {} {
|
||||
return [set a 123]
|
||||
}
|
||||
}
|
||||
set x [interp eval test_interp {useSet}]
|
||||
interp eval test_interp {
|
||||
rename set ""
|
||||
proc set {args} {
|
||||
return "set called with $args"
|
||||
}
|
||||
}
|
||||
list $x \
|
||||
[interp eval test_interp {useSet}] \
|
||||
[interp delete test_interp]
|
||||
} {123 {set called with a 123} {}}
|
||||
test basic-24.2 {Tcl_DeleteCommandFromToken, deleting commands changes command epoch} {
|
||||
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
||||
catch {rename p ""}
|
||||
proc p {} {
|
||||
return "global p"
|
||||
}
|
||||
namespace eval test_ns_basic {
|
||||
proc p {} {
|
||||
return "namespace p"
|
||||
}
|
||||
proc callP {} {
|
||||
p
|
||||
}
|
||||
}
|
||||
list [test_ns_basic::callP] \
|
||||
[rename test_ns_basic::p ""] \
|
||||
[test_ns_basic::callP]
|
||||
} {{namespace p} {} {global p}}
|
||||
test basic-24.3 {Tcl_DeleteCommandFromToken, delete imported cmds that refer to a deleted cmd} {
|
||||
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
||||
catch {rename p ""}
|
||||
namespace eval test_ns_basic {
|
||||
namespace export p
|
||||
proc p {} {return 42}
|
||||
}
|
||||
namespace eval test_ns_basic2 {
|
||||
namespace import ::test_ns_basic::*
|
||||
proc callP {} {
|
||||
p
|
||||
}
|
||||
}
|
||||
list [test_ns_basic2::callP] \
|
||||
[info commands test_ns_basic2::*] \
|
||||
[rename test_ns_basic::p ""] \
|
||||
[catch {test_ns_basic2::callP} msg] $msg \
|
||||
[info commands test_ns_basic2::*]
|
||||
} {42 {::test_ns_basic2::callP ::test_ns_basic2::p} {} 1 {invalid command name "p"} ::test_ns_basic2::callP}
|
||||
|
||||
test basic-25.1 {TclCleanupCommand} {emptyTest} {
|
||||
} {}
|
||||
|
||||
test basic-26.1 {Tcl_EvalObj: preserve object while evaling it} -setup {
|
||||
proc myHandler {msg options} {
|
||||
set ::x [dict get $options -errorinfo]
|
||||
}
|
||||
set handler [interp bgerror {}]
|
||||
interp bgerror {} [namespace which myHandler]
|
||||
set fName [makeFile {} test1]
|
||||
} -body {
|
||||
# If object isn't preserved, errorInfo would be set to
|
||||
# "foo\n while executing\n\"garbage bytes\"" because the object's
|
||||
# string would have been freed, leaving garbage bytes for the error
|
||||
# message.
|
||||
set f [open $fName w]
|
||||
chan event $f writable "chan event $f writable {}; error foo"
|
||||
set x {}
|
||||
vwait x
|
||||
close $f
|
||||
set x
|
||||
} -cleanup {
|
||||
removeFile test1
|
||||
interp bgerror {} $handler
|
||||
rename myHandler {}
|
||||
} -result "foo\n while executing\n\"error foo\""
|
||||
|
||||
test basic-26.2 {Tcl_EvalObjEx, pure-list branch: preserve "objv"} -body {
|
||||
#
|
||||
# Follow the pure-list branch in a manner that
|
||||
# a - the pure-list internal rep is destroyed by shimmering
|
||||
# b - the command returns an error
|
||||
# As the error code in Tcl_EvalObjv accesses the list elements, this will
|
||||
# cause a segfault if [Bug 1119369] has not been fixed.
|
||||
# NOTE: a MEM_DEBUG build may be necessary to guarantee the segfault.
|
||||
#
|
||||
|
||||
set SRC [list foo 1] ;# pure-list command
|
||||
proc foo str {
|
||||
# Shimmer pure-list to cmdName, cleanup and error
|
||||
proc $::SRC {} {}; $::SRC
|
||||
error "BAD CALL"
|
||||
}
|
||||
catch {eval $SRC}
|
||||
} -result 1 -cleanup {
|
||||
rename foo {}
|
||||
rename $::SRC {}
|
||||
unset ::SRC
|
||||
}
|
||||
|
||||
test basic-26.3 {Tcl_EvalObjEx, pure-list branch: preserve "objv"} -body {
|
||||
#
|
||||
# Follow the pure-list branch in a manner that
|
||||
# a - the pure-list internal rep is destroyed by shimmering
|
||||
# b - the command accesses its command line
|
||||
# This will cause a segfault if [Bug 1119369] has not been fixed.
|
||||
# NOTE: a MEM_DEBUG build may be necessary to guarantee the segfault.
|
||||
#
|
||||
|
||||
set SRC [list foo 1] ;# pure-list command
|
||||
proc foo str {
|
||||
# Shimmer pure-list to cmdName, cleanup and error
|
||||
proc $::SRC {} {}; $::SRC
|
||||
info level 0
|
||||
}
|
||||
catch {eval $SRC}
|
||||
} -result 0 -cleanup {
|
||||
rename foo {}
|
||||
rename $::SRC {}
|
||||
unset ::SRC
|
||||
}
|
||||
|
||||
test basic-27.1 {Tcl_ExprLong} {emptyTest} {
|
||||
} {}
|
||||
|
||||
test basic-28.1 {Tcl_ExprDouble} {emptyTest} {
|
||||
} {}
|
||||
|
||||
test basic-29.1 {Tcl_ExprBoolean} {emptyTest} {
|
||||
} {}
|
||||
|
||||
test basic-30.1 {Tcl_ExprLongObj} {emptyTest} {
|
||||
} {}
|
||||
|
||||
test basic-31.1 {Tcl_ExprDoubleObj} {emptyTest} {
|
||||
} {}
|
||||
|
||||
test basic-32.1 {Tcl_ExprBooleanObj} {emptyTest} {
|
||||
} {}
|
||||
|
||||
test basic-36.1 {Tcl_EvalObjv, lookup of "unknown" command} {
|
||||
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
||||
catch {interp delete test_interp}
|
||||
interp create test_interp
|
||||
interp eval test_interp {
|
||||
proc unknown {args} {
|
||||
return "global unknown"
|
||||
}
|
||||
namespace eval test_ns_basic {
|
||||
proc unknown {args} {
|
||||
return "namespace unknown"
|
||||
}
|
||||
}
|
||||
}
|
||||
list [interp alias test_interp newAlias test_interp doesntExist] \
|
||||
[catch {interp eval test_interp {newAlias}} msg] $msg \
|
||||
[interp delete test_interp]
|
||||
} {newAlias 0 {global unknown} {}}
|
||||
|
||||
test basic-37.1 {Tcl_ExprString: see expr.test} {emptyTest} {
|
||||
} {}
|
||||
|
||||
test basic-38.1 {Tcl_ExprObj} {emptyTest} {
|
||||
} {}
|
||||
|
||||
# Tests basic-39.* and basic-40.* refactored into trace.test
|
||||
|
||||
test basic-41.1 {Tcl_AddErrorInfo} {emptyTest} {
|
||||
} {}
|
||||
|
||||
test basic-42.1 {Tcl_AddObjErrorInfo} {emptyTest} {
|
||||
} {}
|
||||
|
||||
test basic-43.1 {Tcl_VarEval} {emptyTest} {
|
||||
} {}
|
||||
|
||||
test basic-44.1 {Tcl_GlobalEval} {emptyTest} {
|
||||
} {}
|
||||
|
||||
test basic-45.1 {Tcl_SetRecursionLimit: see interp.test} {emptyTest} {
|
||||
} {}
|
||||
|
||||
test basic-46.1 {Tcl_AllowExceptions: exception return not allowed} {stdio} {
|
||||
catch {close $f}
|
||||
set res [catch {
|
||||
set f [open |[list [interpreter]] w+]
|
||||
chan configure $f -buffering line
|
||||
puts $f {chan configure stdout -buffering line}
|
||||
puts $f continue
|
||||
puts $f {puts $::errorInfo}
|
||||
puts $f {puts DONE}
|
||||
set newMsg {}
|
||||
set msg {}
|
||||
while {$newMsg != "DONE"} {
|
||||
set newMsg [gets $f]
|
||||
append msg "${newMsg}\n"
|
||||
}
|
||||
close $f
|
||||
} error]
|
||||
list $res $msg
|
||||
} {1 {invoked "continue" outside of a loop
|
||||
while executing
|
||||
"continue"
|
||||
DONE
|
||||
}}
|
||||
|
||||
test basic-46.2 {Tcl_AllowExceptions: exception return not allowed} -setup {
|
||||
set fName [makeFile {
|
||||
puts hello
|
||||
break
|
||||
} BREAKtest]
|
||||
} -constraints {
|
||||
exec
|
||||
} -body {
|
||||
exec [interpreter] $fName
|
||||
} -cleanup {
|
||||
removeFile BREAKtest
|
||||
} -returnCodes error -match glob -result {hello
|
||||
invoked "break" outside of a loop
|
||||
while executing
|
||||
"break"
|
||||
(file "*BREAKtest" line 3)}
|
||||
|
||||
test basic-46.3 {Tcl_AllowExceptions: exception return not allowed} -setup {
|
||||
set fName [makeFile {
|
||||
interp alias {} patch {} info patchlevel
|
||||
patch
|
||||
break
|
||||
} BREAKtest]
|
||||
} -constraints {
|
||||
exec
|
||||
} -body {
|
||||
exec [interpreter] $fName
|
||||
} -cleanup {
|
||||
removeFile BREAKtest
|
||||
} -returnCodes error -match glob -result {invoked "break" outside of a loop
|
||||
while executing
|
||||
"break"
|
||||
(file "*BREAKtest" line 4)}
|
||||
|
||||
test basic-46.4 {Tcl_AllowExceptions: exception return not allowed} -setup {
|
||||
set fName [makeFile {
|
||||
foo [set a 1] [break]
|
||||
} BREAKtest]
|
||||
} -constraints {
|
||||
exec
|
||||
} -body {
|
||||
exec [interpreter] $fName
|
||||
} -cleanup {
|
||||
removeFile BREAKtest
|
||||
} -returnCodes error -match glob -result {invoked "break" outside of a loop
|
||||
while executing*
|
||||
"foo \[set a 1] \[break]"
|
||||
(file "*BREAKtest" line 2)}
|
||||
|
||||
test basic-46.5 {Tcl_AllowExceptions: exception return not allowed} -setup {
|
||||
set fName [makeFile {
|
||||
return -code return
|
||||
} BREAKtest]
|
||||
} -constraints {
|
||||
exec
|
||||
} -body {
|
||||
exec [interpreter] $fName
|
||||
} -cleanup {
|
||||
removeFile BREAKtest
|
||||
} -returnCodes error -match glob -result {command returned bad code: 2
|
||||
while executing
|
||||
"return -code return"
|
||||
(file "*BREAKtest" line 2)}
|
||||
|
||||
test basic-47.1 {Tcl_EvalEx: check for missing close-bracket} -body {
|
||||
subst {a[set b [format cd]}
|
||||
} -returnCodes error -result {missing close-bracket}
|
||||
|
||||
# Some lists for expansion tests to work with
|
||||
set l1 [list a {b b} c d]
|
||||
set l2 [list e f {g g} h]
|
||||
proc l3 {} {
|
||||
list i j k {l l}
|
||||
}
|
||||
|
||||
# Do all tests once byte compiled and once with direct string evaluation
|
||||
for {set noComp 0} {$noComp <= 1} {incr noComp} {
|
||||
|
||||
if $noComp {
|
||||
interp alias {} run {} testevalex
|
||||
set constraints testevalex
|
||||
} else {
|
||||
interp alias {} run {} if 1
|
||||
set constraints {}
|
||||
}
|
||||
|
||||
test basic-47.2.$noComp {Tcl_EvalEx: error during word expansion} -body {
|
||||
run {{*}\{}
|
||||
} -constraints $constraints -returnCodes error -result {unmatched open brace in list}
|
||||
|
||||
test basic-47.3.$noComp {Tcl_EvalEx, error during substitution} -body {
|
||||
run {{*}[error foo]}
|
||||
} -constraints $constraints -returnCodes error -result foo
|
||||
|
||||
test basic-47.4.$noComp {Tcl_EvalEx: no expansion} $constraints {
|
||||
run {list {*} {*} {*}}
|
||||
} {* * *}
|
||||
|
||||
test basic-47.5.$noComp {Tcl_EvalEx: expansion} $constraints {
|
||||
run {list {*}{} {*} {*}x {*}"y z"}
|
||||
} {* x y z}
|
||||
|
||||
test basic-47.6.$noComp {Tcl_EvalEx: expansion to zero args} $constraints {
|
||||
run {list {*}{}}
|
||||
} {}
|
||||
|
||||
test basic-47.7.$noComp {Tcl_EvalEx: expansion to one arg} $constraints {
|
||||
run {list {*}x}
|
||||
} x
|
||||
|
||||
test basic-47.8.$noComp {Tcl_EvalEx: expansion to many args} $constraints {
|
||||
run {list {*}"y z"}
|
||||
} {y z}
|
||||
|
||||
test basic-47.9.$noComp {Tcl_EvalEx: expansion and subst order} $constraints {
|
||||
set x 0
|
||||
run {list [incr x] {*}[incr x] [incr x] \
|
||||
{*}[list [incr x] [incr x]] [incr x]}
|
||||
} {1 2 3 4 5 6}
|
||||
|
||||
test basic-47.10.$noComp {Tcl_EvalEx: expand and memory management} $constraints {
|
||||
run {concat {*}{} a b c d e f g h i j k l m n o p q r}
|
||||
} {a b c d e f g h i j k l m n o p q r}
|
||||
|
||||
test basic-47.11.$noComp {Tcl_EvalEx: expand and memory management} $constraints {
|
||||
run {concat {*}1 a b c d e f g h i j k l m n o p q r}
|
||||
} {1 a b c d e f g h i j k l m n o p q r}
|
||||
|
||||
test basic-47.12.$noComp {Tcl_EvalEx: expand and memory management} $constraints {
|
||||
run {concat {*}{1 2} a b c d e f g h i j k l m n o p q r}
|
||||
} {1 2 a b c d e f g h i j k l m n o p q r}
|
||||
|
||||
test basic-47.13.$noComp {Tcl_EvalEx: expand and memory management} $constraints {
|
||||
run {concat {*}{} {*}{1 2} a b c d e f g h i j k l m n o p q}
|
||||
} {1 2 a b c d e f g h i j k l m n o p q}
|
||||
|
||||
test basic-47.14.$noComp {Tcl_EvalEx: expand and memory management} $constraints {
|
||||
run {concat {*}{} a b c d e f g h i j k l m n o p q r s}
|
||||
} {a b c d e f g h i j k l m n o p q r s}
|
||||
|
||||
test basic-47.15.$noComp {Tcl_EvalEx: expand and memory management} $constraints {
|
||||
run {concat {*}1 a b c d e f g h i j k l m n o p q r s}
|
||||
} {1 a b c d e f g h i j k l m n o p q r s}
|
||||
|
||||
test basic-47.16.$noComp {Tcl_EvalEx: expand and memory management} $constraints {
|
||||
run {concat {*}{1 2} a b c d e f g h i j k l m n o p q r s}
|
||||
} {1 2 a b c d e f g h i j k l m n o p q r s}
|
||||
|
||||
test basic-47.17.$noComp {Tcl_EvalEx: expand and memory management} $constraints {
|
||||
run {concat {*}{} {*}{1 2} a b c d e f g h i j k l m n o p q r}
|
||||
} {1 2 a b c d e f g h i j k l m n o p q r}
|
||||
|
||||
test basic-48.1.$noComp {expansion: parsing} $constraints {
|
||||
run { # A comment
|
||||
|
||||
# Another comment
|
||||
list 1 2\
|
||||
3 {*}$::l1
|
||||
|
||||
# Comment again
|
||||
}
|
||||
} {1 2 3 a {b b} c d}
|
||||
|
||||
test basic-48.2.$noComp {no expansion} $constraints {
|
||||
run {list $::l1 $::l2 [l3]}
|
||||
} {{a {b b} c d} {e f {g g} h} {i j k {l l}}}
|
||||
|
||||
test basic-48.3.$noComp {expansion} $constraints {
|
||||
run {list {*}$::l1 $::l2 {*}[l3]}
|
||||
} {a {b b} c d {e f {g g} h} i j k {l l}}
|
||||
|
||||
test basic-48.4.$noComp {expansion: really long cmd} $constraints {
|
||||
set cmd [list list]
|
||||
for {set t 0} {$t < 500} {incr t} {
|
||||
lappend cmd {{*}$::l1}
|
||||
}
|
||||
llength [run [join $cmd]]
|
||||
} 2000
|
||||
|
||||
test basic-48.5.$noComp {expansion: error detection} -setup {
|
||||
set l "a {a b}x y"
|
||||
} -constraints $constraints -body {
|
||||
run {list $::l1 {*}$l}
|
||||
} -cleanup {
|
||||
unset l
|
||||
} -returnCodes 1 -result {list element in braces followed by "x" instead of space}
|
||||
|
||||
test basic-48.6.$noComp {expansion: odd usage} $constraints {
|
||||
run {list {*}$::l1$::l2}
|
||||
} {a {b b} c de f {g g} h}
|
||||
|
||||
test basic-48.7.$noComp {expansion: odd usage} -constraints $constraints -body {
|
||||
run {list {*}[l3]$::l1}
|
||||
} -returnCodes 1 -result {list element in braces followed by "a" instead of space}
|
||||
|
||||
test basic-48.8.$noComp {expansion: odd usage} $constraints {
|
||||
run {list {*}hej$::l1}
|
||||
} {heja {b b} c d}
|
||||
|
||||
test basic-48.9.$noComp {expansion: Not all {*} should trigger} $constraints {
|
||||
run {list {*}$::l1 \{*\}$::l2 "{*}$::l1" {{*} i j k}}
|
||||
} {a {b b} c d {{*}e f {g g} h} {{*}a {b b} c d} {{*} i j k}}
|
||||
|
||||
test basic-48.10.$noComp {expansion: expansion of command word} -setup {
|
||||
set cmd [list string range jultomte]
|
||||
} -constraints $constraints -body {
|
||||
run {{*}$cmd 2 6}
|
||||
} -cleanup {
|
||||
unset cmd
|
||||
} -result ltomt
|
||||
|
||||
test basic-48.11.$noComp {expansion: expansion into nothing} -setup {
|
||||
set cmd {}
|
||||
set bar {}
|
||||
} -constraints $constraints -body {
|
||||
run {{*}$cmd {*}$bar}
|
||||
} -cleanup {
|
||||
unset cmd bar
|
||||
} -result {}
|
||||
|
||||
test basic-48.12.$noComp {expansion: odd usage} $constraints {
|
||||
run {list {*}$::l1 {*}"hej hopp" {*}$::l2}
|
||||
} {a {b b} c d hej hopp e f {g g} h}
|
||||
|
||||
test basic-48.13.$noComp {expansion: odd usage} $constraints {
|
||||
run {list {*}$::l1 {*}{hej hopp} {*}$::l2}
|
||||
} {a {b b} c d hej hopp e f {g g} h}
|
||||
|
||||
test basic-48.14.$noComp {expansion: hash command} -setup {
|
||||
catch {rename \# ""}
|
||||
set cmd "#"
|
||||
} -constraints $constraints -body {
|
||||
run { {*}$cmd apa bepa }
|
||||
} -cleanup {
|
||||
unset cmd
|
||||
} -returnCodes 1 -result {invalid command name "#"}
|
||||
|
||||
test basic-48.15.$noComp {expansion: complex words} -setup {
|
||||
set a(x) [list a {b c} d e]
|
||||
set b x
|
||||
set c [list {f\ g h\ i j k} x y]
|
||||
set d {0\ 1 2 3}
|
||||
} -constraints $constraints -body {
|
||||
run { lappend d {*}$a($b) {*}[lindex $c 0] }
|
||||
} -cleanup {
|
||||
unset a b c d
|
||||
} -result {{0 1} 2 3 a {b c} d e {f g} {h i} j k}
|
||||
|
||||
testConstraint memory [llength [info commands memory]]
|
||||
test basic-48.16.$noComp {expansion: testing for leaks} -setup {
|
||||
proc getbytes {} {
|
||||
set lines [split [memory info] "\n"]
|
||||
lindex [lindex $lines 3] 3
|
||||
}
|
||||
# This test is made to stress the allocation, reallocation and
|
||||
# object reference management in Tcl_EvalEx.
|
||||
proc stress {} {
|
||||
set a x
|
||||
# Create free objects that should disappear
|
||||
set l [list 1$a 2$a 3$a 4$a 5$a 6$a 7$a]
|
||||
# A short number of words and a short result (8)
|
||||
set l [run {list {*}$l $a$a}]
|
||||
# A short number of words and a longer result (27)
|
||||
set l [run {list {*}$l $a$a {*}$l $a$a {*}$l $a$a}]
|
||||
# A short number of words and a longer result, with an error
|
||||
# This is to stress the cleanup in the error case
|
||||
if {![catch {run {_moo_ {*}$l $a$a {*}$l $a$a {*}$l}}]} {
|
||||
error "An error was expected in the previous statement"
|
||||
}
|
||||
# Many words
|
||||
set l [run {list {*}$l $a$a {*}$l $a$a \
|
||||
{*}$l $a$a {*}$l $a$a \
|
||||
{*}$l $a$a {*}$l $a$a \
|
||||
{*}$l $a$a {*}$l $a$a \
|
||||
{*}$l $a$a {*}$l $a$a \
|
||||
{*}$l $a$a {*}$l $a$a \
|
||||
{*}$l $a$a {*}$l $a$a \
|
||||
{*}$l $a$a {*}$l $a$a \
|
||||
{*}$l $a$a {*}$l $a$a \
|
||||
{*}$l $a$a}]
|
||||
|
||||
if {[llength $l] != 19*28} {
|
||||
error "Bad Length: [llength $l] should be [expr {19*28}]"
|
||||
}
|
||||
}
|
||||
} -constraints [linsert $constraints 0 memory] -body {
|
||||
set end [getbytes]
|
||||
for {set i 0} {$i < 5} {incr i} {
|
||||
stress
|
||||
set tmp $end
|
||||
set end [getbytes]
|
||||
}
|
||||
set leak [expr {$end - $tmp}]
|
||||
} -cleanup {
|
||||
unset end i tmp
|
||||
rename getbytes {}
|
||||
rename stress {}
|
||||
} -result 0
|
||||
|
||||
test basic-48.17.$noComp {expansion: object safety} -setup {
|
||||
set old_precision $::tcl_precision
|
||||
set ::tcl_precision 4
|
||||
} -constraints $constraints -body {
|
||||
set third [expr {1.0/3.0}]
|
||||
set l [list $third $third]
|
||||
set x [run {list $third {*}$l $third}]
|
||||
set res [list]
|
||||
foreach t $x {
|
||||
lappend res [expr {$t * 3.0}]
|
||||
}
|
||||
set res
|
||||
} -cleanup {
|
||||
set ::tcl_precision $old_precision
|
||||
unset old_precision res t l x third
|
||||
} -result {1.0 1.0 1.0 1.0}
|
||||
|
||||
test basic-48.18.$noComp {expansion: list semantics} -constraints $constraints -body {
|
||||
set badcmd {
|
||||
list a b
|
||||
set apa 10
|
||||
}
|
||||
set apa 0
|
||||
list [llength [run { {*}$badcmd }]] $apa
|
||||
} -cleanup {
|
||||
unset apa badcmd
|
||||
} -result {5 0}
|
||||
|
||||
test basic-48.19.$noComp {expansion: error checking order} -body {
|
||||
set badlist "a {}x y"
|
||||
set a 0
|
||||
set b 0
|
||||
catch {run {list [incr a] {*}$badlist [incr b]}}
|
||||
list $a $b
|
||||
} -constraints $constraints -cleanup {
|
||||
unset badlist a b
|
||||
} -result {1 0}
|
||||
|
||||
test basic-48.20.$noComp {expansion: odd case with word boundaries} $constraints {
|
||||
run {list {*}$::l1 {*}"hej hopp" {*}$::l2}
|
||||
} {a {b b} c d hej hopp e f {g g} h}
|
||||
|
||||
test basic-48.21.$noComp {expansion: odd case with word boundaries} $constraints {
|
||||
run {list {*}$::l1 {*}{hej hopp} {*}$::l2}
|
||||
} {a {b b} c d hej hopp e f {g g} h}
|
||||
|
||||
test basic-48.22.$noComp {expansion: odd case with word boundaries} -body {
|
||||
run {list {*}$::l1 {*}"hej hopp {*}$::l2}
|
||||
} -constraints $constraints -returnCodes error -result {missing "}
|
||||
|
||||
test basic-48.23.$noComp {expansion: handle return codes} -constraints $constraints -body {
|
||||
set res {}
|
||||
for {set t 0} {$t < 10} {incr t} {
|
||||
run { {*}break }
|
||||
}
|
||||
lappend res $t
|
||||
|
||||
for {set t 0} {$t < 10} {incr t} {
|
||||
run { {*}continue }
|
||||
set t 20
|
||||
}
|
||||
lappend res $t
|
||||
|
||||
lappend res [catch { run { {*}{error Hejsan} } } err]
|
||||
lappend res $err
|
||||
} -cleanup {
|
||||
unset res t
|
||||
} -result {0 10 1 Hejsan}
|
||||
|
||||
} ;# End of noComp loop
|
||||
|
||||
test basic-49.1 {Tcl_EvalEx: verify TCL_EVAL_GLOBAL operation} testevalex {
|
||||
set ::x global
|
||||
namespace eval ns {
|
||||
variable x namespace
|
||||
testevalex {set x changed} global
|
||||
set ::result [list $::x $x]
|
||||
}
|
||||
namespace delete ns
|
||||
set ::result
|
||||
} {changed namespace}
|
||||
test basic-49.2 {Tcl_EvalEx: verify TCL_EVAL_GLOBAL operation} testevalex {
|
||||
set ::x global
|
||||
namespace eval ns {
|
||||
variable x namespace
|
||||
testevalex {set ::context $x} global
|
||||
}
|
||||
namespace delete ns
|
||||
set ::context
|
||||
} {global}
|
||||
|
||||
# Clean up after expand tests
|
||||
unset noComp l1 l2 constraints
|
||||
rename l3 {}
|
||||
rename run {}
|
||||
|
||||
#cleanup
|
||||
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
||||
catch {namespace delete george}
|
||||
catch {interp delete test_interp}
|
||||
catch {rename p ""}
|
||||
catch {rename q ""}
|
||||
catch {rename cmd ""}
|
||||
catch {rename value:at: ""}
|
||||
unset -nocomplain x
|
||||
cleanupTests
|
||||
return
|
||||
2435
tests/binary.test
Normal file
2435
tests/binary.test
Normal file
File diff suppressed because it is too large
Load Diff
89
tests/case.test
Normal file
89
tests/case.test
Normal file
@@ -0,0 +1,89 @@
|
||||
# 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.
|
||||
# Copyright (c) 1994 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
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}}
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
229
tests/chan.test
Normal file
229
tests/chan.test
Normal file
@@ -0,0 +1,229 @@
|
||||
# This file contains a collection of tests for the Tcl built-in 'chan'
|
||||
# command. Sourcing this file into Tcl runs the tests and generates
|
||||
# output for errors. No output means no errors were found.
|
||||
#
|
||||
# Copyright (c) 2005 Donal K. Fellows
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest 2
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
#
|
||||
# Note: The tests for the chan methods "create" and "postevent"
|
||||
# currently reside in the file "ioCmd.test".
|
||||
#
|
||||
|
||||
test chan-1.1 {chan command general syntax} -body {
|
||||
chan
|
||||
} -returnCodes error -result "wrong # args: should be \"chan subcommand ?argument ...?\""
|
||||
test chan-1.2 {chan command general syntax} -body {
|
||||
chan FOOBAR
|
||||
} -returnCodes error -result "unknown or ambiguous subcommand \"FOOBAR\": must be blocked, close, configure, copy, create, eof, event, flush, gets, names, pending, postevent, puts, read, seek, tell, or truncate"
|
||||
|
||||
test chan-2.1 {chan command: blocked subcommand} -body {
|
||||
chan blocked foo bar
|
||||
} -returnCodes error -result "wrong # args: should be \"chan blocked channelId\""
|
||||
|
||||
test chan-3.1 {chan command: close subcommand} -body {
|
||||
chan close foo bar
|
||||
} -returnCodes error -result "wrong # args: should be \"chan close channelId\""
|
||||
|
||||
test chan-4.1 {chan command: configure subcommand} -body {
|
||||
chan configure
|
||||
} -returnCodes error -result "wrong # args: should be \"chan configure channelId ?optionName? ?value? ?optionName value?...\""
|
||||
test chan-4.2 {chan command: [Bug 800753]} -body {
|
||||
chan configure stdout -eofchar \u0100
|
||||
} -returnCodes error -match glob -result {bad value*}
|
||||
test chan-4.3 {chan command: [Bug 800753]} -body {
|
||||
chan configure stdout -eofchar \u0000
|
||||
} -returnCodes error -match glob -result {bad value*}
|
||||
test chan-4.4 {chan command: check valid inValue, no outValue} -body {
|
||||
chan configure stdout -eofchar [list \x27 {}]
|
||||
} -returnCodes ok -result {}
|
||||
test chan-4.5 {chan command: check valid inValue, invalid outValue} -body {
|
||||
chan configure stdout -eofchar [list \x27 \x80]
|
||||
} -returnCodes error -match glob -result {bad value for -eofchar:*}
|
||||
test chan-4.6 {chan command: check no inValue, valid outValue} -body {
|
||||
chan configure stdout -eofchar [list {} \x27]
|
||||
} -returnCodes ok -result {}
|
||||
|
||||
test chan-5.1 {chan command: copy subcommand} -body {
|
||||
chan copy foo
|
||||
} -returnCodes error -result "wrong # args: should be \"chan copy input output ?-size size? ?-command callback?\""
|
||||
|
||||
test chan-6.1 {chan command: eof subcommand} -body {
|
||||
chan eof foo bar
|
||||
} -returnCodes error -result "wrong # args: should be \"chan eof channelId\""
|
||||
|
||||
test chan-7.1 {chan command: event subcommand} -body {
|
||||
chan event foo
|
||||
} -returnCodes error -result "wrong # args: should be \"chan event channelId event ?script?\""
|
||||
|
||||
test chan-8.1 {chan command: flush subcommand} -body {
|
||||
chan flush foo bar
|
||||
} -returnCodes error -result "wrong # args: should be \"chan flush channelId\""
|
||||
|
||||
test chan-9.1 {chan command: gets subcommand} -body {
|
||||
chan gets
|
||||
} -returnCodes error -result "wrong # args: should be \"chan gets channelId ?varName?\""
|
||||
|
||||
test chan-10.1 {chan command: names subcommand} -body {
|
||||
chan names foo bar
|
||||
} -returnCodes error -result "wrong # args: should be \"chan names ?pattern?\""
|
||||
|
||||
test chan-11.1 {chan command: puts subcommand} -body {
|
||||
chan puts foo bar foo bar
|
||||
} -returnCodes error -result "wrong # args: should be \"chan puts ?-nonewline? ?channelId? string\""
|
||||
|
||||
test chan-12.1 {chan command: read subcommand} -body {
|
||||
chan read
|
||||
} -returnCodes error -result "wrong # args: should be \"chan read channelId ?numChars?\" or \"chan read ?-nonewline? channelId\""
|
||||
|
||||
test chan-13.1 {chan command: seek subcommand} -body {
|
||||
chan seek foo bar foo bar
|
||||
} -returnCodes error -result "wrong # args: should be \"chan seek channelId offset ?origin?\""
|
||||
|
||||
test chan-14.1 {chan command: tell subcommand} -body {
|
||||
chan tell foo bar
|
||||
} -returnCodes error -result "wrong # args: should be \"chan tell channelId\""
|
||||
|
||||
test chan-15.1 {chan command: truncate subcommand} -body {
|
||||
chan truncate foo bar foo bar
|
||||
} -returnCodes error -result "wrong \# args: should be \"chan truncate channelId ?length?\""
|
||||
test chan-15.2 {chan command: truncate subcommand} -setup {
|
||||
set file [makeFile {} testTruncate]
|
||||
set f [open $file w+]
|
||||
fconfigure $f -translation binary
|
||||
} -body {
|
||||
seek $f 0
|
||||
puts -nonewline $f 12345
|
||||
seek $f 0
|
||||
chan truncate $f 2
|
||||
read $f
|
||||
} -result 12 -cleanup {
|
||||
catch {close $f}
|
||||
catch {removeFile $file}
|
||||
}
|
||||
|
||||
# TIP 287: chan pending
|
||||
test chan-16.1 {chan command: pending subcommand} -body {
|
||||
chan pending
|
||||
} -returnCodes error -result "wrong # args: should be \"chan pending mode channelId\""
|
||||
test chan-16.2 {chan command: pending subcommand} -body {
|
||||
chan pending stdin
|
||||
} -returnCodes error -result "wrong # args: should be \"chan pending mode channelId\""
|
||||
test chan-16.3 {chan command: pending subcommand} -body {
|
||||
chan pending stdin stdout stderr
|
||||
} -returnCodes error -result "wrong # args: should be \"chan pending mode channelId\""
|
||||
test chan-16.4 {chan command: pending subcommand} -body {
|
||||
chan pending {input output} stdout
|
||||
} -returnCodes error -result "bad mode \"input output\": must be input or output"
|
||||
test chan-16.5 {chan command: pending input subcommand} -body {
|
||||
chan pending input stdout
|
||||
} -result -1
|
||||
test chan-16.6 {chan command: pending input subcommand} -body {
|
||||
chan pending input stdin
|
||||
} -result 0
|
||||
test chan-16.7 {chan command: pending input subcommand} -body {
|
||||
chan pending input FOOBAR
|
||||
} -returnCodes error -result "can not find channel named \"FOOBAR\""
|
||||
test chan-16.8 {chan command: pending input subcommand} -setup {
|
||||
set file [makeFile {} testAvailable]
|
||||
set f [open $file w+]
|
||||
chan configure $f -translation lf -buffering line
|
||||
} -body {
|
||||
chan puts $f foo
|
||||
chan puts $f bar
|
||||
chan puts $f baz
|
||||
chan seek $f 0
|
||||
chan gets $f
|
||||
chan pending input $f
|
||||
} -result 8 -cleanup {
|
||||
catch {chan close $f}
|
||||
catch {removeFile $file}
|
||||
}
|
||||
test chan-16.9 {chan command: pending input subcommand} -setup {
|
||||
proc chan-16.9-accept {sock addr port} {
|
||||
chan configure $sock -blocking 0 -buffering line -buffersize 32
|
||||
chan event $sock readable [list chan-16.9-readable $sock]
|
||||
}
|
||||
|
||||
proc chan-16.9-readable {sock} {
|
||||
set r [chan gets $sock line]
|
||||
set l [string length $line]
|
||||
set e [chan eof $sock]
|
||||
set b [chan blocked $sock]
|
||||
set i [chan pending input $sock]
|
||||
|
||||
lappend ::chan-16.9-data $r $l $e $b $i
|
||||
|
||||
if {$r != -1 || $e || $l || !$b || $i > 128} {
|
||||
set data [read $sock $i]
|
||||
lappend ::chan-16.9-data [string range $data 0 2]
|
||||
lappend ::chan-16.9-data [string range $data end-2 end]
|
||||
set ::chan-16.9-done 1
|
||||
chan event $sock readable {}
|
||||
} else {
|
||||
after idle chan-16.9-client
|
||||
}
|
||||
}
|
||||
|
||||
proc chan-16.9-client {} {
|
||||
chan puts -nonewline $::client ABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890
|
||||
chan flush $::client
|
||||
}
|
||||
|
||||
set ::server [socket -server chan-16.9-accept -myaddr 127.0.0.1 0]
|
||||
set ::client [socket 127.0.0.1 [lindex [fconfigure $::server -sockname] 2]]
|
||||
set ::chan-16.9-data [list]
|
||||
set ::chan-16.9-done 0
|
||||
} -body {
|
||||
after idle chan-16.9-client
|
||||
vwait ::chan-16.9-done
|
||||
set ::chan-16.9-data
|
||||
} -result {-1 0 0 1 36 -1 0 0 1 72 -1 0 0 1 108 -1 0 0 1 144 ABC 890} -cleanup {
|
||||
catch {chan close $client}
|
||||
catch {chan close $server}
|
||||
rename chan-16.9-accept {}
|
||||
rename chan-16.9-readable {}
|
||||
rename chan-16.9-client {}
|
||||
unset -nocomplain ::chan-16.9-data
|
||||
unset -nocomplain ::chan-16.9-done
|
||||
unset -nocomplain ::server
|
||||
unset -nocomplain ::client
|
||||
}
|
||||
test chan-16.10 {chan command: pending output subcommand} -body {
|
||||
chan pending output stdin
|
||||
} -result -1
|
||||
test chan-16.11 {chan command: pending output subcommand} -body {
|
||||
chan pending output stdout
|
||||
} -result 0
|
||||
test chan-16.12 {chan command: pending output subcommand} -body {
|
||||
chan pending output FOOBAR
|
||||
} -returnCodes error -result "can not find channel named \"FOOBAR\""
|
||||
test chan-16.13 {chan command: pending output subcommand} -setup {
|
||||
set file [makeFile {} testPendingOutput]
|
||||
set f [open $file w+]
|
||||
chan configure $f -translation lf -buffering full -buffersize 1024
|
||||
} -body {
|
||||
set result [list]
|
||||
chan puts $f [string repeat x 512]
|
||||
lappend result [chan pending output $f]
|
||||
chan flush $f
|
||||
lappend result [chan pending output $f]
|
||||
} -result [list 513 0] -cleanup {
|
||||
unset -nocomplain result
|
||||
catch {chan close $f}
|
||||
catch {removeFile $file}
|
||||
}
|
||||
|
||||
cleanupTests
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# End:
|
||||
7705
tests/chanio.test
Normal file
7705
tests/chanio.test
Normal file
File diff suppressed because it is too large
Load Diff
36939
tests/clock.test
Normal file
36939
tests/clock.test
Normal file
File diff suppressed because it is too large
Load Diff
1577
tests/cmdAH.test
Normal file
1577
tests/cmdAH.test
Normal file
File diff suppressed because it is too large
Load Diff
797
tests/cmdIL.test
Normal file
797
tests/cmdIL.test
Normal file
@@ -0,0 +1,797 @@
|
||||
# This file contains a collection of tests for the procedures in the
|
||||
# file tclCmdIL.c. Sourcing this file into Tcl runs the tests and
|
||||
# generates output for errors. No output means no errors were found.
|
||||
#
|
||||
# Copyright (c) 1997 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest 2
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
# Used for constraining memory leak tests
|
||||
testConstraint memory [llength [info commands memory]]
|
||||
|
||||
test cmdIL-1.1 {Tcl_LsortObjCmd procedure} {
|
||||
list [catch {lsort} msg] $msg
|
||||
} {1 {wrong # args: should be "lsort ?options? list"}}
|
||||
test cmdIL-1.2 {Tcl_LsortObjCmd procedure} {
|
||||
list [catch {lsort -foo {1 3 2 5}} msg] $msg
|
||||
} {1 {bad option "-foo": must be -ascii, -command, -decreasing, -dictionary, -increasing, -index, -indices, -integer, -nocase, -real, or -unique}}
|
||||
test cmdIL-1.3 {Tcl_LsortObjCmd procedure, default options} {
|
||||
lsort {d e c b a \{ d35 d300}
|
||||
} {a b c d d300 d35 e \{}
|
||||
test cmdIL-1.4 {Tcl_LsortObjCmd procedure, -ascii option} {
|
||||
lsort -integer -ascii {d e c b a d35 d300}
|
||||
} {a b c d d300 d35 e}
|
||||
test cmdIL-1.5 {Tcl_LsortObjCmd procedure, -command option} {
|
||||
list [catch {lsort -command {1 3 2 5}} msg] $msg
|
||||
} {1 {"-command" option must be followed by comparison command}}
|
||||
test cmdIL-1.6 {Tcl_LsortObjCmd procedure, -command option} -setup {
|
||||
proc cmp {a b} {
|
||||
expr {[string match x* $b] - [string match x* $a]}
|
||||
}
|
||||
} -body {
|
||||
lsort -command cmp {x1 abc x2 def x3 x4}
|
||||
} -result {x1 x2 x3 x4 abc def} -cleanup {
|
||||
rename cmp ""
|
||||
}
|
||||
test cmdIL-1.7 {Tcl_LsortObjCmd procedure, -decreasing option} {
|
||||
lsort -decreasing {d e c b a d35 d300}
|
||||
} {e d35 d300 d c b a}
|
||||
test cmdIL-1.8 {Tcl_LsortObjCmd procedure, -dictionary option} {
|
||||
lsort -dictionary {d e c b a d35 d300}
|
||||
} {a b c d d35 d300 e}
|
||||
test cmdIL-1.9 {Tcl_LsortObjCmd procedure, -dictionary option} {
|
||||
lsort -dictionary {1k 0k 10k}
|
||||
} {0k 1k 10k}
|
||||
test cmdIL-1.10 {Tcl_LsortObjCmd procedure, -increasing option} {
|
||||
lsort -decreasing -increasing {d e c b a d35 d300}
|
||||
} {a b c d d300 d35 e}
|
||||
test cmdIL-1.11 {Tcl_LsortObjCmd procedure, -index option} {
|
||||
list [catch {lsort -index {1 3 2 5}} msg] $msg
|
||||
} {1 {"-index" option must be followed by list index}}
|
||||
test cmdIL-1.12 {Tcl_LsortObjCmd procedure, -index option} {
|
||||
list [catch {lsort -index foo {1 3 2 5}} msg] $msg
|
||||
} {1 {bad index "foo": must be integer?[+-]integer? or end?[+-]integer?}}
|
||||
test cmdIL-1.13 {Tcl_LsortObjCmd procedure, -index option} {
|
||||
lsort -index end -integer {{2 25} {10 20 50 100} {3 16 42} 1}
|
||||
} {1 {2 25} {3 16 42} {10 20 50 100}}
|
||||
test cmdIL-1.14 {Tcl_LsortObjCmd procedure, -index option} {
|
||||
lsort -index 1 -integer {{1 25 100} {3 16 42} {10 20 50}}
|
||||
} {{3 16 42} {10 20 50} {1 25 100}}
|
||||
test cmdIL-1.15 {Tcl_LsortObjCmd procedure, -integer option} {
|
||||
lsort -integer {24 6 300 18}
|
||||
} {6 18 24 300}
|
||||
test cmdIL-1.16 {Tcl_LsortObjCmd procedure, -integer option} {
|
||||
list [catch {lsort -integer {1 3 2.4}} msg] $msg
|
||||
} {1 {expected integer but got "2.4"}}
|
||||
test cmdIL-1.17 {Tcl_LsortObjCmd procedure, -real option} {
|
||||
lsort -real {24.2 6e3 150e-1}
|
||||
} {150e-1 24.2 6e3}
|
||||
test cmdIL-1.18 {Tcl_LsortObjCmd procedure, bogus list} {
|
||||
list [catch {lsort "1 2 3 \{ 4"} msg] $msg
|
||||
} {1 {unmatched open brace in list}}
|
||||
test cmdIL-1.19 {Tcl_LsortObjCmd procedure, empty list} {
|
||||
lsort {}
|
||||
} {}
|
||||
test cmdIL-1.22 {Tcl_LsortObjCmd procedure, unique sort} {
|
||||
lsort -integer -unique {3 1 2 3 1 4 3}
|
||||
} {1 2 3 4}
|
||||
test cmdIL-1.23 {Tcl_LsortObjCmd procedure, unique sort with index} {
|
||||
# lsort -unique should return the last unique item
|
||||
lsort -unique -index 0 {{a b} {c b} {a c} {d a}}
|
||||
} {{a c} {c b} {d a}}
|
||||
test cmdIL-1.24 {Tcl_LsortObjCmd procedure, order of -index and -command} -setup {
|
||||
catch {rename 1 ""}
|
||||
proc testcmp {a b} {return [string compare $a $b]}
|
||||
} -body {
|
||||
set l [list [list a b] [list c d]]
|
||||
list [catch {lsort -command testcmp -index 1 $l} msg] $msg
|
||||
} -cleanup {
|
||||
rename testcmp ""
|
||||
} -result [list 0 [list [list a b] [list c d]]]
|
||||
test cmdIL-1.25 {Tcl_LsortObjCmd procedure, order of -index and -command} -setup {
|
||||
catch {rename 1 ""}
|
||||
proc testcmp {a b} {return [string compare $a $b]}
|
||||
} -body {
|
||||
set l [list [list a b] [list c d]]
|
||||
list [catch {lsort -index 1 -command testcmp $l} msg] $msg
|
||||
} -cleanup {
|
||||
rename testcmp ""
|
||||
} -result [list 0 [list [list a b] [list c d]]]
|
||||
# Note that the required order only exists in the end-1'th element;
|
||||
# indexing using the end element or any fixed offset from the start
|
||||
# will not work...
|
||||
test cmdIL-1.26 {Tcl_LsortObjCmd procedure, offset indexing from end} {
|
||||
lsort -index end-1 {{a 1 e i} {b 2 3 f g} {c 4 5 6 d h}}
|
||||
} {{c 4 5 6 d h} {a 1 e i} {b 2 3 f g}}
|
||||
test cmdIL-1.27 {Tcl_LsortObjCmd procedure, returning indices} {
|
||||
lsort -indices {a c b}
|
||||
} {0 2 1}
|
||||
test cmdIL-1.28 {Tcl_LsortObjCmd procedure, returning indices} {
|
||||
lsort -indices -unique -decreasing -real {1.2 34.5 34.5 5.6}
|
||||
} {2 3 0}
|
||||
test cmdIL-1.29 {Tcl_LsortObjCmd procedure, loss of list rep during sorting} {
|
||||
set l {1 2 3}
|
||||
string length [lsort -command {apply {args {string length $::l}}} $l]
|
||||
} 5
|
||||
|
||||
# Can't think of any good tests for the MergeSort and MergeLists
|
||||
# procedures, except a bunch of random lists to sort.
|
||||
|
||||
test cmdIL-2.1 {MergeSort and MergeLists procedures} -setup {
|
||||
set result {}
|
||||
set r 1435753299
|
||||
proc rand {} {
|
||||
global r
|
||||
set r [expr {(16807 * $r) % (0x7fffffff)}]
|
||||
}
|
||||
} -body {
|
||||
for {set i 0} {$i < 150} {incr i} {
|
||||
set x {}
|
||||
for {set j 0} {$j < $i} {incr j} {
|
||||
lappend x [expr {[rand] & 0xfff}]
|
||||
}
|
||||
set y [lsort -integer $x]
|
||||
set old -1
|
||||
foreach el $y {
|
||||
if {$el < $old} {
|
||||
append result "list {$x} sorted to {$y}, element $el out of order\n"
|
||||
break
|
||||
}
|
||||
set old $el
|
||||
}
|
||||
}
|
||||
set result
|
||||
} -cleanup {
|
||||
rename rand ""
|
||||
} -result {}
|
||||
|
||||
test cmdIL-3.1 {SortCompare procedure, skip comparisons after error} -setup {
|
||||
proc cmp {a b} {
|
||||
global x
|
||||
incr x
|
||||
error "error #$x"
|
||||
}
|
||||
} -body {
|
||||
set x 0
|
||||
list [catch {lsort -integer -command cmp {48 6 28 190 16 2 3 6 1}} msg] \
|
||||
$msg $x
|
||||
} -cleanup {
|
||||
rename cmp ""
|
||||
} -result {1 {error #1} 1}
|
||||
test cmdIL-3.2 {SortCompare procedure, -index option} {
|
||||
list [catch {lsort -integer -index 2 "\\\{ {30 40 50}"} msg] $msg
|
||||
} {1 {unmatched open brace in list}}
|
||||
test cmdIL-3.3 {SortCompare procedure, -index option} {
|
||||
list [catch {lsort -integer -index 2 {{20 10} {15 30 40}}} msg] $msg
|
||||
} {1 {element 2 missing from sublist "20 10"}}
|
||||
test cmdIL-3.4 {SortCompare procedure, -index option} {
|
||||
list [catch {lsort -integer -index 2 "{a b c} \\\{"} msg] $msg
|
||||
} {1 {expected integer but got "c"}}
|
||||
test cmdIL-3.4.1 {SortCompare procedure, -index option} {
|
||||
list [catch {lsort -integer -index 2 "{1 2 3} \\\{"} msg] $msg
|
||||
} {1 {unmatched open brace in list}}
|
||||
test cmdIL-3.5 {SortCompare procedure, -index option} {
|
||||
list [catch {lsort -integer -index 2 {{20 10 13} {15}}} msg] $msg
|
||||
} {1 {element 2 missing from sublist "15"}}
|
||||
test cmdIL-3.6 {SortCompare procedure, -index option} {
|
||||
lsort -integer -index 2 {{1 15 30} {2 5 25} {3 25 20}}
|
||||
} {{3 25 20} {2 5 25} {1 15 30}}
|
||||
test cmdIL-3.7 {SortCompare procedure, -ascii option} {
|
||||
lsort -ascii {d e c b a d35 d300 100 20}
|
||||
} {100 20 a b c d d300 d35 e}
|
||||
test cmdIL-3.8 {SortCompare procedure, -dictionary option} {
|
||||
lsort -dictionary {d e c b a d35 d300 100 20}
|
||||
} {20 100 a b c d d35 d300 e}
|
||||
test cmdIL-3.9 {SortCompare procedure, -integer option} {
|
||||
list [catch {lsort -integer {x 3}} msg] $msg
|
||||
} {1 {expected integer but got "x"}}
|
||||
test cmdIL-3.10 {SortCompare procedure, -integer option} {
|
||||
list [catch {lsort -integer {3 q}} msg] $msg
|
||||
} {1 {expected integer but got "q"}}
|
||||
test cmdIL-3.11 {SortCompare procedure, -integer option} {
|
||||
lsort -integer {35 21 0x20 30 0o23 100 8}
|
||||
} {8 0o23 21 30 0x20 35 100}
|
||||
test cmdIL-3.12 {SortCompare procedure, -real option} {
|
||||
list [catch {lsort -real {6...4 3}} msg] $msg
|
||||
} {1 {expected floating-point number but got "6...4"}}
|
||||
test cmdIL-3.13 {SortCompare procedure, -real option} {
|
||||
list [catch {lsort -real {3 1x7}} msg] $msg
|
||||
} {1 {expected floating-point number but got "1x7"}}
|
||||
test cmdIL-3.14 {SortCompare procedure, -real option} {
|
||||
lsort -real {24 2.5e01 16.7 85e-1 10.004}
|
||||
} {85e-1 10.004 16.7 24 2.5e01}
|
||||
test cmdIL-3.15 {SortCompare procedure, -command option} -body {
|
||||
proc cmp {a b} {
|
||||
error "comparison error"
|
||||
}
|
||||
list [catch {lsort -command cmp {48 6}} msg] $msg $::errorInfo
|
||||
} -cleanup {
|
||||
rename cmp ""
|
||||
} -result {1 {comparison error} {comparison error
|
||||
while executing
|
||||
"error "comparison error""
|
||||
(procedure "cmp" line 2)
|
||||
invoked from within
|
||||
"cmp 48 6"
|
||||
(-compare command)
|
||||
invoked from within
|
||||
"lsort -command cmp {48 6}"}}
|
||||
test cmdIL-3.16 {SortCompare procedure, -command option, long command} -body {
|
||||
proc cmp {dummy a b} {
|
||||
string compare $a $b
|
||||
}
|
||||
lsort -command {cmp {this argument is very very long in order to make the dstring overflow its statically allocated space}} {{this first element is also long in order to help expand the dstring} {the second element, last but not least, is quite long also, in order to make absolutely sure that space is allocated dynamically for the dstring}}
|
||||
} -cleanup {
|
||||
rename cmp ""
|
||||
} -result {{the second element, last but not least, is quite long also, in order to make absolutely sure that space is allocated dynamically for the dstring} {this first element is also long in order to help expand the dstring}}
|
||||
test cmdIL-3.17 {SortCompare procedure, -command option, non-integer result} -body {
|
||||
proc cmp {a b} {
|
||||
return foow
|
||||
}
|
||||
list [catch {lsort -command cmp {48 6}} msg] $msg
|
||||
} -cleanup {
|
||||
rename cmp ""
|
||||
} -result {1 {-compare command returned non-integer result}}
|
||||
test cmdIL-3.18 {SortCompare procedure, -command option} -body {
|
||||
proc cmp {a b} {
|
||||
expr {$b - $a}
|
||||
}
|
||||
lsort -command cmp {48 6 18 22 21 35 36}
|
||||
} -cleanup {
|
||||
rename cmp ""
|
||||
} -result {48 36 35 22 21 18 6}
|
||||
test cmdIL-3.19 {SortCompare procedure, -decreasing option} {
|
||||
lsort -decreasing -integer {35 21 0x20 30 0o23 100 8}
|
||||
} {100 35 0x20 30 21 0o23 8}
|
||||
|
||||
test cmdIL-4.1 {DictionaryCompare procedure, numerics, leading zeros} {
|
||||
lsort -dictionary {a003b a03b}
|
||||
} {a03b a003b}
|
||||
test cmdIL-4.2 {DictionaryCompare procedure, numerics, leading zeros} {
|
||||
lsort -dictionary {a3b a03b}
|
||||
} {a3b a03b}
|
||||
test cmdIL-4.3 {DictionaryCompare procedure, numerics, leading zeros} {
|
||||
lsort -dictionary {a3b A03b}
|
||||
} {A03b a3b}
|
||||
test cmdIL-4.4 {DictionaryCompare procedure, numerics, leading zeros} {
|
||||
lsort -dictionary {a3b a03B}
|
||||
} {a3b a03B}
|
||||
test cmdIL-4.5 {DictionaryCompare procedure, numerics, leading zeros} {
|
||||
lsort -dictionary {00000 000}
|
||||
} {000 00000}
|
||||
test cmdIL-4.6 {DictionaryCompare procedure, numerics, different lengths} {
|
||||
lsort -dictionary {a321b a03210b}
|
||||
} {a321b a03210b}
|
||||
test cmdIL-4.7 {DictionaryCompare procedure, numerics, different lengths} {
|
||||
lsort -dictionary {a03210b a321b}
|
||||
} {a321b a03210b}
|
||||
test cmdIL-4.8 {DictionaryCompare procedure, numerics} {
|
||||
lsort -dictionary {48 6a 18b 22a 21aa 35 36}
|
||||
} {6a 18b 21aa 22a 35 36 48}
|
||||
test cmdIL-4.9 {DictionaryCompare procedure, numerics} {
|
||||
lsort -dictionary {a123x a123b}
|
||||
} {a123b a123x}
|
||||
test cmdIL-4.10 {DictionaryCompare procedure, numerics} {
|
||||
lsort -dictionary {a123b a123x}
|
||||
} {a123b a123x}
|
||||
test cmdIL-4.11 {DictionaryCompare procedure, numerics} {
|
||||
lsort -dictionary {a1b aab}
|
||||
} {a1b aab}
|
||||
test cmdIL-4.12 {DictionaryCompare procedure, numerics} {
|
||||
lsort -dictionary {a1b a!b}
|
||||
} {a!b a1b}
|
||||
test cmdIL-4.13 {DictionaryCompare procedure, numerics} {
|
||||
lsort -dictionary {a1b2c a1b1c}
|
||||
} {a1b1c a1b2c}
|
||||
test cmdIL-4.14 {DictionaryCompare procedure, numerics} {
|
||||
lsort -dictionary {a1b2c a1b3c}
|
||||
} {a1b2c a1b3c}
|
||||
test cmdIL-4.15 {DictionaryCompare procedure, long numbers} {
|
||||
lsort -dictionary {a7654884321988762b a7654884321988761b}
|
||||
} {a7654884321988761b a7654884321988762b}
|
||||
test cmdIL-4.16 {DictionaryCompare procedure, long numbers} {
|
||||
lsort -dictionary {a8765488432198876b a7654884321988761b}
|
||||
} {a7654884321988761b a8765488432198876b}
|
||||
test cmdIL-4.17 {DictionaryCompare procedure, case} {
|
||||
lsort -dictionary {aBCd abcc}
|
||||
} {abcc aBCd}
|
||||
test cmdIL-4.18 {DictionaryCompare procedure, case} {
|
||||
lsort -dictionary {aBCd abce}
|
||||
} {aBCd abce}
|
||||
test cmdIL-4.19 {DictionaryCompare procedure, case} {
|
||||
lsort -dictionary {abcd ABcc}
|
||||
} {ABcc abcd}
|
||||
test cmdIL-4.20 {DictionaryCompare procedure, case} {
|
||||
lsort -dictionary {abcd ABce}
|
||||
} {abcd ABce}
|
||||
test cmdIL-4.21 {DictionaryCompare procedure, case} {
|
||||
lsort -dictionary {abCD ABcd}
|
||||
} {ABcd abCD}
|
||||
test cmdIL-4.22 {DictionaryCompare procedure, case} {
|
||||
lsort -dictionary {ABcd aBCd}
|
||||
} {ABcd aBCd}
|
||||
test cmdIL-4.23 {DictionaryCompare procedure, case} {
|
||||
lsort -dictionary {ABcd AbCd}
|
||||
} {ABcd AbCd}
|
||||
test cmdIL-4.24 {DictionaryCompare procedure, international characters} {hasIsoLocale} {
|
||||
::tcltest::set_iso8859_1_locale
|
||||
set result [lsort -dictionary "a b c A B C \xe3 \xc4"]
|
||||
::tcltest::restore_locale
|
||||
set result
|
||||
} "A a B b C c \xe3 \xc4"
|
||||
test cmdIL-4.25 {DictionaryCompare procedure, international characters} {hasIsoLocale} {
|
||||
::tcltest::set_iso8859_1_locale
|
||||
set result [lsort -dictionary "a23\xe3 a23\xc5 a23\xe4"]
|
||||
::tcltest::restore_locale
|
||||
set result
|
||||
} "a23\xe3 a23\xe4 a23\xc5"
|
||||
test cmdIL-4.26 {DefaultCompare procedure, signed characters} {
|
||||
set l [lsort [list "abc\200" "abc"]]
|
||||
set viewlist {}
|
||||
foreach s $l {
|
||||
set viewelem ""
|
||||
set len [string length $s]
|
||||
for {set i 0} {$i < $len} {incr i} {
|
||||
set c [string index $s $i]
|
||||
scan $c %c d
|
||||
if {$d > 0 && $d < 128} {
|
||||
append viewelem $c
|
||||
} else {
|
||||
append viewelem "\\[format %03o $d]"
|
||||
}
|
||||
}
|
||||
lappend viewlist $viewelem
|
||||
}
|
||||
set viewlist
|
||||
} [list "abc" "abc\\200"]
|
||||
test cmdIL-4.27 {DictionaryCompare procedure, signed characters} {
|
||||
set l [lsort -dictionary [list "abc\200" "abc"]]
|
||||
set viewlist {}
|
||||
foreach s $l {
|
||||
set viewelem ""
|
||||
set len [string length $s]
|
||||
for {set i 0} {$i < $len} {incr i} {
|
||||
set c [string index $s $i]
|
||||
scan $c %c d
|
||||
if {$d > 0 && $d < 128} {
|
||||
append viewelem $c
|
||||
} else {
|
||||
append viewelem "\\[format %03o $d]"
|
||||
}
|
||||
}
|
||||
lappend viewlist $viewelem
|
||||
}
|
||||
set viewlist
|
||||
} [list "abc" "abc\\200"]
|
||||
test cmdIL-4.28 {DictionaryCompare procedure, chars between Z and a in ASCII} {
|
||||
lsort -dictionary [list AA ` c CC]
|
||||
} [list ` AA c CC]
|
||||
test cmdIL-4.29 {DictionaryCompare procedure, chars between Z and a in ASCII} {
|
||||
lsort -dictionary [list AA ` c ^ \\ CC \[ \]]
|
||||
} [list \[ \\ \] ^ ` AA c CC]
|
||||
test cmdIL-4.30 {DictionaryCompare procedure, chars between Z and a in ASCII} {
|
||||
lsort -dictionary [list AA ` c ^ _ \\ CC \[ dude \] funky]
|
||||
} [list \[ \\ \] ^ _ ` AA c CC dude funky]
|
||||
test cmdIL-4.31 {DictionaryCompare procedure, chars between Z and a in ASCII} {
|
||||
lsort -dictionary [list AA c ` CC]
|
||||
} [list ` AA c CC]
|
||||
test cmdIL-4.32 {DictionaryCompare procedure, chars between Z and a in ASCII} {
|
||||
lsort -dictionary [list AA c CC `]
|
||||
} [list ` AA c CC]
|
||||
test cmdIL-4.33 {DictionaryCompare procedure, chars between Z and a in ASCII} {
|
||||
lsort -dictionary [list AA ! c CC `]
|
||||
} [list ! ` AA c CC]
|
||||
test cmdIL-4.34 {SortCompare procedure, -ascii option with -nocase option} {
|
||||
lsort -ascii -nocase {d e c b a d35 d300 100 20}
|
||||
} {100 20 a b c d d300 d35 e}
|
||||
test cmdIL-4.35 {SortCompare procedure, -ascii option with -nocase option} {
|
||||
lsort -ascii -nocase {d E c B a D35 d300 100 20}
|
||||
} {100 20 a B c d d300 D35 E}
|
||||
test cmdIL-4.36 {SortCompare procedure, UTF-8 with -nocase option} {
|
||||
scan [lsort -ascii -nocase [list \u101 \u100]] %c%c%c
|
||||
} {257 32 256}
|
||||
test cmdIL-4.37 {SortCompare procedure, UTF-8 with -nocase option} {
|
||||
scan [lsort -ascii -nocase [list a\u0000a a]] %c%c%c%c%c
|
||||
} {97 32 97 0 97}
|
||||
test cmdIL-4.38 {SortCompare procedure, UTF-8 with -nocase option} {
|
||||
scan [lsort -ascii -nocase [list a a\u0000a]] %c%c%c%c%c
|
||||
} {97 32 97 0 97}
|
||||
|
||||
test cmdIL-5.1 {lsort with list style index} {
|
||||
lsort -ascii -decreasing -index {0 1} {
|
||||
{{Jim Alpha} 20000410}
|
||||
{{Joe Bravo} 19990320}
|
||||
{{Jacky Charlie} 19390911}
|
||||
}
|
||||
} {{{Jacky Charlie} 19390911} {{Joe Bravo} 19990320} {{Jim Alpha} 20000410}}
|
||||
test cmdIL-5.2 {lsort with list style index} {
|
||||
lsort -decreasing -index {0 1} {
|
||||
{{Jim Alpha} 20000410}
|
||||
{{Joe Bravo} 19990320}
|
||||
{{Jacky Charlie} 19390911}
|
||||
}
|
||||
} {{{Jacky Charlie} 19390911} {{Joe Bravo} 19990320} {{Jim Alpha} 20000410}}
|
||||
test cmdIL-5.3 {lsort with list style index} {
|
||||
lsort -integer -increasing -index {1 end} {
|
||||
{{Jim Alpha} 20000410}
|
||||
{{Joe Bravo} 19990320}
|
||||
{{Jacky Charlie} 19390911}
|
||||
}
|
||||
} {{{Jacky Charlie} 19390911} {{Joe Bravo} 19990320} {{Jim Alpha} 20000410}}
|
||||
test cmdIL-5.4 {lsort with list style index} {
|
||||
lsort -integer -index {1 end-1} {
|
||||
{the {0 1 2 3 4 5} quick}
|
||||
{brown {0 1 2 3 4} fox}
|
||||
{jumps {30 31 2 33} over}
|
||||
{the {0 1 2} lazy}
|
||||
{dogs {0 1}}
|
||||
}
|
||||
} {{dogs {0 1}} {the {0 1 2} lazy} {jumps {30 31 2 33} over} {brown {0 1 2 3 4} fox} {the {0 1 2 3 4 5} quick}}
|
||||
test cmdIL-5.5 {lsort with list style index and sharing} -body {
|
||||
proc test_lsort {l} {
|
||||
set n $l
|
||||
foreach e $l {lappend n [list [expr {rand()}] $e]}
|
||||
lindex [lsort -real -index $l $n] 1 1
|
||||
}
|
||||
expr srand(1)
|
||||
test_lsort 0
|
||||
} -result 0 -cleanup {
|
||||
rename test_lsort ""
|
||||
}
|
||||
|
||||
# Compiled version
|
||||
test cmdIL-6.1 {lassign command syntax} -body {
|
||||
proc testLassign {} {
|
||||
lassign
|
||||
}
|
||||
testLassign
|
||||
} -returnCodes 1 -cleanup {
|
||||
rename testLassign {}
|
||||
} -result {wrong # args: should be "lassign list varName ?varName ...?"}
|
||||
test cmdIL-6.2 {lassign command syntax} -body {
|
||||
proc testLassign {} {
|
||||
lassign x
|
||||
}
|
||||
testLassign
|
||||
} -returnCodes 1 -cleanup {
|
||||
rename testLassign {}
|
||||
} -result {wrong # args: should be "lassign list varName ?varName ...?"}
|
||||
test cmdIL-6.3 {lassign command} -body {
|
||||
proc testLassign {} {
|
||||
set x FAIL
|
||||
list [lassign a x] $x
|
||||
}
|
||||
testLassign
|
||||
} -result {{} a} -cleanup {
|
||||
rename testLassign {}
|
||||
}
|
||||
test cmdIL-6.4 {lassign command} -body {
|
||||
proc testLassign {} {
|
||||
set x FAIL
|
||||
set y FAIL
|
||||
list [lassign a x y] $x $y
|
||||
}
|
||||
testLassign
|
||||
} -result {{} a {}} -cleanup {
|
||||
rename testLassign {}
|
||||
}
|
||||
test cmdIL-6.5 {lassign command} -body {
|
||||
proc testLassign {} {
|
||||
set x FAIL
|
||||
set y FAIL
|
||||
list [lassign {a b} x y] $x $y
|
||||
}
|
||||
testLassign
|
||||
} -result {{} a b} -cleanup {
|
||||
rename testLassign {}
|
||||
}
|
||||
test cmdIL-6.6 {lassign command} -body {
|
||||
proc testLassign {} {
|
||||
set x FAIL
|
||||
set y FAIL
|
||||
list [lassign {a b c} x y] $x $y
|
||||
}
|
||||
testLassign
|
||||
} -result {c a b} -cleanup {
|
||||
rename testLassign {}
|
||||
}
|
||||
test cmdIL-6.7 {lassign command} -body {
|
||||
proc testLassign {} {
|
||||
set x FAIL
|
||||
set y FAIL
|
||||
list [lassign {a b c d} x y] $x $y
|
||||
}
|
||||
testLassign
|
||||
} -result {{c d} a b} -cleanup {
|
||||
rename testLassign {}
|
||||
}
|
||||
test cmdIL-6.8 {lassign command - list format error} -body {
|
||||
proc testLassign {} {
|
||||
set x FAIL
|
||||
set y FAIL
|
||||
list [catch {lassign {a {b}c d} x y} msg] $msg $x $y
|
||||
}
|
||||
testLassign
|
||||
} -result {1 {list element in braces followed by "c" instead of space} FAIL FAIL} -cleanup {
|
||||
rename testLassign {}
|
||||
}
|
||||
test cmdIL-6.9 {lassign command - assignment to arrays} -body {
|
||||
proc testLassign {} {
|
||||
list [lassign {a b} x(x)] $x(x)
|
||||
}
|
||||
testLassign
|
||||
} -result {b a} -cleanup {
|
||||
rename testLassign {}
|
||||
}
|
||||
test cmdIL-6.10 {lassign command - variable update error} -body {
|
||||
proc testLassign {} {
|
||||
set x(x) {}
|
||||
lassign a x
|
||||
}
|
||||
testLassign
|
||||
} -returnCodes 1 -result {can't set "x": variable is array} -cleanup {
|
||||
rename testLassign {}
|
||||
}
|
||||
test cmdIL-6.11 {lassign command - variable update error} -body {
|
||||
proc testLassign {} {
|
||||
set x(x) {}
|
||||
set y FAIL
|
||||
list [catch {lassign a y x} msg] $msg $y
|
||||
}
|
||||
testLassign
|
||||
} -result {1 {can't set "x": variable is array} a} -cleanup {
|
||||
rename testLassign {}
|
||||
}
|
||||
test cmdIL-6.12 {lassign command - memory leak testing} -setup {
|
||||
unset -nocomplain x y
|
||||
set x(x) {}
|
||||
set y FAIL
|
||||
proc getbytes {} {
|
||||
set lines [split [memory info] "\n"]
|
||||
lindex [lindex $lines 3] 3
|
||||
}
|
||||
proc stress {} {
|
||||
global x y
|
||||
lassign {} y y y y y y y y y y y y y y y y y y y y y y y y y y y y y y
|
||||
catch {lassign {} y y y y y y y y y y y y y y y y y y y y y y y y y x}
|
||||
catch {lassign {} x}
|
||||
}
|
||||
} -constraints memory -body {
|
||||
set end [getbytes]
|
||||
for {set i 0} {$i < 5} {incr i} {
|
||||
stress
|
||||
set tmp $end
|
||||
set end [getbytes]
|
||||
}
|
||||
expr {$end - $tmp}
|
||||
} -result 0 -cleanup {
|
||||
unset -nocomplain x y i tmp end
|
||||
rename getbytes {}
|
||||
rename stress {}
|
||||
}
|
||||
# Force non-compiled version
|
||||
test cmdIL-6.13 {lassign command syntax} -body {
|
||||
proc testLassign {} {
|
||||
set lassign lassign
|
||||
$lassign
|
||||
}
|
||||
testLassign
|
||||
} -returnCodes 1 -cleanup {
|
||||
rename testLassign {}
|
||||
} -result {wrong # args: should be "lassign list varName ?varName ...?"}
|
||||
test cmdIL-6.14 {lassign command syntax} -body {
|
||||
proc testLassign {} {
|
||||
set lassign lassign
|
||||
$lassign x
|
||||
}
|
||||
testLassign
|
||||
} -returnCodes 1 -cleanup {
|
||||
rename testLassign {}
|
||||
} -result {wrong # args: should be "lassign list varName ?varName ...?"}
|
||||
test cmdIL-6.15 {lassign command} -body {
|
||||
proc testLassign {} {
|
||||
set lassign lassign
|
||||
set x FAIL
|
||||
list [$lassign a x] $x
|
||||
}
|
||||
testLassign
|
||||
} -result {{} a} -cleanup {
|
||||
rename testLassign {}
|
||||
}
|
||||
test cmdIL-6.16 {lassign command} -body {
|
||||
proc testLassign {} {
|
||||
set lassign lassign
|
||||
set x FAIL
|
||||
set y FAIL
|
||||
list [$lassign a x y] $x $y
|
||||
}
|
||||
testLassign
|
||||
} -result {{} a {}} -cleanup {
|
||||
rename testLassign {}
|
||||
}
|
||||
test cmdIL-6.17 {lassign command} -body {
|
||||
proc testLassign {} {
|
||||
set lassign lassign
|
||||
set x FAIL
|
||||
set y FAIL
|
||||
list [$lassign {a b} x y] $x $y
|
||||
}
|
||||
testLassign
|
||||
} -result {{} a b} -cleanup {
|
||||
rename testLassign {}
|
||||
}
|
||||
test cmdIL-6.18 {lassign command} -body {
|
||||
proc testLassign {} {
|
||||
set lassign lassign
|
||||
set x FAIL
|
||||
set y FAIL
|
||||
list [$lassign {a b c} x y] $x $y
|
||||
}
|
||||
testLassign
|
||||
} -result {c a b} -cleanup {
|
||||
rename testLassign {}
|
||||
}
|
||||
test cmdIL-6.19 {lassign command} -body {
|
||||
proc testLassign {} {
|
||||
set lassign lassign
|
||||
set x FAIL
|
||||
set y FAIL
|
||||
list [$lassign {a b c d} x y] $x $y
|
||||
}
|
||||
testLassign
|
||||
} -result {{c d} a b} -cleanup {
|
||||
rename testLassign {}
|
||||
}
|
||||
test cmdIL-6.20 {lassign command - list format error} -body {
|
||||
proc testLassign {} {
|
||||
set lassign lassign
|
||||
set x FAIL
|
||||
set y FAIL
|
||||
list [catch {$lassign {a {b}c d} x y} msg] $msg $x $y
|
||||
}
|
||||
testLassign
|
||||
} -result {1 {list element in braces followed by "c" instead of space} FAIL FAIL} -cleanup {
|
||||
rename testLassign {}
|
||||
}
|
||||
test cmdIL-6.21 {lassign command - assignment to arrays} -body {
|
||||
proc testLassign {} {
|
||||
set lassign lassign
|
||||
list [$lassign {a b} x(x)] $x(x)
|
||||
}
|
||||
testLassign
|
||||
} -result {b a} -cleanup {
|
||||
rename testLassign {}
|
||||
}
|
||||
test cmdIL-6.22 {lassign command - variable update error} -body {
|
||||
proc testLassign {} {
|
||||
set lassign lassign
|
||||
set x(x) {}
|
||||
$lassign a x
|
||||
}
|
||||
testLassign
|
||||
} -returnCodes 1 -result {can't set "x": variable is array} -cleanup {
|
||||
rename testLassign {}
|
||||
}
|
||||
test cmdIL-6.23 {lassign command - variable update error} -body {
|
||||
proc testLassign {} {
|
||||
set lassign lassign
|
||||
set x(x) {}
|
||||
set y FAIL
|
||||
list [catch {$lassign a y x} msg] $msg $y
|
||||
}
|
||||
testLassign
|
||||
} -result {1 {can't set "x": variable is array} a} -cleanup {
|
||||
rename testLassign {}
|
||||
}
|
||||
test cmdIL-6.24 {lassign command - memory leak testing} -setup {
|
||||
set x(x) {}
|
||||
set y FAIL
|
||||
proc getbytes {} {
|
||||
set lines [split [memory info] "\n"]
|
||||
lindex [lindex $lines 3] 3
|
||||
}
|
||||
proc stress {} {
|
||||
global x y
|
||||
set lassign lassign
|
||||
$lassign {} y y y y y y y y y y y y y y y y y y y y y y y y y y y y y y
|
||||
catch {$lassign {} y y y y y y y y y y y y y y y y y y y y y y y y y x}
|
||||
catch {$lassign {} x}
|
||||
}
|
||||
} -constraints memory -body {
|
||||
set end [getbytes]
|
||||
for {set i 0} {$i < 5} {incr i} {
|
||||
stress
|
||||
set tmp $end
|
||||
set end [getbytes]
|
||||
}
|
||||
expr {$end - $tmp}
|
||||
} -result 0 -cleanup {
|
||||
unset -nocomplain x y i tmp end
|
||||
rename getbytes {}
|
||||
rename stress {}
|
||||
}
|
||||
# Assorted shimmering problems
|
||||
test cmdIL-6.25 {lassign command - shimmering protection} -body {
|
||||
proc testLassign {} {
|
||||
set x {a b c}
|
||||
list [lassign $x $x y] $x [set $x] $y
|
||||
}
|
||||
testLassign
|
||||
} -result {c {a b c} a b} -cleanup {
|
||||
rename testLassign {}
|
||||
}
|
||||
test cmdIL-6.26 {lassign command - shimmering protection} -body {
|
||||
proc testLassign {} {
|
||||
set x {a b c}
|
||||
set lassign lassign
|
||||
list [$lassign $x $x y] $x [set $x] $y
|
||||
}
|
||||
testLassign
|
||||
} -result {c {a b c} a b} -cleanup {
|
||||
rename testLassign {}
|
||||
}
|
||||
|
||||
test cmdIL-7.1 {lreverse command} -body {
|
||||
lreverse
|
||||
} -returnCodes error -result "wrong # args: should be \"lreverse list\""
|
||||
test cmdIL-7.2 {lreverse command} -body {
|
||||
lreverse a b
|
||||
} -returnCodes error -result "wrong # args: should be \"lreverse list\""
|
||||
test cmdIL-7.3 {lreverse command} -body {
|
||||
lreverse "not \{a list"
|
||||
} -returnCodes error -result {unmatched open brace in list}
|
||||
test cmdIL-7.4 {lreverse command - shared object} {
|
||||
set x {a b {c d} e f}
|
||||
lreverse $x
|
||||
} {f e {c d} b a}
|
||||
test cmdIL-7.5 {lreverse command - unshared object} {
|
||||
lreverse [list a b {c d} e f]
|
||||
} {f e {c d} b a}
|
||||
test cmdIL-7.6 {lreverse command - unshared object [Bug 1672585]} {
|
||||
lreverse [set x {1 2 3}][unset x]
|
||||
} {3 2 1}
|
||||
test cmdIL-7.7 {lreverse command - empty object [Bug 1876793]} {
|
||||
lreverse [list]
|
||||
} {}
|
||||
|
||||
testConstraint testobj [llength [info commands testobj]]
|
||||
test cmdIL-7.8 {lreverse command - shared intrep [Bug 1675044]} -setup {
|
||||
teststringobj set 1 {1 2 3}
|
||||
testobj convert 1 list
|
||||
testobj duplicate 1 2
|
||||
variable x [teststringobj get 1]
|
||||
variable y [teststringobj get 2]
|
||||
testobj freeallvars
|
||||
proc K {a b} {return $a}
|
||||
} -constraints testobj -body {
|
||||
lreverse [K $y [unset y]]
|
||||
lindex $x 0
|
||||
} -cleanup {
|
||||
unset -nocomplain x y
|
||||
rename K {}
|
||||
} -result 1
|
||||
|
||||
# This belongs in info test, but adding tests there breaks tests
|
||||
# that compute source file line numbers.
|
||||
test info-20.6 {Bug 3587651} -setup {
|
||||
namespace eval my {namespace eval tcl {namespace eval mathfunc {
|
||||
proc demo x {return 42}
|
||||
}}}} -body { namespace eval my {expr {"demo" in [info functions]}}} -cleanup {
|
||||
namespace delete my
|
||||
} -result 1
|
||||
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# End:
|
||||
104
tests/cmdInfo.test
Normal file
104
tests/cmdInfo.test
Normal file
@@ -0,0 +1,104 @@
|
||||
# Commands covered: none
|
||||
#
|
||||
# This file contains a collection of tests for Tcl_GetCommandInfo,
|
||||
# Tcl_SetCommandInfo, Tcl_CreateCommand, Tcl_DeleteCommand, and
|
||||
# Tcl_NameOfCommand. 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.
|
||||
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
package require tcltest 2
|
||||
namespace import ::tcltest::*
|
||||
|
||||
testConstraint testcmdinfo [llength [info commands testcmdinfo]]
|
||||
testConstraint testcmdtoken [llength [info commands testcmdtoken]]
|
||||
|
||||
test cmdinfo-1.1 {command procedure and clientData} {testcmdinfo} {
|
||||
testcmdinfo create x1
|
||||
testcmdinfo get x1
|
||||
} {CmdProc1 original CmdDelProc1 original :: stringProc}
|
||||
test cmdinfo-1.2 {command procedure and clientData} {testcmdinfo} {
|
||||
testcmdinfo create x1
|
||||
x1
|
||||
} {CmdProc1 original}
|
||||
test cmdinfo-1.3 {command procedure and clientData} {testcmdinfo} {
|
||||
testcmdinfo create x1
|
||||
testcmdinfo modify x1
|
||||
testcmdinfo get x1
|
||||
} {CmdProc2 new_command_data CmdDelProc2 new_delete_data :: stringProc}
|
||||
test cmdinfo-1.4 {command procedure and clientData} {testcmdinfo} {
|
||||
testcmdinfo create x1
|
||||
testcmdinfo modify x1
|
||||
x1
|
||||
} {CmdProc2 new_command_data}
|
||||
|
||||
test cmdinfo-2.1 {command deletion callbacks} {testcmdinfo} {
|
||||
testcmdinfo create x1
|
||||
testcmdinfo delete x1
|
||||
} {CmdDelProc1 original}
|
||||
test cmdinfo-2.2 {command deletion callbacks} {testcmdinfo} {
|
||||
testcmdinfo create x1
|
||||
testcmdinfo modify x1
|
||||
testcmdinfo delete x1
|
||||
} {CmdDelProc2 new_delete_data}
|
||||
|
||||
test cmdinfo-3.1 {Tcl_Get/SetCommandInfo return values} {testcmdinfo} {
|
||||
testcmdinfo get non_existent
|
||||
} {??}
|
||||
test cmdinfo-3.2 {Tcl_Get/SetCommandInfo return values} {testcmdinfo} {
|
||||
testcmdinfo create x1
|
||||
testcmdinfo modify x1
|
||||
} 1
|
||||
test cmdinfo-3.3 {Tcl_Get/SetCommandInfo return values} {testcmdinfo} {
|
||||
testcmdinfo modify non_existent
|
||||
} 0
|
||||
|
||||
test cmdinfo-4.1 {Tcl_GetCommandName/Tcl_GetCommandFullName procedures} \
|
||||
{testcmdtoken} {
|
||||
set x [testcmdtoken create x1]
|
||||
rename x1 newName
|
||||
set y [testcmdtoken name $x]
|
||||
rename newName x1
|
||||
lappend y {*}[testcmdtoken name $x]
|
||||
} {newName ::newName x1 ::x1}
|
||||
|
||||
catch {rename newTestCmd {}}
|
||||
catch {rename newTestCmd2 {}}
|
||||
|
||||
test cmdinfo-5.1 {Names for commands created when inside namespaces} \
|
||||
{testcmdtoken} {
|
||||
# create namespace cmdInfoNs1
|
||||
namespace eval cmdInfoNs1 {} ;# creates namespace cmdInfoNs1
|
||||
# create namespace cmdInfoNs1::cmdInfoNs2 and execute a script in it
|
||||
set x [namespace eval cmdInfoNs1::cmdInfoNs2 {
|
||||
# the following creates a cmd in the global namespace
|
||||
testcmdtoken create testCmd
|
||||
}]
|
||||
set y [testcmdtoken name $x]
|
||||
rename ::testCmd newTestCmd
|
||||
lappend y {*}[testcmdtoken name $x]
|
||||
} {testCmd ::testCmd newTestCmd ::newTestCmd}
|
||||
|
||||
test cmdinfo-6.1 {Names for commands created when outside namespaces} \
|
||||
{testcmdtoken} {
|
||||
set x [testcmdtoken create cmdInfoNs1::cmdInfoNs2::testCmd]
|
||||
set y [testcmdtoken name $x]
|
||||
rename cmdInfoNs1::cmdInfoNs2::testCmd newTestCmd2
|
||||
lappend y {*}[testcmdtoken name $x]
|
||||
} {testCmd ::cmdInfoNs1::cmdInfoNs2::testCmd newTestCmd2 ::newTestCmd2}
|
||||
|
||||
# cleanup
|
||||
catch {namespace delete cmdInfoNs1::cmdInfoNs2 cmdInfoNs1}
|
||||
catch {rename x1 ""}
|
||||
cleanupTests
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# End:
|
||||
356
tests/cmdMZ.test
Normal file
356
tests/cmdMZ.test
Normal file
@@ -0,0 +1,356 @@
|
||||
# The tests in this file cover the procedures in tclCmdMZ.c.
|
||||
#
|
||||
# This file contains a collection of tests for one or more of the Tcl
|
||||
# built-in commands. Sourcing this file into Tcl runs the tests and
|
||||
# generates output for errors. No output means no errors were found.
|
||||
#
|
||||
# Copyright (c) 1991-1993 The Regents of the University of California.
|
||||
# Copyright (c) 1994 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[catch {package require tcltest 2.1}]} {
|
||||
puts stderr "Skipping tests in [info script]. tcltest 2.1 required."
|
||||
return
|
||||
}
|
||||
|
||||
namespace eval ::tcl::test::cmdMZ {
|
||||
namespace import ::tcltest::cleanupTests
|
||||
namespace import ::tcltest::customMatch
|
||||
namespace import ::tcltest::makeFile
|
||||
namespace import ::tcltest::removeFile
|
||||
namespace import ::tcltest::temporaryDirectory
|
||||
namespace import ::tcltest::test
|
||||
|
||||
# Tcl_PwdObjCmd
|
||||
|
||||
test cmdMZ-1.1 {Tcl_PwdObjCmd} {
|
||||
list [catch {pwd a} msg] $msg
|
||||
} {1 {wrong # args: should be "pwd"}}
|
||||
test cmdMZ-1.2 {Tcl_PwdObjCmd: simple pwd} {
|
||||
catch pwd
|
||||
} 0
|
||||
test cmdMZ-1.3 {Tcl_PwdObjCmd: simple pwd} {
|
||||
expr [string length pwd]>0
|
||||
} 1
|
||||
test cmdMZ-1.4 {Tcl_PwdObjCmd: failure} {unix nonPortable} {
|
||||
# This test fails on various unix platforms (eg Linux) where
|
||||
# permissions caching causes this to fail. The caching is strictly
|
||||
# incorrect, but we have no control over that.
|
||||
set foodir [file join [temporaryDirectory] foo]
|
||||
file delete -force $foodir
|
||||
file mkdir $foodir
|
||||
set cwd [pwd]
|
||||
cd $foodir
|
||||
file attr . -permissions 000
|
||||
set result [list [catch {pwd} msg] $msg]
|
||||
cd $cwd
|
||||
file delete -force $foodir
|
||||
set result
|
||||
} {1 {error getting working directory name: permission denied}}
|
||||
|
||||
# The tests for Tcl_RegexpObjCmd, Tcl_RegsubObjCmd are in regexp.test
|
||||
|
||||
# Tcl_RenameObjCmd
|
||||
|
||||
test cmdMZ-2.1 {Tcl_RenameObjCmd: error conditions} {
|
||||
list [catch {rename r1} msg] $msg $::errorCode
|
||||
} {1 {wrong # args: should be "rename oldName newName"} NONE}
|
||||
test cmdMZ-2.2 {Tcl_RenameObjCmd: error conditions} {
|
||||
list [catch {rename r1 r2 r3} msg] $msg $::errorCode
|
||||
} {1 {wrong # args: should be "rename oldName newName"} NONE}
|
||||
test cmdMZ-2.3 {Tcl_RenameObjCmd: success} {
|
||||
catch {rename r2 {}}
|
||||
proc r1 {} {return "r1"}
|
||||
rename r1 r2
|
||||
r2
|
||||
} {r1}
|
||||
test cmdMZ-2.4 {Tcl_RenameObjCmd: success} {
|
||||
proc r1 {} {return "r1"}
|
||||
rename r1 {}
|
||||
list [catch {r1} msg] $msg
|
||||
} {1 {invalid command name "r1"}}
|
||||
|
||||
# Some tests for Tcl_ReturnObjCmd are in proc-old.test
|
||||
|
||||
test cmdMZ-return-1.0 {return checks for bad option values} -body {
|
||||
return -options foo
|
||||
} -returnCodes error -match glob -result {bad -options value:*}
|
||||
test cmdMZ-return-1.1 {return checks for bad option values} -body {
|
||||
return -code foo
|
||||
} -returnCodes error -match glob -result {bad completion code*}
|
||||
test cmdMZ-return-1.2 {return checks for bad option values} -body {
|
||||
return -code 0x100000000
|
||||
} -returnCodes error -match glob -result {bad completion code*}
|
||||
test cmdMZ-return-1.3 {return checks for bad option values} -body {
|
||||
return -level foo
|
||||
} -returnCodes error -match glob -result {bad -level value:*}
|
||||
test cmdMZ-return-1.4 {return checks for bad option values} -body {
|
||||
return -level -1
|
||||
} -returnCodes error -match glob -result {bad -level value:*}
|
||||
test cmdMZ-return-1.5 {return checks for bad option values} -body {
|
||||
return -level 3.1415926
|
||||
} -returnCodes error -match glob -result {bad -level value:*}
|
||||
|
||||
proc dictSort {d} {
|
||||
foreach k [lsort [dict keys $d]] {
|
||||
lappend result $k [dict get $d $k]
|
||||
}
|
||||
return $result
|
||||
}
|
||||
|
||||
test cmdMZ-return-2.0 {return option handling} {
|
||||
list [catch return -> foo] [dictSort $foo]
|
||||
} {2 {-code 0 -level 1}}
|
||||
test cmdMZ-return-2.1 {return option handling} {
|
||||
list [catch {return -bar soom} -> foo] [dictSort $foo]
|
||||
} {2 {-bar soom -code 0 -level 1}}
|
||||
test cmdMZ-return-2.2 {return option handling} {
|
||||
list [catch {return -code return} -> foo] [dictSort $foo]
|
||||
} {2 {-code 0 -level 2}}
|
||||
test cmdMZ-return-2.3 {return option handling} {
|
||||
list [catch {return -code return -level 10} -> foo] [dictSort $foo]
|
||||
} {2 {-code 0 -level 11}}
|
||||
test cmdMZ-return-2.4 {return option handling} -body {
|
||||
return -level 0 -code error
|
||||
} -returnCodes error -result {}
|
||||
test cmdMZ-return-2.5 {return option handling} -body {
|
||||
return -level 0 -code return
|
||||
} -returnCodes return -result {}
|
||||
test cmdMZ-return-2.6 {return option handling} -body {
|
||||
return -level 0 -code break
|
||||
} -returnCodes break -result {}
|
||||
test cmdMZ-return-2.7 {return option handling} -body {
|
||||
return -level 0 -code continue
|
||||
} -returnCodes continue -result {}
|
||||
test cmdMZ-return-2.8 {return option handling} -body {
|
||||
return -level 0 -code -1
|
||||
} -returnCodes -1 -result {}
|
||||
test cmdMZ-return-2.9 {return option handling} -body {
|
||||
return -level 0 -code 10
|
||||
} -returnCodes 10 -result {}
|
||||
test cmdMZ-return-2.10 {return option handling} {
|
||||
list [catch {return -level 0 -code error} -> foo] [dictSort $foo]
|
||||
} {1 {-code 1 -errorcode NONE -errorinfo {
|
||||
while executing
|
||||
"return -level 0 -code error"} -errorline 1 -level 0}}
|
||||
test cmdMZ-return-2.11 {return option handling} {
|
||||
list [catch {return -level 0 -code break} -> foo] [dictSort $foo]
|
||||
} {3 {-code 3 -level 0}}
|
||||
test cmdMZ-return-2.12 {return option handling} -body {
|
||||
return -level 0 -code error -options {-code ok}
|
||||
} -returnCodes ok -result {}
|
||||
test cmdMZ-return-2.13 {return option handling} -body {
|
||||
return -level 0 -code error -options {-code foo}
|
||||
} -returnCodes error -match glob -result {bad completion code*}
|
||||
test cmdMZ-return-2.14 {return option handling} -body {
|
||||
return -level 0 -code error -options {-code foo -options {-code break}}
|
||||
} -returnCodes break -result {}
|
||||
|
||||
test cmdMZ-return-2.15 {return opton handling} -setup {
|
||||
proc p {} {
|
||||
return -code error -errorcode {a b} c
|
||||
}
|
||||
} -body {
|
||||
list [catch p result] $result $::errorCode
|
||||
} -cleanup {
|
||||
rename p {}
|
||||
} -result {1 c {a b}}
|
||||
|
||||
test cmdMZ-return-2.16 {return opton handling} -setup {
|
||||
proc p {} {
|
||||
return -code error -errorcode [list a b] c
|
||||
}
|
||||
} -body {
|
||||
list [catch p result] $result $::errorCode
|
||||
} -cleanup {
|
||||
rename p {}
|
||||
} -result {1 c {a b}}
|
||||
|
||||
test cmdMZ-return-2.17 {return opton handling} -setup {
|
||||
proc p {} {
|
||||
return -code error -errorcode a\ b c
|
||||
}
|
||||
} -body {
|
||||
list [catch p result] $result $::errorCode
|
||||
} -cleanup {
|
||||
rename p {}
|
||||
} -result {1 c {a b}}
|
||||
|
||||
|
||||
# Check that the result of a [return -options $opts $result] is
|
||||
# indistinguishable from that of the originally caught script, no
|
||||
# matter what the script is/does. (TIP 90)
|
||||
set i 0
|
||||
foreach script {
|
||||
{}
|
||||
{format x}
|
||||
{set}
|
||||
{set a 1}
|
||||
{error}
|
||||
{error foo}
|
||||
{error foo bar}
|
||||
{error foo bar baz}
|
||||
{return -level 0}
|
||||
{return -code error}
|
||||
{return -code error -errorinfo foo}
|
||||
{return -code error -errorinfo foo -errorcode bar}
|
||||
{return -code error -errorinfo foo -errorcode bar -errorline 10}
|
||||
{return -options {x y z 2}}
|
||||
{return -level 3 -code break sdf}
|
||||
} {
|
||||
test cmdMZ-return-3.$i "check that return after a catch is same:\n$script" {
|
||||
set one [list [catch $script foo bar] $foo [dictSort $bar] \
|
||||
$::errorCode $::errorInfo]
|
||||
set two [list [catch {return -options $bar $foo} foo2 bar2] \
|
||||
$foo2 [dictSort $bar2] $::errorCode $::errorInfo]
|
||||
string equal $one $two
|
||||
} 1
|
||||
incr i
|
||||
}
|
||||
|
||||
# The tests for Tcl_ScanObjCmd are in scan.test
|
||||
|
||||
# Tcl_SourceObjCmd
|
||||
# More tests of Tcl_SourceObjCmd are in source.test
|
||||
|
||||
test cmdMZ-3.3 {Tcl_SourceObjCmd: error conditions} -constraints {
|
||||
unixOrPc
|
||||
} -body {
|
||||
list [catch {source} msg] $msg
|
||||
} -match glob -result {1 {wrong # args: should be "source*fileName"}}
|
||||
test cmdMZ-3.4 {Tcl_SourceObjCmd: error conditions} -constraints {
|
||||
unixOrPc
|
||||
} -body {
|
||||
list [catch {source a b} msg] $msg
|
||||
} -match glob -result {1 {wrong # args: should be "source*fileName"}}
|
||||
|
||||
proc ListGlobMatch {expected actual} {
|
||||
if {[llength $expected] != [llength $actual]} {
|
||||
return 0
|
||||
}
|
||||
foreach e $expected a $actual {
|
||||
if {![string match $e $a]} {
|
||||
return 0
|
||||
}
|
||||
}
|
||||
return 1
|
||||
}
|
||||
customMatch listGlob [namespace which ListGlobMatch]
|
||||
|
||||
test cmdMZ-3.5 {Tcl_SourceObjCmd: error in script} -body {
|
||||
set file [makeFile {
|
||||
set x 146
|
||||
error "error in sourced file"
|
||||
set y $x
|
||||
} source.file]
|
||||
set result [list [catch {source $file} msg] $msg $::errorInfo]
|
||||
removeFile source.file
|
||||
set result
|
||||
} -match listGlob -result {1 {error in sourced file} {error in sourced file
|
||||
while executing
|
||||
"error "error in sourced file""
|
||||
(file "*" line 3)
|
||||
invoked from within
|
||||
"source $file"}}
|
||||
test cmdMZ-3.6 {Tcl_SourceObjCmd: simple script} {
|
||||
set file [makeFile {list result} source.file]
|
||||
set result [source $file]
|
||||
removeFile source.file
|
||||
set result
|
||||
} result
|
||||
|
||||
# Tcl_SplitObjCmd
|
||||
|
||||
test cmdMZ-4.1 {Tcl_SplitObjCmd: split errors} {
|
||||
list [catch split msg] $msg $::errorCode
|
||||
} {1 {wrong # args: should be "split string ?splitChars?"} NONE}
|
||||
test cmdMZ-4.2 {Tcl_SplitObjCmd: split errors} {
|
||||
list [catch {split a b c} msg] $msg $::errorCode
|
||||
} {1 {wrong # args: should be "split string ?splitChars?"} NONE}
|
||||
test cmdMZ-4.3 {Tcl_SplitObjCmd: basic split commands} {
|
||||
split "a\n b\t\r c\n "
|
||||
} {a {} b {} {} c {} {}}
|
||||
test cmdMZ-4.4 {Tcl_SplitObjCmd: basic split commands} {
|
||||
split "word 1xyzword 2zword 3" xyz
|
||||
} {{word 1} {} {} {word 2} {word 3}}
|
||||
test cmdMZ-4.5 {Tcl_SplitObjCmd: basic split commands} {
|
||||
split "12345" {}
|
||||
} {1 2 3 4 5}
|
||||
test cmdMZ-4.6 {Tcl_SplitObjCmd: basic split commands} {
|
||||
split "a\}b\[c\{\]\$"
|
||||
} "a\\\}b\\\[c\\\{\\\]\\\$"
|
||||
test cmdMZ-4.7 {Tcl_SplitObjCmd: basic split commands} {
|
||||
split {} {}
|
||||
} {}
|
||||
test cmdMZ-4.8 {Tcl_SplitObjCmd: basic split commands} {
|
||||
split {}
|
||||
} {}
|
||||
test cmdMZ-4.9 {Tcl_SplitObjCmd: basic split commands} {
|
||||
split { }
|
||||
} {{} {} {} {}}
|
||||
test cmdMZ-4.10 {Tcl_SplitObjCmd: basic split commands} {
|
||||
proc foo {} {
|
||||
set x {}
|
||||
foreach f [split {]\n} {}] {
|
||||
append x $f
|
||||
}
|
||||
return $x
|
||||
}
|
||||
foo
|
||||
} {]\n}
|
||||
test cmdMZ-4.11 {Tcl_SplitObjCmd: basic split commands} {
|
||||
proc foo {} {
|
||||
set x ab\000c
|
||||
set y [split $x {}]
|
||||
return $y
|
||||
}
|
||||
foo
|
||||
} "a b \000 c"
|
||||
test cmdMZ-4.12 {Tcl_SplitObjCmd: basic split commands} {
|
||||
split "a0ab1b2bbb3\000c4" ab\000c
|
||||
} {{} 0 {} 1 2 {} {} 3 {} 4}
|
||||
test cmdMZ-4.13 {Tcl_SplitObjCmd: basic split commands} {
|
||||
# if not UTF-8 aware, result is "a {} {} b qw\xe5 {} N wq"
|
||||
split "a\u4e4eb qw\u5e4e\x4e wq" " \u4e4e"
|
||||
} "a b qw\u5e4eN wq"
|
||||
|
||||
# The tests for Tcl_StringObjCmd are in string.test
|
||||
# The tests for Tcl_SubstObjCmd are in subst.test
|
||||
# The tests for Tcl_SwitchObjCmd are in switch.test
|
||||
|
||||
test cmdMZ-5.1 {Tcl_TimeObjCmd: basic format of command} {
|
||||
list [catch {time} msg] $msg
|
||||
} {1 {wrong # args: should be "time command ?count?"}}
|
||||
test cmdMZ-5.2 {Tcl_TimeObjCmd: basic format of command} {
|
||||
list [catch {time a b c} msg] $msg
|
||||
} {1 {wrong # args: should be "time command ?count?"}}
|
||||
test cmdMZ-5.3 {Tcl_TimeObjCmd: basic format of command} {
|
||||
list [catch {time a b} msg] $msg
|
||||
} {1 {expected integer but got "b"}}
|
||||
test cmdMZ-5.4 {Tcl_TimeObjCmd: nothing happens with negative iteration counts} {
|
||||
time bogusCmd -12456
|
||||
} {0 microseconds per iteration}
|
||||
test cmdMZ-5.5 {Tcl_TimeObjCmd: result format} {
|
||||
regexp {^\d+ microseconds per iteration} [time {format 1}]
|
||||
} 1
|
||||
test cmdMZ-5.6 {Tcl_TimeObjCmd: slower commands take longer} {
|
||||
expr {[lindex [time {after 2}] 0] < [lindex [time {after 1000}] 0]}
|
||||
} 1
|
||||
test cmdMZ-5.7 {Tcl_TimeObjCmd: errors generate right trace} {
|
||||
list [catch {time {error foo}} msg] $msg $::errorInfo
|
||||
} {1 foo {foo
|
||||
while executing
|
||||
"error foo"
|
||||
invoked from within
|
||||
"time {error foo}"}}
|
||||
|
||||
# The tests for Tcl_WhileObjCmd are in while.test
|
||||
|
||||
# cleanup
|
||||
cleanupTests
|
||||
}
|
||||
namespace delete ::tcl::test::cmdMZ
|
||||
return
|
||||
674
tests/compExpr-old.test
Normal file
674
tests/compExpr-old.test
Normal file
@@ -0,0 +1,674 @@
|
||||
# Commands covered: expr
|
||||
#
|
||||
# This file contains the original set of tests for the compilation (and
|
||||
# indirectly execution) of Tcl's expr command. A new set of tests covering
|
||||
# the new implementation are in the files "parseExpr.test" and
|
||||
# "compExpr.test". Sourcing this file into Tcl runs the tests and generates
|
||||
# output for errors. No output means no errors were found.
|
||||
#
|
||||
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest 2
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} {
|
||||
testConstraint testmathfunctions 0
|
||||
} else {
|
||||
testConstraint testmathfunctions 1
|
||||
}
|
||||
|
||||
# Big test for correct ordering of data in [expr]
|
||||
|
||||
proc testIEEE {} {
|
||||
variable ieeeValues
|
||||
binary scan [binary format dd -1.0 1.0] c* c
|
||||
switch -exact -- $c {
|
||||
{0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} {
|
||||
# little endian
|
||||
binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \
|
||||
ieeeValues(-Infinity)
|
||||
binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \
|
||||
ieeeValues(-Normal)
|
||||
binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \
|
||||
ieeeValues(-Subnormal)
|
||||
binary scan \x00\x00\x00\x00\x00\x00\x00\x80 d \
|
||||
ieeeValues(-0)
|
||||
binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \
|
||||
ieeeValues(+0)
|
||||
binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \
|
||||
ieeeValues(+Subnormal)
|
||||
binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \
|
||||
ieeeValues(+Normal)
|
||||
binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \
|
||||
ieeeValues(+Infinity)
|
||||
binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \
|
||||
ieeeValues(NaN)
|
||||
set ieeeValues(littleEndian) 1
|
||||
return 1
|
||||
}
|
||||
{-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} {
|
||||
binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \
|
||||
ieeeValues(-Infinity)
|
||||
binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \
|
||||
ieeeValues(-Normal)
|
||||
binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \
|
||||
ieeeValues(-Subnormal)
|
||||
binary scan \x80\x00\x00\x00\x00\x00\x00\x00 d \
|
||||
ieeeValues(-0)
|
||||
binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \
|
||||
ieeeValues(+0)
|
||||
binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \
|
||||
ieeeValues(+Subnormal)
|
||||
binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \
|
||||
ieeeValues(+Normal)
|
||||
binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \
|
||||
ieeeValues(+Infinity)
|
||||
binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \
|
||||
ieeeValues(NaN)
|
||||
set ieeeValues(littleEndian) 0
|
||||
return 1
|
||||
}
|
||||
default {
|
||||
return 0
|
||||
}
|
||||
}
|
||||
}
|
||||
testConstraint ieeeFloatingPoint [testIEEE]
|
||||
|
||||
testConstraint longIs32bit [expr {int(0x80000000) < 0}]
|
||||
testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}]
|
||||
|
||||
# procedures used below
|
||||
|
||||
proc put_hello_char {c} {
|
||||
global a
|
||||
append a [format %c $c]
|
||||
return $c
|
||||
}
|
||||
proc hello_world {} {
|
||||
global a
|
||||
set a ""
|
||||
set L1 [set l0 [set h_1 [set q 0]]]
|
||||
for {put_hello_char [expr [put_hello_char [expr [set h 7]*10+2]]+29]} {$l0?[put_hello_char $l0]
|
||||
:!$h_1} {put_hello_char $ll;expr {$L1==2?[set ll [expr 32+0-0+[set bar 0]]]:0}} {expr {[incr L1]==[expr 1+([string length "abc"]-[string length "abc"])]
|
||||
?[set ll [set l0 [expr 54<<1]]]:$ll==108&&$L1<3?
|
||||
[incr ll [expr 1|1<<1]; set ll $ll; set ll $ll; set ll $ll; set ll $ll; set l0 [expr ([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])]; set l0; set l0 $l0; set l0; set l0]:$L1==4&&$ll==32?[set ll [expr 19+$h1+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])+[set foo [expr ([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])]]]]
|
||||
:[set q [expr $q-$h1+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])]]};expr {$L1==5?[incr ll -8; set ll $ll; set ll]:$q&&$h1&&1};expr {$L1==4+2
|
||||
?[incr ll 3]:[expr ([string length "abc"]-[string length "abc"])+1]};expr {$ll==($h<<4)+2+0&&$L1!=6?[incr ll -6]:[set h1 [expr 100+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])]]}
|
||||
expr {$L1!=1<<3?[incr q [expr ([string length "abc"]-[string length "abc"])-1]]:[set h_1 [set ll $h1]]}
|
||||
}
|
||||
set a
|
||||
}
|
||||
|
||||
proc 12days {a b c} {
|
||||
global xxx
|
||||
expr {1<$a?[expr {$a<3?[12days -79 -13 [string range $c [12days -87 \
|
||||
[expr 1-$b] [string range $c [12days -86 0 [string range $c 1 end]] \
|
||||
end]] end]]:1};expr {$a<$b?[12days [expr $a+1] $b $c]:3};expr {[12days \
|
||||
-94 [expr $a-27] $c]&&$a==2?$b<13?[12days 2 [expr $b+1] "%s %d %d\n"]:9
|
||||
:16}]:$a<0?$a<-72?[12days $b $a "@n'+,#'/*\{\}w+/w#cdnr/+,\{\}r/*de\}+,/*\{*+,/w\{%+,/w#q#n+,/#\{l+,/n\{n+,/+#n+,/#;#q#n+,/+k#;*+,/'r :'d*'3,\}\{w+K w'K:'+\}e#';dq#'l q#'+d'K#!/+k#;q#'r\}eKK#\}w'r\}eKK\{nl\]'/#;#q#n')\{)#\}w')\{)\{nl\]'/+#n';d\}rw' i;# )\{nl\]!/n\{n#'; r\{#w'r nc\{nl\]'/#\{l,+'K \{rw' iK\{;\[\{nl\]'/w#q#n'wk nw' iwk\{KK\{nl\]!/w\{%'l##w#' i; :\{nl\]'/*\{q#'ld;r'\}\{nlwb!/*de\}'c ;;\{nl'-\{\}rw\]'/+,\}##'*\}#nc,',#nw\]'/+kd'+e\}+;#'rdq#w! nr'/ ') \}+\}\{rl#'\{n' ')# \}'+\}##(!!/"]
|
||||
:$a<-50?[string compare [format %c $b] [string index $c 0]]==0?[append \
|
||||
xxx [string index $c 31];scan [string index $c 31] %c x;set x]
|
||||
:[12days -65 $b [string range $c 1 end]]:[12days [expr ([string compare \
|
||||
[string index $c 0] "/"]==0)+$a] $b [string range $c 1 end]]:0<$a
|
||||
?[12days 2 2 "%s"]:[string compare [string index $c 0] "/"]==0||
|
||||
[12days 0 [12days -61 [scan [string index $c 0] %c x; set x] \
|
||||
"!ek;dc i@bK'(q)-\[w\]*%n+r3#l,\{\}:\nuwloca-O;m .vpbks,fxntdCeghiry"] \
|
||||
[string range $c 1 end]]}
|
||||
}
|
||||
proc do_twelve_days {} {
|
||||
global xxx
|
||||
set xxx ""
|
||||
12days 1 1 1
|
||||
set result [string length $xxx]
|
||||
unset xxx
|
||||
return $result
|
||||
}
|
||||
|
||||
# start of tests
|
||||
|
||||
catch {unset a b i x}
|
||||
|
||||
test compExpr-old-1.1 {TclCompileExprCmd: no expression} {
|
||||
list [catch {expr } msg] $msg
|
||||
} {1 {wrong # args: should be "expr arg ?arg ...?"}}
|
||||
test compExpr-old-1.2 {TclCompileExprCmd: one expression word} {
|
||||
expr -25
|
||||
} -25
|
||||
test compExpr-old-1.3 {TclCompileExprCmd: two expression words} {
|
||||
expr -8.2 -6
|
||||
} -14.2
|
||||
test compExpr-old-1.4 {TclCompileExprCmd: five expression words} {
|
||||
expr 20 - 5 +10 -7
|
||||
} 18
|
||||
test compExpr-old-1.5 {TclCompileExprCmd: quoted expression word} {
|
||||
expr "0005"
|
||||
} 5
|
||||
test compExpr-old-1.6 {TclCompileExprCmd: quoted expression word} {
|
||||
catch {expr "0005"zxy} msg
|
||||
set msg
|
||||
} {extra characters after close-quote}
|
||||
test compExpr-old-1.7 {TclCompileExprCmd: expression word in braces} {
|
||||
expr {-0005}
|
||||
} -5
|
||||
test compExpr-old-1.8 {TclCompileExprCmd: expression word in braces} {
|
||||
expr {{-0x1234}}
|
||||
} -4660
|
||||
test compExpr-old-1.9 {TclCompileExprCmd: expression word in braces} {
|
||||
catch {expr {-0005}foo} msg
|
||||
set msg
|
||||
} {extra characters after close-brace}
|
||||
test compExpr-old-1.10 {TclCompileExprCmd: other expression word in braces} {
|
||||
expr 4*[llength "6 2"]
|
||||
} 8
|
||||
test compExpr-old-1.11 {TclCompileExprCmd: expression word terminated by ;} {
|
||||
expr 4*[llength "6 2"];
|
||||
} 8
|
||||
test compExpr-old-1.12 {TclCompileExprCmd: inlined expr (in "catch") inside other catch} {
|
||||
set a xxx
|
||||
catch {
|
||||
# Might not be a number
|
||||
set a [expr 10*$a]
|
||||
}
|
||||
} 1
|
||||
test compExpr-old-1.13 {TclCompileExprCmd: second level of substitutions in expr not in braces with single var reference} {
|
||||
set a xxx
|
||||
set x 27; set bool {$x}; if $bool {set a foo}
|
||||
set a
|
||||
} foo
|
||||
test compExpr-old-1.14 {TclCompileExprCmd: second level of substitutions in expr with comparison as top-level operator} {
|
||||
set a xxx
|
||||
set x 2; set b {$x}; set a [expr $b == 2]
|
||||
set a
|
||||
} 1
|
||||
|
||||
test compExpr-old-2.1 {TclCompileExpr: are builtin functions registered?} {
|
||||
expr double(5*[llength "6 2"])
|
||||
} 10.0
|
||||
test compExpr-old-2.2 {TclCompileExpr: error in expr} -body {
|
||||
expr 2***3
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-old-2.3 {TclCompileExpr: junk after legal expr} -body {
|
||||
expr 7*[llength "a b"]foo
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-old-2.4 {TclCompileExpr: numeric expr string rep == formatted int rep} {
|
||||
expr {0001}
|
||||
} 1
|
||||
|
||||
test compExpr-old-3.1 {CompileCondExpr: just lor expr} {expr 3||0} 1
|
||||
test compExpr-old-3.2 {CompileCondExpr: error in lor expr} -body {
|
||||
expr x||3
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-old-3.3 {CompileCondExpr: test true arm} {expr 3>2?44:66} 44
|
||||
test compExpr-old-3.4 {CompileCondExpr: error compiling true arm} -body {
|
||||
expr 3>2?2***3:66
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-old-3.5 {CompileCondExpr: test false arm} {expr 2>3?44:66} 66
|
||||
test compExpr-old-3.6 {CompileCondExpr: error compiling false arm} -body {
|
||||
expr 2>3?44:2***3
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-old-3.7 {CompileCondExpr: long arms & nested cond exprs} {
|
||||
hello_world
|
||||
} {Hello world}
|
||||
test compExpr-old-3.8 {CompileCondExpr: long arms & nested cond exprs} unix {
|
||||
# Fails with a stack overflow on threaded Windows builds
|
||||
do_twelve_days
|
||||
} 2358
|
||||
|
||||
test compExpr-old-4.1 {CompileLorExpr: just land expr} {expr 1.3&&3.3} 1
|
||||
test compExpr-old-4.2 {CompileLorExpr: error in land expr} -body {
|
||||
expr x&&3
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-old-4.3 {CompileLorExpr: simple lor exprs} {expr 0||1.0} 1
|
||||
test compExpr-old-4.4 {CompileLorExpr: simple lor exprs} {expr 3.0||0.0} 1
|
||||
test compExpr-old-4.5 {CompileLorExpr: simple lor exprs} {expr 0||0||1} 1
|
||||
test compExpr-old-4.6 {CompileLorExpr: error compiling lor arm} -body {
|
||||
expr 2***3||4.0
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-old-4.7 {CompileLorExpr: error compiling lor arm} -body {
|
||||
expr 1.3||2***3
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-old-4.8 {CompileLorExpr: error compiling lor arms} {
|
||||
list [catch {expr {"a"||"b"}} msg] $msg
|
||||
} {1 {expected boolean value but got "a"}}
|
||||
test compExpr-old-4.9 {CompileLorExpr: long lor arm} {
|
||||
set a "abcdefghijkl"
|
||||
set i 7
|
||||
expr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]}
|
||||
} 1
|
||||
|
||||
test compExpr-old-5.1 {CompileLandExpr: just bitor expr} {expr 7|0x13} 23
|
||||
test compExpr-old-5.2 {CompileLandExpr: error in bitor expr} -body {
|
||||
expr x|3
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-old-5.3 {CompileLandExpr: simple land exprs} {expr 0&&1.0} 0
|
||||
test compExpr-old-5.4 {CompileLandExpr: simple land exprs} {expr 0&&0} 0
|
||||
test compExpr-old-5.5 {CompileLandExpr: simple land exprs} {expr 3.0&&1.2} 1
|
||||
test compExpr-old-5.6 {CompileLandExpr: simple land exprs} {expr 1&&1&&2} 1
|
||||
test compExpr-old-5.7 {CompileLandExpr: error compiling land arm} -body {
|
||||
expr 2***3&&4.0
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-old-5.8 {CompileLandExpr: error compiling land arm} -body {
|
||||
expr 1.3&&2***3
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-old-5.9 {CompileLandExpr: error compiling land arm} {
|
||||
list [catch {expr {"a"&&"b"}} msg] $msg
|
||||
} {1 {expected boolean value but got "a"}}
|
||||
test compExpr-old-5.10 {CompileLandExpr: long land arms} {
|
||||
set a "abcdefghijkl"
|
||||
set i 7
|
||||
expr {[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]}
|
||||
} 1
|
||||
|
||||
test compExpr-old-6.1 {CompileBitXorExpr: just bitand expr} {expr 7&0x13} 3
|
||||
test compExpr-old-6.2 {CompileBitXorExpr: error in bitand expr} -body {
|
||||
expr x|3
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-old-6.3 {CompileBitXorExpr: simple bitxor exprs} {expr 7^0x13} 20
|
||||
test compExpr-old-6.4 {CompileBitXorExpr: simple bitxor exprs} {expr 3^0x10} 19
|
||||
test compExpr-old-6.5 {CompileBitXorExpr: simple bitxor exprs} {expr 0^7} 7
|
||||
test compExpr-old-6.6 {CompileBitXorExpr: simple bitxor exprs} {expr -1^7} -8
|
||||
test compExpr-old-6.7 {CompileBitXorExpr: error compiling bitxor arm} -body {
|
||||
expr 2***3|6
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-old-6.8 {CompileBitXorExpr: error compiling bitxor arm} -body {
|
||||
expr 2^x
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-old-6.9 {CompileBitXorExpr: runtime error in bitxor arm} {
|
||||
list [catch {expr {24.0^3}} msg] $msg
|
||||
} {1 {can't use floating-point value as operand of "^"}}
|
||||
test compExpr-old-6.10 {CompileBitXorExpr: runtime error in bitxor arm} {
|
||||
list [catch {expr {"a"^"b"}} msg] $msg
|
||||
} {1 {can't use non-numeric string as operand of "^"}}
|
||||
|
||||
test compExpr-old-7.1 {CompileBitAndExpr: just equality expr} {expr 3==2} 0
|
||||
test compExpr-old-7.2 {CompileBitAndExpr: just equality expr} {expr 2.0==2} 1
|
||||
test compExpr-old-7.3 {CompileBitAndExpr: just equality expr} {expr 3.2!=2.2} 1
|
||||
test compExpr-old-7.4 {CompileBitAndExpr: just equality expr} {expr {"abc" == "abd"}} 0
|
||||
test compExpr-old-7.5 {CompileBitAndExpr: error in equality expr} -body {
|
||||
expr x==3
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-old-7.6 {CompileBitAndExpr: simple bitand exprs} {expr 7&0x13} 3
|
||||
test compExpr-old-7.7 {CompileBitAndExpr: simple bitand exprs} {expr 0xf2&0x53} 82
|
||||
test compExpr-old-7.8 {CompileBitAndExpr: simple bitand exprs} {expr 3&6} 2
|
||||
test compExpr-old-7.9 {CompileBitAndExpr: simple bitand exprs} {expr -1&-7} -7
|
||||
test compExpr-old-7.10 {CompileBitAndExpr: error compiling bitand arm} -body {
|
||||
expr 2***3&6
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-old-7.11 {CompileBitAndExpr: error compiling bitand arm} -body {
|
||||
expr 2&x
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-old-7.12 {CompileBitAndExpr: runtime error in bitand arm} {
|
||||
list [catch {expr {24.0&3}} msg] $msg
|
||||
} {1 {can't use floating-point value as operand of "&"}}
|
||||
test compExpr-old-7.13 {CompileBitAndExpr: runtime error in bitand arm} {
|
||||
list [catch {expr {"a"&"b"}} msg] $msg
|
||||
} {1 {can't use non-numeric string as operand of "&"}}
|
||||
|
||||
test compExpr-old-8.1 {CompileEqualityExpr: just relational expr} {expr 3>=2} 1
|
||||
test compExpr-old-8.2 {CompileEqualityExpr: just relational expr} {expr 2<=2.1} 1
|
||||
test compExpr-old-8.3 {CompileEqualityExpr: just relational expr} {expr 3.2>"2.2"} 1
|
||||
test compExpr-old-8.4 {CompileEqualityExpr: just relational expr} {expr {"0y"<"0x12"}} 0
|
||||
test compExpr-old-8.5 {CompileEqualityExpr: error in relational expr} -body {
|
||||
expr x>3
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-old-8.6 {CompileEqualityExpr: simple equality exprs} {expr 7==0x13} 0
|
||||
test compExpr-old-8.7 {CompileEqualityExpr: simple equality exprs} {expr -0xf2!=0x53} 1
|
||||
test compExpr-old-8.8 {CompileEqualityExpr: simple equality exprs} {expr {"12398712938788234-1298379" != ""}} 1
|
||||
test compExpr-old-8.9 {CompileEqualityExpr: simple equality exprs} {expr -1!="abc"} 1
|
||||
test compExpr-old-8.10 {CompileEqualityExpr: error compiling equality arm} -body {
|
||||
expr 2***3==6
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-old-8.11 {CompileEqualityExpr: error compiling equality arm} -body {
|
||||
expr 2!=x
|
||||
} -returnCodes error -match glob -result *
|
||||
|
||||
|
||||
test compExpr-old-9.1 {CompileRelationalExpr: just shift expr} {expr 3<<2} 12
|
||||
test compExpr-old-9.2 {CompileRelationalExpr: just shift expr} {expr 0xff>>2} 63
|
||||
test compExpr-old-9.3 {CompileRelationalExpr: just shift expr} {expr -1>>2} -1
|
||||
test compExpr-old-9.4 {CompileRelationalExpr: just shift expr} {expr {1<<3}} 8
|
||||
|
||||
# The following test is different for 32-bit versus 64-bit
|
||||
# architectures because LONG_MIN is different
|
||||
|
||||
test compExpr-old-9.5a {CompileRelationalExpr: shift expr producing LONG_MIN} longIs64bit {
|
||||
expr {int(1<<63)}
|
||||
} -9223372036854775808
|
||||
test compExpr-old-9.5b {CompileRelationalExpr: shift expr producing LONG_MIN} longIs32bit {
|
||||
expr {int(1<<31)}
|
||||
} -2147483648
|
||||
|
||||
test compExpr-old-9.6 {CompileRelationalExpr: error in shift expr} -body {
|
||||
expr x>>3
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-old-9.7 {CompileRelationalExpr: simple relational exprs} {expr 0xff>=+0x3} 1
|
||||
test compExpr-old-9.8 {CompileRelationalExpr: simple relational exprs} {expr -0xf2<0x3} 1
|
||||
test compExpr-old-9.9 {CompileRelationalExpr: error compiling relational arm} -body {
|
||||
expr 2***3>6
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-old-9.10 {CompileRelationalExpr: error compiling relational arm} -body {
|
||||
expr 2<x
|
||||
} -returnCodes error -match glob -result *
|
||||
|
||||
test compExpr-old-10.1 {CompileShiftExpr: just add expr} {expr 4+-2} 2
|
||||
test compExpr-old-10.2 {CompileShiftExpr: just add expr} {expr 0xff-2} 253
|
||||
test compExpr-old-10.3 {CompileShiftExpr: just add expr} {expr -1--2} 1
|
||||
test compExpr-old-10.4 {CompileShiftExpr: just add expr} {expr 1-0o123} -82
|
||||
test compExpr-old-10.5 {CompileShiftExpr: error in add expr} -body {
|
||||
expr x+3
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-old-10.6 {CompileShiftExpr: simple shift exprs} {expr 0xff>>0x3} 31
|
||||
test compExpr-old-10.7 {CompileShiftExpr: simple shift exprs} {expr -0xf2<<0x3} -1936
|
||||
test compExpr-old-10.8 {CompileShiftExpr: error compiling shift arm} -body {
|
||||
expr 2***3>>6
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-old-10.9 {CompileShiftExpr: error compiling shift arm} -body {
|
||||
expr 2<<x
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-old-10.10 {CompileShiftExpr: runtime error} {
|
||||
list [catch {expr {24.0>>43}} msg] $msg
|
||||
} {1 {can't use floating-point value as operand of ">>"}}
|
||||
test compExpr-old-10.11 {CompileShiftExpr: runtime error} {
|
||||
list [catch {expr {"a"<<"b"}} msg] $msg
|
||||
} {1 {can't use non-numeric string as operand of "<<"}}
|
||||
|
||||
test compExpr-old-11.1 {CompileAddExpr: just multiply expr} {expr 4*-2} -8
|
||||
test compExpr-old-11.2 {CompileAddExpr: just multiply expr} {expr 0xff%2} 1
|
||||
test compExpr-old-11.3 {CompileAddExpr: just multiply expr} {expr -1/2} -1
|
||||
test compExpr-old-11.4 {CompileAddExpr: just multiply expr} {expr 7891%0o123} 6
|
||||
test compExpr-old-11.5 {CompileAddExpr: error in multiply expr} -body {
|
||||
expr x*3
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-old-11.6 {CompileAddExpr: simple add exprs} {expr 0xff++0x3} 258
|
||||
test compExpr-old-11.7 {CompileAddExpr: simple add exprs} {expr -0xf2--0x3} -239
|
||||
test compExpr-old-11.8 {CompileAddExpr: error compiling add arm} -body {
|
||||
expr 2***3+6
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-old-11.9 {CompileAddExpr: error compiling add arm} -body {
|
||||
expr 2-x
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-old-11.10 {CompileAddExpr: runtime error} {
|
||||
list [catch {expr {24.0+"xx"}} msg] $msg
|
||||
} {1 {can't use non-numeric string as operand of "+"}}
|
||||
test compExpr-old-11.11 {CompileAddExpr: runtime error} {
|
||||
list [catch {expr {"a"-"b"}} msg] $msg
|
||||
} {1 {can't use non-numeric string as operand of "-"}}
|
||||
test compExpr-old-11.12 {CompileAddExpr: runtime error} {
|
||||
list [catch {expr {3/0}} msg] $msg
|
||||
} {1 {divide by zero}}
|
||||
test compExpr-old-11.13a {CompileAddExpr: runtime error} ieeeFloatingPoint {
|
||||
list [catch {expr {2.3/0.0}} msg] $msg
|
||||
} {0 Inf}
|
||||
test compExpr-old-11.13b {CompileAddExpr: runtime error} !ieeeFloatingPoint {
|
||||
list [catch {expr {2.3/0.0}} msg] $msg
|
||||
} {1 {divide by zero}}
|
||||
|
||||
test compExpr-old-12.1 {CompileMultiplyExpr: just unary expr} {expr ~4} -5
|
||||
test compExpr-old-12.2 {CompileMultiplyExpr: just unary expr} {expr --5} 5
|
||||
test compExpr-old-12.3 {CompileMultiplyExpr: just unary expr} {expr !27} 0
|
||||
test compExpr-old-12.4 {CompileMultiplyExpr: just unary expr} {expr ~0xff00ff} -16711936
|
||||
test compExpr-old-12.5 {CompileMultiplyExpr: error in unary expr} -body {
|
||||
expr ~x
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-old-12.6 {CompileMultiplyExpr: simple multiply exprs} {expr 0xff*0x3} 765
|
||||
test compExpr-old-12.7 {CompileMultiplyExpr: simple multiply exprs} {expr -0xf2%-0x3} -2
|
||||
test compExpr-old-12.8 {CompileMultiplyExpr: error compiling multiply arm} -body {
|
||||
expr 2*3%%6
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-old-12.9 {CompileMultiplyExpr: error compiling multiply arm} -body {
|
||||
expr 2*x
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-old-12.10 {CompileMultiplyExpr: runtime error} {
|
||||
list [catch {expr {24.0*"xx"}} msg] $msg
|
||||
} {1 {can't use non-numeric string as operand of "*"}}
|
||||
test compExpr-old-12.11 {CompileMultiplyExpr: runtime error} {
|
||||
list [catch {expr {"a"/"b"}} msg] $msg
|
||||
} {1 {can't use non-numeric string as operand of "/"}}
|
||||
|
||||
test compExpr-old-13.1 {CompileUnaryExpr: unary exprs} {expr -0xff} -255
|
||||
test compExpr-old-13.2 {CompileUnaryExpr: unary exprs} {expr +0o00123} 83
|
||||
test compExpr-old-13.3 {CompileUnaryExpr: unary exprs} {expr +--++36} 36
|
||||
test compExpr-old-13.4 {CompileUnaryExpr: unary exprs} {expr !2} 0
|
||||
test compExpr-old-13.5 {CompileUnaryExpr: unary exprs} {expr +--+-62.0} -62.0
|
||||
test compExpr-old-13.6 {CompileUnaryExpr: unary exprs} {expr !0.0} 1
|
||||
test compExpr-old-13.7 {CompileUnaryExpr: unary exprs} {expr !0xef} 0
|
||||
test compExpr-old-13.8 {CompileUnaryExpr: error compiling unary expr} -body {
|
||||
expr ~x
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-old-13.9 {CompileUnaryExpr: error compiling unary expr} -body {
|
||||
expr !1.x
|
||||
set msg
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-old-13.10 {CompileUnaryExpr: runtime error} {
|
||||
list [catch {expr {~"xx"}} msg] $msg
|
||||
} {1 {can't use non-numeric string as operand of "~"}}
|
||||
test compExpr-old-13.11 {CompileUnaryExpr: runtime error} {
|
||||
list [catch {expr ~4.0} msg] $msg
|
||||
} {1 {can't use floating-point value as operand of "~"}}
|
||||
test compExpr-old-13.12 {CompileUnaryExpr: just primary expr} {expr 0x123} 291
|
||||
test compExpr-old-13.13 {CompileUnaryExpr: just primary expr} {
|
||||
set a 27
|
||||
expr $a
|
||||
} 27
|
||||
test compExpr-old-13.14 {CompileUnaryExpr: just primary expr} {
|
||||
expr double(27)
|
||||
} 27.0
|
||||
test compExpr-old-13.15 {CompileUnaryExpr: just primary expr} {expr "123"} 123
|
||||
test compExpr-old-13.16 {CompileUnaryExpr: error in primary expr} {
|
||||
catch {expr [set]} msg
|
||||
set msg
|
||||
} {wrong # args: should be "set varName ?newValue?"}
|
||||
test compExpr-old-14.1 {CompilePrimaryExpr: literal primary} {expr 1} 1
|
||||
test compExpr-old-14.2 {CompilePrimaryExpr: literal primary} {expr 123} 123
|
||||
test compExpr-old-14.3 {CompilePrimaryExpr: literal primary} {expr 0xff} 255
|
||||
test compExpr-old-14.4 {CompilePrimaryExpr: literal primary} {expr 0o0010} 8
|
||||
test compExpr-old-14.5 {CompilePrimaryExpr: literal primary} {expr 62.0} 62.0
|
||||
test compExpr-old-14.6 {CompilePrimaryExpr: literal primary} {
|
||||
expr 3.1400000
|
||||
} 3.14
|
||||
test compExpr-old-14.7 {CompilePrimaryExpr: literal primary} {expr {{abcde}<{abcdef}}} 1
|
||||
test compExpr-old-14.8 {CompilePrimaryExpr: literal primary} {expr {{abc\
|
||||
def} < {abcdef}}} 1
|
||||
test compExpr-old-14.9 {CompilePrimaryExpr: literal primary} {expr {{abc\tde} > {abc\tdef}}} 0
|
||||
test compExpr-old-14.10 {CompilePrimaryExpr: literal primary} {expr {{123}}} 123
|
||||
test compExpr-old-14.11 {CompilePrimaryExpr: var reference primary} {
|
||||
set i 789
|
||||
list [expr {$i}] [expr $i]
|
||||
} {789 789}
|
||||
test compExpr-old-14.12 {CompilePrimaryExpr: var reference primary} {
|
||||
set i {789} ;# test expr's aggressive conversion to numeric semantics
|
||||
list [expr {$i}] [expr $i]
|
||||
} {789 789}
|
||||
test compExpr-old-14.13 {CompilePrimaryExpr: var reference primary} {
|
||||
catch {unset a}
|
||||
set a(foo) foo
|
||||
set a(bar) bar
|
||||
set a(123) 123
|
||||
set result ""
|
||||
lappend result [expr $a(123)] [expr {$a(bar)<$a(foo)}]
|
||||
catch {unset a}
|
||||
set result
|
||||
} {123 1}
|
||||
test compExpr-old-14.14 {CompilePrimaryExpr: var reference primary} {
|
||||
set i 123 ;# test "$var.0" floating point conversion hack
|
||||
list [expr $i] [expr $i.0] [expr $i.0/12.0]
|
||||
} {123 123.0 10.25}
|
||||
test compExpr-old-14.15 {CompilePrimaryExpr: var reference primary} {
|
||||
set i 123
|
||||
catch {expr $i.2} msg
|
||||
set msg
|
||||
} 123.2
|
||||
test compExpr-old-14.16 {CompilePrimaryExpr: error compiling var reference primary} -body {
|
||||
expr {$a(foo}
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-old-14.17 {CompilePrimaryExpr: string primary that looks like var ref} -body {
|
||||
expr $
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-old-14.18 {CompilePrimaryExpr: quoted string primary} {
|
||||
expr "21"
|
||||
} 21
|
||||
test compExpr-old-14.19 {CompilePrimaryExpr: quoted string primary} {
|
||||
set i 123
|
||||
set x 456
|
||||
expr "$i+$x"
|
||||
} 579
|
||||
test compExpr-old-14.20 {CompilePrimaryExpr: quoted string primary} {
|
||||
set i 3
|
||||
set x 6
|
||||
expr 2+"$i.$x"
|
||||
} 5.6
|
||||
test compExpr-old-14.21 {CompilePrimaryExpr: error in quoted string primary} {
|
||||
catch {expr "[set]"} msg
|
||||
set msg
|
||||
} {wrong # args: should be "set varName ?newValue?"}
|
||||
test compExpr-old-14.22 {CompilePrimaryExpr: subcommand primary} {
|
||||
expr {[set i 123; set i]}
|
||||
} 123
|
||||
test compExpr-old-14.23 {CompilePrimaryExpr: error in subcommand primary} -body {
|
||||
catch {expr {[set]}} msg
|
||||
set ::errorInfo
|
||||
} -match glob -result {wrong # args: should be "set varName ?newValue?"
|
||||
while *ing
|
||||
"set"*}
|
||||
test compExpr-old-14.24 {CompilePrimaryExpr: error in subcommand primary} -body {
|
||||
expr {[set i}
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-old-14.25 {CompilePrimaryExpr: math function primary} {
|
||||
format %.6g [expr exp(1.0)]
|
||||
} 2.71828
|
||||
test compExpr-old-14.26 {CompilePrimaryExpr: math function primary} {
|
||||
format %.6g [expr pow(2.0+0.1,3.0+0.1)]
|
||||
} 9.97424
|
||||
test compExpr-old-14.27 {CompilePrimaryExpr: error in math function primary} -body {
|
||||
expr sinh::(2.0)
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-old-14.28 {CompilePrimaryExpr: subexpression primary} {
|
||||
expr 2+(3*4)
|
||||
} 14
|
||||
test compExpr-old-14.29 {CompilePrimaryExpr: error in subexpression primary} -body {
|
||||
catch {expr 2+(3*[set])} msg
|
||||
set ::errorInfo
|
||||
} -match glob -result {wrong # args: should be "set varName ?newValue?"
|
||||
while *ing
|
||||
"set"*}
|
||||
test compExpr-old-14.30 {CompilePrimaryExpr: missing paren in subexpression primary} -body {
|
||||
expr 2+(3*(4+5)
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-old-14.31 {CompilePrimaryExpr: just var ref in subexpression primary} {
|
||||
set i "5+10"
|
||||
list "[expr $i] == 15" "[expr ($i)] == 15" "[eval expr ($i)] == 15"
|
||||
} {{15 == 15} {15 == 15} {15 == 15}}
|
||||
test compExpr-old-14.32 {CompilePrimaryExpr: unexpected token} -body {
|
||||
expr @
|
||||
} -returnCodes error -match glob -result *
|
||||
|
||||
test compExpr-old-15.1 {CompileMathFuncCall: missing parenthesis} -body {
|
||||
expr sinh2.0)
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-old-15.2 {CompileMathFuncCall: unknown math function} -body {
|
||||
catch {expr whazzathuh(1)} msg
|
||||
set ::errorInfo
|
||||
} -match glob -result {* "*whazzathuh"
|
||||
while *ing
|
||||
"expr whazzathuh(1)"}
|
||||
test compExpr-old-15.3 {CompileMathFuncCall: too many arguments} -body {
|
||||
catch {expr sin(1,2,3)} msg
|
||||
set ::errorInfo
|
||||
} -match glob -result {too many arguments for math function*
|
||||
while *ing
|
||||
"expr sin(1,2,3)"}
|
||||
test compExpr-old-15.4 {CompileMathFuncCall: ')' found before last required arg} -body {
|
||||
catch {expr sin()} msg
|
||||
set ::errorInfo
|
||||
} -match glob -result {too few arguments for math function*
|
||||
while *ing
|
||||
"expr sin()"}
|
||||
test compExpr-old-15.5 {CompileMathFuncCall: too few arguments} -body {
|
||||
catch {expr pow(1)} msg
|
||||
set ::errorInfo
|
||||
} -match glob -result {too few arguments for math function*
|
||||
while *ing
|
||||
"expr pow(1)"}
|
||||
test compExpr-old-15.6 {CompileMathFuncCall: missing ')'} -body {
|
||||
expr sin(1
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-old-15.7 {CompileMathFuncCall: call registered math function} testmathfunctions {
|
||||
expr 2*T1()
|
||||
} 246
|
||||
test compExpr-old-15.8 {CompileMathFuncCall: call registered math function} testmathfunctions {
|
||||
expr T2()*3
|
||||
} 1035
|
||||
test compExpr-old-15.9 {CompileMathFuncCall: call registered math function} testmathfunctions {
|
||||
expr T3(21, 37)
|
||||
} 37
|
||||
test compExpr-old-15.10 {CompileMathFuncCall: call registered math function} testmathfunctions {
|
||||
expr T3(21.2, 37)
|
||||
} 37.0
|
||||
test compExpr-old-15.11 {CompileMathFuncCall: call registered math function} testmathfunctions {
|
||||
expr T3(-21.2, -17.5)
|
||||
} -17.5
|
||||
|
||||
test compExpr-old-16.1 {GetToken: checks whether integer token starting with "0x" (e.g., "0x$") is invalid} {
|
||||
catch {unset a}
|
||||
set a(VALUE) ff15
|
||||
set i 123
|
||||
if {[expr 0x$a(VALUE)] & 16} {
|
||||
set i {}
|
||||
}
|
||||
set i
|
||||
} {}
|
||||
test compExpr-old-16.2 {GetToken: check for string literal in braces} {
|
||||
expr {{1}}
|
||||
} {1}
|
||||
|
||||
# Check "expr" and computed command names.
|
||||
|
||||
test compExpr-old-17.1 {expr and computed command names} {
|
||||
set i 0
|
||||
set z expr
|
||||
$z 1+2
|
||||
} 3
|
||||
|
||||
# Check correct conversion of operands to numbers: If the string looks like
|
||||
# an integer, convert to integer. Otherwise, if the string looks like a
|
||||
# double, convert to double.
|
||||
|
||||
test compExpr-old-18.1 {expr and conversion of operands to numbers} {
|
||||
set x [lindex 11 0]
|
||||
catch {expr int($x)}
|
||||
expr {$x}
|
||||
} 11
|
||||
|
||||
# Check "expr" and interpreter result object resetting before appending
|
||||
# an error msg during evaluation of exprs not in {}s
|
||||
|
||||
test compExpr-old-19.1 {expr and interpreter result object resetting} {
|
||||
proc p {} {
|
||||
set t 10.0
|
||||
set x 2.0
|
||||
set dx 0.2
|
||||
set f {$dx-$x/10}
|
||||
set g {-$x/5}
|
||||
set center 1.0
|
||||
set x [expr $x-$center]
|
||||
set dx [expr $dx+$g]
|
||||
set x [expr $x+$f+$center]
|
||||
set x [expr $x+$f+$center]
|
||||
set y [expr round($x)]
|
||||
}
|
||||
p
|
||||
} 3
|
||||
|
||||
# cleanup
|
||||
if {[info exists a]} {
|
||||
unset a
|
||||
}
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
366
tests/compExpr.test
Normal file
366
tests/compExpr.test
Normal file
@@ -0,0 +1,366 @@
|
||||
# This file contains a collection of tests for the procedures in the
|
||||
# file tclCompExpr.c. Sourcing this file into Tcl runs the tests and
|
||||
# generates output for errors. No output means no errors were found.
|
||||
#
|
||||
# Copyright (c) 1997 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} {
|
||||
testConstraint testmathfunctions 0
|
||||
} else {
|
||||
testConstraint testmathfunctions 1
|
||||
}
|
||||
|
||||
# Constrain memory leak tests
|
||||
testConstraint memory [llength [info commands memory]]
|
||||
|
||||
catch {unset a}
|
||||
|
||||
test compExpr-1.1 {TclCompileExpr procedure, successful expr parse and compile} {
|
||||
expr 1+2
|
||||
} 3
|
||||
test compExpr-1.2 {TclCompileExpr procedure, error parsing expr} -body {
|
||||
expr 1+2+
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-1.3 {TclCompileExpr procedure, error compiling expr} -body {
|
||||
list [catch {expr "foo(123)"} msg] $msg
|
||||
} -match glob -result {1 {* "*foo"}}
|
||||
|
||||
test compExpr-1.4 {TclCompileExpr procedure, expr has no operators} {
|
||||
set a {0o00123}
|
||||
expr {$a}
|
||||
} 83
|
||||
|
||||
test compExpr-2.1 {CompileSubExpr procedure, TCL_TOKEN_WORD parse token} {
|
||||
catch {unset a}
|
||||
set a 27
|
||||
expr {"foo$a" < "bar"}
|
||||
} 0
|
||||
test compExpr-2.2 {CompileSubExpr procedure, error compiling TCL_TOKEN_WORD parse token} -body {
|
||||
expr {"00[expr 1+]" + 17}
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-2.3 {CompileSubExpr procedure, TCL_TOKEN_TEXT parse token} {
|
||||
expr {{12345}}
|
||||
} 12345
|
||||
test compExpr-2.4 {CompileSubExpr procedure, empty TCL_TOKEN_TEXT parse token} {
|
||||
expr {{}}
|
||||
} {}
|
||||
test compExpr-2.5 {CompileSubExpr procedure, TCL_TOKEN_BS parse token} {
|
||||
expr "\{ \\
|
||||
+123 \}"
|
||||
} 123
|
||||
test compExpr-2.6 {CompileSubExpr procedure, TCL_TOKEN_COMMAND parse token} {
|
||||
expr {[info tclversion] != ""}
|
||||
} 1
|
||||
test compExpr-2.7 {CompileSubExpr procedure, TCL_TOKEN_COMMAND parse token} {
|
||||
expr {[]}
|
||||
} {}
|
||||
test compExpr-2.8 {CompileSubExpr procedure, error in TCL_TOKEN_COMMAND parse token} -body {
|
||||
expr {[foo "bar"xxx] + 17}
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-2.9 {CompileSubExpr procedure, TCL_TOKEN_VARIABLE parse token} {
|
||||
catch {unset a}
|
||||
set a 123
|
||||
expr {$a*2}
|
||||
} 246
|
||||
test compExpr-2.10 {CompileSubExpr procedure, TCL_TOKEN_VARIABLE parse token} {
|
||||
catch {unset a}
|
||||
catch {unset b}
|
||||
set a(george) martha
|
||||
set b geo
|
||||
expr {$a(${b}rge)}
|
||||
} martha
|
||||
test compExpr-2.11 {CompileSubExpr procedure, error in TCL_TOKEN_VARIABLE parse token} {
|
||||
catch {unset a}
|
||||
list [catch {expr {$a + 17}} msg] $msg
|
||||
} {1 {can't read "a": no such variable}}
|
||||
test compExpr-2.12 {CompileSubExpr procedure, TCL_TOKEN_SUB_EXPR parse token} {
|
||||
expr {27||3? 3<<(1+4) : 4&&9}
|
||||
} 96
|
||||
test compExpr-2.13 {CompileSubExpr procedure, error in TCL_TOKEN_SUB_EXPR parse token} {
|
||||
catch {unset a}
|
||||
set a 15
|
||||
list [catch {expr {27 || "$a[expr 1+]00"}} msg] $msg
|
||||
} {0 1}
|
||||
test compExpr-2.14 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, op found} {
|
||||
expr {5*6}
|
||||
} 30
|
||||
test compExpr-2.15 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, math function found} {
|
||||
format %.6g [expr {sin(2.0)}]
|
||||
} 0.909297
|
||||
test compExpr-2.16 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, math function not found} -body {
|
||||
list [catch {expr {fred(2.0)}} msg] $msg
|
||||
} -match glob -result {1 {* "*fred"}}
|
||||
test compExpr-2.17 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} {
|
||||
expr {4*2}
|
||||
} 8
|
||||
test compExpr-2.18 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} {
|
||||
expr {4/2}
|
||||
} 2
|
||||
test compExpr-2.19 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} {
|
||||
expr {4%2}
|
||||
} 0
|
||||
test compExpr-2.20 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} {
|
||||
expr {4<<2}
|
||||
} 16
|
||||
test compExpr-2.21 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} {
|
||||
expr {4>>2}
|
||||
} 1
|
||||
test compExpr-2.22 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} {
|
||||
expr {4<2}
|
||||
} 0
|
||||
test compExpr-2.23 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} {
|
||||
expr {4>2}
|
||||
} 1
|
||||
test compExpr-2.24 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} {
|
||||
expr {4<=2}
|
||||
} 0
|
||||
test compExpr-2.25 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} {
|
||||
expr {4>=2}
|
||||
} 1
|
||||
test compExpr-2.26 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} {
|
||||
expr {4==2}
|
||||
} 0
|
||||
test compExpr-2.27 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} {
|
||||
expr {4!=2}
|
||||
} 1
|
||||
test compExpr-2.28 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} {
|
||||
expr {4&2}
|
||||
} 0
|
||||
test compExpr-2.29 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} {
|
||||
expr {4^2}
|
||||
} 6
|
||||
test compExpr-2.30 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} {
|
||||
expr {4|2}
|
||||
} 6
|
||||
test compExpr-2.31 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator, 1 operand} {
|
||||
expr {!4}
|
||||
} 0
|
||||
test compExpr-2.32 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator, 1 operand} {
|
||||
expr {~4}
|
||||
} -5
|
||||
test compExpr-2.33 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator, comparison} {
|
||||
catch {unset a}
|
||||
set a 15
|
||||
expr {$a==15} ;# compiled out-of-line to runtime call on Tcl_ExprObjCmd
|
||||
} 1
|
||||
test compExpr-2.34 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} {
|
||||
expr {+2}
|
||||
} 2
|
||||
test compExpr-2.35 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, error in special operator} -body {
|
||||
expr {+[expr 1+]}
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-2.36 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} {
|
||||
expr {4+2}
|
||||
} 6
|
||||
test compExpr-2.37 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, error in special operator} -body {
|
||||
expr {[expr 1+]+5}
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-2.38 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, error in special operator} -body {
|
||||
expr {5+[expr 1+]}
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-2.39 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} {
|
||||
expr {-2}
|
||||
} -2
|
||||
test compExpr-2.40 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} {
|
||||
expr {4-2}
|
||||
} 2
|
||||
test compExpr-2.41 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} {
|
||||
catch {unset a}
|
||||
set a true
|
||||
expr {0||$a}
|
||||
} 1
|
||||
test compExpr-2.42 {CompileSubExpr procedure, error in TCL_TOKEN_SUB_EXPR parse token} {
|
||||
catch {unset a}
|
||||
set a 15
|
||||
list [catch {expr {27 || "$a[expr 1+]00"}} msg] $msg
|
||||
} {0 1}
|
||||
test compExpr-2.43 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} {
|
||||
catch {unset a}
|
||||
set a false
|
||||
expr {3&&$a}
|
||||
} 0
|
||||
test compExpr-2.44 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} {
|
||||
catch {unset a}
|
||||
set a false
|
||||
expr {$a||1? 1 : 0}
|
||||
} 1
|
||||
test compExpr-2.45 {CompileSubExpr procedure, error in TCL_TOKEN_SUB_EXPR parse token} {
|
||||
catch {unset a}
|
||||
set a 15
|
||||
list [catch {expr {1? 54 : "$a[expr 1+]00"}} msg] $msg
|
||||
} {0 54}
|
||||
|
||||
test compExpr-3.1 {CompileLandOrLorExpr procedure, numeric 1st operand} {
|
||||
catch {unset a}
|
||||
set a 2
|
||||
expr {[set a]||0}
|
||||
} 1
|
||||
test compExpr-3.2 {CompileLandOrLorExpr procedure, nonnumeric 1st operand} {
|
||||
catch {unset a}
|
||||
set a no
|
||||
expr {$a&&1}
|
||||
} 0
|
||||
test compExpr-3.3 {CompileSubExpr procedure, error in 1st operand} -body {
|
||||
expr {[expr *2]||0}
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-3.4 {CompileLandOrLorExpr procedure, result is 1 or 0} {
|
||||
catch {unset a}
|
||||
catch {unset b}
|
||||
set a no
|
||||
set b true
|
||||
expr {$a || $b}
|
||||
} 1
|
||||
test compExpr-3.5 {CompileLandOrLorExpr procedure, short-circuit semantics} {
|
||||
catch {unset a}
|
||||
set a yes
|
||||
expr {$a || [exit]}
|
||||
} 1
|
||||
test compExpr-3.6 {CompileLandOrLorExpr procedure, short-circuit semantics} {
|
||||
catch {unset a}
|
||||
set a no
|
||||
expr {$a && [exit]}
|
||||
} 0
|
||||
test compExpr-3.7 {CompileLandOrLorExpr procedure, numeric 2nd operand} {
|
||||
catch {unset a}
|
||||
set a 2
|
||||
expr {0||[set a]}
|
||||
} 1
|
||||
test compExpr-3.8 {CompileLandOrLorExpr procedure, nonnumeric 2nd operand} {
|
||||
catch {unset a}
|
||||
set a no
|
||||
expr {1&&$a}
|
||||
} 0
|
||||
test compExpr-3.9 {CompileLandOrLorExpr procedure, error in 2nd operand} -body {
|
||||
expr {0||[expr %2]}
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-3.10 {CompileLandOrLorExpr procedure, long lor/land arm} {
|
||||
set a "abcdefghijkl"
|
||||
set i 7
|
||||
expr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]}
|
||||
} 1
|
||||
|
||||
test compExpr-4.1 {CompileCondExpr procedure, simple test} {
|
||||
catch {unset a}
|
||||
set a 2
|
||||
expr {($a > 1)? "ok" : "nope"}
|
||||
} ok
|
||||
test compExpr-4.2 {CompileCondExpr procedure, complex test, convert to numeric} {
|
||||
catch {unset a}
|
||||
set a no
|
||||
expr {[set a]? 27 : -54}
|
||||
} -54
|
||||
test compExpr-4.3 {CompileCondExpr procedure, error in test} -body {
|
||||
expr {[expr *2]? +1 : -1}
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-4.4 {CompileCondExpr procedure, simple "true" clause} {
|
||||
catch {unset a}
|
||||
set a no
|
||||
expr {1? (27-2) : -54}
|
||||
} 25
|
||||
test compExpr-4.5 {CompileCondExpr procedure, convert "true" clause to numeric} {
|
||||
catch {unset a}
|
||||
set a no
|
||||
expr {1? $a : -54}
|
||||
} no
|
||||
test compExpr-4.6 {CompileCondExpr procedure, error in "true" clause} -body {
|
||||
expr {1? [expr *2] : -127}
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-4.7 {CompileCondExpr procedure, simple "false" clause} {
|
||||
catch {unset a}
|
||||
set a no
|
||||
expr {(2-2)? -3.14159 : "nope"}
|
||||
} nope
|
||||
test compExpr-4.8 {CompileCondExpr procedure, convert "false" clause to numeric} {
|
||||
catch {unset a}
|
||||
set a 0o0123
|
||||
expr {0? 42 : $a}
|
||||
} 83
|
||||
test compExpr-4.9 {CompileCondExpr procedure, error in "false" clause} {
|
||||
list [catch {expr {1? 15 : [expr *2]}} msg] $msg
|
||||
} {0 15}
|
||||
|
||||
test compExpr-5.1 {CompileMathFuncCall procedure, math function found} {
|
||||
format %.6g [expr atan2(1.0, 2.0)]
|
||||
} 0.463648
|
||||
test compExpr-5.2 {CompileMathFuncCall procedure, math function not found} -body {
|
||||
list [catch {expr {do_it()}} msg] $msg
|
||||
} -match glob -result {1 {* "*do_it"}}
|
||||
test compExpr-5.3 {CompileMathFuncCall: call registered math function} testmathfunctions {
|
||||
expr 3*T1()-1
|
||||
} 368
|
||||
test compExpr-5.4 {CompileMathFuncCall: call registered math function} testmathfunctions {
|
||||
expr T2()*3
|
||||
} 1035
|
||||
test compExpr-5.5 {CompileMathFuncCall procedure, too few arguments} -body {
|
||||
list [catch {expr {atan2(1.0)}} msg] $msg
|
||||
} -match glob -result {1 {too few arguments for math function*}}
|
||||
test compExpr-5.6 {CompileMathFuncCall procedure, complex argument} {
|
||||
format %.6g [expr pow(2.1, 27.5-(24.4*(5%2)))]
|
||||
} 9.97424
|
||||
test compExpr-5.7 {CompileMathFuncCall procedure, error in argument} -body {
|
||||
expr {sinh(2.*)}
|
||||
} -returnCodes error -match glob -result *
|
||||
test compExpr-5.8 {CompileMathFuncCall procedure, too many arguments} -body {
|
||||
list [catch {expr {sinh(2.0, 3.0)}} msg] $msg
|
||||
} -match glob -result {1 {too many arguments for math function*}}
|
||||
test compExpr-5.9 {CompileMathFuncCall procedure, too many arguments} -body {
|
||||
list [catch {expr {0 <= rand(5.2)}} msg] $msg
|
||||
} -match glob -result {1 {too many arguments for math function*}}
|
||||
|
||||
test compExpr-6.1 {LogSyntaxError procedure, error in expr longer than 60 chars} -body {
|
||||
expr {(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)/} -1 foo 3
|
||||
} -returnCodes error -match glob -result *
|
||||
|
||||
test compExpr-7.1 {Memory Leak} -constraints memory -setup {
|
||||
proc getbytes {} {
|
||||
set lines [split [memory info] \n]
|
||||
lindex $lines 3 3
|
||||
}
|
||||
} -body {
|
||||
set end [getbytes]
|
||||
for {set i 0} {$i < 5} {incr i} {
|
||||
interp create slave
|
||||
slave eval expr 1+2+3+4+5+6+7+8+9+10+11+12+13
|
||||
interp delete slave
|
||||
set tmp $end
|
||||
set end [getbytes]
|
||||
}
|
||||
set leakedBytes [expr {$end - $tmp}]
|
||||
} -cleanup {
|
||||
unset end i tmp
|
||||
rename getbytes {}
|
||||
} -result 0
|
||||
|
||||
test compExpr-7.2 {[Bug 1869989]: expr parser memleak} -constraints memory -setup {
|
||||
proc getbytes {} {
|
||||
set lines [split [memory info] \n]
|
||||
lindex $lines 3 3
|
||||
}
|
||||
} -body {
|
||||
set i 5
|
||||
set end [getbytes]
|
||||
while {[incr i -1]} {
|
||||
expr ${i}000
|
||||
set tmp $end
|
||||
set end [getbytes]
|
||||
}
|
||||
set leakedBytes [expr {$end - $tmp}]
|
||||
} -cleanup {
|
||||
unset end i tmp
|
||||
rename getbytes {}
|
||||
} -result 0
|
||||
|
||||
# cleanup
|
||||
catch {unset a}
|
||||
catch {unset b}
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
640
tests/compile.test
Normal file
640
tests/compile.test
Normal file
@@ -0,0 +1,640 @@
|
||||
# This file contains tests for the files tclCompile.c, tclCompCmds.c
|
||||
# and tclLiteral.c
|
||||
#
|
||||
# This file contains a collection of tests for one or more of the Tcl
|
||||
# built-in commands. Sourcing this file into Tcl runs the tests and
|
||||
# generates output for errors. No output means no errors were found.
|
||||
#
|
||||
# Copyright (c) 1997 by Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
package require tcltest 2
|
||||
namespace import -force ::tcltest::*
|
||||
|
||||
testConstraint exec [llength [info commands exec]]
|
||||
testConstraint memory [llength [info commands memory]]
|
||||
testConstraint testevalex [llength [info commands testevalex]]
|
||||
|
||||
# The following tests are very incomplete, although the rest of the
|
||||
# test suite covers this file fairly well.
|
||||
|
||||
catch {rename p ""}
|
||||
catch {namespace delete test_ns_compile}
|
||||
catch {unset x}
|
||||
catch {unset y}
|
||||
catch {unset a}
|
||||
|
||||
test compile-1.1 {TclCompileString: look up cmds in proc ns, not current ns} {
|
||||
catch {namespace delete test_ns_compile}
|
||||
catch {unset x}
|
||||
set x 123
|
||||
namespace eval test_ns_compile {
|
||||
proc set {args} {
|
||||
global x
|
||||
lappend x test_ns_compile::set
|
||||
}
|
||||
proc p {} {
|
||||
set 0
|
||||
}
|
||||
}
|
||||
list [test_ns_compile::p] [set x]
|
||||
} {{123 test_ns_compile::set} {123 test_ns_compile::set}}
|
||||
test compile-1.2 {TclCompileString, error result is reset if TclGetLong determines word isn't an integer} {
|
||||
proc p {x} {info commands 3m}
|
||||
list [catch {p} msg] $msg
|
||||
} {1 {wrong # args: should be "p x"}}
|
||||
test compile-2.1 {TclCompileDollarVar: global scalar name with ::s} {
|
||||
catch {unset x}
|
||||
set x 123
|
||||
list $::x [expr {[lsearch -exact [info globals] x] != 0}]
|
||||
} {123 1}
|
||||
test compile-2.2 {TclCompileDollarVar: global scalar name with ::s} {
|
||||
catch {unset y}
|
||||
proc p {} {
|
||||
set ::y 789
|
||||
return $::y
|
||||
}
|
||||
list [p] $::y [expr {[lsearch -exact [info globals] y] != 0}]
|
||||
} {789 789 1}
|
||||
test compile-2.3 {TclCompileDollarVar: global array name with ::s} {
|
||||
catch {unset a}
|
||||
set ::a(1) 2
|
||||
list $::a(1) [set ::a($::a(1)) 3] $::a(2) [expr {[lsearch -exact [info globals] a] != 0}]
|
||||
} {2 3 3 1}
|
||||
test compile-2.4 {TclCompileDollarVar: global scalar name with ::s} {
|
||||
catch {unset a}
|
||||
proc p {} {
|
||||
set ::a(1) 1
|
||||
return $::a($::a(1))
|
||||
}
|
||||
list [p] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}]
|
||||
} {1 1 1}
|
||||
test compile-2.5 {TclCompileDollarVar: global array, called as ${arrName(0)}} {
|
||||
catch {unset a}
|
||||
proc p {} {
|
||||
global a
|
||||
set a(1) 1
|
||||
return ${a(1)}$::a(1)$a(1)
|
||||
}
|
||||
list [p] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}]
|
||||
} {111 1 1}
|
||||
|
||||
test compile-3.1 {TclCompileCatchCmd: only catch cmds with scalar vars are compiled inline} {
|
||||
catch {unset a}
|
||||
set a(1) xyzzyx
|
||||
proc p {} {
|
||||
global a
|
||||
catch {set x 123} a(1)
|
||||
}
|
||||
list [p] $a(1)
|
||||
} {0 123}
|
||||
test compile-3.2 {TclCompileCatchCmd: non-local variables} {
|
||||
set ::foo 1
|
||||
proc catch-test {} {
|
||||
catch {set x 3} ::foo
|
||||
}
|
||||
catch-test
|
||||
set ::foo
|
||||
} 3
|
||||
test compile-3.3 {TclCompileCatchCmd: overagressive compiling [bug 219184]} {
|
||||
proc catch-test {str} {
|
||||
catch [eval $str GOOD]
|
||||
error BAD
|
||||
}
|
||||
catch {catch-test error} ::foo
|
||||
set ::foo
|
||||
} {GOOD}
|
||||
test compile-3.4 {TclCompileCatchCmd: bcc'ed [return] is caught} {
|
||||
proc foo {} {
|
||||
set fail [catch {
|
||||
return 1
|
||||
}] ; # {}
|
||||
return 2
|
||||
}
|
||||
foo
|
||||
} {2}
|
||||
test compile-3.5 {TclCompileCatchCmd: recover from error, [Bug 705406]} {
|
||||
proc foo {} {
|
||||
catch {
|
||||
if {[a]} {
|
||||
if b {}
|
||||
}
|
||||
}
|
||||
}
|
||||
list [catch foo msg] $msg
|
||||
} {0 1}
|
||||
test compile-3.6 {TclCompileCatchCmd: error in storing result [Bug 3098302]} {*}{
|
||||
-setup {
|
||||
namespace eval catchtest {
|
||||
variable result1 {}
|
||||
}
|
||||
trace add variable catchtest::result1 write catchtest::failtrace
|
||||
proc catchtest::failtrace {n1 n2 op} {
|
||||
return -code error "trace on $n1 fails by request"
|
||||
}
|
||||
}
|
||||
-body {
|
||||
proc catchtest::x {} {
|
||||
variable result1
|
||||
set count 0
|
||||
for {set i 0} {$i < 10} {incr i} {
|
||||
set status2 [catch {
|
||||
set status1 [catch {
|
||||
return -code error -level 0 "original failure"
|
||||
} result1 options1]
|
||||
} result2 options2]
|
||||
incr count
|
||||
}
|
||||
list $count $result2
|
||||
}
|
||||
catchtest::x
|
||||
}
|
||||
-result {10 {can't set "result1": trace on result1 fails by request}}
|
||||
-cleanup {namespace delete catchtest}
|
||||
}
|
||||
|
||||
|
||||
test compile-4.1 {TclCompileForCmd: command substituted test expression} {
|
||||
set i 0
|
||||
set j 0
|
||||
# Should be "forever"
|
||||
for {} [expr $i < 3] {} {
|
||||
set j [incr i]
|
||||
if {$j > 3} break
|
||||
}
|
||||
set j
|
||||
} {4}
|
||||
|
||||
test compile-5.1 {TclCompileForeachCmd: exception stack} {
|
||||
proc foreach-exception-test {} {
|
||||
foreach array(index) [list 1 2 3] break
|
||||
foreach array(index) [list 1 2 3] break
|
||||
foreach scalar [list 1 2 3] break
|
||||
}
|
||||
list [catch foreach-exception-test result] $result
|
||||
} {0 {}}
|
||||
test compile-5.2 {TclCompileForeachCmd: non-local variables} {
|
||||
set ::foo 1
|
||||
proc foreach-test {} {
|
||||
foreach ::foo {1 2 3} {}
|
||||
}
|
||||
foreach-test
|
||||
set ::foo
|
||||
} 3
|
||||
|
||||
test compile-6.1 {TclCompileSetCmd: global scalar names with ::s} {
|
||||
catch {unset x}
|
||||
catch {unset y}
|
||||
set x 123
|
||||
proc p {} {
|
||||
set ::y 789
|
||||
return $::y
|
||||
}
|
||||
list $::x [expr {[lsearch -exact [info globals] x] != 0}] \
|
||||
[p] $::y [expr {[lsearch -exact [info globals] y] != 0}]
|
||||
} {123 1 789 789 1}
|
||||
test compile-6.2 {TclCompileSetCmd: global array names with ::s} {
|
||||
catch {unset a}
|
||||
set ::a(1) 2
|
||||
proc p {} {
|
||||
set ::a(1) 1
|
||||
return $::a($::a(1))
|
||||
}
|
||||
list $::a(1) [p] [set ::a($::a(1)) 3] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}]
|
||||
} {2 1 3 3 1}
|
||||
test compile-6.3 {TclCompileSetCmd: namespace var names with ::s} {
|
||||
catch {namespace delete test_ns_compile}
|
||||
catch {unset x}
|
||||
namespace eval test_ns_compile {
|
||||
variable v hello
|
||||
variable arr
|
||||
set ::x $::test_ns_compile::v
|
||||
set ::test_ns_compile::arr(1) 123
|
||||
}
|
||||
list $::x $::test_ns_compile::arr(1)
|
||||
} {hello 123}
|
||||
|
||||
test compile-7.1 {TclCompileWhileCmd: command substituted test expression} {
|
||||
set i 0
|
||||
set j 0
|
||||
# Should be "forever"
|
||||
while [expr $i < 3] {
|
||||
set j [incr i]
|
||||
if {$j > 3} break
|
||||
}
|
||||
set j
|
||||
} {4}
|
||||
|
||||
test compile-8.1 {CollectArgInfo: binary data} {
|
||||
list [catch "string length \000foo" msg] $msg
|
||||
} {0 4}
|
||||
test compile-8.2 {CollectArgInfo: binary data} {
|
||||
list [catch "string length foo\000" msg] $msg
|
||||
} {0 4}
|
||||
test compile-8.3 {CollectArgInfo: handle "]" at end of command properly} {
|
||||
set x ]
|
||||
} {]}
|
||||
|
||||
test compile-9.1 {UpdateStringOfByteCode: called for duplicate of compiled empty object} {
|
||||
proc p {} {
|
||||
set x {}
|
||||
eval $x
|
||||
append x { }
|
||||
eval $x
|
||||
}
|
||||
p
|
||||
} {}
|
||||
|
||||
test compile-10.1 {BLACKBOX: exception stack overflow} {
|
||||
set x {{0}}
|
||||
set y 0
|
||||
while {$y < 100} {
|
||||
if !$x {incr y}
|
||||
}
|
||||
} {}
|
||||
|
||||
test compile-11.1 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
|
||||
proc p {} {
|
||||
# shared object - Interp result && Var 'r'
|
||||
set r [list foobar]
|
||||
# command that will add error to result
|
||||
lindex a bogus
|
||||
}
|
||||
list [catch {p} msg] $msg
|
||||
} {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}}
|
||||
test compile-11.2 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
|
||||
proc p {} { set r [list foobar] ; string index a bogus }
|
||||
list [catch {p} msg] $msg
|
||||
} {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}}
|
||||
test compile-11.3 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body {
|
||||
proc p {} { set r [list foobar] ; string index a 0o9 }
|
||||
list [catch {p} msg] $msg
|
||||
} -match glob -result {1 {*invalid octal number*}}
|
||||
test compile-11.4 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
|
||||
proc p {} { set r [list foobar] ; array set var {one two many} }
|
||||
list [catch {p} msg] $msg
|
||||
} {1 {list must have an even number of elements}}
|
||||
test compile-11.5 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
|
||||
proc p {} { set r [list foobar] ; incr foo bar baz}
|
||||
list [catch {p} msg] $msg
|
||||
} {1 {wrong # args: should be "incr varName ?increment?"}}
|
||||
test compile-11.6 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
|
||||
proc p {} { set r [list foobar] ; incr}
|
||||
list [catch {p} msg] $msg
|
||||
} {1 {wrong # args: should be "incr varName ?increment?"}}
|
||||
test compile-11.7 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body {
|
||||
proc p {} { set r [list foobar] ; expr !a }
|
||||
p
|
||||
} -returnCodes error -match glob -result *
|
||||
test compile-11.8 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body {
|
||||
proc p {} { set r [list foobar] ; expr {!a} }
|
||||
p
|
||||
} -returnCodes error -match glob -result *
|
||||
test compile-11.9 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
|
||||
proc p {} { set r [list foobar] ; llength "\{" }
|
||||
list [catch {p} msg] $msg
|
||||
} {1 {unmatched open brace in list}}
|
||||
|
||||
#
|
||||
# Special section for tests of tclLiteral.c
|
||||
# The following tests check for incorrect memory handling in
|
||||
# TclReleaseLiteral. They are only effective when tcl is compiled
|
||||
# with TCL_MEM_DEBUG
|
||||
#
|
||||
# Special test for leak on interp delete [Bug 467523].
|
||||
test compile-12.1 {testing literal leak on interp delete} -setup {
|
||||
proc getbytes {} {
|
||||
set lines [split [memory info] "\n"]
|
||||
lindex $lines 3 3
|
||||
}
|
||||
} -constraints memory -body {
|
||||
set end [getbytes]
|
||||
for {set i 0} {$i < 5} {incr i} {
|
||||
interp create foo
|
||||
foo eval {
|
||||
namespace eval bar {}
|
||||
}
|
||||
interp delete foo
|
||||
set tmp $end
|
||||
set end [getbytes]
|
||||
}
|
||||
set leakedBytes [expr {$end - $tmp}]
|
||||
} -cleanup {
|
||||
rename getbytes {}
|
||||
unset -nocomplain end i tmp leakedBytes
|
||||
} -result 0
|
||||
# Special test for a memory error in a preliminary fix of [Bug 467523].
|
||||
# It requires executing a helpfile. Presumably the child process is
|
||||
# used because when this test fails, it crashes.
|
||||
test compile-12.2 {testing error on literal deletion} -constraints {memory exec} -body {
|
||||
set sourceFile [makeFile {
|
||||
for {set i 0} {$i < 5} {incr i} {
|
||||
namespace eval bar {}
|
||||
namespace delete bar
|
||||
}
|
||||
puts 0
|
||||
} source.file]
|
||||
exec [interpreter] $sourceFile
|
||||
} -cleanup {
|
||||
catch {removeFile $sourceFile}
|
||||
} -result 0
|
||||
# Test to catch buffer overrun in TclCompileTokens from buf 530320
|
||||
test compile-12.3 {check for a buffer overrun} -body {
|
||||
proc crash {} {
|
||||
puts $array([expr {a+2}])
|
||||
}
|
||||
crash
|
||||
} -returnCodes error -cleanup {
|
||||
rename crash {}
|
||||
} -match glob -result *
|
||||
test compile-12.4 {TclCleanupLiteralTable segfault} -body {
|
||||
# Tcl Bug 1001997
|
||||
# Here, we're trying to test a case that causes a crash in
|
||||
# TclCleanupLiteralTable. The conditions that we're trying to
|
||||
# establish are:
|
||||
# - TclCleanupLiteralTable is attempting to clean up a bytecode
|
||||
# object in the literal table.
|
||||
# - The bytecode object in question contains the only reference
|
||||
# to another literal.
|
||||
# - The literal in question is in the same hash bucket as the bytecode
|
||||
# object, and immediately follows it in the chain.
|
||||
# Since newly registered literals are added at the FRONT of the
|
||||
# bucket chains, and since the bytecode object is registered before
|
||||
# its literals, this is difficult to achieve. What we do is:
|
||||
# (a) do a [namespace eval] of a string that's calculated to
|
||||
# hash into the same bucket as a literal that it contains.
|
||||
# In this case, the script and the variable 'bugbug'
|
||||
# land in the same bucket.
|
||||
# (b) do a [namespace eval] of a string that contains enough
|
||||
# literals to force TclRegisterLiteral to rebuild the global
|
||||
# literal table. The newly created hash buckets will contain
|
||||
# the literals, IN REVERSE ORDER, thus putting the bytecode
|
||||
# immediately ahead of 'bugbug' and 'bug4345bug'. The bytecode
|
||||
# object will contain the only references to those two literals.
|
||||
# (c) Delete the interpreter to invoke TclCleanupLiteralTable
|
||||
# and tickle the bug.
|
||||
proc foo {} {
|
||||
set i [interp create]
|
||||
$i eval {
|
||||
namespace eval ::w {concat 4649; variable bugbug}
|
||||
namespace eval ::w {
|
||||
concat x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 \
|
||||
x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 \
|
||||
x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 \
|
||||
x31 x32 X33 X34 X35 X36 X37 X38 X39 X40 \
|
||||
x41 x42 x43 x44 x45 x46 x47 x48 x49 x50 \
|
||||
x51 x52 x53 x54 x55 x56 x57 x58 x59 x60 \
|
||||
x61 x62 x63 x64
|
||||
concat y1 y2 y3 y4 y5 y6 y7 y8 y9 y10 \
|
||||
y11 y12 y13 y14 y15 y16 y17 y18 y19 y20 \
|
||||
y21 y22 y23 y24 y25 y26 y27 y28 y29 y30 \
|
||||
y31 y32 Y33 Y34 Y35 Y36 Y37 Y38 Y39 Y40 \
|
||||
y41 y42 y43 y44 y45 y46 y47 y48 y49 y50 \
|
||||
y51 y52 y53 y54 y55 y56 y57 y58 y59 y60 \
|
||||
y61 y62 y63 y64
|
||||
concat z1 z2 z3 z4 z5 z6 z7 z8 z9 z10 \
|
||||
z11 z12 z13 z14 z15 z16 z17 z18 z19 z20 \
|
||||
z21 z22 z23 z24 z25 z26 z27 z28 z29 z30 \
|
||||
z31 z32
|
||||
}
|
||||
}
|
||||
interp delete $i; # must not crash
|
||||
return ok
|
||||
}
|
||||
foo
|
||||
} -cleanup {
|
||||
rename foo {}
|
||||
} -result ok
|
||||
|
||||
# Special test for underestimating the maxStackSize required for a
|
||||
# compiled command. A failure will cause a segfault in the child
|
||||
# process.
|
||||
test compile-13.1 {testing underestimate of maxStackSize in list cmd} {exec} {
|
||||
set body {set x [list}
|
||||
for {set i 0} {$i < 3000} {incr i} {
|
||||
append body " $i"
|
||||
}
|
||||
append body {]; puts OK}
|
||||
regsub BODY {proc crash {} {BODY}; crash} $body script
|
||||
list [catch {exec [interpreter] << $script} msg] $msg
|
||||
} {0 OK}
|
||||
|
||||
# Special test for compiling tokens from a copy of the source
|
||||
# string [Bug #599788]
|
||||
test compile-14.1 {testing errors in element name; segfault?} {} {
|
||||
catch {set a([error])} msg1
|
||||
catch {set bubba([join $abba $jubba]) $vol} msg2
|
||||
list $msg1 $msg2
|
||||
} {{wrong # args: should be "error message ?errorInfo? ?errorCode?"} {can't read "abba": no such variable}}
|
||||
|
||||
# Tests compile-15.* cover Tcl Bug 633204
|
||||
test compile-15.1 {proper TCL_RETURN code from [return]} {
|
||||
proc p {} {catch return}
|
||||
set result [p]
|
||||
rename p {}
|
||||
set result
|
||||
} 2
|
||||
test compile-15.2 {proper TCL_RETURN code from [return]} {
|
||||
proc p {} {catch {return foo}}
|
||||
set result [p]
|
||||
rename p {}
|
||||
set result
|
||||
} 2
|
||||
test compile-15.3 {proper TCL_RETURN code from [return]} {
|
||||
proc p {} {catch {return $::tcl_library}}
|
||||
set result [p]
|
||||
rename p {}
|
||||
set result
|
||||
} 2
|
||||
test compile-15.4 {proper TCL_RETURN code from [return]} {
|
||||
proc p {} {catch {return [info library]}}
|
||||
set result [p]
|
||||
rename p {}
|
||||
set result
|
||||
} 2
|
||||
test compile-15.5 {proper TCL_RETURN code from [return]} {
|
||||
proc p {} {catch {set a 1}; return}
|
||||
set result [p]
|
||||
rename p {}
|
||||
set result
|
||||
} ""
|
||||
|
||||
for {set noComp 0} {$noComp <= 1} {incr noComp} {
|
||||
|
||||
if $noComp {
|
||||
interp alias {} run {} testevalex
|
||||
set constraints testevalex
|
||||
} else {
|
||||
interp alias {} run {} if 1
|
||||
set constraints {}
|
||||
}
|
||||
|
||||
test compile-16.1.$noComp {TclCompileScript: word expansion} $constraints {
|
||||
run "list [string repeat {{*}a } 255]"
|
||||
} [lrepeat 255 a]
|
||||
test compile-16.2.$noComp {TclCompileScript: word expansion} $constraints {
|
||||
run "list [string repeat {{*}a } 256]"
|
||||
} [lrepeat 256 a]
|
||||
test compile-16.3.$noComp {TclCompileScript: word expansion} $constraints {
|
||||
run "list [string repeat {{*}a } 257]"
|
||||
} [lrepeat 257 a]
|
||||
test compile-16.4.$noComp {TclCompileScript: word expansion} $constraints {
|
||||
run {{*}list}
|
||||
} {}
|
||||
test compile-16.5.$noComp {TclCompileScript: word expansion} $constraints {
|
||||
run {{*}list {*}{x y z}}
|
||||
} {x y z}
|
||||
test compile-16.6.$noComp {TclCompileScript: word expansion} $constraints {
|
||||
run {{*}list {*}[list x y z]}
|
||||
} {x y z}
|
||||
test compile-16.7.$noComp {TclCompileScript: word expansion} $constraints {
|
||||
run {{*}list {*}[list x y z][list x y z]}
|
||||
} {x y zx y z}
|
||||
test compile-16.8.$noComp {TclCompileScript: word expansion} -body {
|
||||
set l {x y z}
|
||||
run {{*}list {*}$l}
|
||||
} -constraints $constraints -cleanup {
|
||||
unset l
|
||||
} -result {x y z}
|
||||
test compile-16.9.$noComp {TclCompileScript: word expansion} -body {
|
||||
set l {x y z}
|
||||
run {{*}list {*}$l$l}
|
||||
} -constraints $constraints -cleanup {
|
||||
unset l
|
||||
} -result {x y zx y z}
|
||||
test compile-16.10.$noComp {TclCompileScript: word expansion} -body {
|
||||
run {{*}\{}
|
||||
} -constraints $constraints -returnCodes error \
|
||||
-result {unmatched open brace in list}
|
||||
test compile-16.11.$noComp {TclCompileScript: word expansion} -body {
|
||||
proc badList {} {return \{}
|
||||
run {{*}[badList]}
|
||||
} -constraints $constraints -cleanup {
|
||||
rename badList {}
|
||||
} -returnCodes error -result {unmatched open brace in list}
|
||||
test compile-16.12.$noComp {TclCompileScript: word expansion} $constraints {
|
||||
run {{*}list x y z}
|
||||
} {x y z}
|
||||
test compile-16.13.$noComp {TclCompileScript: word expansion} $constraints {
|
||||
run {{*}list x y {*}z}
|
||||
} {x y z}
|
||||
test compile-16.14.$noComp {TclCompileScript: word expansion} $constraints {
|
||||
run {{*}list x {*}y z}
|
||||
} {x y z}
|
||||
test compile-16.15.$noComp {TclCompileScript: word expansion} $constraints {
|
||||
run {list x y {*}z}
|
||||
} {x y z}
|
||||
test compile-16.16.$noComp {TclCompileScript: word expansion} $constraints {
|
||||
run {list x {*}y z}
|
||||
} {x y z}
|
||||
test compile-16.17.$noComp {TclCompileScript: word expansion} $constraints {
|
||||
run {list {*}x y z}
|
||||
} {x y z}
|
||||
|
||||
# These tests note that expansion can in theory cause the number of
|
||||
# arguments to a command to exceed INT_MAX, which is as big as objc
|
||||
# is allowed to get.
|
||||
#
|
||||
# In practice, it seems we will run out of memory before we confront
|
||||
# this issue. Note that compiled operations run out of memory at
|
||||
# smaller objc values than direct string evaluation.
|
||||
#
|
||||
# These tests are constrained as knownBug because they are likely
|
||||
# to cause memory allocation panics somewhere, and we don't want
|
||||
# panics in the test suite.
|
||||
#
|
||||
test compile-16.18.$noComp {TclCompileScript: word expansion} -body {
|
||||
proc LongList {} {return [lrepeat [expr {1<<10}] x]}
|
||||
llength [run "list [string repeat {{*}[LongList] } [expr {1<<10}]]"]
|
||||
} -constraints [linsert $constraints 0 knownBug] -cleanup {
|
||||
rename LongList {}
|
||||
} -returnCodes ok -result [expr {1<<20}]
|
||||
test compile-16.19.$noComp {TclCompileScript: word expansion} -body {
|
||||
proc LongList {} {return [lrepeat [expr {1<<11}] x]}
|
||||
llength [run "list [string repeat {{*}[LongList] } [expr {1<<11}]]"]
|
||||
} -constraints [linsert $constraints 0 knownBug] -cleanup {
|
||||
rename LongList {}
|
||||
} -returnCodes ok -result [expr {1<<22}]
|
||||
test compile-16.20.$noComp {TclCompileScript: word expansion} -body {
|
||||
proc LongList {} {return [lrepeat [expr {1<<12}] x]}
|
||||
llength [run "list [string repeat {{*}[LongList] } [expr {1<<12}]]"]
|
||||
} -constraints [linsert $constraints 0 knownBug] -cleanup {
|
||||
rename LongList {}
|
||||
} -returnCodes ok -result [expr {1<<24}]
|
||||
# This is the one that should cause overflow
|
||||
test compile-16.21.$noComp {TclCompileScript: word expansion} -body {
|
||||
proc LongList {} {return [lrepeat [expr {1<<16}] x]}
|
||||
llength [run "list [string repeat {{*}[LongList] } [expr {1<<16}]]"]
|
||||
} -constraints [linsert $constraints 0 knownBug] -cleanup {
|
||||
rename LongList {}
|
||||
} -returnCodes ok -result [expr {wide(1)<<32}]
|
||||
test compile-16.22.$noComp {
|
||||
Bug 845412: TclCompileScript: word expansion not mandatory
|
||||
} -body {
|
||||
# This test may crash and will fail unless Bug 845412 is fixed.
|
||||
proc ReturnResults args {return $args}
|
||||
run "ReturnResults [string repeat {x } 260]"
|
||||
} -constraints $constraints -cleanup {
|
||||
rename ReturnResults {}
|
||||
} -returnCodes ok -result [string trim [string repeat {x } 260]]
|
||||
test compile-16.23.$noComp {
|
||||
Bug 1032805: defer parse error until run time
|
||||
} -constraints $constraints -body {
|
||||
namespace eval x {
|
||||
run {
|
||||
proc if {a b} {uplevel 1 [list set $a $b]}
|
||||
if 1 {syntax {}{}}
|
||||
}
|
||||
}
|
||||
} -cleanup {
|
||||
namespace delete x
|
||||
} -returnCodes ok -result {syntax {}{}}
|
||||
test compile-16.24.$noComp {
|
||||
Bug 1638414: bad list constant as first expanded term
|
||||
} -constraints $constraints -body {
|
||||
run "{*}\"\{foo bar\""
|
||||
} -returnCodes error -result {unmatched open brace in list}
|
||||
} ;# End of noComp loop
|
||||
|
||||
# These tests are messy because it wrecks the interpreter it runs in!
|
||||
# They demonstrate issues arising from [FRQ 1101710]
|
||||
test compile-17.1 {Command interpretation binding for compiled code} -constraints knownBug -setup {
|
||||
set i [interp create]
|
||||
} -body {
|
||||
$i eval {
|
||||
if 1 {
|
||||
expr [
|
||||
proc expr args {return substituted}
|
||||
format {[subst compiled]}
|
||||
]
|
||||
}
|
||||
}
|
||||
} -cleanup {
|
||||
interp delete $i
|
||||
} -result substituted
|
||||
test compile-17.2 {Command interpretation binding for non-compiled code} -setup {
|
||||
set i [interp create]
|
||||
} -body {
|
||||
$i eval {
|
||||
if 1 {
|
||||
[subst expr] [
|
||||
proc expr args {return substituted}
|
||||
format {[subst compiled]}
|
||||
]
|
||||
}
|
||||
}
|
||||
} -cleanup {
|
||||
interp delete $i
|
||||
} -result substituted
|
||||
|
||||
# cleanup
|
||||
catch {rename p ""}
|
||||
catch {namespace delete test_ns_compile}
|
||||
catch {unset x}
|
||||
catch {unset y}
|
||||
catch {unset a}
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
52
tests/concat.test
Normal file
52
tests/concat.test
Normal file
@@ -0,0 +1,52 @@
|
||||
# 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.
|
||||
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
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: one empty argument} {
|
||||
concat {}
|
||||
} {}
|
||||
|
||||
test concat-3.1 {error: no arguments} {
|
||||
list [catch concat msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
test concat-4.1 {pruning off extra white space} {
|
||||
concat {} {a b c}
|
||||
} {a b c}
|
||||
test concat-4.2 {pruning off extra white space} {
|
||||
concat x y " a b c \n\t " " " " def "
|
||||
} {x y a b c def}
|
||||
test concat-4.3 {pruning off extra white space sets length correctly} {
|
||||
llength [concat { {{a}} }]
|
||||
} 1
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
60
tests/config.test
Normal file
60
tests/config.test
Normal file
@@ -0,0 +1,60 @@
|
||||
# -*- tcl -*-
|
||||
# Commands covered: pkgconfig
|
||||
#
|
||||
# This file contains a collection of tests for one or more of the Tcl
|
||||
# built-in commands. Sourcing this file into Tcl runs the tests and
|
||||
# generates output for errors. No output means no errors were found.
|
||||
#
|
||||
# Copyright (c) 1991-1993 The Regents of the University of California.
|
||||
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
test pkgconfig-1.1 {query keys} {
|
||||
lsort [::tcl::pkgconfig list]
|
||||
} {64bit bindir,install bindir,runtime compile_debug compile_stats debug docdir,install docdir,runtime includedir,install includedir,runtime libdir,install libdir,runtime mem_debug optimized profiled scriptdir,install scriptdir,runtime threaded}
|
||||
test pkgconfig-1.2 {query keys multiple times} {
|
||||
string compare [::tcl::pkgconfig list] [::tcl::pkgconfig list]
|
||||
} 0
|
||||
test pkgconfig-1.3 {query value multiple times} {
|
||||
string compare \
|
||||
[::tcl::pkgconfig get bindir,install] \
|
||||
[::tcl::pkgconfig get bindir,install]
|
||||
} 0
|
||||
|
||||
|
||||
test pkgconfig-2.0 {error: missing subcommand} {
|
||||
catch {::tcl::pkgconfig} msg
|
||||
set msg
|
||||
} {wrong # args: should be "::tcl::pkgconfig subcommand ?argument?"}
|
||||
test pkgconfig-2.1 {error: illegal subcommand} {
|
||||
catch {::tcl::pkgconfig foo} msg
|
||||
set msg
|
||||
} {bad subcommand "foo": must be get or list}
|
||||
test pkgconfig-2.2 {error: list with arguments} {
|
||||
catch {::tcl::pkgconfig list foo} msg
|
||||
set msg
|
||||
} {wrong # args: should be "::tcl::pkgconfig list"}
|
||||
test pkgconfig-2.3 {error: get without arguments} {
|
||||
catch {::tcl::pkgconfig get} msg
|
||||
set msg
|
||||
} {wrong # args: should be "::tcl::pkgconfig get key"}
|
||||
test pkgconfig-2.4 {error: query unknown key} {
|
||||
catch {::tcl::pkgconfig get foo} msg
|
||||
set msg
|
||||
} {key not known}
|
||||
test pkgconfig-2.5 {error: query with to many arguments} {
|
||||
catch {::tcl::pkgconfig get foo bar} msg
|
||||
set msg
|
||||
} {wrong # args: should be "::tcl::pkgconfig subcommand ?argument?"}
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
40
tests/dcall.test
Normal file
40
tests/dcall.test
Normal file
@@ -0,0 +1,40 @@
|
||||
# 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.
|
||||
# Copyright (c) 1994 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
package require tcltest 2
|
||||
namespace import ::tcltest::*
|
||||
|
||||
testConstraint testdcall [llength [info commands testdcall]]
|
||||
|
||||
test dcall-1.1 {deletion callbacks} testdcall {
|
||||
lsort -increasing [testdcall 1 2 3]
|
||||
} {1 2 3}
|
||||
test dcall-1.2 {deletion callbacks} testdcall {
|
||||
testdcall
|
||||
} {}
|
||||
test dcall-1.3 {deletion callbacks} testdcall {
|
||||
lsort -increasing [testdcall 20 21 22 -22]
|
||||
} {20 21}
|
||||
test dcall-1.4 {deletion callbacks} testdcall {
|
||||
lsort -increasing [testdcall 20 21 22 -20]
|
||||
} {21 22}
|
||||
test dcall-1.5 {deletion callbacks} testdcall {
|
||||
lsort -increasing [testdcall 20 21 22 -21]
|
||||
} {20 22}
|
||||
test dcall-1.6 {deletion callbacks} testdcall {
|
||||
lsort -increasing [testdcall 20 21 22 -21 -22 -20]
|
||||
} {}
|
||||
|
||||
# cleanup
|
||||
cleanupTests
|
||||
return
|
||||
1254
tests/dict.test
Normal file
1254
tests/dict.test
Normal file
File diff suppressed because it is too large
Load Diff
328
tests/dstring.test
Normal file
328
tests/dstring.test
Normal file
@@ -0,0 +1,328 @@
|
||||
# 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.
|
||||
# Copyright (c) 1994 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
testConstraint testdstring [llength [info commands testdstring]]
|
||||
|
||||
test dstring-1.1 {appending and retrieving} testdstring {
|
||||
testdstring free
|
||||
testdstring append "abc" -1
|
||||
list [testdstring get] [testdstring length]
|
||||
} {abc 3}
|
||||
test dstring-1.2 {appending and retrieving} testdstring {
|
||||
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 {
|
||||
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 {
|
||||
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 {
|
||||
testdstring free
|
||||
testdstring element "x"
|
||||
testdstring element "\{"
|
||||
testdstring element "ab\}"
|
||||
testdstring get
|
||||
} {x \{ ab\}}
|
||||
test dstring-2.3 {appending list elements} testdstring {
|
||||
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-2.4 {appending list elements} testdstring {
|
||||
testdstring free
|
||||
testdstring append "a\{" -1
|
||||
testdstring element abc
|
||||
testdstring append " \{" -1
|
||||
testdstring element xyzzy
|
||||
testdstring get
|
||||
} "a{ abc {xyzzy"
|
||||
test dstring-2.5 {appending list elements} testdstring {
|
||||
testdstring free
|
||||
testdstring append " \{" -1
|
||||
testdstring element abc
|
||||
testdstring get
|
||||
} " {abc"
|
||||
test dstring-2.6 {appending list elements} testdstring {
|
||||
testdstring free
|
||||
testdstring append " " -1
|
||||
testdstring element abc
|
||||
testdstring get
|
||||
} { abc}
|
||||
test dstring-2.7 {appending list elements} testdstring {
|
||||
testdstring free
|
||||
testdstring append "\\ " -1
|
||||
testdstring element abc
|
||||
testdstring get
|
||||
} "\\ abc"
|
||||
test dstring-2.8 {appending list elements} testdstring {
|
||||
testdstring free
|
||||
testdstring append "x " -1
|
||||
testdstring element abc
|
||||
testdstring get
|
||||
} {x abc}
|
||||
test dstring-2.9 {appending list elements} testdstring {
|
||||
testdstring free
|
||||
testdstring element #
|
||||
testdstring get
|
||||
} {{#}}
|
||||
test dstring-2.10 {appending list elements} testdstring {
|
||||
testdstring free
|
||||
testdstring append " " -1
|
||||
testdstring element #
|
||||
testdstring get
|
||||
} { {#}}
|
||||
test dstring-2.11 {appending list elements} testdstring {
|
||||
testdstring free
|
||||
testdstring append \t -1
|
||||
testdstring element #
|
||||
testdstring get
|
||||
} \t{#}
|
||||
test dstring-2.12 {appending list elements} testdstring {
|
||||
testdstring free
|
||||
testdstring append x -1
|
||||
testdstring element #
|
||||
testdstring get
|
||||
} {x #}
|
||||
test dstring-2.13 {appending list elements} testdstring {
|
||||
# This test shows lack of sophistication in Tcl_DStringAppendElement's
|
||||
# decision about whether #-quoting can be disabled.
|
||||
testdstring free
|
||||
testdstring append "x " -1
|
||||
testdstring element #
|
||||
testdstring get
|
||||
} {x {#}}
|
||||
|
||||
test dstring-3.1 {nested sublists} testdstring {
|
||||
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 {
|
||||
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 {
|
||||
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 {
|
||||
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.5 {nested sublists} testdstring {
|
||||
testdstring free
|
||||
testdstring element "\{"
|
||||
testdstring start
|
||||
testdstring element first
|
||||
testdstring element second
|
||||
testdstring end
|
||||
testdstring get
|
||||
} {\{ {first second}}
|
||||
test dstring-3.6 {appending list elements} testdstring {
|
||||
testdstring free
|
||||
testdstring append x -1
|
||||
testdstring start
|
||||
testdstring element #
|
||||
testdstring end
|
||||
testdstring get
|
||||
} {x {{#}}}
|
||||
test dstring-3.7 {appending list elements} testdstring {
|
||||
testdstring free
|
||||
testdstring append x -1
|
||||
testdstring start
|
||||
testdstring append " " -1
|
||||
testdstring element #
|
||||
testdstring end
|
||||
testdstring get
|
||||
} {x { {#}}}
|
||||
test dstring-3.8 {appending list elements} testdstring {
|
||||
testdstring free
|
||||
testdstring append x -1
|
||||
testdstring start
|
||||
testdstring append \t -1
|
||||
testdstring element #
|
||||
testdstring end
|
||||
testdstring get
|
||||
} "x {\t{#}}"
|
||||
test dstring-3.9 {appending list elements} testdstring {
|
||||
testdstring free
|
||||
testdstring append x -1
|
||||
testdstring start
|
||||
testdstring append x -1
|
||||
testdstring element #
|
||||
testdstring end
|
||||
testdstring get
|
||||
} {x {x #}}
|
||||
test dstring-3.10 {appending list elements} testdstring {
|
||||
# This test shows lack of sophistication in Tcl_DStringAppendElement's
|
||||
# decision about whether #-quoting can be disabled.
|
||||
testdstring free
|
||||
testdstring append x -1
|
||||
testdstring start
|
||||
testdstring append "x " -1
|
||||
testdstring element #
|
||||
testdstring end
|
||||
testdstring get
|
||||
} {x {x {#}}}
|
||||
|
||||
test dstring-4.1 {truncation} testdstring {
|
||||
testdstring free
|
||||
testdstring append "abcdefg" -1
|
||||
testdstring trunc 3
|
||||
list [testdstring get] [testdstring length]
|
||||
} {abc 3}
|
||||
test dstring-4.2 {truncation} testdstring {
|
||||
testdstring free
|
||||
testdstring append "xyzzy" -1
|
||||
testdstring trunc 0
|
||||
list [testdstring get] [testdstring length]
|
||||
} {{} 0}
|
||||
|
||||
test dstring-5.1 {copying to result} testdstring {
|
||||
testdstring free
|
||||
testdstring append xyz -1
|
||||
testdstring result
|
||||
} xyz
|
||||
test dstring-5.2 {copying to result} testdstring {
|
||||
testdstring free
|
||||
catch {unset a}
|
||||
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}
|
||||
|
||||
test dstring-6.1 {Tcl_DStringGetResult} testdstring {
|
||||
testdstring free
|
||||
list [testdstring gresult staticsmall] [testdstring get]
|
||||
} {{} short}
|
||||
test dstring-6.2 {Tcl_DStringGetResult} testdstring {
|
||||
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 gresult staticsmall] [testdstring get]
|
||||
} {{} short}
|
||||
test dstring-6.3 {Tcl_DStringGetResult} testdstring {
|
||||
set result {}
|
||||
lappend result [testdstring gresult staticlarge]
|
||||
testdstring append x 1
|
||||
lappend result [testdstring get]
|
||||
} {{} {first0 first1 first2 first3 first4 first5 first6 first7 first8 first9
|
||||
second0 second1 second2 second3 second4 second5 second6 second7 second8 second9
|
||||
third0 third1 third2 third3 third4 third5 third6 third7 third8 third9
|
||||
fourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9
|
||||
fifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9
|
||||
sixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9
|
||||
seventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9
|
||||
x}}
|
||||
test dstring-6.4 {Tcl_DStringGetResult} testdstring {
|
||||
set result {}
|
||||
lappend result [testdstring gresult free]
|
||||
testdstring append y 1
|
||||
lappend result [testdstring get]
|
||||
} {{} {This is a malloc-ed stringy}}
|
||||
test dstring-6.5 {Tcl_DStringGetResult} testdstring {
|
||||
set result {}
|
||||
lappend result [testdstring gresult special]
|
||||
testdstring append z 1
|
||||
lappend result [testdstring get]
|
||||
} {{} {This is a specially-allocated stringz}}
|
||||
|
||||
# cleanup
|
||||
if {[testConstraint testdstring]} {
|
||||
testdstring free
|
||||
}
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
605
tests/encoding.test
Normal file
605
tests/encoding.test
Normal file
@@ -0,0 +1,605 @@
|
||||
# This file contains a collection of tests for tclEncoding.c
|
||||
# Sourcing this file into Tcl runs the tests and generates output for
|
||||
# errors. No output means no errors were found.
|
||||
#
|
||||
# Copyright (c) 1997 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
package require tcltest 2
|
||||
|
||||
namespace eval ::tcl::test::encoding {
|
||||
variable x
|
||||
|
||||
namespace import -force ::tcltest::*
|
||||
|
||||
proc toutf {args} {
|
||||
variable x
|
||||
lappend x "toutf $args"
|
||||
}
|
||||
proc fromutf {args} {
|
||||
variable x
|
||||
lappend x "fromutf $args"
|
||||
}
|
||||
|
||||
proc runtests {} {
|
||||
|
||||
variable x
|
||||
|
||||
# Some tests require the testencoding command
|
||||
testConstraint testencoding [llength [info commands testencoding]]
|
||||
testConstraint exec [llength [info commands exec]]
|
||||
|
||||
# TclInitEncodingSubsystem is tested by the rest of this file
|
||||
# TclFinalizeEncodingSubsystem is not currently tested
|
||||
|
||||
test encoding-1.1 {Tcl_GetEncoding: system encoding} {testencoding} {
|
||||
testencoding create foo [namespace origin toutf] [namespace origin fromutf]
|
||||
set old [encoding system]
|
||||
encoding system foo
|
||||
set x {}
|
||||
encoding convertto abcd
|
||||
encoding system $old
|
||||
testencoding delete foo
|
||||
set x
|
||||
} {{fromutf }}
|
||||
test encoding-1.2 {Tcl_GetEncoding: existing encoding} {testencoding} {
|
||||
testencoding create foo [namespace origin toutf] [namespace origin fromutf]
|
||||
set x {}
|
||||
encoding convertto foo abcd
|
||||
testencoding delete foo
|
||||
set x
|
||||
} {{fromutf }}
|
||||
test encoding-1.3 {Tcl_GetEncoding: load encoding} {
|
||||
list [encoding convertto jis0208 \u4e4e] \
|
||||
[encoding convertfrom jis0208 8C]
|
||||
} "8C \u4e4e"
|
||||
|
||||
test encoding-2.1 {Tcl_FreeEncoding: refcount == 0} {
|
||||
encoding convertto jis0208 \u4e4e
|
||||
} {8C}
|
||||
test encoding-2.2 {Tcl_FreeEncoding: refcount != 0} {testencoding} {
|
||||
set system [encoding system]
|
||||
set path [encoding dirs]
|
||||
encoding system shiftjis ;# incr ref count
|
||||
encoding dirs [list [pwd]]
|
||||
set x [encoding convertto shiftjis \u4e4e] ;# old one found
|
||||
encoding system identity
|
||||
llength shiftjis
|
||||
lappend x [catch {encoding convertto shiftjis \u4e4e} msg] $msg
|
||||
encoding system identity
|
||||
encoding dirs $path
|
||||
encoding system $system
|
||||
set x
|
||||
} "\u008c\u00c1 1 {unknown encoding \"shiftjis\"}"
|
||||
|
||||
test encoding-3.1 {Tcl_GetEncodingName, NULL} {
|
||||
set old [encoding system]
|
||||
encoding system shiftjis
|
||||
set x [encoding system]
|
||||
encoding system $old
|
||||
set x
|
||||
} {shiftjis}
|
||||
test encoding-3.2 {Tcl_GetEncodingName, non-null} {
|
||||
set old [fconfigure stdout -encoding]
|
||||
fconfigure stdout -encoding jis0208
|
||||
set x [fconfigure stdout -encoding]
|
||||
fconfigure stdout -encoding $old
|
||||
set x
|
||||
} {jis0208}
|
||||
|
||||
test encoding-4.1 {Tcl_GetEncodingNames} {testencoding} {
|
||||
cd [makeDirectory tmp]
|
||||
makeDirectory [file join tmp encoding]
|
||||
makeFile {} [file join tmp encoding junk.enc]
|
||||
makeFile {} [file join tmp encoding junk2.enc]
|
||||
set path [encoding dirs]
|
||||
encoding dirs {}
|
||||
catch {unset encodings}
|
||||
catch {unset x}
|
||||
foreach encoding [encoding names] {
|
||||
set encodings($encoding) 1
|
||||
}
|
||||
encoding dirs [list [file join [pwd] encoding]]
|
||||
foreach encoding [encoding names] {
|
||||
if {![info exists encodings($encoding)]} {
|
||||
lappend x $encoding
|
||||
}
|
||||
}
|
||||
encoding dirs $path
|
||||
cd [workingDirectory]
|
||||
removeFile [file join tmp encoding junk2.enc]
|
||||
removeFile [file join tmp encoding junk.enc]
|
||||
removeDirectory [file join tmp encoding]
|
||||
removeDirectory tmp
|
||||
lsort $x
|
||||
} {junk junk2}
|
||||
|
||||
test encoding-5.1 {Tcl_SetSystemEncoding} {
|
||||
set old [encoding system]
|
||||
encoding system jis0208
|
||||
set x [encoding convertto \u4e4e]
|
||||
encoding system identity
|
||||
encoding system $old
|
||||
set x
|
||||
} {8C}
|
||||
test encoding-5.2 {Tcl_SetSystemEncoding: test ref count} {
|
||||
set old [encoding system]
|
||||
encoding system $old
|
||||
string compare $old [encoding system]
|
||||
} {0}
|
||||
|
||||
test encoding-6.1 {Tcl_CreateEncoding: new} {testencoding} {
|
||||
testencoding create foo [namespace code {toutf 1}] \
|
||||
[namespace code {fromutf 2}]
|
||||
set x {}
|
||||
encoding convertfrom foo abcd
|
||||
encoding convertto foo abcd
|
||||
testencoding delete foo
|
||||
set x
|
||||
} {{toutf 1} {fromutf 2}}
|
||||
test encoding-6.2 {Tcl_CreateEncoding: replace encoding} {testencoding} {
|
||||
testencoding create foo [namespace code {toutf a}] \
|
||||
[namespace code {fromutf b}]
|
||||
set x {}
|
||||
encoding convertfrom foo abcd
|
||||
encoding convertto foo abcd
|
||||
testencoding delete foo
|
||||
set x
|
||||
} {{toutf a} {fromutf b}}
|
||||
|
||||
test encoding-7.1 {Tcl_ExternalToUtfDString: small buffer} {
|
||||
encoding convertfrom jis0208 8c8c8c8c
|
||||
} "\u543e\u543e\u543e\u543e"
|
||||
test encoding-7.2 {Tcl_UtfToExternalDString: big buffer} {
|
||||
set a 8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C
|
||||
append a $a
|
||||
append a $a
|
||||
append a $a
|
||||
append a $a
|
||||
set x [encoding convertfrom jis0208 $a]
|
||||
list [string length $x] [string index $x 0]
|
||||
} "512 \u4e4e"
|
||||
|
||||
test encoding-8.1 {Tcl_ExternalToUtf} {
|
||||
set f [open [file join [temporaryDirectory] dummy] w]
|
||||
fconfigure $f -translation binary -encoding iso8859-1
|
||||
puts -nonewline $f "ab\x8c\xc1g"
|
||||
close $f
|
||||
set f [open [file join [temporaryDirectory] dummy] r]
|
||||
fconfigure $f -translation binary -encoding shiftjis
|
||||
set x [read $f]
|
||||
close $f
|
||||
file delete [file join [temporaryDirectory] dummy]
|
||||
set x
|
||||
} "ab\u4e4eg"
|
||||
|
||||
test encoding-9.1 {Tcl_UtfToExternalDString: small buffer} {
|
||||
encoding convertto jis0208 "\u543e\u543e\u543e\u543e"
|
||||
} {8c8c8c8c}
|
||||
test encoding-9.2 {Tcl_UtfToExternalDString: big buffer} {
|
||||
set a \u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e
|
||||
append a $a
|
||||
append a $a
|
||||
append a $a
|
||||
append a $a
|
||||
append a $a
|
||||
append a $a
|
||||
set x [encoding convertto jis0208 $a]
|
||||
list [string length $x] [string range $x 0 1]
|
||||
} "1024 8C"
|
||||
|
||||
test encoding-10.1 {Tcl_UtfToExternal} {
|
||||
set f [open [file join [temporaryDirectory] dummy] w]
|
||||
fconfigure $f -translation binary -encoding shiftjis
|
||||
puts -nonewline $f "ab\u4e4eg"
|
||||
close $f
|
||||
set f [open [file join [temporaryDirectory] dummy] r]
|
||||
fconfigure $f -translation binary -encoding iso8859-1
|
||||
set x [read $f]
|
||||
close $f
|
||||
file delete [file join [temporaryDirectory] dummy]
|
||||
set x
|
||||
} "ab\x8c\xc1g"
|
||||
|
||||
proc viewable {str} {
|
||||
set res ""
|
||||
foreach c [split $str {}] {
|
||||
if {[string is print $c] && [string is ascii $c]} {
|
||||
append res $c
|
||||
} else {
|
||||
append res "\\u[format %4.4x [scan $c %c]]"
|
||||
}
|
||||
}
|
||||
return "$str ($res)"
|
||||
}
|
||||
|
||||
test encoding-11.1 {LoadEncodingFile: unknown encoding} {testencoding} {
|
||||
set system [encoding system]
|
||||
set path [encoding dirs]
|
||||
encoding system iso8859-1
|
||||
encoding dirs {}
|
||||
llength jis0208
|
||||
set x [list [catch {encoding convertto jis0208 \u4e4e} msg] $msg]
|
||||
encoding dirs $path
|
||||
encoding system $system
|
||||
lappend x [encoding convertto jis0208 \u4e4e]
|
||||
} {1 {unknown encoding "jis0208"} 8C}
|
||||
test encoding-11.2 {LoadEncodingFile: single-byte} {
|
||||
encoding convertfrom jis0201 \xa1
|
||||
} "\uff61"
|
||||
test encoding-11.3 {LoadEncodingFile: double-byte} {
|
||||
encoding convertfrom jis0208 8C
|
||||
} "\u4e4e"
|
||||
test encoding-11.4 {LoadEncodingFile: multi-byte} {
|
||||
encoding convertfrom shiftjis \x8c\xc1
|
||||
} "\u4e4e"
|
||||
test encoding-11.5 {LoadEncodingFile: escape file} {
|
||||
viewable [encoding convertto iso2022 \u4e4e]
|
||||
} [viewable "\x1b\$B8C\x1b(B"]
|
||||
test encoding-11.5.1 {LoadEncodingFile: escape file} {
|
||||
viewable [encoding convertto iso2022-jp \u4e4e]
|
||||
} [viewable "\x1b\$B8C\x1b(B"]
|
||||
test encoding-11.6 {LoadEncodingFile: invalid file} {testencoding} {
|
||||
set system [encoding system]
|
||||
set path [encoding dirs]
|
||||
encoding system identity
|
||||
cd [temporaryDirectory]
|
||||
encoding dirs [file join tmp encoding]
|
||||
makeDirectory tmp
|
||||
makeDirectory [file join tmp encoding]
|
||||
set f [open [file join tmp encoding splat.enc] w]
|
||||
fconfigure $f -translation binary
|
||||
puts $f "abcdefghijklmnop"
|
||||
close $f
|
||||
set x [list [catch {encoding convertto splat \u4e4e} msg] $msg]
|
||||
file delete [file join [temporaryDirectory] tmp encoding splat.enc]
|
||||
removeDirectory [file join tmp encoding]
|
||||
removeDirectory tmp
|
||||
cd [workingDirectory]
|
||||
encoding dirs $path
|
||||
encoding system $system
|
||||
set x
|
||||
} {1 {invalid encoding file "splat"}}
|
||||
|
||||
# OpenEncodingFile is fully tested by the rest of the tests in this file.
|
||||
|
||||
test encoding-12.1 {LoadTableEncoding: normal encoding} {
|
||||
set x [encoding convertto iso8859-3 \u120]
|
||||
append x [encoding convertto iso8859-3 \ud5]
|
||||
append x [encoding convertfrom iso8859-3 \xd5]
|
||||
} "\xd5?\u120"
|
||||
test encoding-12.2 {LoadTableEncoding: single-byte encoding} {
|
||||
set x [encoding convertto iso8859-3 ab\u0120g]
|
||||
append x [encoding convertfrom iso8859-3 ab\xd5g]
|
||||
} "ab\xd5gab\u120g"
|
||||
test encoding-12.3 {LoadTableEncoding: multi-byte encoding} {
|
||||
set x [encoding convertto shiftjis ab\u4e4eg]
|
||||
append x [encoding convertfrom shiftjis ab\x8c\xc1g]
|
||||
} "ab\x8c\xc1gab\u4e4eg"
|
||||
test encoding-12.4 {LoadTableEncoding: double-byte encoding} {
|
||||
set x [encoding convertto jis0208 \u4e4e\u3b1]
|
||||
append x [encoding convertfrom jis0208 8C&A]
|
||||
} "8C&A\u4e4e\u3b1"
|
||||
test encoding-12.5 {LoadTableEncoding: symbol encoding} {
|
||||
set x [encoding convertto symbol \u3b3]
|
||||
append x [encoding convertto symbol \u67]
|
||||
append x [encoding convertfrom symbol \x67]
|
||||
} "\x67\x67\u3b3"
|
||||
|
||||
test encoding-13.1 {LoadEscapeTable} {
|
||||
viewable [set x [encoding convertto iso2022 ab\u4e4e\u68d9g]]
|
||||
} [viewable "ab\x1b\$B8C\x1b\$\(DD%\x1b(Bg"]
|
||||
|
||||
test encoding-14.1 {BinaryProc} {
|
||||
encoding convertto identity \x12\x34\x56\xff\x69
|
||||
} "\x12\x34\x56\xc3\xbf\x69"
|
||||
|
||||
test encoding-15.1 {UtfToUtfProc} {
|
||||
encoding convertto utf-8 \xa3
|
||||
} "\xc2\xa3"
|
||||
|
||||
test encoding-15.2 {UtfToUtfProc null character output} {
|
||||
set x \u0000
|
||||
set y [encoding convertto utf-8 \u0000]
|
||||
set y [encoding convertfrom identity $y]
|
||||
binary scan $y H* z
|
||||
list [string bytelength $x] [string bytelength $y] $z
|
||||
} {2 1 00}
|
||||
|
||||
test encoding-15.3 {UtfToUtfProc null character input} {
|
||||
set x [encoding convertfrom identity \x00]
|
||||
set y [encoding convertfrom utf-8 $x]
|
||||
binary scan [encoding convertto identity $y] H* z
|
||||
list [string bytelength $x] [string bytelength $y] $z
|
||||
} {1 2 c080}
|
||||
|
||||
test encoding-16.1 {UnicodeToUtfProc} {
|
||||
set val [encoding convertfrom unicode NN]
|
||||
list $val [format %x [scan $val %c]]
|
||||
} "\u4e4e 4e4e"
|
||||
|
||||
test encoding-17.1 {UtfToUnicodeProc} {
|
||||
} {}
|
||||
|
||||
test encoding-18.1 {TableToUtfProc} {
|
||||
} {}
|
||||
|
||||
test encoding-19.1 {TableFromUtfProc} {
|
||||
} {}
|
||||
|
||||
test encoding-20.1 {TableFreefProc} {
|
||||
} {}
|
||||
|
||||
test encoding-21.1 {EscapeToUtfProc} {
|
||||
} {}
|
||||
|
||||
test encoding-22.1 {EscapeFromUtfProc} {
|
||||
} {}
|
||||
|
||||
set iso2022encData "\u001b\$B;d\$I\$b\$G\$O!\"%A%C%W\$49XF~;~\$K\$4EPO?\$\$\$?\$@\$\$\$?\$4=;=j\$r%-%c%C%7%e%\"%&%H\$N:]\$N\u001b(B
|
||||
\u001b\$B>.@Z<jAwIU@h\$H\$7\$F;HMQ\$7\$F\$*\$j\$^\$9!#62\$lF~\$j\$^\$9\$,!\"@5\$7\$\$=;=j\$r\$4EPO?\$7\$J\$*\u001b(B
|
||||
\u001b\$B\$*4j\$\$\$\$\$?\$7\$^\$9!#\$^\$?!\"BgJQ62=L\$G\$9\$,!\"=;=jJQ99\$N\$\"\$H!\"F|K\\8l%5!<%S%9It!J\u001b(B
|
||||
casino_japanese@___.com \u001b\$B!K\$^\$G\$4=;=jJQ99:Q\$NO\"Mm\$r\$\$\$?\$@\$1\$J\$\$\$G\u001b(B
|
||||
\u001b\$B\$7\$g\$&\$+!)\u001b(B"
|
||||
|
||||
set iso2022uniData [encoding convertfrom iso2022-jp $iso2022encData]
|
||||
set iso2022uniData2 "\u79c1\u3069\u3082\u3067\u306f\u3001\u30c1\u30c3\u30d7\u3054\u8cfc\u5165\u6642\u306b\u3054\u767b\u9332\u3044\u305f\u3060\u3044\u305f\u3054\u4f4f\u6240\u3092\u30ad\u30e3\u30c3\u30b7\u30e5\u30a2\u30a6\u30c8\u306e\u969b\u306e
|
||||
\u5c0f\u5207\u624b\u9001\u4ed8\u5148\u3068\u3057\u3066\u4f7f\u7528\u3057\u3066\u304a\u308a\u307e\u3059\u3002\u6050\u308c\u5165\u308a\u307e\u3059\u304c\u3001\u6b63\u3057\u3044\u4f4f\u6240\u3092\u3054\u767b\u9332\u3057\u306a\u304a
|
||||
\u304a\u9858\u3044\u3044\u305f\u3057\u307e\u3059\u3002\u307e\u305f\u3001\u5927\u5909\u6050\u7e2e\u3067\u3059\u304c\u3001\u4f4f\u6240\u5909\u66f4\u306e\u3042\u3068\u3001\u65e5\u672c\u8a9e\u30b5\u30fc\u30d3\u30b9\u90e8\uff08
|
||||
\u0063\u0061\u0073\u0069\u006e\u006f\u005f\u006a\u0061\u0070\u0061\u006e\u0065\u0073\u0065\u0040\u005f\u005f\u005f\u002e\u0063\u006f\u006d\u0020\uff09\u307e\u3067\u3054\u4f4f\u6240\u5909\u66f4\u6e08\u306e\u9023\u7d61\u3092\u3044\u305f\u3060\u3051\u306a\u3044\u3067
|
||||
\u3057\u3087\u3046\u304b\uff1f"
|
||||
|
||||
cd [temporaryDirectory]
|
||||
set fid [open iso2022.txt w]
|
||||
fconfigure $fid -encoding binary
|
||||
puts -nonewline $fid $iso2022encData
|
||||
close $fid
|
||||
|
||||
test encoding-23.1 {iso2022-jp escape encoding test} {
|
||||
string equal $iso2022uniData $iso2022uniData2
|
||||
} 1
|
||||
test encoding-23.2 {iso2022-jp escape encoding test} {
|
||||
# This checks that 'gets' isn't resetting the encoding inappropriately.
|
||||
# [Bug #523988]
|
||||
set fid [open iso2022.txt r]
|
||||
fconfigure $fid -encoding iso2022-jp
|
||||
set out ""
|
||||
set count 0
|
||||
while {[set num [gets $fid line]] >= 0} {
|
||||
if {$count} {
|
||||
incr count 1 ; # account for newline
|
||||
append out \n
|
||||
}
|
||||
append out $line
|
||||
incr count $num
|
||||
}
|
||||
close $fid
|
||||
if {[string compare $iso2022uniData $out]} {
|
||||
return -code error "iso2022-jp read in doesn't match original"
|
||||
}
|
||||
list $count $out
|
||||
} [list [string length $iso2022uniData] $iso2022uniData]
|
||||
test encoding-23.3 {iso2022-jp escape encoding test} {
|
||||
# read $fis <size> reads size in chars, not raw bytes.
|
||||
set fid [open iso2022.txt r]
|
||||
fconfigure $fid -encoding iso2022-jp
|
||||
set data [read $fid 50]
|
||||
close $fid
|
||||
set data
|
||||
} [string range $iso2022uniData 0 49] ; # 0 .. 49 inclusive == 50
|
||||
cd [workingDirectory]
|
||||
|
||||
test encoding-24.1 {EscapeFreeProc on open channels} -constraints {
|
||||
exec
|
||||
} -setup {
|
||||
# Bug #524674 input
|
||||
set file [makeFile {
|
||||
set f [open [file join [file dirname [info script]] iso2022.txt]]
|
||||
fconfigure $f -encoding iso2022-jp
|
||||
gets $f
|
||||
} iso2022.tcl]
|
||||
} -body {
|
||||
exec [interpreter] $file
|
||||
} -cleanup {
|
||||
removeFile iso2022.tcl
|
||||
} -result {}
|
||||
|
||||
test encoding-24.2 {EscapeFreeProc on open channels} -constraints {
|
||||
exec
|
||||
} -setup {
|
||||
# Bug #524674 output
|
||||
set file [makeFile {
|
||||
encoding system cp1252; # Bug #2891556 crash revelator
|
||||
fconfigure stdout -encoding iso2022-jp
|
||||
puts ab\u4e4e\u68d9g
|
||||
exit
|
||||
} iso2022.tcl]
|
||||
} -body {
|
||||
viewable [exec [interpreter] $file]
|
||||
} -cleanup {
|
||||
removeFile iso2022.tcl
|
||||
} -result "ab\x1b\$B8C\x1b\$(DD%\x1b(Bg (ab\\u001b\$B8C\\u001b\$(DD%\\u001b(Bg)"
|
||||
|
||||
test encoding-24.3 {EscapeFreeProc on open channels} {stdio} {
|
||||
# Bug #219314 - if we don't free escape encodings correctly on
|
||||
# channel closure, we go boom
|
||||
set file [makeFile {
|
||||
encoding system iso2022-jp
|
||||
set a "\u4e4e\u4e5e\u4e5f"; # 3 Japanese Kanji letters
|
||||
puts $a
|
||||
} iso2022.tcl]
|
||||
set f [open "|[list [interpreter] $file]"]
|
||||
fconfigure $f -encoding iso2022-jp
|
||||
set count [gets $f line]
|
||||
close $f
|
||||
removeFile iso2022.tcl
|
||||
list $count [viewable $line]
|
||||
} [list 3 "\u4e4e\u4e5e\u4e5f (\\u4e4e\\u4e5e\\u4e5f)"]
|
||||
|
||||
file delete [file join [temporaryDirectory] iso2022.txt]
|
||||
|
||||
#
|
||||
# Begin jajp encoding round-trip conformity tests
|
||||
#
|
||||
proc foreach-jisx0208 {varName command} {
|
||||
upvar 1 $varName code
|
||||
foreach range {
|
||||
{2121 217E}
|
||||
{2221 222E}
|
||||
{223A 2241}
|
||||
{224A 2250}
|
||||
{225C 226A}
|
||||
{2272 2279}
|
||||
{227E 227E}
|
||||
{2330 2339}
|
||||
{2421 2473}
|
||||
{2521 2576}
|
||||
{2821 2821}
|
||||
{282C 282C}
|
||||
{2837 2837}
|
||||
|
||||
{30 21 4E 7E}
|
||||
{4F21 4F53}
|
||||
|
||||
{50 21 73 7E}
|
||||
{7421 7426}
|
||||
} {
|
||||
if {[llength $range] == 2} {
|
||||
# for adhoc range. simple {first last}. inclusive.
|
||||
set first [scan [lindex $range 0] %x]
|
||||
set last [scan [lindex $range 1] %x]
|
||||
for {set i $first} {$i <= $last} {incr i} {
|
||||
set code $i
|
||||
uplevel 1 $command
|
||||
}
|
||||
} elseif {[llength $range] == 4} {
|
||||
# for uniform range.
|
||||
set h0 [scan [lindex $range 0] %x]
|
||||
set l0 [scan [lindex $range 1] %x]
|
||||
set hend [scan [lindex $range 2] %x]
|
||||
set lend [scan [lindex $range 3] %x]
|
||||
for {set hi $h0} {$hi <= $hend} {incr hi} {
|
||||
for {set lo $l0} {$lo <= $lend} {incr lo} {
|
||||
set code [expr {$hi << 8 | ($lo & 0xff)}]
|
||||
uplevel 1 $command
|
||||
}
|
||||
}
|
||||
} else {
|
||||
error "really?"
|
||||
}
|
||||
}
|
||||
}
|
||||
proc gen-jisx0208-euc-jp {code} {
|
||||
binary format cc \
|
||||
[expr {($code >> 8) | 0x80}] [expr {($code & 0xff) | 0x80}]
|
||||
}
|
||||
proc gen-jisx0208-iso2022-jp {code} {
|
||||
binary format a3cca3 \
|
||||
"\x1b\$B" [expr {$code >> 8}] [expr {$code & 0xff}] "\x1b(B"
|
||||
}
|
||||
proc gen-jisx0208-cp932 {code} {
|
||||
set c1 [expr {($code >> 8) | 0x80}]
|
||||
set c2 [expr {($code & 0xff)| 0x80}]
|
||||
if {$c1 % 2} {
|
||||
set c1 [expr {($c1 >> 1) + ($c1 < 0xdf ? 0x31 : 0x71)}]
|
||||
incr c2 [expr {- (0x60 + ($c2 < 0xe0))}]
|
||||
} else {
|
||||
set c1 [expr {($c1 >> 1) + ($c1 < 0xdf ? 0x30 : 0x70)}]
|
||||
incr c2 -2
|
||||
}
|
||||
binary format cc $c1 $c2
|
||||
}
|
||||
proc channel-diff {fa fb} {
|
||||
set diff {}
|
||||
while {[gets $fa la] >= 0 && [gets $fb lb] >= 0} {
|
||||
if {[string compare $la $lb] == 0} continue
|
||||
# lappend diff $la $lb
|
||||
|
||||
# For more readable (easy to analyze) output.
|
||||
set code [lindex $la 0]
|
||||
binary scan [lindex $la 1] H* expected
|
||||
binary scan [lindex $lb 1] H* got
|
||||
lappend diff [list $code $expected $got]
|
||||
}
|
||||
set diff
|
||||
}
|
||||
|
||||
# Create char tables.
|
||||
cd [temporaryDirectory]
|
||||
foreach enc {cp932 euc-jp iso2022-jp} {
|
||||
set f [open $enc.chars w]
|
||||
fconfigure $f -encoding binary
|
||||
foreach-jisx0208 code {
|
||||
puts $f [format "%04X %s" $code [gen-jisx0208-$enc $code]]
|
||||
}
|
||||
close $f
|
||||
}
|
||||
# shiftjis == cp932 for jisx0208.
|
||||
file copy -force cp932.chars shiftjis.chars
|
||||
|
||||
set NUM 0
|
||||
foreach from {cp932 shiftjis euc-jp iso2022-jp} {
|
||||
foreach to {cp932 shiftjis euc-jp iso2022-jp} {
|
||||
test encoding-25.[incr NUM] "jisx0208 $from => $to" {
|
||||
cd [temporaryDirectory]
|
||||
set f [open $from.chars]
|
||||
fconfigure $f -encoding $from
|
||||
set out [open $from.$to.tcltestout w]
|
||||
fconfigure $out -encoding $to
|
||||
puts -nonewline $out [read $f]
|
||||
close $out
|
||||
close $f
|
||||
|
||||
# then compare $to.chars <=> $from.to.tcltestout as binary.
|
||||
set fa [open $to.chars]
|
||||
fconfigure $fa -encoding binary
|
||||
set fb [open $from.$to.tcltestout]
|
||||
fconfigure $fb -encoding binary
|
||||
set diff [channel-diff $fa $fb]
|
||||
close $fa
|
||||
close $fb
|
||||
|
||||
# Difference should be empty.
|
||||
set diff
|
||||
} {}
|
||||
}
|
||||
}
|
||||
|
||||
testConstraint testgetdefenc [llength [info commands testgetdefenc]]
|
||||
|
||||
test encoding-26.0 {Tcl_GetDefaultEncodingDir} -constraints {
|
||||
testgetdefenc
|
||||
} -setup {
|
||||
set origDir [testgetdefenc]
|
||||
testsetdefenc slappy
|
||||
} -body {
|
||||
testgetdefenc
|
||||
} -cleanup {
|
||||
testsetdefenc $origDir
|
||||
} -result slappy
|
||||
|
||||
file delete {*}[glob -directory [temporaryDirectory] *.chars *.tcltestout]
|
||||
# ===> Cut here <===
|
||||
|
||||
# EscapeFreeProc, GetTableEncoding, unilen
|
||||
# are fully tested by the rest of this file
|
||||
|
||||
test encoding-27.1 {encoding dirs basic behavior} -returnCodes error -body {
|
||||
encoding dirs ? ?
|
||||
} -result {wrong # args: should be "encoding dirs ?dirList?"}
|
||||
test encoding-27.2 {encoding dirs basic behavior} -returnCodes error -body {
|
||||
encoding dirs "\{not a list"
|
||||
} -result "expected directory list but got \"\{not a list\""
|
||||
|
||||
}
|
||||
runtests
|
||||
|
||||
}
|
||||
|
||||
# cleanup
|
||||
namespace delete ::tcl::test::encoding
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
269
tests/env.test
Normal file
269
tests/env.test
Normal file
@@ -0,0 +1,269 @@
|
||||
# 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.
|
||||
# Copyright (c) 1994 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution of
|
||||
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest 2
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
# Some tests require the "exec" command.
|
||||
# Skip them if exec is not defined.
|
||||
testConstraint exec [llength [info commands exec]]
|
||||
|
||||
#
|
||||
# These tests will run on any platform (and indeed crashed on the Mac). So put
|
||||
# them before you test for the existance of exec.
|
||||
#
|
||||
test env-1.1 {propagation of env values to child interpreters} {
|
||||
catch {interp delete child}
|
||||
catch {unset env(test)}
|
||||
interp create child
|
||||
set env(test) garbage
|
||||
set return [child eval {set env(test)}]
|
||||
interp delete child
|
||||
unset env(test)
|
||||
set return
|
||||
} {garbage}
|
||||
#
|
||||
# This one crashed on Solaris under Tcl8.0, so we only want to make sure it
|
||||
# runs.
|
||||
#
|
||||
test env-1.2 {lappend to env value} {
|
||||
catch {unset env(test)}
|
||||
set env(test) aaaaaaaaaaaaaaaa
|
||||
append env(test) bbbbbbbbbbbbbb
|
||||
unset env(test)
|
||||
} {}
|
||||
test env-1.3 {reflection of env by "array names"} {
|
||||
catch {interp delete child}
|
||||
catch {unset env(test)}
|
||||
interp create child
|
||||
child eval {set env(test) garbage}
|
||||
set names [array names env]
|
||||
interp delete child
|
||||
set ix [lsearch $names test]
|
||||
catch {unset env(test)}
|
||||
expr {$ix >= 0}
|
||||
} {1}
|
||||
|
||||
set printenvScript [makeFile {
|
||||
proc lrem {listname name} {
|
||||
upvar $listname list
|
||||
set i [lsearch -nocase $list $name]
|
||||
if {$i >= 0} {
|
||||
set list [lreplace $list $i $i]
|
||||
}
|
||||
return $list
|
||||
}
|
||||
proc mangle s {
|
||||
regsub -all {\[|\\|\]} $s {\\&} s
|
||||
regsub -all {[\u0000-\u001f\u007f-\uffff]} $s {[manglechar &]} s
|
||||
return [subst -novariables $s]
|
||||
}
|
||||
proc manglechar c {
|
||||
return [format {\u%04x} [scan $c %c]]
|
||||
}
|
||||
|
||||
set names [lsort [array names env]]
|
||||
if {$tcl_platform(platform) == "windows"} {
|
||||
lrem names HOME
|
||||
lrem names COMSPEC
|
||||
lrem names ComSpec
|
||||
lrem names ""
|
||||
}
|
||||
foreach name {
|
||||
TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH PURE_PROG_NAME DISPLAY
|
||||
SHLIB_PATH SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH
|
||||
DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING
|
||||
__CF_USER_TEXT_ENCODING SECURITYSESSIONID LANG WINDIR TERM
|
||||
CommonProgramFiles ProgramFiles CommonProgramW6432 ProgramW6432
|
||||
} {
|
||||
lrem names $name
|
||||
}
|
||||
foreach p $names {
|
||||
puts "[mangle $p]=[mangle $env($p)]"
|
||||
}
|
||||
exit
|
||||
} printenv]
|
||||
|
||||
# [exec] is required here to see the actual environment received
|
||||
# by child processes.
|
||||
proc getenv {} {
|
||||
global printenvScript tcltest
|
||||
catch {exec [interpreter] $printenvScript} out
|
||||
if {$out == "child process exited abnormally"} {
|
||||
set out {}
|
||||
}
|
||||
return $out
|
||||
}
|
||||
|
||||
# Save the current environment variables at the start of the test.
|
||||
|
||||
set env2 [array get env]
|
||||
foreach name [array names env] {
|
||||
# Keep some environment variables that support operation of the tcltest
|
||||
# package.
|
||||
if {[string toupper $name] ni {
|
||||
TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH DISPLAY SHLIB_PATH
|
||||
SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH
|
||||
DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING
|
||||
SECURITYSESSIONID LANG WINDIR TERM
|
||||
CONNOMPROGRAMFILES PROGRAMFILES COMMONPROGRAMW6432 PROGRAMW6432
|
||||
}} {
|
||||
unset env($name)
|
||||
}
|
||||
}
|
||||
|
||||
test env-2.1 {adding environment variables} {exec} {
|
||||
getenv
|
||||
} {}
|
||||
|
||||
set env(NAME1) "test string"
|
||||
test env-2.2 {adding environment variables} {exec} {
|
||||
getenv
|
||||
} {NAME1=test string}
|
||||
|
||||
set env(NAME2) "more"
|
||||
test env-2.3 {adding environment variables} {exec} {
|
||||
getenv
|
||||
} {NAME1=test string
|
||||
NAME2=more}
|
||||
|
||||
set env(XYZZY) "garbage"
|
||||
test env-2.4 {adding environment variables} {exec} {
|
||||
getenv
|
||||
} {NAME1=test string
|
||||
NAME2=more
|
||||
XYZZY=garbage}
|
||||
|
||||
set env(NAME2) "new value"
|
||||
test env-3.1 {changing environment variables} {exec} {
|
||||
set result [getenv]
|
||||
unset env(NAME2)
|
||||
set result
|
||||
} {NAME1=test string
|
||||
NAME2=new value
|
||||
XYZZY=garbage}
|
||||
|
||||
test env-4.1 {unsetting environment variables} {exec} {
|
||||
set result [getenv]
|
||||
unset env(NAME1)
|
||||
set result
|
||||
} {NAME1=test string
|
||||
XYZZY=garbage}
|
||||
|
||||
test env-4.2 {unsetting environment variables} {exec} {
|
||||
set result [getenv]
|
||||
unset env(XYZZY)
|
||||
set result
|
||||
} {XYZZY=garbage}
|
||||
|
||||
test env-4.3 {setting international environment variables} {exec} {
|
||||
set env(\ua7) \ub6
|
||||
getenv
|
||||
} {\u00a7=\u00b6}
|
||||
test env-4.4 {changing international environment variables} {exec} {
|
||||
set env(\ua7) \ua7
|
||||
getenv
|
||||
} {\u00a7=\u00a7}
|
||||
test env-4.5 {unsetting international environment variables} {exec} {
|
||||
set env(\ub6) \ua7
|
||||
unset env(\ua7)
|
||||
set result [getenv]
|
||||
unset env(\ub6)
|
||||
set result
|
||||
} {\u00b6=\u00a7}
|
||||
|
||||
test env-5.0 {corner cases - set a value, it should exist} {} {
|
||||
set env(temp) a
|
||||
set result [set env(temp)]
|
||||
unset env(temp)
|
||||
set result
|
||||
} {a}
|
||||
test env-5.1 {corner cases - remove one elem at a time} {} {
|
||||
# When no environment variables exist, the env var will
|
||||
# contain no entries. The "array names" call synchs up
|
||||
# the C-level environ array with the Tcl level env array.
|
||||
# Make sure an empty Tcl array is created.
|
||||
|
||||
set x [array get env]
|
||||
foreach e [array names env] {
|
||||
unset env($e)
|
||||
}
|
||||
set result [catch {array names env}]
|
||||
array set env $x
|
||||
set result
|
||||
} {0}
|
||||
test env-5.2 {corner cases - unset the env array} {} {
|
||||
# Unsetting a variable in an interp detaches the C-level
|
||||
# traces from the Tcl "env" variable.
|
||||
|
||||
interp create i
|
||||
i eval { unset env }
|
||||
i eval { set env(THIS_SHOULDNT_EXIST) a}
|
||||
set result [info exists env(THIS_SHOULDNT_EXIST)]
|
||||
interp delete i
|
||||
set result
|
||||
} {0}
|
||||
test env-5.3 {corner cases - unset the env in master should unset child} {} {
|
||||
# Variables deleted in a master interp should be deleted in
|
||||
# child interp too.
|
||||
|
||||
interp create i
|
||||
i eval { set env(THIS_SHOULD_EXIST) a}
|
||||
set result [set env(THIS_SHOULD_EXIST)]
|
||||
unset env(THIS_SHOULD_EXIST)
|
||||
lappend result [i eval {catch {set env(THIS_SHOULD_EXIST)}}]
|
||||
interp delete i
|
||||
set result
|
||||
} {a 1}
|
||||
test env-5.4 {corner cases - unset the env array} {} {
|
||||
# The info exists command should be in synch with the env array.
|
||||
# Know Bug: 1737
|
||||
|
||||
interp create i
|
||||
i eval { set env(THIS_SHOULD_EXIST) a}
|
||||
set result [info exists env(THIS_SHOULD_EXIST)]
|
||||
lappend result [set env(THIS_SHOULD_EXIST)]
|
||||
lappend result [info exists env(THIS_SHOULD_EXIST)]
|
||||
interp delete i
|
||||
set result
|
||||
} {1 a 1}
|
||||
test env-5.5 {corner cases - cannot have null entries on Windows} {win} {
|
||||
set env() a
|
||||
catch {set env()}
|
||||
} {1}
|
||||
|
||||
test env-6.1 {corner cases - add lots of env variables} {} {
|
||||
set size [array size env]
|
||||
for {set i 0} {$i < 100} {incr i} {
|
||||
set env(BOGUS$i) $i
|
||||
}
|
||||
expr {[array size env] - $size}
|
||||
} 100
|
||||
|
||||
# Restore the environment variables at the end of the test.
|
||||
|
||||
foreach name [array names env] {
|
||||
unset env($name)
|
||||
}
|
||||
array set env $env2
|
||||
|
||||
# cleanup
|
||||
removeFile $printenvScript
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# End:
|
||||
243
tests/error.test
Normal file
243
tests/error.test
Normal file
@@ -0,0 +1,243 @@
|
||||
# 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.
|
||||
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest 2
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
namespace eval ::tcl::test::error {
|
||||
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 index]} b
|
||||
} 1
|
||||
|
||||
test error-1.2 {simple errors from commands} {
|
||||
catch {format [string index]} b
|
||||
set b
|
||||
} {wrong # args: should be "string index string charIndex"}
|
||||
|
||||
test error-1.3 {simple errors from commands} {
|
||||
catch {format [string index]} b
|
||||
set ::errorInfo
|
||||
# this used to return '... while executing ...', but
|
||||
# string index is fully compiled as of 8.4a3
|
||||
} {wrong # args: should be "string index string charIndex"
|
||||
while executing
|
||||
"string index"}
|
||||
|
||||
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 d} b
|
||||
} 1
|
||||
|
||||
test error-1.7 {simple errors from commands} {
|
||||
catch {catch a b c d} b
|
||||
set b
|
||||
} {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"}
|
||||
|
||||
test error-1.8 {simple errors from commands} {
|
||||
# This test is non-portable: it generates a memory fault on
|
||||
# machines like DEC Alphas (infinite recursion overflows
|
||||
# stack?)
|
||||
#
|
||||
# That claims sounds like a bug to be fixed rather than a portability
|
||||
# problem. Anyhow, I believe it's out of date (bug's been fixed) so
|
||||
# this test is re-enabled.
|
||||
|
||||
proc p {} {
|
||||
uplevel 1 catch p error
|
||||
}
|
||||
p
|
||||
} 0
|
||||
|
||||
# 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"
|
||||
(procedure "foo2" line 3)
|
||||
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 script ?resultVarName? ?optionVarName?"}}
|
||||
test error-3.2 {errors in catch command} {
|
||||
list [catch {catch a b c} msg] $msg
|
||||
} {0 1}
|
||||
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}
|
||||
test error-6.2 {catch must reset error state} {
|
||||
catch {error outer [catch {return -level 0 -code error -errorcode BUG}]}
|
||||
list $::errorCode $::errorInfo
|
||||
} {NONE 1}
|
||||
test error-6.3 {catch must reset error state} {
|
||||
set ::errorCode BUG
|
||||
catch {error outer [catch set]}
|
||||
list $::errorCode $::errorInfo
|
||||
} {NONE 1}
|
||||
test error-6.4 {catch must reset error state} {
|
||||
catch {error [catch {error foo bar baz}] 1}
|
||||
list $::errorCode $::errorInfo
|
||||
} {NONE 1}
|
||||
test error-6.5 {catch must reset error state} {
|
||||
catch {error [catch {return -level 0 -code error -errorcode BUG}] 1}
|
||||
list $::errorCode $::errorInfo
|
||||
} {NONE 1}
|
||||
test error-6.6 {catch must reset error state} {
|
||||
catch {return -level 0 -code error -errorinfo [catch {error foo bar baz}]}
|
||||
list $::errorCode $::errorInfo
|
||||
} {NONE 1}
|
||||
test error-6.7 {catch must reset error state} {
|
||||
proc foo {} {
|
||||
return -code error -errorinfo [catch {error foo bar baz}]
|
||||
}
|
||||
catch foo
|
||||
list $::errorCode
|
||||
} {NONE}
|
||||
test error-6.8 {catch must reset error state} {
|
||||
catch {return -level 0 -code error [catch {error foo bar baz}]}
|
||||
list $::errorCode
|
||||
} {NONE}
|
||||
test error-6.9 {catch must reset error state} {
|
||||
proc foo {} {
|
||||
return -code error [catch {error foo bar baz}]
|
||||
}
|
||||
catch foo
|
||||
list $::errorCode
|
||||
} {NONE}
|
||||
|
||||
test error-7.0 {Bug 1397843} -body {
|
||||
variable cmds
|
||||
proc EIWrite args {
|
||||
variable cmds
|
||||
lappend cmds [lindex [info level -2] 0]
|
||||
}
|
||||
proc BadProc {} {
|
||||
set i a
|
||||
incr i
|
||||
}
|
||||
trace add variable ::errorInfo write [namespace code EIWrite]
|
||||
catch BadProc
|
||||
trace remove variable ::errorInfo write [namespace code EIWrite]
|
||||
set cmds
|
||||
} -match glob -result {*BadProc*}
|
||||
}
|
||||
namespace delete ::tcl::test::error
|
||||
|
||||
# cleanup
|
||||
catch {rename p ""}
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
84
tests/eval.test
Normal file
84
tests/eval.test
Normal file
@@ -0,0 +1,84 @@
|
||||
# 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.
|
||||
# Copyright (c) 1994 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
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\"
|
||||
}\""
|
||||
|
||||
test eval-3.1 {eval and pure lists} {
|
||||
eval [list list 1 2 3 4 5]
|
||||
} {1 2 3 4 5}
|
||||
test eval-3.2 {concatenating eval and pure lists} {
|
||||
eval [list list 1] [list 2 3 4 5]
|
||||
} {1 2 3 4 5}
|
||||
test eval-3.3 {eval and canonical lists} {
|
||||
set cmd [list list 1 2 3 4 5]
|
||||
# Force existance of utf-8 rep
|
||||
set dummy($cmd) $cmd
|
||||
unset dummy
|
||||
eval $cmd
|
||||
} {1 2 3 4 5}
|
||||
test eval-3.4 {concatenating eval and canonical lists} {
|
||||
set cmd [list list 1]
|
||||
set cmd2 [list 2 3 4 5]
|
||||
# Force existance of utf-8 rep
|
||||
set dummy($cmd) $cmd
|
||||
set dummy($cmd2) $cmd2
|
||||
unset dummy
|
||||
eval $cmd $cmd2
|
||||
} {1 2 3 4 5}
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
920
tests/event.test
Normal file
920
tests/event.test
Normal file
@@ -0,0 +1,920 @@
|
||||
# This file contains a collection of tests for the procedures in the file
|
||||
# tclEvent.c, which includes the "update", and "vwait" Tcl
|
||||
# commands. Sourcing this file into Tcl runs the tests and generates
|
||||
# output for errors. No output means no errors were found.
|
||||
#
|
||||
# Copyright (c) 1995-1997 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
package require tcltest 2
|
||||
namespace import -force ::tcltest::*
|
||||
|
||||
testConstraint testfilehandler [llength [info commands testfilehandler]]
|
||||
testConstraint testexithandler [llength [info commands testexithandler]]
|
||||
testConstraint testfilewait [llength [info commands testfilewait]]
|
||||
|
||||
test event-1.1 {Tcl_CreateFileHandler, reading} {testfilehandler} {
|
||||
testfilehandler close
|
||||
testfilehandler create 0 readable off
|
||||
testfilehandler clear 0
|
||||
testfilehandler oneevent
|
||||
set result ""
|
||||
lappend result [testfilehandler counts 0]
|
||||
testfilehandler fillpartial 0
|
||||
testfilehandler oneevent
|
||||
lappend result [testfilehandler counts 0]
|
||||
testfilehandler oneevent
|
||||
lappend result [testfilehandler counts 0]
|
||||
testfilehandler close
|
||||
set result
|
||||
} {{0 0} {1 0} {2 0}}
|
||||
test event-1.2 {Tcl_CreateFileHandler, writing} {testfilehandler nonPortable} {
|
||||
# This test is non-portable because on some systems (e.g.
|
||||
# SunOS 4.1.3) pipes seem to be writable always.
|
||||
testfilehandler close
|
||||
testfilehandler create 0 off writable
|
||||
testfilehandler clear 0
|
||||
testfilehandler oneevent
|
||||
set result ""
|
||||
lappend result [testfilehandler counts 0]
|
||||
testfilehandler fillpartial 0
|
||||
testfilehandler oneevent
|
||||
lappend result [testfilehandler counts 0]
|
||||
testfilehandler fill 0
|
||||
testfilehandler oneevent
|
||||
lappend result [testfilehandler counts 0]
|
||||
testfilehandler close
|
||||
set result
|
||||
} {{0 1} {0 2} {0 2}}
|
||||
test event-1.3 {Tcl_DeleteFileHandler} {testfilehandler nonPortable} {
|
||||
testfilehandler close
|
||||
testfilehandler create 2 disabled disabled
|
||||
testfilehandler create 1 readable writable
|
||||
testfilehandler create 0 disabled disabled
|
||||
testfilehandler fillpartial 1
|
||||
set result ""
|
||||
testfilehandler oneevent
|
||||
lappend result [testfilehandler counts 1]
|
||||
testfilehandler oneevent
|
||||
lappend result [testfilehandler counts 1]
|
||||
testfilehandler oneevent
|
||||
lappend result [testfilehandler counts 1]
|
||||
testfilehandler create 1 off off
|
||||
testfilehandler oneevent
|
||||
lappend result [testfilehandler counts 1]
|
||||
testfilehandler close
|
||||
set result
|
||||
} {{0 1} {1 1} {1 2} {0 0}}
|
||||
|
||||
test event-2.1 {Tcl_DeleteFileHandler} {testfilehandler nonPortable} {
|
||||
testfilehandler close
|
||||
testfilehandler create 2 disabled disabled
|
||||
testfilehandler create 1 readable writable
|
||||
testfilehandler fillpartial 1
|
||||
set result ""
|
||||
testfilehandler oneevent
|
||||
lappend result [testfilehandler counts 1]
|
||||
testfilehandler oneevent
|
||||
lappend result [testfilehandler counts 1]
|
||||
testfilehandler oneevent
|
||||
lappend result [testfilehandler counts 1]
|
||||
testfilehandler create 1 off off
|
||||
testfilehandler oneevent
|
||||
lappend result [testfilehandler counts 1]
|
||||
testfilehandler close
|
||||
set result
|
||||
} {{0 1} {1 1} {1 2} {0 0}}
|
||||
test event-2.2 {Tcl_DeleteFileHandler, fd reused & events still pending} \
|
||||
{testfilehandler nonPortable} {
|
||||
testfilehandler close
|
||||
testfilehandler create 0 readable writable
|
||||
testfilehandler fillpartial 0
|
||||
set result ""
|
||||
testfilehandler oneevent
|
||||
lappend result [testfilehandler counts 0]
|
||||
testfilehandler close
|
||||
testfilehandler create 0 readable writable
|
||||
testfilehandler oneevent
|
||||
lappend result [testfilehandler counts 0]
|
||||
testfilehandler close
|
||||
set result
|
||||
} {{0 1} {0 0}}
|
||||
|
||||
test event-3.1 {FileHandlerCheckProc, TCL_FILE_EVENTS off } {testfilehandler} {
|
||||
testfilehandler close
|
||||
testfilehandler create 1 readable writable
|
||||
testfilehandler fillpartial 1
|
||||
testfilehandler windowevent
|
||||
set result [testfilehandler counts 1]
|
||||
testfilehandler close
|
||||
set result
|
||||
} {0 0}
|
||||
|
||||
test event-4.1 {FileHandlerEventProc, race between event and disabling} \
|
||||
{testfilehandler nonPortable} {
|
||||
update
|
||||
testfilehandler close
|
||||
testfilehandler create 2 disabled disabled
|
||||
testfilehandler create 1 readable writable
|
||||
testfilehandler fillpartial 1
|
||||
set result ""
|
||||
testfilehandler oneevent
|
||||
lappend result [testfilehandler counts 1]
|
||||
testfilehandler oneevent
|
||||
lappend result [testfilehandler counts 1]
|
||||
testfilehandler oneevent
|
||||
lappend result [testfilehandler counts 1]
|
||||
testfilehandler create 1 disabled disabled
|
||||
testfilehandler oneevent
|
||||
lappend result [testfilehandler counts 1]
|
||||
testfilehandler close
|
||||
set result
|
||||
} {{0 1} {1 1} {1 2} {0 0}}
|
||||
test event-4.2 {FileHandlerEventProc, TCL_FILE_EVENTS off} \
|
||||
{testfilehandler nonPortable} {
|
||||
update
|
||||
testfilehandler close
|
||||
testfilehandler create 1 readable writable
|
||||
testfilehandler create 2 readable writable
|
||||
testfilehandler fillpartial 1
|
||||
testfilehandler fillpartial 2
|
||||
testfilehandler oneevent
|
||||
set result ""
|
||||
lappend result [testfilehandler counts 1] [testfilehandler counts 2]
|
||||
testfilehandler windowevent
|
||||
lappend result [testfilehandler counts 1] [testfilehandler counts 2]
|
||||
testfilehandler close
|
||||
set result
|
||||
} {{0 0} {0 1} {0 0} {0 1}}
|
||||
update
|
||||
|
||||
test event-5.1 {Tcl_BackgroundError, HandleBgErrors procedures} {
|
||||
catch {rename bgerror {}}
|
||||
proc bgerror msg {
|
||||
global errorInfo errorCode x
|
||||
lappend x [list $msg $errorInfo $errorCode]
|
||||
}
|
||||
after idle {error "a simple error"}
|
||||
after idle {open non_existent}
|
||||
after idle {set errorInfo foobar; set errorCode xyzzy}
|
||||
set x {}
|
||||
update idletasks
|
||||
rename bgerror {}
|
||||
regsub -all [file join {} non_existent] $x "non_existent" x
|
||||
set x
|
||||
} {{{a simple error} {a simple error
|
||||
while executing
|
||||
"error "a simple error""
|
||||
("after" script)} NONE} {{couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory
|
||||
while executing
|
||||
"open non_existent"
|
||||
("after" script)} {POSIX ENOENT {no such file or directory}}}}
|
||||
test event-5.2 {Tcl_BackgroundError, HandleBgErrors procedures} {
|
||||
catch {rename bgerror {}}
|
||||
proc bgerror msg {
|
||||
global x
|
||||
lappend x $msg
|
||||
return -code break
|
||||
}
|
||||
after idle {error "a simple error"}
|
||||
after idle {open non_existent}
|
||||
set x {}
|
||||
update idletasks
|
||||
rename bgerror {}
|
||||
set x
|
||||
} {{a simple error}}
|
||||
test event-5.3 {HandleBgErrors: [Bug 1670155]} -setup {
|
||||
variable x
|
||||
proc demo args {variable x done}
|
||||
variable target [list [namespace which demo] x]
|
||||
proc trial args {variable target; string length $target}
|
||||
trace add execution demo enter [namespace code trial]
|
||||
variable save [interp bgerror {}]
|
||||
interp bgerror {} $target
|
||||
} -body {
|
||||
after 0 {error bar}
|
||||
vwait [namespace which -variable x]
|
||||
} -cleanup {
|
||||
interp bgerror {} $save
|
||||
unset x target save
|
||||
rename demo {}
|
||||
rename trial {}
|
||||
} -result {}
|
||||
test event-5.3.1 {Default [interp bgerror] handler} -body {
|
||||
::tcl::Bgerror
|
||||
} -returnCodes error -match glob -result {*msg options*}
|
||||
test event-5.4 {Default [interp bgerror] handler} -body {
|
||||
::tcl::Bgerror {}
|
||||
} -returnCodes error -match glob -result {*msg options*}
|
||||
test event-5.5 {Default [interp bgerror] handler} -body {
|
||||
::tcl::Bgerror {} {} {}
|
||||
} -returnCodes error -match glob -result {*msg options*}
|
||||
test event-5.6 {Default [interp bgerror] handler} -body {
|
||||
::tcl::Bgerror {} {}
|
||||
} -returnCodes error -match glob -result {*-level*}
|
||||
test event-5.7 {Default [interp bgerror] handler} -body {
|
||||
::tcl::Bgerror {} {-level foo}
|
||||
} -returnCodes error -match glob -result {*expected integer*}
|
||||
test event-5.8 {Default [interp bgerror] handler} -body {
|
||||
::tcl::Bgerror {} {-level 0}
|
||||
} -returnCodes error -match glob -result {*-code*}
|
||||
test event-5.9 {Default [interp bgerror] handler} -body {
|
||||
::tcl::Bgerror {} {-level 0 -code ok}
|
||||
} -returnCodes error -match glob -result {*expected integer*}
|
||||
test event-5.10 {Default [interp bgerror] handler} {
|
||||
proc bgerror {m} {append ::res $m}
|
||||
set ::res {}
|
||||
::tcl::Bgerror {} {-level 0 -code 0}
|
||||
rename bgerror {}
|
||||
set ::res
|
||||
} {}
|
||||
test event-5.11 {Default [interp bgerror] handler} {
|
||||
proc bgerror {m} {append ::res $m}
|
||||
set ::res {}
|
||||
::tcl::Bgerror msg {-level 0 -code 1}
|
||||
rename bgerror {}
|
||||
set ::res
|
||||
} {msg}
|
||||
test event-5.12 {Default [interp bgerror] handler} {
|
||||
proc bgerror {m} {append ::res $m}
|
||||
set ::res {}
|
||||
::tcl::Bgerror msg {-level 0 -code 2}
|
||||
rename bgerror {}
|
||||
set ::res
|
||||
} {command returned bad code: 2}
|
||||
test event-5.13 {Default [interp bgerror] handler} {
|
||||
proc bgerror {m} {append ::res $m}
|
||||
set ::res {}
|
||||
::tcl::Bgerror msg {-level 0 -code 3}
|
||||
rename bgerror {}
|
||||
set ::res
|
||||
} {invoked "break" outside of a loop}
|
||||
test event-5.14 {Default [interp bgerror] handler} {
|
||||
proc bgerror {m} {append ::res $m}
|
||||
set ::res {}
|
||||
::tcl::Bgerror msg {-level 0 -code 4}
|
||||
rename bgerror {}
|
||||
set ::res
|
||||
} {invoked "continue" outside of a loop}
|
||||
test event-5.15 {Default [interp bgerror] handler} {
|
||||
proc bgerror {m} {append ::res $m}
|
||||
set ::res {}
|
||||
::tcl::Bgerror msg {-level 0 -code 5}
|
||||
rename bgerror {}
|
||||
set ::res
|
||||
} {command returned bad code: 5}
|
||||
|
||||
test event-6.1 {BgErrorDeleteProc procedure} {
|
||||
catch {interp delete foo}
|
||||
interp create foo
|
||||
set erroutfile [makeFile Unmodified err.out]
|
||||
foo eval [list set erroutfile $erroutfile]
|
||||
foo eval {
|
||||
proc bgerror args {
|
||||
global errorInfo erroutfile
|
||||
set f [open $erroutfile r+]
|
||||
seek $f 0 end
|
||||
puts $f "$args $errorInfo"
|
||||
close $f
|
||||
}
|
||||
after 100 {error "first error"}
|
||||
after 100 {error "second error"}
|
||||
}
|
||||
after 100 {interp delete foo}
|
||||
after 200
|
||||
update
|
||||
set f [open $erroutfile r]
|
||||
set result [read $f]
|
||||
close $f
|
||||
removeFile $erroutfile
|
||||
set result
|
||||
} {Unmodified
|
||||
}
|
||||
|
||||
test event-7.1 {bgerror / regular} {
|
||||
set errRes {}
|
||||
proc bgerror {err} {
|
||||
global errRes;
|
||||
set errRes $err;
|
||||
}
|
||||
after 0 {error err1}
|
||||
vwait errRes;
|
||||
set errRes;
|
||||
} err1
|
||||
|
||||
test event-7.2 {bgerror / accumulation} {
|
||||
set errRes {}
|
||||
proc bgerror {err} {
|
||||
global errRes;
|
||||
lappend errRes $err;
|
||||
}
|
||||
after 0 {error err1}
|
||||
after 0 {error err2}
|
||||
after 0 {error err3}
|
||||
update
|
||||
set errRes;
|
||||
} {err1 err2 err3}
|
||||
|
||||
test event-7.3 {bgerror / accumulation / break} {
|
||||
set errRes {}
|
||||
proc bgerror {err} {
|
||||
global errRes;
|
||||
lappend errRes $err;
|
||||
return -code break "skip!";
|
||||
}
|
||||
after 0 {error err1}
|
||||
after 0 {error err2}
|
||||
after 0 {error err3}
|
||||
update
|
||||
set errRes;
|
||||
} err1
|
||||
|
||||
test event-7.4 {tkerror is nothing special anymore to tcl} {
|
||||
set errRes {}
|
||||
# we don't just rename bgerror to empty because it could then
|
||||
# be autoloaded...
|
||||
proc bgerror {err} {
|
||||
global errRes;
|
||||
lappend errRes "bg:$err";
|
||||
}
|
||||
proc tkerror {err} {
|
||||
global errRes;
|
||||
lappend errRes "tk:$err";
|
||||
}
|
||||
after 0 {error err1}
|
||||
update
|
||||
rename tkerror {}
|
||||
set errRes
|
||||
} bg:err1
|
||||
|
||||
testConstraint exec [llength [info commands exec]]
|
||||
|
||||
test event-7.5 {correct behaviour when there is no bgerror [Bug 219142]} {exec} {
|
||||
set script {
|
||||
after 1000 error hello
|
||||
after 2000 set a 0
|
||||
vwait a
|
||||
}
|
||||
|
||||
list [catch {exec [interpreter] << $script} errMsg] $errMsg
|
||||
} {1 {hello
|
||||
while executing
|
||||
"error hello"
|
||||
("after" script)}}
|
||||
|
||||
test event-7.6 {safe hidden bgerror fallback} {
|
||||
variable result {}
|
||||
interp create -safe safe
|
||||
safe alias puts puts
|
||||
safe alias result ::append [namespace which -variable result]
|
||||
safe eval {proc bgerror m {result $m\n$::errorCode\n$::errorInfo\n}}
|
||||
safe hide bgerror
|
||||
safe eval after 0 error foo
|
||||
update
|
||||
interp delete safe
|
||||
set result
|
||||
} {foo
|
||||
NONE
|
||||
foo
|
||||
while executing
|
||||
"error foo"
|
||||
("after" script)
|
||||
}
|
||||
|
||||
test event-7.7 {safe hidden bgerror fallback} {
|
||||
variable result {}
|
||||
interp create -safe safe
|
||||
safe alias puts puts
|
||||
safe alias result ::append [namespace which -variable result]
|
||||
safe eval {proc bgerror m {result $m\n$::errorCode\n$::errorInfo\n}}
|
||||
safe hide bgerror
|
||||
safe eval {proc bgerror m {error bar soom baz}}
|
||||
safe eval after 0 error foo
|
||||
update
|
||||
interp delete safe
|
||||
set result
|
||||
} {foo
|
||||
NONE
|
||||
foo
|
||||
while executing
|
||||
"error foo"
|
||||
("after" script)
|
||||
}
|
||||
|
||||
|
||||
# someday : add a test checking that
|
||||
# when there is no bgerror, an error msg goes to stderr
|
||||
# ideally one would use sub interp and transfer a fake stderr
|
||||
# to it, unfortunatly the current interp tcl API does not allow
|
||||
# that. the other option would be to use fork a test but it
|
||||
# then becomes more a file/exec test than a bgerror test.
|
||||
|
||||
# end of bgerror tests
|
||||
catch {rename bgerror {}}
|
||||
|
||||
|
||||
test event-8.1 {Tcl_CreateExitHandler procedure} {stdio testexithandler} {
|
||||
set child [open |[list [interpreter]] r+]
|
||||
puts $child "testexithandler create 41; testexithandler create 4"
|
||||
puts $child "testexithandler create 6; exit"
|
||||
flush $child
|
||||
set result [read $child]
|
||||
close $child
|
||||
set result
|
||||
} {even 6
|
||||
even 4
|
||||
odd 41
|
||||
}
|
||||
|
||||
test event-9.1 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
|
||||
set child [open |[list [interpreter]] r+]
|
||||
puts $child "testexithandler create 41; testexithandler create 4"
|
||||
puts $child "testexithandler create 6; testexithandler delete 41"
|
||||
puts $child "testexithandler create 16; exit"
|
||||
flush $child
|
||||
set result [read $child]
|
||||
close $child
|
||||
set result
|
||||
} {even 16
|
||||
even 6
|
||||
even 4
|
||||
}
|
||||
test event-9.2 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
|
||||
set child [open |[list [interpreter]] r+]
|
||||
puts $child "testexithandler create 41; testexithandler create 4"
|
||||
puts $child "testexithandler create 6; testexithandler delete 4"
|
||||
puts $child "testexithandler create 16; exit"
|
||||
flush $child
|
||||
set result [read $child]
|
||||
close $child
|
||||
set result
|
||||
} {even 16
|
||||
even 6
|
||||
odd 41
|
||||
}
|
||||
test event-9.3 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
|
||||
set child [open |[list [interpreter]] r+]
|
||||
puts $child "testexithandler create 41; testexithandler create 4"
|
||||
puts $child "testexithandler create 6; testexithandler delete 6"
|
||||
puts $child "testexithandler create 16; exit"
|
||||
flush $child
|
||||
set result [read $child]
|
||||
close $child
|
||||
set result
|
||||
} {even 16
|
||||
even 4
|
||||
odd 41
|
||||
}
|
||||
test event-9.4 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
|
||||
set child [open |[list [interpreter]] r+]
|
||||
puts $child "testexithandler create 41; testexithandler delete 41"
|
||||
puts $child "testexithandler create 16; exit"
|
||||
flush $child
|
||||
set result [read $child]
|
||||
close $child
|
||||
set result
|
||||
} {even 16
|
||||
}
|
||||
|
||||
test event-10.1 {Tcl_Exit procedure} {stdio} {
|
||||
set child [open |[list [interpreter]] r+]
|
||||
puts $child "exit 3"
|
||||
list [catch {close $child} msg] $msg [lindex $::errorCode 0] \
|
||||
[lindex $::errorCode 2]
|
||||
} {1 {child process exited abnormally} CHILDSTATUS 3}
|
||||
|
||||
test event-11.1 {Tcl_VwaitCmd procedure} {
|
||||
list [catch {vwait} msg] $msg
|
||||
} {1 {wrong # args: should be "vwait name"}}
|
||||
test event-11.2 {Tcl_VwaitCmd procedure} {
|
||||
list [catch {vwait a b} msg] $msg
|
||||
} {1 {wrong # args: should be "vwait name"}}
|
||||
test event-11.3 {Tcl_VwaitCmd procedure} {
|
||||
catch {unset x}
|
||||
set x 1
|
||||
list [catch {vwait x(1)} msg] $msg
|
||||
} {1 {can't trace "x(1)": variable isn't array}}
|
||||
test event-11.4 {Tcl_VwaitCmd procedure} {} {
|
||||
foreach i [after info] {
|
||||
after cancel $i
|
||||
}
|
||||
after 10; update; # On Mac make sure update won't take long
|
||||
after 100 {set x x-done}
|
||||
after 200 {set y y-done}
|
||||
after 300 {set z z-done}
|
||||
after idle {set q q-done}
|
||||
set x before
|
||||
set y before
|
||||
set z before
|
||||
set q before
|
||||
list [vwait y] $x $y $z $q
|
||||
} {{} x-done y-done before q-done}
|
||||
|
||||
foreach i [after info] {
|
||||
after cancel $i
|
||||
}
|
||||
|
||||
test event-11.5 {Tcl_VwaitCmd procedure: round robin scheduling, 2 sources} {socket} {
|
||||
set test1file [makeFile "" test1]
|
||||
set f1 [open $test1file w]
|
||||
proc accept {s args} {
|
||||
puts $s foobar
|
||||
close $s
|
||||
}
|
||||
catch {set s1 [socket -server accept -myaddr 127.0.0.1 0]}
|
||||
after 1000
|
||||
catch {set s2 [socket 127.0.0.1 [lindex [fconfigure $s1 -sockname] 2]]}
|
||||
close $s1
|
||||
set x 0
|
||||
set y 0
|
||||
set z 0
|
||||
fileevent $s2 readable {incr z}
|
||||
vwait z
|
||||
fileevent $f1 writable {incr x; if {$y == 3} {set z done}}
|
||||
fileevent $s2 readable {incr y; if {$x == 3} {set z done}}
|
||||
vwait z
|
||||
close $f1
|
||||
close $s2
|
||||
removeFile $test1file
|
||||
list $x $y $z
|
||||
} {3 3 done}
|
||||
test event-11.6 {Tcl_VwaitCmd procedure: round robin scheduling, same source} {
|
||||
set test1file [makeFile "" test1]
|
||||
set test2file [makeFile "" test2]
|
||||
set f1 [open $test1file w]
|
||||
set f2 [open $test2file w]
|
||||
set x 0
|
||||
set y 0
|
||||
set z 0
|
||||
update
|
||||
fileevent $f1 writable {incr x; if {$y == 3} {set z done}}
|
||||
fileevent $f2 writable {incr y; if {$x == 3} {set z done}}
|
||||
vwait z
|
||||
close $f1
|
||||
close $f2
|
||||
removeFile $test1file
|
||||
removeFile $test2file
|
||||
list $x $y $z
|
||||
} {3 3 done}
|
||||
|
||||
|
||||
test event-12.1 {Tcl_UpdateCmd procedure} {
|
||||
list [catch {update a b} msg] $msg
|
||||
} {1 {wrong # args: should be "update ?idletasks?"}}
|
||||
test event-12.2 {Tcl_UpdateCmd procedure} {
|
||||
list [catch {update bogus} msg] $msg
|
||||
} {1 {bad option "bogus": must be idletasks}}
|
||||
test event-12.3 {Tcl_UpdateCmd procedure} {
|
||||
foreach i [after info] {
|
||||
after cancel $i
|
||||
}
|
||||
after 500 {set x after}
|
||||
after idle {set y after}
|
||||
after idle {set z "after, y = $y"}
|
||||
set x before
|
||||
set y before
|
||||
set z before
|
||||
update idletasks
|
||||
list $x $y $z
|
||||
} {before after {after, y = after}}
|
||||
test event-12.4 {Tcl_UpdateCmd procedure} {
|
||||
foreach i [after info] {
|
||||
after cancel $i
|
||||
}
|
||||
after 10; update; # On Mac make sure update won't take long
|
||||
after 200 {set x x-done}
|
||||
after 600 {set y y-done}
|
||||
after idle {set z z-done}
|
||||
set x before
|
||||
set y before
|
||||
set z before
|
||||
after 300
|
||||
update
|
||||
list $x $y $z
|
||||
} {x-done before z-done}
|
||||
|
||||
test event-13.1 {Tcl_WaitForFile procedure, readable} {testfilehandler} {
|
||||
foreach i [after info] {
|
||||
after cancel $i
|
||||
}
|
||||
after 100 set x timeout
|
||||
testfilehandler close
|
||||
testfilehandler create 1 off off
|
||||
set x "no timeout"
|
||||
set result [testfilehandler wait 1 readable 0]
|
||||
update
|
||||
testfilehandler close
|
||||
list $result $x
|
||||
} {{} {no timeout}}
|
||||
test event-13.2 {Tcl_WaitForFile procedure, readable} testfilehandler {
|
||||
foreach i [after info] {
|
||||
after cancel $i
|
||||
}
|
||||
after 100 set x timeout
|
||||
testfilehandler close
|
||||
testfilehandler create 1 off off
|
||||
set x "no timeout"
|
||||
set result [testfilehandler wait 1 readable 100]
|
||||
update
|
||||
testfilehandler close
|
||||
list $result $x
|
||||
} {{} timeout}
|
||||
test event-13.3 {Tcl_WaitForFile procedure, readable} testfilehandler {
|
||||
foreach i [after info] {
|
||||
after cancel $i
|
||||
}
|
||||
after 100 set x timeout
|
||||
testfilehandler close
|
||||
testfilehandler create 1 off off
|
||||
testfilehandler fillpartial 1
|
||||
set x "no timeout"
|
||||
set result [testfilehandler wait 1 readable 100]
|
||||
update
|
||||
testfilehandler close
|
||||
list $result $x
|
||||
} {readable {no timeout}}
|
||||
test event-13.4 {Tcl_WaitForFile procedure, writable} \
|
||||
{testfilehandler nonPortable} {
|
||||
foreach i [after info] {
|
||||
after cancel $i
|
||||
}
|
||||
after 100 set x timeout
|
||||
testfilehandler close
|
||||
testfilehandler create 1 off off
|
||||
testfilehandler fill 1
|
||||
set x "no timeout"
|
||||
set result [testfilehandler wait 1 writable 0]
|
||||
update
|
||||
testfilehandler close
|
||||
list $result $x
|
||||
} {{} {no timeout}}
|
||||
test event-13.5 {Tcl_WaitForFile procedure, writable} \
|
||||
{testfilehandler nonPortable} {
|
||||
foreach i [after info] {
|
||||
after cancel $i
|
||||
}
|
||||
after 100 set x timeout
|
||||
testfilehandler close
|
||||
testfilehandler create 1 off off
|
||||
testfilehandler fill 1
|
||||
set x "no timeout"
|
||||
set result [testfilehandler wait 1 writable 100]
|
||||
update
|
||||
testfilehandler close
|
||||
list $result $x
|
||||
} {{} timeout}
|
||||
test event-13.6 {Tcl_WaitForFile procedure, writable} testfilehandler {
|
||||
foreach i [after info] {
|
||||
after cancel $i
|
||||
}
|
||||
after 100 set x timeout
|
||||
testfilehandler close
|
||||
testfilehandler create 1 off off
|
||||
set x "no timeout"
|
||||
set result [testfilehandler wait 1 writable 100]
|
||||
update
|
||||
testfilehandler close
|
||||
list $result $x
|
||||
} {writable {no timeout}}
|
||||
test event-13.7 {Tcl_WaitForFile procedure, don't call other event handlers} testfilehandler {
|
||||
foreach i [after info] {
|
||||
after cancel $i
|
||||
}
|
||||
after 100 lappend x timeout
|
||||
after idle lappend x idle
|
||||
testfilehandler close
|
||||
testfilehandler create 1 off off
|
||||
set x ""
|
||||
set result [list [testfilehandler wait 1 readable 200] $x]
|
||||
update
|
||||
testfilehandler close
|
||||
lappend result $x
|
||||
} {{} {} {timeout idle}}
|
||||
|
||||
test event-13.8 {Tcl_WaitForFile procedure, waiting indefinitely} testfilewait {
|
||||
set f [open "|sleep 2" r]
|
||||
set result ""
|
||||
lappend result [testfilewait $f readable 100]
|
||||
lappend result [testfilewait $f readable -1]
|
||||
close $f
|
||||
set result
|
||||
} {{} readable}
|
||||
|
||||
|
||||
test event-14.1 {Tcl_WaitForFile procedure, readable, big fd} \
|
||||
-constraints {testfilehandler unix} \
|
||||
-setup {
|
||||
set chanList {}
|
||||
for {set i 0} {$i < 32} {incr i} {
|
||||
lappend chanList [open /dev/null r]
|
||||
}
|
||||
} \
|
||||
-body {
|
||||
foreach i [after info] {
|
||||
after cancel $i
|
||||
}
|
||||
after 100 set x timeout
|
||||
testfilehandler close
|
||||
testfilehandler create 1 off off
|
||||
set x "no timeout"
|
||||
set result [testfilehandler wait 1 readable 0]
|
||||
update
|
||||
testfilehandler close
|
||||
list $result $x
|
||||
} \
|
||||
-result {{} {no timeout}} \
|
||||
-cleanup {
|
||||
foreach chan $chanList {close $chan}
|
||||
}
|
||||
|
||||
test event-14.2 {Tcl_WaitForFile procedure, readable, big fd} \
|
||||
-constraints {testfilehandler unix} \
|
||||
-setup {
|
||||
set chanList {}
|
||||
for {set i 0} {$i < 32} {incr i} {
|
||||
lappend chanList [open /dev/null r]
|
||||
}
|
||||
} \
|
||||
-body {
|
||||
foreach i [after info] {
|
||||
after cancel $i
|
||||
}
|
||||
after 100 set x timeout
|
||||
testfilehandler close
|
||||
testfilehandler create 1 off off
|
||||
set x "no timeout"
|
||||
set result [testfilehandler wait 1 readable 100]
|
||||
update
|
||||
testfilehandler close
|
||||
list $result $x
|
||||
} \
|
||||
-result {{} timeout} \
|
||||
-cleanup {
|
||||
foreach chan $chanList {close $chan}
|
||||
}
|
||||
|
||||
test event-14.3 {Tcl_WaitForFile procedure, readable, big fd} \
|
||||
-constraints {testfilehandler unix} \
|
||||
-setup {
|
||||
set chanList {}
|
||||
for {set i 0} {$i < 32} {incr i} {
|
||||
lappend chanList [open /dev/null r]
|
||||
}
|
||||
} \
|
||||
-body {
|
||||
foreach i [after info] {
|
||||
after cancel $i
|
||||
}
|
||||
after 100 set x timeout
|
||||
testfilehandler close
|
||||
testfilehandler create 1 off off
|
||||
testfilehandler fillpartial 1
|
||||
set x "no timeout"
|
||||
set result [testfilehandler wait 1 readable 100]
|
||||
update
|
||||
testfilehandler close
|
||||
list $result $x
|
||||
} \
|
||||
-result {readable {no timeout}} \
|
||||
-cleanup {
|
||||
foreach chan $chanList {close $chan}
|
||||
}
|
||||
|
||||
test event-14.4 {Tcl_WaitForFile procedure, writable, big fd} \
|
||||
-constraints {testfilehandler unix nonPortable} \
|
||||
-setup {
|
||||
set chanList {}
|
||||
for {set i 0} {$i < 32} {incr i} {
|
||||
lappend chanList [open /dev/null r]
|
||||
}
|
||||
} \
|
||||
-body {
|
||||
foreach i [after info] {
|
||||
after cancel $i
|
||||
}
|
||||
after 100 set x timeout
|
||||
testfilehandler close
|
||||
testfilehandler create 1 off off
|
||||
testfilehandler fill 1
|
||||
set x "no timeout"
|
||||
set result [testfilehandler wait 1 writable 0]
|
||||
update
|
||||
testfilehandler close
|
||||
list $result $
|
||||
} \
|
||||
-result {{} {no timeout}} \
|
||||
-cleanup {
|
||||
foreach chan $chanList {close $chan}
|
||||
}
|
||||
|
||||
test event-14.5 {Tcl_WaitForFile procedure, writable, big fd} \
|
||||
-constraints {testfilehandler unix nonPortable} \
|
||||
-setup {
|
||||
set chanList {}
|
||||
for {set i 0} {$i < 32} {incr i} {
|
||||
lappend chanList [open /dev/null r]
|
||||
}
|
||||
} \
|
||||
-body {
|
||||
foreach i [after info] {
|
||||
after cancel $i
|
||||
}
|
||||
after 100 set x timeout
|
||||
testfilehandler close
|
||||
testfilehandler create 1 off off
|
||||
testfilehandler fill 1
|
||||
set x "no timeout"
|
||||
set result [testfilehandler wait 1 writable 100]
|
||||
update
|
||||
testfilehandler close
|
||||
list $result $x
|
||||
} \
|
||||
-result {{} timeout} \
|
||||
-cleanup {
|
||||
foreach chan $chanList {close $chan}
|
||||
}
|
||||
|
||||
test event-14.6 {Tcl_WaitForFile procedure, writable, big fd} \
|
||||
-constraints {testfilehandler unix} \
|
||||
-setup {
|
||||
set chanList {}
|
||||
for {set i 0} {$i < 32} {incr i} {
|
||||
lappend chanList [open /dev/null r]
|
||||
}
|
||||
} \
|
||||
-body {
|
||||
foreach i [after info] {
|
||||
after cancel $i
|
||||
}
|
||||
after 100 set x timeout
|
||||
testfilehandler close
|
||||
testfilehandler create 1 off off
|
||||
set x "no timeout"
|
||||
set result [testfilehandler wait 1 writable 100]
|
||||
update
|
||||
testfilehandler close
|
||||
list $result $x
|
||||
} \
|
||||
-result {writable {no timeout}} \
|
||||
-cleanup {
|
||||
foreach chan $chanList {close $chan}
|
||||
}
|
||||
|
||||
test event-14.7 {Tcl_WaitForFile, don't call other event handlers, big fd} \
|
||||
-constraints {testfilehandler unix} \
|
||||
-setup {
|
||||
set chanList {}
|
||||
for {set i 0} {$i < 32} {incr i} {
|
||||
lappend chanList [open /dev/null r]
|
||||
}
|
||||
} \
|
||||
-body {
|
||||
foreach i [after info] {
|
||||
after cancel $i
|
||||
}
|
||||
after 100 lappend x timeout
|
||||
after idle lappend x idle
|
||||
testfilehandler close
|
||||
testfilehandler create 1 off off
|
||||
set x ""
|
||||
set result [list [testfilehandler wait 1 readable 200] $x]
|
||||
update
|
||||
testfilehandler close
|
||||
lappend result $x
|
||||
} \
|
||||
-result {{} {} {timeout idle}} \
|
||||
-cleanup {
|
||||
foreach chan $chanList {close $chan}
|
||||
}
|
||||
|
||||
|
||||
test event-14.8 {Tcl_WaitForFile procedure, waiting indefinitely, big fd} \
|
||||
-constraints {testfilewait unix} \
|
||||
-body {
|
||||
set f [open "|sleep 2" r]
|
||||
set result ""
|
||||
lappend result [testfilewait $f readable 100]
|
||||
lappend result [testfilewait $f readable -1]
|
||||
close $f
|
||||
set result
|
||||
} \
|
||||
-setup {
|
||||
set chanList {}
|
||||
for {set i 0} {$i < 32} {incr i} {
|
||||
lappend chanList [open /dev/null r]
|
||||
}
|
||||
} \
|
||||
-result {{} readable} \
|
||||
-cleanup {
|
||||
foreach chan $chanList {close $chan}
|
||||
}
|
||||
|
||||
# cleanup
|
||||
foreach i [after info] {
|
||||
after cancel $i
|
||||
}
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
715
tests/exec.test
Normal file
715
tests/exec.test
Normal file
@@ -0,0 +1,715 @@
|
||||
# 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-1994 The Regents of the University of California.
|
||||
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
package require tcltest 2
|
||||
namespace import -force ::tcltest::*
|
||||
|
||||
# All tests require the "exec" command.
|
||||
# Skip them if exec is not defined.
|
||||
testConstraint exec [llength [info commands exec]]
|
||||
unset -nocomplain path
|
||||
set path(echo) [makeFile {
|
||||
puts -nonewline [lindex $argv 0]
|
||||
foreach str [lrange $argv 1 end] {
|
||||
puts -nonewline " $str"
|
||||
}
|
||||
puts {}
|
||||
exit
|
||||
} echo]
|
||||
|
||||
set path(echo2) [makeFile {
|
||||
puts stdout [join $argv]
|
||||
puts stderr [lindex $argv 1]
|
||||
exit
|
||||
} echo2]
|
||||
|
||||
set path(cat) [makeFile {
|
||||
if {$argv == {}} {
|
||||
set argv -
|
||||
}
|
||||
foreach name $argv {
|
||||
if {$name == "-"} {
|
||||
set f stdin
|
||||
} elseif {[catch {open $name r} f] != 0} {
|
||||
puts stderr $f
|
||||
continue
|
||||
}
|
||||
while {[eof $f] == 0} {
|
||||
puts -nonewline [read $f]
|
||||
}
|
||||
if {$f != "stdin"} {
|
||||
close $f
|
||||
}
|
||||
}
|
||||
exit
|
||||
} cat]
|
||||
|
||||
set path(wc) [makeFile {
|
||||
set data [read stdin]
|
||||
set lines [regsub -all "\n" $data {} dummy]
|
||||
set words [regsub -all "\[^ \t\n]+" $data {} dummy]
|
||||
set chars [string length $data]
|
||||
puts [format "%8.d%8.d%8.d" $lines $words $chars]
|
||||
exit
|
||||
} wc]
|
||||
|
||||
set path(sh) [makeFile {
|
||||
if {[lindex $argv 0] != "-c"} {
|
||||
error "sh: unexpected arguments $argv"
|
||||
}
|
||||
set cmd [lindex $argv 1]
|
||||
lappend cmd ";"
|
||||
|
||||
set newcmd {}
|
||||
|
||||
foreach arg $cmd {
|
||||
if {$arg == ";"} {
|
||||
eval exec >@stdout 2>@stderr [list [info nameofexecutable]] $newcmd
|
||||
set newcmd {}
|
||||
continue
|
||||
}
|
||||
if {$arg == "1>&2"} {
|
||||
set arg >@stderr
|
||||
}
|
||||
lappend newcmd $arg
|
||||
}
|
||||
exit
|
||||
} sh]
|
||||
set path(sh2) [makeFile {
|
||||
if {[lindex $argv 0] != "-c"} {
|
||||
error "sh: unexpected arguments $argv"
|
||||
}
|
||||
set cmd [lindex $argv 1]
|
||||
lappend cmd ";"
|
||||
|
||||
set newcmd {}
|
||||
|
||||
foreach arg $cmd {
|
||||
if {$arg == ";"} {
|
||||
eval exec -ignorestderr >@stdout [list [info nameofexecutable]] $newcmd
|
||||
set newcmd {}
|
||||
continue
|
||||
}
|
||||
lappend newcmd $arg
|
||||
}
|
||||
exit
|
||||
} sh2]
|
||||
|
||||
set path(sleep) [makeFile {
|
||||
after [expr $argv*1000]
|
||||
exit
|
||||
} sleep]
|
||||
|
||||
set path(exit) [makeFile {
|
||||
exit $argv
|
||||
} exit]
|
||||
|
||||
# Basic operations.
|
||||
|
||||
test exec-1.1 {basic exec operation} {exec} {
|
||||
exec [interpreter] $path(echo) a b c
|
||||
} "a b c"
|
||||
test exec-1.2 {pipelining} {exec stdio} {
|
||||
exec [interpreter] $path(echo) a b c d | [interpreter] $path(cat) | [interpreter] $path(cat)
|
||||
} "a b c d"
|
||||
test exec-1.3 {pipelining} {exec stdio} {
|
||||
set a [exec [interpreter] $path(echo) a b c d | [interpreter] $path(cat) | [interpreter] $path(wc)]
|
||||
list [scan $a "%d %d %d" b c d] $b $c
|
||||
} {3 1 4}
|
||||
set arg {12345678901234567890123456789012345678901234567890}
|
||||
set arg "$arg$arg$arg$arg$arg$arg"
|
||||
test exec-1.4 {long command lines} {exec} {
|
||||
exec [interpreter] $path(echo) $arg
|
||||
} $arg
|
||||
set arg {}
|
||||
|
||||
# I/O redirection: input from Tcl command.
|
||||
|
||||
test exec-2.1 {redirecting input from immediate source} {exec stdio} {
|
||||
exec [interpreter] $path(cat) << "Sample text"
|
||||
} {Sample text}
|
||||
test exec-2.2 {redirecting input from immediate source} {exec stdio} {
|
||||
exec << "Sample text" [interpreter] $path(cat) | [interpreter] $path(cat)
|
||||
} {Sample text}
|
||||
test exec-2.3 {redirecting input from immediate source} {exec stdio} {
|
||||
exec [interpreter] $path(cat) << "Sample text" | [interpreter] $path(cat)
|
||||
} {Sample text}
|
||||
test exec-2.4 {redirecting input from immediate source} {exec stdio} {
|
||||
exec [interpreter] $path(cat) | [interpreter] $path(cat) << "Sample text"
|
||||
} {Sample text}
|
||||
test exec-2.5 {redirecting input from immediate source} {exec} {
|
||||
exec [interpreter] $path(cat) "<<Joined to arrows"
|
||||
} {Joined to arrows}
|
||||
test exec-2.6 {redirecting input from immediate source, with UTF} {exec} {
|
||||
# If this fails, it may give back:
|
||||
# "\uC3\uA9\uC3\uA0\uC3\uBC\uC3\uB1"
|
||||
# If it does, this means that the UTF -> external conversion did not
|
||||
# occur before writing out the temp file.
|
||||
exec [interpreter] $path(cat) << "\uE9\uE0\uFC\uF1"
|
||||
} "\uE9\uE0\uFC\uF1"
|
||||
|
||||
# I/O redirection: output to file.
|
||||
|
||||
set path(gorp.file) [makeFile {} gorp.file]
|
||||
file delete $path(gorp.file)
|
||||
|
||||
test exec-3.1 {redirecting output to file} {exec} {
|
||||
exec [interpreter] $path(echo) "Some simple words" > $path(gorp.file)
|
||||
exec [interpreter] $path(cat) $path(gorp.file)
|
||||
} "Some simple words"
|
||||
test exec-3.2 {redirecting output to file} {exec stdio} {
|
||||
exec [interpreter] $path(echo) "More simple words" | >$path(gorp.file) [interpreter] $path(cat) | [interpreter] $path(cat)
|
||||
exec [interpreter] $path(cat) $path(gorp.file)
|
||||
} "More simple words"
|
||||
test exec-3.3 {redirecting output to file} {exec stdio} {
|
||||
exec > $path(gorp.file) [interpreter] $path(echo) "Different simple words" | [interpreter] $path(cat) | [interpreter] $path(cat)
|
||||
exec [interpreter] $path(cat) $path(gorp.file)
|
||||
} "Different simple words"
|
||||
test exec-3.4 {redirecting output to file} {exec} {
|
||||
exec [interpreter] $path(echo) "Some simple words" >$path(gorp.file)
|
||||
exec [interpreter] $path(cat) $path(gorp.file)
|
||||
} "Some simple words"
|
||||
test exec-3.5 {redirecting output to file} {exec} {
|
||||
exec [interpreter] $path(echo) "First line" >$path(gorp.file)
|
||||
exec [interpreter] $path(echo) "Second line" >> $path(gorp.file)
|
||||
exec [interpreter] $path(cat) $path(gorp.file)
|
||||
} "First line\nSecond line"
|
||||
test exec-3.6 {redirecting output to file} {exec} {
|
||||
exec [interpreter] $path(echo) "First line" >$path(gorp.file)
|
||||
exec [interpreter] $path(echo) "Second line" >>$path(gorp.file)
|
||||
exec [interpreter] $path(cat) $path(gorp.file)
|
||||
} "First line\nSecond line"
|
||||
test exec-3.7 {redirecting output to file} {exec} {
|
||||
set f [open $path(gorp.file) w]
|
||||
puts $f "Line 1"
|
||||
flush $f
|
||||
exec [interpreter] $path(echo) "More text" >@ $f
|
||||
exec [interpreter] $path(echo) >@$f "Even more"
|
||||
puts $f "Line 3"
|
||||
close $f
|
||||
exec [interpreter] $path(cat) $path(gorp.file)
|
||||
} "Line 1\nMore text\nEven more\nLine 3"
|
||||
|
||||
# I/O redirection: output and stderr to file.
|
||||
|
||||
file delete $path(gorp.file)
|
||||
|
||||
test exec-4.1 {redirecting output and stderr to file} {exec} {
|
||||
exec [interpreter] "$path(echo)" "test output" >& $path(gorp.file)
|
||||
exec [interpreter] "$path(cat)" "$path(gorp.file)"
|
||||
} "test output"
|
||||
test exec-4.2 {redirecting output and stderr to file} {exec} {
|
||||
list [exec [interpreter] "$path(sh)" -c "\"$path(echo)\" foo bar 1>&2" >&$path(gorp.file)] \
|
||||
[exec [interpreter] "$path(cat)" "$path(gorp.file)"]
|
||||
} {{} {foo bar}}
|
||||
test exec-4.3 {redirecting output and stderr to file} {exec} {
|
||||
exec [interpreter] $path(echo) "first line" > $path(gorp.file)
|
||||
list [exec [interpreter] "$path(sh)" -c "\"$path(echo)\" foo bar 1>&2" >>&$path(gorp.file)] \
|
||||
[exec [interpreter] "$path(cat)" "$path(gorp.file)"]
|
||||
} "{} {first line\nfoo bar}"
|
||||
test exec-4.4 {redirecting output and stderr to file} {exec} {
|
||||
set f [open "$path(gorp.file)" w]
|
||||
puts $f "Line 1"
|
||||
flush $f
|
||||
exec [interpreter] "$path(echo)" "More text" >&@ $f
|
||||
exec [interpreter] "$path(echo)" >&@$f "Even more"
|
||||
puts $f "Line 3"
|
||||
close $f
|
||||
exec [interpreter] "$path(cat)" "$path(gorp.file)"
|
||||
} "Line 1\nMore text\nEven more\nLine 3"
|
||||
test exec-4.5 {redirecting output and stderr to file} {exec} {
|
||||
set f [open "$path(gorp.file)" w]
|
||||
puts $f "Line 1"
|
||||
flush $f
|
||||
exec >&@ $f [interpreter] "$path(sh)" -c "\"$path(echo)\" foo bar 1>&2"
|
||||
exec >&@$f [interpreter] "$path(sh)" -c "\"$path(echo)\" xyzzy 1>&2"
|
||||
puts $f "Line 3"
|
||||
close $f
|
||||
exec [interpreter] "$path(cat)" "$path(gorp.file)"
|
||||
} "Line 1\nfoo bar\nxyzzy\nLine 3"
|
||||
|
||||
# I/O redirection: input from file.
|
||||
|
||||
if {[testConstraint exec]} {
|
||||
exec [interpreter] $path(echo) "Just a few thoughts" > $path(gorp.file)
|
||||
}
|
||||
test exec-5.1 {redirecting input from file} {exec} {
|
||||
exec [interpreter] $path(cat) < $path(gorp.file)
|
||||
} {Just a few thoughts}
|
||||
test exec-5.2 {redirecting input from file} {exec stdio} {
|
||||
exec [interpreter] $path(cat) | [interpreter] $path(cat) < $path(gorp.file)
|
||||
} {Just a few thoughts}
|
||||
test exec-5.3 {redirecting input from file} {exec stdio} {
|
||||
exec [interpreter] $path(cat) < $path(gorp.file) | [interpreter] $path(cat)
|
||||
} {Just a few thoughts}
|
||||
test exec-5.4 {redirecting input from file} {exec stdio} {
|
||||
exec < $path(gorp.file) [interpreter] $path(cat) | [interpreter] $path(cat)
|
||||
} {Just a few thoughts}
|
||||
test exec-5.5 {redirecting input from file} {exec} {
|
||||
exec [interpreter] $path(cat) <$path(gorp.file)
|
||||
} {Just a few thoughts}
|
||||
test exec-5.6 {redirecting input from file} {exec} {
|
||||
set f [open $path(gorp.file) r]
|
||||
set result [exec [interpreter] $path(cat) <@ $f]
|
||||
close $f
|
||||
set result
|
||||
} {Just a few thoughts}
|
||||
test exec-5.7 {redirecting input from file} {exec} {
|
||||
set f [open $path(gorp.file) r]
|
||||
set result [exec <@$f [interpreter] $path(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 stdio} {
|
||||
exec [interpreter] "$path(sh)" -c "\"$path(echo)\" foo bar" |& [interpreter] "$path(cat)"
|
||||
} "foo bar"
|
||||
test exec-6.2 {redirecting stderr through a pipeline} {exec stdio} {
|
||||
exec [interpreter] "$path(sh)" -c "\"$path(echo)\" foo bar 1>&2" |& [interpreter] "$path(cat)"
|
||||
} "foo bar"
|
||||
test exec-6.3 {redirecting stderr through a pipeline} {exec stdio} {
|
||||
exec [interpreter] "$path(sh)" -c "\"$path(echo)\" foo bar 1>&2" \
|
||||
|& [interpreter] "$path(sh)" -c "\"$path(echo)\" second msg 1>&2 ; \"$path(cat)\"" |& [interpreter] "$path(cat)"
|
||||
} "second msg\nfoo bar"
|
||||
|
||||
# I/O redirection: combinations.
|
||||
|
||||
set path(gorp.file2) [makeFile {} gorp.file2]
|
||||
file delete $path(gorp.file2)
|
||||
|
||||
test exec-7.1 {multiple I/O redirections} {exec} {
|
||||
exec << "command input" > $path(gorp.file2) [interpreter] $path(cat) < $path(gorp.file)
|
||||
exec [interpreter] $path(cat) $path(gorp.file2)
|
||||
} {Just a few thoughts}
|
||||
test exec-7.2 {multiple I/O redirections} {exec} {
|
||||
exec < $path(gorp.file) << "command input" [interpreter] $path(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} {
|
||||
exec [interpreter] $path(cat) << $a
|
||||
} $a
|
||||
|
||||
# More than 20 arguments to exec.
|
||||
|
||||
test exec-8.2 {long input and output} {exec} {
|
||||
exec [interpreter] $path(echo) 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23
|
||||
} {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23}
|
||||
|
||||
# Commands that return errors.
|
||||
|
||||
test exec-9.1 {commands returning errors} {exec} {
|
||||
set x [catch {exec gorp456} msg]
|
||||
list $x [string tolower $msg] [string tolower $errorCode]
|
||||
} {1 {couldn't execute "gorp456": no such file or directory} {posix enoent {no such file or directory}}}
|
||||
test exec-9.2 {commands returning errors} {exec} {
|
||||
string tolower [list [catch {exec [interpreter] echo foo | foo123} msg] $msg $errorCode]
|
||||
} {1 {couldn't execute "foo123": no such file or directory} {posix enoent {no such file or directory}}}
|
||||
test exec-9.3 {commands returning errors} {exec stdio} {
|
||||
list [catch {exec [interpreter] $path(sleep) 1 | [interpreter] $path(exit) 43 | [interpreter] $path(sleep) 1} msg] $msg
|
||||
} {1 {child process exited abnormally}}
|
||||
test exec-9.4 {commands returning errors} {exec stdio} {
|
||||
list [catch {exec [interpreter] $path(exit) 43 | [interpreter] $path(echo) "foo bar"} msg] $msg
|
||||
} {1 {foo bar
|
||||
child process exited abnormally}}
|
||||
test exec-9.5 {commands returning errors} {exec stdio} {
|
||||
list [catch {exec gorp456 | [interpreter] echo a b c} msg] [string tolower $msg]
|
||||
} {1 {couldn't execute "gorp456": no such file or directory}}
|
||||
test exec-9.6 {commands returning errors} {exec} {
|
||||
list [catch {exec [interpreter] "$path(sh)" -c "\"$path(echo)\" error msg 1>&2"} msg] $msg
|
||||
} {1 {error msg}}
|
||||
test exec-9.7 {commands returning errors} {exec stdio} {
|
||||
list [catch {exec [interpreter] "$path(sh)" -c "\"$path(echo)\" error msg 1>&2 ; \"$path(sleep)\" 1" \
|
||||
| [interpreter] "$path(sh)" -c "\"$path(echo)\" error msg 1>&2 ; \"$path(sleep)\" 1"} msg] $msg
|
||||
} {1 {error msg
|
||||
error msg}}
|
||||
|
||||
set path(err) [makeFile {} err]
|
||||
|
||||
test exec-9.8 {commands returning errors} {exec} {
|
||||
set f [open $path(err) w]
|
||||
puts $f {
|
||||
puts stdout out
|
||||
puts stderr err
|
||||
}
|
||||
close $f
|
||||
list [catch {exec [interpreter] $path(err)} msg] $msg
|
||||
} {1 {out
|
||||
err}}
|
||||
|
||||
# Errors in executing the Tcl command, as opposed to errors in the
|
||||
# processes that are invoked.
|
||||
|
||||
test exec-10.1 {errors in exec invocation} {exec} {
|
||||
list [catch {exec} msg] $msg
|
||||
} {1 {wrong # args: should be "exec ?switches? arg ?arg ...?"}}
|
||||
test exec-10.2 {errors in exec invocation} {exec} {
|
||||
list [catch {exec | cat} msg] $msg
|
||||
} {1 {illegal use of | or |& in command}}
|
||||
test exec-10.3 {errors in exec invocation} {exec} {
|
||||
list [catch {exec cat |} msg] $msg
|
||||
} {1 {illegal use of | or |& in command}}
|
||||
test exec-10.4 {errors in exec invocation} {exec} {
|
||||
list [catch {exec cat | | cat} msg] $msg
|
||||
} {1 {illegal use of | or |& in command}}
|
||||
test exec-10.5 {errors in exec invocation} {exec} {
|
||||
list [catch {exec cat | |& cat} msg] $msg
|
||||
} {1 {illegal use of | or |& in command}}
|
||||
test exec-10.6 {errors in exec invocation} {exec} {
|
||||
list [catch {exec cat |&} msg] $msg
|
||||
} {1 {illegal use of | or |& in command}}
|
||||
test exec-10.7 {errors in exec invocation} {exec} {
|
||||
list [catch {exec cat <} msg] $msg
|
||||
} {1 {can't specify "<" as last word in command}}
|
||||
test exec-10.8 {errors in exec invocation} {exec} {
|
||||
list [catch {exec cat >} msg] $msg
|
||||
} {1 {can't specify ">" as last word in command}}
|
||||
test exec-10.9 {errors in exec invocation} {exec} {
|
||||
list [catch {exec cat <<} msg] $msg
|
||||
} {1 {can't specify "<<" as last word in command}}
|
||||
test exec-10.10 {errors in exec invocation} {exec} {
|
||||
list [catch {exec cat >>} msg] $msg
|
||||
} {1 {can't specify ">>" as last word in command}}
|
||||
test exec-10.11 {errors in exec invocation} {exec} {
|
||||
list [catch {exec cat >&} msg] $msg
|
||||
} {1 {can't specify ">&" as last word in command}}
|
||||
test exec-10.12 {errors in exec invocation} {exec} {
|
||||
list [catch {exec cat >>&} msg] $msg
|
||||
} {1 {can't specify ">>&" as last word in command}}
|
||||
test exec-10.13 {errors in exec invocation} {exec} {
|
||||
list [catch {exec cat >@} msg] $msg
|
||||
} {1 {can't specify ">@" as last word in command}}
|
||||
test exec-10.14 {errors in exec invocation} {exec} {
|
||||
list [catch {exec cat <@} msg] $msg
|
||||
} {1 {can't specify "<@" as last word in command}}
|
||||
test exec-10.15 {errors in exec invocation} {exec} {
|
||||
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} {exec} {
|
||||
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} {exec} {
|
||||
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 $path(gorp.file) w]
|
||||
test exec-10.18 {errors in exec invocation} {exec} {
|
||||
list [catch {exec cat <@ $f} msg] $msg
|
||||
} "1 {channel \"$f\" wasn't opened for reading}"
|
||||
close $f
|
||||
set f [open $path(gorp.file) r]
|
||||
test exec-10.19 {errors in exec invocation} {exec} {
|
||||
list [catch {exec cat >@ $f} msg] $msg
|
||||
} "1 {channel \"$f\" wasn't opened for writing}"
|
||||
close $f
|
||||
test exec-10.20 {errors in exec invocation} {exec} {
|
||||
list [catch {exec ~non_existent_user/foo/bar} msg] $msg
|
||||
} {1 {user "non_existent_user" doesn't exist}}
|
||||
test exec-10.21 {errors in exec invocation} {exec} {
|
||||
list [catch {exec [interpreter] true | ~xyzzy_bad_user/x | false} msg] $msg
|
||||
} {1 {user "xyzzy_bad_user" doesn't exist}}
|
||||
test exec-10.22 {errors in exec invocation} \
|
||||
-constraints exec \
|
||||
-returnCodes 1 \
|
||||
-body {exec echo test > ~non_existent_user/foo/bar} \
|
||||
-result {user "non_existent_user" doesn't exist}
|
||||
# Commands in background.
|
||||
|
||||
test exec-11.1 {commands in background} {exec} {
|
||||
set x [lindex [time {exec [interpreter] $path(sleep) 2 &}] 0]
|
||||
expr $x<1000000
|
||||
} 1
|
||||
test exec-11.2 {commands in background} {exec} {
|
||||
list [catch {exec [interpreter] $path(echo) a &b} msg] $msg
|
||||
} {0 {a &b}}
|
||||
test exec-11.3 {commands in background} {exec} {
|
||||
llength [exec [interpreter] $path(sleep) 1 &]
|
||||
} 1
|
||||
test exec-11.4 {commands in background} {exec stdio} {
|
||||
llength [exec [interpreter] $path(sleep) 1 | [interpreter] $path(sleep) 1 | [interpreter] $path(sleep) 1 &]
|
||||
} 3
|
||||
test exec-11.5 {commands in background} {exec} {
|
||||
set f [open $path(gorp.file) w]
|
||||
puts $f [list catch [list exec [info nameofexecutable] $path(echo) foo &]]
|
||||
close $f
|
||||
string compare "foo" [exec [interpreter] $path(gorp.file)]
|
||||
} 0
|
||||
|
||||
# Make sure that background commands are properly reaped when
|
||||
# they eventually die.
|
||||
|
||||
if {[testConstraint exec]} {
|
||||
exec [interpreter] $path(sleep) 3
|
||||
}
|
||||
test exec-12.1 {reaping background processes} \
|
||||
{exec unix nonPortable} {
|
||||
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 unix nonPortable} {
|
||||
exec sleep 2 | sleep 2 | sleep 2 &
|
||||
catch {exec ps | fgrep -i "sleep" | fgrep -i -v fgrep | wc} msg
|
||||
set x [lindex $msg 0]
|
||||
exec sleep 3
|
||||
catch {exec ps | fgrep -i "sleep" | fgrep -i -v fgrep | wc} msg
|
||||
list $x [lindex $msg 0]
|
||||
} {3 0}
|
||||
test exec-12.3 {reaping background processes} \
|
||||
{exec unix nonPortable} {
|
||||
exec sleep 1000 &
|
||||
exec sleep 1000 &
|
||||
set x [exec ps | fgrep "sleep" | 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" | fgrep -v fgrep | wc} msg
|
||||
set x [lindex $msg 0]
|
||||
|
||||
foreach i $pids {
|
||||
catch {exec kill -KILL $i}
|
||||
}
|
||||
catch {exec ps | fgrep "sleep" | 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} {exec} {
|
||||
list [catch {exec [interpreter] $path(cat) < a/b/c} msg] [string tolower $errorCode]
|
||||
} {1 {posix enoent {no such file or directory}}}
|
||||
test exec-13.2 {setting errorCode variable} {exec} {
|
||||
list [catch {exec [interpreter] $path(cat) > a/b/c} msg] [string tolower $errorCode]
|
||||
} {1 {posix enoent {no such file or directory}}}
|
||||
test exec-13.3 {setting errorCode variable} {exec} {
|
||||
set x [catch {exec _weird_cmd_} msg]
|
||||
list $x [string tolower $msg] [lindex $errorCode 0] \
|
||||
[string tolower [lrange $errorCode 2 end]]
|
||||
} {1 {couldn't execute "_weird_cmd_": no such file or directory} POSIX {{no such file or directory}}}
|
||||
|
||||
test exec-13.4 {extended exit result codes} {
|
||||
-constraints {win}
|
||||
-setup {
|
||||
set tmp [makeFile {exit 0x00000101} tmpfile.exec-13.4]
|
||||
}
|
||||
-body {
|
||||
list [catch {exec [interpreter] $tmp} err]\
|
||||
[lreplace $::errorCode 1 1 {}]
|
||||
}
|
||||
-cleanup {
|
||||
removeFile $tmp
|
||||
}
|
||||
-result {1 {CHILDSTATUS {} 257}}
|
||||
}
|
||||
|
||||
test exec-13.5 {extended exit result codes: max value} {
|
||||
-constraints {win}
|
||||
-setup {
|
||||
set tmp [makeFile {exit 0x3fffffff} tmpfile.exec-13.5]
|
||||
}
|
||||
-body {
|
||||
list [catch {exec [interpreter] $tmp} err]\
|
||||
[lreplace $::errorCode 1 1 {}]
|
||||
}
|
||||
-cleanup {
|
||||
removeFile $tmp
|
||||
}
|
||||
-result {1 {CHILDSTATUS {} 1073741823}}
|
||||
}
|
||||
|
||||
test exec-13.6 {extended exit result codes: signalled} {
|
||||
-constraints {win}
|
||||
-setup {
|
||||
set tmp [makeFile {exit 0xC0000016} tmpfile.exec-13.6]
|
||||
}
|
||||
-body {
|
||||
list [catch {exec [interpreter] $tmp} err]\
|
||||
[lreplace $::errorCode 1 1 {}]
|
||||
}
|
||||
-cleanup {
|
||||
removeFile $tmp
|
||||
}
|
||||
-result {1 {CHILDKILLED {} SIGABRT SIGABRT}}
|
||||
}
|
||||
|
||||
# Switches before the first argument
|
||||
|
||||
test exec-14.1 {-keepnewline switch} {exec} {
|
||||
exec -keepnewline [interpreter] $path(echo) foo
|
||||
} "foo\n"
|
||||
test exec-14.2 {-keepnewline switch} {exec} {
|
||||
list [catch {exec -keepnewline} msg] $msg
|
||||
} {1 {wrong # args: should be "exec ?switches? arg ?arg ...?"}}
|
||||
test exec-14.3 {unknown switch} {exec} {
|
||||
list [catch {exec -gorp} msg] $msg
|
||||
} {1 {bad switch "-gorp": must be -ignorestderr, -keepnewline, or --}}
|
||||
test exec-14.4 {-- switch} {exec} {
|
||||
list [catch {exec -- -gorp} msg] [string tolower $msg]
|
||||
} {1 {couldn't execute "-gorp": no such file or directory}}
|
||||
test exec-14.5 {-ignorestderr switch} {exec} {
|
||||
# Alas, the use of -ignorestderr is buried here :-(
|
||||
exec [interpreter] $path(sh2) -c [list $path(echo2) foo bar] 2>@1
|
||||
} "foo bar\nbar"
|
||||
|
||||
# Redirecting standard error separately from standard output
|
||||
|
||||
test exec-15.1 {standard error redirection} {exec} {
|
||||
exec [interpreter] "$path(echo)" "First line" > "$path(gorp.file)"
|
||||
list [exec [interpreter] "$path(sh)" -c "\"$path(echo)\" foo bar 1>&2" 2> "$path(gorp.file)"] \
|
||||
[exec [interpreter] "$path(cat)" "$path(gorp.file)"]
|
||||
} {{} {foo bar}}
|
||||
test exec-15.2 {standard error redirection} {exec stdio} {
|
||||
list [exec [interpreter] "$path(sh)" -c "\"$path(echo)\" foo bar 1>&2" \
|
||||
| [interpreter] "$path(echo)" biz baz >$path(gorp.file) 2> "$path(gorp.file2)"] \
|
||||
[exec [interpreter] "$path(cat)" "$path(gorp.file)"] \
|
||||
[exec [interpreter] "$path(cat)" "$path(gorp.file2)"]
|
||||
} {{} {biz baz} {foo bar}}
|
||||
test exec-15.3 {standard error redirection} {exec stdio} {
|
||||
list [exec [interpreter] "$path(sh)" -c "\"$path(echo)\" foo bar 1>&2" \
|
||||
| [interpreter] "$path(echo)" biz baz 2>$path(gorp.file) > "$path(gorp.file2)"] \
|
||||
[exec [interpreter] "$path(cat)" "$path(gorp.file)"] \
|
||||
[exec [interpreter] "$path(cat)" "$path(gorp.file2)"]
|
||||
} {{} {foo bar} {biz baz}}
|
||||
test exec-15.4 {standard error redirection} {exec} {
|
||||
set f [open "$path(gorp.file)" w]
|
||||
puts $f "Line 1"
|
||||
flush $f
|
||||
exec [interpreter] "$path(sh)" -c "\"$path(echo)\" foo bar 1>&2" 2>@ $f
|
||||
puts $f "Line 3"
|
||||
close $f
|
||||
exec [interpreter] "$path(cat)" "$path(gorp.file)"
|
||||
} {Line 1
|
||||
foo bar
|
||||
Line 3}
|
||||
test exec-15.5 {standard error redirection} {exec} {
|
||||
exec [interpreter] "$path(echo)" "First line" > "$path(gorp.file)"
|
||||
exec [interpreter] "$path(sh)" -c "\"$path(echo)\" foo bar 1>&2" 2>> "$path(gorp.file)"
|
||||
exec [interpreter] "$path(cat)" "$path(gorp.file)"
|
||||
} {First line
|
||||
foo bar}
|
||||
test exec-15.6 {standard error redirection} {exec stdio} {
|
||||
exec [interpreter] "$path(sh)" -c "\"$path(echo)\" foo bar 1>&2" > "$path(gorp.file2)" 2> "$path(gorp.file)" \
|
||||
>& "$path(gorp.file)" 2> "$path(gorp.file2)" | [interpreter] "$path(echo)" biz baz
|
||||
list [exec [interpreter] "$path(cat)" "$path(gorp.file)"] [exec [interpreter] "$path(cat)" "$path(gorp.file2)"]
|
||||
} {{biz baz} {foo bar}}
|
||||
test exec-15.7 {standard error redirection 2>@1} {exec stdio} {
|
||||
# This redirects stderr output into normal result output from exec
|
||||
exec [interpreter] "$path(sh)" -c "\"$path(echo)\" foo bar 1>&2" 2>@1
|
||||
} {foo bar}
|
||||
|
||||
test exec-16.1 {flush output before exec} {exec} {
|
||||
set f [open $path(gorp.file) w]
|
||||
puts $f "First line"
|
||||
exec [interpreter] $path(echo) "Second line" >@ $f
|
||||
puts $f "Third line"
|
||||
close $f
|
||||
exec [interpreter] $path(cat) $path(gorp.file)
|
||||
} {First line
|
||||
Second line
|
||||
Third line}
|
||||
test exec-16.2 {flush output before exec} {exec} {
|
||||
set f [open $path(gorp.file) w]
|
||||
puts $f "First line"
|
||||
exec [interpreter] << {puts stderr {Second line}} >&@ $f > $path(gorp.file2)
|
||||
puts $f "Third line"
|
||||
close $f
|
||||
exec [interpreter] $path(cat) $path(gorp.file)
|
||||
} {First line
|
||||
Second line
|
||||
Third line}
|
||||
|
||||
set path(script) [makeFile {} script]
|
||||
|
||||
test exec-17.1 { inheriting standard I/O } {exec} {
|
||||
set f [open $path(script) w]
|
||||
puts -nonewline $f {close stdout
|
||||
set f [}
|
||||
puts $f [list open $path(gorp.file) w]]
|
||||
puts $f [list catch \
|
||||
[list exec [info nameofexecutable] $path(echo) foobar &]]
|
||||
puts $f [list exec [info nameofexecutable] $path(sleep) 2]
|
||||
puts $f {close $f}
|
||||
close $f
|
||||
catch {exec [interpreter] $path(script)} result
|
||||
set f [open $path(gorp.file) r]
|
||||
lappend result [read $f]
|
||||
close $f
|
||||
set result
|
||||
} {{foobar
|
||||
}}
|
||||
|
||||
test exec-18.1 { exec cat deals with weird file names} {exec tempNotWin} {
|
||||
# This is cross-platform, but the cat isn't predictably correct on
|
||||
# Windows.
|
||||
set f "foo\[\{blah"
|
||||
set path(fooblah) [makeFile {} $f]
|
||||
set fout [open $path(fooblah) w]
|
||||
puts $fout "contents"
|
||||
close $fout
|
||||
set res [list [catch {exec cat $path(fooblah)} msg] $msg]
|
||||
removeFile $f
|
||||
set res
|
||||
} {0 contents}
|
||||
|
||||
# Note that this test cannot be adapted to work on Windows; that platform has
|
||||
# no kernel support for an analog of O_APPEND.
|
||||
test exec-19.1 {exec >> uses O_APPEND} {
|
||||
-constraints {exec unix}
|
||||
-setup {
|
||||
set tmpfile [makeFile {0} tmpfile.exec-19.1]
|
||||
}
|
||||
-body {
|
||||
# Note that we have to allow for the current contents of the
|
||||
# temporary file, which is why the result is 14 and not 12
|
||||
exec /bin/sh -c \
|
||||
{for a in 1 2 3; do sleep 1; echo $a; done} >>$tmpfile &
|
||||
exec /bin/sh -c \
|
||||
{for a in a b c; do sleep 1; echo $a; done} >>$tmpfile &
|
||||
# The above two shell invokations take about 3 seconds to
|
||||
# finish, so allow 5s (in case the machine is busy)
|
||||
after 5000
|
||||
# Check that no bytes have got lost through mixups with
|
||||
# overlapping appends, which is only guaranteed to work when
|
||||
# we set O_APPEND on the file descriptor in the [exec >>...]
|
||||
file size $tmpfile
|
||||
}
|
||||
-cleanup {
|
||||
removeFile $tmpfile
|
||||
}
|
||||
-result 14
|
||||
}
|
||||
|
||||
# cleanup
|
||||
|
||||
foreach file {script gorp.file gorp.file2 echo echo2 cat wc sh sh2 sleep exit err} {
|
||||
removeFile $file
|
||||
}
|
||||
unset -nocomplain path
|
||||
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
1003
tests/execute.test
Normal file
1003
tests/execute.test
Normal file
File diff suppressed because it is too large
Load Diff
1205
tests/expr-old.test
Normal file
1205
tests/expr-old.test
Normal file
File diff suppressed because it is too large
Load Diff
7179
tests/expr.test
Normal file
7179
tests/expr.test
Normal file
File diff suppressed because it is too large
Load Diff
2580
tests/fCmd.test
Normal file
2580
tests/fCmd.test
Normal file
File diff suppressed because it is too large
Load Diff
1708
tests/fileName.test
Normal file
1708
tests/fileName.test
Normal file
File diff suppressed because it is too large
Load Diff
1118
tests/fileSystem.test
Normal file
1118
tests/fileSystem.test
Normal file
File diff suppressed because it is too large
Load Diff
71
tests/for-old.test
Normal file
71
tests/for-old.test
Normal file
@@ -0,0 +1,71 @@
|
||||
# Commands covered: for, continue, break
|
||||
#
|
||||
# This file contains the original set of tests for Tcl's for command.
|
||||
# Since the for command is now compiled, a new set of tests covering
|
||||
# the new implementation is in the file "for.test". Sourcing this file
|
||||
# into Tcl runs the tests and generates output for errors.
|
||||
# No output means no errors were found.
|
||||
#
|
||||
# Copyright (c) 1991-1993 The Regents of the University of California.
|
||||
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
# Check "for" and its use of continue and break.
|
||||
|
||||
catch {unset a i}
|
||||
test for-old-1.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-old-1.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-old-1.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-old-1.4 {for tests} {catch {for 1 2 3} msg} 1
|
||||
test for-old-1.5 {for tests} {
|
||||
catch {for 1 2 3} msg
|
||||
set msg
|
||||
} {wrong # args: should be "for start test next command"}
|
||||
test for-old-1.6 {for tests} {catch {for 1 2 3 4 5} msg} 1
|
||||
test for-old-1.7 {for tests} {
|
||||
catch {for 1 2 3 4 5} msg
|
||||
set msg
|
||||
} {wrong # args: should be "for start test next command"}
|
||||
test for-old-1.8 {for tests} {
|
||||
set a {xyz}
|
||||
for {set i 1} {$i<6} {set i [expr $i+1]} {}
|
||||
set a
|
||||
} xyz
|
||||
test for-old-1.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}
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
817
tests/for.test
Normal file
817
tests/for.test
Normal file
@@ -0,0 +1,817 @@
|
||||
# Commands covered: 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) 1996 Sun Microsystems, Inc.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest 2
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
# Basic "for" operation.
|
||||
|
||||
test for-1.1 {TclCompileForCmd: missing initial command} {
|
||||
list [catch {for} msg] $msg
|
||||
} {1 {wrong # args: should be "for start test next command"}}
|
||||
test for-1.2 {TclCompileForCmd: error in initial command} -body {
|
||||
list [catch {for {set}} msg] $msg $::errorInfo
|
||||
} -match glob -result {1 {wrong # args: should be "for start test next command"} {wrong # args: should be "for start test next command"
|
||||
while *ing
|
||||
"for {set}"}}
|
||||
catch {unset i}
|
||||
test for-1.3 {TclCompileForCmd: missing test expression} {
|
||||
catch {for {set i 0}} msg
|
||||
set msg
|
||||
} {wrong # args: should be "for start test next command"}
|
||||
test for-1.4 {TclCompileForCmd: error in test expression} -body {
|
||||
catch {for {set i 0} {$i<}} msg
|
||||
set ::errorInfo
|
||||
} -match glob -result {wrong # args: should be "for start test next command"
|
||||
while *ing
|
||||
"for {set i 0} {$i<}"}
|
||||
test for-1.5 {TclCompileForCmd: test expression is enclosed in quotes} {
|
||||
set i 0
|
||||
for {} "$i > 5" {incr i} {}
|
||||
} {}
|
||||
test for-1.6 {TclCompileForCmd: missing "next" command} {
|
||||
catch {for {set i 0} {$i < 5}} msg
|
||||
set msg
|
||||
} {wrong # args: should be "for start test next command"}
|
||||
test for-1.7 {TclCompileForCmd: missing command body} {
|
||||
catch {for {set i 0} {$i < 5} {incr i}} msg
|
||||
set msg
|
||||
} {wrong # args: should be "for start test next command"}
|
||||
test for-1.8 {TclCompileForCmd: error compiling command body} -body {
|
||||
catch {for {set i 0} {$i < 5} {incr i} {set}} msg
|
||||
set ::errorInfo
|
||||
} -match glob -result {wrong # args: should be "set varName ?newValue?"
|
||||
while *ing
|
||||
"set"*}
|
||||
catch {unset a}
|
||||
test for-1.9 {TclCompileForCmd: simple command body} {
|
||||
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-1.10 {TclCompileForCmd: command body in quotes} {
|
||||
set a {}
|
||||
for {set i 1} {$i<6} {set i [expr $i+1]} "append a x"
|
||||
set a
|
||||
} {xxxxx}
|
||||
test for-1.11 {TclCompileForCmd: computed command body} {
|
||||
catch {unset x1}
|
||||
catch {unset bb}
|
||||
catch {unset x2}
|
||||
set x1 {append a x1; }
|
||||
set bb {break}
|
||||
set x2 {; append a x2}
|
||||
set a {}
|
||||
for {set i 1} {$i<6} {set i [expr $i+1]} $x1$bb$x2
|
||||
set a
|
||||
} {x1}
|
||||
test for-1.12 {TclCompileForCmd: error in "next" command} -body {
|
||||
catch {for {set i 0} {$i < 5} {set} {format $i}} msg
|
||||
set ::errorInfo
|
||||
} -match glob -result {wrong # args: should be "set varName ?newValue?"
|
||||
while *ing
|
||||
"set"*}
|
||||
test for-1.13 {TclCompileForCmd: long command body} {
|
||||
set a {}
|
||||
for {set i 1} {$i<6} {set i [expr $i+1]} {
|
||||
if $i==4 break
|
||||
if $i>5 continue
|
||||
if {$i>6 && $tcl_platform(machine)=="xxx"} {
|
||||
catch {set a $a} msg
|
||||
catch {incr i 5} msg
|
||||
catch {incr i -5} msg
|
||||
}
|
||||
if {$i>6 && $tcl_platform(machine)=="xxx"} {
|
||||
catch {set a $a} msg
|
||||
catch {incr i 5} msg
|
||||
catch {incr i -5} msg
|
||||
}
|
||||
if {$i>6 && $tcl_platform(machine)=="xxx"} {
|
||||
catch {set a $a} msg
|
||||
catch {incr i 5} msg
|
||||
catch {incr i -5} msg
|
||||
}
|
||||
if {$i>6 && $tcl_platform(machine)=="xxx"} {
|
||||
catch {set a $a} msg
|
||||
catch {incr i 5} msg
|
||||
catch {incr i -5} msg
|
||||
}
|
||||
if {$i>6 && $tcl_platform(machine)=="xxx"} {
|
||||
catch {set a $a} msg
|
||||
catch {incr i 5} msg
|
||||
catch {incr i -5} msg
|
||||
}
|
||||
set a [concat $a $i]
|
||||
}
|
||||
set a
|
||||
} {1 2 3}
|
||||
test for-1.14 {TclCompileForCmd: for command result} {
|
||||
set a [for {set i 0} {$i < 5} {incr i} {}]
|
||||
set a
|
||||
} {}
|
||||
test for-1.15 {TclCompileForCmd: for command result} {
|
||||
set a [for {set i 0} {$i < 5} {incr i} {if $i==3 break}]
|
||||
set a
|
||||
} {}
|
||||
|
||||
# Check "for" and "continue".
|
||||
|
||||
test for-2.1 {TclCompileContinueCmd: arguments after "continue"} {
|
||||
catch {continue foo} msg
|
||||
set msg
|
||||
} {wrong # args: should be "continue"}
|
||||
test for-2.2 {TclCompileContinueCmd: continue result} {
|
||||
catch continue
|
||||
} 4
|
||||
test for-2.3 {continue tests} {
|
||||
set a {}
|
||||
for {set i 1} {$i <= 4} {set i [expr $i+1]} {
|
||||
if {$i == 2} continue
|
||||
set a [concat $a $i]
|
||||
}
|
||||
set a
|
||||
} {1 3 4}
|
||||
test for-2.4 {continue tests} {
|
||||
set a {}
|
||||
for {set i 1} {$i <= 4} {set i [expr $i+1]} {
|
||||
if {$i != 2} continue
|
||||
set a [concat $a $i]
|
||||
}
|
||||
set a
|
||||
} {2}
|
||||
test for-2.5 {continue tests, nested loops} {
|
||||
set msg {}
|
||||
for {set i 1} {$i <= 4} {incr i} {
|
||||
for {set a 1} {$a <= 2} {incr a} {
|
||||
if {$i>=2 && $a>=2} continue
|
||||
set msg [concat $msg "$i.$a"]
|
||||
}
|
||||
}
|
||||
set msg
|
||||
} {1.1 1.2 2.1 3.1 4.1}
|
||||
test for-2.6 {continue tests, long command body} {
|
||||
set a {}
|
||||
for {set i 1} {$i<6} {set i [expr $i+1]} {
|
||||
if $i==2 continue
|
||||
if $i==4 break
|
||||
if $i>5 continue
|
||||
if {$i>6 && $tcl_platform(machine)=="xxx"} {
|
||||
catch {set a $a} msg
|
||||
catch {incr i 5} msg
|
||||
catch {incr i -5} msg
|
||||
}
|
||||
if {$i>6 && $tcl_platform(machine)=="xxx"} {
|
||||
catch {set a $a} msg
|
||||
catch {incr i 5} msg
|
||||
catch {incr i -5} msg
|
||||
}
|
||||
if {$i>6 && $tcl_platform(machine)=="xxx"} {
|
||||
catch {set a $a} msg
|
||||
catch {incr i 5} msg
|
||||
catch {incr i -5} msg
|
||||
}
|
||||
if {$i>6 && $tcl_platform(machine)=="xxx"} {
|
||||
catch {set a $a} msg
|
||||
catch {incr i 5} msg
|
||||
catch {incr i -5} msg
|
||||
}
|
||||
if {$i>6 && $tcl_platform(machine)=="xxx"} {
|
||||
catch {set a $a} msg
|
||||
catch {incr i 5} msg
|
||||
catch {incr i -5} msg
|
||||
}
|
||||
set a [concat $a $i]
|
||||
}
|
||||
set a
|
||||
} {1 3}
|
||||
|
||||
# Check "for" and "break".
|
||||
|
||||
test for-3.1 {TclCompileBreakCmd: arguments after "break"} {
|
||||
catch {break foo} msg
|
||||
set msg
|
||||
} {wrong # args: should be "break"}
|
||||
test for-3.2 {TclCompileBreakCmd: break result} {
|
||||
catch break
|
||||
} 3
|
||||
test for-3.3 {break tests} {
|
||||
set a {}
|
||||
for {set i 1} {$i <= 4} {incr i} {
|
||||
if {$i == 3} break
|
||||
set a [concat $a $i]
|
||||
}
|
||||
set a
|
||||
} {1 2}
|
||||
test for-3.4 {break tests, nested loops} {
|
||||
set msg {}
|
||||
for {set i 1} {$i <= 4} {incr i} {
|
||||
for {set a 1} {$a <= 2} {incr a} {
|
||||
if {$i>=2 && $a>=2} break
|
||||
set msg [concat $msg "$i.$a"]
|
||||
}
|
||||
}
|
||||
set msg
|
||||
} {1.1 1.2 2.1 3.1 4.1}
|
||||
test for-3.5 {break tests, long command body} {
|
||||
set a {}
|
||||
for {set i 1} {$i<6} {set i [expr $i+1]} {
|
||||
if $i==2 continue
|
||||
if $i==5 break
|
||||
if $i>5 continue
|
||||
if {$i>6 && $tcl_platform(machine)=="xxx"} {
|
||||
catch {set a $a} msg
|
||||
catch {incr i 5} msg
|
||||
catch {incr i -5} msg
|
||||
}
|
||||
if {$i>6 && $tcl_platform(machine)=="xxx"} {
|
||||
catch {set a $a} msg
|
||||
catch {incr i 5} msg
|
||||
catch {incr i -5} msg
|
||||
}
|
||||
if {$i>6 && $tcl_platform(machine)=="xxx"} {
|
||||
catch {set a $a} msg
|
||||
catch {incr i 5} msg
|
||||
catch {incr i -5} msg
|
||||
}
|
||||
if $i==4 break
|
||||
if {$i>6 && $tcl_platform(machine)=="xxx"} {
|
||||
catch {set a $a} msg
|
||||
catch {incr i 5} msg
|
||||
catch {incr i -5} msg
|
||||
}
|
||||
if {$i>6 && $tcl_platform(machine)=="xxx"} {
|
||||
catch {set a $a} msg
|
||||
catch {incr i 5} msg
|
||||
catch {incr i -5} msg
|
||||
}
|
||||
set a [concat $a $i]
|
||||
}
|
||||
set a
|
||||
} {1 3}
|
||||
# A simplified version of exmh's mail formatting routine to stress "for",
|
||||
# "break", "while", and "if".
|
||||
proc formatMail {} {
|
||||
array set lines {
|
||||
0 {Return-path: george@tcl} \
|
||||
1 {Return-path: <george@tcl>} \
|
||||
2 {Received: from tcl by tcl.Somewhere.COM (SMI-8.6/SMI-SVR4)} \
|
||||
3 { id LAA10027; Wed, 11 Sep 1996 11:14:53 -0700} \
|
||||
4 {Message-id: <199609111814.LAA10027@tcl.Somewhere.COM>} \
|
||||
5 {X-mailer: exmh version 1.6.9 8/22/96} \
|
||||
6 {Mime-version: 1.0} \
|
||||
7 {Content-type: text/plain; charset=iso-8859-1} \
|
||||
8 {Content-transfer-encoding: quoted-printable} \
|
||||
9 {Content-length: 2162} \
|
||||
10 {To: fred} \
|
||||
11 {Subject: tcl7.6} \
|
||||
12 {Date: Wed, 11 Sep 1996 11:14:53 -0700} \
|
||||
13 {From: George <george@tcl>} \
|
||||
14 {The Tcl 7.6 and Tk 4.2 releases} \
|
||||
15 {} \
|
||||
16 {This page contains information about Tcl 7.6 and Tk4.2, which are the most recent} \
|
||||
17 {releases of the Tcl scripting language and the Tk toolkit. The first beta versions of these} \
|
||||
18 {releases were released on August 30, 1996. These releases contain only minor changes,} \
|
||||
19 {so we hope to have only a single beta release and to go final in early October, 1996. } \
|
||||
20 {} \
|
||||
21 {} \
|
||||
22 {What's new } \
|
||||
23 {} \
|
||||
24 {The most important changes in the releases are summarized below. See the README} \
|
||||
25 {and changes files in the distributions for more complete information on what has} \
|
||||
26 {changed, including both feature changes and bug fixes. } \
|
||||
27 {} \
|
||||
28 { There are new options to the file command for copying files (file copy),} \
|
||||
29 { deleting files and directories (file delete), creating directories (file} \
|
||||
30 { mkdir), and renaming files (file rename). } \
|
||||
31 { The implementation of exec has been improved greatly for Windows 95 and} \
|
||||
32 { Windows NT. } \
|
||||
33 { There is a new memory allocator for the Macintosh version, which should be} \
|
||||
34 { more efficient than the old one. } \
|
||||
35 { Tk's grid geometry manager has been completely rewritten. The layout} \
|
||||
36 { algorithm produces much better layouts than before, especially where rows or} \
|
||||
37 { columns were stretchable. } \
|
||||
38 { There are new commands for creating common dialog boxes:} \
|
||||
39 { tk_chooseColor, tk_getOpenFile, tk_getSaveFile and} \
|
||||
40 { tk_messageBox. These use native dialog boxes if they are available. } \
|
||||
41 { There is a new virtual event mechanism for handling events in a more portable} \
|
||||
42 { way. See the new command event. It also allows events (both physical and} \
|
||||
43 { virtual) to be generated dynamically. } \
|
||||
44 {} \
|
||||
45 {Tcl 7.6 and Tk 4.2 are backwards-compatible with Tcl 7.5 and Tk 4.1 except for} \
|
||||
46 {changes in the C APIs for custom channel drivers. Scripts written for earlier releases} \
|
||||
47 {should work on these new releases as well. } \
|
||||
48 {} \
|
||||
49 {Obtaining The Releases} \
|
||||
50 {} \
|
||||
51 {Binary Releases} \
|
||||
52 {} \
|
||||
53 {Pre-compiled releases are available for the following platforms: } \
|
||||
54 {} \
|
||||
55 { Windows 3.1, Windows 95, and Windows NT: Fetch} \
|
||||
56 { ftp://ftp.sunlabs.com/pub/tcl/win42b1.exe, then execute it. The file is a} \
|
||||
57 { self-extracting executable. It will install the Tcl and Tk libraries, the wish and} \
|
||||
58 { tclsh programs, and documentation. } \
|
||||
59 { Macintosh (both 68K and PowerPC): Fetch} \
|
||||
60 { ftp://ftp.sunlabs.com/pub/tcl/mactk4.2b1.sea.hqx. The file is in binhex format,} \
|
||||
61 { which is understood by Fetch, StuffIt, and many other Mac utilities. The} \
|
||||
62 { unpacked file is a self-installing executable: double-click on it and it will create a} \
|
||||
63 { folder containing all that you need to run Tcl and Tk. } \
|
||||
64 { UNIX (Solaris 2.* and SunOS, other systems soon to follow). Easy to install} \
|
||||
65 { binary packages are now for sale at the Sun Labs Tcl/Tk Shop. Check it out!} \
|
||||
}
|
||||
|
||||
set result ""
|
||||
set NL "
|
||||
"
|
||||
set tag {level= type=text/plain part=0 sel Charset}
|
||||
set ix [lsearch -regexp $tag text/enriched]
|
||||
if {$ix < 0} {
|
||||
set ranges {}
|
||||
set quote 0
|
||||
}
|
||||
set breakrange {6.42 78.0}
|
||||
set F1 [lindex $breakrange 0]
|
||||
set F2 [lindex $breakrange 1]
|
||||
set breakrange [lrange $breakrange 2 end]
|
||||
if {[string length $F1] == 0} {
|
||||
set F1 -1
|
||||
set break 0
|
||||
} else {
|
||||
set break 1
|
||||
}
|
||||
|
||||
set xmailer 0
|
||||
set inheaders 1
|
||||
set last [array size lines]
|
||||
set plen 2
|
||||
for {set L 1} {$L < $last} {incr L} {
|
||||
set line $lines($L)
|
||||
if {$inheaders} {
|
||||
# Blank or empty line terminates headers
|
||||
# Leading --- terminates headers
|
||||
if {[regexp {^[ ]*$} $line] || [regexp {^--+} $line]} {
|
||||
set inheaders 0
|
||||
}
|
||||
if {[regexp -nocase {^x-mailer:} $line]} {
|
||||
continue
|
||||
}
|
||||
}
|
||||
if $inheaders {
|
||||
set limit 55
|
||||
} else {
|
||||
set limit 55
|
||||
|
||||
# Decide whether or not to break the body line
|
||||
|
||||
if {$plen > 0} {
|
||||
if {[string first {> } $line] == 0} {
|
||||
# This is quoted text from previous message, don't reformat
|
||||
append result $line $NL
|
||||
if {$quote && !$inheaders} {
|
||||
# Fix from <sarr@umich.edu> to handle text/enriched
|
||||
if {$L > $L1 && $L < $L2 && $line != {}} {
|
||||
# enriched requires two newlines for each one.
|
||||
append result $NL
|
||||
} elseif {$L > $L2} {
|
||||
set L1 [lindex $ranges 0]
|
||||
set L2 [lindex $ranges 1]
|
||||
set ranges [lrange $ranges 2 end]
|
||||
set quote [llength $L1]
|
||||
}
|
||||
}
|
||||
continue
|
||||
}
|
||||
}
|
||||
if {$F1 < 0} {
|
||||
# Nothing left to format
|
||||
append result $line $NL
|
||||
continue
|
||||
} elseif {$L < $F1} {
|
||||
# Not yet to formatted block
|
||||
append result $line $NL
|
||||
continue
|
||||
} elseif {$L > $F2} {
|
||||
# Past formatted block
|
||||
set F1 [lindex $breakrange 0]
|
||||
set F2 [lindex $breakrange 1]
|
||||
set breakrange [lrange $breakrange 2 end]
|
||||
append result $line $NL
|
||||
if {[string length $F1] == 0} {
|
||||
set F1 -1
|
||||
}
|
||||
continue
|
||||
}
|
||||
}
|
||||
set climit [expr $limit-1]
|
||||
set cutoff 50
|
||||
set continuation 0
|
||||
|
||||
while {[string length $line] > $limit} {
|
||||
for {set c [expr $limit-1]} {$c >= $cutoff} {incr c -1} {
|
||||
set char [string index $line $c]
|
||||
if {$char == " " || $char == "\t"} {
|
||||
break
|
||||
}
|
||||
if {$char == ">"} { ;# Hack for enriched formatting
|
||||
break
|
||||
}
|
||||
}
|
||||
if {$c < $cutoff} {
|
||||
if {! $inheaders} {
|
||||
set c [expr $limit-1]
|
||||
} else {
|
||||
set c [string length $line]
|
||||
}
|
||||
}
|
||||
set newline [string range $line 0 $c]
|
||||
if {! $continuation} {
|
||||
append result $newline $NL
|
||||
} else {
|
||||
append result \ $newline $NL
|
||||
}
|
||||
incr c
|
||||
set line [string trimright [string range $line $c end]]
|
||||
if {$inheaders} {
|
||||
set continuation 1
|
||||
set limit $climit
|
||||
}
|
||||
}
|
||||
if {$continuation} {
|
||||
if {[string length $line] != 0} {
|
||||
append result \ $line $NL
|
||||
}
|
||||
} else {
|
||||
append result $line $NL
|
||||
if {$quote && !$inheaders} {
|
||||
if {$L > $L1 && $L < $L2 && $line != {}} {
|
||||
# enriched requires two newlines for each one.
|
||||
append result "" $NL
|
||||
} elseif {$L > $L2} {
|
||||
set L1 [lindex $ranges 0]
|
||||
set L2 [lindex $ranges 1]
|
||||
set ranges [lrange $ranges 2 end]
|
||||
set quote [llength $L1]
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
return $result
|
||||
}
|
||||
test for-3.6 {break tests} {
|
||||
formatMail
|
||||
} {Return-path: <george@tcl>
|
||||
Received: from tcl by tcl.Somewhere.COM (SMI-8.6/SMI-SVR4)
|
||||
id LAA10027; Wed, 11 Sep 1996 11:14:53 -0700
|
||||
Message-id: <199609111814.LAA10027@tcl.Somewhere.COM>
|
||||
Mime-version: 1.0
|
||||
Content-type: text/plain; charset=iso-8859-1
|
||||
Content-transfer-encoding: quoted-printable
|
||||
Content-length: 2162
|
||||
To: fred
|
||||
Subject: tcl7.6
|
||||
Date: Wed, 11 Sep 1996 11:14:53 -0700
|
||||
From: George <george@tcl>
|
||||
The Tcl 7.6 and Tk 4.2 releases
|
||||
|
||||
This page contains information about Tcl 7.6 and Tk4.2,
|
||||
which are the most recent
|
||||
releases of the Tcl scripting language and the Tk toolk
|
||||
it. The first beta versions of these
|
||||
releases were released on August 30, 1996. These releas
|
||||
es contain only minor changes,
|
||||
so we hope to have only a single beta release and to
|
||||
go final in early October, 1996.
|
||||
|
||||
|
||||
What's new
|
||||
|
||||
The most important changes in the releases are summariz
|
||||
ed below. See the README
|
||||
and changes files in the distributions for more complet
|
||||
e information on what has
|
||||
changed, including both feature changes and bug fixes.
|
||||
|
||||
There are new options to the file command for
|
||||
copying files (file copy),
|
||||
deleting files and directories (file delete),
|
||||
creating directories (file
|
||||
mkdir), and renaming files (file rename).
|
||||
The implementation of exec has been improved great
|
||||
ly for Windows 95 and
|
||||
Windows NT.
|
||||
There is a new memory allocator for the Macintosh
|
||||
version, which should be
|
||||
more efficient than the old one.
|
||||
Tk's grid geometry manager has been completely
|
||||
rewritten. The layout
|
||||
algorithm produces much better layouts than before
|
||||
, especially where rows or
|
||||
columns were stretchable.
|
||||
There are new commands for creating common dialog
|
||||
boxes:
|
||||
tk_chooseColor, tk_getOpenFile, tk_getSaveFile and
|
||||
tk_messageBox. These use native dialog boxes if
|
||||
they are available.
|
||||
There is a new virtual event mechanism for handlin
|
||||
g events in a more portable
|
||||
way. See the new command event. It also allows
|
||||
events (both physical and
|
||||
virtual) to be generated dynamically.
|
||||
|
||||
Tcl 7.6 and Tk 4.2 are backwards-compatible with Tcl
|
||||
7.5 and Tk 4.1 except for
|
||||
changes in the C APIs for custom channel drivers. Scrip
|
||||
ts written for earlier releases
|
||||
should work on these new releases as well.
|
||||
|
||||
Obtaining The Releases
|
||||
|
||||
Binary Releases
|
||||
|
||||
Pre-compiled releases are available for the following
|
||||
platforms:
|
||||
|
||||
Windows 3.1, Windows 95, and Windows NT: Fetch
|
||||
ftp://ftp.sunlabs.com/pub/tcl/win42b1.exe, then
|
||||
execute it. The file is a
|
||||
self-extracting executable. It will install the
|
||||
Tcl and Tk libraries, the wish and
|
||||
tclsh programs, and documentation.
|
||||
Macintosh (both 68K and PowerPC): Fetch
|
||||
ftp://ftp.sunlabs.com/pub/tcl/mactk4.2b1.sea.hqx.
|
||||
The file is in binhex format,
|
||||
which is understood by Fetch, StuffIt, and many
|
||||
other Mac utilities. The
|
||||
unpacked file is a self-installing executable:
|
||||
double-click on it and it will create a
|
||||
folder containing all that you need to run Tcl
|
||||
and Tk.
|
||||
UNIX (Solaris 2.* and SunOS, other systems
|
||||
soon to follow). Easy to install
|
||||
binary packages are now for sale at the Sun Labs
|
||||
Tcl/Tk Shop. Check it out!
|
||||
}
|
||||
|
||||
# Check that "break" resets the interpreter's result
|
||||
|
||||
test for-4.1 {break must reset the interp result} {
|
||||
catch {
|
||||
set z GLOBTESTDIR/dir2/file2.c
|
||||
if [string match GLOBTESTDIR/dir2/* $z] {
|
||||
break
|
||||
}
|
||||
} j
|
||||
set j
|
||||
} {}
|
||||
|
||||
# Test for incorrect "double evaluation" semantics
|
||||
|
||||
test for-5.1 {possible delayed substitution of increment command} {
|
||||
# Increment should be 5, and lappend should always append $a
|
||||
catch {unset a}
|
||||
catch {unset i}
|
||||
set a 5
|
||||
set i {}
|
||||
for {set a 1} {$a < 12} "incr a $a" {lappend i $a}
|
||||
set i
|
||||
} {1 6 11}
|
||||
|
||||
test for-5.2 {possible delayed substitution of increment command} {
|
||||
# Increment should be 5, and lappend should always append $a
|
||||
catch {rename p ""}
|
||||
proc p {} {
|
||||
set a 5
|
||||
set i {}
|
||||
for {set a 1} {$a < 12} "incr a $a" {lappend i $a}
|
||||
set i
|
||||
}
|
||||
p
|
||||
} {1 6 11}
|
||||
test for-5.3 {possible delayed substitution of body command} {
|
||||
# Increment should be $a, and lappend should always append 5
|
||||
set a 5
|
||||
set i {}
|
||||
for {set a 1} {$a < 12} {incr a $a} "lappend i $a"
|
||||
set i
|
||||
} {5 5 5 5}
|
||||
test for-5.4 {possible delayed substitution of body command} {
|
||||
# Increment should be $a, and lappend should always append 5
|
||||
catch {rename p ""}
|
||||
proc p {} {
|
||||
set a 5
|
||||
set i {}
|
||||
for {set a 1} {$a < 12} {incr a $a} "lappend i $a"
|
||||
set i
|
||||
}
|
||||
p
|
||||
} {5 5 5 5}
|
||||
|
||||
# In the following tests we need to bypass the bytecode compiler by
|
||||
# substituting the command from a variable. This ensures that command
|
||||
# procedure is invoked directly.
|
||||
|
||||
test for-6.1 {Tcl_ForObjCmd: number of args} {
|
||||
set z for
|
||||
catch {$z} msg
|
||||
set msg
|
||||
} {wrong # args: should be "for start test next command"}
|
||||
test for-6.2 {Tcl_ForObjCmd: number of args} {
|
||||
set z for
|
||||
catch {$z {set i 0}} msg
|
||||
set msg
|
||||
} {wrong # args: should be "for start test next command"}
|
||||
test for-6.3 {Tcl_ForObjCmd: number of args} {
|
||||
set z for
|
||||
catch {$z {set i 0} {$i < 5}} msg
|
||||
set msg
|
||||
} {wrong # args: should be "for start test next command"}
|
||||
test for-6.4 {Tcl_ForObjCmd: number of args} {
|
||||
set z for
|
||||
catch {$z {set i 0} {$i < 5} {incr i}} msg
|
||||
set msg
|
||||
} {wrong # args: should be "for start test next command"}
|
||||
test for-6.5 {Tcl_ForObjCmd: number of args} {
|
||||
set z for
|
||||
catch {$z {set i 0} {$i < 5} {incr i} {body} extra} msg
|
||||
set msg
|
||||
} {wrong # args: should be "for start test next command"}
|
||||
test for-6.6 {Tcl_ForObjCmd: error in initial command} -body {
|
||||
set z for
|
||||
list [catch {$z {set} {$i < 5} {incr i} {body}} msg] $msg $::errorInfo
|
||||
} -match glob -result {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?"
|
||||
while *ing
|
||||
"set"
|
||||
("for" initial command)
|
||||
invoked from within
|
||||
"$z {set} {$i < 5} {incr i} {body}"}}
|
||||
test for-6.7 {Tcl_ForObjCmd: error in test expression} -body {
|
||||
set z for
|
||||
catch {$z {set i 0} {i < 5} {incr i} {body}}
|
||||
set ::errorInfo
|
||||
} -match glob -result {*"$z {set i 0} {i < 5} {incr i} {body}"}
|
||||
test for-6.8 {Tcl_ForObjCmd: test expression is enclosed in quotes} {
|
||||
set z for
|
||||
set i 0
|
||||
$z {set i 6} "$i > 5" {incr i} {set y $i}
|
||||
set i
|
||||
} 6
|
||||
test for-6.9 {Tcl_ForObjCmd: error executing command body} -body {
|
||||
set z for
|
||||
catch {$z {set i 0} {$i < 5} {incr i} {set}} msg
|
||||
set ::errorInfo
|
||||
} -match glob -result {wrong # args: should be "set varName ?newValue?"
|
||||
while *ing
|
||||
"set"
|
||||
("for" body line 1)
|
||||
invoked from within
|
||||
"$z {set i 0} {$i < 5} {incr i} {set}"}
|
||||
test for-6.10 {Tcl_ForObjCmd: simple command body} {
|
||||
set z for
|
||||
set a {}
|
||||
$z {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-6.11 {Tcl_ForObjCmd: command body in quotes} {
|
||||
set z for
|
||||
set a {}
|
||||
$z {set i 1} {$i<6} {set i [expr $i+1]} "append a x"
|
||||
set a
|
||||
} {xxxxx}
|
||||
test for-6.12 {Tcl_ForObjCmd: computed command body} {
|
||||
set z for
|
||||
catch {unset x1}
|
||||
catch {unset bb}
|
||||
catch {unset x2}
|
||||
set x1 {append a x1; }
|
||||
set bb {break}
|
||||
set x2 {; append a x2}
|
||||
set a {}
|
||||
$z {set i 1} {$i<6} {set i [expr $i+1]} $x1$bb$x2
|
||||
set a
|
||||
} {x1}
|
||||
test for-6.13 {Tcl_ForObjCmd: error in "next" command} -body {
|
||||
set z for
|
||||
catch {$z {set i 0} {$i < 5} {set} {set j 4}} msg
|
||||
set ::errorInfo
|
||||
} -match glob -result {wrong # args: should be "set varName ?newValue?"
|
||||
while *ing
|
||||
"set"
|
||||
("for" loop-end command)
|
||||
invoked from within
|
||||
"$z {set i 0} {$i < 5} {set} {set j 4}"}
|
||||
test for-6.14 {Tcl_ForObjCmd: long command body} {
|
||||
set z for
|
||||
set a {}
|
||||
$z {set i 1} {$i<6} {set i [expr $i+1]} {
|
||||
if $i==4 break
|
||||
if $i>5 continue
|
||||
if {$i>6 && $tcl_platform(machine)=="xxx"} {
|
||||
catch {set a $a} msg
|
||||
catch {incr i 5} msg
|
||||
catch {incr i -5} msg
|
||||
}
|
||||
if {$i>6 && $tcl_platform(machine)=="xxx"} {
|
||||
catch {set a $a} msg
|
||||
catch {incr i 5} msg
|
||||
catch {incr i -5} msg
|
||||
}
|
||||
if {$i>6 && $tcl_platform(machine)=="xxx"} {
|
||||
catch {set a $a} msg
|
||||
catch {incr i 5} msg
|
||||
catch {incr i -5} msg
|
||||
}
|
||||
if {$i>6 && $tcl_platform(machine)=="xxx"} {
|
||||
catch {set a $a} msg
|
||||
catch {incr i 5} msg
|
||||
catch {incr i -5} msg
|
||||
}
|
||||
if {$i>6 && $tcl_platform(machine)=="xxx"} {
|
||||
catch {set a $a} msg
|
||||
catch {incr i 5} msg
|
||||
catch {incr i -5} msg
|
||||
}
|
||||
set a [concat $a $i]
|
||||
}
|
||||
set a
|
||||
} {1 2 3}
|
||||
test for-6.15 {Tcl_ForObjCmd: for command result} {
|
||||
set z for
|
||||
set a [$z {set i 0} {$i < 5} {incr i} {}]
|
||||
set a
|
||||
} {}
|
||||
test for-6.16 {Tcl_ForObjCmd: for command result} {
|
||||
set z for
|
||||
set a [$z {set i 0} {$i < 5} {incr i} {if $i==3 break}]
|
||||
set a
|
||||
} {}
|
||||
test for-6.17 {Tcl_ForObjCmd: for command result} {
|
||||
list \
|
||||
[catch {for {break} {1} {} {}} err] $err \
|
||||
[catch {for {continue} {1} {} {}} err] $err \
|
||||
[catch {for {} {[break]} {} {}} err] $err \
|
||||
[catch {for {} {[continue]} {} {}} err] $err \
|
||||
[catch {for {} {1} {break} {}} err] $err \
|
||||
[catch {for {} {1} {continue} {}} err] $err \
|
||||
} [list \
|
||||
3 {} \
|
||||
4 {} \
|
||||
3 {} \
|
||||
4 {} \
|
||||
0 {} \
|
||||
4 {} \
|
||||
]
|
||||
test for-6.18 {Tcl_ForObjCmd: for command result} {
|
||||
proc p6181 {} {
|
||||
for {break} {1} {} {}
|
||||
}
|
||||
proc p6182 {} {
|
||||
for {continue} {1} {} {}
|
||||
}
|
||||
proc p6183 {} {
|
||||
for {} {[break]} {} {}
|
||||
}
|
||||
proc p6184 {} {
|
||||
for {} {[continue]} {} {}
|
||||
}
|
||||
proc p6185 {} {
|
||||
for {} {1} {break} {}
|
||||
}
|
||||
proc p6186 {} {
|
||||
for {} {1} {continue} {}
|
||||
}
|
||||
list \
|
||||
[catch {p6181} err] $err \
|
||||
[catch {p6182} err] $err \
|
||||
[catch {p6183} err] $err \
|
||||
[catch {p6184} err] $err \
|
||||
[catch {p6185} err] $err \
|
||||
[catch {p6186} err] $err
|
||||
} [list \
|
||||
1 {invoked "break" outside of a loop} \
|
||||
1 {invoked "continue" outside of a loop} \
|
||||
1 {invoked "break" outside of a loop} \
|
||||
1 {invoked "continue" outside of a loop} \
|
||||
0 {} \
|
||||
1 {invoked "continue" outside of a loop} \
|
||||
]
|
||||
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
273
tests/foreach.test
Normal file
273
tests/foreach.test
Normal file
@@ -0,0 +1,273 @@
|
||||
# Commands covered: foreach, 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.
|
||||
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
catch {unset a}
|
||||
catch {unset x}
|
||||
|
||||
# Basic "foreach" operation.
|
||||
|
||||
test foreach-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 foreach-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 foreach-1.3 {basic foreach tests} {catch {foreach} msg} 1
|
||||
test foreach-1.4 {basic foreach tests} {
|
||||
catch {foreach} msg
|
||||
set msg
|
||||
} {wrong # args: should be "foreach varList list ?varList list ...? command"}
|
||||
test foreach-1.5 {basic foreach tests} {catch {foreach i} msg} 1
|
||||
test foreach-1.6 {basic foreach tests} {
|
||||
catch {foreach i} msg
|
||||
set msg
|
||||
} {wrong # args: should be "foreach varList list ?varList list ...? command"}
|
||||
test foreach-1.7 {basic foreach tests} {catch {foreach i j} msg} 1
|
||||
test foreach-1.8 {basic foreach tests} {
|
||||
catch {foreach i j} msg
|
||||
set msg
|
||||
} {wrong # args: should be "foreach varList list ?varList list ...? command"}
|
||||
test foreach-1.9 {basic foreach tests} {catch {foreach i j k l} msg} 1
|
||||
test foreach-1.10 {basic foreach tests} {
|
||||
catch {foreach i j k l} msg
|
||||
set msg
|
||||
} {wrong # args: should be "foreach varList list ?varList list ...? command"}
|
||||
test foreach-1.11 {basic foreach tests} {
|
||||
set a {}
|
||||
foreach i {} {
|
||||
set a [concat $a $i]
|
||||
}
|
||||
set a
|
||||
} {}
|
||||
test foreach-1.12 {foreach errors} {
|
||||
list [catch {foreach {{a}{b}} {1 2 3} {}} msg] $msg
|
||||
} {1 {list element in braces followed by "{b}" instead of space}}
|
||||
test foreach-1.13 {foreach errors} {
|
||||
list [catch {foreach a {{1 2}3} {}} msg] $msg
|
||||
} {1 {list element in braces followed by "3" instead of space}}
|
||||
catch {unset a}
|
||||
test foreach-1.14 {foreach errors} {
|
||||
catch {unset a}
|
||||
set a(0) 44
|
||||
list [catch {foreach a {1 2 3} {}} msg o] $msg $::errorInfo
|
||||
} {1 {can't set "a": variable is array} {can't set "a": variable is array
|
||||
(setting foreach loop variable "a")
|
||||
invoked from within
|
||||
"foreach a {1 2 3} {}"}}
|
||||
test foreach-1.15 {foreach errors} {
|
||||
list [catch {foreach {} {} {}} msg] $msg
|
||||
} {1 {foreach varlist is empty}}
|
||||
catch {unset a}
|
||||
|
||||
test foreach-2.1 {parallel foreach tests} {
|
||||
set x {}
|
||||
foreach {a b} {1 2 3 4} {
|
||||
append x $b $a
|
||||
}
|
||||
set x
|
||||
} {2143}
|
||||
test foreach-2.2 {parallel foreach tests} {
|
||||
set x {}
|
||||
foreach {a b} {1 2 3 4 5} {
|
||||
append x $b $a
|
||||
}
|
||||
set x
|
||||
} {21435}
|
||||
test foreach-2.3 {parallel foreach tests} {
|
||||
set x {}
|
||||
foreach a {1 2 3} b {4 5 6} {
|
||||
append x $b $a
|
||||
}
|
||||
set x
|
||||
} {415263}
|
||||
test foreach-2.4 {parallel foreach tests} {
|
||||
set x {}
|
||||
foreach a {1 2 3} b {4 5 6 7 8} {
|
||||
append x $b $a
|
||||
}
|
||||
set x
|
||||
} {41526378}
|
||||
test foreach-2.5 {parallel foreach tests} {
|
||||
set x {}
|
||||
foreach {a b} {a b A B aa bb} c {c C cc CC} {
|
||||
append x $a $b $c
|
||||
}
|
||||
set x
|
||||
} {abcABCaabbccCC}
|
||||
test foreach-2.6 {parallel foreach tests} {
|
||||
set x {}
|
||||
foreach a {1 2 3} b {1 2 3} c {1 2 3} d {1 2 3} e {1 2 3} {
|
||||
append x $a $b $c $d $e
|
||||
}
|
||||
set x
|
||||
} {111112222233333}
|
||||
test foreach-2.7 {parallel foreach tests} {
|
||||
set x {}
|
||||
foreach a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} {
|
||||
append x $a $b $c $d $e
|
||||
}
|
||||
set x
|
||||
} {1111 2222334}
|
||||
test foreach-2.8 {foreach only sets vars if repeating loop} {
|
||||
proc foo {} {
|
||||
set rgb {65535 0 0}
|
||||
foreach {r g b} [set rgb] {}
|
||||
return "r=$r, g=$g, b=$b"
|
||||
}
|
||||
foo
|
||||
} {r=65535, g=0, b=0}
|
||||
test foreach-2.9 {foreach only supports local scalar variables} {
|
||||
proc foo {} {
|
||||
set x {}
|
||||
foreach {a(3)} {1 2 3 4} {lappend x [set {a(3)}]}
|
||||
set x
|
||||
}
|
||||
foo
|
||||
} {1 2 3 4}
|
||||
|
||||
test foreach-3.1 {compiled foreach backward jump works correctly} {
|
||||
catch {unset x}
|
||||
proc foo {arrayName} {
|
||||
upvar 1 $arrayName a
|
||||
set l {}
|
||||
foreach member [array names a] {
|
||||
lappend l [list $member [set a($member)]]
|
||||
}
|
||||
return $l
|
||||
}
|
||||
array set x {0 zero 1 one 2 two 3 three}
|
||||
lsort [foo x]
|
||||
} [lsort {{0 zero} {1 one} {2 two} {3 three}}]
|
||||
|
||||
test foreach-4.1 {noncompiled foreach and shared variable or value list objects that are converted to another type} {
|
||||
catch {unset x}
|
||||
foreach {12.0} {a b c} {
|
||||
set x 12.0
|
||||
set x [expr $x + 1]
|
||||
}
|
||||
set x
|
||||
} 13.0
|
||||
|
||||
# Check "continue".
|
||||
|
||||
test foreach-5.1 {continue tests} {catch continue} 4
|
||||
test foreach-5.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 foreach-5.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 foreach-5.4 {continue tests} {catch {continue foo} msg} 1
|
||||
test foreach-5.5 {continue tests} {
|
||||
catch {continue foo} msg
|
||||
set msg
|
||||
} {wrong # args: should be "continue"}
|
||||
|
||||
# Check "break".
|
||||
|
||||
test foreach-6.1 {break tests} {catch break} 3
|
||||
test foreach-6.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 foreach-6.3 {break tests} {catch {break foo} msg} 1
|
||||
test foreach-6.4 {break tests} {
|
||||
catch {break foo} msg
|
||||
set msg
|
||||
} {wrong # args: should be "break"}
|
||||
# Check for bug #406709
|
||||
test foreach-6.5 {break tests} {
|
||||
proc a {} {
|
||||
set a 1
|
||||
foreach b b {list [concat a; break]; incr a}
|
||||
incr a
|
||||
}
|
||||
a
|
||||
} {2}
|
||||
|
||||
# Test for incorrect "double evaluation" semantics
|
||||
test foreach-7.1 {delayed substitution of body} {
|
||||
proc foo {} {
|
||||
set a 0
|
||||
foreach a [list 1 2 3] "
|
||||
set x $a
|
||||
"
|
||||
set x
|
||||
}
|
||||
foo
|
||||
} {0}
|
||||
|
||||
# Test for [Bug 1189274]; crash on failure
|
||||
test foreach-8.1 {empty list handling} {
|
||||
proc crash {} {
|
||||
rename crash {}
|
||||
set a "x y z"
|
||||
set b ""
|
||||
foreach aa $a bb $b { set x "aa = $aa bb = $bb" }
|
||||
}
|
||||
crash
|
||||
} {}
|
||||
|
||||
# [Bug 1671138]; infinite loop with empty var list in bytecompiled version
|
||||
test foreach-9.1 {compiled empty var list} {
|
||||
proc foo {} {
|
||||
foreach {} x {
|
||||
error "reached body"
|
||||
}
|
||||
}
|
||||
list [catch { foo } msg] $msg
|
||||
} {1 {foreach varlist is empty}}
|
||||
|
||||
test foreach-10.1 {foreach: [Bug 1671087]} -setup {
|
||||
proc demo {} {
|
||||
set vals {1 2 3 4}
|
||||
trace add variable x write {string length $vals ;# }
|
||||
foreach {x y} $vals {format $y}
|
||||
}
|
||||
} -body {
|
||||
demo
|
||||
} -cleanup {
|
||||
rename demo {}
|
||||
} -result {}
|
||||
|
||||
# cleanup
|
||||
catch {unset a}
|
||||
catch {unset x}
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
578
tests/format.test
Normal file
578
tests/format.test
Normal file
@@ -0,0 +1,578 @@
|
||||
# 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-1994 The Regents of the University of California.
|
||||
# Copyright (c) 1994-1998 Sun Microsystems, Inc.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest 2
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
# %u output depends on word length, so this test is not portable.
|
||||
testConstraint longIs32bit [expr {int(0x80000000) < 0}]
|
||||
testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}]
|
||||
testConstraint wideIs64bit \
|
||||
[expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}]
|
||||
testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}]
|
||||
|
||||
test format-1.1 {integer formatting} {
|
||||
format "%*d %d %d %d" 6 34 16923 -12 -1
|
||||
} { 34 16923 -12 -1}
|
||||
test format-1.2 {integer formatting} {
|
||||
format "%4d %4d %4d %4d %d %#x %#X" 6 34 16923 -12 -1 14 12
|
||||
} { 6 34 16923 -12 -1 0xe 0XC}
|
||||
test format-1.3 {integer formatting} longIs32bit {
|
||||
format "%4u %4u %4u %4u %d %#o" 6 34 16923 -12 -1 0
|
||||
} { 6 34 16923 4294967284 -1 0}
|
||||
test format-1.3.1 {integer formatting} longIs64bit {
|
||||
format "%4u %4u %4u %4u %d %#o" 6 34 16923 -12 -1 0
|
||||
} { 6 34 16923 18446744073709551604 -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, so these tests are not portable.
|
||||
test format-1.7 {integer formatting} longIs32bit {
|
||||
format "%4x %4x %4x %4x" 6 34 16923 -12 -1
|
||||
} { 6 22 421b fffffff4}
|
||||
test format-1.7.1 {integer formatting} longIs64bit {
|
||||
format "%4x %4x %4x %4x" 6 34 16923 -12 -1
|
||||
} { 6 22 421b fffffffffffffff4}
|
||||
test format-1.8 {integer formatting} longIs32bit {
|
||||
format "%#x %#X %#X %#x" 6 34 16923 -12 -1
|
||||
} {0x6 0X22 0X421B 0xfffffff4}
|
||||
test format-1.8.1 {integer formatting} longIs64bit {
|
||||
format "%#x %#X %#X %#x" 6 34 16923 -12 -1
|
||||
} {0x6 0X22 0X421B 0xfffffffffffffff4}
|
||||
test format-1.9 {integer formatting} longIs32bit {
|
||||
format "%#20x %#20x %#20x %#20x" 6 34 16923 -12 -1
|
||||
} { 0x6 0x22 0x421b 0xfffffff4}
|
||||
test format-1.9.1 {integer formatting} longIs64bit {
|
||||
format "%#20x %#20x %#20x %#20x" 6 34 16923 -12 -1
|
||||
} { 0x6 0x22 0x421b 0xfffffffffffffff4}
|
||||
test format-1.10 {integer formatting} longIs32bit {
|
||||
format "%-#20x %-#20x %-#20x %-#20x" 6 34 16923 -12 -1
|
||||
} {0x6 0x22 0x421b 0xfffffff4 }
|
||||
test format-1.10.1 {integer formatting} longIs64bit {
|
||||
format "%-#20x %-#20x %-#20x %-#20x" 6 34 16923 -12 -1
|
||||
} {0x6 0x22 0x421b 0xfffffffffffffff4 }
|
||||
test format-1.11 {integer formatting} longIs32bit {
|
||||
format "%-#20o %#-20o %#-20o %#-20o" 6 34 16923 -12 -1
|
||||
} {06 042 041033 037777777764 }
|
||||
test format-1.11.1 {integer formatting} longIs64bit {
|
||||
format "%-#20o %#-20o %#-20o %#-20o" 6 34 16923 -12 -1
|
||||
} {06 042 041033 01777777777777777777764}
|
||||
|
||||
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-2.5 {string formatting, embedded nulls} {
|
||||
format "%10s" abc\0def
|
||||
} " abc\0def"
|
||||
test format-2.6 {string formatting, international chars} {
|
||||
format "%10s" abc\ufeffdef
|
||||
} " abc\ufeffdef"
|
||||
test format-2.7 {string formatting, international chars} {
|
||||
format "%.5s" abc\ufeffdef
|
||||
} "abc\ufeffd"
|
||||
test format-2.8 {string formatting, international chars} {
|
||||
format "foo\ufeffbar%s" baz
|
||||
} "foo\ufeffbarbaz"
|
||||
test format-2.9 {string formatting, width} {
|
||||
format "a%5sa" f
|
||||
} "a fa"
|
||||
test format-2.10 {string formatting, width} {
|
||||
format "a%-5sa" f
|
||||
} "af a"
|
||||
test format-2.11 {string formatting, width} {
|
||||
format "a%2sa" foo
|
||||
} "afooa"
|
||||
test format-2.12 {string formatting, width} {
|
||||
format "a%0sa" foo
|
||||
} "afooa"
|
||||
test format-2.13 {string formatting, precision} {
|
||||
format "a%.2sa" foobarbaz
|
||||
} "afoa"
|
||||
test format-2.14 {string formatting, precision} {
|
||||
format "a%.sa" foobarbaz
|
||||
} "aa"
|
||||
test format-2.15 {string formatting, precision} {
|
||||
list [catch {format "a%.-2sa" foobarbaz} msg] $msg
|
||||
} {1 {bad field specifier "-"}}
|
||||
test format-2.16 {string formatting, width and precision} {
|
||||
format "a%5.2sa" foobarbaz
|
||||
} "a foa"
|
||||
test format-2.17 {string formatting, width and precision} {
|
||||
format "a%5.7sa" foobarbaz
|
||||
} "afoobarba"
|
||||
|
||||
test format-3.1 {Tcl_FormatObjCmd: character formatting} {
|
||||
format "|%c|%0c|%-1c|%1c|%-6c|%6c|%*c|%*c|" 65 65 65 65 65 65 3 65 -4 65
|
||||
} "|A|A|A|A|A | A| A|A |"
|
||||
test format-3.2 {Tcl_FormatObjCmd: international character formatting} {
|
||||
format "|%c|%0c|%-1c|%1c|%-6c|%6c|%*c|%*c|" 0xa2 0x4e4e 0x25a 0xc3 0xff08 0 3 0x6575 -4 0x4e4f
|
||||
} "|\ua2|\u4e4e|\u25a|\uc3|\uff08 | \0| \u6575|\u4e4f |"
|
||||
|
||||
test format-4.1 {e and f formats} {eformat} {
|
||||
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-4.2 {e and f formats} {eformat} {
|
||||
format "%20e %20e %20e %20e" 34.2e12 68.514 -.125 -16000. .000053
|
||||
} { 3.420000e+13 6.851400e+01 -1.250000e-01 -1.600000e+04}
|
||||
test format-4.3 {e and f formats} {eformat} {
|
||||
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-4.4 {e and f formats} {eformat} {
|
||||
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-4.5 {e and f formats} {eformat} {
|
||||
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-4.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-4.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-4.8 {e and f formats} {eformat} {
|
||||
format "%.4e %.5e %.6e" -9.99996 -9.99996 9.99996
|
||||
} {-1.0000e+01 -9.99996e+00 9.999960e+00}
|
||||
test format-4.9 {e and f formats} {
|
||||
format "%.4f %.5f %.6f" -9.99996 -9.99996 9.99996
|
||||
} {-10.0000 -9.99996 9.999960}
|
||||
test format-4.10 {e and f formats} {
|
||||
format "%20f %-20f %020f" -9.99996 -9.99996 9.99996
|
||||
} { -9.999960 -9.999960 0000000000009.999960}
|
||||
test format-4.11 {e and f formats} {
|
||||
format "%-020f %020f" -9.99996 -9.99996 9.99996
|
||||
} {-9.999960 -000000000009.999960}
|
||||
test format-4.12 {e and f formats} {eformat} {
|
||||
format "%.0e %#.0e" -9.99996 -9.99996 9.99996
|
||||
} {-1e+01 -1.e+01}
|
||||
test format-4.13 {e and f formats} {
|
||||
format "%.0f %#.0f" -9.99996 -9.99996 9.99996
|
||||
} {-10 -10.}
|
||||
test format-4.14 {e and f formats} {
|
||||
format "%.4f %.5f %.6f" -9.99996 -9.99996 9.99996
|
||||
} {-10.0000 -9.99996 9.999960}
|
||||
test format-4.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-4.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-5.1 {g-format} {eformat} {
|
||||
format "%.3g" 12341.0
|
||||
} {1.23e+04}
|
||||
test format-5.2 {g-format} {eformat} {
|
||||
format "%.3G" 1234.12345
|
||||
} {1.23E+03}
|
||||
test format-5.3 {g-format} {
|
||||
format "%.3g" 123.412345
|
||||
} {123}
|
||||
test format-5.4 {g-format} {
|
||||
format "%.3g" 12.3412345
|
||||
} {12.3}
|
||||
test format-5.5 {g-format} {
|
||||
format "%.3g" 1.23412345
|
||||
} {1.23}
|
||||
test format-5.6 {g-format} {
|
||||
format "%.3g" 1.23412345
|
||||
} {1.23}
|
||||
test format-5.7 {g-format} {
|
||||
format "%.3g" .123412345
|
||||
} {0.123}
|
||||
test format-5.8 {g-format} {
|
||||
format "%.3g" .012341
|
||||
} {0.0123}
|
||||
test format-5.9 {g-format} {
|
||||
format "%.3g" .0012341
|
||||
} {0.00123}
|
||||
test format-5.10 {g-format} {
|
||||
format "%.3g" .00012341
|
||||
} {0.000123}
|
||||
test format-5.11 {g-format} {eformat} {
|
||||
format "%.3g" .00001234
|
||||
} {1.23e-05}
|
||||
test format-5.12 {g-format} {eformat} {
|
||||
format "%.4g" 9999.6
|
||||
} {1e+04}
|
||||
test format-5.13 {g-format} {
|
||||
format "%.4g" 999.96
|
||||
} {1000}
|
||||
test format-5.14 {g-format} {
|
||||
format "%.3g" 1.0
|
||||
} {1}
|
||||
test format-5.15 {g-format} {
|
||||
format "%.3g" .1
|
||||
} {0.1}
|
||||
test format-5.16 {g-format} {
|
||||
format "%.3g" .01
|
||||
} {0.01}
|
||||
test format-5.17 {g-format} {
|
||||
format "%.3g" .001
|
||||
} {0.001}
|
||||
test format-5.18 {g-format} {eformat} {
|
||||
format "%.3g" .00001
|
||||
} {1e-05}
|
||||
test format-5.19 {g-format} {eformat} {
|
||||
format "%#.3g" 1234.0
|
||||
} {1.23e+03}
|
||||
test format-5.20 {g-format} {eformat} {
|
||||
format "%#.3G" 9999.5
|
||||
} {1.00E+04}
|
||||
|
||||
test format-6.1 {floating-point zeroes} {eformat} {
|
||||
format "%e %f %g" 0.0 0.0 0.0 0.0
|
||||
} {0.000000e+00 0.000000 0}
|
||||
test format-6.2 {floating-point zeroes} {eformat} {
|
||||
format "%.4e %.4f %.4g" 0.0 0.0 0.0 0.0
|
||||
} {0.0000e+00 0.0000 0}
|
||||
test format-6.3 {floating-point zeroes} {eformat} {
|
||||
format "%#.4e %#.4f %#.4g" 0.0 0.0 0.0 0.0
|
||||
} {0.0000e+00 0.0000 0.000}
|
||||
test format-6.4 {floating-point zeroes} {eformat} {
|
||||
format "%.0e %.0f %.0g" 0.0 0.0 0.0 0.0
|
||||
} {0e+00 0 0}
|
||||
test format-6.5 {floating-point zeroes} {eformat} {
|
||||
format "%#.0e %#.0f %#.0g" 0.0 0.0 0.0 0.0
|
||||
} {0.e+00 0. 0.}
|
||||
test format-6.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-6.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-6.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-7.1 {various syntax features} {
|
||||
format "%*.*f" 12 3 12.345678901
|
||||
} { 12.346}
|
||||
test format-7.2 {various syntax features} {
|
||||
format "%0*.*f" 12 3 12.345678901
|
||||
} {00000012.346}
|
||||
test format-7.3 {various syntax features} {
|
||||
format "\*\t\\n"
|
||||
} {* \n}
|
||||
|
||||
test format-8.1 {error conditions} {
|
||||
catch format
|
||||
} 1
|
||||
test format-8.2 {error conditions} {
|
||||
catch format msg
|
||||
set msg
|
||||
} {wrong # args: should be "format formatString ?arg arg ...?"}
|
||||
test format-8.3 {error conditions} {
|
||||
catch {format %*d}
|
||||
} 1
|
||||
test format-8.4 {error conditions} {
|
||||
catch {format %*d} msg
|
||||
set msg
|
||||
} {not enough arguments for all format specifiers}
|
||||
test format-8.5 {error conditions} {
|
||||
catch {format %*.*f 12}
|
||||
} 1
|
||||
test format-8.6 {error conditions} {
|
||||
catch {format %*.*f 12} msg
|
||||
set msg
|
||||
} {not enough arguments for all format specifiers}
|
||||
test format-8.7 {error conditions} {
|
||||
catch {format %*.*f 12 3}
|
||||
} 1
|
||||
test format-8.8 {error conditions} {
|
||||
catch {format %*.*f 12 3} msg
|
||||
set msg
|
||||
} {not enough arguments for all format specifiers}
|
||||
test format-8.9 {error conditions} {
|
||||
list [catch {format %*d x 3} msg] $msg
|
||||
} {1 {expected integer but got "x"}}
|
||||
test format-8.10 {error conditions} {
|
||||
list [catch {format %*.*f 2 xyz 3} msg] $msg
|
||||
} {1 {expected integer but got "xyz"}}
|
||||
test format-8.11 {error conditions} {
|
||||
catch {format %d 2a}
|
||||
} 1
|
||||
test format-8.12 {error conditions} {
|
||||
catch {format %d 2a} msg
|
||||
set msg
|
||||
} {expected integer but got "2a"}
|
||||
test format-8.13 {error conditions} {
|
||||
catch {format %c 2x}
|
||||
} 1
|
||||
test format-8.14 {error conditions} {
|
||||
catch {format %c 2x} msg
|
||||
set msg
|
||||
} {expected integer but got "2x"}
|
||||
test format-8.15 {error conditions} {
|
||||
catch {format %f 2.1z}
|
||||
} 1
|
||||
test format-8.16 {error conditions} {
|
||||
catch {format %f 2.1z} msg
|
||||
set msg
|
||||
} {expected floating-point number but got "2.1z"}
|
||||
test format-8.17 {error conditions} {
|
||||
catch {format ab%}
|
||||
} 1
|
||||
test format-8.18 {error conditions} {
|
||||
catch {format ab% 12} msg
|
||||
set msg
|
||||
} {format string ended in middle of field specifier}
|
||||
test format-8.19 {error conditions} {
|
||||
catch {format %q x}
|
||||
} 1
|
||||
test format-8.20 {error conditions} {
|
||||
catch {format %q x} msg
|
||||
set msg
|
||||
} {bad field specifier "q"}
|
||||
test format-8.21 {error conditions} {
|
||||
catch {format %d}
|
||||
} 1
|
||||
test format-8.22 {error conditions} {
|
||||
catch {format %d} msg
|
||||
set msg
|
||||
} {not enough arguments for all format specifiers}
|
||||
test format-8.23 {error conditions} {
|
||||
catch {format "%d %d" 24 xyz} msg
|
||||
set msg
|
||||
} {expected integer but got "xyz"}
|
||||
|
||||
test format-9.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} $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}
|
||||
|
||||
test format-10.1 {"h" format specifier} {
|
||||
format %hd 0xffff
|
||||
} -1
|
||||
test format-10.2 {"h" format specifier} {
|
||||
format %hx 0x10fff
|
||||
} fff
|
||||
test format-10.3 {"h" format specifier} {
|
||||
format %hd 0x10000
|
||||
} 0
|
||||
test format-10.4 {"h" format specifier} {
|
||||
# Bug 1154163: This is minimal behaviour for %hx specifier!
|
||||
format %hx 1
|
||||
} 1
|
||||
test format-10.5 {"h" format specifier} {
|
||||
# Bug 1284178: Highly out-of-range values shouldn't cause errors
|
||||
format %hu 0x100000000
|
||||
} 0
|
||||
|
||||
test format-11.1 {XPG3 %$n specifiers} {
|
||||
format {%2$d %1$d} 4 5
|
||||
} {5 4}
|
||||
test format-11.2 {XPG3 %$n specifiers} {
|
||||
format {%2$d %1$d %1$d %3$d} 4 5 6
|
||||
} {5 4 4 6}
|
||||
test format-11.3 {XPG3 %$n specifiers} {
|
||||
list [catch {format {%2$d %3$d} 4 5} msg] $msg
|
||||
} {1 {"%n$" argument index out of range}}
|
||||
test format-11.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-11.5 {XPG3 %$n specifiers} {
|
||||
list [catch {format {%d %1$d} 4 5 6} msg] $msg
|
||||
} {1 {cannot mix "%" and "%n$" conversion specifiers}}
|
||||
test format-11.6 {XPG3 %$n specifiers} {
|
||||
list [catch {format {%2$d %d} 4 5 6} msg] $msg
|
||||
} {1 {cannot mix "%" and "%n$" conversion specifiers}}
|
||||
test format-11.7 {XPG3 %$n specifiers} {
|
||||
list [catch {format {%2$d %3d} 4 5 6} msg] $msg
|
||||
} {1 {cannot mix "%" and "%n$" conversion specifiers}}
|
||||
test format-11.8 {XPG3 %$n specifiers} {
|
||||
format {%2$*d %3$d} 1 10 4
|
||||
} { 4 4}
|
||||
test format-11.9 {XPG3 %$n specifiers} {
|
||||
format {%2$.*s %4$d} 1 5 abcdefghijklmnop 44
|
||||
} {abcde 44}
|
||||
test format-11.10 {XPG3 %$n specifiers} {
|
||||
list [catch {format {%2$*d} 4} msg] $msg
|
||||
} {1 {"%n$" argument index out of range}}
|
||||
test format-11.11 {XPG3 %$n specifiers} {
|
||||
list [catch {format {%2$*d} 4 5} msg] $msg
|
||||
} {1 {"%n$" argument index out of range}}
|
||||
test format-11.12 {XPG3 %$n specifiers} {
|
||||
list [catch {format {%2$*d} 4 5 6} msg] $msg
|
||||
} {0 { 6}}
|
||||
|
||||
test format-12.1 {negative width specifiers} {
|
||||
format "%*d" -47 25
|
||||
} {25 }
|
||||
|
||||
test format-13.1 {tcl_precision fuzzy comparison} {
|
||||
catch {unset a}
|
||||
catch {unset b}
|
||||
catch {unset c}
|
||||
catch {unset d}
|
||||
set a 0.0000000000001
|
||||
set b 0.00000000000001
|
||||
set c 0.00000000000000001
|
||||
set d [expr $a + $b + $c]
|
||||
format {%0.10f %0.12f %0.15f %0.17f} $d $d $d $d
|
||||
} {0.0000000000 0.000000000000 0.000000000000110 0.00000000000011001}
|
||||
test format-13.2 {tcl_precision fuzzy comparison} {
|
||||
catch {unset a}
|
||||
catch {unset b}
|
||||
catch {unset c}
|
||||
catch {unset d}
|
||||
set a 0.000000000001
|
||||
set b 0.000000000000005
|
||||
set c 0.0000000000000008
|
||||
set d [expr $a + $b + $c]
|
||||
format {%0.10f %0.12f %0.15f %0.17f} $d $d $d $d
|
||||
} {0.0000000000 0.000000000001 0.000000000001006 0.00000000000100580}
|
||||
test format-13.3 {tcl_precision fuzzy comparison} {
|
||||
catch {unset a}
|
||||
catch {unset b}
|
||||
catch {unset c}
|
||||
set a 0.00000000000099
|
||||
set b 0.000000000000011
|
||||
set c [expr $a + $b]
|
||||
format {%0.10f %0.12f %0.15f %0.17f} $c $c $c $c
|
||||
} {0.0000000000 0.000000000001 0.000000000001001 0.00000000000100100}
|
||||
test format-13.4 {tcl_precision fuzzy comparison} {
|
||||
catch {unset a}
|
||||
catch {unset b}
|
||||
catch {unset c}
|
||||
set a 0.444444444444
|
||||
set b 0.33333333333333
|
||||
set c [expr $a + $b]
|
||||
format {%0.10f %0.12f %0.15f %0.16f} $c $c $c $c
|
||||
} {0.7777777778 0.777777777777 0.777777777777330 0.7777777777773300}
|
||||
test format-13.5 {tcl_precision fuzzy comparison} {
|
||||
catch {unset a}
|
||||
catch {unset b}
|
||||
catch {unset c}
|
||||
set a 0.444444444444
|
||||
set b 0.99999999999999
|
||||
set c [expr $a + $b]
|
||||
format {%0.10f %0.12f %0.15f} $c $c $c
|
||||
} {1.4444444444 1.444444444444 1.444444444443990}
|
||||
|
||||
test format-14.1 {testing MAX_FLOAT_SIZE for 0 and 1} {
|
||||
format {%s} ""
|
||||
} {}
|
||||
test format-14.2 {testing MAX_FLOAT_SIZE for 0 and 1} {
|
||||
format {%s} "a"
|
||||
} {a}
|
||||
|
||||
test format-15.1 {testing %0..s 0 padding for chars/strings} {
|
||||
format %05s a
|
||||
} {0000a}
|
||||
test format-15.2 {testing %0..s 0 padding for chars/strings} {
|
||||
format "% 5s" a
|
||||
} { a}
|
||||
test format-15.3 {testing %0..s 0 padding for chars/strings} {
|
||||
format %5s a
|
||||
} { a}
|
||||
test format-15.4 {testing %0..s 0 padding for chars/strings} {
|
||||
format %05c 61
|
||||
} {0000=}
|
||||
test format-15.5 {testing %d space padding for integers} {
|
||||
format "(% 1d) (% 1d)" 10 -10
|
||||
} {( 10) (-10)}
|
||||
test format-15.6 {testing %d plus padding for integers} {
|
||||
format "(%+1d) (%+1d)" 10 -10
|
||||
} {(+10) (-10)}
|
||||
|
||||
set a "0123456789"
|
||||
set b ""
|
||||
for {set i 0} {$i < 290} {incr i} {
|
||||
append b $a
|
||||
}
|
||||
for {set i 290} {$i < 400} {incr i} {
|
||||
test format-16.[expr $i -289] {testing MAX_FLOAT_SIZE} {
|
||||
format {%s} $b
|
||||
} $b
|
||||
append b "x"
|
||||
}
|
||||
|
||||
test format-17.1 {testing %d with wide} {wideIs64bit wideBiggerThanInt} {
|
||||
format %d 7810179016327718216
|
||||
} 1819043144
|
||||
test format-17.2 {testing %ld with wide} {wideIs64bit} {
|
||||
format %ld 7810179016327718216
|
||||
} 7810179016327718216
|
||||
test format-17.3 {testing %ld with non-wide} {wideIs64bit} {
|
||||
format %ld 42
|
||||
} 42
|
||||
test format-17.4 {testing %l with non-integer} {
|
||||
format %lf 1
|
||||
} 1.000000
|
||||
|
||||
test format-18.1 {do not demote existing numeric values} {
|
||||
set a 0xaaaaaaaa
|
||||
# Ensure $a and $b are separate objects
|
||||
set b 0xaaaa
|
||||
append b aaaa
|
||||
|
||||
set result [expr {$a == $b}]
|
||||
format %08lx $b
|
||||
lappend result [expr {$a == $b}]
|
||||
|
||||
set b 0xaaaa
|
||||
append b aaaa
|
||||
|
||||
lappend result [expr {$a == $b}]
|
||||
format %08x $b
|
||||
lappend result [expr {$a == $b}]
|
||||
} {1 1 1 1}
|
||||
test format-18.2 {do not demote existing numeric values} {wideBiggerThanInt} {
|
||||
set a [expr {0xaaaaaaaaaa + 1}]
|
||||
set b 0xaaaaaaaaab
|
||||
list [format %08x $a] [expr {$a == $b}]
|
||||
} {aaaaaaab 1}
|
||||
|
||||
test format-19.1 {
|
||||
regression test - tcl-core message by Brian Griffin on
|
||||
26 0ctober 2004
|
||||
} -body {
|
||||
set x 0x8fedc654
|
||||
list [expr { ~ $x }] [format %08x [expr { ~$x }]]
|
||||
} -match regexp -result {-2414724693 f*701239ab}
|
||||
|
||||
test format-19.2 {Bug 1867855} {
|
||||
format %llx 0
|
||||
} 0
|
||||
|
||||
test format-19.3 {Bug 2830354} {
|
||||
string length [format %340f 0]
|
||||
} 340
|
||||
|
||||
# cleanup
|
||||
catch {unset a}
|
||||
catch {unset b}
|
||||
catch {unset c}
|
||||
catch {unset d}
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# End:
|
||||
98
tests/get.test
Normal file
98
tests/get.test
Normal file
@@ -0,0 +1,98 @@
|
||||
# Commands covered: none
|
||||
#
|
||||
# This file contains a collection of tests for the procedures in the
|
||||
# file tclGet.c. Sourcing this file into Tcl runs the tests and
|
||||
# generates output for errors. No output means no errors were found.
|
||||
#
|
||||
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
testConstraint testgetint [llength [info commands testgetint]]
|
||||
testConstraint longIs32bit [expr {int(0x80000000) < 0}]
|
||||
testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}]
|
||||
|
||||
test get-1.1 {Tcl_GetInt procedure} testgetint {
|
||||
testgetint 44 { 22}
|
||||
} {66}
|
||||
test get-1.2 {Tcl_GetInt procedure} testgetint {
|
||||
testgetint 44 -3
|
||||
} {41}
|
||||
test get-1.3 {Tcl_GetInt procedure} testgetint {
|
||||
testgetint 44 +8
|
||||
} {52}
|
||||
test get-1.4 {Tcl_GetInt procedure} testgetint {
|
||||
list [catch {testgetint 44 foo} msg] $msg
|
||||
} {1 {expected integer but got "foo"}}
|
||||
test get-1.5 {Tcl_GetInt procedure} testgetint {
|
||||
list [catch {testgetint 44 {16 }} msg] $msg
|
||||
} {0 60}
|
||||
test get-1.6 {Tcl_GetInt procedure} testgetint {
|
||||
list [catch {testgetint 44 {16 x}} msg] $msg
|
||||
} {1 {expected integer but got "16 x"}}
|
||||
test get-1.7 {Tcl_GetInt procedure} {testgetint longIs64bit} {
|
||||
list [catch {testgetint 44 18446744073709551616} msg] $msg $errorCode
|
||||
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
|
||||
test get-1.8 {Tcl_GetInt procedure} {testgetint longIs64bit} {
|
||||
list [catch {testgetint 18446744073709551614} msg] $msg
|
||||
} {0 -2}
|
||||
test get-1.9 {Tcl_GetInt procedure} {testgetint longIs64bit} {
|
||||
list [catch {testgetint +18446744073709551614} msg] $msg
|
||||
} {0 -2}
|
||||
test get-1.10 {Tcl_GetInt procedure} {testgetint longIs64bit} {
|
||||
list [catch {testgetint -18446744073709551614} msg] $msg
|
||||
} {0 2}
|
||||
test get-1.11 {Tcl_GetInt procedure} {testgetint longIs32bit} {
|
||||
list [catch {testgetint 44 4294967296} msg] $msg $errorCode
|
||||
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
|
||||
test get-1.12 {Tcl_GetInt procedure} {testgetint longIs32bit} {
|
||||
list [catch {testgetint 4294967294} msg] $msg
|
||||
} {0 -2}
|
||||
test get-1.13 {Tcl_GetInt procedure} {testgetint longIs32bit} {
|
||||
list [catch {testgetint +4294967294} msg] $msg
|
||||
} {0 -2}
|
||||
test get-1.14 {Tcl_GetInt procedure} {testgetint longIs32bit} {
|
||||
list [catch {testgetint -4294967294} msg] $msg
|
||||
} {0 2}
|
||||
|
||||
test get-2.1 {Tcl_GetInt procedure} {
|
||||
format %g 1.23
|
||||
} {1.23}
|
||||
test get-2.2 {Tcl_GetInt procedure} {
|
||||
format %g { 1.23 }
|
||||
} {1.23}
|
||||
test get-2.3 {Tcl_GetInt procedure} {
|
||||
list [catch {format %g clip} msg] $msg
|
||||
} {1 {expected floating-point number but got "clip"}}
|
||||
test get-2.4 {Tcl_GetInt procedure} {
|
||||
format %g .000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001
|
||||
} 0
|
||||
|
||||
test get-3.1 {Tcl_GetInt(FromObj), bad numbers} {
|
||||
# SF bug #634856
|
||||
set result ""
|
||||
set numbers [list 1 +1 ++1 +-1 -+1 -1 --1 "- +1" "+12345678987654321" "++12345678987654321"]
|
||||
foreach num $numbers {
|
||||
lappend result [catch {format %ld $num} msg] $msg
|
||||
}
|
||||
set result
|
||||
} {0 1 0 1 1 {expected integer but got "++1"} 1 {expected integer but got "+-1"} 1 {expected integer but got "-+1"} 0 -1 1 {expected integer but got "--1"} 1 {expected integer but got "- +1"} 0 12345678987654321 1 {expected integer but got "++12345678987654321"}}
|
||||
test get-3.2 {Tcl_GetDouble(FromObj), bad numbers} {
|
||||
set result ""
|
||||
set numbers [list 1.0 +1.0 ++1.0 +-1.0 -+1.0 -1.0 --1.0 "- +1.0"]
|
||||
foreach num $numbers {
|
||||
lappend result [catch {format %g $num} msg] $msg
|
||||
}
|
||||
set result
|
||||
} {0 1 0 1 1 {expected floating-point number but got "++1.0"} 1 {expected floating-point number but got "+-1.0"} 1 {expected floating-point number but got "-+1.0"} 0 -1 1 {expected floating-point number but got "--1.0"} 1 {expected floating-point number but got "- +1.0"}}
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
250
tests/history.test
Normal file
250
tests/history.test
Normal file
@@ -0,0 +1,250 @@
|
||||
# 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.
|
||||
# Copyright (c) 1994 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
# The history command might be autoloaded...
|
||||
if {[catch {history}]} {
|
||||
testConstraint history 0
|
||||
} else {
|
||||
testConstraint history 1
|
||||
}
|
||||
|
||||
if {[testConstraint history]} {
|
||||
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}
|
||||
} else {
|
||||
# Dummy value, must be numeric
|
||||
set num 0
|
||||
}
|
||||
|
||||
# "history event"
|
||||
|
||||
test history-1.1 {event option} history {history event -1} \
|
||||
{set b [format {A test %s} string]}
|
||||
test history-1.2 {event option} history {history event $num} \
|
||||
{set a 12345}
|
||||
test history-1.3 {event option} history {history event [expr $num+2]} \
|
||||
{Another test}
|
||||
test history-1.4 {event option} history {history event set} \
|
||||
{set b [format {A test %s} string]}
|
||||
test history-1.5 {event option} history {history e "* a*"} \
|
||||
{set a 12345}
|
||||
test history-1.6 {event option} history {catch {history event *gorp} msg} 1
|
||||
test history-1.7 {event option} history {
|
||||
catch {history event *gorp} msg
|
||||
set msg
|
||||
} {no event matches "*gorp"}
|
||||
test history-1.8 {event option} history {history event} \
|
||||
{set b [format {A test %s} string]}
|
||||
test history-1.9 {event option} history {catch {history event 123 456} msg} 1
|
||||
test history-1.10 {event option} history {
|
||||
catch {history event 123 456} msg
|
||||
set msg
|
||||
} {wrong # args: should be "history event ?event?"}
|
||||
|
||||
# "history redo"
|
||||
|
||||
if {[testConstraint history]} {
|
||||
set a 0
|
||||
history redo -2
|
||||
}
|
||||
test history-2.1 {redo option} history {set a} 12345
|
||||
if {[testConstraint history]} {
|
||||
set b 0
|
||||
history redo
|
||||
}
|
||||
test history-2.2 {redo option} history {set b} {A test string}
|
||||
test history-2.3 {redo option} history {catch {history redo -3 -4}} 1
|
||||
test history-2.4 {redo option} history {
|
||||
catch {history redo -3 -4} msg
|
||||
set msg
|
||||
} {wrong # args: should be "history redo ?event?"}
|
||||
|
||||
# "history add"
|
||||
|
||||
if {[testConstraint history]} {
|
||||
history add "set a 444" exec
|
||||
}
|
||||
test history-3.1 {add option} history {set a} 444
|
||||
test history-3.2 {add option} history {catch {history add "set a 444" execGorp}} 1
|
||||
test history-3.3 {add option} history {
|
||||
catch {history add "set a 444" execGorp} msg
|
||||
set msg
|
||||
} {bad argument "execGorp": should be "exec"}
|
||||
test history-3.4 {add option} history {catch {history add "set a 444" a} msg} 1
|
||||
test history-3.5 {add option} history {
|
||||
catch {history add "set a 444" a} msg
|
||||
set msg
|
||||
} {bad argument "a": should be "exec"}
|
||||
if {[testConstraint history]} {
|
||||
history add "set a 555" e
|
||||
}
|
||||
test history-3.6 {add option} history {set a} 555
|
||||
if {[testConstraint history]} {
|
||||
history add "set a 666"
|
||||
}
|
||||
test history-3.7 {add option} history {set a} 555
|
||||
test history-3.8 {add option} history {catch {history add "set a 666" e f} msg} 1
|
||||
test history-3.9 {add option} history {
|
||||
catch {history add "set a 666" e f} msg
|
||||
set msg
|
||||
} {wrong # args: should be "history add event ?exec?"}
|
||||
|
||||
# "history change"
|
||||
|
||||
if {[testConstraint history]} {
|
||||
history change "A test value"
|
||||
}
|
||||
test history-4.1 {change option} history {history event [expr {[history n]-1}]} \
|
||||
"A test value"
|
||||
if {[testConstraint history]} {
|
||||
history ch "Another test" -1
|
||||
}
|
||||
test history-4.2 {change option} history {history e} "Another test"
|
||||
test history-4.3 {change option} history {history event [expr {[history n]-1}]} \
|
||||
"A test value"
|
||||
test history-4.4 {change option} history {catch {history change Foo 4 10}} 1
|
||||
test history-4.5 {change option} history {
|
||||
catch {history change Foo 4 10} msg
|
||||
set msg
|
||||
} {wrong # args: should be "history change newValue ?event?"}
|
||||
test history-4.6 {change option} history {
|
||||
catch {history change Foo [expr {[history n]-4}]}
|
||||
} 1
|
||||
if {[testConstraint history]} {
|
||||
set num [expr {[history n]-4}]
|
||||
}
|
||||
test history-4.7 {change option} history {
|
||||
catch {history change Foo $num} msg
|
||||
set msg
|
||||
} "event \"$num\" is too far in the past"
|
||||
|
||||
# "history info"
|
||||
|
||||
if {[testConstraint history]} {
|
||||
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 {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 {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} history {catch {history i 2 3}} 1
|
||||
test history-5.4 {info option} history {
|
||||
catch {history i 2 3} msg
|
||||
set msg
|
||||
} {wrong # args: should be "history info ?count?"}
|
||||
test history-5.5 {info option} history {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"
|
||||
|
||||
if {[testConstraint history]} {
|
||||
history add "foo1"
|
||||
history add "foo2"
|
||||
history add "foo3"
|
||||
history keep 2
|
||||
}
|
||||
test history-6.1 {keep option} history {history event [expr [history n]-1]} foo3
|
||||
test history-6.2 {keep option} history {history event -1} foo2
|
||||
test history-6.3 {keep option} history {catch {history event -3}} 1
|
||||
test history-6.4 {keep option} history {
|
||||
catch {history event -3} msg
|
||||
set msg
|
||||
} {event "-3" is too far in the past}
|
||||
if {[testConstraint history]} {
|
||||
history k 5
|
||||
}
|
||||
test history-6.5 {keep option} history {history event -1} foo2
|
||||
test history-6.6 {keep option} history {history event -2} {}
|
||||
test history-6.7 {keep option} history {history event -3} {}
|
||||
test history-6.8 {keep option} history {history event -4} {}
|
||||
test history-6.9 {keep option} history {catch {history event -5}} 1
|
||||
test history-6.10 {keep option} history {catch {history keep 4 6}} 1
|
||||
test history-6.11 {keep option} history {
|
||||
catch {history keep 4 6} msg
|
||||
set msg
|
||||
} {wrong # args: should be "history keep ?count?"}
|
||||
test history-6.12 {keep option} history {catch {history keep}} 0
|
||||
test history-6.13 {keep option} history {
|
||||
history keep
|
||||
} {5}
|
||||
test history-6.14 {keep option} history {catch {history keep -3}} 1
|
||||
test history-6.15 {keep option} history {
|
||||
catch {history keep -3} msg
|
||||
set msg
|
||||
} {illegal keep count "-3"}
|
||||
test history-6.16 {keep option} history {
|
||||
catch {history keep butter} msg
|
||||
set msg
|
||||
} {illegal keep count "butter"}
|
||||
|
||||
# "history nextid"
|
||||
|
||||
if {[testConstraint history]} {
|
||||
set num [history n]
|
||||
history add "Testing"
|
||||
history add "Testing2"
|
||||
}
|
||||
test history-7.1 {nextid option} history {history event} "Testing"
|
||||
test history-7.2 {nextid option} history {history next} [expr $num+2]
|
||||
test history-7.3 {nextid option} history {catch {history nextid garbage}} 1
|
||||
test history-7.4 {nextid option} history {
|
||||
catch {history nextid garbage} msg
|
||||
set msg
|
||||
} {wrong # args: should be "history nextid"}
|
||||
|
||||
# "history clear"
|
||||
|
||||
if {[testConstraint history]} {
|
||||
set num [history n]
|
||||
history add "Testing"
|
||||
history add "Testing2"
|
||||
}
|
||||
test history-8.1 {clear option} history {catch {history clear junk}} 1
|
||||
test history-8.2 {clear option} history {history clear} {}
|
||||
if {[testConstraint history]} {
|
||||
history add "Testing"
|
||||
}
|
||||
test history-8.3 {clear option} history {history} { 1 Testing}
|
||||
|
||||
# miscellaneous
|
||||
|
||||
test history-9.1 {miscellaneous} history {catch {history gorp} msg} 1
|
||||
test history-9.2 {miscellaneous} history {
|
||||
catch {history gorp} msg
|
||||
set msg
|
||||
} {bad option "gorp": must be add, change, clear, event, info, keep, nextid, or redo}
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
566
tests/http.test
Normal file
566
tests/http.test
Normal file
@@ -0,0 +1,566 @@
|
||||
# Commands covered: http::config, http::geturl, http::wait, http::reset
|
||||
#
|
||||
# This file contains a collection of tests for the http script library.
|
||||
# Sourcing this file into Tcl runs the tests and
|
||||
# generates output for errors. No output means no errors were found.
|
||||
#
|
||||
# Copyright (c) 1991-1993 The Regents of the University of California.
|
||||
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-2000 by Ajuba Solutions.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest 2
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
if {[catch {package require http 2} version]} {
|
||||
if {[info exists http2]} {
|
||||
catch {puts "Cannot load http 2.* package"}
|
||||
return
|
||||
} else {
|
||||
catch {puts "Running http 2.* tests in slave interp"}
|
||||
set interp [interp create http2]
|
||||
$interp eval [list set http2 "running"]
|
||||
$interp eval [list set argv $argv]
|
||||
$interp eval [list source [info script]]
|
||||
interp delete $interp
|
||||
return
|
||||
}
|
||||
}
|
||||
|
||||
proc bgerror {args} {
|
||||
global errorInfo
|
||||
puts stderr "http.test bgerror"
|
||||
puts stderr [join $args]
|
||||
puts stderr $errorInfo
|
||||
}
|
||||
|
||||
set port 8010
|
||||
set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null"
|
||||
catch {unset data}
|
||||
|
||||
# Ensure httpd file exists
|
||||
|
||||
set origFile [file join [pwd] [file dirname [info script]] httpd]
|
||||
set httpdFile [file join [temporaryDirectory] httpd_[pid]]
|
||||
if {![file exists $httpdFile]} {
|
||||
makeFile "" $httpdFile
|
||||
file delete $httpdFile
|
||||
file copy $origFile $httpdFile
|
||||
set removeHttpd 1
|
||||
}
|
||||
|
||||
if {[info commands testthread] == "testthread" && [file exists $httpdFile]} {
|
||||
set httpthread [testthread create "
|
||||
source [list $httpdFile]
|
||||
testthread wait
|
||||
"]
|
||||
testthread send $httpthread [list set port $port]
|
||||
testthread send $httpthread [list set bindata $bindata]
|
||||
testthread send $httpthread {httpd_init $port}
|
||||
puts "Running httpd in thread $httpthread"
|
||||
} else {
|
||||
if {![file exists $httpdFile]} {
|
||||
puts "Cannot read $httpdFile script, http test skipped"
|
||||
unset port
|
||||
return
|
||||
}
|
||||
source $httpdFile
|
||||
# Let the OS pick the port; that's much more flexible
|
||||
if {[catch {httpd_init 0} listen]} {
|
||||
puts "Cannot start http server, http test skipped"
|
||||
unset port
|
||||
return
|
||||
} else {
|
||||
set port [lindex [fconfigure $listen -sockname] 2]
|
||||
}
|
||||
}
|
||||
|
||||
test http-1.1 {http::config} {
|
||||
http::config
|
||||
} [list -accept */* -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -urlencoding utf-8 -useragent "Tcl http client package $version"]
|
||||
test http-1.2 {http::config} {
|
||||
http::config -proxyfilter
|
||||
} http::ProxyRequired
|
||||
test http-1.3 {http::config} {
|
||||
catch {http::config -junk}
|
||||
} 1
|
||||
test http-1.4 {http::config} {
|
||||
set savedconf [http::config]
|
||||
http::config -proxyhost nowhere.come -proxyport 8080 \
|
||||
-proxyfilter myFilter -useragent "Tcl Test Suite" \
|
||||
-urlencoding iso8859-1
|
||||
set x [http::config]
|
||||
http::config {*}$savedconf
|
||||
set x
|
||||
} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -urlencoding iso8859-1 -useragent {Tcl Test Suite}}
|
||||
test http-1.5 {http::config} {
|
||||
list [catch {http::config -proxyhost {} -junk 8080} msg] $msg
|
||||
} {1 {Unknown option -junk, must be: -accept, -proxyfilter, -proxyhost, -proxyport, -urlencoding, -useragent}}
|
||||
test http-1.6 {http::config} {
|
||||
set enc [list [http::config -urlencoding]]
|
||||
http::config -urlencoding iso8859-1
|
||||
lappend enc [http::config -urlencoding]
|
||||
http::config -urlencoding [lindex $enc 0]
|
||||
set enc
|
||||
} {utf-8 iso8859-1}
|
||||
|
||||
test http-2.1 {http::reset} {
|
||||
catch {http::reset http#1}
|
||||
} 0
|
||||
|
||||
test http-3.1 {http::geturl} {
|
||||
list [catch {http::geturl -bogus flag} msg] $msg
|
||||
} {1 {Unknown option flag, can be: -binary, -blocksize, -channel, -command, -handler, -headers, -keepalive, -method, -myaddr, -progress, -protocol, -query, -queryblocksize, -querychannel, -queryprogress, -strict, -timeout, -type, -validate}}
|
||||
test http-3.2 {http::geturl} {
|
||||
catch {http::geturl http:junk} err
|
||||
set err
|
||||
} {Unsupported URL: http:junk}
|
||||
set url //[info hostname]:$port
|
||||
set badurl //[info hostname]:6666
|
||||
test http-3.3 {http::geturl} {
|
||||
set token [http::geturl $url]
|
||||
http::data $token
|
||||
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
|
||||
<h1>Hello, World!</h1>
|
||||
<h2>GET /</h2>
|
||||
</body></html>"
|
||||
set tail /a/b/c
|
||||
set url //[info hostname]:$port/a/b/c
|
||||
set fullurl http://user:pass@[info hostname]:$port/a/b/c
|
||||
set binurl //[info hostname]:$port/binary
|
||||
set posturl //[info hostname]:$port/post
|
||||
set badposturl //[info hostname]:$port/droppost
|
||||
set authorityurl //[info hostname]:$port
|
||||
test http-3.4 {http::geturl} {
|
||||
set token [http::geturl $url]
|
||||
http::data $token
|
||||
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
|
||||
<h1>Hello, World!</h1>
|
||||
<h2>GET $tail</h2>
|
||||
</body></html>"
|
||||
proc selfproxy {host} {
|
||||
global port
|
||||
return [list [info hostname] $port]
|
||||
}
|
||||
test http-3.5 {http::geturl} {
|
||||
http::config -proxyfilter selfproxy
|
||||
set token [http::geturl $url]
|
||||
http::config -proxyfilter http::ProxyRequired
|
||||
http::data $token
|
||||
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
|
||||
<h1>Hello, World!</h1>
|
||||
<h2>GET http:$url</h2>
|
||||
</body></html>"
|
||||
test http-3.6 {http::geturl} {
|
||||
http::config -proxyfilter bogus
|
||||
set token [http::geturl $url]
|
||||
http::config -proxyfilter http::ProxyRequired
|
||||
http::data $token
|
||||
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
|
||||
<h1>Hello, World!</h1>
|
||||
<h2>GET $tail</h2>
|
||||
</body></html>"
|
||||
test http-3.7 {http::geturl} {
|
||||
set token [http::geturl $url -headers {Pragma no-cache}]
|
||||
http::data $token
|
||||
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
|
||||
<h1>Hello, World!</h1>
|
||||
<h2>GET $tail</h2>
|
||||
</body></html>"
|
||||
test http-3.8 {http::geturl} {
|
||||
set token [http::geturl $url -query Name=Value&Foo=Bar -timeout 2000]
|
||||
http::data $token
|
||||
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
|
||||
<h1>Hello, World!</h1>
|
||||
<h2>POST $tail</h2>
|
||||
<h2>Query</h2>
|
||||
<dl>
|
||||
<dt>Name<dd>Value
|
||||
<dt>Foo<dd>Bar
|
||||
</dl>
|
||||
</body></html>"
|
||||
test http-3.9 {http::geturl} {
|
||||
set token [http::geturl $url -validate 1]
|
||||
http::code $token
|
||||
} "HTTP/1.0 200 OK"
|
||||
test http-3.10 {http::geturl queryprogress} {
|
||||
set query foo=bar
|
||||
set sep ""
|
||||
set i 0
|
||||
# Create about 120K of query data
|
||||
while {$i < 14} {
|
||||
incr i
|
||||
append query $sep$query
|
||||
set sep &
|
||||
}
|
||||
|
||||
proc postProgress {token x y} {
|
||||
global postProgress
|
||||
lappend postProgress $y
|
||||
}
|
||||
set postProgress {}
|
||||
set t [http::geturl $posturl -keepalive 0 -query $query \
|
||||
-queryprogress postProgress -queryblocksize 16384]
|
||||
http::wait $t
|
||||
list [http::status $t] [string length $query] $postProgress [http::data $t]
|
||||
} {ok 122879 {16384 32768 49152 65536 81920 98304 114688 122879} {Got 122879 bytes}}
|
||||
test http-3.11 {http::geturl querychannel with -command} {
|
||||
set query foo=bar
|
||||
set sep ""
|
||||
set i 0
|
||||
# Create about 120K of query data
|
||||
while {$i < 14} {
|
||||
incr i
|
||||
append query $sep$query
|
||||
set sep &
|
||||
}
|
||||
set file [makeFile $query outdata]
|
||||
set fp [open $file]
|
||||
|
||||
proc asyncCB {token} {
|
||||
global postResult
|
||||
lappend postResult [http::data $token]
|
||||
}
|
||||
set postResult [list ]
|
||||
set t [http::geturl $posturl -querychannel $fp]
|
||||
http::wait $t
|
||||
set testRes [list [http::status $t] [string length $query] [http::data $t]]
|
||||
|
||||
# Now do async
|
||||
http::cleanup $t
|
||||
close $fp
|
||||
set fp [open $file]
|
||||
set t [http::geturl $posturl -querychannel $fp -command asyncCB]
|
||||
set postResult [list PostStart]
|
||||
http::wait $t
|
||||
close $fp
|
||||
|
||||
lappend testRes [http::status $t] $postResult
|
||||
removeFile outdata
|
||||
set testRes
|
||||
} {ok 122879 {Got 122880 bytes} ok {PostStart {Got 122880 bytes}}}
|
||||
# On Linux platforms when the client and server are on the same host, the
|
||||
# client is unable to read the server's response one it hits the write error.
|
||||
# The status is "eof".
|
||||
# On Windows, the http::wait procedure gets a "connection reset by peer" error
|
||||
# while reading the reply.
|
||||
test http-3.12 {http::geturl querychannel with aborted request} {nonPortable} {
|
||||
set query foo=bar
|
||||
set sep ""
|
||||
set i 0
|
||||
# Create about 120K of query data
|
||||
while {$i < 14} {
|
||||
incr i
|
||||
append query $sep$query
|
||||
set sep &
|
||||
}
|
||||
set file [makeFile $query outdata]
|
||||
set fp [open $file]
|
||||
|
||||
proc asyncCB {token} {
|
||||
global postResult
|
||||
lappend postResult [http::data $token]
|
||||
}
|
||||
proc postProgress {token x y} {
|
||||
global postProgress
|
||||
lappend postProgress $y
|
||||
}
|
||||
set postProgress {}
|
||||
# Now do async
|
||||
set postResult [list PostStart]
|
||||
if {[catch {
|
||||
set t [http::geturl $badposturl -querychannel $fp -command asyncCB \
|
||||
-queryprogress postProgress]
|
||||
http::wait $t
|
||||
upvar #0 $t state
|
||||
} err]} {
|
||||
puts $::errorInfo
|
||||
error $err
|
||||
}
|
||||
|
||||
removeFile outdata
|
||||
list [http::status $t] [http::code $t]
|
||||
} {ok {HTTP/1.0 200 Data follows}}
|
||||
test http-3.13 {http::geturl socket leak test} {
|
||||
set chanCount [llength [file channels]]
|
||||
for {set i 0} {$i < 3} {incr i} {
|
||||
catch {http::geturl $badurl -timeout 5000}
|
||||
}
|
||||
|
||||
# No extra channels should be taken
|
||||
expr {[llength [file channels]] == $chanCount}
|
||||
} 1
|
||||
test http-3.14 "http::geturl $fullurl" {
|
||||
set token [http::geturl $fullurl -validate 1]
|
||||
http::code $token
|
||||
} "HTTP/1.0 200 OK"
|
||||
test http-3.15 {http::geturl parse failures} -body {
|
||||
http::geturl "{invalid}:url"
|
||||
} -returnCodes error -result {Unsupported URL: {invalid}:url}
|
||||
test http-3.16 {http::geturl parse failures} -body {
|
||||
http::geturl http:relative/url
|
||||
} -returnCodes error -result {Unsupported URL: http:relative/url}
|
||||
test http-3.17 {http::geturl parse failures} -body {
|
||||
http::geturl /absolute/url
|
||||
} -returnCodes error -result {Missing host part: /absolute/url}
|
||||
test http-3.18 {http::geturl parse failures} -body {
|
||||
http::geturl http://somewhere:123456789/
|
||||
} -returnCodes error -result {Invalid port number: 123456789}
|
||||
test http-3.19 {http::geturl parse failures} -body {
|
||||
http::geturl http://{user}@somewhere
|
||||
} -returnCodes error -result {Illegal characters in URL user}
|
||||
test http-3.20 {http::geturl parse failures} -body {
|
||||
http::geturl http://%user@somewhere
|
||||
} -returnCodes error -result {Illegal encoding character usage "%us" in URL user}
|
||||
test http-3.21 {http::geturl parse failures} -body {
|
||||
http::geturl http://somewhere/{path}
|
||||
} -returnCodes error -result {Illegal characters in URL path}
|
||||
test http-3.22 {http::geturl parse failures} -body {
|
||||
http::geturl http://somewhere/%path
|
||||
} -returnCodes error -result {Illegal encoding character usage "%pa" in URL path}
|
||||
test http-3.23 {http::geturl parse failures} -body {
|
||||
http::geturl http://somewhere/path?{query}
|
||||
} -returnCodes error -result {Illegal characters in URL path}
|
||||
test http-3.24 {http::geturl parse failures} -body {
|
||||
http::geturl http://somewhere/path?%query
|
||||
} -returnCodes error -result {Illegal encoding character usage "%qu" in URL path}
|
||||
test http-3.25 {http::geturl: -headers override -type} -body {
|
||||
set token [http::geturl $url/headers -type "text/plain" -query dummy \
|
||||
-headers [list "Content-Type" "text/plain;charset=utf-8"]]
|
||||
http::data $token
|
||||
} -cleanup {
|
||||
http::cleanup $token
|
||||
} -match regexp -result {(?n)Accept \*/\*
|
||||
Host .*
|
||||
User-Agent .*
|
||||
Connection close
|
||||
Content-Type {text/plain;charset=utf-8}
|
||||
Content-Length 5}
|
||||
test http-3.26 {http::geturl: -headers override -type default} -body {
|
||||
set token [http::geturl $url/headers -query dummy \
|
||||
-headers [list "Content-Type" "text/plain;charset=utf-8"]]
|
||||
http::data $token
|
||||
} -cleanup {
|
||||
http::cleanup $token
|
||||
} -match regexp -result {(?n)Accept \*/\*
|
||||
Host .*
|
||||
User-Agent .*
|
||||
Connection close
|
||||
Content-Type {text/plain;charset=utf-8}
|
||||
Content-Length 5}
|
||||
test http-3.30 {http::geturl query without path} -body {
|
||||
set token [http::geturl $authorityurl?var=val]
|
||||
http::ncode $token
|
||||
} -cleanup {
|
||||
catch { http::cleanup $token }
|
||||
} -result 200
|
||||
test http-3.31 {http::geturl fragment without path} -body {
|
||||
set token [http::geturl "$authorityurl#fragment42"]
|
||||
http::ncode $token
|
||||
} -cleanup {
|
||||
catch { http::cleanup $token }
|
||||
} -result 200
|
||||
|
||||
test http-4.1 {http::Event} {
|
||||
set token [http::geturl $url -keepalive 0]
|
||||
upvar #0 $token data
|
||||
array set meta $data(meta)
|
||||
expr {($data(totalsize) == $meta(Content-Length))}
|
||||
} 1
|
||||
test http-4.2 {http::Event} {
|
||||
set token [http::geturl $url]
|
||||
upvar #0 $token data
|
||||
array set meta $data(meta)
|
||||
string compare $data(type) [string trim $meta(Content-Type)]
|
||||
} 0
|
||||
test http-4.3 {http::Event} {
|
||||
set token [http::geturl $url]
|
||||
http::code $token
|
||||
} {HTTP/1.0 200 Data follows}
|
||||
test http-4.4 {http::Event} {
|
||||
set testfile [makeFile "" testfile]
|
||||
set out [open $testfile w]
|
||||
set token [http::geturl $url -channel $out]
|
||||
close $out
|
||||
set in [open $testfile]
|
||||
set x [read $in]
|
||||
close $in
|
||||
removeFile $testfile
|
||||
set x
|
||||
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
|
||||
<h1>Hello, World!</h1>
|
||||
<h2>GET $tail</h2>
|
||||
</body></html>"
|
||||
test http-4.5 {http::Event} {
|
||||
set testfile [makeFile "" testfile]
|
||||
set out [open $testfile w]
|
||||
fconfigure $out -translation lf
|
||||
set token [http::geturl $url -channel $out]
|
||||
close $out
|
||||
upvar #0 $token data
|
||||
removeFile $testfile
|
||||
expr {$data(currentsize) == $data(totalsize)}
|
||||
} 1
|
||||
test http-4.6 {http::Event} {
|
||||
set testfile [makeFile "" testfile]
|
||||
set out [open $testfile w]
|
||||
set token [http::geturl $binurl -channel $out]
|
||||
close $out
|
||||
set in [open $testfile]
|
||||
fconfigure $in -translation binary
|
||||
set x [read $in]
|
||||
close $in
|
||||
removeFile $testfile
|
||||
set x
|
||||
} "$bindata[string trimleft $binurl /]"
|
||||
proc myProgress {token total current} {
|
||||
global progress httpLog
|
||||
if {[info exists httpLog] && $httpLog} {
|
||||
puts "progress $total $current"
|
||||
}
|
||||
set progress [list $total $current]
|
||||
}
|
||||
if 0 {
|
||||
# This test hangs on Windows95 because the client never gets EOF
|
||||
set httpLog 1
|
||||
test http-4.6.1 {http::Event} knownBug {
|
||||
set token [http::geturl $url -blocksize 50 -progress myProgress]
|
||||
set progress
|
||||
} {111 111}
|
||||
}
|
||||
test http-4.7 {http::Event} {
|
||||
set token [http::geturl $url -keepalive 0 -progress myProgress]
|
||||
set progress
|
||||
} {111 111}
|
||||
test http-4.8 {http::Event} {
|
||||
set token [http::geturl $url]
|
||||
http::status $token
|
||||
} {ok}
|
||||
test http-4.9 {http::Event} {
|
||||
set token [http::geturl $url -progress myProgress]
|
||||
http::code $token
|
||||
} {HTTP/1.0 200 Data follows}
|
||||
test http-4.10 {http::Event} {
|
||||
set token [http::geturl $url -progress myProgress]
|
||||
http::size $token
|
||||
} {111}
|
||||
# Timeout cases
|
||||
# Short timeout to working server (the test server). This lets us try a
|
||||
# reset during the connection.
|
||||
test http-4.11 {http::Event} {
|
||||
set token [http::geturl $url -timeout 1 -keepalive 0 -command {#}]
|
||||
http::reset $token
|
||||
http::status $token
|
||||
} {reset}
|
||||
# Longer timeout with reset.
|
||||
test http-4.12 {http::Event} {
|
||||
set token [http::geturl $url/?timeout=10 -keepalive 0 -command {#}]
|
||||
http::reset $token
|
||||
http::status $token
|
||||
} {reset}
|
||||
# Medium timeout to working server that waits even longer. The timeout
|
||||
# hits while waiting for a reply.
|
||||
test http-4.13 {http::Event} {
|
||||
set token [http::geturl $url?timeout=30 -keepalive 0 -timeout 10 -command {#}]
|
||||
http::wait $token
|
||||
http::status $token
|
||||
} {timeout}
|
||||
# Longer timeout to good host, bad port, gets an error after the
|
||||
# connection "completes" but the socket is bad.
|
||||
test http-4.14 {http::Event} -body {
|
||||
set token [http::geturl $badurl/?timeout=10 -timeout 10000 -command \#]
|
||||
if {$token eq ""} {
|
||||
error "bogus return from http::geturl"
|
||||
}
|
||||
http::wait $token
|
||||
lindex [http::error $token] 0
|
||||
} -result {connect failed connection refused}
|
||||
# Bogus host
|
||||
test http-4.15 {http::Event} -body {
|
||||
# This test may fail if you use a proxy server. That is to be
|
||||
# expected and is not a problem with Tcl.
|
||||
set token [http::geturl //not_a_host.tcl.tk -timeout 1000 -command \#]
|
||||
http::wait $token
|
||||
http::status $token
|
||||
# error codes vary among platforms.
|
||||
} -returnCodes 1 -match glob -result "couldn't open socket*"
|
||||
|
||||
test http-5.1 {http::formatQuery} {
|
||||
http::formatQuery name1 value1 name2 "value two"
|
||||
} {name1=value1&name2=value%20two}
|
||||
# test http-5.2 obsoleted by 5.4 and 5.5 with http 2.5
|
||||
test http-5.3 {http::formatQuery} {
|
||||
http::formatQuery lines "line1\nline2\nline3"
|
||||
} {lines=line1%0D%0Aline2%0D%0Aline3}
|
||||
test http-5.4 {http::formatQuery} {
|
||||
http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2
|
||||
} {name1=~bwelch&name2=%C2%A1%C2%A2%C2%A2}
|
||||
test http-5.5 {http::formatQuery} {
|
||||
set enc [http::config -urlencoding]
|
||||
http::config -urlencoding iso8859-1
|
||||
set res [http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2]
|
||||
http::config -urlencoding $enc
|
||||
set res
|
||||
} {name1=~bwelch&name2=%A1%A2%A2}
|
||||
|
||||
test http-6.1 {http::ProxyRequired} {
|
||||
http::config -proxyhost [info hostname] -proxyport $port
|
||||
set token [http::geturl $url]
|
||||
http::wait $token
|
||||
http::config -proxyhost {} -proxyport {}
|
||||
upvar #0 $token data
|
||||
set data(body)
|
||||
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
|
||||
<h1>Hello, World!</h1>
|
||||
<h2>GET http:$url</h2>
|
||||
</body></html>"
|
||||
|
||||
test http-7.1 {http::mapReply} {
|
||||
http::mapReply "abc\$\[\]\"\\()\}\{"
|
||||
} {abc%24%5B%5D%22%5C%28%29%7D%7B}
|
||||
test http-7.2 {http::mapReply} {
|
||||
# RFC 2718 specifies that we pass urlencoding on utf-8 chars by default,
|
||||
# so make sure this gets converted to utf-8 then urlencoded.
|
||||
http::mapReply "\u2208"
|
||||
} {%E2%88%88}
|
||||
test http-7.3 {http::formatQuery} {
|
||||
set enc [http::config -urlencoding]
|
||||
# this would be reverting to http <=2.4 behavior
|
||||
http::config -urlencoding ""
|
||||
set res [list [catch {http::mapReply "\u2208"} msg] $msg]
|
||||
http::config -urlencoding $enc
|
||||
set res
|
||||
} [list 1 "can't read \"formMap(\u2208)\": no such element in array"]
|
||||
test http-7.4 {http::formatQuery} {
|
||||
set enc [http::config -urlencoding]
|
||||
# this would be reverting to http <=2.4 behavior w/o errors
|
||||
# (unknown chars become '?')
|
||||
http::config -urlencoding "iso8859-1"
|
||||
set res [http::mapReply "\u2208"]
|
||||
http::config -urlencoding $enc
|
||||
set res
|
||||
} {%3F}
|
||||
|
||||
# cleanup
|
||||
catch {unset url}
|
||||
catch {unset badurl}
|
||||
catch {unset port}
|
||||
catch {unset data}
|
||||
if {[info exists httpthread]} {
|
||||
testthread send -async $httpthread {
|
||||
testthread exit
|
||||
}
|
||||
} else {
|
||||
close $listen
|
||||
}
|
||||
|
||||
if {[info exists removeHttpd]} {
|
||||
removeFile $httpdFile
|
||||
}
|
||||
|
||||
rename bgerror {}
|
||||
::tcltest::cleanupTests
|
||||
236
tests/httpd
Normal file
236
tests/httpd
Normal file
@@ -0,0 +1,236 @@
|
||||
# -*- tcl -*-
|
||||
#
|
||||
# The httpd_ procedures implement a stub http server.
|
||||
#
|
||||
# Copyright (c) 1997-1998 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1999-2000 Scriptics Corporation
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
#set httpLog 1
|
||||
|
||||
proc httpd_init {{port 8015}} {
|
||||
socket -server httpdAccept $port
|
||||
}
|
||||
proc httpd_log {args} {
|
||||
global httpLog
|
||||
if {[info exists httpLog] && $httpLog} {
|
||||
puts stderr "httpd: [join $args { }]"
|
||||
}
|
||||
}
|
||||
array set httpdErrors {
|
||||
204 {No Content}
|
||||
400 {Bad Request}
|
||||
401 {Authorization Required}
|
||||
404 {Not Found}
|
||||
503 {Service Unavailable}
|
||||
504 {Service Temporarily Unavailable}
|
||||
}
|
||||
|
||||
proc httpdError {sock code args} {
|
||||
global httpdErrors
|
||||
puts $sock "$code $httpdErrors($code)"
|
||||
httpd_log "error: [join $args { }]"
|
||||
}
|
||||
proc httpdAccept {newsock ipaddr port} {
|
||||
global httpd
|
||||
upvar #0 httpd$newsock data
|
||||
|
||||
fconfigure $newsock -blocking 0 -translation {auto crlf}
|
||||
httpd_log $newsock Connect $ipaddr $port
|
||||
set data(ipaddr) $ipaddr
|
||||
after 50 [list fileevent $newsock readable [list httpdRead $newsock]]
|
||||
}
|
||||
|
||||
# read data from a client request
|
||||
|
||||
proc httpdRead { sock } {
|
||||
upvar #0 httpd$sock data
|
||||
|
||||
if {[eof $sock]} {
|
||||
set readCount -1
|
||||
} elseif {![info exists data(state)]} {
|
||||
|
||||
# Read the protocol line and parse out the URL and query
|
||||
|
||||
set readCount [gets $sock line]
|
||||
if {[regexp {(POST|GET|HEAD) ([^?]+)\??([^ ]*) HTTP/(1.[01])} $line \
|
||||
-> data(proto) data(url) data(query) data(httpversion)]} {
|
||||
set data(state) mime
|
||||
httpd_log $sock Query $line
|
||||
} else {
|
||||
httpdError $sock 400
|
||||
httpd_log $sock Error "bad first line:$line"
|
||||
httpdSockDone $sock
|
||||
}
|
||||
return
|
||||
} elseif {$data(state) == "mime"} {
|
||||
|
||||
# Read the HTTP headers
|
||||
|
||||
set readCount [gets $sock line]
|
||||
if {[regexp {^([^:]+):(.*)$} $line -> key val]} {
|
||||
lappend data(meta) $key [string trim $val]
|
||||
}
|
||||
|
||||
} elseif {$data(state) == "query"} {
|
||||
|
||||
# Read the query data
|
||||
|
||||
if {![info exists data(length_orig)]} {
|
||||
set data(length_orig) $data(length)
|
||||
}
|
||||
set line [read $sock $data(length)]
|
||||
set readCount [string length $line]
|
||||
incr data(length) -$readCount
|
||||
}
|
||||
|
||||
# string compare $readCount 0 maps -1 to -1, 0 to 0, and > 0 to 1
|
||||
|
||||
set state [string compare $readCount 0],$data(state),$data(proto)
|
||||
httpd_log $sock $state
|
||||
switch -- $state {
|
||||
-1,mime,HEAD -
|
||||
-1,mime,GET -
|
||||
-1,mime,POST {
|
||||
# gets would block
|
||||
return
|
||||
}
|
||||
0,mime,HEAD -
|
||||
0,mime,GET -
|
||||
0,query,POST {
|
||||
# Empty line at end of headers,
|
||||
# or eof after query data
|
||||
httpdRespond $sock
|
||||
}
|
||||
0,mime,POST {
|
||||
# Empty line between headers and query data
|
||||
if {![info exists data(mime,content-length)]} {
|
||||
httpd_log $sock Error "No Content-Length for POST"
|
||||
httpdError $sock 400
|
||||
httpdSockDone $sock
|
||||
} else {
|
||||
set data(state) query
|
||||
set data(length) $data(mime,content-length)
|
||||
|
||||
# Special case to simulate servers that respond
|
||||
# without reading the post data.
|
||||
|
||||
if {[string match *droppost* $data(url)]} {
|
||||
fileevent $sock readable {}
|
||||
httpdRespond $sock
|
||||
}
|
||||
}
|
||||
}
|
||||
1,mime,HEAD -
|
||||
1,mime,POST -
|
||||
1,mime,GET {
|
||||
# A line of HTTP headers
|
||||
if {[regexp {([^:]+):[ ]*(.*)} $line dummy key value]} {
|
||||
set data(mime,[string tolower $key]) $value
|
||||
}
|
||||
}
|
||||
-1,query,POST {
|
||||
httpd_log $sock Error "unexpected eof on <$data(url)> request"
|
||||
httpdError $sock 400
|
||||
httpdSockDone $sock
|
||||
}
|
||||
1,query,POST {
|
||||
append data(query) $line
|
||||
if {$data(length) <= 0} {
|
||||
set data(length) $data(length_orig)
|
||||
httpdRespond $sock
|
||||
}
|
||||
}
|
||||
default {
|
||||
if {[eof $sock]} {
|
||||
httpd_log $sock Error "unexpected eof on <$data(url)> request"
|
||||
} else {
|
||||
httpd_log $sock Error "unhandled state <$state> fetching <$data(url)>"
|
||||
}
|
||||
httpdError $sock 404
|
||||
httpdSockDone $sock
|
||||
}
|
||||
}
|
||||
}
|
||||
proc httpdSockDone { sock } {
|
||||
upvar #0 httpd$sock data
|
||||
unset data
|
||||
catch {close $sock}
|
||||
}
|
||||
|
||||
# Respond to the query.
|
||||
|
||||
proc httpdRespond { sock } {
|
||||
global httpd bindata port
|
||||
upvar #0 httpd$sock data
|
||||
|
||||
switch -glob -- $data(url) {
|
||||
*binary* {
|
||||
set html "$bindata[info hostname]:$port$data(url)"
|
||||
set type application/octet-stream
|
||||
}
|
||||
*post* {
|
||||
set html "Got [string length $data(query)] bytes"
|
||||
set type text/plain
|
||||
}
|
||||
*headers* {
|
||||
set html ""
|
||||
set type text/plain
|
||||
foreach {key value} $data(meta) {
|
||||
append html [list $key $value] "\n"
|
||||
}
|
||||
set html [string trim $html]
|
||||
}
|
||||
default {
|
||||
set type text/html
|
||||
|
||||
set html "<html><head><title>HTTP/1.0 TEST</title></head><body>
|
||||
<h1>Hello, World!</h1>
|
||||
<h2>$data(proto) $data(url)</h2>
|
||||
"
|
||||
if {[info exists data(query)] && [string length $data(query)]} {
|
||||
append html "<h2>Query</h2>\n<dl>\n"
|
||||
foreach {key value} [split $data(query) &=] {
|
||||
append html "<dt>$key<dd>$value\n"
|
||||
if {$key == "timeout"} {
|
||||
after $value ;# pause
|
||||
}
|
||||
}
|
||||
append html </dl>\n
|
||||
}
|
||||
append html </body></html>
|
||||
}
|
||||
}
|
||||
|
||||
# Catch errors from premature client closes
|
||||
|
||||
catch {
|
||||
if {$data(proto) == "HEAD"} {
|
||||
puts $sock "HTTP/1.0 200 OK"
|
||||
} else {
|
||||
# Split the response to test for [Bug 26245326]
|
||||
puts -nonewline $sock "HT"
|
||||
flush $sock
|
||||
puts $sock "TP/1.0 200 Data follows"
|
||||
}
|
||||
puts $sock "Date: [clock format [clock seconds] \
|
||||
-format {%a, %d %b %Y %H:%M:%S %Z}]"
|
||||
puts $sock "Content-Type: $type"
|
||||
puts $sock "Content-Length: [string length $html]"
|
||||
foreach {key val} $data(meta) {
|
||||
if {[string match "X-*" $key]} {
|
||||
puts $sock "$key: $val"
|
||||
}
|
||||
}
|
||||
puts $sock ""
|
||||
flush $sock
|
||||
if {$data(proto) != "HEAD"} {
|
||||
fconfigure $sock -translation binary
|
||||
puts -nonewline $sock $html
|
||||
}
|
||||
}
|
||||
httpd_log $sock Done ""
|
||||
httpdSockDone $sock
|
||||
}
|
||||
293
tests/httpold.test
Normal file
293
tests/httpold.test
Normal file
@@ -0,0 +1,293 @@
|
||||
# Commands covered: http_config, http_get, http_wait, http_reset
|
||||
#
|
||||
# This file contains a collection of tests for the http script library.
|
||||
# Sourcing this file into Tcl runs the tests and
|
||||
# generates output for errors. No output means no errors were found.
|
||||
#
|
||||
# Copyright (c) 1991-1993 The Regents of the University of California.
|
||||
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
if {[catch {package require http 1.0}]} {
|
||||
if {[info exists httpold]} {
|
||||
catch {puts "Cannot load http 1.0 package"}
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
} else {
|
||||
catch {puts "Running http 1.0 tests in slave interp"}
|
||||
set interp [interp create httpold]
|
||||
$interp eval [list set httpold "running"]
|
||||
$interp eval [list set argv $argv]
|
||||
$interp eval [list source [info script]]
|
||||
interp delete $interp
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
}
|
||||
}
|
||||
|
||||
set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null"
|
||||
catch {unset data}
|
||||
|
||||
##
|
||||
## The httpd script implement a stub http server
|
||||
##
|
||||
source [file join [file dirname [info script]] httpd]
|
||||
|
||||
set port 8010
|
||||
if [catch {httpd_init $port} listen] {
|
||||
puts "Cannot start http server, http test skipped"
|
||||
unset port
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
}
|
||||
|
||||
test httpold-1.1 {http_config} {
|
||||
http_config
|
||||
} {-accept */* -proxyfilter httpProxyRequired -proxyhost {} -proxyport {} -useragent {Tcl http client package 1.0}}
|
||||
|
||||
test httpold-1.2 {http_config} {
|
||||
http_config -proxyfilter
|
||||
} httpProxyRequired
|
||||
|
||||
test httpold-1.3 {http_config} {
|
||||
catch {http_config -junk}
|
||||
} 1
|
||||
|
||||
test httpold-1.4 {http_config} {
|
||||
http_config -proxyhost nowhere.come -proxyport 8080 -proxyfilter myFilter -useragent "Tcl Test Suite"
|
||||
set x [http_config]
|
||||
http_config -proxyhost {} -proxyport {} -proxyfilter httpProxyRequired \
|
||||
-useragent "Tcl http client package 1.0"
|
||||
set x
|
||||
} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -useragent {Tcl Test Suite}}
|
||||
|
||||
test httpold-1.5 {http_config} {
|
||||
catch {http_config -proxyhost {} -junk 8080}
|
||||
} 1
|
||||
|
||||
test httpold-2.1 {http_reset} {
|
||||
catch {http_reset http#1}
|
||||
} 0
|
||||
|
||||
test httpold-3.1 {http_get} {
|
||||
catch {http_get -bogus flag}
|
||||
} 1
|
||||
test httpold-3.2 {http_get} {
|
||||
catch {http_get http:junk} err
|
||||
set err
|
||||
} {Unsupported URL: http:junk}
|
||||
|
||||
set url [info hostname]:$port
|
||||
test httpold-3.3 {http_get} {
|
||||
set token [http_get $url]
|
||||
http_data $token
|
||||
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
|
||||
<h1>Hello, World!</h1>
|
||||
<h2>GET /</h2>
|
||||
</body></html>"
|
||||
|
||||
set tail /a/b/c
|
||||
set url [info hostname]:$port/a/b/c
|
||||
set binurl [info hostname]:$port/binary
|
||||
|
||||
test httpold-3.4 {http_get} {
|
||||
set token [http_get $url]
|
||||
http_data $token
|
||||
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
|
||||
<h1>Hello, World!</h1>
|
||||
<h2>GET $tail</h2>
|
||||
</body></html>"
|
||||
|
||||
proc selfproxy {host} {
|
||||
global port
|
||||
return [list [info hostname] $port]
|
||||
}
|
||||
test httpold-3.5 {http_get} {
|
||||
http_config -proxyfilter selfproxy
|
||||
set token [http_get $url]
|
||||
http_config -proxyfilter httpProxyRequired
|
||||
http_data $token
|
||||
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
|
||||
<h1>Hello, World!</h1>
|
||||
<h2>GET http://$url</h2>
|
||||
</body></html>"
|
||||
|
||||
test httpold-3.6 {http_get} {
|
||||
http_config -proxyfilter bogus
|
||||
set token [http_get $url]
|
||||
http_config -proxyfilter httpProxyRequired
|
||||
http_data $token
|
||||
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
|
||||
<h1>Hello, World!</h1>
|
||||
<h2>GET $tail</h2>
|
||||
</body></html>"
|
||||
|
||||
test httpold-3.7 {http_get} {
|
||||
set token [http_get $url -headers {Pragma no-cache}]
|
||||
http_data $token
|
||||
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
|
||||
<h1>Hello, World!</h1>
|
||||
<h2>GET $tail</h2>
|
||||
</body></html>"
|
||||
|
||||
test httpold-3.8 {http_get} {
|
||||
set token [http_get $url -query Name=Value&Foo=Bar]
|
||||
http_data $token
|
||||
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
|
||||
<h1>Hello, World!</h1>
|
||||
<h2>POST $tail</h2>
|
||||
<h2>Query</h2>
|
||||
<dl>
|
||||
<dt>Name<dd>Value
|
||||
<dt>Foo<dd>Bar
|
||||
</dl>
|
||||
</body></html>"
|
||||
|
||||
test httpold-3.9 {http_get} {
|
||||
set token [http_get $url -validate 1]
|
||||
http_code $token
|
||||
} "HTTP/1.0 200 OK"
|
||||
|
||||
|
||||
test httpold-4.1 {httpEvent} {
|
||||
set token [http_get $url]
|
||||
upvar #0 $token data
|
||||
array set meta $data(meta)
|
||||
expr ($data(totalsize) == $meta(Content-Length))
|
||||
} 1
|
||||
|
||||
test httpold-4.2 {httpEvent} {
|
||||
set token [http_get $url]
|
||||
upvar #0 $token data
|
||||
array set meta $data(meta)
|
||||
string compare $data(type) [string trim $meta(Content-Type)]
|
||||
} 0
|
||||
|
||||
test httpold-4.3 {httpEvent} {
|
||||
set token [http_get $url]
|
||||
http_code $token
|
||||
} {HTTP/1.0 200 Data follows}
|
||||
|
||||
test httpold-4.4 {httpEvent} {
|
||||
set testfile [makeFile "" testfile]
|
||||
set out [open $testfile w]
|
||||
set token [http_get $url -channel $out]
|
||||
close $out
|
||||
set in [open $testfile]
|
||||
set x [read $in]
|
||||
close $in
|
||||
removeFile $testfile
|
||||
set x
|
||||
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
|
||||
<h1>Hello, World!</h1>
|
||||
<h2>GET $tail</h2>
|
||||
</body></html>"
|
||||
|
||||
test httpold-4.5 {httpEvent} {
|
||||
set testfile [makeFile "" testfile]
|
||||
set out [open $testfile w]
|
||||
set token [http_get $url -channel $out]
|
||||
close $out
|
||||
upvar #0 $token data
|
||||
removeFile $testfile
|
||||
expr $data(currentsize) == $data(totalsize)
|
||||
} 1
|
||||
|
||||
test httpold-4.6 {httpEvent} {
|
||||
set testfile [makeFile "" testfile]
|
||||
set out [open $testfile w]
|
||||
set token [http_get $binurl -channel $out]
|
||||
close $out
|
||||
set in [open $testfile]
|
||||
fconfigure $in -translation binary
|
||||
set x [read $in]
|
||||
close $in
|
||||
removeFile $testfile
|
||||
set x
|
||||
} "$bindata$binurl"
|
||||
|
||||
proc myProgress {token total current} {
|
||||
global progress httpLog
|
||||
if {[info exists httpLog] && $httpLog} {
|
||||
puts "progress $total $current"
|
||||
}
|
||||
set progress [list $total $current]
|
||||
}
|
||||
if 0 {
|
||||
# This test hangs on Windows95 because the client never gets EOF
|
||||
set httpLog 1
|
||||
test httpold-4.6 {httpEvent} {
|
||||
set token [http_get $url -blocksize 50 -progress myProgress]
|
||||
set progress
|
||||
} {111 111}
|
||||
}
|
||||
test httpold-4.7 {httpEvent} {
|
||||
set token [http_get $url -progress myProgress]
|
||||
set progress
|
||||
} {111 111}
|
||||
test httpold-4.8 {httpEvent} {
|
||||
set token [http_get $url]
|
||||
http_status $token
|
||||
} {ok}
|
||||
test httpold-4.9 {httpEvent} {
|
||||
set token [http_get $url -progress myProgress]
|
||||
http_code $token
|
||||
} {HTTP/1.0 200 Data follows}
|
||||
test httpold-4.10 {httpEvent} {
|
||||
set token [http_get $url -progress myProgress]
|
||||
http_size $token
|
||||
} {111}
|
||||
test httpold-4.11 {httpEvent} {
|
||||
set token [http_get $url -timeout 1 -command {#}]
|
||||
http_reset $token
|
||||
http_status $token
|
||||
} {reset}
|
||||
test httpold-4.12 {httpEvent} {
|
||||
update
|
||||
set x {}
|
||||
after 500 {lappend x ok}
|
||||
set token [http_get $url -timeout 1 -command {lappend x fail}]
|
||||
vwait x
|
||||
list [http_status $token] $x
|
||||
} {timeout ok}
|
||||
|
||||
test httpold-5.1 {http_formatQuery} {
|
||||
http_formatQuery name1 value1 name2 "value two"
|
||||
} {name1=value1&name2=value+two}
|
||||
|
||||
test httpold-5.2 {http_formatQuery} {
|
||||
http_formatQuery name1 ~bwelch name2 \xa1\xa2\xa2
|
||||
} {name1=%7ebwelch&name2=%a1%a2%a2}
|
||||
|
||||
test httpold-5.3 {http_formatQuery} {
|
||||
http_formatQuery lines "line1\nline2\nline3"
|
||||
} {lines=line1%0d%0aline2%0d%0aline3}
|
||||
|
||||
test httpold-6.1 {httpProxyRequired} {
|
||||
update
|
||||
http_config -proxyhost [info hostname] -proxyport $port
|
||||
set token [http_get $url]
|
||||
http_wait $token
|
||||
http_config -proxyhost {} -proxyport {}
|
||||
upvar #0 $token data
|
||||
set data(body)
|
||||
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
|
||||
<h1>Hello, World!</h1>
|
||||
<h2>GET http://$url</h2>
|
||||
</body></html>"
|
||||
|
||||
# cleanup
|
||||
catch {unset url}
|
||||
catch {unset port}
|
||||
catch {unset data}
|
||||
close $listen
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
162
tests/if-old.test
Normal file
162
tests/if-old.test
Normal file
@@ -0,0 +1,162 @@
|
||||
# Commands covered: if
|
||||
#
|
||||
# This file contains the original set of tests for Tcl's if command.
|
||||
# Since the if command is now compiled, a new set of tests covering
|
||||
# the new implementation is in the file "if.test". Sourcing this file
|
||||
# into Tcl runs the tests and generates output for errors.
|
||||
# No output means no errors were found.
|
||||
#
|
||||
# Copyright (c) 1991-1993 The Regents of the University of California.
|
||||
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
test if-old-1.1 {taking proper branch} {
|
||||
set a {}
|
||||
if 0 {set a 1} else {set a 2}
|
||||
set a
|
||||
} 2
|
||||
test if-old-1.2 {taking proper branch} {
|
||||
set a {}
|
||||
if 1 {set a 1} else {set a 2}
|
||||
set a
|
||||
} 1
|
||||
test if-old-1.3 {taking proper branch} {
|
||||
set a {}
|
||||
if 1<2 {set a 1}
|
||||
set a
|
||||
} 1
|
||||
test if-old-1.4 {taking proper branch} {
|
||||
set a {}
|
||||
if 1>2 {set a 1}
|
||||
set a
|
||||
} {}
|
||||
test if-old-1.5 {taking proper branch} {
|
||||
set a {}
|
||||
if 0 {set a 1} else {}
|
||||
set a
|
||||
} {}
|
||||
test if-old-1.6 {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-old-1.7 {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-old-1.8 {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-old-1.9 {taking proper branch, multiline test expr} {
|
||||
set a {}
|
||||
if {($tcl_platform(platform) != "foobar1") && \
|
||||
($tcl_platform(platform) != "foobar2")} {set a 3} else {set a 4}
|
||||
set a
|
||||
} {3}
|
||||
|
||||
|
||||
test if-old-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-old-2.2 {optional then-else args} {
|
||||
set a 44
|
||||
if 1 then {set a 1} else {set a 2}
|
||||
set a
|
||||
} 1
|
||||
test if-old-2.3 {optional then-else args} {
|
||||
set a 44
|
||||
if 0 {set a 1} else {set a 2}
|
||||
set a
|
||||
} 2
|
||||
test if-old-2.4 {optional then-else args} {
|
||||
set a 44
|
||||
if 1 {set a 1} else {set a 2}
|
||||
set a
|
||||
} 1
|
||||
test if-old-2.5 {optional then-else args} {
|
||||
set a 44
|
||||
if 0 then {set a 1} {set a 2}
|
||||
set a
|
||||
} 2
|
||||
test if-old-2.6 {optional then-else args} {
|
||||
set a 44
|
||||
if 1 then {set a 1} {set a 2}
|
||||
set a
|
||||
} 1
|
||||
test if-old-2.7 {optional then-else args} {
|
||||
set a 44
|
||||
if 0 then {set a 1} else {set a 2}
|
||||
set a
|
||||
} 2
|
||||
test if-old-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-old-3.1 {return value} {
|
||||
if 1 then {set a 22; concat abc}
|
||||
} abc
|
||||
test if-old-3.2 {return value} {
|
||||
if 0 then {set a 22; concat abc} elseif 1 {concat def} {concat ghi}
|
||||
} def
|
||||
test if-old-3.3 {return value} {
|
||||
if 0 then {set a 22; concat abc} else {concat def}
|
||||
} def
|
||||
test if-old-3.4 {return value} {
|
||||
if 0 then {set a 22; concat abc}
|
||||
} {}
|
||||
test if-old-3.5 {return value} {
|
||||
if 0 then {set a 22; concat abc} elseif 0 {concat def}
|
||||
} {}
|
||||
|
||||
test if-old-4.1 {error conditions} {
|
||||
list [catch {if} msg] $msg
|
||||
} {1 {wrong # args: no expression after "if" argument}}
|
||||
test if-old-4.2 {error conditions} {
|
||||
list [catch {if {[error "error in condition"]} foo} msg] $msg
|
||||
} {1 {error in condition}}
|
||||
test if-old-4.3 {error conditions} {
|
||||
list [catch {if 2} msg] $msg
|
||||
} {1 {wrong # args: no script following "2" argument}}
|
||||
test if-old-4.4 {error conditions} {
|
||||
list [catch {if 2 then} msg] $msg
|
||||
} {1 {wrong # args: no script following "then" argument}}
|
||||
test if-old-4.5 {error conditions} {
|
||||
list [catch {if 2 the} msg] $msg
|
||||
} {1 {invalid command name "the"}}
|
||||
test if-old-4.6 {error conditions} {
|
||||
list [catch {if 2 then {[error "error in then clause"]}} msg] $msg
|
||||
} {1 {error in then clause}}
|
||||
test if-old-4.7 {error conditions} {
|
||||
list [catch {if 0 then foo elseif} msg] $msg
|
||||
} {1 {wrong # args: no expression after "elseif" argument}}
|
||||
test if-old-4.8 {error conditions} {
|
||||
list [catch {if 0 then foo elsei} msg] $msg
|
||||
} {1 {invalid command name "elsei"}}
|
||||
test if-old-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-old-4.10 {error conditions} {
|
||||
list [catch {if 0 then foo elseif 0 bar els} msg] $msg
|
||||
} {1 {invalid command name "els"}}
|
||||
test if-old-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}}
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
1097
tests/if.test
Normal file
1097
tests/if.test
Normal file
File diff suppressed because it is too large
Load Diff
92
tests/incr-old.test
Normal file
92
tests/incr-old.test
Normal file
@@ -0,0 +1,92 @@
|
||||
# Commands covered: incr
|
||||
#
|
||||
# This file contains the original set of tests for Tcl's incr command.
|
||||
# Since the incr command is now compiled, a new set of tests covering
|
||||
# the new implementation is in the file "incr.test". Sourcing this file
|
||||
# into Tcl runs the tests and generates output for errors.
|
||||
# No output means no errors were found.
|
||||
#
|
||||
# Copyright (c) 1991-1993 The Regents of the University of California.
|
||||
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest 2
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
catch {unset x}
|
||||
|
||||
test incr-old-1.1 {basic incr operation} {
|
||||
set x 23
|
||||
list [incr x] $x
|
||||
} {24 24}
|
||||
test incr-old-1.2 {basic incr operation} {
|
||||
set x 106
|
||||
list [incr x -5] $x
|
||||
} {101 101}
|
||||
test incr-old-1.3 {basic incr operation} {
|
||||
set x " -106"
|
||||
list [incr x 1] $x
|
||||
} {-105 -105}
|
||||
test incr-old-1.4 {basic incr operation} {
|
||||
set x " +106"
|
||||
list [incr x 1] $x
|
||||
} {107 107}
|
||||
|
||||
test incr-old-2.1 {incr errors} {
|
||||
list [catch incr msg] $msg
|
||||
} {1 {wrong # args: should be "incr varName ?increment?"}}
|
||||
test incr-old-2.2 {incr errors} {
|
||||
list [catch {incr a b c} msg] $msg
|
||||
} {1 {wrong # args: should be "incr varName ?increment?"}}
|
||||
test incr-old-2.3 {incr errors} {
|
||||
catch {unset x}
|
||||
incr x
|
||||
} 1
|
||||
test incr-old-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"
|
||||
while executing
|
||||
"incr x"}}
|
||||
test incr-old-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-old-2.6 {incr errors} -body {
|
||||
proc readonly args {error "variable is read-only"}
|
||||
set x 123
|
||||
trace var x w readonly
|
||||
list [catch {incr x 1} msg] $msg $::errorInfo
|
||||
} -match glob -result {1 {can't set "x": variable is read-only} {*variable is read-only
|
||||
while executing
|
||||
*
|
||||
"incr x 1"}}
|
||||
catch {unset x}
|
||||
test incr-old-2.7 {incr errors} {
|
||||
set x -
|
||||
list [catch {incr x 1} msg] $msg
|
||||
} {1 {expected integer but got "-"}}
|
||||
test incr-old-2.8 {incr errors} {
|
||||
set x { - }
|
||||
list [catch {incr x 1} msg] $msg
|
||||
} {1 {expected integer but got " - "}}
|
||||
test incr-old-2.9 {incr errors} {
|
||||
set x +
|
||||
list [catch {incr x 1} msg] $msg
|
||||
} {1 {expected integer but got "+"}}
|
||||
test incr-old-2.10 {incr errors} {
|
||||
set x {20 x}
|
||||
list [catch {incr x 1} msg] $msg
|
||||
} {1 {expected integer but got "20 x"}}
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
524
tests/incr.test
Normal file
524
tests/incr.test
Normal file
@@ -0,0 +1,524 @@
|
||||
# Commands covered: incr
|
||||
#
|
||||
# This file contains a collection of tests for one or more of the Tcl
|
||||
# built-in commands. Sourcing this file into Tcl runs the tests and
|
||||
# generates output for errors. No output means no errors were found.
|
||||
#
|
||||
# Copyright (c) 1996 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest 2
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
# Basic "incr" operation.
|
||||
|
||||
catch {unset x}
|
||||
catch {unset i}
|
||||
|
||||
test incr-1.1 {TclCompileIncrCmd: missing variable name} {
|
||||
list [catch {incr} msg] $msg
|
||||
} {1 {wrong # args: should be "incr varName ?increment?"}}
|
||||
test incr-1.2 {TclCompileIncrCmd: simple variable name} {
|
||||
set i 10
|
||||
list [incr i] $i
|
||||
} {11 11}
|
||||
test incr-1.3 {TclCompileIncrCmd: error compiling variable name} {
|
||||
set i 10
|
||||
catch {incr "i"xxx} msg
|
||||
set msg
|
||||
} {extra characters after close-quote}
|
||||
test incr-1.4 {TclCompileIncrCmd: simple variable name in quotes} {
|
||||
set i 17
|
||||
list [incr "i"] $i
|
||||
} {18 18}
|
||||
test incr-1.5 {TclCompileIncrCmd: simple variable name in braces} {
|
||||
catch {unset {a simple var}}
|
||||
set {a simple var} 27
|
||||
list [incr {a simple var}] ${a simple var}
|
||||
} {28 28}
|
||||
test incr-1.6 {TclCompileIncrCmd: simple array variable name} {
|
||||
catch {unset a}
|
||||
set a(foo) 37
|
||||
list [incr a(foo)] $a(foo)
|
||||
} {38 38}
|
||||
test incr-1.7 {TclCompileIncrCmd: non-simple (computed) variable name} {
|
||||
set x "i"
|
||||
set i 77
|
||||
list [incr $x 2] $i
|
||||
} {79 79}
|
||||
test incr-1.8 {TclCompileIncrCmd: non-simple (computed) variable name} {
|
||||
set x "i"
|
||||
set i 77
|
||||
list [incr [set x] +2] $i
|
||||
} {79 79}
|
||||
|
||||
test incr-1.9 {TclCompileIncrCmd: increment given} {
|
||||
set i 10
|
||||
list [incr i +07] $i
|
||||
} {17 17}
|
||||
test incr-1.10 {TclCompileIncrCmd: no increment given} {
|
||||
set i 10
|
||||
list [incr i] $i
|
||||
} {11 11}
|
||||
|
||||
test incr-1.11 {TclCompileIncrCmd: simple global name} {
|
||||
proc p {} {
|
||||
global i
|
||||
set i 54
|
||||
incr i
|
||||
}
|
||||
p
|
||||
} {55}
|
||||
test incr-1.12 {TclCompileIncrCmd: simple local name} {
|
||||
proc p {} {
|
||||
set foo 100
|
||||
incr foo
|
||||
}
|
||||
p
|
||||
} {101}
|
||||
test incr-1.13 {TclCompileIncrCmd: simple but new (unknown) local name} {
|
||||
proc p {} {
|
||||
incr bar
|
||||
}
|
||||
p
|
||||
} 1
|
||||
test incr-1.14 {TclCompileIncrCmd: simple local name, >255 locals} {
|
||||
proc 260locals {} {
|
||||
# create 260 locals
|
||||
set a0 0; set a1 0; set a2 0; set a3 0; set a4 0
|
||||
set a5 0; set a6 0; set a7 0; set a8 0; set a9 0
|
||||
set b0 0; set b1 0; set b2 0; set b3 0; set b4 0
|
||||
set b5 0; set b6 0; set b7 0; set b8 0; set b9 0
|
||||
set c0 0; set c1 0; set c2 0; set c3 0; set c4 0
|
||||
set c5 0; set c6 0; set c7 0; set c8 0; set c9 0
|
||||
set d0 0; set d1 0; set d2 0; set d3 0; set d4 0
|
||||
set d5 0; set d6 0; set d7 0; set d8 0; set d9 0
|
||||
set e0 0; set e1 0; set e2 0; set e3 0; set e4 0
|
||||
set e5 0; set e6 0; set e7 0; set e8 0; set e9 0
|
||||
set f0 0; set f1 0; set f2 0; set f3 0; set f4 0
|
||||
set f5 0; set f6 0; set f7 0; set f8 0; set f9 0
|
||||
set g0 0; set g1 0; set g2 0; set g3 0; set g4 0
|
||||
set g5 0; set g6 0; set g7 0; set g8 0; set g9 0
|
||||
set h0 0; set h1 0; set h2 0; set h3 0; set h4 0
|
||||
set h5 0; set h6 0; set h7 0; set h8 0; set h9 0
|
||||
set i0 0; set i1 0; set i2 0; set i3 0; set i4 0
|
||||
set i5 0; set i6 0; set i7 0; set i8 0; set i9 0
|
||||
set j0 0; set j1 0; set j2 0; set j3 0; set j4 0
|
||||
set j5 0; set j6 0; set j7 0; set j8 0; set j9 0
|
||||
set k0 0; set k1 0; set k2 0; set k3 0; set k4 0
|
||||
set k5 0; set k6 0; set k7 0; set k8 0; set k9 0
|
||||
set l0 0; set l1 0; set l2 0; set l3 0; set l4 0
|
||||
set l5 0; set l6 0; set l7 0; set l8 0; set l9 0
|
||||
set m0 0; set m1 0; set m2 0; set m3 0; set m4 0
|
||||
set m5 0; set m6 0; set m7 0; set m8 0; set m9 0
|
||||
set n0 0; set n1 0; set n2 0; set n3 0; set n4 0
|
||||
set n5 0; set n6 0; set n7 0; set n8 0; set n9 0
|
||||
set o0 0; set o1 0; set o2 0; set o3 0; set o4 0
|
||||
set o5 0; set o6 0; set o7 0; set o8 0; set o9 0
|
||||
set p0 0; set p1 0; set p2 0; set p3 0; set p4 0
|
||||
set p5 0; set p6 0; set p7 0; set p8 0; set p9 0
|
||||
set q0 0; set q1 0; set q2 0; set q3 0; set q4 0
|
||||
set q5 0; set q6 0; set q7 0; set q8 0; set q9 0
|
||||
set r0 0; set r1 0; set r2 0; set r3 0; set r4 0
|
||||
set r5 0; set r6 0; set r7 0; set r8 0; set r9 0
|
||||
set s0 0; set s1 0; set s2 0; set s3 0; set s4 0
|
||||
set s5 0; set s6 0; set s7 0; set s8 0; set s9 0
|
||||
set t0 0; set t1 0; set t2 0; set t3 0; set t4 0
|
||||
set t5 0; set t6 0; set t7 0; set t8 0; set t9 0
|
||||
set u0 0; set u1 0; set u2 0; set u3 0; set u4 0
|
||||
set u5 0; set u6 0; set u7 0; set u8 0; set u9 0
|
||||
set v0 0; set v1 0; set v2 0; set v3 0; set v4 0
|
||||
set v5 0; set v6 0; set v7 0; set v8 0; set v9 0
|
||||
set w0 0; set w1 0; set w2 0; set w3 0; set w4 0
|
||||
set w5 0; set w6 0; set w7 0; set w8 0; set w9 0
|
||||
set x0 0; set x1 0; set x2 0; set x3 0; set x4 0
|
||||
set x5 0; set x6 0; set x7 0; set x8 0; set x9 0
|
||||
set y0 0; set y1 0; set y2 0; set y3 0; set y4 0
|
||||
set y5 0; set y6 0; set y7 0; set y8 0; set y9 0
|
||||
set z0 0; set z1 0; set z2 0; set z3 0; set z4 0
|
||||
set z5 0; set z6 0; set z7 0; set z8 0; set z9 0
|
||||
# now increment the last one (local var index > 255)
|
||||
incr z9
|
||||
}
|
||||
260locals
|
||||
} {1}
|
||||
test incr-1.15 {TclCompileIncrCmd: variable is array} {
|
||||
catch {unset a}
|
||||
set a(foo) 27
|
||||
set x [incr a(foo) 11]
|
||||
catch {unset a}
|
||||
set x
|
||||
} 38
|
||||
test incr-1.16 {TclCompileIncrCmd: variable is array, elem substitutions} {
|
||||
catch {unset a}
|
||||
set i 5
|
||||
set a(foo5) 27
|
||||
set x [incr a(foo$i) 11]
|
||||
catch {unset a}
|
||||
set x
|
||||
} 38
|
||||
|
||||
test incr-1.17 {TclCompileIncrCmd: increment given, simple int} {
|
||||
set i 5
|
||||
incr i 123
|
||||
} 128
|
||||
test incr-1.18 {TclCompileIncrCmd: increment given, simple int} {
|
||||
set i 5
|
||||
incr i -100
|
||||
} -95
|
||||
test incr-1.19 {TclCompileIncrCmd: increment given, but erroneous} -body {
|
||||
set i 5
|
||||
catch {incr i [set]} msg
|
||||
set ::errorInfo
|
||||
} -match glob -result {wrong # args: should be "set varName ?newValue?"
|
||||
while *ing
|
||||
"set"*}
|
||||
test incr-1.20 {TclCompileIncrCmd: increment given, in quotes} {
|
||||
set i 25
|
||||
incr i "-100"
|
||||
} -75
|
||||
test incr-1.21 {TclCompileIncrCmd: increment given, in braces} {
|
||||
set i 24
|
||||
incr i {126}
|
||||
} 150
|
||||
test incr-1.22 {TclCompileIncrCmd: increment given, large int} {
|
||||
set i 5
|
||||
incr i 200000
|
||||
} 200005
|
||||
test incr-1.23 {TclCompileIncrCmd: increment given, formatted int != int} {
|
||||
set i 25
|
||||
incr i 0o00012345 ;# an octal literal
|
||||
} 5374
|
||||
test incr-1.24 {TclCompileIncrCmd: increment given, formatted int != int} {
|
||||
set i 25
|
||||
catch {incr i 1a} msg
|
||||
set msg
|
||||
} {expected integer but got "1a"}
|
||||
|
||||
test incr-1.25 {TclCompileIncrCmd: too many arguments} {
|
||||
set i 10
|
||||
catch {incr i 10 20} msg
|
||||
set msg
|
||||
} {wrong # args: should be "incr varName ?increment?"}
|
||||
|
||||
|
||||
test incr-1.26 {TclCompileIncrCmd: runtime error, bad variable name} {
|
||||
unset -nocomplain {"foo}
|
||||
incr {"foo}
|
||||
} 1
|
||||
test incr-1.27 {TclCompileIncrCmd: runtime error, bad variable name} -body {
|
||||
list [catch {incr [set]} msg] $msg $::errorInfo
|
||||
} -match glob -result {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?"
|
||||
while *ing
|
||||
"set"*}}
|
||||
test incr-1.28 {TclCompileIncrCmd: runtime error, readonly variable} -body {
|
||||
proc readonly args {error "variable is read-only"}
|
||||
set x 123
|
||||
trace var x w readonly
|
||||
list [catch {incr x 1} msg] $msg $::errorInfo
|
||||
} -match glob -result {1 {can't set "x": variable is read-only} {*variable is read-only
|
||||
while executing
|
||||
*
|
||||
"incr x 1"}}
|
||||
catch {unset x}
|
||||
test incr-1.29 {TclCompileIncrCmd: runtime error, bad variable value} {
|
||||
set x " - "
|
||||
list [catch {incr x 1} msg] $msg
|
||||
} {1 {expected integer but got " - "}}
|
||||
|
||||
test incr-1.30 {TclCompileIncrCmd: array var, braced (no subs)} {
|
||||
catch {unset array}
|
||||
set array(\$foo) 4
|
||||
incr {array($foo)}
|
||||
} 5
|
||||
|
||||
# Check "incr" and computed command names.
|
||||
|
||||
test incr-2.0 {incr and computed command names} {
|
||||
set i 5
|
||||
set z incr
|
||||
$z i -1
|
||||
set i
|
||||
} 4
|
||||
catch {unset x}
|
||||
catch {unset i}
|
||||
|
||||
test incr-2.1 {incr command (not compiled): missing variable name} {
|
||||
set z incr
|
||||
list [catch {$z} msg] $msg
|
||||
} {1 {wrong # args: should be "incr varName ?increment?"}}
|
||||
test incr-2.2 {incr command (not compiled): simple variable name} {
|
||||
set z incr
|
||||
set i 10
|
||||
list [$z i] $i
|
||||
} {11 11}
|
||||
test incr-2.3 {incr command (not compiled): error compiling variable name} {
|
||||
set z incr
|
||||
set i 10
|
||||
catch {$z "i"xxx} msg
|
||||
set msg
|
||||
} {extra characters after close-quote}
|
||||
test incr-2.4 {incr command (not compiled): simple variable name in quotes} {
|
||||
set z incr
|
||||
set i 17
|
||||
list [$z "i"] $i
|
||||
} {18 18}
|
||||
test incr-2.5 {incr command (not compiled): simple variable name in braces} {
|
||||
set z incr
|
||||
catch {unset {a simple var}}
|
||||
set {a simple var} 27
|
||||
list [$z {a simple var}] ${a simple var}
|
||||
} {28 28}
|
||||
test incr-2.6 {incr command (not compiled): simple array variable name} {
|
||||
set z incr
|
||||
catch {unset a}
|
||||
set a(foo) 37
|
||||
list [$z a(foo)] $a(foo)
|
||||
} {38 38}
|
||||
test incr-2.7 {incr command (not compiled): non-simple (computed) variable name} {
|
||||
set z incr
|
||||
set x "i"
|
||||
set i 77
|
||||
list [$z $x 2] $i
|
||||
} {79 79}
|
||||
test incr-2.8 {incr command (not compiled): non-simple (computed) variable name} {
|
||||
set z incr
|
||||
set x "i"
|
||||
set i 77
|
||||
list [$z [set x] +2] $i
|
||||
} {79 79}
|
||||
|
||||
test incr-2.9 {incr command (not compiled): increment given} {
|
||||
set z incr
|
||||
set i 10
|
||||
list [$z i +07] $i
|
||||
} {17 17}
|
||||
test incr-2.10 {incr command (not compiled): no increment given} {
|
||||
set z incr
|
||||
set i 10
|
||||
list [$z i] $i
|
||||
} {11 11}
|
||||
|
||||
test incr-2.11 {incr command (not compiled): simple global name} {
|
||||
proc p {} {
|
||||
set z incr
|
||||
global i
|
||||
set i 54
|
||||
$z i
|
||||
}
|
||||
p
|
||||
} {55}
|
||||
test incr-2.12 {incr command (not compiled): simple local name} {
|
||||
proc p {} {
|
||||
set z incr
|
||||
set foo 100
|
||||
$z foo
|
||||
}
|
||||
p
|
||||
} {101}
|
||||
test incr-2.13 {incr command (not compiled): simple but new (unknown) local name} {
|
||||
proc p {} {
|
||||
set z incr
|
||||
$z bar
|
||||
}
|
||||
p
|
||||
} 1
|
||||
test incr-2.14 {incr command (not compiled): simple local name, >255 locals} {
|
||||
proc 260locals {} {
|
||||
set z incr
|
||||
# create 260 locals
|
||||
set a0 0; set a1 0; set a2 0; set a3 0; set a4 0
|
||||
set a5 0; set a6 0; set a7 0; set a8 0; set a9 0
|
||||
set b0 0; set b1 0; set b2 0; set b3 0; set b4 0
|
||||
set b5 0; set b6 0; set b7 0; set b8 0; set b9 0
|
||||
set c0 0; set c1 0; set c2 0; set c3 0; set c4 0
|
||||
set c5 0; set c6 0; set c7 0; set c8 0; set c9 0
|
||||
set d0 0; set d1 0; set d2 0; set d3 0; set d4 0
|
||||
set d5 0; set d6 0; set d7 0; set d8 0; set d9 0
|
||||
set e0 0; set e1 0; set e2 0; set e3 0; set e4 0
|
||||
set e5 0; set e6 0; set e7 0; set e8 0; set e9 0
|
||||
set f0 0; set f1 0; set f2 0; set f3 0; set f4 0
|
||||
set f5 0; set f6 0; set f7 0; set f8 0; set f9 0
|
||||
set g0 0; set g1 0; set g2 0; set g3 0; set g4 0
|
||||
set g5 0; set g6 0; set g7 0; set g8 0; set g9 0
|
||||
set h0 0; set h1 0; set h2 0; set h3 0; set h4 0
|
||||
set h5 0; set h6 0; set h7 0; set h8 0; set h9 0
|
||||
set i0 0; set i1 0; set i2 0; set i3 0; set i4 0
|
||||
set i5 0; set i6 0; set i7 0; set i8 0; set i9 0
|
||||
set j0 0; set j1 0; set j2 0; set j3 0; set j4 0
|
||||
set j5 0; set j6 0; set j7 0; set j8 0; set j9 0
|
||||
set k0 0; set k1 0; set k2 0; set k3 0; set k4 0
|
||||
set k5 0; set k6 0; set k7 0; set k8 0; set k9 0
|
||||
set l0 0; set l1 0; set l2 0; set l3 0; set l4 0
|
||||
set l5 0; set l6 0; set l7 0; set l8 0; set l9 0
|
||||
set m0 0; set m1 0; set m2 0; set m3 0; set m4 0
|
||||
set m5 0; set m6 0; set m7 0; set m8 0; set m9 0
|
||||
set n0 0; set n1 0; set n2 0; set n3 0; set n4 0
|
||||
set n5 0; set n6 0; set n7 0; set n8 0; set n9 0
|
||||
set o0 0; set o1 0; set o2 0; set o3 0; set o4 0
|
||||
set o5 0; set o6 0; set o7 0; set o8 0; set o9 0
|
||||
set p0 0; set p1 0; set p2 0; set p3 0; set p4 0
|
||||
set p5 0; set p6 0; set p7 0; set p8 0; set p9 0
|
||||
set q0 0; set q1 0; set q2 0; set q3 0; set q4 0
|
||||
set q5 0; set q6 0; set q7 0; set q8 0; set q9 0
|
||||
set r0 0; set r1 0; set r2 0; set r3 0; set r4 0
|
||||
set r5 0; set r6 0; set r7 0; set r8 0; set r9 0
|
||||
set s0 0; set s1 0; set s2 0; set s3 0; set s4 0
|
||||
set s5 0; set s6 0; set s7 0; set s8 0; set s9 0
|
||||
set t0 0; set t1 0; set t2 0; set t3 0; set t4 0
|
||||
set t5 0; set t6 0; set t7 0; set t8 0; set t9 0
|
||||
set u0 0; set u1 0; set u2 0; set u3 0; set u4 0
|
||||
set u5 0; set u6 0; set u7 0; set u8 0; set u9 0
|
||||
set v0 0; set v1 0; set v2 0; set v3 0; set v4 0
|
||||
set v5 0; set v6 0; set v7 0; set v8 0; set v9 0
|
||||
set w0 0; set w1 0; set w2 0; set w3 0; set w4 0
|
||||
set w5 0; set w6 0; set w7 0; set w8 0; set w9 0
|
||||
set x0 0; set x1 0; set x2 0; set x3 0; set x4 0
|
||||
set x5 0; set x6 0; set x7 0; set x8 0; set x9 0
|
||||
set y0 0; set y1 0; set y2 0; set y3 0; set y4 0
|
||||
set y5 0; set y6 0; set y7 0; set y8 0; set y9 0
|
||||
set z0 0; set z1 0; set z2 0; set z3 0; set z4 0
|
||||
set z5 0; set z6 0; set z7 0; set z8 0; set z9 0
|
||||
# now increment the last one (local var index > 255)
|
||||
$z z9
|
||||
}
|
||||
260locals
|
||||
} {1}
|
||||
test incr-2.15 {incr command (not compiled): variable is array} {
|
||||
set z incr
|
||||
catch {unset a}
|
||||
set a(foo) 27
|
||||
set x [$z a(foo) 11]
|
||||
catch {unset a}
|
||||
set x
|
||||
} 38
|
||||
test incr-2.16 {incr command (not compiled): variable is array, elem substitutions} {
|
||||
set z incr
|
||||
catch {unset a}
|
||||
set i 5
|
||||
set a(foo5) 27
|
||||
set x [$z a(foo$i) 11]
|
||||
catch {unset a}
|
||||
set x
|
||||
} 38
|
||||
|
||||
test incr-2.17 {incr command (not compiled): increment given, simple int} {
|
||||
set z incr
|
||||
set i 5
|
||||
$z i 123
|
||||
} 128
|
||||
test incr-2.18 {incr command (not compiled): increment given, simple int} {
|
||||
set z incr
|
||||
set i 5
|
||||
$z i -100
|
||||
} -95
|
||||
test incr-2.19 {incr command (not compiled): increment given, but erroneous} -body {
|
||||
set z incr
|
||||
set i 5
|
||||
catch {$z i [set]} msg
|
||||
set ::errorInfo
|
||||
} -match glob -result {wrong # args: should be "set varName ?newValue?"
|
||||
while *ing
|
||||
"set"*}
|
||||
test incr-2.20 {incr command (not compiled): increment given, in quotes} {
|
||||
set z incr
|
||||
set i 25
|
||||
$z i "-100"
|
||||
} -75
|
||||
test incr-2.21 {incr command (not compiled): increment given, in braces} {
|
||||
set z incr
|
||||
set i 24
|
||||
$z i {126}
|
||||
} 150
|
||||
test incr-2.22 {incr command (not compiled): increment given, large int} {
|
||||
set z incr
|
||||
set i 5
|
||||
$z i 200000
|
||||
} 200005
|
||||
test incr-2.23 {incr command (not compiled): increment given, formatted int != int} {
|
||||
set z incr
|
||||
set i 25
|
||||
$z i 0o00012345 ;# an octal literal
|
||||
} 5374
|
||||
test incr-2.24 {incr command (not compiled): increment given, formatted int != int} {
|
||||
set z incr
|
||||
set i 25
|
||||
catch {$z i 1a} msg
|
||||
set msg
|
||||
} {expected integer but got "1a"}
|
||||
|
||||
test incr-2.25 {incr command (not compiled): too many arguments} {
|
||||
set z incr
|
||||
set i 10
|
||||
catch {$z i 10 20} msg
|
||||
set msg
|
||||
} {wrong # args: should be "incr varName ?increment?"}
|
||||
|
||||
|
||||
test incr-2.26 {incr command (not compiled): runtime error, bad variable name} {
|
||||
unset -nocomplain {"foo}
|
||||
set z incr
|
||||
$z {"foo}
|
||||
} 1
|
||||
test incr-2.27 {incr command (not compiled): runtime error, bad variable name} -body {
|
||||
set z incr
|
||||
list [catch {$z [set]} msg] $msg $::errorInfo
|
||||
} -match glob -result {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?"
|
||||
while *ing
|
||||
"set"*}}
|
||||
test incr-2.28 {incr command (not compiled): runtime error, readonly variable} -body {
|
||||
set z incr
|
||||
proc readonly args {error "variable is read-only"}
|
||||
set x 123
|
||||
trace var x w readonly
|
||||
list [catch {$z x 1} msg] $msg $::errorInfo
|
||||
} -match glob -result {1 {can't set "x": variable is read-only} {*variable is read-only
|
||||
while executing
|
||||
*
|
||||
"$z x 1"}}
|
||||
catch {unset x}
|
||||
test incr-2.29 {incr command (not compiled): runtime error, bad variable value} {
|
||||
set z incr
|
||||
set x " - "
|
||||
list [catch {$z x 1} msg] $msg
|
||||
} {1 {expected integer but got " - "}}
|
||||
test incr-2.30 {incr command (not compiled): bad increment} {
|
||||
set z incr
|
||||
set x 0
|
||||
list [catch {$z x 1a} msg] $msg $::errorInfo
|
||||
} {1 {expected integer but got "1a"} {expected integer but got "1a"
|
||||
(reading increment)
|
||||
invoked from within
|
||||
"$z x 1a"}}
|
||||
test incr-2.31 {incr command (compiled): bad increment} {
|
||||
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-3.1 {increment by wide amount: bytecode route} {
|
||||
set x 0
|
||||
incr x 123123123123
|
||||
} 123123123123
|
||||
test incr-3.2 {increment by wide amount: command route} {
|
||||
set z incr
|
||||
set x 0
|
||||
$z x 123123123123
|
||||
} 123123123123
|
||||
|
||||
test incr-4.1 {increment non-existing array element [Bug 1445454]} -body {
|
||||
proc x {} {incr a(1)}
|
||||
x
|
||||
} -cleanup {
|
||||
rename x {}
|
||||
} -result 1
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
137
tests/indexObj.test
Normal file
137
tests/indexObj.test
Normal file
@@ -0,0 +1,137 @@
|
||||
# This file is a Tcl script to test out the the procedures in file
|
||||
# tkIndexObj.c, which implement indexed table lookups. The tests here
|
||||
# are organized in the standard fashion for Tcl tests.
|
||||
#
|
||||
# Copyright (c) 1997 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
testConstraint testindexobj [llength [info commands testindexobj]]
|
||||
|
||||
test indexObj-1.1 {exact match} testindexobj {
|
||||
testindexobj 1 1 xyz abc def xyz alm
|
||||
} {2}
|
||||
test indexObj-1.2 {exact match} testindexobj {
|
||||
testindexobj 1 1 abc abc def xyz alm
|
||||
} {0}
|
||||
test indexObj-1.3 {exact match} testindexobj {
|
||||
testindexobj 1 1 alm abc def xyz alm
|
||||
} {3}
|
||||
test indexObj-1.4 {unique abbreviation} testindexobj {
|
||||
testindexobj 1 1 xy abc def xalb xyz alm
|
||||
} {3}
|
||||
test indexObj-1.5 {multiple abbreviations and exact match} testindexobj {
|
||||
testindexobj 1 1 x abc def xalb xyz alm x
|
||||
} {5}
|
||||
test indexObj-1.6 {forced exact match} testindexobj {
|
||||
testindexobj 1 0 xy abc def xalb xy alm
|
||||
} {3}
|
||||
test indexObj-1.7 {forced exact match} testindexobj {
|
||||
testindexobj 1 0 x abc def xalb xyz alm x
|
||||
} {5}
|
||||
test indexObj-1.8 {exact match of empty values} testindexobj {
|
||||
testindexobj 1 1 {} a aa aaa {} b bb bbb
|
||||
} 3
|
||||
test indexObj-1.9 {exact match of empty values} testindexobj {
|
||||
testindexobj 1 0 {} a aa aaa {} b bb bbb
|
||||
} 3
|
||||
|
||||
test indexObj-2.1 {no match} testindexobj {
|
||||
list [catch {testindexobj 1 1 dddd abc def xalb xyz alm x} msg] $msg
|
||||
} {1 {bad token "dddd": must be abc, def, xalb, xyz, alm, or x}}
|
||||
test indexObj-2.2 {no match} testindexobj {
|
||||
list [catch {testindexobj 1 1 dddd abc} msg] $msg
|
||||
} {1 {bad token "dddd": must be abc}}
|
||||
test indexObj-2.3 {no match: no abbreviations} testindexobj {
|
||||
list [catch {testindexobj 1 0 xy abc def xalb xyz alm} msg] $msg
|
||||
} {1 {bad token "xy": must be abc, def, xalb, xyz, or alm}}
|
||||
test indexObj-2.4 {ambiguous value} testindexobj {
|
||||
list [catch {testindexobj 1 1 d dumb daughter a c} msg] $msg
|
||||
} {1 {ambiguous token "d": must be dumb, daughter, a, or c}}
|
||||
test indexObj-2.5 {omit error message} testindexobj {
|
||||
list [catch {testindexobj 0 1 d x} msg] $msg
|
||||
} {1 {}}
|
||||
test indexObj-2.6 {TCL_EXACT => no "ambiguous" error message} testindexobj {
|
||||
list [catch {testindexobj 1 0 d dumb daughter a c} msg] $msg
|
||||
} {1 {bad token "d": must be dumb, daughter, a, or c}}
|
||||
test indexObj-2.7 {exact match of empty values} testindexobj {
|
||||
list [catch {testindexobj 1 1 {} a b c} msg] $msg
|
||||
} {1 {ambiguous token "": must be a, b, or c}}
|
||||
test indexObj-2.8 {exact match of empty values: singleton case} testindexobj {
|
||||
list [catch {testindexobj 1 0 {} a} msg] $msg
|
||||
} {1 {bad token "": must be a}}
|
||||
test indexObj-2.9 {non-exact match of empty values: singleton case} testindexobj {
|
||||
# NOTE this is a special case. Although the empty string is a
|
||||
# unique prefix, we have an established history of rejecting
|
||||
# empty lookup keys, requiring any unique prefix match to have
|
||||
# at least one character.
|
||||
list [catch {testindexobj 1 1 {} a} msg] $msg
|
||||
} {1 {bad token "": must be a}}
|
||||
|
||||
test indexObj-3.1 {cache result to skip next lookup} testindexobj {
|
||||
testindexobj check 42
|
||||
} {42}
|
||||
|
||||
test indexObj-4.1 {free old internal representation} testindexobj {
|
||||
set x {a b}
|
||||
lindex $x 1
|
||||
testindexobj 1 1 $x abc def {a b} zzz
|
||||
} {2}
|
||||
|
||||
test indexObj-5.1 {Tcl_WrongNumArgs} testindexobj {
|
||||
testwrongnumargs 1 "?option?" mycmd
|
||||
} "wrong # args: should be \"mycmd ?option?\""
|
||||
test indexObj-5.2 {Tcl_WrongNumArgs} testindexobj {
|
||||
testwrongnumargs 2 "bar" mycmd foo
|
||||
} "wrong # args: should be \"mycmd foo bar\""
|
||||
test indexObj-5.3 {Tcl_WrongNumArgs} testindexobj {
|
||||
testwrongnumargs 0 "bar" mycmd foo
|
||||
} "wrong # args: should be \"bar\""
|
||||
test indexObj-5.4 {Tcl_WrongNumArgs} testindexobj {
|
||||
testwrongnumargs 0 "" mycmd foo
|
||||
} "wrong # args: should be \"\""
|
||||
test indexObj-5.5 {Tcl_WrongNumArgs} testindexobj {
|
||||
testwrongnumargs 1 "" mycmd foo
|
||||
} "wrong # args: should be \"mycmd\""
|
||||
test indexObj-5.6 {Tcl_WrongNumArgs} testindexobj {
|
||||
testwrongnumargs 2 "" mycmd foo
|
||||
} "wrong # args: should be \"mycmd foo\""
|
||||
# Contrast this with test proc-3.6; they have to be like this because
|
||||
# of [Bug 1066837] so Itcl won't break.
|
||||
test indexObj-5.7 {Tcl_WrongNumArgs} testindexobj {
|
||||
testwrongnumargs 2 "fee fi" "fo fum" foo bar
|
||||
} "wrong # args: should be \"fo fum foo fee fi\""
|
||||
|
||||
test indexObj-6.1 {Tcl_GetIndexFromObjStruct} testindexobj {
|
||||
set x a
|
||||
testgetindexfromobjstruct $x 0
|
||||
} "wrong # args: should be \"testgetindexfromobjstruct a 0\""
|
||||
test indexObj-6.2 {Tcl_GetIndexFromObjStruct} testindexobj {
|
||||
set x a
|
||||
testgetindexfromobjstruct $x 0
|
||||
testgetindexfromobjstruct $x 0
|
||||
} "wrong # args: should be \"testgetindexfromobjstruct a 0\""
|
||||
test indexObj-6.3 {Tcl_GetIndexFromObjStruct} testindexobj {
|
||||
set x c
|
||||
testgetindexfromobjstruct $x 1
|
||||
} "wrong # args: should be \"testgetindexfromobjstruct c 1\""
|
||||
test indexObj-6.4 {Tcl_GetIndexFromObjStruct} testindexobj {
|
||||
set x c
|
||||
testgetindexfromobjstruct $x 1
|
||||
testgetindexfromobjstruct $x 1
|
||||
} "wrong # args: should be \"testgetindexfromobjstruct c 1\""
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# End:
|
||||
1824
tests/info.test
Normal file
1824
tests/info.test
Normal file
File diff suppressed because it is too large
Load Diff
214
tests/init.test
Normal file
214
tests/init.test
Normal file
@@ -0,0 +1,214 @@
|
||||
# Functionality covered: this file contains a collection of tests for the
|
||||
# auto loading and namespaces.
|
||||
#
|
||||
# Sourcing this file into Tcl runs the tests and generates output for
|
||||
# errors. No output means no errors were found.
|
||||
#
|
||||
# Copyright (c) 1997 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest 2.3.4
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
# Clear out any namespaces called test_ns_*
|
||||
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
||||
|
||||
# Six cases - white box testing
|
||||
|
||||
test init-1.1 {auto_qualify - absolute cmd - namespace} {
|
||||
auto_qualify ::foo::bar ::blue
|
||||
} ::foo::bar
|
||||
|
||||
test init-1.2 {auto_qualify - absolute cmd - global} {
|
||||
auto_qualify ::global ::sub
|
||||
} global
|
||||
|
||||
test init-1.3 {auto_qualify - no colons cmd - global} {
|
||||
auto_qualify nocolons ::
|
||||
} nocolons
|
||||
|
||||
test init-1.4 {auto_qualify - no colons cmd - namespace} {
|
||||
auto_qualify nocolons ::sub
|
||||
} {::sub::nocolons nocolons}
|
||||
|
||||
test init-1.5 {auto_qualify - colons in cmd - global} {
|
||||
auto_qualify foo::bar ::
|
||||
} ::foo::bar
|
||||
|
||||
test init-1.6 {auto_qualify - colons in cmd - namespace} {
|
||||
auto_qualify foo::bar ::sub
|
||||
} {::sub::foo::bar ::foo::bar}
|
||||
|
||||
# Some additional tests
|
||||
|
||||
test init-1.7 {auto_qualify - multiples colons 1} {
|
||||
auto_qualify :::foo::::bar ::blue
|
||||
} ::foo::bar
|
||||
|
||||
test init-1.8 {auto_qualify - multiple colons 2} {
|
||||
auto_qualify :::foo ::bar
|
||||
} foo
|
||||
|
||||
|
||||
# we use a sub interp and auto_reset and double the tests because there is 2
|
||||
# places where auto_loading occur (before loading the indexes files and after)
|
||||
|
||||
set testInterp [interp create]
|
||||
tcltest::loadIntoSlaveInterpreter $testInterp {*}$argv
|
||||
interp eval $testInterp {
|
||||
namespace import -force ::tcltest::*
|
||||
auto_reset
|
||||
catch {rename parray {}}
|
||||
|
||||
test init-2.0 {load parray - stage 1} {
|
||||
set ret [catch {parray} error]
|
||||
rename parray {} ; # remove it, for the next test - that should not fail.
|
||||
list $ret $error
|
||||
} {1 {wrong # args: should be "parray a ?pattern?"}}
|
||||
|
||||
|
||||
test init-2.1 {load parray - stage 2} {
|
||||
set ret [catch {parray} error]
|
||||
list $ret $error
|
||||
} {1 {wrong # args: should be "parray a ?pattern?"}}
|
||||
|
||||
|
||||
auto_reset
|
||||
catch {rename ::safe::setLogCmd {}}
|
||||
#unset auto_index(::safe::setLogCmd)
|
||||
#unset auto_oldpath
|
||||
|
||||
test init-2.2 {load ::safe::setLogCmd - stage 1} {
|
||||
::safe::setLogCmd
|
||||
rename ::safe::setLogCmd {} ; # should not fail
|
||||
} {}
|
||||
|
||||
test init-2.3 {load ::safe::setLogCmd - stage 2} {
|
||||
::safe::setLogCmd
|
||||
rename ::safe::setLogCmd {} ; # should not fail
|
||||
} {}
|
||||
|
||||
auto_reset
|
||||
catch {rename ::safe::setLogCmd {}}
|
||||
|
||||
test init-2.4 {load safe:::setLogCmd - stage 1} {
|
||||
safe:::setLogCmd ; # intentionally 3 :
|
||||
rename ::safe::setLogCmd {} ; # should not fail
|
||||
} {}
|
||||
|
||||
test init-2.5 {load safe:::setLogCmd - stage 2} {
|
||||
safe:::setLogCmd ; # intentionally 3 :
|
||||
rename ::safe::setLogCmd {} ; # should not fail
|
||||
} {}
|
||||
|
||||
auto_reset
|
||||
catch {rename ::safe::setLogCmd {}}
|
||||
|
||||
test init-2.6 {load setLogCmd from safe:: - stage 1} {
|
||||
namespace eval safe setLogCmd
|
||||
rename ::safe::setLogCmd {} ; # should not fail
|
||||
} {}
|
||||
|
||||
test init-2.7 {oad setLogCmd from safe:: - stage 2} {
|
||||
namespace eval safe setLogCmd
|
||||
rename ::safe::setLogCmd {} ; # should not fail
|
||||
} {}
|
||||
|
||||
|
||||
|
||||
test init-2.8 {load tcl::HistAdd} -setup {
|
||||
auto_reset
|
||||
catch {rename ::tcl::HistAdd {}}
|
||||
} -body {
|
||||
# 3 ':' on purpose
|
||||
list [catch {tcl:::HistAdd} error] $error
|
||||
} -cleanup {
|
||||
rename ::tcl::HistAdd {} ;
|
||||
} -result {1 {wrong # args: should be "tcl:::HistAdd command ?exec?"}}
|
||||
|
||||
|
||||
test init-3.0 {random stuff in the auto_index, should still work} {
|
||||
set auto_index(foo:::bar::blah) {
|
||||
namespace eval foo {namespace eval bar {proc blah {} {return 1}}}
|
||||
}
|
||||
foo:::bar::blah
|
||||
} 1
|
||||
|
||||
# Tests that compare the error stack trace generated when autoloading
|
||||
# with that generated when no autoloading is necessary. Ideally they
|
||||
# should be the same.
|
||||
|
||||
set count 0
|
||||
foreach arg [subst -nocommands -novariables {
|
||||
c
|
||||
{argument
|
||||
which spans
|
||||
multiple lines}
|
||||
{argument which is all on one line but which is of such great length that the Tcl C library will truncate it when appending it onto the global error stack}
|
||||
{argument which spans multiple lines
|
||||
and is long enough to be truncated and
|
||||
" <- includes a false lead in the prune point search
|
||||
and must be longer still to force truncation}
|
||||
{contrived example: rare circumstance
|
||||
where the point at which to prune the
|
||||
error stack cannot be uniquely determined.
|
||||
foo bar foo
|
||||
"}
|
||||
{contrived example: rare circumstance
|
||||
where the point at which to prune the
|
||||
error stack cannot be uniquely determined.
|
||||
foo bar
|
||||
"}
|
||||
{argument that contains non-ASCII character, \u20ac, and which is of such great length that it will be longer than 150 bytes so it will be truncated by the Tcl C library}
|
||||
}] { ;# emacs needs -> "
|
||||
|
||||
test init-4.$count.0 {::errorInfo produced by [unknown]} {
|
||||
auto_reset
|
||||
catch {parray a b $arg}
|
||||
set first $::errorInfo
|
||||
catch {parray a b $arg}
|
||||
set second $::errorInfo
|
||||
string equal $first $second
|
||||
} 1
|
||||
|
||||
test init-4.$count.1 {::errorInfo produced by [unknown]} {
|
||||
auto_reset
|
||||
namespace eval junk [list array set $arg [list 1 2 3 4]]
|
||||
trace variable ::junk::$arg r \
|
||||
"[list error [subst {Variable \"$arg\" is write-only}]] ;# "
|
||||
catch {parray ::junk::$arg}
|
||||
set first $::errorInfo
|
||||
catch {parray ::junk::$arg}
|
||||
set second $::errorInfo
|
||||
string equal $first $second
|
||||
} 1
|
||||
|
||||
incr count
|
||||
}
|
||||
|
||||
test init-5.0 {return options passed through ::unknown} -setup {
|
||||
catch {rename xxx {}}
|
||||
set ::auto_index(::xxx) {proc ::xxx {} {
|
||||
return -code error -level 2 xxx
|
||||
}}
|
||||
} -body {
|
||||
set code [catch {::xxx} foo bar]
|
||||
set code2 [catch {::xxx} foo2 bar2]
|
||||
list $code $foo $bar $code2 $foo2 $bar2
|
||||
} -cleanup {
|
||||
unset ::auto_index(::xxx)
|
||||
} -result {2 xxx {-errorcode NONE -code 1 -level 1} 2 xxx {-code 1 -level 1 -errorcode NONE}}
|
||||
|
||||
cleanupTests
|
||||
} ;# End of [interp eval $testInterp]
|
||||
|
||||
# cleanup
|
||||
interp delete $testInterp
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
|
||||
3559
tests/interp.test
Normal file
3559
tests/interp.test
Normal file
File diff suppressed because it is too large
Load Diff
7791
tests/io.test
Normal file
7791
tests/io.test
Normal file
File diff suppressed because it is too large
Load Diff
3553
tests/ioCmd.test
Normal file
3553
tests/ioCmd.test
Normal file
File diff suppressed because it is too large
Load Diff
331
tests/ioUtil.test
Normal file
331
tests/ioUtil.test
Normal file
@@ -0,0 +1,331 @@
|
||||
# This file (ioUtil.test) tests the hookable TclStat(), TclAccess(),
|
||||
# and Tcl_OpenFileChannel, routines in the file generic/tclIOUtils.c.
|
||||
# Sourcing this file into Tcl runs the tests and generates output for
|
||||
# errors. No output means no errors were found.
|
||||
#
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest 2
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
testConstraint testopenfilechannelproc \
|
||||
[llength [info commands testopenfilechannelproc]]
|
||||
testConstraint testaccessproc [llength [info commands testaccessproc]]
|
||||
testConstraint teststatproc [llength [info commands teststatproc]]
|
||||
|
||||
set unsetScript {
|
||||
catch {unset testStat1(size)}
|
||||
catch {unset testStat2(size)}
|
||||
catch {unset testStat3(size)}
|
||||
}
|
||||
|
||||
test ioUtil-1.1 {TclStat: Check that none of the test procs are there.} {} {
|
||||
catch {file stat testStat1%.fil testStat1} err1
|
||||
catch {file stat testStat2%.fil testStat2} err2
|
||||
catch {file stat testStat3%.fil testStat3} err3
|
||||
list $err1 $err2 $err3
|
||||
} {{could not read "testStat1%.fil": no such file or directory} {could not read "testStat2%.fil": no such file or directory} {could not read "testStat3%.fil": no such file or directory}}
|
||||
|
||||
test ioUtil-1.2 {TclStatInsertProc: Insert the 3 test TclStat_ procedures.} {teststatproc} {
|
||||
catch {teststatproc insert TclpStat} err1
|
||||
teststatproc insert TestStatProc1
|
||||
teststatproc insert TestStatProc2
|
||||
teststatproc insert TestStatProc3
|
||||
set err1
|
||||
} {bad arg "insert": must be TestStatProc1, TestStatProc2, or TestStatProc3}
|
||||
|
||||
test ioUtil-1.3 {TclStat: Use "file stat ?" to invoke each procedure.} {teststatproc} {
|
||||
file stat testStat2%.fil testStat2
|
||||
file stat testStat1%.fil testStat1
|
||||
file stat testStat3%.fil testStat3
|
||||
|
||||
list $testStat2(size) $testStat1(size) $testStat3(size)
|
||||
} {2345 1234 3456}
|
||||
|
||||
eval $unsetScript
|
||||
|
||||
test ioUtil-1.4 {TclStatDeleteProc: "TclpStat" function should not be deletable.} {teststatproc} {
|
||||
catch {teststatproc delete TclpStat} err2
|
||||
set err2
|
||||
} {"TclpStat": could not be deleteed}
|
||||
|
||||
test ioUtil-1.5 {TclStatDeleteProc: Delete the 2nd TclStat procedure.} {teststatproc} {
|
||||
# Delete the 2nd procedure and test that it longer exists but that
|
||||
# the others do actually return a result.
|
||||
|
||||
teststatproc delete TestStatProc2
|
||||
file stat testStat1%.fil testStat1
|
||||
catch {file stat testStat2%.fil testStat2} err3
|
||||
file stat testStat3%.fil testStat3
|
||||
|
||||
list $testStat1(size) $err3 $testStat3(size)
|
||||
} {1234 {could not read "testStat2%.fil": no such file or directory} 3456}
|
||||
|
||||
eval $unsetScript
|
||||
|
||||
test ioUtil-1.6 {TclStatDeleteProc: Delete the 1st TclStat procedure.} {teststatproc} {
|
||||
# Next delete the 1st procedure and test that only the 3rd procedure
|
||||
# is the only one that exists.
|
||||
|
||||
teststatproc delete TestStatProc1
|
||||
catch {file stat testStat1%.fil testStat1} err4
|
||||
catch {file stat testStat2%.fil testStat2} err5
|
||||
file stat testStat3%.fil testStat3
|
||||
|
||||
list $err4 $err5 $testStat3(size)
|
||||
} {{could not read "testStat1%.fil": no such file or directory} {could not read "testStat2%.fil": no such file or directory} 3456}
|
||||
|
||||
eval $unsetScript
|
||||
|
||||
test ioUtil-1.7 {TclStatDeleteProc: Delete the 3rd procedure & verify all are gone.} {teststatproc} {
|
||||
# Finally delete the 3rd procedure and check that none of the
|
||||
# procedures exist.
|
||||
|
||||
teststatproc delete TestStatProc3
|
||||
catch {file stat testStat1%.fil testStat1} err6
|
||||
catch {file stat testStat2%.fil testStat2} err7
|
||||
catch {file stat testStat3%.fil testStat3} err8
|
||||
|
||||
list $err6 $err7 $err8
|
||||
} {{could not read "testStat1%.fil": no such file or directory} {could not read "testStat2%.fil": no such file or directory} {could not read "testStat3%.fil": no such file or directory}}
|
||||
|
||||
eval $unsetScript
|
||||
|
||||
test ioUtil-1.8 {TclStatDeleteProc: Verify that all procs have been deleted.} {teststatproc} {
|
||||
# Attempt to delete all the Stat procs. again to ensure they no longer
|
||||
# exist and an error is returned.
|
||||
|
||||
catch {teststatproc delete TestStatProc1} err9
|
||||
catch {teststatproc delete TestStatProc2} err10
|
||||
catch {teststatproc delete TestStatProc3} err11
|
||||
|
||||
list $err9 $err10 $err11
|
||||
} {{"TestStatProc1": could not be deleteed} {"TestStatProc2": could not be deleteed} {"TestStatProc3": could not be deleteed}}
|
||||
|
||||
eval $unsetScript
|
||||
|
||||
test ioUtil-1.9 {TclAccess: Check that none of the test procs are there.} {
|
||||
catch {file exists testAccess1%.fil} err1
|
||||
catch {file exists testAccess2%.fil} err2
|
||||
catch {file exists testAccess3%.fil} err3
|
||||
list $err1 $err2 $err3
|
||||
} {0 0 0}
|
||||
|
||||
test ioUtil-1.10 {TclAccessInsertProc: Insert the 3 test TclAccess_ procedures.} {testaccessproc} {
|
||||
catch {testaccessproc insert TclpAccess} err1
|
||||
testaccessproc insert TestAccessProc1
|
||||
testaccessproc insert TestAccessProc2
|
||||
testaccessproc insert TestAccessProc3
|
||||
set err1
|
||||
} {bad arg "insert": must be TestAccessProc1, TestAccessProc2, or TestAccessProc3}
|
||||
|
||||
test ioUtil-2.3 {TclAccess: Use "file access ?" to invoke each procedure.} {testaccessproc} {
|
||||
list [file exists testAccess2%.fil] \
|
||||
[file exists testAccess1%.fil] \
|
||||
[file exists testAccess3%.fil]
|
||||
} {1 1 1}
|
||||
|
||||
test ioUtil-2.4 {TclAccessDeleteProc: "TclpAccess" function should not be deletable.} {testaccessproc} {
|
||||
catch {testaccessproc delete TclpAccess} err2
|
||||
set err2
|
||||
} {"TclpAccess": could not be deleteed}
|
||||
|
||||
test ioUtil-2.5 {TclAccessDeleteProc: Delete the 2nd TclAccess procedure.} {testaccessproc} {
|
||||
# Delete the 2nd procedure and test that it longer exists but that
|
||||
# the others do actually return a result.
|
||||
|
||||
testaccessproc delete TestAccessProc2
|
||||
set res1 [file exists testAccess1%.fil]
|
||||
catch {file exists testAccess2%.fil} err3
|
||||
set res2 [file exists testAccess3%.fil]
|
||||
|
||||
list $res1 $err3 $res2
|
||||
} {1 0 1}
|
||||
|
||||
test ioUtil-2.6 {TclAccessDeleteProc: Delete the 1st TclAccess procedure.} {testaccessproc} {
|
||||
# Next delete the 1st procedure and test that only the 3rd procedure
|
||||
# is the only one that exists.
|
||||
|
||||
testaccessproc delete TestAccessProc1
|
||||
catch {file exists testAccess1%.fil} err4
|
||||
catch {file exists testAccess2%.fil} err5
|
||||
set res3 [file exists testAccess3%.fil]
|
||||
|
||||
list $err4 $err5 $res3
|
||||
} {0 0 1}
|
||||
|
||||
test ioUtil-2.7 {TclAccessDeleteProc: Delete the 3rd procedure & verify all are gone.} {testaccessproc} {
|
||||
# Finally delete the 3rd procedure and check that none of the
|
||||
# procedures exist.
|
||||
|
||||
testaccessproc delete TestAccessProc3
|
||||
catch {file exists testAccess1%.fil} err6
|
||||
catch {file exists testAccess2%.fil} err7
|
||||
catch {file exists testAccess3%.fil} err8
|
||||
|
||||
list $err6 $err7 $err8
|
||||
} {0 0 0}
|
||||
|
||||
test ioUtil-2.8 {TclAccessDeleteProc: Verify that all procs have been deleted.} {testaccessproc} {
|
||||
# Attempt to delete all the Access procs. again to ensure they no longer
|
||||
# exist and an error is returned.
|
||||
|
||||
catch {testaccessproc delete TestAccessProc1} err9
|
||||
catch {testaccessproc delete TestAccessProc2} err10
|
||||
catch {testaccessproc delete TestAccessProc3} err11
|
||||
|
||||
list $err9 $err10 $err11
|
||||
} {{"TestAccessProc1": could not be deleteed} {"TestAccessProc2": could not be deleteed} {"TestAccessProc3": could not be deleteed}}
|
||||
|
||||
# Some of the following tests require a writable current directory
|
||||
set oldpwd [pwd]
|
||||
cd [temporaryDirectory]
|
||||
|
||||
test ioUtil-3.1 {TclOpenFileChannel: Check that none of the test procs are there.} {testopenfilechannelproc} {
|
||||
catch {file delete -force {*}[glob *testOpenFileChannel*]}
|
||||
catch {file exists testOpenFileChannel1%.fil} err1
|
||||
catch {file exists testOpenFileChannel2%.fil} err2
|
||||
catch {file exists testOpenFileChannel3%.fil} err3
|
||||
catch {file exists __testOpenFileChannel1%__.fil} err4
|
||||
catch {file exists __testOpenFileChannel2%__.fil} err5
|
||||
catch {file exists __testOpenFileChannel3%__.fil} err6
|
||||
list $err1 $err2 $err3 $err4 $err5 $err6
|
||||
} {0 0 0 0 0 0}
|
||||
|
||||
test ioUtil-3.2 {TclOpenFileChannelInsertProc: Insert the 3 test TclOpenFileChannel_ procedures.} {testopenfilechannelproc} {
|
||||
catch {testopenfilechannelproc insert TclpOpenFileChannel} err1
|
||||
testopenfilechannelproc insert TestOpenFileChannelProc1
|
||||
testopenfilechannelproc insert TestOpenFileChannelProc2
|
||||
testopenfilechannelproc insert TestOpenFileChannelProc3
|
||||
set err1
|
||||
} {bad arg "insert": must be TestOpenFileChannelProc1, TestOpenFileChannelProc2, or TestOpenFileChannelProc3}
|
||||
|
||||
test ioUtil-3.3 {TclOpenFileChannel: Use "file openfilechannel ?" to invoke each procedure.} {testopenfilechannelproc} {
|
||||
close [open __testOpenFileChannel1%__.fil w]
|
||||
close [open __testOpenFileChannel2%__.fil w]
|
||||
close [open __testOpenFileChannel3%__.fil w]
|
||||
|
||||
catch {
|
||||
close [open testOpenFileChannel1%.fil r]
|
||||
close [open testOpenFileChannel2%.fil r]
|
||||
close [open testOpenFileChannel3%.fil r]
|
||||
} err
|
||||
|
||||
file delete __testOpenFileChannel1%__.fil
|
||||
file delete __testOpenFileChannel2%__.fil
|
||||
file delete __testOpenFileChannel3%__.fil
|
||||
|
||||
set err
|
||||
} {}
|
||||
|
||||
test ioUtil-3.4 {TclOpenFileChannelDeleteProc: "TclpOpenFileChannel" function should not be deletable.} {testopenfilechannelproc} {
|
||||
catch {testopenfilechannelproc delete TclpOpenFileChannel} err2
|
||||
set err2
|
||||
} {"TclpOpenFileChannel": could not be deleteed}
|
||||
|
||||
test ioUtil-3.5 {TclOpenFileChannelDeleteProc: Delete the 2nd TclOpenFileChannel procedure.} {testopenfilechannelproc} {
|
||||
# Delete the 2nd procedure and test that it longer exists but that
|
||||
# the others do actually return a result.
|
||||
|
||||
testopenfilechannelproc delete TestOpenFileChannelProc2
|
||||
|
||||
close [open __testOpenFileChannel1%__.fil w]
|
||||
close [open __testOpenFileChannel3%__.fil w]
|
||||
|
||||
catch {
|
||||
close [open testOpenFileChannel1%.fil r]
|
||||
catch {close [open testOpenFileChannel2%.fil r]} msg1
|
||||
close [open testOpenFileChannel3%.fil r]
|
||||
} err3
|
||||
|
||||
file delete __testOpenFileChannel1%__.fil
|
||||
file delete __testOpenFileChannel3%__.fil
|
||||
|
||||
list $err3 $msg1
|
||||
} {{} {couldn't open "testOpenFileChannel2%.fil": no such file or directory}}
|
||||
|
||||
test ioUtil-3.6 {TclOpenFileChannelDeleteProc: Delete the 1st TclOpenFileChannel procedure.} {testopenfilechannelproc} {
|
||||
# Next delete the 1st procedure and test that only the 3rd procedure
|
||||
# is the only one that exists.
|
||||
|
||||
testopenfilechannelproc delete TestOpenFileChannelProc1
|
||||
|
||||
close [open __testOpenFileChannel3%__.fil w]
|
||||
|
||||
catch {
|
||||
catch {close [open testOpenFileChannel1%.fil r]} msg2
|
||||
catch {close [open testOpenFileChannel2%.fil r]} msg3
|
||||
close [open testOpenFileChannel3%.fil r]
|
||||
} err4
|
||||
|
||||
file delete __testOpenFileChannel3%__.fil
|
||||
|
||||
list $err4 $msg2 $msg3
|
||||
} [list {} \
|
||||
{couldn't open "testOpenFileChannel1%.fil": no such file or directory}\
|
||||
{couldn't open "testOpenFileChannel2%.fil": no such file or directory}]
|
||||
|
||||
test ioUtil-3.7 {TclOpenFileChannelDeleteProc: Delete the 3rd procedure & verify all are gone.} {testopenfilechannelproc} {
|
||||
# Finally delete the 3rd procedure and check that none of the
|
||||
# procedures exist.
|
||||
|
||||
testopenfilechannelproc delete TestOpenFileChannelProc3
|
||||
catch {
|
||||
catch {close [open testOpenFileChannel1%.fil r]} msg4
|
||||
catch {close [open testOpenFileChannel2%.fil r]} msg5
|
||||
catch {close [open testOpenFileChannel3%.fil r]} msg6
|
||||
} err5
|
||||
|
||||
list $err5 $msg4 $msg5 $msg6
|
||||
} [list 1 \
|
||||
{couldn't open "testOpenFileChannel1%.fil": no such file or directory}\
|
||||
{couldn't open "testOpenFileChannel2%.fil": no such file or directory}\
|
||||
{couldn't open "testOpenFileChannel3%.fil": no such file or directory}]
|
||||
|
||||
test ioUtil-3.8 {TclOpenFileChannelDeleteProc: Verify that all procs have been deleted.} {testopenfilechannelproc} {
|
||||
|
||||
# Attempt to delete all the OpenFileChannel procs. again to ensure they no
|
||||
# longer exist and an error is returned.
|
||||
|
||||
catch {testopenfilechannelproc delete TestOpenFileChannelProc1} err9
|
||||
catch {testopenfilechannelproc delete TestOpenFileChannelProc2} err10
|
||||
catch {testopenfilechannelproc delete TestOpenFileChannelProc3} err11
|
||||
|
||||
list $err9 $err10 $err11
|
||||
} {{"TestOpenFileChannelProc1": could not be deleteed} {"TestOpenFileChannelProc2": could not be deleteed} {"TestOpenFileChannelProc3": could not be deleteed}}
|
||||
|
||||
test ioUtil-4.1 {open ... a+ must not use O_APPEND: Bug 1773127} -setup {
|
||||
set f [tcltest::makeFile {} ioutil41.tmp]
|
||||
set fid [open $f wb]
|
||||
puts -nonewline $fid 123
|
||||
close $fid
|
||||
} -body {
|
||||
set fid [open $f ab+]
|
||||
puts -nonewline $fid 456
|
||||
seek $fid 2
|
||||
set d [read $fid 2]
|
||||
seek $fid 4
|
||||
puts -nonewline $fid x
|
||||
close $fid
|
||||
set fid [open $f rb]
|
||||
append d [read $fid]
|
||||
close $fid
|
||||
return $d
|
||||
} -cleanup {
|
||||
tcltest::removeFile $f
|
||||
} -result 341234x6
|
||||
|
||||
cd $oldpwd
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# End:
|
||||
941
tests/iogt.test
Normal file
941
tests/iogt.test
Normal file
@@ -0,0 +1,941 @@
|
||||
# -*- tcl -*-
|
||||
# Commands covered: transform, and stacking in general
|
||||
#
|
||||
# This file contains a collection of tests for Giot
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
#
|
||||
# Copyright (c) 2000 Ajuba Solutions.
|
||||
# Copyright (c) 2000 Andreas Kupries.
|
||||
# All rights reserved.
|
||||
|
||||
if {[catch {package require tcltest 2.1}]} {
|
||||
puts stderr "Skipping tests in [info script]. tcltest 2.1 required."
|
||||
return
|
||||
}
|
||||
namespace eval ::tcl::test::iogt {
|
||||
namespace import ::tcltest::*
|
||||
|
||||
testConstraint testchannel [llength [info commands testchannel]]
|
||||
|
||||
set path(dummy) [makeFile {abcdefghijklmnopqrstuvwxyz0123456789,./?><;'\|":[]\}\{`~!@#$%^&*()_+-=
|
||||
} dummy]
|
||||
|
||||
# " capture coloring of quotes
|
||||
|
||||
set path(dummyout) [makeFile {} dummyout]
|
||||
|
||||
set path(__echo_srv__.tcl) [makeFile {
|
||||
#!/usr/local/bin/tclsh
|
||||
# -*- tcl -*-
|
||||
# echo server
|
||||
#
|
||||
# arguments, options: port to listen on for connections.
|
||||
# delay till echo of first block
|
||||
# delay between blocks
|
||||
# blocksize ...
|
||||
|
||||
set port [lindex $argv 0]
|
||||
set fdelay [lindex $argv 1]
|
||||
set idelay [lindex $argv 2]
|
||||
set bsizes [lrange $argv 3 end]
|
||||
set c 0
|
||||
|
||||
proc newconn {sock rhost rport} {
|
||||
variable fdelay
|
||||
variable c
|
||||
incr c
|
||||
variable c$c
|
||||
|
||||
#puts stdout "C $sock $rhost $rport / $fdelay" ; flush stdout
|
||||
|
||||
upvar 0 c$c conn
|
||||
set conn(after) {}
|
||||
set conn(state) 0
|
||||
set conn(size) 0
|
||||
set conn(data) ""
|
||||
set conn(delay) $fdelay
|
||||
|
||||
fileevent $sock readable [list echoGet $c $sock]
|
||||
fconfigure $sock -translation binary -buffering none -blocking 0
|
||||
}
|
||||
|
||||
proc echoGet {c sock} {
|
||||
variable fdelay
|
||||
variable c$c
|
||||
upvar 0 c$c conn
|
||||
|
||||
if {[eof $sock]} {
|
||||
# one-shot echo
|
||||
exit
|
||||
}
|
||||
|
||||
append conn(data) [read $sock]
|
||||
|
||||
#puts stdout "G $c $sock $conn(data) <<$conn(data)>>" ; flush stdout
|
||||
|
||||
if {$conn(after) == {}} {
|
||||
set conn(after) [after $conn(delay) [list echoPut $c $sock]]
|
||||
}
|
||||
}
|
||||
|
||||
proc echoPut {c sock} {
|
||||
variable idelay
|
||||
variable fdelay
|
||||
variable bsizes
|
||||
variable c$c
|
||||
upvar 0 c$c conn
|
||||
|
||||
if {[string length $conn(data)] == 0} {
|
||||
#puts stdout "C $c $sock" ; flush stdout
|
||||
# auto terminate
|
||||
close $sock
|
||||
exit
|
||||
#set conn(delay) $fdelay
|
||||
return
|
||||
}
|
||||
|
||||
|
||||
set conn(delay) $idelay
|
||||
|
||||
set n [lindex $bsizes $conn(size)]
|
||||
|
||||
#puts stdout "P $c $sock $n >>" ; flush stdout
|
||||
|
||||
#puts __________________________________________
|
||||
#parray conn
|
||||
#puts n=<$n>
|
||||
|
||||
|
||||
if {[string length $conn(data)] >= $n} {
|
||||
puts -nonewline $sock [string range $conn(data) 0 $n]
|
||||
set conn(data) [string range $conn(data) [incr n] end]
|
||||
}
|
||||
|
||||
incr conn(size)
|
||||
if {$conn(size) >= [llength $bsizes]} {
|
||||
set conn(size) [expr {[llength $bsizes]-1}]
|
||||
}
|
||||
|
||||
set conn(after) [after $conn(delay) [list echoPut $c $sock]]
|
||||
}
|
||||
|
||||
#fileevent stdin readable {exit ;#cut}
|
||||
|
||||
# main
|
||||
socket -server newconn -myaddr 127.0.0.1 $port
|
||||
vwait forever
|
||||
} __echo_srv__.tcl]
|
||||
|
||||
|
||||
########################################################################
|
||||
|
||||
proc fevent {fdelay idelay blocks script data} {
|
||||
# start and initialize an echo server, prepare data
|
||||
# transmission, then hand over to the test script.
|
||||
# this has to start real transmission via 'flush'.
|
||||
# The server is stopped after completion of the test.
|
||||
|
||||
# fixed port, not so good. lets hope for the best, for now.
|
||||
set port 4000
|
||||
|
||||
exec tclsh __echo_srv__.tcl \
|
||||
$port $fdelay $idelay {*}$blocks >@stdout &
|
||||
|
||||
after 500
|
||||
|
||||
#puts stdout "> $port" ; flush stdout
|
||||
|
||||
set sk [socket localhost $port]
|
||||
fconfigure $sk \
|
||||
-blocking 0 \
|
||||
-buffering full \
|
||||
-buffersize [expr {10+[llength $data]}]
|
||||
|
||||
puts -nonewline $sk $data
|
||||
|
||||
# The channel is prepared to go off.
|
||||
|
||||
#puts stdout ">>>>>" ; flush stdout
|
||||
|
||||
uplevel #0 set sock $sk
|
||||
set res [uplevel #0 $script]
|
||||
|
||||
catch {close $sk}
|
||||
return $res
|
||||
}
|
||||
|
||||
# --------------------------------------------------------------
|
||||
# utility transformations ...
|
||||
|
||||
proc id {op data} {
|
||||
switch -- $op {
|
||||
create/write -
|
||||
create/read -
|
||||
delete/write -
|
||||
delete/read -
|
||||
clear_read {;#ignore}
|
||||
flush/write -
|
||||
flush/read -
|
||||
write -
|
||||
read {
|
||||
return $data
|
||||
}
|
||||
query/maxRead {return -1}
|
||||
}
|
||||
}
|
||||
|
||||
proc id_optrail {var op data} {
|
||||
variable $var
|
||||
upvar 0 $var trail
|
||||
|
||||
lappend trail $op
|
||||
|
||||
switch -- $op {
|
||||
create/write - create/read -
|
||||
delete/write - delete/read -
|
||||
flush/read -
|
||||
clear/read { #ignore }
|
||||
flush/write -
|
||||
write -
|
||||
read {
|
||||
return $data
|
||||
}
|
||||
query/maxRead {
|
||||
return -1
|
||||
}
|
||||
default {
|
||||
lappend trail "error $op"
|
||||
error $op
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
proc id_fulltrail {var op data} {
|
||||
variable $var
|
||||
upvar 0 $var trail
|
||||
|
||||
#puts stdout ">> $var $op $data" ; flush stdout
|
||||
|
||||
switch -- $op {
|
||||
create/write - create/read -
|
||||
delete/write - delete/read -
|
||||
clear_read {
|
||||
set res *ignored*
|
||||
}
|
||||
flush/write - flush/read -
|
||||
write -
|
||||
read {
|
||||
set res $data
|
||||
}
|
||||
query/maxRead {
|
||||
set res -1
|
||||
}
|
||||
}
|
||||
|
||||
#catch {puts stdout "\t>* $res" ; flush stdout}
|
||||
#catch {puts stdout "x$res"} msg
|
||||
|
||||
lappend trail [list $op $data $res]
|
||||
return $res
|
||||
}
|
||||
|
||||
proc counter {var op data} {
|
||||
variable $var
|
||||
upvar 0 $var n
|
||||
|
||||
switch -- $op {
|
||||
create/write - create/read -
|
||||
delete/write - delete/read -
|
||||
clear_read {;#ignore}
|
||||
flush/write - flush/read {return {}}
|
||||
write {
|
||||
return $data
|
||||
}
|
||||
read {
|
||||
if {$n > 0} {
|
||||
incr n -[string length $data]
|
||||
if {$n < 0} {
|
||||
set n 0
|
||||
}
|
||||
}
|
||||
return $data
|
||||
}
|
||||
query/maxRead {
|
||||
return $n
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
proc counter_audit {var vtrail op data} {
|
||||
variable $var
|
||||
variable $vtrail
|
||||
upvar 0 $var n $vtrail trail
|
||||
|
||||
switch -- $op {
|
||||
create/write - create/read -
|
||||
delete/write - delete/read -
|
||||
clear_read {
|
||||
set res {}
|
||||
}
|
||||
flush/write - flush/read {
|
||||
set res {}
|
||||
}
|
||||
write {
|
||||
set res $data
|
||||
}
|
||||
read {
|
||||
if {$n > 0} {
|
||||
incr n -[string length $data]
|
||||
if {$n < 0} {
|
||||
set n 0
|
||||
}
|
||||
}
|
||||
set res $data
|
||||
}
|
||||
query/maxRead {
|
||||
set res $n
|
||||
}
|
||||
}
|
||||
|
||||
lappend trail [list counter:$op $data $res]
|
||||
return $res
|
||||
}
|
||||
|
||||
|
||||
proc rblocks {var vtrail n op data} {
|
||||
variable $var
|
||||
variable $vtrail
|
||||
upvar 0 $var buf $vtrail trail
|
||||
|
||||
set res {}
|
||||
|
||||
switch -- $op {
|
||||
create/write - create/read -
|
||||
delete/write - delete/read -
|
||||
clear_read {
|
||||
set buf {}
|
||||
}
|
||||
flush/write {
|
||||
}
|
||||
flush/read {
|
||||
set res $buf
|
||||
set buf {}
|
||||
}
|
||||
write {
|
||||
set data
|
||||
}
|
||||
read {
|
||||
append buf $data
|
||||
|
||||
set b [expr {$n * ([string length $buf] / $n)}]
|
||||
|
||||
append op " $n [string length $buf] :- $b"
|
||||
|
||||
set res [string range $buf 0 [incr b -1]]
|
||||
set buf [string range $buf [incr b] end]
|
||||
#return $res
|
||||
}
|
||||
query/maxRead {
|
||||
set res -1
|
||||
}
|
||||
}
|
||||
|
||||
lappend trail [list rblock | $op $data $res | $buf]
|
||||
return $res
|
||||
}
|
||||
|
||||
|
||||
# --------------------------------------------------------------
|
||||
# ... and convenience procedures to stack them
|
||||
|
||||
proc identity {-attach channel} {
|
||||
testchannel transform $channel -command [namespace code id]
|
||||
}
|
||||
|
||||
proc audit_ops {var -attach channel} {
|
||||
testchannel transform $channel -command [namespace code [list id_optrail $var]]
|
||||
}
|
||||
|
||||
proc audit_flow {var -attach channel} {
|
||||
testchannel transform $channel -command [namespace code [list id_fulltrail $var]]
|
||||
}
|
||||
|
||||
proc stopafter {var n -attach channel} {
|
||||
variable $var
|
||||
upvar 0 $var vn
|
||||
set vn $n
|
||||
testchannel transform $channel -command [namespace code [list counter $var]]
|
||||
}
|
||||
|
||||
proc stopafter_audit {var trail n -attach channel} {
|
||||
variable $var
|
||||
upvar 0 $var vn
|
||||
set vn $n
|
||||
testchannel transform $channel -command [namespace code [list counter_audit $var $trail]]
|
||||
}
|
||||
|
||||
proc rblocks_t {var trail n -attach channel} {
|
||||
testchannel transform $channel -command [namespace code [list rblocks $var $trail $n]]
|
||||
}
|
||||
|
||||
# --------------------------------------------------------------
|
||||
# serialize an array, with keys in sorted order.
|
||||
|
||||
proc array_sget {v} {
|
||||
upvar $v a
|
||||
|
||||
set res [list]
|
||||
foreach n [lsort [array names a]] {
|
||||
lappend res $n $a($n)
|
||||
}
|
||||
set res
|
||||
}
|
||||
|
||||
proc asort {alist} {
|
||||
# sort a list of key/value pairs by key, removes duplicates too.
|
||||
|
||||
array set a $alist
|
||||
array_sget a
|
||||
}
|
||||
|
||||
########################################################################
|
||||
|
||||
test iogt-1.1 {stack/unstack} testchannel {
|
||||
set fh [open $path(dummy) r]
|
||||
identity -attach $fh
|
||||
testchannel unstack $fh
|
||||
close $fh
|
||||
} {}
|
||||
|
||||
test iogt-1.2 {stack/close} testchannel {
|
||||
set fh [open $path(dummy) r]
|
||||
identity -attach $fh
|
||||
close $fh
|
||||
} {}
|
||||
|
||||
test iogt-1.3 {stack/unstack, configuration, options} testchannel {
|
||||
set fh [open $path(dummy) r]
|
||||
set ca [asort [fconfigure $fh]]
|
||||
identity -attach $fh
|
||||
set cb [asort [fconfigure $fh]]
|
||||
testchannel unstack $fh
|
||||
set cc [asort [fconfigure $fh]]
|
||||
close $fh
|
||||
|
||||
# With this system none of the buffering, translation and
|
||||
# encoding option may change their values with channels
|
||||
# stacked upon each other or not.
|
||||
|
||||
# cb == ca == cc
|
||||
|
||||
list [string equal $ca $cb] [string equal $cb $cc] [string equal $ca $cc]
|
||||
} {1 1 1}
|
||||
|
||||
test iogt-1.4 {stack/unstack, configuration} testchannel {
|
||||
set fh [open $path(dummy) r]
|
||||
set ca [asort [fconfigure $fh]]
|
||||
identity -attach $fh
|
||||
fconfigure $fh \
|
||||
-buffering line \
|
||||
-translation cr \
|
||||
-encoding shiftjis
|
||||
testchannel unstack $fh
|
||||
set cc [asort [fconfigure $fh]]
|
||||
|
||||
set res [list \
|
||||
[string equal $ca $cc] \
|
||||
[fconfigure $fh -buffering] \
|
||||
[fconfigure $fh -translation] \
|
||||
[fconfigure $fh -encoding] \
|
||||
]
|
||||
|
||||
close $fh
|
||||
set res
|
||||
} {0 line cr shiftjis}
|
||||
|
||||
test iogt-2.0 {basic I/O going through transform} testchannel {
|
||||
set fin [open $path(dummy) r]
|
||||
set fout [open $path(dummyout) w]
|
||||
|
||||
identity -attach $fin
|
||||
identity -attach $fout
|
||||
|
||||
fcopy $fin $fout
|
||||
|
||||
close $fin
|
||||
close $fout
|
||||
|
||||
set fin [open $path(dummy) r]
|
||||
set fout [open $path(dummyout) r]
|
||||
|
||||
set res [string equal [set in [read $fin]] [set out [read $fout]]]
|
||||
lappend res [string length $in] [string length $out]
|
||||
|
||||
close $fin
|
||||
close $fout
|
||||
|
||||
set res
|
||||
} {1 71 71}
|
||||
|
||||
|
||||
test iogt-2.1 {basic I/O, operation trail} {testchannel unix} {
|
||||
set fin [open $path(dummy) r]
|
||||
set fout [open $path(dummyout) w]
|
||||
|
||||
set ain [list] ; set aout [list]
|
||||
audit_ops ain -attach $fin
|
||||
audit_ops aout -attach $fout
|
||||
|
||||
fconfigure $fin -buffersize 10
|
||||
fconfigure $fout -buffersize 10
|
||||
|
||||
fcopy $fin $fout
|
||||
|
||||
close $fin
|
||||
close $fout
|
||||
|
||||
set res "[join $ain \n]\n--------\n[join $aout \n]"
|
||||
} {create/read
|
||||
query/maxRead
|
||||
read
|
||||
query/maxRead
|
||||
read
|
||||
query/maxRead
|
||||
read
|
||||
query/maxRead
|
||||
read
|
||||
query/maxRead
|
||||
read
|
||||
query/maxRead
|
||||
read
|
||||
query/maxRead
|
||||
read
|
||||
query/maxRead
|
||||
read
|
||||
query/maxRead
|
||||
flush/read
|
||||
delete/read
|
||||
--------
|
||||
create/write
|
||||
write
|
||||
write
|
||||
write
|
||||
write
|
||||
write
|
||||
write
|
||||
write
|
||||
write
|
||||
flush/write
|
||||
delete/write}
|
||||
|
||||
test iogt-2.2 {basic I/O, data trail} {testchannel unix} {
|
||||
set fin [open $path(dummy) r]
|
||||
set fout [open $path(dummyout) w]
|
||||
|
||||
set ain [list] ; set aout [list]
|
||||
audit_flow ain -attach $fin
|
||||
audit_flow aout -attach $fout
|
||||
|
||||
fconfigure $fin -buffersize 10
|
||||
fconfigure $fout -buffersize 10
|
||||
|
||||
fcopy $fin $fout
|
||||
|
||||
close $fin
|
||||
close $fout
|
||||
|
||||
set res "[join $ain \n]\n--------\n[join $aout \n]"
|
||||
} {create/read {} *ignored*
|
||||
query/maxRead {} -1
|
||||
read abcdefghij abcdefghij
|
||||
query/maxRead {} -1
|
||||
read klmnopqrst klmnopqrst
|
||||
query/maxRead {} -1
|
||||
read uvwxyz0123 uvwxyz0123
|
||||
query/maxRead {} -1
|
||||
read 456789,./? 456789,./?
|
||||
query/maxRead {} -1
|
||||
read {><;'\|":[]} {><;'\|":[]}
|
||||
query/maxRead {} -1
|
||||
read {\}\{`~!@#$} {\}\{`~!@#$}
|
||||
query/maxRead {} -1
|
||||
read %^&*()_+-= %^&*()_+-=
|
||||
query/maxRead {} -1
|
||||
read {
|
||||
} {
|
||||
}
|
||||
query/maxRead {} -1
|
||||
flush/read {} {}
|
||||
delete/read {} *ignored*
|
||||
--------
|
||||
create/write {} *ignored*
|
||||
write abcdefghij abcdefghij
|
||||
write klmnopqrst klmnopqrst
|
||||
write uvwxyz0123 uvwxyz0123
|
||||
write 456789,./? 456789,./?
|
||||
write {><;'\|":[]} {><;'\|":[]}
|
||||
write {\}\{`~!@#$} {\}\{`~!@#$}
|
||||
write %^&*()_+-= %^&*()_+-=
|
||||
write {
|
||||
} {
|
||||
}
|
||||
flush/write {} {}
|
||||
delete/write {} *ignored*}
|
||||
|
||||
|
||||
test iogt-2.3 {basic I/O, mixed trail} {testchannel unix} {
|
||||
set fin [open $path(dummy) r]
|
||||
set fout [open $path(dummyout) w]
|
||||
|
||||
set trail [list]
|
||||
audit_flow trail -attach $fin
|
||||
audit_flow trail -attach $fout
|
||||
|
||||
fconfigure $fin -buffersize 20
|
||||
fconfigure $fout -buffersize 10
|
||||
|
||||
fcopy $fin $fout
|
||||
|
||||
close $fin
|
||||
close $fout
|
||||
|
||||
join $trail \n
|
||||
} {create/read {} *ignored*
|
||||
create/write {} *ignored*
|
||||
query/maxRead {} -1
|
||||
read abcdefghijklmnopqrst abcdefghijklmnopqrst
|
||||
write abcdefghij abcdefghij
|
||||
write klmnopqrst klmnopqrst
|
||||
query/maxRead {} -1
|
||||
read uvwxyz0123456789,./? uvwxyz0123456789,./?
|
||||
write uvwxyz0123 uvwxyz0123
|
||||
write 456789,./? 456789,./?
|
||||
query/maxRead {} -1
|
||||
read {><;'\|":[]\}\{`~!@#$} {><;'\|":[]\}\{`~!@#$}
|
||||
write {><;'\|":[]} {><;'\|":[]}
|
||||
write {\}\{`~!@#$} {\}\{`~!@#$}
|
||||
query/maxRead {} -1
|
||||
read {%^&*()_+-=
|
||||
} {%^&*()_+-=
|
||||
}
|
||||
query/maxRead {} -1
|
||||
flush/read {} {}
|
||||
write %^&*()_+-= %^&*()_+-=
|
||||
write {
|
||||
} {
|
||||
}
|
||||
delete/read {} *ignored*
|
||||
flush/write {} {}
|
||||
delete/write {} *ignored*}
|
||||
|
||||
|
||||
test iogt-3.0 {Tcl_Channel valid after stack/unstack, fevent handling} \
|
||||
{testchannel unknownFailure} {
|
||||
# This test to check the validity of aquired Tcl_Channel references is
|
||||
# not possible because even a backgrounded fcopy will immediately start
|
||||
# to copy data, without waiting for the event loop. This is done only in
|
||||
# case of an underflow on the read size!. So stacking transforms after the
|
||||
# fcopy will miss information, or are not used at all.
|
||||
#
|
||||
# I was able to circumvent this by using the echo.tcl server with a big
|
||||
# delay, causing the fcopy to underflow immediately.
|
||||
|
||||
proc DoneCopy {n {err {}}} {
|
||||
variable copy ; set copy 1
|
||||
}
|
||||
|
||||
set fin [open $path(dummy) r]
|
||||
|
||||
fevent 1000 500 {20 20 20 10 1 1} {
|
||||
close $fin
|
||||
|
||||
set fout [open dummyout w]
|
||||
|
||||
flush $sock ; # now, or fcopy will error us out
|
||||
# But the 1 second delay should be enough to
|
||||
# initialize everything else here.
|
||||
|
||||
fcopy $sock $fout -command [namespace code DoneCopy]
|
||||
|
||||
# transform after fcopy got its handles !
|
||||
# They should be still valid for fcopy.
|
||||
|
||||
set trail [list]
|
||||
audit_ops trail -attach $fout
|
||||
|
||||
vwait [namespace which -variable copy]
|
||||
} [read $fin] ; # {}
|
||||
|
||||
close $fout
|
||||
|
||||
rename DoneCopy {}
|
||||
|
||||
# Check result of copy.
|
||||
|
||||
set fin [open $path(dummy) r]
|
||||
set fout [open $path(dummyout) r]
|
||||
|
||||
set res [string equal [read $fin] [read $fout]]
|
||||
|
||||
close $fin
|
||||
close $fout
|
||||
|
||||
list $res $trail
|
||||
} {1 {create/write create/read write flush/write flush/read delete/write delete/read}}
|
||||
|
||||
|
||||
test iogt-4.0 {fileevent readable, after transform} {testchannel unknownFailure} {
|
||||
set fin [open $path(dummy) r]
|
||||
set data [read $fin]
|
||||
close $fin
|
||||
|
||||
set trail [list]
|
||||
set got [list]
|
||||
|
||||
proc Done {args} {
|
||||
variable stop
|
||||
set stop 1
|
||||
}
|
||||
|
||||
proc Get {sock} {
|
||||
variable trail
|
||||
variable got
|
||||
if {[eof $sock]} {
|
||||
Done
|
||||
lappend trail "xxxxxxxxxxxxx"
|
||||
close $sock
|
||||
return
|
||||
}
|
||||
lappend trail "vvvvvvvvvvvvv"
|
||||
lappend trail "\tgot: [lappend got "\[\[[read $sock]\]\]"]"
|
||||
lappend trail "============="
|
||||
#puts stdout $__ ; flush stdout
|
||||
#read $sock
|
||||
}
|
||||
|
||||
fevent 1000 500 {20 20 20 10 1} {
|
||||
audit_flow trail -attach $sock
|
||||
rblocks_t rbuf trail 23 -attach $sock
|
||||
|
||||
fileevent $sock readable [list Get $sock]
|
||||
|
||||
flush $sock ; # now, or fcopy will error us out
|
||||
# But the 1 second delay should be enough to
|
||||
# initialize everything else here.
|
||||
|
||||
vwait [namespace which -variable stop]
|
||||
} $data
|
||||
|
||||
|
||||
rename Done {}
|
||||
rename Get {}
|
||||
|
||||
join [list [join $got \n] ~~~~~~~~ [join $trail \n]] \n
|
||||
} {[[]]
|
||||
[[abcdefghijklmnopqrstuvw]]
|
||||
[[xyz0123456789,./?><;'\|]]
|
||||
[[]]
|
||||
[[]]
|
||||
[[":[]\}\{`~!@#$%^&*()]]
|
||||
[[]]
|
||||
~~~~~~~~
|
||||
create/write {} *ignored*
|
||||
create/read {} *ignored*
|
||||
rblock | create/write {} {} | {}
|
||||
rblock | create/read {} {} | {}
|
||||
vvvvvvvvvvvvv
|
||||
rblock | query/maxRead {} -1 | {}
|
||||
query/maxRead {} -1
|
||||
read abcdefghijklmnopqrstu abcdefghijklmnopqrstu
|
||||
query/maxRead {} -1
|
||||
rblock | {read 23 21 :- 0} abcdefghijklmnopqrstu {} | abcdefghijklmnopqrstu
|
||||
rblock | query/maxRead {} -1 | abcdefghijklmnopqrstu
|
||||
query/maxRead {} -1
|
||||
got: {[[]]}
|
||||
=============
|
||||
vvvvvvvvvvvvv
|
||||
rblock | query/maxRead {} -1 | abcdefghijklmnopqrstu
|
||||
query/maxRead {} -1
|
||||
read vwxyz0123456789,./?>< vwxyz0123456789,./?><
|
||||
query/maxRead {} -1
|
||||
rblock | {read 23 42 :- 23} vwxyz0123456789,./?>< abcdefghijklmnopqrstuvw | xyz0123456789,./?><
|
||||
rblock | query/maxRead {} -1 | xyz0123456789,./?><
|
||||
query/maxRead {} -1
|
||||
got: {[[]]} {[[abcdefghijklmnopqrstuvw]]}
|
||||
=============
|
||||
vvvvvvvvvvvvv
|
||||
rblock | query/maxRead {} -1 | xyz0123456789,./?><
|
||||
query/maxRead {} -1
|
||||
read {;'\|":[]\}\{`~!@#$%^&} {;'\|":[]\}\{`~!@#$%^&}
|
||||
query/maxRead {} -1
|
||||
rblock | {read 23 40 :- 23} {;'\|":[]\}\{`~!@#$%^&} {xyz0123456789,./?><;'\|} | {":[]\}\{`~!@#$%^&}
|
||||
rblock | query/maxRead {} -1 | {":[]\}\{`~!@#$%^&}
|
||||
query/maxRead {} -1
|
||||
got: {[[]]} {[[abcdefghijklmnopqrstuvw]]} {[[xyz0123456789,./?><;'\|]]}
|
||||
=============
|
||||
vvvvvvvvvvvvv
|
||||
rblock | query/maxRead {} -1 | {":[]\}\{`~!@#$%^&}
|
||||
query/maxRead {} -1
|
||||
read *( *(
|
||||
query/maxRead {} -1
|
||||
rblock | {read 23 19 :- 0} *( {} | {":[]\}\{`~!@#$%^&*(}
|
||||
rblock | query/maxRead {} -1 | {":[]\}\{`~!@#$%^&*(}
|
||||
query/maxRead {} -1
|
||||
got: {[[]]} {[[abcdefghijklmnopqrstuvw]]} {[[xyz0123456789,./?><;'\|]]} {[[]]}
|
||||
=============
|
||||
vvvvvvvvvvvvv
|
||||
rblock | query/maxRead {} -1 | {":[]\}\{`~!@#$%^&*(}
|
||||
query/maxRead {} -1
|
||||
read ) )
|
||||
query/maxRead {} -1
|
||||
rblock | {read 23 20 :- 0} ) {} | {":[]\}\{`~!@#$%^&*()}
|
||||
rblock | query/maxRead {} -1 | {":[]\}\{`~!@#$%^&*()}
|
||||
query/maxRead {} -1
|
||||
got: {[[]]} {[[abcdefghijklmnopqrstuvw]]} {[[xyz0123456789,./?><;'\|]]} {[[]]} {[[]]}
|
||||
=============
|
||||
vvvvvvvvvvvvv
|
||||
rblock | query/maxRead {} -1 | {":[]\}\{`~!@#$%^&*()}
|
||||
query/maxRead {} -1
|
||||
flush/read {} {}
|
||||
rblock | flush/read {} {":[]\}\{`~!@#$%^&*()} | {}
|
||||
rblock | query/maxRead {} -1 | {}
|
||||
query/maxRead {} -1
|
||||
got: {[[]]} {[[abcdefghijklmnopqrstuvw]]} {[[xyz0123456789,./?><;'\|]]} {[[]]} {[[]]} {[[":[]\}\{`~!@#$%^&*()]]}
|
||||
=============
|
||||
vvvvvvvvvvvvv
|
||||
rblock | query/maxRead {} -1 | {}
|
||||
query/maxRead {} -1
|
||||
got: {[[]]} {[[abcdefghijklmnopqrstuvw]]} {[[xyz0123456789,./?><;'\|]]} {[[]]} {[[]]} {[[":[]\}\{`~!@#$%^&*()]]} {[[]]}
|
||||
xxxxxxxxxxxxx
|
||||
rblock | flush/write {} {} | {}
|
||||
rblock | delete/write {} {} | {}
|
||||
rblock | delete/read {} {} | {}
|
||||
flush/write {} {}
|
||||
delete/write {} *ignored*
|
||||
delete/read {} *ignored*} ; # catch unescaped quote "
|
||||
|
||||
|
||||
test iogt-5.0 {EOF simulation} {testchannel unknownFailure} {
|
||||
set fin [open $path(dummy) r]
|
||||
set fout [open $path(dummyout) w]
|
||||
|
||||
set trail [list]
|
||||
|
||||
audit_flow trail -attach $fin
|
||||
stopafter_audit d trail 20 -attach $fin
|
||||
audit_flow trail -attach $fout
|
||||
|
||||
fconfigure $fin -buffersize 20
|
||||
fconfigure $fout -buffersize 10
|
||||
|
||||
fcopy $fin $fout
|
||||
testchannel unstack $fin
|
||||
|
||||
# now copy the rest in the channel
|
||||
lappend trail {**after unstack**}
|
||||
|
||||
fcopy $fin $fout
|
||||
|
||||
close $fin
|
||||
close $fout
|
||||
|
||||
join $trail \n
|
||||
} {create/read {} *ignored*
|
||||
counter:create/read {} {}
|
||||
create/write {} *ignored*
|
||||
counter:query/maxRead {} 20
|
||||
query/maxRead {} -1
|
||||
read {abcdefghijklmnopqrstuvwxyz0123456789,./?><;'\|":[]\}\{`~!@#$%^&*()_+-=
|
||||
} {abcdefghijklmnopqrstuvwxyz0123456789,./?><;'\|":[]\}\{`~!@#$%^&*()_+-=
|
||||
}
|
||||
query/maxRead {} -1
|
||||
flush/read {} {}
|
||||
counter:read abcdefghijklmnopqrst abcdefghijklmnopqrst
|
||||
write abcdefghij abcdefghij
|
||||
write klmnopqrst klmnopqrst
|
||||
counter:query/maxRead {} 0
|
||||
counter:flush/read {} {}
|
||||
counter:delete/read {} {}
|
||||
**after unstack**
|
||||
query/maxRead {} -1
|
||||
write uvwxyz0123 uvwxyz0123
|
||||
write 456789,./? 456789,./?
|
||||
write {><;'\|":[]} {><;'\|":[]}
|
||||
write {\}\{`~!@#$} {\}\{`~!@#$}
|
||||
write %^&*()_+-= %^&*()_+-=
|
||||
write {
|
||||
} {
|
||||
}
|
||||
query/maxRead {} -1
|
||||
delete/read {} *ignored*
|
||||
flush/write {} {}
|
||||
delete/write {} *ignored*}
|
||||
|
||||
proc constX {op data} {
|
||||
# replace anything coming in with a same-length string of x'es.
|
||||
switch -- $op {
|
||||
create/write - create/read -
|
||||
delete/write - delete/read -
|
||||
clear_read {;#ignore}
|
||||
flush/write - flush/read -
|
||||
write -
|
||||
read {
|
||||
return [string repeat x [string length $data]]
|
||||
}
|
||||
query/maxRead {return -1}
|
||||
}
|
||||
}
|
||||
|
||||
proc constx {-attach channel} {
|
||||
testchannel transform $channel -command [namespace code constX]
|
||||
}
|
||||
|
||||
test iogt-6.0 {Push back} testchannel {
|
||||
set f [open $path(dummy) r]
|
||||
|
||||
# contents of dummy = "abcdefghi..."
|
||||
read $f 3 ; # skip behind "abc"
|
||||
|
||||
constx -attach $f
|
||||
|
||||
# expect to get "xxx" from the transform because
|
||||
# of unread "def" input to transform which returns "xxx".
|
||||
#
|
||||
# Actually the IO layer pre-read the whole file and will
|
||||
# read "def" directly from the buffer without bothering
|
||||
# to consult the newly stacked transformation. This is
|
||||
# wrong.
|
||||
|
||||
set res [read $f 3]
|
||||
close $f
|
||||
set res
|
||||
} {xxx}
|
||||
|
||||
test iogt-6.1 {Push back and up} {testchannel knownBug} {
|
||||
set f [open $path(dummy) r]
|
||||
|
||||
# contents of dummy = "abcdefghi..."
|
||||
read $f 3 ; # skip behind "abc"
|
||||
|
||||
constx -attach $f
|
||||
set res [read $f 3]
|
||||
|
||||
testchannel unstack $f
|
||||
append res [read $f 3]
|
||||
close $f
|
||||
set res
|
||||
} {xxxghi}
|
||||
|
||||
|
||||
# cleanup
|
||||
foreach file [list dummy dummyout __echo_srv__.tcl] {
|
||||
removeFile $file
|
||||
}
|
||||
cleanupTests
|
||||
}
|
||||
namespace delete ::tcl::test::iogt
|
||||
return
|
||||
52
tests/join.test
Normal file
52
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.
|
||||
# Copyright (c) 1994 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
test join-1.1 {basic join commands} {
|
||||
join {a b c} xyz
|
||||
} axyzbxyzc
|
||||
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}
|
||||
|
||||
test join-3.1 {joinString is binary ok} {
|
||||
string length [join {a b c} a\0b]
|
||||
} 9
|
||||
|
||||
test join-3.2 {join is binary ok} {
|
||||
string length [join "a\0b a\0b a\0b"]
|
||||
} 11
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
40
tests/license.terms
Normal file
40
tests/license.terms
Normal file
@@ -0,0 +1,40 @@
|
||||
This software is copyrighted by the Regents of the University of
|
||||
California, Sun Microsystems, Inc., Scriptics Corporation, ActiveState
|
||||
Corporation and other parties. The following terms apply to all files
|
||||
associated with the software unless explicitly disclaimed in
|
||||
individual files.
|
||||
|
||||
The authors hereby grant permission to use, copy, modify, distribute,
|
||||
and license this software and its documentation for any purpose, provided
|
||||
that existing copyright notices are retained in all copies and that this
|
||||
notice is included verbatim in any distributions. No written agreement,
|
||||
license, or royalty fee is required for any of the authorized uses.
|
||||
Modifications to this software may be copyrighted by their authors
|
||||
and need not follow the licensing terms described here, provided that
|
||||
the new terms are clearly indicated on the first page of each file where
|
||||
they apply.
|
||||
|
||||
IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
|
||||
FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
|
||||
ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
|
||||
DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
|
||||
POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
|
||||
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
|
||||
FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
|
||||
IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
|
||||
NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
|
||||
MODIFICATIONS.
|
||||
|
||||
GOVERNMENT USE: If you are acquiring this software on behalf of the
|
||||
U.S. government, the Government shall have only "Restricted Rights"
|
||||
in the software and related documentation as defined in the Federal
|
||||
Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
|
||||
are acquiring the software on behalf of the Department of Defense, the
|
||||
software shall be classified as "Commercial Computer Software" and the
|
||||
Government shall have only "Restricted Rights" as defined in Clause
|
||||
252.227-7013 (b) (3) of DFARs. Notwithstanding the foregoing, the
|
||||
authors grant the U.S. Government and others acting in its behalf
|
||||
permission to use and distribute the software in accordance with the
|
||||
terms specified in this license.
|
||||
455
tests/lindex.test
Normal file
455
tests/lindex.test
Normal file
@@ -0,0 +1,455 @@
|
||||
# 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.
|
||||
# Copyright (c) 1994 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
# Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest 2.2
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
set minus -
|
||||
testConstraint testevalex [llength [info commands testevalex]]
|
||||
|
||||
# Tests of Tcl_LindexObjCmd, NOT COMPILED
|
||||
|
||||
test lindex-1.1 {wrong # args} testevalex {
|
||||
list [catch {testevalex lindex} result] $result
|
||||
} "1 {wrong # args: should be \"lindex list ?index...?\"}"
|
||||
|
||||
# Indices that are lists or convertible to lists
|
||||
|
||||
test lindex-2.1 {empty index list} testevalex {
|
||||
set x {}
|
||||
list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
|
||||
} {{a b c} {a b c}}
|
||||
test lindex-2.2 {singleton index list} testevalex {
|
||||
set x { 1 }
|
||||
list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
|
||||
} {b b}
|
||||
test lindex-2.3 {multiple indices in list} testevalex {
|
||||
set x {1 2}
|
||||
list [testevalex {lindex {{a b c} {d e f}} $x}] \
|
||||
[testevalex {lindex {{a b c} {d e f}} $x}]
|
||||
} {f f}
|
||||
test lindex-2.4 {malformed index list} testevalex {
|
||||
set x \{
|
||||
list [catch { testevalex {lindex {a b c} $x} } result] $result
|
||||
} {1 bad\ index\ \"\{\":\ must\ be\ integer?\[+-\]integer?\ or\ end?\[+-\]integer?}
|
||||
|
||||
# Indices that are integers or convertible to integers
|
||||
|
||||
test lindex-3.1 {integer -1} testevalex {
|
||||
set x ${minus}1
|
||||
list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
|
||||
} {{} {}}
|
||||
test lindex-3.2 {integer 0} testevalex {
|
||||
set x [string range 00 0 0]
|
||||
list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
|
||||
} {a a}
|
||||
test lindex-3.3 {integer 2} testevalex {
|
||||
set x [string range 22 0 0]
|
||||
list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
|
||||
} {c c}
|
||||
test lindex-3.4 {integer 3} testevalex {
|
||||
set x [string range 33 0 0]
|
||||
list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
|
||||
} {{} {}}
|
||||
test lindex-3.5 {bad octal} -constraints testevalex -body {
|
||||
set x 0o8
|
||||
list [catch { testevalex {lindex {a b c} $x} } result] $result
|
||||
} -match glob -result {1 {*invalid octal number*}}
|
||||
test lindex-3.6 {bad octal} -constraints testevalex -body {
|
||||
set x -0o9
|
||||
list [catch { testevalex {lindex {a b c} $x} } result] $result
|
||||
} -match glob -result {1 {*invalid octal number*}}
|
||||
test lindex-3.7 {indexes don't shimmer wide ints} {
|
||||
set x [expr {(wide(1)<<31) - 2}]
|
||||
list $x [lindex {1 2 3} $x] [incr x] [incr x]
|
||||
} {2147483646 {} 2147483647 2147483648}
|
||||
|
||||
# Indices relative to end
|
||||
|
||||
test lindex-4.1 {index = end} testevalex {
|
||||
set x end
|
||||
list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
|
||||
} {c c}
|
||||
test lindex-4.2 {index = end--1} testevalex {
|
||||
set x end--1
|
||||
list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
|
||||
} {{} {}}
|
||||
test lindex-4.3 {index = end-0} testevalex {
|
||||
set x end-0
|
||||
list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
|
||||
} {c c}
|
||||
test lindex-4.4 {index = end-2} testevalex {
|
||||
set x end-2
|
||||
list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
|
||||
} {a a}
|
||||
test lindex-4.5 {index = end-3} testevalex {
|
||||
set x end-3
|
||||
list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
|
||||
} {{} {}}
|
||||
test lindex-4.6 {bad octal} -constraints testevalex -body {
|
||||
set x end-0o8
|
||||
list [catch { testevalex {lindex {a b c} $x} } result] $result
|
||||
} -match glob -result {1 {*invalid octal number*}}
|
||||
test lindex-4.7 {bad octal} -constraints testevalex -body {
|
||||
set x end--0o9
|
||||
list [catch { testevalex {lindex {a b c} $x} } result] $result
|
||||
} -match glob -result {1 {*invalid octal number*}}
|
||||
test lindex-4.8 {bad integer, not octal} testevalex {
|
||||
set x end-0a2
|
||||
list [catch { testevalex {lindex {a b c} $x} } result] $result
|
||||
} {1 {bad index "end-0a2": must be integer?[+-]integer? or end?[+-]integer?}}
|
||||
test lindex-4.9 {obsolete test} testevalex {
|
||||
set x end
|
||||
list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
|
||||
} {c c}
|
||||
test lindex-4.10 {incomplete end-} testevalex {
|
||||
set x end-
|
||||
list [catch { testevalex {lindex {a b c} $x} } result] $result
|
||||
} {1 {bad index "end-": must be integer?[+-]integer? or end?[+-]integer?}}
|
||||
|
||||
test lindex-5.1 {bad second index} testevalex {
|
||||
list [catch { testevalex {lindex {a b c} 0 0a2} } result] $result
|
||||
} {1 {bad index "0a2": must be integer?[+-]integer? or end?[+-]integer?}}
|
||||
test lindex-5.2 {good second index} testevalex {
|
||||
testevalex {lindex {{a b c} {d e f} {g h i}} 1 2}
|
||||
} f
|
||||
test lindex-5.3 {three indices} testevalex {
|
||||
testevalex {lindex {{{a b} {c d}} {{e f} {g h}}} 1 0 1}
|
||||
} f
|
||||
|
||||
test lindex-6.1 {error conditions in parsing list} testevalex {
|
||||
list [catch {testevalex {lindex "a \{" 2}} msg] $msg
|
||||
} {1 {unmatched open brace in list}}
|
||||
test lindex-6.2 {error conditions in parsing list} testevalex {
|
||||
list [catch {testevalex {lindex {a {b c}d e} 2}} msg] $msg
|
||||
} {1 {list element in braces followed by "d" instead of space}}
|
||||
test lindex-6.3 {error conditions in parsing list} testevalex {
|
||||
list [catch {testevalex {lindex {a "b c"def ghi} 2}} msg] $msg
|
||||
} {1 {list element in quotes followed by "def" instead of space}}
|
||||
|
||||
test lindex-7.1 {quoted elements} testevalex {
|
||||
testevalex {lindex {a "b c" d} 1}
|
||||
} {b c}
|
||||
test lindex-7.2 {quoted elements} testevalex {
|
||||
testevalex {lindex {"{}" b c} 0}
|
||||
} {{}}
|
||||
test lindex-7.3 {quoted elements} testevalex {
|
||||
testevalex {lindex {ab "c d \" x" y} 1}
|
||||
} {c d " x}
|
||||
test lindex-7.4 {quoted elements} {
|
||||
lindex {a b {c d "e} {f g"}} 2
|
||||
} {c d "e}
|
||||
|
||||
test lindex-8.1 {data reuse} testevalex {
|
||||
set x 0
|
||||
testevalex {lindex $x $x}
|
||||
} {0}
|
||||
test lindex-8.2 {data reuse} testevalex {
|
||||
set a 0
|
||||
testevalex {lindex $a $a $a}
|
||||
} 0
|
||||
test lindex-8.3 {data reuse} testevalex {
|
||||
set a 1
|
||||
testevalex {lindex $a $a $a}
|
||||
} {}
|
||||
test lindex-8.4 {data reuse} testevalex {
|
||||
set x [list 0 0]
|
||||
testevalex {lindex $x $x}
|
||||
} {0}
|
||||
test lindex-8.5 {data reuse} testevalex {
|
||||
set x 0
|
||||
testevalex {lindex $x [list $x $x]}
|
||||
} {0}
|
||||
test lindex-8.6 {data reuse} testevalex {
|
||||
set x [list 1 1]
|
||||
testevalex {lindex $x $x}
|
||||
} {}
|
||||
test lindex-8.7 {data reuse} testevalex {
|
||||
set x 1
|
||||
testevalex {lindex $x [list $x $x]}
|
||||
} {}
|
||||
|
||||
#----------------------------------------------------------------------
|
||||
|
||||
# Compilation tests for lindex
|
||||
|
||||
test lindex-9.1 {wrong # args} {
|
||||
list [catch {lindex} result] $result
|
||||
} "1 {wrong # args: should be \"lindex list ?index...?\"}"
|
||||
test lindex-9.2 {ensure that compilation works in the right order} {
|
||||
proc foo {} {
|
||||
rename foo {}
|
||||
lindex 1 0
|
||||
}
|
||||
foo
|
||||
} 1
|
||||
|
||||
# Indices that are lists or convertible to lists
|
||||
|
||||
test lindex-10.1 {empty index list} {
|
||||
set x {}
|
||||
catch {
|
||||
list [lindex {a b c} $x] [lindex {a b c} $x]
|
||||
} result
|
||||
set result
|
||||
} {{a b c} {a b c}}
|
||||
test lindex-10.2 {singleton index list} {
|
||||
set x { 1 }
|
||||
catch {
|
||||
list [lindex {a b c} $x] [lindex {a b c} $x]
|
||||
} result
|
||||
set result
|
||||
} {b b}
|
||||
test lindex-10.3 {multiple indices in list} {
|
||||
set x {1 2}
|
||||
catch {
|
||||
list [lindex {{a b c} {d e f}} $x] [lindex {{a b c} {d e f}} $x]
|
||||
} result
|
||||
set result
|
||||
} {f f}
|
||||
test lindex-10.4 {malformed index list} {
|
||||
set x \{
|
||||
list [catch { lindex {a b c} $x } result] $result
|
||||
} {1 bad\ index\ \"\{\":\ must\ be\ integer?\[+-\]integer?\ or\ end?\[+-\]integer?}
|
||||
|
||||
# Indices that are integers or convertible to integers
|
||||
|
||||
test lindex-11.1 {integer -1} {
|
||||
set x ${minus}1
|
||||
catch {
|
||||
list [lindex {a b c} $x] [lindex {a b c} $x]
|
||||
} result
|
||||
set result
|
||||
} {{} {}}
|
||||
test lindex-11.2 {integer 0} {
|
||||
set x [string range 00 0 0]
|
||||
catch {
|
||||
list [lindex {a b c} $x] [lindex {a b c} $x]
|
||||
} result
|
||||
set result
|
||||
} {a a}
|
||||
test lindex-11.3 {integer 2} {
|
||||
set x [string range 22 0 0]
|
||||
catch {
|
||||
list [lindex {a b c} $x] [lindex {a b c} $x]
|
||||
} result
|
||||
set result
|
||||
} {c c}
|
||||
test lindex-11.4 {integer 3} {
|
||||
set x [string range 33 0 0]
|
||||
catch {
|
||||
list [lindex {a b c} $x] [lindex {a b c} $x]
|
||||
} result
|
||||
set result
|
||||
} {{} {}}
|
||||
test lindex-11.5 {bad octal} -body {
|
||||
set x 0o8
|
||||
list [catch { lindex {a b c} $x } result] $result
|
||||
} -match glob -result {1 {*invalid octal number*}}
|
||||
test lindex-11.6 {bad octal} -body {
|
||||
set x -0o9
|
||||
list [catch { lindex {a b c} $x } result] $result
|
||||
} -match glob -result {1 {*invalid octal number*}}
|
||||
|
||||
# Indices relative to end
|
||||
|
||||
test lindex-12.1 {index = end} {
|
||||
set x end
|
||||
catch {
|
||||
list [lindex {a b c} $x] [lindex {a b c} $x]
|
||||
} result
|
||||
set result
|
||||
} {c c}
|
||||
test lindex-12.2 {index = end--1} {
|
||||
set x end--1
|
||||
catch {
|
||||
list [lindex {a b c} $x] [lindex {a b c} $x]
|
||||
} result
|
||||
set result
|
||||
} {{} {}}
|
||||
test lindex-12.3 {index = end-0} {
|
||||
set x end-0
|
||||
catch {
|
||||
list [lindex {a b c} $x] [lindex {a b c} $x]
|
||||
} result
|
||||
set result
|
||||
} {c c}
|
||||
test lindex-12.4 {index = end-2} {
|
||||
set x end-2
|
||||
catch {
|
||||
list [lindex {a b c} $x] [lindex {a b c} $x]
|
||||
} result
|
||||
set result
|
||||
} {a a}
|
||||
test lindex-12.5 {index = end-3} {
|
||||
set x end-3
|
||||
catch {
|
||||
list [lindex {a b c} $x] [lindex {a b c} $x]
|
||||
} result
|
||||
set result
|
||||
} {{} {}}
|
||||
test lindex-12.6 {bad octal} -body {
|
||||
set x end-0o8
|
||||
list [catch { lindex {a b c} $x } result] $result
|
||||
} -match glob -result {1 {*invalid octal number*}}
|
||||
test lindex-12.7 {bad octal} -body {
|
||||
set x end--0o9
|
||||
list [catch { lindex {a b c} $x } result] $result
|
||||
} -match glob -result {1 {*invalid octal number*}}
|
||||
test lindex-12.8 {bad integer, not octal} {
|
||||
set x end-0a2
|
||||
list [catch { lindex {a b c} $x } result] $result
|
||||
} {1 {bad index "end-0a2": must be integer?[+-]integer? or end?[+-]integer?}}
|
||||
test lindex-12.9 {obsolete test} {
|
||||
set x end
|
||||
catch {
|
||||
list [lindex {a b c} $x] [lindex {a b c} $x]
|
||||
} result
|
||||
set result
|
||||
} {c c}
|
||||
test lindex-12.10 {incomplete end-} {
|
||||
set x end-
|
||||
list [catch { lindex {a b c} $x } result] $result
|
||||
} {1 {bad index "end-": must be integer?[+-]integer? or end?[+-]integer?}}
|
||||
|
||||
test lindex-13.1 {bad second index} {
|
||||
list [catch { lindex {a b c} 0 0a2 } result] $result
|
||||
} {1 {bad index "0a2": must be integer?[+-]integer? or end?[+-]integer?}}
|
||||
test lindex-13.2 {good second index} {
|
||||
catch {
|
||||
lindex {{a b c} {d e f} {g h i}} 1 2
|
||||
} result
|
||||
set result
|
||||
} f
|
||||
test lindex-13.3 {three indices} {
|
||||
catch {
|
||||
lindex {{{a b} {c d}} {{e f} {g h}}} 1 0 1
|
||||
} result
|
||||
set result
|
||||
} f
|
||||
|
||||
test lindex-14.1 {error conditions in parsing list} {
|
||||
list [catch { lindex "a \{" 2 } msg] $msg
|
||||
} {1 {unmatched open brace in list}}
|
||||
test lindex-14.2 {error conditions in parsing list} {
|
||||
list [catch { lindex {a {b c}d e} 2 } msg] $msg
|
||||
} {1 {list element in braces followed by "d" instead of space}}
|
||||
test lindex-14.3 {error conditions in parsing list} {
|
||||
list [catch { lindex {a "b c"def ghi} 2 } msg] $msg
|
||||
} {1 {list element in quotes followed by "def" instead of space}}
|
||||
|
||||
test lindex-15.1 {quoted elements} {
|
||||
catch {
|
||||
lindex {a "b c" d} 1
|
||||
} result
|
||||
set result
|
||||
} {b c}
|
||||
test lindex-15.2 {quoted elements} {
|
||||
catch {
|
||||
lindex {"{}" b c} 0
|
||||
} result
|
||||
set result
|
||||
} {{}}
|
||||
test lindex-15.3 {quoted elements} {
|
||||
catch {
|
||||
lindex {ab "c d \" x" y} 1
|
||||
} result
|
||||
set result
|
||||
} {c d " x}
|
||||
test lindex-15.4 {quoted elements} {
|
||||
catch {
|
||||
lindex {a b {c d "e} {f g"}} 2
|
||||
} result
|
||||
set result
|
||||
} {c d "e}
|
||||
|
||||
test lindex-16.1 {data reuse} {
|
||||
set x 0
|
||||
catch {
|
||||
lindex $x $x
|
||||
} result
|
||||
set result
|
||||
} {0}
|
||||
test lindex-16.2 {data reuse} {
|
||||
set a 0
|
||||
catch {
|
||||
lindex $a $a $a
|
||||
} result
|
||||
set result
|
||||
} 0
|
||||
test lindex-16.3 {data reuse} {
|
||||
set a 1
|
||||
catch {
|
||||
lindex $a $a $a
|
||||
} result
|
||||
set result
|
||||
} {}
|
||||
test lindex-16.4 {data reuse} {
|
||||
set x [list 0 0]
|
||||
catch {
|
||||
lindex $x $x
|
||||
} result
|
||||
set result
|
||||
} {0}
|
||||
test lindex-16.5 {data reuse} {
|
||||
set x 0
|
||||
catch {
|
||||
lindex $x [list $x $x]
|
||||
} result
|
||||
set result
|
||||
} {0}
|
||||
test lindex-16.6 {data reuse} {
|
||||
set x [list 1 1]
|
||||
catch {
|
||||
lindex $x $x
|
||||
} result
|
||||
set result
|
||||
} {}
|
||||
test lindex-16.7 {data reuse} {
|
||||
set x 1
|
||||
catch {
|
||||
lindex $x [list $x $x]
|
||||
} result
|
||||
set result
|
||||
} {}
|
||||
|
||||
test lindex-17.0 {Bug 1718580} {*}{
|
||||
-body {
|
||||
lindex {} end foo
|
||||
}
|
||||
-match glob
|
||||
-result {bad index "foo"*}
|
||||
-returnCodes 1
|
||||
}
|
||||
|
||||
test lindex-17.1 {Bug 1718580} {*}{
|
||||
-body {
|
||||
lindex a end foo
|
||||
}
|
||||
-match glob
|
||||
-result {bad index "foo"*}
|
||||
-returnCodes 1
|
||||
}
|
||||
|
||||
catch { unset minus }
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# End:
|
||||
279
tests/link.test
Normal file
279
tests/link.test
Normal file
@@ -0,0 +1,279 @@
|
||||
# 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.
|
||||
# Copyright (c) 1994 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest 2
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
testConstraint testlink [llength [info commands testlink]]
|
||||
|
||||
foreach i {int real bool string} {
|
||||
catch {unset $i}
|
||||
}
|
||||
test link-1.1 {reading C variables from Tcl} {testlink} {
|
||||
testlink delete
|
||||
testlink set 43 1.23 4 - 12341234 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
|
||||
testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
|
||||
list $int $real $bool $string $wide
|
||||
} {43 1.23 1 NULL 12341234}
|
||||
test link-1.2 {reading C variables from Tcl} {testlink} {
|
||||
testlink delete
|
||||
testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
|
||||
testlink set -3 2 0 "A long string with spaces" 43214321 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
|
||||
list $int $real $bool $string $wide $int $real $bool $string $wide
|
||||
} {-3 2.0 0 {A long string with spaces} 43214321 -3 2.0 0 {A long string with spaces} 43214321}
|
||||
|
||||
test link-2.1 {writing C variables from Tcl} {testlink} {
|
||||
testlink delete
|
||||
testlink set 43 1.21 4 - 56785678 64 250 30000 60000 0xbaadbeef 12321 32123 3.25 1231231234
|
||||
testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
|
||||
set int "0o0721"
|
||||
set real -10.5
|
||||
set bool true
|
||||
set string abcdef
|
||||
set wide 135135
|
||||
set char 79
|
||||
set uchar 161
|
||||
set short 8000
|
||||
set ushort 40000
|
||||
set uint 0xc001babe
|
||||
set long 34543
|
||||
set ulong 567890
|
||||
set float 1.0987654321
|
||||
set uwide 357357357357
|
||||
concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide
|
||||
} {465 -10.5 1 abcdef 135135 79 161 8000 40000 -1073628482 34543 567890 1.0987653732299805 357357357357 | 0o0721 -10.5 true abcdef 135135 79 161 8000 40000 0xc001babe 34543 567890 1.0987654321 357357357357}
|
||||
test link-2.2 {writing bad values into variables} {testlink} {
|
||||
testlink delete
|
||||
testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
|
||||
testlink create 1 1 1 1 1 1 1 1 1 1 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} {
|
||||
testlink delete
|
||||
testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
|
||||
testlink create 1 1 1 1 1 1 1 1 1 1 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} {
|
||||
testlink delete
|
||||
testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
|
||||
testlink create 1 1 1 1 1 1 1 1 1 1 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-2.5 {writing bad values into variables} {testlink} {
|
||||
testlink delete
|
||||
testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
|
||||
testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
|
||||
list [catch {set wide gorp} msg] $msg $bool
|
||||
} {1 {can't set "wide": variable must have integer value} 1}
|
||||
|
||||
test link-3.1 {read-only variables} {testlink} {
|
||||
testlink delete
|
||||
testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
|
||||
testlink create 0 1 1 0 0 0 0 0 0 0 0 0 0 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 \
|
||||
[catch {set wide 12341234} msg] $msg $wide
|
||||
} {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 1 {can't set "wide": linked variable is read-only} 56785678}
|
||||
test link-3.2 {read-only variables} {testlink} {
|
||||
testlink delete
|
||||
testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
|
||||
testlink create 1 0 0 1 1 0 0 0 0 0 0 0 0 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\
|
||||
[catch {set wide 12341234} msg] $msg $wide
|
||||
} {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} 0 12341234 12341234}
|
||||
|
||||
test link-4.1 {unsetting linked variables} {testlink} {
|
||||
testlink delete
|
||||
testlink set -6 -2.5 0 stringValue 13579 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
|
||||
testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
|
||||
unset int real bool string wide
|
||||
list [catch {set int} msg] $msg [catch {set real} msg] $msg \
|
||||
[catch {set bool} msg] $msg [catch {set string} msg] $msg \
|
||||
[catch {set wide} msg] $msg
|
||||
} {0 -6 0 -2.5 0 0 0 stringValue 0 13579}
|
||||
test link-4.2 {unsetting linked variables} {testlink} {
|
||||
testlink delete
|
||||
testlink set -6 -2.1 0 stringValue 97531 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
|
||||
testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
|
||||
unset int real bool string wide
|
||||
set int 102
|
||||
set real 16
|
||||
set bool true
|
||||
set string newValue
|
||||
set wide 333555
|
||||
lrange [testlink get] 0 4
|
||||
} {102 16.0 1 newValue 333555}
|
||||
|
||||
test link-5.1 {unlinking variables} {testlink} {
|
||||
testlink delete
|
||||
testlink set -6 -2.25 0 stringValue 13579 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
|
||||
testlink delete
|
||||
set int xx1
|
||||
set real qrst
|
||||
set bool bogus
|
||||
set string 12345
|
||||
set wide 875421
|
||||
set char skjdf
|
||||
set uchar dslfjk
|
||||
set short slkf
|
||||
set ushort skrh
|
||||
set uint sfdkfkh
|
||||
set long srkjh
|
||||
set ulong sjkg
|
||||
set float dskjfbjfd
|
||||
set uwide isdfsngs
|
||||
testlink get
|
||||
} {-6 -2.25 0 stringValue 13579 64 250 30000 60000 -1091585346 12321 32123 3.25 1231231234}
|
||||
test link-5.2 {unlinking variables} {testlink} {
|
||||
testlink delete
|
||||
testlink set -6 -2.25 0 stringValue 97531 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
|
||||
testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
|
||||
testlink delete
|
||||
testlink set 25 14.7 7 - 999999 65 251 30001 60001 0xbabebeef 12322 32124 3.125 12312312340
|
||||
list $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide
|
||||
} {-6 -2.25 0 stringValue 97531 64 250 30000 60000 3203381950 12321 32123 3.25 1231231234}
|
||||
|
||||
test link-6.1 {errors in setting up link} {testlink} {
|
||||
testlink delete
|
||||
catch {unset int}
|
||||
set int(44) 1
|
||||
list [catch {testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1} msg] $msg
|
||||
} {1 {can't set "int": variable is array}}
|
||||
catch {unset int}
|
||||
|
||||
test link-7.1 {access to linked variables via upvar} {testlink} {
|
||||
proc x {} {
|
||||
upvar int y
|
||||
unset y
|
||||
}
|
||||
testlink delete
|
||||
testlink create 1 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||
testlink set 14 {} {} {} {} {} {} {} {} {} {} {} {} {}
|
||||
x
|
||||
list [catch {set int} msg] $msg
|
||||
} {0 14}
|
||||
test link-7.2 {access to linked variables via upvar} {testlink} {
|
||||
proc x {} {
|
||||
upvar int y
|
||||
return [set y]
|
||||
}
|
||||
testlink delete
|
||||
testlink create 1 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||
testlink set 0 {} {} {} {} {} {} {} {} {} {} {} {} {}
|
||||
set int
|
||||
testlink set 23 {} {} {} {} {} {} {} {} {} {} {} {} {}
|
||||
x
|
||||
list [x] $int
|
||||
} {23 23}
|
||||
test link-7.3 {access to linked variables via upvar} {testlink} {
|
||||
proc x {} {
|
||||
upvar int y
|
||||
set y 44
|
||||
}
|
||||
testlink delete
|
||||
testlink create 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||
testlink set 11 {} {} {} {} {} {} {} {} {} {} {} {} {}
|
||||
list [catch x msg] $msg $int
|
||||
} {1 {can't set "y": linked variable is read-only} 11}
|
||||
test link-7.4 {access to linked variables via upvar} {testlink} {
|
||||
proc x {} {
|
||||
upvar int y
|
||||
set y abc
|
||||
}
|
||||
testlink delete
|
||||
testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
|
||||
testlink set -4 {} {} {} {} {} {} {} {} {} {} {} {} {}
|
||||
list [catch x msg] $msg $int
|
||||
} {1 {can't set "y": variable must have integer value} -4}
|
||||
test link-7.5 {access to linked variables via upvar} {testlink} {
|
||||
proc x {} {
|
||||
upvar real y
|
||||
set y abc
|
||||
}
|
||||
testlink delete
|
||||
testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
|
||||
testlink set -4 16.75 {} {} {} {} {} {} {} {} {} {} {} {}
|
||||
list [catch x msg] $msg $real
|
||||
} {1 {can't set "y": variable must have real value} 16.75}
|
||||
test link-7.6 {access to linked variables via upvar} {testlink} {
|
||||
proc x {} {
|
||||
upvar bool y
|
||||
set y abc
|
||||
}
|
||||
testlink delete
|
||||
testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
|
||||
testlink set -4 16.3 1 {} {} {} {} {} {} {} {} {} {} {}
|
||||
list [catch x msg] $msg $bool
|
||||
} {1 {can't set "y": variable must have boolean value} 1}
|
||||
test link-7.7 {access to linked variables via upvar} {testlink} {
|
||||
proc x {} {
|
||||
upvar wide y
|
||||
set y abc
|
||||
}
|
||||
testlink delete
|
||||
testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
|
||||
testlink set -4 16.3 1 {} 778899 {} {} {} {} {} {} {} {} {}
|
||||
list [catch x msg] $msg $wide
|
||||
} {1 {can't set "y": variable must have integer value} 778899}
|
||||
|
||||
test link-8.1 {Tcl_UpdateLinkedVar procedure} {testlink} {
|
||||
proc x args {
|
||||
global x int real bool string wide
|
||||
lappend x $args $int $real $bool $string $wide
|
||||
}
|
||||
set x {}
|
||||
testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
|
||||
testlink set 14 -2.0 0 xyzzy 995511 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
|
||||
trace var int w x
|
||||
testlink update 32 4.0 3 abcd 113355 65 251 30001 60001 0xbabebeef 12322 32124 3.125 12312312340
|
||||
trace vdelete int w x
|
||||
set x
|
||||
} {{int {} w} 32 -2.0 0 xyzzy 995511}
|
||||
test link-8.2 {Tcl_UpdateLinkedVar procedure} {testlink} {
|
||||
proc x args {
|
||||
global x int real bool string wide
|
||||
lappend x $args $int $real $bool $string $wide
|
||||
}
|
||||
set x {}
|
||||
testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
|
||||
testlink set 14 -2.0 0 xyzzy 995511 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
|
||||
testlink delete
|
||||
trace var int w x
|
||||
testlink update 32 4.0 6 abcd 113355 65 251 30001 60001 0xbabebeef 12322 32124 3.125 12312312340
|
||||
trace vdelete int w x
|
||||
set x
|
||||
} {}
|
||||
test link-8.3 {Tcl_UpdateLinkedVar procedure, read-only variable} {testlink} {
|
||||
testlink create 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||
list [catch {
|
||||
testlink update 47 {} {} {} {} {} {} {} {} {} {} {} {} {}
|
||||
} msg] $msg $int
|
||||
} {0 {} 47}
|
||||
|
||||
catch {testlink set 0 0 0 - 0 0 0 0 0 0 0 0 0 0}
|
||||
catch {testlink delete}
|
||||
foreach i {int real bool string wide} {
|
||||
catch {unset $i}
|
||||
}
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
113
tests/linsert.test
Normal file
113
tests/linsert.test
Normal file
@@ -0,0 +1,113 @@
|
||||
# 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.
|
||||
# Copyright (c) 1994 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
catch {unset lis}
|
||||
catch {rename p ""}
|
||||
|
||||
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-1.17 {linsert command} {
|
||||
linsert {a b c} end q r
|
||||
} {a b c q r}
|
||||
test linsert-1.18 {linsert command} {
|
||||
linsert {a} end q r
|
||||
} {a q r}
|
||||
test linsert-1.19 {linsert command} {
|
||||
linsert {} end q r
|
||||
} {q r}
|
||||
test linsert-1.20 {linsert command, use of end-int index} {
|
||||
linsert {a b c d} end-2 e f
|
||||
} {a b e f c d}
|
||||
|
||||
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 {bad index "12x": must be integer?[+-]integer? or end?[+-]integer?}}
|
||||
test linsert-2.4 {linsert errors} {
|
||||
list [catch {linsert \{ 12 2} msg] $msg
|
||||
} {1 {unmatched open brace in list}}
|
||||
|
||||
test linsert-3.1 {linsert won't modify shared argument objects} {
|
||||
proc p {} {
|
||||
linsert "a b c" 1 "x y"
|
||||
return "a b c"
|
||||
}
|
||||
p
|
||||
} "a b c"
|
||||
test linsert-3.2 {linsert won't modify shared argument objects} {
|
||||
catch {unset lis}
|
||||
set lis [format "a \"%s\" c" "b"]
|
||||
linsert $lis 0 [string length $lis]
|
||||
} "7 a b c"
|
||||
|
||||
# cleanup
|
||||
catch {unset lis}
|
||||
catch {rename p ""}
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
114
tests/list.test
Normal file
114
tests/list.test
Normal file
@@ -0,0 +1,114 @@
|
||||
# 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.
|
||||
# Copyright (c) 1994 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
# 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} {}
|
||||
test list-1.25 {basic tests} {list # #} {{#} #}
|
||||
test list-1.26 {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 0
|
||||
proc lcheck {testid a b c} {
|
||||
global num d
|
||||
set d [list $a $b $c]
|
||||
test ${testid}-0 {what goes in must come out} {lindex $d 0} $a
|
||||
test ${testid}-1 {what goes in must come out} {lindex $d 1} $b
|
||||
test ${testid}-2 {what goes in must come out} {lindex $d 2} $c
|
||||
}
|
||||
lcheck list-2.1 a b c
|
||||
lcheck list-2.2 "a b" c\td e\nf
|
||||
lcheck list-2.3 {{a b}} {} { }
|
||||
lcheck list-2.4 \$ \$ab ab\$
|
||||
lcheck list-2.5 \; \;ab ab\;
|
||||
lcheck list-2.6 \[ \[ab ab\[
|
||||
lcheck list-2.7 \\ \\ab ab\\
|
||||
lcheck list-2.8 {"} {"ab} {ab"} ;#" Stupid emacs highlighting!
|
||||
lcheck list-2.9 {a b} { ab} {ab }
|
||||
lcheck list-2.10 a{ a{b \{ab
|
||||
lcheck list-2.11 a} a}b }ab
|
||||
lcheck list-2.12 a\\} {a \}b} {a \{c}
|
||||
lcheck list-2.13 xyz \\ 1\\\n2
|
||||
lcheck list-2.14 "{ab}\\" "{ab}xy" abc
|
||||
|
||||
concat {}
|
||||
|
||||
# Check that tclListObj.c's SetListFromAny handles possible overlarge
|
||||
# string rep lengths in the source object.
|
||||
|
||||
proc slowsort list {
|
||||
set result {}
|
||||
set last [expr [llength $list] - 1]
|
||||
while {$last > 0} {
|
||||
set minIndex [expr [llength $list] - 1]
|
||||
set min [lindex $list $last]
|
||||
set i [expr $minIndex-1]
|
||||
while {$i >= 0} {
|
||||
if {[string compare [lindex $list $i] $min] < 0} {
|
||||
set minIndex $i
|
||||
set min [lindex $list $i]
|
||||
}
|
||||
set i [expr $i-1]
|
||||
}
|
||||
set result [concat $result [list $min]]
|
||||
if {$minIndex == 0} {
|
||||
set list [lrange $list 1 end]
|
||||
} else {
|
||||
set list [concat [lrange $list 0 [expr $minIndex-1]] \
|
||||
[lrange $list [expr $minIndex+1] end]]
|
||||
}
|
||||
set last [expr $last-1]
|
||||
}
|
||||
return [concat $result $list]
|
||||
}
|
||||
test list-3.1 {SetListFromAny and lrange/concat results} {
|
||||
slowsort {fred julie alex carol bill annie}
|
||||
} {alex annie bill carol fred julie}
|
||||
|
||||
test list-4.1 {Bug 3173086} {
|
||||
string is list "{[list \\\\\}]}"
|
||||
} 1
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
206
tests/listObj.test
Normal file
206
tests/listObj.test
Normal file
@@ -0,0 +1,206 @@
|
||||
# Functionality covered: operation of the procedures in tclListObj.c that
|
||||
# implement the Tcl type manager for the list object type.
|
||||
#
|
||||
# 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) 1995-1996 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
testConstraint testobj [llength [info commands testobj]]
|
||||
|
||||
catch {unset x}
|
||||
test listobj-1.1 {Tcl_GetListObjType} emptyTest {
|
||||
# Test removed; tested an internal detail
|
||||
# that's no longer correct, and duplicated test obj-1.1
|
||||
} {}
|
||||
|
||||
test listobj-2.1 {Tcl_SetListObj, use in lappend} {
|
||||
catch {unset x}
|
||||
list [lappend x 1 abc def] [lappend x 1 ghi jkl] $x
|
||||
} {{1 abc def} {1 abc def 1 ghi jkl} {1 abc def 1 ghi jkl}}
|
||||
test listobj-2.2 {Tcl_SetListObj, use in ObjInterpProc} {
|
||||
proc return_args {args} {
|
||||
return $args
|
||||
}
|
||||
list [return_args] [return_args x] [return_args x y]
|
||||
} {{} x {x y}}
|
||||
test listobj-2.3 {Tcl_SetListObj, zero element count} {
|
||||
list
|
||||
} {}
|
||||
|
||||
test listobj-3.1 {Tcl_ListObjAppend, list conversion} {
|
||||
catch {unset x}
|
||||
list [lappend x 1 2 abc "long string"] $x
|
||||
} {{1 2 abc {long string}} {1 2 abc {long string}}}
|
||||
test listobj-3.2 {Tcl_ListObjAppend, list conversion} {
|
||||
set x ""
|
||||
list [lappend x first second] [lappend x third fourth] $x
|
||||
} {{first second} {first second third fourth} {first second third fourth}}
|
||||
test listobj-3.3 {Tcl_ListObjAppend, list conversion} {
|
||||
set x "abc def"
|
||||
list [lappend x first second] $x
|
||||
} {{abc def first second} {abc def first second}}
|
||||
test listobj-3.4 {Tcl_ListObjAppend, error in conversion} {
|
||||
set x " \{"
|
||||
list [catch {lappend x abc def} msg] $msg
|
||||
} {1 {unmatched open brace in list}}
|
||||
test listobj-3.5 {Tcl_ListObjAppend, force internal rep array to grow} {
|
||||
set x ""
|
||||
list [lappend x 1 1] [lappend x 2 2] [lappend x 3 3] [lappend x 4 4] \
|
||||
[lappend x 5 5] [lappend x 6 6] [lappend x 7 7] [lappend x 8 8] $x
|
||||
} {{1 1} {1 1 2 2} {1 1 2 2 3 3} {1 1 2 2 3 3 4 4} {1 1 2 2 3 3 4 4 5 5} {1 1 2 2 3 3 4 4 5 5 6 6} {1 1 2 2 3 3 4 4 5 5 6 6 7 7} {1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8} {1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8}}
|
||||
|
||||
test listobj-4.1 {Tcl_ListObjAppendElement, list conversion} {
|
||||
catch {unset x}
|
||||
list [lappend x 1] $x
|
||||
} {1 1}
|
||||
test listobj-4.2 {Tcl_ListObjAppendElement, list conversion} {
|
||||
set x ""
|
||||
list [lappend x first] [lappend x second] $x
|
||||
} {first {first second} {first second}}
|
||||
test listobj-4.3 {Tcl_ListObjAppendElement, list conversion} {
|
||||
set x "abc def"
|
||||
list [lappend x first] $x
|
||||
} {{abc def first} {abc def first}}
|
||||
test listobj-4.4 {Tcl_ListObjAppendElement, error in conversion} {
|
||||
set x " \{"
|
||||
list [catch {lappend x abc} msg] $msg
|
||||
} {1 {unmatched open brace in list}}
|
||||
test listobj-4.5 {Tcl_ListObjAppendElement, force internal rep array to grow} {
|
||||
set x ""
|
||||
list [lappend x 1] [lappend x 2] [lappend x 3] [lappend x 4] \
|
||||
[lappend x 5] [lappend x 6] [lappend x 7] [lappend x 8] $x
|
||||
} {1 {1 2} {1 2 3} {1 2 3 4} {1 2 3 4 5} {1 2 3 4 5 6} {1 2 3 4 5 6 7} {1 2 3 4 5 6 7 8} {1 2 3 4 5 6 7 8}}
|
||||
|
||||
test listobj-5.1 {Tcl_ListObjIndex, basic tests} {
|
||||
lindex {a b c} 0
|
||||
} a
|
||||
test listobj-5.2 {Tcl_ListObjIndex, basic tests} {
|
||||
lindex a 0
|
||||
} a
|
||||
test listobj-5.3 {Tcl_ListObjIndex, basic tests} {
|
||||
lindex {a {b c d} x} 1
|
||||
} {b c d}
|
||||
test listobj-5.4 {Tcl_ListObjIndex, basic tests} {
|
||||
lindex {a b c} 3
|
||||
} {}
|
||||
test listobj-5.5 {Tcl_ListObjIndex, basic tests} {
|
||||
lindex {a b c} 100
|
||||
} {}
|
||||
test listobj-5.6 {Tcl_ListObjIndex, basic tests} {
|
||||
lindex a 100
|
||||
} {}
|
||||
test listobj-5.7 {Tcl_ListObjIndex, basic tests} {
|
||||
lindex {} -1
|
||||
} {}
|
||||
test listobj-5.8 {Tcl_ListObjIndex, error in conversion} {
|
||||
set x " \{"
|
||||
list [catch {lindex $x 0} msg] $msg
|
||||
} {1 {unmatched open brace in list}}
|
||||
|
||||
test listobj-6.1 {Tcl_ListObjLength} {
|
||||
llength {a b c d}
|
||||
} 4
|
||||
test listobj-6.2 {Tcl_ListObjLength} {
|
||||
llength {a b c {a b {c d}} d}
|
||||
} 5
|
||||
test listobj-6.3 {Tcl_ListObjLength} {
|
||||
llength {}
|
||||
} 0
|
||||
test listobj-6.4 {Tcl_ListObjLength, convert from non-list} {
|
||||
llength 123
|
||||
} 1
|
||||
test listobj-6.5 {Tcl_ListObjLength, error converting from non-list} {
|
||||
list [catch {llength "a b c \{"} msg] $msg
|
||||
} {1 {unmatched open brace in list}}
|
||||
test listobj-6.6 {Tcl_ListObjLength, error converting from non-list} {
|
||||
list [catch {llength "a {b}c"} msg] $msg
|
||||
} {1 {list element in braces followed by "c" instead of space}}
|
||||
|
||||
test listobj-7.1 {Tcl_ListObjReplace, conversion from non-list} {
|
||||
lreplace 123 0 0 x
|
||||
} {x}
|
||||
test listobj-7.2 {Tcl_ListObjReplace, error converting from non-list} {
|
||||
list [catch {lreplace "a b c \{" 1 1 x} msg] $msg
|
||||
} {1 {unmatched open brace in list}}
|
||||
test listobj-7.3 {Tcl_ListObjReplace, error converting from non-list} {
|
||||
list [catch {lreplace "a {b}c" 1 2 x} msg] $msg
|
||||
} {1 {list element in braces followed by "c" instead of space}}
|
||||
test listobj-7.4 {Tcl_ListObjReplace, negative first element index} {
|
||||
lreplace {1 2 3 4 5} -1 1 a
|
||||
} {a 3 4 5}
|
||||
test listobj-7.5 {Tcl_ListObjReplace, last element index >= num elems} {
|
||||
lreplace {1 2 3 4 5} 3 7 a b c
|
||||
} {1 2 3 a b c}
|
||||
test listobj-7.6 {Tcl_ListObjReplace, first element index > last index} {
|
||||
lreplace {1 2 3 4 5} 3 1 a b c
|
||||
} {1 2 3 a b c 4 5}
|
||||
test listobj-7.7 {Tcl_ListObjReplace, no new elements} {
|
||||
lreplace {1 2 3 4 5} 1 1
|
||||
} {1 3 4 5}
|
||||
test listobj-7.8 {Tcl_ListObjReplace, shrink array in place} {
|
||||
lreplace {1 2 3 4 5 6 7} 4 5
|
||||
} {1 2 3 4 7}
|
||||
test listobj-7.9 {Tcl_ListObjReplace, grow array in place} {
|
||||
lreplace {1 2 3 4 5 6 7} 1 3 a b c d e
|
||||
} {1 a b c d e 5 6 7}
|
||||
test listobj-7.10 {Tcl_ListObjReplace, replace tail of array} {
|
||||
lreplace {1 2 3 4 5 6 7} 3 6 a
|
||||
} {1 2 3 a}
|
||||
test listobj-7.11 {Tcl_ListObjReplace, must grow internal array} {
|
||||
lreplace {1 2 3 4 5} 2 3 a b c d e f g h i j k l
|
||||
} {1 2 a b c d e f g h i j k l 5}
|
||||
test listobj-7.12 {Tcl_ListObjReplace, grow array, insert at start} {
|
||||
lreplace {1 2 3 4 5} -1 -1 a b c d e f g h i j k l
|
||||
} {a b c d e f g h i j k l 1 2 3 4 5}
|
||||
test listobj-7.13 {Tcl_ListObjReplace, grow array, insert at end} {
|
||||
lreplace {1 2 3 4 5} 4 1 a b c d e f g h i j k l
|
||||
} {1 2 3 4 a b c d e f g h i j k l 5}
|
||||
|
||||
test listobj-8.1 {SetListFromAny} {
|
||||
lindex {0 foo\x00help 2} 1
|
||||
} "foo\x00help"
|
||||
|
||||
test listobj-9.1 {UpdateStringOfList} {
|
||||
string length [list foo\x00help]
|
||||
} 8
|
||||
|
||||
test listobj-10.1 {Bug [2971669]} {*}{
|
||||
-constraints testobj
|
||||
-setup {
|
||||
testobj freeallvars
|
||||
}
|
||||
-body {
|
||||
set result {}
|
||||
lappend result \
|
||||
[testlistobj set 1 a b c d e] \
|
||||
[testlistobj replace 1 0x7fffffff 0x7fffffff f] \
|
||||
[testlistobj get 1]
|
||||
}
|
||||
-cleanup {
|
||||
testobj freeallvars
|
||||
}
|
||||
-result {{a b c d e} {} {a b c d e f}}
|
||||
}
|
||||
|
||||
test listobj-11.1 {Bug 3598580: Tcl_ListObjReplace refcount management} testobj {
|
||||
testobj bug3598580
|
||||
} 123
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# End:
|
||||
41
tests/llength.test
Normal file
41
tests/llength.test
Normal file
@@ -0,0 +1,41 @@
|
||||
# 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.
|
||||
# Copyright (c) 1994 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
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}}
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
211
tests/load.test
Normal file
211
tests/load.test
Normal file
@@ -0,0 +1,211 @@
|
||||
# Commands covered: load
|
||||
#
|
||||
# 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) 1995 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest 2
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
# Figure out what extension is used for shared libraries on this
|
||||
# platform.
|
||||
if {![info exists ext]} {
|
||||
set ext [info sharedlibextension]
|
||||
}
|
||||
# Tests require the existence of one of the DLLs in the dltest directory.
|
||||
set testDir [file join [file dirname [info nameofexecutable]] dltest]
|
||||
set x [file join $testDir pkga$ext]
|
||||
set dll "[file tail $x]Required"
|
||||
testConstraint $dll [file readable $x]
|
||||
|
||||
# Tests also require that this DLL has not already been loaded.
|
||||
set loaded "[file tail $x]Loaded"
|
||||
set alreadyLoaded [info loaded]
|
||||
testConstraint $loaded [expr {![string match *pkga* $alreadyLoaded]}]
|
||||
|
||||
set alreadyTotalLoaded [info loaded]
|
||||
|
||||
# Certain tests require the 'teststaticpkg' command from tcltest
|
||||
|
||||
testConstraint teststaticpkg [llength [info commands teststaticpkg]]
|
||||
|
||||
# Test load-10.1 requires the 'testsimplefilesystem' command from tcltest
|
||||
|
||||
testConstraint testsimplefilesystem \
|
||||
[llength [info commands testsimplefilesystem]]
|
||||
|
||||
test load-1.1 {basic errors} {} {
|
||||
list [catch {load} msg] $msg
|
||||
} "1 {wrong \# args: should be \"load fileName ?packageName? ?interp?\"}"
|
||||
test load-1.2 {basic errors} {} {
|
||||
list [catch {load a b c d} msg] $msg
|
||||
} "1 {wrong \# args: should be \"load fileName ?packageName? ?interp?\"}"
|
||||
test load-1.3 {basic errors} {} {
|
||||
list [catch {load a b foobar} msg] $msg
|
||||
} {1 {could not find interpreter "foobar"}}
|
||||
test load-1.4 {basic errors} {} {
|
||||
list [catch {load {}} msg] $msg
|
||||
} {1 {must specify either file name or package name}}
|
||||
test load-1.5 {basic errors} {} {
|
||||
list [catch {load {} {}} msg] $msg
|
||||
} {1 {must specify either file name or package name}}
|
||||
test load-1.6 {basic errors} {} {
|
||||
list [catch {load {} Unknown} msg] $msg
|
||||
} {1 {package "Unknown" isn't loaded statically}}
|
||||
|
||||
test load-2.1 {basic loading, with guess for package name} \
|
||||
[list $dll $loaded] {
|
||||
load [file join $testDir pkga$ext]
|
||||
list [pkga_eq abc def] [info commands pkga_*]
|
||||
} {0 {pkga_eq pkga_quote}}
|
||||
interp create -safe child
|
||||
test load-2.2 {loading into a safe interpreter, with package name conversion} \
|
||||
[list $dll $loaded] {
|
||||
load [file join $testDir pkgb$ext] pKgB child
|
||||
list [child eval pkgb_sub 44 13] [catch {child eval pkgb_unsafe} msg] $msg \
|
||||
[catch {pkgb_sub 12 10} msg2] $msg2
|
||||
} {31 1 {invalid command name "pkgb_unsafe"} 1 {invalid command name "pkgb_sub"}}
|
||||
test load-2.3 {loading with no _Init procedure} -constraints [list $dll $loaded] \
|
||||
-body {
|
||||
list [catch {load [file join $testDir pkgc$ext] foo} msg] $msg
|
||||
} -match glob -result {1 {*couldn't find procedure Foo_Init}}
|
||||
test load-2.4 {loading with no _SafeInit procedure} [list $dll $loaded] {
|
||||
list [catch {load [file join $testDir pkga$ext] {} child} msg] $msg
|
||||
} {1 {can't use package in a safe interpreter: no Pkga_SafeInit procedure}}
|
||||
|
||||
test load-3.1 {error in _Init procedure, same interpreter} \
|
||||
[list $dll $loaded] {
|
||||
list [catch {load [file join $testDir pkge$ext] pkge} msg] \
|
||||
$msg $::errorInfo $::errorCode
|
||||
} {1 {couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory
|
||||
while executing
|
||||
"open non_existent"
|
||||
invoked from within
|
||||
"if 44 {open non_existent}"
|
||||
invoked from within
|
||||
"load [file join $testDir pkge$ext] pkge"} {POSIX ENOENT {no such file or directory}}}
|
||||
test load-3.2 {error in _Init procedure, slave interpreter} \
|
||||
[list $dll $loaded] {
|
||||
catch {interp delete x}
|
||||
interp create x
|
||||
set ::errorCode foo
|
||||
set ::errorInfo bar
|
||||
set result [list [catch {load [file join $testDir pkge$ext] pkge x} msg] \
|
||||
$msg $::errorInfo $::errorCode]
|
||||
interp delete x
|
||||
set result
|
||||
} {1 {couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory
|
||||
while executing
|
||||
"open non_existent"
|
||||
invoked from within
|
||||
"if 44 {open non_existent}"
|
||||
invoked from within
|
||||
"load [file join $testDir pkge$ext] pkge x"} {POSIX ENOENT {no such file or directory}}}
|
||||
|
||||
test load-4.1 {reloading package into same interpreter} [list $dll $loaded] {
|
||||
list [catch {load [file join $testDir pkga$ext] pkga} msg] $msg
|
||||
} {0 {}}
|
||||
test load-4.2 {reloading package into same interpreter} [list $dll $loaded] {
|
||||
list [catch {load [file join $testDir pkga$ext] pkgb} msg] $msg
|
||||
} [list 1 "file \"[file join $testDir pkga$ext]\" is already loaded for package \"Pkga\""]
|
||||
|
||||
test load-5.1 {file name not specified and no static package: pick default} \
|
||||
[list $dll $loaded] {
|
||||
catch {interp delete x}
|
||||
interp create x
|
||||
load [file join $testDir pkga$ext] pkga
|
||||
load {} pkga x
|
||||
set result [info loaded x]
|
||||
interp delete x
|
||||
set result
|
||||
} [list [list [file join $testDir pkga$ext] Pkga]]
|
||||
|
||||
# On some platforms, like SunOS 4.1.3, these tests can't be run because
|
||||
# they cause the process to exit.
|
||||
#
|
||||
# As of 2005, such ancient broken systems no longer matter.
|
||||
|
||||
test load-6.1 {errors loading file} [list $dll $loaded] {
|
||||
catch {load foo foo}
|
||||
} {1}
|
||||
|
||||
test load-7.1 {Tcl_StaticPackage procedure} [list teststaticpkg] {
|
||||
set x "not loaded"
|
||||
teststaticpkg Test 1 0
|
||||
load {} Test
|
||||
load {} Test child
|
||||
list [set x] [child eval set x]
|
||||
} {loaded loaded}
|
||||
test load-7.2 {Tcl_StaticPackage procedure} [list teststaticpkg] {
|
||||
set x "not loaded"
|
||||
teststaticpkg Another 0 0
|
||||
load {} Another
|
||||
child eval {set x "not loaded"}
|
||||
list [catch {load {} Another child} msg] $msg \
|
||||
[child eval set x] [set x]
|
||||
} {1 {can't use package in a safe interpreter: no Another_SafeInit procedure} {not loaded} loaded}
|
||||
test load-7.3 {Tcl_StaticPackage procedure} [list teststaticpkg] {
|
||||
set x "not loaded"
|
||||
teststaticpkg More 0 1
|
||||
load {} More
|
||||
set x
|
||||
} {not loaded}
|
||||
test load-7.4 {Tcl_StaticPackage procedure, redundant calls} \
|
||||
[list teststaticpkg $dll $loaded] {
|
||||
teststaticpkg Double 0 1
|
||||
teststaticpkg Double 0 1
|
||||
info loaded
|
||||
} [concat [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkge$ext] Pkge] [list [file join $testDir pkgb$ext] Pkgb] [list [file join $testDir pkga$ext] Pkga]] $alreadyTotalLoaded]
|
||||
|
||||
test load-8.1 {TclGetLoadedPackages procedure} [list teststaticpkg $dll $loaded] {
|
||||
info loaded
|
||||
} [concat [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkge$ext] Pkge] [list [file join $testDir pkgb$ext] Pkgb] [list [file join $testDir pkga$ext] Pkga]] $alreadyTotalLoaded]
|
||||
test load-8.2 {TclGetLoadedPackages procedure} [list teststaticpkg] {
|
||||
list [catch {info loaded gorp} msg] $msg
|
||||
} {1 {could not find interpreter "gorp"}}
|
||||
test load-8.3 {TclGetLoadedPackages procedure} [list teststaticpkg $dll $loaded] {
|
||||
list [info loaded {}] [info loaded child]
|
||||
} [list [concat [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded] [list {{} Test} [list [file join $testDir pkgb$ext] Pkgb]]]
|
||||
test load-8.4 {TclGetLoadedPackages procedure} [list $dll $loaded teststaticpkg] {
|
||||
load [file join $testDir pkgb$ext] pkgb
|
||||
list [info loaded {}] [lsort [info commands pkgb_*]]
|
||||
} [list [concat [list [list [file join $testDir pkgb$ext] Pkgb] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded] {pkgb_sub pkgb_unsafe}]
|
||||
interp delete child
|
||||
|
||||
test load-9.1 {Tcl_StaticPackage, load already-loaded package into another interp} \
|
||||
-constraints {teststaticpkg} \
|
||||
-setup {
|
||||
interp create child1
|
||||
interp create child2
|
||||
load {} Tcltest child1
|
||||
load {} Tcltest child2
|
||||
} \
|
||||
-body {
|
||||
child1 eval { teststaticpkg Loadninepointone 0 1 }
|
||||
child2 eval { teststaticpkg Loadninepointone 0 1 }
|
||||
list \
|
||||
[child1 eval { info loaded {} }] \
|
||||
[child2 eval { info loaded {} }]
|
||||
} \
|
||||
-result {{{{} Loadninepointone} {{} Tcltest}} {{{} Loadninepointone} {{} Tcltest}}} \
|
||||
-cleanup { interp delete child1 ; interp delete child2 }
|
||||
|
||||
test load-10.1 {load from vfs} \
|
||||
-constraints [list $dll $loaded testsimplefilesystem] \
|
||||
-setup {set dir [pwd]; cd $testDir; testsimplefilesystem 1} \
|
||||
-body {list [catch {load simplefs:/pkgd$ext pkgd} msg] $msg} \
|
||||
-result {0 {}} \
|
||||
-cleanup {testsimplefilesystem 0; cd $dir; unset dir}
|
||||
|
||||
# cleanup
|
||||
unset ext
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
89
tests/lrange.test
Normal file
89
tests/lrange.test
Normal file
@@ -0,0 +1,89 @@
|
||||
# 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.
|
||||
# Copyright (c) 1994 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
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 end
|
||||
} {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-1.11 {range of list elements} {
|
||||
lrange "a b c d" end end
|
||||
} d
|
||||
test lrange-1.12 {range of list elements} {
|
||||
lrange "a b c d" end 100000
|
||||
} d
|
||||
test lrange-1.13 {range of list elements} {
|
||||
lrange "a b c d" end 3
|
||||
} d
|
||||
test lrange-1.14 {range of list elements} {
|
||||
lrange "a b c d" end 2
|
||||
} {}
|
||||
test lrange-1.15 {range of list elements} {
|
||||
concat \"[lrange {a b \{\ } 0 2]"
|
||||
} {"a b \{\ "}
|
||||
test lrange-1.16 {list element quoting} {
|
||||
lrange {[append a .b]} 0 end
|
||||
} {{[append} a .b\]}
|
||||
|
||||
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 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}}
|
||||
test lrange-2.4 {error conditions} {
|
||||
list [catch {lrange a 0 enigma} msg] $msg
|
||||
} {1 {bad index "enigma": must be integer?[+-]integer? or end?[+-]integer?}}
|
||||
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}}
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
77
tests/lrepeat.test
Normal file
77
tests/lrepeat.test
Normal file
@@ -0,0 +1,77 @@
|
||||
# Commands covered: lrepeat
|
||||
#
|
||||
# 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) 2003 by Simon Geard.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest 2
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
## Arg errors
|
||||
test lrepeat-1.1 {error cases} {
|
||||
-body {
|
||||
lrepeat
|
||||
}
|
||||
-returnCodes 1
|
||||
-result {wrong # args: should be "lrepeat positiveCount value ?value ...?"}
|
||||
}
|
||||
test lrepeat-1.2 {error cases} {
|
||||
-body {
|
||||
lrepeat 1
|
||||
}
|
||||
-returnCodes 1
|
||||
-result {wrong # args: should be "lrepeat positiveCount value ?value ...?"}
|
||||
}
|
||||
test lrepeat-1.3 {error cases} {
|
||||
-body {
|
||||
lrepeat a 1
|
||||
}
|
||||
-returnCodes 1
|
||||
-result {expected integer but got "a"}
|
||||
}
|
||||
test lrepeat-1.4 {error cases} {
|
||||
-body {
|
||||
lrepeat -3 1
|
||||
}
|
||||
-returnCodes 1
|
||||
-result {must have a count of at least 1}
|
||||
}
|
||||
test lrepeat-1.5 {error cases} {
|
||||
-body {
|
||||
lrepeat 0
|
||||
}
|
||||
-returnCodes 1
|
||||
-result {wrong # args: should be "lrepeat positiveCount value ?value ...?"}
|
||||
}
|
||||
test lrepeat-1.6 {error cases} {
|
||||
-body {
|
||||
lrepeat 3.5 1
|
||||
}
|
||||
-returnCodes 1
|
||||
-result {expected integer but got "3.5"}
|
||||
}
|
||||
|
||||
## Okay
|
||||
test lrepeat-2.1 {normal cases} {
|
||||
lrepeat 10 a
|
||||
} {a a a a a a a a a a}
|
||||
test lrepeat-2.2 {normal cases} {
|
||||
lrepeat 3 [lrepeat 3 0]
|
||||
} {{0 0 0} {0 0 0} {0 0 0}}
|
||||
test lrepeat-2.3 {normal cases} {
|
||||
lrepeat 3 a b c
|
||||
} {a b c a b c a b c}
|
||||
test lrepeat-2.4 {normal cases} {
|
||||
lrepeat 3 [lrepeat 2 a] b c
|
||||
} {{a a} b c {a a} b c {a a} b c}
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
136
tests/lreplace.test
Normal file
136
tests/lreplace.test
Normal file
@@ -0,0 +1,136 @@
|
||||
# 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.
|
||||
# Copyright (c) 1994 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
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 1 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-1.19 {lreplace command} {
|
||||
lreplace {1 2 3 4} 2 end x y z
|
||||
} {1 2 x y z}
|
||||
test lreplace-1.20 {lreplace command} {
|
||||
lreplace {1 2 3 4} end end a
|
||||
} {1 2 3 a}
|
||||
test lreplace-1.21 {lreplace command} {
|
||||
lreplace {1 2 3 4} end 3 a
|
||||
} {1 2 3 a}
|
||||
test lreplace-1.22 {lreplace command} {
|
||||
lreplace {1 2 3 4} end end
|
||||
} {1 2 3}
|
||||
test lreplace-1.23 {lreplace command} {
|
||||
lreplace {1 2 3 4} 2 -1 xy
|
||||
} {1 2 xy 3 4}
|
||||
test lreplace-1.24 {lreplace command} {
|
||||
lreplace {1 2 3 4} end -1 z
|
||||
} {1 2 3 z 4}
|
||||
test lreplace-1.25 {lreplace command} {
|
||||
concat \"[lreplace {\}\ hello} end end]\"
|
||||
} {"\}\ "}
|
||||
test lreplace-1.26 {lreplace command} {
|
||||
catch {unset foo}
|
||||
set foo {a b}
|
||||
list [set foo [lreplace $foo end end]] \
|
||||
[set foo [lreplace $foo end end]] \
|
||||
[set foo [lreplace $foo end end]]
|
||||
} {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 {bad index "a": must be integer?[+-]integer? or end?[+-]integer?}}
|
||||
test lreplace-2.4 {lreplace errors} {
|
||||
list [catch {lreplace x 10 x} msg] $msg
|
||||
} {1 {bad index "x": must be integer?[+-]integer? or end?[+-]integer?}}
|
||||
test lreplace-2.5 {lreplace errors} {
|
||||
list [catch {lreplace x 10 1x} msg] $msg
|
||||
} {1 {bad index "1x": must be integer?[+-]integer? or end?[+-]integer?}}
|
||||
test lreplace-2.6 {lreplace errors} {
|
||||
list [catch {lreplace x 3 2} msg] $msg
|
||||
} {1 {list doesn't contain element 3}}
|
||||
test lreplace-2.7 {lreplace errors} {
|
||||
list [catch {lreplace x 1 1} msg] $msg
|
||||
} {1 {list doesn't contain element 1}}
|
||||
|
||||
test lreplace-3.1 {lreplace won't modify shared argument objects} {
|
||||
proc p {} {
|
||||
lreplace "a b c" 1 1 "x y"
|
||||
return "a b c"
|
||||
}
|
||||
p
|
||||
} "a b c"
|
||||
|
||||
# cleanup
|
||||
catch {unset foo}
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
484
tests/lsearch.test
Normal file
484
tests/lsearch.test
Normal file
@@ -0,0 +1,484 @@
|
||||
# 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.
|
||||
# Copyright (c) 1994 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
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} {
|
||||
lsearch -exact {foo bar cat} ba
|
||||
} -1
|
||||
test lsearch-2.4 {search modes} {
|
||||
lsearch -exact {foo bar cat} bart
|
||||
} -1
|
||||
test lsearch-2.5 {search modes} {
|
||||
lsearch -exact {foo bar cat} bar
|
||||
} 1
|
||||
test lsearch-2.6 {search modes} {
|
||||
list [catch {lsearch -regexp {xyz bbcc *bc*} *bc*} msg] $msg
|
||||
} {1 {couldn't compile regular expression pattern: quantifier operand invalid}}
|
||||
test lsearch-2.7 {search modes} {
|
||||
lsearch -regexp {b.x ^bc xy bcx} ^bc
|
||||
} 3
|
||||
test lsearch-2.8 {search modes} {
|
||||
lsearch -glob {xyz bbcc *bc*} *bc*
|
||||
} 1
|
||||
test lsearch-2.9 {search modes} {
|
||||
lsearch -glob {b.x ^bc xy bcx} ^bc
|
||||
} 1
|
||||
test lsearch-2.10 {search modes} {
|
||||
list [catch {lsearch -glib {b.x bx xy bcx} b.x} msg] $msg
|
||||
} {1 {bad option "-glib": must be -all, -ascii, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}}
|
||||
test lsearch-2.11 {search modes with -nocase} {
|
||||
lsearch -exact -nocase {a b c A B C} A
|
||||
} 0
|
||||
test lsearch-2.12 {search modes with -nocase} {
|
||||
lsearch -glob -nocase {a b c A B C} A*
|
||||
} 0
|
||||
test lsearch-2.13 {search modes with -nocase} {
|
||||
lsearch -regexp -nocase {a b c A B C} ^A\$
|
||||
} 0
|
||||
test lsearch-2.14 {search modes without -nocase} {
|
||||
lsearch -exact {a b c A B C} A
|
||||
} 3
|
||||
test lsearch-2.15 {search modes without -nocase} {
|
||||
lsearch -glob {a b c A B C} A*
|
||||
} 3
|
||||
test lsearch-2.16 {search modes without -nocase} {
|
||||
lsearch -regexp {a b c A B C} ^A\$
|
||||
} 3
|
||||
|
||||
test lsearch-3.1 {lsearch errors} {
|
||||
list [catch lsearch msg] $msg
|
||||
} {1 {wrong # args: should be "lsearch ?options? list pattern"}}
|
||||
test lsearch-3.2 {lsearch errors} {
|
||||
list [catch {lsearch a} msg] $msg
|
||||
} {1 {wrong # args: should be "lsearch ?options? list pattern"}}
|
||||
test lsearch-3.3 {lsearch errors} {
|
||||
list [catch {lsearch a b c} msg] $msg
|
||||
} {1 {bad option "a": must be -all, -ascii, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}}
|
||||
test lsearch-3.4 {lsearch errors} {
|
||||
list [catch {lsearch a b c d} msg] $msg
|
||||
} {1 {bad option "a": must be -all, -ascii, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}}
|
||||
test lsearch-3.5 {lsearch errors} {
|
||||
list [catch {lsearch "\{" b} msg] $msg
|
||||
} {1 {unmatched open brace in list}}
|
||||
test lsearch-3.6 {lsearch errors} {
|
||||
list [catch {lsearch -index a b} msg] $msg
|
||||
} {1 {"-index" option must be followed by list index}}
|
||||
test lsearch-3.7 {lsearch errors} {
|
||||
list [catch {lsearch -subindices -exact a b} msg] $msg
|
||||
} {1 {-subindices cannot be used without -index option}}
|
||||
|
||||
test lsearch-4.1 {binary data} {
|
||||
lsearch -exact [list foo one\000two bar] bar
|
||||
} 2
|
||||
test lsearch-4.2 {binary data} {
|
||||
set x one
|
||||
append x \x00
|
||||
append x two
|
||||
lsearch -exact [list foo one\000two bar] $x
|
||||
} 1
|
||||
|
||||
# Make a sorted list
|
||||
set l {}
|
||||
set l2 {}
|
||||
for {set i 0} {$i < 100} {incr i} {
|
||||
lappend l $i
|
||||
lappend l2 [expr {double($i)/2}]
|
||||
}
|
||||
set increasingIntegers [lsort -integer $l]
|
||||
set decreasingIntegers [lsort -decreasing -integer $l]
|
||||
set increasingDoubles [lsort -real $l2]
|
||||
set decreasingDoubles [lsort -decreasing -real $l2]
|
||||
set increasingStrings [lsort {48 6a 18b 22a 21aa 35 36}]
|
||||
set decreasingStrings [lsort -decreasing {48 6a 18b 22a 21aa 35 36}]
|
||||
set increasingDictionary [lsort -dictionary {48 6a 18b 22a 21aa 35 36}]
|
||||
set decreasingDictionary [lsort -dictionary -decreasing $increasingDictionary]
|
||||
|
||||
set l {}
|
||||
for {set i 0} {$i < 10} {incr i} {
|
||||
lappend l $i $i $i $i $i
|
||||
}
|
||||
set repeatingIncreasingIntegers [lsort -integer $l]
|
||||
set repeatingDecreasingIntegers [lsort -integer -decreasing $l]
|
||||
|
||||
test lsearch-5.1 {binary search} {
|
||||
set res {}
|
||||
for {set i 0} {$i < 100} {incr i} {
|
||||
lappend res [lsearch -integer -sorted $increasingIntegers $i]
|
||||
}
|
||||
set res
|
||||
} $increasingIntegers
|
||||
test lsearch-5.2 {binary search} {
|
||||
set res {}
|
||||
for {set i 0} {$i < 100} {incr i} {
|
||||
lappend res [lsearch -integer -decreasing -sorted \
|
||||
$decreasingIntegers $i]
|
||||
}
|
||||
set res
|
||||
} $decreasingIntegers
|
||||
test lsearch-5.3 {binary search finds leftmost occurances} {
|
||||
set res {}
|
||||
for {set i 0} {$i < 10} {incr i} {
|
||||
lappend res [lsearch -integer -sorted $repeatingIncreasingIntegers $i]
|
||||
}
|
||||
set res
|
||||
} [list 0 5 10 15 20 25 30 35 40 45]
|
||||
test lsearch-5.4 {binary search -decreasing finds leftmost occurances} {
|
||||
set res {}
|
||||
for {set i 9} {$i >= 0} {incr i -1} {
|
||||
lappend res [lsearch -sorted -integer -decreasing \
|
||||
$repeatingDecreasingIntegers $i]
|
||||
}
|
||||
set res
|
||||
} [list 0 5 10 15 20 25 30 35 40 45]
|
||||
|
||||
test lsearch-6.1 {integer search} {
|
||||
set res {}
|
||||
for {set i 0} {$i < 100} {incr i} {
|
||||
lappend res [lsearch -exact -integer $increasingIntegers $i]
|
||||
}
|
||||
set res
|
||||
} [lrange $increasingIntegers 0 99]
|
||||
test lsearch-6.2 {decreasing integer search} {
|
||||
set res {}
|
||||
for {set i 0} {$i < 100} {incr i} {
|
||||
lappend res [lsearch -exact -integer -decreasing \
|
||||
$decreasingIntegers $i]
|
||||
}
|
||||
set res
|
||||
} [lrange $decreasingIntegers 0 99]
|
||||
test lsearch-6.3 {sorted integer search} {
|
||||
set res {}
|
||||
for {set i 0} {$i < 100} {incr i} {
|
||||
lappend res [lsearch -sorted -integer $increasingIntegers $i]
|
||||
}
|
||||
set res
|
||||
} [lrange $increasingIntegers 0 99]
|
||||
test lsearch-6.4 {sorted decreasing integer search} {
|
||||
set res {}
|
||||
for {set i 0} {$i < 100} {incr i} {
|
||||
lappend res [lsearch -integer -sorted -decreasing \
|
||||
$decreasingIntegers $i]
|
||||
}
|
||||
set res
|
||||
} [lrange $decreasingIntegers 0 99]
|
||||
|
||||
test lsearch-7.1 {double search} {
|
||||
set res {}
|
||||
for {set i 0} {$i < 100} {incr i} {
|
||||
lappend res [lsearch -exact -real $increasingDoubles \
|
||||
[expr {double($i)/2}]]
|
||||
}
|
||||
set res
|
||||
} [lrange $increasingIntegers 0 99]
|
||||
test lsearch-7.2 {decreasing double search} {
|
||||
set res {}
|
||||
for {set i 0} {$i < 100} {incr i} {
|
||||
lappend res [lsearch -exact -real -decreasing \
|
||||
$decreasingDoubles [expr {double($i)/2}]]
|
||||
}
|
||||
set res
|
||||
} [lrange $decreasingIntegers 0 99]
|
||||
test lsearch-7.3 {sorted double search} {
|
||||
set res {}
|
||||
for {set i 0} {$i < 100} {incr i} {
|
||||
lappend res [lsearch -sorted -real \
|
||||
$increasingDoubles [expr {double($i)/2}]]
|
||||
}
|
||||
set res
|
||||
} [lrange $increasingIntegers 0 99]
|
||||
test lsearch-7.4 {sorted decreasing double search} {
|
||||
set res {}
|
||||
for {set i 0} {$i < 100} {incr i} {
|
||||
lappend res [lsearch -sorted -real -decreasing \
|
||||
$decreasingDoubles [expr {double($i)/2}]]
|
||||
}
|
||||
set res
|
||||
} [lrange $decreasingIntegers 0 99]
|
||||
|
||||
test lsearch-8.1 {dictionary search} {
|
||||
set res {}
|
||||
foreach val {6a 18b 21aa 22a 35 36 48} {
|
||||
lappend res [lsearch -exact -dictionary $increasingDictionary $val]
|
||||
}
|
||||
set res
|
||||
} [list 0 1 2 3 4 5 6]
|
||||
test lsearch-8.2 {decreasing dictionary search} {
|
||||
set res {}
|
||||
foreach val {6a 18b 21aa 22a 35 36 48} {
|
||||
lappend res [lsearch -exact -dictionary $decreasingDictionary $val]
|
||||
}
|
||||
set res
|
||||
} [list 6 5 4 3 2 1 0]
|
||||
test lsearch-8.3 {sorted dictionary search} {
|
||||
set res {}
|
||||
foreach val {6a 18b 21aa 22a 35 36 48} {
|
||||
lappend res [lsearch -sorted -dictionary $increasingDictionary $val]
|
||||
}
|
||||
set res
|
||||
} [list 0 1 2 3 4 5 6]
|
||||
test lsearch-8.4 {decreasing sorted dictionary search} {
|
||||
set res {}
|
||||
foreach val {6a 18b 21aa 22a 35 36 48} {
|
||||
lappend res [lsearch -decreasing -sorted -dictionary \
|
||||
$decreasingDictionary $val]
|
||||
}
|
||||
set res
|
||||
} [list 6 5 4 3 2 1 0]
|
||||
|
||||
test lsearch-9.1 {ascii search} {
|
||||
set res {}
|
||||
foreach val {18b 21aa 22a 35 36 48 6a} {
|
||||
lappend res [lsearch -exact -ascii $increasingStrings $val]
|
||||
}
|
||||
set res
|
||||
} [list 0 1 2 3 4 5 6]
|
||||
test lsearch-9.2 {decreasing ascii search} {
|
||||
set res {}
|
||||
foreach val {18b 21aa 22a 35 36 48 6a} {
|
||||
lappend res [lsearch -exact -ascii $decreasingStrings $val]
|
||||
}
|
||||
set res
|
||||
} [list 6 5 4 3 2 1 0]
|
||||
test lsearch-9.3 {sorted ascii search} {
|
||||
set res {}
|
||||
foreach val {18b 21aa 22a 35 36 48 6a} {
|
||||
lappend res [lsearch -sorted -ascii $increasingStrings $val]
|
||||
}
|
||||
set res
|
||||
} [list 0 1 2 3 4 5 6]
|
||||
test lsearch-9.4 {decreasing sorted ascii search} {
|
||||
set res {}
|
||||
foreach val {18b 21aa 22a 35 36 48 6a} {
|
||||
lappend res [lsearch -decreasing -sorted -ascii \
|
||||
$decreasingStrings $val]
|
||||
}
|
||||
set res
|
||||
} [list 6 5 4 3 2 1 0]
|
||||
|
||||
test lsearch-10.1 {offset searching} {
|
||||
lsearch -start 2 {a b c a b c} a
|
||||
} 3
|
||||
test lsearch-10.2 {offset searching} {
|
||||
lsearch -start 2 {a b c d e f} a
|
||||
} -1
|
||||
test lsearch-10.3 {offset searching} {
|
||||
lsearch -start end-4 {a b c a b c} a
|
||||
} 3
|
||||
test lsearch-10.4 {offset searching} {
|
||||
list [catch {lsearch -start foobar {a b c a b c} a} msg] $msg
|
||||
} {1 {bad index "foobar": must be integer?[+-]integer? or end?[+-]integer?}}
|
||||
test lsearch-10.5 {offset searching} {
|
||||
list [catch {lsearch -start 1 2} msg] $msg
|
||||
} {1 {missing starting index}}
|
||||
test lsearch-10.6 {binary search with offset} {
|
||||
set res {}
|
||||
for {set i 0} {$i < 100} {incr i} {
|
||||
lappend res [lsearch -integer -start 2 -sorted $increasingIntegers $i]
|
||||
}
|
||||
set res
|
||||
} [concat -1 -1 [lrange $increasingIntegers 2 end]]
|
||||
test lsearch-10.7 {offset searching with an empty list} {
|
||||
# Stop bug #694232 from reocurring
|
||||
lsearch -start 0 {} x
|
||||
} -1
|
||||
test lsearch-10.8 {offset searching past the end of the list} {
|
||||
# Stop [Bug 1374778] from reoccurring
|
||||
lsearch -start 10 {a b c} c
|
||||
} -1
|
||||
test lsearch-10.9 {offset searching past the end of the list} {
|
||||
# Stop [Bug 1374778] from reoccurring
|
||||
lsearch -start 10 -all {a b c} c
|
||||
} {}
|
||||
test lsearch-10.10 {offset searching past the end of the list} {
|
||||
# Stop [Bug 1374778] from reoccurring
|
||||
lsearch -start 10 -inline {a b c} c
|
||||
} {}
|
||||
|
||||
test lsearch-11.1 {negated searches} {
|
||||
lsearch -not {a a a b a a a} a
|
||||
} 3
|
||||
test lsearch-11.2 {negated searches} {
|
||||
lsearch -not {a a a a a a a} a
|
||||
} -1
|
||||
|
||||
test lsearch-12.1 {return values instead of indices} {
|
||||
lsearch -glob -inline {a1 b2 c3 d4} c*
|
||||
} c3
|
||||
test lsearch-12.2 {return values instead of indices} {
|
||||
lsearch -glob -inline {a1 b2 c3 d4} e*
|
||||
} {}
|
||||
|
||||
test lsearch-13.1 {search for all matches} {
|
||||
lsearch -all {a b a c a d} 1
|
||||
} {}
|
||||
test lsearch-13.2 {search for all matches} {
|
||||
lsearch -all {a b a c a d} a
|
||||
} {0 2 4}
|
||||
test lsearch-13.3 {search for all matches with -nocase} {
|
||||
lsearch -all -exact -nocase {a b c A B C} A
|
||||
} {0 3}
|
||||
test lsearch-13.4 {search for all matches with -nocase} {
|
||||
lsearch -all -glob -nocase {a b c A B C} A*
|
||||
} {0 3}
|
||||
test lsearch-13.5 {search for all matches with -nocase} {
|
||||
lsearch -all -regexp -nocase {a b c A B C} ^A\$
|
||||
} {0 3}
|
||||
|
||||
test lsearch-14.1 {combinations: -all and -inline} {
|
||||
lsearch -all -inline -glob {a1 b2 a3 c4 a5 d6} a*
|
||||
} {a1 a3 a5}
|
||||
test lsearch-14.2 {combinations: -all, -inline and -not} {
|
||||
lsearch -all -inline -not -glob {a1 b2 a3 c4 a5 d6} a*
|
||||
} {b2 c4 d6}
|
||||
test lsearch-14.3 {combinations: -all and -not} {
|
||||
lsearch -all -not -glob {a1 b2 a3 c4 a5 d6} a*
|
||||
} {1 3 5}
|
||||
test lsearch-14.4 {combinations: -inline and -not} {
|
||||
lsearch -inline -not -glob {a1 b2 a3 c4 a5 d6} a*
|
||||
} {b2}
|
||||
test lsearch-14.5 {combinations: -start, -all and -inline} {
|
||||
lsearch -start 2 -all -inline -glob {a1 b2 a3 c4 a5 d6} a*
|
||||
} {a3 a5}
|
||||
test lsearch-14.6 {combinations: -start, -all, -inline and -not} {
|
||||
lsearch -start 2 -all -inline -not -glob {a1 b2 a3 c4 a5 d6} a*
|
||||
} {c4 d6}
|
||||
test lsearch-14.7 {combinations: -start, -all and -not} {
|
||||
lsearch -start 2 -all -not -glob {a1 b2 a3 c4 a5 d6} a*
|
||||
} {3 5}
|
||||
test lsearch-14.8 {combinations: -start, -inline and -not} {
|
||||
lsearch -start 2 -inline -not -glob {a1 b2 a3 c4 a5 d6} a*
|
||||
} {c4}
|
||||
|
||||
test lsearch-15.1 {make sure no shimmering occurs} {
|
||||
set x [expr int(sin(0))]
|
||||
lsearch -start $x $x $x
|
||||
} 0
|
||||
|
||||
test lsearch-16.1 {lsearch -regexp shared object} {
|
||||
set str a
|
||||
lsearch -regexp $str $str
|
||||
} 0
|
||||
# Bug 1366683
|
||||
test lsearch-16.2 {lsearch -regexp allows internal backrefs} {
|
||||
lsearch -regexp {a aa b} {(.)\1}
|
||||
} 1
|
||||
|
||||
test lsearch-17.1 {lsearch -index option, basic functionality} {
|
||||
lsearch -index 1 {{a c} {a b} {a a}} a
|
||||
} 2
|
||||
test lsearch-17.2 {lsearch -index option, basic functionality} {
|
||||
lsearch -index 1 -exact {{a c} {a b} {a a}} a
|
||||
} 2
|
||||
test lsearch-17.3 {lsearch -index option, basic functionality} {
|
||||
lsearch -index 1 -glob {{ab cb} {ab bb} {ab ab}} b*
|
||||
} 1
|
||||
test lsearch-17.4 {lsearch -index option, basic functionality} {
|
||||
lsearch -index 1 -regexp {{ab cb} {ab bb} {ab ab}} {[cb]b}
|
||||
} 0
|
||||
test lsearch-17.5 {lsearch -index option, basic functionality} {
|
||||
lsearch -all -index 0 -exact {{a c} {a b} {d a}} a
|
||||
} {0 1}
|
||||
test lsearch-17.6 {lsearch -index option, basic functionality} {
|
||||
lsearch -all -index 1 -glob {{ab cb} {ab bb} {db bx}} b*
|
||||
} {1 2}
|
||||
test lsearch-17.7 {lsearch -index option, basic functionality} {
|
||||
lsearch -all -index 1 -regexp {{ab cb} {ab bb} {ab ab}} {[cb]b}
|
||||
} {0 1}
|
||||
|
||||
test lsearch-18.1 {lsearch -index option, list as index basic functionality} {
|
||||
lsearch -index {0 0} {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a
|
||||
} 1
|
||||
test lsearch-18.2 {lsearch -index option, list as index basic functionality} {
|
||||
lsearch -index {2 0} -exact {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a
|
||||
} 0
|
||||
test lsearch-18.3 {lsearch -index option, list as index basic functionality} {
|
||||
lsearch -index {1 1} -glob {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} b*
|
||||
} 0
|
||||
test lsearch-18.4 {lsearch -index option, list as index basic functionality} {
|
||||
lsearch -index {0 1} -regexp {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} {[cb]b}
|
||||
} 0
|
||||
test lsearch-18.5 {lsearch -index option, list as index basic functionality} {
|
||||
lsearch -all -index {0 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a
|
||||
} {0 1}
|
||||
|
||||
test lsearch-19.1 {lsearch -sunindices option} {
|
||||
lsearch -subindices -index {0 0} {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a
|
||||
} {1 0 0}
|
||||
test lsearch-19.2 {lsearch -sunindices option} {
|
||||
lsearch -subindices -index {2 0} -exact {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a
|
||||
} {0 2 0}
|
||||
test lsearch-19.3 {lsearch -sunindices option} {
|
||||
lsearch -subindices -index {1 1} -glob {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} b*
|
||||
} {0 1 1}
|
||||
test lsearch-19.4 {lsearch -sunindices option} {
|
||||
lsearch -subindices -index {0 1} -regexp {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} {[cb]b}
|
||||
} {0 0 1}
|
||||
test lsearch-19.5 {lsearch -sunindices option} {
|
||||
lsearch -subindices -all -index {0 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a
|
||||
} {{0 0 0} {1 0 0}}
|
||||
|
||||
test lsearch-20.1 {lsearch -index option, index larger than sublists} {
|
||||
list [catch {lsearch -index 2 {{a c} {a b} {a a}} a} msg] $msg
|
||||
} {1 {element 2 missing from sublist "a c"}}
|
||||
test lsearch-20.2 {lsearch -index option, malformed index} {
|
||||
list [catch {lsearch -index foo {{a c} {a b} {a a}} a} msg] $msg
|
||||
} {1 {bad index "foo": must be integer?[+-]integer? or end?[+-]integer?}}
|
||||
test lsearch-20.3 {lsearch -index option, malformed index} {
|
||||
list [catch {lsearch -index \{ {{a c} {a b} {a a}} a} msg] $msg
|
||||
} {1 {unmatched open brace in list}}
|
||||
|
||||
test lsearch-21.1 {lsearch shimmering crash} {
|
||||
set x 0
|
||||
lsearch -exact -integer $x $x
|
||||
} 0
|
||||
test lsearch-21.2 {lsearch shimmering crash} {
|
||||
set x 0.5
|
||||
lsearch -exact -real $x $x
|
||||
} 0
|
||||
|
||||
# cleanup
|
||||
catch {unset res}
|
||||
catch {unset increasingIntegers}
|
||||
catch {unset decreasingIntegers}
|
||||
catch {unset increasingDoubles}
|
||||
catch {unset decreasingDoubles}
|
||||
catch {unset increasingStrings}
|
||||
catch {unset decreasingStrings}
|
||||
catch {unset increasingDictionary}
|
||||
catch {unset decreasingDictionary}
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
416
tests/lset.test
Normal file
416
tests/lset.test
Normal file
@@ -0,0 +1,416 @@
|
||||
# This file is a -*- tcl -*- test script
|
||||
|
||||
# Commands covered: lset
|
||||
#
|
||||
# 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) 2001 by Kevin B. Kenny. All rights reserved.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
proc failTrace {name1 name2 op} {
|
||||
error "trace failed"
|
||||
}
|
||||
|
||||
testConstraint testevalex [llength [info commands testevalex]]
|
||||
|
||||
set noRead {}
|
||||
trace add variable noRead read failTrace
|
||||
set noWrite {a b c}
|
||||
trace add variable noWrite write failTrace
|
||||
|
||||
test lset-1.1 {lset, not compiled, arg count} testevalex {
|
||||
list [catch {testevalex lset} msg] $msg
|
||||
} "1 {wrong \# args: should be \"lset listVar ?index? ?index...? value\"}"
|
||||
test lset-1.2 {lset, not compiled, no such var} testevalex {
|
||||
list [catch {testevalex {lset noSuchVar 0 {}}} msg] $msg
|
||||
} "1 {can't read \"noSuchVar\": no such variable}"
|
||||
test lset-1.3 {lset, not compiled, var not readable} testevalex {
|
||||
list [catch {testevalex {lset noRead 0 {}}} msg] $msg
|
||||
} "1 {can't read \"noRead\": trace failed}"
|
||||
|
||||
test lset-2.1 {lset, not compiled, 3 args, second arg a plain index} testevalex {
|
||||
set x {0 1 2}
|
||||
list [testevalex {lset x 0 3}] $x
|
||||
} {{3 1 2} {3 1 2}}
|
||||
test lset-2.2 {lset, not compiled, 3 args, second arg neither index nor list} testevalex {
|
||||
set x {0 1 2}
|
||||
list [catch {
|
||||
testevalex {lset x {{bad}1} 3}
|
||||
} msg] $msg
|
||||
} {1 {bad index "{bad}1": must be integer?[+-]integer? or end?[+-]integer?}}
|
||||
|
||||
test lset-3.1 {lset, not compiled, 3 args, data duplicated} testevalex {
|
||||
set x {0 1 2}
|
||||
list [testevalex {lset x 0 $x}] $x
|
||||
} {{{0 1 2} 1 2} {{0 1 2} 1 2}}
|
||||
test lset-3.2 {lset, not compiled, 3 args, data duplicated} testevalex {
|
||||
set x {0 1}
|
||||
set y $x
|
||||
list [testevalex {lset x 0 2}] $x $y
|
||||
} {{2 1} {2 1} {0 1}}
|
||||
test lset-3.3 {lset, not compiled, 3 args, data duplicated} testevalex {
|
||||
set x {0 1}
|
||||
set y $x
|
||||
list [testevalex {lset x 0 $x}] $x $y
|
||||
} {{{0 1} 1} {{0 1} 1} {0 1}}
|
||||
test lset-3.4 {lset, not compiled, 3 args, data duplicated} testevalex {
|
||||
set x {0 1 2}
|
||||
list [testevalex {lset x [list 0] $x}] $x
|
||||
} {{{0 1 2} 1 2} {{0 1 2} 1 2}}
|
||||
test lset-3.5 {lset, not compiled, 3 args, data duplicated} testevalex {
|
||||
set x {0 1}
|
||||
set y $x
|
||||
list [testevalex {lset x [list 0] 2}] $x $y
|
||||
} {{2 1} {2 1} {0 1}}
|
||||
test lset-3.6 {lset, not compiled, 3 args, data duplicated} testevalex {
|
||||
set x {0 1}
|
||||
set y $x
|
||||
list [testevalex {lset x [list 0] $x}] $x $y
|
||||
} {{{0 1} 1} {{0 1} 1} {0 1}}
|
||||
|
||||
test lset-4.1 {lset, not compiled, 3 args, not a list} testevalex {
|
||||
set a "x \{"
|
||||
list [catch {
|
||||
testevalex {lset a [list 0] y}
|
||||
} msg] $msg
|
||||
} {1 {unmatched open brace in list}}
|
||||
test lset-4.2 {lset, not compiled, 3 args, bad index} testevalex {
|
||||
set a {x y z}
|
||||
list [catch {
|
||||
testevalex {lset a [list 2a2] w}
|
||||
} msg] $msg
|
||||
} {1 {bad index "2a2": must be integer?[+-]integer? or end?[+-]integer?}}
|
||||
test lset-4.3 {lset, not compiled, 3 args, index out of range} testevalex {
|
||||
set a {x y z}
|
||||
list [catch {
|
||||
testevalex {lset a [list -1] w}
|
||||
} msg] $msg
|
||||
} {1 {list index out of range}}
|
||||
test lset-4.4 {lset, not compiled, 3 args, index out of range} testevalex {
|
||||
set a {x y z}
|
||||
list [catch {
|
||||
testevalex {lset a [list 3] w}
|
||||
} msg] $msg
|
||||
} {1 {list index out of range}}
|
||||
test lset-4.5 {lset, not compiled, 3 args, index out of range} testevalex {
|
||||
set a {x y z}
|
||||
list [catch {
|
||||
testevalex {lset a [list end--1] w}
|
||||
} msg] $msg
|
||||
} {1 {list index out of range}}
|
||||
test lset-4.6 {lset, not compiled, 3 args, index out of range} testevalex {
|
||||
set a {x y z}
|
||||
list [catch {
|
||||
testevalex {lset a [list end-3] w}
|
||||
} msg] $msg
|
||||
} {1 {list index out of range}}
|
||||
test lset-4.7 {lset, not compiled, 3 args, not a list} testevalex {
|
||||
set a "x \{"
|
||||
list [catch {
|
||||
testevalex {lset a 0 y}
|
||||
} msg] $msg
|
||||
} {1 {unmatched open brace in list}}
|
||||
test lset-4.8 {lset, not compiled, 3 args, bad index} testevalex {
|
||||
set a {x y z}
|
||||
list [catch {
|
||||
testevalex {lset a 2a2 w}
|
||||
} msg] $msg
|
||||
} {1 {bad index "2a2": must be integer?[+-]integer? or end?[+-]integer?}}
|
||||
test lset-4.9 {lset, not compiled, 3 args, index out of range} testevalex {
|
||||
set a {x y z}
|
||||
list [catch {
|
||||
testevalex {lset a -1 w}
|
||||
} msg] $msg
|
||||
} {1 {list index out of range}}
|
||||
test lset-4.10 {lset, not compiled, 3 args, index out of range} testevalex {
|
||||
set a {x y z}
|
||||
list [catch {
|
||||
testevalex {lset a 3 w}
|
||||
} msg] $msg
|
||||
} {1 {list index out of range}}
|
||||
test lset-4.11 {lset, not compiled, 3 args, index out of range} testevalex {
|
||||
set a {x y z}
|
||||
list [catch {
|
||||
testevalex {lset a end--1 w}
|
||||
} msg] $msg
|
||||
} {1 {list index out of range}}
|
||||
test lset-4.12 {lset, not compiled, 3 args, index out of range} testevalex {
|
||||
set a {x y z}
|
||||
list [catch {
|
||||
testevalex {lset a end-3 w}
|
||||
} msg] $msg
|
||||
} {1 {list index out of range}}
|
||||
|
||||
test lset-5.1 {lset, not compiled, 3 args, can't set variable} testevalex {
|
||||
list [catch {
|
||||
testevalex {lset noWrite 0 d}
|
||||
} msg] $msg $noWrite
|
||||
} {1 {can't set "noWrite": trace failed} {d b c}}
|
||||
test lset-5.2 {lset, not compiled, 3 args, can't set variable} testevalex {
|
||||
list [catch {
|
||||
testevalex {lset noWrite [list 0] d}
|
||||
} msg] $msg $noWrite
|
||||
} {1 {can't set "noWrite": trace failed} {d b c}}
|
||||
|
||||
test lset-6.1 {lset, not compiled, 3 args, 1-d list basics} testevalex {
|
||||
set a {x y z}
|
||||
list [testevalex {lset a 0 a}] $a
|
||||
} {{a y z} {a y z}}
|
||||
test lset-6.2 {lset, not compiled, 3 args, 1-d list basics} testevalex {
|
||||
set a {x y z}
|
||||
list [testevalex {lset a [list 0] a}] $a
|
||||
} {{a y z} {a y z}}
|
||||
test lset-6.3 {lset, not compiled, 1-d list basics} testevalex {
|
||||
set a {x y z}
|
||||
list [testevalex {lset a 2 a}] $a
|
||||
} {{x y a} {x y a}}
|
||||
test lset-6.4 {lset, not compiled, 1-d list basics} testevalex {
|
||||
set a {x y z}
|
||||
list [testevalex {lset a [list 2] a}] $a
|
||||
} {{x y a} {x y a}}
|
||||
test lset-6.5 {lset, not compiled, 1-d list basics} testevalex {
|
||||
set a {x y z}
|
||||
list [testevalex {lset a end a}] $a
|
||||
} {{x y a} {x y a}}
|
||||
test lset-6.6 {lset, not compiled, 1-d list basics} testevalex {
|
||||
set a {x y z}
|
||||
list [testevalex {lset a [list end] a}] $a
|
||||
} {{x y a} {x y a}}
|
||||
test lset-6.7 {lset, not compiled, 1-d list basics} testevalex {
|
||||
set a {x y z}
|
||||
list [testevalex {lset a end-0 a}] $a
|
||||
} {{x y a} {x y a}}
|
||||
test lset-6.8 {lset, not compiled, 1-d list basics} testevalex {
|
||||
set a {x y z}
|
||||
list [testevalex {lset a [list end-0] a}] $a
|
||||
} {{x y a} {x y a}}
|
||||
test lset-6.9 {lset, not compiled, 1-d list basics} testevalex {
|
||||
set a {x y z}
|
||||
list [testevalex {lset a end-2 a}] $a
|
||||
} {{a y z} {a y z}}
|
||||
test lset-6.10 {lset, not compiled, 1-d list basics} testevalex {
|
||||
set a {x y z}
|
||||
list [testevalex {lset a [list end-2] a}] $a
|
||||
} {{a y z} {a y z}}
|
||||
|
||||
test lset-7.1 {lset, not compiled, data sharing} testevalex {
|
||||
set a 0
|
||||
list [testevalex {lset a $a {gag me}}] $a
|
||||
} {{{gag me}} {{gag me}}}
|
||||
test lset-7.2 {lset, not compiled, data sharing} testevalex {
|
||||
set a [list 0]
|
||||
list [testevalex {lset a $a {gag me}}] $a
|
||||
} {{{gag me}} {{gag me}}}
|
||||
test lset-7.3 {lset, not compiled, data sharing} testevalex {
|
||||
set a {x y}
|
||||
list [testevalex {lset a 0 $a}] $a
|
||||
} {{{x y} y} {{x y} y}}
|
||||
test lset-7.4 {lset, not compiled, data sharing} testevalex {
|
||||
set a {x y}
|
||||
list [testevalex {lset a [list 0] $a}] $a
|
||||
} {{{x y} y} {{x y} y}}
|
||||
test lset-7.5 {lset, not compiled, data sharing} testevalex {
|
||||
set n 0
|
||||
set a {x y}
|
||||
list [testevalex {lset a $n $n}] $a $n
|
||||
} {{0 y} {0 y} 0}
|
||||
test lset-7.6 {lset, not compiled, data sharing} testevalex {
|
||||
set n [list 0]
|
||||
set a {x y}
|
||||
list [testevalex {lset a $n $n}] $a $n
|
||||
} {{0 y} {0 y} 0}
|
||||
test lset-7.7 {lset, not compiled, data sharing} testevalex {
|
||||
set n 0
|
||||
set a [list $n $n]
|
||||
list [testevalex {lset a $n 1}] $a $n
|
||||
} {{1 0} {1 0} 0}
|
||||
test lset-7.8 {lset, not compiled, data sharing} testevalex {
|
||||
set n [list 0]
|
||||
set a [list $n $n]
|
||||
list [testevalex {lset a $n 1}] $a $n
|
||||
} {{1 0} {1 0} 0}
|
||||
test lset-7.9 {lset, not compiled, data sharing} testevalex {
|
||||
set a 0
|
||||
list [testevalex {lset a $a $a}] $a
|
||||
} {0 0}
|
||||
test lset-7.10 {lset, not compiled, data sharing} testevalex {
|
||||
set a [list 0]
|
||||
list [testevalex {lset a $a $a}] $a
|
||||
} {0 0}
|
||||
|
||||
test lset-8.1 {lset, not compiled, malformed sublist} testevalex {
|
||||
set a [list "a \{" b]
|
||||
list [catch {testevalex {lset a 0 1 c}} msg] $msg
|
||||
} {1 {unmatched open brace in list}}
|
||||
test lset-8.2 {lset, not compiled, malformed sublist} testevalex {
|
||||
set a [list "a \{" b]
|
||||
list [catch {testevalex {lset a {0 1} c}} msg] $msg
|
||||
} {1 {unmatched open brace in list}}
|
||||
test lset-8.3 {lset, not compiled, bad second index} testevalex {
|
||||
set a {{b c} {d e}}
|
||||
list [catch {testevalex {lset a 0 2a2 f}} msg] $msg
|
||||
} {1 {bad index "2a2": must be integer?[+-]integer? or end?[+-]integer?}}
|
||||
test lset-8.4 {lset, not compiled, bad second index} testevalex {
|
||||
set a {{b c} {d e}}
|
||||
list [catch {testevalex {lset a {0 2a2} f}} msg] $msg
|
||||
} {1 {bad index "2a2": must be integer?[+-]integer? or end?[+-]integer?}}
|
||||
test lset-8.5 {lset, not compiled, second index out of range} testevalex {
|
||||
set a {{b c} {d e} {f g}}
|
||||
list [catch {testevalex {lset a 2 -1 h}} msg] $msg
|
||||
} {1 {list index out of range}}
|
||||
test lset-8.6 {lset, not compiled, second index out of range} testevalex {
|
||||
set a {{b c} {d e} {f g}}
|
||||
list [catch {testevalex {lset a {2 -1} h}} msg] $msg
|
||||
} {1 {list index out of range}}
|
||||
test lset-8.7 {lset, not compiled, second index out of range} testevalex {
|
||||
set a {{b c} {d e} {f g}}
|
||||
list [catch {testevalex {lset a 2 2 h}} msg] $msg
|
||||
} {1 {list index out of range}}
|
||||
test lset-8.8 {lset, not compiled, second index out of range} testevalex {
|
||||
set a {{b c} {d e} {f g}}
|
||||
list [catch {testevalex {lset a {2 2} h}} msg] $msg
|
||||
} {1 {list index out of range}}
|
||||
test lset-8.9 {lset, not compiled, second index out of range} testevalex {
|
||||
set a {{b c} {d e} {f g}}
|
||||
list [catch {testevalex {lset a 2 end--1 h}} msg] $msg
|
||||
} {1 {list index out of range}}
|
||||
test lset-8.10 {lset, not compiled, second index out of range} testevalex {
|
||||
set a {{b c} {d e} {f g}}
|
||||
list [catch {testevalex {lset a {2 end--1} h}} msg] $msg
|
||||
} {1 {list index out of range}}
|
||||
test lset-8.11 {lset, not compiled, second index out of range} testevalex {
|
||||
set a {{b c} {d e} {f g}}
|
||||
list [catch {testevalex {lset a 2 end-2 h}} msg] $msg
|
||||
} {1 {list index out of range}}
|
||||
test lset-8.12 {lset, not compiled, second index out of range} testevalex {
|
||||
set a {{b c} {d e} {f g}}
|
||||
list [catch {testevalex {lset a {2 end-2} h}} msg] $msg
|
||||
} {1 {list index out of range}}
|
||||
|
||||
test lset-9.1 {lset, not compiled, entire variable} testevalex {
|
||||
set a x
|
||||
list [testevalex {lset a y}] $a
|
||||
} {y y}
|
||||
test lset-9.2 {lset, not compiled, entire variable} testevalex {
|
||||
set a x
|
||||
list [testevalex {lset a {} y}] $a
|
||||
} {y y}
|
||||
|
||||
test lset-10.1 {lset, not compiled, shared data} testevalex {
|
||||
set row {p q}
|
||||
set a [list $row $row]
|
||||
list [testevalex {lset a 0 0 x}] $a
|
||||
} {{{x q} {p q}} {{x q} {p q}}}
|
||||
test lset-10.2 {lset, not compiled, shared data} testevalex {
|
||||
set row {p q}
|
||||
set a [list $row $row]
|
||||
list [testevalex {lset a {0 0} x}] $a
|
||||
} {{{x q} {p q}} {{x q} {p q}}}
|
||||
test lset-10.3 {lset, not compiled, shared data, [Bug 1333036]} testevalex {
|
||||
set a [list [list p q] [list r s]]
|
||||
set b $a
|
||||
list [testevalex {lset b {0 0} x}] $a
|
||||
} {{{x q} {r s}} {{p q} {r s}}}
|
||||
|
||||
test lset-11.1 {lset, not compiled, 2-d basics} testevalex {
|
||||
set a {{b c} {d e}}
|
||||
list [testevalex {lset a 0 0 f}] $a
|
||||
} {{{f c} {d e}} {{f c} {d e}}}
|
||||
test lset-11.2 {lset, not compiled, 2-d basics} testevalex {
|
||||
set a {{b c} {d e}}
|
||||
list [testevalex {lset a {0 0} f}] $a
|
||||
} {{{f c} {d e}} {{f c} {d e}}}
|
||||
test lset-11.3 {lset, not compiled, 2-d basics} testevalex {
|
||||
set a {{b c} {d e}}
|
||||
list [testevalex {lset a 0 1 f}] $a
|
||||
} {{{b f} {d e}} {{b f} {d e}}}
|
||||
test lset-11.4 {lset, not compiled, 2-d basics} testevalex {
|
||||
set a {{b c} {d e}}
|
||||
list [testevalex {lset a {0 1} f}] $a
|
||||
} {{{b f} {d e}} {{b f} {d e}}}
|
||||
test lset-11.5 {lset, not compiled, 2-d basics} testevalex {
|
||||
set a {{b c} {d e}}
|
||||
list [testevalex {lset a 1 0 f}] $a
|
||||
} {{{b c} {f e}} {{b c} {f e}}}
|
||||
test lset-11.6 {lset, not compiled, 2-d basics} testevalex {
|
||||
set a {{b c} {d e}}
|
||||
list [testevalex {lset a {1 0} f}] $a
|
||||
} {{{b c} {f e}} {{b c} {f e}}}
|
||||
test lset-11.7 {lset, not compiled, 2-d basics} testevalex {
|
||||
set a {{b c} {d e}}
|
||||
list [testevalex {lset a 1 1 f}] $a
|
||||
} {{{b c} {d f}} {{b c} {d f}}}
|
||||
test lset-11.8 {lset, not compiled, 2-d basics} testevalex {
|
||||
set a {{b c} {d e}}
|
||||
list [testevalex {lset a {1 1} f}] $a
|
||||
} {{{b c} {d f}} {{b c} {d f}}}
|
||||
|
||||
test lset-12.0 {lset, not compiled, typical sharing pattern} testevalex {
|
||||
set zero 0
|
||||
set row [list $zero $zero $zero $zero]
|
||||
set ident [list $row $row $row $row]
|
||||
for { set i 0 } { $i < 4 } { incr i } {
|
||||
testevalex {lset ident $i $i 1}
|
||||
}
|
||||
set ident
|
||||
} {{1 0 0 0} {0 1 0 0} {0 0 1 0} {0 0 0 1}}
|
||||
|
||||
test lset-13.0 {lset, not compiled, shimmering hell} testevalex {
|
||||
set a 0
|
||||
list [testevalex {lset a $a $a $a $a {gag me}}] $a
|
||||
} {{{{{{gag me}}}}} {{{{{gag me}}}}}}
|
||||
test lset-13.1 {lset, not compiled, shimmering hell} testevalex {
|
||||
set a [list 0]
|
||||
list [testevalex {lset a $a $a $a $a {gag me}}] $a
|
||||
} {{{{{{gag me}}}}} {{{{{gag me}}}}}}
|
||||
test lset-13.2 {lset, not compiled, shimmering hell} testevalex {
|
||||
set a [list 0 0 0 0]
|
||||
list [testevalex {lset a $a {gag me}}] $a
|
||||
} {{{{{{gag me}}}} 0 0 0} {{{{{gag me}}}} 0 0 0}}
|
||||
|
||||
test lset-14.1 {lset, not compiled, list args, is string rep preserved?} testevalex {
|
||||
set a { { 1 2 } { 3 4 } }
|
||||
catch { testevalex {lset a {1 5} 5} }
|
||||
list $a [lindex $a 1]
|
||||
} "{ { 1 2 } { 3 4 } } { 3 4 }"
|
||||
test lset-14.2 {lset, not compiled, flat args, is string rep preserved?} testevalex {
|
||||
set a { { 1 2 } { 3 4 } }
|
||||
catch { testevalex {lset a 1 5 5} }
|
||||
list $a [lindex $a 1]
|
||||
} "{ { 1 2 } { 3 4 } } { 3 4 }"
|
||||
|
||||
testConstraint testobj [llength [info commands testobj]]
|
||||
test lset-15.1 {lset: shared intrep [Bug 1677512]} -setup {
|
||||
teststringobj set 1 {{1 2} 3}
|
||||
testobj convert 1 list
|
||||
testobj duplicate 1 2
|
||||
variable x [teststringobj get 1]
|
||||
variable y [teststringobj get 2]
|
||||
testobj freeallvars
|
||||
set l [list $y z]
|
||||
unset y
|
||||
} -constraints testobj -body {
|
||||
lset l 0 0 0 5
|
||||
lindex $x 0 0
|
||||
} -cleanup {
|
||||
unset -nocomplain x l
|
||||
} -result 1
|
||||
|
||||
catch {unset noRead}
|
||||
catch {unset noWrite}
|
||||
catch {rename failTrace {}}
|
||||
catch {unset ::x}
|
||||
catch {unset ::y}
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
431
tests/lsetComp.test
Normal file
431
tests/lsetComp.test
Normal file
@@ -0,0 +1,431 @@
|
||||
# This file is a -*- tcl -*- test script
|
||||
|
||||
# Commands covered: lset
|
||||
#
|
||||
# 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) 2001 by Kevin B. Kenny. All rights reserved.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
# Procedure to evaluate a script within a proc, to test compilation
|
||||
# functionality
|
||||
|
||||
proc evalInProc { script } {
|
||||
proc testProc {} $script
|
||||
set status [catch {
|
||||
testProc
|
||||
} result]
|
||||
rename testProc {}
|
||||
return [list $status $result]
|
||||
}
|
||||
|
||||
# Tests for the bytecode compilation of the 'lset' command
|
||||
|
||||
test lsetComp-1.1 {lset, compiled, wrong \# args} {
|
||||
evalInProc {
|
||||
lset
|
||||
}
|
||||
} "1 {wrong \# args: should be \"lset listVar ?index? ?index...? value\"}"
|
||||
|
||||
test lsetComp-2.1 {lset, compiled, list of args, not a simple var name} {
|
||||
evalInProc {
|
||||
set y x
|
||||
set x {{1 2} {3 4}}
|
||||
lset $y {1 1} 5
|
||||
}
|
||||
} "0 {{1 2} {3 5}}"
|
||||
|
||||
test lsetComp-2.2 {lset, compiled, list of args, scalar on stack} {
|
||||
evalInProc {
|
||||
set ::x {{1 2} {3 4}}
|
||||
lset ::x {1 1} 5
|
||||
}
|
||||
} "0 {{1 2} {3 5}}"
|
||||
|
||||
test lsetComp-2.3 {lset, compiled, list of args, scalar, one-byte offset} {
|
||||
evalInProc {
|
||||
set x {{1 2} {3 4}}
|
||||
lset x {1 1} 5
|
||||
}
|
||||
} "0 {{1 2} {3 5}}"
|
||||
|
||||
test lsetComp-2.4 {lset, compiled, list of args, scalar, four-byte offset} {
|
||||
evalInProc {
|
||||
set x0 0; set x1 0; set x2 0; set x3 0;
|
||||
set x4 0; set x5 0; set x6 0; set x7 0;
|
||||
set x8 0; set x9 0; set x10 0; set x11 0;
|
||||
set x12 0; set x13 0; set x14 0; set x15 0;
|
||||
set x16 0; set x17 0; set x18 0; set x19 0;
|
||||
set x20 0; set x21 0; set x22 0; set x23 0;
|
||||
set x24 0; set x25 0; set x26 0; set x27 0;
|
||||
set x28 0; set x29 0; set x30 0; set x31 0;
|
||||
set x32 0; set x33 0; set x34 0; set x35 0;
|
||||
set x36 0; set x37 0; set x38 0; set x39 0;
|
||||
set x40 0; set x41 0; set x42 0; set x43 0;
|
||||
set x44 0; set x45 0; set x46 0; set x47 0;
|
||||
set x48 0; set x49 0; set x50 0; set x51 0;
|
||||
set x52 0; set x53 0; set x54 0; set x55 0;
|
||||
set x56 0; set x57 0; set x58 0; set x59 0;
|
||||
set x60 0; set x61 0; set x62 0; set x63 0;
|
||||
set x64 0; set x65 0; set x66 0; set x67 0;
|
||||
set x68 0; set x69 0; set x70 0; set x71 0;
|
||||
set x72 0; set x73 0; set x74 0; set x75 0;
|
||||
set x76 0; set x77 0; set x78 0; set x79 0;
|
||||
set x80 0; set x81 0; set x82 0; set x83 0;
|
||||
set x84 0; set x85 0; set x86 0; set x87 0;
|
||||
set x88 0; set x89 0; set x90 0; set x91 0;
|
||||
set x92 0; set x93 0; set x94 0; set x95 0;
|
||||
set x96 0; set x97 0; set x98 0; set x99 0;
|
||||
set x100 0; set x101 0; set x102 0; set x103 0;
|
||||
set x104 0; set x105 0; set x106 0; set x107 0;
|
||||
set x108 0; set x109 0; set x110 0; set x111 0;
|
||||
set x112 0; set x113 0; set x114 0; set x115 0;
|
||||
set x116 0; set x117 0; set x118 0; set x119 0;
|
||||
set x120 0; set x121 0; set x122 0; set x123 0;
|
||||
set x124 0; set x125 0; set x126 0; set x127 0;
|
||||
set x128 0; set x129 0; set x130 0; set x131 0;
|
||||
set x132 0; set x133 0; set x134 0; set x135 0;
|
||||
set x136 0; set x137 0; set x138 0; set x139 0;
|
||||
set x140 0; set x141 0; set x142 0; set x143 0;
|
||||
set x144 0; set x145 0; set x146 0; set x147 0;
|
||||
set x148 0; set x149 0; set x150 0; set x151 0;
|
||||
set x152 0; set x153 0; set x154 0; set x155 0;
|
||||
set x156 0; set x157 0; set x158 0; set x159 0;
|
||||
set x160 0; set x161 0; set x162 0; set x163 0;
|
||||
set x164 0; set x165 0; set x166 0; set x167 0;
|
||||
set x168 0; set x169 0; set x170 0; set x171 0;
|
||||
set x172 0; set x173 0; set x174 0; set x175 0;
|
||||
set x176 0; set x177 0; set x178 0; set x179 0;
|
||||
set x180 0; set x181 0; set x182 0; set x183 0;
|
||||
set x184 0; set x185 0; set x186 0; set x187 0;
|
||||
set x188 0; set x189 0; set x190 0; set x191 0;
|
||||
set x192 0; set x193 0; set x194 0; set x195 0;
|
||||
set x196 0; set x197 0; set x198 0; set x199 0;
|
||||
set x200 0; set x201 0; set x202 0; set x203 0;
|
||||
set x204 0; set x205 0; set x206 0; set x207 0;
|
||||
set x208 0; set x209 0; set x210 0; set x211 0;
|
||||
set x212 0; set x213 0; set x214 0; set x215 0;
|
||||
set x216 0; set x217 0; set x218 0; set x219 0;
|
||||
set x220 0; set x221 0; set x222 0; set x223 0;
|
||||
set x224 0; set x225 0; set x226 0; set x227 0;
|
||||
set x228 0; set x229 0; set x230 0; set x231 0;
|
||||
set x232 0; set x233 0; set x234 0; set x235 0;
|
||||
set x236 0; set x237 0; set x238 0; set x239 0;
|
||||
set x240 0; set x241 0; set x242 0; set x243 0;
|
||||
set x244 0; set x245 0; set x246 0; set x247 0;
|
||||
set x248 0; set x249 0; set x250 0; set x251 0;
|
||||
set x252 0; set x253 0; set x254 0; set x255 0;
|
||||
set x {{1 2} {3 4}}
|
||||
lset x {1 1} 5
|
||||
}
|
||||
} "0 {{1 2} {3 5}}"
|
||||
|
||||
test lsetComp-2.5 {lset, compiled, list of args, array on stack} {
|
||||
evalInProc {
|
||||
set ::y(0) {{1 2} {3 4}}
|
||||
lset ::y(0) {1 1} 5
|
||||
}
|
||||
} "0 {{1 2} {3 5}}"
|
||||
|
||||
test lsetComp-2.6 {lset, compiled, list of args, array, one-byte offset} {
|
||||
evalInProc {
|
||||
set y(0) {{1 2} {3 4}}
|
||||
lset y(0) {1 1} 5
|
||||
}
|
||||
} "0 {{1 2} {3 5}}"
|
||||
|
||||
test lsetComp-2.7 {lset, compiled, list of args, array, four-byte offset} {
|
||||
evalInProc {
|
||||
set x0 0; set x1 0; set x2 0; set x3 0;
|
||||
set x4 0; set x5 0; set x6 0; set x7 0;
|
||||
set x8 0; set x9 0; set x10 0; set x11 0;
|
||||
set x12 0; set x13 0; set x14 0; set x15 0;
|
||||
set x16 0; set x17 0; set x18 0; set x19 0;
|
||||
set x20 0; set x21 0; set x22 0; set x23 0;
|
||||
set x24 0; set x25 0; set x26 0; set x27 0;
|
||||
set x28 0; set x29 0; set x30 0; set x31 0;
|
||||
set x32 0; set x33 0; set x34 0; set x35 0;
|
||||
set x36 0; set x37 0; set x38 0; set x39 0;
|
||||
set x40 0; set x41 0; set x42 0; set x43 0;
|
||||
set x44 0; set x45 0; set x46 0; set x47 0;
|
||||
set x48 0; set x49 0; set x50 0; set x51 0;
|
||||
set x52 0; set x53 0; set x54 0; set x55 0;
|
||||
set x56 0; set x57 0; set x58 0; set x59 0;
|
||||
set x60 0; set x61 0; set x62 0; set x63 0;
|
||||
set x64 0; set x65 0; set x66 0; set x67 0;
|
||||
set x68 0; set x69 0; set x70 0; set x71 0;
|
||||
set x72 0; set x73 0; set x74 0; set x75 0;
|
||||
set x76 0; set x77 0; set x78 0; set x79 0;
|
||||
set x80 0; set x81 0; set x82 0; set x83 0;
|
||||
set x84 0; set x85 0; set x86 0; set x87 0;
|
||||
set x88 0; set x89 0; set x90 0; set x91 0;
|
||||
set x92 0; set x93 0; set x94 0; set x95 0;
|
||||
set x96 0; set x97 0; set x98 0; set x99 0;
|
||||
set x100 0; set x101 0; set x102 0; set x103 0;
|
||||
set x104 0; set x105 0; set x106 0; set x107 0;
|
||||
set x108 0; set x109 0; set x110 0; set x111 0;
|
||||
set x112 0; set x113 0; set x114 0; set x115 0;
|
||||
set x116 0; set x117 0; set x118 0; set x119 0;
|
||||
set x120 0; set x121 0; set x122 0; set x123 0;
|
||||
set x124 0; set x125 0; set x126 0; set x127 0;
|
||||
set x128 0; set x129 0; set x130 0; set x131 0;
|
||||
set x132 0; set x133 0; set x134 0; set x135 0;
|
||||
set x136 0; set x137 0; set x138 0; set x139 0;
|
||||
set x140 0; set x141 0; set x142 0; set x143 0;
|
||||
set x144 0; set x145 0; set x146 0; set x147 0;
|
||||
set x148 0; set x149 0; set x150 0; set x151 0;
|
||||
set x152 0; set x153 0; set x154 0; set x155 0;
|
||||
set x156 0; set x157 0; set x158 0; set x159 0;
|
||||
set x160 0; set x161 0; set x162 0; set x163 0;
|
||||
set x164 0; set x165 0; set x166 0; set x167 0;
|
||||
set x168 0; set x169 0; set x170 0; set x171 0;
|
||||
set x172 0; set x173 0; set x174 0; set x175 0;
|
||||
set x176 0; set x177 0; set x178 0; set x179 0;
|
||||
set x180 0; set x181 0; set x182 0; set x183 0;
|
||||
set x184 0; set x185 0; set x186 0; set x187 0;
|
||||
set x188 0; set x189 0; set x190 0; set x191 0;
|
||||
set x192 0; set x193 0; set x194 0; set x195 0;
|
||||
set x196 0; set x197 0; set x198 0; set x199 0;
|
||||
set x200 0; set x201 0; set x202 0; set x203 0;
|
||||
set x204 0; set x205 0; set x206 0; set x207 0;
|
||||
set x208 0; set x209 0; set x210 0; set x211 0;
|
||||
set x212 0; set x213 0; set x214 0; set x215 0;
|
||||
set x216 0; set x217 0; set x218 0; set x219 0;
|
||||
set x220 0; set x221 0; set x222 0; set x223 0;
|
||||
set x224 0; set x225 0; set x226 0; set x227 0;
|
||||
set x228 0; set x229 0; set x230 0; set x231 0;
|
||||
set x232 0; set x233 0; set x234 0; set x235 0;
|
||||
set x236 0; set x237 0; set x238 0; set x239 0;
|
||||
set x240 0; set x241 0; set x242 0; set x243 0;
|
||||
set x244 0; set x245 0; set x246 0; set x247 0;
|
||||
set x248 0; set x249 0; set x250 0; set x251 0;
|
||||
set x252 0; set x253 0; set x254 0; set x255 0;
|
||||
set y(0) {{1 2} {3 4}}
|
||||
lset y(0) {1 1} 5
|
||||
}
|
||||
} "0 {{1 2} {3 5}}"
|
||||
|
||||
test lsetComp-2.8 {lset, compiled, list of args, error } {
|
||||
evalInProc {
|
||||
set x { {1 2} {3 4} }
|
||||
lset x {1 5} 5
|
||||
}
|
||||
} "1 {list index out of range}"
|
||||
|
||||
test lsetComp-2.9 {lset, compiled, list of args, error - is string preserved} {
|
||||
set ::x { { 1 2 } { 3 4 } }
|
||||
evalInProc {
|
||||
lset ::x { 1 5 } 5
|
||||
}
|
||||
list $::x [lindex $::x 1]
|
||||
} "{ { 1 2 } { 3 4 } } { 3 4 }"
|
||||
|
||||
test lsetComp-3.1 {lset, compiled, flat args, not a simple var name} {
|
||||
evalInProc {
|
||||
set y x
|
||||
set x {{1 2} {3 4}}
|
||||
lset $y 1 1 5
|
||||
}
|
||||
} "0 {{1 2} {3 5}}"
|
||||
|
||||
test lsetComp-3.2 {lset, compiled, flat args, scalar on stack} {
|
||||
evalInProc {
|
||||
set ::x {{1 2} {3 4}}
|
||||
lset ::x 1 1 5
|
||||
}
|
||||
} "0 {{1 2} {3 5}}"
|
||||
|
||||
test lsetComp-3.3 {lset, compiled, flat args, scalar, one-byte offset} {
|
||||
evalInProc {
|
||||
set x {{1 2} {3 4}}
|
||||
lset x 1 1 5
|
||||
}
|
||||
} "0 {{1 2} {3 5}}"
|
||||
|
||||
test lsetComp-3.4 {lset, compiled, scalar, four-byte offset} {
|
||||
evalInProc {
|
||||
set x0 0; set x1 0; set x2 0; set x3 0;
|
||||
set x4 0; set x5 0; set x6 0; set x7 0;
|
||||
set x8 0; set x9 0; set x10 0; set x11 0;
|
||||
set x12 0; set x13 0; set x14 0; set x15 0;
|
||||
set x16 0; set x17 0; set x18 0; set x19 0;
|
||||
set x20 0; set x21 0; set x22 0; set x23 0;
|
||||
set x24 0; set x25 0; set x26 0; set x27 0;
|
||||
set x28 0; set x29 0; set x30 0; set x31 0;
|
||||
set x32 0; set x33 0; set x34 0; set x35 0;
|
||||
set x36 0; set x37 0; set x38 0; set x39 0;
|
||||
set x40 0; set x41 0; set x42 0; set x43 0;
|
||||
set x44 0; set x45 0; set x46 0; set x47 0;
|
||||
set x48 0; set x49 0; set x50 0; set x51 0;
|
||||
set x52 0; set x53 0; set x54 0; set x55 0;
|
||||
set x56 0; set x57 0; set x58 0; set x59 0;
|
||||
set x60 0; set x61 0; set x62 0; set x63 0;
|
||||
set x64 0; set x65 0; set x66 0; set x67 0;
|
||||
set x68 0; set x69 0; set x70 0; set x71 0;
|
||||
set x72 0; set x73 0; set x74 0; set x75 0;
|
||||
set x76 0; set x77 0; set x78 0; set x79 0;
|
||||
set x80 0; set x81 0; set x82 0; set x83 0;
|
||||
set x84 0; set x85 0; set x86 0; set x87 0;
|
||||
set x88 0; set x89 0; set x90 0; set x91 0;
|
||||
set x92 0; set x93 0; set x94 0; set x95 0;
|
||||
set x96 0; set x97 0; set x98 0; set x99 0;
|
||||
set x100 0; set x101 0; set x102 0; set x103 0;
|
||||
set x104 0; set x105 0; set x106 0; set x107 0;
|
||||
set x108 0; set x109 0; set x110 0; set x111 0;
|
||||
set x112 0; set x113 0; set x114 0; set x115 0;
|
||||
set x116 0; set x117 0; set x118 0; set x119 0;
|
||||
set x120 0; set x121 0; set x122 0; set x123 0;
|
||||
set x124 0; set x125 0; set x126 0; set x127 0;
|
||||
set x128 0; set x129 0; set x130 0; set x131 0;
|
||||
set x132 0; set x133 0; set x134 0; set x135 0;
|
||||
set x136 0; set x137 0; set x138 0; set x139 0;
|
||||
set x140 0; set x141 0; set x142 0; set x143 0;
|
||||
set x144 0; set x145 0; set x146 0; set x147 0;
|
||||
set x148 0; set x149 0; set x150 0; set x151 0;
|
||||
set x152 0; set x153 0; set x154 0; set x155 0;
|
||||
set x156 0; set x157 0; set x158 0; set x159 0;
|
||||
set x160 0; set x161 0; set x162 0; set x163 0;
|
||||
set x164 0; set x165 0; set x166 0; set x167 0;
|
||||
set x168 0; set x169 0; set x170 0; set x171 0;
|
||||
set x172 0; set x173 0; set x174 0; set x175 0;
|
||||
set x176 0; set x177 0; set x178 0; set x179 0;
|
||||
set x180 0; set x181 0; set x182 0; set x183 0;
|
||||
set x184 0; set x185 0; set x186 0; set x187 0;
|
||||
set x188 0; set x189 0; set x190 0; set x191 0;
|
||||
set x192 0; set x193 0; set x194 0; set x195 0;
|
||||
set x196 0; set x197 0; set x198 0; set x199 0;
|
||||
set x200 0; set x201 0; set x202 0; set x203 0;
|
||||
set x204 0; set x205 0; set x206 0; set x207 0;
|
||||
set x208 0; set x209 0; set x210 0; set x211 0;
|
||||
set x212 0; set x213 0; set x214 0; set x215 0;
|
||||
set x216 0; set x217 0; set x218 0; set x219 0;
|
||||
set x220 0; set x221 0; set x222 0; set x223 0;
|
||||
set x224 0; set x225 0; set x226 0; set x227 0;
|
||||
set x228 0; set x229 0; set x230 0; set x231 0;
|
||||
set x232 0; set x233 0; set x234 0; set x235 0;
|
||||
set x236 0; set x237 0; set x238 0; set x239 0;
|
||||
set x240 0; set x241 0; set x242 0; set x243 0;
|
||||
set x244 0; set x245 0; set x246 0; set x247 0;
|
||||
set x248 0; set x249 0; set x250 0; set x251 0;
|
||||
set x252 0; set x253 0; set x254 0; set x255 0;
|
||||
set x {{1 2} {3 4}}
|
||||
lset x 1 1 5
|
||||
}
|
||||
} "0 {{1 2} {3 5}}"
|
||||
|
||||
test lsetComp-3.5 {lset, compiled, flat args, array on stack} {
|
||||
evalInProc {
|
||||
set ::y(0) {{1 2} {3 4}}
|
||||
lset ::y(0) 1 1 5
|
||||
}
|
||||
} "0 {{1 2} {3 5}}"
|
||||
|
||||
test lsetComp-3.6 {lset, compiled, flat args, array, one-byte offset} {
|
||||
evalInProc {
|
||||
set y(0) {{1 2} {3 4}}
|
||||
lset y(0) 1 1 5
|
||||
}
|
||||
} "0 {{1 2} {3 5}}"
|
||||
|
||||
test lsetComp-3.7 {lset, compiled, flat args, array, four-byte offset} {
|
||||
evalInProc {
|
||||
set x0 0; set x1 0; set x2 0; set x3 0;
|
||||
set x4 0; set x5 0; set x6 0; set x7 0;
|
||||
set x8 0; set x9 0; set x10 0; set x11 0;
|
||||
set x12 0; set x13 0; set x14 0; set x15 0;
|
||||
set x16 0; set x17 0; set x18 0; set x19 0;
|
||||
set x20 0; set x21 0; set x22 0; set x23 0;
|
||||
set x24 0; set x25 0; set x26 0; set x27 0;
|
||||
set x28 0; set x29 0; set x30 0; set x31 0;
|
||||
set x32 0; set x33 0; set x34 0; set x35 0;
|
||||
set x36 0; set x37 0; set x38 0; set x39 0;
|
||||
set x40 0; set x41 0; set x42 0; set x43 0;
|
||||
set x44 0; set x45 0; set x46 0; set x47 0;
|
||||
set x48 0; set x49 0; set x50 0; set x51 0;
|
||||
set x52 0; set x53 0; set x54 0; set x55 0;
|
||||
set x56 0; set x57 0; set x58 0; set x59 0;
|
||||
set x60 0; set x61 0; set x62 0; set x63 0;
|
||||
set x64 0; set x65 0; set x66 0; set x67 0;
|
||||
set x68 0; set x69 0; set x70 0; set x71 0;
|
||||
set x72 0; set x73 0; set x74 0; set x75 0;
|
||||
set x76 0; set x77 0; set x78 0; set x79 0;
|
||||
set x80 0; set x81 0; set x82 0; set x83 0;
|
||||
set x84 0; set x85 0; set x86 0; set x87 0;
|
||||
set x88 0; set x89 0; set x90 0; set x91 0;
|
||||
set x92 0; set x93 0; set x94 0; set x95 0;
|
||||
set x96 0; set x97 0; set x98 0; set x99 0;
|
||||
set x100 0; set x101 0; set x102 0; set x103 0;
|
||||
set x104 0; set x105 0; set x106 0; set x107 0;
|
||||
set x108 0; set x109 0; set x110 0; set x111 0;
|
||||
set x112 0; set x113 0; set x114 0; set x115 0;
|
||||
set x116 0; set x117 0; set x118 0; set x119 0;
|
||||
set x120 0; set x121 0; set x122 0; set x123 0;
|
||||
set x124 0; set x125 0; set x126 0; set x127 0;
|
||||
set x128 0; set x129 0; set x130 0; set x131 0;
|
||||
set x132 0; set x133 0; set x134 0; set x135 0;
|
||||
set x136 0; set x137 0; set x138 0; set x139 0;
|
||||
set x140 0; set x141 0; set x142 0; set x143 0;
|
||||
set x144 0; set x145 0; set x146 0; set x147 0;
|
||||
set x148 0; set x149 0; set x150 0; set x151 0;
|
||||
set x152 0; set x153 0; set x154 0; set x155 0;
|
||||
set x156 0; set x157 0; set x158 0; set x159 0;
|
||||
set x160 0; set x161 0; set x162 0; set x163 0;
|
||||
set x164 0; set x165 0; set x166 0; set x167 0;
|
||||
set x168 0; set x169 0; set x170 0; set x171 0;
|
||||
set x172 0; set x173 0; set x174 0; set x175 0;
|
||||
set x176 0; set x177 0; set x178 0; set x179 0;
|
||||
set x180 0; set x181 0; set x182 0; set x183 0;
|
||||
set x184 0; set x185 0; set x186 0; set x187 0;
|
||||
set x188 0; set x189 0; set x190 0; set x191 0;
|
||||
set x192 0; set x193 0; set x194 0; set x195 0;
|
||||
set x196 0; set x197 0; set x198 0; set x199 0;
|
||||
set x200 0; set x201 0; set x202 0; set x203 0;
|
||||
set x204 0; set x205 0; set x206 0; set x207 0;
|
||||
set x208 0; set x209 0; set x210 0; set x211 0;
|
||||
set x212 0; set x213 0; set x214 0; set x215 0;
|
||||
set x216 0; set x217 0; set x218 0; set x219 0;
|
||||
set x220 0; set x221 0; set x222 0; set x223 0;
|
||||
set x224 0; set x225 0; set x226 0; set x227 0;
|
||||
set x228 0; set x229 0; set x230 0; set x231 0;
|
||||
set x232 0; set x233 0; set x234 0; set x235 0;
|
||||
set x236 0; set x237 0; set x238 0; set x239 0;
|
||||
set x240 0; set x241 0; set x242 0; set x243 0;
|
||||
set x244 0; set x245 0; set x246 0; set x247 0;
|
||||
set x248 0; set x249 0; set x250 0; set x251 0;
|
||||
set x252 0; set x253 0; set x254 0; set x255 0;
|
||||
set y(0) {{1 2} {3 4}}
|
||||
lset y(0) 1 1 5
|
||||
}
|
||||
} "0 {{1 2} {3 5}}"
|
||||
|
||||
test lsetComp-3.8 {lset, compiled, flat args, error } {
|
||||
evalInProc {
|
||||
set x { {1 2} {3 4} }
|
||||
lset x 1 5 5
|
||||
}
|
||||
} "1 {list index out of range}"
|
||||
|
||||
test lsetComp-3.9 {lset, compiled, flat args, error - is string preserved} {
|
||||
set ::x { { 1 2 } { 3 4 } }
|
||||
evalInProc {
|
||||
lset ::x 1 5 5
|
||||
}
|
||||
list $::x [lindex $::x 1]
|
||||
} "{ { 1 2 } { 3 4 } } { 3 4 }"
|
||||
|
||||
catch { rename evalInProc {} }
|
||||
catch { unset ::x }
|
||||
catch { unset ::y }
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
181
tests/macOSXFCmd.test
Normal file
181
tests/macOSXFCmd.test
Normal file
@@ -0,0 +1,181 @@
|
||||
# This file tests the tclMacOSXFCmd.c file.
|
||||
#
|
||||
# This file contains a collection of tests for one or more of the Tcl
|
||||
# built-in commands. Sourcing this file into Tcl runs the tests and
|
||||
# generates output for errors. No output means no errors were found.
|
||||
#
|
||||
# Copyright (c) 2003 Tcl Core Team.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
# These tests really need to be run from a writable directory, which
|
||||
# it is assumed [temporaryDirectory] is.
|
||||
set oldcwd [pwd]
|
||||
cd [temporaryDirectory]
|
||||
|
||||
# check whether macosx file attributes are supported
|
||||
testConstraint macosxFileAttr 0
|
||||
if {[testConstraint unix] && $tcl_platform(os) eq "Darwin"} {
|
||||
catch {file delete -force -- foo.test}
|
||||
close [open foo.test w]
|
||||
catch {
|
||||
file attributes foo.test -creator
|
||||
testConstraint macosxFileAttr 1
|
||||
}
|
||||
file delete -force -- foo.test
|
||||
}
|
||||
|
||||
test macOSXFCmd-1.1 {MacOSXGetFileAttribute - file not found} {macosxFileAttr notRoot} {
|
||||
catch {file delete -force -- foo.test}
|
||||
list [catch {file attributes foo.test -creator} msg] $msg
|
||||
} {1 {could not read "foo.test": no such file or directory}}
|
||||
test macOSXFCmd-1.2 {MacOSXGetFileAttribute - creator} {macosxFileAttr notRoot} {
|
||||
catch {file delete -force -- foo.test}
|
||||
close [open foo.test w]
|
||||
list [catch {file attributes foo.test -creator} msg] $msg \
|
||||
[file delete -force -- foo.test]
|
||||
} {0 {} {}}
|
||||
test macOSXFCmd-1.3 {MacOSXGetFileAttribute - type} {macosxFileAttr notRoot} {
|
||||
catch {file delete -force -- foo.test}
|
||||
close [open foo.test w]
|
||||
list [catch {file attributes foo.test -type} msg] $msg \
|
||||
[file delete -force -- foo.test]
|
||||
} {0 {} {}}
|
||||
test macOSXFCmd-1.4 {MacOSXGetFileAttribute - hidden} {macosxFileAttr notRoot} {
|
||||
catch {file delete -force -- foo.test}
|
||||
close [open foo.test w]
|
||||
list [catch {file attributes foo.test -hidden} msg] $msg \
|
||||
[file delete -force -- foo.test]
|
||||
} {0 0 {}}
|
||||
test macOSXFCmd-1.5 {MacOSXGetFileAttribute - rsrclength} {macosxFileAttr notRoot} {
|
||||
catch {file delete -force -- foo.test}
|
||||
close [open foo.test w]
|
||||
list [catch {file attributes foo.test -rsrclength} msg] $msg \
|
||||
[file delete -force -- foo.test]
|
||||
} {0 0 {}}
|
||||
|
||||
test macOSXFCmd-2.1 {MacOSXSetFileAttribute - file not found} {macosxFileAttr notRoot} {
|
||||
catch {file delete -force -- foo.test}
|
||||
list [catch {file attributes foo.test -creator FOOC} msg] $msg
|
||||
} {1 {could not read "foo.test": no such file or directory}}
|
||||
test macOSXFCmd-2.2 {MacOSXSetFileAttribute - creator} {macosxFileAttr notRoot} {
|
||||
catch {file delete -force -- foo.test}
|
||||
close [open foo.test w]
|
||||
list [catch {file attributes foo.test -creator FOOC} msg] $msg \
|
||||
[catch {file attributes foo.test -creator} msg] $msg \
|
||||
[file delete -force -- foo.test]
|
||||
} {0 {} 0 FOOC {}}
|
||||
test macOSXFCmd-2.3 {MacOSXSetFileAttribute - empty creator} {macosxFileAttr notRoot} {
|
||||
catch {file delete -force -- foo.test}
|
||||
close [open foo.test w]
|
||||
list [catch {file attributes foo.test -creator {}} msg] $msg \
|
||||
[catch {file attributes foo.test -creator} msg] $msg \
|
||||
[file delete -force -- foo.test]
|
||||
} {0 {} 0 {} {}}
|
||||
test macOSXFCmd-2.4 {MacOSXSetFileAttribute - type} {macosxFileAttr notRoot} {
|
||||
catch {file delete -force -- foo.test}
|
||||
close [open foo.test w]
|
||||
list [catch {file attributes foo.test -type FOOT} msg] $msg \
|
||||
[catch {file attributes foo.test -type} msg] $msg \
|
||||
[file delete -force -- foo.test]
|
||||
} {0 {} 0 FOOT {}}
|
||||
test macOSXFCmd-2.5 {MacOSXSetFileAttribute - empty type} {macosxFileAttr notRoot} {
|
||||
catch {file delete -force -- foo.test}
|
||||
close [open foo.test w]
|
||||
list [catch {file attributes foo.test -type {}} msg] $msg \
|
||||
[catch {file attributes foo.test -type} msg] $msg \
|
||||
[file delete -force -- foo.test]
|
||||
} {0 {} 0 {} {}}
|
||||
test macOSXFCmd-2.6 {MacOSXSetFileAttribute - hidden} {macosxFileAttr notRoot} {
|
||||
catch {file delete -force -- foo.test}
|
||||
close [open foo.test w]
|
||||
list [catch {file attributes foo.test -hidden 1} msg] $msg \
|
||||
[catch {file attributes foo.test -hidden} msg] $msg \
|
||||
[file delete -force -- foo.test]
|
||||
} {0 {} 0 1 {}}
|
||||
test macOSXFCmd-2.7 {MacOSXSetFileAttribute - rsrclength} {macosxFileAttr notRoot} {
|
||||
catch {file delete -force -- foo.test}
|
||||
close [open foo.test w]
|
||||
catch {
|
||||
set f [open foo.test/..namedfork/rsrc w]
|
||||
fconfigure $f -translation lf -eofchar {}
|
||||
puts -nonewline $f "foo"
|
||||
close $f
|
||||
}
|
||||
list [catch {file attributes foo.test -rsrclength} msg] $msg \
|
||||
[catch {file attributes foo.test -rsrclength 0} msg] $msg \
|
||||
[catch {file attributes foo.test -rsrclength} msg] $msg \
|
||||
[file delete -force -- foo.test]
|
||||
} {0 3 0 {} 0 0 {}}
|
||||
|
||||
test macOSXFCmd-3.1 {MacOSXCopyFileAttributes} {macosxFileAttr notRoot} {
|
||||
catch {file delete -force -- foo.test}
|
||||
catch {file delete -force -- bar.test}
|
||||
close [open foo.test w]
|
||||
catch {
|
||||
file attributes foo.test -creator FOOC -type FOOT -hidden 1
|
||||
set f [open foo.test/..namedfork/rsrc w]
|
||||
fconfigure $f -translation lf -eofchar {}
|
||||
puts -nonewline $f "foo"
|
||||
close $f
|
||||
file copy foo.test bar.test
|
||||
}
|
||||
list [catch {file attributes bar.test -creator} msg] $msg \
|
||||
[catch {file attributes bar.test -type} msg] $msg \
|
||||
[catch {file attributes bar.test -hidden} msg] $msg \
|
||||
[catch {file attributes bar.test -rsrclength} msg] $msg \
|
||||
[file delete -force -- foo.test bar.test]
|
||||
} {0 FOOC 0 FOOT 0 1 0 3 {}}
|
||||
|
||||
test macOSXFCmd-4.1 {TclMacOSXMatchType} {macosxFileAttr notRoot} {
|
||||
file mkdir globtest
|
||||
cd globtest
|
||||
foreach f {bar baz foo inv inw .nv reg} {
|
||||
catch {file delete -force -- $f.test}
|
||||
close [open $f.test w]
|
||||
}
|
||||
catch {file delete -force -- dir.test}
|
||||
file mkdir dir.test
|
||||
catch {
|
||||
file attributes bar.test -type FOOT
|
||||
file attributes baz.test -creator FOOC -type FOOT
|
||||
file attributes foo.test -creator FOOC
|
||||
file attributes inv.test -hidden 1
|
||||
file attributes inw.test -hidden 1 -type FOOT
|
||||
file attributes dir.test -hidden 1
|
||||
}
|
||||
set res [list \
|
||||
[catch {glob *.test} msg] $msg \
|
||||
[catch {glob -types FOOT *.test} msg] $msg \
|
||||
[catch {glob -types {{macintosh type FOOT}} *.test} msg] $msg \
|
||||
[catch {glob -types FOOTT *.test} msg] $msg \
|
||||
[catch {glob -types {{macintosh type FOOTT}} *.test} msg] $msg \
|
||||
[catch {glob -types {{macintosh type {}}} *.test} msg] $msg \
|
||||
[catch {glob -types {{macintosh creator FOOC}} *.test} msg] $msg \
|
||||
[catch {glob -types {{macintosh creator FOOC} {macintosh type FOOT}} *.test} msg] $msg \
|
||||
[catch {glob -types hidden *.test} msg] $msg \
|
||||
[catch {glob -types {hidden FOOT} *.test} msg] $msg \
|
||||
]
|
||||
cd ..
|
||||
file delete -force globtest
|
||||
set res
|
||||
} [list \
|
||||
0 {bar.test baz.test dir.test foo.test inv.test inw.test reg.test} \
|
||||
0 {bar.test baz.test inw.test} 0 {bar.test baz.test inw.test} \
|
||||
1 {bad argument to "-types": FOOTT} \
|
||||
1 {expected Macintosh OS type but got "FOOTT": } \
|
||||
0 {foo.test inv.test reg.test} 0 {baz.test foo.test} \
|
||||
0 baz.test 0 {.nv.test dir.test inv.test inw.test} \
|
||||
0 inw.test
|
||||
]
|
||||
|
||||
# cleanup
|
||||
cd $oldcwd
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
33
tests/macOSXLoad.test
Normal file
33
tests/macOSXLoad.test
Normal file
@@ -0,0 +1,33 @@
|
||||
# Commands covered: load unload
|
||||
#
|
||||
# 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) 1995 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest 2
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
set oldTSF $::tcltest::testSingleFile
|
||||
set ::tcltest::testSingleFile false
|
||||
|
||||
if {[testConstraint unix] && $tcl_platform(os) eq "Darwin" &&
|
||||
![string match *pkga* [info loaded]]} {
|
||||
# On Darwin, test .bundle (un)loading in addition to .dylib
|
||||
set ext .bundle
|
||||
source [file join [file dirname [info script]] load.test]
|
||||
set ext .bundle
|
||||
source [file join [file dirname [info script]] unload.test]
|
||||
unset -nocomplain ext
|
||||
}
|
||||
|
||||
set ::tcltest::testSingleFile $oldTSF
|
||||
unset oldTSF
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
1305
tests/main.test
Normal file
1305
tests/main.test
Normal file
File diff suppressed because it is too large
Load Diff
1338
tests/mathop.test
Normal file
1338
tests/mathop.test
Normal file
File diff suppressed because it is too large
Load Diff
76
tests/misc.test
Normal file
76
tests/misc.test
Normal file
@@ -0,0 +1,76 @@
|
||||
# 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.
|
||||
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
testConstraint testhashsystemhash [llength [info commands testhashsystemhash]]
|
||||
|
||||
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 {}
|
||||
join [list [catch tstProc msg] $msg $::errorInfo] \n
|
||||
} [subst -novariables -nocommands {1
|
||||
missing close-brace for variable name
|
||||
missing close-brace for variable name
|
||||
while executing
|
||||
"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 ..."
|
||||
(procedure "tstProc" line 4)
|
||||
invoked from within
|
||||
"tstProc"}]
|
||||
|
||||
for {set i 1} {$i<300} {incr i} {
|
||||
test misc-2.$i {hash table with sys-alloc} testhashsystemhash \
|
||||
"testhashsystemhash $i" OK
|
||||
}
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
664
tests/msgcat.test
Normal file
664
tests/msgcat.test
Normal file
@@ -0,0 +1,664 @@
|
||||
# This file contains a collection of tests for the msgcat package.
|
||||
# Sourcing this file into Tcl runs the tests and
|
||||
# generates output for errors. No output means no errors were found.
|
||||
#
|
||||
# Copyright (c) 1998 Mark Harrison.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
# Contributions from Don Porter, NIST, 2002. (not subject to US copyright)
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
#
|
||||
# Note that after running these tests, entries will be left behind in the
|
||||
# message catalogs for locales foo, foo_BAR, and foo_BAR_baz.
|
||||
|
||||
package require Tcl 8.5
|
||||
if {[catch {package require tcltest 2}]} {
|
||||
puts stderr "Skipping tests in [info script]. tcltest 2 required."
|
||||
return
|
||||
}
|
||||
if {[catch {package require msgcat 1.5}]} {
|
||||
puts stderr "Skipping tests in [info script]. No msgcat 1.5 found to test."
|
||||
return
|
||||
}
|
||||
|
||||
namespace eval ::msgcat::test {
|
||||
namespace import ::msgcat::*
|
||||
namespace import ::tcltest::test
|
||||
namespace import ::tcltest::cleanupTests
|
||||
namespace import ::tcltest::temporaryDirectory
|
||||
namespace import ::tcltest::make*
|
||||
namespace import ::tcltest::remove*
|
||||
|
||||
# Tests msgcat-0.*: locale initialization
|
||||
|
||||
proc PowerSet {l} {
|
||||
if {[llength $l] == 0} {return [list [list]]}
|
||||
set element [lindex $l 0]
|
||||
set rest [lrange $l 1 end]
|
||||
set result [list]
|
||||
foreach x [PowerSet $rest] {
|
||||
lappend result [linsert $x 0 $element]
|
||||
lappend result $x
|
||||
}
|
||||
return $result
|
||||
}
|
||||
|
||||
variable envVars {LC_ALL LC_MESSAGES LANG}
|
||||
variable count 0
|
||||
variable body
|
||||
variable result
|
||||
variable setVars
|
||||
foreach setVars [PowerSet $envVars] {
|
||||
set result [string tolower [lindex $setVars 0]]
|
||||
if {[string length $result] == 0} {
|
||||
if {[info exists ::tcl::mac::locale]} {
|
||||
set result [string tolower \
|
||||
[msgcat::ConvertLocale $::tcl::mac::locale]]
|
||||
} else {
|
||||
if {([info sharedlibextension] eq ".dll")
|
||||
&& ![catch {package require registry}]} {
|
||||
# Windows and Cygwin have other ways to determine the
|
||||
# locale when the environment variables are missing
|
||||
# and the registry package is present
|
||||
continue
|
||||
}
|
||||
set result c
|
||||
}
|
||||
}
|
||||
test msgcat-0.$count [list \
|
||||
locale initialization from environment variables $setVars \
|
||||
] -setup {
|
||||
variable var
|
||||
foreach var $envVars {
|
||||
catch {variable $var $::env($var)}
|
||||
unset -nocomplain ::env($var)
|
||||
}
|
||||
foreach var $setVars {
|
||||
set ::env($var) $var
|
||||
}
|
||||
interp create [namespace current]::i
|
||||
i eval [list package ifneeded msgcat [package provide msgcat] \
|
||||
[package ifneeded msgcat [package provide msgcat]]]
|
||||
i eval package require msgcat
|
||||
} -cleanup {
|
||||
interp delete [namespace current]::i
|
||||
foreach var $envVars {
|
||||
unset -nocomplain ::env($var)
|
||||
catch {set ::env($var) [set [namespace current]::$var]}
|
||||
}
|
||||
} -body {i eval msgcat::mclocale} -result $result
|
||||
incr count
|
||||
}
|
||||
unset -nocomplain result
|
||||
|
||||
# Could add tests of initialization from Windows registry here.
|
||||
# Use a fake registry package.
|
||||
|
||||
# Tests msgcat-1.*: [mclocale], [mcpreferences]
|
||||
|
||||
test msgcat-1.3 {mclocale set, single element} -setup {
|
||||
variable locale [mclocale]
|
||||
} -cleanup {
|
||||
mclocale $locale
|
||||
} -body {
|
||||
mclocale en
|
||||
} -result en
|
||||
|
||||
test msgcat-1.4 {mclocale get, single element} -setup {
|
||||
variable locale [mclocale]
|
||||
mclocale en
|
||||
} -cleanup {
|
||||
mclocale $locale
|
||||
} -body {
|
||||
mclocale
|
||||
} -result en
|
||||
|
||||
test msgcat-1.5 {mcpreferences, single element} -setup {
|
||||
variable locale [mclocale]
|
||||
mclocale en
|
||||
} -cleanup {
|
||||
mclocale $locale
|
||||
} -body {
|
||||
mcpreferences
|
||||
} -result {en {}}
|
||||
|
||||
test msgcat-1.6 {mclocale set, two elements} -setup {
|
||||
variable locale [mclocale]
|
||||
} -cleanup {
|
||||
mclocale $locale
|
||||
} -body {
|
||||
mclocale en_US
|
||||
} -result en_us
|
||||
|
||||
test msgcat-1.7 {mclocale get, two elements} -setup {
|
||||
variable locale [mclocale]
|
||||
mclocale en_US
|
||||
} -cleanup {
|
||||
mclocale $locale
|
||||
} -body {
|
||||
mclocale
|
||||
} -result en_us
|
||||
|
||||
test msgcat-1.8 {mcpreferences, two elements} -setup {
|
||||
variable locale [mclocale]
|
||||
mclocale en_US
|
||||
} -cleanup {
|
||||
mclocale $locale
|
||||
} -body {
|
||||
mcpreferences
|
||||
} -result {en_us en {}}
|
||||
|
||||
test msgcat-1.9 {mclocale set, three elements} -setup {
|
||||
variable locale [mclocale]
|
||||
} -cleanup {
|
||||
mclocale $locale
|
||||
} -body {
|
||||
mclocale en_US_funky
|
||||
} -result en_us_funky
|
||||
|
||||
test msgcat-1.10 {mclocale get, three elements} -setup {
|
||||
variable locale [mclocale]
|
||||
mclocale en_US_funky
|
||||
} -cleanup {
|
||||
mclocale $locale
|
||||
} -body {
|
||||
mclocale
|
||||
} -result en_us_funky
|
||||
|
||||
test msgcat-1.11 {mcpreferences, three elements} -setup {
|
||||
variable locale [mclocale]
|
||||
mclocale en_US_funky
|
||||
} -cleanup {
|
||||
mclocale $locale
|
||||
} -body {
|
||||
mcpreferences
|
||||
} -result {en_us_funky en_us en {}}
|
||||
|
||||
test msgcat-1.12 {mclocale set, reject evil input} -setup {
|
||||
variable locale [mclocale]
|
||||
} -cleanup {
|
||||
mclocale $locale
|
||||
} -body {
|
||||
mclocale /path/to/evil/code
|
||||
} -returnCodes error -match glob -result {invalid newLocale value *}
|
||||
|
||||
test msgcat-1.13 {mclocale set, reject evil input} -setup {
|
||||
variable locale [mclocale]
|
||||
} -cleanup {
|
||||
mclocale $locale
|
||||
} -body {
|
||||
mclocale looks/ok/../../../../but/is/path/to/evil/code
|
||||
} -returnCodes error -match glob -result {invalid newLocale value *}
|
||||
|
||||
# Tests msgcat-2.*: [mcset], [mcmset], namespace partitioning
|
||||
|
||||
test msgcat-2.1 {mcset, global scope} {
|
||||
namespace eval :: ::msgcat::mcset foo_BAR text1 text2
|
||||
} {text2}
|
||||
|
||||
test msgcat-2.2 {mcset, global scope, default} {
|
||||
namespace eval :: ::msgcat::mcset foo_BAR text3
|
||||
} {text3}
|
||||
|
||||
test msgcat-2.2.1 {mcset, namespace overlap} {
|
||||
namespace eval baz {::msgcat::mcset foo_BAR con1 con1baz}
|
||||
} {con1baz}
|
||||
|
||||
test msgcat-2.3 {mcset, namespace overlap} -setup {
|
||||
namespace eval bar {::msgcat::mcset foo_BAR con1 con1bar}
|
||||
namespace eval baz {::msgcat::mcset foo_BAR con1 con1baz}
|
||||
variable locale [mclocale]
|
||||
mclocale foo_BAR
|
||||
} -cleanup {
|
||||
mclocale $locale
|
||||
} -body {
|
||||
namespace eval bar {::msgcat::mc con1}
|
||||
} -result con1bar
|
||||
|
||||
test msgcat-2.4 {mcset, namespace overlap} -setup {
|
||||
namespace eval bar {::msgcat::mcset foo_BAR con1 con1bar}
|
||||
namespace eval baz {::msgcat::mcset foo_BAR con1 con1baz}
|
||||
variable locale [mclocale]
|
||||
mclocale foo_BAR
|
||||
} -cleanup {
|
||||
mclocale $locale
|
||||
} -body {
|
||||
namespace eval baz {::msgcat::mc con1}
|
||||
} -result con1baz
|
||||
|
||||
test msgcat-2.5 {mcmset, global scope} -setup {
|
||||
namespace eval :: {
|
||||
::msgcat::mcmset foo_BAR {
|
||||
src1 trans1
|
||||
src2 trans2
|
||||
}
|
||||
}
|
||||
variable locale [mclocale]
|
||||
mclocale foo_BAR
|
||||
} -cleanup {
|
||||
mclocale $locale
|
||||
} -body {
|
||||
namespace eval :: {
|
||||
::msgcat::mc src1
|
||||
}
|
||||
} -result trans1
|
||||
|
||||
test msgcat-2.6 {mcmset, namespace overlap} -setup {
|
||||
namespace eval bar {::msgcat::mcmset foo_BAR {con2 con2bar}}
|
||||
namespace eval baz {::msgcat::mcmset foo_BAR {con2 con2baz}}
|
||||
variable locale [mclocale]
|
||||
mclocale foo_BAR
|
||||
} -cleanup {
|
||||
mclocale $locale
|
||||
} -body {
|
||||
namespace eval bar {::msgcat::mc con2}
|
||||
} -result con2bar
|
||||
|
||||
test msgcat-2.7 {mcmset, namespace overlap} -setup {
|
||||
namespace eval bar {::msgcat::mcmset foo_BAR {con2 con2bar}}
|
||||
namespace eval baz {::msgcat::mcmset foo_BAR {con2 con2baz}}
|
||||
variable locale [mclocale]
|
||||
mclocale foo_BAR
|
||||
} -cleanup {
|
||||
mclocale $locale
|
||||
} -body {
|
||||
namespace eval baz {::msgcat::mc con2}
|
||||
} -result con2baz
|
||||
|
||||
# Tests msgcat-3.*: [mcset], [mc], catalog "inheritance"
|
||||
#
|
||||
# Test mcset and mc, ensuring that more specific locales
|
||||
# (e.g. en_UK) will search less specific locales
|
||||
# (e.g. en) for translation strings.
|
||||
#
|
||||
# Do this for the 15 permutations of
|
||||
# locales: {foo foo_BAR foo_BAR_baz}
|
||||
# strings: {ov0 ov1 ov2 ov3 ov4}
|
||||
# locale ROOT defines ov0, ov1, ov2, ov3
|
||||
# locale foo defines ov1, ov2, ov3
|
||||
# locale foo_BAR defines ov2, ov3
|
||||
# locale foo_BAR_BAZ defines ov3
|
||||
# (ov4 is defined in none)
|
||||
# So,
|
||||
# ov3 should be resolved in foo, foo_BAR, foo_BAR_baz
|
||||
# ov2 should be resolved in foo, foo_BAR
|
||||
# ov2 should resolve to foo_BAR in foo_BAR_baz
|
||||
# ov1 should be resolved in foo
|
||||
# ov1 should resolve to foo in foo_BAR, foo_BAR_baz
|
||||
# ov4 should be resolved in none, and call mcunknown
|
||||
#
|
||||
variable count 2
|
||||
variable result
|
||||
array set result {
|
||||
foo,ov0 ov0_ROOT foo,ov1 ov1_foo foo,ov2 ov2_foo
|
||||
foo,ov3 ov3_foo foo,ov4 ov4
|
||||
foo_BAR,ov0 ov0_ROOT foo_BAR,ov1 ov1_foo foo_BAR,ov2 ov2_foo_BAR
|
||||
foo_BAR,ov3 ov3_foo_BAR foo_BAR,ov4 ov4
|
||||
foo_BAR_baz,ov0 ov0_ROOT foo_BAR_baz,ov1 ov1_foo
|
||||
foo_BAR_baz,ov2 ov2_foo_BAR
|
||||
foo_BAR_baz,ov3 ov3_foo_BAR_baz foo_BAR_baz,ov4 ov4
|
||||
}
|
||||
variable loc
|
||||
variable string
|
||||
foreach loc {foo foo_BAR foo_BAR_baz} {
|
||||
foreach string {ov0 ov1 ov2 ov3 ov4} {
|
||||
test msgcat-3.$count {mcset, overlap} -setup {
|
||||
mcset {} ov0 ov0_ROOT
|
||||
mcset {} ov1 ov1_ROOT
|
||||
mcset {} ov2 ov2_ROOT
|
||||
mcset {} ov3 ov3_ROOT
|
||||
mcset foo ov1 ov1_foo
|
||||
mcset foo ov2 ov2_foo
|
||||
mcset foo ov3 ov3_foo
|
||||
mcset foo_BAR ov2 ov2_foo_BAR
|
||||
mcset foo_BAR ov3 ov3_foo_BAR
|
||||
mcset foo_BAR_baz ov3 ov3_foo_BAR_baz
|
||||
variable locale [mclocale]
|
||||
mclocale $loc
|
||||
} -cleanup {
|
||||
mclocale $locale
|
||||
} -body {
|
||||
mc $string
|
||||
} -result $result($loc,$string)
|
||||
incr count
|
||||
}
|
||||
}
|
||||
unset -nocomplain result
|
||||
|
||||
# Tests msgcat-4.*: [mcunknown]
|
||||
|
||||
test msgcat-4.2 {mcunknown, default} -setup {
|
||||
mcset foo unk1 "unknown 1"
|
||||
variable locale [mclocale]
|
||||
mclocale foo
|
||||
} -cleanup {
|
||||
mclocale $locale
|
||||
} -body {
|
||||
mc unk1
|
||||
} -result {unknown 1}
|
||||
|
||||
test msgcat-4.3 {mcunknown, default} -setup {
|
||||
mcset foo unk1 "unknown 1"
|
||||
variable locale [mclocale]
|
||||
mclocale foo
|
||||
} -cleanup {
|
||||
mclocale $locale
|
||||
} -body {
|
||||
mc unk2
|
||||
} -result unk2
|
||||
|
||||
test msgcat-4.4 {mcunknown, overridden} -setup {
|
||||
rename ::msgcat::mcunknown SavedMcunknown
|
||||
proc ::msgcat::mcunknown {dom s} {
|
||||
return unknown:$dom:$s
|
||||
}
|
||||
mcset foo unk1 "unknown 1"
|
||||
variable locale [mclocale]
|
||||
mclocale foo
|
||||
} -cleanup {
|
||||
mclocale $locale
|
||||
rename ::msgcat::mcunknown {}
|
||||
rename SavedMcunknown ::msgcat::mcunknown
|
||||
} -body {
|
||||
mc unk1
|
||||
} -result {unknown 1}
|
||||
|
||||
test msgcat-4.5 {mcunknown, overridden} -setup {
|
||||
rename ::msgcat::mcunknown SavedMcunknown
|
||||
proc ::msgcat::mcunknown {dom s} {
|
||||
return unknown:$dom:$s
|
||||
}
|
||||
mcset foo unk1 "unknown 1"
|
||||
variable locale [mclocale]
|
||||
mclocale foo
|
||||
} -cleanup {
|
||||
mclocale $locale
|
||||
rename ::msgcat::mcunknown {}
|
||||
rename SavedMcunknown ::msgcat::mcunknown
|
||||
} -body {
|
||||
mc unk2
|
||||
} -result {unknown:foo:unk2}
|
||||
|
||||
test msgcat-4.6 {mcunknown, uplevel context} -setup {
|
||||
rename ::msgcat::mcunknown SavedMcunknown
|
||||
proc ::msgcat::mcunknown {dom s} {
|
||||
return "unknown:$dom:$s:[expr {[info level] - 1}]"
|
||||
}
|
||||
mcset foo unk1 "unknown 1"
|
||||
variable locale [mclocale]
|
||||
mclocale foo
|
||||
} -cleanup {
|
||||
mclocale $locale
|
||||
rename ::msgcat::mcunknown {}
|
||||
rename SavedMcunknown ::msgcat::mcunknown
|
||||
} -body {
|
||||
mc unk2
|
||||
} -result unknown:foo:unk2:[info level]
|
||||
|
||||
# Tests msgcat-5.*: [mcload]
|
||||
|
||||
variable locales {{} foo foo_BAR foo_BAR_baz}
|
||||
set msgdir [makeDirectory msgdir]
|
||||
foreach loc $locales {
|
||||
if { $loc eq {} } {
|
||||
set msg ROOT
|
||||
} else {
|
||||
set msg [string tolower $loc]
|
||||
}
|
||||
makeFile [list ::msgcat::mcset $loc abc abc-$loc] $msg.msg $msgdir
|
||||
}
|
||||
variable count 1
|
||||
foreach loc {foo foo_BAR foo_BAR_baz} {
|
||||
test msgcat-5.$count {mcload} -setup {
|
||||
variable locale [mclocale]
|
||||
mclocale $loc
|
||||
} -cleanup {
|
||||
mclocale $locale
|
||||
} -body {
|
||||
mcload $msgdir
|
||||
} -result [expr { $count+1 }]
|
||||
incr count
|
||||
}
|
||||
|
||||
# Even though foo_BAR_notexist does not exist,
|
||||
# foo_BAR, foo and the root should be loaded.
|
||||
test msgcat-5.4 {mcload} -setup {
|
||||
variable locale [mclocale]
|
||||
mclocale foo_BAR_notexist
|
||||
} -cleanup {
|
||||
mclocale $locale
|
||||
} -body {
|
||||
mcload $msgdir
|
||||
} -result 3
|
||||
|
||||
test msgcat-5.5 {mcload} -setup {
|
||||
variable locale [mclocale]
|
||||
mclocale no_FI_notexist
|
||||
} -cleanup {
|
||||
mclocale $locale
|
||||
} -body {
|
||||
mcload $msgdir
|
||||
} -result 1
|
||||
|
||||
test msgcat-5.6 {mcload} -setup {
|
||||
variable locale [mclocale]
|
||||
mclocale foo
|
||||
mcload $msgdir
|
||||
} -cleanup {
|
||||
mclocale $locale
|
||||
} -body {
|
||||
mc abc
|
||||
} -result abc-foo
|
||||
|
||||
test msgcat-5.7 {mcload} -setup {
|
||||
variable locale [mclocale]
|
||||
mclocale foo_BAR
|
||||
mcload $msgdir
|
||||
} -cleanup {
|
||||
mclocale $locale
|
||||
} -body {
|
||||
mc abc
|
||||
} -result abc-foo_BAR
|
||||
|
||||
test msgcat-5.8 {mcload} -setup {
|
||||
variable locale [mclocale]
|
||||
mclocale foo_BAR_baz
|
||||
mcload $msgdir
|
||||
} -cleanup {
|
||||
mclocale $locale
|
||||
} -body {
|
||||
mc abc
|
||||
} -result abc-foo_BAR_baz
|
||||
|
||||
test msgcat-5.9 {mcload} -setup {
|
||||
variable locale [mclocale]
|
||||
mclocale no_FI_notexist
|
||||
mcload $msgdir
|
||||
} -cleanup {
|
||||
mclocale $locale
|
||||
} -body {
|
||||
mc abc
|
||||
} -result abc-
|
||||
|
||||
test msgcat-5.10 {mcload} -setup {
|
||||
rename ::msgcat::mcunknown SavedMcunknown
|
||||
proc ::msgcat::mcunknown {dom s} {
|
||||
return unknown:$dom:$s
|
||||
}
|
||||
variable locale [mclocale]
|
||||
mclocale no_FI_notexist
|
||||
mcload $msgdir
|
||||
} -cleanup {
|
||||
mclocale $locale
|
||||
rename ::msgcat::mcunknown {}
|
||||
rename SavedMcunknown ::msgcat::mcunknown
|
||||
} -body {
|
||||
mc def
|
||||
} -result unknown:no_fi_notexist:def
|
||||
|
||||
foreach loc $locales {
|
||||
if { $loc eq {} } {
|
||||
set msg ROOT
|
||||
} else {
|
||||
set msg [string tolower $loc]
|
||||
}
|
||||
removeFile $msg.msg $msgdir
|
||||
}
|
||||
removeDirectory msgdir
|
||||
|
||||
# Tests msgcat-6.*: [mcset], [mc] namespace inheritance
|
||||
#
|
||||
# Test mcset and mc, ensuring that resolution for messages
|
||||
# proceeds from the current ns to its parent and so on to the
|
||||
# global ns.
|
||||
#
|
||||
# Do this for the 12 permutations of
|
||||
# locales: foo
|
||||
# namespaces: foo foo::bar foo::bar::baz
|
||||
# strings: {ov1 ov2 ov3 ov4}
|
||||
# namespace ::foo defines ov1, ov2, ov3
|
||||
# namespace ::foo::bar defines ov2, ov3
|
||||
# namespace ::foo::bar::baz defines ov3
|
||||
#
|
||||
# ov4 is not defined in any namespace.
|
||||
#
|
||||
# So,
|
||||
# ov3 should be resolved in ::foo::bar::baz, ::foo::bar, ::foo;
|
||||
# ov2 should be resolved in ::foo, ::foo::bar
|
||||
# ov1 should be resolved in ::foo
|
||||
# ov4 should be resolved in none, and call mcunknown
|
||||
#
|
||||
|
||||
variable result
|
||||
array set result {
|
||||
foo,ov1 ov1_foo foo,ov2 ov2_foo foo,ov3 ov3_foo foo,ov4 ov4
|
||||
foo::bar,ov1 ov1_foo foo::bar,ov2 ov2_foo_bar
|
||||
foo::bar,ov3 ov3_foo_bar foo::bar,ov4 ov4 foo::bar::baz,ov1 ov1_foo
|
||||
foo::bar::baz,ov2 ov2_foo_bar foo::bar::baz,ov3 ov3_foo_bar_baz
|
||||
foo::bar::baz,ov4 ov4
|
||||
}
|
||||
variable count 1
|
||||
variable ns
|
||||
foreach ns {foo foo::bar foo::bar::baz} {
|
||||
foreach string {ov1 ov2 ov3 ov4} {
|
||||
test msgcat-6.$count {mcset, overlap} -setup {
|
||||
namespace eval foo {
|
||||
::msgcat::mcset foo ov1 ov1_foo
|
||||
::msgcat::mcset foo ov2 ov2_foo
|
||||
::msgcat::mcset foo ov3 ov3_foo
|
||||
namespace eval bar {
|
||||
::msgcat::mcset foo ov2 ov2_foo_bar
|
||||
::msgcat::mcset foo ov3 ov3_foo_bar
|
||||
namespace eval baz {
|
||||
::msgcat::mcset foo ov3 "ov3_foo_bar_baz"
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
variable locale [mclocale]
|
||||
mclocale foo
|
||||
} -cleanup {
|
||||
mclocale $locale
|
||||
namespace delete foo
|
||||
} -body {
|
||||
namespace eval $ns [list ::msgcat::mc $string]
|
||||
} -result $result($ns,$string)
|
||||
incr count
|
||||
}
|
||||
}
|
||||
|
||||
# Tests msgcat-7.*: [mc] extra args processed by [format]
|
||||
|
||||
test msgcat-7.1 {mc extra args go through to format} -setup {
|
||||
mcset foo format1 "this is a test"
|
||||
mcset foo format2 "this is a %s"
|
||||
mcset foo format3 "this is a %s %s"
|
||||
variable locale [mclocale]
|
||||
mclocale foo
|
||||
} -cleanup {
|
||||
mclocale $locale
|
||||
} -body {
|
||||
mc format1 "good test"
|
||||
} -result "this is a test"
|
||||
|
||||
test msgcat-7.2 {mc extra args go through to format} -setup {
|
||||
mcset foo format1 "this is a test"
|
||||
mcset foo format2 "this is a %s"
|
||||
mcset foo format3 "this is a %s %s"
|
||||
variable locale [mclocale]
|
||||
mclocale foo
|
||||
} -cleanup {
|
||||
mclocale $locale
|
||||
} -body {
|
||||
mc format2 "good test"
|
||||
} -result "this is a good test"
|
||||
|
||||
test msgcat-7.3 {mc errors from format are propagated} -setup {
|
||||
mcset foo format1 "this is a test"
|
||||
mcset foo format2 "this is a %s"
|
||||
mcset foo format3 "this is a %s %s"
|
||||
variable locale [mclocale]
|
||||
mclocale foo
|
||||
} -cleanup {
|
||||
mclocale $locale
|
||||
} -body {
|
||||
catch {mc format3 "good test"}
|
||||
} -result 1
|
||||
|
||||
test msgcat-7.4 {mc, extra args are given to unknown} -setup {
|
||||
mcset foo format1 "this is a test"
|
||||
mcset foo format2 "this is a %s"
|
||||
mcset foo format3 "this is a %s %s"
|
||||
variable locale [mclocale]
|
||||
mclocale foo
|
||||
} -cleanup {
|
||||
mclocale $locale
|
||||
} -body {
|
||||
mc "this is a %s" "good test"
|
||||
} -result "this is a good test"
|
||||
|
||||
# Tests msgcat-8.*: [mcflset]
|
||||
|
||||
set msgdir1 [makeDirectory msgdir1]
|
||||
makeFile {::msgcat::mcflset k1 v1} l1.msg $msgdir1
|
||||
|
||||
test msgcat-8.1 {mcflset} -setup {
|
||||
variable locale [mclocale]
|
||||
mclocale l1
|
||||
mcload $msgdir1
|
||||
} -cleanup {
|
||||
mclocale $locale
|
||||
} -body {
|
||||
mc k1
|
||||
} -result v1
|
||||
|
||||
removeFile l1.msg $msgdir1
|
||||
removeDirectory msgdir1
|
||||
|
||||
set msgdir2 [makeDirectory msgdir2]
|
||||
set msgdir3 [makeDirectory msgdir3]
|
||||
makeFile "::msgcat::mcflset k2 v2 ; ::msgcat::mcload [list $msgdir3]"\
|
||||
l2.msg $msgdir2
|
||||
makeFile {::msgcat::mcflset k3 v3} l2.msg $msgdir3
|
||||
|
||||
# chained mcload
|
||||
test msgcat-8.2 {mcflset} -setup {
|
||||
variable locale [mclocale]
|
||||
mclocale l2
|
||||
mcload $msgdir2
|
||||
} -cleanup {
|
||||
mclocale $locale
|
||||
} -body {
|
||||
return [mc k2][mc k3]
|
||||
} -result v2v3
|
||||
|
||||
removeFile l2.msg $msgdir2
|
||||
removeDirectory msgdir2
|
||||
removeDirectory msgdir3
|
||||
|
||||
cleanupTests
|
||||
}
|
||||
namespace delete ::msgcat::test
|
||||
return
|
||||
|
||||
847
tests/namespace-old.test
Normal file
847
tests/namespace-old.test
Normal file
@@ -0,0 +1,847 @@
|
||||
# Functionality covered: this file contains slightly modified versions of
|
||||
# the original tests written by Mike McLennan of Lucent Technologies for
|
||||
# the procedures in tclNamesp.c that implement Tcl's basic support for
|
||||
# namespaces. Other namespace-related tests appear in namespace.test
|
||||
# and variable.test.
|
||||
#
|
||||
# Sourcing this file into Tcl runs the tests and generates output for
|
||||
# errors. No output means no errors were found.
|
||||
#
|
||||
# Copyright (c) 1997 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1997 Lucent Technologies
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest 2.2
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
# Clear out any namespaces called test_ns_*
|
||||
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
||||
|
||||
test namespace-old-1.1 {usage for "namespace" command} {
|
||||
list [catch {namespace} msg] $msg
|
||||
} {1 {wrong # args: should be "namespace subcommand ?arg ...?"}}
|
||||
|
||||
test namespace-old-1.2 {global namespace's name is "::" or {}} {
|
||||
list [namespace current] [namespace eval {} {namespace current}]
|
||||
} {:: ::}
|
||||
|
||||
test namespace-old-1.3 {usage for "namespace eval"} {
|
||||
list [catch {namespace eval} msg] $msg
|
||||
} {1 {wrong # args: should be "namespace eval name arg ?arg...?"}}
|
||||
|
||||
test namespace-old-1.4 {create new namespaces} {
|
||||
list [lsort [namespace children :: test_ns_simple*]] \
|
||||
[namespace eval test_ns_simple {}] \
|
||||
[namespace eval test_ns_simple2 {}] \
|
||||
[lsort [namespace children :: test_ns_simple*]]
|
||||
} {{} {} {} {::test_ns_simple ::test_ns_simple2}}
|
||||
|
||||
test namespace-old-1.5 {access a new namespace} {
|
||||
namespace eval test_ns_simple { namespace current }
|
||||
} {::test_ns_simple}
|
||||
|
||||
test namespace-old-1.6 {usage for "namespace eval"} {
|
||||
list [catch {namespace eval} msg] $msg
|
||||
} {1 {wrong # args: should be "namespace eval name arg ?arg...?"}}
|
||||
|
||||
test namespace-old-1.7 {usage for "namespace eval"} {
|
||||
list [catch {namespace eval test_ns_xyzzy} msg] $msg
|
||||
} {1 {wrong # args: should be "namespace eval name arg ?arg...?"}}
|
||||
|
||||
test namespace-old-1.8 {command "namespace eval" concatenates args} {
|
||||
namespace eval test_ns_simple namespace current
|
||||
} {::test_ns_simple}
|
||||
|
||||
test namespace-old-1.9 {add elements to a namespace} {
|
||||
namespace eval test_ns_simple {
|
||||
variable test_ns_x 0
|
||||
proc test {test_ns_x} {
|
||||
return "test: $test_ns_x"
|
||||
}
|
||||
}
|
||||
} {}
|
||||
|
||||
test namespace-old-1.10 {commands in a namespace} {
|
||||
namespace eval test_ns_simple { info commands [namespace current]::*}
|
||||
} {::test_ns_simple::test}
|
||||
|
||||
test namespace-old-1.11 {variables in a namespace} {
|
||||
namespace eval test_ns_simple { info vars [namespace current]::* }
|
||||
} {::test_ns_simple::test_ns_x}
|
||||
|
||||
test namespace-old-1.12 {global vars are separate from locals vars} {
|
||||
list [test_ns_simple::test 123] [set test_ns_simple::test_ns_x]
|
||||
} {{test: 123} 0}
|
||||
|
||||
test namespace-old-1.13 {add to an existing namespace} {
|
||||
namespace eval test_ns_simple {
|
||||
variable test_ns_y 123
|
||||
proc _backdoor {cmd} {
|
||||
eval $cmd
|
||||
}
|
||||
}
|
||||
} ""
|
||||
|
||||
test namespace-old-1.14 {commands in a namespace} {
|
||||
lsort [namespace eval test_ns_simple {info commands [namespace current]::*}]
|
||||
} {::test_ns_simple::_backdoor ::test_ns_simple::test}
|
||||
|
||||
test namespace-old-1.15 {variables in a namespace} {
|
||||
lsort [namespace eval test_ns_simple {info vars [namespace current]::*}]
|
||||
} {::test_ns_simple::test_ns_x ::test_ns_simple::test_ns_y}
|
||||
test namespace-old-1.16 {variables in a namespace} {
|
||||
lsort [info vars test_ns_simple::*]
|
||||
} {::test_ns_simple::test_ns_x ::test_ns_simple::test_ns_y}
|
||||
|
||||
test namespace-old-1.17 {commands in a namespace are hidden} {
|
||||
list [catch "_backdoor {return yes!}" msg] $msg
|
||||
} {1 {invalid command name "_backdoor"}}
|
||||
test namespace-old-1.18 {using namespace qualifiers} {
|
||||
list [catch "test_ns_simple::_backdoor {return yes!}" msg] $msg
|
||||
} {0 yes!}
|
||||
test namespace-old-1.19 {using absolute namespace qualifiers} {
|
||||
list [catch "::test_ns_simple::_backdoor {return yes!}" msg] $msg
|
||||
} {0 yes!}
|
||||
|
||||
test namespace-old-1.20 {variables in a namespace are hidden} {
|
||||
list [catch "set test_ns_x" msg] $msg [catch "set test_ns_y" msg] $msg
|
||||
} {1 {can't read "test_ns_x": no such variable} 1 {can't read "test_ns_y": no such variable}}
|
||||
test namespace-old-1.21 {using namespace qualifiers} {
|
||||
list [catch "set test_ns_simple::test_ns_x" msg] $msg \
|
||||
[catch "set test_ns_simple::test_ns_y" msg] $msg
|
||||
} {0 0 0 123}
|
||||
test namespace-old-1.22 {using absolute namespace qualifiers} {
|
||||
list [catch "set ::test_ns_simple::test_ns_x" msg] $msg \
|
||||
[catch "set ::test_ns_simple::test_ns_y" msg] $msg
|
||||
} {0 0 0 123}
|
||||
test namespace-old-1.23 {variables can be accessed within a namespace} {
|
||||
test_ns_simple::_backdoor {
|
||||
variable test_ns_x
|
||||
variable test_ns_y
|
||||
return "$test_ns_x $test_ns_y"
|
||||
}
|
||||
} {0 123}
|
||||
|
||||
test namespace-old-1.24 {setting global variables} {
|
||||
test_ns_simple::_backdoor {variable test_ns_x; set test_ns_x "new val"}
|
||||
namespace eval test_ns_simple {set test_ns_x}
|
||||
} {new val}
|
||||
|
||||
test namespace-old-1.25 {qualified variables don't need a global declaration} {
|
||||
namespace eval test_ns_another { variable test_ns_x 456 }
|
||||
set cmd {set ::test_ns_another::test_ns_x}
|
||||
list [catch {test_ns_simple::_backdoor "$cmd some-value"} msg] $msg \
|
||||
[eval $cmd]
|
||||
} {0 some-value some-value}
|
||||
|
||||
test namespace-old-1.26 {namespace qualifiers are okay after $'s} {
|
||||
namespace eval test_ns_simple { set test_ns_x 12; set test_ns_y 34 }
|
||||
set cmd {list $::test_ns_simple::test_ns_x $::test_ns_simple::test_ns_y}
|
||||
list [test_ns_simple::_backdoor $cmd] [eval $cmd]
|
||||
} {{12 34} {12 34}}
|
||||
|
||||
test namespace-old-1.27 {can create commands with null names} {
|
||||
proc test_ns_simple:: {args} {return $args}
|
||||
} {}
|
||||
|
||||
# -----------------------------------------------------------------------
|
||||
# TEST: using "info" in namespace contexts
|
||||
# -----------------------------------------------------------------------
|
||||
test namespace-old-2.1 {querying: info commands} {
|
||||
lsort [test_ns_simple::_backdoor {info commands [namespace current]::*}]
|
||||
} {::test_ns_simple:: ::test_ns_simple::_backdoor ::test_ns_simple::test}
|
||||
|
||||
test namespace-old-2.2 {querying: info procs} {
|
||||
lsort [test_ns_simple::_backdoor {info procs}]
|
||||
} {{} _backdoor test}
|
||||
|
||||
test namespace-old-2.3 {querying: info vars} {
|
||||
lsort [info vars test_ns_simple::*]
|
||||
} {::test_ns_simple::test_ns_x ::test_ns_simple::test_ns_y}
|
||||
|
||||
test namespace-old-2.4 {querying: info vars} {
|
||||
lsort [test_ns_simple::_backdoor {info vars [namespace current]::*}]
|
||||
} {::test_ns_simple::test_ns_x ::test_ns_simple::test_ns_y}
|
||||
|
||||
test namespace-old-2.5 {querying: info locals} {
|
||||
lsort [test_ns_simple::_backdoor {info locals}]
|
||||
} {cmd}
|
||||
|
||||
test namespace-old-2.6 {querying: info exists} {
|
||||
test_ns_simple::_backdoor {info exists test_ns_x}
|
||||
} {0}
|
||||
|
||||
test namespace-old-2.7 {querying: info exists} {
|
||||
test_ns_simple::_backdoor {info exists cmd}
|
||||
} {1}
|
||||
|
||||
test namespace-old-2.8 {querying: info args} {
|
||||
info args test_ns_simple::_backdoor
|
||||
} {cmd}
|
||||
|
||||
test namespace-old-2.9 {querying: info body} {
|
||||
string trim [info body test_ns_simple::test]
|
||||
} {return "test: $test_ns_x"}
|
||||
|
||||
# -----------------------------------------------------------------------
|
||||
# TEST: namespace qualifiers, namespace tail
|
||||
# -----------------------------------------------------------------------
|
||||
test namespace-old-3.1 {usage for "namespace qualifiers"} {
|
||||
list [catch "namespace qualifiers" msg] $msg
|
||||
} {1 {wrong # args: should be "namespace qualifiers string"}}
|
||||
|
||||
test namespace-old-3.2 {querying: namespace qualifiers} {
|
||||
list [namespace qualifiers ""] \
|
||||
[namespace qualifiers ::] \
|
||||
[namespace qualifiers x] \
|
||||
[namespace qualifiers ::x] \
|
||||
[namespace qualifiers foo::x] \
|
||||
[namespace qualifiers ::foo::bar::xyz]
|
||||
} {{} {} {} {} foo ::foo::bar}
|
||||
|
||||
test namespace-old-3.3 {usage for "namespace tail"} {
|
||||
list [catch "namespace tail" msg] $msg
|
||||
} {1 {wrong # args: should be "namespace tail string"}}
|
||||
|
||||
test namespace-old-3.4 {querying: namespace tail} {
|
||||
list [namespace tail ""] \
|
||||
[namespace tail ::] \
|
||||
[namespace tail x] \
|
||||
[namespace tail ::x] \
|
||||
[namespace tail foo::x] \
|
||||
[namespace tail ::foo::bar::xyz]
|
||||
} {{} {} x x x xyz}
|
||||
|
||||
# -----------------------------------------------------------------------
|
||||
# TEST: delete commands and namespaces
|
||||
# -----------------------------------------------------------------------
|
||||
test namespace-old-4.1 {define test namespaces} {
|
||||
namespace eval test_ns_delete {
|
||||
namespace eval ns1 {
|
||||
variable var1 1
|
||||
proc cmd1 {} {return "cmd1"}
|
||||
}
|
||||
namespace eval ns2 {
|
||||
variable var2 2
|
||||
proc cmd2 {} {return "cmd2"}
|
||||
}
|
||||
namespace eval another {}
|
||||
lsort [namespace children]
|
||||
}
|
||||
} {::test_ns_delete::another ::test_ns_delete::ns1 ::test_ns_delete::ns2}
|
||||
|
||||
test namespace-old-4.2 {it's okay to invoke "namespace delete" with no args} {
|
||||
list [catch {namespace delete} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
test namespace-old-4.3 {command "namespace delete" doesn't support patterns} {
|
||||
set cmd {
|
||||
namespace eval test_ns_delete {namespace delete ns*}
|
||||
}
|
||||
list [catch $cmd msg] $msg
|
||||
} {1 {unknown namespace "ns*" in namespace delete command}}
|
||||
|
||||
test namespace-old-4.4 {command "namespace delete" handles multiple args} {
|
||||
set cmd {
|
||||
namespace eval test_ns_delete {
|
||||
namespace delete \
|
||||
{*}[namespace children [namespace current] ns?]
|
||||
}
|
||||
}
|
||||
list [catch $cmd msg] $msg [namespace children test_ns_delete]
|
||||
} {0 {} ::test_ns_delete::another}
|
||||
|
||||
# -----------------------------------------------------------------------
|
||||
# TEST: namespace hierarchy
|
||||
# -----------------------------------------------------------------------
|
||||
test namespace-old-5.1 {define nested namespaces} {
|
||||
set test_ns_var_global "var in ::"
|
||||
proc test_ns_cmd_global {} {return "cmd in ::"}
|
||||
|
||||
namespace eval test_ns_hier1 {
|
||||
set test_ns_var_hier1 "particular to hier1"
|
||||
proc test_ns_cmd_hier1 {} {return "particular to hier1"}
|
||||
|
||||
set test_ns_level 1
|
||||
proc test_ns_show {} {return "[namespace current]: 1"}
|
||||
|
||||
namespace eval test_ns_hier2 {
|
||||
set test_ns_var_hier2 "particular to hier2"
|
||||
proc test_ns_cmd_hier2 {} {return "particular to hier2"}
|
||||
|
||||
set test_ns_level 2
|
||||
proc test_ns_show {} {return "[namespace current]: 2"}
|
||||
|
||||
namespace eval test_ns_hier3a {}
|
||||
namespace eval test_ns_hier3b {}
|
||||
}
|
||||
|
||||
namespace eval test_ns_hier2a {}
|
||||
namespace eval test_ns_hier2b {}
|
||||
}
|
||||
} {}
|
||||
|
||||
test namespace-old-5.2 {namespaces can be nested} {
|
||||
list [namespace eval test_ns_hier1 {namespace current}] \
|
||||
[namespace eval test_ns_hier1 {
|
||||
namespace eval test_ns_hier2 {namespace current}
|
||||
}]
|
||||
} {::test_ns_hier1 ::test_ns_hier1::test_ns_hier2}
|
||||
|
||||
test namespace-old-5.3 {namespace qualifiers work in namespace command} {
|
||||
list [namespace eval ::test_ns_hier1 {namespace current}] \
|
||||
[namespace eval test_ns_hier1::test_ns_hier2 {namespace current}] \
|
||||
[namespace eval ::test_ns_hier1::test_ns_hier2 {namespace current}]
|
||||
} {::test_ns_hier1 ::test_ns_hier1::test_ns_hier2 ::test_ns_hier1::test_ns_hier2}
|
||||
|
||||
test namespace-old-5.4 {nested namespaces can access global namespace} {
|
||||
list [namespace eval test_ns_hier1 {set test_ns_var_global}] \
|
||||
[namespace eval test_ns_hier1 {test_ns_cmd_global}] \
|
||||
[namespace eval test_ns_hier1::test_ns_hier2 {set test_ns_var_global}] \
|
||||
[namespace eval test_ns_hier1::test_ns_hier2 {test_ns_cmd_global}]
|
||||
} {{var in ::} {cmd in ::} {var in ::} {cmd in ::}}
|
||||
|
||||
test namespace-old-5.5 {variables in different namespaces don't conflict} {
|
||||
list [set test_ns_hier1::test_ns_level] \
|
||||
[set test_ns_hier1::test_ns_hier2::test_ns_level]
|
||||
} {1 2}
|
||||
|
||||
test namespace-old-5.6 {commands in different namespaces don't conflict} {
|
||||
list [test_ns_hier1::test_ns_show] \
|
||||
[test_ns_hier1::test_ns_hier2::test_ns_show]
|
||||
} {{::test_ns_hier1: 1} {::test_ns_hier1::test_ns_hier2: 2}}
|
||||
|
||||
test namespace-old-5.7 {nested namespaces don't see variables in parent} {
|
||||
set cmd {
|
||||
namespace eval test_ns_hier1::test_ns_hier2 {set test_ns_var_hier1}
|
||||
}
|
||||
list [catch $cmd msg] $msg
|
||||
} {1 {can't read "test_ns_var_hier1": no such variable}}
|
||||
|
||||
test namespace-old-5.8 {nested namespaces don't see commands in parent} {
|
||||
set cmd {
|
||||
namespace eval test_ns_hier1::test_ns_hier2 {test_ns_cmd_hier1}
|
||||
}
|
||||
list [catch $cmd msg] $msg
|
||||
} {1 {invalid command name "test_ns_cmd_hier1"}}
|
||||
|
||||
test namespace-old-5.9 {usage for "namespace children"} {
|
||||
list [catch {namespace children test_ns_hier1 y z} msg] $msg
|
||||
} {1 {wrong # args: should be "namespace children ?name? ?pattern?"}}
|
||||
|
||||
test namespace-old-5.10 {command "namespace children" must get valid namespace} -body {
|
||||
namespace children xyzzy
|
||||
} -returnCodes error -result {namespace "xyzzy" not found in "::"}
|
||||
|
||||
test namespace-old-5.11 {querying namespace children} {
|
||||
lsort [namespace children :: test_ns_hier*]
|
||||
} {::test_ns_hier1}
|
||||
|
||||
test namespace-old-5.12 {querying namespace children} {
|
||||
lsort [namespace children test_ns_hier1]
|
||||
} {::test_ns_hier1::test_ns_hier2 ::test_ns_hier1::test_ns_hier2a ::test_ns_hier1::test_ns_hier2b}
|
||||
|
||||
test namespace-old-5.13 {querying namespace children} {
|
||||
lsort [namespace eval test_ns_hier1 {namespace children}]
|
||||
} {::test_ns_hier1::test_ns_hier2 ::test_ns_hier1::test_ns_hier2a ::test_ns_hier1::test_ns_hier2b}
|
||||
|
||||
test namespace-old-5.14 {querying namespace children} {
|
||||
lsort [namespace children test_ns_hier1::test_ns_hier2]
|
||||
} {::test_ns_hier1::test_ns_hier2::test_ns_hier3a ::test_ns_hier1::test_ns_hier2::test_ns_hier3b}
|
||||
|
||||
test namespace-old-5.15 {querying namespace children} {
|
||||
lsort [namespace eval test_ns_hier1::test_ns_hier2 {namespace children}]
|
||||
} {::test_ns_hier1::test_ns_hier2::test_ns_hier3a ::test_ns_hier1::test_ns_hier2::test_ns_hier3b}
|
||||
|
||||
test namespace-old-5.16 {querying namespace children with patterns} {
|
||||
lsort [namespace children test_ns_hier1::test_ns_hier2 test_ns_*]
|
||||
} {::test_ns_hier1::test_ns_hier2::test_ns_hier3a ::test_ns_hier1::test_ns_hier2::test_ns_hier3b}
|
||||
|
||||
test namespace-old-5.17 {querying namespace children with patterns} {
|
||||
lsort [namespace children test_ns_hier1::test_ns_hier2 *b]
|
||||
} {::test_ns_hier1::test_ns_hier2::test_ns_hier3b}
|
||||
|
||||
test namespace-old-5.18 {usage for "namespace parent"} {
|
||||
list [catch {namespace parent x y} msg] $msg
|
||||
} {1 {wrong # args: should be "namespace parent ?name?"}}
|
||||
|
||||
test namespace-old-5.19 {command "namespace parent" must get valid namespace} -body {
|
||||
namespace parent xyzzy
|
||||
} -returnCodes error -result {namespace "xyzzy" not found in "::"}
|
||||
|
||||
test namespace-old-5.20 {querying namespace parent} {
|
||||
list [namespace eval :: {namespace parent}] \
|
||||
[namespace eval test_ns_hier1 {namespace parent}] \
|
||||
[namespace eval test_ns_hier1::test_ns_hier2 {namespace parent}] \
|
||||
[namespace eval test_ns_hier1::test_ns_hier2::test_ns_hier3a {namespace parent}] \
|
||||
} {{} :: ::test_ns_hier1 ::test_ns_hier1::test_ns_hier2}
|
||||
|
||||
test namespace-old-5.21 {querying namespace parent for explicit namespace} {
|
||||
list [namespace parent ::] \
|
||||
[namespace parent test_ns_hier1] \
|
||||
[namespace parent test_ns_hier1::test_ns_hier2] \
|
||||
[namespace parent test_ns_hier1::test_ns_hier2::test_ns_hier3a]
|
||||
} {{} :: ::test_ns_hier1 ::test_ns_hier1::test_ns_hier2}
|
||||
|
||||
# -----------------------------------------------------------------------
|
||||
# TEST: name resolution and caching
|
||||
# -----------------------------------------------------------------------
|
||||
test namespace-old-6.1 {relative ns names only looked up in current ns} {
|
||||
namespace eval test_ns_cache1 {}
|
||||
namespace eval test_ns_cache2 {}
|
||||
namespace eval test_ns_cache2::test_ns_cache3 {}
|
||||
set trigger {
|
||||
namespace eval test_ns_cache2 {namespace current}
|
||||
}
|
||||
set trigger2 {
|
||||
namespace eval test_ns_cache2::test_ns_cache3 {namespace current}
|
||||
}
|
||||
list [namespace eval test_ns_cache1 $trigger] \
|
||||
[namespace eval test_ns_cache1 $trigger2]
|
||||
} {::test_ns_cache1::test_ns_cache2 ::test_ns_cache1::test_ns_cache2::test_ns_cache3}
|
||||
|
||||
test namespace-old-6.2 {relative ns names only looked up in current ns} {
|
||||
namespace eval test_ns_cache1::test_ns_cache2 {}
|
||||
list [namespace eval test_ns_cache1 $trigger] \
|
||||
[namespace eval test_ns_cache1 $trigger2]
|
||||
} {::test_ns_cache1::test_ns_cache2 ::test_ns_cache1::test_ns_cache2::test_ns_cache3}
|
||||
|
||||
test namespace-old-6.3 {relative ns names only looked up in current ns} {
|
||||
namespace eval test_ns_cache1::test_ns_cache2::test_ns_cache3 {}
|
||||
list [namespace eval test_ns_cache1 $trigger] \
|
||||
[namespace eval test_ns_cache1 $trigger2]
|
||||
} {::test_ns_cache1::test_ns_cache2 ::test_ns_cache1::test_ns_cache2::test_ns_cache3}
|
||||
|
||||
test namespace-old-6.4 {relative ns names only looked up in current ns} {
|
||||
namespace delete test_ns_cache1::test_ns_cache2
|
||||
list [namespace eval test_ns_cache1 $trigger] \
|
||||
[namespace eval test_ns_cache1 $trigger2]
|
||||
} {::test_ns_cache1::test_ns_cache2 ::test_ns_cache1::test_ns_cache2::test_ns_cache3}
|
||||
|
||||
test namespace-old-6.5 {define test commands} {
|
||||
proc test_ns_cache_cmd {} {
|
||||
return "global version"
|
||||
}
|
||||
namespace eval test_ns_cache1 {
|
||||
proc trigger {} {
|
||||
test_ns_cache_cmd
|
||||
}
|
||||
}
|
||||
test_ns_cache1::trigger
|
||||
} {global version}
|
||||
|
||||
test namespace-old-6.6 {one-level check for command shadowing} {
|
||||
proc test_ns_cache1::test_ns_cache_cmd {} {
|
||||
return "cache1 version"
|
||||
}
|
||||
test_ns_cache1::trigger
|
||||
} {cache1 version}
|
||||
|
||||
test namespace-old-6.7 {renaming commands changes command epoch} {
|
||||
namespace eval test_ns_cache1 {
|
||||
rename test_ns_cache_cmd test_ns_new
|
||||
}
|
||||
test_ns_cache1::trigger
|
||||
} {global version}
|
||||
|
||||
test namespace-old-6.8 {renaming back handles shadowing} {
|
||||
namespace eval test_ns_cache1 {
|
||||
rename test_ns_new test_ns_cache_cmd
|
||||
}
|
||||
test_ns_cache1::trigger
|
||||
} {cache1 version}
|
||||
|
||||
test namespace-old-6.9 {deleting commands changes command epoch} {
|
||||
namespace eval test_ns_cache1 {
|
||||
rename test_ns_cache_cmd ""
|
||||
}
|
||||
test_ns_cache1::trigger
|
||||
} {global version}
|
||||
|
||||
test namespace-old-6.10 {define test namespaces} {
|
||||
namespace eval test_ns_cache2 {
|
||||
proc test_ns_cache_cmd {} {
|
||||
return "global cache2 version"
|
||||
}
|
||||
}
|
||||
namespace eval test_ns_cache1 {
|
||||
proc trigger {} {
|
||||
test_ns_cache2::test_ns_cache_cmd
|
||||
}
|
||||
}
|
||||
namespace eval test_ns_cache1::test_ns_cache2 {
|
||||
proc trigger {} {
|
||||
test_ns_cache_cmd
|
||||
}
|
||||
}
|
||||
list [test_ns_cache1::trigger] [test_ns_cache1::test_ns_cache2::trigger]
|
||||
} {{global cache2 version} {global version}}
|
||||
|
||||
test namespace-old-6.11 {commands affect all parent namespaces} {
|
||||
proc test_ns_cache1::test_ns_cache2::test_ns_cache_cmd {} {
|
||||
return "cache2 version"
|
||||
}
|
||||
list [test_ns_cache1::trigger] [test_ns_cache1::test_ns_cache2::trigger]
|
||||
} {{cache2 version} {cache2 version}}
|
||||
|
||||
test namespace-old-6.12 {define test variables} {
|
||||
variable test_ns_cache_var "global version"
|
||||
set trigger {set test_ns_cache_var}
|
||||
namespace eval test_ns_cache1 $trigger
|
||||
} {global version}
|
||||
|
||||
test namespace-old-6.13 {one-level check for variable shadowing} {
|
||||
namespace eval test_ns_cache1 {
|
||||
variable test_ns_cache_var "cache1 version"
|
||||
}
|
||||
namespace eval test_ns_cache1 $trigger
|
||||
} {cache1 version}
|
||||
|
||||
test namespace-old-6.14 {deleting variables changes variable epoch} {
|
||||
namespace eval test_ns_cache1 {
|
||||
unset test_ns_cache_var
|
||||
}
|
||||
namespace eval test_ns_cache1 $trigger
|
||||
} {global version}
|
||||
|
||||
test namespace-old-6.15 {define test namespaces} {
|
||||
namespace eval test_ns_cache2 {
|
||||
variable test_ns_cache_var "global cache2 version"
|
||||
}
|
||||
set trigger2 {set test_ns_cache2::test_ns_cache_var}
|
||||
list [namespace eval test_ns_cache1 $trigger2] \
|
||||
[namespace eval test_ns_cache1::test_ns_cache2 $trigger]
|
||||
} {{global cache2 version} {global version}}
|
||||
|
||||
test namespace-old-6.16 {public variables affect all parent namespaces} {
|
||||
variable test_ns_cache1::test_ns_cache2::test_ns_cache_var "cache2 version"
|
||||
list [namespace eval test_ns_cache1 $trigger2] \
|
||||
[namespace eval test_ns_cache1::test_ns_cache2 $trigger]
|
||||
} {{cache2 version} {cache2 version}}
|
||||
|
||||
test namespace-old-6.17 {usage for "namespace which"} {
|
||||
list [catch "namespace which -baz x" msg] $msg
|
||||
} {1 {wrong # args: should be "namespace which ?-command? ?-variable? name"}}
|
||||
test namespace-old-6.18 {usage for "namespace which"} {
|
||||
# Presume no imported command called -command ;^)
|
||||
namespace which -command
|
||||
} {}
|
||||
|
||||
test namespace-old-6.19 {querying: namespace which -command} {
|
||||
proc test_ns_cache1::test_ns_cache_cmd {} {
|
||||
return "cache1 version"
|
||||
}
|
||||
list [namespace eval :: {namespace which test_ns_cache_cmd}] \
|
||||
[namespace eval test_ns_cache1 {namespace which test_ns_cache_cmd}] \
|
||||
[namespace eval :: {namespace which -command test_ns_cache_cmd}] \
|
||||
[namespace eval test_ns_cache1 {namespace which -command test_ns_cache_cmd}]
|
||||
} {::test_ns_cache_cmd ::test_ns_cache1::test_ns_cache_cmd ::test_ns_cache_cmd ::test_ns_cache1::test_ns_cache_cmd}
|
||||
|
||||
test namespace-old-6.20 {command "namespace which" may not find commands} {
|
||||
namespace eval test_ns_cache1 {namespace which -command xyzzy}
|
||||
} {}
|
||||
|
||||
test namespace-old-6.21 {querying: namespace which -variable} {
|
||||
namespace eval test_ns_cache1::test_ns_cache2 {
|
||||
namespace which -variable test_ns_cache_var
|
||||
}
|
||||
} {::test_ns_cache1::test_ns_cache2::test_ns_cache_var}
|
||||
|
||||
test namespace-old-6.22 {command "namespace which" may not find variables} {
|
||||
namespace eval test_ns_cache1 {namespace which -variable xyzzy}
|
||||
} {}
|
||||
|
||||
# -----------------------------------------------------------------------
|
||||
# TEST: uplevel/upvar across namespace boundaries
|
||||
# -----------------------------------------------------------------------
|
||||
test namespace-old-7.1 {define test namespace} {
|
||||
namespace eval test_ns_uplevel {
|
||||
variable x 0
|
||||
variable y 1
|
||||
|
||||
proc show_vars {num} {
|
||||
return [uplevel $num {info vars}]
|
||||
}
|
||||
proc test_uplevel {num} {
|
||||
set a 0
|
||||
set b 1
|
||||
namespace eval ::test_ns_uplevel " return \[show_vars $num\] "
|
||||
}
|
||||
}
|
||||
} {}
|
||||
test namespace-old-7.2 {uplevel can access namespace call frame} {
|
||||
list [expr {[lsearch -exact [test_ns_uplevel::test_uplevel 1] x]>=0}] \
|
||||
[expr {[lsearch -exact [test_ns_uplevel::test_uplevel 1] y]>=0}]
|
||||
} {1 1}
|
||||
test namespace-old-7.3 {uplevel can go beyond namespace call frame} {
|
||||
lsort [test_ns_uplevel::test_uplevel 2]
|
||||
} {a b num}
|
||||
test namespace-old-7.4 {uplevel can go up to global context} {
|
||||
expr {[test_ns_uplevel::test_uplevel 3] == [info globals]}
|
||||
} {1}
|
||||
|
||||
test namespace-old-7.5 {absolute call frame references work too} {
|
||||
list [expr {[lsearch -exact [test_ns_uplevel::test_uplevel #2] x]>=0}] \
|
||||
[expr {[lsearch -exact [test_ns_uplevel::test_uplevel #2] y]>=0}]
|
||||
} {1 1}
|
||||
test namespace-old-7.6 {absolute call frame references work too} {
|
||||
lsort [test_ns_uplevel::test_uplevel #1]
|
||||
} {a b num}
|
||||
test namespace-old-7.7 {absolute call frame references work too} {
|
||||
expr {[test_ns_uplevel::test_uplevel #0] == [info globals]}
|
||||
} {1}
|
||||
|
||||
test namespace-old-7.8 {namespaces are included in the call stack} {
|
||||
namespace eval test_ns_upvar {
|
||||
variable scope "test_ns_upvar"
|
||||
|
||||
proc show_val {var num} {
|
||||
upvar $num $var x
|
||||
return $x
|
||||
}
|
||||
proc test_upvar {num} {
|
||||
set scope "test_ns_upvar::test_upvar"
|
||||
namespace eval ::test_ns_upvar " return \[show_val scope $num\] "
|
||||
}
|
||||
}
|
||||
} {}
|
||||
test namespace-old-7.9 {upvar can access namespace call frame} {
|
||||
test_ns_upvar::test_upvar 1
|
||||
} {test_ns_upvar}
|
||||
test namespace-old-7.10 {upvar can go beyond namespace call frame} {
|
||||
test_ns_upvar::test_upvar 2
|
||||
} {test_ns_upvar::test_upvar}
|
||||
test namespace-old-7.11 {absolute call frame references work too} {
|
||||
test_ns_upvar::test_upvar #2
|
||||
} {test_ns_upvar}
|
||||
test namespace-old-7.12 {absolute call frame references work too} {
|
||||
test_ns_upvar::test_upvar #1
|
||||
} {test_ns_upvar::test_upvar}
|
||||
|
||||
# -----------------------------------------------------------------------
|
||||
# TEST: variable traces across namespace boundaries
|
||||
# -----------------------------------------------------------------------
|
||||
test namespace-old-8.1 {traces work across namespace boundaries} {
|
||||
namespace eval test_ns_trace {
|
||||
namespace eval foo {
|
||||
variable x ""
|
||||
}
|
||||
|
||||
variable status ""
|
||||
proc monitor {name1 name2 op} {
|
||||
variable status
|
||||
lappend status "$op: $name1"
|
||||
}
|
||||
trace variable foo::x rwu [namespace code monitor]
|
||||
}
|
||||
set test_ns_trace::foo::x "yes!"
|
||||
set test_ns_trace::foo::x
|
||||
unset test_ns_trace::foo::x
|
||||
|
||||
namespace eval test_ns_trace { set status }
|
||||
} {{w: test_ns_trace::foo::x} {r: test_ns_trace::foo::x} {u: test_ns_trace::foo::x}}
|
||||
|
||||
# -----------------------------------------------------------------------
|
||||
# TEST: imported commands
|
||||
# -----------------------------------------------------------------------
|
||||
test namespace-old-9.1 {empty "namespace export" list} {
|
||||
list [catch "namespace export" msg] $msg
|
||||
} {0 {}}
|
||||
test namespace-old-9.2 {usage for "namespace export" command} {
|
||||
list [catch "namespace export test_ns_trace::zzz" msg] $msg
|
||||
} {1 {invalid export pattern "test_ns_trace::zzz": pattern can't specify a namespace}}
|
||||
|
||||
test namespace-old-9.3 {define test namespaces for import} {
|
||||
namespace eval test_ns_export {
|
||||
namespace export cmd1 cmd2 cmd3
|
||||
proc cmd1 {args} {return "cmd1: $args"}
|
||||
proc cmd2 {args} {return "cmd2: $args"}
|
||||
proc cmd3 {args} {return "cmd3: $args"}
|
||||
proc cmd4 {args} {return "cmd4: $args"}
|
||||
proc cmd5 {args} {return "cmd5: $args"}
|
||||
proc cmd6 {args} {return "cmd6: $args"}
|
||||
}
|
||||
lsort [info commands test_ns_export::*]
|
||||
} {::test_ns_export::cmd1 ::test_ns_export::cmd2 ::test_ns_export::cmd3 ::test_ns_export::cmd4 ::test_ns_export::cmd5 ::test_ns_export::cmd6}
|
||||
|
||||
test namespace-old-9.4 {check export status} {
|
||||
set x ""
|
||||
namespace eval test_ns_import {
|
||||
namespace export cmd1 cmd2
|
||||
namespace import ::test_ns_export::*
|
||||
}
|
||||
foreach cmd [lsort [info commands test_ns_import::*]] {
|
||||
lappend x $cmd
|
||||
}
|
||||
set x
|
||||
} {::test_ns_import::cmd1 ::test_ns_import::cmd2 ::test_ns_import::cmd3}
|
||||
|
||||
test namespace-old-9.5 {empty import list in "namespace import" command} {
|
||||
lsort [namespace import]
|
||||
} {bytestring cleanupTests configure customMatch debug errorChannel errorFile getMatchingFiles interpreter limitConstraints loadFile loadScript loadTestedCommands mainThread makeDirectory makeFile match matchDirectories matchFiles normalizeMsg normalizePath outputChannel outputFile preserveCore removeDirectory removeFile restoreState runAllTests saveState singleProcess skip skipDirectories skipFiles temporaryDirectory test testConstraint testsDirectory threadReap verbose viewFile workingDirectory}
|
||||
|
||||
test namespace-old-9.7 {empty forget list for "namespace forget" command} {
|
||||
namespace forget
|
||||
} {}
|
||||
|
||||
catch {rename cmd1 {}}
|
||||
catch {rename cmd2 {}}
|
||||
catch {rename ncmd {}}
|
||||
catch {rename ncmd1 {}}
|
||||
catch {rename ncmd2 {}}
|
||||
test namespace-old-9.8 {only exported commands are imported} {
|
||||
namespace import test_ns_import::cmd*
|
||||
set x [lsort [info commands cmd*]]
|
||||
} {cmd1 cmd2}
|
||||
|
||||
test namespace-old-9.9 {imported commands work just the same as original} {
|
||||
list [cmd1 test 1 2 3] [test_ns_import::cmd1 test 4 5 6]
|
||||
} {{cmd1: test 1 2 3} {cmd1: test 4 5 6}}
|
||||
|
||||
test namespace-old-9.10 {commands can be imported from many namespaces} {
|
||||
namespace eval test_ns_import2 {
|
||||
namespace export ncmd ncmd1 ncmd2
|
||||
proc ncmd {args} {return "ncmd: $args"}
|
||||
proc ncmd1 {args} {return "ncmd1: $args"}
|
||||
proc ncmd2 {args} {return "ncmd2: $args"}
|
||||
proc ncmd3 {args} {return "ncmd3: $args"}
|
||||
}
|
||||
namespace import test_ns_import2::*
|
||||
lsort [concat [info commands cmd*] [info commands ncmd*]]
|
||||
} {cmd1 cmd2 ncmd ncmd1 ncmd2}
|
||||
|
||||
test namespace-old-9.11 {imported commands can be removed by deleting them} {
|
||||
rename cmd1 ""
|
||||
lsort [concat [info commands cmd*] [info commands ncmd*]]
|
||||
} {cmd2 ncmd ncmd1 ncmd2}
|
||||
|
||||
test namespace-old-9.12 {command "namespace forget" checks for valid namespaces} {
|
||||
list [catch {namespace forget xyzzy::*} msg] $msg
|
||||
} {1 {unknown namespace in namespace forget pattern "xyzzy::*"}}
|
||||
|
||||
test namespace-old-9.13 {command "namespace forget" ignores patterns that don't match} {
|
||||
list [catch {namespace forget test_ns_import::xy*zzy} msg] $msg \
|
||||
[lsort [info commands cmd?]]
|
||||
} {0 {} cmd2}
|
||||
|
||||
test namespace-old-9.14 {imported commands can be removed} {
|
||||
namespace forget test_ns_import::cmd?
|
||||
list [lsort [info commands cmd?]] \
|
||||
[catch {cmd1 another test} msg] $msg
|
||||
} {{} 1 {invalid command name "cmd1"}}
|
||||
|
||||
test namespace-old-9.15 {existing commands can't be overwritten} {
|
||||
proc cmd1 {x y} {
|
||||
return [expr $x+$y]
|
||||
}
|
||||
list [catch {namespace import test_ns_import::cmd?} msg] $msg \
|
||||
[cmd1 3 5]
|
||||
} {1 {can't import command "cmd1": already exists} 8}
|
||||
|
||||
test namespace-old-9.16 {use "-force" option to override existing commands} {
|
||||
list [cmd1 3 5] \
|
||||
[namespace import -force test_ns_import::cmd?] \
|
||||
[cmd1 3 5]
|
||||
} {8 {} {cmd1: 3 5}}
|
||||
|
||||
test namespace-old-9.17 {commands can be imported into many namespaces} {
|
||||
namespace eval test_ns_import_use {
|
||||
namespace import ::test_ns_import::* ::test_ns_import2::ncmd?
|
||||
lsort [concat [info commands ::test_ns_import_use::cmd*] \
|
||||
[info commands ::test_ns_import_use::ncmd*]]
|
||||
}
|
||||
} {::test_ns_import_use::cmd1 ::test_ns_import_use::cmd2 ::test_ns_import_use::ncmd1 ::test_ns_import_use::ncmd2}
|
||||
|
||||
test namespace-old-9.18 {when command is deleted, imported commands go away} {
|
||||
namespace eval test_ns_import { rename cmd1 "" }
|
||||
list [info commands cmd1] \
|
||||
[namespace eval test_ns_import_use {info commands cmd1}]
|
||||
} {{} {}}
|
||||
|
||||
test namespace-old-9.19 {when namesp is deleted, all imported commands go away} {
|
||||
namespace delete test_ns_import test_ns_import2
|
||||
list [info commands cmd*] \
|
||||
[info commands ncmd*] \
|
||||
[namespace eval test_ns_import_use {info commands cmd*}] \
|
||||
[namespace eval test_ns_import_use {info commands ncmd*}] \
|
||||
} {{} {} {} {}}
|
||||
|
||||
# -----------------------------------------------------------------------
|
||||
# TEST: scoped values
|
||||
# -----------------------------------------------------------------------
|
||||
test namespace-old-10.1 {define namespace for scope test} {
|
||||
namespace eval test_ns_inscope {
|
||||
variable x "x-value"
|
||||
proc show {args} {
|
||||
return "show: $args"
|
||||
}
|
||||
proc do {args} {
|
||||
return [eval $args]
|
||||
}
|
||||
list [set x] [show test]
|
||||
}
|
||||
} {x-value {show: test}}
|
||||
|
||||
test namespace-old-10.2 {command "namespace code" requires one argument} {
|
||||
list [catch {namespace code} msg] $msg
|
||||
} {1 {wrong # args: should be "namespace code arg"}}
|
||||
|
||||
test namespace-old-10.3 {command "namespace code" requires one argument} {
|
||||
list [catch {namespace code first "second arg" third} msg] $msg
|
||||
} {1 {wrong # args: should be "namespace code arg"}}
|
||||
|
||||
test namespace-old-10.4 {command "namespace code" gets current namesp context} {
|
||||
namespace eval test_ns_inscope {
|
||||
namespace code {"1 2 3" "4 5" 6}
|
||||
}
|
||||
} {::namespace inscope ::test_ns_inscope {"1 2 3" "4 5" 6}}
|
||||
|
||||
test namespace-old-10.5 {with one arg, first "scope" sticks} {
|
||||
set sval [namespace eval test_ns_inscope {namespace code {one two}}]
|
||||
namespace code $sval
|
||||
} {::namespace inscope ::test_ns_inscope {one two}}
|
||||
|
||||
test namespace-old-10.6 {with many args, each "scope" adds new args} {
|
||||
set sval [namespace eval test_ns_inscope {namespace code {one two}}]
|
||||
namespace code "$sval three"
|
||||
} {::namespace inscope ::test_ns_inscope {one two} three}
|
||||
|
||||
test namespace-old-10.7 {scoped commands work with eval} {
|
||||
set cref [namespace eval test_ns_inscope {namespace code show}]
|
||||
list [eval $cref "a" "b c" "d e f"]
|
||||
} {{show: a b c d e f}}
|
||||
|
||||
test namespace-old-10.8 {scoped commands execute in namespace context} {
|
||||
set cref [namespace eval test_ns_inscope {
|
||||
namespace code {set x "some new value"}
|
||||
}]
|
||||
list [set test_ns_inscope::x] [eval $cref] [set test_ns_inscope::x]
|
||||
} {x-value {some new value} {some new value}}
|
||||
|
||||
foreach cmd [info commands test_ns_*] {
|
||||
rename $cmd ""
|
||||
}
|
||||
catch {rename cmd {}}
|
||||
catch {rename cmd1 {}}
|
||||
catch {rename cmd2 {}}
|
||||
catch {rename ncmd {}}
|
||||
catch {rename ncmd1 {}}
|
||||
catch {rename ncmd2 {}}
|
||||
catch {unset cref}
|
||||
catch {unset trigger}
|
||||
catch {unset trigger2}
|
||||
catch {unset sval}
|
||||
catch {unset msg}
|
||||
catch {unset x}
|
||||
catch {unset test_ns_var_global}
|
||||
catch {unset cmd}
|
||||
eval namespace delete [namespace children :: test_ns_*]
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
2676
tests/namespace.test
Normal file
2676
tests/namespace.test
Normal file
File diff suppressed because it is too large
Load Diff
324
tests/notify.test
Normal file
324
tests/notify.test
Normal file
@@ -0,0 +1,324 @@
|
||||
# -*- tcl -*-
|
||||
#
|
||||
# notify.test --
|
||||
#
|
||||
# This file tests several functions in the file, 'generic/tclNotify.c'.
|
||||
#
|
||||
# This file contains a collection of tests for one or more of the Tcl
|
||||
# built-in commands. Sourcing this file into Tcl runs the tests and
|
||||
# generates output for errors. No output means no errors were found.
|
||||
#
|
||||
# Copyright (c) 2003 by Kevin B. Kenny. All rights reserved.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest 2
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
testConstraint testevent [llength [info commands testevent]]
|
||||
|
||||
test notify-1.1 {Tcl_QueueEvent and delivery of a single event} \
|
||||
-constraints {testevent} \
|
||||
-body {
|
||||
set delivered {}
|
||||
after 10 set done 1
|
||||
testevent queue one tail {lappend delivered one; expr 1}
|
||||
vwait done
|
||||
set delivered
|
||||
} \
|
||||
-result {one}
|
||||
|
||||
test notify-1.2 {Tcl_QueueEvent and delivery of events in order} \
|
||||
-constraints {testevent} \
|
||||
-body {
|
||||
set delivered {}
|
||||
after 10 set done 1
|
||||
testevent queue one tail {lappend delivered one; expr 1}
|
||||
testevent queue two tail {lappend delivered two; expr 1}
|
||||
testevent queue three tail {lappend delivered three; expr 1}
|
||||
vwait done
|
||||
set delivered
|
||||
} \
|
||||
-result {one two three}
|
||||
|
||||
test notify-1.3 {Tcl_QueueEvent at head} \
|
||||
-constraints {testevent} \
|
||||
-body {
|
||||
set delivered {}
|
||||
after 10 set done 1
|
||||
testevent queue one head {lappend delivered one; expr 1}
|
||||
vwait done
|
||||
set delivered
|
||||
} \
|
||||
-result one
|
||||
|
||||
test notify-1.4 {Tcl_QueueEvent multiple events at head} \
|
||||
-constraints {testevent} \
|
||||
-body {
|
||||
set delivered {}
|
||||
after 10 set done 1
|
||||
testevent queue one head {lappend delivered one; expr 1}
|
||||
testevent queue two head {lappend delivered two; expr 1}
|
||||
testevent queue three head {lappend delivered three; expr 1}
|
||||
vwait done
|
||||
set delivered
|
||||
} \
|
||||
-result {three two one}
|
||||
|
||||
test notify-1.5 {Tcl_QueueEvent marker event into an empty queue} \
|
||||
-constraints {testevent} \
|
||||
-body {
|
||||
set delivered {}
|
||||
after 10 set done 1
|
||||
testevent queue one mark {lappend delivered one; expr 1}
|
||||
vwait done
|
||||
set delivered
|
||||
} \
|
||||
-result one
|
||||
|
||||
test notify-1.6 {Tcl_QueueEvent first marker event in a nonempty queue} \
|
||||
-constraints {testevent} \
|
||||
-body {
|
||||
set delivered {}
|
||||
after 10 set done 1
|
||||
testevent queue one tail {lappend delivered one; expr 1}
|
||||
testevent queue two mark {lappend delivered two; expr 1}
|
||||
testevent queue three head {lappend delivered three; expr 1}
|
||||
vwait done
|
||||
set delivered
|
||||
} \
|
||||
-result {three two one}
|
||||
|
||||
test notify-1.7 {Tcl_QueueEvent second marker event} \
|
||||
-constraints {testevent} \
|
||||
-body {
|
||||
set delivered {}
|
||||
after 10 set done 1
|
||||
testevent queue one mark {lappend delivered one; expr 1}
|
||||
testevent queue two mark {lappend delivered two; expr 1}
|
||||
vwait done
|
||||
set delivered
|
||||
} \
|
||||
-result {one two}
|
||||
|
||||
test notify-1.8 {Tcl_QueueEvent preexisting event following second marker} \
|
||||
-constraints {testevent} \
|
||||
-body {
|
||||
set delivered {}
|
||||
after 10 set done 1
|
||||
testevent queue one mark {lappend delivered one; expr 1}
|
||||
testevent queue two tail {lappend delivered two; expr 1}
|
||||
testevent queue three mark {lappend delivered three; expr 1}
|
||||
vwait done
|
||||
set delivered
|
||||
} \
|
||||
-result {one three two}
|
||||
|
||||
test notify-2.1 {remove sole element, don't replace } \
|
||||
-constraints {testevent} \
|
||||
-body {
|
||||
set delivered {}
|
||||
after 10 set done 1
|
||||
testevent queue one tail {lappend delivered one; expr 1}
|
||||
testevent delete one
|
||||
vwait done
|
||||
set delivered
|
||||
} \
|
||||
-result {}
|
||||
|
||||
test notify-2.2 {remove and replace sole element} \
|
||||
-constraints {testevent} \
|
||||
-body {
|
||||
set delivered {}
|
||||
after 10 set done 1
|
||||
testevent queue one tail {lappend delivered one; expr 1}
|
||||
testevent delete one
|
||||
testevent queue two tail {lappend delivered two; expr 1}
|
||||
vwait done
|
||||
set delivered
|
||||
} \
|
||||
-result two
|
||||
|
||||
test notify-2.3 {remove first element} \
|
||||
-constraints {testevent} \
|
||||
-body {
|
||||
set delivered {}
|
||||
after 10 set done 1
|
||||
testevent queue one tail {lappend delivered one; expr 1}
|
||||
testevent queue two tail {lappend delivered two; expr 1}
|
||||
testevent delete one
|
||||
vwait done
|
||||
set delivered
|
||||
} \
|
||||
-result {two}
|
||||
|
||||
test notify-2.4 {remove and replace first element} \
|
||||
-constraints {testevent} \
|
||||
-body {
|
||||
set delivered {}
|
||||
after 10 set done 1
|
||||
testevent queue one tail {lappend delivered one; expr 1}
|
||||
testevent queue two tail {lappend delivered two; expr 1}
|
||||
testevent delete one
|
||||
testevent queue three head {lappend delivered three; expr 1};
|
||||
vwait done
|
||||
set delivered
|
||||
} \
|
||||
-result {three two}
|
||||
|
||||
test notify-2.5 {remove last element} \
|
||||
-constraints {testevent} \
|
||||
-body {
|
||||
set delivered {}
|
||||
after 10 set done 1
|
||||
testevent queue one tail {lappend delivered one; expr 1}
|
||||
testevent queue two tail {lappend delivered two; expr 1}
|
||||
testevent delete two
|
||||
vwait done
|
||||
set delivered
|
||||
} \
|
||||
-result {one}
|
||||
|
||||
|
||||
test notify-2.6 {remove and replace last element} \
|
||||
-constraints {testevent} \
|
||||
-body {
|
||||
set delivered {}
|
||||
after 10 set done 1
|
||||
testevent queue one tail {lappend delivered one; expr 1}
|
||||
testevent queue two tail {lappend delivered two; expr 1}
|
||||
testevent delete two
|
||||
testevent queue three tail {lappend delivered three; expr 1};
|
||||
vwait done
|
||||
set delivered
|
||||
} \
|
||||
-result {one three}
|
||||
|
||||
test notify-2.7 {remove a middle element} \
|
||||
-constraints {testevent} \
|
||||
-body {
|
||||
set delivered {}
|
||||
after 10 set done 1
|
||||
testevent queue one tail {lappend delivered one; expr 1}
|
||||
testevent queue two tail {lappend delivered two; expr 1}
|
||||
testevent queue three tail {lappend delivered three; expr 1}
|
||||
testevent delete two
|
||||
vwait done
|
||||
set delivered
|
||||
} \
|
||||
-result {one three}
|
||||
|
||||
test notify-2.8 {remove a marker event that's the sole event in the queue} \
|
||||
-constraints {testevent} \
|
||||
-body {
|
||||
set delivered {}
|
||||
after 10 set done 1
|
||||
testevent queue one mark {lappend delivered one; expr 1}
|
||||
testevent delete one
|
||||
vwait done
|
||||
set delivered
|
||||
} \
|
||||
-result {}
|
||||
|
||||
test notify-2.9 {remove and replace a marker event that's the sole event} \
|
||||
-constraints {testevent} \
|
||||
-body {
|
||||
set delivered {}
|
||||
after 10 set done 1
|
||||
testevent queue one mark {lappend delivered one; expr 1}
|
||||
testevent delete one
|
||||
testevent queue two mark {lappend delivered two; expr 1}
|
||||
vwait done
|
||||
set delivered
|
||||
} \
|
||||
-result two
|
||||
|
||||
test notify-2.10 {remove marker event from head} \
|
||||
-constraints {testevent} \
|
||||
-body {
|
||||
set delivered {}
|
||||
after 10 set done 1
|
||||
testevent queue one mark {lappend delivered one; expr 1}
|
||||
testevent queue two mark {lappend delivered two; expr 1}
|
||||
testevent delete one
|
||||
vwait done
|
||||
set delivered
|
||||
} \
|
||||
-result two
|
||||
|
||||
test notify-2.11 {remove and replace marker event at head} \
|
||||
-constraints {testevent} \
|
||||
-body {
|
||||
set delivered {}
|
||||
after 10 set done 1
|
||||
testevent queue one mark {lappend delivered one; expr 1}
|
||||
testevent queue two tail {lappend delivered two; expr 1}
|
||||
testevent delete one
|
||||
testevent queue three mark {lappend delivered three; expr 1}
|
||||
vwait done
|
||||
set delivered
|
||||
} \
|
||||
-result {three two}
|
||||
|
||||
test notify-2.12 {remove marker event at tail} \
|
||||
-constraints {testevent} \
|
||||
-body {
|
||||
set delivered {}
|
||||
after 10 set done 1
|
||||
testevent queue one mark {lappend delivered one; expr 1}
|
||||
testevent queue two mark {lappend delivered two; expr 1}
|
||||
testevent delete two
|
||||
vwait done
|
||||
set delivered
|
||||
} \
|
||||
-result {one}
|
||||
|
||||
test notify-2.13 {remove and replace marker event at tail} \
|
||||
-constraints {testevent} \
|
||||
-body {
|
||||
set delivered {}
|
||||
after 10 set done 1
|
||||
testevent queue one mark {lappend delivered one; expr 1}
|
||||
testevent queue two mark {lappend delivered two; expr 1}
|
||||
testevent delete two
|
||||
testevent queue three mark {lappend delivered three; expr 1}
|
||||
vwait done
|
||||
set delivered
|
||||
} \
|
||||
-result {one three}
|
||||
|
||||
test notify-2.14 {remove marker event from middle} \
|
||||
-constraints {testevent} \
|
||||
-body {
|
||||
set delivered {}
|
||||
after 10 set done 1
|
||||
testevent queue one mark {lappend delivered one; expr 1}
|
||||
testevent queue two mark {lappend delivered two; expr 1}
|
||||
testevent queue three mark {lappend delivered three; expr 1}
|
||||
testevent delete two
|
||||
vwait done
|
||||
set delivered
|
||||
} \
|
||||
-result {one three}
|
||||
|
||||
test notify-2.15 {remove and replace marker event at middle} \
|
||||
-constraints {testevent} \
|
||||
-body {
|
||||
set delivered {}
|
||||
after 10 set done 1
|
||||
testevent queue one mark {lappend delivered one; expr 1}
|
||||
testevent queue two mark {lappend delivered two; expr 1}
|
||||
testevent queue three tail {lappend delivered three; expr 1}
|
||||
testevent delete two
|
||||
testevent queue four mark {lappend delivered four; expr 1};
|
||||
vwait done
|
||||
set delivered
|
||||
} \
|
||||
-result {one four three}
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
632
tests/obj.test
Normal file
632
tests/obj.test
Normal file
@@ -0,0 +1,632 @@
|
||||
# Functionality covered: this file contains a collection of tests for the
|
||||
# procedures in tclObj.c that implement Tcl's basic type support and the
|
||||
# type managers for the types boolean, double, and integer.
|
||||
#
|
||||
# Sourcing this file into Tcl runs the tests and generates output for
|
||||
# errors. No output means no errors were found.
|
||||
#
|
||||
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
testConstraint testobj [llength [info commands testobj]]
|
||||
testConstraint longIs32bit [expr {int(0x80000000) < 0}]
|
||||
testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}]
|
||||
|
||||
test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} testobj {
|
||||
set r 1
|
||||
foreach {t} {
|
||||
{array search}
|
||||
bytearray
|
||||
bytecode
|
||||
cmdName
|
||||
dict
|
||||
end-offset
|
||||
regexp
|
||||
string
|
||||
} {
|
||||
set first [string first $t [testobj types]]
|
||||
set r [expr {$r && ($first != -1)}]
|
||||
}
|
||||
set result $r
|
||||
} {1}
|
||||
|
||||
test obj-2.1 {Tcl_GetObjType error} testobj {
|
||||
list [testintobj set 1 0] [catch {testobj convert 1 foo} msg] $msg
|
||||
} {0 1 {no type foo found}}
|
||||
test obj-2.2 {Tcl_GetObjType and Tcl_ConvertToType} testobj {
|
||||
set result ""
|
||||
lappend result [testobj freeallvars]
|
||||
lappend result [testintobj set 1 12]
|
||||
lappend result [testobj convert 1 bytearray]
|
||||
lappend result [testobj type 1]
|
||||
lappend result [testobj refcount 1]
|
||||
} {{} 12 12 bytearray 3}
|
||||
|
||||
test obj-3.1 {Tcl_ConvertToType error} testobj {
|
||||
list [testdoubleobj set 1 12.34] \
|
||||
[catch {testobj convert 1 end-offset} msg] \
|
||||
$msg
|
||||
} {12.34 1 {bad index "12.34": must be end?[+-]integer?}}
|
||||
test obj-3.2 {Tcl_ConvertToType error, "empty string" object} testobj {
|
||||
list [testobj newobj 1] [catch {testobj convert 1 end-offset} msg] $msg
|
||||
} {{} 1 {bad index "": must be end?[+-]integer?}}
|
||||
|
||||
test obj-4.1 {Tcl_NewObj and AllocateFreeObjects} testobj {
|
||||
set result ""
|
||||
lappend result [testobj freeallvars]
|
||||
lappend result [testobj newobj 1]
|
||||
lappend result [testobj type 1]
|
||||
lappend result [testobj refcount 1]
|
||||
} {{} {} string 2}
|
||||
|
||||
test obj-5.1 {Tcl_FreeObj} testobj {
|
||||
set result ""
|
||||
lappend result [testintobj set 1 12345]
|
||||
lappend result [testobj freeallvars]
|
||||
lappend result [catch {testintobj get 1} msg]
|
||||
lappend result $msg
|
||||
} {12345 {} 1 {variable 1 is unset (NULL)}}
|
||||
|
||||
test obj-6.1 {Tcl_DuplicateObj, object has internal rep} testobj {
|
||||
set result ""
|
||||
lappend result [testobj freeallvars]
|
||||
lappend result [testintobj set 1 47]
|
||||
lappend result [testobj duplicate 1 2]
|
||||
lappend result [testintobj get 2]
|
||||
lappend result [testobj refcount 1]
|
||||
lappend result [testobj refcount 2]
|
||||
} {{} 47 47 47 2 3}
|
||||
test obj-6.2 {Tcl_DuplicateObj, "empty string" object} testobj {
|
||||
set result ""
|
||||
lappend result [testobj freeallvars]
|
||||
lappend result [testobj newobj 1]
|
||||
lappend result [testobj duplicate 1 2]
|
||||
lappend result [testintobj get 2]
|
||||
lappend result [testobj refcount 1]
|
||||
lappend result [testobj refcount 2]
|
||||
} {{} {} {} {} 2 3}
|
||||
|
||||
# We assume that testobj is an indicator for test*obj as well
|
||||
|
||||
test obj-7.1 {Tcl_GetString, return existing string rep} testobj {
|
||||
set result ""
|
||||
lappend result [testintobj set 1 47]
|
||||
lappend result [testintobj get2 1]
|
||||
} {47 47}
|
||||
test obj-7.2 {Tcl_GetString, "empty string" object} testobj {
|
||||
set result ""
|
||||
lappend result [testobj newobj 1]
|
||||
lappend result [teststringobj append 1 abc -1]
|
||||
lappend result [teststringobj get2 1]
|
||||
} {{} abc abc}
|
||||
test obj-7.3 {Tcl_GetString, returns string internal rep (DString)} testobj {
|
||||
set result ""
|
||||
lappend result [teststringobj set 1 xyz]
|
||||
lappend result [teststringobj append 1 abc -1]
|
||||
lappend result [teststringobj get2 1]
|
||||
} {xyz xyzabc xyzabc}
|
||||
test obj-7.4 {Tcl_GetString, recompute string rep from internal rep} testobj {
|
||||
set result ""
|
||||
lappend result [testintobj set 1 77]
|
||||
lappend result [testintobj mult10 1]
|
||||
lappend result [teststringobj get2 1]
|
||||
} {77 770 770}
|
||||
|
||||
test obj-8.1 {Tcl_GetStringFromObj, return existing string rep} testobj {
|
||||
set result ""
|
||||
lappend result [testintobj set 1 47]
|
||||
lappend result [testintobj get 1]
|
||||
} {47 47}
|
||||
test obj-8.2 {Tcl_GetStringFromObj, "empty string" object} testobj {
|
||||
set result ""
|
||||
lappend result [testobj newobj 1]
|
||||
lappend result [teststringobj append 1 abc -1]
|
||||
lappend result [teststringobj get 1]
|
||||
} {{} abc abc}
|
||||
test obj-8.3 {Tcl_GetStringFromObj, returns string internal rep (DString)} testobj {
|
||||
set result ""
|
||||
lappend result [teststringobj set 1 xyz]
|
||||
lappend result [teststringobj append 1 abc -1]
|
||||
lappend result [teststringobj get 1]
|
||||
} {xyz xyzabc xyzabc}
|
||||
test obj-8.4 {Tcl_GetStringFromObj, recompute string rep from internal rep} testobj {
|
||||
set result ""
|
||||
lappend result [testintobj set 1 77]
|
||||
lappend result [testintobj mult10 1]
|
||||
lappend result [teststringobj get 1]
|
||||
} {77 770 770}
|
||||
|
||||
test obj-9.1 {Tcl_NewBooleanObj} testobj {
|
||||
set result ""
|
||||
lappend result [testobj freeallvars]
|
||||
lappend result [testbooleanobj set 1 0]
|
||||
lappend result [testobj type 1]
|
||||
lappend result [testobj refcount 1]
|
||||
} {{} 0 int 2}
|
||||
|
||||
test obj-10.1 {Tcl_SetBooleanObj, existing "empty string" object} testobj {
|
||||
set result ""
|
||||
lappend result [testobj freeallvars]
|
||||
lappend result [testobj newobj 1]
|
||||
lappend result [testbooleanobj set 1 0] ;# makes existing obj boolean
|
||||
lappend result [testobj type 1]
|
||||
lappend result [testobj refcount 1]
|
||||
} {{} {} 0 int 2}
|
||||
test obj-10.2 {Tcl_SetBooleanObj, existing non-"empty string" object} testobj {
|
||||
set result ""
|
||||
lappend result [testobj freeallvars]
|
||||
lappend result [testintobj set 1 98765]
|
||||
lappend result [testbooleanobj set 1 1] ;# makes existing obj boolean
|
||||
lappend result [testobj type 1]
|
||||
lappend result [testobj refcount 1]
|
||||
} {{} 98765 1 int 2}
|
||||
|
||||
test obj-11.1 {Tcl_GetBooleanFromObj, existing boolean object} testobj {
|
||||
set result ""
|
||||
lappend result [testbooleanobj set 1 1]
|
||||
lappend result [testbooleanobj not 1] ;# gets existing boolean rep
|
||||
} {1 0}
|
||||
test obj-11.2 {Tcl_GetBooleanFromObj, convert to boolean} testobj {
|
||||
set result ""
|
||||
lappend result [testintobj set 1 47]
|
||||
lappend result [testbooleanobj not 1] ;# must convert to bool
|
||||
lappend result [testobj type 1]
|
||||
} {47 0 int}
|
||||
test obj-11.3 {Tcl_GetBooleanFromObj, error converting to boolean} testobj {
|
||||
set result ""
|
||||
lappend result [teststringobj set 1 abc]
|
||||
lappend result [catch {testbooleanobj not 1} msg]
|
||||
lappend result $msg
|
||||
} {abc 1 {expected boolean value but got "abc"}}
|
||||
test obj-11.4 {Tcl_GetBooleanFromObj, error converting from "empty string"} testobj {
|
||||
set result ""
|
||||
lappend result [testobj newobj 1]
|
||||
lappend result [catch {testbooleanobj not 1} msg]
|
||||
lappend result $msg
|
||||
} {{} 1 {expected boolean value but got ""}}
|
||||
test obj-11.5 {Tcl_GetBooleanFromObj, convert hex to boolean} testobj {
|
||||
set result ""
|
||||
lappend result [teststringobj set 1 0xac]
|
||||
lappend result [testbooleanobj not 1]
|
||||
lappend result [testobj type 1]
|
||||
} {0xac 0 int}
|
||||
test obj-11.6 {Tcl_GetBooleanFromObj, convert float to boolean} testobj {
|
||||
set result ""
|
||||
lappend result [teststringobj set 1 5.42]
|
||||
lappend result [testbooleanobj not 1]
|
||||
lappend result [testobj type 1]
|
||||
} {5.42 0 int}
|
||||
|
||||
test obj-12.1 {DupBooleanInternalRep} testobj {
|
||||
set result ""
|
||||
lappend result [testbooleanobj set 1 1]
|
||||
lappend result [testobj duplicate 1 2] ;# uses DupBooleanInternalRep
|
||||
lappend result [testbooleanobj get 2]
|
||||
} {1 1 1}
|
||||
|
||||
test obj-13.1 {SetBooleanFromAny, int to boolean special case} testobj {
|
||||
set result ""
|
||||
lappend result [testintobj set 1 1234]
|
||||
lappend result [testbooleanobj not 1] ;# converts with SetBooleanFromAny
|
||||
lappend result [testobj type 1]
|
||||
} {1234 0 int}
|
||||
test obj-13.2 {SetBooleanFromAny, double to boolean special case} testobj {
|
||||
set result ""
|
||||
lappend result [testdoubleobj set 1 3.14159]
|
||||
lappend result [testbooleanobj not 1] ;# converts with SetBooleanFromAny
|
||||
lappend result [testobj type 1]
|
||||
} {3.14159 0 int}
|
||||
test obj-13.3 {SetBooleanFromAny, special case strings representing booleans} testobj {
|
||||
set result ""
|
||||
foreach s {yes no true false on off} {
|
||||
teststringobj set 1 $s
|
||||
lappend result [testbooleanobj not 1]
|
||||
}
|
||||
lappend result [testobj type 1]
|
||||
} {0 1 0 1 0 1 int}
|
||||
test obj-13.4 {SetBooleanFromAny, recompute string rep then parse it} testobj {
|
||||
set result ""
|
||||
lappend result [testintobj set 1 456]
|
||||
lappend result [testintobj div10 1]
|
||||
lappend result [testbooleanobj not 1] ;# converts with SetBooleanFromAny
|
||||
lappend result [testobj type 1]
|
||||
} {456 45 0 int}
|
||||
test obj-13.5 {SetBooleanFromAny, error parsing string} testobj {
|
||||
set result ""
|
||||
lappend result [teststringobj set 1 abc]
|
||||
lappend result [catch {testbooleanobj not 1} msg]
|
||||
lappend result $msg
|
||||
} {abc 1 {expected boolean value but got "abc"}}
|
||||
test obj-13.6 {SetBooleanFromAny, error parsing string} testobj {
|
||||
set result ""
|
||||
lappend result [teststringobj set 1 x1.0]
|
||||
lappend result [catch {testbooleanobj not 1} msg]
|
||||
lappend result $msg
|
||||
} {x1.0 1 {expected boolean value but got "x1.0"}}
|
||||
test obj-13.7 {SetBooleanFromAny, error converting from "empty string"} testobj {
|
||||
set result ""
|
||||
lappend result [testobj newobj 1]
|
||||
lappend result [catch {testbooleanobj not 1} msg]
|
||||
lappend result $msg
|
||||
} {{} 1 {expected boolean value but got ""}}
|
||||
test obj-13.8 {SetBooleanFromAny, unicode strings} testobj {
|
||||
set result ""
|
||||
lappend result [teststringobj set 1 1\u7777]
|
||||
lappend result [catch {testbooleanobj not 1} msg]
|
||||
lappend result $msg
|
||||
} "1\u7777 1 {expected boolean value but got \"1\u7777\"}"
|
||||
|
||||
test obj-14.1 {UpdateStringOfBoolean} testobj {
|
||||
set result ""
|
||||
lappend result [testbooleanobj set 1 0]
|
||||
lappend result [testbooleanobj not 1]
|
||||
lappend result [testbooleanobj get 1] ;# must update string rep
|
||||
} {0 1 1}
|
||||
|
||||
test obj-15.1 {Tcl_NewDoubleObj} testobj {
|
||||
set result ""
|
||||
lappend result [testobj freeallvars]
|
||||
lappend result [testdoubleobj set 1 3.1459]
|
||||
lappend result [testobj type 1]
|
||||
lappend result [testobj refcount 1]
|
||||
} {{} 3.1459 double 2}
|
||||
|
||||
test obj-16.1 {Tcl_SetDoubleObj, existing "empty string" object} testobj {
|
||||
set result ""
|
||||
lappend result [testobj freeallvars]
|
||||
lappend result [testobj newobj 1]
|
||||
lappend result [testdoubleobj set 1 0.123] ;# makes existing obj boolean
|
||||
lappend result [testobj type 1]
|
||||
lappend result [testobj refcount 1]
|
||||
} {{} {} 0.123 double 2}
|
||||
test obj-16.2 {Tcl_SetDoubleObj, existing non-"empty string" object} testobj {
|
||||
set result ""
|
||||
lappend result [testobj freeallvars]
|
||||
lappend result [testintobj set 1 98765]
|
||||
lappend result [testdoubleobj set 1 27.56] ;# makes existing obj double
|
||||
lappend result [testobj type 1]
|
||||
lappend result [testobj refcount 1]
|
||||
} {{} 98765 27.56 double 2}
|
||||
|
||||
test obj-17.1 {Tcl_GetDoubleFromObj, existing double object} testobj {
|
||||
set result ""
|
||||
lappend result [testdoubleobj set 1 16.1]
|
||||
lappend result [testdoubleobj mult10 1] ;# gets existing double rep
|
||||
} {16.1 161.0}
|
||||
test obj-17.2 {Tcl_GetDoubleFromObj, convert to double} testobj {
|
||||
set result ""
|
||||
lappend result [testintobj set 1 477]
|
||||
lappend result [testdoubleobj div10 1] ;# must convert to bool
|
||||
lappend result [testobj type 1]
|
||||
} {477 47.7 double}
|
||||
test obj-17.3 {Tcl_GetDoubleFromObj, error converting to double} testobj {
|
||||
set result ""
|
||||
lappend result [teststringobj set 1 abc]
|
||||
lappend result [catch {testdoubleobj mult10 1} msg]
|
||||
lappend result $msg
|
||||
} {abc 1 {expected floating-point number but got "abc"}}
|
||||
test obj-17.4 {Tcl_GetDoubleFromObj, error converting from "empty string"} testobj {
|
||||
set result ""
|
||||
lappend result [testobj newobj 1]
|
||||
lappend result [catch {testdoubleobj div10 1} msg]
|
||||
lappend result $msg
|
||||
} {{} 1 {expected floating-point number but got ""}}
|
||||
|
||||
test obj-18.1 {DupDoubleInternalRep} testobj {
|
||||
set result ""
|
||||
lappend result [testdoubleobj set 1 17.1]
|
||||
lappend result [testobj duplicate 1 2] ;# uses DupDoubleInternalRep
|
||||
lappend result [testdoubleobj get 2]
|
||||
} {17.1 17.1 17.1}
|
||||
|
||||
test obj-19.1 {SetDoubleFromAny, int to double special case} testobj {
|
||||
set result ""
|
||||
lappend result [testintobj set 1 1234]
|
||||
lappend result [testdoubleobj mult10 1] ;# converts with SetDoubleFromAny
|
||||
lappend result [testobj type 1]
|
||||
} {1234 12340.0 double}
|
||||
test obj-19.2 {SetDoubleFromAny, boolean to double special case} testobj {
|
||||
set result ""
|
||||
lappend result [testbooleanobj set 1 1]
|
||||
lappend result [testdoubleobj mult10 1] ;# converts with SetDoubleFromAny
|
||||
lappend result [testobj type 1]
|
||||
} {1 10.0 double}
|
||||
test obj-19.3 {SetDoubleFromAny, recompute string rep then parse it} testobj {
|
||||
set result ""
|
||||
lappend result [testintobj set 1 456]
|
||||
lappend result [testintobj div10 1]
|
||||
lappend result [testdoubleobj mult10 1] ;# converts with SetDoubleFromAny
|
||||
lappend result [testobj type 1]
|
||||
} {456 45 450.0 double}
|
||||
test obj-19.4 {SetDoubleFromAny, error parsing string} testobj {
|
||||
set result ""
|
||||
lappend result [teststringobj set 1 abc]
|
||||
lappend result [catch {testdoubleobj mult10 1} msg]
|
||||
lappend result $msg
|
||||
} {abc 1 {expected floating-point number but got "abc"}}
|
||||
test obj-19.5 {SetDoubleFromAny, error parsing string} testobj {
|
||||
set result ""
|
||||
lappend result [teststringobj set 1 x1.0]
|
||||
lappend result [catch {testdoubleobj mult10 1} msg]
|
||||
lappend result $msg
|
||||
} {x1.0 1 {expected floating-point number but got "x1.0"}}
|
||||
test obj-19.6 {SetDoubleFromAny, error converting from "empty string"} testobj {
|
||||
set result ""
|
||||
lappend result [testobj newobj 1]
|
||||
lappend result [catch {testdoubleobj div10 1} msg]
|
||||
lappend result $msg
|
||||
} {{} 1 {expected floating-point number but got ""}}
|
||||
|
||||
test obj-20.1 {UpdateStringOfDouble} testobj {
|
||||
set result ""
|
||||
lappend result [testdoubleobj set 1 3.14159]
|
||||
lappend result [testdoubleobj mult10 1]
|
||||
lappend result [testdoubleobj get 1] ;# must update string rep
|
||||
} {3.14159 31.4159 31.4159}
|
||||
|
||||
test obj-21.1 {Tcl_NewIntObj} testobj {
|
||||
set result ""
|
||||
lappend result [testobj freeallvars]
|
||||
lappend result [testintobj set 1 55]
|
||||
lappend result [testobj type 1]
|
||||
lappend result [testobj refcount 1]
|
||||
} {{} 55 int 2}
|
||||
|
||||
test obj-22.1 {Tcl_SetIntObj, existing "empty string" object} testobj {
|
||||
set result ""
|
||||
lappend result [testobj freeallvars]
|
||||
lappend result [testobj newobj 1]
|
||||
lappend result [testintobj set 1 77] ;# makes existing obj int
|
||||
lappend result [testobj type 1]
|
||||
lappend result [testobj refcount 1]
|
||||
} {{} {} 77 int 2}
|
||||
test obj-22.2 {Tcl_SetIntObj, existing non-"empty string" object} testobj {
|
||||
set result ""
|
||||
lappend result [testobj freeallvars]
|
||||
lappend result [testdoubleobj set 1 12.34]
|
||||
lappend result [testintobj set 1 77] ;# makes existing obj int
|
||||
lappend result [testobj type 1]
|
||||
lappend result [testobj refcount 1]
|
||||
} {{} 12.34 77 int 2}
|
||||
|
||||
test obj-23.1 {Tcl_GetIntFromObj, existing int object} testobj {
|
||||
set result ""
|
||||
lappend result [testintobj set 1 22]
|
||||
lappend result [testintobj mult10 1] ;# gets existing int rep
|
||||
} {22 220}
|
||||
test obj-23.2 {Tcl_GetIntFromObj, convert to int} testobj {
|
||||
set result ""
|
||||
lappend result [testintobj set 1 477]
|
||||
lappend result [testintobj div10 1] ;# must convert to bool
|
||||
lappend result [testobj type 1]
|
||||
} {477 47 int}
|
||||
test obj-23.3 {Tcl_GetIntFromObj, error converting to int} testobj {
|
||||
set result ""
|
||||
lappend result [teststringobj set 1 abc]
|
||||
lappend result [catch {testintobj mult10 1} msg]
|
||||
lappend result $msg
|
||||
} {abc 1 {expected integer but got "abc"}}
|
||||
test obj-23.4 {Tcl_GetIntFromObj, error converting from "empty string"} testobj {
|
||||
set result ""
|
||||
lappend result [testobj newobj 1]
|
||||
lappend result [catch {testintobj div10 1} msg]
|
||||
lappend result $msg
|
||||
} {{} 1 {expected integer but got ""}}
|
||||
test obj-23.5 {Tcl_GetIntFromObj, integer too large to represent as non-long error} {testobj} {
|
||||
set result ""
|
||||
lappend result [testobj newobj 1]
|
||||
lappend result [testintobj inttoobigtest 1]
|
||||
} {{} 1}
|
||||
|
||||
test obj-24.1 {DupIntInternalRep} testobj {
|
||||
set result ""
|
||||
lappend result [testintobj set 1 23]
|
||||
lappend result [testobj duplicate 1 2] ;# uses DupIntInternalRep
|
||||
lappend result [testintobj get 2]
|
||||
} {23 23 23}
|
||||
|
||||
test obj-25.1 {SetIntFromAny, int to int special case} testobj {
|
||||
set result ""
|
||||
lappend result [testintobj set 1 1234]
|
||||
lappend result [testintobj mult10 1] ;# converts with SetIntFromAny
|
||||
lappend result [testobj type 1]
|
||||
} {1234 12340 int}
|
||||
test obj-25.2 {SetIntFromAny, boolean to int special case} testobj {
|
||||
set result ""
|
||||
lappend result [testbooleanobj set 1 1]
|
||||
lappend result [testintobj mult10 1] ;# converts with SetIntFromAny
|
||||
lappend result [testobj type 1]
|
||||
} {1 10 int}
|
||||
test obj-25.3 {SetIntFromAny, recompute string rep then parse it} testobj {
|
||||
set result ""
|
||||
lappend result [testintobj set 1 456]
|
||||
lappend result [testintobj div10 1]
|
||||
lappend result [testintobj mult10 1] ;# converts with SetIntFromAny
|
||||
lappend result [testobj type 1]
|
||||
} {456 45 450 int}
|
||||
test obj-25.4 {SetIntFromAny, error parsing string} testobj {
|
||||
set result ""
|
||||
lappend result [teststringobj set 1 abc]
|
||||
lappend result [catch {testintobj mult10 1} msg]
|
||||
lappend result $msg
|
||||
} {abc 1 {expected integer but got "abc"}}
|
||||
test obj-25.5 {SetIntFromAny, error parsing string} testobj {
|
||||
set result ""
|
||||
lappend result [teststringobj set 1 x17]
|
||||
lappend result [catch {testintobj mult10 1} msg]
|
||||
lappend result $msg
|
||||
} {x17 1 {expected integer but got "x17"}}
|
||||
test obj-25.6 {SetIntFromAny, integer too large} {testobj} {
|
||||
set result ""
|
||||
lappend result [teststringobj set 1 123456789012345678901]
|
||||
lappend result [catch {testintobj mult10 1} msg]
|
||||
lappend result $msg
|
||||
} {123456789012345678901 1 {integer value too large to represent}}
|
||||
test obj-25.7 {SetIntFromAny, error converting from "empty string"} testobj {
|
||||
set result ""
|
||||
lappend result [testobj newobj 1]
|
||||
lappend result [catch {testintobj div10 1} msg]
|
||||
lappend result $msg
|
||||
} {{} 1 {expected integer but got ""}}
|
||||
|
||||
test obj-26.1 {UpdateStringOfInt} testobj {
|
||||
set result ""
|
||||
lappend result [testintobj set 1 512]
|
||||
lappend result [testintobj mult10 1]
|
||||
lappend result [testintobj get 1] ;# must update string rep
|
||||
} {512 5120 5120}
|
||||
|
||||
test obj-27.1 {Tcl_NewLongObj} testobj {
|
||||
set result ""
|
||||
lappend result [testobj freeallvars]
|
||||
testintobj setmaxlong 1
|
||||
lappend result [testintobj ismaxlong 1]
|
||||
lappend result [testobj type 1]
|
||||
lappend result [testobj refcount 1]
|
||||
} {{} 1 int 1}
|
||||
|
||||
test obj-28.1 {Tcl_SetLongObj, existing "empty string" object} testobj {
|
||||
set result ""
|
||||
lappend result [testobj freeallvars]
|
||||
lappend result [testobj newobj 1]
|
||||
lappend result [testintobj setlong 1 77] ;# makes existing obj long int
|
||||
lappend result [testobj type 1]
|
||||
lappend result [testobj refcount 1]
|
||||
} {{} {} 77 int 2}
|
||||
test obj-28.2 {Tcl_SetLongObj, existing non-"empty string" object} testobj {
|
||||
set result ""
|
||||
lappend result [testobj freeallvars]
|
||||
lappend result [testdoubleobj set 1 12.34]
|
||||
lappend result [testintobj setlong 1 77] ;# makes existing obj long int
|
||||
lappend result [testobj type 1]
|
||||
lappend result [testobj refcount 1]
|
||||
} {{} 12.34 77 int 2}
|
||||
|
||||
test obj-29.1 {Tcl_GetLongFromObj, existing long integer object} testobj {
|
||||
set result ""
|
||||
lappend result [testintobj setlong 1 22]
|
||||
lappend result [testintobj mult10 1] ;# gets existing long int rep
|
||||
} {22 220}
|
||||
test obj-29.2 {Tcl_GetLongFromObj, convert to long} testobj {
|
||||
set result ""
|
||||
lappend result [testintobj setlong 1 477]
|
||||
lappend result [testintobj div10 1] ;# must convert to bool
|
||||
lappend result [testobj type 1]
|
||||
} {477 47 int}
|
||||
test obj-29.3 {Tcl_GetLongFromObj, error converting to long integer} testobj {
|
||||
set result ""
|
||||
lappend result [teststringobj set 1 abc]
|
||||
lappend result [catch {testintobj ismaxlong 1} msg] ;# cvts to long int
|
||||
lappend result $msg
|
||||
} {abc 1 {expected integer but got "abc"}}
|
||||
test obj-29.4 {Tcl_GetLongFromObj, error converting from "empty string"} testobj {
|
||||
set result ""
|
||||
lappend result [testobj newobj 1]
|
||||
lappend result [catch {testintobj ismaxlong 1} msg] ;# cvts to long int
|
||||
lappend result $msg
|
||||
} {{} 1 {expected integer but got ""}}
|
||||
|
||||
test obj-30.1 {Ref counting and object deletion, simple types} testobj {
|
||||
set result ""
|
||||
lappend result [testobj freeallvars]
|
||||
lappend result [testintobj set 1 1024]
|
||||
lappend result [testobj assign 1 2] ;# vars 1 and 2 share the int obj
|
||||
lappend result [testobj type 2]
|
||||
lappend result [testobj refcount 1]
|
||||
lappend result [testobj refcount 2]
|
||||
lappend result [testbooleanobj set 2 0] ;# must copy on write, now 2 objs
|
||||
lappend result [testobj type 2]
|
||||
lappend result [testobj refcount 1]
|
||||
lappend result [testobj refcount 2]
|
||||
} {{} 1024 1024 int 4 4 0 int 3 2}
|
||||
|
||||
|
||||
test obj-31.1 {regenerate string rep of "end"} testobj {
|
||||
testobj freeallvars
|
||||
teststringobj set 1 end
|
||||
testobj convert 1 end-offset
|
||||
testobj invalidateStringRep 1
|
||||
} end
|
||||
test obj-31.2 {regenerate string rep of "end-1"} testobj {
|
||||
testobj freeallvars
|
||||
teststringobj set 1 end-0x1
|
||||
testobj convert 1 end-offset
|
||||
testobj invalidateStringRep 1
|
||||
} end-1
|
||||
test obj-31.3 {regenerate string rep of "end--1"} testobj {
|
||||
testobj freeallvars
|
||||
teststringobj set 1 end--0x1
|
||||
testobj convert 1 end-offset
|
||||
testobj invalidateStringRep 1
|
||||
} end--1
|
||||
test obj-31.4 {regenerate string rep of "end-bigInteger"} testobj {
|
||||
testobj freeallvars
|
||||
teststringobj set 1 end-0x7fffffff
|
||||
testobj convert 1 end-offset
|
||||
testobj invalidateStringRep 1
|
||||
} end-2147483647
|
||||
test obj-31.5 {regenerate string rep of "end--bigInteger"} testobj {
|
||||
testobj freeallvars
|
||||
teststringobj set 1 end--0x7fffffff
|
||||
testobj convert 1 end-offset
|
||||
testobj invalidateStringRep 1
|
||||
} end--2147483647
|
||||
test obj-31.6 {regenerate string rep of "end--bigInteger"} {testobj longIs32bit} {
|
||||
testobj freeallvars
|
||||
teststringobj set 1 end--0x80000000
|
||||
testobj convert 1 end-offset
|
||||
testobj invalidateStringRep 1
|
||||
} end--2147483648
|
||||
|
||||
test obj-32.1 {freeing very large object trees} {
|
||||
set x {}
|
||||
for {set i 0} {$i<100000} {incr i} {
|
||||
set x [list $x {}]
|
||||
}
|
||||
unset x
|
||||
} {}
|
||||
|
||||
test obj-33.1 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
|
||||
set x 0x8000; append x 0000
|
||||
list [string is integer $x] [expr { wide($x) }]
|
||||
} {1 2147483648}
|
||||
test obj-33.2 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
|
||||
set x 0xffff; append x ffff
|
||||
list [string is integer $x] [expr { wide($x) }]
|
||||
} {1 4294967295}
|
||||
test obj-33.3 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
|
||||
set x 0x10000; append x 0000
|
||||
list [string is integer $x] [expr { wide($x) }]
|
||||
} {0 4294967296}
|
||||
test obj-33.4 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
|
||||
set x -0x8000; append x 0000
|
||||
list [string is integer $x] [expr { wide($x) }]
|
||||
} {1 -2147483648}
|
||||
test obj-33.5 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
|
||||
set x -0x8000; append x 0001
|
||||
list [string is integer $x] [expr { wide($x) }]
|
||||
} {1 -2147483649}
|
||||
test obj-33.6 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
|
||||
set x -0xffff; append x ffff
|
||||
list [string is integer $x] [expr { wide($x) }]
|
||||
} {1 -4294967295}
|
||||
test obj-33.7 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
|
||||
set x -0x10000; append x 0000
|
||||
list [string is integer $x] [expr { wide($x) }]
|
||||
} {0 -4294967296}
|
||||
|
||||
if {[testConstraint testobj]} {
|
||||
testobj freeallvars
|
||||
}
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
245
tests/opt.test
Normal file
245
tests/opt.test
Normal file
@@ -0,0 +1,245 @@
|
||||
# Package covered: opt1.0/optparse.tcl
|
||||
#
|
||||
# This file contains a collection of tests for one or more of the Tcl
|
||||
# built-in commands. Sourcing this file into Tcl runs the tests and
|
||||
# generates output for errors. No output means no errors were found.
|
||||
#
|
||||
# Copyright (c) 1991-1993 The Regents of the University of California.
|
||||
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
# the package we are going to test
|
||||
package require opt 0.4.1
|
||||
|
||||
# we are using implementation specifics to test the package
|
||||
|
||||
|
||||
#### functions tests #####
|
||||
|
||||
set n $::tcl::OptDescN
|
||||
|
||||
test opt-1.1 {OptKeyRegister / check that auto allocation is skipping existing keys} {
|
||||
list [::tcl::OptKeyRegister {} $n] [::tcl::OptKeyRegister {} [expr $n+1]] [::tcl::OptKeyRegister {}]
|
||||
} "$n [expr $n+1] [expr $n+2]"
|
||||
|
||||
test opt-2.1 {OptKeyDelete} {
|
||||
list [::tcl::OptKeyRegister {} testkey] \
|
||||
[info exists ::tcl::OptDesc(testkey)] \
|
||||
[::tcl::OptKeyDelete testkey] \
|
||||
[info exists ::tcl::OptDesc(testkey)]
|
||||
} {testkey 1 {} 0}
|
||||
|
||||
test opt-3.1 {OptParse / temp key is removed} {
|
||||
set n $::tcl::OptDescN
|
||||
set prev [array names ::tcl::OptDesc]
|
||||
::tcl::OptKeyRegister {} $n
|
||||
list [info exists ::tcl::OptDesc($n)]\
|
||||
[::tcl::OptKeyDelete $n]\
|
||||
[::tcl::OptParse {{-foo}} {}]\
|
||||
[info exists ::tcl::OptDesc($n)]\
|
||||
[expr {"[lsort $prev]"=="[lsort [array names ::tcl::OptDesc]]"}]
|
||||
} {1 {} {} 0 1}
|
||||
test opt-3.2 {OptParse / temp key is removed even on errors} {
|
||||
set n $::tcl::OptDescN
|
||||
catch {::tcl::OptKeyDelete $n}
|
||||
list [catch {::tcl::OptParse {{-foo}} {-blah}}] \
|
||||
[info exists ::tcl::OptDesc($n)]
|
||||
} {1 0}
|
||||
|
||||
test opt-4.1 {OptProc} {
|
||||
::tcl::OptProc optTest {} {}
|
||||
optTest ;
|
||||
::tcl::OptKeyDelete optTest
|
||||
} {}
|
||||
|
||||
test opt-5.1 {OptProcArgGiven} {
|
||||
::tcl::OptProc optTest {{-foo}} {
|
||||
if {[::tcl::OptProcArgGiven "-foo"]} {
|
||||
return 1
|
||||
} else {
|
||||
return 0
|
||||
}
|
||||
}
|
||||
list [optTest] [optTest -f] [optTest -F] [optTest -fOO]
|
||||
} {0 1 1 1}
|
||||
|
||||
test opt-6.1 {OptKeyParse} {
|
||||
::tcl::OptKeyRegister {} test;
|
||||
list [catch {::tcl::OptKeyParse test {-help}} msg] $msg
|
||||
} {1 {Usage information:
|
||||
Var/FlagName Type Value Help
|
||||
------------ ---- ----- ----
|
||||
( -help gives this help )}}
|
||||
|
||||
test opt-7.1 {OptCheckType} {
|
||||
list \
|
||||
[::tcl::OptCheckType 23 int] \
|
||||
[::tcl::OptCheckType 23 float] \
|
||||
[::tcl::OptCheckType true boolean] \
|
||||
[::tcl::OptCheckType "-blah" any] \
|
||||
[::tcl::OptCheckType {a b c} list] \
|
||||
[::tcl::OptCheckType maYbe choice {yes maYbe no}] \
|
||||
[catch {::tcl::OptCheckType "-blah" string}] \
|
||||
[catch {::tcl::OptCheckType 6 boolean}] \
|
||||
[catch {::tcl::OptCheckType x float}] \
|
||||
[catch {::tcl::OptCheckType "a \{ c" list}] \
|
||||
[catch {::tcl::OptCheckType 2.3 int}] \
|
||||
[catch {::tcl::OptCheckType foo choice {x y Foo z}}]
|
||||
} {23 23.0 1 -blah {a b c} maYbe 1 1 1 1 1 1}
|
||||
|
||||
test opt-8.1 {List utilities} {
|
||||
::tcl::Lempty {}
|
||||
} 1
|
||||
test opt-8.2 {List utilities} {
|
||||
::tcl::Lempty {a b c}
|
||||
} 0
|
||||
test opt-8.3 {List utilities} {
|
||||
::tcl::Lget {a {b c d} e} {1 2}
|
||||
} d
|
||||
test opt-8.4 {List utilities} {
|
||||
set l {a {b c d e} f}
|
||||
::tcl::Lvarset l {1 2} D
|
||||
set l
|
||||
} {a {b c D e} f}
|
||||
test opt-8.5 {List utilities} {
|
||||
set l {a b c}
|
||||
::tcl::Lvarset1 l 6 X
|
||||
set l
|
||||
} {a b c {} {} {} X}
|
||||
test opt-8.6 {List utilities} {
|
||||
set l {a {b c 7 e} f}
|
||||
::tcl::Lvarincr l {1 2}
|
||||
set l
|
||||
} {a {b c 8 e} f}
|
||||
test opt-8.7 {List utilities} {
|
||||
set l {a {b c 7 e} f}
|
||||
::tcl::Lvarincr l {1 2} -9
|
||||
set l
|
||||
} {a {b c -2 e} f}
|
||||
# 8.8 and 8.9 missing?
|
||||
test opt-8.10 {List utilities} {
|
||||
set l {a {b c 7 e} f}
|
||||
::tcl::Lvarpop l
|
||||
set l
|
||||
} {{b c 7 e} f}
|
||||
test opt-8.11 {List utilities} {
|
||||
catch {unset x}
|
||||
set l {a {b c 7 e} f}
|
||||
list [::tcl::Lassign $l u v w x] \
|
||||
$u $v $w [info exists x]
|
||||
} {3 a {b c 7 e} f 0}
|
||||
|
||||
test opt-9.1 {Misc utilities} {
|
||||
catch {unset v}
|
||||
::tcl::SetMax v 3
|
||||
::tcl::SetMax v 7
|
||||
::tcl::SetMax v 6
|
||||
set v
|
||||
} 7
|
||||
test opt-9.2 {Misc utilities} {
|
||||
catch {unset v}
|
||||
::tcl::SetMin v 3
|
||||
::tcl::SetMin v -7
|
||||
::tcl::SetMin v 1
|
||||
set v
|
||||
} -7
|
||||
|
||||
#### behaviour tests #####
|
||||
|
||||
test opt-10.1 {ambigous flags} {
|
||||
::tcl::OptProc optTest {{-fla} {-other} {-flag2xyz} {-flag3xyz}} {}
|
||||
catch {optTest -fL} msg
|
||||
set msg
|
||||
} {ambigous option "-fL", choose from:
|
||||
-fla boolflag (false)
|
||||
-flag2xyz boolflag (false)
|
||||
-flag3xyz boolflag (false) }
|
||||
test opt-10.2 {non ambigous flags} {
|
||||
::tcl::OptProc optTest {{-flag1xyz} {-other} {-flag2xyz} {-flag3xyz}} {
|
||||
return $flag2xyz
|
||||
}
|
||||
optTest -fLaG2
|
||||
} 1
|
||||
test opt-10.3 {non ambigous flags because of exact match} {
|
||||
::tcl::OptProc optTest {{-flag1x} {-other} {-flag1} {-flag1xy}} {
|
||||
return $flag1
|
||||
}
|
||||
optTest -flAg1
|
||||
} 1
|
||||
test opt-10.4 {ambigous flags, not exact match} {
|
||||
::tcl::OptProc optTest {{-flag1xy} {-other} {-flag1} {-flag1xyz}} {
|
||||
return $flag1
|
||||
}
|
||||
catch {optTest -fLag1X} msg
|
||||
set msg
|
||||
} {ambigous option "-fLag1X", choose from:
|
||||
-flag1xy boolflag (false)
|
||||
-flag1xyz boolflag (false) }
|
||||
|
||||
# medium size overall test example: (defined once)
|
||||
::tcl::OptProc optTest {
|
||||
{cmd -choice {print save delete} "sub command to choose"}
|
||||
{-allowBoing -boolean true}
|
||||
{arg2 -string "this is help"}
|
||||
{?arg3? 7 "optional number"}
|
||||
{-moreflags}
|
||||
} {
|
||||
list $cmd $allowBoing $arg2 $arg3 $moreflags
|
||||
}
|
||||
|
||||
test opt-10.5 {medium size overall test} {
|
||||
list [catch {optTest} msg] $msg
|
||||
} {1 {no value given for parameter "cmd" (use -help for full usage) :
|
||||
cmd choice (print save delete) sub command to choose}}
|
||||
test opt-10.6 {medium size overall test} {
|
||||
list [catch {optTest -help} msg] $msg
|
||||
} {1 {Usage information:
|
||||
Var/FlagName Type Value Help
|
||||
------------ ---- ----- ----
|
||||
( -help gives this help )
|
||||
cmd choice (print save delete) sub command to choose
|
||||
-allowBoing boolean (true)
|
||||
arg2 string () this is help
|
||||
?arg3? int (7) optional number
|
||||
-moreflags boolflag (false) }}
|
||||
test opt-10.7 {medium size overall test} {
|
||||
optTest save tst
|
||||
} {save 1 tst 7 0}
|
||||
test opt-10.8 {medium size overall test} {
|
||||
optTest save -allowBoing false -- 8
|
||||
} {save 0 8 7 0}
|
||||
test opt-10.9 {medium size overall test} {
|
||||
optTest save tst -m --
|
||||
} {save 1 tst 7 1}
|
||||
test opt-10.10 {medium size overall test} {
|
||||
list [catch {optTest save tst foo} msg] [lindex [split $msg "\n"] 0]
|
||||
} {1 {too many arguments (unexpected argument(s): foo), usage:}}
|
||||
|
||||
test opt-11.1 {too many args test 2} {
|
||||
set key [::tcl::OptKeyRegister {-foo}]
|
||||
list [catch {::tcl::OptKeyParse $key {-foo blah}} msg] $msg\
|
||||
[::tcl::OptKeyDelete $key]
|
||||
} {1 {too many arguments (unexpected argument(s): blah), usage:
|
||||
Var/FlagName Type Value Help
|
||||
------------ ---- ----- ----
|
||||
( -help gives this help )
|
||||
-foo boolflag (false) } {}}
|
||||
test opt-11.2 {default value for args} {
|
||||
set args {}
|
||||
set key [::tcl::OptKeyRegister {{args -list {a b c} "args..."}}]
|
||||
::tcl::OptKeyParse $key {}
|
||||
::tcl::OptKeyDelete $key
|
||||
set args
|
||||
} {a b c}
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
69
tests/package.test
Normal file
69
tests/package.test
Normal file
@@ -0,0 +1,69 @@
|
||||
# This file contains tests for the ::package::* commands.
|
||||
# Note that the tests are limited to Tcl scripts only, there are no shared
|
||||
# libraries against which to test.
|
||||
#
|
||||
# Sourcing this file into Tcl runs the tests and generates output for
|
||||
# errors. No output means no errors were found.
|
||||
#
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
# All rights reserved.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
test package-1.1 {pkg::create gives error on insufficient args} {
|
||||
catch {::pkg::create}
|
||||
} 1
|
||||
test package-1.2 {pkg::create gives error on bad args} {
|
||||
catch {::pkg::create -foo bar -bar baz -baz boo}
|
||||
} 1
|
||||
test package-1.3 {pkg::create gives error on no value given} {
|
||||
catch {::pkg::create -name foo -version 1.0 -source test.tcl -load}
|
||||
} 1
|
||||
test package-1.4 {pkg::create gives error on no name given} {
|
||||
catch {::pkg::create -version 1.0 -source test.tcl -load foo.so}
|
||||
} 1
|
||||
test package-1.5 {pkg::create gives error on no version given} {
|
||||
catch {::pkg::create -name foo -source test.tcl -load foo.so}
|
||||
} 1
|
||||
test package-1.6 {pkg::create gives error on no source or load options} {
|
||||
catch {::pkg::create -name foo -version 1.0 -version 2.0}
|
||||
} 1
|
||||
test package-1.7 {pkg::create gives correct output for 1 direct source} {
|
||||
::pkg::create -name foo -version 1.0 -source test.tcl
|
||||
} {package ifneeded foo 1.0 [list source [file join $dir test.tcl]]}
|
||||
test package-1.8 {pkg::create gives correct output for 2 direct sources} {
|
||||
::pkg::create -name foo -version 1.0 -source test.tcl -source test2.tcl
|
||||
} {package ifneeded foo 1.0 [list source [file join $dir test.tcl]]\n[list source [file join $dir test2.tcl]]}
|
||||
test package-1.9 {pkg::create gives correct output for 1 direct load} {
|
||||
::pkg::create -name foo -version 1.0 -load test.so
|
||||
} {package ifneeded foo 1.0 [list load [file join $dir test.so]]}
|
||||
test package-1.10 {pkg::create gives correct output for 2 direct loads} {
|
||||
::pkg::create -name foo -version 1.0 -load test.so -load test2.so
|
||||
} {package ifneeded foo 1.0 [list load [file join $dir test.so]]\n[list load [file join $dir test2.so]]}
|
||||
test package-1.11 {pkg::create gives correct output for 1 lazy source} {
|
||||
::pkg::create -name foo -version 1.0 -source {test.tcl {foo bar}}
|
||||
} {package ifneeded foo 1.0 [list tclPkgSetup $dir foo 1.0 {{test.tcl source {foo bar}}}]}
|
||||
test package-1.12 {pkg::create gives correct output for 2 lazy sources} {
|
||||
::pkg::create -name foo -version 1.0 -source {test.tcl {foo bar}} \
|
||||
-source {test2.tcl {baz boo}}
|
||||
} {package ifneeded foo 1.0 [list tclPkgSetup $dir foo 1.0 {{test.tcl source {foo bar}} {test2.tcl source {baz boo}}}]}
|
||||
test package-1.13 {pkg::create gives correct output for 1 lazy load} {
|
||||
::pkg::create -name foo -version 1.0 -load {test.so {foo bar}}
|
||||
} {package ifneeded foo 1.0 [list tclPkgSetup $dir foo 1.0 {{test.so load {foo bar}}}]}
|
||||
test package-1.14 {pkg::create gives correct output for 2 lazy loads} {
|
||||
::pkg::create -name foo -version 1.0 -load {test.so {foo bar}} \
|
||||
-load {test2.so {baz boo}}
|
||||
} {package ifneeded foo 1.0 [list tclPkgSetup $dir foo 1.0 {{test.so load {foo bar}} {test2.so load {baz boo}}}]}
|
||||
test package-1.15 {pkg::create gives correct output for 1 each, direct} {
|
||||
::pkg::create -name foo -version 1.0 -source test.tcl -load test2.so
|
||||
} {package ifneeded foo 1.0 [list load [file join $dir test2.so]]\n[list source [file join $dir test.tcl]]}
|
||||
test package-1.16 {pkg::create gives correct output for 1 direct, 1 lazy} {
|
||||
::pkg::create -name foo -version 1.0 -source test.tcl \
|
||||
-source {test2.tcl {foo bar}}
|
||||
} {package ifneeded foo 1.0 [list source [file join $dir test.tcl]]\n[list tclPkgSetup $dir foo 1.0 {{test2.tcl source {foo bar}}}]}
|
||||
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
1128
tests/parse.test
Normal file
1128
tests/parse.test
Normal file
File diff suppressed because it is too large
Load Diff
1057
tests/parseExpr.test
Normal file
1057
tests/parseExpr.test
Normal file
File diff suppressed because it is too large
Load Diff
541
tests/parseOld.test
Normal file
541
tests/parseOld.test
Normal file
@@ -0,0 +1,541 @@
|
||||
# Commands covered: set (plus basic command syntax). Also tests the
|
||||
# procedures in the file tclOldParse.c. This set of tests is an old
|
||||
# one that predates the new parser in Tcl 8.1.
|
||||
#
|
||||
# This file contains a collection of tests for one or more of the Tcl
|
||||
# built-in commands. Sourcing this file into Tcl runs the tests and
|
||||
# generates output for errors. No output means no errors were found.
|
||||
#
|
||||
# Copyright (c) 1991-1993 The Regents of the University of California.
|
||||
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
package require tcltest
|
||||
namespace import ::tcltest::*
|
||||
|
||||
testConstraint testwordend [llength [info commands testwordend]]
|
||||
|
||||
# Save the argv value for restoration later
|
||||
set savedArgv $argv
|
||||
|
||||
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 parseOld-1.1 {basic argument parsing} {
|
||||
set arg1 {}
|
||||
fourArgs a b c d
|
||||
list $arg1 $arg2 $arg3 $arg4
|
||||
} {a b c d}
|
||||
test parseOld-1.2 {basic argument parsing} {
|
||||
set arg1 {}
|
||||
eval "fourArgs 123\v4\f56\r7890"
|
||||
list $arg1 $arg2 $arg3 $arg4
|
||||
} {123 4 56 7890}
|
||||
|
||||
# Quotes.
|
||||
|
||||
test parseOld-2.1 {quotes and variable-substitution} {
|
||||
getArgs "a b c" d
|
||||
set argv
|
||||
} {{a b c} d}
|
||||
test parseOld-2.2 {quotes and variable-substitution} {
|
||||
set a 101
|
||||
getArgs "a$a b c"
|
||||
set argv
|
||||
} {{a101 b c}}
|
||||
test parseOld-2.3 {quotes and variable-substitution} {
|
||||
set argv "xy[format xabc]"
|
||||
set argv
|
||||
} {xyxabc}
|
||||
test parseOld-2.4 {quotes and variable-substitution} {
|
||||
set argv "xy\t"
|
||||
set argv
|
||||
} xy\t
|
||||
test parseOld-2.5 {quotes and variable-substitution} {
|
||||
set argv "a b c
|
||||
d e f"
|
||||
set argv
|
||||
} a\ b\tc\nd\ e\ f
|
||||
test parseOld-2.6 {quotes and variable-substitution} {
|
||||
set argv a"bcd"e
|
||||
set argv
|
||||
} {a"bcd"e}
|
||||
|
||||
# Braces.
|
||||
|
||||
test parseOld-3.1 {braces} {
|
||||
getArgs {a b c} d
|
||||
set argv
|
||||
} "{a b c} d"
|
||||
test parseOld-3.2 {braces} {
|
||||
set a 101
|
||||
set argv {a$a b c}
|
||||
set b [string index $argv 1]
|
||||
set b
|
||||
} {$}
|
||||
test parseOld-3.3 {braces} {
|
||||
set argv {a[format xyz] b}
|
||||
string length $argv
|
||||
} 15
|
||||
test parseOld-3.4 {braces} {
|
||||
set argv {a\nb\}}
|
||||
string length $argv
|
||||
} 6
|
||||
test parseOld-3.5 {braces} {
|
||||
set argv {{{{}}}}
|
||||
set argv
|
||||
} "{{{}}}"
|
||||
test parseOld-3.6 {braces} {
|
||||
set argv a{{}}b
|
||||
set argv
|
||||
} "a{{}}b"
|
||||
test parseOld-3.7 {braces} {
|
||||
set a [format "last]"]
|
||||
set a
|
||||
} {last]}
|
||||
|
||||
# Command substitution.
|
||||
|
||||
test parseOld-4.1 {command substitution} {
|
||||
set a [format xyz]
|
||||
set a
|
||||
} xyz
|
||||
test parseOld-4.2 {command substitution} {
|
||||
set a a[format xyz]b[format q]
|
||||
set a
|
||||
} axyzbq
|
||||
test parseOld-4.3 {command substitution} {
|
||||
set a a[
|
||||
set b 22;
|
||||
format %s $b
|
||||
|
||||
]b
|
||||
set a
|
||||
} a22b
|
||||
test parseOld-4.4 {command substitution} {
|
||||
set a 7.7
|
||||
if [catch {expr int($a)}] {set a foo}
|
||||
set a
|
||||
} 7.7
|
||||
|
||||
# Variable substitution.
|
||||
|
||||
test parseOld-5.1 {variable substitution} {
|
||||
set a 123
|
||||
set b $a
|
||||
set b
|
||||
} 123
|
||||
test parseOld-5.2 {variable substitution} {
|
||||
set a 345
|
||||
set b x$a.b
|
||||
set b
|
||||
} x345.b
|
||||
test parseOld-5.3 {variable substitution} {
|
||||
set _123z xx
|
||||
set b $_123z^
|
||||
set b
|
||||
} xx^
|
||||
test parseOld-5.4 {variable substitution} {
|
||||
set a 78
|
||||
set b a${a}b
|
||||
set b
|
||||
} a78b
|
||||
test parseOld-5.5 {variable substitution} {catch {$_non_existent_} msg} 1
|
||||
test parseOld-5.6 {variable substitution} {
|
||||
catch {$_non_existent_} msg
|
||||
set msg
|
||||
} {can't read "_non_existent_": no such variable}
|
||||
test parseOld-5.7 {array variable substitution} {
|
||||
unset -nocomplain a
|
||||
set a(xyz) 123
|
||||
set b $a(xyz)foo
|
||||
set b
|
||||
} 123foo
|
||||
test parseOld-5.8 {array variable substitution} {
|
||||
unset -nocomplain a
|
||||
set "a(x y z)" 123
|
||||
set b $a(x y z)foo
|
||||
set b
|
||||
} 123foo
|
||||
test parseOld-5.9 {array variable substitution} {
|
||||
unset -nocomplain a qqq
|
||||
set "a(x y z)" qqq
|
||||
set $a([format x]\ y [format z]) foo
|
||||
set qqq
|
||||
} foo
|
||||
test parseOld-5.10 {array variable substitution} {
|
||||
unset -nocomplain a
|
||||
list [catch {set b $a(22)} msg] $msg
|
||||
} {1 {can't read "a(22)": no such variable}}
|
||||
test parseOld-5.11 {array variable substitution} {
|
||||
set b a$!
|
||||
set b
|
||||
} {a$!}
|
||||
test parseOld-5.12 {empty array name support} {
|
||||
list [catch {set b a$()} msg] $msg
|
||||
} {1 {can't read "()": no such variable}}
|
||||
unset -nocomplain a
|
||||
test parseOld-5.13 {array variable substitution} {
|
||||
unset -nocomplain 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 parseOld-5.14 {array variable substitution} {
|
||||
unset -nocomplain a b a1
|
||||
set a1(22) foo
|
||||
set a(foo) bar
|
||||
set b $a($a1(22))
|
||||
set b
|
||||
} bar
|
||||
unset -nocomplain a a1
|
||||
|
||||
test parseOld-7.1 {backslash substitution} {
|
||||
set a "\a\c\n\]\}"
|
||||
string length $a
|
||||
} 5
|
||||
test parseOld-7.2 {backslash substitution} {
|
||||
set a {\a\c\n\]\}}
|
||||
string length $a
|
||||
} 10
|
||||
test parseOld-7.3 {backslash substitution} {
|
||||
set a "abc\
|
||||
def"
|
||||
set a
|
||||
} {abc def}
|
||||
test parseOld-7.4 {backslash substitution} {
|
||||
set a {abc\
|
||||
def}
|
||||
set a
|
||||
} {abc def}
|
||||
test parseOld-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 parseOld-7.6 {backslash substitution} {
|
||||
eval "concat abc\\"
|
||||
} "abc\\"
|
||||
test parseOld-7.7 {backslash substitution} {
|
||||
eval "concat \\\na"
|
||||
} "a"
|
||||
test parseOld-7.8 {backslash substitution} {
|
||||
eval "concat x\\\n a"
|
||||
} "x a"
|
||||
test parseOld-7.9 {backslash substitution} {
|
||||
eval "concat \\x"
|
||||
} "x"
|
||||
test parseOld-7.10 {backslash substitution} {
|
||||
eval "list a b\\\nc d"
|
||||
} {a b c d}
|
||||
test parseOld-7.11 {backslash substitution} {
|
||||
eval "list a \"b c\"\\\nd e"
|
||||
} {a {b c} d e}
|
||||
test parseOld-7.12 {backslash substitution} {
|
||||
list \ua2
|
||||
} [bytestring "\xc2\xa2"]
|
||||
test parseOld-7.13 {backslash substitution} {
|
||||
list \u4e21
|
||||
} [bytestring "\xe4\xb8\xa1"]
|
||||
test parseOld-7.14 {backslash substitution} {
|
||||
list \u4e2k
|
||||
} [bytestring "\xd3\xa2k"]
|
||||
|
||||
# Semi-colon.
|
||||
|
||||
test parseOld-8.1 {semi-colons} {
|
||||
set b 0
|
||||
getArgs a;set b 2
|
||||
set argv
|
||||
} a
|
||||
test parseOld-8.2 {semi-colons} {
|
||||
set b 0
|
||||
getArgs a;set b 2
|
||||
set b
|
||||
} 2
|
||||
test parseOld-8.3 {semi-colons} {
|
||||
getArgs a b ; set b 1
|
||||
set argv
|
||||
} {a b}
|
||||
test parseOld-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 parseOld-9.1 {result initialization} {concat abc} abc
|
||||
test parseOld-9.2 {result initialization} {concat abc; proc foo {} {}} {}
|
||||
test parseOld-9.3 {result initialization} {concat abc; proc foo {} $a} {}
|
||||
test parseOld-9.4 {result initialization} {proc foo {} [concat abc]} {}
|
||||
test parseOld-9.5 {result initialization} {concat abc; } abc
|
||||
test parseOld-9.6 {result initialization} {
|
||||
eval {
|
||||
concat abc
|
||||
}} abc
|
||||
test parseOld-9.7 {result initialization} {} {}
|
||||
test parseOld-9.8 {result initialization} {concat abc; ; ;} abc
|
||||
|
||||
# Syntax errors.
|
||||
|
||||
test parseOld-10.1 {syntax errors} {catch "set a \{bcd" msg} 1
|
||||
test parseOld-10.2 {syntax errors} {
|
||||
catch "set a \{bcd" msg
|
||||
set msg
|
||||
} {missing close-brace}
|
||||
test parseOld-10.3 {syntax errors} {catch {set a "bcd} msg} 1
|
||||
test parseOld-10.4 {syntax errors} {
|
||||
catch {set a "bcd} msg
|
||||
set msg
|
||||
} {missing "}
|
||||
#" Emacs formatting >:^(
|
||||
test parseOld-10.5 {syntax errors} {catch {set a "bcd"xy} msg} 1
|
||||
test parseOld-10.6 {syntax errors} {
|
||||
catch {set a "bcd"xy} msg
|
||||
set msg
|
||||
} {extra characters after close-quote}
|
||||
test parseOld-10.7 {syntax errors} {catch "set a {bcd}xy" msg} 1
|
||||
test parseOld-10.8 {syntax errors} {
|
||||
catch "set a {bcd}xy" msg
|
||||
set msg
|
||||
} {extra characters after close-brace}
|
||||
test parseOld-10.9 {syntax errors} {catch {set a [format abc} msg} 1
|
||||
test parseOld-10.10 {syntax errors} {
|
||||
catch {set a [format abc} msg
|
||||
set msg
|
||||
} {missing close-bracket}
|
||||
test parseOld-10.11 {syntax errors} {catch gorp-a-lot msg} 1
|
||||
test parseOld-10.12 {syntax errors} {
|
||||
catch gorp-a-lot msg
|
||||
set msg
|
||||
} {invalid command name "gorp-a-lot"}
|
||||
test parseOld-10.13 {syntax errors} {
|
||||
set a [concat {a}\
|
||||
{b}]
|
||||
set a
|
||||
} {a b}
|
||||
|
||||
# The next test will fail on the Mac, 'cause the MSL uses a fixed sized
|
||||
# buffer for %d conversions (LAME!). I won't leave the test out, however,
|
||||
# since MetroWerks may some day fix this.
|
||||
|
||||
test parseOld-10.14 {syntax errors} {
|
||||
list [catch {eval \$x[format "%01000d" 0](} msg] $msg $::errorInfo
|
||||
} {1 {missing )} {missing )
|
||||
while executing
|
||||
"$x0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000..."
|
||||
("eval" body line 1)
|
||||
invoked from within
|
||||
"eval \$x[format "%01000d" 0]("}}
|
||||
test parseOld-10.15 {syntax errors, missplaced braces} {
|
||||
catch {
|
||||
proc misplaced_end_brace {} {
|
||||
set what foo
|
||||
set when [expr ${what}size - [set off$what]}]
|
||||
} msg
|
||||
set msg
|
||||
} {extra characters after close-brace}
|
||||
test parseOld-10.16 {syntax errors, missplaced braces} {
|
||||
catch {
|
||||
set a {
|
||||
set what foo
|
||||
set when [expr ${what}size - [set off$what]}]
|
||||
} msg
|
||||
set msg
|
||||
} {extra characters after close-brace}
|
||||
test parseOld-10.17 {syntax errors, unusual spacing} {
|
||||
list [catch {return [ [1]]} msg] $msg
|
||||
} {1 {invalid command name "1"}}
|
||||
# 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 parseOld-11.1 {long values} {
|
||||
string length $a
|
||||
} 214
|
||||
test parseOld-11.2 {long values} {
|
||||
llength $a
|
||||
} 43
|
||||
test parseOld-11.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 parseOld-11.4 {long values} {
|
||||
set b "$a"
|
||||
set b
|
||||
} $a
|
||||
test parseOld-11.5 {long values} {
|
||||
set b [set a]
|
||||
set b
|
||||
} $a
|
||||
test parseOld-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 parseOld-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 parseOld-11.8 {long values} {
|
||||
set b
|
||||
} $a
|
||||
test parseOld-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
|
||||
test parseOld-11.10-[incr i] {long values} {
|
||||
set j
|
||||
} $test
|
||||
}
|
||||
test parseOld-11.11 {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
|
||||
|
||||
test parseOld-12.1 {comments} {
|
||||
set a old
|
||||
eval { # set a new}
|
||||
set a
|
||||
} {old}
|
||||
test parseOld-12.2 {comments} {
|
||||
set a old
|
||||
eval " # set a new\nset a new"
|
||||
set a
|
||||
} {new}
|
||||
test parseOld-12.3 {comments} {
|
||||
set a old
|
||||
eval " # set a new\\\nset a new"
|
||||
set a
|
||||
} {old}
|
||||
test parseOld-12.4 {comments} {
|
||||
set a old
|
||||
eval " # set a new\\\\\nset a new"
|
||||
set a
|
||||
} {new}
|
||||
|
||||
test parseOld-13.1 {comments at the end of a bracketed script} {
|
||||
set x "[
|
||||
expr 1+1
|
||||
# skip this!
|
||||
]"
|
||||
} {2}
|
||||
|
||||
test parseOld-14.1 {TclWordEnd procedure} {testwordend} {
|
||||
testwordend " \n abc"
|
||||
} {c}
|
||||
test parseOld-14.2 {TclWordEnd procedure} {testwordend} {
|
||||
testwordend " \\\n"
|
||||
} {}
|
||||
test parseOld-14.3 {TclWordEnd procedure} {testwordend} {
|
||||
testwordend " \\\n "
|
||||
} { }
|
||||
test parseOld-14.4 {TclWordEnd procedure} {testwordend} {
|
||||
testwordend {"abc"}
|
||||
} {"}
|
||||
#" Emacs formatting :^(
|
||||
test parseOld-14.5 {TclWordEnd procedure} {testwordend} {
|
||||
testwordend {{xyz}}
|
||||
} \}
|
||||
test parseOld-14.6 {TclWordEnd procedure} {testwordend} {
|
||||
testwordend {{a{}b{}\}} xyz}
|
||||
} "\} xyz"
|
||||
test parseOld-14.7 {TclWordEnd procedure} {testwordend} {
|
||||
testwordend {abc[this is a]def ghi}
|
||||
} {f ghi}
|
||||
test parseOld-14.8 {TclWordEnd procedure} {testwordend} {
|
||||
testwordend "puts\\\n\n "
|
||||
} "s\\\n\n "
|
||||
test parseOld-14.9 {TclWordEnd procedure} {testwordend} {
|
||||
testwordend "puts\\\n "
|
||||
} "s\\\n "
|
||||
test parseOld-14.10 {TclWordEnd procedure} {testwordend} {
|
||||
testwordend "puts\\\n xyz"
|
||||
} "s\\\n xyz"
|
||||
test parseOld-14.11 {TclWordEnd procedure} {testwordend} {
|
||||
testwordend {a$x.$y(a long index) foo}
|
||||
} ") foo"
|
||||
test parseOld-14.12 {TclWordEnd procedure} {testwordend} {
|
||||
testwordend {abc; def}
|
||||
} {; def}
|
||||
test parseOld-14.13 {TclWordEnd procedure} {testwordend} {
|
||||
testwordend {abc def}
|
||||
} {c def}
|
||||
test parseOld-14.14 {TclWordEnd procedure} {testwordend} {
|
||||
testwordend {abc def}
|
||||
} {c def}
|
||||
test parseOld-14.15 {TclWordEnd procedure} {testwordend} {
|
||||
testwordend "abc\ndef"
|
||||
} "c\ndef"
|
||||
test parseOld-14.16 {TclWordEnd procedure} {testwordend} {
|
||||
testwordend "abc"
|
||||
} {c}
|
||||
test parseOld-14.17 {TclWordEnd procedure} {testwordend} {
|
||||
testwordend "a\000bc"
|
||||
} {c}
|
||||
test parseOld-14.18 {TclWordEnd procedure} {testwordend} {
|
||||
testwordend \[a\000\]
|
||||
} {]}
|
||||
test parseOld-14.19 {TclWordEnd procedure} {testwordend} {
|
||||
testwordend \"a\000\"
|
||||
} {"}
|
||||
#" Emacs formatting :^(
|
||||
test parseOld-14.20 {TclWordEnd procedure} {testwordend} {
|
||||
testwordend a{\000}b
|
||||
} {b}
|
||||
test parseOld-14.21 {TclWordEnd procedure} {testwordend} {
|
||||
testwordend " \000b"
|
||||
} {b}
|
||||
|
||||
test parseOld-15.1 {TclScriptEnd procedure} {
|
||||
info complete {puts [
|
||||
expr 1+1
|
||||
#this is a comment ]}
|
||||
} {0}
|
||||
test parseOld-15.2 {TclScriptEnd procedure} {
|
||||
info complete "abc\\\n"
|
||||
} {0}
|
||||
test parseOld-15.3 {TclScriptEnd procedure} {
|
||||
info complete "abc\\\\\n"
|
||||
} {1}
|
||||
test parseOld-15.4 {TclScriptEnd procedure} {
|
||||
info complete "xyz \[abc \{abc\]"
|
||||
} {0}
|
||||
test parseOld-15.5 {TclScriptEnd procedure} {
|
||||
info complete "xyz \[abc"
|
||||
} {0}
|
||||
|
||||
# cleanup
|
||||
set argv $savedArgv
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
57
tests/pid.test
Normal file
57
tests/pid.test
Normal file
@@ -0,0 +1,57 @@
|
||||
# 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.
|
||||
# Copyright (c) 1994-1995 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest 2
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
testConstraint pidDefined [llength [info commands pid]]
|
||||
|
||||
test pid-1.1 {pid command} pidDefined {
|
||||
regexp {(^[0-9]+$)|(^0x[0-9a-fA-F]+$)} [pid]
|
||||
} 1
|
||||
test pid-1.2 {pid command} -constraints {unixOrPc unixExecs pidDefined} -setup {
|
||||
set path(test1) [makeFile {} test1]
|
||||
file delete $path(test1)
|
||||
} -body {
|
||||
set f [open |[list echo foo | cat >$path(test1)] 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]}]
|
||||
} -cleanup {
|
||||
removeFile test1
|
||||
} -result {2 1 1 0}
|
||||
test pid-1.3 {pid command} -constraints pidDefined -setup {
|
||||
set path(test1) [makeFile {} test1]
|
||||
file delete $path(test1)
|
||||
} -body {
|
||||
set f [open $path(test1) w]
|
||||
set pids [pid $f]
|
||||
close $f
|
||||
set pids
|
||||
} -cleanup {
|
||||
removeFile test1
|
||||
} -result {}
|
||||
test pid-1.4 {pid command} pidDefined {
|
||||
list [catch {pid a b} msg] $msg
|
||||
} {1 {wrong # args: should be "pid ?channelId?"}}
|
||||
test pid-1.5 {pid command} pidDefined {
|
||||
list [catch {pid gorp} msg] $msg
|
||||
} {1 {can not find channel named "gorp"}}
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
1219
tests/pkg.test
Normal file
1219
tests/pkg.test
Normal file
File diff suppressed because it is too large
Load Diff
699
tests/pkgMkIndex.test
Normal file
699
tests/pkgMkIndex.test
Normal file
@@ -0,0 +1,699 @@
|
||||
# This file contains tests for the pkg_mkIndex command.
|
||||
# Note that the tests are limited to Tcl scripts only, there are no shared
|
||||
# libraries against which to test.
|
||||
#
|
||||
# Sourcing this file into Tcl runs the tests and generates output for
|
||||
# errors. No output means no errors were found.
|
||||
#
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
# All rights reserved.
|
||||
|
||||
package require tcltest 2
|
||||
namespace import ::tcltest::*
|
||||
|
||||
set fullPkgPath [makeDirectory pkg]
|
||||
|
||||
|
||||
namespace eval pkgtest {
|
||||
# Namespace for procs we can discard
|
||||
}
|
||||
|
||||
# pkgtest::parseArgs --
|
||||
#
|
||||
# Parse an argument list.
|
||||
#
|
||||
# Arguments:
|
||||
# <flags> (optional) arguments starting with a dash are collected
|
||||
# as options to pkg_mkIndex and passed to pkg_mkIndex.
|
||||
# dirPath the directory to index
|
||||
# pattern0 pattern to index
|
||||
# ... pattern to index
|
||||
# patternN pattern to index
|
||||
#
|
||||
# Results:
|
||||
# Returns a three element list:
|
||||
# 0: the options
|
||||
# 1: the directory to index
|
||||
# 2: the patterns list
|
||||
|
||||
proc pkgtest::parseArgs { args } {
|
||||
set options ""
|
||||
|
||||
set argc [llength $args]
|
||||
for {set iarg 0} {$iarg < $argc} {incr iarg} {
|
||||
set a [lindex $args $iarg]
|
||||
if {[regexp {^-} $a]} {
|
||||
lappend options $a
|
||||
if {$a eq "-load"} {
|
||||
incr iarg
|
||||
lappend options [lindex $args $iarg]
|
||||
}
|
||||
} else {
|
||||
break
|
||||
}
|
||||
}
|
||||
|
||||
set dirPath [lindex $args $iarg]
|
||||
incr iarg
|
||||
set patternList [lrange $args $iarg end]
|
||||
|
||||
return [list $options $dirPath $patternList]
|
||||
}
|
||||
|
||||
# pkgtest::parseIndex --
|
||||
#
|
||||
# Loads a pkgIndex.tcl file, records all the calls to "package ifneeded".
|
||||
#
|
||||
# Arguments:
|
||||
# filePath path to the pkgIndex.tcl file.
|
||||
#
|
||||
# Results:
|
||||
# Returns a list, in "array set/get" format, where the keys are the package
|
||||
# name and version (in the form "$name:$version"), and the values the rest
|
||||
# of the command line.
|
||||
|
||||
proc pkgtest::parseIndex { filePath } {
|
||||
# create a slave interpreter, where we override "package ifneeded"
|
||||
|
||||
set slave [interp create]
|
||||
if {[catch {
|
||||
$slave eval {
|
||||
rename package package_original
|
||||
proc package { args } {
|
||||
if {[lindex $args 0] eq "ifneeded"} {
|
||||
set pkg [lindex $args 1]
|
||||
set ver [lindex $args 2]
|
||||
set ::PKGS($pkg:$ver) [lindex $args 3]
|
||||
} else {
|
||||
return [package_original {*}$args]
|
||||
}
|
||||
}
|
||||
array set ::PKGS {}
|
||||
}
|
||||
|
||||
set dir [file dirname $filePath]
|
||||
$slave eval {set curdir [pwd]}
|
||||
$slave eval [list cd $dir]
|
||||
$slave eval [list set dir $dir]
|
||||
$slave eval [list source [file tail $filePath]]
|
||||
$slave eval {cd $curdir}
|
||||
|
||||
# Create the list in sorted order, so that we don't get spurious
|
||||
# errors because the order has changed.
|
||||
|
||||
array set P {}
|
||||
foreach {k v} [$slave eval {array get ::PKGS}] {
|
||||
set P($k) $v
|
||||
}
|
||||
|
||||
set PKGS ""
|
||||
foreach k [lsort [array names P]] {
|
||||
lappend PKGS $k $P($k)
|
||||
}
|
||||
} err opts]} {
|
||||
set ei [dict get $opts -errorinfo]
|
||||
set ec [dict get $opts -errorcode]
|
||||
|
||||
catch {interp delete $slave}
|
||||
|
||||
error $ei $ec
|
||||
}
|
||||
|
||||
interp delete $slave
|
||||
|
||||
return $PKGS
|
||||
}
|
||||
|
||||
# pkgtest::createIndex --
|
||||
#
|
||||
# Runs pkg_mkIndex for the given directory and set of patterns.
|
||||
# This procedure deletes any pkgIndex.tcl file in the target directory,
|
||||
# then runs pkg_mkIndex.
|
||||
#
|
||||
# Arguments:
|
||||
# <flags> (optional) arguments starting with a dash are collected
|
||||
# as options to pkg_mkIndex and passed to pkg_mkIndex.
|
||||
# dirPath the directory to index
|
||||
# pattern0 pattern to index
|
||||
# ... pattern to index
|
||||
# patternN pattern to index
|
||||
#
|
||||
# Results:
|
||||
# Returns a two element list:
|
||||
# 0: 1 if the procedure encountered an error, 0 otherwise.
|
||||
# 1: the error result if element 0 was 1
|
||||
|
||||
proc pkgtest::createIndex { args } {
|
||||
set parsed [parseArgs {*}$args]
|
||||
set options [lindex $parsed 0]
|
||||
set dirPath [lindex $parsed 1]
|
||||
set patternList [lindex $parsed 2]
|
||||
|
||||
file mkdir $dirPath
|
||||
|
||||
if {[catch {
|
||||
file delete [file join $dirPath pkgIndex.tcl]
|
||||
pkg_mkIndex {*}$options $dirPath {*}$patternList
|
||||
} err]} {
|
||||
return [list 1 $err]
|
||||
}
|
||||
|
||||
return [list 0 {}]
|
||||
}
|
||||
|
||||
# makePkgList --
|
||||
#
|
||||
# Takes the output of a pkgtest::parseIndex call, filters it and returns a
|
||||
# cleaned up list of packages and their actions.
|
||||
#
|
||||
# Arguments:
|
||||
# inList output from a pkgtest::parseIndex.
|
||||
#
|
||||
# Results:
|
||||
# Returns a list of two element lists:
|
||||
# 0: the name:version
|
||||
# 1: a list describing the package.
|
||||
# For tclPkgSetup packages it consists of:
|
||||
# 0: the keyword tclPkgSetup
|
||||
# 1: the first file to source, with its exported procedures
|
||||
# 2: the second file ...
|
||||
# N: the N-1st file ...
|
||||
|
||||
proc makePkgList { inList } {
|
||||
set pkgList ""
|
||||
|
||||
foreach {k v} $inList {
|
||||
switch [lindex $v 0] {
|
||||
tclPkgSetup {
|
||||
set l tclPkgSetup
|
||||
foreach s [lindex $v 4] {
|
||||
lappend l $s
|
||||
}
|
||||
}
|
||||
|
||||
source {
|
||||
set l $v
|
||||
}
|
||||
|
||||
default {
|
||||
error "can't handle $k $v"
|
||||
}
|
||||
}
|
||||
|
||||
lappend pkgList [list $k $l]
|
||||
}
|
||||
|
||||
return $pkgList
|
||||
}
|
||||
|
||||
# pkgtest::runIndex --
|
||||
#
|
||||
# Runs pkg_mkIndex, parses the generated index file.
|
||||
#
|
||||
# Arguments:
|
||||
# <flags> (optional) arguments starting with a dash are collected
|
||||
# as options to pkg_mkIndex and passed to pkg_mkIndex.
|
||||
# dirPath the directory to index
|
||||
# pattern0 pattern to index
|
||||
# ... pattern to index
|
||||
# patternN pattern to index
|
||||
#
|
||||
# Results:
|
||||
# Returns a two element list:
|
||||
# 0: 1 if the procedure encountered an error, 0 otherwise.
|
||||
# 1: if no error, this is the parsed generated index file, in the format
|
||||
# returned by pkgtest::parseIndex.
|
||||
# If error, this is the error result.
|
||||
|
||||
proc pkgtest::runCreatedIndex {rv args} {
|
||||
if {[lindex $rv 0] == 0} {
|
||||
set parsed [parseArgs {*}$args]
|
||||
set dirPath [lindex $parsed 1]
|
||||
set idxFile [file join $dirPath pkgIndex.tcl]
|
||||
|
||||
if {[catch {
|
||||
set result [list 0 [makePkgList [parseIndex $idxFile]]]
|
||||
} err]} {
|
||||
set result [list 1 $err]
|
||||
}
|
||||
file delete $idxFile
|
||||
} else {
|
||||
set result $rv
|
||||
}
|
||||
|
||||
return $result
|
||||
}
|
||||
proc pkgtest::runIndex { args } {
|
||||
set rv [createIndex {*}$args]
|
||||
return [runCreatedIndex $rv {*}$args]
|
||||
}
|
||||
|
||||
# If there is no match to the patterns, make sure the directory hasn't
|
||||
# changed on us
|
||||
|
||||
test pkgMkIndex-1.1 {nothing matches pattern - current dir is the same} {
|
||||
list [pkgtest::runIndex -lazy $fullPkgPath nomatch.tcl] [pwd]
|
||||
} [list {1 {no files matched glob pattern "nomatch.tcl"}} [pwd]]
|
||||
|
||||
makeFile {
|
||||
# This is a simple package, just to check basic functionality.
|
||||
package provide simple 1.0
|
||||
namespace eval simple {
|
||||
namespace export lower upper
|
||||
}
|
||||
proc simple::lower { stg } {
|
||||
return [string tolower $stg]
|
||||
}
|
||||
proc simple::upper { stg } {
|
||||
return [string toupper $stg]
|
||||
}
|
||||
} [file join pkg simple.tcl]
|
||||
|
||||
test pkgMkIndex-2.1 {simple package} {
|
||||
pkgtest::runIndex -lazy $fullPkgPath simple.tcl
|
||||
} {0 {{simple:1.0 {tclPkgSetup {simple.tcl source {::simple::lower ::simple::upper}}}}}}
|
||||
|
||||
test pkgMkIndex-2.2 {simple package - use -direct} {
|
||||
pkgtest::runIndex -direct $fullPkgPath simple.tcl
|
||||
} "0 {{simple:1.0 {[list source [file join $fullPkgPath simple.tcl]]}}}"
|
||||
|
||||
test pkgMkIndex-2.3 {simple package - direct loading is default} {
|
||||
pkgtest::runIndex $fullPkgPath simple.tcl
|
||||
} "0 {{simple:1.0 {[list source [file join $fullPkgPath simple.tcl]]}}}"
|
||||
|
||||
test pkgMkIndex-2.4 {simple package - use -verbose} -body {
|
||||
pkgtest::runIndex -verbose $fullPkgPath simple.tcl
|
||||
} -result "0 {{simple:1.0 {[list source [file join $fullPkgPath simple.tcl]]}}}" \
|
||||
-errorOutput {successful sourcing of simple.tcl
|
||||
packages provided were {simple 1.0}
|
||||
processed simple.tcl
|
||||
}
|
||||
|
||||
removeFile [file join pkg simple.tcl]
|
||||
|
||||
makeFile {
|
||||
# Contains global symbols, used to check that they don't have a leading ::
|
||||
package provide global 1.0
|
||||
proc global_lower { stg } {
|
||||
return [string tolower $stg]
|
||||
}
|
||||
proc global_upper { stg } {
|
||||
return [string toupper $stg]
|
||||
}
|
||||
} [file join pkg global.tcl]
|
||||
|
||||
test pkgMkIndex-3.1 {simple package with global symbols} {
|
||||
pkgtest::runIndex -lazy $fullPkgPath global.tcl
|
||||
} {0 {{global:1.0 {tclPkgSetup {global.tcl source {global_lower global_upper}}}}}}
|
||||
|
||||
removeFile [file join pkg global.tcl]
|
||||
|
||||
makeFile {
|
||||
# This package is required by pkg1.
|
||||
# This package is split into two files, to test packages that are split
|
||||
# over multiple files.
|
||||
package provide pkg2 1.0
|
||||
namespace eval pkg2 {
|
||||
namespace export p2-1
|
||||
}
|
||||
proc pkg2::p2-1 { num } {
|
||||
return [expr $num * 2]
|
||||
}
|
||||
} [file join pkg pkg2_a.tcl]
|
||||
|
||||
makeFile {
|
||||
# This package is required by pkg1.
|
||||
# This package is split into two files, to test packages that are split
|
||||
# over multiple files.
|
||||
package provide pkg2 1.0
|
||||
namespace eval pkg2 {
|
||||
namespace export p2-2
|
||||
}
|
||||
proc pkg2::p2-2 { num } {
|
||||
return [expr $num * 3]
|
||||
}
|
||||
} [file join pkg pkg2_b.tcl]
|
||||
|
||||
test pkgMkIndex-4.1 {split package} {
|
||||
pkgtest::runIndex -lazy $fullPkgPath pkg2_a.tcl pkg2_b.tcl
|
||||
} {0 {{pkg2:1.0 {tclPkgSetup {pkg2_a.tcl source ::pkg2::p2-1} {pkg2_b.tcl source ::pkg2::p2-2}}}}}
|
||||
|
||||
test pkgMkIndex-4.2 {split package - direct loading} {
|
||||
pkgtest::runIndex -direct $fullPkgPath pkg2_a.tcl pkg2_b.tcl
|
||||
} "0 {{pkg2:1.0 {[list source [file join $fullPkgPath pkg2_a.tcl]]
|
||||
[list source [file join $fullPkgPath pkg2_b.tcl]]}}}"
|
||||
|
||||
# Add the direct1 directory to auto_path, so that the direct1 package
|
||||
# can be found.
|
||||
set direct1 [makeDirectory direct1]
|
||||
lappend auto_path $direct1
|
||||
makeFile {
|
||||
# This is referenced by pkgIndex.tcl as a -direct script.
|
||||
package provide direct1 1.0
|
||||
namespace eval direct1 {
|
||||
namespace export pd1 pd2
|
||||
}
|
||||
proc direct1::pd1 { stg } {
|
||||
return [string tolower $stg]
|
||||
}
|
||||
proc direct1::pd2 { stg } {
|
||||
return [string toupper $stg]
|
||||
}
|
||||
} [file join direct1 direct1.tcl]
|
||||
pkg_mkIndex -direct $direct1 direct1.tcl
|
||||
|
||||
makeFile {
|
||||
# Does a package require of direct1, whose pkgIndex.tcl entry
|
||||
# is created above with option -direct. This tests that pkg_mkIndex
|
||||
# can handle code that is sourced in pkgIndex.tcl files.
|
||||
package require direct1
|
||||
package provide std 1.0
|
||||
namespace eval std {
|
||||
namespace export p1 p2
|
||||
}
|
||||
proc std::p1 { stg } {
|
||||
return [string tolower $stg]
|
||||
}
|
||||
proc std::p2 { stg } {
|
||||
return [string toupper $stg]
|
||||
}
|
||||
} [file join pkg std.tcl]
|
||||
|
||||
test pkgMkIndex-5.1 {requires -direct package} {
|
||||
pkgtest::runIndex -lazy $fullPkgPath std.tcl
|
||||
} {0 {{std:1.0 {tclPkgSetup {std.tcl source {::std::p1 ::std::p2}}}}}}
|
||||
|
||||
removeFile [file join direct1 direct1.tcl]
|
||||
file delete [file join $direct1 pkgIndex.tcl]
|
||||
removeDirectory direct1
|
||||
removeFile [file join pkg std.tcl]
|
||||
|
||||
makeFile {
|
||||
# This package requires pkg3, but it does
|
||||
# not use any of pkg3's procs in the code that is executed by the file
|
||||
# (i.e. references to pkg3's procs are in the proc bodies only).
|
||||
package require pkg3 1.0
|
||||
package provide pkg1 1.0
|
||||
namespace eval pkg1 {
|
||||
namespace export p1-1 p1-2
|
||||
}
|
||||
proc pkg1::p1-1 { num } {
|
||||
return [pkg3::p3-1 $num]
|
||||
}
|
||||
proc pkg1::p1-2 { num } {
|
||||
return [pkg3::p3-2 $num]
|
||||
}
|
||||
} [file join pkg pkg1.tcl]
|
||||
|
||||
makeFile {
|
||||
package provide pkg3 1.0
|
||||
namespace eval pkg3 {
|
||||
namespace export p3-1 p3-2
|
||||
}
|
||||
proc pkg3::p3-1 { num } {
|
||||
return {[expr $num * 2]}
|
||||
}
|
||||
proc pkg3::p3-2 { num } {
|
||||
return {[expr $num * 3]}
|
||||
}
|
||||
} [file join pkg pkg3.tcl]
|
||||
|
||||
test pkgMkIndex-6.1 {pkg1 requires pkg3} {
|
||||
pkgtest::runIndex -lazy $fullPkgPath pkg1.tcl pkg3.tcl
|
||||
} {0 {{pkg1:1.0 {tclPkgSetup {pkg1.tcl source {::pkg1::p1-1 ::pkg1::p1-2}}}} {pkg3:1.0 {tclPkgSetup {pkg3.tcl source {::pkg3::p3-1 ::pkg3::p3-2}}}}}}
|
||||
|
||||
test pkgMkIndex-6.2 {pkg1 requires pkg3 - use -direct} {
|
||||
pkgtest::runIndex -direct $fullPkgPath pkg1.tcl pkg3.tcl
|
||||
} "0 {{pkg1:1.0 {[list source [file join $fullPkgPath pkg1.tcl]]}} {pkg3:1.0 {[list source [file join $fullPkgPath pkg3.tcl]]}}}"
|
||||
|
||||
removeFile [file join pkg pkg1.tcl]
|
||||
|
||||
makeFile {
|
||||
# This package requires pkg3, and it calls
|
||||
# a pkg3 proc in the code that is executed by the file
|
||||
package require pkg3 1.0
|
||||
package provide pkg4 1.0
|
||||
namespace eval pkg4 {
|
||||
namespace export p4-1 p4-2
|
||||
variable m2 [pkg3::p3-1 10]
|
||||
}
|
||||
proc pkg4::p4-1 { num } {
|
||||
variable m2
|
||||
return [expr {$m2 * $num}]
|
||||
}
|
||||
proc pkg4::p4-2 { num } {
|
||||
return [pkg3::p3-2 $num]
|
||||
}
|
||||
} [file join pkg pkg4.tcl]
|
||||
|
||||
test pkgMkIndex-7.1 {pkg4 uses pkg3} {
|
||||
pkgtest::runIndex -lazy $fullPkgPath pkg4.tcl pkg3.tcl
|
||||
} {0 {{pkg3:1.0 {tclPkgSetup {pkg3.tcl source {::pkg3::p3-1 ::pkg3::p3-2}}}} {pkg4:1.0 {tclPkgSetup {pkg4.tcl source {::pkg4::p4-1 ::pkg4::p4-2}}}}}}
|
||||
|
||||
test pkgMkIndex-7.2 {pkg4 uses pkg3 - use -direct} {
|
||||
pkgtest::runIndex -direct $fullPkgPath pkg4.tcl pkg3.tcl
|
||||
} "0 {{pkg3:1.0 {[list source [file join $fullPkgPath pkg3.tcl]]}} {pkg4:1.0 {[list source [file join $fullPkgPath pkg4.tcl]]}}}"
|
||||
|
||||
removeFile [file join pkg pkg4.tcl]
|
||||
removeFile [file join pkg pkg3.tcl]
|
||||
|
||||
makeFile {
|
||||
# This package requires pkg2, and it calls
|
||||
# a pkg2 proc in the code that is executed by the file.
|
||||
# Pkg2 is a split package.
|
||||
package require pkg2 1.0
|
||||
package provide pkg5 1.0
|
||||
namespace eval pkg5 {
|
||||
namespace export p5-1 p5-2
|
||||
variable m2 [pkg2::p2-1 10]
|
||||
variable m3 [pkg2::p2-2 10]
|
||||
}
|
||||
proc pkg5::p5-1 { num } {
|
||||
variable m2
|
||||
return [expr {$m2 * $num}]
|
||||
}
|
||||
proc pkg5::p5-2 { num } {
|
||||
variable m2
|
||||
return [expr {$m2 * $num}]
|
||||
}
|
||||
} [file join pkg pkg5.tcl]
|
||||
|
||||
test pkgMkIndex-8.1 {pkg5 uses pkg2} {
|
||||
pkgtest::runIndex -lazy $fullPkgPath pkg5.tcl pkg2_a.tcl pkg2_b.tcl
|
||||
} {0 {{pkg2:1.0 {tclPkgSetup {pkg2_a.tcl source ::pkg2::p2-1} {pkg2_b.tcl source ::pkg2::p2-2}}} {pkg5:1.0 {tclPkgSetup {pkg5.tcl source {::pkg5::p5-1 ::pkg5::p5-2}}}}}}
|
||||
|
||||
test pkgMkIndex-8.2 {pkg5 uses pkg2 - use -direct} {
|
||||
pkgtest::runIndex -direct $fullPkgPath pkg5.tcl pkg2_a.tcl pkg2_b.tcl
|
||||
} "0 {{pkg2:1.0 {[list source [file join $fullPkgPath pkg2_a.tcl]]
|
||||
[list source [file join $fullPkgPath pkg2_b.tcl]]}} {pkg5:1.0 {[list source [file join $fullPkgPath pkg5.tcl]]}}}"
|
||||
|
||||
removeFile [file join pkg pkg5.tcl]
|
||||
removeFile [file join pkg pkg2_a.tcl]
|
||||
removeFile [file join pkg pkg2_b.tcl]
|
||||
|
||||
makeFile {
|
||||
# This package requires circ2, and circ2
|
||||
# requires circ3, which in turn requires circ1.
|
||||
# In case of cirularities, pkg_mkIndex should give up when it gets stuck.
|
||||
package require circ2 1.0
|
||||
package provide circ1 1.0
|
||||
namespace eval circ1 {
|
||||
namespace export c1-1 c1-2 c1-3 c1-4
|
||||
}
|
||||
proc circ1::c1-1 { num } {
|
||||
return [circ2::c2-1 $num]
|
||||
}
|
||||
proc circ1::c1-2 { num } {
|
||||
return [circ2::c2-2 $num]
|
||||
}
|
||||
proc circ1::c1-3 {} {
|
||||
return 10
|
||||
}
|
||||
proc circ1::c1-4 {} {
|
||||
return 20
|
||||
}
|
||||
} [file join pkg circ1.tcl]
|
||||
|
||||
makeFile {
|
||||
# This package is required by circ1, and
|
||||
# requires circ3. Circ3, in turn, requires circ1 to give us a circularity.
|
||||
package require circ3 1.0
|
||||
package provide circ2 1.0
|
||||
namespace eval circ2 {
|
||||
namespace export c2-1 c2-2
|
||||
}
|
||||
proc circ2::c2-1 { num } {
|
||||
return [expr $num * [circ3::c3-1]]
|
||||
}
|
||||
proc circ2::c2-2 { num } {
|
||||
return [expr $num * [circ3::c3-2]]
|
||||
}
|
||||
} [file join pkg circ2.tcl]
|
||||
|
||||
makeFile {
|
||||
# This package is required by circ2, and in
|
||||
# turn requires circ1. This closes the circularity.
|
||||
package require circ1 1.0
|
||||
package provide circ3 1.0
|
||||
namespace eval circ3 {
|
||||
namespace export c3-1 c3-4
|
||||
}
|
||||
proc circ3::c3-1 {} {
|
||||
return [circ1::c1-3]
|
||||
}
|
||||
proc circ3::c3-2 {} {
|
||||
return [circ1::c1-4]
|
||||
}
|
||||
} [file join pkg circ3.tcl]
|
||||
|
||||
test pkgMkIndex-9.1 {circular packages} {
|
||||
pkgtest::runIndex -lazy $fullPkgPath circ1.tcl circ2.tcl circ3.tcl
|
||||
} {0 {{circ1:1.0 {tclPkgSetup {circ1.tcl source {::circ1::c1-1 ::circ1::c1-2 ::circ1::c1-3 ::circ1::c1-4}}}} {circ2:1.0 {tclPkgSetup {circ2.tcl source {::circ2::c2-1 ::circ2::c2-2}}}} {circ3:1.0 {tclPkgSetup {circ3.tcl source ::circ3::c3-1}}}}}
|
||||
|
||||
removeFile [file join pkg circ1.tcl]
|
||||
removeFile [file join pkg circ2.tcl]
|
||||
removeFile [file join pkg circ3.tcl]
|
||||
|
||||
# Some tests require the existence of one of the DLLs in the dltest directory
|
||||
set x [file join [file dirname [info nameofexecutable]] dltest \
|
||||
pkga[info sharedlibextension]]
|
||||
set dll "[file tail $x]Required"
|
||||
testConstraint $dll [file exists $x]
|
||||
|
||||
if {[testConstraint $dll]} {
|
||||
makeFile {
|
||||
# This package provides Pkga, which is also provided by a DLL.
|
||||
package provide Pkga 1.0
|
||||
proc pkga_neq { x } {
|
||||
return [expr {! [pkgq_eq $x]}]
|
||||
}
|
||||
} [file join pkg pkga.tcl]
|
||||
file copy -force $x $fullPkgPath
|
||||
}
|
||||
testConstraint exec [llength [info commands ::exec]]
|
||||
|
||||
test pkgMkIndex-10.1 {package in DLL and script} [list exec $dll] {
|
||||
# Do all [load]ing of shared libraries in another process, so
|
||||
# we can delete the file and not get stuck because we're holding
|
||||
# a reference to it.
|
||||
set cmd [list pkg_mkIndex -lazy $fullPkgPath [file tail $x] pkga.tcl]
|
||||
exec [interpreter] << $cmd
|
||||
pkgtest::runCreatedIndex {0 {}} -lazy $fullPkgPath pkga[info sharedlibextension] pkga.tcl
|
||||
} "0 {{Pkga:1.0 {tclPkgSetup {pkga[info sharedlibextension] load {pkga_eq pkga_quote}} {pkga.tcl source pkga_neq}}}}"
|
||||
test pkgMkIndex-10.2 {package in DLL hidden by -load} [list exec $dll] {
|
||||
# Do all [load]ing of shared libraries in another process, so
|
||||
# we can delete the file and not get stuck because we're holding
|
||||
# a reference to it.
|
||||
#
|
||||
# This test depends on context from prior test, so repeat it.
|
||||
set script "[list pkg_mkIndex -lazy $fullPkgPath [file tail $x] pkga.tcl]\n"
|
||||
append script \
|
||||
"[list pkg_mkIndex -lazy -load Pkg* $fullPkgPath [file tail $x]]"
|
||||
exec [interpreter] << $script
|
||||
pkgtest::runCreatedIndex {0 {}} -lazy -load Pkg* -- $fullPkgPath pkga[info sharedlibextension]
|
||||
} {0 {}}
|
||||
|
||||
if {[testConstraint $dll]} {
|
||||
file delete -force [file join $fullPkgPath [file tail $x]]
|
||||
removeFile [file join pkg pkga.tcl]
|
||||
}
|
||||
|
||||
# Tolerate "namespace import" at the global scope
|
||||
|
||||
makeFile {
|
||||
package provide fubar 1.0
|
||||
namespace eval ::fubar:: {
|
||||
#
|
||||
# export only public functions.
|
||||
#
|
||||
namespace export {[a-z]*}
|
||||
}
|
||||
proc ::fubar::foo {bar} {
|
||||
puts "$bar"
|
||||
return true
|
||||
}
|
||||
namespace import ::fubar::foo
|
||||
} [file join pkg import.tcl]
|
||||
|
||||
test pkgMkIndex-11.1 {conflicting namespace imports} {
|
||||
pkgtest::runIndex -lazy $fullPkgPath import.tcl
|
||||
} {0 {{fubar:1.0 {tclPkgSetup {import.tcl source ::fubar::foo}}}}}
|
||||
|
||||
removeFile [file join pkg import.tcl]
|
||||
|
||||
# Verify that the auto load list generated is correct even when there
|
||||
# is a proc name conflict between two namespaces (ie, ::foo::baz and
|
||||
# ::bar::baz)
|
||||
|
||||
makeFile {
|
||||
package provide football 1.0
|
||||
namespace eval ::pro:: {
|
||||
#
|
||||
# export only public functions.
|
||||
#
|
||||
namespace export {[a-z]*}
|
||||
}
|
||||
namespace eval ::college:: {
|
||||
#
|
||||
# export only public functions.
|
||||
#
|
||||
namespace export {[a-z]*}
|
||||
}
|
||||
proc ::pro::team {} {
|
||||
puts "go packers!"
|
||||
return true
|
||||
}
|
||||
proc ::college::team {} {
|
||||
puts "go badgers!"
|
||||
return true
|
||||
}
|
||||
} [file join pkg samename.tcl]
|
||||
|
||||
test pkgMkIndex-12.1 {same name procs in different namespace} {
|
||||
pkgtest::runIndex -lazy $fullPkgPath samename.tcl
|
||||
} {0 {{football:1.0 {tclPkgSetup {samename.tcl source {::college::team ::pro::team}}}}}}
|
||||
|
||||
removeFile [file join pkg samename.tcl]
|
||||
|
||||
# Proc names with embedded spaces are properly listed (ie, correct number of
|
||||
# braces) in result
|
||||
makeFile {
|
||||
package provide spacename 1.0
|
||||
proc {a b} {} {}
|
||||
proc {c d} {} {}
|
||||
} [file join pkg spacename.tcl]
|
||||
|
||||
test pkgMkIndex-13.1 {proc names with embedded spaces} {
|
||||
pkgtest::runIndex -lazy $fullPkgPath spacename.tcl
|
||||
} {0 {{spacename:1.0 {tclPkgSetup {spacename.tcl source {{a b} {c d}}}}}}}
|
||||
|
||||
removeFile [file join pkg spacename.tcl]
|
||||
|
||||
# Test the tcl::Pkg::CompareExtension helper function
|
||||
test pkgMkIndex-14.1 {tcl::Pkg::CompareExtension} {unix} {
|
||||
tcl::Pkg::CompareExtension foo.so .so
|
||||
} 1
|
||||
test pkgMkIndex-14.2 {tcl::Pkg::CompareExtension} {unix} {
|
||||
tcl::Pkg::CompareExtension foo.so.bar .so
|
||||
} 0
|
||||
test pkgMkIndex-14.3 {tcl::Pkg::CompareExtension} {unix} {
|
||||
tcl::Pkg::CompareExtension foo.so.1 .so
|
||||
} 1
|
||||
test pkgMkIndex-14.4 {tcl::Pkg::CompareExtension} {unix} {
|
||||
tcl::Pkg::CompareExtension foo.so.1.2 .so
|
||||
} 1
|
||||
test pkgMkIndex-14.5 {tcl::Pkg::CompareExtension} {unix} {
|
||||
tcl::Pkg::CompareExtension foo .so
|
||||
} 0
|
||||
test pkgMkIndex-14.6 {tcl::Pkg::CompareExtension} {unix} {
|
||||
tcl::Pkg::CompareExtension foo.so.1.2.bar .so
|
||||
} 0
|
||||
|
||||
# cleanup
|
||||
|
||||
removeDirectory pkg
|
||||
|
||||
namespace delete pkgtest
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
|
||||
66
tests/platform.test
Normal file
66
tests/platform.test
Normal file
@@ -0,0 +1,66 @@
|
||||
# The file tests the tcl_platform variable
|
||||
#
|
||||
# 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) 1999 by Scriptics Corporation
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
package require tcltest 2
|
||||
|
||||
namespace eval ::tcl::test::platform {
|
||||
namespace import ::tcltest::testConstraint
|
||||
namespace import ::tcltest::test
|
||||
namespace import ::tcltest::cleanupTests
|
||||
|
||||
variable ::tcl_platform
|
||||
|
||||
testConstraint testCPUID [llength [info commands testcpuid]]
|
||||
|
||||
test platform-1.1 {TclpSetVariables: tcl_platform} {
|
||||
interp create i
|
||||
i eval {catch {unset tcl_platform(debug)}}
|
||||
i eval {catch {unset tcl_platform(threaded)}}
|
||||
set result [i eval {lsort [array names tcl_platform]}]
|
||||
interp delete i
|
||||
set result
|
||||
} {byteOrder machine os osVersion platform pointerSize user wordSize}
|
||||
|
||||
# Test assumes twos-complement arithmetic, which is true of virtually
|
||||
# everything these days. Note that this does *not* use wide(), and
|
||||
# this is intentional since that could make Tcl's numbers wider than
|
||||
# the machine-integer on some platforms...
|
||||
test platform-2.1 {tcl_platform(wordSize) indicates size of native word} {
|
||||
set result [expr {int(1 << (8 * $tcl_platform(wordSize) - 1))}]
|
||||
# Result must be the largest bit in a machine word, which this checks
|
||||
# without assuming how wide the word really is
|
||||
list [expr {$result < 0}] [expr {$result ^ int($result - 1)}]
|
||||
} {1 -1}
|
||||
|
||||
# On Windows/UNIX, test that the CPU ID works
|
||||
|
||||
test platform-3.1 {CPU ID on Windows/UNIX} \
|
||||
-constraints testCPUID \
|
||||
-body {
|
||||
set cpudata [testcpuid 0]
|
||||
binary format iii \
|
||||
[lindex $cpudata 1] \
|
||||
[lindex $cpudata 3] \
|
||||
[lindex $cpudata 2]
|
||||
} \
|
||||
-match regexp \
|
||||
-result {^(?:AuthenticAMD|CentaurHauls|CyrixInstead|GenuineIntel)$}
|
||||
|
||||
# cleanup
|
||||
cleanupTests
|
||||
|
||||
}
|
||||
namespace delete ::tcl::test::platform
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# End:
|
||||
520
tests/proc-old.test
Normal file
520
tests/proc-old.test
Normal file
@@ -0,0 +1,520 @@
|
||||
# Commands covered: proc, return, global
|
||||
#
|
||||
# This file, proc-old.test, includes the original set of tests for Tcl's
|
||||
# proc, return, and global commands. There is now a new file proc.test
|
||||
# that contains tests for the tclProc.c source file.
|
||||
#
|
||||
# Sourcing this file into Tcl runs the tests and generates output for
|
||||
# errors. No output means no errors were found.
|
||||
#
|
||||
# Copyright (c) 1991-1993 The Regents of the University of California.
|
||||
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
catch {rename t1 ""}
|
||||
catch {rename foo ""}
|
||||
|
||||
proc tproc {} {return a; return b}
|
||||
test proc-old-1.1 {simple procedure call and return} {tproc} a
|
||||
proc tproc x {
|
||||
set x [expr $x+1]
|
||||
return $x
|
||||
}
|
||||
test proc-old-1.2 {simple procedure call and return} {tproc 2} 3
|
||||
test proc-old-1.3 {simple procedure call and return} {
|
||||
proc tproc {} {return foo}
|
||||
} {}
|
||||
test proc-old-1.4 {simple procedure call and return} {
|
||||
proc tproc {} {return}
|
||||
tproc
|
||||
} {}
|
||||
proc tproc1 {a} {incr a; return $a}
|
||||
proc tproc2 {a b} {incr a; return $a}
|
||||
test proc-old-1.5 {simple procedure call and return (2 procs with same body but different parameters)} {
|
||||
list [tproc1 123] [tproc2 456 789]
|
||||
} {124 457}
|
||||
test proc-old-1.6 {simple procedure call and return (shared proc body string)} {
|
||||
set x {}
|
||||
proc tproc {} {} ;# body is shared with x
|
||||
list [tproc] [append x foo]
|
||||
} {{} foo}
|
||||
|
||||
test proc-old-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-old-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-old-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-old-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-old-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-old-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-old-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-old-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-old-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-old-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-old-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-old-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-old-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-old-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-old-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-old-30.1 {arguments and defaults} {
|
||||
proc tproc {x y z} {
|
||||
return [list $x $y $z]
|
||||
}
|
||||
tproc 11 12 13
|
||||
} {11 12 13}
|
||||
test proc-old-30.2 {arguments and defaults} {
|
||||
proc tproc {x y z} {
|
||||
return [list $x $y $z]
|
||||
}
|
||||
list [catch {tproc 11 12} msg] $msg
|
||||
} {1 {wrong # args: should be "tproc x y z"}}
|
||||
test proc-old-30.3 {arguments and defaults} {
|
||||
proc tproc {x y z} {
|
||||
return [list $x $y $z]
|
||||
}
|
||||
list [catch {tproc 11 12 13 14} msg] $msg
|
||||
} {1 {wrong # args: should be "tproc x y z"}}
|
||||
test proc-old-30.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-old-30.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-old-30.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-old-30.7 {arguments and defaults} {
|
||||
proc tproc {x {y y-default} {z z-default}} {
|
||||
return [list $x $y $z]
|
||||
}
|
||||
list [catch {tproc} msg] $msg
|
||||
} {1 {wrong # args: should be "tproc x ?y? ?z?"}}
|
||||
test proc-old-30.8 {arguments and defaults} {
|
||||
list [catch {
|
||||
proc tproc {x {y y-default} z} {
|
||||
return [list $x $y $z]
|
||||
}
|
||||
tproc 2 3
|
||||
} msg] $msg
|
||||
} {1 {wrong # args: should be "tproc x ?y? z"}}
|
||||
test proc-old-30.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-old-30.10 {arguments and defaults} {
|
||||
proc tproc {x {y y-default} args} {
|
||||
return [list $x $y $args]
|
||||
}
|
||||
tproc 2 3
|
||||
} {2 3 {}}
|
||||
test proc-old-30.11 {arguments and defaults} {
|
||||
proc tproc {x {y y-default} args} {
|
||||
return [list $x $y $args]
|
||||
}
|
||||
tproc 2
|
||||
} {2 y-default {}}
|
||||
test proc-old-30.12 {arguments and defaults} {
|
||||
proc tproc {x {y y-default} args} {
|
||||
return [list $x $y $args]
|
||||
}
|
||||
list [catch {tproc} msg] $msg
|
||||
} {1 {wrong # args: should be "tproc x ?y? ..."}}
|
||||
|
||||
test proc-old-4.1 {variable numbers of arguments} {
|
||||
proc tproc args {return $args}
|
||||
tproc
|
||||
} {}
|
||||
test proc-old-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-old-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-old-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-old-4.5 {variable numbers of arguments} {
|
||||
proc tproc {x y args} {return $args}
|
||||
tproc 1 2
|
||||
} {}
|
||||
test proc-old-4.6 {variable numbers of arguments} {
|
||||
proc tproc {x missing args} {return $args}
|
||||
list [catch {tproc 1} msg] $msg
|
||||
} {1 {wrong # args: should be "tproc x missing ..."}}
|
||||
|
||||
test proc-old-5.1 {error conditions} {
|
||||
list [catch {proc} msg] $msg
|
||||
} {1 {wrong # args: should be "proc name args body"}}
|
||||
test proc-old-5.2 {error conditions} {
|
||||
list [catch {proc tproc b} msg] $msg
|
||||
} {1 {wrong # args: should be "proc name args body"}}
|
||||
test proc-old-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-old-5.4 {error conditions} {
|
||||
list [catch {proc tproc \{xyz {return foo}} msg] $msg
|
||||
} {1 {unmatched open brace in list}}
|
||||
test proc-old-5.5 {error conditions} {
|
||||
list [catch {proc tproc {{} y} {return foo}} msg] $msg
|
||||
} {1 {argument with no name}}
|
||||
test proc-old-5.6 {error conditions} {
|
||||
list [catch {proc tproc {{} y} {return foo}} msg] $msg
|
||||
} {1 {argument with no name}}
|
||||
test proc-old-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-old-5.8 {error conditions} {
|
||||
catch {return}
|
||||
} 2
|
||||
test proc-old-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-old-5.10 {error conditions} {
|
||||
list [catch {tproc} msg] $msg
|
||||
} {1 {variable "a" already exists}}
|
||||
test proc-old-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-old-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-old-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-old-5.14 {error conditions} {
|
||||
proc tproc {} {
|
||||
set a 22
|
||||
break
|
||||
return
|
||||
}
|
||||
catch tproc msg
|
||||
set ::errorInfo
|
||||
} {invoked "break" outside of a loop
|
||||
(procedure "tproc" line 1)
|
||||
invoked from within
|
||||
"tproc"}
|
||||
test proc-old-5.15 {error conditions} {
|
||||
proc tproc {} {
|
||||
set a 22
|
||||
continue
|
||||
return
|
||||
}
|
||||
catch tproc msg
|
||||
set ::errorInfo
|
||||
} {invoked "continue" outside of a loop
|
||||
(procedure "tproc" line 1)
|
||||
invoked from within
|
||||
"tproc"}
|
||||
test proc-old-5.16 {error conditions} {
|
||||
proc foo args {
|
||||
global fooMsg
|
||||
set fooMsg "foo was called: $args"
|
||||
}
|
||||
proc tproc {} {
|
||||
set x 44
|
||||
trace var x u foo
|
||||
while {$x < 100} {
|
||||
error "Nested error"
|
||||
}
|
||||
}
|
||||
set fooMsg "foo not called"
|
||||
list [catch tproc msg] $msg $::errorInfo $fooMsg
|
||||
} {1 {Nested error} {Nested error
|
||||
while executing
|
||||
"error "Nested error""
|
||||
(procedure "tproc" line 5)
|
||||
invoked from within
|
||||
"tproc"} {foo was called: x {} u}}
|
||||
|
||||
# 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-old-6.1 {procedure that redefines itself} {
|
||||
proc tproc {} {
|
||||
proc tproc {} {
|
||||
return 44
|
||||
}
|
||||
return 45
|
||||
}
|
||||
tproc
|
||||
} 45
|
||||
test proc-old-6.2 {procedure that deletes itself} {
|
||||
proc tproc {} {
|
||||
rename tproc {}
|
||||
return 45
|
||||
}
|
||||
tproc
|
||||
} 45
|
||||
|
||||
proc tproc code {
|
||||
return -code $code abc
|
||||
}
|
||||
test proc-old-7.1 {return with special completion code} {
|
||||
list [catch {tproc ok} msg] $msg
|
||||
} {0 abc}
|
||||
test proc-old-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-old-7.3 {return with special completion code} {
|
||||
list [catch {tproc return} msg] $msg
|
||||
} {2 abc}
|
||||
test proc-old-7.4 {return with special completion code} {
|
||||
list [catch {tproc break} msg] $msg
|
||||
} {3 abc}
|
||||
test proc-old-7.5 {return with special completion code} {
|
||||
list [catch {tproc continue} msg] $msg
|
||||
} {4 abc}
|
||||
test proc-old-7.6 {return with special completion code} {
|
||||
list [catch {tproc -14} msg] $msg
|
||||
} {-14 abc}
|
||||
test proc-old-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-old-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-old-7.9 {return with special completion code} {
|
||||
proc tproc2 {} {
|
||||
tproc return
|
||||
}
|
||||
list [catch tproc2 msg] $msg
|
||||
} {0 abc}
|
||||
test proc-old-7.10 {return with special completion code} {
|
||||
proc tproc2 {} {
|
||||
return -code error
|
||||
}
|
||||
list [catch tproc2 msg] $msg
|
||||
} {1 {}}
|
||||
test proc-old-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
|
||||
}
|
||||
set msg [list [catch tproc2 msg] $msg $::errorInfo $::errorCode]
|
||||
regsub -all [file join {} _bad_file_name] $msg "_bad_file_name" msg
|
||||
normalizeMsg $msg
|
||||
} {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-old-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
|
||||
}
|
||||
set msg [list [catch tproc2 msg] $msg $::errorInfo $::errorCode]
|
||||
regsub -all [file join {} _bad_file_name] $msg "_bad_file_name" msg
|
||||
normalizeMsg $msg
|
||||
} {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-old-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
|
||||
}
|
||||
set msg [list [catch tproc2 msg] $msg $::errorInfo $::errorCode]
|
||||
regsub -all [file join {} _bad_file_name] $msg "_bad_file_name" msg
|
||||
normalizeMsg $msg
|
||||
} {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-old-7.14 {return with special completion code} {
|
||||
proc tproc2 {} {
|
||||
global errorCode errorInfo
|
||||
catch {open _bad_file_name r} msg
|
||||
return -code error $msg
|
||||
}
|
||||
set msg [list [catch tproc2 msg] $msg $::errorInfo $::errorCode]
|
||||
regsub -all [file join {} _bad_file_name] $msg "_bad_file_name" msg
|
||||
normalizeMsg $msg
|
||||
} {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-old-7.15 {return with special completion code} {
|
||||
list [catch {return -badOption foo message} msg] $msg
|
||||
} {2 message}
|
||||
|
||||
test proc-old-8.1 {unset and undefined local arrays} {
|
||||
proc t1 {} {
|
||||
foreach v {xxx, yyy} {
|
||||
catch {unset $v}
|
||||
}
|
||||
set yyy(foo) bar
|
||||
}
|
||||
t1
|
||||
} bar
|
||||
|
||||
test proc-old-9.1 {empty command name} {
|
||||
catch {rename {} ""}
|
||||
proc t1 {args} {
|
||||
return
|
||||
}
|
||||
set v [t1]
|
||||
catch {$v}
|
||||
} 1
|
||||
|
||||
test proc-old-10.1 {ByteCode epoch change during recursive proc execution} {
|
||||
proc t1 x {
|
||||
set y 20
|
||||
rename expr expr.old
|
||||
rename expr.old expr
|
||||
if $x then {t1 0} ;# recursive call after foo's code is invalidated
|
||||
return 20
|
||||
}
|
||||
t1 1
|
||||
} 20
|
||||
|
||||
# cleanup
|
||||
catch {rename t1 ""}
|
||||
catch {rename foo ""}
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
408
tests/proc.test
Normal file
408
tests/proc.test
Normal file
@@ -0,0 +1,408 @@
|
||||
# This file contains tests for the tclProc.c source file. Tests appear in
|
||||
# the same order as the C code that they test. The set of tests is
|
||||
# currently incomplete since it includes only new tests, in particular
|
||||
# tests for code changed for the addition of Tcl namespaces. Other
|
||||
# procedure-related tests appear in other test files such as proc-old.test.
|
||||
#
|
||||
# Sourcing this file into Tcl runs the tests and generates output for
|
||||
# errors. No output means no errors were found.
|
||||
#
|
||||
# Copyright (c) 1997 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
if {[catch {package require procbodytest}]} {
|
||||
testConstraint procbodytest 0
|
||||
} else {
|
||||
testConstraint procbodytest 1
|
||||
}
|
||||
|
||||
testConstraint memory [llength [info commands memory]]
|
||||
|
||||
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
||||
catch {rename p ""}
|
||||
catch {rename {} ""}
|
||||
catch {unset msg}
|
||||
|
||||
test proc-1.1 {Tcl_ProcObjCmd, put proc in namespace specified in name, if any} {
|
||||
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
||||
namespace eval test_ns_1 {
|
||||
namespace eval baz {}
|
||||
}
|
||||
proc test_ns_1::baz::p {} {
|
||||
return "p in [namespace current]"
|
||||
}
|
||||
list [test_ns_1::baz::p] \
|
||||
[namespace eval test_ns_1 {baz::p}] \
|
||||
[info commands test_ns_1::baz::*]
|
||||
} {{p in ::test_ns_1::baz} {p in ::test_ns_1::baz} ::test_ns_1::baz::p}
|
||||
test proc-1.2 {Tcl_ProcObjCmd, namespace specified in proc name must exist} {
|
||||
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
||||
list [catch {proc test_ns_1::baz::p {} {}} msg] $msg
|
||||
} {1 {can't create procedure "test_ns_1::baz::p": unknown namespace}}
|
||||
test proc-1.3 {Tcl_ProcObjCmd, empty proc name} {
|
||||
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
||||
proc :: {} {
|
||||
return "empty called"
|
||||
}
|
||||
list [::] \
|
||||
[info body {}]
|
||||
} {{empty called} {
|
||||
return "empty called"
|
||||
}}
|
||||
test proc-1.4 {Tcl_ProcObjCmd, simple proc name and proc defined in namespace} {
|
||||
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
||||
namespace eval test_ns_1 {
|
||||
namespace eval baz {
|
||||
proc p {} {
|
||||
return "p in [namespace current]"
|
||||
}
|
||||
}
|
||||
}
|
||||
list [test_ns_1::baz::p] \
|
||||
[info commands test_ns_1::baz::*]
|
||||
} {{p in ::test_ns_1::baz} ::test_ns_1::baz::p}
|
||||
test proc-1.5 {Tcl_ProcObjCmd, qualified proc name and proc defined in namespace} {
|
||||
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
||||
namespace eval test_ns_1::baz {}
|
||||
namespace eval test_ns_1 {
|
||||
proc baz::p {} {
|
||||
return "p in [namespace current]"
|
||||
}
|
||||
}
|
||||
list [test_ns_1::baz::p] \
|
||||
[info commands test_ns_1::baz::*] \
|
||||
[namespace eval test_ns_1::baz {namespace which p}]
|
||||
} {{p in ::test_ns_1::baz} ::test_ns_1::baz::p ::test_ns_1::baz::p}
|
||||
test proc-1.6 {Tcl_ProcObjCmd, namespace code ignores single ":"s in middle or end of command names} {
|
||||
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
||||
namespace eval test_ns_1 {
|
||||
proc q: {} {return "q:"}
|
||||
proc value:at: {} {return "value:at:"}
|
||||
}
|
||||
list [namespace eval test_ns_1 {q:}] \
|
||||
[namespace eval test_ns_1 {value:at:}] \
|
||||
[test_ns_1::q:] \
|
||||
[test_ns_1::value:at:] \
|
||||
[lsort [info commands test_ns_1::*]] \
|
||||
[namespace eval test_ns_1 {namespace which q:}] \
|
||||
[namespace eval test_ns_1 {namespace which value:at:}]
|
||||
} {q: value:at: q: value:at: {::test_ns_1::q: ::test_ns_1::value:at:} ::test_ns_1::q: ::test_ns_1::value:at:}
|
||||
test proc-1.7 {Tcl_ProcObjCmd, check that formal parameter names are not array elements} {
|
||||
catch {rename p ""}
|
||||
list [catch {proc p {a(1) a(2)} {
|
||||
set z [expr $a(1)+$a(2)]
|
||||
puts "$z=z, $a(1)=$a(1)"
|
||||
}} msg] $msg
|
||||
} {1 {formal parameter "a(1)" is an array element}}
|
||||
test proc-1.8 {Tcl_ProcObjCmd, check that formal parameter names are simple names} {
|
||||
catch {rename p ""}
|
||||
list [catch {proc p {b:a b::a} {
|
||||
}} msg] $msg
|
||||
} {1 {formal parameter "b::a" is not a simple name}}
|
||||
|
||||
test proc-2.1 {TclFindProc, simple proc name and proc not in namespace} {
|
||||
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
||||
catch {rename p ""}
|
||||
proc p {} {return "p in [namespace current]"}
|
||||
info body p
|
||||
} {return "p in [namespace current]"}
|
||||
test proc-2.2 {TclFindProc, simple proc name and proc defined in namespace} {
|
||||
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
||||
namespace eval test_ns_1 {
|
||||
namespace eval baz {
|
||||
proc p {} {return "p in [namespace current]"}
|
||||
}
|
||||
}
|
||||
namespace eval test_ns_1::baz {info body p}
|
||||
} {return "p in [namespace current]"}
|
||||
test proc-2.3 {TclFindProc, qualified proc name and proc defined in namespace} {
|
||||
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
||||
namespace eval test_ns_1::baz {}
|
||||
namespace eval test_ns_1 {
|
||||
proc baz::p {} {return "p in [namespace current]"}
|
||||
}
|
||||
namespace eval test_ns_1 {info body baz::p}
|
||||
} {return "p in [namespace current]"}
|
||||
test proc-2.4 {TclFindProc, global proc and executing in namespace} {
|
||||
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
||||
catch {rename p ""}
|
||||
proc p {} {return "global p"}
|
||||
namespace eval test_ns_1::baz {info body p}
|
||||
} {return "global p"}
|
||||
|
||||
test proc-3.1 {TclObjInterpProc, proc defined and executing in same namespace} {
|
||||
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
||||
proc p {} {return "p in [namespace current]"}
|
||||
p
|
||||
} {p in ::}
|
||||
test proc-3.2 {TclObjInterpProc, proc defined and executing in same namespace} {
|
||||
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
||||
namespace eval test_ns_1::baz {
|
||||
proc p {} {return "p in [namespace current]"}
|
||||
p
|
||||
}
|
||||
} {p in ::test_ns_1::baz}
|
||||
test proc-3.3 {TclObjInterpProc, proc defined and executing in different namespaces} {
|
||||
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
||||
catch {rename p ""}
|
||||
proc p {} {return "p in [namespace current]"}
|
||||
namespace eval test_ns_1::baz {
|
||||
p
|
||||
}
|
||||
} {p in ::}
|
||||
test proc-3.4 {TclObjInterpProc, procs execute in the namespace in which they were defined unless renamed into new namespace} {
|
||||
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
||||
catch {rename p ""}
|
||||
namespace eval test_ns_1::baz {
|
||||
proc p {} {return "p in [namespace current]"}
|
||||
rename ::test_ns_1::baz::p ::p
|
||||
list [p] [namespace which p]
|
||||
}
|
||||
} {{p in ::} ::p}
|
||||
test proc-3.5 {TclObjInterpProc, any old result is reset before appending error msg about missing arguments} {
|
||||
proc p {x} {info commands 3m}
|
||||
list [catch {p} msg] $msg
|
||||
} {1 {wrong # args: should be "p x"}}
|
||||
|
||||
test proc-3.6 {TclObjInterpProc, proper quoting of proc name, Bug 942757} {
|
||||
proc {a b c} {x} {info commands 3m}
|
||||
list [catch {{a b c}} msg] $msg
|
||||
} {1 {wrong # args: should be "{a b c} x"}}
|
||||
|
||||
test proc-3.7 {TclObjInterpProc, wrong num args, Bug 3366265} {
|
||||
proc {} {x} {}
|
||||
list [catch {{}} msg] $msg
|
||||
} {1 {wrong # args: should be "{} x"}}
|
||||
|
||||
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
||||
catch {rename p ""}
|
||||
catch {rename {} ""}
|
||||
catch {rename {a b c} {}}
|
||||
catch {unset msg}
|
||||
|
||||
catch {rename p ""}
|
||||
catch {rename t ""}
|
||||
|
||||
# Note that the test require that procedures whose body is used to create
|
||||
# procbody objects must be executed before the procbodytest::proc command
|
||||
# is executed, so that the Proc struct is populated correctly (CompiledLocals
|
||||
# are added at compile time).
|
||||
|
||||
test proc-4.1 {TclCreateProc, procbody obj} procbodytest {
|
||||
catch {
|
||||
proc p x {return "$x:$x"}
|
||||
set rv [p P]
|
||||
procbodytest::proc t x p
|
||||
lappend rv [t T]
|
||||
set rv
|
||||
} result
|
||||
catch {rename p ""}
|
||||
catch {rename t ""}
|
||||
set result
|
||||
} {P:P T:T}
|
||||
test proc-4.2 {TclCreateProc, procbody obj, use compiled locals} procbodytest {
|
||||
catch {
|
||||
proc p x {
|
||||
set y [string tolower $x]
|
||||
return "$x:$y"
|
||||
}
|
||||
set rv [p P]
|
||||
procbodytest::proc t x p
|
||||
lappend rv [t T]
|
||||
set rv
|
||||
} result
|
||||
catch {rename p ""}
|
||||
catch {rename t ""}
|
||||
set result
|
||||
} {P:p T:t}
|
||||
test proc-4.3 {TclCreateProc, procbody obj, too many args} procbodytest {
|
||||
catch {
|
||||
proc p x {
|
||||
set y [string tolower $x]
|
||||
return "$x:$y"
|
||||
}
|
||||
set rv [p P]
|
||||
procbodytest::proc t {x x1 x2} p
|
||||
lappend rv [t T]
|
||||
set rv
|
||||
} result
|
||||
catch {rename p ""}
|
||||
catch {rename t ""}
|
||||
set result
|
||||
} {procedure "t": arg list contains 3 entries, precompiled header expects 1}
|
||||
test proc-4.4 {TclCreateProc, procbody obj, inconsistent arg name} procbodytest {
|
||||
catch {
|
||||
proc p {x y z} {
|
||||
set v [join [list $x $y $z]]
|
||||
set w [string tolower $v]
|
||||
return "$v:$w"
|
||||
}
|
||||
set rv [p P Q R]
|
||||
procbodytest::proc t {x x1 z} p
|
||||
lappend rv [t S T U]
|
||||
set rv
|
||||
} result
|
||||
catch {rename p ""}
|
||||
catch {rename t ""}
|
||||
set result
|
||||
} {procedure "t": formal parameter 1 is inconsistent with precompiled body}
|
||||
test proc-4.5 {TclCreateProc, procbody obj, inconsistent arg default type} procbodytest {
|
||||
catch {
|
||||
proc p {x y {z Z}} {
|
||||
set v [join [list $x $y $z]]
|
||||
set w [string tolower $v]
|
||||
return "$v:$w"
|
||||
}
|
||||
set rv [p P Q R]
|
||||
procbodytest::proc t {x y z} p
|
||||
lappend rv [t S T U]
|
||||
set rv
|
||||
} result
|
||||
catch {rename p ""}
|
||||
catch {rename t ""}
|
||||
set result
|
||||
} {procedure "t": formal parameter 2 is inconsistent with precompiled body}
|
||||
test proc-4.6 {TclCreateProc, procbody obj, inconsistent arg default type} procbodytest {
|
||||
catch {
|
||||
proc p {x y z} {
|
||||
set v [join [list $x $y $z]]
|
||||
set w [string tolower $v]
|
||||
return "$v:$w"
|
||||
}
|
||||
set rv [p P Q R]
|
||||
procbodytest::proc t {x y {z Z}} p
|
||||
lappend rv [t S T U]
|
||||
set rv
|
||||
} result
|
||||
catch {rename p ""}
|
||||
catch {rename t ""}
|
||||
set result
|
||||
} {procedure "t": formal parameter 2 is inconsistent with precompiled body}
|
||||
test proc-4.7 {TclCreateProc, procbody obj, inconsistent arg default value} procbodytest {
|
||||
catch {
|
||||
proc p {x y {z Z}} {
|
||||
set v [join [list $x $y $z]]
|
||||
set w [string tolower $v]
|
||||
return "$v:$w"
|
||||
}
|
||||
set rv [p P Q R]
|
||||
procbodytest::proc t {x y {z ZZ}} p
|
||||
lappend rv [t S T U]
|
||||
set rv
|
||||
} result
|
||||
catch {rename p ""}
|
||||
catch {rename t ""}
|
||||
set result
|
||||
} {procedure "t": formal parameter "z" has default value inconsistent with precompiled body}
|
||||
test proc-4.8 {TclCreateProc, procbody obj, no leak on multiple iterations} -setup {
|
||||
proc getbytes {} {
|
||||
set lines [split [memory info] "\n"]
|
||||
lindex $lines 3 3
|
||||
}
|
||||
proc px x {
|
||||
set y [string tolower $x]
|
||||
return "$x:$y"
|
||||
}
|
||||
px x
|
||||
} -constraints {procbodytest memory} -body {
|
||||
|
||||
set end [getbytes]
|
||||
for {set i 0} {$i < 5} {incr i} {
|
||||
|
||||
procbodytest::proc tx x px
|
||||
|
||||
set tmp $end
|
||||
set end [getbytes]
|
||||
}
|
||||
set leakedBytes [expr {$end - $tmp}]
|
||||
} -cleanup {
|
||||
rename getbytes {}
|
||||
unset -nocomplain end i tmp leakedBytes
|
||||
} -result 0
|
||||
|
||||
test proc-5.1 {Bytecompiling noop; test for correct argument substitution} {
|
||||
proc p args {} ; # this will be bytecompiled into t
|
||||
proc t {} {
|
||||
set res {}
|
||||
set a 0
|
||||
set b 0
|
||||
trace add variable a read {append res a ;#}
|
||||
trace add variable b write {append res b ;#}
|
||||
p $a ccccccw {bfe} {$a} [incr b] [incr a] {[incr b]} {$a} hello
|
||||
set res
|
||||
}
|
||||
set result [t]
|
||||
catch {rename p ""}
|
||||
catch {rename t ""}
|
||||
set result
|
||||
} {aba}
|
||||
|
||||
test proc-6.1 {ProcessProcResultCode: Bug 647307 (negative return code)} {
|
||||
proc a {} {return -code -5}
|
||||
proc b {} a
|
||||
set result [catch b]
|
||||
rename a {}
|
||||
rename b {}
|
||||
set result
|
||||
} -5
|
||||
|
||||
test proc-7.1 {Redefining a compiled cmd: Bug 729692} {
|
||||
proc bar args {}
|
||||
proc foo {} {
|
||||
proc bar args {return bar}
|
||||
bar
|
||||
}
|
||||
foo
|
||||
} bar
|
||||
|
||||
test proc-7.2 {Shadowing a compiled cmd: Bug 729692} {
|
||||
namespace eval ugly {}
|
||||
proc ugly::foo {} {
|
||||
proc set args {return bar}
|
||||
set x 1
|
||||
}
|
||||
set res [list [catch {ugly::foo} msg] $msg]
|
||||
namespace delete ugly
|
||||
set res
|
||||
} {0 bar}
|
||||
|
||||
test proc-7.3 {Returning loop exception from redefined cmd: Bug 729692} {
|
||||
namespace eval ugly {}
|
||||
proc ugly::foo {} {
|
||||
set i 0
|
||||
while { 1 } {
|
||||
if { [incr i] > 3 } {
|
||||
proc continue {} {return -code break}
|
||||
}
|
||||
continue
|
||||
}
|
||||
return $i
|
||||
}
|
||||
set res [list [catch {ugly::foo} msg] $msg]
|
||||
namespace delete ugly
|
||||
set res
|
||||
} {0 4}
|
||||
|
||||
test proc-7.4 {Proc struct outlives its interp: Bug 3532959} {
|
||||
set lambda x
|
||||
lappend lambda {set a 1}
|
||||
interp create slave
|
||||
slave eval [list apply $lambda foo]
|
||||
interp delete slave
|
||||
unset lambda
|
||||
} {}
|
||||
|
||||
|
||||
# cleanup
|
||||
catch {rename p ""}
|
||||
catch {rename t ""}
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
31
tests/pwd.test
Normal file
31
tests/pwd.test
Normal file
@@ -0,0 +1,31 @@
|
||||
# Commands covered: 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.
|
||||
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest 2
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
test pwd-1.1 {simple pwd} {
|
||||
catch pwd
|
||||
} 0
|
||||
test pwd-1.2 {simple pwd} {
|
||||
expr [string length pwd]>0
|
||||
} 1
|
||||
test pwd-1.3 {pwd takes no args} -body {
|
||||
pwd foobar
|
||||
} -returnCodes error -result "wrong \# args: should be \"pwd\""
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
1078
tests/reg.test
Normal file
1078
tests/reg.test
Normal file
File diff suppressed because it is too large
Load Diff
980
tests/regexp.test
Normal file
980
tests/regexp.test
Normal file
@@ -0,0 +1,980 @@
|
||||
# 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.
|
||||
# Copyright (c) 1998 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest 2
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
testConstraint exec [llength [info commands exec]]
|
||||
|
||||
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-1.5 {basic regexp operation} {
|
||||
regexp {^([^ ]*)[ ]*([^ ]*)} "" a
|
||||
} 1
|
||||
test regexp-1.6 {basic regexp operation} {
|
||||
list [catch {regexp {} abc} msg] $msg
|
||||
} {0 1}
|
||||
test regexp-1.7 {regexp utf compliance} {
|
||||
# if not UTF-8 aware, result is "0 1"
|
||||
set foo "\u4e4eb q"
|
||||
regexp "\u4e4eb q" "a\u4e4eb qw\u5e4e\x4e wq" bar
|
||||
list [string compare $foo $bar] [regexp 4 $bar]
|
||||
} {0 0}
|
||||
|
||||
test regexp-1.8 {regexp ***= metasyntax} {
|
||||
regexp -- "***=o" "aeiou"
|
||||
} 1
|
||||
test regexp-1.9 {regexp ***= metasyntax} {
|
||||
set string "aeiou"
|
||||
regexp -- "***=o" $string
|
||||
} 1
|
||||
test regexp-1.10 {regexp ***= metasyntax} {
|
||||
set string "aeiou"
|
||||
set re "***=o"
|
||||
regexp -- $re $string
|
||||
} 1
|
||||
test regexp-1.11 {regexp ***= metasyntax} {
|
||||
regexp -- "***=y" "aeiou"
|
||||
} 0
|
||||
test regexp-1.12 {regexp ***= metasyntax} {
|
||||
set string "aeiou"
|
||||
regexp -- "***=y" $string
|
||||
} 0
|
||||
test regexp-1.13 {regexp ***= metasyntax} {
|
||||
set string "aeiou"
|
||||
set re "***=y"
|
||||
regexp -- $re $string
|
||||
} 0
|
||||
|
||||
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 {}; set fa {}; set fb {};
|
||||
list [regexp (1*)(2*)(3*)(4*)(5*)(6*)(7*)(8*)(9*)(a*)(b*) \
|
||||
12223345556789999aabbb \
|
||||
foo f1 f2 f3 f4 f5 f6 f7 f8 f9 fa fb] $foo $f1 $f2 $f3 $f4 $f5 \
|
||||
$f6 $f7 $f8 $f9 $fa $fb
|
||||
} {1 12223345556789999aabbb 1 222 33 4 555 6 7 8 9999 aa bbb}
|
||||
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-2.8 {getting substrings back from regexp} {
|
||||
set match {}
|
||||
list [regexp {^a*b} aaaab match] $match
|
||||
} {1 aaaab}
|
||||
test regexp-2.9 {getting substrings back from regexp} {
|
||||
set foo {}
|
||||
set f2 {}
|
||||
list [regexp f\352te(b*)c f\352tebbbbc foo f2] $foo $f2
|
||||
} [list 1 f\352tebbbbc bbbb]
|
||||
test regexp-2.10 {getting substrings back from regexp} {
|
||||
set foo {}
|
||||
set f2 {}
|
||||
list [regexp f\352te(b*)c eff\352tebbbbc foo f2] $foo $f2
|
||||
} [list 1 f\352tebbbbc bbbb]
|
||||
|
||||
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 regexp} {
|
||||
list [regexp -nocase $x $x foo] $foo
|
||||
} "1 $x"
|
||||
catch {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 -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}}
|
||||
test regexp-6.4 {regexp errors} {
|
||||
list [catch {regexp a( b} msg] $msg
|
||||
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
|
||||
test regexp-6.5 {regexp errors} {
|
||||
list [catch {regexp a( b} msg] $msg
|
||||
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
|
||||
test regexp-6.6 {regexp errors} {
|
||||
list [catch {regexp a a f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1} msg] $msg
|
||||
} {0 1}
|
||||
test regexp-6.7 {regexp errors} {
|
||||
list [catch {regexp (x)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.) xyzzy} msg] $msg
|
||||
} {0 0}
|
||||
test regexp-6.8 {regexp errors} {
|
||||
catch {unset f1}
|
||||
set f1 44
|
||||
list [catch {regexp abc abc f1(f2)} msg] $msg
|
||||
} {1 {couldn't set variable "f1(f2)"}}
|
||||
test regexp-6.9 {regexp errors, -start bad int check} {
|
||||
list [catch {regexp -start bogus {^$} {}} msg] $msg
|
||||
} {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}}
|
||||
|
||||
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-7.17 {regsub utf compliance} {
|
||||
# if not UTF-8 aware, result is "0 1"
|
||||
set foo "xyz555ijka\u4e4ebpqr"
|
||||
regsub a\u4e4eb xyza\u4e4ebijka\u4e4ebpqr 555 bar
|
||||
list [string compare $foo $bar] [regexp 4 $bar]
|
||||
} {0 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
|
||||
} {4 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
|
||||
} {4 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
|
||||
} {2 {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 {expanded syntax in regsub} {
|
||||
set foo xxx
|
||||
list [regsub -expanded ". \#comment\n . \#comment2" abc def foo] $foo
|
||||
} {1 defc}
|
||||
test regexp-10.2 {newline sensitivity in regsub} {
|
||||
set foo xxx
|
||||
list [regsub -line {^a.*b$} "dabc\naxyb\n" 123 foo] $foo
|
||||
} "1 {dabc\n123\n}"
|
||||
test regexp-10.3 {newline sensitivity in regsub} {
|
||||
set foo xxx
|
||||
list [regsub -line {^a.*b$} "dabc\naxyb\nxb" 123 foo] $foo
|
||||
} "1 {dabc\n123\nxb}"
|
||||
test regexp-10.4 {partial newline sensitivity in regsub} {
|
||||
set foo xxx
|
||||
list [regsub -lineanchor {^a.*b$} "da\naxyb\nxb" 123 foo] $foo
|
||||
} "1 {da\n123}"
|
||||
test regexp-10.5 {inverse partial newline sensitivity in regsub} {
|
||||
set foo xxx
|
||||
list [regsub -linestop {a.*b} "da\nbaxyb\nxb" 123 foo] $foo
|
||||
} "1 {da\nb123\nxb}"
|
||||
|
||||
test regexp-11.1 {regsub errors} {
|
||||
list [catch {regsub a b} msg] $msg
|
||||
} {1 {wrong # args: should be "regsub ?switches? exp string subSpec ?varName?"}}
|
||||
test regexp-11.2 {regsub errors} {
|
||||
list [catch {regsub -nocase a b} msg] $msg
|
||||
} {1 {wrong # args: should be "regsub ?switches? exp string subSpec ?varName?"}}
|
||||
test regexp-11.3 {regsub errors} {
|
||||
list [catch {regsub -nocase -all a b} msg] $msg
|
||||
} {1 {wrong # args: should be "regsub ?switches? exp string subSpec ?varName?"}}
|
||||
test regexp-11.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-11.5 {regsub errors} {
|
||||
list [catch {regsub -gorp a b c} msg] $msg
|
||||
} {1 {bad switch "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}}
|
||||
test regexp-11.6 {regsub errors} {
|
||||
list [catch {regsub -nocase a( b c d} msg] $msg
|
||||
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
|
||||
test regexp-11.7 {regsub errors} {
|
||||
catch {unset f1}
|
||||
set f1 44
|
||||
list [catch {regsub -nocase aaa aaa xxx f1(f2)} msg] $msg
|
||||
} {1 {couldn't set variable "f1(f2)"}}
|
||||
test regexp-11.8 {regsub errors, -start bad int check} {
|
||||
list [catch {regsub -start bogus pattern string rep var} msg] $msg
|
||||
} {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}}
|
||||
test regexp-11.9 {regsub without final variable name returns value} {
|
||||
regsub b abaca X
|
||||
} {aXaca}
|
||||
test regexp-11.10 {regsub without final variable name returns value} {
|
||||
regsub -all a abaca X
|
||||
} {XbXcX}
|
||||
test regexp-11.11 {regsub without final variable name returns value} {
|
||||
regsub b(.*?)d abcdeabcfde {,&,\1,}
|
||||
} {a,bcd,c,eabcfde}
|
||||
test regexp-11.12 {regsub without final variable name returns value} {
|
||||
regsub -all b(.*?)d abcdeabcfde {,&,\1,}
|
||||
} {a,bcd,c,ea,bcfd,cf,e}
|
||||
|
||||
# This test crashes on the Mac unless you increase the Stack Space to about 1
|
||||
# Meg. This is probably bigger than most users want...
|
||||
# 8.2.3 regexp reduced stack space requirements, but this should be
|
||||
# tested again
|
||||
test regexp-12.1 {Tcl_RegExpExec: large number of subexpressions} {macCrash} {
|
||||
list [regexp (.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.) abcdefghijklmnopqrstuvwxyz all 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] $all $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
|
||||
} {1 abcdefghijklmnopqrstuvwxyz 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}
|
||||
|
||||
test regexp-13.1 {regsub of a very large string} {
|
||||
# This test is designed to stress the memory subsystem in order
|
||||
# to catch Bug #933. It only fails if the Tcl memory allocator
|
||||
# is in use.
|
||||
|
||||
set line {BEGIN_TABLE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; END_TABLE}
|
||||
set filedata [string repeat $line 200]
|
||||
for {set i 1} {$i<10} {incr i} {
|
||||
regsub -all "BEGIN_TABLE " $filedata "" newfiledata
|
||||
}
|
||||
set x done
|
||||
} {done}
|
||||
|
||||
test regexp-14.1 {CompileRegexp: regexp cache} {
|
||||
regexp .*a b
|
||||
regexp .*b c
|
||||
regexp .*c d
|
||||
regexp .*d e
|
||||
regexp .*e f
|
||||
set x .
|
||||
append x *a
|
||||
regexp $x bbba
|
||||
} 1
|
||||
test regexp-14.2 {CompileRegexp: regexp cache, different flags} {
|
||||
regexp .*a b
|
||||
regexp .*b c
|
||||
regexp .*c d
|
||||
regexp .*d e
|
||||
regexp .*e f
|
||||
set x .
|
||||
append x *a
|
||||
regexp -nocase $x bbba
|
||||
} 1
|
||||
test regexp-14.3 {CompileRegexp: regexp cache, empty regexp and empty cache} -constraints {
|
||||
exec
|
||||
} -setup {
|
||||
set junk [makeFile {puts [regexp {} foo]} junk.tcl]
|
||||
} -body {
|
||||
exec [interpreter] $junk
|
||||
} -cleanup {
|
||||
removeFile junk.tcl
|
||||
} -result 1
|
||||
|
||||
test regexp-15.1 {regexp -start} {
|
||||
catch {unset x}
|
||||
list [regexp -start -10 {\d} 1abc2de3 x] $x
|
||||
} {1 1}
|
||||
test regexp-15.2 {regexp -start} {
|
||||
catch {unset x}
|
||||
list [regexp -start 2 {\d} 1abc2de3 x] $x
|
||||
} {1 2}
|
||||
test regexp-15.3 {regexp -start} {
|
||||
catch {unset x}
|
||||
list [regexp -start 4 {\d} 1abc2de3 x] $x
|
||||
} {1 2}
|
||||
test regexp-15.4 {regexp -start} {
|
||||
catch {unset x}
|
||||
list [regexp -start 5 {\d} 1abc2de3 x] $x
|
||||
} {1 3}
|
||||
test regexp-15.5 {regexp -start, over end of string} {
|
||||
catch {unset x}
|
||||
list [regexp -start [string length 1abc2de3] {\d} 1abc2de3 x] [info exists x]
|
||||
} {0 0}
|
||||
test regexp-15.6 {regexp -start, loss of ^$ behavior} {
|
||||
list [regexp -start 2 {^$} {}]
|
||||
} {0}
|
||||
test regexp-15.7 {regexp -start, double option} {
|
||||
regexp -start 2 -start 0 a abc
|
||||
} 1
|
||||
test regexp-15.8 {regexp -start, double option} {
|
||||
regexp -start 0 -start 2 a abc
|
||||
} 0
|
||||
test regexp-15.9 {regexp -start, end relative index} {
|
||||
catch {unset x}
|
||||
list [regexp -start end {\d} 1abc2de3 x] [info exists x]
|
||||
} {0 0}
|
||||
test regexp-15.10 {regexp -start, end relative index} {
|
||||
catch {unset x}
|
||||
list [regexp -start end-1 {\d} 1abc2de3 x] [info exists x] $x
|
||||
} {1 1 3}
|
||||
|
||||
test regexp-16.1 {regsub -start} {
|
||||
catch {unset x}
|
||||
list [regsub -all -start 2 {\d} a1b2c3d4e5 {/&} x] $x
|
||||
} {4 a1b/2c/3d/4e/5}
|
||||
test regexp-16.2 {regsub -start} {
|
||||
catch {unset x}
|
||||
list [regsub -all -start -25 {z} hello {/&} x] $x
|
||||
} {0 hello}
|
||||
test regexp-16.3 {regsub -start} {
|
||||
catch {unset x}
|
||||
list [regsub -all -start 3 {z} hello {/&} x] $x
|
||||
} {0 hello}
|
||||
test regexp-16.4 {regsub -start, \A behavior} {
|
||||
set out {}
|
||||
lappend out [regsub -start 0 -all {\A(\w)} {abcde} {/\1} x] $x
|
||||
lappend out [regsub -start 2 -all {\A(\w)} {abcde} {/\1} x] $x
|
||||
} {5 /a/b/c/d/e 3 ab/c/d/e}
|
||||
test regexp-16.5 {regsub -start, double option} {
|
||||
list [regsub -start 2 -start 0 a abc c x] $x
|
||||
} {1 cbc}
|
||||
test regexp-16.6 {regsub -start, double option} {
|
||||
list [regsub -start 0 -start 2 a abc c x] $x
|
||||
} {0 abc}
|
||||
test regexp-16.7 {regexp -start, end relative index} {
|
||||
list [regsub -start end a aaa b x] $x
|
||||
} {0 aaa}
|
||||
test regexp-16.8 {regexp -start, end relative index} {
|
||||
list [regsub -start end-1 a aaa b x] $x
|
||||
} {1 aab}
|
||||
|
||||
test regexp-17.1 {regexp -inline} {
|
||||
regexp -inline b ababa
|
||||
} {b}
|
||||
test regexp-17.2 {regexp -inline} {
|
||||
regexp -inline (b) ababa
|
||||
} {b b}
|
||||
test regexp-17.3 {regexp -inline -indices} {
|
||||
regexp -inline -indices (b) ababa
|
||||
} {{1 1} {1 1}}
|
||||
test regexp-17.4 {regexp -inline} {
|
||||
regexp -inline {\w(\d+)\w} " hello 23 there456def "
|
||||
} {e456d 456}
|
||||
test regexp-17.5 {regexp -inline no matches} {
|
||||
regexp -inline {\w(\d+)\w} ""
|
||||
} {}
|
||||
test regexp-17.6 {regexp -inline no matches} {
|
||||
regexp -inline hello goodbye
|
||||
} {}
|
||||
test regexp-17.7 {regexp -inline, no matchvars allowed} {
|
||||
list [catch {regexp -inline b abc match} msg] $msg
|
||||
} {1 {regexp match variables not allowed when using -inline}}
|
||||
|
||||
test regexp-18.1 {regexp -all} {
|
||||
regexp -all b bbbbb
|
||||
} {5}
|
||||
test regexp-18.2 {regexp -all} {
|
||||
regexp -all b abababbabaaaaaaaaaab
|
||||
} {6}
|
||||
test regexp-18.3 {regexp -all -inline} {
|
||||
regexp -all -inline b abababbabaaaaaaaaaab
|
||||
} {b b b b b b}
|
||||
test regexp-18.4 {regexp -all -inline} {
|
||||
regexp -all -inline {\w(\w)} abcdefg
|
||||
} {ab b cd d ef f}
|
||||
test regexp-18.5 {regexp -all -inline} {
|
||||
regexp -all -inline {\w(\w)$} abcdefg
|
||||
} {fg g}
|
||||
test regexp-18.6 {regexp -all -inline} {
|
||||
regexp -all -inline {\d+} 10:20:30:40
|
||||
} {10 20 30 40}
|
||||
test regexp-18.7 {regexp -all -inline} {
|
||||
list [catch {regexp -all -inline b abc match} msg] $msg
|
||||
} {1 {regexp match variables not allowed when using -inline}}
|
||||
test regexp-18.8 {regexp -all} {
|
||||
# This should not cause an infinite loop
|
||||
regexp -all -inline {a*} a
|
||||
} {a}
|
||||
test regexp-18.9 {regexp -all} {
|
||||
# Yes, the expected result is {a {}}. Here's why:
|
||||
# Start at index 0; a* matches the "a" there then stops.
|
||||
# Go to index 1; a* matches the lambda (or {}) there then stops. Recall
|
||||
# that a* matches zero or more "a"'s; thus it matches the string "b", as
|
||||
# there are zero or more "a"'s there.
|
||||
# Go to index 2; this is past the end of the string, so stop.
|
||||
regexp -all -inline {a*} ab
|
||||
} {a {}}
|
||||
test regexp-18.10 {regexp -all} {
|
||||
# Yes, the expected result is {a {} a}. Here's why:
|
||||
# Start at index 0; a* matches the "a" there then stops.
|
||||
# Go to index 1; a* matches the lambda (or {}) there then stops. Recall
|
||||
# that a* matches zero or more "a"'s; thus it matches the string "b", as
|
||||
# there are zero or more "a"'s there.
|
||||
# Go to index 2; a* matches the "a" there then stops.
|
||||
# Go to index 3; this is past the end of the string, so stop.
|
||||
regexp -all -inline {a*} aba
|
||||
} {a {} a}
|
||||
test regexp-18.11 {regexp -all} {
|
||||
regexp -all -inline {^a} aaaa
|
||||
} {a}
|
||||
test regexp-18.12 {regexp -all -inline -indices} {
|
||||
regexp -all -inline -indices a(b(c)d|e(f)g)h abcdhaefgh
|
||||
} {{0 4} {1 3} {2 2} {-1 -1} {5 9} {6 8} {-1 -1} {7 7}}
|
||||
|
||||
test regexp-19.1 {regsub null replacement} {
|
||||
regsub -all {@} {@hel@lo@} "\0a\0" result
|
||||
list $result [string length $result]
|
||||
} "\0a\0hel\0a\0lo\0a\0 14"
|
||||
|
||||
test regexp-20.1 {regsub shared object shimmering} {
|
||||
# Bug #461322
|
||||
set a abcdefghijklmnopqurstuvwxyz
|
||||
set b $a
|
||||
set c abcdefghijklmnopqurstuvwxyz0123456789
|
||||
regsub $a $c $b d
|
||||
list $d [string length $d] [string bytelength $d]
|
||||
} {abcdefghijklmnopqurstuvwxyz0123456789 37 37}
|
||||
test regexp-20.2 {regsub shared object shimmering with -about} {
|
||||
eval regexp -about abc
|
||||
} {0 {}}
|
||||
|
||||
test regexp-21.1 {regsub works with empty string} {
|
||||
regsub -- ^ {} foo
|
||||
} {foo}
|
||||
test regexp-21.2 {regsub works with empty string} {
|
||||
regsub -- \$ {} foo
|
||||
} {foo}
|
||||
test regexp-21.3 {regsub works with empty string offset} {
|
||||
regsub -start 0 -- ^ {} foo
|
||||
} {foo}
|
||||
test regexp-21.4 {regsub works with empty string offset} {
|
||||
regsub -start 0 -- \$ {} foo
|
||||
} {foo}
|
||||
test regexp-21.5 {regsub works with empty string offset} {
|
||||
regsub -start 3 -- \$ {123} foo
|
||||
} {123foo}
|
||||
test regexp-21.6 {regexp works with empty string} {
|
||||
regexp -- ^ {}
|
||||
} {1}
|
||||
test regexp-21.7 {regexp works with empty string} {
|
||||
regexp -start 0 -- ^ {}
|
||||
} {1}
|
||||
test regexp-21.8 {regexp works with empty string offset} {
|
||||
regexp -start 3 -- ^ {123}
|
||||
} {0}
|
||||
test regexp-21.9 {regexp works with empty string offset} {
|
||||
regexp -start 3 -- \$ {123}
|
||||
} {1}
|
||||
test regexp-21.10 {multiple matches handle newlines} {
|
||||
regsub -all -lineanchor -- {^#[^\n]*\n} "#one\n#two\n#three\n" foo\n
|
||||
} "foo\nfoo\nfoo\n"
|
||||
test regexp-21.11 {multiple matches handle newlines} {
|
||||
regsub -all -line -- ^ "a\nb\nc" \#
|
||||
} "\#a\n\#b\n\#c"
|
||||
test regexp-21.12 {multiple matches handle newlines} {
|
||||
regsub -all -line -- ^ "\n\n" \#
|
||||
} "\#\n\#\n\#"
|
||||
test regexp-21.13 {multiple matches handle newlines} {
|
||||
regexp -all -inline -indices -line -- ^ "a\nb\nc"
|
||||
} {{0 -1} {2 1} {4 3}}
|
||||
|
||||
test regexp-22.1 {Bug 1810038} {
|
||||
regexp ($|^X)* {}
|
||||
} 1
|
||||
test regexp-22.2 {regexp compile and backrefs, Bug 1857126} {
|
||||
regexp -- {([bc])\1} bb
|
||||
} 1
|
||||
test regexp-22.3 {Bug 3604074} {
|
||||
# This will hang in interps where the bug is not fixed
|
||||
regexp ((((((((a)*)*)*)*)*)*)*)* a
|
||||
} 1
|
||||
test regexp-22.4 {Bug 3606139} -setup {
|
||||
interp alias {} a {} string repeat a
|
||||
} -body {
|
||||
# This crashes in interps where the bug is not fixed
|
||||
regexp [join [list [a 160]([a 55])[a 668]([a 55])[a 669]([a 55]) \
|
||||
[a 668]([a 55])[a 649]([a 55])[a 668]([a 55])[a 668]([a 55]) \
|
||||
[a 672]([a 55])[a 669]([a 55])[a 671]([a 55])[a 671]([a 55]) \
|
||||
[a 672]([a 55])[a 652]([a 55])[a 672]([a 55])[a 671]([a 55]) \
|
||||
[a 671]([a 55])[a 671]([a 55])[a 653]([a 55])[a 672]([a 55]) \
|
||||
[a 653]([a 55])[a 672]([a 55])[a 672]([a 55])[a 652]([a 55]) \
|
||||
[a 671]([a 55])[a 652]([a 55])[a 652]([a 55])[a 672]([a 55]) \
|
||||
[a 672]([a 55])[a 672]([a 55])[a 653]([a 55])[a 671]([a 55]) \
|
||||
[a 669]([a 55])[a 649]([a 55])[a 668]([a 55])[a 668]([a 55]) \
|
||||
[a 668]([a 55])[a 650]([a 55])[a 650]([a 55])[a 672]([a 55]) \
|
||||
[a 669]([a 55])[a 669]([a 55])[a 668]([a 55])[a 668]([a 55]) \
|
||||
[a 668]([a 55])[a 669]([a 55])[a 672]([a 55])[a 669]([a 55]) \
|
||||
[a 669]([a 55])[a 669]([a 55])[a 669]([a 55])[a 672]([a 55]) \
|
||||
[a 670]([a 55])[a 671]([a 55])[a 672]([a 55])[a 672]([a 55]) \
|
||||
[a 671]([a 55])[a 671]([a 55])[a 672]([a 55])[a 669]([a 55]) \
|
||||
[a 668]([a 55])[a 668]([a 55])[a 669]([a 55])[a 668]([a 55]) \
|
||||
[a 669]([a 55])[a 668]([a 55])[a 669]([a 55])[a 669]([a 55]) \
|
||||
[a 668]([a 55])[a 668]([a 55])[a 669]([a 55])[a 668]([a 55]) \
|
||||
[a 669]([a 55])[a 669]([a 55])[a 669]([a 55])[a 669]([a 55]) \
|
||||
[a 668]([a 55])[a 669]([a 55])[a 672]([a 55])[a 669]([a 55]) \
|
||||
[a 669]([a 55])[a 669]([a 55])[a 669]([a 55])[a 668]([a 55]) \
|
||||
[a 669]([a 55])[a 669]([a 55])[a 668]([a 55])[a 668]([a 55]) \
|
||||
[a 668]([a 55])[a 669]([a 55])[a 668]([a 55])[a 669]([a 55]) \
|
||||
[a 672]([a 55])[a 669]([a 55])[a 669]([a 55])[a 710]([a 55]) \
|
||||
[a 668]([a 55])[a 669]([a 55])[a 668]([a 55])[a 669]([a 55]) \
|
||||
[a 668]([a 55])[a 669]([a 55])[a 668]([a 55])[a 668]([a 55]) \
|
||||
[a 668]([a 55])[a 668]([a 55])[a 668]([a 55])[a 669]([a 55]) \
|
||||
[a 672]([a 55])[a 669]([a 55])[a 669]([a 55])[a 668]([a 55]) \
|
||||
[a 669]([a 55])[a 669]([a 55])[a 668]([a 55])[a 668]([a 55]) \
|
||||
[a 668]([a 55])[a 668]([a 55])[a 668]([a 55])[a 668]([a 55]) \
|
||||
[a 667]([a 55])[a 668]([a 55])[a 669]([a 55])[a 668]([a 55]) \
|
||||
[a 671]([a 55])[a 669]([a 55])[a 668]([a 55])[a 669]([a 55]) \
|
||||
[a 669]([a 55])[a 669]([a 55])[a 668]([a 55])[a 669]([a 55]) \
|
||||
[a 668]([a 55])[a 710]([a 55])[a 668]([a 55])[a 668]([a 55]) \
|
||||
[a 668]([a 55])[a 668]([a 55])[a 668]([a 55])[a 511]] {}] a
|
||||
} -cleanup {
|
||||
rename a {}
|
||||
} -returnCodes 1 -result {couldn't compile regular expression pattern: nfa has too many states}
|
||||
test regexp-22.5 {Bug 3610026} -setup {
|
||||
set e {}
|
||||
set cp 99
|
||||
while {$cp < 32864} {
|
||||
append e [format %c [incr cp]]
|
||||
}
|
||||
} -body {
|
||||
regexp -about $e
|
||||
} -cleanup {
|
||||
unset -nocomplain e cp
|
||||
} -returnCodes error -match glob -result {*too many colors*}
|
||||
test regexp-22.6 {Bug 6585b21ca8} {
|
||||
expr {[regexp {(\w).*?\1} Programmer m] ? $m : "<NONE>"}
|
||||
} rogr
|
||||
|
||||
|
||||
test regexp-23.1 {regexp -all and -line} {
|
||||
set string ""
|
||||
list \
|
||||
[regexp -all -inline -indices -line -- {^} $string] \
|
||||
[regexp -all -inline -indices -line -- {^$} $string] \
|
||||
[regexp -all -inline -indices -line -- {$} $string]
|
||||
} {{{0 -1}} {{0 -1}} {{0 -1}}}
|
||||
test regexp-23.2 {regexp -all and -line} {
|
||||
set string "\n"
|
||||
list \
|
||||
[regexp -all -inline -indices -line -- {^} $string] \
|
||||
[regexp -all -inline -indices -line -- {^$} $string] \
|
||||
[regexp -all -inline -indices -line -- {$} $string]
|
||||
} {{{0 -1}} {{0 -1}} {{0 -1}}}
|
||||
test regexp-23.3 {regexp -all and -line} {
|
||||
set string "\n\n"
|
||||
list \
|
||||
[regexp -all -inline -indices -line -- {^} $string] \
|
||||
[regexp -all -inline -indices -line -- {^$} $string] \
|
||||
[regexp -all -inline -indices -line -- {$} $string]
|
||||
} {{{0 -1} {1 0}} {{0 -1} {1 0}} {{0 -1} {1 0}}}
|
||||
test regexp-23.4 {regexp -all and -line} {
|
||||
set string "a"
|
||||
list \
|
||||
[regexp -all -inline -indices -line -- {^} $string] \
|
||||
[regexp -all -inline -indices -line -- {^.*$} $string] \
|
||||
[regexp -all -inline -indices -line -- {$} $string]
|
||||
} {{{0 -1}} {{0 0}} {{1 0}}}
|
||||
test regexp-23.5 {regexp -all and -line} {knownBug} {
|
||||
set string "a\n"
|
||||
list \
|
||||
[regexp -all -inline -indices -line -- {^} $string] \
|
||||
[regexp -all -inline -indices -line -- {^.*$} $string] \
|
||||
[regexp -all -inline -indices -line -- {$} $string]
|
||||
} {{{0 -1} {2 1}} {{0 0} {2 1}} {{1 0} {2 1}}}
|
||||
test regexp-23.6 {regexp -all and -line} {
|
||||
set string "\na"
|
||||
list \
|
||||
[regexp -all -inline -indices -line -- {^} $string] \
|
||||
[regexp -all -inline -indices -line -- {^.*$} $string] \
|
||||
[regexp -all -inline -indices -line -- {$} $string]
|
||||
} {{{0 -1} {1 0}} {{0 -1} {1 1}} {{0 -1} {2 1}}}
|
||||
test regexp-23.7 {regexp -all and -line} {knownBug} {
|
||||
set string "ab\n"
|
||||
list \
|
||||
[regexp -all -inline -indices -line -- {^} $string] \
|
||||
[regexp -all -inline -indices -line -- {^.*$} $string] \
|
||||
[regexp -all -inline -indices -line -- {$} $string]
|
||||
} {{{0 -1} {3 2}} {{0 1} {3 2}} {{2 1} {3 2}}}
|
||||
test regexp-23.8 {regexp -all and -line} {
|
||||
set string "a\nb"
|
||||
list \
|
||||
[regexp -all -inline -indices -line -- {^} $string] \
|
||||
[regexp -all -inline -indices -line -- {^.*$} $string] \
|
||||
[regexp -all -inline -indices -line -- {$} $string]
|
||||
} {{{0 -1} {2 1}} {{0 0} {2 2}} {{1 0} {3 2}}}
|
||||
test regexp-23.9 {regexp -all and -line} {knownBug} {
|
||||
set string "a\nb\n"
|
||||
list \
|
||||
[regexp -all -inline -indices -line -- {^} $string] \
|
||||
[regexp -all -inline -indices -line -- {^.*$} $string] \
|
||||
[regexp -all -inline -indices -line -- {$} $string]
|
||||
} {{{0 -1} {2 1} {4 3}} {{0 0} {2 2} {4 3}} {{1 0} {3 2} {4 3}}}
|
||||
test regexp-23.10 {regexp -all and -line} {
|
||||
set string "a\nb\nc"
|
||||
list \
|
||||
[regexp -all -inline -indices -line -- {^} $string] \
|
||||
[regexp -all -inline -indices -line -- {^.*$} $string] \
|
||||
[regexp -all -inline -indices -line -- {$} $string]
|
||||
} {{{0 -1} {2 1} {4 3}} {{0 0} {2 2} {4 4}} {{1 0} {3 2} {5 4}}}
|
||||
test regexp-23.11 {regexp -all and -line} {
|
||||
regexp -all -inline -indices -line -- {b} "abb\nb"
|
||||
} {{1 1} {2 2} {4 4}}
|
||||
|
||||
test regexp-24.1 {regsub -all and -line} {
|
||||
foreach {v1 v2 v3} {{} {} {}} {}
|
||||
set string ""
|
||||
list \
|
||||
[regsub -line -all {^} $string {<&>} v1] $v1 \
|
||||
[regsub -line -all {^$} $string {<&>} v2] $v2 \
|
||||
[regsub -line -all {$} $string {<&>} v3] $v3
|
||||
} {1 <> 1 <> 1 <>}
|
||||
test regexp-24.2 {regsub -all and -line} {
|
||||
foreach {v1 v2 v3} {{} {} {}} {}
|
||||
set string "\n"
|
||||
list \
|
||||
[regsub -line -all {^} $string {<&>} v1] $v1 \
|
||||
[regsub -line -all {^$} $string {<&>} v2] $v2 \
|
||||
[regsub -line -all {$} $string {<&>} v3] $v3
|
||||
} "2 {<>\n<>} 2 {<>\n<>} 2 {<>\n<>}"
|
||||
test regexp-24.3 {regsub -all and -line} {
|
||||
foreach {v1 v2 v3} {{} {} {}} {}
|
||||
set string "\n\n"
|
||||
list \
|
||||
[regsub -line -all {^} $string {<&>} v1] $v1 \
|
||||
[regsub -line -all {^$} $string {<&>} v2] $v2 \
|
||||
[regsub -line -all {$} $string {<&>} v3] $v3
|
||||
} "3 {<>\n<>\n<>} 3 {<>\n<>\n<>} 3 {<>\n<>\n<>}"
|
||||
test regexp-24.4 {regsub -all and -line} {
|
||||
foreach {v1 v2 v3} {{} {} {}} {}
|
||||
set string "a"
|
||||
list \
|
||||
[regsub -line -all {^} $string {<&>} v1] $v1 \
|
||||
[regsub -line -all {^.*$} $string {<&>} v2] $v2 \
|
||||
[regsub -line -all {$} $string {<&>} v3] $v3
|
||||
} {1 <>a 1 <a> 1 a<>}
|
||||
test regexp-24.5 {regsub -all and -line} {
|
||||
foreach {v1 v2 v3} {{} {} {}} {}
|
||||
set string "a\n"
|
||||
list \
|
||||
[regsub -line -all {^} $string {<&>} v1] $v1 \
|
||||
[regsub -line -all {^.*$} $string {<&>} v2] $v2 \
|
||||
[regsub -line -all {$} $string {<&>} v3] $v3
|
||||
} "2 {<>a\n<>} 2 {<a>\n<>} 2 {a<>\n<>}"
|
||||
test regexp-24.6 {regsub -all and -line} {
|
||||
foreach {v1 v2 v3} {{} {} {}} {}
|
||||
set string "\na"
|
||||
list \
|
||||
[regsub -line -all {^} $string {<&>} v1] $v1 \
|
||||
[regsub -line -all {^.*$} $string {<&>} v2] $v2 \
|
||||
[regsub -line -all {$} $string {<&>} v3] $v3
|
||||
} "2 {<>\n<>a} 2 {<>\n<a>} 2 {<>\na<>}"
|
||||
test regexp-24.7 {regsub -all and -line} {
|
||||
foreach {v1 v2 v3} {{} {} {}} {}
|
||||
set string "ab\n"
|
||||
list \
|
||||
[regsub -line -all {^} $string {<&>} v1] $v1 \
|
||||
[regsub -line -all {^.*$} $string {<&>} v2] $v2 \
|
||||
[regsub -line -all {$} $string {<&>} v3] $v3
|
||||
} "2 {<>ab\n<>} 2 {<ab>\n<>} 2 {ab<>\n<>}"
|
||||
test regexp-24.8 {regsub -all and -line} {
|
||||
foreach {v1 v2 v3} {{} {} {}} {}
|
||||
set string "a\nb"
|
||||
list \
|
||||
[regsub -line -all {^} $string {<&>} v1] $v1 \
|
||||
[regsub -line -all {^.*$} $string {<&>} v2] $v2 \
|
||||
[regsub -line -all {$} $string {<&>} v3] $v3
|
||||
} "2 {<>a\n<>b} 2 {<a>\n<b>} 2 {a<>\nb<>}"
|
||||
test regexp-24.9 {regsub -all and -line} {
|
||||
foreach {v1 v2 v3} {{} {} {}} {}
|
||||
set string "a\nb\n"
|
||||
list \
|
||||
[regsub -line -all {^} $string {<&>} v1] $v1 \
|
||||
[regsub -line -all {^.*$} $string {<&>} v2] $v2 \
|
||||
[regsub -line -all {$} $string {<&>} v3] $v3
|
||||
} "3 {<>a\n<>b\n<>} 3 {<a>\n<b>\n<>} 3 {a<>\nb<>\n<>}"
|
||||
test regexp-24.10 {regsub -all and -line} {
|
||||
foreach {v1 v2 v3} {{} {} {}} {}
|
||||
set string "a\nb\nc"
|
||||
list \
|
||||
[regsub -line -all {^} $string {<&>} v1] $v1 \
|
||||
[regsub -line -all {^.*$} $string {<&>} v2] $v2 \
|
||||
[regsub -line -all {$} $string {<&>} v3] $v3
|
||||
} "3 {<>a\n<>b\n<>c} 3 {<a>\n<b>\n<c>} 3 {a<>\nb<>\nc<>}"
|
||||
test regexp-24.11 {regsub -all and -line} {
|
||||
regsub -line -all {b} "abb\nb" {<&>}
|
||||
} "a<b><b>\n<b>"
|
||||
|
||||
test regexp-25.1 {regexp without -line option} {
|
||||
set foo ""
|
||||
list [regexp {a.*b} "dabc\naxyb\n" foo] $foo
|
||||
} "1 {abc\naxyb}"
|
||||
test regexp-25.2 {regexp without -line option} {
|
||||
set foo ""
|
||||
list [regexp {^a.*b$} "dabc\naxyb\n" foo] $foo
|
||||
} {0 {}}
|
||||
test regexp-25.3 {regexp with -line option} {
|
||||
set foo ""
|
||||
list [regexp -line {^a.*b$} "dabc\naxyb\n" foo] $foo
|
||||
} {1 axyb}
|
||||
test regexp-25.4 {regexp with -line option} {
|
||||
set foo ""
|
||||
list [regexp -line {^a.*b$} "dabc\naxyb\nxb" foo] $foo
|
||||
} {1 axyb}
|
||||
test regexp-25.5 {regexp without -line option} {
|
||||
set foo ""
|
||||
list [regexp {^a.*b$} "dabc\naxyb\nxb" foo] $foo
|
||||
} {0 {}}
|
||||
test regexp-25.6 {regexp without -line option} {
|
||||
set foo ""
|
||||
list [regexp {a.*b$} "dabc\naxyb\nxb" foo] $foo
|
||||
} "1 {abc\naxyb\nxb}"
|
||||
test regexp-25.7 {regexp with -lineanchor option} {
|
||||
set foo ""
|
||||
list [regexp -lineanchor {^a.*b$} "dabc\naxyb\nxb" foo] $foo
|
||||
} "1 {axyb\nxb}"
|
||||
test regexp-25.8 {regexp with -lineanchor and -linestop option} {
|
||||
set foo ""
|
||||
list [regexp -lineanchor -linestop {^a.*b$} "dabc\naxyb\nxb" foo] $foo
|
||||
} {1 axyb}
|
||||
test regexp-25.9 {regexp with -linestop option} {
|
||||
set foo ""
|
||||
list [regexp -linestop {a.*b} "ab\naxyb\nxb" foo] $foo
|
||||
} {1 ab}
|
||||
|
||||
test regexp-26.1 {matches start of line 1 time} {
|
||||
regexp -all -inline -- {^a+} "aab\naaa"
|
||||
} {aa}
|
||||
test regexp-26.2 {matches start of line(s) 2 times} {
|
||||
regexp -all -inline -line -- {^a+} "aab\naaa"
|
||||
} {aa aaa}
|
||||
test regexp-26.3 {effect of -line -all and -start} {
|
||||
list \
|
||||
[regexp -all -inline -line -start 0 -- {^a+} "aab\naaa"] \
|
||||
[regexp -all -inline -line -start 1 -- {^a+} "aab\naaa"] \
|
||||
[regexp -all -inline -line -start 3 -- {^a+} "aab\naaa"] \
|
||||
[regexp -all -inline -line -start 4 -- {^a+} "aab\naaa"] \
|
||||
} {{aa aaa} aaa aaa aaa}
|
||||
test regexp-26.5 {match length 0, match length 1} {
|
||||
regexp -all -inline -line -- {^b*} "a\nb"
|
||||
} {{} b}
|
||||
test regexp-26.6 {non reporting capture group} {
|
||||
regexp -all -inline -line -- {^(?:a+|b)} "aab\naaa"
|
||||
} {aa aaa}
|
||||
test regexp-26.7 {Tcl bug 2826551: -line sensitive regexp and -start} {
|
||||
set match1 {}
|
||||
set match2 {}
|
||||
list \
|
||||
[regexp -start 0 -indices -line {^a} "\nab" match1] $match1 \
|
||||
[regexp -start 1 -indices -line {^a} "\nab" match2] $match2
|
||||
} {1 {1 1} 1 {1 1}}
|
||||
test regexp-26.8 {Tcl bug 2826551: diff regexp with -line option} {
|
||||
set data "@1\n2\n+3\n@4\n-5\n+6\n7\n@8\n9\n"
|
||||
regexp -all -inline -line {^@.*\n(?:[^@].*\n?)*} $data
|
||||
} "{@1\n2\n+3\n} {@4\n-5\n+6\n7\n} {@8\n9\n}"
|
||||
test regexp-26.9 {Tcl bug 2826551: diff regexp with embedded -line option} {
|
||||
set data "@1\n2\n+3\n@4\n-5\n+6\n7\n@8\n9\n"
|
||||
regexp -all -inline {(?n)^@.*\n(?:[^@].*\n?)*} $data
|
||||
} "{@1\n2\n+3\n} {@4\n-5\n+6\n7\n} {@8\n9\n}"
|
||||
test regexp-26.10 {regexp with -line option} {
|
||||
regexp -all -inline -line -- {a*} "a\n"
|
||||
} {a {}}
|
||||
test regexp-26.11 {regexp without -line option} {
|
||||
regexp -all -inline -- {a*} "a\n"
|
||||
} {a {}}
|
||||
test regexp-26.12 {regexp with -line option} {
|
||||
regexp -all -inline -line -- {a*} "b\n"
|
||||
} {{} {}}
|
||||
test regexp-26.13 {regexp without -line option} {
|
||||
regexp -all -inline -- {a*} "b\n"
|
||||
} {{} {}}
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
987
tests/regexpComp.test
Normal file
987
tests/regexpComp.test
Normal file
@@ -0,0 +1,987 @@
|
||||
# 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.
|
||||
# Copyright (c) 1998 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest 2
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
# Procedure to evaluate a script within a proc, to test compilation
|
||||
# functionality
|
||||
|
||||
proc evalInProc { script } {
|
||||
proc testProc {} $script
|
||||
set status [catch {
|
||||
testProc
|
||||
} result]
|
||||
rename testProc {}
|
||||
return $result
|
||||
#return [list $status $result]
|
||||
}
|
||||
|
||||
catch {unset foo}
|
||||
test regexpComp-1.1 {basic regexp operation} {
|
||||
evalInProc {
|
||||
regexp ab*c abbbc
|
||||
}
|
||||
} 1
|
||||
test regexpComp-1.2 {basic regexp operation} {
|
||||
evalInProc {
|
||||
regexp ab*c ac
|
||||
}
|
||||
} 1
|
||||
test regexpComp-1.3 {basic regexp operation} {
|
||||
evalInProc {
|
||||
regexp ab*c ab
|
||||
}
|
||||
} 0
|
||||
test regexpComp-1.4 {basic regexp operation} {
|
||||
evalInProc {
|
||||
regexp -- -gorp abc-gorpxxx
|
||||
}
|
||||
} 1
|
||||
test regexpComp-1.5 {basic regexp operation} {
|
||||
evalInProc {
|
||||
regexp {^([^ ]*)[ ]*([^ ]*)} "" a
|
||||
}
|
||||
} 1
|
||||
test regexpComp-1.6 {basic regexp operation} {
|
||||
list [catch {regexp {} abc} msg] $msg
|
||||
} {0 1}
|
||||
test regexpComp-1.7 {regexp utf compliance} {
|
||||
# if not UTF-8 aware, result is "0 1"
|
||||
evalInProc {
|
||||
set foo "\u4e4eb q"
|
||||
regexp "\u4e4eb q" "a\u4e4eb qw\u5e4e\x4e wq" bar
|
||||
list [string compare $foo $bar] [regexp 4 $bar]
|
||||
}
|
||||
} {0 0}
|
||||
|
||||
test regexpComp-1.8 {regexp ***= metasyntax} {
|
||||
evalInProc {
|
||||
regexp -- "***=o" "aeiou"
|
||||
}
|
||||
} 1
|
||||
test regexpComp-1.9 {regexp ***= metasyntax} {
|
||||
evalInProc {
|
||||
set string "aeiou"
|
||||
regexp -- "***=o" $string
|
||||
}
|
||||
} 1
|
||||
test regexpComp-1.10 {regexp ***= metasyntax} {
|
||||
evalInProc {
|
||||
set string "aeiou"
|
||||
set re "***=o"
|
||||
regexp -- $re $string
|
||||
}
|
||||
} 1
|
||||
test regexpComp-1.11 {regexp ***= metasyntax} {
|
||||
evalInProc {
|
||||
regexp -- "***=y" "aeiou"
|
||||
}
|
||||
} 0
|
||||
test regexpComp-1.12 {regexp ***= metasyntax} {
|
||||
evalInProc {
|
||||
set string "aeiou"
|
||||
regexp -- "***=y" $string
|
||||
}
|
||||
} 0
|
||||
test regexpComp-1.13 {regexp ***= metasyntax} {
|
||||
evalInProc {
|
||||
set string "aeiou"
|
||||
set re "***=y"
|
||||
regexp -- $re $string
|
||||
}
|
||||
} 0
|
||||
test regexpComp-1.14 {regexp ***= metasyntax} {
|
||||
evalInProc {
|
||||
set string "aeiou"
|
||||
set re "***=e*o"
|
||||
regexp -- $re $string
|
||||
}
|
||||
} 0
|
||||
test regexpComp-1.15 {regexp ***= metasyntax} {
|
||||
evalInProc {
|
||||
set string "ae*ou"
|
||||
set re "***=e*o"
|
||||
regexp -- $re $string
|
||||
}
|
||||
} 1
|
||||
test regexpComp-1.16 {regexp ***= metasyntax} {
|
||||
evalInProc {
|
||||
set string {ae*[o]?ua}
|
||||
set re {***=e*[o]?u}
|
||||
regexp -- $re $string
|
||||
}
|
||||
} 1
|
||||
|
||||
test regexpComp-2.1 {getting substrings back from regexp} {
|
||||
evalInProc {
|
||||
set foo {}
|
||||
list [regexp ab*c abbbbc foo] $foo
|
||||
}
|
||||
} {1 abbbbc}
|
||||
test regexpComp-2.2 {getting substrings back from regexp} {
|
||||
evalInProc {
|
||||
set foo {}
|
||||
set f2 {}
|
||||
list [regexp a(b*)c abbbbc foo f2] $foo $f2
|
||||
}
|
||||
} {1 abbbbc bbbb}
|
||||
test regexpComp-2.3 {getting substrings back from regexp} {
|
||||
evalInProc {
|
||||
set foo {}
|
||||
set f2 {}
|
||||
list [regexp a(b*)(c) abbbbc foo f2] $foo $f2
|
||||
}
|
||||
} {1 abbbbc bbbb}
|
||||
test regexpComp-2.4 {getting substrings back from regexp} {
|
||||
evalInProc {
|
||||
set foo {}
|
||||
set f2 {}
|
||||
set f3 {}
|
||||
list [regexp a(b*)(c) abbbbc foo f2 f3] $foo $f2 $f3
|
||||
}
|
||||
} {1 abbbbc bbbb c}
|
||||
test regexpComp-2.5 {getting substrings back from regexp} {
|
||||
evalInProc {
|
||||
set foo {}; set f1 {}; set f2 {}; set f3 {}; set f4 {}; set f5 {};
|
||||
set f6 {}; set f7 {}; set f8 {}; set f9 {}; set fa {}; set fb {};
|
||||
list [regexp (1*)(2*)(3*)(4*)(5*)(6*)(7*)(8*)(9*)(a*)(b*) \
|
||||
12223345556789999aabbb \
|
||||
foo f1 f2 f3 f4 f5 f6 f7 f8 f9 fa fb] $foo $f1 $f2 $f3 $f4 $f5 \
|
||||
$f6 $f7 $f8 $f9 $fa $fb
|
||||
}
|
||||
} {1 12223345556789999aabbb 1 222 33 4 555 6 7 8 9999 aa bbb}
|
||||
test regexpComp-2.6 {getting substrings back from regexp} {
|
||||
evalInProc {
|
||||
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 regexpComp-2.7 {getting substrings back from regexp} {
|
||||
evalInProc {
|
||||
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 regexpComp-2.8 {getting substrings back from regexp} {
|
||||
evalInProc {
|
||||
set match {}
|
||||
list [regexp {^a*b} aaaab match] $match
|
||||
}
|
||||
} {1 aaaab}
|
||||
|
||||
test regexpComp-3.1 {-indices option to regexp} {
|
||||
evalInProc {
|
||||
set foo {}
|
||||
list [regexp -indices ab*c abbbbc foo] $foo
|
||||
}
|
||||
} {1 {0 5}}
|
||||
test regexpComp-3.2 {-indices option to regexp} {
|
||||
evalInProc {
|
||||
set foo {}
|
||||
set f2 {}
|
||||
list [regexp -indices a(b*)c abbbbc foo f2] $foo $f2
|
||||
}
|
||||
} {1 {0 5} {1 4}}
|
||||
test regexpComp-3.3 {-indices option to regexp} {
|
||||
evalInProc {
|
||||
set foo {}
|
||||
set f2 {}
|
||||
list [regexp -indices a(b*)(c) abbbbc foo f2] $foo $f2
|
||||
}
|
||||
} {1 {0 5} {1 4}}
|
||||
test regexpComp-3.4 {-indices option to regexp} {
|
||||
evalInProc {
|
||||
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 regexpComp-3.5 {-indices option to regexp} {
|
||||
evalInProc {
|
||||
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 regexpComp-3.6 {getting substrings back from regexp} {
|
||||
evalInProc {
|
||||
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 regexpComp-3.7 {getting substrings back from regexp} {
|
||||
evalInProc {
|
||||
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 regexpComp-4.1 {-nocase option to regexp} {
|
||||
evalInProc {
|
||||
regexp -nocase foo abcFOo
|
||||
}
|
||||
} 1
|
||||
test regexpComp-4.2 {-nocase option to regexp} {
|
||||
evalInProc {
|
||||
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 regexpComp-4.3 {-nocase option to regexp} {
|
||||
evalInProc {
|
||||
regexp -nocase FOo abcFOo
|
||||
}
|
||||
} 1
|
||||
set ::x abcdefghijklmnopqrstuvwxyz1234567890
|
||||
set ::x $x$x$x$x$x$x$x$x$x$x$x$x
|
||||
test regexpComp-4.4 {case conversion in regexp} {
|
||||
evalInProc {
|
||||
list [regexp -nocase $::x $::x foo] $foo
|
||||
}
|
||||
} "1 $x"
|
||||
catch {unset ::x}
|
||||
|
||||
test regexpComp-5.1 {exercise cache of compiled expressions} {
|
||||
evalInProc {
|
||||
regexp .*a b
|
||||
regexp .*b c
|
||||
regexp .*c d
|
||||
regexp .*d e
|
||||
regexp .*e f
|
||||
regexp .*a bbba
|
||||
}
|
||||
} 1
|
||||
test regexpComp-5.2 {exercise cache of compiled expressions} {
|
||||
evalInProc {
|
||||
regexp .*a b
|
||||
regexp .*b c
|
||||
regexp .*c d
|
||||
regexp .*d e
|
||||
regexp .*e f
|
||||
regexp .*b xxxb
|
||||
}
|
||||
} 1
|
||||
test regexpComp-5.3 {exercise cache of compiled expressions} {
|
||||
evalInProc {
|
||||
regexp .*a b
|
||||
regexp .*b c
|
||||
regexp .*c d
|
||||
regexp .*d e
|
||||
regexp .*e f
|
||||
regexp .*c yyyc
|
||||
}
|
||||
} 1
|
||||
test regexpComp-5.4 {exercise cache of compiled expressions} {
|
||||
evalInProc {
|
||||
regexp .*a b
|
||||
regexp .*b c
|
||||
regexp .*c d
|
||||
regexp .*d e
|
||||
regexp .*e f
|
||||
regexp .*d 1d
|
||||
}
|
||||
} 1
|
||||
test regexpComp-5.5 {exercise cache of compiled expressions} {
|
||||
evalInProc {
|
||||
regexp .*a b
|
||||
regexp .*b c
|
||||
regexp .*c d
|
||||
regexp .*d e
|
||||
regexp .*e f
|
||||
regexp .*e xe
|
||||
}
|
||||
} 1
|
||||
|
||||
test regexpComp-6.1 {regexp errors} {
|
||||
evalInProc {
|
||||
list [catch {regexp a} msg] $msg
|
||||
}
|
||||
} {1 {wrong # args: should be "regexp ?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"}}
|
||||
test regexpComp-6.2 {regexp errors} {
|
||||
evalInProc {
|
||||
list [catch {regexp -nocase a} msg] $msg
|
||||
}
|
||||
} {1 {wrong # args: should be "regexp ?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"}}
|
||||
test regexpComp-6.3 {regexp errors} {
|
||||
evalInProc {
|
||||
list [catch {regexp -gorp a} msg] $msg
|
||||
}
|
||||
} {1 {bad switch "-gorp": must be -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}}
|
||||
test regexpComp-6.4 {regexp errors} {
|
||||
evalInProc {
|
||||
list [catch {regexp a( b} msg] $msg
|
||||
}
|
||||
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
|
||||
test regexpComp-6.5 {regexp errors} {
|
||||
evalInProc {
|
||||
list [catch {regexp a( b} msg] $msg
|
||||
}
|
||||
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
|
||||
test regexpComp-6.6 {regexp errors} {
|
||||
evalInProc {
|
||||
list [catch {regexp a a f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1} msg] $msg
|
||||
}
|
||||
} {0 1}
|
||||
test regexpComp-6.7 {regexp errors} {
|
||||
evalInProc {
|
||||
list [catch {regexp (x)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.) xyzzy} msg] $msg
|
||||
}
|
||||
} {0 0}
|
||||
test regexpComp-6.8 {regexp errors} {
|
||||
evalInProc {
|
||||
catch {unset f1}
|
||||
set f1 44
|
||||
list [catch {regexp abc abc f1(f2)} msg] $msg
|
||||
}
|
||||
} {1 {couldn't set variable "f1(f2)"}}
|
||||
test regexpComp-6.9 {regexp errors, -start bad int check} {
|
||||
evalInProc {
|
||||
list [catch {regexp -start bogus {^$} {}} msg] $msg
|
||||
}
|
||||
} {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}}
|
||||
|
||||
test regexpComp-7.1 {basic regsub operation} {
|
||||
evalInProc {
|
||||
list [regsub aa+ xaxaaaxaa 111&222 foo] $foo
|
||||
}
|
||||
} {1 xax111aaa222xaa}
|
||||
test regexpComp-7.2 {basic regsub operation} {
|
||||
evalInProc {
|
||||
list [regsub aa+ aaaxaa &111 foo] $foo
|
||||
}
|
||||
} {1 aaa111xaa}
|
||||
test regexpComp-7.3 {basic regsub operation} {
|
||||
evalInProc {
|
||||
list [regsub aa+ xaxaaa 111& foo] $foo
|
||||
}
|
||||
} {1 xax111aaa}
|
||||
test regexpComp-7.4 {basic regsub operation} {
|
||||
evalInProc {
|
||||
list [regsub aa+ aaa 11&2&333 foo] $foo
|
||||
}
|
||||
} {1 11aaa2aaa333}
|
||||
test regexpComp-7.5 {basic regsub operation} {
|
||||
evalInProc {
|
||||
list [regsub aa+ xaxaaaxaa &2&333 foo] $foo
|
||||
}
|
||||
} {1 xaxaaa2aaa333xaa}
|
||||
test regexpComp-7.6 {basic regsub operation} {
|
||||
evalInProc {
|
||||
list [regsub aa+ xaxaaaxaa 1&22& foo] $foo
|
||||
}
|
||||
} {1 xax1aaa22aaaxaa}
|
||||
test regexpComp-7.7 {basic regsub operation} {
|
||||
evalInProc {
|
||||
list [regsub a(a+) xaxaaaxaa {1\122\1} foo] $foo
|
||||
}
|
||||
} {1 xax1aa22aaxaa}
|
||||
test regexpComp-7.8 {basic regsub operation} {
|
||||
evalInProc {
|
||||
list [regsub a(a+) xaxaaaxaa {1\\\122\1} foo] $foo
|
||||
}
|
||||
} "1 {xax1\\aa22aaxaa}"
|
||||
test regexpComp-7.9 {basic regsub operation} {
|
||||
evalInProc {
|
||||
list [regsub a(a+) xaxaaaxaa {1\\122\1} foo] $foo
|
||||
}
|
||||
} "1 {xax1\\122aaxaa}"
|
||||
test regexpComp-7.10 {basic regsub operation} {
|
||||
evalInProc {
|
||||
list [regsub a(a+) xaxaaaxaa {1\\&\1} foo] $foo
|
||||
}
|
||||
} "1 {xax1\\aaaaaxaa}"
|
||||
test regexpComp-7.11 {basic regsub operation} {
|
||||
evalInProc {
|
||||
list [regsub a(a+) xaxaaaxaa {1\&\1} foo] $foo
|
||||
}
|
||||
} {1 xax1&aaxaa}
|
||||
test regexpComp-7.12 {basic regsub operation} {
|
||||
evalInProc {
|
||||
list [regsub a(a+) xaxaaaxaa {\1\1\1\1&&} foo] $foo
|
||||
}
|
||||
} {1 xaxaaaaaaaaaaaaaaxaa}
|
||||
test regexpComp-7.13 {basic regsub operation} {
|
||||
evalInProc {
|
||||
set foo xxx
|
||||
list [regsub abc xyz 111 foo] $foo
|
||||
}
|
||||
} {0 xyz}
|
||||
test regexpComp-7.14 {basic regsub operation} {
|
||||
evalInProc {
|
||||
set foo xxx
|
||||
list [regsub ^ xyz "111 " foo] $foo
|
||||
}
|
||||
} {1 {111 xyz}}
|
||||
test regexpComp-7.15 {basic regsub operation} {
|
||||
evalInProc {
|
||||
set foo xxx
|
||||
list [regsub -- -foo abc-foodef "111 " foo] $foo
|
||||
}
|
||||
} {1 {abc111 def}}
|
||||
test regexpComp-7.16 {basic regsub operation} {
|
||||
evalInProc {
|
||||
set foo xxx
|
||||
list [regsub x "" y foo] $foo
|
||||
}
|
||||
} {0 {}}
|
||||
test regexpComp-7.17 {regsub utf compliance} {
|
||||
evalInProc {
|
||||
# if not UTF-8 aware, result is "0 1"
|
||||
set foo "xyz555ijka\u4e4ebpqr"
|
||||
regsub a\u4e4eb xyza\u4e4ebijka\u4e4ebpqr 555 bar
|
||||
list [string compare $foo $bar] [regexp 4 $bar]
|
||||
}
|
||||
} {0 0}
|
||||
|
||||
test regexpComp-8.1 {case conversion in regsub} {
|
||||
evalInProc {
|
||||
list [regsub -nocase a(a+) xaAAaAAay & foo] $foo
|
||||
}
|
||||
} {1 xaAAaAAay}
|
||||
test regexpComp-8.2 {case conversion in regsub} {
|
||||
evalInProc {
|
||||
list [regsub -nocase a(a+) xaAAaAAay & foo] $foo
|
||||
}
|
||||
} {1 xaAAaAAay}
|
||||
test regexpComp-8.3 {case conversion in regsub} {
|
||||
evalInProc {
|
||||
set foo 123
|
||||
list [regsub a(a+) xaAAaAAay & foo] $foo
|
||||
}
|
||||
} {0 xaAAaAAay}
|
||||
test regexpComp-8.4 {case conversion in regsub} {
|
||||
evalInProc {
|
||||
set foo 123
|
||||
list [regsub -nocase a CaDE b foo] $foo
|
||||
}
|
||||
} {1 CbDE}
|
||||
test regexpComp-8.5 {case conversion in regsub} {
|
||||
evalInProc {
|
||||
set foo 123
|
||||
list [regsub -nocase XYZ CxYzD b foo] $foo
|
||||
}
|
||||
} {1 CbD}
|
||||
test regexpComp-8.6 {case conversion in regsub} {
|
||||
evalInProc {
|
||||
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 regexpComp-9.1 {-all option to regsub} {
|
||||
evalInProc {
|
||||
set foo 86
|
||||
list [regsub -all x+ axxxbxxcxdx |&| foo] $foo
|
||||
}
|
||||
} {4 a|xxx|b|xx|c|x|d|x|}
|
||||
test regexpComp-9.2 {-all option to regsub} {
|
||||
evalInProc {
|
||||
set foo 86
|
||||
list [regsub -nocase -all x+ aXxXbxxcXdx |&| foo] $foo
|
||||
}
|
||||
} {4 a|XxX|b|xx|c|X|d|x|}
|
||||
test regexpComp-9.3 {-all option to regsub} {
|
||||
evalInProc {
|
||||
set foo 86
|
||||
list [regsub x+ axxxbxxcxdx |&| foo] $foo
|
||||
}
|
||||
} {1 a|xxx|bxxcxdx}
|
||||
test regexpComp-9.4 {-all option to regsub} {
|
||||
evalInProc {
|
||||
set foo 86
|
||||
list [regsub -all bc axxxbxxcxdx |&| foo] $foo
|
||||
}
|
||||
} {0 axxxbxxcxdx}
|
||||
test regexpComp-9.5 {-all option to regsub} {
|
||||
evalInProc {
|
||||
set foo xxx
|
||||
list [regsub -all node "node node more" yy foo] $foo
|
||||
}
|
||||
} {2 {yy yy more}}
|
||||
test regexpComp-9.6 {-all option to regsub} {
|
||||
evalInProc {
|
||||
set foo xxx
|
||||
list [regsub -all ^ xxx 123 foo] $foo
|
||||
}
|
||||
} {1 123xxx}
|
||||
|
||||
test regexpComp-10.1 {expanded syntax in regsub} {
|
||||
evalInProc {
|
||||
set foo xxx
|
||||
list [regsub -expanded ". \#comment\n . \#comment2" abc def foo] $foo
|
||||
}
|
||||
} {1 defc}
|
||||
test regexpComp-10.2 {newline sensitivity in regsub} {
|
||||
evalInProc {
|
||||
set foo xxx
|
||||
list [regsub -line {^a.*b$} "dabc\naxyb\n" 123 foo] $foo
|
||||
}
|
||||
} "1 {dabc\n123\n}"
|
||||
test regexpComp-10.3 {newline sensitivity in regsub} {
|
||||
evalInProc {
|
||||
set foo xxx
|
||||
list [regsub -line {^a.*b$} "dabc\naxyb\nxb" 123 foo] $foo
|
||||
}
|
||||
} "1 {dabc\n123\nxb}"
|
||||
test regexpComp-10.4 {partial newline sensitivity in regsub} {
|
||||
evalInProc {
|
||||
set foo xxx
|
||||
list [regsub -lineanchor {^a.*b$} "da\naxyb\nxb" 123 foo] $foo
|
||||
}
|
||||
} "1 {da\n123}"
|
||||
test regexpComp-10.5 {inverse partial newline sensitivity in regsub} {
|
||||
evalInProc {
|
||||
set foo xxx
|
||||
list [regsub -linestop {a.*b} "da\nbaxyb\nxb" 123 foo] $foo
|
||||
}
|
||||
} "1 {da\nb123\nxb}"
|
||||
|
||||
test regexpComp-11.1 {regsub errors} {
|
||||
evalInProc {
|
||||
list [catch {regsub a b} msg] $msg
|
||||
}
|
||||
} {1 {wrong # args: should be "regsub ?switches? exp string subSpec ?varName?"}}
|
||||
test regexpComp-11.2 {regsub errors} {
|
||||
evalInProc {
|
||||
list [catch {regsub -nocase a b} msg] $msg
|
||||
}
|
||||
} {1 {wrong # args: should be "regsub ?switches? exp string subSpec ?varName?"}}
|
||||
test regexpComp-11.3 {regsub errors} {
|
||||
evalInProc {
|
||||
list [catch {regsub -nocase -all a b} msg] $msg
|
||||
}
|
||||
} {1 {wrong # args: should be "regsub ?switches? exp string subSpec ?varName?"}}
|
||||
test regexpComp-11.4 {regsub errors} {
|
||||
evalInProc {
|
||||
list [catch {regsub a b c d e f} msg] $msg
|
||||
}
|
||||
} {1 {wrong # args: should be "regsub ?switches? exp string subSpec ?varName?"}}
|
||||
test regexpComp-11.5 {regsub errors} {
|
||||
evalInProc {
|
||||
list [catch {regsub -gorp a b c} msg] $msg
|
||||
}
|
||||
} {1 {bad switch "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}}
|
||||
test regexpComp-11.6 {regsub errors} {
|
||||
evalInProc {
|
||||
list [catch {regsub -nocase a( b c d} msg] $msg
|
||||
}
|
||||
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
|
||||
test regexpComp-11.7 {regsub errors} {
|
||||
evalInProc {
|
||||
catch {unset f1}
|
||||
set f1 44
|
||||
list [catch {regsub -nocase aaa aaa xxx f1(f2)} msg] $msg
|
||||
}
|
||||
} {1 {couldn't set variable "f1(f2)"}}
|
||||
test regexpComp-11.8 {regsub errors, -start bad int check} {
|
||||
evalInProc {
|
||||
list [catch {regsub -start bogus pattern string rep var} msg] $msg
|
||||
}
|
||||
} {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}}
|
||||
|
||||
# This test crashes on the Mac unless you increase the Stack Space to about 1
|
||||
# Meg. This is probably bigger than most users want...
|
||||
# 8.2.3 regexp reduced stack space requirements, but this should be
|
||||
# tested again
|
||||
test regexpComp-12.1 {Tcl_RegExpExec: large number of subexpressions} {macCrash} {
|
||||
evalInProc {
|
||||
list [regexp (.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.) abcdefghijklmnopqrstuvwxyz all 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] $all $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
|
||||
}
|
||||
} {1 abcdefghijklmnopqrstuvwxyz 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}
|
||||
|
||||
test regexpComp-13.1 {regsub of a very large string} {
|
||||
# This test is designed to stress the memory subsystem in order
|
||||
# to catch Bug #933. It only fails if the Tcl memory allocator
|
||||
# is in use.
|
||||
|
||||
set line {BEGIN_TABLE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; END_TABLE}
|
||||
set filedata [string repeat $line 200]
|
||||
for {set i 1} {$i<10} {incr i} {
|
||||
regsub -all "BEGIN_TABLE " $filedata "" newfiledata
|
||||
}
|
||||
set x done
|
||||
} {done}
|
||||
|
||||
test regexpComp-14.1 {CompileRegexp: regexp cache} {
|
||||
evalInProc {
|
||||
regexp .*a b
|
||||
regexp .*b c
|
||||
regexp .*c d
|
||||
regexp .*d e
|
||||
regexp .*e f
|
||||
set x .
|
||||
append x *a
|
||||
regexp $x bbba
|
||||
}
|
||||
} 1
|
||||
test regexpComp-14.2 {CompileRegexp: regexp cache, different flags} {
|
||||
evalInProc {
|
||||
regexp .*a b
|
||||
regexp .*b c
|
||||
regexp .*c d
|
||||
regexp .*d e
|
||||
regexp .*e f
|
||||
set x .
|
||||
append x *a
|
||||
regexp -nocase $x bbba
|
||||
}
|
||||
} 1
|
||||
|
||||
testConstraint exec [llength [info commands exec]]
|
||||
test regexpComp-14.3 {CompileRegexp: regexp cache, empty regexp and empty cache} -constraints {
|
||||
exec
|
||||
} -setup {
|
||||
set junk [makeFile {puts [regexp {} foo]} junk.tcl]
|
||||
} -body {
|
||||
exec [interpreter] $junk
|
||||
} -cleanup {
|
||||
removeFile junk.tcl
|
||||
} -result 1
|
||||
|
||||
test regexpComp-15.1 {regexp -start} {
|
||||
catch {unset x}
|
||||
list [regexp -start -10 {\d} 1abc2de3 x] $x
|
||||
} {1 1}
|
||||
test regexpComp-15.2 {regexp -start} {
|
||||
catch {unset x}
|
||||
list [regexp -start 2 {\d} 1abc2de3 x] $x
|
||||
} {1 2}
|
||||
test regexpComp-15.3 {regexp -start} {
|
||||
catch {unset x}
|
||||
list [regexp -start 4 {\d} 1abc2de3 x] $x
|
||||
} {1 2}
|
||||
test regexpComp-15.4 {regexp -start} {
|
||||
catch {unset x}
|
||||
list [regexp -start 5 {\d} 1abc2de3 x] $x
|
||||
} {1 3}
|
||||
test regexpComp-15.5 {regexp -start, over end of string} {
|
||||
catch {unset x}
|
||||
list [regexp -start [string length 1abc2de3] {\d} 1abc2de3 x] [info exists x]
|
||||
} {0 0}
|
||||
test regexpComp-15.6 {regexp -start, loss of ^$ behavior} {
|
||||
list [regexp -start 2 {^$} {}]
|
||||
} {0}
|
||||
|
||||
test regexpComp-16.1 {regsub -start} {
|
||||
catch {unset x}
|
||||
list [regsub -all -start 2 {\d} a1b2c3d4e5 {/&} x] $x
|
||||
} {4 a1b/2c/3d/4e/5}
|
||||
test regexpComp-16.2 {regsub -start} {
|
||||
catch {unset x}
|
||||
list [regsub -all -start -25 {z} hello {/&} x] $x
|
||||
} {0 hello}
|
||||
test regexpComp-16.3 {regsub -start} {
|
||||
catch {unset x}
|
||||
list [regsub -all -start 3 {z} hello {/&} x] $x
|
||||
} {0 hello}
|
||||
test regexpComp-16.4 {regsub -start, \A behavior} {
|
||||
set out {}
|
||||
lappend out [regsub -start 0 -all {\A(\w)} {abcde} {/\1} x] $x
|
||||
lappend out [regsub -start 2 -all {\A(\w)} {abcde} {/\1} x] $x
|
||||
} {5 /a/b/c/d/e 3 ab/c/d/e}
|
||||
|
||||
test regexpComp-17.1 {regexp -inline} {
|
||||
regexp -inline b ababa
|
||||
} {b}
|
||||
test regexpComp-17.2 {regexp -inline} {
|
||||
regexp -inline (b) ababa
|
||||
} {b b}
|
||||
test regexpComp-17.3 {regexp -inline -indices} {
|
||||
regexp -inline -indices (b) ababa
|
||||
} {{1 1} {1 1}}
|
||||
test regexpComp-17.4 {regexp -inline} {
|
||||
regexp -inline {\w(\d+)\w} " hello 23 there456def "
|
||||
} {e456d 456}
|
||||
test regexpComp-17.5 {regexp -inline no matches} {
|
||||
regexp -inline {\w(\d+)\w} ""
|
||||
} {}
|
||||
test regexpComp-17.6 {regexp -inline no matches} {
|
||||
regexp -inline hello goodbye
|
||||
} {}
|
||||
test regexpComp-17.7 {regexp -inline, no matchvars allowed} {
|
||||
list [catch {regexp -inline b abc match} msg] $msg
|
||||
} {1 {regexp match variables not allowed when using -inline}}
|
||||
|
||||
test regexpComp-18.1 {regexp -all} {
|
||||
regexp -all b bbbbb
|
||||
} {5}
|
||||
test regexpComp-18.2 {regexp -all} {
|
||||
regexp -all b abababbabaaaaaaaaaab
|
||||
} {6}
|
||||
test regexpComp-18.3 {regexp -all -inline} {
|
||||
regexp -all -inline b abababbabaaaaaaaaaab
|
||||
} {b b b b b b}
|
||||
test regexpComp-18.4 {regexp -all -inline} {
|
||||
regexp -all -inline {\w(\w)} abcdefg
|
||||
} {ab b cd d ef f}
|
||||
test regexpComp-18.5 {regexp -all -inline} {
|
||||
regexp -all -inline {\w(\w)$} abcdefg
|
||||
} {fg g}
|
||||
test regexpComp-18.6 {regexp -all -inline} {
|
||||
regexp -all -inline {\d+} 10:20:30:40
|
||||
} {10 20 30 40}
|
||||
test regexpComp-18.7 {regexp -all -inline} {
|
||||
list [catch {regexp -all -inline b abc match} msg] $msg
|
||||
} {1 {regexp match variables not allowed when using -inline}}
|
||||
test regexpComp-18.8 {regexp -all} {
|
||||
# This should not cause an infinite loop
|
||||
regexp -all -inline {a*} a
|
||||
} {a}
|
||||
test regexpComp-18.9 {regexp -all} {
|
||||
# Yes, the expected result is {a {}}. Here's why:
|
||||
# Start at index 0; a* matches the "a" there then stops.
|
||||
# Go to index 1; a* matches the lambda (or {}) there then stops. Recall
|
||||
# that a* matches zero or more "a"'s; thus it matches the string "b", as
|
||||
# there are zero or more "a"'s there.
|
||||
# Go to index 2; this is past the end of the string, so stop.
|
||||
regexp -all -inline {a*} ab
|
||||
} {a {}}
|
||||
test regexpComp-18.10 {regexp -all} {
|
||||
# Yes, the expected result is {a {} a}. Here's why:
|
||||
# Start at index 0; a* matches the "a" there then stops.
|
||||
# Go to index 1; a* matches the lambda (or {}) there then stops. Recall
|
||||
# that a* matches zero or more "a"'s; thus it matches the string "b", as
|
||||
# there are zero or more "a"'s there.
|
||||
# Go to index 2; a* matches the "a" there then stops.
|
||||
# Go to index 3; this is past the end of the string, so stop.
|
||||
regexp -all -inline {a*} aba
|
||||
} {a {} a}
|
||||
test regexpComp-18.11 {regexp -all} {
|
||||
evalInProc {
|
||||
regexp -all -inline {^a} aaaa
|
||||
}
|
||||
} {a}
|
||||
test regexpComp-18.12 {regexp -all -inline -indices} {
|
||||
evalInProc {
|
||||
regexp -all -inline -indices a(b(c)d|e(f)g)h abcdhaefgh
|
||||
}
|
||||
} {{0 4} {1 3} {2 2} {-1 -1} {5 9} {6 8} {-1 -1} {7 7}}
|
||||
|
||||
test regexpComp-19.1 {regsub null replacement} {
|
||||
evalInProc {
|
||||
regsub -all {@} {@hel@lo@} "\0a\0" result
|
||||
list $result [string length $result]
|
||||
}
|
||||
} "\0a\0hel\0a\0lo\0a\0 14"
|
||||
|
||||
test regexpComp-20.1 {regsub shared object shimmering} {
|
||||
evalInProc {
|
||||
# Bug #461322
|
||||
set a abcdefghijklmnopqurstuvwxyz
|
||||
set b $a
|
||||
set c abcdefghijklmnopqurstuvwxyz0123456789
|
||||
regsub $a $c $b d
|
||||
list $d [string length $d] [string bytelength $d]
|
||||
}
|
||||
} [list abcdefghijklmnopqurstuvwxyz0123456789 37 37]
|
||||
test regexpComp-20.2 {regsub shared object shimmering with -about} {
|
||||
evalInProc {
|
||||
eval regexp -about abc
|
||||
}
|
||||
} {0 {}}
|
||||
|
||||
test regexpComp-21.1 {regexp command compiling tests} {
|
||||
evalInProc {
|
||||
regexp foo bar
|
||||
}
|
||||
} 0
|
||||
test regexpComp-21.2 {regexp command compiling tests} {
|
||||
evalInProc {
|
||||
regexp {^foo$} dogfood
|
||||
}
|
||||
} 0
|
||||
test regexpComp-21.3 {regexp command compiling tests} {
|
||||
evalInProc {
|
||||
set a foo
|
||||
regexp {^foo$} $a
|
||||
}
|
||||
} 1
|
||||
test regexpComp-21.4 {regexp command compiling tests} {
|
||||
evalInProc {
|
||||
regexp foo dogfood
|
||||
}
|
||||
} 1
|
||||
test regexpComp-21.5 {regexp command compiling tests} {
|
||||
evalInProc {
|
||||
regexp -nocase FOO dogfod
|
||||
}
|
||||
} 0
|
||||
test regexpComp-21.6 {regexp command compiling tests} {
|
||||
evalInProc {
|
||||
regexp -n foo dogfoOd
|
||||
}
|
||||
} 1
|
||||
test regexpComp-21.7 {regexp command compiling tests} {
|
||||
evalInProc {
|
||||
regexp -no -- FoO dogfood
|
||||
}
|
||||
} 1
|
||||
test regexpComp-21.8 {regexp command compiling tests} {
|
||||
evalInProc {
|
||||
regexp -- foo dogfod
|
||||
}
|
||||
} 0
|
||||
test regexpComp-21.9 {regexp command compiling tests} {
|
||||
evalInProc {
|
||||
list [catch {regexp -- -nocase foo dogfod} msg] $msg
|
||||
}
|
||||
} {0 0}
|
||||
test regexpComp-21.10 {regexp command compiling tests} {
|
||||
evalInProc {
|
||||
list [regsub -all "" foo bar str] $str
|
||||
}
|
||||
} {3 barfbarobaro}
|
||||
test regexpComp-21.11 {regexp command compiling tests} {
|
||||
evalInProc {
|
||||
list [regsub -all "" "" bar str] $str
|
||||
}
|
||||
} {0 {}}
|
||||
|
||||
test regexpComp-22.0.1 {Bug 1810038} {
|
||||
evalInProc {
|
||||
regexp ($|^X)* {}
|
||||
}
|
||||
} 1
|
||||
|
||||
test regexpComp-22.0.2 {regexp compile and backrefs, Bug 1857126} {
|
||||
evalInProc {
|
||||
regexp -- {([bc])\1} bb
|
||||
}
|
||||
} 1
|
||||
|
||||
set i 0
|
||||
foreach {str exp result} {
|
||||
foo ^foo 1
|
||||
foobar ^foobar$ 1
|
||||
foobar bar$ 1
|
||||
foobar ^$ 0
|
||||
"" ^$ 1
|
||||
anything $ 1
|
||||
anything ^.*$ 1
|
||||
anything ^.*a$ 0
|
||||
anything ^.*a.*$ 1
|
||||
anything ^.*.*$ 1
|
||||
anything ^.*..*$ 1
|
||||
anything ^.*b$ 0
|
||||
anything ^a.*$ 1
|
||||
} {
|
||||
test regexpComp-22.[incr i] {regexp command compiling tests} \
|
||||
[subst {evalInProc {set a "$str"; regexp {$exp} \$a}}] $result
|
||||
}
|
||||
|
||||
set i 0
|
||||
foreach {str exp result} {
|
||||
foo ^foo 1
|
||||
foobar ^foobar$ 1
|
||||
foobar bar$ 1
|
||||
foobar ^$ 0
|
||||
"" ^$ 1
|
||||
anything $ 1
|
||||
anything ^.*$ 1
|
||||
anything ^.*a$ 0
|
||||
anything ^.*a.*$ 1
|
||||
anything ^.*.*$ 1
|
||||
anything ^.*..*$ 1
|
||||
anything ^.*b$ 0
|
||||
anything ^a.*$ 1
|
||||
} {
|
||||
test regexpComp-23.[incr i] {regexp command compiling tests INST_REGEXP} \
|
||||
[subst {evalInProc {set a "$str"; set re "$exp"; regexp \$re \$a}}] $result
|
||||
}
|
||||
|
||||
test regexpComp-24.1 {regexp command compiling tests} {
|
||||
evalInProc {
|
||||
set re foo
|
||||
regexp -nocase $re bar
|
||||
}
|
||||
} 0
|
||||
test regexpComp-24.2 {regexp command compiling tests} {
|
||||
evalInProc {
|
||||
set re {^foo$}
|
||||
regexp $re dogfood
|
||||
}
|
||||
} 0
|
||||
test regexpComp-24.3 {regexp command compiling tests} {
|
||||
evalInProc {
|
||||
set a foo
|
||||
set re {^foo$}
|
||||
regexp $re $a
|
||||
}
|
||||
} 1
|
||||
test regexpComp-24.4 {regexp command compiling tests} {
|
||||
evalInProc {
|
||||
set re foo
|
||||
regexp $re dogfood
|
||||
}
|
||||
} 1
|
||||
test regexpComp-24.5 {regexp command compiling tests} {
|
||||
evalInProc {
|
||||
set re FOO
|
||||
regexp -nocase $re dogfod
|
||||
}
|
||||
} 0
|
||||
test regexpComp-24.6 {regexp command compiling tests} {
|
||||
evalInProc {
|
||||
set re foo
|
||||
regexp -n $re dogfoOd
|
||||
}
|
||||
} 1
|
||||
test regexpComp-24.7 {regexp command compiling tests} {
|
||||
evalInProc {
|
||||
set re FoO
|
||||
regexp -no -- $re dogfood
|
||||
}
|
||||
} 1
|
||||
test regexpComp-24.8 {regexp command compiling tests} {
|
||||
evalInProc {
|
||||
set re foo
|
||||
regexp -- $re dogfod
|
||||
}
|
||||
} 0
|
||||
test regexpComp-24.9 {regexp command compiling tests} {
|
||||
evalInProc {
|
||||
set re "("
|
||||
list [catch {regexp -- $re dogfod} msg] $msg
|
||||
}
|
||||
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
|
||||
test regexpComp-24.10 {regexp command compiling tests} {
|
||||
# Bug 1902436 - last * escaped
|
||||
evalInProc {
|
||||
set text {this is *bold* !}
|
||||
set re {\*bold\*}
|
||||
regexp -- $re $text
|
||||
}
|
||||
} 1
|
||||
test regexpComp-24.11 {regexp command compiling tests} {
|
||||
# Bug 1902436 - last * escaped
|
||||
evalInProc {
|
||||
set text {this is *bold* !}
|
||||
set re {\*bold\*.*!}
|
||||
regexp -- $re $text
|
||||
}
|
||||
} 1
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
623
tests/registry.test
Normal file
623
tests/registry.test
Normal file
@@ -0,0 +1,623 @@
|
||||
# registry.test --
|
||||
#
|
||||
# This file contains a collection of tests for the registry command.
|
||||
# Sourcing this file into Tcl runs the tests and generates output for
|
||||
# errors. No output means no errors were found.
|
||||
#
|
||||
# In order for these tests to run, the registry package must be on the
|
||||
# auto_path or the registry package must have been loaded already.
|
||||
#
|
||||
# Copyright (c) 1997 by Sun Microsystems, Inc. All rights reserved.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest 2
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
testConstraint reg 0
|
||||
if {[testConstraint win]} {
|
||||
if {![catch {
|
||||
::tcltest::loadTestedCommands
|
||||
package require registry
|
||||
}]} {
|
||||
testConstraint reg 1
|
||||
}
|
||||
}
|
||||
|
||||
# determine the current locale
|
||||
testConstraint english [expr {
|
||||
[llength [info commands testlocale]]
|
||||
&& [string match "English*" [testlocale all ""]]
|
||||
}]
|
||||
|
||||
test registry-1.1 {argument parsing for registry command} {win reg} {
|
||||
list [catch {registry} msg] $msg
|
||||
} {1 {wrong # args: should be "registry option ?arg arg ...?"}}
|
||||
test registry-1.2 {argument parsing for registry command} {win reg} {
|
||||
list [catch {registry foo} msg] $msg
|
||||
} {1 {bad option "foo": must be broadcast, delete, get, keys, set, type, or values}}
|
||||
|
||||
test registry-1.3 {argument parsing for registry command} {win reg} {
|
||||
list [catch {registry d} msg] $msg
|
||||
} {1 {wrong # args: should be "registry delete keyName ?valueName?"}}
|
||||
test registry-1.4 {argument parsing for registry command} {win reg} {
|
||||
list [catch {registry delete} msg] $msg
|
||||
} {1 {wrong # args: should be "registry delete keyName ?valueName?"}}
|
||||
test registry-1.5 {argument parsing for registry command} {win reg} {
|
||||
list [catch {registry delete foo bar baz} msg] $msg
|
||||
} {1 {wrong # args: should be "registry delete keyName ?valueName?"}}
|
||||
|
||||
test registry-1.6 {argument parsing for registry command} {win reg} {
|
||||
list [catch {registry g} msg] $msg
|
||||
} {1 {wrong # args: should be "registry get keyName valueName"}}
|
||||
test registry-1.7 {argument parsing for registry command} {win reg} {
|
||||
list [catch {registry get} msg] $msg
|
||||
} {1 {wrong # args: should be "registry get keyName valueName"}}
|
||||
test registry-1.8 {argument parsing for registry command} {win reg} {
|
||||
list [catch {registry get foo} msg] $msg
|
||||
} {1 {wrong # args: should be "registry get keyName valueName"}}
|
||||
test registry-1.9 {argument parsing for registry command} {win reg} {
|
||||
list [catch {registry get foo bar baz} msg] $msg
|
||||
} {1 {wrong # args: should be "registry get keyName valueName"}}
|
||||
|
||||
test registry-1.10 {argument parsing for registry command} {win reg} {
|
||||
list [catch {registry k} msg] $msg
|
||||
} {1 {wrong # args: should be "registry keys keyName ?pattern?"}}
|
||||
test registry-1.11 {argument parsing for registry command} {win reg} {
|
||||
list [catch {registry keys} msg] $msg
|
||||
} {1 {wrong # args: should be "registry keys keyName ?pattern?"}}
|
||||
test registry-1.12 {argument parsing for registry command} {win reg} {
|
||||
list [catch {registry keys foo bar baz} msg] $msg
|
||||
} {1 {wrong # args: should be "registry keys keyName ?pattern?"}}
|
||||
|
||||
test registry-1.13 {argument parsing for registry command} {win reg} {
|
||||
list [catch {registry s} msg] $msg
|
||||
} {1 {wrong # args: should be "registry set keyName ?valueName data ?type??"}}
|
||||
test registry-1.14 {argument parsing for registry command} {win reg} {
|
||||
list [catch {registry set} msg] $msg
|
||||
} {1 {wrong # args: should be "registry set keyName ?valueName data ?type??"}}
|
||||
test registry-1.15 {argument parsing for registry command} {win reg} {
|
||||
list [catch {registry set foo bar} msg] $msg
|
||||
} {1 {wrong # args: should be "registry set keyName ?valueName data ?type??"}}
|
||||
test registry-1.16 {argument parsing for registry command} {win reg} {
|
||||
list [catch {registry set foo bar baz blat gorp} msg] $msg
|
||||
} {1 {wrong # args: should be "registry set keyName ?valueName data ?type??"}}
|
||||
|
||||
test registry-1.17 {argument parsing for registry command} {win reg} {
|
||||
list [catch {registry t} msg] $msg
|
||||
} {1 {wrong # args: should be "registry type keyName valueName"}}
|
||||
test registry-1.18 {argument parsing for registry command} {win reg} {
|
||||
list [catch {registry type} msg] $msg
|
||||
} {1 {wrong # args: should be "registry type keyName valueName"}}
|
||||
test registry-1.19 {argument parsing for registry command} {win reg} {
|
||||
list [catch {registry type foo} msg] $msg
|
||||
} {1 {wrong # args: should be "registry type keyName valueName"}}
|
||||
test registry-1.20 {argument parsing for registry command} {win reg} {
|
||||
list [catch {registry type foo bar baz} msg] $msg
|
||||
} {1 {wrong # args: should be "registry type keyName valueName"}}
|
||||
|
||||
test registry-1.21 {argument parsing for registry command} {win reg} {
|
||||
list [catch {registry v} msg] $msg
|
||||
} {1 {wrong # args: should be "registry values keyName ?pattern?"}}
|
||||
test registry-1.22 {argument parsing for registry command} {win reg} {
|
||||
list [catch {registry values} msg] $msg
|
||||
} {1 {wrong # args: should be "registry values keyName ?pattern?"}}
|
||||
test registry-1.23 {argument parsing for registry command} {win reg} {
|
||||
list [catch {registry values foo bar baz} msg] $msg
|
||||
} {1 {wrong # args: should be "registry values keyName ?pattern?"}}
|
||||
|
||||
test registry-2.1 {DeleteKey: bad key} {win reg} {
|
||||
list [catch {registry delete foo} msg] $msg
|
||||
} {1 {bad root name "foo": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}}
|
||||
test registry-2.2 {DeleteKey: bad key} {win reg} {
|
||||
list [catch {registry delete HKEY_CURRENT_USER} msg] $msg
|
||||
} {1 {bad key: cannot delete root keys}}
|
||||
test registry-2.3 {DeleteKey: bad key} {win reg} {
|
||||
list [catch {registry delete HKEY_CURRENT_USER\\} msg] $msg
|
||||
} {1 {bad key: cannot delete root keys}}
|
||||
test registry-2.4 {DeleteKey: subkey at root level} {win reg} {
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
registry keys HKEY_CURRENT_USER TclFoobar
|
||||
} {}
|
||||
test registry-2.5 {DeleteKey: subkey below root level} {win reg} {
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar\\test
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar\\test
|
||||
set result [registry keys HKEY_CURRENT_USER TclFoobar\\test]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} {}
|
||||
test registry-2.6 {DeleteKey: recursive delete} {win reg} {
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar\\test1
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar\\test2\\test3
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result [registry keys HKEY_CURRENT_USER TclFoobar]
|
||||
set result
|
||||
} {}
|
||||
test registry-2.7 {DeleteKey: trailing backslashes} {win reg english} {
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar\\baz
|
||||
list [catch {registry delete HKEY_CURRENT_USER\\TclFoobar\\} msg] $msg
|
||||
} {1 {unable to delete key: The configuration registry key is invalid.}}
|
||||
test registry-2.8 {DeleteKey: failure} {win reg} {
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
} {}
|
||||
test registry-2.9 {DeleteKey: unicode} {win reg} {
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar\\test\u00c7bar\\a
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar\\test\u00c7bar\\b
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar\\test\u00c7bar
|
||||
set result [registry keys HKEY_CURRENT_USER\\TclFoobar]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} {}
|
||||
|
||||
test registry-3.1 {DeleteValue} {win reg} {
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar\\baz test1 blort
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar\\baz test2 blat
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar\\baz test1
|
||||
set result [registry values HKEY_CURRENT_USER\\TclFoobar\\baz]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} test2
|
||||
test registry-3.2 {DeleteValue: bad key} {win reg english} {
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
list [catch {registry delete HKEY_CURRENT_USER\\TclFoobar test} msg] $msg
|
||||
} {1 {unable to open key: The system cannot find the file specified.}}
|
||||
test registry-3.3 {DeleteValue: bad value} {win reg english} {
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar\\baz test2 blort
|
||||
set result [list [catch {registry delete HKEY_CURRENT_USER\\TclFoobar test1} msg] $msg]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} {1 {unable to delete value "test1" from key "HKEY_CURRENT_USER\TclFoobar": The system cannot find the file specified.}}
|
||||
test registry-3.4 {DeleteValue: Unicode} {win reg} {
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar\\\u00c7baz \u00c7test1 blort
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar\\\u00c7baz test2 blat
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar\\\u00c7baz \u00c7test1
|
||||
set result [registry values HKEY_CURRENT_USER\\TclFoobar\\\u00c7baz]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} test2
|
||||
|
||||
test registry-4.1 {GetKeyNames: bad key} {win reg english} {
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
list [catch {registry keys HKEY_CURRENT_USER\\TclFoobar} msg] $msg
|
||||
} {1 {unable to open key: The system cannot find the file specified.}}
|
||||
test registry-4.2 {GetKeyNames} {win reg} {
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar\\baz
|
||||
set result [registry keys HKEY_CURRENT_USER\\TclFoobar]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} {baz}
|
||||
test registry-4.3 {GetKeyNames: remote key} {win reg nonPortable english} {
|
||||
set hostname [info hostname]
|
||||
registry set \\\\$hostname\\HKEY_CURRENT_USER\\TclFoobar\\baz
|
||||
set result [registry keys \\\\gaspode\\HKEY_CURRENT_USER\\TclFoobar]
|
||||
registry delete \\\\$hostname\\HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} {baz}
|
||||
test registry-4.4 {GetKeyNames: empty key} {win reg} {
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar
|
||||
set result [registry keys HKEY_CURRENT_USER\\TclFoobar]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} {}
|
||||
test registry-4.5 {GetKeyNames: patterns} {win reg} {
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar\\baz
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar\\blat
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar\\foo
|
||||
set result [lsort [registry keys HKEY_CURRENT_USER\\TclFoobar b*]]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} {baz blat}
|
||||
test registry-4.6 {GetKeyNames: names with spaces} {win reg} {
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar\\baz\ bar
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar\\blat
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar\\foo
|
||||
set result [lsort [registry keys HKEY_CURRENT_USER\\TclFoobar b*]]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} {{baz bar} blat}
|
||||
test registry-4.7 {GetKeyNames: Unicode} {win reg english} {
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar\\baz\u00c7bar
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar\\blat
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar\\foo
|
||||
set result [lsort [registry keys HKEY_CURRENT_USER\\TclFoobar b*]]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} "baz\u00c7bar blat"
|
||||
test registry-4.8 {GetKeyNames: Unicode} {win reg nt} {
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar\\baz\u30b7bar
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar\\blat
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar\\foo
|
||||
set result [lsort [registry keys HKEY_CURRENT_USER\\TclFoobar b*]]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} "baz\u30b7bar blat"
|
||||
test registry-4.9 {GetKeyNames: very long key [Bug 1682211]} {*}{
|
||||
-constraints {win reg}
|
||||
-setup {
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar\\a
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar\\b[string repeat x 254]
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar\\c
|
||||
}
|
||||
-body {
|
||||
lsort [registry keys HKEY_CURRENT_USER\\TclFoobar]
|
||||
}
|
||||
-cleanup {
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
}} \
|
||||
-result [list a b[string repeat x 254] c]
|
||||
|
||||
test registry-5.1 {GetType} {win reg english} {
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
list [catch {registry type HKEY_CURRENT_USER\\TclFoobar val1} msg] $msg
|
||||
} {1 {unable to open key: The system cannot find the file specified.}}
|
||||
test registry-5.2 {GetType} {win reg english} {
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar
|
||||
list [catch {registry type HKEY_CURRENT_USER\\TclFoobar val1} msg] $msg
|
||||
} {1 {unable to get type of value "val1" from key "HKEY_CURRENT_USER\TclFoobar": The system cannot find the file specified.}}
|
||||
test registry-5.3 {GetType} {win reg} {
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar val1 foobar none
|
||||
set result [registry type HKEY_CURRENT_USER\\TclFoobar val1]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} none
|
||||
test registry-5.4 {GetType} {win reg} {
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar val1 foobar
|
||||
set result [registry type HKEY_CURRENT_USER\\TclFoobar val1]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} sz
|
||||
test registry-5.5 {GetType} {win reg} {
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar val1 foobar sz
|
||||
set result [registry type HKEY_CURRENT_USER\\TclFoobar val1]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} sz
|
||||
test registry-5.6 {GetType} {win reg} {
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar val1 foobar expand_sz
|
||||
set result [registry type HKEY_CURRENT_USER\\TclFoobar val1]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} expand_sz
|
||||
test registry-5.7 {GetType} {win reg} {
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar val1 1 binary
|
||||
set result [registry type HKEY_CURRENT_USER\\TclFoobar val1]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} binary
|
||||
test registry-5.8 {GetType} {win reg} {
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar val1 1 dword
|
||||
set result [registry type HKEY_CURRENT_USER\\TclFoobar val1]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} dword
|
||||
test registry-5.9 {GetType} {win reg} {
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar val1 1 dword_big_endian
|
||||
set result [registry type HKEY_CURRENT_USER\\TclFoobar val1]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} dword_big_endian
|
||||
test registry-5.10 {GetType} {win reg} {
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar val1 1 link
|
||||
set result [registry type HKEY_CURRENT_USER\\TclFoobar val1]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} link
|
||||
test registry-5.11 {GetType} {win reg} {
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar val1 foobar multi_sz
|
||||
set result [registry type HKEY_CURRENT_USER\\TclFoobar val1]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} multi_sz
|
||||
test registry-5.12 {GetType} {win reg} {
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar val1 1 resource_list
|
||||
set result [registry type HKEY_CURRENT_USER\\TclFoobar val1]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} resource_list
|
||||
test registry-5.13 {GetType: unknown types} {win reg} {
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar val1 1 24
|
||||
set result [registry type HKEY_CURRENT_USER\\TclFoobar val1]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} 24
|
||||
test registry-5.14 {GetType: Unicode} {win reg} {
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar va\u00c7l1 1 24
|
||||
set result [registry type HKEY_CURRENT_USER\\TclFoobar va\u00c7l1]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} 24
|
||||
|
||||
test registry-6.1 {GetValue} {win reg english} {
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
list [catch {registry get HKEY_CURRENT_USER\\TclFoobar val1} msg] $msg
|
||||
} {1 {unable to open key: The system cannot find the file specified.}}
|
||||
test registry-6.2 {GetValue} {win reg english} {
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar
|
||||
list [catch {registry get HKEY_CURRENT_USER\\TclFoobar val1} msg] $msg
|
||||
} {1 {unable to get value "val1" from key "HKEY_CURRENT_USER\TclFoobar": The system cannot find the file specified.}}
|
||||
test registry-6.3 {GetValue} {win reg} {
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar val1 foobar none
|
||||
set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} foobar
|
||||
test registry-6.4 {GetValue} {win reg} {
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar val1 foobar
|
||||
set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} foobar
|
||||
test registry-6.5 {GetValue} {win reg} {
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar val1 foobar sz
|
||||
set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} foobar
|
||||
test registry-6.6 {GetValue} {win reg} {
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar val1 foobar expand_sz
|
||||
set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} foobar
|
||||
test registry-6.7 {GetValue} {win reg} {
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar val1 1 binary
|
||||
set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} 1
|
||||
test registry-6.8 {GetValue} {win reg} {
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar val1 0x20 dword
|
||||
set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} 32
|
||||
test registry-6.9 {GetValue} {win reg} {
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar val1 0x20 dword_big_endian
|
||||
set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} 32
|
||||
test registry-6.10 {GetValue} {win reg} {
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar val1 1 link
|
||||
set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} 1
|
||||
test registry-6.11 {GetValue} {win reg} {
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar val1 foobar multi_sz
|
||||
set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} foobar
|
||||
test registry-6.12 {GetValue} {win reg} {
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar val1 {foo\ bar baz} multi_sz
|
||||
set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} {{foo bar} baz}
|
||||
test registry-6.13 {GetValue} {win reg} {
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar val1 {} multi_sz
|
||||
set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} {}
|
||||
test registry-6.14 {GetValue: truncation of multivalues with null elements} \
|
||||
{win reg} {
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar val1 {a {} b} multi_sz
|
||||
set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} a
|
||||
test registry-6.15 {GetValue} {win reg} {
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar val1 1 resource_list
|
||||
set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} 1
|
||||
test registry-6.16 {GetValue: unknown types} {win reg} {
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar val1 1 24
|
||||
set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} 1
|
||||
test registry-6.17 {GetValue: Unicode value names} {win reg} {
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar val\u00c71 foobar multi_sz
|
||||
set result [registry get HKEY_CURRENT_USER\\TclFoobar val\u00c71]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} foobar
|
||||
test registry-6.18 {GetValue: values with Unicode strings} {win reg nt} {
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar val1 {foo ba\u30b7r baz} multi_sz
|
||||
set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} "foo ba\u30b7r baz"
|
||||
test registry-6.19 {GetValue: values with Unicode strings} {win reg english} {
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar val1 {foo ba\u00c7r baz} multi_sz
|
||||
set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} "foo ba\u00c7r baz"
|
||||
test registry-6.20 {GetValue: values with Unicode strings with embedded nulls} {win reg} {
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar val1 {foo ba\u0000r baz} multi_sz
|
||||
set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} "foo ba r baz"
|
||||
test registry-6.21 {GetValue: very long value names and values} {pcOnly reg} {
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar [string repeat k 199] [string repeat x 199] multi_sz
|
||||
set result [registry get HKEY_CURRENT_USER\\TclFoobar [string repeat k 199]]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} [string repeat x 199]
|
||||
|
||||
test registry-7.1 {GetValueNames: bad key} {win reg english} {
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
list [catch {registry values HKEY_CURRENT_USER\\TclFoobar} msg] $msg
|
||||
} {1 {unable to open key: The system cannot find the file specified.}}
|
||||
test registry-7.2 {GetValueNames} {win reg} {
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar baz foobar
|
||||
set result [registry values HKEY_CURRENT_USER\\TclFoobar]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} baz
|
||||
test registry-7.3 {GetValueNames} {win reg} {
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar baz foobar1
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar blat foobar2
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar {} foobar3
|
||||
set result [lsort [registry values HKEY_CURRENT_USER\\TclFoobar]]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} {{} baz blat}
|
||||
test registry-7.4 {GetValueNames: remote key} {win reg nonPortable english} {
|
||||
set hostname [info hostname]
|
||||
registry set \\\\$hostname\\HKEY_CURRENT_USER\\TclFoobar baz blat
|
||||
set result [registry values \\\\$hostname\\HKEY_CURRENT_USER\\TclFoobar]
|
||||
registry delete \\\\$hostname\\HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} baz
|
||||
test registry-7.5 {GetValueNames: empty key} {win reg} {
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar
|
||||
set result [registry values HKEY_CURRENT_USER\\TclFoobar]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} {}
|
||||
test registry-7.6 {GetValueNames: patterns} {win reg} {
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar baz foobar1
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar blat foobar2
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar foo foobar3
|
||||
set result [lsort [registry values HKEY_CURRENT_USER\\TclFoobar b*]]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} {baz blat}
|
||||
test registry-7.7 {GetValueNames: names with spaces} {win reg} {
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar baz\ bar foobar1
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar blat foobar2
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar foo foobar3
|
||||
set result [lsort [registry values HKEY_CURRENT_USER\\TclFoobar b*]]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} {{baz bar} blat}
|
||||
|
||||
test registry-8.1 {OpenSubKey} {win reg nonPortable english} {
|
||||
# This test will only succeed if the current user does not have registry
|
||||
# access on the specified machine.
|
||||
list [catch {registry keys {\\mom\HKEY_LOCAL_MACHINE}} msg] $msg
|
||||
} {1 {unable to open key: Access is denied.}}
|
||||
test registry-8.2 {OpenSubKey} {win reg} {
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar
|
||||
set result [registry keys HKEY_CURRENT_USER TclFoobar]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} TclFoobar
|
||||
test registry-8.3 {OpenSubKey} {win reg english} {
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
list [catch {registry keys HKEY_CURRENT_USER\\TclFoobar} msg] $msg
|
||||
} {1 {unable to open key: The system cannot find the file specified.}}
|
||||
|
||||
test registry-9.1 {ParseKeyName: bad keys} {win reg} {
|
||||
list [catch {registry values \\} msg] $msg
|
||||
} "1 {bad key \"\\\": must start with a valid root}"
|
||||
test registry-9.2 {ParseKeyName: bad keys} {win reg} {
|
||||
list [catch {registry values \\foobar} msg] $msg
|
||||
} {1 {bad key "\foobar": must start with a valid root}}
|
||||
test registry-9.3 {ParseKeyName: bad keys} {win reg} {
|
||||
list [catch {registry values \\\\} msg] $msg
|
||||
} {1 {bad root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}}
|
||||
test registry-9.4 {ParseKeyName: bad keys} {win reg} {
|
||||
list [catch {registry values \\\\\\} msg] $msg
|
||||
} {1 {bad root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}}
|
||||
test registry-9.5 {ParseKeyName: bad keys} {win reg english nt} {
|
||||
list [catch {registry values \\\\\\HKEY_CURRENT_USER} msg] $msg
|
||||
} {1 {unable to open key: The network address is invalid.}}
|
||||
test registry-9.6 {ParseKeyName: bad keys} {win reg} {
|
||||
list [catch {registry values \\\\gaspode} msg] $msg
|
||||
} {1 {bad root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}}
|
||||
test registry-9.7 {ParseKeyName: bad keys} {win reg} {
|
||||
list [catch {registry values foobar} msg] $msg
|
||||
} {1 {bad root name "foobar": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}}
|
||||
test registry-9.8 {ParseKeyName: null keys} {win reg} {
|
||||
list [catch {registry delete HKEY_CURRENT_USER\\} msg] $msg
|
||||
} {1 {bad key: cannot delete root keys}}
|
||||
test registry-9.9 {ParseKeyName: null keys} {win reg english} {
|
||||
list [catch {registry keys HKEY_CURRENT_USER\\TclFoobar\\baz} msg] $msg
|
||||
} {1 {unable to open key: The system cannot find the file specified.}}
|
||||
|
||||
test registry-10.1 {RecursiveDeleteKey} {win reg} {
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar\\test1
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar\\test2\\test3
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result [registry keys HKEY_CURRENT_USER TclFoobar]
|
||||
set result
|
||||
} {}
|
||||
test registry-10.2 {RecursiveDeleteKey} {win reg} {
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar\\test1
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar\\test2\\test3
|
||||
set result [registry delete HKEY_CURRENT_USER\\TclFoobar\\test2\\test4]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} {}
|
||||
|
||||
test registry-11.1 {SetValue: recursive creation} {win reg} {
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar\\baz blat foobar
|
||||
set result [registry get HKEY_CURRENT_USER\\TclFoobar\\baz blat]
|
||||
} foobar
|
||||
test registry-11.2 {SetValue: modification} {win reg} {
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar\\baz blat foobar
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar\\baz blat frob
|
||||
set result [registry get HKEY_CURRENT_USER\\TclFoobar\\baz blat]
|
||||
} frob
|
||||
test registry-11.3 {SetValue: failure} {win reg nonPortable english} {
|
||||
# This test will only succeed if the current user does not have registry
|
||||
# access on the specified machine.
|
||||
list [catch {registry set {\\mom\HKEY_CURRENT_USER\TclFoobar} bar foobar} msg] $msg
|
||||
} {1 {unable to open key: Access is denied.}}
|
||||
|
||||
test registry-12.1 {BroadcastValue} {win reg} {
|
||||
list [catch {registry broadcast} msg] $msg
|
||||
} {1 {wrong # args: should be "registry broadcast keyName ?-timeout millisecs?"}}
|
||||
test registry-12.2 {BroadcastValue} {win reg} {
|
||||
list [catch {registry broadcast "" -time} msg] $msg
|
||||
} {1 {wrong # args: should be "registry broadcast keyName ?-timeout millisecs?"}}
|
||||
test registry-12.3 {BroadcastValue} {win reg} {
|
||||
list [catch {registry broadcast "" - 500} msg] $msg
|
||||
} {1 {wrong # args: should be "registry broadcast keyName ?-timeout millisecs?"}}
|
||||
test registry-12.4 {BroadcastValue} {win reg} {
|
||||
list [catch {registry broadcast {Environment}} msg] $msg
|
||||
} {0 {1 0}}
|
||||
test registry-12.5 {BroadcastValue} {win reg} {
|
||||
list [catch {registry b {}} msg] $msg
|
||||
} {0 {1 0}}
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# tcl-indent-level: 4
|
||||
# fill-column: 78
|
||||
# End:
|
||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user