From 4d555006cf6508a46285b59a91a6413e6567ba51 Mon Sep 17 00:00:00 2001 From: jenn Date: Tue, 14 Dec 1999 21:36:43 +0000 Subject: Modified tcltest library to set testConstraint(root) and testConstraint(notRoot) properly if UID is 0; disabled tests in fCmd.test that are potentially dangerous. FossilOrigin-Name: 77755a87bc1f46a383fc766f95772a85acd69a99 --- ChangeLog | 9 +++++++++ library/tcltest/tcltest.tcl | 12 +++++++----- library/tcltest1.0/tcltest.tcl | 12 +++++++----- tests/fCmd.test | 8 ++++---- 4 files changed, 27 insertions(+), 14 deletions(-) diff --git a/ChangeLog b/ChangeLog index b4286e5..8ce394a 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,12 @@ +1999-12-13 Jennifer Hom + + * library/tcltest1.0/tcltest.tcl: Modified testConstraint(root) + and testConstraint(notRoot) so that they will be set to the proper + values if the user name is 'root' or the uid is 0. + + * tests/fCmd.test: Added knownBug constraints to fCmd-8.1, + fCmd-5.5, and fCmd-6.17; these are potentially dangerous tests. + 1999-12-07 Jeff Hobbs * library/http2.1/http.tcl: fixed error handling in http::Event diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 32de76e..6d1c9bb 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -12,7 +12,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: tcltest.tcl,v 1.9.4.4 1999/10/30 11:07:05 hobbs Exp $ +# RCS: @(#) $Id: tcltest.tcl,v 1.9.4.5 1999/12/14 21:36:43 jenn Exp $ package provide tcltest 1.0 @@ -458,13 +458,15 @@ proc ::tcltest::initConstraints {} { set ::tcltest::testConstraints(root) 0 set ::tcltest::testConstraints(notRoot) 1 - set user {} if {[string equal $tcl_platform(platform) "unix"]} { - catch {set user [exec whoami]} + set user {} + set id {} + catch {regexp {^uid=(\d+)\((\w+)\)} [exec id] dummy id user} if {[string equal $user ""]} { - catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user} + catch {set user [exec whoami]} } - if {([string equal $user "root"]) || ([string equal $user ""])} { + if {([string equal $user "root"]) || ([string equal $user ""]) \ + || ($id == 0)} { set ::tcltest::testConstraints(root) 1 set ::tcltest::testConstraints(notRoot) 0 } diff --git a/library/tcltest1.0/tcltest.tcl b/library/tcltest1.0/tcltest.tcl index 32de76e..6d1c9bb 100644 --- a/library/tcltest1.0/tcltest.tcl +++ b/library/tcltest1.0/tcltest.tcl @@ -12,7 +12,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: tcltest.tcl,v 1.9.4.4 1999/10/30 11:07:05 hobbs Exp $ +# RCS: @(#) $Id: tcltest.tcl,v 1.9.4.5 1999/12/14 21:36:43 jenn Exp $ package provide tcltest 1.0 @@ -458,13 +458,15 @@ proc ::tcltest::initConstraints {} { set ::tcltest::testConstraints(root) 0 set ::tcltest::testConstraints(notRoot) 1 - set user {} if {[string equal $tcl_platform(platform) "unix"]} { - catch {set user [exec whoami]} + set user {} + set id {} + catch {regexp {^uid=(\d+)\((\w+)\)} [exec id] dummy id user} if {[string equal $user ""]} { - catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user} + catch {set user [exec whoami]} } - if {([string equal $user "root"]) || ([string equal $user ""])} { + if {([string equal $user "root"]) || ([string equal $user ""]) \ + || ($id == 0)} { set ::tcltest::testConstraints(root) 1 set ::tcltest::testConstraints(notRoot) 0 } diff --git a/tests/fCmd.test b/tests/fCmd.test index c1af5c9..ec4c8b6 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.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: fCmd.test,v 1.6 1999/07/01 17:36:18 jenn Exp $ +# RCS: @(#) $Id: fCmd.test,v 1.6.4.1 1999/12/14 21:36:44 jenn Exp $ # if {[lsearch [namespace children] ::tcltest] == -1} { @@ -359,7 +359,7 @@ test fCmd-5.4 {TclFileDeleteCmd: multiple files} {notRoot} { file delete tf1 td1 tf2 lappend x [file exist tf1] [file exist tf2] [file exist tf3] } {1 1 1 0 0 0} -test fCmd-5.5 {TclFileDeleteCmd: stop at first error} {notRoot unixOrPc} { +test fCmd-5.5 {TclFileDeleteCmd: stop at first error} {notRoot unixOrPc knownBug} { cleanup createfile tf1 createfile tf2 @@ -488,7 +488,7 @@ test fCmd-6.16 {CopyRenameOneFile: TclpCopyRenameOneFile fails} {notRoot} { list [catch {file rename -force td2 td1} msg] $msg } [subst {1 {error renaming "td2" to "[file join td1 td2]": file already exists}}] -test fCmd-6.17 {CopyRenameOneFile: errno == EINVAL} {notRoot} { +test fCmd-6.17 {CopyRenameOneFile: errno == EINVAL} {notRoot knownBug} { cleanup list [catch {file rename -force $root tf1} msg] $msg } [subst {1 {error renaming "$root" to "tf1": trying to rename a volume or move a directory into itself}}] @@ -648,7 +648,7 @@ test fCmd-7.5 {FileForceOption: multiple times through loop} {notRoot} { } {1 {no files matched glob patterns "-- -force"}} test fCmd-8.1 {FileBasename: basename of ~user: argc == 1 && *path == ~} \ - {unixOnly notRoot} { + {unixOnly notRoot knownBug} { file mkdir td1 file attr td1 -perm 040000 set result [list [catch {file rename ~$user td1} msg] $msg] -- cgit v0.12