From 0e23807506cde25fbd9689f83c09a35db89fa79f Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Tue, 5 Jan 2010 18:58:36 +0000
Subject:         * 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]

---
 ChangeLog            |  7 +++++++
 generic/tclPathObj.c | 36 ++++++++++--------------------------
 tests/fileName.test  | 17 ++++++++++++++++-
 3 files changed, 33 insertions(+), 27 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index b346e52..9927869 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 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
-- 
cgit v0.12