summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorhobbs <hobbs>2000-01-12 11:13:25 (GMT)
committerhobbs <hobbs>2000-01-12 11:13:25 (GMT)
commitf0c936b8a5365ec18f126e2c15715509d64bb440 (patch)
tree82af689b665b52d5f4be35155ac4d08136341e92
parent406d6b83a7c5904f8364bca9dafa894901281bc2 (diff)
downloadtcl-f0c936b8a5365ec18f126e2c15715509d64bb440.zip
tcl-f0c936b8a5365ec18f126e2c15715509d64bb440.tar.gz
tcl-f0c936b8a5365ec18f126e2c15715509d64bb440.tar.bz2
* tests/info.test:
* generic/tclCmdIL.c: fixed 'info procs ::namesp::*' behavior (Dejong) * tests/unixFCmd.test: * unix/tclUnixFCmd.c: added support for symbolic permissions setting in SetPermissionsAttribute (file attr $file -perm ...) [Bug: 3970] * tests/utf.test: fixed test that allowed \8 as octal value
-rw-r--r--tests/expr.test5
-rw-r--r--tests/info.test60
-rw-r--r--tests/namespace.test6
-rw-r--r--tests/unixFCmd.test31
-rw-r--r--tests/utf.test6
5 files changed, 99 insertions, 9 deletions
diff --git a/tests/expr.test b/tests/expr.test
index 042002a..58fd168 100644
--- a/tests/expr.test
+++ b/tests/expr.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: expr.test,v 1.7 1999/12/04 06:16:48 hobbs Exp $
+# RCS: @(#) $Id: expr.test,v 1.8 2000/01/12 11:13:25 hobbs Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -647,6 +647,9 @@ test expr-18.1 {expr and conversion of operands to numbers} {
catch {expr int($x)}
expr {$x}
} 11
+test expr-18.2 {whitespace strings should not be == 0 (buggy strtod)} {
+ expr {" "}
+} { }
# Check "expr" and interpreter result object resetting before appending
# an error msg during evaluation of exprs not in {}s
diff --git a/tests/info.test b/tests/info.test
index 9297931..a9ba98b 100644
--- a/tests/info.test
+++ b/tests/info.test
@@ -11,7 +11,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: info.test,v 1.12 1999/12/12 02:27:03 hobbs Exp $
+# RCS: @(#) $Id: info.test,v 1.13 2000/01/12 11:13:25 hobbs Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -426,6 +426,64 @@ test info-15.4 {info procs option} {
list [info procs] [info procs p*]
}
} {{p q r} p}
+test info-15.5 {info procs option with a proc in a namespace} {
+ catch {namespace delete test_ns_info2}
+ namespace eval test_ns_info2 {
+ proc p1 { arg } {
+ puts cmd
+ }
+ proc p2 { arg } {
+ puts cmd
+ }
+ }
+ info procs ::test_ns_info2::p1
+} {::test_ns_info2::p1}
+test info-15.6 {info procs option with a pattern in a namespace} {
+ catch {namespace delete test_ns_info2}
+ namespace eval test_ns_info2 {
+ proc p1 { arg } {
+ puts cmd
+ }
+ proc p2 { arg } {
+ puts cmd
+ }
+ }
+ lsort [info procs ::test_ns_info2::p*]
+} [lsort [list ::test_ns_info2::p1 ::test_ns_info2::p2]]
+test info-15.7 {info procs option with a global shadowing proc} {
+ catch {namespace delete test_ns_info2}
+ proc string_cmd { arg } {
+ puts cmd
+ }
+ namespace eval test_ns_info2 {
+ proc string_cmd { arg } {
+ puts cmd
+ }
+ }
+ info procs test_ns_info2::string*
+} {::test_ns_info2::string_cmd}
+# This regression test is currently commented out because it requires
+# that the implementation of "info procs" looks into the global namespace,
+# which it does not (in contrast to "info commands")
+if {0} {
+test info-15.8 {info procs option with a global shadowing proc} {
+ catch {namespace delete test_ns_info2}
+ proc string_cmd { arg } {
+ puts cmd
+ }
+ proc string_cmd2 { arg } {
+ puts cmd
+ }
+ namespace eval test_ns_info2 {
+ proc string_cmd { arg } {
+ puts cmd
+ }
+ }
+ namespace eval test_ns_info2 {
+ lsort [info procs string*]
+ }
+} [lsort [list string_cmd string_cmd2]]
+}
test info-16.1 {info script option} {
list [catch {info script x} msg] $msg
diff --git a/tests/namespace.test b/tests/namespace.test
index c954aa2..5843187 100644
--- a/tests/namespace.test
+++ b/tests/namespace.test
@@ -11,7 +11,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: namespace.test,v 1.6 1999/06/26 20:55:08 rjohnson Exp $
+# RCS: @(#) $Id: namespace.test,v 1.7 2000/01/12 11:13:25 hobbs Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -675,8 +675,8 @@ test namespace-21.6 {NamespaceChildrenCmd, glob-style pattern given} {
} {::test_ns_1::test_ns_foo}
test namespace-21.7 {NamespaceChildrenCmd, glob-style pattern given} {
namespace eval test_ns_1::test_ns_foo {}
- namespace children test_ns_1 test*
-} {::test_ns_1::test_ns_2 ::test_ns_1::test_ns_foo}
+ lsort [namespace children test_ns_1 test*]
+} [lsort {::test_ns_1::test_ns_2 ::test_ns_1::test_ns_foo}]
test namespace-22.1 {NamespaceCodeCmd, bad args} {
catch {eval namespace delete [namespace children :: test_ns_*]}
diff --git a/tests/unixFCmd.test b/tests/unixFCmd.test
index b06977c..79b63dd 100644
--- a/tests/unixFCmd.test
+++ b/tests/unixFCmd.test
@@ -9,7 +9,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: unixFCmd.test,v 1.9 1999/07/01 17:36:20 jenn Exp $
+# RCS: @(#) $Id: unixFCmd.test,v 1.10 2000/01/12 11:13:25 hobbs Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -267,7 +267,34 @@ test unixFCmd-17.3 {SetPermissionsAttribute} {unixOnly notRoot} {
close [open foo.test w]
list [catch {file attributes foo.test -permissions foo} msg] $msg \
[file delete -force -- foo.test]
-} {1 {expected integer but got "foo"} {}}
+} {1 {unknown permission string format "foo"} {}}
+test unixFCmd-17.3 {SetPermissionsAttribute} {unixOnly notRoot} {
+ catch {file delete -force -- foo.test}
+ close [open foo.test w]
+ list [catch {file attributes foo.test -permissions ---rwx} msg] $msg \
+ [file delete -force -- foo.test]
+} {1 {unknown permission string format "---rwx"} {}}
+
+close [open foo.test w]
+set ::i 4
+proc permcheck {permstr expected} {
+ test unixFCmd-17.[incr ::i] {SetPermissionsAttribute} {unixOnly notRoot} \
+ [subst {
+ file attributes foo.test -permissions $permstr
+ file attributes foo.test -permissions
+ }
+ ] $expected
+}
+permcheck rwxrwxrwx 00777
+permcheck r--r---w- 00442
+permcheck 0 00000
+permcheck u+rwx,g+r 00740
+permcheck u-w 00540
+permcheck o+rwx 00547
+permcheck --x--x--x 00111
+permcheck a+rwx 00777
+file delete -force -- foo.test
+
test unixFCmd-18.1 {Unix pwd} {nonPortable unixOnly notRoot} {
# This test is nonportable because SunOS generates a weird error
# message when the current directory isn't readable.
diff --git a/tests/utf.test b/tests/utf.test
index 3250097..6c8ee89 100644
--- a/tests/utf.test
+++ b/tests/utf.test
@@ -8,7 +8,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: utf.test,v 1.5 1999/06/26 20:55:17 rjohnson Exp $
+# RCS: @(#) $Id: utf.test,v 1.6 2000/01/12 11:13:26 hobbs Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -141,7 +141,9 @@ bsCheck \\ 92
bsCheck \Ca 67
bsCheck \Ma 77
bsCheck \CMa 67
-bsCheck \8a 8
+# prior to 8.3, this returned 8, as \8 as accepted as an
+# octal value - but it isn't! [Bug: 3975]
+bsCheck \8a 56
bsCheck \14 12
bsCheck \141 97
bsCheck b\0 98