Import Tcl-core 8.6.6 (as of svn r86089)
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.
|
||||
54
tests/aaa_exit.test
Normal file
54
tests/aaa_exit.test
Normal file
@@ -0,0 +1,54 @@
|
||||
# Commands covered: exit, emphasis on finalization hangs
|
||||
#
|
||||
# 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 exit-1.1 {normal, quick exit} {
|
||||
set f [open "|[interpreter] << \"exec [interpreter] << {set ::env(TCL_FINALIZE_ON_EXIT) 0;exit}\"" r]
|
||||
set aft [after 1000 {set done "Quick exit hangs !!!"}]
|
||||
fileevent $f readable {after cancel $aft;set done OK}
|
||||
vwait done
|
||||
if {$done != "OK"} {
|
||||
fconfigure $f -blocking 0
|
||||
close $f
|
||||
} else {
|
||||
if {[catch {close $f} err]} {
|
||||
set done "Quick exit misbehaves: $err"
|
||||
}
|
||||
}
|
||||
set done
|
||||
} OK
|
||||
|
||||
test exit-1.2 {full-finalized exit} {
|
||||
set f [open "|[interpreter] << \"exec [interpreter] << {set ::env(TCL_FINALIZE_ON_EXIT) 1;exit}\"" r]
|
||||
set aft [after 1000 {set done "Full-finalized exit hangs !!!"}]
|
||||
fileevent $f readable {after cancel $aft;set done OK}
|
||||
vwait done
|
||||
if {$done != "OK"} {
|
||||
fconfigure $f -blocking 0
|
||||
close $f
|
||||
} else {
|
||||
if {[catch {close $f} err]} {
|
||||
set done "Full-finalized exit misbehaves: $err"
|
||||
}
|
||||
}
|
||||
set done
|
||||
} OK
|
||||
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
22
tests/all.tcl
Normal file
22
tests/all.tcl
Normal file
@@ -0,0 +1,22 @@
|
||||
# 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 prefer latest
|
||||
package require Tcl 8.5
|
||||
package require tcltest 2.2
|
||||
namespace import tcltest::*
|
||||
configure {*}$argv -testdir [file dir [info script]]
|
||||
if {[singleProcess]} {
|
||||
interp debug {} -frame 1
|
||||
}
|
||||
runAllTests
|
||||
proc exit args {}
|
||||
323
tests/append.test
Normal file
323
tests/append.test
Normal file
@@ -0,0 +1,323 @@
|
||||
# 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::*
|
||||
}
|
||||
unset -nocomplain x
|
||||
|
||||
test append-1.1 {append command} {
|
||||
unset -nocomplain 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} -returnCodes error -body {
|
||||
append
|
||||
} -result {wrong # args: should be "append varName ?value ...?"}
|
||||
test append-3.2 {append errors} -returnCodes error -body {
|
||||
set x ""
|
||||
append x(0) 44
|
||||
} -result {can't set "x(0)": variable isn't array}
|
||||
test append-3.3 {append errors} -returnCodes error -body {
|
||||
unset -nocomplain x
|
||||
append x
|
||||
} -result {can't read "x": no such variable}
|
||||
|
||||
test append-4.1 {lappend command} {
|
||||
unset -nocomplain 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} -body {
|
||||
proc foo {} {
|
||||
global x
|
||||
set x old
|
||||
unset x
|
||||
lappend x new
|
||||
}
|
||||
foo
|
||||
} -cleanup {
|
||||
rename foo {}
|
||||
} -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} -returnCodes error -body {
|
||||
set x " \{"
|
||||
lappend x abc
|
||||
} -result {unmatched open brace in list}
|
||||
test append-4.10 {lappend command} -returnCodes error -body {
|
||||
set x " \{"
|
||||
lappend x abc
|
||||
} -result {unmatched open brace in list}
|
||||
test append-4.11 {lappend command} -returnCodes error -body {
|
||||
set x "\{\{\{"
|
||||
lappend x abc
|
||||
} -result {unmatched open brace in list}
|
||||
test append-4.12 {lappend command} -returnCodes error -body {
|
||||
set x "x \{\{\{"
|
||||
lappend x abc
|
||||
} -result {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} {
|
||||
unset -nocomplain x
|
||||
lappend x
|
||||
} {}
|
||||
test append-4.18 {lappend command} {
|
||||
unset -nocomplain x
|
||||
lappend x {}
|
||||
} {{}}
|
||||
test append-4.19 {lappend command} {
|
||||
unset -nocomplain x
|
||||
lappend x(0)
|
||||
} {}
|
||||
test append-4.20 {lappend command} {
|
||||
unset -nocomplain x
|
||||
lappend x(0) abc
|
||||
} {abc}
|
||||
unset -nocomplain x
|
||||
test append-4.21 {lappend command} -returnCodes error -body {
|
||||
set x \"
|
||||
lappend x
|
||||
} -result {unmatched open quote in list}
|
||||
test append-4.22 {lappend command} -returnCodes error -body {
|
||||
set x \"
|
||||
lappend x abc
|
||||
} -result {unmatched open quote in list}
|
||||
|
||||
test append-5.1 {long lappends} -setup {
|
||||
unset -nocomplain x
|
||||
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 ne "item $i"} {
|
||||
return "element $i should have been \"item $i\", was \"$j\""
|
||||
}
|
||||
}
|
||||
return ok
|
||||
}
|
||||
} -body {
|
||||
set x ""
|
||||
for {set i 0} {$i < 300} {incr i} {
|
||||
lappend x "item $i"
|
||||
}
|
||||
check $x 300
|
||||
} -cleanup {
|
||||
rename check {}
|
||||
} -result ok
|
||||
|
||||
test append-6.1 {lappend errors} -returnCodes error -body {
|
||||
lappend
|
||||
} -result {wrong # args: should be "lappend varName ?value ...?"}
|
||||
test append-6.2 {lappend errors} -returnCodes error -body {
|
||||
set x ""
|
||||
lappend x(0) 44
|
||||
} -result {can't set "x(0)": variable isn't array}
|
||||
|
||||
test append-7.1 {lappend-created var and error in trace on that var} -setup {
|
||||
catch {rename foo ""}
|
||||
unset -nocomplain x
|
||||
} -body {
|
||||
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
|
||||
} -result {0 1 {can't read "x": no such variable}}
|
||||
test append-7.2 {lappend var triggers read trace} -setup {
|
||||
unset -nocomplain myvar
|
||||
unset -nocomplain ::result
|
||||
} -body {
|
||||
trace variable myvar r foo
|
||||
proc foo {args} {append ::result $args}
|
||||
lappend myvar a
|
||||
return $::result
|
||||
} -result {myvar {} r}
|
||||
test append-7.3 {lappend var triggers read trace, array var} -setup {
|
||||
unset -nocomplain myvar
|
||||
unset -nocomplain ::result
|
||||
} -body {
|
||||
# The behavior of read triggers on lappend changed in 8.0 to not trigger
|
||||
# them, and was changed back in 8.4.
|
||||
trace variable myvar r foo
|
||||
proc foo {args} {append ::result $args}
|
||||
lappend myvar(b) a
|
||||
return $::result
|
||||
} -result {myvar b r}
|
||||
test append-7.4 {lappend var triggers read trace, array var exists} -setup {
|
||||
unset -nocomplain myvar
|
||||
unset -nocomplain ::result
|
||||
} -body {
|
||||
set myvar(0) 1
|
||||
trace variable myvar r foo
|
||||
proc foo {args} {append ::result $args}
|
||||
lappend myvar(b) a
|
||||
return $::result
|
||||
} -result {myvar b r}
|
||||
test append-7.5 {append var does not trigger read trace} -setup {
|
||||
unset -nocomplain myvar
|
||||
unset -nocomplain ::result
|
||||
} -body {
|
||||
trace variable myvar r foo
|
||||
proc foo {args} {append ::result $args}
|
||||
append myvar a
|
||||
info exists ::result
|
||||
} -result {0}
|
||||
|
||||
# THERE ARE NO append-8.* TESTS
|
||||
|
||||
# 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} -setup {
|
||||
unset -nocomplain myvar
|
||||
} -body {
|
||||
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
|
||||
} -result {0 {{new value}}}
|
||||
test append-9.1 {bug 3057639, lappend direct eval, read trace on non-existing env element} -setup {
|
||||
unset -nocomplain ::env(__DUMMY__)
|
||||
} -body {
|
||||
list [catch {
|
||||
lappend ::env(__DUMMY__) "new value"
|
||||
} msg] $msg
|
||||
} -cleanup {
|
||||
unset -nocomplain ::env(__DUMMY__)
|
||||
} -result {0 {{new value}}}
|
||||
test append-9.2 {bug 3057639, append direct eval, read trace on non-existing array variable element} -setup {
|
||||
unset -nocomplain myvar
|
||||
} -body {
|
||||
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
|
||||
} -result {0 {new value}}
|
||||
test append-9.3 {bug 3057639, append direct eval, read trace on non-existing env element} -setup {
|
||||
unset -nocomplain ::env(__DUMMY__)
|
||||
} -body {
|
||||
list [catch {
|
||||
append ::env(__DUMMY__) "new value"
|
||||
} msg] $msg
|
||||
} -cleanup {
|
||||
unset -nocomplain ::env(__DUMMY__)
|
||||
} -result {0 {new value}}
|
||||
|
||||
test append-10.1 {Bug 214cc0eb22: lappend with no values} {
|
||||
set lst "# 1 2 3"
|
||||
[subst lappend] lst
|
||||
} "# 1 2 3"
|
||||
test append-10.2 {Bug 214cc0eb22: lappend with no values} -body {
|
||||
set lst "1 \{ 2"
|
||||
[subst lappend] lst
|
||||
} -returnCodes error -result {unmatched open brace in list}
|
||||
test append-10.3 {Bug 214cc0eb22: expanded lappend with no values} {
|
||||
set lst "# 1 2 3"
|
||||
[subst lappend] lst {*}[list]
|
||||
} "# 1 2 3"
|
||||
test append-10.4 {Bug 214cc0eb22: expanded lappend with no values} -body {
|
||||
set lst "1 \{ 2"
|
||||
[subst lappend] lst {*}[list]
|
||||
} -returnCodes error -result {unmatched open brace in list}
|
||||
|
||||
unset -nocomplain i x result y
|
||||
catch {rename foo ""}
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# fill-column: 78
|
||||
# End:
|
||||
476
tests/appendComp.test
Normal file
476
tests/appendComp.test
Normal file
@@ -0,0 +1,476 @@
|
||||
# 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} -setup {
|
||||
unset -nocomplain x
|
||||
} -body {
|
||||
proc foo {} {append ::x 1 2 abc "long string"}
|
||||
list [foo] $x
|
||||
} -result {{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} -returnCodes error -body {
|
||||
proc foo {} {append}
|
||||
foo
|
||||
} -result {wrong # args: should be "append varName ?value ...?"}
|
||||
test appendComp-3.2 {append errors} -returnCodes error -body {
|
||||
proc foo {} {
|
||||
set x ""
|
||||
append x(0) 44
|
||||
}
|
||||
foo
|
||||
} -result {can't set "x(0)": variable isn't array}
|
||||
test appendComp-3.3 {append errors} -returnCodes error -body {
|
||||
proc foo {} {
|
||||
unset -nocomplain x
|
||||
append x
|
||||
}
|
||||
foo
|
||||
} -result {can't read "x": no such variable}
|
||||
|
||||
test appendComp-4.1 {lappend command} {
|
||||
proc foo {} {
|
||||
global x
|
||||
unset -nocomplain 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} -returnCodes error -body {
|
||||
proc foo {} {
|
||||
set x " \{"
|
||||
lappend x abc
|
||||
}
|
||||
foo
|
||||
} -result {unmatched open brace in list}
|
||||
test appendComp-4.10 {lappend command} -returnCodes error -body {
|
||||
proc foo {} {
|
||||
set x " \{"
|
||||
lappend x abc
|
||||
}
|
||||
foo
|
||||
} -result {unmatched open brace in list}
|
||||
test appendComp-4.11 {lappend command} -returnCodes error -body {
|
||||
proc foo {} {
|
||||
set x "\{\{\{"
|
||||
lappend x abc
|
||||
}
|
||||
foo
|
||||
} -result {unmatched open brace in list}
|
||||
test appendComp-4.12 {lappend command} -returnCodes error -body {
|
||||
proc foo {} {
|
||||
set x "x \{\{\{"
|
||||
lappend x abc
|
||||
}
|
||||
foo
|
||||
} -result {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}
|
||||
|
||||
test appendComp-5.1 {long lappends} -setup {
|
||||
unset -nocomplain x
|
||||
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} {incr i} {
|
||||
set j [lindex $var $i]
|
||||
if {$j ne "item $i"} {
|
||||
return "element $i should have been \"item $i\", was \"$j\""
|
||||
}
|
||||
}
|
||||
return ok
|
||||
}
|
||||
} -body {
|
||||
set x ""
|
||||
for {set i 0} {$i < 300} {set i [expr $i+1]} {
|
||||
lappend x "item $i"
|
||||
}
|
||||
check $x 300
|
||||
} -cleanup {
|
||||
unset -nocomplain x
|
||||
catch {rename check ""}
|
||||
} -result ok
|
||||
|
||||
test appendComp-6.1 {lappend errors} -returnCodes error -body {
|
||||
proc foo {} {lappend}
|
||||
foo
|
||||
} -result {wrong # args: should be "lappend varName ?value ...?"}
|
||||
test appendComp-6.2 {lappend errors} -returnCodes error -body {
|
||||
proc foo {} {
|
||||
set x ""
|
||||
lappend x(0) 44
|
||||
}
|
||||
foo
|
||||
} -result {can't set "x(0)": variable isn't array}
|
||||
|
||||
test appendComp-7.1 {lappendComp-created var and error in trace on that var} -setup {
|
||||
catch {rename foo ""}
|
||||
unset -nocomplain x
|
||||
} -body {
|
||||
proc bar {} {
|
||||
global 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
|
||||
} -result {0 1 {can't read "x": no such variable}}
|
||||
test appendComp-7.2 {lappend var triggers read trace, index var} -setup {
|
||||
unset -nocomplain ::result
|
||||
} -body {
|
||||
proc bar {} {
|
||||
trace variable myvar r foo
|
||||
proc foo {args} {append ::result $args}
|
||||
lappend myvar a
|
||||
return $::result
|
||||
}
|
||||
bar
|
||||
} -result {myvar {} r} -constraints {bug-3057639}
|
||||
test appendComp-7.3 {lappend var triggers read trace, stack var} -setup {
|
||||
unset -nocomplain ::result
|
||||
unset -nocomplain ::myvar
|
||||
} -body {
|
||||
proc bar {} {
|
||||
trace variable ::myvar r foo
|
||||
proc foo {args} {append ::result $args}
|
||||
lappend ::myvar a
|
||||
return $::result
|
||||
}
|
||||
bar
|
||||
} -result {::myvar {} r} -constraints {bug-3057639}
|
||||
test appendComp-7.4 {lappend var triggers read trace, array var} -setup {
|
||||
unset -nocomplain ::result
|
||||
} -body {
|
||||
# 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 {} {
|
||||
trace variable myvar r foo
|
||||
proc foo {args} {append ::result $args}
|
||||
lappend myvar(b) a
|
||||
return $::result
|
||||
}
|
||||
bar
|
||||
} -result {myvar b r} -constraints {bug-3057639}
|
||||
test appendComp-7.5 {lappend var triggers read trace, array var} -setup {
|
||||
unset -nocomplain ::result
|
||||
} -body {
|
||||
# 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 {} {
|
||||
trace variable myvar r foo
|
||||
proc foo {args} {append ::result $args}
|
||||
lappend myvar(b) a b
|
||||
return $::result
|
||||
}
|
||||
bar
|
||||
} -result {myvar b r}
|
||||
test appendComp-7.6 {lappend var triggers read trace, array var exists} -setup {
|
||||
unset -nocomplain ::result
|
||||
} -body {
|
||||
proc bar {} {
|
||||
set myvar(0) 1
|
||||
trace variable myvar r foo
|
||||
proc foo {args} {append ::result $args}
|
||||
lappend myvar(b) a
|
||||
return $::result
|
||||
}
|
||||
bar
|
||||
} -result {myvar b r} -constraints {bug-3057639}
|
||||
test appendComp-7.7 {lappend var triggers read trace, array stack var} -setup {
|
||||
unset -nocomplain ::myvar
|
||||
unset -nocomplain ::result
|
||||
} -body {
|
||||
proc bar {} {
|
||||
trace variable ::myvar r foo
|
||||
proc foo {args} {append ::result $args}
|
||||
lappend ::myvar(b) a
|
||||
return $::result
|
||||
}
|
||||
bar
|
||||
} -result {::myvar b r} -constraints {bug-3057639}
|
||||
test appendComp-7.8 {lappend var triggers read trace, array stack var} -setup {
|
||||
unset -nocomplain ::myvar
|
||||
unset -nocomplain ::result
|
||||
} -body {
|
||||
proc bar {} {
|
||||
trace variable ::myvar r foo
|
||||
proc foo {args} {append ::result $args}
|
||||
lappend ::myvar(b) a b
|
||||
return $::result
|
||||
}
|
||||
bar
|
||||
} -result {::myvar b r}
|
||||
test appendComp-7.9 {append var does not trigger read trace} -setup {
|
||||
unset -nocomplain ::result
|
||||
} -body {
|
||||
proc bar {} {
|
||||
trace variable myvar r foo
|
||||
proc foo {args} {append ::result $args}
|
||||
append myvar a
|
||||
info exists ::result
|
||||
}
|
||||
bar
|
||||
} -result {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} -setup {
|
||||
unset -nocomplain myvar
|
||||
array set myvar {}
|
||||
} -body {
|
||||
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
|
||||
} -result {0 {{new value}}}
|
||||
test appendComp-9.1 {bug 3057639, lappend direct eval, read trace on non-existing env element} -setup {
|
||||
unset -nocomplain ::env(__DUMMY__)
|
||||
} -body {
|
||||
proc foo {} {
|
||||
lappend ::env(__DUMMY__) "new value"
|
||||
}
|
||||
list [catch { foo } msg] $msg
|
||||
} -cleanup {
|
||||
unset -nocomplain ::env(__DUMMY__)
|
||||
} -result {0 {{new value}}}
|
||||
test appendComp-9.2 {bug 3057639, append compiled, read trace on non-existing array variable element} -setup {
|
||||
unset -nocomplain myvar
|
||||
array set myvar {}
|
||||
} -body {
|
||||
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
|
||||
} -result {0 {new value}}
|
||||
test appendComp-9.3 {bug 3057639, append direct eval, read trace on non-existing env element} -setup {
|
||||
unset -nocomplain ::env(__DUMMY__)
|
||||
} -body {
|
||||
proc foo {} {
|
||||
append ::env(__DUMMY__) "new value"
|
||||
}
|
||||
list [catch { foo } msg] $msg
|
||||
} -cleanup {
|
||||
unset -nocomplain ::env(__DUMMY__)
|
||||
} -result {0 {new value}}
|
||||
|
||||
test appendComp-10.1 {Bug 214cc0eb22: lappend with no values} {
|
||||
apply {lst {
|
||||
lappend lst
|
||||
}} "# 1 2 3"
|
||||
} "# 1 2 3"
|
||||
test appendComp-10.2 {Bug 214cc0eb22: lappend with no values} -body {
|
||||
apply {lst {
|
||||
lappend lst
|
||||
}} "1 \{ 2"
|
||||
} -returnCodes error -result {unmatched open brace in list}
|
||||
test appendComp-10.3 {Bug 214cc0eb22: expanded lappend with no values} {
|
||||
apply {lst {
|
||||
lappend lst {*}[list]
|
||||
}} "# 1 2 3"
|
||||
} "# 1 2 3"
|
||||
test appendComp-10.4 {Bug 214cc0eb22: expanded lappend with no values} -body {
|
||||
apply {lst {
|
||||
lappend lst {*}[list]
|
||||
}} "1 \{ 2"
|
||||
} -returnCodes error -result {unmatched open brace in list}
|
||||
|
||||
catch {unset i x result y}
|
||||
catch {rename foo ""}
|
||||
catch {rename bar ""}
|
||||
catch {rename check ""}
|
||||
catch {rename bar {}}
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# fill-column: 78
|
||||
# End:
|
||||
321
tests/apply.test
Normal file
321
tests/apply.test
Normal file
@@ -0,0 +1,321 @@
|
||||
# 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} -returnCodes error -body {
|
||||
apply
|
||||
} -result {wrong # args: should be "apply lambdaExpr ?arg ...?"}
|
||||
|
||||
# Tests for malformed lambda
|
||||
|
||||
test apply-2.0 {malformed lambda} -returnCodes error -body {
|
||||
set lambda a
|
||||
apply $lambda
|
||||
} -result {can't interpret "a" as a lambda expression}
|
||||
test apply-2.1 {malformed lambda} -returnCodes error -body {
|
||||
set lambda [list a b c d]
|
||||
apply $lambda
|
||||
} -result {can't interpret "a b c d" as a lambda expression}
|
||||
test apply-2.2 {malformed lambda} {
|
||||
set lambda [list {{}} boo]
|
||||
list [catch {apply $lambda} msg] $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]
|
||||
list [catch {apply $lambda} msg] $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]
|
||||
list [catch {apply $lambda} msg] $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]
|
||||
list [catch {apply $lambda} msg] $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} -body {
|
||||
set lambda [list x {set x 1}]
|
||||
apply $lambda
|
||||
} -returnCodes error -result {wrong # args: should be "apply lambdaExpr x"}
|
||||
test apply-4.2 {error in arguments to lambda expression} -body {
|
||||
set lambda [list x {set x 1}]
|
||||
apply $lambda a b
|
||||
} -returnCodes error -result {wrong # args: should be "apply lambdaExpr x"}
|
||||
test apply-4.3 {error in arguments to lambda expression} -body {
|
||||
interp alias {} foo {} ::apply [list x {set x 1}]
|
||||
foo a b
|
||||
} -cleanup {
|
||||
rename foo {}
|
||||
} -returnCodes error -result {wrong # args: should be "foo x"}
|
||||
test apply-4.4 {error in arguments to lambda expression} -body {
|
||||
interp alias {} foo {} ::apply [list x {set x 1}] a
|
||||
foo b
|
||||
} -cleanup {
|
||||
rename foo {}
|
||||
} -returnCodes error -result {wrong # args: should be "foo"}
|
||||
test apply-4.5 {error in arguments to lambda expression} -body {
|
||||
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"}
|
||||
}
|
||||
bar boo
|
||||
} -cleanup {
|
||||
namespace delete ::a
|
||||
} -returnCodes error -result {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
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# fill-column: 78
|
||||
# End:
|
||||
3378
tests/assemble.test
Normal file
3378
tests/assemble.test
Normal file
File diff suppressed because it is too large
Load Diff
68
tests/assocd.test
Normal file
68
tests/assocd.test
Normal file
@@ -0,0 +1,68 @@
|
||||
# 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::*
|
||||
|
||||
::tcltest::loadTestedCommands
|
||||
catch [list package require -exact Tcltest [info patchlevel]]
|
||||
|
||||
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
|
||||
216
tests/async.test
Normal file
216
tests/async.test
Normal file
@@ -0,0 +1,216 @@
|
||||
# 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::*
|
||||
}
|
||||
|
||||
::tcltest::loadTestedCommands
|
||||
catch [list package require -exact Tcltest [info patchlevel]]
|
||||
|
||||
testConstraint testasync [llength [info commands testasync]]
|
||||
testConstraint threaded [::tcl::pkgconfig get 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}}
|
||||
|
||||
test async-4.1 {async interrupting bytecode sequence} -constraints {
|
||||
testasync threaded
|
||||
} -setup {
|
||||
set hm [testasync create async3]
|
||||
proc nothing {} {
|
||||
# empty proc
|
||||
}
|
||||
} -body {
|
||||
apply {{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
|
||||
}} $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 {
|
||||
apply {{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
|
||||
}} $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 {
|
||||
apply [list {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
|
||||
}]] $hm
|
||||
} -result {test pattern} -cleanup {
|
||||
testasync delete $hm
|
||||
}
|
||||
|
||||
# cleanup
|
||||
if {[testConstraint testasync]} {
|
||||
testasync delete
|
||||
}
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# End:
|
||||
372
tests/autoMkindex.test
Normal file
372
tests/autoMkindex.test
Normal file
@@ -0,0 +1,372 @@
|
||||
# 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 {"::tcltest" ni [namespace children]} {
|
||||
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} -setup {
|
||||
file delete tclIndex
|
||||
} -body {
|
||||
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)]
|
||||
}
|
||||
}
|
||||
return $result
|
||||
} -cleanup {
|
||||
namespace delete tcl_autoMkindex_tmp
|
||||
} -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} -setup {
|
||||
file delete tclIndex
|
||||
interp create slave
|
||||
} -body {
|
||||
auto_mkindex . autoMkindex.tcl
|
||||
slave 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]
|
||||
}
|
||||
return $info
|
||||
}
|
||||
} -cleanup {
|
||||
interp delete slave
|
||||
} -result "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} -setup {
|
||||
file delete tclIndex
|
||||
} -body {
|
||||
auto_mkindex_parser::slavehook {
|
||||
_%@namespace eval ::blt {
|
||||
proc foo {} {}
|
||||
_%@namespace export foo
|
||||
}
|
||||
}
|
||||
auto_mkindex_parser::slavehook { _%@namespace import -force ::blt::* }
|
||||
auto_mkindex . autoMkindex.tcl
|
||||
file exists tclIndex
|
||||
} -cleanup {
|
||||
# Reset initCommands to avoid trashing other tests
|
||||
AutoMkindexTestReset
|
||||
} -result 1
|
||||
# The auto_mkindex_parser::command is used to register commands that create
|
||||
# new commands.
|
||||
test autoMkindex-3.2 {auto_mkindex_parser::command} -setup {
|
||||
file delete tclIndex
|
||||
} -body {
|
||||
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"
|
||||
}
|
||||
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)]
|
||||
}
|
||||
return $::result
|
||||
}
|
||||
} -cleanup {
|
||||
namespace delete tcl_autoMkindex_tmp
|
||||
# Reset initCommands to avoid trashing other tests
|
||||
AutoMkindexTestReset
|
||||
} -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} -setup {
|
||||
file delete tclIndex
|
||||
} -constraints {knownBug} -body {
|
||||
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"
|
||||
}
|
||||
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)]
|
||||
}
|
||||
}
|
||||
list [lsearch -inline $::result *mycmd4*] \
|
||||
[lsearch -inline $::result *mycmd5*] \
|
||||
[lsearch -inline $::result *mycmd6*]
|
||||
} -cleanup {
|
||||
namespace delete tcl_autoMkindex_tmp
|
||||
# Reset initCommands to avoid trashing other tests
|
||||
AutoMkindexTestReset
|
||||
} -result "{::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
|
||||
|
||||
test autoMkindex-4.1 {platform independent source commands} -setup {
|
||||
file delete tclIndex
|
||||
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]
|
||||
} -body {
|
||||
auto_mkindex . pkg/samename.tcl
|
||||
set f [open tclIndex r]
|
||||
lsort [lrange [split [string trim [read $f]] "\n"] end-1 end]
|
||||
} -cleanup {
|
||||
catch {close $f}
|
||||
removeFile [file join pkg samename.tcl]
|
||||
removeDirectory pkg
|
||||
} -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]]}}
|
||||
|
||||
test autoMkindex-5.1 {escape magic tcl chars in general code} -setup {
|
||||
file delete tclIndex
|
||||
makeDirectory pkg
|
||||
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]
|
||||
set result {}
|
||||
} -body {
|
||||
auto_mkindex . pkg/magicchar.tcl
|
||||
set f [open tclIndex r]
|
||||
lindex [split [string trim [read $f]] "\n"] end
|
||||
} -cleanup {
|
||||
catch {close $f}
|
||||
removeFile [file join pkg magicchar.tcl]
|
||||
removeDirectory pkg
|
||||
} -result {set auto_index(testProc) [list source [file join $dir pkg magicchar.tcl]]}
|
||||
test autoMkindex-5.2 {correctly locate auto loaded procs with []} -setup {
|
||||
file delete tclIndex
|
||||
makeDirectory pkg
|
||||
makeFile {
|
||||
proc {[magic mojo proc]} {} {}
|
||||
} [file join pkg magicchar2.tcl]
|
||||
set result {}
|
||||
interp create slave
|
||||
} -body {
|
||||
auto_mkindex . pkg/magicchar2.tcl
|
||||
# Make a slave interp to test the autoloading
|
||||
slave eval {lappend auto_path [pwd]}
|
||||
slave eval {catch {{[magic mojo proc]}}}
|
||||
} -cleanup {
|
||||
interp delete slave
|
||||
removeFile [file join pkg magicchar2.tcl]
|
||||
removeDirectory pkg
|
||||
} -result 0
|
||||
|
||||
# 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
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# fill-column: 78
|
||||
# End:
|
||||
987
tests/basic.test
Normal file
987
tests/basic.test
Normal file
@@ -0,0 +1,987 @@
|
||||
# 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::*
|
||||
|
||||
::tcltest::loadTestedCommands
|
||||
catch [list package require -exact Tcltest [info patchlevel]]
|
||||
|
||||
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} -constraints {
|
||||
testevalex
|
||||
} -body {
|
||||
testevalex {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
|
||||
2849
tests/binary.test
Normal file
2849
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? ?pattern 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
|
||||
275
tests/chan.test
Normal file
275
tests/chan.test
Normal file
@@ -0,0 +1,275 @@
|
||||
# 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 ?arg ...?\""
|
||||
test chan-1.2 {chan command general syntax} -body {
|
||||
chan FOOBAR
|
||||
} -returnCodes error -match glob -result "unknown or ambiguous subcommand \"FOOBAR\": must be *"
|
||||
|
||||
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 zet
|
||||
} -returnCodes error -result "wrong # args: should be \"chan close channelId ?direction?\""
|
||||
test chan-3.2 {chan command: close subcommand} -setup {
|
||||
set chan [open [info script] r]
|
||||
} -body {
|
||||
chan close $chan bar
|
||||
} -cleanup {
|
||||
close $chan
|
||||
} -returnCodes error -result "bad direction \"bar\": must be read or write"
|
||||
test chan-3.3 {chan command: close subcommand} -setup {
|
||||
set chan [open [info script] r]
|
||||
} -body {
|
||||
chan close $chan write
|
||||
} -cleanup {
|
||||
close $chan
|
||||
} -returnCodes error -result "Half-close of write-side not possible, side not opened or already closed"
|
||||
test chan-4.1 {chan command: configure subcommand} -body {
|
||||
chan configure
|
||||
} -returnCodes error -result "wrong # args: should be \"chan configure channelId ?-option 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 {} -cleanup {chan configure stdout -eofchar [list {} {}]}
|
||||
|
||||
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}
|
||||
}
|
||||
|
||||
# TIP 304: chan pipe
|
||||
|
||||
test chan-17.1 {chan command: pipe subcommand} -body {
|
||||
chan pipe foo
|
||||
} -returnCodes error -result "wrong # args: should be \"chan pipe \""
|
||||
|
||||
test chan-17.2 {chan command: pipe subcommand} -body {
|
||||
chan pipe foo bar
|
||||
} -returnCodes error -result "wrong # args: should be \"chan pipe \""
|
||||
|
||||
test chan-17.3 {chan command: pipe subcommand} -body {
|
||||
set l [chan pipe]
|
||||
foreach {pr pw} $l break
|
||||
list [llength $l] [fconfigure $pr -blocking] [fconfigure $pw -blocking]
|
||||
} -result [list 2 1 1] -cleanup {
|
||||
close $pw
|
||||
close $pr
|
||||
}
|
||||
|
||||
test chan-17.4 {chan command: pipe subcommand} -body {
|
||||
set ::done 0
|
||||
foreach {::pr ::pw} [chan pipe] break
|
||||
after 100 {puts $::pw foo;flush $::pw}
|
||||
fileevent $::pr readable {set ::done 1}
|
||||
after 500 {set ::done -1}
|
||||
vwait ::done
|
||||
set out nope
|
||||
if {$::done==1} {gets $::pr out}
|
||||
list $::done $out
|
||||
} -result [list 1 foo] -cleanup {
|
||||
close $::pw
|
||||
close $::pr
|
||||
}
|
||||
|
||||
cleanupTests
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# End:
|
||||
7742
tests/chanio.test
Normal file
7742
tests/chanio.test
Normal file
File diff suppressed because it is too large
Load Diff
36974
tests/clock.test
Normal file
36974
tests/clock.test
Normal file
File diff suppressed because it is too large
Load Diff
1665
tests/cmdAH.test
Normal file
1665
tests/cmdAH.test
Normal file
File diff suppressed because it is too large
Load Diff
745
tests/cmdIL.test
Normal file
745
tests/cmdIL.test
Normal file
@@ -0,0 +1,745 @@
|
||||
# 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::*
|
||||
}
|
||||
|
||||
::tcltest::loadTestedCommands
|
||||
catch [list package require -exact Tcltest [info patchlevel]]
|
||||
|
||||
# Used for constraining memory leak tests
|
||||
testConstraint memory [llength [info commands memory]]
|
||||
testConstraint testobj [llength [info commands testobj]]
|
||||
|
||||
test cmdIL-1.1 {Tcl_LsortObjCmd procedure} -returnCodes error -body {
|
||||
lsort
|
||||
} -result {wrong # args: should be "lsort ?-option value ...? list"}
|
||||
test cmdIL-1.2 {Tcl_LsortObjCmd procedure} -returnCodes error -body {
|
||||
lsort -foo {1 3 2 5}
|
||||
} -result {bad option "-foo": must be -ascii, -command, -decreasing, -dictionary, -increasing, -index, -indices, -integer, -nocase, -real, -stride, 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} -body {
|
||||
lsort -command {1 3 2 5}
|
||||
} -returnCodes error -result {"-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} -body {
|
||||
lsort -index {1 3 2 5}
|
||||
} -returnCodes error -result {"-index" option must be followed by list index}
|
||||
test cmdIL-1.12 {Tcl_LsortObjCmd procedure, -index option} -body {
|
||||
lsort -index foo {1 3 2 5}
|
||||
} -returnCodes error -result {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} -body {
|
||||
lsort -integer {1 3 2.4}
|
||||
} -returnCodes error -result {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} -body {
|
||||
lsort "1 2 3 \{ 4"
|
||||
} -returnCodes error -result {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]]
|
||||
lsort -command testcmp -index 1 $l
|
||||
} -cleanup {
|
||||
rename testcmp ""
|
||||
} -result [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]]
|
||||
lsort -index 1 -command testcmp $l
|
||||
} -cleanup {
|
||||
rename testcmp ""
|
||||
} -result [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
|
||||
test cmdIL-1.30 {Tcl_LsortObjCmd procedure, -stride option} {
|
||||
lsort -stride 2 {f e d c b a}
|
||||
} {b a d c f e}
|
||||
test cmdIL-1.31 {Tcl_LsortObjCmd procedure, -stride option} {
|
||||
lsort -stride 3 {f e d c b a}
|
||||
} {c b a f e d}
|
||||
test cmdIL-1.32 {lsort -stride errors} -returnCodes error -body {
|
||||
lsort -stride foo bar
|
||||
} -result {expected integer but got "foo"}
|
||||
test cmdIL-1.33 {lsort -stride errors} -returnCodes error -body {
|
||||
lsort -stride 1 bar
|
||||
} -result {stride length must be at least 2}
|
||||
test cmdIL-1.34 {lsort -stride errors} -returnCodes error -body {
|
||||
lsort -stride 2 {a b c}
|
||||
} -result {list size must be a multiple of the stride length}
|
||||
test cmdIL-1.35 {lsort -stride errors} -returnCodes error -body {
|
||||
lsort -stride 2 -index 3 {a b c d}
|
||||
} -result {when used with "-stride", the leading "-index" value must be within the group}
|
||||
test cmdIL-1.36 {lsort -stride and -index: Bug 2918962} {
|
||||
lsort -stride 2 -index {0 1} {
|
||||
{{c o d e} 54321} {{b l a h} 94729}
|
||||
{{b i g} 12345} {{d e m o} 34512}
|
||||
}
|
||||
} {{{b i g} 12345} {{d e m o} 34512} {{c o d e} 54321} {{b l a h} 94729}}
|
||||
|
||||
# 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
|
||||
}
|
||||
}
|
||||
string trim $result
|
||||
} -cleanup {
|
||||
rename rand ""
|
||||
} -result {}
|
||||
|
||||
test cmdIL-3.1 {SortCompare procedure, skip comparisons after error} -body {
|
||||
set ::x 0
|
||||
list [catch {
|
||||
lsort -integer -command {apply {{a b} {
|
||||
incr ::x
|
||||
error "error #$::x"
|
||||
}}} {48 6 28 190 16 2 3 6 1}
|
||||
} msg] $msg $::x
|
||||
} -result {1 {error #1} 1}
|
||||
test cmdIL-3.2 {SortCompare procedure, -index option} -body {
|
||||
lsort -integer -index 2 "\\\{ {30 40 50}"
|
||||
} -returnCodes error -result {unmatched open brace in list}
|
||||
test cmdIL-3.3 {SortCompare procedure, -index option} -body {
|
||||
lsort -integer -index 2 {{20 10} {15 30 40}}
|
||||
} -returnCodes error -result {element 2 missing from sublist "20 10"}
|
||||
test cmdIL-3.4 {SortCompare procedure, -index option} -body {
|
||||
lsort -integer -index 2 "{a b c} \\\{"
|
||||
} -returnCodes error -result {expected integer but got "c"}
|
||||
test cmdIL-3.4.1 {SortCompare procedure, -index option} -body {
|
||||
lsort -integer -index 2 "{1 2 3} \\\{"
|
||||
} -returnCodes error -result {unmatched open brace in list}
|
||||
test cmdIL-3.5 {SortCompare procedure, -index option} -body {
|
||||
lsort -integer -index 2 {{20 10 13} {15}}
|
||||
} -returnCodes error -result {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} -body {
|
||||
lsort -integer {x 3}
|
||||
} -returnCodes error -result {expected integer but got "x"}
|
||||
test cmdIL-3.10 {SortCompare procedure, -integer option} -body {
|
||||
lsort -integer {3 q}
|
||||
} -returnCodes error -result {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} -body {
|
||||
lsort -real {6...4 3}
|
||||
} -returnCodes error -result {expected floating-point number but got "6...4"}
|
||||
test cmdIL-3.13 {SortCompare procedure, -real option} -body {
|
||||
lsort -real {3 1x7}
|
||||
} -returnCodes error -result {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
|
||||
}
|
||||
lsort -command cmp {48 6}
|
||||
} -returnCodes error -cleanup {
|
||||
rename cmp ""
|
||||
} -result {-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 ""
|
||||
}
|
||||
test cmdIL-5.6 {lsort with multiple list-style index options} {
|
||||
lsort -index {1 2 3} -index 0 {{a b} {c d} {b e}}
|
||||
} {{a b} {b e} {c d}}
|
||||
|
||||
# Compiled version
|
||||
test cmdIL-6.1 {lassign command syntax} -returnCodes error -body {
|
||||
apply {{} { lassign }}
|
||||
} -result {wrong # args: should be "lassign list ?varName ...?"}
|
||||
test cmdIL-6.2 {lassign command syntax} {
|
||||
apply {{} { lassign x }}
|
||||
} x
|
||||
test cmdIL-6.3 {lassign command} -body {
|
||||
apply {{} {
|
||||
set x FAIL
|
||||
list [lassign a x] $x
|
||||
}}
|
||||
} -result {{} a}
|
||||
test cmdIL-6.4 {lassign command} -body {
|
||||
apply {{} {
|
||||
set x FAIL
|
||||
set y FAIL
|
||||
list [lassign a x y] $x $y
|
||||
}}
|
||||
} -result {{} a {}}
|
||||
test cmdIL-6.5 {lassign command} -body {
|
||||
apply {{} {
|
||||
set x FAIL
|
||||
set y FAIL
|
||||
list [lassign {a b} x y] $x $y
|
||||
}}
|
||||
} -result {{} a b}
|
||||
test cmdIL-6.6 {lassign command} -body {
|
||||
apply {{} {
|
||||
set x FAIL
|
||||
set y FAIL
|
||||
list [lassign {a b c} x y] $x $y
|
||||
}}
|
||||
} -result {c a b}
|
||||
test cmdIL-6.7 {lassign command} -body {
|
||||
apply {{} {
|
||||
set x FAIL
|
||||
set y FAIL
|
||||
list [lassign {a b c d} x y] $x $y
|
||||
}}
|
||||
} -result {{c d} a b}
|
||||
test cmdIL-6.8 {lassign command - list format error} -body {
|
||||
apply {{} {
|
||||
set x FAIL
|
||||
set y FAIL
|
||||
list [catch {lassign {a {b}c d} x y} msg] $msg $x $y
|
||||
}}
|
||||
} -result {1 {list element in braces followed by "c" instead of space} FAIL FAIL}
|
||||
test cmdIL-6.9 {lassign command - assignment to arrays} -body {
|
||||
apply {{} {
|
||||
list [lassign {a b} x(x)] $x(x)
|
||||
}}
|
||||
} -result {b a}
|
||||
test cmdIL-6.10 {lassign command - variable update error} -body {
|
||||
apply {{} {
|
||||
set x(x) {}
|
||||
lassign a x
|
||||
}}
|
||||
} -returnCodes error -result {can't set "x": variable is array}
|
||||
test cmdIL-6.11 {lassign command - variable update error} -body {
|
||||
apply {{} {
|
||||
set x(x) {}
|
||||
set y FAIL
|
||||
list [catch {lassign a y x} msg] $msg $y
|
||||
}}
|
||||
} -result {1 {can't set "x": variable is array} a}
|
||||
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} -returnCodes error -body {
|
||||
apply {{} {
|
||||
set lassign lassign
|
||||
$lassign
|
||||
}}
|
||||
} -result {wrong # args: should be "lassign list ?varName ...?"}
|
||||
test cmdIL-6.14 {lassign command syntax} {
|
||||
apply {{} {
|
||||
set lassign lassign
|
||||
$lassign x
|
||||
}}
|
||||
} x
|
||||
test cmdIL-6.15 {lassign command} -body {
|
||||
apply {{} {
|
||||
set lassign lassign
|
||||
set x FAIL
|
||||
list [$lassign a x] $x
|
||||
}}
|
||||
} -result {{} a}
|
||||
test cmdIL-6.16 {lassign command} -body {
|
||||
apply {{} {
|
||||
set lassign lassign
|
||||
set x FAIL
|
||||
set y FAIL
|
||||
list [$lassign a x y] $x $y
|
||||
}}
|
||||
} -result {{} a {}}
|
||||
test cmdIL-6.17 {lassign command} -body {
|
||||
apply {{} {
|
||||
set lassign lassign
|
||||
set x FAIL
|
||||
set y FAIL
|
||||
list [$lassign {a b} x y] $x $y
|
||||
}}
|
||||
} -result {{} a b}
|
||||
test cmdIL-6.18 {lassign command} -body {
|
||||
apply {{} {
|
||||
set lassign lassign
|
||||
set x FAIL
|
||||
set y FAIL
|
||||
list [$lassign {a b c} x y] $x $y
|
||||
}}
|
||||
} -result {c a b}
|
||||
test cmdIL-6.19 {lassign command} -body {
|
||||
apply {{} {
|
||||
set lassign lassign
|
||||
set x FAIL
|
||||
set y FAIL
|
||||
list [$lassign {a b c d} x y] $x $y
|
||||
}}
|
||||
} -result {{c d} a b}
|
||||
test cmdIL-6.20 {lassign command - list format error} -body {
|
||||
apply {{} {
|
||||
set lassign lassign
|
||||
set x FAIL
|
||||
set y FAIL
|
||||
list [catch {$lassign {a {b}c d} x y} msg] $msg $x $y
|
||||
}}
|
||||
} -result {1 {list element in braces followed by "c" instead of space} FAIL FAIL}
|
||||
test cmdIL-6.21 {lassign command - assignment to arrays} -body {
|
||||
apply {{} {
|
||||
set lassign lassign
|
||||
list [$lassign {a b} x(x)] $x(x)
|
||||
}}
|
||||
} -result {b a}
|
||||
test cmdIL-6.22 {lassign command - variable update error} -body {
|
||||
apply {{} {
|
||||
set lassign lassign
|
||||
set x(x) {}
|
||||
$lassign a x
|
||||
}}
|
||||
} -returnCodes 1 -result {can't set "x": variable is array}
|
||||
test cmdIL-6.23 {lassign command - variable update error} -body {
|
||||
apply {{} {
|
||||
set lassign lassign
|
||||
set x(x) {}
|
||||
set y FAIL
|
||||
list [catch {$lassign a y x} msg] $msg $y
|
||||
}}
|
||||
} -result {1 {can't set "x": variable is array} a}
|
||||
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 {
|
||||
apply {{} {
|
||||
set x {a b c}
|
||||
list [lassign $x $x y] $x [set $x] $y
|
||||
}}
|
||||
} -result {c {a b c} a b}
|
||||
test cmdIL-6.26 {lassign command - shimmering protection} -body {
|
||||
apply {{} {
|
||||
set x {a b c}
|
||||
set lassign lassign
|
||||
list [$lassign $x $x y] $x [set $x] $y
|
||||
}}
|
||||
} -result {c {a b c} a b}
|
||||
|
||||
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]
|
||||
} {}
|
||||
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:
|
||||
107
tests/cmdInfo.test
Normal file
107
tests/cmdInfo.test
Normal file
@@ -0,0 +1,107 @@
|
||||
# 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::*
|
||||
|
||||
::tcltest::loadTestedCommands
|
||||
catch [list package require -exact Tcltest [info patchlevel]]
|
||||
|
||||
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:
|
||||
355
tests/cmdMZ.test
Normal file
355
tests/cmdMZ.test
Normal file
@@ -0,0 +1,355 @@
|
||||
# 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
|
||||
|
||||
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]
|
||||
|
||||
# Tcl_PwdObjCmd
|
||||
|
||||
test cmdMZ-1.1 {Tcl_PwdObjCmd} -returnCodes error -body {
|
||||
pwd a
|
||||
} -result {wrong # args: should be "pwd"}
|
||||
test cmdMZ-1.2 {Tcl_PwdObjCmd: simple pwd} {
|
||||
catch pwd
|
||||
} 0
|
||||
test cmdMZ-1.3 {Tcl_PwdObjCmd: simple pwd} -body {
|
||||
pwd
|
||||
} -match glob -result {?*}
|
||||
test cmdMZ-1.4 {Tcl_PwdObjCmd: failure} -setup {
|
||||
set cwd [pwd]
|
||||
set foodir [file join [temporaryDirectory] foo]
|
||||
file delete -force $foodir
|
||||
file mkdir $foodir
|
||||
cd $foodir
|
||||
} -constraints {unix nonPortable} -body {
|
||||
# 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.
|
||||
file attr . -permissions 000
|
||||
pwd
|
||||
} -returnCodes error -cleanup {
|
||||
cd $cwd
|
||||
file delete -force $foodir
|
||||
} -result {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} -returnCodes error -body {
|
||||
rename r1
|
||||
} -result {wrong # args: should be "rename oldName newName"}
|
||||
test cmdMZ-2.2 {Tcl_RenameObjCmd: error conditions} -returnCodes error -body {
|
||||
rename r1 r2 r3
|
||||
} -result {wrong # args: should be "rename oldName newName"}
|
||||
test cmdMZ-2.3 {Tcl_RenameObjCmd: success} -setup {
|
||||
catch {rename r2 {}}
|
||||
} -body {
|
||||
proc r1 {} {return "r1"}
|
||||
rename r1 r2
|
||||
r2
|
||||
} -result {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 err
|
||||
} -returnCodes error -match glob -result {bad completion code "err": must be ok, error, return, break, continue*, or an integer}
|
||||
test cmdMZ-return-1.2 {return checks for bad option values} -body {
|
||||
return -code 0x100000000
|
||||
} -returnCodes error -match glob -result {bad completion code "0x100000000": must be ok, error, return, break, continue*, or an integer}
|
||||
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} {
|
||||
set result {}
|
||||
foreach k [lsort [dict keys $d]] {
|
||||
dict set 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} -body {
|
||||
list [catch {return -level 0 -code error} -> foo] [dictSort $foo]
|
||||
} -match glob -result {1 {-code 1 -errorcode NONE -errorinfo {
|
||||
while executing
|
||||
"return -level 0 -code error"} -errorline 1 -errorstack * -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 err}
|
||||
} -returnCodes error -match glob -result {bad completion code "err": must be ok, error, return, break, continue*, or an integer}
|
||||
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} {
|
||||
list [catch {
|
||||
apply {{} {
|
||||
return -code error -errorcode {a b} c
|
||||
}}
|
||||
} result] $result $::errorCode
|
||||
} {1 c {a b}}
|
||||
test cmdMZ-return-2.16 {return opton handling} {
|
||||
list [catch {
|
||||
apply {{} {
|
||||
return -code error -errorcode [list a b] c
|
||||
}}
|
||||
} result] $result $::errorCode
|
||||
} {1 c {a b}}
|
||||
test cmdMZ-return-2.17 {return opton handling} {
|
||||
list [catch {
|
||||
apply {{} {
|
||||
return -code error -errorcode a\ b c
|
||||
}}
|
||||
} result] $result $::errorCode
|
||||
} {1 c {a b}}
|
||||
test cmdMZ-return-2.18 {return option handling} {
|
||||
list [catch {
|
||||
return -code error -errorstack [list CALL a CALL b] yo
|
||||
} -> foo] [dictSort $foo] [info errorstack]
|
||||
} {2 {-code 1 -errorcode NONE -errorstack {CALL a CALL b} -level 1} {CALL a CALL 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)
|
||||
foreach {testid script} {
|
||||
cmdMZ-return-3.0 {}
|
||||
cmdMZ-return-3.1 {format x}
|
||||
cmdMZ-return-3.2 {set}
|
||||
cmdMZ-return-3.3 {set a 1}
|
||||
cmdMZ-return-3.4 {error}
|
||||
cmdMZ-return-3.5 {error foo}
|
||||
cmdMZ-return-3.6 {error foo bar}
|
||||
cmdMZ-return-3.7 {error foo bar baz}
|
||||
cmdMZ-return-3.8 {return -level 0}
|
||||
cmdMZ-return-3.9 {return -code error}
|
||||
cmdMZ-return-3.10 {return -code error -errorinfo foo}
|
||||
cmdMZ-return-3.11 {return -code error -errorinfo foo -errorcode bar}
|
||||
cmdMZ-return-3.12 {return -code error -errorinfo foo -errorcode bar -errorline 10}
|
||||
cmdMZ-return-3.12.1 {return -code error -errorinfo foo -errorcode bar -errorline 10 -errorstack baz}
|
||||
cmdMZ-return-3.13 {return -options {x y z 2}}
|
||||
cmdMZ-return-3.14 {return -level 3 -code break sdf}
|
||||
} {
|
||||
test $testid "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
|
||||
}
|
||||
|
||||
# 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
|
||||
} -returnCodes error -body {
|
||||
source
|
||||
} -match glob -result {wrong # args: should be "source*fileName"}
|
||||
test cmdMZ-3.4 {Tcl_SourceObjCmd: error conditions} -constraints {
|
||||
unixOrPc
|
||||
} -returnCodes error -body {
|
||||
source a b
|
||||
} -match glob -result {wrong # args: should be "source*fileName"}
|
||||
test cmdMZ-3.5 {Tcl_SourceObjCmd: error in script} -body {
|
||||
set file [makeFile {
|
||||
set x 146
|
||||
error "error in sourced file"
|
||||
set y $x
|
||||
} source.file]
|
||||
list [catch {source $file} msg] $msg $::errorInfo
|
||||
} -cleanup {
|
||||
removeFile source.file
|
||||
} -match listGlob -result {1 {error in sourced file} {error in sourced file
|
||||
while executing
|
||||
"error "error in sourced file""
|
||||
(file "*" line 3)
|
||||
invoked from within
|
||||
"source $file"}}
|
||||
test cmdMZ-3.6 {Tcl_SourceObjCmd: simple script} -body {
|
||||
set file [makeFile {list ok} source.file]
|
||||
source $file
|
||||
} -cleanup {
|
||||
removeFile source.file
|
||||
} -result ok
|
||||
|
||||
# Tcl_SplitObjCmd
|
||||
|
||||
test cmdMZ-4.1 {Tcl_SplitObjCmd: split errors} -returnCodes error -body {
|
||||
split
|
||||
} -result {wrong # args: should be "split string ?splitChars?"}
|
||||
test cmdMZ-4.2 {Tcl_SplitObjCmd: split errors} -returnCodes error -body {
|
||||
split a b c
|
||||
} -result {wrong # args: should be "split string ?splitChars?"}
|
||||
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} {
|
||||
apply {{} {
|
||||
set x {}
|
||||
foreach f [split {]\n} {}] {
|
||||
append x $f
|
||||
}
|
||||
return $x
|
||||
}}
|
||||
} {]\n}
|
||||
test cmdMZ-4.11 {Tcl_SplitObjCmd: basic split commands} {
|
||||
apply {{} {
|
||||
set x ab\000c
|
||||
set y [split $x {}]
|
||||
binary scan $y c* z
|
||||
return $z
|
||||
}}
|
||||
} {97 32 98 32 0 32 99}
|
||||
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} -body {
|
||||
time
|
||||
} -returnCodes error -result {wrong # args: should be "time command ?count?"}
|
||||
test cmdMZ-5.2 {Tcl_TimeObjCmd: basic format of command} -body {
|
||||
time a b c
|
||||
} -returnCodes error -result {wrong # args: should be "time command ?count?"}
|
||||
test cmdMZ-5.3 {Tcl_TimeObjCmd: basic format of command} -body {
|
||||
time a b
|
||||
} -returnCodes error -result {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} -body {
|
||||
time {format 1}
|
||||
} -match regexp -result {^\d+ microseconds per iteration}
|
||||
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
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# End:
|
||||
677
tests/compExpr-old.test
Normal file
677
tests/compExpr-old.test
Normal file
@@ -0,0 +1,677 @@
|
||||
# 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::*
|
||||
}
|
||||
|
||||
::tcltest::loadTestedCommands
|
||||
catch [list package require -exact Tcltest [info patchlevel]]
|
||||
|
||||
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
|
||||
396
tests/compExpr.test
Normal file
396
tests/compExpr.test
Normal file
@@ -0,0 +1,396 @@
|
||||
# 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 {"::tcltest" ni [namespace children]} {
|
||||
package require tcltest 2
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
::tcltest::loadTestedCommands
|
||||
catch [list package require -exact Tcltest [info patchlevel]]
|
||||
|
||||
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} -setup {
|
||||
unset -nocomplain a
|
||||
} -body {
|
||||
set a 27
|
||||
expr {"foo$a" < "bar"}
|
||||
} -result 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} -setup {
|
||||
unset -nocomplain a
|
||||
} -body {
|
||||
set a 123
|
||||
expr {$a*2}
|
||||
} -result 246
|
||||
test compExpr-2.10 {CompileSubExpr procedure, TCL_TOKEN_VARIABLE parse token} -setup {
|
||||
unset -nocomplain a
|
||||
unset -nocomplain b
|
||||
} -body {
|
||||
set a(george) martha
|
||||
set b geo
|
||||
expr {$a(${b}rge)}
|
||||
} -result martha
|
||||
test compExpr-2.11 {CompileSubExpr procedure, error in TCL_TOKEN_VARIABLE parse token} -body {
|
||||
unset -nocomplain a
|
||||
expr {$a + 17}
|
||||
} -returnCodes error -result {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} -setup {
|
||||
unset -nocomplain a
|
||||
} -body {
|
||||
set a 15
|
||||
list [catch {expr {27 || "$a[expr 1+]00"}} msg] $msg
|
||||
} -result {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} -setup {
|
||||
unset -nocomplain a
|
||||
} -body {
|
||||
set a 15
|
||||
expr {$a==15} ;# compiled out-of-line to runtime call on Tcl_ExprObjCmd
|
||||
} -result 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} -setup {
|
||||
unset -nocomplain a
|
||||
} -body {
|
||||
set a true
|
||||
expr {0||$a}
|
||||
} -result 1
|
||||
test compExpr-2.42 {CompileSubExpr procedure, error in TCL_TOKEN_SUB_EXPR parse token} -setup {
|
||||
unset -nocomplain a
|
||||
} -body {
|
||||
set a 15
|
||||
list [catch {expr {27 || "$a[expr 1+]00"}} msg] $msg
|
||||
} -result {0 1}
|
||||
test compExpr-2.43 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} -setup {
|
||||
unset -nocomplain a
|
||||
} -body {
|
||||
set a false
|
||||
expr {3&&$a}
|
||||
} -result 0
|
||||
test compExpr-2.44 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} -setup {
|
||||
unset -nocomplain a
|
||||
} -body {
|
||||
set a false
|
||||
expr {$a||1? 1 : 0}
|
||||
} -result 1
|
||||
test compExpr-2.45 {CompileSubExpr procedure, error in TCL_TOKEN_SUB_EXPR parse token} -setup {
|
||||
unset -nocomplain a
|
||||
} -body {
|
||||
set a 15
|
||||
list [catch {expr {1? 54 : "$a[expr 1+]00"}} msg] $msg
|
||||
} -result {0 54}
|
||||
|
||||
test compExpr-3.1 {CompileLandOrLorExpr procedure, numeric 1st operand} -setup {
|
||||
unset -nocomplain a
|
||||
} -body {
|
||||
set a 2
|
||||
expr {[set a]||0}
|
||||
} -result 1
|
||||
test compExpr-3.2 {CompileLandOrLorExpr procedure, nonnumeric 1st operand} -setup {
|
||||
unset -nocomplain a
|
||||
} -body {
|
||||
set a no
|
||||
expr {$a&&1}
|
||||
} -result 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} -setup {
|
||||
unset -nocomplain a
|
||||
unset -nocomplain b
|
||||
} -body {
|
||||
set a no
|
||||
set b true
|
||||
expr {$a || $b}
|
||||
} -result 1
|
||||
test compExpr-3.5 {CompileLandOrLorExpr procedure, short-circuit semantics} -setup {
|
||||
unset -nocomplain a
|
||||
} -body {
|
||||
set a yes
|
||||
expr {$a || [exit]}
|
||||
} -result 1
|
||||
test compExpr-3.6 {CompileLandOrLorExpr procedure, short-circuit semantics} -setup {
|
||||
unset -nocomplain a
|
||||
} -body {
|
||||
set a no
|
||||
expr {$a && [exit]}
|
||||
} -result 0
|
||||
test compExpr-3.7 {CompileLandOrLorExpr procedure, numeric 2nd operand} -setup {
|
||||
unset -nocomplain a
|
||||
} -body {
|
||||
set a 2
|
||||
expr {0||[set a]}
|
||||
} -result 1
|
||||
test compExpr-3.8 {CompileLandOrLorExpr procedure, nonnumeric 2nd operand} -setup {
|
||||
unset -nocomplain a
|
||||
} -body {
|
||||
set a no
|
||||
expr {1&&$a}
|
||||
} -result 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} -setup {
|
||||
unset -nocomplain a
|
||||
} -body {
|
||||
set a 2
|
||||
expr {($a > 1)? "ok" : "nope"}
|
||||
} -result ok
|
||||
test compExpr-4.2 {CompileCondExpr procedure, complex test, convert to numeric} -setup {
|
||||
unset -nocomplain a
|
||||
} -body {
|
||||
set a no
|
||||
expr {[set a]? 27 : -54}
|
||||
} -result -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} -setup {
|
||||
unset -nocomplain a
|
||||
} -body {
|
||||
set a no
|
||||
expr {1? (27-2) : -54}
|
||||
} -result 25
|
||||
test compExpr-4.5 {CompileCondExpr procedure, convert "true" clause to numeric} -setup {
|
||||
unset -nocomplain a
|
||||
} -body {
|
||||
set a no
|
||||
expr {1? $a : -54}
|
||||
} -result 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} -setup {
|
||||
unset -nocomplain a
|
||||
} -body {
|
||||
set a no
|
||||
expr {(2-2)? -3.14159 : "nope"}
|
||||
} -result nope
|
||||
test compExpr-4.8 {CompileCondExpr procedure, convert "false" clause to numeric} -setup {
|
||||
unset -nocomplain a
|
||||
} -body {
|
||||
set a 0o0123
|
||||
expr {0? 42 : $a}
|
||||
} -result 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 {
|
||||
expr {do_it()}
|
||||
} -returnCodes error -match glob -result {* "*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 {
|
||||
expr {atan2(1.0)}
|
||||
} -returnCodes error -match glob -result {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 {
|
||||
expr {sinh(2.0, 3.0)}
|
||||
} -returnCodes error -match glob -result {too many arguments for math function*}
|
||||
test compExpr-5.9 {CompileMathFuncCall procedure, too many arguments} -body {
|
||||
expr {0 <= rand(5.2)}
|
||||
} -returnCodes error -match glob -result {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
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# fill-column: 78
|
||||
# End:
|
||||
1056
tests/compile.test
Normal file
1056
tests/compile.test
Normal file
File diff suppressed because it is too large
Load Diff
57
tests/concat.test
Normal file
57
tests/concat.test
Normal file
@@ -0,0 +1,57 @@
|
||||
# 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 {"::tcltest" ni [namespace children]} {
|
||||
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
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# fill-column: 78
|
||||
# End:
|
||||
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 ?arg?"}
|
||||
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 ?arg?"}
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
753
tests/coroutine.test
Normal file
753
tests/coroutine.test
Normal file
@@ -0,0 +1,753 @@
|
||||
# Commands covered: coroutine, yield, yieldto, [info coroutine]
|
||||
#
|
||||
# This file contains a collection of tests for experimental commands that are
|
||||
# found in ::tcl::unsupported. The tests will migrate to normal test files
|
||||
# if/when the commands find their way into the core.
|
||||
#
|
||||
# Copyright (c) 2008 by 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
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
::tcltest::loadTestedCommands
|
||||
catch [list package require -exact Tcltest [info patchlevel]]
|
||||
|
||||
testConstraint testnrelevels [llength [info commands testnrelevels]]
|
||||
testConstraint memory [llength [info commands memory]]
|
||||
|
||||
set lambda [list {{start 0} {stop 10}} {
|
||||
# init
|
||||
set i $start
|
||||
set imax $stop
|
||||
yield
|
||||
while {$i < $imax} {
|
||||
yield [expr {$i*$stop}]
|
||||
incr i
|
||||
}
|
||||
}]
|
||||
|
||||
test coroutine-1.1 {coroutine basic} -setup {
|
||||
coroutine foo ::apply $lambda
|
||||
set res {}
|
||||
} -body {
|
||||
for {set k 1} {$k < 4} {incr k} {
|
||||
lappend res [foo]
|
||||
}
|
||||
set res
|
||||
} -cleanup {
|
||||
rename foo {}
|
||||
unset res
|
||||
} -result {0 10 20}
|
||||
test coroutine-1.2 {coroutine basic} -setup {
|
||||
coroutine foo ::apply $lambda 2 8
|
||||
set res {}
|
||||
} -body {
|
||||
for {set k 1} {$k < 4} {incr k} {
|
||||
lappend res [foo]
|
||||
}
|
||||
set res
|
||||
} -cleanup {
|
||||
rename foo {}
|
||||
unset res
|
||||
} -result {16 24 32}
|
||||
test coroutine-1.3 {yield returns new arg} -setup {
|
||||
set body {
|
||||
# init
|
||||
set i $start
|
||||
set imax $stop
|
||||
yield
|
||||
while {$i < $imax} {
|
||||
set stop [yield [expr {$i*$stop}]]
|
||||
incr i
|
||||
}
|
||||
}
|
||||
coroutine foo ::apply [list {{start 2} {stop 10}} $body]
|
||||
set res {}
|
||||
} -body {
|
||||
for {set k 1} {$k < 4} {incr k} {
|
||||
lappend res [foo $k]
|
||||
}
|
||||
set res
|
||||
} -cleanup {
|
||||
rename foo {}
|
||||
unset res
|
||||
} -result {20 6 12}
|
||||
test coroutine-1.4 {yield in nested proc} -setup {
|
||||
proc moo {} {
|
||||
upvar 1 i i stop stop
|
||||
yield [expr {$i*$stop}]
|
||||
}
|
||||
set body {
|
||||
# init
|
||||
set i $start
|
||||
set imax $stop
|
||||
yield
|
||||
while {$i < $imax} {
|
||||
moo
|
||||
incr i
|
||||
}
|
||||
}
|
||||
coroutine foo ::apply [list {{start 0} {stop 10}} $body]
|
||||
set res {}
|
||||
} -body {
|
||||
for {set k 1} {$k < 4} {incr k} {
|
||||
lappend res [foo $k]
|
||||
}
|
||||
set res
|
||||
} -cleanup {
|
||||
rename foo {}
|
||||
rename moo {}
|
||||
unset body res
|
||||
} -result {0 10 20}
|
||||
test coroutine-1.5 {just yield} -body {
|
||||
coroutine foo yield
|
||||
list [foo] [catch foo msg] $msg
|
||||
} -cleanup {
|
||||
unset msg
|
||||
} -result {{} 1 {invalid command name "foo"}}
|
||||
test coroutine-1.6 {just yield} -body {
|
||||
coroutine foo [list yield]
|
||||
list [foo] [catch foo msg] $msg
|
||||
} -cleanup {
|
||||
unset msg
|
||||
} -result {{} 1 {invalid command name "foo"}}
|
||||
test coroutine-1.7 {yield in nested uplevel} -setup {
|
||||
set body {
|
||||
# init
|
||||
set i $start
|
||||
set imax $stop
|
||||
yield
|
||||
while {$i < $imax} {
|
||||
uplevel 0 [list yield [expr {$i*$stop}]]
|
||||
incr i
|
||||
}
|
||||
}
|
||||
coroutine foo ::apply [list {{start 0} {stop 10}} $body]
|
||||
set res {}
|
||||
} -body {
|
||||
for {set k 1} {$k < 4} {incr k} {
|
||||
lappend res [eval foo $k]
|
||||
}
|
||||
set res
|
||||
} -cleanup {
|
||||
rename foo {}
|
||||
unset body res
|
||||
} -result {0 10 20}
|
||||
test coroutine-1.8 {yield in nested uplevel} -setup {
|
||||
set body {
|
||||
# init
|
||||
set i $start
|
||||
set imax $stop
|
||||
yield
|
||||
while {$i < $imax} {
|
||||
uplevel 0 yield [expr {$i*$stop}]
|
||||
incr i
|
||||
}
|
||||
}
|
||||
coroutine foo ::apply [list {{start 0} {stop 10}} $body]
|
||||
set res {}
|
||||
} -body {
|
||||
for {set k 1} {$k < 4} {incr k} {
|
||||
lappend res [eval foo $k]
|
||||
}
|
||||
set res
|
||||
} -cleanup {
|
||||
rename foo {}
|
||||
unset body res
|
||||
} -result {0 10 20}
|
||||
test coroutine-1.9 {yield in nested eval} -setup {
|
||||
proc moo {} {
|
||||
upvar 1 i i stop stop
|
||||
yield [expr {$i*$stop}]
|
||||
}
|
||||
set body {
|
||||
# init
|
||||
set i $start
|
||||
set imax $stop
|
||||
yield
|
||||
while {$i < $imax} {
|
||||
eval moo
|
||||
incr i
|
||||
}
|
||||
}
|
||||
coroutine foo ::apply [list {{start 0} {stop 10}} $body]
|
||||
set res {}
|
||||
} -body {
|
||||
for {set k 1} {$k < 4} {incr k} {
|
||||
lappend res [foo $k]
|
||||
}
|
||||
set res
|
||||
} -cleanup {
|
||||
rename moo {}
|
||||
unset body res
|
||||
} -result {0 10 20}
|
||||
test coroutine-1.10 {yield in nested eval} -setup {
|
||||
set body {
|
||||
# init
|
||||
set i $start
|
||||
set imax $stop
|
||||
yield
|
||||
while {$i < $imax} {
|
||||
eval yield [expr {$i*$stop}]
|
||||
incr i
|
||||
}
|
||||
}
|
||||
coroutine foo ::apply [list {{start 0} {stop 10}} $body]
|
||||
set res {}
|
||||
} -body {
|
||||
for {set k 1} {$k < 4} {incr k} {
|
||||
lappend res [eval foo $k]
|
||||
}
|
||||
set res
|
||||
} -cleanup {
|
||||
unset body res
|
||||
} -result {0 10 20}
|
||||
test coroutine-1.11 {yield outside coroutine} -setup {
|
||||
proc moo {} {
|
||||
upvar 1 i i stop stop
|
||||
yield [expr {$i*$stop}]
|
||||
}
|
||||
} -body {
|
||||
variable i 5 stop 6
|
||||
moo
|
||||
} -cleanup {
|
||||
rename moo {}
|
||||
unset i stop
|
||||
} -returnCodes error -result {yield can only be called in a coroutine}
|
||||
test coroutine-1.12 {proc as coroutine} -setup {
|
||||
set body {
|
||||
# init
|
||||
set i $start
|
||||
set imax $stop
|
||||
yield
|
||||
while {$i < $imax} {
|
||||
uplevel 0 [list yield [expr {$i*$stop}]]
|
||||
incr i
|
||||
}
|
||||
}
|
||||
proc moo {{start 0} {stop 10}} $body
|
||||
coroutine foo moo 2 8
|
||||
} -body {
|
||||
list [foo] [foo]
|
||||
} -cleanup {
|
||||
unset body
|
||||
rename moo {}
|
||||
rename foo {}
|
||||
} -result {16 24}
|
||||
test coroutine-1.13 {subst as coroutine: literal} {
|
||||
list [coroutine foo eval {subst {>>[yield a],[yield b]<<}}] [foo x] [foo y]
|
||||
} {a b >>x,y<<}
|
||||
test coroutine-1.14 {subst as coroutine: in variable} {
|
||||
set pattern {>>[yield c],[yield d]<<}
|
||||
list [coroutine foo eval {subst $pattern}] [foo p] [foo q]
|
||||
} {c d >>p,q<<}
|
||||
|
||||
test coroutine-2.1 {self deletion on return} -body {
|
||||
coroutine foo set x 3
|
||||
foo
|
||||
} -returnCodes error -result {invalid command name "foo"}
|
||||
test coroutine-2.2 {self deletion on return} -body {
|
||||
coroutine foo ::apply [list {} {yield; yield 1; return 2}]
|
||||
list [foo] [foo] [catch foo msg] $msg
|
||||
} -result {1 2 1 {invalid command name "foo"}}
|
||||
test coroutine-2.3 {self deletion on error return} -body {
|
||||
coroutine foo ::apply [list {} {yield;yield 1; error ouch!}]
|
||||
list [foo] [catch foo msg] $msg [catch foo msg] $msg
|
||||
} -result {1 1 ouch! 1 {invalid command name "foo"}}
|
||||
test coroutine-2.4 {self deletion on other return} -body {
|
||||
coroutine foo ::apply [list {} {yield;yield 1; return -code 100 ouch!}]
|
||||
list [foo] [catch foo msg] $msg [catch foo msg] $msg
|
||||
} -result {1 100 ouch! 1 {invalid command name "foo"}}
|
||||
test coroutine-2.5 {deletion of suspended coroutine} -body {
|
||||
coroutine foo ::apply [list {} {yield; yield 1; return 2}]
|
||||
list [foo] [rename foo {}] [catch foo msg] $msg
|
||||
} -result {1 {} 1 {invalid command name "foo"}}
|
||||
test coroutine-2.6 {deletion of running coroutine} -body {
|
||||
coroutine foo ::apply [list {} {yield; rename foo {}; yield 1; return 2}]
|
||||
list [foo] [catch foo msg] $msg
|
||||
} -result {1 1 {invalid command name "foo"}}
|
||||
|
||||
test coroutine-3.1 {info level computation} -setup {
|
||||
proc a {} {while 1 {yield [info level]}}
|
||||
proc b {} foo
|
||||
} -body {
|
||||
# note that coroutines execute in uplevel #0
|
||||
set l0 [coroutine foo a]
|
||||
set l1 [foo]
|
||||
set l2 [b]
|
||||
list $l0 $l1 $l2
|
||||
} -cleanup {
|
||||
rename a {}
|
||||
rename b {}
|
||||
} -result {1 1 1}
|
||||
test coroutine-3.2 {info frame computation} -setup {
|
||||
proc a {} {while 1 {yield [info frame]}}
|
||||
proc b {} foo
|
||||
} -body {
|
||||
set l0 [coroutine foo a]
|
||||
set l1 [foo]
|
||||
set l2 [b]
|
||||
expr {$l2 - $l1}
|
||||
} -cleanup {
|
||||
rename a {}
|
||||
rename b {}
|
||||
} -result 1
|
||||
test coroutine-3.3 {info coroutine} -setup {
|
||||
proc a {} {info coroutine}
|
||||
proc b {} a
|
||||
} -body {
|
||||
b
|
||||
} -cleanup {
|
||||
rename a {}
|
||||
rename b {}
|
||||
} -result {}
|
||||
test coroutine-3.4 {info coroutine} -setup {
|
||||
proc a {} {info coroutine}
|
||||
proc b {} a
|
||||
} -body {
|
||||
coroutine foo b
|
||||
} -cleanup {
|
||||
rename a {}
|
||||
rename b {}
|
||||
} -result ::foo
|
||||
test coroutine-3.5 {info coroutine} -setup {
|
||||
proc a {} {info coroutine}
|
||||
proc b {} {rename [info coroutine] {}; a}
|
||||
} -body {
|
||||
coroutine foo b
|
||||
} -cleanup {
|
||||
rename a {}
|
||||
rename b {}
|
||||
} -result {}
|
||||
test coroutine-3.6 {info frame, bug #2910094} -setup {
|
||||
proc stack {} {
|
||||
set res [list "LEVEL:[set lev [info frame]]"]
|
||||
for {set i 1} {$i < $lev} {incr i} {
|
||||
lappend res [info frame $i]
|
||||
}
|
||||
set res
|
||||
# the precise command depends on line numbers and such, is likely not
|
||||
# to be stable: just check that the test completes!
|
||||
return
|
||||
}
|
||||
proc a {} stack
|
||||
} -body {
|
||||
coroutine aa a
|
||||
} -cleanup {
|
||||
rename stack {}
|
||||
rename a {}
|
||||
} -result {}
|
||||
test coroutine-3.7 {bug 0b874c344d} {
|
||||
dict get [coroutine X coroutine Y info frame 0] cmd
|
||||
} {coroutine X coroutine Y info frame 0}
|
||||
|
||||
test coroutine-4.1 {bug #2093188} -setup {
|
||||
proc foo {} {
|
||||
set v 1
|
||||
trace add variable v {write unset} bar
|
||||
yield
|
||||
set v 2
|
||||
yield
|
||||
set v 3
|
||||
}
|
||||
proc bar args {lappend ::res $args}
|
||||
coroutine a foo
|
||||
} -body {
|
||||
list [a] [a] $::res
|
||||
} -cleanup {
|
||||
rename foo {}
|
||||
rename bar {}
|
||||
unset ::res
|
||||
} -result {{} 3 {{v {} write} {v {} write} {v {} unset}}}
|
||||
test coroutine-4.2 {bug #2093188} -setup {
|
||||
proc foo {} {
|
||||
set v 1
|
||||
trace add variable v {read unset} bar
|
||||
yield
|
||||
set v 2
|
||||
set v
|
||||
yield
|
||||
set v 3
|
||||
}
|
||||
proc bar args {lappend ::res $args}
|
||||
coroutine a foo
|
||||
} -body {
|
||||
list [a] [a] $::res
|
||||
} -cleanup {
|
||||
rename foo {}
|
||||
rename bar {}
|
||||
unset ::res
|
||||
} -result {{} 3 {{v {} read} {v {} unset}}}
|
||||
|
||||
test coroutine-4.3 {bug #2093947} -setup {
|
||||
proc foo {} {
|
||||
set v 1
|
||||
trace add variable v {write unset} bar
|
||||
yield
|
||||
set v 2
|
||||
yield
|
||||
set v 3
|
||||
}
|
||||
proc bar args {lappend ::res $args}
|
||||
} -body {
|
||||
coroutine a foo
|
||||
a
|
||||
a
|
||||
coroutine a foo
|
||||
a
|
||||
rename a {}
|
||||
set ::res
|
||||
} -cleanup {
|
||||
rename foo {}
|
||||
rename bar {}
|
||||
unset ::res
|
||||
} -result {{v {} write} {v {} write} {v {} unset} {v {} write} {v {} unset}}
|
||||
|
||||
test coroutine-4.4 {bug #2917627: cmd resolution} -setup {
|
||||
proc a {} {return global}
|
||||
namespace eval b {proc a {} {return local}}
|
||||
} -body {
|
||||
namespace eval b {coroutine foo a}
|
||||
} -cleanup {
|
||||
rename a {}
|
||||
namespace delete b
|
||||
} -result local
|
||||
|
||||
test coroutine-4.5 {bug #2724403} -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} {
|
||||
set ns ::y$i
|
||||
namespace eval $ns {}
|
||||
proc ${ns}::start {} {yield; puts hello}
|
||||
coroutine ${ns}::run ${ns}::start
|
||||
namespace delete $ns
|
||||
set start $end
|
||||
set end [getbytes]
|
||||
}
|
||||
set leakedBytes [expr {$end - $start}]
|
||||
} -cleanup {
|
||||
rename getbytes {}
|
||||
unset i ns start end
|
||||
} -result 0
|
||||
|
||||
test coroutine-4.6 {compile context, bug #3282869} -setup {
|
||||
unset -nocomplain ::x
|
||||
proc f x {
|
||||
coroutine D eval {yield X$x;yield Y}
|
||||
}
|
||||
} -body {
|
||||
f 12
|
||||
} -cleanup {
|
||||
rename f {}
|
||||
} -returnCodes error -match glob -result {can't read *}
|
||||
|
||||
test coroutine-4.7 {compile context, bug #3282869} -setup {
|
||||
proc f x {
|
||||
coroutine D eval {yield X$x;yield Y$x}
|
||||
}
|
||||
} -body {
|
||||
set ::x 15
|
||||
set ::x [f 12]
|
||||
D
|
||||
} -cleanup {
|
||||
D
|
||||
unset ::x
|
||||
rename f {}
|
||||
} -result YX15
|
||||
|
||||
test coroutine-5.1 {right numLevels on coro return} -constraints {testnrelevels} \
|
||||
-setup {
|
||||
proc nestedYield {{val {}}} {
|
||||
yield $val
|
||||
}
|
||||
proc getNumLevel {} {
|
||||
# remove the level for this proc's call
|
||||
expr {[lindex [testnrelevels] 1] - 1}
|
||||
}
|
||||
proc relativeLevel base {
|
||||
# remove the level for this proc's call
|
||||
expr {[getNumLevel] - $base - 1}
|
||||
}
|
||||
proc foo {} {
|
||||
while 1 {
|
||||
nestedYield
|
||||
}
|
||||
}
|
||||
set res {}
|
||||
} -body {
|
||||
set base [getNumLevel]
|
||||
lappend res [relativeLevel $base]
|
||||
eval {coroutine a foo}
|
||||
# back to base level
|
||||
lappend res [relativeLevel $base]
|
||||
a
|
||||
lappend res [relativeLevel $base]
|
||||
eval a
|
||||
lappend res [relativeLevel $base]
|
||||
eval {eval a}
|
||||
lappend res [relativeLevel $base]
|
||||
rename a {}
|
||||
lappend res [relativeLevel $base]
|
||||
set res
|
||||
} -cleanup {
|
||||
rename foo {}
|
||||
rename nestedYield {}
|
||||
rename getNumLevel {}
|
||||
rename relativeLevel {}
|
||||
unset res
|
||||
} -result {0 0 0 0 0 0}
|
||||
test coroutine-5.2 {right numLevels within coro} -constraints {testnrelevels} \
|
||||
-setup {
|
||||
proc nestedYield {{val {}}} {
|
||||
yield $val
|
||||
}
|
||||
proc getNumLevel {} {
|
||||
# remove the level for this proc's call
|
||||
expr {[lindex [testnrelevels] 1] - 1}
|
||||
}
|
||||
proc relativeLevel base {
|
||||
# remove the level for this proc's call
|
||||
expr {[getNumLevel] - $base - 1}
|
||||
}
|
||||
proc foo base {
|
||||
while 1 {
|
||||
set base [nestedYield [relativeLevel $base]]
|
||||
}
|
||||
}
|
||||
set res {}
|
||||
} -body {
|
||||
lappend res [eval {coroutine a foo [getNumLevel]}]
|
||||
lappend res [a [getNumLevel]]
|
||||
lappend res [eval {a [getNumLevel]}]
|
||||
lappend res [eval {eval {a [getNumLevel]}}]
|
||||
set base [lindex $res 0]
|
||||
foreach x $res[set res {}] {
|
||||
lappend res [expr {$x-$base}]
|
||||
}
|
||||
set res
|
||||
} -cleanup {
|
||||
rename a {}
|
||||
rename foo {}
|
||||
rename nestedYield {}
|
||||
rename getNumLevel {}
|
||||
rename relativeLevel {}
|
||||
unset res
|
||||
} -result {0 0 0 0}
|
||||
|
||||
test coroutine-6.1 {coroutine nargs} -body {
|
||||
coroutine a ::apply $lambda
|
||||
a
|
||||
} -cleanup {
|
||||
rename a {}
|
||||
} -result 0
|
||||
test coroutine-6.2 {coroutine nargs} -body {
|
||||
coroutine a ::apply $lambda
|
||||
a a
|
||||
} -cleanup {
|
||||
rename a {}
|
||||
} -result 0
|
||||
test coroutine-6.3 {coroutine nargs} -body {
|
||||
coroutine a ::apply $lambda
|
||||
a a a
|
||||
} -cleanup {
|
||||
rename a {}
|
||||
} -returnCodes error -result {wrong # args: should be "a ?arg?"}
|
||||
|
||||
test coroutine-7.1 {yieldto} -body {
|
||||
coroutine c apply {{} {
|
||||
yield
|
||||
yieldto return -level 0 -code 1 quux
|
||||
return quuy
|
||||
}}
|
||||
set res [list [catch c msg] $msg]
|
||||
lappend res [catch c msg] $msg
|
||||
lappend res [catch c msg] $msg
|
||||
} -cleanup {
|
||||
unset res
|
||||
} -result [list 1 quux 0 quuy 1 {invalid command name "c"}]
|
||||
test coroutine-7.2 {multi-argument yielding with yieldto} -body {
|
||||
proc corobody {} {
|
||||
set a 1
|
||||
while 1 {
|
||||
set a [yield $a]
|
||||
set a [yieldto return -level 0 $a]
|
||||
lappend a [llength $a]
|
||||
}
|
||||
}
|
||||
coroutine a corobody
|
||||
coroutine b corobody
|
||||
list [a x] [a y z] [a \{p] [a \{q r] [a] [a] [rename a {}] \
|
||||
[b ok] [rename b {}]
|
||||
} -cleanup {
|
||||
rename corobody {}
|
||||
} -result {x {y z 2} \{p {\{q r 2} {} 0 {} ok {}}
|
||||
test coroutine-7.3 {yielding between coroutines} -body {
|
||||
proc juggler {target {value ""}} {
|
||||
if {$value eq ""} {
|
||||
set value [yield [info coroutine]]
|
||||
}
|
||||
while {[llength $value]} {
|
||||
lappend ::result $value [info coroutine]
|
||||
set value [lrange $value 0 end-1]
|
||||
lassign [yieldto $target $value] value
|
||||
}
|
||||
# Clear nested collection of coroutines
|
||||
catch $target
|
||||
}
|
||||
set result ""
|
||||
coroutine j1 juggler [coroutine j2 juggler [coroutine j3 juggler j1]]\
|
||||
{a b c d e}
|
||||
list $result [info command j1] [info command j2] [info command j3]
|
||||
} -cleanup {
|
||||
catch {rename juggler ""}
|
||||
} -result {{{a b c d e} ::j1 {a b c d} ::j2 {a b c} ::j3 {a b} ::j1 a ::j2} {} {} {}}
|
||||
test coroutine-7.4 {Bug 8ff0cb9fe1} -setup {
|
||||
proc foo {a b} {catch yield; return 1}
|
||||
} -cleanup {
|
||||
rename foo {}
|
||||
} -body {
|
||||
coroutine demo lsort -command foo {a b}
|
||||
} -result {b a}
|
||||
test coroutine-7.5 {return codes} {
|
||||
set result {}
|
||||
foreach code {0 1 2 3 4 5} {
|
||||
lappend result [catch {coroutine demo return -level 0 -code $code}]
|
||||
}
|
||||
set result
|
||||
} {0 1 2 3 4 5}
|
||||
test coroutine-7.6 {Early yield crashes} {
|
||||
proc foo args {}
|
||||
trace add execution foo enter {catch yield}
|
||||
coroutine demo foo
|
||||
rename foo {}
|
||||
} {}
|
||||
test coroutine-7.7 {Bug 2486550} -setup {
|
||||
interp hide {} yield
|
||||
} -body {
|
||||
coroutine demo interp invokehidden {} yield ok
|
||||
} -cleanup {
|
||||
demo
|
||||
interp expose {} yield
|
||||
} -result ok
|
||||
test coroutine-7.8 {yieldto context nuke: Bug a90d9331bc} -setup {
|
||||
namespace eval cotest {}
|
||||
set ::result ""
|
||||
} -body {
|
||||
proc cotest::body {} {
|
||||
lappend ::result a
|
||||
yield OUT
|
||||
lappend ::result b
|
||||
yieldto ::return -level 0 123
|
||||
lappend ::result c
|
||||
return
|
||||
}
|
||||
lappend ::result [coroutine cotest cotest::body]
|
||||
namespace delete cotest
|
||||
namespace eval cotest {}
|
||||
lappend ::result [cotest]
|
||||
cotest
|
||||
return $result
|
||||
} -returnCodes error -cleanup {
|
||||
catch {namespace delete ::cotest}
|
||||
catch {rename cotest ""}
|
||||
} -result {yieldto called in deleted namespace}
|
||||
test coroutine-7.9 {yieldto context nuke: Bug a90d9331bc} -setup {
|
||||
namespace eval cotest {}
|
||||
set ::result ""
|
||||
} -body {
|
||||
proc cotest::body {} {
|
||||
set y ::yieldto
|
||||
lappend ::result a
|
||||
yield OUT
|
||||
lappend ::result b
|
||||
$y ::return -level 0 123
|
||||
lappend ::result c
|
||||
return
|
||||
}
|
||||
lappend ::result [coroutine cotest cotest::body]
|
||||
namespace delete cotest
|
||||
namespace eval cotest {}
|
||||
lappend ::result [cotest]
|
||||
cotest
|
||||
return $result
|
||||
} -returnCodes error -cleanup {
|
||||
catch {namespace delete ::cotest}
|
||||
catch {rename cotest ""}
|
||||
} -result {yieldto called in deleted namespace}
|
||||
test coroutine-7.10 {yieldto context nuke: Bug a90d9331bc} -setup {
|
||||
namespace eval cotest {}
|
||||
set ::result ""
|
||||
} -body {
|
||||
proc cotest::body {} {
|
||||
lappend ::result a
|
||||
yield OUT
|
||||
lappend ::result b
|
||||
yieldto ::return -level 0 -cotest [namespace delete ::cotest] 123
|
||||
lappend ::result c
|
||||
return
|
||||
}
|
||||
lappend ::result [coroutine cotest cotest::body]
|
||||
lappend ::result [cotest]
|
||||
cotest
|
||||
return $result
|
||||
} -returnCodes error -cleanup {
|
||||
catch {namespace delete ::cotest}
|
||||
catch {rename cotest ""}
|
||||
} -result {yieldto called in deleted namespace}
|
||||
test coroutine-7.11 {yieldto context nuke: Bug a90d9331bc} -setup {
|
||||
namespace eval cotest {}
|
||||
set ::result ""
|
||||
} -body {
|
||||
proc cotest::body {} {
|
||||
set y ::yieldto
|
||||
lappend ::result a
|
||||
yield OUT
|
||||
lappend ::result b
|
||||
$y ::return -level 0 -cotest [namespace delete ::cotest] 123
|
||||
lappend ::result c
|
||||
return
|
||||
}
|
||||
lappend ::result [coroutine cotest cotest::body]
|
||||
lappend ::result [cotest]
|
||||
cotest
|
||||
return $result
|
||||
} -returnCodes error -cleanup {
|
||||
catch {namespace delete ::cotest}
|
||||
catch {rename cotest ""}
|
||||
} -result {yieldto called in deleted namespace}
|
||||
test coroutine-7.12 {coro floor above street level #3008307} -body {
|
||||
proc c {} {
|
||||
yield
|
||||
}
|
||||
proc cc {} {
|
||||
coroutine C c
|
||||
}
|
||||
proc boom {} {
|
||||
cc ; # coro created at level 2
|
||||
C ; # and called at level 1
|
||||
}
|
||||
boom ; # does not crash: the coro floor is a good insulator
|
||||
list
|
||||
} -result {}
|
||||
|
||||
|
||||
# cleanup
|
||||
unset lambda
|
||||
::tcltest::cleanupTests
|
||||
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# End:
|
||||
43
tests/dcall.test
Normal file
43
tests/dcall.test
Normal file
@@ -0,0 +1,43 @@
|
||||
# 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::*
|
||||
|
||||
::tcltest::loadTestedCommands
|
||||
catch [list package require -exact Tcltest [info patchlevel]]
|
||||
|
||||
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
|
||||
2065
tests/dict.test
Normal file
2065
tests/dict.test
Normal file
File diff suppressed because it is too large
Load Diff
439
tests/dstring.test
Normal file
439
tests/dstring.test
Normal file
@@ -0,0 +1,439 @@
|
||||
# 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 {"::tcltest" ni [namespace children]} {
|
||||
package require tcltest
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
::tcltest::loadTestedCommands
|
||||
catch [list package require -exact Tcltest [info patchlevel]]
|
||||
|
||||
testConstraint testdstring [llength [info commands testdstring]]
|
||||
if {[testConstraint testdstring]} {
|
||||
testdstring free
|
||||
}
|
||||
|
||||
test dstring-1.1 {appending and retrieving} -constraints testdstring -setup {
|
||||
testdstring free
|
||||
} -body {
|
||||
testdstring append "abc" -1
|
||||
list [testdstring get] [testdstring length]
|
||||
} -cleanup {
|
||||
testdstring free
|
||||
} -result {abc 3}
|
||||
test dstring-1.2 {appending and retrieving} -constraints testdstring -setup {
|
||||
testdstring free
|
||||
} -body {
|
||||
testdstring append "abc" -1
|
||||
testdstring append " xyzzy" 3
|
||||
testdstring append " 12345" -1
|
||||
list [testdstring get] [testdstring length]
|
||||
} -cleanup {
|
||||
testdstring free
|
||||
} -result {{abc xy 12345} 12}
|
||||
test dstring-1.3 {appending and retrieving} -constraints testdstring -setup {
|
||||
testdstring free
|
||||
} -body {
|
||||
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]
|
||||
} -cleanup {
|
||||
testdstring free
|
||||
} -result {{aaaaaaaaaaaaaaaaaaaaa
|
||||
bbbbbbbbbbbbbbbbbbbbb
|
||||
ccccccccccccccccccccc
|
||||
ddddddddddddddddddddd
|
||||
eeeeeeeeeeeeeeeeeeeee
|
||||
fffffffffffffffffffff
|
||||
ggggggggggggggggggggg
|
||||
hhhhhhhhhhhhhhhhhhhhh
|
||||
iiiiiiiiiiiiiiiiiiiii
|
||||
jjjjjjjjjjjjjjjjjjjjj
|
||||
kkkkkkkkkkkkkkkkkkkkk
|
||||
lllllllllllllllllllll
|
||||
mmmmmmmmmmmmmmmmmmmmm
|
||||
nnnnnnnnnnnnnnnnnnnnn
|
||||
ooooooooooooooooooooo
|
||||
ppppppppppppppppppppp
|
||||
} 352}
|
||||
|
||||
test dstring-2.1 {appending list elements} -constraints testdstring -setup {
|
||||
testdstring free
|
||||
} -body {
|
||||
testdstring element "abc"
|
||||
testdstring element "d e f"
|
||||
list [testdstring get] [testdstring length]
|
||||
} -cleanup {
|
||||
testdstring free
|
||||
} -result {{abc {d e f}} 11}
|
||||
test dstring-2.2 {appending list elements} -constraints testdstring -setup {
|
||||
testdstring free
|
||||
} -body {
|
||||
testdstring element "x"
|
||||
testdstring element "\{"
|
||||
testdstring element "ab\}"
|
||||
testdstring get
|
||||
} -cleanup {
|
||||
testdstring free
|
||||
} -result {x \{ ab\}}
|
||||
test dstring-2.3 {appending list elements} -constraints testdstring -setup {
|
||||
testdstring free
|
||||
} -body {
|
||||
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
|
||||
} -cleanup {
|
||||
testdstring free
|
||||
} -result {aaaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbb ccccccccccccccccccccc ddddddddddddddddddddd eeeeeeeeeeeeeeeeeeeee fffffffffffffffffffff ggggggggggggggggggggg hhhhhhhhhhhhhhhhhhhhh iiiiiiiiiiiiiiiiiiiii jjjjjjjjjjjjjjjjjjjjj kkkkkkkkkkkkkkkkkkkkk lllllllllllllllllllll mmmmmmmmmmmmmmmmmmmmm nnnnnnnnnnnnnnnnnnnnn ooooooooooooooooooooo ppppppppppppppppppppp}
|
||||
test dstring-2.4 {appending list elements} -constraints testdstring -setup {
|
||||
testdstring free
|
||||
} -body {
|
||||
testdstring append "a\{" -1
|
||||
testdstring element abc
|
||||
testdstring append " \{" -1
|
||||
testdstring element xyzzy
|
||||
testdstring get
|
||||
} -cleanup {
|
||||
testdstring free
|
||||
} -result "a{ abc {xyzzy"
|
||||
test dstring-2.5 {appending list elements} -constraints testdstring -setup {
|
||||
testdstring free
|
||||
} -body {
|
||||
testdstring append " \{" -1
|
||||
testdstring element abc
|
||||
testdstring get
|
||||
} -cleanup {
|
||||
testdstring free
|
||||
} -result " {abc"
|
||||
test dstring-2.6 {appending list elements} -constraints testdstring -setup {
|
||||
testdstring free
|
||||
} -body {
|
||||
testdstring append " " -1
|
||||
testdstring element abc
|
||||
testdstring get
|
||||
} -cleanup {
|
||||
testdstring free
|
||||
} -result { abc}
|
||||
test dstring-2.7 {appending list elements} -constraints testdstring -setup {
|
||||
testdstring free
|
||||
} -body {
|
||||
testdstring append "\\ " -1
|
||||
testdstring element abc
|
||||
testdstring get
|
||||
} -cleanup {
|
||||
testdstring free
|
||||
} -result "\\ abc"
|
||||
test dstring-2.8 {appending list elements} -constraints testdstring -setup {
|
||||
testdstring free
|
||||
} -body {
|
||||
testdstring append "x " -1
|
||||
testdstring element abc
|
||||
testdstring get
|
||||
} -cleanup {
|
||||
testdstring free
|
||||
} -result {x abc}
|
||||
test dstring-2.9 {appending list elements} -constraints testdstring -setup {
|
||||
testdstring free
|
||||
} -body {
|
||||
testdstring element #
|
||||
testdstring get
|
||||
} -cleanup {
|
||||
testdstring free
|
||||
} -result {{#}}
|
||||
test dstring-2.10 {appending list elements} -constraints testdstring -setup {
|
||||
testdstring free
|
||||
} -body {
|
||||
testdstring append " " -1
|
||||
testdstring element #
|
||||
testdstring get
|
||||
} -cleanup {
|
||||
testdstring free
|
||||
} -result { {#}}
|
||||
test dstring-2.11 {appending list elements} -constraints testdstring -setup {
|
||||
testdstring free
|
||||
} -body {
|
||||
testdstring append \t -1
|
||||
testdstring element #
|
||||
testdstring get
|
||||
} -cleanup {
|
||||
testdstring free
|
||||
} -result \t{#}
|
||||
test dstring-2.12 {appending list elements} -constraints testdstring -setup {
|
||||
testdstring free
|
||||
} -body {
|
||||
testdstring append x -1
|
||||
testdstring element #
|
||||
testdstring get
|
||||
} -cleanup {
|
||||
testdstring free
|
||||
} -result {x #}
|
||||
test dstring-2.13 {appending list elements} -constraints testdstring -body {
|
||||
# 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
|
||||
} -cleanup {
|
||||
testdstring free
|
||||
} -result {x {#}}
|
||||
|
||||
test dstring-3.1 {nested sublists} -constraints testdstring -setup {
|
||||
testdstring free
|
||||
} -body {
|
||||
testdstring start
|
||||
testdstring element foo
|
||||
testdstring element bar
|
||||
testdstring end
|
||||
testdstring element another
|
||||
testdstring get
|
||||
} -cleanup {
|
||||
testdstring free
|
||||
} -result {{foo bar} another}
|
||||
test dstring-3.2 {nested sublists} -constraints testdstring -setup {
|
||||
testdstring free
|
||||
} -body {
|
||||
testdstring start
|
||||
testdstring start
|
||||
testdstring element abc
|
||||
testdstring element def
|
||||
testdstring end
|
||||
testdstring end
|
||||
testdstring element ghi
|
||||
testdstring get
|
||||
} -cleanup {
|
||||
testdstring free
|
||||
} -result {{{abc def}} ghi}
|
||||
test dstring-3.3 {nested sublists} -constraints testdstring -setup {
|
||||
testdstring free
|
||||
} -body {
|
||||
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
|
||||
} -cleanup {
|
||||
testdstring free
|
||||
} -result {{{{foo foo2}} foo3} foo4}
|
||||
test dstring-3.4 {nested sublists} -constraints testdstring -setup {
|
||||
testdstring free
|
||||
} -body {
|
||||
testdstring element before
|
||||
testdstring start
|
||||
testdstring element during
|
||||
testdstring element more
|
||||
testdstring end
|
||||
testdstring element last
|
||||
testdstring get
|
||||
} -cleanup {
|
||||
testdstring free
|
||||
} -result {before {during more} last}
|
||||
test dstring-3.5 {nested sublists} -constraints testdstring -setup {
|
||||
testdstring free
|
||||
} -body {
|
||||
testdstring element "\{"
|
||||
testdstring start
|
||||
testdstring element first
|
||||
testdstring element second
|
||||
testdstring end
|
||||
testdstring get
|
||||
} -cleanup {
|
||||
testdstring free
|
||||
} -result {\{ {first second}}
|
||||
test dstring-3.6 {appending list elements} -constraints testdstring -setup {
|
||||
testdstring free
|
||||
} -body {
|
||||
testdstring append x -1
|
||||
testdstring start
|
||||
testdstring element #
|
||||
testdstring end
|
||||
testdstring get
|
||||
} -cleanup {
|
||||
testdstring free
|
||||
} -result {x {{#}}}
|
||||
test dstring-3.7 {appending list elements} -constraints testdstring -setup {
|
||||
testdstring free
|
||||
} -body {
|
||||
testdstring append x -1
|
||||
testdstring start
|
||||
testdstring append " " -1
|
||||
testdstring element #
|
||||
testdstring end
|
||||
testdstring get
|
||||
} -cleanup {
|
||||
testdstring free
|
||||
} -result {x { {#}}}
|
||||
test dstring-3.8 {appending list elements} -constraints testdstring -setup {
|
||||
testdstring free
|
||||
} -body {
|
||||
testdstring append x -1
|
||||
testdstring start
|
||||
testdstring append \t -1
|
||||
testdstring element #
|
||||
testdstring end
|
||||
testdstring get
|
||||
} -cleanup {
|
||||
testdstring free
|
||||
} -result "x {\t{#}}"
|
||||
test dstring-3.9 {appending list elements} -constraints testdstring -setup {
|
||||
testdstring free
|
||||
} -body {
|
||||
testdstring append x -1
|
||||
testdstring start
|
||||
testdstring append x -1
|
||||
testdstring element #
|
||||
testdstring end
|
||||
testdstring get
|
||||
} -cleanup {
|
||||
testdstring free
|
||||
} -result {x {x #}}
|
||||
test dstring-3.10 {appending list elements} -constraints testdstring -body {
|
||||
# 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
|
||||
} -cleanup {
|
||||
testdstring free
|
||||
} -result {x {x {#}}}
|
||||
|
||||
test dstring-4.1 {truncation} -constraints testdstring -setup {
|
||||
testdstring free
|
||||
} -body {
|
||||
testdstring append "abcdefg" -1
|
||||
testdstring trunc 3
|
||||
list [testdstring get] [testdstring length]
|
||||
} -cleanup {
|
||||
testdstring free
|
||||
} -result {abc 3}
|
||||
test dstring-4.2 {truncation} -constraints testdstring -setup {
|
||||
testdstring free
|
||||
} -body {
|
||||
testdstring append "xyzzy" -1
|
||||
testdstring trunc 0
|
||||
list [testdstring get] [testdstring length]
|
||||
} -cleanup {
|
||||
testdstring free
|
||||
} -result {{} 0}
|
||||
|
||||
test dstring-5.1 {copying to result} -constraints testdstring -setup {
|
||||
testdstring free
|
||||
} -body {
|
||||
testdstring append xyz -1
|
||||
testdstring result
|
||||
} -cleanup {
|
||||
testdstring free
|
||||
} -result xyz
|
||||
test dstring-5.2 {copying to result} -constraints testdstring -setup {
|
||||
testdstring free
|
||||
unset -nocomplain a
|
||||
} -body {
|
||||
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]
|
||||
} -cleanup {
|
||||
testdstring free
|
||||
} -result {{aaaaaaaaaaaaaaaaaaaaa
|
||||
bbbbbbbbbbbbbbbbbbbbb
|
||||
ccccccccccccccccccccc
|
||||
ddddddddddddddddddddd
|
||||
eeeeeeeeeeeeeeeeeeeee
|
||||
fffffffffffffffffffff
|
||||
ggggggggggggggggggggg
|
||||
hhhhhhhhhhhhhhhhhhhhh
|
||||
iiiiiiiiiiiiiiiiiiiii
|
||||
jjjjjjjjjjjjjjjjjjjjj
|
||||
kkkkkkkkkkkkkkkkkkkkk
|
||||
lllllllllllllllllllll
|
||||
mmmmmmmmmmmmmmmmmmmmm
|
||||
nnnnnnnnnnnnnnnnnnnnn
|
||||
ooooooooooooooooooooo
|
||||
ppppppppppppppppppppp
|
||||
} abc}
|
||||
|
||||
test dstring-6.1 {Tcl_DStringGetResult} -constraints testdstring -setup {
|
||||
testdstring free
|
||||
} -body {
|
||||
list [testdstring gresult staticsmall] [testdstring get]
|
||||
} -cleanup {
|
||||
testdstring free
|
||||
} -result {{} short}
|
||||
test dstring-6.2 {Tcl_DStringGetResult} -constraints testdstring -setup {
|
||||
testdstring free
|
||||
} -body {
|
||||
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]
|
||||
} -cleanup {
|
||||
testdstring free
|
||||
} -result {{} short}
|
||||
test dstring-6.3 {Tcl_DStringGetResult} -constraints testdstring -body {
|
||||
set result {}
|
||||
lappend result [testdstring gresult staticlarge]
|
||||
testdstring append x 1
|
||||
lappend result [testdstring get]
|
||||
} -cleanup {
|
||||
testdstring free
|
||||
} -result {{} {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} -constraints testdstring -body {
|
||||
set result {}
|
||||
lappend result [testdstring gresult free]
|
||||
testdstring append y 1
|
||||
lappend result [testdstring get]
|
||||
} -cleanup {
|
||||
testdstring free
|
||||
} -result {{} {This is a malloc-ed stringy}}
|
||||
test dstring-6.5 {Tcl_DStringGetResult} -constraints testdstring -body {
|
||||
set result {}
|
||||
lappend result [testdstring gresult special]
|
||||
testdstring append z 1
|
||||
lappend result [testdstring get]
|
||||
} -cleanup {
|
||||
testdstring free
|
||||
} -result {{} {This is a specially-allocated stringz}}
|
||||
|
||||
# cleanup
|
||||
if {[testConstraint testdstring]} {
|
||||
testdstring free
|
||||
}
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# fill-column: 78
|
||||
# End:
|
||||
610
tests/encoding.test
Normal file
610
tests/encoding.test
Normal file
@@ -0,0 +1,610 @@
|
||||
# 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::*
|
||||
|
||||
catch {
|
||||
::tcltest::loadTestedCommands
|
||||
package require -exact Tcltest [info patchlevel]
|
||||
}
|
||||
|
||||
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]]
|
||||
testConstraint testgetdefenc [llength [info commands testgetdefenc]]
|
||||
|
||||
# TclInitEncodingSubsystem is tested by the rest of this file
|
||||
# TclFinalizeEncodingSubsystem is not currently tested
|
||||
|
||||
test encoding-1.1 {Tcl_GetEncoding: system encoding} -setup {
|
||||
set old [encoding system]
|
||||
} -constraints {testencoding} -body {
|
||||
testencoding create foo [namespace origin toutf] [namespace origin fromutf]
|
||||
encoding system foo
|
||||
set x {}
|
||||
encoding convertto abcd
|
||||
return $x
|
||||
} -cleanup {
|
||||
encoding system $old
|
||||
testencoding delete foo
|
||||
} -result {{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
|
||||
return $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} -setup {
|
||||
set system [encoding system]
|
||||
set path [encoding dirs]
|
||||
} -constraints {testencoding} -body {
|
||||
encoding system shiftjis ;# incr ref count
|
||||
encoding dirs [list [pwd]]
|
||||
set x [encoding convertto shiftjis \u4e4e] ;# old one found
|
||||
encoding system identity
|
||||
llength shiftjis ;# Shimmer away any cache of Tcl_Encoding
|
||||
lappend x [catch {encoding convertto shiftjis \u4e4e} msg] $msg
|
||||
} -cleanup {
|
||||
encoding system identity
|
||||
encoding dirs $path
|
||||
encoding system $system
|
||||
} -result "\u008c\u00c1 1 {unknown encoding \"shiftjis\"}"
|
||||
|
||||
test encoding-3.1 {Tcl_GetEncodingName, NULL} -setup {
|
||||
set old [encoding system]
|
||||
} -body {
|
||||
encoding system shiftjis
|
||||
encoding system
|
||||
} -cleanup {
|
||||
encoding system $old
|
||||
} -result {shiftjis}
|
||||
test encoding-3.2 {Tcl_GetEncodingName, non-null} -setup {
|
||||
set old [fconfigure stdout -encoding]
|
||||
} -body {
|
||||
fconfigure stdout -encoding jis0208
|
||||
fconfigure stdout -encoding
|
||||
} -cleanup {
|
||||
fconfigure stdout -encoding $old
|
||||
} -result {jis0208}
|
||||
|
||||
test encoding-4.1 {Tcl_GetEncodingNames} -constraints {testencoding} -setup {
|
||||
cd [makeDirectory tmp]
|
||||
makeDirectory [file join tmp encoding]
|
||||
set path [encoding dirs]
|
||||
encoding dirs {}
|
||||
catch {unset encodings}
|
||||
catch {unset x}
|
||||
} -body {
|
||||
foreach encoding [encoding names] {
|
||||
set encodings($encoding) 1
|
||||
}
|
||||
makeFile {} [file join tmp encoding junk.enc]
|
||||
makeFile {} [file join tmp encoding junk2.enc]
|
||||
encoding dirs [list [file join [pwd] encoding]]
|
||||
foreach encoding [encoding names] {
|
||||
if {![info exists encodings($encoding)]} {
|
||||
lappend x $encoding
|
||||
}
|
||||
}
|
||||
lsort $x
|
||||
} -cleanup {
|
||||
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
|
||||
} -result {junk junk2}
|
||||
|
||||
test encoding-5.1 {Tcl_SetSystemEncoding} -setup {
|
||||
set old [encoding system]
|
||||
} -body {
|
||||
encoding system jis0208
|
||||
encoding convertto \u4e4e
|
||||
} -cleanup {
|
||||
encoding system identity
|
||||
encoding system $old
|
||||
} -result {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
|
||||
return $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
|
||||
return $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]
|
||||
return $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]
|
||||
return $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 ;# Shimmer any cached Tcl_Encoding in shared literal
|
||||
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} -constraints {testencoding} -setup {
|
||||
set system [encoding system]
|
||||
set path [encoding dirs]
|
||||
encoding system identity
|
||||
} -body {
|
||||
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
|
||||
encoding convertto splat \u4e4e
|
||||
} -returnCodes error -cleanup {
|
||||
file delete [file join [temporaryDirectory] tmp encoding splat.enc]
|
||||
removeDirectory [file join tmp encoding]
|
||||
removeDirectory tmp
|
||||
cd [workingDirectory]
|
||||
encoding dirs $path
|
||||
encoding system $system
|
||||
} -result {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
|
||||
return $data
|
||||
} [string range $iso2022uniData 0 49] ; # 0 .. 49 inclusive == 50
|
||||
cd [workingDirectory]
|
||||
|
||||
# Code to make the next few tests more intelligible; the code being tested
|
||||
# should be in the body of the test!
|
||||
proc runInSubprocess {contents {filename iso2022.tcl}} {
|
||||
set theFile [makeFile $contents $filename]
|
||||
try {
|
||||
exec [interpreter] $theFile
|
||||
} finally {
|
||||
removeFile $theFile
|
||||
}
|
||||
}
|
||||
|
||||
test encoding-24.1 {EscapeFreeProc on open channels} exec {
|
||||
runInSubprocess {
|
||||
set f [open [file join [file dirname [info script]] iso2022.txt]]
|
||||
fconfigure $f -encoding iso2022-jp
|
||||
gets $f
|
||||
}
|
||||
} {}
|
||||
test encoding-24.2 {EscapeFreeProc on open channels} {exec} {
|
||||
# Bug #524674 output
|
||||
viewable [runInSubprocess {
|
||||
encoding system cp1252; # Bug #2891556 crash revelator
|
||||
fconfigure stdout -encoding iso2022-jp
|
||||
puts ab\u4e4e\u68d9g
|
||||
set env(TCL_FINALIZE_ON_EXIT) 1
|
||||
exit
|
||||
}]
|
||||
} "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.
|
||||
scan $range %x%x first last
|
||||
for {set i $first} {$i <= $last} {incr i} {
|
||||
set code $i
|
||||
uplevel 1 $command
|
||||
}
|
||||
} elseif {[llength $range] == 4} {
|
||||
# for uniform range.
|
||||
scan $range %x%x%x%x h0 l0 hend lend
|
||||
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]
|
||||
}
|
||||
return $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" -setup {
|
||||
cd [temporaryDirectory]
|
||||
} -body {
|
||||
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 rb]
|
||||
set fb [open $from.$to.tcltestout rb]
|
||||
channel-diff $fa $fb
|
||||
# Difference should be empty.
|
||||
} -cleanup {
|
||||
close $fa
|
||||
close $fb
|
||||
} -result {}
|
||||
}
|
||||
}
|
||||
|
||||
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
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# End:
|
||||
349
tests/env.test
Normal file
349
tests/env.test
Normal file
@@ -0,0 +1,349 @@
|
||||
# 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} -setup {
|
||||
catch {interp delete child}
|
||||
catch {unset env(test)}
|
||||
} -body {
|
||||
interp create child
|
||||
set env(test) garbage
|
||||
child eval {set env(test)}
|
||||
} -cleanup {
|
||||
interp delete child
|
||||
unset env(test)
|
||||
} -result {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} -setup {
|
||||
catch {unset env(test)}
|
||||
} -body {
|
||||
set env(test) aaaaaaaaaaaaaaaa
|
||||
append env(test) bbbbbbbbbbbbbb
|
||||
unset env(test)
|
||||
}
|
||||
test env-1.3 {reflection of env by "array names"} -setup {
|
||||
catch {interp delete child}
|
||||
catch {unset env(test)}
|
||||
} -body {
|
||||
interp create child
|
||||
child eval {set env(test) garbage}
|
||||
expr {"test" in [array names env]}
|
||||
} -cleanup {
|
||||
interp delete child
|
||||
catch {unset env(test)}
|
||||
} -result {1}
|
||||
|
||||
set printenvScript [makeFile {
|
||||
encoding system iso8859-1
|
||||
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) eq "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 eq "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)
|
||||
}
|
||||
}
|
||||
|
||||
# Need to run 'getenv' in known encoding, so save the current one here...
|
||||
set sysenc [encoding system]
|
||||
|
||||
test env-2.1 {adding environment variables} -setup {
|
||||
encoding system iso8859-1
|
||||
} -constraints {exec} -body {
|
||||
getenv
|
||||
} -cleanup {
|
||||
encoding system $sysenc
|
||||
} -result {}
|
||||
test env-2.2 {adding environment variables} -setup {
|
||||
encoding system iso8859-1
|
||||
} -constraints {exec} -body {
|
||||
set env(NAME1) "test string"
|
||||
getenv
|
||||
} -cleanup {
|
||||
encoding system $sysenc
|
||||
} -result {NAME1=test string}
|
||||
test env-2.3 {adding environment variables} -setup {
|
||||
encoding system iso8859-1
|
||||
set env(NAME1) "test string"
|
||||
} -constraints {exec} -body {
|
||||
set env(NAME2) "more"
|
||||
getenv
|
||||
} -cleanup {
|
||||
encoding system $sysenc
|
||||
} -result {NAME1=test string
|
||||
NAME2=more}
|
||||
test env-2.4 {adding environment variables} -setup {
|
||||
encoding system iso8859-1
|
||||
set env(NAME1) "test string"
|
||||
set env(NAME2) "more"
|
||||
} -constraints {exec} -body {
|
||||
set env(XYZZY) "garbage"
|
||||
getenv
|
||||
} -cleanup {
|
||||
encoding system $sysenc
|
||||
} -result {NAME1=test string
|
||||
NAME2=more
|
||||
XYZZY=garbage}
|
||||
|
||||
set env(NAME1) "test string"
|
||||
set env(NAME2) "new value"
|
||||
set env(XYZZY) "garbage"
|
||||
test env-3.1 {changing environment variables} -setup {
|
||||
encoding system iso8859-1
|
||||
} -constraints {exec} -body {
|
||||
set result [getenv]
|
||||
unset env(NAME2)
|
||||
set result
|
||||
} -cleanup {
|
||||
encoding system $sysenc
|
||||
} -result {NAME1=test string
|
||||
NAME2=new value
|
||||
XYZZY=garbage}
|
||||
unset -nocomplain env(NAME2)
|
||||
|
||||
test env-4.1 {unsetting environment variables: default} -setup {
|
||||
encoding system iso8859-1
|
||||
} -constraints {exec} -body {
|
||||
getenv
|
||||
} -cleanup {
|
||||
encoding system $sysenc
|
||||
} -result {NAME1=test string
|
||||
XYZZY=garbage}
|
||||
test env-4.2 {unsetting environment variables} -setup {
|
||||
encoding system iso8859-1
|
||||
} -constraints {exec} -body {
|
||||
unset env(NAME1)
|
||||
getenv
|
||||
} -cleanup {
|
||||
unset env(XYZZY)
|
||||
encoding system $sysenc
|
||||
} -result {XYZZY=garbage}
|
||||
unset -nocomplain env(NAME1) env(XYZZY)
|
||||
test env-4.3 {setting international environment variables} -setup {
|
||||
encoding system iso8859-1
|
||||
} -constraints {exec} -body {
|
||||
set env(\ua7) \ub6
|
||||
getenv
|
||||
} -cleanup {
|
||||
encoding system $sysenc
|
||||
} -result {\u00a7=\u00b6}
|
||||
test env-4.4 {changing international environment variables} -setup {
|
||||
encoding system iso8859-1
|
||||
} -constraints {exec} -body {
|
||||
set env(\ua7) \ua7
|
||||
getenv
|
||||
} -cleanup {
|
||||
encoding system $sysenc
|
||||
} -result {\u00a7=\u00a7}
|
||||
test env-4.5 {unsetting international environment variables} -setup {
|
||||
encoding system iso8859-1
|
||||
set env(\ua7) \ua7
|
||||
} -body {
|
||||
set env(\ub6) \ua7
|
||||
unset env(\ua7)
|
||||
getenv
|
||||
} -constraints {exec} -cleanup {
|
||||
unset env(\ub6)
|
||||
encoding system $sysenc
|
||||
} -result {\u00b6=\u00a7}
|
||||
|
||||
test env-5.0 {corner cases - set a value, it should exist} -body {
|
||||
set env(temp) a
|
||||
set env(temp)
|
||||
} -cleanup {
|
||||
unset env(temp)
|
||||
} -result {a}
|
||||
test env-5.1 {corner cases - remove one elem at a time} -setup {
|
||||
set x [array get env]
|
||||
} -body {
|
||||
# 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.
|
||||
foreach e [array names env] {
|
||||
unset env($e)
|
||||
}
|
||||
array size env
|
||||
} -cleanup {
|
||||
array set env $x
|
||||
} -result {0}
|
||||
test env-5.2 {corner cases - unset the env array} -setup {
|
||||
interp create i
|
||||
} -body {
|
||||
# Unsetting a variable in an interp detaches the C-level traces from the
|
||||
# Tcl "env" variable.
|
||||
i eval {
|
||||
unset env
|
||||
set env(THIS_SHOULDNT_EXIST) a
|
||||
}
|
||||
info exists env(THIS_SHOULDNT_EXIST)
|
||||
} -cleanup {
|
||||
interp delete i
|
||||
} -result {0}
|
||||
test env-5.3 {corner cases: unset the env in master should unset child} -setup {
|
||||
interp create i
|
||||
} -body {
|
||||
# Variables deleted in a master interp should be deleted in child interp
|
||||
# too.
|
||||
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)}}]
|
||||
} -cleanup {
|
||||
interp delete i
|
||||
} -result {a 1}
|
||||
test env-5.4 {corner cases - unset the env array} -setup {
|
||||
interp create i
|
||||
} -body {
|
||||
# The info exists command should be in synch with the env array.
|
||||
# Know Bug: 1737
|
||||
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)]
|
||||
} -cleanup {
|
||||
interp delete i
|
||||
} -result {1 a 1}
|
||||
test env-5.5 {corner cases - cannot have null entries on Windows} -constraints win -body {
|
||||
set env() a
|
||||
catch {set env()}
|
||||
} -result 1
|
||||
|
||||
test env-6.1 {corner cases - add lots of env variables} -body {
|
||||
set size [array size env]
|
||||
for {set i 0} {$i < 100} {incr i} {
|
||||
set env(BOGUS$i) $i
|
||||
}
|
||||
expr {[array size env] - $size}
|
||||
} -result 100
|
||||
|
||||
test env-7.1 {[219226]: whole env array should not be unset by read} -body {
|
||||
set n [array size env]
|
||||
set s [array startsearch env]
|
||||
while {[array anymore env $s]} {
|
||||
array nextelement env $s
|
||||
incr n -1
|
||||
}
|
||||
array donesearch env $s
|
||||
return $n
|
||||
} -result 0
|
||||
|
||||
test env-7.2 {[219226]: links to env elements should not be removed by read} -body {
|
||||
apply {{} {
|
||||
set ::env(test7_2) ok
|
||||
upvar env(test7_2) elem
|
||||
set ::env(PATH)
|
||||
return $elem
|
||||
}}
|
||||
} -result ok
|
||||
|
||||
test env-7.3 {[9b4702]: testing existence of env(some_thing) should not destroy trace} -body {
|
||||
apply {{} {
|
||||
catch {unset ::env(test7_3)}
|
||||
proc foo args {
|
||||
set ::env(test7_3) ok
|
||||
}
|
||||
trace add variable ::env(not_yet_existent) write foo
|
||||
info exists ::env(not_yet_existent)
|
||||
set ::env(not_yet_existent) "Now I'm here";
|
||||
return [info exists ::env(test7_3)]
|
||||
}}
|
||||
} -result 1
|
||||
|
||||
# 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:
|
||||
1211
tests/error.test
Normal file
1211
tests/error.test
Normal file
File diff suppressed because it is too large
Load Diff
89
tests/eval.test
Normal file
89
tests/eval.test
Normal file
@@ -0,0 +1,89 @@
|
||||
# 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 {"::tcltest" ni [namespace children]} {
|
||||
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
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# fill-column: 78
|
||||
# End:
|
||||
961
tests/event.test
Normal file
961
tests/event.test
Normal file
@@ -0,0 +1,961 @@
|
||||
# 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::*
|
||||
|
||||
catch {
|
||||
::tcltest::loadTestedCommands
|
||||
package require -exact Tcltest [info patchlevel]
|
||||
set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1]
|
||||
}
|
||||
|
||||
|
||||
testConstraint testfilehandler [llength [info commands testfilehandler]]
|
||||
testConstraint testexithandler [llength [info commands testexithandler]]
|
||||
testConstraint testfilewait [llength [info commands testfilewait]]
|
||||
testConstraint exec [llength [info commands exec]]
|
||||
|
||||
test event-1.1 {Tcl_CreateFileHandler, reading} -setup {
|
||||
testfilehandler close
|
||||
set result ""
|
||||
} -constraints {testfilehandler} -body {
|
||||
testfilehandler create 0 readable off
|
||||
testfilehandler clear 0
|
||||
testfilehandler oneevent
|
||||
lappend result [testfilehandler counts 0]
|
||||
testfilehandler fillpartial 0
|
||||
testfilehandler oneevent
|
||||
lappend result [testfilehandler counts 0]
|
||||
testfilehandler oneevent
|
||||
lappend result [testfilehandler counts 0]
|
||||
} -cleanup {
|
||||
testfilehandler close
|
||||
} -result {{0 0} {1 0} {2 0}}
|
||||
test event-1.2 {Tcl_CreateFileHandler, writing} -setup {
|
||||
testfilehandler close
|
||||
set result ""
|
||||
} -constraints {testfilehandler nonPortable} -body {
|
||||
# This test is non-portable because on some systems (e.g., SunOS 4.1.3)
|
||||
# pipes seem to be writable always.
|
||||
testfilehandler create 0 off writable
|
||||
testfilehandler clear 0
|
||||
testfilehandler oneevent
|
||||
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]
|
||||
} -cleanup {
|
||||
testfilehandler close
|
||||
} -result {{0 1} {0 2} {0 2}}
|
||||
test event-1.3 {Tcl_DeleteFileHandler} -setup {
|
||||
testfilehandler close
|
||||
set result ""
|
||||
} -constraints {testfilehandler nonPortable} -body {
|
||||
testfilehandler create 2 disabled disabled
|
||||
testfilehandler create 1 readable writable
|
||||
testfilehandler create 0 disabled disabled
|
||||
testfilehandler fillpartial 1
|
||||
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]
|
||||
} -cleanup {
|
||||
testfilehandler close
|
||||
} -result {{0 1} {1 1} {1 2} {0 0}}
|
||||
|
||||
test event-2.1 {Tcl_DeleteFileHandler} -setup {
|
||||
testfilehandler close
|
||||
set result ""
|
||||
} -constraints {testfilehandler nonPortable} -body {
|
||||
testfilehandler create 2 disabled disabled
|
||||
testfilehandler create 1 readable writable
|
||||
testfilehandler fillpartial 1
|
||||
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]
|
||||
} -cleanup {
|
||||
testfilehandler close
|
||||
} -result {{0 1} {1 1} {1 2} {0 0}}
|
||||
test event-2.2 {Tcl_DeleteFileHandler, fd reused & events still pending} -setup {
|
||||
testfilehandler close
|
||||
set result ""
|
||||
} -constraints {testfilehandler nonPortable} -body {
|
||||
testfilehandler create 0 readable writable
|
||||
testfilehandler fillpartial 0
|
||||
testfilehandler oneevent
|
||||
lappend result [testfilehandler counts 0]
|
||||
testfilehandler close
|
||||
testfilehandler create 0 readable writable
|
||||
testfilehandler oneevent
|
||||
lappend result [testfilehandler counts 0]
|
||||
} -cleanup {
|
||||
testfilehandler close
|
||||
} -result {{0 1} {0 0}}
|
||||
|
||||
test event-3.1 {FileHandlerCheckProc, TCL_FILE_EVENTS off} -setup {
|
||||
testfilehandler close
|
||||
} -constraints {testfilehandler} -body {
|
||||
testfilehandler create 1 readable writable
|
||||
testfilehandler fillpartial 1
|
||||
testfilehandler windowevent
|
||||
testfilehandler counts 1
|
||||
} -cleanup {
|
||||
testfilehandler close
|
||||
} -result {0 0}
|
||||
|
||||
test event-4.1 {FileHandlerEventProc, race between event and disabling} -setup {
|
||||
update
|
||||
testfilehandler close
|
||||
set result ""
|
||||
} -constraints {testfilehandler nonPortable} -body {
|
||||
testfilehandler create 2 disabled disabled
|
||||
testfilehandler create 1 readable writable
|
||||
testfilehandler fillpartial 1
|
||||
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]
|
||||
} -cleanup {
|
||||
testfilehandler close
|
||||
} -result {{0 1} {1 1} {1 2} {0 0}}
|
||||
test event-4.2 {FileHandlerEventProc, TCL_FILE_EVENTS off} -setup {
|
||||
update
|
||||
testfilehandler close
|
||||
} -constraints {testfilehandler nonPortable} -body {
|
||||
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]
|
||||
} -cleanup {
|
||||
testfilehandler close
|
||||
} -result {{0 0} {0 1} {0 0} {0 1}}
|
||||
update
|
||||
|
||||
test event-5.1 {Tcl_BackgroundError, HandleBgErrors procedures} -setup {
|
||||
catch {rename bgerror {}}
|
||||
} -body {
|
||||
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
|
||||
regsub -all [file join {} non_existent] $x "non_existent"
|
||||
} -cleanup {
|
||||
rename bgerror {}
|
||||
} -result {{{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} -setup {
|
||||
catch {rename bgerror {}}
|
||||
} -body {
|
||||
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
|
||||
return $x
|
||||
} -cleanup {
|
||||
rename bgerror {}
|
||||
} -result {{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} -body {
|
||||
proc bgerror {m} {append ::res $m}
|
||||
set ::res {}
|
||||
::tcl::Bgerror {} {-level 0 -code 0}
|
||||
return $::res
|
||||
} -cleanup {
|
||||
rename bgerror {}
|
||||
} -result {}
|
||||
test event-5.11 {Default [interp bgerror] handler} -body {
|
||||
proc bgerror {m} {append ::res $m}
|
||||
set ::res {}
|
||||
::tcl::Bgerror msg {-level 0 -code 1}
|
||||
return $::res
|
||||
} -cleanup {
|
||||
rename bgerror {}
|
||||
} -result {msg}
|
||||
test event-5.12 {Default [interp bgerror] handler} -body {
|
||||
proc bgerror {m} {append ::res $m}
|
||||
set ::res {}
|
||||
::tcl::Bgerror msg {-level 0 -code 2}
|
||||
return $::res
|
||||
} -cleanup {
|
||||
rename bgerror {}
|
||||
} -result {command returned bad code: 2}
|
||||
test event-5.13 {Default [interp bgerror] handler} -body {
|
||||
proc bgerror {m} {append ::res $m}
|
||||
set ::res {}
|
||||
::tcl::Bgerror msg {-level 0 -code 3}
|
||||
return $::res
|
||||
} -cleanup {
|
||||
rename bgerror {}
|
||||
} -result {invoked "break" outside of a loop}
|
||||
test event-5.14 {Default [interp bgerror] handler} -body {
|
||||
proc bgerror {m} {append ::res $m}
|
||||
set ::res {}
|
||||
::tcl::Bgerror msg {-level 0 -code 4}
|
||||
return $::res
|
||||
} -cleanup {
|
||||
rename bgerror {}
|
||||
} -result {invoked "continue" outside of a loop}
|
||||
test event-5.15 {Default [interp bgerror] handler} -body {
|
||||
proc bgerror {m} {append ::res $m}
|
||||
set ::res {}
|
||||
::tcl::Bgerror msg {-level 0 -code 5}
|
||||
return $::res
|
||||
} -cleanup {
|
||||
rename bgerror {}
|
||||
} -result {command returned bad code: 5}
|
||||
|
||||
test event-6.1 {BgErrorDeleteProc procedure} -setup {
|
||||
catch {interp delete foo}
|
||||
interp create foo
|
||||
set erroutfile [makeFile Unmodified err.out]
|
||||
} -body {
|
||||
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
|
||||
return $result
|
||||
} -cleanup {
|
||||
removeFile $erroutfile
|
||||
} -result {Unmodified
|
||||
}
|
||||
|
||||
test event-7.1 {bgerror / regular} {
|
||||
set errRes {}
|
||||
proc bgerror {err} {
|
||||
global errRes
|
||||
set errRes $err
|
||||
}
|
||||
after 0 {error err1}
|
||||
vwait errRes
|
||||
return $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
|
||||
return $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
|
||||
return $errRes
|
||||
} err1
|
||||
test event-7.4 {tkerror is nothing special anymore to tcl} -body {
|
||||
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
|
||||
return $errRes
|
||||
} -cleanup {
|
||||
rename tkerror {}
|
||||
} -result bg:err1
|
||||
test event-7.5 {correct behaviour when there is no bgerror [Bug 219142]} -body {
|
||||
exec [interpreter] << {
|
||||
after 1000 error hello
|
||||
after 2000 set a 0
|
||||
vwait a
|
||||
}
|
||||
} -constraints {exec} -returnCodes error -result {hello
|
||||
while executing
|
||||
"error hello"
|
||||
("after" script)}
|
||||
test event-7.6 {safe hidden bgerror fallback} -setup {
|
||||
variable result {}
|
||||
interp create -safe safe
|
||||
} -body {
|
||||
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
|
||||
return $result
|
||||
} -cleanup {
|
||||
interp delete safe
|
||||
} -result {foo
|
||||
NONE
|
||||
foo
|
||||
while executing
|
||||
"error foo"
|
||||
("after" script)
|
||||
}
|
||||
test event-7.7 {safe hidden bgerror fallback} -setup {
|
||||
variable result {}
|
||||
interp create -safe safe
|
||||
} -body {
|
||||
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
|
||||
return $result
|
||||
} -cleanup {
|
||||
interp delete safe
|
||||
} -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 "catch {load $::tcltestlib Tcltest}"
|
||||
puts $child "testexithandler create 41; testexithandler create 4"
|
||||
puts $child "testexithandler create 6; exit"
|
||||
flush $child
|
||||
set result [read $child]
|
||||
close $child
|
||||
return $result
|
||||
} {even 6
|
||||
even 4
|
||||
odd 41
|
||||
}
|
||||
|
||||
test event-9.1 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
|
||||
set child [open |[list [interpreter]] r+]
|
||||
puts $child "catch {load $::tcltestlib Tcltest}"
|
||||
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
|
||||
return $result
|
||||
} {even 16
|
||||
even 6
|
||||
even 4
|
||||
}
|
||||
test event-9.2 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
|
||||
set child [open |[list [interpreter]] r+]
|
||||
puts $child "catch {load $::tcltestlib Tcltest}"
|
||||
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
|
||||
return $result
|
||||
} {even 16
|
||||
even 6
|
||||
odd 41
|
||||
}
|
||||
test event-9.3 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
|
||||
set child [open |[list [interpreter]] r+]
|
||||
puts $child "catch {load $::tcltestlib Tcltest}"
|
||||
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
|
||||
return $result
|
||||
} {even 16
|
||||
even 4
|
||||
odd 41
|
||||
}
|
||||
test event-9.4 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
|
||||
set child [open |[list [interpreter]] r+]
|
||||
puts $child "catch {load $::tcltestlib Tcltest}"
|
||||
puts $child "testexithandler create 41; testexithandler delete 41"
|
||||
puts $child "testexithandler create 16; exit"
|
||||
flush $child
|
||||
set result [read $child]
|
||||
close $child
|
||||
return $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} -returnCodes error -body {
|
||||
vwait
|
||||
} -result {wrong # args: should be "vwait name"}
|
||||
test event-11.2 {Tcl_VwaitCmd procedure} -returnCodes error -body {
|
||||
vwait a b
|
||||
} -result {wrong # args: should be "vwait name"}
|
||||
test event-11.3 {Tcl_VwaitCmd procedure} -setup {
|
||||
catch {unset x}
|
||||
} -body {
|
||||
set x 1
|
||||
vwait x(1)
|
||||
} -returnCodes error -result {can't trace "x(1)": variable isn't array}
|
||||
test event-11.4 {Tcl_VwaitCmd procedure} -setup {
|
||||
foreach i [after info] {
|
||||
after cancel $i
|
||||
}
|
||||
after 10; update; # On Mac make sure update won't take long
|
||||
} -body {
|
||||
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
|
||||
} -cleanup {
|
||||
foreach i [after info] {
|
||||
after cancel $i
|
||||
}
|
||||
} -result {{} x-done y-done before q-done}
|
||||
test event-11.5 {Tcl_VwaitCmd procedure: round robin scheduling, 2 sources} -setup {
|
||||
set test1file [makeFile "" test1]
|
||||
} -constraints {socket} -body {
|
||||
set f1 [open $test1file w]
|
||||
proc accept {s args} {
|
||||
puts $s foobar
|
||||
close $s
|
||||
}
|
||||
set s1 [socket -server accept -myaddr 127.0.0.1 0]
|
||||
after 1000
|
||||
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
|
||||
list $x $y $z
|
||||
} -cleanup {
|
||||
removeFile $test1file
|
||||
} -result {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-11.7 {Bug 16828b3744} {
|
||||
after idle {
|
||||
set ::t::v 1
|
||||
namespace delete ::t
|
||||
}
|
||||
namespace eval ::t {
|
||||
vwait ::t::v
|
||||
}
|
||||
} {}
|
||||
test event-11.8 {Bug 16828b3744} -setup {
|
||||
oo::class create A {
|
||||
variable continue
|
||||
|
||||
method start {} {
|
||||
after idle [self] destroy
|
||||
|
||||
set continue 0
|
||||
vwait [namespace current]::continue
|
||||
}
|
||||
destructor {
|
||||
set continue 1
|
||||
}
|
||||
}
|
||||
} -body {
|
||||
[A new] start
|
||||
} -cleanup {
|
||||
A destroy
|
||||
} -result {}
|
||||
|
||||
test event-12.1 {Tcl_UpdateCmd procedure} -returnCodes error -body {
|
||||
update a b
|
||||
} -result {wrong # args: should be "update ?idletasks?"}
|
||||
test event-12.2 {Tcl_UpdateCmd procedure} -returnCodes error -body {
|
||||
update bogus
|
||||
} -result {bad option "bogus": must be idletasks}
|
||||
test event-12.3 {Tcl_UpdateCmd procedure} -setup {
|
||||
foreach i [after info] {
|
||||
after cancel $i
|
||||
}
|
||||
} -body {
|
||||
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
|
||||
} -cleanup {
|
||||
foreach i [after info] {
|
||||
after cancel $i
|
||||
}
|
||||
} -result {before after {after, y = after}}
|
||||
test event-12.4 {Tcl_UpdateCmd procedure} -setup {
|
||||
foreach i [after info] {
|
||||
after cancel $i
|
||||
}
|
||||
} -body {
|
||||
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
|
||||
} -cleanup {
|
||||
foreach i [after info] {
|
||||
after cancel $i
|
||||
}
|
||||
} -result {x-done before z-done}
|
||||
|
||||
test event-13.1 {Tcl_WaitForFile procedure, readable} -setup {
|
||||
foreach i [after info] {
|
||||
after cancel $i
|
||||
}
|
||||
testfilehandler close
|
||||
} -constraints {testfilehandler} -body {
|
||||
after 100 set x timeout
|
||||
testfilehandler create 1 off off
|
||||
set x "no timeout"
|
||||
set result [testfilehandler wait 1 readable 0]
|
||||
update
|
||||
list $result $x
|
||||
} -cleanup {
|
||||
testfilehandler close
|
||||
foreach i [after info] {
|
||||
after cancel $i
|
||||
}
|
||||
} -result {{} {no timeout}}
|
||||
test event-13.2 {Tcl_WaitForFile procedure, readable} -setup {
|
||||
foreach i [after info] {
|
||||
after cancel $i
|
||||
}
|
||||
testfilehandler close
|
||||
} -constraints testfilehandler -body {
|
||||
after 100 set x timeout
|
||||
testfilehandler create 1 off off
|
||||
set x "no timeout"
|
||||
set result [testfilehandler wait 1 readable 100]
|
||||
update
|
||||
list $result $x
|
||||
} -cleanup {
|
||||
testfilehandler close
|
||||
foreach i [after info] {
|
||||
after cancel $i
|
||||
}
|
||||
} -result {{} timeout}
|
||||
test event-13.3 {Tcl_WaitForFile procedure, readable} -setup {
|
||||
foreach i [after info] {
|
||||
after cancel $i
|
||||
}
|
||||
testfilehandler close
|
||||
} -constraints testfilehandler -body {
|
||||
after 100 set x timeout
|
||||
testfilehandler create 1 off off
|
||||
testfilehandler fillpartial 1
|
||||
set x "no timeout"
|
||||
set result [testfilehandler wait 1 readable 100]
|
||||
update
|
||||
list $result $x
|
||||
} -cleanup {
|
||||
testfilehandler close
|
||||
foreach i [after info] {
|
||||
after cancel $i
|
||||
}
|
||||
} -result {readable {no timeout}}
|
||||
test event-13.4 {Tcl_WaitForFile procedure, writable} -setup {
|
||||
foreach i [after info] {
|
||||
after cancel $i
|
||||
}
|
||||
testfilehandler close
|
||||
} -constraints {testfilehandler nonPortable} -body {
|
||||
after 100 set x timeout
|
||||
testfilehandler create 1 off off
|
||||
testfilehandler fill 1
|
||||
set x "no timeout"
|
||||
set result [testfilehandler wait 1 writable 0]
|
||||
update
|
||||
list $result $x
|
||||
} -cleanup {
|
||||
testfilehandler close
|
||||
foreach i [after info] {
|
||||
after cancel $i
|
||||
}
|
||||
} -result {{} {no timeout}}
|
||||
test event-13.5 {Tcl_WaitForFile procedure, writable} -setup {
|
||||
foreach i [after info] {
|
||||
after cancel $i
|
||||
}
|
||||
testfilehandler close
|
||||
} -constraints {testfilehandler nonPortable} -body {
|
||||
after 100 set x timeout
|
||||
testfilehandler create 1 off off
|
||||
testfilehandler fill 1
|
||||
set x "no timeout"
|
||||
set result [testfilehandler wait 1 writable 100]
|
||||
update
|
||||
list $result $x
|
||||
} -cleanup {
|
||||
testfilehandler close
|
||||
foreach i [after info] {
|
||||
after cancel $i
|
||||
}
|
||||
} -result {{} timeout}
|
||||
test event-13.6 {Tcl_WaitForFile procedure, writable} -setup {
|
||||
foreach i [after info] {
|
||||
after cancel $i
|
||||
}
|
||||
testfilehandler close
|
||||
} -constraints testfilehandler -body {
|
||||
after 100 set x timeout
|
||||
testfilehandler create 1 off off
|
||||
set x "no timeout"
|
||||
set result [testfilehandler wait 1 writable 100]
|
||||
update
|
||||
list $result $x
|
||||
} -cleanup {
|
||||
testfilehandler close
|
||||
foreach i [after info] {
|
||||
after cancel $i
|
||||
}
|
||||
} -result {writable {no timeout}}
|
||||
test event-13.7 {Tcl_WaitForFile procedure, don't call other event handlers} -setup {
|
||||
foreach i [after info] {
|
||||
after cancel $i
|
||||
}
|
||||
testfilehandler close
|
||||
} -constraints testfilehandler -body {
|
||||
after 100 lappend x timeout
|
||||
after idle lappend x idle
|
||||
testfilehandler create 1 off off
|
||||
set x ""
|
||||
set result [list [testfilehandler wait 1 readable 200] $x]
|
||||
update
|
||||
lappend result $x
|
||||
} -cleanup {
|
||||
testfilehandler close
|
||||
foreach i [after info] {
|
||||
after cancel $i
|
||||
}
|
||||
} -result {{} {} {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
|
||||
return $result
|
||||
} {{} readable}
|
||||
|
||||
test event-14.1 {Tcl_WaitForFile procedure, readable, big fd} -setup {
|
||||
set chanList {}
|
||||
for {set i 0} {$i < 32} {incr i} {
|
||||
lappend chanList [open /dev/null r]
|
||||
}
|
||||
foreach i [after info] {after cancel $i}
|
||||
testfilehandler close
|
||||
} -constraints {testfilehandler unix} -body {
|
||||
after 100 set x timeout
|
||||
testfilehandler create 1 off off
|
||||
set x "no timeout"
|
||||
set result [testfilehandler wait 1 readable 0]
|
||||
update
|
||||
list $result $x
|
||||
} -cleanup {
|
||||
testfilehandler close
|
||||
foreach chan $chanList {close $chan}
|
||||
foreach i [after info] {after cancel $i}
|
||||
} -result {{} {no timeout}}
|
||||
test event-14.2 {Tcl_WaitForFile procedure, readable, big fd} -setup {
|
||||
set chanList {}
|
||||
for {set i 0} {$i < 32} {incr i} {
|
||||
lappend chanList [open /dev/null r]
|
||||
}
|
||||
foreach i [after info] {after cancel $i}
|
||||
testfilehandler close
|
||||
} -constraints {testfilehandler unix} -body {
|
||||
after 100 set x timeout
|
||||
testfilehandler create 1 off off
|
||||
set x "no timeout"
|
||||
set result [testfilehandler wait 1 readable 100]
|
||||
update
|
||||
list $result $x
|
||||
} -cleanup {
|
||||
testfilehandler close
|
||||
foreach chan $chanList {close $chan}
|
||||
foreach i [after info] {after cancel $i}
|
||||
} -result {{} timeout}
|
||||
test event-14.3 {Tcl_WaitForFile procedure, readable, big fd} -setup {
|
||||
set chanList {}
|
||||
for {set i 0} {$i < 32} {incr i} {
|
||||
lappend chanList [open /dev/null r]
|
||||
}
|
||||
foreach i [after info] {after cancel $i}
|
||||
testfilehandler close
|
||||
} -constraints {testfilehandler unix} -body {
|
||||
after 100 set x timeout
|
||||
testfilehandler create 1 off off
|
||||
testfilehandler fillpartial 1
|
||||
set x "no timeout"
|
||||
set result [testfilehandler wait 1 readable 100]
|
||||
update
|
||||
list $result $x
|
||||
} -cleanup {
|
||||
testfilehandler close
|
||||
foreach chan $chanList {close $chan}
|
||||
foreach i [after info] {after cancel $i}
|
||||
} -result {readable {no timeout}}
|
||||
test event-14.4 {Tcl_WaitForFile procedure, writable, big fd} -setup {
|
||||
set chanList {}
|
||||
for {set i 0} {$i < 32} {incr i} {
|
||||
lappend chanList [open /dev/null r]
|
||||
}
|
||||
foreach i [after info] {after cancel $i}
|
||||
testfilehandler close
|
||||
} -constraints {testfilehandler unix nonPortable} -body {
|
||||
after 100 set x timeout
|
||||
testfilehandler create 1 off off
|
||||
testfilehandler fill 1
|
||||
set x "no timeout"
|
||||
set result [testfilehandler wait 1 writable 0]
|
||||
update
|
||||
list $result $x
|
||||
} -cleanup {
|
||||
testfilehandler close
|
||||
foreach chan $chanList {close $chan}
|
||||
foreach i [after info] {after cancel $i}
|
||||
} -result {{} {no timeout}}
|
||||
test event-14.5 {Tcl_WaitForFile procedure, writable, big fd} -setup {
|
||||
set chanList {}
|
||||
for {set i 0} {$i < 32} {incr i} {
|
||||
lappend chanList [open /dev/null r]
|
||||
}
|
||||
foreach i [after info] {after cancel $i}
|
||||
testfilehandler close
|
||||
} -constraints {testfilehandler unix nonPortable} -body {
|
||||
after 100 set x timeout
|
||||
testfilehandler create 1 off off
|
||||
testfilehandler fill 1
|
||||
set x "no timeout"
|
||||
set result [testfilehandler wait 1 writable 100]
|
||||
update
|
||||
list $result $x
|
||||
} -cleanup {
|
||||
testfilehandler close
|
||||
foreach chan $chanList {close $chan}
|
||||
foreach i [after info] {after cancel $i}
|
||||
} -result {{} timeout}
|
||||
test event-14.6 {Tcl_WaitForFile procedure, writable, big fd} -setup {
|
||||
set chanList {}
|
||||
for {set i 0} {$i < 32} {incr i} {
|
||||
lappend chanList [open /dev/null r]
|
||||
}
|
||||
foreach i [after info] {after cancel $i}
|
||||
testfilehandler close
|
||||
} -constraints {testfilehandler unix} -body {
|
||||
after 100 set x timeout
|
||||
testfilehandler create 1 off off
|
||||
set x "no timeout"
|
||||
set result [testfilehandler wait 1 writable 100]
|
||||
update
|
||||
list $result $x
|
||||
} -cleanup {
|
||||
testfilehandler close
|
||||
foreach chan $chanList {close $chan}
|
||||
foreach i [after info] {after cancel $i}
|
||||
} -result {writable {no timeout}}
|
||||
test event-14.7 {Tcl_WaitForFile, don't call other event handlers, big fd} -setup {
|
||||
set chanList {}
|
||||
for {set i 0} {$i < 32} {incr i} {
|
||||
lappend chanList [open /dev/null r]
|
||||
}
|
||||
foreach i [after info] {after cancel $i}
|
||||
testfilehandler close
|
||||
} -constraints {testfilehandler unix} -body {
|
||||
after 100 lappend x timeout
|
||||
after idle lappend x idle
|
||||
testfilehandler create 1 off off
|
||||
set x ""
|
||||
set result [list [testfilehandler wait 1 readable 200] $x]
|
||||
update
|
||||
lappend result $x
|
||||
} -cleanup {
|
||||
testfilehandler close
|
||||
foreach chan $chanList {close $chan}
|
||||
foreach i [after info] {after cancel $i}
|
||||
} -result {{} {} {timeout idle}}
|
||||
test event-14.8 {Tcl_WaitForFile procedure, waiting indefinitely, big fd} -setup {
|
||||
set chanList {}
|
||||
for {set i 0} {$i < 32} {incr i} {
|
||||
lappend chanList [open /dev/null r]
|
||||
}
|
||||
} -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
|
||||
return $result
|
||||
} -cleanup {
|
||||
foreach chan $chanList {close $chan}
|
||||
} -result {{} readable}
|
||||
|
||||
# cleanup
|
||||
foreach i [after info] {
|
||||
after cancel $i
|
||||
}
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# End:
|
||||
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
|
||||
|
||||
# Utilities that are like bourne shell stalwarts, but cross-platform.
|
||||
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 eq ""} {
|
||||
set argv -
|
||||
}
|
||||
fconfigure stdout -translation binary
|
||||
foreach name $argv {
|
||||
if {$name eq "-"} {
|
||||
set f stdin
|
||||
} elseif {[catch {open $name r} f] != 0} {
|
||||
puts stderr $f
|
||||
continue
|
||||
}
|
||||
fconfigure $f -translation binary
|
||||
while {[eof $f] == 0} {
|
||||
puts -nonewline [read $f]
|
||||
}
|
||||
if {$f ne "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] ne "-c"} {
|
||||
error "sh: unexpected arguments $argv"
|
||||
}
|
||||
set cmd [lindex $argv 1]
|
||||
lappend cmd ";"
|
||||
set newcmd {}
|
||||
foreach arg $cmd {
|
||||
if {$arg eq ";"} {
|
||||
exec >@stdout 2>@stderr [info nameofexecutable] {*}$newcmd
|
||||
set newcmd {}
|
||||
continue
|
||||
}
|
||||
if {$arg eq "1>&2"} {
|
||||
set arg >@stderr
|
||||
}
|
||||
lappend newcmd $arg
|
||||
}
|
||||
exit
|
||||
} sh]
|
||||
set path(sh2) [makeFile {
|
||||
if {[lindex $argv 0] ne "-c"} {
|
||||
error "sh: unexpected arguments $argv"
|
||||
}
|
||||
set cmd [lindex $argv 1]
|
||||
lappend cmd ";"
|
||||
set newcmd {}
|
||||
foreach arg $cmd {
|
||||
if {$arg eq ";"} {
|
||||
exec -ignorestderr >@stdout [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]
|
||||
|
||||
proc readfile filename {
|
||||
set f [open $filename]
|
||||
set d [read $f]
|
||||
close $f
|
||||
return [string trimright $d \n]
|
||||
}
|
||||
|
||||
# ----------------------------------------------------------------------
|
||||
# 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} -setup {
|
||||
set sysenc [encoding system]
|
||||
encoding system iso8859-1
|
||||
proc quotenonascii s {
|
||||
regsub -all {\[|\\|\]} $s {\\&} s
|
||||
regsub -all "\[\u007f-\uffff\]" $s \
|
||||
{[apply {c {format {\u%04x} [scan $c %c]}} &]} s
|
||||
return [subst -novariables $s]
|
||||
}
|
||||
} -constraints {exec} -body {
|
||||
# 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.
|
||||
quotenonascii [exec [interpreter] $path(cat) << "\uE9\uE0\uFC\uF1"]
|
||||
} -cleanup {
|
||||
encoding system $sysenc
|
||||
rename quotenonascii {}
|
||||
} -result {\u00e9\u00e0\u00fc\u00f1}
|
||||
|
||||
# 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} -constraints {exec} -body {
|
||||
set f [open $path(gorp.file) r]
|
||||
exec [interpreter] $path(cat) <@ $f
|
||||
} -cleanup {
|
||||
close $f
|
||||
} -result {Just a few thoughts}
|
||||
test exec-5.7 {redirecting input from file} -constraints {exec} -body {
|
||||
set f [open $path(gorp.file) r]
|
||||
exec <@$f [interpreter] $path(cat)
|
||||
} -cleanup {
|
||||
close $f
|
||||
} -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} -constraints {exec stdio} -body {
|
||||
exec [interpreter] $path(sleep) 1 | [interpreter] $path(exit) 43 | [interpreter] $path(sleep) 1
|
||||
} -returnCodes error -result {child process exited abnormally}
|
||||
test exec-9.4 {commands returning errors} -constraints {exec stdio} -body {
|
||||
exec [interpreter] $path(exit) 43 | [interpreter] $path(echo) "foo bar"
|
||||
} -returnCodes error -result {foo bar
|
||||
child process exited abnormally}
|
||||
test exec-9.5 {commands returning errors} -constraints {exec stdio} -body {
|
||||
exec gorp456 | [interpreter] echo a b c
|
||||
} -returnCodes error -result {couldn't execute "gorp456": no such file or directory}
|
||||
test exec-9.6 {commands returning errors} -constraints {exec} -body {
|
||||
exec [interpreter] $path(sh) -c "\"$path(echo)\" error msg 1>&2"
|
||||
} -returnCodes error -result {error msg}
|
||||
test exec-9.7 {commands returning errors} -constraints {exec stdio nonPortable} -body {
|
||||
# This test can fail easily on multiprocessor machines
|
||||
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"
|
||||
} -returnCodes error -result {error msg
|
||||
error msg}
|
||||
set path(err) [makeFile {} err]
|
||||
test exec-9.8 {commands returning errors} -constraints {exec} -setup {
|
||||
set f [open $path(err) w]
|
||||
puts $f {
|
||||
puts stdout out
|
||||
puts stderr err
|
||||
}
|
||||
close $f
|
||||
} -body {
|
||||
exec [interpreter] $path(err)
|
||||
} -returnCodes error -result {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} -constraints {exec} -body {
|
||||
exec
|
||||
} -returnCodes error -result {wrong # args: should be "exec ?-option ...? arg ?arg ...?"}
|
||||
test exec-10.2 {errors in exec invocation} -constraints {exec} -body {
|
||||
exec | cat
|
||||
} -returnCodes error -result {illegal use of | or |& in command}
|
||||
test exec-10.3 {errors in exec invocation} -constraints {exec} -body {
|
||||
exec cat |
|
||||
} -returnCodes error -result {illegal use of | or |& in command}
|
||||
test exec-10.4 {errors in exec invocation} -constraints {exec} -body {
|
||||
exec cat | | cat
|
||||
} -returnCodes error -result {illegal use of | or |& in command}
|
||||
test exec-10.5 {errors in exec invocation} -constraints {exec} -body {
|
||||
exec cat | |& cat
|
||||
} -returnCodes error -result {illegal use of | or |& in command}
|
||||
test exec-10.6 {errors in exec invocation} -constraints {exec} -body {
|
||||
exec cat |&
|
||||
} -returnCodes error -result {illegal use of | or |& in command}
|
||||
test exec-10.7 {errors in exec invocation} -constraints {exec} -body {
|
||||
exec cat <
|
||||
} -returnCodes error -result {can't specify "<" as last word in command}
|
||||
test exec-10.8 {errors in exec invocation} -constraints {exec} -body {
|
||||
exec cat >
|
||||
} -returnCodes error -result {can't specify ">" as last word in command}
|
||||
test exec-10.9 {errors in exec invocation} -constraints {exec} -body {
|
||||
exec cat <<
|
||||
} -returnCodes error -result {can't specify "<<" as last word in command}
|
||||
test exec-10.10 {errors in exec invocation} -constraints {exec} -body {
|
||||
exec cat >>
|
||||
} -returnCodes error -result {can't specify ">>" as last word in command}
|
||||
test exec-10.11 {errors in exec invocation} -constraints {exec} -body {
|
||||
exec cat >&
|
||||
} -returnCodes error -result {can't specify ">&" as last word in command}
|
||||
test exec-10.12 {errors in exec invocation} -constraints {exec} -body {
|
||||
exec cat >>&
|
||||
} -returnCodes error -result {can't specify ">>&" as last word in command}
|
||||
test exec-10.13 {errors in exec invocation} -constraints {exec} -body {
|
||||
exec cat >@
|
||||
} -returnCodes error -result {can't specify ">@" as last word in command}
|
||||
test exec-10.14 {errors in exec invocation} -constraints {exec} -body {
|
||||
exec cat <@
|
||||
} -returnCodes error -result {can't specify "<@" as last word in command}
|
||||
test exec-10.15 {errors in exec invocation} -constraints {exec} -body {
|
||||
exec cat < a/b/c
|
||||
} -returnCodes error -result {couldn't read file "a/b/c": no such file or directory}
|
||||
test exec-10.16 {errors in exec invocation} -constraints {exec} -body {
|
||||
exec cat << foo > a/b/c
|
||||
} -returnCodes error -result {couldn't write file "a/b/c": no such file or directory}
|
||||
test exec-10.17 {errors in exec invocation} -constraints {exec} -body {
|
||||
exec cat << foo > a/b/c
|
||||
} -returnCodes error -result {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} -constraints {exec} -body {
|
||||
exec cat <@ $f
|
||||
} -returnCodes error -result "channel \"$f\" wasn't opened for reading"
|
||||
close $f
|
||||
set f [open $path(gorp.file) r]
|
||||
test exec-10.19 {errors in exec invocation} -constraints {exec} -body {
|
||||
exec cat >@ $f
|
||||
} -returnCodes error -result "channel \"$f\" wasn't opened for writing"
|
||||
close $f
|
||||
test exec-10.20 {errors in exec invocation} -constraints {exec} -body {
|
||||
exec ~non_existent_user/foo/bar
|
||||
} -returnCodes error -result {user "non_existent_user" doesn't exist}
|
||||
test exec-10.21 {errors in exec invocation} -constraints {exec} -body {
|
||||
exec [interpreter] true | ~xyzzy_bad_user/x | false
|
||||
} -returnCodes error -result {user "xyzzy_bad_user" doesn't exist}
|
||||
test exec-10.22 {errors in exec invocation} -constraints exec -body {
|
||||
exec echo test > ~non_existent_user/foo/bar
|
||||
} -returnCodes error -result {user "non_existent_user" doesn't exist}
|
||||
# Commands in background.
|
||||
|
||||
test exec-11.1 {commands in background} {exec} {
|
||||
set time [time {exec [interpreter] $path(sleep) 2 &}]
|
||||
expr {[lindex $time 0] < 1000000}
|
||||
} 1
|
||||
test exec-11.2 {commands in background} -constraints {exec} -body {
|
||||
exec [interpreter] $path(echo) a &b
|
||||
} -result {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
|
||||
exec [interpreter] $path(gorp.file)
|
||||
} foo
|
||||
|
||||
# Make sure that background commands are properly reaped when they
|
||||
# eventually die.
|
||||
|
||||
if {[testConstraint exec] && [testConstraint nonPortable]} {
|
||||
after 1300
|
||||
exec [interpreter] $path(sleep) 1
|
||||
}
|
||||
test exec-12.1 {reaping background processes} {exec unix nonPortable} {
|
||||
for {set i 0} {$i < 20} {incr i} {
|
||||
exec echo foo > /dev/null &
|
||||
}
|
||||
after 1000
|
||||
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]
|
||||
after 3000
|
||||
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} -setup {
|
||||
set tmp [makeFile {exit 0x00000101} tmpfile.exec-13.4]
|
||||
} -constraints {win} -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} -setup {
|
||||
set tmp [makeFile {exit 0x3fffffff} tmpfile.exec-13.5]
|
||||
} -constraints {win} -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} -setup {
|
||||
set tmp [makeFile {exit 0xC0000016} tmpfile.exec-13.6]
|
||||
} -constraints {win} -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} -constraints {exec} -body {
|
||||
exec -keepnewline
|
||||
} -returnCodes error -result {wrong # args: should be "exec ?-option ...? arg ?arg ...?"}
|
||||
test exec-14.3 {unknown switch} -constraints {exec} -body {
|
||||
exec -gorp
|
||||
} -returnCodes error -result {bad option "-gorp": must be -ignorestderr, -keepnewline, or --}
|
||||
test exec-14.4 {-- switch} -constraints {exec} -body {
|
||||
exec -- -gorp
|
||||
} -returnCodes error -result {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
|
||||
readfile $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)"
|
||||
readfile $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 [readfile $path(gorp.file)] [readfile $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
|
||||
readfile $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
|
||||
readfile $path(gorp.file)
|
||||
} {First line
|
||||
Second line
|
||||
Third line}
|
||||
|
||||
test exec-17.1 {inheriting standard I/O} -constraints {exec} -setup {
|
||||
set path(script) [makeFile {} script]
|
||||
set f [open $path(script) w]
|
||||
puts $f [list lassign [list \
|
||||
[info nameofexecutable] $path(gorp.file) $path(echo) $path(sleep) \
|
||||
] exe file echo sleep]
|
||||
puts $f {
|
||||
close stdout
|
||||
set f [open $file w]
|
||||
catch {exec $exe $echo foobar &}
|
||||
exec $exe $sleep 2
|
||||
close $f
|
||||
}
|
||||
close $f
|
||||
} -body {
|
||||
catch {exec [interpreter] $path(script)} result
|
||||
list $result [readfile $path(gorp.file)]
|
||||
} -cleanup {
|
||||
removeFile $path(script)
|
||||
} -result {{} foobar}
|
||||
|
||||
test exec-18.1 {exec deals with weird file names} -body {
|
||||
set path(fooblah) [makeFile {contents} "foo\[\{blah"]
|
||||
exec [interpreter] $path(cat) $path(fooblah)
|
||||
} -constraints {exec} -cleanup {
|
||||
removeFile $path(fooblah)
|
||||
} -result contents
|
||||
test exec-18.2 {exec cat deals with weird file names} -body {
|
||||
# This is cross-platform, but the cat isn't predictably correct on
|
||||
# Windows.
|
||||
set path(fooblah) [makeFile {contents} "foo\[\{blah"]
|
||||
exec cat $path(fooblah)
|
||||
} -constraints {exec tempNotWin} -cleanup {
|
||||
removeFile $path(fooblah)
|
||||
} -result contents
|
||||
|
||||
# Note that this test cannot be adapted to work on Windows; that platform has
|
||||
# no kernel support for an analog of O_APPEND. OTOH, that means we can assume
|
||||
# that there is a POSIX shell...
|
||||
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
|
||||
|
||||
# Tests to ensure batch files and .CMD (Bug 9ece99d58b)
|
||||
# can be executed on Windows
|
||||
test exec-20.0 {exec .bat file} -constraints {win} -body {
|
||||
set log [makeFile {} exec20.log]
|
||||
exec [makeFile "echo %1> $log" exec20.bat] "Testing exec-20.0"
|
||||
viewFile $log
|
||||
} -result "\"Testing exec-20.0\""
|
||||
test exec-20.1 {exec .CMD file} -constraints {win} -body {
|
||||
set log [makeFile {} exec201.log]
|
||||
exec [makeFile "echo %1> $log" exec201.CMD] "Testing exec-20.1"
|
||||
viewFile $log
|
||||
} -result "\"Testing exec-20.1\""
|
||||
|
||||
|
||||
|
||||
|
||||
# ----------------------------------------------------------------------
|
||||
# cleanup
|
||||
|
||||
foreach file {gorp.file gorp.file2 echo echo2 cat wc sh sh2 sleep exit err} {
|
||||
removeFile $file
|
||||
}
|
||||
unset -nocomplain path
|
||||
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# End:
|
||||
1088
tests/execute.test
Normal file
1088
tests/execute.test
Normal file
File diff suppressed because it is too large
Load Diff
1208
tests/expr-old.test
Normal file
1208
tests/expr-old.test
Normal file
File diff suppressed because it is too large
Load Diff
7194
tests/expr.test
Normal file
7194
tests/expr.test
Normal file
File diff suppressed because it is too large
Load Diff
2608
tests/fCmd.test
Normal file
2608
tests/fCmd.test
Normal file
File diff suppressed because it is too large
Load Diff
1633
tests/fileName.test
Normal file
1633
tests/fileName.test
Normal file
File diff suppressed because it is too large
Load Diff
956
tests/fileSystem.test
Normal file
956
tests/fileSystem.test
Normal file
@@ -0,0 +1,956 @@
|
||||
# This file tests the filesystem and vfs internals.
|
||||
#
|
||||
# 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) 2002 Vincent Darley.
|
||||
#
|
||||
# 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::fileSystem {
|
||||
namespace import ::tcltest::*
|
||||
|
||||
catch {
|
||||
file delete -force link.file
|
||||
file delete -force dir.link
|
||||
file delete -force [file join dir.dir linkinside.file]
|
||||
}
|
||||
|
||||
testConstraint loaddll 0
|
||||
catch {
|
||||
::tcltest::loadTestedCommands
|
||||
package require -exact Tcltest [info patchlevel]
|
||||
set ::ddever [package require dde]
|
||||
set ::ddelib [lindex [package ifneeded dde $::ddever] 1]
|
||||
set ::regver [package require registry]
|
||||
set ::reglib [lindex [package ifneeded registry $::regver] 1]
|
||||
testConstraint loaddll 1
|
||||
}
|
||||
|
||||
# Test for commands defined in Tcltest executable
|
||||
testConstraint testfilesystem [llength [info commands ::testfilesystem]]
|
||||
testConstraint testsetplatform [llength [info commands ::testsetplatform]]
|
||||
testConstraint testsimplefilesystem [llength [info commands ::testsimplefilesystem]]
|
||||
|
||||
cd [tcltest::temporaryDirectory]
|
||||
makeFile "test file" gorp.file
|
||||
makeDirectory dir.dir
|
||||
makeDirectory [file join dir.dir dirinside.dir]
|
||||
makeFile "test file in directory" [file join dir.dir inside.file]
|
||||
|
||||
testConstraint unusedDrive 0
|
||||
testConstraint moreThanOneDrive 0
|
||||
apply {{} {
|
||||
# The variables 'drive' and 'drives' will be used below.
|
||||
variable drive {} drives {}
|
||||
if {[testConstraint win]} {
|
||||
set vols [string map [list :/ {}] [file volumes]]
|
||||
for {set i 0} {$i < 26} {incr i} {
|
||||
set drive [format %c [expr {$i + 65}]]
|
||||
if {$drive ni $vols} {
|
||||
testConstraint unusedDrive 1
|
||||
break
|
||||
}
|
||||
}
|
||||
|
||||
set dir [pwd]
|
||||
try {
|
||||
foreach vol [file volumes] {
|
||||
if {![catch {cd $vol}]} {
|
||||
lappend drives $vol
|
||||
}
|
||||
}
|
||||
testConstraint moreThanOneDrive [llength $drives]
|
||||
} finally {
|
||||
cd $dir
|
||||
}
|
||||
}
|
||||
} ::tcl::test::fileSystem}
|
||||
|
||||
proc testPathEqual {one two} {
|
||||
if {$one eq $two} {
|
||||
return "ok"
|
||||
}
|
||||
return "not equal: $one $two"
|
||||
}
|
||||
|
||||
testConstraint hasLinks [expr {![catch {
|
||||
file link link.file gorp.file
|
||||
cd dir.dir
|
||||
file link \
|
||||
[file join linkinside.file] \
|
||||
[file join inside.file]
|
||||
cd ..
|
||||
file link dir.link dir.dir
|
||||
cd dir.dir
|
||||
file link [file join dirinside.link] \
|
||||
[file join dirinside.dir]
|
||||
cd ..
|
||||
}]}]
|
||||
|
||||
if {[testConstraint testsetplatform]} {
|
||||
set platform [testgetplatform]
|
||||
}
|
||||
|
||||
# ----------------------------------------------------------------------
|
||||
|
||||
test filesystem-1.0 {link normalisation} {hasLinks} {
|
||||
string equal [file normalize gorp.file] [file normalize link.file]
|
||||
} {0}
|
||||
test filesystem-1.1 {link normalisation} {hasLinks} {
|
||||
string equal [file normalize dir.dir] [file normalize dir.link]
|
||||
} {0}
|
||||
test filesystem-1.2 {link normalisation} {hasLinks unix} {
|
||||
testPathEqual [file normalize [file join gorp.file foo]] \
|
||||
[file normalize [file join link.file foo]]
|
||||
} ok
|
||||
test filesystem-1.3 {link normalisation} {hasLinks} {
|
||||
testPathEqual [file normalize [file join dir.dir foo]] \
|
||||
[file normalize [file join dir.link foo]]
|
||||
} ok
|
||||
test filesystem-1.4 {link normalisation} {hasLinks} {
|
||||
testPathEqual [file normalize [file join dir.dir inside.file]] \
|
||||
[file normalize [file join dir.link inside.file]]
|
||||
} ok
|
||||
test filesystem-1.5 {link normalisation} {hasLinks} {
|
||||
testPathEqual [file normalize [file join dir.dir linkinside.file]] \
|
||||
[file normalize [file join dir.dir linkinside.file]]
|
||||
} ok
|
||||
test filesystem-1.6 {link normalisation} {hasLinks} {
|
||||
string equal [file normalize [file join dir.dir linkinside.file]] \
|
||||
[file normalize [file join dir.link inside.file]]
|
||||
} {0}
|
||||
test filesystem-1.7 {link normalisation} {hasLinks unix} {
|
||||
testPathEqual [file normalize [file join dir.link linkinside.file foo]] \
|
||||
[file normalize [file join dir.dir inside.file foo]]
|
||||
} ok
|
||||
test filesystem-1.8 {link normalisation} {hasLinks} {
|
||||
string equal [file normalize [file join dir.dir linkinside.filefoo]] \
|
||||
[file normalize [file join dir.link inside.filefoo]]
|
||||
} {0}
|
||||
test filesystem-1.9 {link normalisation} -setup {
|
||||
file delete -force dir.link
|
||||
} -constraints {unix hasLinks} -body {
|
||||
file link dir.link [file nativename dir.dir]
|
||||
testPathEqual [file normalize [file join dir.dir linkinside.file foo]] \
|
||||
[file normalize [file join dir.link inside.file foo]]
|
||||
} -result ok
|
||||
test filesystem-1.10 {link normalisation: double link} -constraints {
|
||||
unix hasLinks
|
||||
} -body {
|
||||
file link dir2.link dir.link
|
||||
testPathEqual [file normalize [file join dir.dir linkinside.file foo]] \
|
||||
[file normalize [file join dir2.link inside.file foo]]
|
||||
} -cleanup {
|
||||
file delete dir2.link
|
||||
} -result ok
|
||||
makeDirectory dir2.file
|
||||
test filesystem-1.11 {link normalisation: double link, back in tree} {unix hasLinks} {
|
||||
file link dir2.link dir.link
|
||||
file link [file join dir2.file dir2.link] [file join .. dir2.link]
|
||||
testPathEqual [file normalize [file join dir.dir linkinside.file foo]] \
|
||||
[file normalize [file join dir2.file dir2.link inside.file foo]]
|
||||
} ok
|
||||
test filesystem-1.12 {file new native path} {} {
|
||||
for {set i 0} {$i < 10} {incr i} {
|
||||
foreach f [lsort [glob -nocomplain -type l *]] {
|
||||
catch {file readlink $f}
|
||||
}
|
||||
}
|
||||
# If we reach here we've succeeded. We used to crash above.
|
||||
expr 1
|
||||
} {1}
|
||||
test filesystem-1.13 {file normalisation} {win} {
|
||||
# This used to be broken
|
||||
file normalize C:/thislongnamedoesntexist
|
||||
} {C:/thislongnamedoesntexist}
|
||||
test filesystem-1.14 {file normalisation} {win} {
|
||||
# This used to be broken
|
||||
file normalize c:/
|
||||
} {C:/}
|
||||
test filesystem-1.15 {file normalisation} {win} {
|
||||
file normalize c:/../
|
||||
} {C:/}
|
||||
test filesystem-1.16 {file normalisation} {win} {
|
||||
file normalize c:/.
|
||||
} {C:/}
|
||||
test filesystem-1.17 {file normalisation} {win} {
|
||||
file normalize c:/..
|
||||
} {C:/}
|
||||
test filesystem-1.17.1 {file normalisation} {win} {
|
||||
file normalize c:\\..
|
||||
} {C:/}
|
||||
test filesystem-1.18 {file normalisation} {win} {
|
||||
file normalize c:/./
|
||||
} {C:/}
|
||||
test filesystem-1.19 {file normalisation} {win unusedDrive} {
|
||||
file normalize ${drive}:/./../../..
|
||||
} "${drive}:/"
|
||||
test filesystem-1.20 {file normalisation} {win} {
|
||||
file normalize //name/foo/../
|
||||
} {//name/foo}
|
||||
test filesystem-1.21 {file normalisation} {win} {
|
||||
file normalize C:///foo/./
|
||||
} {C:/foo}
|
||||
test filesystem-1.22 {file normalisation} {win} {
|
||||
file normalize //name/foo/.
|
||||
} {//name/foo}
|
||||
test filesystem-1.23 {file normalisation} {win} {
|
||||
file normalize c:/./foo
|
||||
} {C:/foo}
|
||||
test filesystem-1.24 {file normalisation} {win unusedDrive} {
|
||||
file normalize ${drive}:/./../../../a
|
||||
} "${drive}:/a"
|
||||
test filesystem-1.25 {file normalisation} {win unusedDrive} {
|
||||
file normalize ${drive}:/./.././../../a
|
||||
} "${drive}:/a"
|
||||
test filesystem-1.25.1 {file normalisation} {win unusedDrive} {
|
||||
file normalize ${drive}:/./.././..\\..\\a\\bb
|
||||
} "${drive}:/a/bb"
|
||||
test filesystem-1.26 {link normalisation: link and ..} -setup {
|
||||
file delete -force dir2.link
|
||||
} -constraints {hasLinks} -body {
|
||||
set dir [file join dir2 foo bar]
|
||||
file mkdir $dir
|
||||
file link dir2.link [file join dir2 foo bar]
|
||||
testPathEqual [file normalize [file join dir2 foo x]] \
|
||||
[file normalize [file join dir2.link .. x]]
|
||||
} -result ok
|
||||
test filesystem-1.27 {file normalisation: up and down with ..} {
|
||||
set dir [file join dir2 foo bar]
|
||||
file mkdir $dir
|
||||
set dir2 [file join dir2 .. dir2 foo .. foo bar]
|
||||
list [testPathEqual [file normalize $dir] [file normalize $dir2]] \
|
||||
[file exists $dir] [file exists $dir2]
|
||||
} {ok 1 1}
|
||||
test filesystem-1.28 {link normalisation: link with .. and ..} -setup {
|
||||
file delete -force dir2.link
|
||||
} -constraints {hasLinks} -body {
|
||||
set dir [file join dir2 foo bar]
|
||||
file mkdir $dir
|
||||
set to [file join dir2 .. dir2 foo .. foo bar]
|
||||
file link dir2.link $to
|
||||
testPathEqual [file normalize [file join dir2 foo x]] \
|
||||
[file normalize [file join dir2.link .. x]]
|
||||
} -result ok
|
||||
test filesystem-1.29 {link normalisation: link with ..} -setup {
|
||||
file delete -force dir2.link
|
||||
} -constraints {hasLinks} -body {
|
||||
set dir [file join dir2 foo bar]
|
||||
file mkdir $dir
|
||||
set to [file join dir2 .. dir2 foo .. foo bar]
|
||||
file link dir2.link $to
|
||||
set res [file normalize [file join dir2.link x yyy z]]
|
||||
if {[string match *..* $res]} {
|
||||
return "$res must not contain '..'"
|
||||
}
|
||||
return "ok"
|
||||
} -result {ok}
|
||||
test filesystem-1.29.1 {link normalisation with two consecutive links} {hasLinks} {
|
||||
testPathEqual [file normalize [file join dir.link dirinside.link abc]] \
|
||||
[file normalize [file join dir.dir dirinside.dir abc]]
|
||||
} ok
|
||||
file delete -force dir2.file
|
||||
file delete -force dir2.link
|
||||
file delete -force link.file dir.link
|
||||
file delete -force dir2
|
||||
file delete -force [file join dir.dir dirinside.link]
|
||||
removeFile [file join dir.dir inside.file]
|
||||
removeDirectory [file join dir.dir dirinside.dir]
|
||||
removeDirectory dir.dir
|
||||
test filesystem-1.30 {normalisation of nonexistent user} -body {
|
||||
file normalize ~noonewiththisname
|
||||
} -returnCodes error -result {user "noonewiththisname" doesn't exist}
|
||||
test filesystem-1.31 {link normalisation: link near filesystem root} {testsetplatform} {
|
||||
testsetplatform unix
|
||||
file normalize /foo/../bar
|
||||
} {/bar}
|
||||
test filesystem-1.32 {link normalisation: link near filesystem root} {testsetplatform} {
|
||||
testsetplatform unix
|
||||
file normalize /../bar
|
||||
} {/bar}
|
||||
test filesystem-1.33 {link normalisation: link near filesystem root} {testsetplatform} {
|
||||
testsetplatform windows
|
||||
set res [file normalize C:/../bar]
|
||||
if {[testConstraint unix]} {
|
||||
# Some unices go further in normalizing this -- not really a problem
|
||||
# since this is a Windows test.
|
||||
regexp {C:/bar$} $res res
|
||||
}
|
||||
set res
|
||||
} {C:/bar}
|
||||
if {[testConstraint testsetplatform]} {
|
||||
testsetplatform $platform
|
||||
}
|
||||
test filesystem-1.34 {file normalisation with '/./'} -body {
|
||||
file normalize /foo/bar/anc/./.tml
|
||||
} -match regexp -result {^(?:(?!/\./).)*$}
|
||||
test filesystem-1.35a {file normalisation with '/./'} -body {
|
||||
file normalize /ffo/bar/anc/./foo/.tml
|
||||
} -match regexp -result {^(?:(?!/\./).)*$}
|
||||
test filesystem-1.35b {file normalisation with '/./'} {
|
||||
llength [regexp -all foo [file normalize /ffo/bar/anc/./foo/.tml]]
|
||||
} 1
|
||||
test filesystem-1.36a {file normalisation with '/./'} -body {
|
||||
file normalize /foo/bar/anc/././asdasd/.tml
|
||||
} -match regexp -result {^(?:(?!/\./).)*$}
|
||||
test filesystem-1.36b {file normalisation with '/./'} {
|
||||
llength [regexp -all asdasd [file normalize /foo/bar/anc/././asdasd/.tml]]
|
||||
} 1
|
||||
test filesystem-1.37 {file normalisation with '/./'} -body {
|
||||
set fname "/abc/./def/./ghi/./asda/.././.././asd/x/../../../../....."
|
||||
file norm $fname
|
||||
} -match regexp -result {^(?:[^/]|/(?:[^/]|$))+$}
|
||||
test filesystem-1.38 {file normalisation with volume relative} -setup {
|
||||
set dir [pwd]
|
||||
} -constraints {win moreThanOneDrive} -body {
|
||||
set path "[string range [lindex $drives 0] 0 1]foo"
|
||||
cd [lindex $drives 1]
|
||||
file norm $path
|
||||
} -cleanup {
|
||||
cd $dir
|
||||
} -result "[lindex $drives 0]foo"
|
||||
test filesystem-1.39 {file normalisation with volume relative} -setup {
|
||||
set old [pwd]
|
||||
} -constraints {win} -body {
|
||||
set drv C:/
|
||||
cd [lindex [glob -type d -dir $drv *] 0]
|
||||
file norm [string range $drv 0 1]
|
||||
} -cleanup {
|
||||
cd $old
|
||||
} -match regexp -result {.*[^/]}
|
||||
test filesystem-1.40 {file normalisation with repeated separators} {
|
||||
testPathEqual [file norm foo////bar] [file norm foo/bar]
|
||||
} ok
|
||||
test filesystem-1.41 {file normalisation with repeated separators} {win} {
|
||||
testPathEqual [file norm foo\\\\\\bar] [file norm foo/bar]
|
||||
} ok
|
||||
test filesystem-1.42 {file normalisation .. beyond root (Bug 1379287)} {
|
||||
testPathEqual [file norm /xxx/..] [file norm /]
|
||||
} ok
|
||||
test filesystem-1.42.1 {file normalisation .. beyond root (Bug 1379287)} {
|
||||
testPathEqual [file norm /xxx/../] [file norm /]
|
||||
} ok
|
||||
test filesystem-1.43 {file normalisation .. beyond root (Bug 1379287)} {
|
||||
testPathEqual [file norm /xxx/foo/../..] [file norm /]
|
||||
} ok
|
||||
test filesystem-1.43.1 {file normalisation .. beyond root (Bug 1379287)} {
|
||||
testPathEqual [file norm /xxx/foo/../../] [file norm /]
|
||||
} ok
|
||||
test filesystem-1.44 {file normalisation .. beyond root (Bug 1379287)} {
|
||||
testPathEqual [file norm /xxx/foo/../../bar] [file norm /bar]
|
||||
} ok
|
||||
test filesystem-1.45 {file normalisation .. beyond root (Bug 1379287)} {
|
||||
testPathEqual [file norm /xxx/../../bar] [file norm /bar]
|
||||
} ok
|
||||
test filesystem-1.46 {file normalisation .. beyond root (Bug 1379287)} {
|
||||
testPathEqual [file norm /xxx/../bar] [file norm /bar]
|
||||
} ok
|
||||
test filesystem-1.47 {file normalisation .. beyond root (Bug 1379287)} {
|
||||
testPathEqual [file norm /..] [file norm /]
|
||||
} ok
|
||||
test filesystem-1.48 {file normalisation .. beyond root (Bug 1379287)} {
|
||||
testPathEqual [file norm /../] [file norm /]
|
||||
} ok
|
||||
test filesystem-1.49 {file normalisation .. beyond root (Bug 1379287)} {
|
||||
testPathEqual [file norm /.] [file norm /]
|
||||
} ok
|
||||
test filesystem-1.50 {file normalisation .. beyond root (Bug 1379287)} {
|
||||
testPathEqual [file norm /./] [file norm /]
|
||||
} ok
|
||||
test filesystem-1.51 {file normalisation .. beyond root (Bug 1379287)} {
|
||||
testPathEqual [file norm /../..] [file norm /]
|
||||
} ok
|
||||
test filesystem-1.51.1 {file normalisation .. beyond root (Bug 1379287)} {
|
||||
testPathEqual [file norm /../../] [file norm /]
|
||||
} ok
|
||||
|
||||
test filesystem-2.0 {new native path} {unix} {
|
||||
foreach f [lsort [glob -nocomplain /usr/bin/c*]] {
|
||||
catch {file readlink $f}
|
||||
}
|
||||
# If we reach here we've succeeded. We used to crash above.
|
||||
return ok
|
||||
} ok
|
||||
|
||||
# Make sure the testfilesystem hasn't been registered.
|
||||
if {[testConstraint testfilesystem]} {
|
||||
proc resetfs {} {
|
||||
while {![catch {testfilesystem 0}]} {}
|
||||
}
|
||||
}
|
||||
|
||||
test filesystem-3.1 {Tcl_FSRegister & Tcl_FSUnregister} testfilesystem {
|
||||
set result {}
|
||||
lappend result [testfilesystem 1]
|
||||
lappend result [testfilesystem 0]
|
||||
lappend result [catch {testfilesystem 0} msg] $msg
|
||||
} {registered unregistered 1 failed}
|
||||
test filesystem-3.3 {Tcl_FSRegister} testfilesystem {
|
||||
testfilesystem 1
|
||||
testfilesystem 1
|
||||
testfilesystem 0
|
||||
testfilesystem 0
|
||||
} {unregistered}
|
||||
test filesystem-3.4 {Tcl_FSRegister} -constraints testfilesystem -body {
|
||||
testfilesystem 1
|
||||
file system bar
|
||||
} -cleanup {
|
||||
testfilesystem 0
|
||||
} -result {reporting}
|
||||
test filesystem-3.5 {Tcl_FSUnregister} testfilesystem {
|
||||
resetfs
|
||||
lindex [file system bar] 0
|
||||
} {native}
|
||||
|
||||
test filesystem-4.0 {testfilesystem} -constraints testfilesystem -body {
|
||||
testfilesystem 1
|
||||
set filesystemReport {}
|
||||
file exists foo
|
||||
testfilesystem 0
|
||||
return $filesystemReport
|
||||
} -match glob -result {*{access foo}}
|
||||
test filesystem-4.1 {testfilesystem} -constraints testfilesystem -body {
|
||||
testfilesystem 1
|
||||
set filesystemReport {}
|
||||
catch {file stat foo bar}
|
||||
testfilesystem 0
|
||||
return $filesystemReport
|
||||
} -match glob -result {*{stat foo}}
|
||||
test filesystem-4.2 {testfilesystem} -constraints testfilesystem -body {
|
||||
testfilesystem 1
|
||||
set filesystemReport {}
|
||||
catch {file lstat foo bar}
|
||||
testfilesystem 0
|
||||
return $filesystemReport
|
||||
} -match glob -result {*{lstat foo}}
|
||||
test filesystem-4.3 {testfilesystem} -constraints testfilesystem -body {
|
||||
testfilesystem 1
|
||||
set filesystemReport {}
|
||||
catch {glob *}
|
||||
testfilesystem 0
|
||||
return $filesystemReport
|
||||
} -match glob -result {*{matchindirectory *}*}
|
||||
|
||||
test filesystem-5.1 {cache and ~} -constraints testfilesystem -setup {
|
||||
set orig $::env(HOME)
|
||||
} -body {
|
||||
set ::env(HOME) /foo/bar/blah
|
||||
set testdir ~
|
||||
set res1 "Parent of ~ (/foo/bar/blah) is [file dirname $testdir]"
|
||||
set ::env(HOME) /a/b/c
|
||||
set res2 "Parent of ~ (/a/b/c) is [file dirname $testdir]"
|
||||
list $res1 $res2
|
||||
} -cleanup {
|
||||
set ::env(HOME) $orig
|
||||
} -match regexp -result {{Parent of ~ \(/foo/bar/blah\) is ([a-zA-Z]:)?(/cygwin)?(/foo/bar|foo:bar)} {Parent of ~ \(/a/b/c\) is ([a-zA-Z]:)?(/cygwin)?(/a/b|a:b)}}
|
||||
|
||||
test filesystem-6.1 {empty file name} -returnCodes error -body {
|
||||
open ""
|
||||
} -result {couldn't open "": no such file or directory}
|
||||
test filesystem-6.2 {empty file name} -returnCodes error -body {
|
||||
file stat "" arr
|
||||
} -result {could not read "": no such file or directory}
|
||||
test filesystem-6.3 {empty file name} -returnCodes error -body {
|
||||
file atime ""
|
||||
} -result {could not read "": no such file or directory}
|
||||
test filesystem-6.4 {empty file name} -returnCodes error -body {
|
||||
file attributes ""
|
||||
} -result {could not read "": no such file or directory}
|
||||
test filesystem-6.5 {empty file name} -returnCodes error -body {
|
||||
file copy "" ""
|
||||
} -result {error copying "": no such file or directory}
|
||||
test filesystem-6.6 {empty file name} {file delete ""} {}
|
||||
test filesystem-6.7 {empty file name} {file dirname ""} .
|
||||
test filesystem-6.8 {empty file name} {file executable ""} 0
|
||||
test filesystem-6.9 {empty file name} {file exists ""} 0
|
||||
test filesystem-6.10 {empty file name} {file extension ""} {}
|
||||
test filesystem-6.11 {empty file name} {file isdirectory ""} 0
|
||||
test filesystem-6.12 {empty file name} {file isfile ""} 0
|
||||
test filesystem-6.13 {empty file name} {file join ""} {}
|
||||
test filesystem-6.14 {empty file name} -returnCodes error -body {
|
||||
file link ""
|
||||
} -result {could not read link "": no such file or directory}
|
||||
test filesystem-6.15 {empty file name} -returnCodes error -body {
|
||||
file lstat "" arr
|
||||
} -result {could not read "": no such file or directory}
|
||||
test filesystem-6.16 {empty file name} -returnCodes error -body {
|
||||
file mtime ""
|
||||
} -result {could not read "": no such file or directory}
|
||||
test filesystem-6.17 {empty file name} -returnCodes error -body {
|
||||
file mtime "" 0
|
||||
} -result {could not read "": no such file or directory}
|
||||
test filesystem-6.18 {empty file name} -returnCodes error -body {
|
||||
file mkdir ""
|
||||
} -result {can't create directory "": no such file or directory}
|
||||
test filesystem-6.19 {empty file name} {file nativename ""} {}
|
||||
test filesystem-6.20 {empty file name} {file normalize ""} {}
|
||||
test filesystem-6.21 {empty file name} {file owned ""} 0
|
||||
test filesystem-6.22 {empty file name} {file pathtype ""} relative
|
||||
test filesystem-6.23 {empty file name} {file readable ""} 0
|
||||
test filesystem-6.24 {empty file name} -returnCodes error -body {
|
||||
file readlink ""
|
||||
} -result {could not read link "": no such file or directory}
|
||||
test filesystem-6.25 {empty file name} -returnCodes error -body {
|
||||
file rename "" ""
|
||||
} -result {error renaming "": no such file or directory}
|
||||
test filesystem-6.26 {empty file name} {file rootname ""} {}
|
||||
test filesystem-6.27 {empty file name} -returnCodes error -body {
|
||||
file separator ""
|
||||
} -result {unrecognised path}
|
||||
test filesystem-6.28 {empty file name} -returnCodes error -body {
|
||||
file size ""
|
||||
} -result {could not read "": no such file or directory}
|
||||
test filesystem-6.29 {empty file name} {file split ""} {}
|
||||
test filesystem-6.30 {empty file name} -returnCodes error -body {
|
||||
file system ""
|
||||
} -result {unrecognised path}
|
||||
test filesystem-6.31 {empty file name} {file tail ""} {}
|
||||
test filesystem-6.32 {empty file name} -returnCodes error -body {
|
||||
file type ""
|
||||
} -result {could not read "": no such file or directory}
|
||||
test filesystem-6.33 {empty file name} {file writable ""} 0
|
||||
test filesystem-6.34 {file name with (invalid) nul character} {
|
||||
list [catch "open foo\x00" msg] $msg
|
||||
} [list 1 "couldn't open \"foo\x00\": filename is invalid on this platform"]
|
||||
|
||||
# Make sure the testfilesystem hasn't been registered.
|
||||
if {[testConstraint testfilesystem]} {
|
||||
while {![catch {testfilesystem 0}]} {}
|
||||
}
|
||||
|
||||
test filesystem-7.1.1 {load from vfs} -setup {
|
||||
set dir [pwd]
|
||||
} -constraints {win testsimplefilesystem loaddll} -body {
|
||||
# This may cause a crash on exit
|
||||
cd [file dirname $::ddelib]
|
||||
testsimplefilesystem 1
|
||||
# This loads dde via a complex copy-to-temp operation
|
||||
load simplefs:/[file tail $::ddelib] dde
|
||||
testsimplefilesystem 0
|
||||
return ok
|
||||
# The real result of this test is what happens when Tcl exits.
|
||||
} -cleanup {
|
||||
cd $dir
|
||||
} -result ok
|
||||
test filesystem-7.1.2 {load from vfs, and then unload again} -setup {
|
||||
set dir [pwd]
|
||||
} -constraints {win testsimplefilesystem loaddll} -body {
|
||||
# This may cause a crash on exit
|
||||
cd [file dirname $::reglib]
|
||||
testsimplefilesystem 1
|
||||
# This loads reg via a complex copy-to-temp operation
|
||||
load simplefs:/[file tail $::reglib] Registry
|
||||
unload simplefs:/[file tail $::reglib]
|
||||
testsimplefilesystem 0
|
||||
return ok
|
||||
# The real result of this test is what happens when Tcl exits.
|
||||
} -cleanup {
|
||||
cd $dir
|
||||
} -result ok
|
||||
test filesystem-7.2 {cross-filesystem copy from vfs maintains mtime} -setup {
|
||||
set dir [pwd]
|
||||
cd [tcltest::temporaryDirectory]
|
||||
} -constraints testsimplefilesystem -body {
|
||||
# We created this file several tests ago.
|
||||
set origtime [file mtime gorp.file]
|
||||
set res [file exists gorp.file]
|
||||
testsimplefilesystem 1
|
||||
file delete -force theCopy
|
||||
file copy simplefs:/gorp.file theCopy
|
||||
testsimplefilesystem 0
|
||||
set newtime [file mtime theCopy]
|
||||
lappend res [expr {$origtime == $newtime ? 1 : "$origtime != $newtime"}]
|
||||
} -cleanup {
|
||||
catch {file delete theCopy}
|
||||
cd $dir
|
||||
} -result {1 1}
|
||||
test filesystem-7.3 {glob in simplefs} -setup {
|
||||
set dir [pwd]
|
||||
cd [tcltest::temporaryDirectory]
|
||||
} -constraints testsimplefilesystem -body {
|
||||
file mkdir simpledir
|
||||
close [open [file join simpledir simplefile] w]
|
||||
testsimplefilesystem 1
|
||||
glob -nocomplain -dir simplefs:/simpledir *
|
||||
} -cleanup {
|
||||
catch {testsimplefilesystem 0}
|
||||
file delete -force simpledir
|
||||
cd $dir
|
||||
} -result {simplefs:/simpledir/simplefile}
|
||||
test filesystem-7.3.1 {glob in simplefs: no path/dir} -setup {
|
||||
set dir [pwd]
|
||||
cd [tcltest::temporaryDirectory]
|
||||
} -constraints testsimplefilesystem -body {
|
||||
file mkdir simpledir
|
||||
close [open [file join simpledir simplefile] w]
|
||||
testsimplefilesystem 1
|
||||
set res [glob -nocomplain simplefs:/simpledir/*]
|
||||
lappend res {*}[glob -nocomplain simplefs:/simpledir]
|
||||
} -cleanup {
|
||||
catch {testsimplefilesystem 0}
|
||||
file delete -force simpledir
|
||||
cd $dir
|
||||
} -result {simplefs:/simpledir/simplefile simplefs:/simpledir}
|
||||
test filesystem-7.3.2 {glob in simplefs: no path/dir, no subdirectory} -setup {
|
||||
set dir [pwd]
|
||||
cd [tcltest::temporaryDirectory]
|
||||
} -constraints testsimplefilesystem -body {
|
||||
file mkdir simpledir
|
||||
close [open [file join simpledir simplefile] w]
|
||||
testsimplefilesystem 1
|
||||
glob -nocomplain simplefs:/s*
|
||||
} -cleanup {
|
||||
catch {testsimplefilesystem 0}
|
||||
file delete -force simpledir
|
||||
cd $dir
|
||||
} -match glob -result ?*
|
||||
test filesystem-7.3.3 {glob in simplefs: pattern is a volume} -setup {
|
||||
set dir [pwd]
|
||||
cd [tcltest::temporaryDirectory]
|
||||
} -constraints testsimplefilesystem -body {
|
||||
file mkdir simpledir
|
||||
close [open [file join simpledir simplefile] w]
|
||||
testsimplefilesystem 1
|
||||
glob -nocomplain simplefs:/*
|
||||
} -cleanup {
|
||||
testsimplefilesystem 0
|
||||
file delete -force simpledir
|
||||
cd $dir
|
||||
} -match glob -result ?*
|
||||
test filesystem-7.4 {cross-filesystem file copy with -force} -setup {
|
||||
set dir [pwd]
|
||||
cd [tcltest::temporaryDirectory]
|
||||
set fout [open [file join simplefile] w]
|
||||
puts -nonewline $fout "1234567890"
|
||||
close $fout
|
||||
testsimplefilesystem 1
|
||||
} -constraints testsimplefilesystem -body {
|
||||
# First copy should succeed
|
||||
set res [catch {file copy simplefs:/simplefile file2} err]
|
||||
lappend res $err
|
||||
# Second copy should fail (no -force)
|
||||
lappend res [catch {file copy simplefs:/simplefile file2} err]
|
||||
lappend res $err
|
||||
# Third copy should succeed (-force)
|
||||
lappend res [catch {file copy -force simplefs:/simplefile file2} err]
|
||||
lappend res $err
|
||||
lappend res [file exists file2]
|
||||
} -cleanup {
|
||||
catch {testsimplefilesystem 0}
|
||||
file delete -force simplefile
|
||||
file delete -force file2
|
||||
cd $dir
|
||||
} -result {0 {} 1 {error copying "simplefs:/simplefile" to "file2": file already exists} 0 {} 1}
|
||||
test filesystem-7.5 {cross-filesystem file copy with -force} -setup {
|
||||
set dir [pwd]
|
||||
cd [tcltest::temporaryDirectory]
|
||||
set fout [open [file join simplefile] w]
|
||||
puts -nonewline $fout "1234567890"
|
||||
close $fout
|
||||
testsimplefilesystem 1
|
||||
} -constraints {testsimplefilesystem unix} -body {
|
||||
# First copy should succeed
|
||||
set res [catch {file copy simplefs:/simplefile file2} err]
|
||||
lappend res $err
|
||||
file attributes file2 -permissions 0000
|
||||
# Second copy should fail (no -force)
|
||||
lappend res [catch {file copy simplefs:/simplefile file2} err]
|
||||
lappend res $err
|
||||
# Third copy should succeed (-force)
|
||||
lappend res [catch {file copy -force simplefs:/simplefile file2} err]
|
||||
lappend res $err
|
||||
lappend res [file exists file2]
|
||||
} -cleanup {
|
||||
testsimplefilesystem 0
|
||||
file delete -force simplefile
|
||||
file delete -force file2
|
||||
cd $dir
|
||||
} -result {0 {} 1 {error copying "simplefs:/simplefile" to "file2": file already exists} 0 {} 1}
|
||||
test filesystem-7.6 {cross-filesystem dir copy with -force} -setup {
|
||||
set dir [pwd]
|
||||
cd [tcltest::temporaryDirectory]
|
||||
file delete -force simpledir
|
||||
file mkdir simpledir
|
||||
file mkdir dir2
|
||||
set fout [open [file join simpledir simplefile] w]
|
||||
puts -nonewline $fout "1234567890"
|
||||
close $fout
|
||||
testsimplefilesystem 1
|
||||
} -constraints testsimplefilesystem -body {
|
||||
# First copy should succeed
|
||||
set res [catch {file copy simplefs:/simpledir dir2} err]
|
||||
lappend res $err
|
||||
# Second copy should fail (no -force)
|
||||
lappend res [catch {file copy simplefs:/simpledir dir2} err]
|
||||
lappend res $err
|
||||
# Third copy should succeed (-force)
|
||||
lappend res [catch {file copy -force simplefs:/simpledir dir2} err]
|
||||
lappend res $err
|
||||
lappend res [file exists [file join dir2 simpledir]] \
|
||||
[file exists [file join dir2 simpledir simplefile]]
|
||||
} -cleanup {
|
||||
testsimplefilesystem 0
|
||||
file delete -force simpledir
|
||||
file delete -force dir2
|
||||
cd $dir
|
||||
} -result {0 {} 1 {error copying "simplefs:/simpledir" to "dir2/simpledir": file already exists} 0 {} 1 1}
|
||||
test filesystem-7.7 {cross-filesystem dir copy with -force} -setup {
|
||||
set dir [pwd]
|
||||
cd [tcltest::temporaryDirectory]
|
||||
file delete -force simpledir
|
||||
file mkdir simpledir
|
||||
file mkdir dir2
|
||||
set fout [open [file join simpledir simplefile] w]
|
||||
puts -nonewline $fout "1234567890"
|
||||
close $fout
|
||||
testsimplefilesystem 1
|
||||
} -constraints {testsimplefilesystem unix} -body {
|
||||
# First copy should succeed
|
||||
set res [catch {file copy simplefs:/simpledir dir2} err]
|
||||
lappend res $err
|
||||
# Second copy should fail (no -force)
|
||||
lappend res [catch {file copy simplefs:/simpledir dir2} err]
|
||||
lappend res $err
|
||||
# Third copy should succeed (-force)
|
||||
# I've noticed on some Unices that this only succeeds intermittently (some
|
||||
# runs work, some fail). This needs examining further.
|
||||
lappend res [catch {file copy -force simplefs:/simpledir dir2} err]
|
||||
lappend res $err
|
||||
lappend res [file exists [file join dir2 simpledir]] \
|
||||
[file exists [file join dir2 simpledir simplefile]]
|
||||
} -cleanup {
|
||||
testsimplefilesystem 0
|
||||
file delete -force simpledir
|
||||
file delete -force dir2
|
||||
cd $dir
|
||||
} -result {0 {} 1 {error copying "simplefs:/simpledir" to "dir2/simpledir": file already exists} 0 {} 1 1}
|
||||
removeFile gorp.file
|
||||
test filesystem-7.8 {vfs cd} -setup {
|
||||
set dir [pwd]
|
||||
cd [tcltest::temporaryDirectory]
|
||||
file delete -force simpledir
|
||||
file mkdir simpledir
|
||||
testsimplefilesystem 1
|
||||
} -constraints testsimplefilesystem -body {
|
||||
# This can variously cause an infinite loop or simply have no effect at
|
||||
# all (before certain bugs were fixed, of course).
|
||||
cd simplefs:/simpledir
|
||||
pwd
|
||||
} -cleanup {
|
||||
cd [tcltest::temporaryDirectory]
|
||||
testsimplefilesystem 0
|
||||
file delete -force simpledir
|
||||
cd $dir
|
||||
} -result {simplefs:/simpledir}
|
||||
|
||||
test filesystem-8.1 {relative path objects and caching of pwd} -setup {
|
||||
set dir [pwd]
|
||||
cd [tcltest::temporaryDirectory]
|
||||
} -body {
|
||||
makeDirectory abc
|
||||
makeDirectory def
|
||||
makeFile "contents" [file join abc foo]
|
||||
cd abc
|
||||
set f "foo"
|
||||
set res {}
|
||||
lappend res [file exists $f]
|
||||
lappend res [file exists $f]
|
||||
cd ..
|
||||
cd def
|
||||
# If we haven't cleared the object's cwd cache, Tcl will think it still
|
||||
# exists.
|
||||
lappend res [file exists $f]
|
||||
lappend res [file exists $f]
|
||||
} -cleanup {
|
||||
removeFile [file join abc foo]
|
||||
removeDirectory abc
|
||||
removeDirectory def
|
||||
cd $dir
|
||||
} -result {1 1 0 0}
|
||||
test filesystem-8.2 {relative path objects and use of pwd} -setup {
|
||||
set origdir [pwd]
|
||||
cd [tcltest::temporaryDirectory]
|
||||
} -body {
|
||||
set dir "abc"
|
||||
makeDirectory $dir
|
||||
makeFile "contents" [file join abc foo]
|
||||
cd $dir
|
||||
file exists [lindex [glob *] 0]
|
||||
} -cleanup {
|
||||
cd [tcltest::temporaryDirectory]
|
||||
removeFile [file join abc foo]
|
||||
removeDirectory abc
|
||||
cd $origdir
|
||||
} -result 1
|
||||
test filesystem-8.3 {path objects and empty string} {
|
||||
set anchor ""
|
||||
set dst foo
|
||||
set res $dst
|
||||
set yyy [file split $anchor]
|
||||
set dst [file join $anchor $dst]
|
||||
lappend res $dst $yyy
|
||||
} {foo foo {}}
|
||||
|
||||
proc TestFind1 {d f} {
|
||||
set r1 [file exists [file join $d $f]]
|
||||
lappend res "[file join $d $f] found: $r1"
|
||||
lappend res "is dir a dir? [file isdirectory $d]"
|
||||
set r2 [file exists [file join $d $f]]
|
||||
lappend res "[file join $d $f] found: $r2"
|
||||
return $res
|
||||
}
|
||||
proc TestFind2 {d f} {
|
||||
set r1 [file exists [file join $d $f]]
|
||||
lappend res "[file join $d $f] found: $r1"
|
||||
lappend res "is dir a dir? [file isdirectory [file join $d]]"
|
||||
set r2 [file exists [file join $d $f]]
|
||||
lappend res "[file join $d $f] found: $r2"
|
||||
return $res
|
||||
}
|
||||
|
||||
test filesystem-9.1 {path objects and join and object rep} -setup {
|
||||
set origdir [pwd]
|
||||
cd [tcltest::temporaryDirectory]
|
||||
} -body {
|
||||
file mkdir [file join a b c]
|
||||
TestFind1 a [file join b . c]
|
||||
} -cleanup {
|
||||
file delete -force a
|
||||
cd $origdir
|
||||
} -result {{a/b/./c found: 1} {is dir a dir? 1} {a/b/./c found: 1}}
|
||||
test filesystem-9.2 {path objects and join and object rep} -setup {
|
||||
set origdir [pwd]
|
||||
cd [tcltest::temporaryDirectory]
|
||||
} -body {
|
||||
file mkdir [file join a b c]
|
||||
TestFind2 a [file join b . c]
|
||||
} -cleanup {
|
||||
file delete -force a
|
||||
cd $origdir
|
||||
} -result {{a/b/./c found: 1} {is dir a dir? 1} {a/b/./c found: 1}}
|
||||
test filesystem-9.2.1 {path objects and join and object rep} -setup {
|
||||
set origdir [pwd]
|
||||
cd [tcltest::temporaryDirectory]
|
||||
} -body {
|
||||
file mkdir [file join a b c]
|
||||
TestFind2 a [file join b .]
|
||||
} -cleanup {
|
||||
file delete -force a
|
||||
cd $origdir
|
||||
} -result {{a/b/. found: 1} {is dir a dir? 1} {a/b/. found: 1}}
|
||||
test filesystem-9.3 {path objects and join and object rep} -setup {
|
||||
set origdir [pwd]
|
||||
cd [tcltest::temporaryDirectory]
|
||||
} -body {
|
||||
file mkdir [file join a b c]
|
||||
TestFind1 a [file join b .. b c]
|
||||
} -cleanup {
|
||||
file delete -force a
|
||||
cd $origdir
|
||||
} -result {{a/b/../b/c found: 1} {is dir a dir? 1} {a/b/../b/c found: 1}}
|
||||
test filesystem-9.4 {path objects and join and object rep} -setup {
|
||||
set origdir [pwd]
|
||||
cd [tcltest::temporaryDirectory]
|
||||
} -body {
|
||||
file mkdir [file join a b c]
|
||||
TestFind2 a [file join b .. b c]
|
||||
} -cleanup {
|
||||
file delete -force a
|
||||
cd $origdir
|
||||
} -result {{a/b/../b/c found: 1} {is dir a dir? 1} {a/b/../b/c found: 1}}
|
||||
test filesystem-9.5 {path objects and file tail and object rep} -setup {
|
||||
set origdir [pwd]
|
||||
cd [tcltest::temporaryDirectory]
|
||||
} -body {
|
||||
file mkdir dgp
|
||||
close [open dgp/test w]
|
||||
foreach relative [glob -nocomplain [file join * test]] {
|
||||
set absolute [file join [pwd] $relative]
|
||||
set res [list [file tail $absolute] "test"]
|
||||
}
|
||||
return $res
|
||||
} -cleanup {
|
||||
file delete -force dgp
|
||||
cd $origdir
|
||||
} -result {test test}
|
||||
test filesystem-9.6 {path objects and file tail and object rep} win {
|
||||
set res {}
|
||||
set p "C:\\toto"
|
||||
lappend res [file join $p toto]
|
||||
file isdirectory $p
|
||||
lappend res [file join $p toto]
|
||||
} {C:/toto/toto C:/toto/toto}
|
||||
test filesystem-9.7 {path objects and glob and file tail and tilde} -setup {
|
||||
set res {}
|
||||
set origdir [pwd]
|
||||
cd [tcltest::temporaryDirectory]
|
||||
} -body {
|
||||
file mkdir tilde
|
||||
close [open tilde/~testNotExist w]
|
||||
cd tilde
|
||||
set file [lindex [glob *test*] 0]
|
||||
lappend res [file exists $file] [catch {file tail $file} r] $r
|
||||
lappend res $file
|
||||
lappend res [file exists $file] [catch {file tail $file} r] $r
|
||||
lappend res [catch {file tail $file} r] $r
|
||||
} -cleanup {
|
||||
cd [tcltest::temporaryDirectory]
|
||||
file delete -force tilde
|
||||
cd $origdir
|
||||
} -result {0 1 {user "testNotExist" doesn't exist} ~testNotExist 0 1 {user "testNotExist" doesn't exist} 1 {user "testNotExist" doesn't exist}}
|
||||
test filesystem-9.8 {path objects and glob and file tail and tilde} -setup {
|
||||
set res {}
|
||||
set origdir [pwd]
|
||||
cd [tcltest::temporaryDirectory]
|
||||
} -body {
|
||||
file mkdir tilde
|
||||
close [open tilde/~testNotExist w]
|
||||
cd tilde
|
||||
set file1 [lindex [glob *test*] 0]
|
||||
set file2 "~testNotExist"
|
||||
lappend res $file1 $file2
|
||||
lappend res [catch {file tail $file1} r] $r
|
||||
lappend res [catch {file tail $file2} r] $r
|
||||
} -cleanup {
|
||||
cd [tcltest::temporaryDirectory]
|
||||
file delete -force tilde
|
||||
cd $origdir
|
||||
} -result {~testNotExist ~testNotExist 1 {user "testNotExist" doesn't exist} 1 {user "testNotExist" doesn't exist}}
|
||||
test filesystem-9.9 {path objects and glob and file tail and tilde} -setup {
|
||||
set res {}
|
||||
set origdir [pwd]
|
||||
cd [tcltest::temporaryDirectory]
|
||||
} -body {
|
||||
file mkdir tilde
|
||||
close [open tilde/~testNotExist w]
|
||||
cd tilde
|
||||
set file1 [lindex [glob *test*] 0]
|
||||
set file2 "~testNotExist"
|
||||
lappend res [catch {file exists $file1} r] $r
|
||||
lappend res [catch {file exists $file2} r] $r
|
||||
lappend res [string equal $file1 $file2]
|
||||
} -cleanup {
|
||||
cd [tcltest::temporaryDirectory]
|
||||
file delete -force tilde
|
||||
cd $origdir
|
||||
} -result {0 0 0 0 1}
|
||||
|
||||
# ----------------------------------------------------------------------
|
||||
|
||||
test filesystem-10.1 {Bug 3414754} {
|
||||
string match */ [file join [pwd] foo/]
|
||||
} 0
|
||||
|
||||
cleanupTests
|
||||
unset -nocomplain drive drives
|
||||
}
|
||||
namespace delete ::tcl::test::fileSystem
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# End:
|
||||
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
|
||||
1360
tests/for.test
Normal file
1360
tests/for.test
Normal file
File diff suppressed because it is too large
Load Diff
294
tests/foreach.test
Normal file
294
tests/foreach.test
Normal file
@@ -0,0 +1,294 @@
|
||||
# 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-9.2 {line numbers} -setup {
|
||||
proc linenumber {} {dict get [info frame -1] line}
|
||||
} -body {
|
||||
apply {n {
|
||||
foreach x y {*}{
|
||||
} {return [incr n -[linenumber]]}
|
||||
}} [linenumber]
|
||||
} -cleanup {
|
||||
rename linenumber {}
|
||||
} -result 1
|
||||
|
||||
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 {}
|
||||
|
||||
test foreach-11.1 {error then dereference loop var (dev bug)} {
|
||||
catch { foreach a 0 b {1 2 3} { error x } }
|
||||
set a
|
||||
} 0
|
||||
test foreach-11.2 {error then dereference loop var (dev bug)} {
|
||||
catch { foreach a 0 b {1 2 3} { incr a $b; error x } }
|
||||
set a
|
||||
} 1
|
||||
|
||||
# cleanup
|
||||
catch {unset a}
|
||||
catch {unset x}
|
||||
catch {rename foo {}}
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
581
tests/format.test
Normal file
581
tests/format.test
Normal file
@@ -0,0 +1,581 @@
|
||||
# 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-1.12 {integer formatting} {
|
||||
format "%b %#b %llb" 5 5 [expr {2**100}]
|
||||
} {101 0b101 10000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000}
|
||||
|
||||
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 ...?"}
|
||||
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
|
||||
|
||||
# Note that this test may fail in future versions
|
||||
test format-20.1 {Bug 2932421: plain %s caused intrep change of args} -body {
|
||||
set x [dict create a b c d]
|
||||
format %s $x
|
||||
# After this, obj in $x should be a dict with a non-NULL bytes field
|
||||
tcl::unsupported::representation $x
|
||||
} -match glob -result {value is a dict with *, string representation "*"}
|
||||
|
||||
# cleanup
|
||||
catch {unset a}
|
||||
catch {unset b}
|
||||
catch {unset c}
|
||||
catch {unset d}
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# End:
|
||||
101
tests/get.test
Normal file
101
tests/get.test
Normal file
@@ -0,0 +1,101 @@
|
||||
# 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::*
|
||||
}
|
||||
|
||||
::tcltest::loadTestedCommands
|
||||
catch [list package require -exact Tcltest [info patchlevel]]
|
||||
|
||||
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
|
||||
255
tests/history.test
Normal file
255
tests/history.test
Normal file
@@ -0,0 +1,255 @@
|
||||
# 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 clear
|
||||
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
|
||||
} {unknown or ambiguous subcommand "gorp": must be add, change, clear, event, info, keep, nextid, or redo}
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# End:
|
||||
668
tests/http.test
Normal file
668
tests/http.test
Normal file
@@ -0,0 +1,668 @@
|
||||
# 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.
|
||||
|
||||
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
|
||||
}
|
||||
|
||||
catch {package require Thread 2.7-}
|
||||
if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} {
|
||||
set httpthread [thread::create -preserved]
|
||||
thread::send $httpthread [list source $httpdFile]
|
||||
thread::send $httpthread [list set port $port]
|
||||
thread::send $httpthread [list set bindata $bindata]
|
||||
thread::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 -useragent UserAgent
|
||||
http::config
|
||||
} [list -accept */* -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -urlencoding utf-8 -useragent "UserAgent"]
|
||||
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} -returnCodes error -body {
|
||||
http::config -proxyhost {} -junk 8080
|
||||
} -result {Unknown option -junk, must be: -accept, -proxyfilter, -proxyhost, -proxyport, -urlencoding, -useragent}
|
||||
test http-1.6 {http::config} -setup {
|
||||
set oldenc [http::config -urlencoding]
|
||||
} -body {
|
||||
set enc [list [http::config -urlencoding]]
|
||||
http::config -urlencoding iso8859-1
|
||||
lappend enc [http::config -urlencoding]
|
||||
} -cleanup {
|
||||
http::config -urlencoding $oldenc
|
||||
} -result {utf-8 iso8859-1}
|
||||
|
||||
test http-2.1 {http::reset} {
|
||||
catch {http::reset http#1}
|
||||
} 0
|
||||
|
||||
test http-3.1 {http::geturl} -returnCodes error -body {
|
||||
http::geturl -bogus flag
|
||||
} -result {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} -returnCodes error -body {
|
||||
http::geturl http:junk
|
||||
} -result {Unsupported URL: http:junk}
|
||||
set url //[info hostname]:$port
|
||||
set badurl //[info hostname]:[expr $port+1]
|
||||
test http-3.3 {http::geturl} -body {
|
||||
set token [http::geturl $url]
|
||||
http::data $token
|
||||
} -cleanup {
|
||||
http::cleanup $token
|
||||
} -result "<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
|
||||
set ipv6url http://\[::1\]:$port/
|
||||
test http-3.4 {http::geturl} -body {
|
||||
set token [http::geturl $url]
|
||||
http::data $token
|
||||
} -cleanup {
|
||||
http::cleanup $token
|
||||
} -result "<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} -body {
|
||||
http::config -proxyfilter selfproxy
|
||||
set token [http::geturl $url]
|
||||
http::data $token
|
||||
} -cleanup {
|
||||
http::config -proxyfilter http::ProxyRequired
|
||||
http::cleanup $token
|
||||
} -result "<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} -body {
|
||||
http::config -proxyfilter bogus
|
||||
set token [http::geturl $url]
|
||||
http::data $token
|
||||
} -cleanup {
|
||||
http::config -proxyfilter http::ProxyRequired
|
||||
http::cleanup $token
|
||||
} -result "<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} -body {
|
||||
set token [http::geturl $url -headers {Pragma no-cache}]
|
||||
http::data $token
|
||||
} -cleanup {
|
||||
http::cleanup $token
|
||||
} -result "<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} -body {
|
||||
set token [http::geturl $url -query Name=Value&Foo=Bar -timeout 2000]
|
||||
http::data $token
|
||||
} -cleanup {
|
||||
http::cleanup $token
|
||||
} -result "<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} -body {
|
||||
set token [http::geturl $url -validate 1]
|
||||
http::code $token
|
||||
} -cleanup {
|
||||
http::cleanup $token
|
||||
} -result "HTTP/1.0 200 OK"
|
||||
test http-3.10 {http::geturl queryprogress} -setup {
|
||||
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 &
|
||||
}
|
||||
} -body {
|
||||
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]
|
||||
} -cleanup {
|
||||
http::cleanup $t
|
||||
} -result {ok 122879 {16384 32768 49152 65536 81920 98304 114688 122879} {Got 122879 bytes}}
|
||||
test http-3.11 {http::geturl querychannel with -command} -setup {
|
||||
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]
|
||||
} -body {
|
||||
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
|
||||
} -cleanup {
|
||||
removeFile outdata
|
||||
http::cleanup $t
|
||||
} -result {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} -setup {
|
||||
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]
|
||||
} -constraints {nonPortable} -body {
|
||||
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
|
||||
}
|
||||
list [http::status $t] [http::code $t]
|
||||
} -cleanup {
|
||||
removeFile outdata
|
||||
http::cleanup $t
|
||||
} -result {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" -body {
|
||||
set token [http::geturl $fullurl -validate 1]
|
||||
http::code $token
|
||||
} -cleanup {
|
||||
http::cleanup $token
|
||||
} -result "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::meta} -setup {
|
||||
unset -nocomplain m token
|
||||
} -body {
|
||||
set token [http::geturl $url -timeout 2000]
|
||||
array set m [http::meta $token]
|
||||
lsort [array names m]
|
||||
} -cleanup {
|
||||
http::cleanup $token
|
||||
unset -nocomplain m token
|
||||
} -result {Content-Length Content-Type Date}
|
||||
test http-3.26 {http::meta} -setup {
|
||||
unset -nocomplain m token
|
||||
} -body {
|
||||
set token [http::geturl $url -headers {X-Check 1} -timeout 2000]
|
||||
array set m [http::meta $token]
|
||||
lsort [array names m]
|
||||
} -cleanup {
|
||||
http::cleanup $token
|
||||
unset -nocomplain m token
|
||||
} -result {Content-Length Content-Type Date X-Check}
|
||||
test http-3.27 {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)Host .*
|
||||
User-Agent .*
|
||||
Connection close
|
||||
Content-Type {text/plain;charset=utf-8}
|
||||
Accept \*/\*
|
||||
Accept-Encoding .*
|
||||
Content-Length 5}
|
||||
test http-3.28 {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)Host .*
|
||||
User-Agent .*
|
||||
Connection close
|
||||
Content-Type {text/plain;charset=utf-8}
|
||||
Accept \*/\*
|
||||
Accept-Encoding .*
|
||||
Content-Length 5}
|
||||
test http-3.29 {http::geturl IPv6 address} -body {
|
||||
# We only want to see if the URL gets parsed correctly. This is
|
||||
# the case if http::geturl succeeds or returns a socket related
|
||||
# error. If the parsing is wrong, we'll get a parse error.
|
||||
# It'd be better to separate the URL parser from http::geturl, so
|
||||
# that it can be tested without also trying to make a connection.
|
||||
set error [catch {http::geturl $ipv6url -validate 1} token]
|
||||
if {$error && [string match "couldn't open socket: *" $token]} {
|
||||
set error 0
|
||||
}
|
||||
set error
|
||||
} -cleanup {
|
||||
catch { http::cleanup $token }
|
||||
} -result 0
|
||||
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
|
||||
# Bug c11a51c482
|
||||
test http-3.32 {http::geturl: -headers override -accept default} -body {
|
||||
set token [http::geturl $url/headers -query dummy \
|
||||
-headers [list "Accept" "text/plain,application/tcl-test-value"]]
|
||||
http::data $token
|
||||
} -cleanup {
|
||||
http::cleanup $token
|
||||
} -match regexp -result {(?n)Host .*
|
||||
User-Agent .*
|
||||
Connection close
|
||||
Accept text/plain,application/tcl-test-value
|
||||
Accept-Encoding .*
|
||||
Content-Type application/x-www-form-urlencoded
|
||||
Content-Length 5}
|
||||
|
||||
test http-4.1 {http::Event} -body {
|
||||
set token [http::geturl $url -keepalive 0]
|
||||
upvar #0 $token data
|
||||
array set meta $data(meta)
|
||||
expr {($data(totalsize) == $meta(Content-Length))}
|
||||
} -cleanup {
|
||||
http::cleanup $token
|
||||
} -result 1
|
||||
test http-4.2 {http::Event} -body {
|
||||
set token [http::geturl $url]
|
||||
upvar #0 $token data
|
||||
array set meta $data(meta)
|
||||
string compare $data(type) [string trim $meta(Content-Type)]
|
||||
} -cleanup {
|
||||
http::cleanup $token
|
||||
} -result 0
|
||||
test http-4.3 {http::Event} -body {
|
||||
set token [http::geturl $url]
|
||||
http::code $token
|
||||
} -cleanup {
|
||||
http::cleanup $token
|
||||
} -result {HTTP/1.0 200 Data follows}
|
||||
test http-4.4 {http::Event} -setup {
|
||||
set testfile [makeFile "" testfile]
|
||||
} -body {
|
||||
set out [open $testfile w]
|
||||
set token [http::geturl $url -channel $out]
|
||||
close $out
|
||||
set in [open $testfile]
|
||||
set x [read $in]
|
||||
} -cleanup {
|
||||
catch {close $in}
|
||||
catch {close $out}
|
||||
removeFile $testfile
|
||||
http::cleanup $token
|
||||
} -result "<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} -setup {
|
||||
set testfile [makeFile "" testfile]
|
||||
} -body {
|
||||
set out [open $testfile w]
|
||||
fconfigure $out -translation lf
|
||||
set token [http::geturl $url -channel $out]
|
||||
close $out
|
||||
upvar #0 $token data
|
||||
expr {$data(currentsize) == $data(totalsize)}
|
||||
} -cleanup {
|
||||
removeFile $testfile
|
||||
http::cleanup $token
|
||||
} -result 1
|
||||
test http-4.6 {http::Event} -setup {
|
||||
set testfile [makeFile "" testfile]
|
||||
} -body {
|
||||
set out [open $testfile w]
|
||||
set token [http::geturl $binurl -channel $out]
|
||||
close $out
|
||||
set in [open $testfile]
|
||||
fconfigure $in -translation binary
|
||||
read $in
|
||||
} -cleanup {
|
||||
catch {close $in}
|
||||
catch {close $out}
|
||||
removeFile $testfile
|
||||
http::cleanup $token
|
||||
} -result "$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]
|
||||
}
|
||||
test http-4.6.1 {http::Event} knownBug {
|
||||
set token [http::geturl $url -blocksize 50 -progress myProgress]
|
||||
return $progress
|
||||
} {111 111}
|
||||
test http-4.7 {http::Event} -body {
|
||||
set token [http::geturl $url -keepalive 0 -progress myProgress]
|
||||
return $progress
|
||||
} -cleanup {
|
||||
http::cleanup $token
|
||||
} -result {111 111}
|
||||
test http-4.8 {http::Event} -body {
|
||||
set token [http::geturl $url]
|
||||
http::status $token
|
||||
} -cleanup {
|
||||
http::cleanup $token
|
||||
} -result {ok}
|
||||
test http-4.9 {http::Event} -body {
|
||||
set token [http::geturl $url -progress myProgress]
|
||||
http::code $token
|
||||
} -cleanup {
|
||||
http::cleanup $token
|
||||
} -result {HTTP/1.0 200 Data follows}
|
||||
test http-4.10 {http::Event} -body {
|
||||
set token [http::geturl $url -progress myProgress]
|
||||
http::size $token
|
||||
} -cleanup {
|
||||
http::cleanup $token
|
||||
} -result {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} -body {
|
||||
set token [http::geturl $url -timeout 1 -keepalive 0 -command \#]
|
||||
http::reset $token
|
||||
http::status $token
|
||||
} -cleanup {
|
||||
http::cleanup $token
|
||||
} -result {reset}
|
||||
# Longer timeout with reset.
|
||||
test http-4.12 {http::Event} -body {
|
||||
set token [http::geturl $url/?timeout=10 -keepalive 0 -command \#]
|
||||
http::reset $token
|
||||
http::status $token
|
||||
} -cleanup {
|
||||
http::cleanup $token
|
||||
} -result {reset}
|
||||
# Medium timeout to working server that waits even longer. The timeout
|
||||
# hits while waiting for a reply.
|
||||
test http-4.13 {http::Event} -body {
|
||||
set token [http::geturl $url?timeout=30 -keepalive 0 -timeout 10 -command \#]
|
||||
http::wait $token
|
||||
http::status $token
|
||||
} -cleanup {
|
||||
http::cleanup $token
|
||||
} -result {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
|
||||
} -cleanup {
|
||||
catch {http::cleanup $token}
|
||||
} -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.
|
||||
} -cleanup {
|
||||
catch {http::cleanup $token}
|
||||
} -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} -body {
|
||||
http::config -proxyhost [info hostname] -proxyport $port
|
||||
set token [http::geturl $url]
|
||||
http::wait $token
|
||||
upvar #0 $token data
|
||||
set data(body)
|
||||
} -cleanup {
|
||||
http::config -proxyhost {} -proxyport {}
|
||||
http::cleanup $token
|
||||
} -result "<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} -setup {
|
||||
set enc [http::config -urlencoding]
|
||||
} -returnCodes error -body {
|
||||
# this would be reverting to http <=2.4 behavior
|
||||
http::config -urlencoding ""
|
||||
http::mapReply "\u2208"
|
||||
} -cleanup {
|
||||
http::config -urlencoding $enc
|
||||
} -result "can't read \"formMap(\u2208)\": no such element in array"
|
||||
test http-7.4 {http::formatQuery} -setup {
|
||||
set enc [http::config -urlencoding]
|
||||
} -body {
|
||||
# this would be reverting to http <=2.4 behavior w/o errors
|
||||
# (unknown chars become '?')
|
||||
http::config -urlencoding "iso8859-1"
|
||||
http::mapReply "\u2208"
|
||||
} -cleanup {
|
||||
http::config -urlencoding $enc
|
||||
} -result {%3F}
|
||||
|
||||
# cleanup
|
||||
catch {unset url}
|
||||
catch {unset badurl}
|
||||
catch {unset port}
|
||||
catch {unset data}
|
||||
if {[info exists httpthread]} {
|
||||
thread::release $httpthread
|
||||
} else {
|
||||
close $listen
|
||||
}
|
||||
|
||||
if {[info exists removeHttpd]} {
|
||||
removeFile $httpdFile
|
||||
}
|
||||
|
||||
rename bgerror {}
|
||||
::tcltest::cleanupTests
|
||||
|
||||
# Local variables:
|
||||
# mode: tcl
|
||||
# End:
|
||||
675
tests/http11.test
Normal file
675
tests/http11.test
Normal file
@@ -0,0 +1,675 @@
|
||||
# http11.test -- -*- tcl-*-
|
||||
#
|
||||
# Test HTTP/1.1 features.
|
||||
#
|
||||
# Copyright (C) 2009 Pat Thoyts <patthoyts@users.sourceforge.net>
|
||||
#
|
||||
# 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::*
|
||||
|
||||
package require http 2.8
|
||||
|
||||
# start the server
|
||||
variable httpd_output
|
||||
proc create_httpd {} {
|
||||
proc httpd_read {chan} {
|
||||
variable httpd_output
|
||||
if {[gets $chan line] != -1} {
|
||||
#puts stderr "read '$line'"
|
||||
set httpd_output $line
|
||||
}
|
||||
if {[eof $chan]} {
|
||||
puts stderr "eof from httpd"
|
||||
fileevent $chan readable {}
|
||||
close $chan
|
||||
}
|
||||
}
|
||||
variable httpd_output
|
||||
set httpd_script [file join [pwd] [file dirname [info script]] httpd11.tcl]
|
||||
set httpd [open "|[list [interpreter] -encoding utf-8 $httpd_script]" r+]
|
||||
fconfigure $httpd -buffering line -blocking 0
|
||||
fileevent $httpd readable [list httpd_read $httpd]
|
||||
vwait httpd_output
|
||||
variable httpd_port [lindex $httpd_output 2]
|
||||
return $httpd
|
||||
}
|
||||
|
||||
proc halt_httpd {} {
|
||||
variable httpd_output
|
||||
variable httpd
|
||||
if {[info exists httpd]} {
|
||||
puts $httpd "quit"
|
||||
vwait httpd_output
|
||||
close $httpd
|
||||
}
|
||||
unset -nocomplain httpd_output httpd
|
||||
}
|
||||
|
||||
proc meta {tok {key ""}} {
|
||||
set meta [http::meta $tok]
|
||||
if {$key ne ""} {
|
||||
if {[dict exists $meta $key]} {
|
||||
return [dict get $meta $key]
|
||||
} else {
|
||||
return ""
|
||||
}
|
||||
}
|
||||
return $meta
|
||||
}
|
||||
|
||||
proc check_crc {tok args} {
|
||||
set crc [meta $tok x-crc32]
|
||||
set data [expr {[llength $args] ? [lindex $args 0] : [http::data $tok]}]
|
||||
set chk [format %x [zlib crc32 $data]]
|
||||
if {$crc ne $chk} {
|
||||
return "crc32 mismatch: $crc ne $chk"
|
||||
}
|
||||
return "ok"
|
||||
}
|
||||
|
||||
makeFile "<html><head><title>test</title></head><body><p>this is a test</p>\n[string repeat {<p>This is a tcl test file.</p>} 4192]\n</body></html>" testdoc.html
|
||||
|
||||
# -------------------------------------------------------------------------
|
||||
|
||||
test http11-1.0 "normal request for document " -setup {
|
||||
variable httpd [create_httpd]
|
||||
} -body {
|
||||
set tok [http::geturl http://localhost:$httpd_port/testdoc.html -timeout 10000]
|
||||
http::wait $tok
|
||||
list [http::status $tok] [http::code $tok] [check_crc $tok] [meta $tok connection]
|
||||
} -cleanup {
|
||||
http::cleanup $tok
|
||||
halt_httpd
|
||||
} -result {ok {HTTP/1.1 200 OK} ok close}
|
||||
|
||||
test http11-1.1 "normal,gzip,non-chunked" -setup {
|
||||
variable httpd [create_httpd]
|
||||
} -body {
|
||||
set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
|
||||
-timeout 10000 -headers {accept-encoding gzip}]
|
||||
http::wait $tok
|
||||
list [http::status $tok] [http::code $tok] [check_crc $tok] \
|
||||
[meta $tok content-encoding] [meta $tok transfer-encoding]
|
||||
} -cleanup {
|
||||
http::cleanup $tok
|
||||
halt_httpd
|
||||
} -result {ok {HTTP/1.1 200 OK} ok gzip {}}
|
||||
|
||||
test http11-1.2 "normal,deflated,non-chunked" -setup {
|
||||
variable httpd [create_httpd]
|
||||
} -body {
|
||||
set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
|
||||
-timeout 10000 -headers {accept-encoding deflate}]
|
||||
http::wait $tok
|
||||
list [http::status $tok] [http::code $tok] [check_crc $tok] \
|
||||
[meta $tok content-encoding] [meta $tok transfer-encoding]
|
||||
} -cleanup {
|
||||
http::cleanup $tok
|
||||
halt_httpd
|
||||
} -result {ok {HTTP/1.1 200 OK} ok deflate {}}
|
||||
|
||||
test http11-1.3 "normal,compressed,non-chunked" -setup {
|
||||
variable httpd [create_httpd]
|
||||
} -body {
|
||||
set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
|
||||
-timeout 10000 -headers {accept-encoding compress}]
|
||||
http::wait $tok
|
||||
list [http::status $tok] [http::code $tok] [check_crc $tok] \
|
||||
[meta $tok content-encoding] [meta $tok transfer-encoding]
|
||||
} -cleanup {
|
||||
http::cleanup $tok
|
||||
halt_httpd
|
||||
} -result {ok {HTTP/1.1 200 OK} ok compress {}}
|
||||
|
||||
test http11-1.4 "normal,identity,non-chunked" -setup {
|
||||
variable httpd [create_httpd]
|
||||
} -body {
|
||||
set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
|
||||
-timeout 10000 -headers {accept-encoding identity}]
|
||||
http::wait $tok
|
||||
list [http::status $tok] [http::code $tok] [check_crc $tok] \
|
||||
[meta $tok content-encoding] [meta $tok transfer-encoding]
|
||||
} -cleanup {
|
||||
http::cleanup $tok
|
||||
halt_httpd
|
||||
} -result {ok {HTTP/1.1 200 OK} ok {} {}}
|
||||
|
||||
test http11-1.5 "normal request for document, unsupported coding" -setup {
|
||||
variable httpd [create_httpd]
|
||||
} -body {
|
||||
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
|
||||
-timeout 10000 -headers {accept-encoding unsupported}]
|
||||
http::wait $tok
|
||||
list [http::status $tok] [http::code $tok] [check_crc $tok] \
|
||||
[meta $tok content-encoding]
|
||||
} -cleanup {
|
||||
http::cleanup $tok
|
||||
halt_httpd
|
||||
} -result {ok {HTTP/1.1 200 OK} ok {}}
|
||||
|
||||
test http11-1.6 "normal, specify 1.1 " -setup {
|
||||
variable httpd [create_httpd]
|
||||
} -body {
|
||||
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
|
||||
-protocol 1.1 -timeout 10000]
|
||||
http::wait $tok
|
||||
list [http::status $tok] [http::code $tok] [check_crc $tok] \
|
||||
[meta $tok connection] [meta $tok transfer-encoding]
|
||||
} -cleanup {
|
||||
http::cleanup $tok
|
||||
halt_httpd
|
||||
} -result {ok {HTTP/1.1 200 OK} ok close chunked}
|
||||
|
||||
test http11-1.7 "normal, 1.1 and keepalive " -setup {
|
||||
variable httpd [create_httpd]
|
||||
} -body {
|
||||
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
|
||||
-protocol 1.1 -keepalive 1 -timeout 10000]
|
||||
http::wait $tok
|
||||
list [http::status $tok] [http::code $tok] [check_crc $tok] \
|
||||
[meta $tok connection] [meta $tok transfer-encoding]
|
||||
} -cleanup {
|
||||
http::cleanup $tok
|
||||
halt_httpd
|
||||
} -result {ok {HTTP/1.1 200 OK} ok {} chunked}
|
||||
|
||||
test http11-1.8 "normal, 1.1 and keepalive, server close" -setup {
|
||||
variable httpd [create_httpd]
|
||||
} -body {
|
||||
set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
|
||||
-protocol 1.1 -keepalive 1 -timeout 10000]
|
||||
http::wait $tok
|
||||
list [http::status $tok] [http::code $tok] [check_crc $tok] \
|
||||
[meta $tok connection] [meta $tok transfer-encoding]
|
||||
} -cleanup {
|
||||
http::cleanup $tok
|
||||
halt_httpd
|
||||
} -result {ok {HTTP/1.1 200 OK} ok close {}}
|
||||
|
||||
test http11-1.9 "normal,gzip,chunked" -setup {
|
||||
variable httpd [create_httpd]
|
||||
} -body {
|
||||
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
|
||||
-timeout 10000 -headers {accept-encoding gzip}]
|
||||
http::wait $tok
|
||||
list [http::status $tok] [http::code $tok] [check_crc $tok] \
|
||||
[meta $tok content-encoding] [meta $tok transfer-encoding]
|
||||
} -cleanup {
|
||||
http::cleanup $tok
|
||||
halt_httpd
|
||||
} -result {ok {HTTP/1.1 200 OK} ok gzip chunked}
|
||||
|
||||
test http11-1.10 "normal,deflate,chunked" -setup {
|
||||
variable httpd [create_httpd]
|
||||
} -body {
|
||||
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
|
||||
-timeout 10000 -headers {accept-encoding deflate}]
|
||||
http::wait $tok
|
||||
list [http::status $tok] [http::code $tok] [check_crc $tok] \
|
||||
[meta $tok content-encoding] [meta $tok transfer-encoding]
|
||||
} -cleanup {
|
||||
http::cleanup $tok
|
||||
halt_httpd
|
||||
} -result {ok {HTTP/1.1 200 OK} ok deflate chunked}
|
||||
|
||||
test http11-1.11 "normal,compress,chunked" -setup {
|
||||
variable httpd [create_httpd]
|
||||
} -body {
|
||||
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
|
||||
-timeout 10000 -headers {accept-encoding compress}]
|
||||
http::wait $tok
|
||||
list [http::status $tok] [http::code $tok] [check_crc $tok] \
|
||||
[meta $tok content-encoding] [meta $tok transfer-encoding]
|
||||
} -cleanup {
|
||||
http::cleanup $tok
|
||||
halt_httpd
|
||||
} -result {ok {HTTP/1.1 200 OK} ok compress chunked}
|
||||
|
||||
test http11-1.12 "normal,identity,chunked" -setup {
|
||||
variable httpd [create_httpd]
|
||||
} -body {
|
||||
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
|
||||
-timeout 10000 -headers {accept-encoding identity}]
|
||||
http::wait $tok
|
||||
list [http::status $tok] [http::code $tok] [check_crc $tok] \
|
||||
[meta $tok content-encoding] [meta $tok transfer-encoding]
|
||||
} -cleanup {
|
||||
http::cleanup $tok
|
||||
halt_httpd
|
||||
} -result {ok {HTTP/1.1 200 OK} ok {} chunked}
|
||||
|
||||
# -------------------------------------------------------------------------
|
||||
|
||||
test http11-2.0 "-channel" -setup {
|
||||
variable httpd [create_httpd]
|
||||
set chan [open [makeFile {} testfile.tmp] wb+]
|
||||
} -body {
|
||||
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
|
||||
-timeout 5000 -channel $chan]
|
||||
http::wait $tok
|
||||
seek $chan 0
|
||||
set data [read $chan]
|
||||
list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
|
||||
[meta $tok connection] [meta $tok transfer-encoding]
|
||||
} -cleanup {
|
||||
http::cleanup $tok
|
||||
close $chan
|
||||
removeFile testfile.tmp
|
||||
halt_httpd
|
||||
} -result {ok {HTTP/1.1 200 OK} ok close chunked}
|
||||
|
||||
test http11-2.1 "-channel, encoding gzip" -setup {
|
||||
variable httpd [create_httpd]
|
||||
set chan [open [makeFile {} testfile.tmp] wb+]
|
||||
} -body {
|
||||
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
|
||||
-timeout 5000 -channel $chan -headers {accept-encoding gzip}]
|
||||
http::wait $tok
|
||||
seek $chan 0
|
||||
set data [read $chan]
|
||||
list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
|
||||
[meta $tok connection] [meta $tok content-encoding]\
|
||||
[meta $tok transfer-encoding]
|
||||
} -cleanup {
|
||||
http::cleanup $tok
|
||||
close $chan
|
||||
removeFile testfile.tmp
|
||||
halt_httpd
|
||||
} -result {ok {HTTP/1.1 200 OK} ok close gzip chunked}
|
||||
|
||||
test http11-2.2 "-channel, encoding deflate" -setup {
|
||||
variable httpd [create_httpd]
|
||||
set chan [open [makeFile {} testfile.tmp] wb+]
|
||||
} -body {
|
||||
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
|
||||
-timeout 5000 -channel $chan -headers {accept-encoding deflate}]
|
||||
http::wait $tok
|
||||
seek $chan 0
|
||||
set data [read $chan]
|
||||
list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
|
||||
[meta $tok connection] [meta $tok content-encoding]\
|
||||
[meta $tok transfer-encoding]
|
||||
} -cleanup {
|
||||
http::cleanup $tok
|
||||
close $chan
|
||||
removeFile testfile.tmp
|
||||
halt_httpd
|
||||
} -result {ok {HTTP/1.1 200 OK} ok close deflate chunked}
|
||||
|
||||
test http11-2.3 "-channel,encoding compress" -setup {
|
||||
variable httpd [create_httpd]
|
||||
set chan [open [makeFile {} testfile.tmp] wb+]
|
||||
} -body {
|
||||
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
|
||||
-timeout 5000 -channel $chan \
|
||||
-headers {accept-encoding compress}]
|
||||
http::wait $tok
|
||||
seek $chan 0
|
||||
set data [read $chan]
|
||||
list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
|
||||
[meta $tok connection] [meta $tok content-encoding]\
|
||||
[meta $tok transfer-encoding]
|
||||
} -cleanup {
|
||||
http::cleanup $tok
|
||||
close $chan
|
||||
removeFile testfile.tmp
|
||||
halt_httpd
|
||||
} -result {ok {HTTP/1.1 200 OK} ok close compress chunked}
|
||||
|
||||
test http11-2.4 "-channel,encoding identity" -setup {
|
||||
variable httpd [create_httpd]
|
||||
set chan [open [makeFile {} testfile.tmp] wb+]
|
||||
} -body {
|
||||
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
|
||||
-timeout 5000 -channel $chan \
|
||||
-headers {accept-encoding identity}]
|
||||
http::wait $tok
|
||||
seek $chan 0
|
||||
set data [read $chan]
|
||||
list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
|
||||
[meta $tok connection] [meta $tok content-encoding]\
|
||||
[meta $tok transfer-encoding]
|
||||
} -cleanup {
|
||||
http::cleanup $tok
|
||||
close $chan
|
||||
removeFile testfile.tmp
|
||||
halt_httpd
|
||||
} -result {ok {HTTP/1.1 200 OK} ok close {} chunked}
|
||||
|
||||
test http11-2.5 "-channel,encoding unsupported" -setup {
|
||||
variable httpd [create_httpd]
|
||||
set chan [open [makeFile {} testfile.tmp] wb+]
|
||||
} -body {
|
||||
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
|
||||
-timeout 5000 -channel $chan \
|
||||
-headers {accept-encoding unsupported}]
|
||||
http::wait $tok
|
||||
seek $chan 0
|
||||
set data [read $chan]
|
||||
list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
|
||||
[meta $tok connection] [meta $tok content-encoding]\
|
||||
[meta $tok transfer-encoding]
|
||||
} -cleanup {
|
||||
http::cleanup $tok
|
||||
close $chan
|
||||
removeFile testfile.tmp
|
||||
halt_httpd
|
||||
} -result {ok {HTTP/1.1 200 OK} ok close {} chunked}
|
||||
|
||||
test http11-2.6 "-channel,encoding gzip,non-chunked" -setup {
|
||||
variable httpd [create_httpd]
|
||||
set chan [open [makeFile {} testfile.tmp] wb+]
|
||||
} -body {
|
||||
set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
|
||||
-timeout 5000 -channel $chan -headers {accept-encoding gzip}]
|
||||
http::wait $tok
|
||||
seek $chan 0
|
||||
set data [read $chan]
|
||||
list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
|
||||
[meta $tok connection] [meta $tok content-encoding]\
|
||||
[meta $tok transfer-encoding]\
|
||||
[expr {[file size testdoc.html]-[file size testfile.tmp]}]
|
||||
} -cleanup {
|
||||
http::cleanup $tok
|
||||
close $chan
|
||||
removeFile testfile.tmp
|
||||
halt_httpd
|
||||
} -result {ok {HTTP/1.1 200 OK} ok close gzip {} 0}
|
||||
|
||||
test http11-2.7 "-channel,encoding deflate,non-chunked" -setup {
|
||||
variable httpd [create_httpd]
|
||||
set chan [open [makeFile {} testfile.tmp] wb+]
|
||||
} -body {
|
||||
set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
|
||||
-timeout 5000 -channel $chan -headers {accept-encoding deflate}]
|
||||
http::wait $tok
|
||||
seek $chan 0
|
||||
set data [read $chan]
|
||||
list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
|
||||
[meta $tok connection] [meta $tok content-encoding]\
|
||||
[meta $tok transfer-encoding]\
|
||||
[expr {[file size testdoc.html]-[file size testfile.tmp]}]
|
||||
} -cleanup {
|
||||
http::cleanup $tok
|
||||
close $chan
|
||||
removeFile testfile.tmp
|
||||
halt_httpd
|
||||
} -result {ok {HTTP/1.1 200 OK} ok close deflate {} 0}
|
||||
|
||||
test http11-2.8 "-channel,encoding compress,non-chunked" -setup {
|
||||
variable httpd [create_httpd]
|
||||
set chan [open [makeFile {} testfile.tmp] wb+]
|
||||
} -body {
|
||||
set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
|
||||
-timeout 5000 -channel $chan -headers {accept-encoding compress}]
|
||||
http::wait $tok
|
||||
seek $chan 0
|
||||
set data [read $chan]
|
||||
list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
|
||||
[meta $tok connection] [meta $tok content-encoding]\
|
||||
[meta $tok transfer-encoding]\
|
||||
[expr {[file size testdoc.html]-[file size testfile.tmp]}]
|
||||
} -cleanup {
|
||||
http::cleanup $tok
|
||||
close $chan
|
||||
removeFile testfile.tmp
|
||||
halt_httpd
|
||||
} -result {ok {HTTP/1.1 200 OK} ok close compress {} 0}
|
||||
|
||||
test http11-2.9 "-channel,encoding identity,non-chunked" -setup {
|
||||
variable httpd [create_httpd]
|
||||
set chan [open [makeFile {} testfile.tmp] wb+]
|
||||
} -body {
|
||||
set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
|
||||
-timeout 5000 -channel $chan -headers {accept-encoding identity}]
|
||||
http::wait $tok
|
||||
seek $chan 0
|
||||
set data [read $chan]
|
||||
list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
|
||||
[meta $tok connection] [meta $tok content-encoding]\
|
||||
[meta $tok transfer-encoding]\
|
||||
[expr {[file size testdoc.html]-[file size testfile.tmp]}]
|
||||
} -cleanup {
|
||||
http::cleanup $tok
|
||||
close $chan
|
||||
removeFile testfile.tmp
|
||||
halt_httpd
|
||||
} -result {ok {HTTP/1.1 200 OK} ok close {} {} 0}
|
||||
|
||||
test http11-2.10 "-channel,deflate,keepalive" -setup {
|
||||
variable httpd [create_httpd]
|
||||
set chan [open [makeFile {} testfile.tmp] wb+]
|
||||
} -body {
|
||||
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
|
||||
-timeout 5000 -channel $chan -keepalive 1 \
|
||||
-headers {accept-encoding deflate}]
|
||||
http::wait $tok
|
||||
seek $chan 0
|
||||
set data [read $chan]
|
||||
list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
|
||||
[meta $tok connection] [meta $tok content-encoding]\
|
||||
[meta $tok transfer-encoding]\
|
||||
[expr {[file size testdoc.html]-[file size testfile.tmp]}]
|
||||
} -cleanup {
|
||||
http::cleanup $tok
|
||||
close $chan
|
||||
removeFile testfile.tmp
|
||||
halt_httpd
|
||||
} -result {ok {HTTP/1.1 200 OK} ok {} deflate chunked 0}
|
||||
|
||||
test http11-2.11 "-channel,identity,keepalive" -setup {
|
||||
variable httpd [create_httpd]
|
||||
set chan [open [makeFile {} testfile.tmp] wb+]
|
||||
} -body {
|
||||
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
|
||||
-headers {accept-encoding identity} \
|
||||
-timeout 5000 -channel $chan -keepalive 1]
|
||||
http::wait $tok
|
||||
seek $chan 0
|
||||
set data [read $chan]
|
||||
list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
|
||||
[meta $tok connection] [meta $tok content-encoding]\
|
||||
[meta $tok transfer-encoding]
|
||||
} -cleanup {
|
||||
http::cleanup $tok
|
||||
close $chan
|
||||
removeFile testfile.tmp
|
||||
halt_httpd
|
||||
} -result {ok {HTTP/1.1 200 OK} ok {} {} chunked}
|
||||
|
||||
test http11-2.12 "-channel,negotiate,keepalive" -setup {
|
||||
variable httpd [create_httpd]
|
||||
set chan [open [makeFile {} testfile.tmp] wb+]
|
||||
} -body {
|
||||
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
|
||||
-timeout 5000 -channel $chan -keepalive 1]
|
||||
http::wait $tok
|
||||
seek $chan 0
|
||||
set data [read $chan]
|
||||
list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
|
||||
[meta $tok connection] [meta $tok content-encoding]\
|
||||
[meta $tok transfer-encoding] [meta $tok x-requested-encodings]\
|
||||
[expr {[file size testdoc.html]-[file size testfile.tmp]}]
|
||||
} -cleanup {
|
||||
http::cleanup $tok
|
||||
close $chan
|
||||
removeFile testfile.tmp
|
||||
halt_httpd
|
||||
} -result {ok {HTTP/1.1 200 OK} ok {} gzip chunked gzip,deflate,compress 0}
|
||||
|
||||
|
||||
# -------------------------------------------------------------------------
|
||||
#
|
||||
# The following tests for the -handler option will require changes in
|
||||
# the future. At the moment we cannot handler chunked data with this
|
||||
# option. Therefore we currently force HTTP/1.0 protocol version.
|
||||
#
|
||||
# Once this is solved, these tests should be fixed to assume chunked
|
||||
# returns in 3.2 and 3.3 and HTTP/1.1 in all but test 3.1
|
||||
|
||||
proc handler {var sock token} {
|
||||
upvar #0 $var data
|
||||
set chunk [read $sock]
|
||||
append data $chunk
|
||||
#::http::Log "handler read [string length $chunk] ([chan configure $sock -buffersize])"
|
||||
if {[eof $sock]} {
|
||||
#::http::Log "handler eof $sock"
|
||||
chan event $sock readable {}
|
||||
}
|
||||
}
|
||||
|
||||
test http11-3.0 "-handler,close,identity" -setup {
|
||||
variable httpd [create_httpd]
|
||||
set testdata ""
|
||||
} -body {
|
||||
set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
|
||||
-timeout 10000 -handler [namespace code [list handler testdata]]]
|
||||
http::wait $tok
|
||||
list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\
|
||||
[meta $tok connection] [meta $tok content-encoding] \
|
||||
[meta $tok transfer-encoding] \
|
||||
[expr {[file size testdoc.html]-[string length $testdata]}]
|
||||
} -cleanup {
|
||||
http::cleanup $tok
|
||||
unset -nocomplain testdata
|
||||
halt_httpd
|
||||
} -result {ok {HTTP/1.0 200 OK} ok close {} {} 0}
|
||||
|
||||
test http11-3.1 "-handler,protocol1.0" -setup {
|
||||
variable httpd [create_httpd]
|
||||
set testdata ""
|
||||
} -body {
|
||||
set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
|
||||
-timeout 10000 -protocol 1.0 \
|
||||
-handler [namespace code [list handler testdata]]]
|
||||
http::wait $tok
|
||||
list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\
|
||||
[meta $tok connection] [meta $tok content-encoding] \
|
||||
[meta $tok transfer-encoding] \
|
||||
[expr {[file size testdoc.html]-[string length $testdata]}]
|
||||
} -cleanup {
|
||||
http::cleanup $tok
|
||||
unset -nocomplain testdata
|
||||
halt_httpd
|
||||
} -result {ok {HTTP/1.0 200 OK} ok close {} {} 0}
|
||||
|
||||
test http11-3.2 "-handler,close,chunked" -setup {
|
||||
variable httpd [create_httpd]
|
||||
set testdata ""
|
||||
} -body {
|
||||
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
|
||||
-timeout 10000 -keepalive 0 -binary 1\
|
||||
-handler [namespace code [list handler testdata]]]
|
||||
http::wait $tok
|
||||
list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\
|
||||
[meta $tok connection] [meta $tok content-encoding] \
|
||||
[meta $tok transfer-encoding] \
|
||||
[expr {[file size testdoc.html]-[string length $testdata]}]
|
||||
} -cleanup {
|
||||
http::cleanup $tok
|
||||
unset -nocomplain testdata
|
||||
halt_httpd
|
||||
} -result {ok {HTTP/1.0 200 OK} ok close {} {} 0}
|
||||
|
||||
test http11-3.3 "-handler,keepalive,chunked" -setup {
|
||||
variable httpd [create_httpd]
|
||||
set testdata ""
|
||||
} -body {
|
||||
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
|
||||
-timeout 10000 -keepalive 1 -binary 1\
|
||||
-handler [namespace code [list handler testdata]]]
|
||||
http::wait $tok
|
||||
list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\
|
||||
[meta $tok connection] [meta $tok content-encoding] \
|
||||
[meta $tok transfer-encoding] \
|
||||
[expr {[file size testdoc.html]-[string length $testdata]}]
|
||||
} -cleanup {
|
||||
http::cleanup $tok
|
||||
unset -nocomplain testdata
|
||||
halt_httpd
|
||||
} -result {ok {HTTP/1.0 200 OK} ok close {} {} 0}
|
||||
|
||||
test http11-4.0 "normal post request" -setup {
|
||||
variable httpd [create_httpd]
|
||||
} -body {
|
||||
set query [http::formatQuery q 1 z 2]
|
||||
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
|
||||
-query $query -timeout 10000]
|
||||
http::wait $tok
|
||||
list status [http::status $tok] code [http::code $tok]\
|
||||
crc [check_crc $tok]\
|
||||
connection [meta $tok connection]\
|
||||
query-length [meta $tok x-query-length]
|
||||
} -cleanup {
|
||||
http::cleanup $tok
|
||||
halt_httpd
|
||||
} -result {status ok code {HTTP/1.1 200 OK} crc ok connection close query-length 7}
|
||||
|
||||
test http11-4.1 "normal post request, check query length" -setup {
|
||||
variable httpd [create_httpd]
|
||||
} -body {
|
||||
set query [http::formatQuery q 1 z 2]
|
||||
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
|
||||
-headers [list x-check-query yes] \
|
||||
-query $query -timeout 10000]
|
||||
http::wait $tok
|
||||
list status [http::status $tok] code [http::code $tok]\
|
||||
crc [check_crc $tok]\
|
||||
connection [meta $tok connection]\
|
||||
query-length [meta $tok x-query-length]
|
||||
} -cleanup {
|
||||
http::cleanup $tok
|
||||
halt_httpd
|
||||
} -result {status ok code {HTTP/1.1 200 OK} crc ok connection close query-length 7}
|
||||
|
||||
test http11-4.2 "normal post request, check long query length" -setup {
|
||||
variable httpd [create_httpd]
|
||||
} -body {
|
||||
set query [string repeat a 24576]
|
||||
set tok [http::geturl http://localhost:$httpd_port/testdoc.html\
|
||||
-headers [list x-check-query yes]\
|
||||
-query $query -timeout 10000]
|
||||
http::wait $tok
|
||||
list status [http::status $tok] code [http::code $tok]\
|
||||
crc [check_crc $tok]\
|
||||
connection [meta $tok connection]\
|
||||
query-length [meta $tok x-query-length]
|
||||
} -cleanup {
|
||||
http::cleanup $tok
|
||||
halt_httpd
|
||||
} -result {status ok code {HTTP/1.1 200 OK} crc ok connection close query-length 24576}
|
||||
|
||||
test http11-4.3 "normal post request, check channel query length" -setup {
|
||||
variable httpd [create_httpd]
|
||||
set chan [open [makeFile {} testfile.tmp] wb+]
|
||||
puts -nonewline $chan [string repeat [encoding convertto utf-8 "This is a test\n"] 8192]
|
||||
flush $chan
|
||||
seek $chan 0
|
||||
} -body {
|
||||
set tok [http::geturl http://localhost:$httpd_port/testdoc.html\
|
||||
-headers [list x-check-query yes]\
|
||||
-querychannel $chan -timeout 10000]
|
||||
http::wait $tok
|
||||
list status [http::status $tok] code [http::code $tok]\
|
||||
crc [check_crc $tok]\
|
||||
connection [meta $tok connection]\
|
||||
query-length [meta $tok x-query-length]
|
||||
} -cleanup {
|
||||
http::cleanup $tok
|
||||
close $chan
|
||||
removeFile testfile.tmp
|
||||
halt_httpd
|
||||
} -result {status ok code {HTTP/1.1 200 OK} crc ok connection close query-length 122880}
|
||||
|
||||
# -------------------------------------------------------------------------
|
||||
|
||||
foreach p {create_httpd httpd_read halt_httpd meta check_crc} {
|
||||
if {[llength [info proc $p]]} {rename $p {}}
|
||||
}
|
||||
removeFile testdoc.html
|
||||
unset -nocomplain httpd_port httpd p
|
||||
|
||||
::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
|
||||
}
|
||||
255
tests/httpd11.tcl
Normal file
255
tests/httpd11.tcl
Normal file
@@ -0,0 +1,255 @@
|
||||
# httpd11.tcl -- -*- tcl -*-
|
||||
#
|
||||
# A simple httpd for testing HTTP/1.1 client features.
|
||||
# Not suitable for use on a internet connected port.
|
||||
#
|
||||
# Copyright (C) 2009 Pat Thoyts <patthoyts@users.sourceforge.net>
|
||||
#
|
||||
# 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.6
|
||||
|
||||
proc ::tcl::dict::get? {dict key} {
|
||||
if {[dict exists $dict $key]} {
|
||||
return [dict get $dict $key]
|
||||
}
|
||||
return
|
||||
}
|
||||
namespace ensemble configure dict \
|
||||
-map [linsert [namespace ensemble configure dict -map] end get? ::tcl::dict::get?]
|
||||
|
||||
proc make-chunk-generator {data {size 4096}} {
|
||||
variable _chunk_gen_uid
|
||||
if {![info exists _chunk_gen_uid]} {set _chunk_gen_uid 0}
|
||||
set lambda {{data size} {
|
||||
set pos 0
|
||||
yield
|
||||
while {1} {
|
||||
set payload [string range $data $pos [expr {$pos + $size - 1}]]
|
||||
incr pos $size
|
||||
set chunk [format %x [string length $payload]]\r\n$payload\r\n
|
||||
yield $chunk
|
||||
if {![string length $payload]} {return}
|
||||
}
|
||||
}}
|
||||
set name chunker[incr _chunk_gen_uid]
|
||||
coroutine $name ::apply $lambda $data $size
|
||||
return $name
|
||||
}
|
||||
|
||||
proc get-chunks {data {compression gzip}} {
|
||||
switch -exact -- $compression {
|
||||
gzip { set data [zlib gzip $data] }
|
||||
deflate { set data [zlib deflate $data] }
|
||||
compress { set data [zlib compress $data] }
|
||||
}
|
||||
|
||||
set data ""
|
||||
set chunker [make-chunk-generator $data 512]
|
||||
while {[string length [set chunk [$chunker]]]} {
|
||||
append data $chunk
|
||||
}
|
||||
return $data
|
||||
}
|
||||
|
||||
proc blow-chunks {data {ochan stdout} {compression gzip}} {
|
||||
switch -exact -- $compression {
|
||||
gzip { set data [zlib gzip $data] }
|
||||
deflate { set data [zlib deflate $data] }
|
||||
compress { set data [zlib compress $data] }
|
||||
}
|
||||
|
||||
set chunker [make-chunk-generator $data 512]
|
||||
while {[string length [set chunk [$chunker]]]} {
|
||||
puts -nonewline $ochan $chunk
|
||||
}
|
||||
return
|
||||
}
|
||||
|
||||
proc mime-type {filename} {
|
||||
switch -exact -- [file extension $filename] {
|
||||
.htm - .html { return {text text/html}}
|
||||
.png { return {binary image/png} }
|
||||
.jpg { return {binary image/jpeg} }
|
||||
.gif { return {binary image/gif} }
|
||||
.css { return {text text/css} }
|
||||
.xml { return {text text/xml} }
|
||||
.xhtml {return {text application/xml+html} }
|
||||
.svg { return {text image/svg+xml} }
|
||||
.txt - .tcl - .c - .h { return {text text/plain}}
|
||||
}
|
||||
return {binary text/plain}
|
||||
}
|
||||
|
||||
proc Puts {chan s} {puts $chan $s; puts $s}
|
||||
|
||||
proc Service {chan addr port} {
|
||||
chan event $chan readable [info coroutine]
|
||||
while {1} {
|
||||
set meta {}
|
||||
chan configure $chan -buffering line -encoding iso8859-1 -translation crlf
|
||||
chan configure $chan -blocking 0
|
||||
yield
|
||||
while {[gets $chan line] < 0} {
|
||||
if {[eof $chan]} {chan event $chan readable {}; close $chan; return}
|
||||
yield
|
||||
}
|
||||
if {[eof $chan]} {chan event $chan readable {}; close $chan; return}
|
||||
foreach {req url protocol} {GET {} HTTP/1.1} break
|
||||
regexp {^(\S+)\s+(.*)\s(\S+)?$} $line -> req url protocol
|
||||
|
||||
puts $line
|
||||
while {[gets $chan line] > 0} {
|
||||
if {[regexp {^([^:]+):(.*)$} $line -> key val]} {
|
||||
puts [list $key [string trim $val]]
|
||||
lappend meta [string tolower $key] [string trim $val]
|
||||
}
|
||||
yield
|
||||
}
|
||||
|
||||
set encoding identity
|
||||
set transfer ""
|
||||
set close 1
|
||||
set type text/html
|
||||
set code "404 Not Found"
|
||||
set data "<html><head><title>Error 404</title></head>"
|
||||
append data "<body><h1>Not Found</h1><p>Try again.</p></body></html>"
|
||||
|
||||
if {[scan $url {%[^?]?%s} path query] < 2} {
|
||||
set query ""
|
||||
}
|
||||
|
||||
switch -exact -- $req {
|
||||
GET - HEAD {
|
||||
}
|
||||
POST {
|
||||
# Read the query.
|
||||
set qlen [dict get? $meta content-length]
|
||||
if {[string is integer -strict $qlen]} {
|
||||
chan configure $chan -buffering none -translation binary
|
||||
while {[string length $query] < $qlen} {
|
||||
append query [read $chan $qlen]
|
||||
if {[string length $query] < $qlen} {yield}
|
||||
}
|
||||
# Check for excess query bytes [Bug 2715421]
|
||||
if {[dict get? $meta x-check-query] eq "yes"} {
|
||||
chan configure $chan -blocking 0
|
||||
append query [read $chan]
|
||||
}
|
||||
}
|
||||
}
|
||||
default {
|
||||
# invalid request error 5??
|
||||
}
|
||||
}
|
||||
if {$query ne ""} {puts $query}
|
||||
|
||||
set path [string trimleft $path /]
|
||||
set path [file join [pwd] $path]
|
||||
if {[file exists $path] && [file isfile $path]} {
|
||||
foreach {what type} [mime-type $path] break
|
||||
set f [open $path r]
|
||||
if {$what eq "binary"} {chan configure $f -translation binary}
|
||||
set data [read $f]
|
||||
close $f
|
||||
set code "200 OK"
|
||||
set close [expr {[dict get? $meta connection] eq "close"}]
|
||||
}
|
||||
|
||||
if {$protocol eq "HTTP/1.1"} {
|
||||
foreach enc [split [dict get? $meta accept-encoding] ,] {
|
||||
set enc [string trim $enc]
|
||||
if {$enc in {deflate gzip compress}} {
|
||||
set encoding $enc
|
||||
break
|
||||
}
|
||||
}
|
||||
set transfer chunked
|
||||
} else {
|
||||
set close 1
|
||||
}
|
||||
|
||||
foreach pair [split $query &] {
|
||||
if {[scan $pair {%[^=]=%s} key val] != 2} {set val ""}
|
||||
switch -exact -- $key {
|
||||
close {set close 1 ; set transfer 0}
|
||||
transfer {set transfer $val}
|
||||
content-type {set type $val}
|
||||
}
|
||||
}
|
||||
|
||||
chan configure $chan -buffering line -encoding iso8859-1 -translation crlf
|
||||
Puts $chan "$protocol $code"
|
||||
Puts $chan "content-type: $type"
|
||||
Puts $chan [format "x-crc32: %08x" [zlib crc32 $data]]
|
||||
if {$req eq "POST"} {
|
||||
Puts $chan [format "x-query-length: %d" [string length $query]]
|
||||
}
|
||||
if {$close} {
|
||||
Puts $chan "connection: close"
|
||||
}
|
||||
Puts $chan "x-requested-encodings: [dict get? $meta accept-encoding]"
|
||||
if {$encoding eq "identity"} {
|
||||
Puts $chan "content-length: [string length $data]"
|
||||
} else {
|
||||
Puts $chan "content-encoding: $encoding"
|
||||
}
|
||||
if {$transfer eq "chunked"} {
|
||||
Puts $chan "transfer-encoding: chunked"
|
||||
}
|
||||
puts $chan ""
|
||||
flush $chan
|
||||
|
||||
chan configure $chan -buffering full -translation binary
|
||||
if {$transfer eq "chunked"} {
|
||||
blow-chunks $data $chan $encoding
|
||||
} elseif {$encoding ne "identity"} {
|
||||
puts -nonewline $chan [zlib $encoding $data]
|
||||
} else {
|
||||
puts -nonewline $chan $data
|
||||
}
|
||||
|
||||
if {$close} {
|
||||
chan event $chan readable {}
|
||||
close $chan
|
||||
puts "close $chan"
|
||||
return
|
||||
} else {
|
||||
flush $chan
|
||||
}
|
||||
puts "pipeline $chan"
|
||||
}
|
||||
}
|
||||
|
||||
proc Accept {chan addr port} {
|
||||
coroutine client$chan Service $chan $addr $port
|
||||
return
|
||||
}
|
||||
|
||||
proc Control {chan} {
|
||||
if {[gets $chan line] != -1} {
|
||||
if {[string trim $line] eq "quit"} {
|
||||
set ::forever 1
|
||||
}
|
||||
}
|
||||
if {[eof $chan]} {
|
||||
chan event $chan readable {}
|
||||
}
|
||||
}
|
||||
|
||||
proc Main {{port 0}} {
|
||||
set server [socket -server Accept -myaddr localhost $port]
|
||||
puts [chan configure $server -sockname]
|
||||
flush stdout
|
||||
chan event stdin readable [list Control stdin]
|
||||
vwait ::forever
|
||||
close $server
|
||||
return "done"
|
||||
}
|
||||
|
||||
if {!$tcl_interactive} {
|
||||
set r [catch [linsert $argv 0 Main] err]
|
||||
if {$r} {puts stderr $errorInfo} elseif {[string length $err]} {puts $err}
|
||||
exit $r
|
||||
}
|
||||
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
|
||||
1282
tests/if.test
Normal file
1282
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
|
||||
522
tests/incr.test
Normal file
522
tests/incr.test
Normal file
@@ -0,0 +1,522 @@
|
||||
# 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 {"::tcltest" ni [namespace children]} {
|
||||
package require tcltest 2
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
unset -nocomplain x i
|
||||
proc readonly varName {
|
||||
upvar 1 $varName var
|
||||
trace add variable var write \
|
||||
{apply {{args} {error "variable is read-only"}}}
|
||||
}
|
||||
|
||||
# Basic "incr" operation.
|
||||
|
||||
test incr-1.1 {TclCompileIncrCmd: missing variable name} -returnCodes error -body {
|
||||
incr
|
||||
} -result {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} -body {
|
||||
set i 10
|
||||
incr "i"xxx
|
||||
} -returnCodes error -result {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} -setup {
|
||||
unset -nocomplain {a simple var}
|
||||
} -body {
|
||||
set {a simple var} 27
|
||||
list [incr {a simple var}] ${a simple var}
|
||||
} -result {28 28}
|
||||
test incr-1.6 {TclCompileIncrCmd: simple array variable name} -setup {
|
||||
unset -nocomplain a
|
||||
} -body {
|
||||
set a(foo) 37
|
||||
list [incr a(foo)] $a(foo)
|
||||
} -result {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} -setup {
|
||||
unset -nocomplain a
|
||||
} -body {
|
||||
set a(foo) 27
|
||||
incr a(foo) 11
|
||||
} -cleanup {
|
||||
unset -nocomplain a
|
||||
} -result 38
|
||||
test incr-1.16 {TclCompileIncrCmd: variable is array, elem substitutions} -setup {
|
||||
unset -nocomplain a
|
||||
} -body {
|
||||
set i 5
|
||||
set a(foo5) 27
|
||||
incr a(foo$i) 11
|
||||
} -cleanup {
|
||||
unset -nocomplain a
|
||||
} -result 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]} -> opts
|
||||
dict get $opts -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} -body {
|
||||
set i 25
|
||||
incr i 1a
|
||||
} -returnCodes error -result {expected integer but got "1a"}
|
||||
test incr-1.25 {TclCompileIncrCmd: too many arguments} -body {
|
||||
set i 10
|
||||
incr i 10 20
|
||||
} -returnCodes error -result {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 {
|
||||
set x 123
|
||||
readonly x
|
||||
list [catch {incr x 1} msg] $msg $::errorInfo
|
||||
} -match glob -cleanup {
|
||||
unset -nocomplain x
|
||||
} -result {1 {can't set "x": variable is read-only} {*variable is read-only
|
||||
while executing
|
||||
*
|
||||
"incr x 1"}}
|
||||
test incr-1.29 {TclCompileIncrCmd: runtime error, bad variable value} -body {
|
||||
set x " - "
|
||||
incr x 1
|
||||
} -returnCodes error -result {expected integer but got " - "}
|
||||
test incr-1.30 {TclCompileIncrCmd: array var, braced (no subs)} -setup {
|
||||
catch {unset array}
|
||||
} -body {
|
||||
set array(\$foo) 4
|
||||
incr {array($foo)}
|
||||
} -result 5
|
||||
|
||||
# Check "incr" and computed command names.
|
||||
|
||||
unset -nocomplain x i
|
||||
test incr-2.0 {incr and computed command names} {
|
||||
set i 5
|
||||
set z incr
|
||||
$z i -1
|
||||
return $i
|
||||
} 4
|
||||
test incr-2.1 {incr command (not compiled): missing variable name} -body {
|
||||
set z incr
|
||||
$z
|
||||
} -returnCodes error -result {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} -body {
|
||||
set z incr
|
||||
set i 10
|
||||
$z "i"xxx
|
||||
} -returnCodes error -result {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} -setup {
|
||||
unset -nocomplain {a simple var}
|
||||
} -body {
|
||||
set z incr
|
||||
set {a simple var} 27
|
||||
list [$z {a simple var}] ${a simple var}
|
||||
} -result {28 28}
|
||||
test incr-2.6 {incr command (not compiled): simple array variable name} -setup {
|
||||
unset -nocomplain a
|
||||
} -body {
|
||||
set z incr
|
||||
set a(foo) 37
|
||||
list [$z a(foo)] $a(foo)
|
||||
} -result {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} -setup {
|
||||
unset -nocomplain a
|
||||
} -body {
|
||||
set z incr
|
||||
set a(foo) 27
|
||||
$z a(foo) 11
|
||||
} -cleanup {
|
||||
unset -nocomplain a
|
||||
} -result 38
|
||||
test incr-2.16 {incr command (not compiled): variable is array, elem substitutions} -setup {
|
||||
unset -nocomplain a
|
||||
} -body {
|
||||
set z incr
|
||||
set i 5
|
||||
set a(foo5) 27
|
||||
$z a(foo$i) 11
|
||||
} -cleanup {
|
||||
unset -nocomplain a
|
||||
} -result 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]} -> opts
|
||||
dict get $opts -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} -body {
|
||||
set z incr
|
||||
set i 25
|
||||
$z i 1a
|
||||
} -returnCodes error -result {expected integer but got "1a"}
|
||||
test incr-2.25 {incr command (not compiled): too many arguments} -body {
|
||||
set z incr
|
||||
set i 10
|
||||
$z i 10 20
|
||||
} -returnCodes error -result {wrong # args: should be "incr varName ?increment?"}
|
||||
test incr-2.26 {incr command (not compiled): runtime error, bad variable name} -setup {
|
||||
unset -nocomplain {"foo}
|
||||
} -body {
|
||||
set z incr
|
||||
$z {"foo}
|
||||
} -result 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
|
||||
set x 123
|
||||
readonly x
|
||||
list [catch {$z x 1} msg] $msg $::errorInfo
|
||||
} -match glob -cleanup {
|
||||
unset -nocomplain x
|
||||
} -result {1 {can't set "x": variable is read-only} {*variable is read-only
|
||||
while executing
|
||||
*
|
||||
"$z x 1"}}
|
||||
test incr-2.29 {incr command (not compiled): runtime error, bad variable value} -body {
|
||||
set z incr
|
||||
set x " - "
|
||||
$z x 1
|
||||
} -returnCodes error -result {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
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# fill-column: 78
|
||||
# End:
|
||||
166
tests/indexObj.test
Normal file
166
tests/indexObj.test
Normal file
@@ -0,0 +1,166 @@
|
||||
# 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 2
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
::tcltest::loadTestedCommands
|
||||
catch [list package require -exact Tcltest [info patchlevel]]
|
||||
|
||||
testConstraint testindexobj [llength [info commands testindexobj]]
|
||||
testConstraint testparseargs [llength [info commands testparseargs]]
|
||||
|
||||
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 "?-switch?" mycmd
|
||||
} "wrong # args: should be \"mycmd ?-switch?\""
|
||||
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\""
|
||||
|
||||
test indexObj-7.1 {Tcl_ParseArgsObjv} testparseargs {
|
||||
testparseargs
|
||||
} {0 1 testparseargs}
|
||||
test indexObj-7.2 {Tcl_ParseArgsObjv} testparseargs {
|
||||
testparseargs -bool
|
||||
} {1 1 testparseargs}
|
||||
test indexObj-7.3 {Tcl_ParseArgsObjv} testparseargs {
|
||||
testparseargs -bool bar
|
||||
} {1 2 {testparseargs bar}}
|
||||
test indexObj-7.4 {Tcl_ParseArgsObjv} testparseargs {
|
||||
testparseargs bar
|
||||
} {0 2 {testparseargs bar}}
|
||||
test indexObj-7.5 {Tcl_ParseArgsObjv} -constraints testparseargs -body {
|
||||
testparseargs -help
|
||||
} -returnCodes error -result {Command-specific options:
|
||||
-bool: booltest
|
||||
--: Marks the end of the options
|
||||
-help: Print summary of command-line options and abort}
|
||||
test indexObj-7.6 {Tcl_ParseArgsObjv} testparseargs {
|
||||
testparseargs -- -bool -help
|
||||
} {0 3 {testparseargs -bool -help}}
|
||||
test indexObj-7.7 {Tcl_ParseArgsObjv memory management} testparseargs {
|
||||
testparseargs 1 2 3 4 5 6 7 8 9 0 -bool 1 2 3 4 5 6 7 8 9 0
|
||||
} {1 21 {testparseargs 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0}}
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# End:
|
||||
2421
tests/info.test
Normal file
2421
tests/info.test
Normal file
File diff suppressed because it is too large
Load Diff
195
tests/init.test
Normal file
195
tests/init.test
Normal file
@@ -0,0 +1,195 @@
|
||||
# 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 {"::tcltest" ni [namespace children]} {
|
||||
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::*
|
||||
customMatch pairwise {apply {{mode pair} {
|
||||
if {[llength $pair] != 2} {error "need a pair of values to check"}
|
||||
string $mode [lindex $pair 0] [lindex $pair 1]
|
||||
}}}
|
||||
|
||||
auto_reset
|
||||
catch {rename parray {}}
|
||||
|
||||
test init-2.0 {load parray - stage 1} -body {
|
||||
parray
|
||||
} -returnCodes error -cleanup {
|
||||
rename parray {} ;# remove it, for the next test - that should not fail.
|
||||
} -result {wrong # args: should be "parray a ?pattern?"}
|
||||
test init-2.1 {load parray - stage 2} -body {
|
||||
parray
|
||||
} -returnCodes error -result {wrong # args: should be "parray a ?pattern?"}
|
||||
auto_reset
|
||||
catch {rename ::safe::setLogCmd {}}
|
||||
#unset -nocomplain auto_index(::safe::setLogCmd) 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
|
||||
tcl:::HistAdd
|
||||
} -returnCodes error -cleanup {
|
||||
rename ::tcl::HistAdd {}
|
||||
} -result {wrong # args: should be "tcl:::HistAdd event ?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]} -setup {
|
||||
auto_reset
|
||||
} -body {
|
||||
catch {parray a b $arg}
|
||||
set first $::errorInfo
|
||||
catch {parray a b $arg}
|
||||
list $first $::errorInfo
|
||||
} -match pairwise -result equal
|
||||
test init-4.$count.1 {::errorInfo produced by [unknown]} -setup {
|
||||
auto_reset
|
||||
} -body {
|
||||
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}
|
||||
list $first $::errorInfo
|
||||
} -match pairwise -result equal
|
||||
|
||||
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)
|
||||
} -match glob -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
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# fill-column: 78
|
||||
# End:
|
||||
3666
tests/interp.test
Normal file
3666
tests/interp.test
Normal file
File diff suppressed because it is too large
Load Diff
8670
tests/io.test
Normal file
8670
tests/io.test
Normal file
File diff suppressed because it is too large
Load Diff
3843
tests/ioCmd.test
Normal file
3843
tests/ioCmd.test
Normal file
File diff suppressed because it is too large
Load Diff
2093
tests/ioTrans.test
Normal file
2093
tests/ioTrans.test
Normal file
File diff suppressed because it is too large
Load Diff
955
tests/iogt.test
Normal file
955
tests/iogt.test
Normal file
@@ -0,0 +1,955 @@
|
||||
# -*- 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
|
||||
}
|
||||
|
||||
::tcltest::loadTestedCommands
|
||||
catch [list package require -exact Tcltest [info patchlevel]]
|
||||
|
||||
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
|
||||
namespace upvar [namespace current] c$c conn
|
||||
|
||||
#puts stdout "C $sock $rhost $rport / $fdelay" ; flush stdout
|
||||
|
||||
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
|
||||
namespace upvar [namespace current] 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
|
||||
namespace upvar [namespace current] 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.
|
||||
|
||||
upvar 1 sock sk
|
||||
|
||||
# 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
|
||||
|
||||
set res [uplevel 1 $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} {
|
||||
namespace upvar [namespace current] $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 id_torture {chan op data} {
|
||||
switch -- $op {
|
||||
create/write -
|
||||
create/read -
|
||||
delete/write -
|
||||
delete/read -
|
||||
clear_read {;#ignore}
|
||||
flush/write -
|
||||
flush/read {}
|
||||
write {
|
||||
global level
|
||||
if {$level} {
|
||||
return
|
||||
}
|
||||
incr level
|
||||
testchannel unstack $chan
|
||||
testchannel transform $chan \
|
||||
-command [namespace code [list id_torture $chan]]
|
||||
return $data
|
||||
}
|
||||
read {
|
||||
testchannel unstack $chan
|
||||
testchannel transform $chan \
|
||||
-command [namespace code [list id_torture $chan]]
|
||||
return $data
|
||||
}
|
||||
query/maxRead {return -1}
|
||||
}
|
||||
}
|
||||
|
||||
proc counter {var op data} {
|
||||
namespace upvar [namespace current] $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} {
|
||||
namespace upvar [namespace current] $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} {
|
||||
namespace upvar [namespace current] $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 torture {-attach channel} {
|
||||
testchannel transform $channel -command [namespace code [list id_torture $channel]]
|
||||
}
|
||||
|
||||
proc stopafter {var n -attach channel} {
|
||||
namespace upvar [namespace current] $var vn
|
||||
set vn $n
|
||||
testchannel transform $channel -command [namespace code [list counter $var]]
|
||||
}
|
||||
proc stopafter_audit {var trail n -attach channel} {
|
||||
namespace upvar [namespace current] $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} -setup {
|
||||
set fh [open $path(dummy) r]
|
||||
} -constraints testchannel -body {
|
||||
set ca [asort [fconfigure $fh]]
|
||||
identity -attach $fh
|
||||
fconfigure $fh -buffering line -translation cr -encoding shiftjis
|
||||
testchannel unstack $fh
|
||||
set cc [asort [fconfigure $fh]]
|
||||
list [string equal $ca $cc] [fconfigure $fh -buffering] \
|
||||
[fconfigure $fh -translation] [fconfigure $fh -encoding]
|
||||
} -cleanup {
|
||||
close $fh
|
||||
} -result {0 line cr shiftjis}
|
||||
|
||||
test iogt-2.0 {basic I/O going through transform} -setup {
|
||||
set fin [open $path(dummy) r]
|
||||
set fout [open $path(dummyout) w]
|
||||
} -constraints testchannel -body {
|
||||
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]
|
||||
list [string equal [set in [read $fin]] [set out [read $fout]]] \
|
||||
[string length $in] [string length $out]
|
||||
} -cleanup {
|
||||
close $fin
|
||||
close $fout
|
||||
} -result {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
|
||||
query/maxRead
|
||||
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 {} {}
|
||||
query/maxRead {} -1
|
||||
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 {
|
||||
} {
|
||||
}
|
||||
query/maxRead {} -1
|
||||
delete/read {} *ignored*
|
||||
flush/write {} {}
|
||||
delete/write {} *ignored*}
|
||||
|
||||
test iogt-2.4 {basic I/O, mixed trail} {testchannel} {
|
||||
set fh [open $path(dummy) r]
|
||||
torture -attach $fh
|
||||
chan configure $fh -buffersize 2
|
||||
set x [read $fh]
|
||||
testchannel unstack $fh
|
||||
close $fh
|
||||
set x
|
||||
} {}
|
||||
test iogt-2.5 {basic I/O, mixed trail} {testchannel} {
|
||||
set ::level 0
|
||||
set fh [open $path(dummyout) w]
|
||||
torture -attach $fh
|
||||
puts -nonewline $fh abcdef
|
||||
flush $fh
|
||||
testchannel unstack $fh
|
||||
close $fh
|
||||
} {}
|
||||
|
||||
test iogt-3.0 {Tcl_Channel valid after stack/unstack, fevent handling} -setup {
|
||||
proc DoneCopy {n {err {}}} {
|
||||
variable copy 1
|
||||
}
|
||||
} -constraints {testchannel knownBug} -body {
|
||||
# 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.
|
||||
set fin [open $path(dummy) r]
|
||||
fevent 1000 500 {20 20 20 10 1 1} {
|
||||
variable copy
|
||||
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
|
||||
# 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
|
||||
} -cleanup {
|
||||
rename DoneCopy {}
|
||||
} -result {1 {create/write create/read write flush/write flush/read delete/write delete/read}}
|
||||
|
||||
test iogt-4.0 {fileevent readable, after transform} -setup {
|
||||
set fin [open $path(dummy) r]
|
||||
set data [read $fin]
|
||||
close $fin
|
||||
set trail [list]
|
||||
set got [list]
|
||||
proc Done {args} {
|
||||
variable 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
|
||||
}
|
||||
|
||||
} -constraints {testchannel knownBug} -body {
|
||||
fevent 1000 500 {20 20 20 10 1} {
|
||||
variable stop
|
||||
audit_flow trail -attach $sock
|
||||
rblocks_t rbuf trail 23 -attach $sock
|
||||
|
||||
fileevent $sock readable [namespace code [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
|
||||
join [list [join $got \n] ~~~~~~~~ [join $trail \n]] \n
|
||||
} -cleanup {
|
||||
rename Done {}
|
||||
rename Get {}
|
||||
} -result {[[]]
|
||||
[[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} -setup {
|
||||
set fin [open $path(dummy) r]
|
||||
set fout [open $path(dummyout) w]
|
||||
set trail [list]
|
||||
} -constraints {testchannel knownBug} -result {
|
||||
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
|
||||
} -result {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} -constraints testchannel -body {
|
||||
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.
|
||||
read $f 3
|
||||
} -cleanup {
|
||||
close $f
|
||||
} -result {xxx}
|
||||
test iogt-6.1 {Push back and up} -constraints {testchannel knownBug} -body {
|
||||
|
||||
# This test demonstrates the bug/misfeature in the stacked
|
||||
# channel implementation that data can be discarded if it is
|
||||
# read into the buffers of one channel in the stack, and then
|
||||
# that channel is popped before anything above it reads.
|
||||
#
|
||||
# This bug can be worked around by always setting -buffersize
|
||||
# to 1, but who wants to do that?
|
||||
|
||||
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]
|
||||
} -cleanup {
|
||||
close $f
|
||||
} -result {xxxghi}
|
||||
|
||||
|
||||
# Driver for a base channel that emits several short "files"
|
||||
# with each terminated by a fleeting EOF
|
||||
proc driver {cmd args} {
|
||||
variable buffer
|
||||
variable index
|
||||
set chan [lindex $args 0]
|
||||
switch -- $cmd {
|
||||
initialize {
|
||||
set index($chan) 0
|
||||
set buffer($chan) .....
|
||||
return {initialize finalize watch read}
|
||||
}
|
||||
finalize {
|
||||
if {![info exists index($chan)]} {return}
|
||||
unset index($chan) buffer($chan)
|
||||
return
|
||||
}
|
||||
watch {}
|
||||
read {
|
||||
set n [lindex $args 1]
|
||||
if {![info exists index($chan)]} {
|
||||
driver initialize $chan
|
||||
}
|
||||
set new [expr {$index($chan) + $n}]
|
||||
set result [string range $buffer($chan) $index($chan) $new-1]
|
||||
set index($chan) $new
|
||||
if {[string length $result] == 0} {
|
||||
driver finalize $chan
|
||||
}
|
||||
return $result
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
test iogt-7.0 {Handle fleeting EOF} -constraints {testchannel} -body {
|
||||
set chan [chan create read [namespace which driver]]
|
||||
identity -attach $chan
|
||||
list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \
|
||||
[read $chan] [eof $chan]
|
||||
} -cleanup {
|
||||
close $chan
|
||||
} -result {0 ..... 1 {} 0 ..... 1}
|
||||
|
||||
proc delay {op data} {
|
||||
variable store
|
||||
switch -- $op {
|
||||
create/write - create/read -
|
||||
delete/write - delete/read -
|
||||
flush/write - write -
|
||||
clear_read {;#ignore}
|
||||
flush/read -
|
||||
read {
|
||||
if {![info exists store]} {set store {}}
|
||||
set reply $store
|
||||
set store $data
|
||||
return $reply
|
||||
}
|
||||
query/maxRead {return -1}
|
||||
}
|
||||
}
|
||||
|
||||
test iogt-7.1 {Handle fleeting EOF} -constraints {testchannel} -body {
|
||||
set chan [chan create read [namespace which driver]]
|
||||
testchannel transform $chan -command [namespace code delay]
|
||||
list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \
|
||||
[read $chan] [eof $chan]
|
||||
} -cleanup {
|
||||
close $chan
|
||||
} -result {0 ..... 1 {} 0 ..... 1}
|
||||
|
||||
rename delay {}
|
||||
rename driver {}
|
||||
|
||||
# cleanup
|
||||
foreach file [list dummy dummyout __echo_srv__.tcl] {
|
||||
removeFile $file
|
||||
}
|
||||
cleanupTests
|
||||
}
|
||||
namespace delete ::tcl::test::iogt
|
||||
return
|
||||
55
tests/join.test
Normal file
55
tests/join.test
Normal file
@@ -0,0 +1,55 @@
|
||||
# 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?"} {TCL WRONGARGS}}
|
||||
test join-2.2 {join errors} {
|
||||
list [catch {join a b c} msg] $msg $errorCode
|
||||
} {1 {wrong # args: should be "join list ?joinString?"} {TCL WRONGARGS}}
|
||||
test join-2.3 {join errors} {
|
||||
list [catch {join "a \{ c" 111} msg] $msg $errorCode
|
||||
} {1 {unmatched open brace in list} {TCL VALUE LIST BRACE}}
|
||||
|
||||
test join-3.1 {joinString is binary ok} {
|
||||
string length [join {a b c} a\0b]
|
||||
} 9
|
||||
test join-3.2 {join is binary ok} {
|
||||
string length [join "a\0b a\0b a\0b"]
|
||||
} 11
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# End:
|
||||
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-7014 (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.
|
||||
458
tests/lindex.test
Normal file
458
tests/lindex.test
Normal file
@@ -0,0 +1,458 @@
|
||||
# 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::*
|
||||
}
|
||||
|
||||
::tcltest::loadTestedCommands
|
||||
catch [list package require -exact Tcltest [info patchlevel]]
|
||||
|
||||
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:
|
||||
310
tests/link.test
Normal file
310
tests/link.test
Normal file
@@ -0,0 +1,310 @@
|
||||
# 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 {"::tcltest" ni [namespace children]} {
|
||||
package require tcltest 2
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
::tcltest::loadTestedCommands
|
||||
catch [list package require -exact Tcltest [info patchlevel]]
|
||||
|
||||
testConstraint testlink [llength [info commands testlink]]
|
||||
|
||||
foreach i {int real bool string} {
|
||||
unset -nocomplain $i
|
||||
}
|
||||
|
||||
test link-1.1 {reading C variables from Tcl} -constraints {testlink} -setup {
|
||||
testlink delete
|
||||
} -body {
|
||||
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
|
||||
} -result {43 1.23 1 NULL 12341234}
|
||||
test link-1.2 {reading C variables from Tcl} -constraints {testlink} -setup {
|
||||
testlink delete
|
||||
} -body {
|
||||
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
|
||||
} -result {-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} -constraints {testlink} -setup {
|
||||
testlink delete
|
||||
} -body {
|
||||
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
|
||||
} -result {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} -setup {
|
||||
testlink delete
|
||||
} -constraints {testlink} -body {
|
||||
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
|
||||
} -result {1 {can't set "int": variable must have integer value} 43}
|
||||
test link-2.3 {writing bad values into variables} -setup {
|
||||
testlink delete
|
||||
} -constraints {testlink} -body {
|
||||
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
|
||||
} -result {1 {can't set "real": variable must have real value} 1.23}
|
||||
test link-2.4 {writing bad values into variables} -setup {
|
||||
testlink delete
|
||||
} -constraints {testlink} -body {
|
||||
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
|
||||
} -result {1 {can't set "bool": variable must have boolean value} 1}
|
||||
test link-2.5 {writing bad values into variables} -setup {
|
||||
testlink delete
|
||||
} -constraints {testlink} -body {
|
||||
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
|
||||
} -result {1 {can't set "wide": variable must have integer value} 1}
|
||||
|
||||
test link-3.1 {read-only variables} -constraints {testlink} -setup {
|
||||
testlink delete
|
||||
} -body {
|
||||
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
|
||||
} -result {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} -constraints {testlink} -setup {
|
||||
testlink delete
|
||||
} -body {
|
||||
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
|
||||
} -result {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} -constraints {testlink} -setup {
|
||||
testlink delete
|
||||
} -body {
|
||||
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
|
||||
} -result {0 -6 0 -2.5 0 0 0 stringValue 0 13579}
|
||||
test link-4.2 {unsetting linked variables} -constraints {testlink} -setup {
|
||||
testlink delete
|
||||
} -body {
|
||||
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
|
||||
} -result {102 16.0 1 newValue 333555}
|
||||
|
||||
test link-5.1 {unlinking variables} -constraints {testlink} -setup {
|
||||
testlink delete
|
||||
} -body {
|
||||
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
|
||||
} -result {-6 -2.25 0 stringValue 13579 64 250 30000 60000 -1091585346 12321 32123 3.25 1231231234}
|
||||
test link-5.2 {unlinking variables} -constraints {testlink} -setup {
|
||||
testlink delete
|
||||
} -body {
|
||||
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
|
||||
} -result {-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} -setup {
|
||||
testlink delete
|
||||
unset -nocomplain int
|
||||
} -constraints {testlink} -body {
|
||||
set int(44) 1
|
||||
testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
|
||||
} -cleanup {
|
||||
unset -nocomplain int
|
||||
} -returnCodes error -result {can't set "int": variable is array}
|
||||
|
||||
test link-7.1 {access to linked variables via upvar} -setup {
|
||||
testlink delete
|
||||
} -constraints {testlink} -body {
|
||||
proc x {} {
|
||||
upvar int y
|
||||
unset y
|
||||
}
|
||||
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
|
||||
} -result {0 14}
|
||||
test link-7.2 {access to linked variables via upvar} -setup {
|
||||
testlink delete
|
||||
} -constraints {testlink} -body {
|
||||
proc x {} {
|
||||
upvar int y
|
||||
return [set y]
|
||||
}
|
||||
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
|
||||
} -result {23 23}
|
||||
test link-7.3 {access to linked variables via upvar} -setup {
|
||||
testlink delete
|
||||
} -constraints {testlink} -body {
|
||||
proc x {} {
|
||||
upvar int y
|
||||
set y 44
|
||||
}
|
||||
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
|
||||
} -result {1 {can't set "y": linked variable is read-only} 11}
|
||||
test link-7.4 {access to linked variables via upvar} -setup {
|
||||
testlink delete
|
||||
} -constraints {testlink} -body {
|
||||
proc x {} {
|
||||
upvar int y
|
||||
set y abc
|
||||
}
|
||||
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
|
||||
} -result {1 {can't set "y": variable must have integer value} -4}
|
||||
test link-7.5 {access to linked variables via upvar} -setup {
|
||||
testlink delete
|
||||
} -constraints {testlink} -body {
|
||||
proc x {} {
|
||||
upvar real y
|
||||
set y abc
|
||||
}
|
||||
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
|
||||
} -result {1 {can't set "y": variable must have real value} 16.75}
|
||||
test link-7.6 {access to linked variables via upvar} -setup {
|
||||
testlink delete
|
||||
} -constraints {testlink} -body {
|
||||
proc x {} {
|
||||
upvar bool y
|
||||
set y abc
|
||||
}
|
||||
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
|
||||
} -result {1 {can't set "y": variable must have boolean value} 1}
|
||||
test link-7.7 {access to linked variables via upvar} -setup {
|
||||
testlink delete
|
||||
} -constraints {testlink} -body {
|
||||
proc x {} {
|
||||
upvar wide y
|
||||
set y abc
|
||||
}
|
||||
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
|
||||
} -result {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
|
||||
return $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
|
||||
return $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} {
|
||||
unset -nocomplain $i
|
||||
}
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# fill-column: 78
|
||||
# End:
|
||||
119
tests/linsert.test
Normal file
119
tests/linsert.test
Normal file
@@ -0,0 +1,119 @@
|
||||
# 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 ...?"}}
|
||||
test linsert-2.2 {linsert errors} {
|
||||
list [catch {linsert a b} msg] $msg
|
||||
} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}}
|
||||
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-2.5 {syntax (TIP 323)} {
|
||||
linsert {a b c} 0
|
||||
} [list a b c]
|
||||
test linsert-2.6 {syntax (TIP 323)} {
|
||||
linsert "a\nb\nc" 0
|
||||
} [list a b c]
|
||||
|
||||
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
|
||||
134
tests/list.test
Normal file
134
tests/list.test
Normal file
@@ -0,0 +1,134 @@
|
||||
# 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 #\{ #\{} {\#\{ #\{}
|
||||
test list-1.27 {basic null treatment} {
|
||||
set l [list "" "\0" "\0\0"]
|
||||
set e "{} \0 \0\0"
|
||||
string equal $l $e
|
||||
} 1
|
||||
test list-1.28 {basic null treatment} {
|
||||
set result "\0a\0b"
|
||||
list $result [string length $result]
|
||||
} "\0a\0b 4"
|
||||
test list-1.29 {basic null treatment} {
|
||||
set result "\0a\0b"
|
||||
set srep "$result 4"
|
||||
set lrep [list $result [string length $result]]
|
||||
string equal $srep $lrep
|
||||
} 1
|
||||
test list-1.30 {basic null treatment} {
|
||||
set l [list "\0abc" "xyz"]
|
||||
set e "\0abc xyz"
|
||||
string equal $l $e
|
||||
} 1
|
||||
|
||||
# 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
|
||||
209
tests/listObj.test
Normal file
209
tests/listObj.test
Normal file
@@ -0,0 +1,209 @@
|
||||
# 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::*
|
||||
}
|
||||
|
||||
::tcltest::loadTestedCommands
|
||||
catch [list package require -exact Tcltest [info patchlevel]]
|
||||
|
||||
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
|
||||
471
tests/lmap.test
Normal file
471
tests/lmap.test
Normal file
@@ -0,0 +1,471 @@
|
||||
# Commands covered: lmap, 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.
|
||||
# Copyright (c) 2011 Trevor Davel
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
#
|
||||
# RCS: @(#) $Id: $
|
||||
|
||||
if {"::tcltest" ni [namespace children]} {
|
||||
package require tcltest 2
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
unset -nocomplain a b i x
|
||||
|
||||
# ----- Non-compiled operation -----------------------------------------------
|
||||
|
||||
# Basic "lmap" operation (non-compiled)
|
||||
test lmap-1.1 {basic lmap tests} {
|
||||
set a {}
|
||||
lmap i {a b c d} {
|
||||
set a [concat $a $i]
|
||||
}
|
||||
} {a {a b} {a b c} {a b c d}}
|
||||
test lmap-1.2 {basic lmap tests} {
|
||||
lmap i {a b {{c d} e} {123 {{x}}}} {
|
||||
set i
|
||||
}
|
||||
} {a b {{c d} e} {123 {{x}}}}
|
||||
test lmap-1.2a {basic lmap tests} {
|
||||
lmap i {a b {{c d} e} {123 {{x}}}} {
|
||||
return -level 0 $i
|
||||
}
|
||||
} {a b {{c d} e} {123 {{x}}}}
|
||||
test lmap-1.4 {basic lmap tests} -returnCodes error -body {
|
||||
lmap
|
||||
} -result {wrong # args: should be "lmap varList list ?varList list ...? command"}
|
||||
test lmap-1.6 {basic lmap tests} -returnCodes error -body {
|
||||
lmap i
|
||||
} -result {wrong # args: should be "lmap varList list ?varList list ...? command"}
|
||||
test lmap-1.8 {basic lmap tests} -returnCodes error -body {
|
||||
lmap i j
|
||||
} -result {wrong # args: should be "lmap varList list ?varList list ...? command"}
|
||||
test lmap-1.10 {basic lmap tests} -returnCodes error -body {
|
||||
lmap i j k l
|
||||
} -result {wrong # args: should be "lmap varList list ?varList list ...? command"}
|
||||
test lmap-1.11 {basic lmap tests} {
|
||||
lmap i {} {
|
||||
set i
|
||||
}
|
||||
} {}
|
||||
test lmap-1.12 {basic lmap tests} {
|
||||
lmap i {} {
|
||||
return -level 0 x
|
||||
}
|
||||
} {}
|
||||
test lmap-1.13 {lmap errors} -returnCodes error -body {
|
||||
lmap {{a}{b}} {1 2 3} {}
|
||||
} -result {list element in braces followed by "{b}" instead of space}
|
||||
test lmap-1.14 {lmap errors} -returnCodes error -body {
|
||||
lmap a {{1 2}3} {}
|
||||
} -result {list element in braces followed by "3" instead of space}
|
||||
unset -nocomplain a
|
||||
test lmap-1.15 {lmap errors} -setup {
|
||||
unset -nocomplain a
|
||||
} -body {
|
||||
set a(0) 44
|
||||
list [catch {lmap a {1 2 3} {}} msg o] $msg $::errorInfo
|
||||
} -result {1 {can't set "a": variable is array} {can't set "a": variable is array
|
||||
(setting lmap loop variable "a")
|
||||
invoked from within
|
||||
"lmap a {1 2 3} {}"}}
|
||||
test lmap-1.16 {lmap errors} -returnCodes error -body {
|
||||
lmap {} {} {}
|
||||
} -result {lmap varlist is empty}
|
||||
unset -nocomplain a
|
||||
|
||||
# Parallel "lmap" operation (non-compiled)
|
||||
test lmap-2.1 {parallel lmap tests} {
|
||||
lmap {a b} {1 2 3 4} {
|
||||
list $b $a
|
||||
}
|
||||
} {{2 1} {4 3}}
|
||||
test lmap-2.2 {parallel lmap tests} {
|
||||
lmap {a b} {1 2 3 4 5} {
|
||||
list $b $a
|
||||
}
|
||||
} {{2 1} {4 3} {{} 5}}
|
||||
test lmap-2.3 {parallel lmap tests} {
|
||||
lmap a {1 2 3} b {4 5 6} {
|
||||
list $b $a
|
||||
}
|
||||
} {{4 1} {5 2} {6 3}}
|
||||
test lmap-2.4 {parallel lmap tests} {
|
||||
lmap a {1 2 3} b {4 5 6 7 8} {
|
||||
list $b $a
|
||||
}
|
||||
} {{4 1} {5 2} {6 3} {7 {}} {8 {}}}
|
||||
test lmap-2.5 {parallel lmap tests} {
|
||||
lmap {a b} {a b A B aa bb} c {c C cc CC} {
|
||||
list $a $b $c
|
||||
}
|
||||
} {{a b c} {A B C} {aa bb cc} {{} {} CC}}
|
||||
test lmap-2.6 {parallel lmap tests} {
|
||||
lmap a {1 2 3} b {1 2 3} c {1 2 3} d {1 2 3} e {1 2 3} {
|
||||
list $a$b$c$d$e
|
||||
}
|
||||
} {11111 22222 33333}
|
||||
test lmap-2.7 {parallel lmap tests} {
|
||||
lmap a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} {
|
||||
set x $a$b$c$d$e
|
||||
}
|
||||
} {{1111 2} 222 33 4}
|
||||
test lmap-2.8 {parallel lmap tests} {
|
||||
lmap a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} {
|
||||
join [list $a $b $c $d $e] .
|
||||
}
|
||||
} {{.1.1.1.1 2} .2.2.2. .3..3. ...4.}
|
||||
test lmap-2.9 {lmap only sets vars if repeating loop} {
|
||||
namespace eval ::lmap_test {
|
||||
set rgb {65535 0 0}
|
||||
lmap {r g b} [set rgb] {}
|
||||
set ::x "r=$r, g=$g, b=$b"
|
||||
}
|
||||
namespace delete ::lmap_test
|
||||
set x
|
||||
} {r=65535, g=0, b=0}
|
||||
test lmap-2.10 {lmap only supports local scalar variables} -setup {
|
||||
unset -nocomplain a
|
||||
} -body {
|
||||
lmap {a(3)} {1 2 3 4} {set {a(3)}}
|
||||
} -result {1 2 3 4}
|
||||
unset -nocomplain a
|
||||
|
||||
# "lmap" with "continue" and "break" (non-compiled)
|
||||
test lmap-3.1 {continue tests} {
|
||||
lmap i {a b c d} {
|
||||
if {[string compare $i "b"] == 0} continue
|
||||
set i
|
||||
}
|
||||
} {a c d}
|
||||
test lmap-3.2 {continue tests} {
|
||||
set x 0
|
||||
list [lmap i {a b c d} {
|
||||
incr x
|
||||
if {[string compare $i "b"] != 0} continue
|
||||
set i
|
||||
}] $x
|
||||
} {b 4}
|
||||
test lmap-3.3 {break tests} {
|
||||
set x 0
|
||||
list [lmap i {a b c d} {
|
||||
incr x
|
||||
if {[string compare $i "c"] == 0} break
|
||||
set i
|
||||
}] $x
|
||||
} {{a b} 3}
|
||||
# Check for bug similar to #406709
|
||||
test lmap-3.4 {break tests} {
|
||||
set a 1
|
||||
lmap b b {list [concat a; break]; incr a}
|
||||
incr a
|
||||
} {2}
|
||||
|
||||
# ----- Compiled operation ---------------------------------------------------
|
||||
|
||||
# Basic "lmap" operation (compiled)
|
||||
test lmap-4.1 {basic lmap tests} {
|
||||
apply {{} {
|
||||
set a {}
|
||||
lmap i {a b c d} {
|
||||
set a [concat $a $i]
|
||||
}
|
||||
}}
|
||||
} {a {a b} {a b c} {a b c d}}
|
||||
test lmap-4.2 {basic lmap tests} {
|
||||
apply {{} {
|
||||
lmap i {a b {{c d} e} {123 {{x}}}} {
|
||||
set i
|
||||
}
|
||||
}}
|
||||
} {a b {{c d} e} {123 {{x}}}}
|
||||
test lmap-4.2a {basic lmap tests} {
|
||||
apply {{} {
|
||||
lmap i {a b {{c d} e} {123 {{x}}}} {
|
||||
return -level 0 $i
|
||||
}
|
||||
}}
|
||||
} {a b {{c d} e} {123 {{x}}}}
|
||||
test lmap-4.4 {basic lmap tests} -returnCodes error -body {
|
||||
apply {{} { lmap }}
|
||||
} -result {wrong # args: should be "lmap varList list ?varList list ...? command"}
|
||||
test lmap-4.6 {basic lmap tests} -returnCodes error -body {
|
||||
apply {{} { lmap i }}
|
||||
} -result {wrong # args: should be "lmap varList list ?varList list ...? command"}
|
||||
test lmap-4.8 {basic lmap tests} -returnCodes error -body {
|
||||
apply {{} { lmap i j }}
|
||||
} -result {wrong # args: should be "lmap varList list ?varList list ...? command"}
|
||||
test lmap-4.10 {basic lmap tests} -returnCodes error -body {
|
||||
apply {{} { lmap i j k l }}
|
||||
} -result {wrong # args: should be "lmap varList list ?varList list ...? command"}
|
||||
test lmap-4.11 {basic lmap tests} {
|
||||
apply {{} { lmap i {} { set i } }}
|
||||
} {}
|
||||
test lmap-4.12 {basic lmap tests} {
|
||||
apply {{} { lmap i {} { return -level 0 x } }}
|
||||
} {}
|
||||
test lmap-4.13 {lmap errors} -returnCodes error -body {
|
||||
apply {{} { lmap {{a}{b}} {1 2 3} {} }}
|
||||
} -result {list element in braces followed by "{b}" instead of space}
|
||||
test lmap-4.14 {lmap errors} -returnCodes error -body {
|
||||
apply {{} { lmap a {{1 2}3} {} }}
|
||||
} -result {list element in braces followed by "3" instead of space}
|
||||
unset -nocomplain a
|
||||
test lmap-4.15 {lmap errors} {
|
||||
apply {{} {
|
||||
set a(0) 44
|
||||
list [catch {lmap a {1 2 3} {}} msg o] $msg $::errorInfo
|
||||
}}
|
||||
} {1 {can't set "a": variable is array} {can't set "a": variable is array
|
||||
while executing
|
||||
"lmap a {1 2 3} {}"}}
|
||||
test lmap-4.16 {lmap errors} -returnCodes error -body {
|
||||
apply {{} {
|
||||
lmap {} {} {}
|
||||
}}
|
||||
} -result {lmap varlist is empty}
|
||||
unset -nocomplain a
|
||||
|
||||
# Parallel "lmap" operation (compiled)
|
||||
test lmap-5.1 {parallel lmap tests} {
|
||||
apply {{} {
|
||||
lmap {a b} {1 2 3 4} {
|
||||
list $b $a
|
||||
}
|
||||
}}
|
||||
} {{2 1} {4 3}}
|
||||
test lmap-5.2 {parallel lmap tests} {
|
||||
apply {{} {
|
||||
lmap {a b} {1 2 3 4 5} {
|
||||
list $b $a
|
||||
}
|
||||
}}
|
||||
} {{2 1} {4 3} {{} 5}}
|
||||
test lmap-5.3 {parallel lmap tests} {
|
||||
apply {{} {
|
||||
lmap a {1 2 3} b {4 5 6} {
|
||||
list $b $a
|
||||
}
|
||||
}}
|
||||
} {{4 1} {5 2} {6 3}}
|
||||
test lmap-5.4 {parallel lmap tests} {
|
||||
apply {{} {
|
||||
lmap a {1 2 3} b {4 5 6 7 8} {
|
||||
list $b $a
|
||||
}
|
||||
}}
|
||||
} {{4 1} {5 2} {6 3} {7 {}} {8 {}}}
|
||||
test lmap-5.5 {parallel lmap tests} {
|
||||
apply {{} {
|
||||
lmap {a b} {a b A B aa bb} c {c C cc CC} {
|
||||
list $a $b $c
|
||||
}
|
||||
}}
|
||||
} {{a b c} {A B C} {aa bb cc} {{} {} CC}}
|
||||
test lmap-5.6 {parallel lmap tests} {
|
||||
apply {{} {
|
||||
lmap a {1 2 3} b {1 2 3} c {1 2 3} d {1 2 3} e {1 2 3} {
|
||||
list $a$b$c$d$e
|
||||
}
|
||||
}}
|
||||
} {11111 22222 33333}
|
||||
test lmap-5.7 {parallel lmap tests} {
|
||||
apply {{} {
|
||||
lmap a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} {
|
||||
set x $a$b$c$d$e
|
||||
}
|
||||
}}
|
||||
} {{1111 2} 222 33 4}
|
||||
test lmap-5.8 {parallel lmap tests} {
|
||||
apply {{} {
|
||||
lmap a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} {
|
||||
join [list $a $b $c $d $e] .
|
||||
}
|
||||
}}
|
||||
} {{.1.1.1.1 2} .2.2.2. .3..3. ...4.}
|
||||
test lmap-5.9 {lmap only sets vars if repeating loop} {
|
||||
apply {{} {
|
||||
set rgb {65535 0 0}
|
||||
lmap {r g b} [set rgb] {}
|
||||
return "r=$r, g=$g, b=$b"
|
||||
}}
|
||||
} {r=65535, g=0, b=0}
|
||||
test lmap-5.10 {lmap only supports local scalar variables} {
|
||||
apply {{} {
|
||||
lmap {a(3)} {1 2 3 4} {set {a(3)}}
|
||||
}}
|
||||
} {1 2 3 4}
|
||||
|
||||
# "lmap" with "continue" and "break" (compiled)
|
||||
test lmap-6.1 {continue tests} {
|
||||
apply {{} {
|
||||
lmap i {a b c d} {
|
||||
if {[string compare $i "b"] == 0} continue
|
||||
set i
|
||||
}
|
||||
}}
|
||||
} {a c d}
|
||||
test lmap-6.2 {continue tests} {
|
||||
apply {{} {
|
||||
list [lmap i {a b c d} {
|
||||
incr x
|
||||
if {[string compare $i "b"] != 0} continue
|
||||
set i
|
||||
}] $x
|
||||
}}
|
||||
} {b 4}
|
||||
test lmap-6.3 {break tests} {
|
||||
apply {{} {
|
||||
list [lmap i {a b c d} {
|
||||
incr x
|
||||
if {[string compare $i "c"] == 0} break
|
||||
set i
|
||||
}] $x
|
||||
}}
|
||||
} {{a b} 3}
|
||||
# Check for bug similar to #406709
|
||||
test lmap-6.4 {break tests} {
|
||||
apply {{} {
|
||||
set a 1
|
||||
lmap b b {list [concat a; break]; incr a}
|
||||
incr a
|
||||
}}
|
||||
} {2}
|
||||
|
||||
# ----- Special cases and bugs -----------------------------------------------
|
||||
test lmap-7.1 {compiled lmap backward jump works correctly} -setup {
|
||||
unset -nocomplain x
|
||||
} -body {
|
||||
array set x {0 zero 1 one 2 two 3 three}
|
||||
lsort [apply {{arrayName} {
|
||||
upvar 1 $arrayName a
|
||||
lmap member [array names a] {
|
||||
list $member [set a($member)]
|
||||
}
|
||||
}} x]
|
||||
} -result [lsort {{0 zero} {1 one} {2 two} {3 three}}]
|
||||
test lmap-7.2 {noncompiled lmap and shared variable or value list objects that are converted to another type} -setup {
|
||||
unset -nocomplain x
|
||||
} -body {
|
||||
lmap {12.0} {a b c} {
|
||||
set x 12.0
|
||||
set x [expr $x + 1]
|
||||
}
|
||||
} -result {13.0 13.0 13.0}
|
||||
# Test for incorrect "double evaluation" semantics
|
||||
test lmap-7.3 {delayed substitution of body} {
|
||||
apply {{} {
|
||||
set a 0
|
||||
lmap a [list 1 2 3] "
|
||||
set x $a
|
||||
"
|
||||
return $x
|
||||
}}
|
||||
} {0}
|
||||
# Related to "foreach" test for [Bug 1189274]; crash on failure
|
||||
test lmap-7.4 {empty list handling} {
|
||||
proc crash {} {
|
||||
rename crash {}
|
||||
set a "x y z"
|
||||
set b ""
|
||||
lmap aa $a bb $b { set x "aa = $aa bb = $bb" }
|
||||
}
|
||||
crash
|
||||
} {{aa = x bb = } {aa = y bb = } {aa = z bb = }}
|
||||
# Related to [Bug 1671138]; infinite loop with empty var list in bytecompiled
|
||||
# version.
|
||||
test lmap-7.5 {compiled empty var list} -returnCodes error -body {
|
||||
proc foo {} {
|
||||
lmap {} x {
|
||||
error "reached body"
|
||||
}
|
||||
}
|
||||
foo
|
||||
} -cleanup {
|
||||
catch {rename foo ""}
|
||||
} -result {lmap varlist is empty}
|
||||
test lmap-7.6 {lmap: related to "foreach" [Bug 1671087]} -setup {
|
||||
proc demo {} {
|
||||
set vals {1 2 3 4}
|
||||
trace add variable x write {string length $vals ;# }
|
||||
lmap {x y} $vals {format $y}
|
||||
}
|
||||
} -body {
|
||||
demo
|
||||
} -cleanup {
|
||||
rename demo {}
|
||||
} -result {2 4}
|
||||
# Huge lists must not overflow the bytecode interpreter (development bug)
|
||||
test lmap-7.7 {huge list non-compiled} -setup {
|
||||
unset -nocomplain a b x
|
||||
} -body {
|
||||
set x [lmap a [lrepeat 1000000 x] { set b y$a }]
|
||||
list $b [llength $x] [string length $x]
|
||||
} -result {yx 1000000 2999999}
|
||||
test lmap-7.8 {huge list compiled} -setup {
|
||||
unset -nocomplain a b x
|
||||
} -body {
|
||||
set x [apply {{times} {
|
||||
global b
|
||||
lmap a [lrepeat $times x] { set b Y$a }
|
||||
}} 1000000]
|
||||
list $b [llength $x] [string length $x]
|
||||
} -result {Yx 1000000 2999999}
|
||||
test lmap-7.9 {error then dereference loop var (dev bug)} {
|
||||
catch { lmap a 0 b {1 2 3} { error x } }
|
||||
set a
|
||||
} 0
|
||||
test lmap-7.9a {error then dereference loop var (dev bug)} {
|
||||
catch { lmap a 0 b {1 2 3} { incr a $b; error x } }
|
||||
set a
|
||||
} 1
|
||||
|
||||
# ----- Coroutines -----------------------------------------------------------
|
||||
test lmap-8.1 {lmap non-compiled with coroutines} -body {
|
||||
coroutine coro apply {{} {
|
||||
set values [yield [info coroutine]]
|
||||
eval lmap i [list $values] {{ yield $i }}
|
||||
}} ;# returns 'coro'
|
||||
coro {a b c d e f} ;# -> a
|
||||
coro 1 ;# -> b
|
||||
coro 2 ;# -> c
|
||||
coro 3 ;# -> d
|
||||
coro 4 ;# -> e
|
||||
coro 5 ;# -> f
|
||||
list [coro 6] [info commands coro]
|
||||
} -cleanup {
|
||||
catch {rename coro ""}
|
||||
} -result {{1 2 3 4 5 6} {}}
|
||||
test lmap-8.2 {lmap compiled with coroutines} -body {
|
||||
coroutine coro apply {{} {
|
||||
set values [yield [info coroutine]]
|
||||
lmap i $values { yield $i }
|
||||
}} ;# returns 'coro'
|
||||
coro {a b c d e f} ;# -> a
|
||||
coro 1 ;# -> b
|
||||
coro 2 ;# -> c
|
||||
coro 3 ;# -> d
|
||||
coro 4 ;# -> e
|
||||
coro 5 ;# -> f
|
||||
list [coro 6] [info commands coro]
|
||||
} -cleanup {
|
||||
catch {rename coro ""}
|
||||
} -result {{1 2 3 4 5 6} {}}
|
||||
|
||||
# cleanup
|
||||
unset -nocomplain a x
|
||||
catch {rename foo {}}
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# End:
|
||||
248
tests/load.test
Normal file
248
tests/load.test
Normal file
@@ -0,0 +1,248 @@
|
||||
# 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::*
|
||||
}
|
||||
|
||||
::tcltest::loadTestedCommands
|
||||
catch [list package require -exact Tcltest [info patchlevel]]
|
||||
|
||||
# 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 ?-global? ?-lazy? ?--? fileName ?packageName? ?interp?\"}"
|
||||
test load-1.2 {basic errors} {} {
|
||||
list [catch {load a b c d} msg] $msg
|
||||
} "1 {wrong \# args: should be \"load ?-global? ?-lazy? ?--? 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 -global {}} msg] $msg
|
||||
} {1 {must specify either file name or package name}}
|
||||
test load-1.5 {basic errors} {} {
|
||||
list [catch {load -lazy {} {}} 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-1.7 {basic errors} {} {
|
||||
list [catch {load -abc foo} msg] $msg
|
||||
} "1 {bad option \"-abc\": must be -global, -lazy, or --}"
|
||||
test load-1.8 {basic errors} {} {
|
||||
list [catch {load -global} msg] $msg
|
||||
} "1 {couldn't figure out package name for -global}"
|
||||
|
||||
test load-2.1 {basic loading, with guess for package name} \
|
||||
[list $dll $loaded] {
|
||||
load -global [file join $testDir pkga$ext]
|
||||
list [pkga_eq abc def] [lsort [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 -lazy [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 $errorCode
|
||||
} -match glob \
|
||||
-result [list 1 {cannot find symbol "Foo_Init"*} \
|
||||
{TCL LOOKUP LOAD_SYMBOL *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} -setup {
|
||||
catch {load [file join $testDir pkga$ext] pkga}
|
||||
} -constraints [list $dll $loaded] -returnCodes error -body {
|
||||
load [file join $testDir pkga$ext] pkgb
|
||||
} -result "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 -global [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}
|
||||
catch {load [file join $testDir pkga$ext] pkga}
|
||||
catch {load [file join $testDir pkgb$ext] pkgb}
|
||||
catch {load [file join $testDir pkge$ext] pkge}
|
||||
set currentRealPackages [list [list [file join $testDir pkge$ext] Pkge] [list [file join $testDir pkgb$ext] Pkgb] [list [file join $testDir pkga$ext] Pkga]]
|
||||
test load-7.4 {Tcl_StaticPackage procedure, redundant calls} -setup {
|
||||
teststaticpkg Test 1 0
|
||||
teststaticpkg Another 0 0
|
||||
teststaticpkg More 0 1
|
||||
} -constraints [list teststaticpkg $dll $loaded] -body {
|
||||
teststaticpkg Double 0 1
|
||||
teststaticpkg Double 0 1
|
||||
info loaded
|
||||
} -result [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealPackages {*}$alreadyTotalLoaded]
|
||||
|
||||
teststaticpkg Test 1 1
|
||||
teststaticpkg Another 0 1
|
||||
teststaticpkg More 0 1
|
||||
teststaticpkg Double 0 1
|
||||
test load-8.1 {TclGetLoadedPackages procedure} [list teststaticpkg $dll $loaded] {
|
||||
lsort -index 1 [info loaded]
|
||||
} [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealPackages {*}$alreadyTotalLoaded]]
|
||||
test load-8.2 {TclGetLoadedPackages procedure} -body {
|
||||
info loaded gorp
|
||||
} -returnCodes error -result {could not find interpreter "gorp"}
|
||||
test load-8.3a {TclGetLoadedPackages procedure} [list teststaticpkg $dll $loaded] {
|
||||
lsort -index 1 [info loaded {}]
|
||||
} [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga] [list [file join $testDir pkgb$ext] Pkgb] {*}$alreadyLoaded]]
|
||||
test load-8.3b {TclGetLoadedPackages procedure} [list teststaticpkg $dll $loaded] {
|
||||
lsort -index 1 [info loaded child]
|
||||
} [lsort -index 1 [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 [lsort -index 1 [info loaded {}]] [lsort [info commands pkgb_*]]
|
||||
} [list [lsort -index 1 [concat [list [list [file join $testDir pkgb$ext] Pkgb] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded]] {pkgb_demo 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 {} }]
|
||||
} \
|
||||
-match glob -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}
|
||||
|
||||
test load-11.1 {Load TclOO extension using Stubs (Bug [f51efe99a7])} \
|
||||
[list $dll $loaded] {
|
||||
load [file join $testDir pkgooa$ext]
|
||||
list [pkgooa_stubsok] [lsort [info commands pkgooa_*]]
|
||||
} {1 pkgooa_stubsok}
|
||||
|
||||
# cleanup
|
||||
unset ext
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# End:
|
||||
100
tests/lrange.test
Normal file
100
tests/lrange.test
Normal file
@@ -0,0 +1,100 @@
|
||||
# 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 \{\ "}
|
||||
# emacs highlighting bug workaround --> "
|
||||
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}}
|
||||
|
||||
test lrange-3.1 {Bug 3588366: end-offsets before start} {
|
||||
apply {l {
|
||||
lrange $l 0 end-5
|
||||
}} {1 2 3 4 5}
|
||||
} {}
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# End:
|
||||
84
tests/lrepeat.test
Normal file
84
tests/lrepeat.test
Normal file
@@ -0,0 +1,84 @@
|
||||
# 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 count ?value ...?"}
|
||||
}
|
||||
test lrepeat-1.2 {Accept zero elements(TIP 323)} {
|
||||
-body {
|
||||
lrepeat 1
|
||||
}
|
||||
-result {}
|
||||
}
|
||||
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 {bad count "-3": must be integer >= 0}
|
||||
}
|
||||
test lrepeat-1.5 {Accept zero repetitions (TIP 323)} {
|
||||
-body {
|
||||
lrepeat 0
|
||||
}
|
||||
-result {}
|
||||
}
|
||||
test lrepeat-1.6 {error cases} {
|
||||
-body {
|
||||
lrepeat 3.5 1
|
||||
}
|
||||
-returnCodes 1
|
||||
-result {expected integer but got "3.5"}
|
||||
}
|
||||
test lrepeat-1.7 {Accept zero repetitions (TIP 323)} {
|
||||
-body {
|
||||
lrepeat 0 a b c
|
||||
}
|
||||
-result {}
|
||||
}
|
||||
test lrepeat-1.8 {Do not build enormous lists - Bug 2130992} -body {
|
||||
lrepeat 0x10000000 a b c d e f g h
|
||||
} -returnCodes error -match glob -result *
|
||||
|
||||
## 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
|
||||
240
tests/lreplace.test
Normal file
240
tests/lreplace.test
Normal file
@@ -0,0 +1,240 @@
|
||||
# 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-1.27 {lreplace command} {
|
||||
lreplace x 1 1
|
||||
} x
|
||||
test lreplace-1.28 {lreplace command} {
|
||||
lreplace x 1 1 y
|
||||
} {x y}
|
||||
|
||||
test lreplace-2.1 {lreplace errors} {
|
||||
list [catch lreplace msg] $msg
|
||||
} {1 {wrong # args: should be "lreplace list first last ?element ...?"}}
|
||||
test lreplace-2.2 {lreplace errors} {
|
||||
list [catch {lreplace a b} msg] $msg
|
||||
} {1 {wrong # args: should be "lreplace list first last ?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 2 2} msg] $msg
|
||||
} {1 {list doesn't contain element 2}}
|
||||
|
||||
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"
|
||||
|
||||
test lreplace-4.1 {Bug ccc2c2cc98: lreplace edge case} {
|
||||
lreplace {} 1 1
|
||||
} {}
|
||||
test lreplace-4.2 {Bug ccc2c2cc98: lreplace edge case} {
|
||||
lreplace { } 1 1
|
||||
} {}
|
||||
test lreplace-4.3 {lreplace edge case} {
|
||||
lreplace {1 2 3} 2 0
|
||||
} {1 2 3}
|
||||
test lreplace-4.4 {lreplace edge case} {
|
||||
lreplace {1 2 3 4 5} 3 1
|
||||
} {1 2 3 4 5}
|
||||
test lreplace-4.5 {lreplace edge case} {
|
||||
lreplace {1 2 3 4 5} 3 0 _
|
||||
} {1 2 3 _ 4 5}
|
||||
test lreplace-4.6 {lreplace end-x: bug a4cb3f06c4} {
|
||||
lreplace {0 1 2 3 4} 0 end-2
|
||||
} {3 4}
|
||||
test lreplace-4.6.1 {lreplace end-x: bug a4cb3f06c4} {
|
||||
lreplace {0 1 2 3 4} 0 end-2 a b c
|
||||
} {a b c 3 4}
|
||||
test lreplace-4.7 {lreplace with two end-indexes: increasing} {
|
||||
lreplace {0 1 2 3 4} end-2 end-1
|
||||
} {0 1 4}
|
||||
test lreplace-4.7.1 {lreplace with two end-indexes: increasing} {
|
||||
lreplace {0 1 2 3 4} end-2 end-1 a b c
|
||||
} {0 1 a b c 4}
|
||||
test lreplace-4.8 {lreplace with two end-indexes: equal} {
|
||||
lreplace {0 1 2 3 4} end-2 end-2
|
||||
} {0 1 3 4}
|
||||
test lreplace-4.8.1 {lreplace with two end-indexes: equal} {
|
||||
lreplace {0 1 2 3 4} end-2 end-2 a b c
|
||||
} {0 1 a b c 3 4}
|
||||
test lreplace-4.9 {lreplace with two end-indexes: decreasing} {
|
||||
lreplace {0 1 2 3 4} end-2 end-3
|
||||
} {0 1 2 3 4}
|
||||
test lreplace-4.9.1 {lreplace with two end-indexes: decreasing} {
|
||||
lreplace {0 1 2 3 4} end-2 end-3 a b c
|
||||
} {0 1 a b c 2 3 4}
|
||||
test lreplace-4.10 {lreplace with two equal indexes} {
|
||||
lreplace {0 1 2 3 4} 2 2
|
||||
} {0 1 3 4}
|
||||
test lreplace-4.10.1 {lreplace with two equal indexes} {
|
||||
lreplace {0 1 2 3 4} 2 2 a b c
|
||||
} {0 1 a b c 3 4}
|
||||
test lreplace-4.11 {lreplace end index first} {
|
||||
lreplace {0 1 2 3 4} end-2 1 a b c
|
||||
} {0 1 a b c 2 3 4}
|
||||
test lreplace-4.12 {lreplace end index first} {
|
||||
lreplace {0 1 2 3 4} end-2 2 a b c
|
||||
} {0 1 a b c 3 4}
|
||||
test lreplace-4.13 {lreplace empty list} {
|
||||
lreplace {} 1 1 1
|
||||
} 1
|
||||
test lreplace-4.14 {lreplace empty list} {
|
||||
lreplace {} 2 2 2
|
||||
} 2
|
||||
|
||||
test lreplace-5.1 {compiled lreplace: Bug 47ac84309b} {
|
||||
apply {x {
|
||||
lreplace $x end 0
|
||||
}} {a b c}
|
||||
} {a b c}
|
||||
test lreplace-5.2 {compiled lreplace: Bug 47ac84309b} {
|
||||
apply {x {
|
||||
lreplace $x end 0 A
|
||||
}} {a b c}
|
||||
} {a b A c}
|
||||
|
||||
# Testing for compiled behaviour. Far too many variations to check with
|
||||
# spelt-out tests. Note that this *just* checks whether the compiled version
|
||||
# and the interpreted version are the same, not whether the interpreted
|
||||
# version is correct.
|
||||
apply {{} {
|
||||
set lss {{} {a} {a b c} {a b c d}}
|
||||
set ins {{} A {A B}}
|
||||
set idxs {-2 -1 0 1 2 3 end-3 end-2 end-1 end end+1 end+2}
|
||||
set lreplace lreplace
|
||||
|
||||
foreach ls $lss {
|
||||
foreach a $idxs {
|
||||
foreach b $idxs {
|
||||
foreach i $ins {
|
||||
set expected [list [catch {$lreplace $ls $a $b {*}$i} m] $m]
|
||||
set tester [list lreplace $ls $a $b {*}$i]
|
||||
set script [list catch $tester m]
|
||||
set script "list \[$script\] \$m"
|
||||
test lreplace-6.[incr n] {lreplace battery} \
|
||||
[list apply [list {} $script]] $expected
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}}
|
||||
|
||||
# cleanup
|
||||
catch {unset foo}
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# End:
|
||||
528
tests/lsearch.test
Normal file
528
tests/lsearch.test
Normal file
@@ -0,0 +1,528 @@
|
||||
# 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 {"::tcltest" ni [namespace children]} {
|
||||
package require tcltest 2
|
||||
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} -returnCodes error -body {
|
||||
lsearch -regexp {xyz bbcc *bc*} *bc*
|
||||
} -result {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} -returnCodes error -body {
|
||||
lsearch -glib {b.x bx xy bcx} b.x
|
||||
} -result {bad option "-glib": must be -all, -ascii, -bisect, -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} -returnCodes error -body {
|
||||
lsearch
|
||||
} -result {wrong # args: should be "lsearch ?-option value ...? list pattern"}
|
||||
test lsearch-3.2 {lsearch errors} -returnCodes error -body {
|
||||
lsearch a
|
||||
} -result {wrong # args: should be "lsearch ?-option value ...? list pattern"}
|
||||
test lsearch-3.3 {lsearch errors} -returnCodes error -body {
|
||||
lsearch a b c
|
||||
} -result {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}
|
||||
test lsearch-3.4 {lsearch errors} -returnCodes error -body {
|
||||
lsearch a b c d
|
||||
} -result {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}
|
||||
test lsearch-3.5 {lsearch errors} -returnCodes error -body {
|
||||
lsearch "\{" b
|
||||
} -result {unmatched open brace in list}
|
||||
test lsearch-3.6 {lsearch errors} -returnCodes error -body {
|
||||
lsearch -index a b
|
||||
} -result {"-index" option must be followed by list index}
|
||||
test lsearch-3.7 {lsearch errors} -returnCodes error -body {
|
||||
lsearch -subindices -exact a b
|
||||
} -result {-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} -returnCodes error -body {
|
||||
lsearch -start foobar {a b c a b c} a
|
||||
} -result {bad index "foobar": must be integer?[+-]integer? or end?[+-]integer?}
|
||||
test lsearch-10.5 {offset searching} -returnCodes error -body {
|
||||
lsearch -start 1 2
|
||||
} -result {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} -body {
|
||||
lsearch -index 2 {{a c} {a b} {a a}} a
|
||||
} -returnCodes error -result {element 2 missing from sublist "a c"}
|
||||
test lsearch-20.2 {lsearch -index option, malformed index} -body {
|
||||
lsearch -index foo {{a c} {a b} {a a}} a
|
||||
} -returnCodes error -result {bad index "foo": must be integer?[+-]integer? or end?[+-]integer?}
|
||||
test lsearch-20.3 {lsearch -index option, malformed index} -body {
|
||||
lsearch -index \{ {{a c} {a b} {a a}} a
|
||||
} -returnCodes error -result {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
|
||||
|
||||
test lsearch-22.1 {lsearch -bisect} -setup {
|
||||
set res {}
|
||||
} -body {
|
||||
foreach i {0 1 5 6 7 8 15 16} {
|
||||
lappend res [lsearch -bisect -integer {1 4 5 7 9 15} $i]
|
||||
}
|
||||
return $res
|
||||
} -result {-1 0 2 2 3 3 5 5}
|
||||
test lsearch-22.2 {lsearch -bisect, last of equals} -setup {
|
||||
set res {}
|
||||
} -body {
|
||||
foreach i {0 1 2 3} {
|
||||
lappend res [lsearch -bisect -integer {0 0 1 1 1 2 2 2 3 3 3} $i]
|
||||
}
|
||||
return $res
|
||||
} -result {1 4 7 10}
|
||||
test lsearch-22.3 {lsearch -bisect decreasing order} -setup {
|
||||
set res {}
|
||||
} -body {
|
||||
foreach i {0 1 5 6 7 8 15 16} {
|
||||
lappend res [lsearch -bisect -integer -decreasing {15 9 7 5 4 1} $i]
|
||||
}
|
||||
return $res
|
||||
} -result {5 5 3 2 2 1 0 -1}
|
||||
test lsearch-22.4 {lsearch -bisect, last of equals, decreasing} -setup {
|
||||
set res {}
|
||||
} -body {
|
||||
foreach i {0 1 2 3} {
|
||||
lappend res [lsearch -bisect -integer -decreasing \
|
||||
{3 3 3 2 2 2 1 1 1 0 0} $i]
|
||||
}
|
||||
return $res
|
||||
} -result {10 8 5 2}
|
||||
test lsearch-22.5 {lsearch -bisect, all equal} {
|
||||
lsearch -bisect -integer {5 5 5 5} 5
|
||||
} {3}
|
||||
test lsearch-22.6 {lsearch -sorted, all equal} {
|
||||
lsearch -sorted -integer {5 5 5 5} 5
|
||||
} {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
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# End:
|
||||
481
tests/lset.test
Normal file
481
tests/lset.test
Normal file
@@ -0,0 +1,481 @@
|
||||
# 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::*
|
||||
}
|
||||
|
||||
::tcltest::loadTestedCommands
|
||||
catch [list package require -exact Tcltest [info patchlevel]]
|
||||
|
||||
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 4] w}
|
||||
} msg] $msg
|
||||
} {1 {list index out of range}}
|
||||
test lset-4.5a {lset, not compiled, 3 args, index out of range} testevalex {
|
||||
set a {x y z}
|
||||
list [catch {
|
||||
testevalex {lset a [list end--2] w}
|
||||
} msg] $msg
|
||||
} {1 {list index out of range}}
|
||||
test lset-4.5b {lset, not compiled, 3 args, index out of range} testevalex {
|
||||
set a {x y z}
|
||||
list [catch {
|
||||
testevalex {lset a [list end+2] 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 4 w}
|
||||
} msg] $msg
|
||||
} {1 {list index out of range}}
|
||||
test lset-4.11a {lset, not compiled, 3 args, index out of range} testevalex {
|
||||
set a {x y z}
|
||||
list [catch {
|
||||
testevalex {lset a end--2 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+2 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 3 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 3} h}} msg] $msg
|
||||
} {1 {list index out of range}}
|
||||
test lset-8.9a {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.9b {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.10a {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.10b {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.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
|
||||
|
||||
test lset-16.1 {lset - grow a variable} testevalex {
|
||||
set x {}
|
||||
testevalex {lset x 0 {test 1}}
|
||||
testevalex {lset x 1 {test 2}}
|
||||
set x
|
||||
} {{test 1} {test 2}}
|
||||
test lset-16.2 {lset - multiple created sublists} testevalex {
|
||||
set x {}
|
||||
testevalex {lset x 0 0 {test 1}}
|
||||
} {{{test 1}}}
|
||||
test lset-16.3 {lset - sublists 3 deep} testevalex {
|
||||
set x {}
|
||||
testevalex {lset x 0 0 0 {test 1}}
|
||||
} {{{{test 1}}}}
|
||||
test lset-16.4 {lset - append to inner list} testevalex {
|
||||
set x {test 1}
|
||||
testevalex {lset x 1 1 2}
|
||||
testevalex {lset x 1 2 3}
|
||||
testevalex {lset x 1 2 1 4}
|
||||
} {test {1 2 {3 4}}}
|
||||
|
||||
test lset-16.5 {lset - grow a variable} testevalex {
|
||||
set x {}
|
||||
testevalex {lset x end+1 {test 1}}
|
||||
testevalex {lset x end+1 {test 2}}
|
||||
set x
|
||||
} {{test 1} {test 2}}
|
||||
test lset-16.6 {lset - multiple created sublists} testevalex {
|
||||
set x {}
|
||||
testevalex {lset x end+1 end+1 {test 1}}
|
||||
} {{{test 1}}}
|
||||
test lset-16.7 {lset - sublists 3 deep} testevalex {
|
||||
set x {}
|
||||
testevalex {lset x end+1 end+1 end+1 {test 1}}
|
||||
} {{{{test 1}}}}
|
||||
test lset-16.8 {lset - append to inner list} testevalex {
|
||||
set x {test 1}
|
||||
testevalex {lset x end end+1 2}
|
||||
testevalex {lset x end end+1 3}
|
||||
testevalex {lset x end end end+1 4}
|
||||
} {test {1 2 {3 4}}}
|
||||
|
||||
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
|
||||
1297
tests/main.test
Normal file
1297
tests/main.test
Normal file
File diff suppressed because it is too large
Load Diff
1340
tests/mathop.test
Normal file
1340
tests/mathop.test
Normal file
File diff suppressed because it is too large
Load Diff
74
tests/misc.test
Normal file
74
tests/misc.test
Normal file
@@ -0,0 +1,74 @@
|
||||
# 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::*
|
||||
}
|
||||
|
||||
::tcltest::loadTestedCommands
|
||||
catch [list package require -exact Tcltest [info patchlevel]]
|
||||
|
||||
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 $\{"
|
||||
(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
|
||||
1085
tests/msgcat.test
Normal file
1085
tests/msgcat.test
Normal file
File diff suppressed because it is too large
Load Diff
861
tests/namespace-old.test
Normal file
861
tests/namespace-old.test
Normal file
@@ -0,0 +1,861 @@
|
||||
# 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 {"::tcltest" ni [namespace children]} {
|
||||
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"
|
||||
}
|
||||
}
|
||||
} {}
|
||||
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
|
||||
}
|
||||
}
|
||||
} ""
|
||||
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}
|
||||
} {}
|
||||
# Redeclare; later tests depend on it
|
||||
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}}
|
||||
namespace eval test_ns_delete {
|
||||
namespace eval ns1 {}
|
||||
namespace eval ns2 {}
|
||||
namespace eval another {}
|
||||
}
|
||||
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}
|
||||
set ::test_ns_var_global "var in ::"
|
||||
proc test_ns_cmd_global {} {return "cmd in ::"}
|
||||
namespace eval test_ns_hier1 {
|
||||
variable test_ns_var_hier1 "particular to hier1"
|
||||
proc test_ns_cmd_hier1 {} {return "particular to hier1"}
|
||||
variable test_ns_level 1
|
||||
proc test_ns_show {} {return "[namespace current]: 1"}
|
||||
namespace eval test_ns_hier2 {
|
||||
variable test_ns_var_hier2 "particular to hier2"
|
||||
proc test_ns_cmd_hier2 {} {return "particular to hier2"}
|
||||
variable 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.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
|
||||
# -----------------------------------------------------------------------
|
||||
set trigger {namespace eval test_ns_cache2 {namespace current}}
|
||||
set trigger2 {namespace eval test_ns_cache2::test_ns_cache3 {namespace current}}
|
||||
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 {}
|
||||
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}
|
||||
namespace eval test_ns_cache1::test_ns_cache2 {}
|
||||
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}
|
||||
namespace eval test_ns_cache1 {
|
||||
proc trigger {} {test_ns_cache_cmd}
|
||||
}
|
||||
test namespace-old-6.5 {define test commands} {
|
||||
proc test_ns_cache_cmd {} {
|
||||
return "global version"
|
||||
}
|
||||
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}
|
||||
proc test_ns_cache_cmd {} {
|
||||
return "global version"
|
||||
}
|
||||
test namespace-old-6.7 {renaming commands changes command epoch} -setup {
|
||||
proc test_ns_cache1::test_ns_cache_cmd {} {
|
||||
return "cache1 version"
|
||||
}
|
||||
} -body {
|
||||
list [test_ns_cache1::trigger] \
|
||||
[namespace eval test_ns_cache1 {rename test_ns_cache_cmd test_ns_new}]\
|
||||
[test_ns_cache1::trigger]
|
||||
} -result {{cache1 version} {} {global version}}
|
||||
test namespace-old-6.8 {renaming back handles shadowing} -setup {
|
||||
proc test_ns_cache1::test_ns_new {} {
|
||||
return "cache1 version"
|
||||
}
|
||||
} -body {
|
||||
list [test_ns_cache1::trigger] \
|
||||
[namespace eval test_ns_cache1 {rename test_ns_new test_ns_cache_cmd}]\
|
||||
[test_ns_cache1::trigger]
|
||||
} -result {{global version} {} {cache1 version}}
|
||||
test namespace-old-6.9 {deleting commands changes command epoch} -setup {
|
||||
proc test_ns_cache1::test_ns_cache_cmd {} {
|
||||
return "cache1 version"
|
||||
}
|
||||
} -body {
|
||||
list [test_ns_cache1::trigger] \
|
||||
[namespace eval test_ns_cache1 {rename test_ns_cache_cmd ""}] \
|
||||
[test_ns_cache1::trigger]
|
||||
} -result {{cache1 version} {} {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}}
|
||||
namespace eval test_ns_cache1 {
|
||||
proc trigger {} { test_ns_cache2::test_ns_cache_cmd }
|
||||
namespace eval test_ns_cache2 {
|
||||
proc trigger {} { test_ns_cache_cmd }
|
||||
}
|
||||
}
|
||||
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}
|
||||
set trigger {set test_ns_cache_var}
|
||||
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}
|
||||
variable ::test_ns_cache_var "global version"
|
||||
test namespace-old-6.14 {deleting variables changes variable epoch} {
|
||||
namespace eval test_ns_cache1 {
|
||||
variable test_ns_cache_var "cache1 version"
|
||||
}
|
||||
list [namespace eval test_ns_cache1 $trigger] \
|
||||
[namespace eval test_ns_cache1 {unset test_ns_cache_var}] \
|
||||
[namespace eval test_ns_cache1 $trigger]
|
||||
} {{cache1 version} {} {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}}
|
||||
set trigger2 {set test_ns_cache2::test_ns_cache_var}
|
||||
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}
|
||||
} {}
|
||||
variable test_ns_cache1::test_ns_cache2::test_ns_cache_var "cache2 version"
|
||||
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\] "
|
||||
}
|
||||
}
|
||||
} {}
|
||||
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 {"x" in [test_ns_uplevel::test_uplevel 1]}] \
|
||||
[expr {"y" in [test_ns_uplevel::test_uplevel 1]}]
|
||||
} {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 {"x" in [test_ns_uplevel::test_uplevel #2]}] \
|
||||
[expr {"y" in [test_ns_uplevel::test_uplevel #2]}]
|
||||
} {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\] "
|
||||
}
|
||||
}
|
||||
} {}
|
||||
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}
|
||||
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"}
|
||||
}
|
||||
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}
|
||||
namespace eval test_ns_import {
|
||||
namespace export cmd1 cmd2
|
||||
namespace import ::test_ns_export::*
|
||||
}
|
||||
test namespace-old-9.5 {empty import list in "namespace import" command} {
|
||||
namespace eval test_ns_import_empty {
|
||||
namespace import ::test_ns_export::*
|
||||
try {
|
||||
lsort [namespace import]
|
||||
} finally {
|
||||
namespace delete [namespace current]
|
||||
}
|
||||
}
|
||||
} {cmd1 cmd2 cmd3}
|
||||
# there is no namespace-old-9.6
|
||||
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}
|
||||
namespace import test_ns_import::cmd*
|
||||
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}
|
||||
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::*
|
||||
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}
|
||||
catch { rename cmd1 "" }
|
||||
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} {
|
||||
proc cmd1 {x y} { return [expr $x+$y] }
|
||||
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}
|
||||
namespace eval test_ns_inscope {
|
||||
proc show {args} {
|
||||
return "show: $args"
|
||||
}
|
||||
}
|
||||
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}}
|
||||
namespace eval test_ns_inscope {
|
||||
variable x "x-value"
|
||||
}
|
||||
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
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# End:
|
||||
3282
tests/namespace.test
Normal file
3282
tests/namespace.test
Normal file
File diff suppressed because it is too large
Load Diff
327
tests/notify.test
Normal file
327
tests/notify.test
Normal file
@@ -0,0 +1,327 @@
|
||||
# -*- 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::*
|
||||
}
|
||||
|
||||
::tcltest::loadTestedCommands
|
||||
catch [list package require -exact Tcltest [info patchlevel]]
|
||||
|
||||
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
|
||||
451
tests/nre.test
Normal file
451
tests/nre.test
Normal file
@@ -0,0 +1,451 @@
|
||||
# Commands covered: proc, apply, [interp alias], [namespce import]
|
||||
#
|
||||
# This file contains a collection of tests for the non-recursive executor that
|
||||
# avoids recursive calls to TEBC. Only the NRE behaviour is tested here, the
|
||||
# actual command functionality is tested in the specific test file.
|
||||
#
|
||||
# Copyright (c) 2008 by 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
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
::tcltest::loadTestedCommands
|
||||
catch [list package require -exact Tcltest [info patchlevel]]
|
||||
|
||||
testConstraint testnrelevels [llength [info commands testnrelevels]]
|
||||
|
||||
#
|
||||
# The tests that risked blowing the C stack on failure have been removed: we
|
||||
# can now actually measure using testnrelevels.
|
||||
#
|
||||
|
||||
if {[testConstraint testnrelevels]} {
|
||||
namespace eval testnre {
|
||||
namespace path ::tcl::mathop
|
||||
#
|
||||
# [testnrelevels] returns a 6-list with: C-stack depth, iPtr->numlevels,
|
||||
# cmdFrame level, callFrame level, tosPtr and callback depth
|
||||
#
|
||||
variable last [testnrelevels]
|
||||
proc depthDiff {} {
|
||||
variable last
|
||||
set depth [testnrelevels]
|
||||
set res {}
|
||||
foreach t $depth l $last {
|
||||
lappend res [expr {$t-$l}]
|
||||
}
|
||||
set last $depth
|
||||
return $res
|
||||
}
|
||||
proc setabs {} {
|
||||
variable abs [- [lindex [testnrelevels] 0]]
|
||||
}
|
||||
|
||||
variable body0 {
|
||||
set x [depthDiff]
|
||||
if {[incr i] > 10} {
|
||||
namespace upvar [namespace qualifiers \
|
||||
[namespace origin depthDiff]] abs abs
|
||||
incr abs [lindex [testnrelevels] 0]
|
||||
return [list [lrange $x 0 3] $abs]
|
||||
}
|
||||
}
|
||||
proc makebody txt {
|
||||
variable body0
|
||||
return "$body0; $txt"
|
||||
}
|
||||
namespace export *
|
||||
}
|
||||
namespace import testnre::*
|
||||
}
|
||||
|
||||
test nre-0.1 {levels while unwinding} {
|
||||
testnreunwind
|
||||
} {0 0 0}
|
||||
|
||||
test nre-1.1 {self-recursive procs} -setup {
|
||||
proc a i [makebody {a $i}]
|
||||
} -body {
|
||||
setabs
|
||||
a 0
|
||||
} -cleanup {
|
||||
rename a {}
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 1 1 1} 0}
|
||||
test nre-1.2 {self-recursive lambdas} -setup {
|
||||
set a [list i [makebody {apply $::a $i}]]
|
||||
} -body {
|
||||
setabs
|
||||
apply $a 0
|
||||
} -cleanup {
|
||||
unset a
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 1 1 1} 0}
|
||||
test nre-1.3 {mutually recursive procs and lambdas} -setup {
|
||||
proc a i {
|
||||
apply $::b [incr i]
|
||||
}
|
||||
set b [list i [makebody {a $i}]]
|
||||
} -body {
|
||||
setabs
|
||||
a 0
|
||||
} -cleanup {
|
||||
rename a {}
|
||||
unset b
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 2 2 2} 0}
|
||||
|
||||
#
|
||||
# Test that aliases are non-recursive
|
||||
#
|
||||
|
||||
test nre-2.1 {alias is not recursive} -setup {
|
||||
proc a i [makebody {b $i}]
|
||||
interp alias {} b {} a
|
||||
} -body {
|
||||
setabs
|
||||
a 0
|
||||
} -cleanup {
|
||||
rename a {}
|
||||
rename b {}
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 2 1 1} 0}
|
||||
|
||||
#
|
||||
# Test that imports are non-recursive
|
||||
#
|
||||
|
||||
test nre-3.1 {imports are not recursive} -setup {
|
||||
namespace eval foo {
|
||||
setabs
|
||||
namespace export a
|
||||
}
|
||||
proc foo::a i [makebody {::a $i}]
|
||||
namespace import foo::a
|
||||
} -body {
|
||||
a 0
|
||||
} -cleanup {
|
||||
rename a {}
|
||||
namespace delete ::foo
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 2 1 1} 0}
|
||||
|
||||
test nre-4.1 {ensembles are not recursive} -setup {
|
||||
proc a i [makebody {b foo $i}]
|
||||
namespace ensemble create \
|
||||
-command b \
|
||||
-map [list foo a]
|
||||
} -body {
|
||||
setabs
|
||||
a 0
|
||||
} -cleanup {
|
||||
rename a {}
|
||||
rename b {}
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 2 1 1} 0}
|
||||
|
||||
test nre-4.2 {(compiled) ensembles do not break tailcall} -setup {
|
||||
# Fix Bug d87cb18205
|
||||
proc b {} {
|
||||
tailcall append result first
|
||||
}
|
||||
set map [namespace ensemble configure ::dict -map]
|
||||
dict set map a b
|
||||
namespace ensemble configure ::dict -map $map
|
||||
proc demo {} {
|
||||
dict a
|
||||
append result second
|
||||
}
|
||||
} -body {
|
||||
demo
|
||||
} -cleanup {
|
||||
rename demo {}
|
||||
namespace ensemble configure ::dict -map [dict remove $map a]
|
||||
unset map
|
||||
rename b {}
|
||||
} -result firstsecond
|
||||
|
||||
test nre-5.1 {[namespace eval] is not recursive} -setup {
|
||||
namespace eval ::foo {
|
||||
setabs
|
||||
}
|
||||
proc foo::a i [makebody {namespace eval ::foo [list a $i]}]
|
||||
} -body {
|
||||
::foo::a 0
|
||||
} -cleanup {
|
||||
namespace delete ::foo
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 2 2 2} 0}
|
||||
test nre-5.2 {[namespace eval] is not recursive} -setup {
|
||||
namespace eval ::foo {
|
||||
setabs
|
||||
}
|
||||
proc foo::a i [makebody {namespace eval ::foo "set x $i; a $i"}]
|
||||
} -body {
|
||||
foo::a 0
|
||||
} -cleanup {
|
||||
namespace delete ::foo
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 2 2 2} 0}
|
||||
|
||||
test nre-6.1 {[uplevel] is not recursive} -setup {
|
||||
proc a i [makebody {uplevel 1 [list a $i]}]
|
||||
} -body {
|
||||
setabs
|
||||
a 0
|
||||
} -cleanup {
|
||||
rename a {}
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 2 2 0} 0}
|
||||
test nre-6.2 {[uplevel] is not recursive} -setup {
|
||||
setabs
|
||||
proc a i [makebody {uplevel 1 "set x $i; a $i"}]
|
||||
} -body {
|
||||
a 0
|
||||
} -cleanup {
|
||||
rename a {}
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 2 2 0} 0}
|
||||
|
||||
test nre-7.1 {[catch] is not recursive} -setup {
|
||||
setabs
|
||||
proc a i [makebody {uplevel 1 "catch {a $i} msg; set msg"}]
|
||||
} -body {
|
||||
a 0
|
||||
} -cleanup {
|
||||
rename a {}
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 3 3 0} 0}
|
||||
test nre-7.2 {[if] is not recursive} -setup {
|
||||
setabs
|
||||
proc a i [makebody {uplevel 1 "if 1 {a $i}"}]
|
||||
} -body {
|
||||
a 0
|
||||
} -cleanup {
|
||||
rename a {}
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 2 2 0} 0}
|
||||
test nre-7.3 {[while] is not recursive} -setup {
|
||||
setabs
|
||||
proc a i [makebody {uplevel 1 "while 1 {set res \[a $i\]; break}; set res"}]
|
||||
} -body {
|
||||
a 0
|
||||
} -cleanup {
|
||||
rename a {}
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 2 2 0} 0}
|
||||
test nre-7.4 {[for] is not recursive} -setup {
|
||||
setabs
|
||||
proc a i [makebody {uplevel 1 "for {set j 0} {\$j < 10} {incr j} {set res \[a $i\]; break}; set res"}]
|
||||
} -body {
|
||||
a 0
|
||||
} -cleanup {
|
||||
rename a {}
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 2 2 0} 0}
|
||||
test nre-7.5 {[foreach] is not recursive} -setup {
|
||||
#
|
||||
# Enable once [foreach] is NR-enabled
|
||||
#
|
||||
setabs
|
||||
proc a i [makebody {uplevel 1 "foreach j {1 2 3 4 5 6} {set res \[a $i\]; break}; set res"}]
|
||||
} -body {
|
||||
a 0
|
||||
} -cleanup {
|
||||
rename a {}
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 3 3 0} 0}
|
||||
test nre-7.6 {[eval] is not recursive} -setup {
|
||||
proc a i [makebody {eval [list a $i]}]
|
||||
} -body {
|
||||
setabs
|
||||
a 0
|
||||
} -cleanup {
|
||||
rename a {}
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 2 2 1} 0}
|
||||
test nre-7.7 {[eval] is not recursive} -setup {
|
||||
proc a i [makebody {eval "a $i"}]
|
||||
} -body {
|
||||
setabs
|
||||
a 0
|
||||
} -cleanup {
|
||||
rename a {}
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 2 2 1} 0}
|
||||
test nre-7.8 {bug #2910748: switch out of stale BC is not nre-aware} -setup {
|
||||
proc foo args {}
|
||||
foo
|
||||
coroutine bar apply {{} {
|
||||
yield
|
||||
proc foo args {return ok}
|
||||
while 1 {
|
||||
yield [incr i]
|
||||
foo
|
||||
}
|
||||
}}
|
||||
} -body {
|
||||
# if switching to plain eval is not nre aware, this will cause a "cannot
|
||||
# yield" error
|
||||
list [bar] [bar] [bar]
|
||||
} -cleanup {
|
||||
rename bar {}
|
||||
rename foo {}
|
||||
} -result {1 2 3}
|
||||
|
||||
test nre-8.1 {nre and {*}} -body {
|
||||
# force an expansion that grows the evaluation stack, check that nre
|
||||
# adapts the TEBCdataPtr. This crashes on failure.
|
||||
proc inner {} {
|
||||
set long [lrepeat 1000000 1]
|
||||
list {*}$long
|
||||
}
|
||||
proc outer {} inner
|
||||
lrange [outer] 0 2
|
||||
} -cleanup {
|
||||
rename inner {}
|
||||
rename outer {}
|
||||
} -result {1 1 1}
|
||||
test nre-8.2 {nre and {*}, [Bug 2415422]} -body {
|
||||
# force an expansion that grows the evaluation stack, check that nre
|
||||
# adapts the bcFramePtr. This causes an NRE assertion to fail if it is not
|
||||
# done properly.
|
||||
proc nop {} {}
|
||||
proc crash {} {
|
||||
foreach val [list {*}[lrepeat 100000 x]] {
|
||||
nop
|
||||
}
|
||||
}
|
||||
crash
|
||||
} -cleanup {
|
||||
rename nop {}
|
||||
rename crash {}
|
||||
}
|
||||
|
||||
#
|
||||
# Basic TclOO tests
|
||||
#
|
||||
|
||||
test nre-oo.1 {really deep calls in oo - direct} -setup {
|
||||
oo::object create foo
|
||||
oo::objdefine foo method bar i [makebody {foo bar $i}]
|
||||
} -body {
|
||||
setabs
|
||||
foo bar 0
|
||||
} -cleanup {
|
||||
foo destroy
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 1 1 1} 0}
|
||||
test nre-oo.2 {really deep calls in oo - call via [self]} -setup {
|
||||
oo::object create foo
|
||||
oo::objdefine foo method bar i [makebody {[self] bar $i}]
|
||||
} -body {
|
||||
setabs
|
||||
foo bar 0
|
||||
} -cleanup {
|
||||
foo destroy
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 1 1 1} 0}
|
||||
test nre-oo.3 {really deep calls in oo - private calls} -setup {
|
||||
oo::object create foo
|
||||
oo::objdefine foo method bar i [makebody {my bar $i}]
|
||||
} -body {
|
||||
setabs
|
||||
foo bar 0
|
||||
} -cleanup {
|
||||
foo destroy
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 1 1 1} 0}
|
||||
test nre-oo.4 {really deep calls in oo - overriding} -setup {
|
||||
oo::class create foo {
|
||||
method bar i [makebody {my bar $i}]
|
||||
}
|
||||
oo::class create boo {
|
||||
superclass foo
|
||||
method bar i [makebody {next $i}]
|
||||
}
|
||||
} -body {
|
||||
setabs
|
||||
[boo new] bar 0
|
||||
} -cleanup {
|
||||
foo destroy
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 1 1 1} 0}
|
||||
test nre-oo.5 {really deep calls in oo - forwards} -setup {
|
||||
oo::object create foo
|
||||
set body [makebody {my boo $i}]
|
||||
oo::objdefine foo "
|
||||
method bar i {$body}
|
||||
forward boo ::foo bar
|
||||
"
|
||||
} -body {
|
||||
setabs
|
||||
foo bar 0
|
||||
} -cleanup {
|
||||
foo destroy
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 2 1 1} 0}
|
||||
|
||||
#
|
||||
# NASTY BUG found by tcllib's interp package
|
||||
#
|
||||
|
||||
test nre-X.1 {eval in wrong interp} -setup {
|
||||
set i [interp create]
|
||||
$i eval {proc filter lst {lsearch -all -inline -not $lst "::tcl"}}
|
||||
} -body {
|
||||
$i eval {
|
||||
set x {namespace children ::}
|
||||
set y [list namespace children ::]
|
||||
namespace delete {*}[filter [{*}$y]]
|
||||
set j [interp create]
|
||||
$j alias filter filter
|
||||
$j eval {namespace delete {*}[filter [namespace children ::]]}
|
||||
namespace eval foo {}
|
||||
list [filter [eval $x]] [filter [eval $y]] [filter [$j eval $x]] [filter [$j eval $y]]
|
||||
}
|
||||
} -cleanup {
|
||||
interp delete $i
|
||||
} -result {::foo ::foo {} {}}
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
|
||||
if {[testConstraint testnrelevels]} {
|
||||
namespace forget testnre::*
|
||||
namespace delete testnre
|
||||
}
|
||||
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# fill-column: 78
|
||||
# End:
|
||||
635
tests/obj.test
Normal file
635
tests/obj.test
Normal file
@@ -0,0 +1,635 @@
|
||||
# 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::*
|
||||
}
|
||||
|
||||
::tcltest::loadTestedCommands
|
||||
catch [list package require -exact Tcltest [info patchlevel]]
|
||||
|
||||
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} {
|
||||
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} {
|
||||
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
|
||||
3737
tests/oo.test
Normal file
3737
tests/oo.test
Normal file
File diff suppressed because it is too large
Load Diff
1065
tests/ooNext2.test
Normal file
1065
tests/ooNext2.test
Normal file
File diff suppressed because it is too large
Load Diff
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.6
|
||||
|
||||
# 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
|
||||
1279
tests/package.test
Normal file
1279
tests/package.test
Normal file
File diff suppressed because it is too large
Load Diff
1138
tests/parse.test
Normal file
1138
tests/parse.test
Normal file
File diff suppressed because it is too large
Load Diff
1079
tests/parseExpr.test
Normal file
1079
tests/parseExpr.test
Normal file
File diff suppressed because it is too large
Load Diff
552
tests/parseOld.test
Normal file
552
tests/parseOld.test
Normal file
@@ -0,0 +1,552 @@
|
||||
# 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 2
|
||||
namespace import ::tcltest::*
|
||||
|
||||
::tcltest::loadTestedCommands
|
||||
catch [list package require -exact Tcltest [info patchlevel]]
|
||||
|
||||
testConstraint testwordend [llength [info commands testwordend]]
|
||||
testConstraint testbytestring [llength [info commands testbytestring]]
|
||||
|
||||
# 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} testbytestring {
|
||||
expr {[list \ua2] eq [testbytestring "\xc2\xa2"]}
|
||||
} 1
|
||||
test parseOld-7.13 {backslash substitution} testbytestring {
|
||||
expr {[list \u4e21] eq [testbytestring "\xe4\xb8\xa1"]}
|
||||
} 1
|
||||
test parseOld-7.14 {backslash substitution} testbytestring {
|
||||
expr {[list \u4e2k] eq [testbytestring "\xd3\xa2k"]}
|
||||
} 1
|
||||
|
||||
# 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.
|
||||
|
||||
set a 22
|
||||
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
|
||||
# Duplicate action of previous test
|
||||
llength [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]]
|
||||
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
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# End:
|
||||
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
|
||||
698
tests/pkgMkIndex.test
Normal file
698
tests/pkgMkIndex.test
Normal file
@@ -0,0 +1,698 @@
|
||||
# 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]"
|
||||
append script \n \
|
||||
"[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
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# 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