summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2010-01-05 18:58:12 (GMT)
committerdgp <dgp@users.sourceforge.net>2010-01-05 18:58:12 (GMT)
commit6c429a0ad16df02718539a22c3e9f8d9b92df937 (patch)
treeef190eb25737fc57bc8e1ba3c90d8835649e6857
parentaa97f95a4ce2d6977a8e82caf00674c5e83270ea (diff)
downloadtcl-6c429a0ad16df02718539a22c3e9f8d9b92df937.zip
tcl-6c429a0ad16df02718539a22c3e9f8d9b92df937.tar.gz
tcl-6c429a0ad16df02718539a22c3e9f8d9b92df937.tar.bz2
* generic/tclPathObj.c (TclPathPart): Correct inconsistency between
* tests/fileName.test (filename-14.31): the string rep and the intrep of a path value created by [file rootname]. Thanks to Vitaly Magerya for reporting. [Bug 2918610]
-rw-r--r--ChangeLog7
-rw-r--r--generic/tclPathObj.c36
-rw-r--r--tests/fileName.test16
3 files changed, 32 insertions, 27 deletions
diff --git a/ChangeLog b/ChangeLog
index 849fca6..9b76168 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2010-01-05 Don Porter <dgp@users.sourceforge.net>
+
+ * generic/tclPathObj.c (TclPathPart): Correct inconsistency between
+ * tests/fileName.test (filename-14.31): the string rep and the intrep
+ of a path value created by [file rootname]. Thanks to Vitaly Magerya
+ for reporting. [Bug 2918610]
+
2010-01-03 Donal K. Fellows <dkf@users.sf.net>
* unix/tcl.m4 (SC_CONFIG_CFLAGS): [Bug 1636685]: Use the configuration
diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c
index bd69f09..13eeb2b 100644
--- a/generic/tclPathObj.c
+++ b/generic/tclPathObj.c
@@ -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: tclPathObj.c,v 1.66.2.10 2009/10/27 20:30:48 dgp Exp $
+ * RCS: @(#) $Id: tclPathObj.c,v 1.66.2.11 2010/01/05 18:58:12 dgp Exp $
*/
#include "tclInt.h"
@@ -660,34 +660,18 @@ TclPathPart(
return pathPtr;
} else {
/*
- * Duplicate the object we were given and then trim off
- * the extension of the tail component of the path.
+ * Need to return the whole path with the extension
+ * suffix removed. Do that by joining our "head" to
+ * our "tail" with the extension suffix removed from
+ * the tail.
*/
- FsPath *fsDupPtr;
- Tcl_Obj *root = Tcl_DuplicateObj(pathPtr);
+ Tcl_Obj *resultPtr =
+ TclNewFSPathObj(fsPathPtr->cwdPtr, fileName,
+ (int)(length - strlen(extension)));
- Tcl_IncrRefCount(root);
- fsDupPtr = PATHOBJ(root);
- if (Tcl_IsShared(fsDupPtr->normPathPtr)) {
- TclDecrRefCount(fsDupPtr->normPathPtr);
- fsDupPtr->normPathPtr = Tcl_NewStringObj(fileName,
- (int)(length - strlen(extension)));
- Tcl_IncrRefCount(fsDupPtr->normPathPtr);
- } else {
- Tcl_SetObjLength(fsDupPtr->normPathPtr,
- (int)(length - strlen(extension)));
- }
-
- /*
- * Must also trim the string representation if we have it.
- */
-
- if (root->bytes != NULL && root->length > 0) {
- root->length -= strlen(extension);
- root->bytes[root->length] = 0;
- }
- return root;
+ Tcl_IncrRefCount(resultPtr);
+ return resultPtr;
}
}
default:
diff --git a/tests/fileName.test b/tests/fileName.test
index 9fe9f34..3196295 100644
--- a/tests/fileName.test
+++ b/tests/fileName.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: fileName.test,v 1.51.8.10 2009/10/28 16:45:54 kennykb Exp $
+# RCS: @(#) $Id: fileName.test,v 1.51.8.11 2010/01/05 18:58:12 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -1348,6 +1348,20 @@ test filename-14.30 {Bug 2710920} {unixOrPc} {
file rootname [lindex [lsort [glob globTest/*/]] 0]
} globTest/a1/
+test filename-14.31 {Bug 2918610} -setup {
+ set d [makeDirectory foo]
+ makeFile {} bar.soom $d
+} -body {
+ foreach fn [glob $d/bar.soom] {
+ set root [file rootname $fn]
+ close [open $root {WRONLY CREAT}]
+ }
+ llength [glob -directory $d *]
+} -cleanup {
+ file delete -force $d/bar
+ removeFile bar.soom $d
+ removeDirectory foo
+} -result 2
unset globname