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

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  <jenn@scriptics.com>
+
+	* 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  <hobbs@scriptics.com>
 
 	* 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]