Nail [Bug 1464039] by allowing the empty string to be exactly matched by

Tcl_GetIndexFromObj. Also added tests.

3 files changed, 59 insertions, 43 deletions

diff --git a/ChangeLog b/ChangeLog
index 88f8e85..f4cbca3 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,29 +1,33 @@
+2006-04-05  Donal K. Fellows  <donal.k.fellows@manchester.ac.uk>
+
+	* generic/tclIndexObj.c (Tcl_GetIndexFromObjStruct): Allow empty
+	strings to be matched by the Tcl_GetIndexFromObj machinery, but only
+	ever exactly. [Bug 1464039]
+
 2006-04-03  Andreas Kupries <andreask@activestate.com>
 
-	* generic/tclIO.c (ReadChars): Added check and panic and
-	  commentary to a piece of code which relies on BUFFER_PADDING to
-	  create enough space at the beginning of each buffer for the
-	  insertion of partial multi-byte data at the beginning of a
-	  buffer. To explain why this code is ok, and as precaution if
-	  someone twiddled the BUFFER_PADDING into uselessness.
-	
-	* generic/tclIO.c (ReadChars): [SF Tcl Bug 1462248]. Added code to
-	  temporarily suppress the use of TCL_ENCODING_END set when eof
-	  was reached while the buffer we are converting is not truly the
-	  last buffer in the queue. Together with the Utf bug below it was
-	  possible to completely bollox the buffer data structures,
-	  eventually crashing Tcl.
-
-	* generic/tclEncoding.c (UtfToUtfProc): Fixed problem where the
-	  function accessed memory beyond the end of the input
-	  buffer. When TCL_ENCODING_END is set and the last bytes of the
-	  buffer start a multi-byte sequence. This bug contributed to [SF
-	  Tcl Bug 1462248].
+	* generic/tclIO.c (ReadChars): Added check, panic and commentary to
+	piece of code which relies on BUFFER_PADDING to create enough space at
+	the beginning of each buffer for the insertion of partial multibyte
+	data at the beginning of a buffer. Commentary explains why this code
+	is OK, and the panic is as a precaution if someone twiddled the
+	BUFFER_PADDING into uselessness.
+
+	* generic/tclIO.c (ReadChars): [Bug 1462248].  Temporarily suppress
+	the use of TCL_ENCODING_END set when EOF was reached while the buffer
+	we are converting is not truly the last buffer in the queue. Together
+	with the Utf bug below it was possible to completely wreck the buffer
+	data structures, eventually crashing Tcl.
+
+	* generic/tclEncoding.c (UtfToUtfProc): Stop accessing memory beyond
+	the end of the input buffer when TCL_ENCODING_END is set and the last
+	bytes of the buffer start a multi-byte sequence. This bug contributed
+	to [Bug 1462248].
 
 2006-03-30  Miguel Sofer  <msofer@users.sf.net>
 
 	* generic/tclExecute.c: remove unused var and silence gcc warning
-	
+
 2006-03-29  Jeff Hobbs  <jeffh@ActiveState.com>
 
 	* win/Makefile.in: convert _NATIVE paths to use / to avoid ".\"
@@ -53,7 +57,7 @@
 
 	* macosx/Tcl.xcode/default.pbxuser:     add '-singleproc 1' cli arg to
 	* macosx/Tcl.xcodeproj/default.pbxuser: tcltest to ease test debugging.
-	
+
 	* macosx/Tcl.xcode/project.pbxproj:     removed $prefix/share from
 	* macosx/Tcl.xcodeproj/project.pbxproj: TCL_PACKAGE_PATH as per change
 	to unix/configure.in of 2006-03-13.
@@ -1016,8 +1020,8 @@
 2005-11-18  Andreas Kupries  <andreask@activestate.com>
 
 	* generic/tclIO.c (TclFinalizeIOSubsystem): Applied Pat Thoyts' patch
-	for [SF Tcl Bug 1359094]. This moves the retrieval of the next channel
-	state to the end of the loop, as the called closeproc may close other
+	for [Bug 1359094]. This moves the retrieval of the next channel state
+	to the end of the loop, as the called closeproc may close other
 	channels, i.e. modify the list we are iterating, invalidating any
 	pointer retrieved earlier.
 
diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c
index c9f8e1d..bdd291c 100644
--- a/generic/tclIndexObj.c
+++ b/generic/tclIndexObj.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: tclIndexObj.c,v 1.28 2006/02/16 20:25:07 dgp Exp $
+ * RCS: @(#) $Id: tclIndexObj.c,v 1.29 2006/04/05 12:48:25 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -165,7 +165,7 @@ Tcl_GetIndexFromObjStruct(
     int flags,			/* 0 or TCL_EXACT */
     int *indexPtr)		/* Place to store resulting integer index. */
 {
-    int index, length, i, numAbbrev;
+    int index, idx, numAbbrev;
     char *key, *p1;
     CONST char *p2;
     CONST char * CONST *entryPtr;
@@ -185,34 +185,26 @@ Tcl_GetIndexFromObjStruct(
     }
 
     /*
-     * Lookup the value of the object in the table.  Accept unique
+     * Lookup the value of the object in the table. Accept unique
      * abbreviations unless TCL_EXACT is set in flags.
      */
 
-    key = Tcl_GetStringFromObj(objPtr, &length);
+    key = TclGetString(objPtr);
     index = -1;
     numAbbrev = 0;
 
     /*
-     * The key should not be empty, otherwise it's not a match.
-     */
-
-    if (key[0] == '\0') {
-	goto error;
-    }
-
-    /*
      * Scan the table looking for one of:
      *  - An exact match (always preferred)
      *  - A single abbreviation (allowed depending on flags)
      *  - Several abbreviations (never allowed, but overridden by exact match)
      */
 
-    for (entryPtr = tablePtr, i = 0; *entryPtr != NULL;
-	    entryPtr = NEXT_ENTRY(entryPtr, offset), i++) {
+    for (entryPtr = tablePtr, idx = 0; *entryPtr != NULL;
+	    entryPtr = NEXT_ENTRY(entryPtr, offset), idx++) {
 	for (p1 = key, p2 = *entryPtr; *p1 == *p2; p1++, p2++) {
 	    if (*p1 == '\0') {
-		index = i;
+		index = idx;
 		goto done;
 	    }
 	}
@@ -226,15 +218,19 @@ Tcl_GetIndexFromObjStruct(
 	     */
 
 	    numAbbrev++;
-	    index = i;
+	    index = idx;
 	}
     }
 
     /*
-     * Check if we were instructed to disallow abbreviations.
+     * Check if we were instructed to disallow abbreviations. Note that we do
+     * not allow the empty string as an abbreviation of anything; it is only
+     * processed by this function as a non-error case if the table of strings
+     * has an entry in it that is itself an empty string. This only matters in
+     * the case where the table has a singleton entry.
      */
 
-    if ((flags & TCL_EXACT) || (numAbbrev != 1)) {
+    if ((flags & TCL_EXACT) || (key[0] == '\0') || (numAbbrev != 1)) {
 	goto error;
     }
 
@@ -270,7 +266,7 @@ Tcl_GetIndexFromObjStruct(
 
 	TclNewObj(resultPtr);
 	Tcl_SetObjResult(interp, resultPtr);
-	Tcl_AppendStringsToObj(resultPtr, (numAbbrev > 1) && 
+	Tcl_AppendStringsToObj(resultPtr, (numAbbrev > 1) &&
 		!(flags & TCL_EXACT) ? "ambiguous " : "bad ", msg, " \"", key,
 		"\": must be ", STRING_AT(tablePtr, offset, 0), NULL);
 	for (entryPtr = NEXT_ENTRY(tablePtr, offset), count = 0;
diff --git a/tests/indexObj.test b/tests/indexObj.test
index ca58cc3..6df9082 100644
--- a/tests/indexObj.test
+++ b/tests/indexObj.test
@@ -8,7 +8,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: indexObj.test,v 1.10 2006/02/16 20:25:07 dgp Exp $
+# RCS: @(#) $Id: indexObj.test,v 1.11 2006/04/05 12:48:26 dkf Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -38,6 +38,12 @@ test indexObj-1.6 {forced exact match} testindexobj {
 test indexObj-1.7 {forced exact match} testindexobj {
     testindexobj 1 0 x abc def xalb xyz alm x
 } {5}
+test indexObj-1.8 {exact match of empty values} testindexobj {
+    testindexobj 1 1 {} a aa aaa {} b bb bbb
+} 3
+test indexObj-1.9 {exact match of empty values} testindexobj {
+    testindexobj 1 0 {} a aa aaa {} b bb bbb
+} 3
 
 test indexObj-2.1 {no match} testindexobj {
     list [catch {testindexobj 1 1 dddd abc def xalb xyz alm x} msg] $msg
@@ -57,6 +63,12 @@ test indexObj-2.5 {omit error message} testindexobj {
 test indexObj-2.6 {TCL_EXACT => no "ambiguous" error message} {
     list [catch {testindexobj 1 0 d dumb daughter a c} msg] $msg
 } {1 {bad token "d": must be dumb, daughter, a, or c}}
+test indexObj-2.7 {exact match of empty values} testindexobj {
+    list [catch {testindexobj 1 1 {} a b c} msg] $msg
+} {1 {bad token "": must be a, b, or c}}
+test indexObj-2.8 {exact match of empty values: singleton case} testindexobj {
+    list [catch {testindexobj 1 1 {} a} msg] $msg
+} {1 {bad token "": must be a}}
 
 test indexObj-3.1 {cache result to skip next lookup} testindexobj {
     testindexobj check 42
@@ -114,3 +126,7 @@ test indexObj-6.4 {Tcl_GetIndexFromObjStruct} testindexobj {
 # cleanup
 ::tcltest::cleanupTests
 return
+
+# Local Variables:
+# mode: tcl
+# End: