summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorvincentdarley <vincentdarley>2006-03-19 22:47:28 (GMT)
committervincentdarley <vincentdarley>2006-03-19 22:47:28 (GMT)
commit65445fd58393fa26379df62078124e7ca893bb75 (patch)
treec4a57331f774fdba513a729f09ae6776ac109c00
parent72206dd82f0adc6ea37e52500b0be03bb3b830fb (diff)
downloadtcl-65445fd58393fa26379df62078124e7ca893bb75.zip
tcl-65445fd58393fa26379df62078124e7ca893bb75.tar.gz
tcl-65445fd58393fa26379df62078124e7ca893bb75.tar.bz2
backport of file writable fixes
-rw-r--r--ChangeLog10
-rw-r--r--generic/tclTest.c65
-rw-r--r--tests/fCmd.test35
-rwxr-xr-xtests/tcltest.test3
-rw-r--r--tests/winFCmd.test10
-rw-r--r--unix/tclUnixTest.c65
-rw-r--r--win/tclWinFile.c7
7 files changed, 117 insertions, 78 deletions
diff --git a/ChangeLog b/ChangeLog
index fc6ce1d..c5272f2 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,13 @@
+2006-03-18 Vince Darley <vincentdarley@sourceforge.net>
+
+ * generic/tclTest.c:
+ * win/tclWinFile.c:
+ * win/tclWinTest.c:
+ * tests/fCmd.test:
+ * tests/winFCmd.test:
+ * tests/tcltest.test: Backport of [file writable] fixes for
+ Windows from HEAD. [Bug 1193497]
+
2006-03-16 Andreas Kupries <andreask@activestate.com>
* doc/open.n: Documented the changed behaviour of 'a'ppend mode.
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 59c3148..52ab14e 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -14,7 +14,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclTest.c,v 1.62.2.11 2005/12/15 04:08:26 das Exp $
+ * RCS: @(#) $Id: tclTest.c,v 1.62.2.12 2006/03/19 22:47:29 vincentdarley Exp $
*/
#define TCL_TEST
@@ -208,8 +208,6 @@ static int TestcmdtokenCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestcmdtraceCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
-static int TestchmodCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, CONST char **argv));
static int TestcreatecommandCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestdcallCmd _ANSI_ARGS_((ClientData dummy,
@@ -581,8 +579,6 @@ Tcltest_Init(interp)
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testchannelevent", TestChannelEventCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
- Tcl_CreateCommand(interp, "testchmod", TestchmodCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testcmdtoken", TestcmdtokenCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testcmdinfo", TestcmdinfoCmd, (ClientData) 0,
@@ -3999,65 +3995,6 @@ TestpanicCmd(dummy, interp, argc, argv)
return TCL_OK;
}
-/*
- *---------------------------------------------------------------------------
- *
- * TestchmodCmd --
- *
- * Implements the "testchmod" cmd. Used when testing "file"
- * command. The only attribute used by the Mac and Windows platforms
- * is the user write flag; if this is not set, the file is
- * made read-only. Otehrwise, the file is made read-write.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * Changes permissions of specified files.
- *
- *---------------------------------------------------------------------------
- */
-
-static int
-TestchmodCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
-{
- int i, mode;
- char *rest;
-
- if (argc < 2) {
- usage:
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " mode file ?file ...?", (char *) NULL);
- return TCL_ERROR;
- }
-
- mode = (int) strtol(argv[1], &rest, 8);
- if ((rest == argv[1]) || (*rest != '\0')) {
- goto usage;
- }
-
- for (i = 2; i < argc; i++) {
- Tcl_DString buffer;
- CONST char *translated;
-
- translated = Tcl_TranslateFileName(interp, argv[i], &buffer);
- if (translated == NULL) {
- return TCL_ERROR;
- }
- if (chmod(translated, (unsigned) mode) != 0) {
- Tcl_AppendResult(interp, translated, ": ", Tcl_PosixError(interp),
- (char *) NULL);
- return TCL_ERROR;
- }
- Tcl_DStringFree(&buffer);
- }
- return TCL_OK;
-}
-
static int
TestfileCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
diff --git a/tests/fCmd.test b/tests/fCmd.test
index cb6d200..c53f8d4 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.26.2.7 2005/10/07 22:35:03 hobbs Exp $
+# RCS: @(#) $Id: fCmd.test,v 1.26.2.8 2006/03/19 22:47:30 vincentdarley Exp $
#
if {[lsearch [namespace children] ::tcltest] == -1} {
@@ -20,6 +20,8 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
tcltest::testConstraint testsetplatform [string equal testsetplatform [info commands testsetplatform]]
tcltest::testConstraint testchmod [string equal testchmod [info commands testchmod]]
+testConstraint 95or98 [expr {[testConstraint 95] || [testConstraint 98]}]
+testConstraint 2000orNewer [expr {![testConstraint 95or98]}]
# Several tests require need to match results against the unix username
set user {}
@@ -890,7 +892,7 @@ test fCmd-10.2 {file copy: comprehensive: file to new name} {notRoot testchmod}
file copy tf2 tf4
list [lsort [glob tf*]] [contents tf3] [contents tf4] [file writable tf3] [file writable tf4]
} {{tf1 tf2 tf3 tf4} tf1 tf2 1 0}
-test fCmd-10.3 {file copy: comprehensive: dir to new name} {notRoot unixOrPc testchmod} {
+test fCmd-10.3 {file copy: comprehensive: dir to new name} {notRoot unixOrPc 95or98 testchmod} {
cleanup
file mkdir [file join td1 tdx]
file mkdir [file join td2 tdy]
@@ -905,6 +907,20 @@ test fCmd-10.3 {file copy: comprehensive: dir to new name} {notRoot unixOrPc tes
}
set msg
} [subst {{td1 td2 td3 td4} [file join td3 tdx] [file join td4 tdy] 1 0}]
+test fCmd-10.3.1 {file copy: comprehensive: dir to new name} {notRoot pc 2000orNewer testchmod} {
+ # On Windows with ACLs, copying a directory is defined like this
+ cleanup
+ file mkdir [file join td1 tdx]
+ file mkdir [file join td2 tdy]
+ testchmod 555 td2
+ file copy td1 td3
+ file copy td2 td4
+ set msg [list [lsort [glob td*]] [glob -directory td3 t*] \
+ [glob -directory td4 t*] [file writable td3] [file writable td4]]
+ testchmod 755 td2
+ testchmod 755 td4
+ set msg
+} [subst {{td1 td2 td3 td4} [file join td3 tdx] [file join td4 tdy] 1 1}]
test fCmd-10.4 {file copy: comprehensive: file to existing file} {notRoot testchmod} {
cleanup
createfile tf1
@@ -977,7 +993,7 @@ test fCmd-10.7 {file rename: comprehensive: file to new name and dir} {notRoot t
[file writable [file join td1 tf3]] [file writable [file join td1 tf4]]
} [subst {{tf1 tf2} {[file join td1 tf3] [file join td1 tf4]} 1 0}]
test fCmd-10.8 {file rename: comprehensive: dir to new name and dir} \
- {notRoot unixOrPc testchmod} {
+ {notRoot unixOrPc 95or98 testchmod} {
cleanup
file mkdir td1
file mkdir td2
@@ -988,6 +1004,19 @@ test fCmd-10.8 {file rename: comprehensive: dir to new name and dir} \
list [lsort [glob td*]] [lsort [glob -directory td3 t*]] \
[file writable [file join td3 td3]] [file writable [file join td3 td4]]
} [subst {{td1 td2 td3} {[file join td3 td3] [file join td3 td4]} 1 0}]
+test fCmd-10.8.1 {file rename: comprehensive: dir to new name and dir} \
+ {notRoot pc 2000orNewer testchmod} {
+ # On Windows with ACLs, copying a directory is defined like this
+ cleanup
+ file mkdir td1
+ file mkdir td2
+ file mkdir td3
+ testchmod 555 td2
+ file copy td1 [file join td3 td3]
+ file copy td2 [file join td3 td4]
+ list [lsort [glob td*]] [lsort [glob -directory td3 t*]] \
+ [file writable [file join td3 td3]] [file writable [file join td3 td4]]
+} [subst {{td1 td2 td3} {[file join td3 td3] [file join td3 td4]} 1 1}]
test fCmd-10.9 {file copy: comprehensive: source and target incompatible} \
{notRoot} {
cleanup
diff --git a/tests/tcltest.test b/tests/tcltest.test
index 7d3b1c4..c40826b 100755
--- a/tests/tcltest.test
+++ b/tests/tcltest.test
@@ -6,7 +6,7 @@
# Copyright (c) 2000 by Ajuba Solutions
# All rights reserved.
#
-# RCS: @(#) $Id: tcltest.test,v 1.37.2.10 2005/02/25 22:37:52 dgp Exp $
+# RCS: @(#) $Id: tcltest.test,v 1.37.2.11 2006/03/19 22:47:30 vincentdarley Exp $
# Note that there are several places where the value of
# tcltest::currentFailure is stored/reset in the -setup/-cleanup
@@ -558,6 +558,7 @@ switch $tcl_platform(platform) {
}
default {
catch {file attributes $notWriteableDir -readonly 1}
+ catch {testchmod 000 $notWriteableDir}
}
}
diff --git a/tests/winFCmd.test b/tests/winFCmd.test
index a6221c4..159317b 100644
--- a/tests/winFCmd.test
+++ b/tests/winFCmd.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: winFCmd.test,v 1.20.2.8 2005/03/15 22:10:58 vincentdarley Exp $
+# RCS: @(#) $Id: winFCmd.test,v 1.20.2.9 2006/03/19 22:47:30 vincentdarley Exp $
#
if {[lsearch [namespace children] ::tcltest] == -1} {
@@ -688,11 +688,11 @@ test winFCmd-7.10 {TraverseWinTree: can't read directory: handle == INVALID} \
test winFCmd-7.11 {TraverseWinTree: call TraversalCopy: DOTREE_PRED} {pcOnly} {
cleanup
file mkdir td1
- testchmod 000 td1
createfile td1/tf1 tf1
+ testchmod 000 td1
testfile cpdir td1 td2
list [file exists td2] [file writable td2]
-} {1 0}
+} {1 1}
test winFCmd-7.12 {TraverseWinTree: call TraversalDelete: DOTREE_PRED} {pcOnly} {
cleanup
file mkdir td1
@@ -744,11 +744,11 @@ test winFCmd-7.18 {TraverseWinTree: recurse on files: several files and dir} \
test winFCmd-7.19 {TraverseWinTree: call TraversalCopy: DOTREE_POSTD} {pcOnly} {
cleanup
file mkdir td1
- testchmod 000 td1
createfile td1/tf1 tf1
+ testchmod 000 td1
testfile cpdir td1 td2
list [file exists td2] [file writable td2]
-} {1 0}
+} {1 1}
test winFCmd-7.20 {TraverseWinTree: call TraversalDelete: DOTREE_POSTD} \
{pcOnly} {
cleanup
diff --git a/unix/tclUnixTest.c b/unix/tclUnixTest.c
index e4c5662..905a986 100644
--- a/unix/tclUnixTest.c
+++ b/unix/tclUnixTest.c
@@ -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: tclUnixTest.c,v 1.14.2.1 2003/10/13 01:00:38 hobbs Exp $
+ * RCS: @(#) $Id: tclUnixTest.c,v 1.14.2.2 2006/03/19 22:47:30 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -83,6 +83,8 @@ static int TestalarmCmd _ANSI_ARGS_((ClientData dummy,
static int TestgotsigCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static void AlarmHandler _ANSI_ARGS_(());
+static int TestchmodCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int argc, CONST char **argv));
/*
*----------------------------------------------------------------------
@@ -105,6 +107,8 @@ int
TclplatformtestInit(interp)
Tcl_Interp *interp; /* Interpreter to add commands to. */
{
+ Tcl_CreateCommand(interp, "testchmod", TestchmodCmd,
+ (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testfilehandler", TestfilehandlerCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testfilewait", TestfilewaitCmd,
@@ -703,3 +707,62 @@ TestgotsigCmd(clientData, interp, argc, argv)
gotsig = "0";
return TCL_OK;
}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TestchmodCmd --
+ *
+ * Implements the "testchmod" cmd. Used when testing "file" command.
+ * The only attribute used by the Windows platform is the user write
+ * flag; if this is not set, the file is made read-only. Otehrwise, the
+ * file is made read-write.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Changes permissions of specified files.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static int
+TestchmodCmd(dummy, interp, argc, argv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int argc; /* Number of arguments. */
+ CONST char **argv; /* Argument strings. */
+{
+ int i, mode;
+ char *rest;
+
+ if (argc < 2) {
+ usage:
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " mode file ?file ...?", NULL);
+ return TCL_ERROR;
+ }
+
+ mode = (int) strtol(argv[1], &rest, 8);
+ if ((rest == argv[1]) || (*rest != '\0')) {
+ goto usage;
+ }
+
+ for (i = 2; i < argc; i++) {
+ Tcl_DString buffer;
+ CONST char *translated;
+
+ translated = Tcl_TranslateFileName(interp, argv[i], &buffer);
+ if (translated == NULL) {
+ return TCL_ERROR;
+ }
+ if (chmod(translated, (unsigned) mode) != 0) {
+ Tcl_AppendResult(interp, translated, ": ", Tcl_PosixError(interp),
+ NULL);
+ return TCL_ERROR;
+ }
+ Tcl_DStringFree(&buffer);
+ }
+ return TCL_OK;
+}
diff --git a/win/tclWinFile.c b/win/tclWinFile.c
index f4d882b..507c2a1 100644
--- a/win/tclWinFile.c
+++ b/win/tclWinFile.c
@@ -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: tclWinFile.c,v 1.44.2.14 2006/03/10 10:35:25 vincentdarley Exp $
+ * RCS: @(#) $Id: tclWinFile.c,v 1.44.2.15 2006/03/19 22:47:30 vincentdarley Exp $
*/
//#define _WIN32_WINNT 0x0500
@@ -1342,8 +1342,7 @@ NativeAccess(
}
if ((mode & W_OK)
- && !(attr & FILE_ATTRIBUTE_DIRECTORY)
- /* && (tclWinProcs->getFileSecurityProc == NULL) */
+ && (tclWinProcs->getFileSecurityProc == NULL)
&& (attr & FILE_ATTRIBUTE_READONLY)) {
/*
* We don't have the advanced 'getFileSecurityProc', and
@@ -1520,6 +1519,7 @@ NativeAccess(
* we must still check the 'attr' value.
*/
if ((mode & W_OK)
+ && !(attr & FILE_ATTRIBUTE_DIRECTORY)
&& (attr & FILE_ATTRIBUTE_READONLY)) {
Tcl_SetErrno(EACCES);
return -1;
@@ -2611,7 +2611,6 @@ TclpObjNormalizePath(interp, pathPtr, nextCheckpoint)
return nextCheckpoint;
}
-
/*
*---------------------------------------------------------------------------
*