diff options
| -rw-r--r-- | ChangeLog | 6 | ||||
| -rw-r--r-- | generic/tclIndexObj.c | 22 | ||||
| -rw-r--r-- | tests/indexObj.test | 26 |
3 files changed, 28 insertions, 26 deletions
@@ -1,3 +1,9 @@ +2006-04-05 Donal K. Fellows <donal.k.fellows@man.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-04 Don Porter <dgp@users.sourceforge.net> * generic/tclPkg.c: Revised Bug 1162286 fix from 2005-11-08 diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index bdfca15..7bc046d 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.16.2.2 2006/02/16 20:21:54 dgp Exp $ + * RCS: @(#) $Id: tclIndexObj.c,v 1.16.2.3 2006/04/05 13:20:09 dkf Exp $ */ #include "tclInt.h" @@ -171,7 +171,7 @@ Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, int flags; /* 0 or TCL_EXACT */ int *indexPtr; /* Place to store resulting integer index. */ { - int index, length, i, numAbbrev; + int index, i, numAbbrev; char *key, *p1; CONST char *p2; CONST char * CONST *entryPtr; @@ -195,19 +195,11 @@ Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, * 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) @@ -235,9 +227,13 @@ Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, } } /* - * 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; } diff --git a/tests/indexObj.test b/tests/indexObj.test index dee0dfa..168b225 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.7.18.1 2006/02/16 20:21:54 dgp Exp $ +# RCS: @(#) $Id: indexObj.test,v 1.7.18.2 2006/04/05 13:20:14 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -43,6 +43,12 @@ test indexObj-1.6 {forced exact match} { test indexObj-1.7 {forced exact match} { testindexobj 1 0 x abc def xalb xyz alm x } {5} +test indexObj-1.8 {exact match of empty values} { + testindexobj 1 1 {} a aa aaa {} b bb bbb +} 3 +test indexObj-1.9 {exact match of empty values} { + testindexobj 1 0 {} a aa aaa {} b bb bbb +} 3 test indexObj-2.1 {no match} { list [catch {testindexobj 1 1 dddd abc def xalb xyz alm x} msg] $msg @@ -62,6 +68,12 @@ test indexObj-2.5 {omit error message} { 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} { + list [catch {testindexobj 1 1 {} a b c} msg] $msg +} {1 {ambiguous token "": must be a, b, or c}} +test indexObj-2.8 {exact match of empty values: singleton case} { + 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 check 42 @@ -114,15 +126,3 @@ test indexObj-6.4 {Tcl_GetIndexFromObjStruct} { # cleanup ::tcltest::cleanupTests return - - - - - - - - - - - - |