diff options
| -rw-r--r-- | ChangeLog | 7 | ||||
| -rw-r--r-- | generic/tclPathObj.c | 36 | ||||
| -rw-r--r-- | tests/fileName.test | 17 |
3 files changed, 33 insertions, 27 deletions
@@ -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 610c05e..d6f2618 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.85 2009/12/21 23:25:39 nijtmans Exp $ + * RCS: @(#) $Id: tclPathObj.c,v 1.86 2010/01/05 18:58:36 dgp Exp $ */ #include "tclInt.h" @@ -661,34 +661,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 c02cea3..d46391a 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.65 2009/10/28 16:46:33 kennykb Exp $ +# RCS: @(#) $Id: fileName.test,v 1.66 2010/01/05 18:58:36 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -1290,6 +1290,21 @@ 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 # The following tests are only valid for Unix systems. On some systems, like |