Implemented TIP#195 - tcl::prefix command. [Patch 1040206]

6 files changed, 710 insertions, 12 deletions

diff --git a/ChangeLog b/ChangeLog
index 3332bd0..f30ca11 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,11 @@
 2008-10-03  Donal K. Fellows  <dkf@users.sf.net>
 
+	TIP #195 IMPLEMENTATION
+
+	* generic/tclIndexObj.c (TclGetIndexFromObjList, PrefixMatchObjCmd)
+	* doc/prefix.n, tests/string.test: Added [tcl::prefix] command for
+	working with prefixes of strings at the Tcl level. [Patch 1040206]
+
 	TIP #265 IMPLEMENTATION
 
 	* generic/tclIndexObj.c (Tcl_ParseArgsObjv, PrintUsage):
diff --git a/doc/prefix.n b/doc/prefix.n
new file mode 100644
index 0000000..02bd8ce
--- /dev/null
+++ b/doc/prefix.n
@@ -0,0 +1,93 @@
+'\"
+'\" Copyright (c) 2008 Peter Spjuth <pspjuth@users.sourceforge.net>
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\" 
+'\" RCS: @(#) $Id: prefix.n,v 1.1 2008/10/03 00:01:35 dkf Exp $
+'\" 
+.so man.macros
+.TH prefix n 8.6 Tcl "Tcl Built-In Commands"
+.BS
+'\" Note:  do not modify the .SH NAME line immediately below!
+.SH NAME
+prefix \- Facilities for prefix matching
+.SH SYNOPSIS
+.nf
+\fB::tcl::prefix all\fR \fItable\fR \fIstring\fR
+\fB::tcl::prefix longest\fR \fItable\fR \fIstring\fR
+\fB::tcl::prefix match\fR \fI?option ...?\fR \fItable\fR \fIstring\fR
+.fi
+.BE
+.SH DESCRIPTION
+This document describes commands looking up a prefix in a list of strings.
+The following commands are supported:
+.TP
+\fB::tcl::prefix all\fR \fItable\fR \fIstring\fR
+Returns a list of all elements in \fItable\fR that begins with
+the prefix \fIstring\fR.
+.TP
+\fB::tcl::prefix longest\fR \fItable\fR \fIstring\fR
+Returns the longest common prefix among all elements in \fItable\fR that
+begins with the prefix \fIstring\fR.
+.TP
+\fB::tcl::prefix match\fR ?\fIoptions\fR? \fItable\fR \fIstring\fR
+If \fIstring\fR equals one element in \fItable\fR or is a prefix to exactly
+one element, the matched element is returned.  If not, the result depends
+on the -error option.
+.TP 20
+\fB\-exact\fR
+.
+Accept only exact matches.
+.TP 20
+\fB\-message\0\fIstring\fR
+.
+Use \fIstring\fR in the error message at a mismatch. Default is "option".
+.TP 20
+\fB\-error\0\fIoptions\fR
+.
+The \fIoptions\fR are used when no match is found.
+If \fIoptions\fR is empty, no error is generated and an empty string is returned.
+Otherwise the \fIoptions\fR are used as \fBreturn\fR options when generating
+the error message.  The default corresponds to setting "-level 0".
+Example: If \fB-error\fR "-errorcode MyError -level 1" is used, an error would
+be generated as [return -errorcode MyError -level 1 -code error "ErrMsg"].
+.SH "EXAMPLES"
+.PP
+Basic use:
+.CS
+namespace import ::tcl::prefix
+\fBprefix match\fR {apa bepa cepa} apa
+     \fI\(-> apa\fR
+\fBprefix match\fR {apa bepa cepa} a
+     \fI\(-> apa\fR
+\fBprefix match\fR -exact {apa bepa cepa} a
+     \fI\(-> bad option "a": must be apa, bepa, or cepa\fR
+\fBprefix match\fR -message "switch" {apa ada bepa cepa} a
+     \fI\(-> ambiguous switch "a": must be apa, ada, bepa, or cepa\fR
+\fBprefix longest\fR {fblocked fconfigure fcopy file fileevent flush} fc
+     \fI\(-> fco\fR
+\fBprefix all\fR {fblocked fconfigure fcopy file fileevent flush} fc
+     \fI\(-> fconfigure fcopy\fR
+.CE
+.PP
+Simplifying option matching:
+.CS
+array set opts {-apa 1 -bepa "" -cepa 0}
+foreach {arg val} $args {
+    set opts([prefix match {-apa -bepa -cepa} $arg]) $val
+}
+.CE
+.PP
+Switch supporting prefixes:
+.CS
+switch [prefix match {apa bepa cepa} $arg] {
+    apa  { }
+    bepa { }
+    cepa { }
+}
+.CE
+.SH "SEE ALSO"
+lsearch(n)
+.SH "KEYWORDS"
+prefix
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index d0a8635..036707d 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -16,7 +16,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclBasic.c,v 1.369 2008/10/02 20:59:45 dgp Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.370 2008/10/03 00:01:35 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -750,6 +750,7 @@ Tcl_CreateInterp(void)
     TclInitDictCmd(interp);
     TclInitInfoCmd(interp);
     TclInitStringCmd(interp);
+    TclInitPrefixCmd(interp);
 
     /*
      * Register "clock" subcommands. These *do* go through
diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c
index 144503f..2d29adf 100644
--- a/generic/tclIndexObj.c
+++ b/generic/tclIndexObj.c
@@ -12,7 +12,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.39 2008/10/02 23:32:13 dkf Exp $
+ * RCS: @(#) $Id: tclIndexObj.c,v 1.40 2008/10/03 00:01:35 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -25,6 +25,15 @@ static int		SetIndexFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
 static void		UpdateStringOfIndex(Tcl_Obj *objPtr);
 static void		DupIndex(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr);
 static void		FreeIndex(Tcl_Obj *objPtr);
+static int		PrefixAllObjCmd(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const objv[]);
+static int		PrefixLongestObjCmd(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const objv[]);
+static int		PrefixMatchObjCmd(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const objv[]);
 static void		PrintUsage(Tcl_Interp *interp,
 			    const Tcl_ArgvInfo *argTable);
 
@@ -50,9 +59,9 @@ static Tcl_ObjType indexType = {
  */
 
 typedef struct {
-    void *tablePtr;			/* Pointer to the table of strings */
-    int offset;				/* Offset between table entries */
-    int index;				/* Selected index into table. */
+    void *tablePtr;		/* Pointer to the table of strings */
+    int offset;			/* Offset between table entries */
+    int index;			/* Selected index into table. */
 } IndexRep;
 
 /*
@@ -76,7 +85,7 @@ typedef struct {
  *
  * Results:
  *	If the value of objPtr is identical to or a unique abbreviation for
- *	one of the entries in objPtr, then the return value is TCL_OK and the
+ *	one of the entries in tablePtr, then the return value is TCL_OK and the
  *	index of the matching entry is stored at *indexPtr. If there isn't a
  *	proper match, then TCL_ERROR is returned and an error message is left
  *	in interp's result (unless interp is NULL). The msg argument is used
@@ -131,6 +140,92 @@ Tcl_GetIndexFromObj(
 /*
  *----------------------------------------------------------------------
  *
+ * TclGetIndexFromObjList --
+ *
+ *	This procedure looks up an object's value in a table of strings
+ *	and returns the index of the matching string, if any.
+ *
+ * Results:
+ *	If the value of objPtr is identical to or a unique abbreviation
+ *	for one of the entries in tableObjPtr, then the return value is
+ *	TCL_OK and the index of the matching entry is stored at
+ *	*indexPtr.  If there isn't a proper match, then TCL_ERROR is
+ *	returned and an error message is left in interp's result (unless
+ *	interp is NULL).  The msg argument is used in the error
+ *	message; for example, if msg has the value "option" then the
+ *	error message will say something flag 'bad option "foo": must be
+ *	...'
+ *
+ * Side effects:
+ *	The result of the lookup is cached as the internal rep of
+ *	objPtr, so that repeated lookups can be done quickly.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclGetIndexFromObjList(
+    Tcl_Interp *interp, 	/* Used for error reporting if not NULL. */
+    Tcl_Obj *objPtr,		/* Object containing the string to lookup. */
+    Tcl_Obj *tableObjPtr,	/* List of strings to compare against the
+				 * value of objPtr. */
+    const char *msg,		/* Identifying word to use in error
+				 * messages. */
+    int flags,			/* 0 or TCL_EXACT */
+    int *indexPtr)		/* Place to store resulting integer index. */
+{
+
+    int objc, result, t;
+    Tcl_Obj **objv;
+    char **tablePtr;
+
+    /*
+     * Use Tcl_GetIndexFromObjStruct to do the work to avoid duplicating
+     * most of the code there.  This is a bit ineffiecient but simpler.
+     */
+
+    result = Tcl_ListObjGetElements(interp, tableObjPtr, &objc, &objv);
+    if (result != TCL_OK) {
+	return result;
+    }
+
+    /*
+     * Build a string table from the list.
+     */
+
+    tablePtr = (char **) ckalloc((objc + 1) * sizeof(char *));
+    for (t = 0; t < objc; t++) {
+	if (objv[t] == objPtr) {
+	    /*
+	     * An exact match is always chosen, so we can stop here.
+	     */
+
+	    ckfree((char *) tablePtr);
+	    *indexPtr = t;
+	    return TCL_OK;
+	}
+
+	tablePtr[t] = Tcl_GetString(objv[t]);
+    }
+    tablePtr[objc] = NULL;
+
+    result = Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr,
+	    sizeof(char *), msg, flags, indexPtr);
+
+    /*
+     * The internal rep must be cleared since tablePtr will go away.
+     */
+
+    TclFreeIntRep(objPtr);
+    objPtr->typePtr = NULL;
+    ckfree((char *) tablePtr);
+
+    return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * Tcl_GetIndexFromObjStruct --
  *
  *	This function looks up an object's value given a starting string and
@@ -139,7 +234,7 @@ Tcl_GetIndexFromObj(
  *
  * Results:
  *	If the value of objPtr is identical to or a unique abbreviation for
- *	one of the entries in objPtr, then the return value is TCL_OK and the
+ *	one of the entries in tablePtr, then the return value is TCL_OK and the
  *	index of the matching entry is stored at *indexPtr. If there isn't a
  *	proper match, then TCL_ERROR is returned and an error message is left
  *	in interp's result (unless interp is NULL). The msg argument is used
@@ -250,8 +345,8 @@ Tcl_GetIndexFromObjStruct(
  	objPtr->typePtr = &indexType;
     }
     indexRep->tablePtr = (void *) tablePtr;
-    indexRep->offset = offset;
-    indexRep->index = index;
+    indexRep->offset   = offset;
+    indexRep->index    = index;
 
     *indexPtr = index;
     return TCL_OK;
@@ -340,7 +435,7 @@ UpdateStringOfIndex(
     register char *buf;
     register unsigned len;
     register const char *indexStr = EXPAND_OF(indexRep);
-
+	    
     len = strlen(indexStr);
     buf = (char *) ckalloc(len + 1);
     memcpy(buf, indexStr, len+1);
@@ -406,6 +501,308 @@ FreeIndex(
 /*
  *----------------------------------------------------------------------
  *
+ * TclInitPrefixCmd --
+ *
+ *	This procedure creates the "prefix" Tcl command. See the user
+ *	documentation for details on what it does.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Command
+TclInitPrefixCmd(
+    Tcl_Interp *interp)		/* Current interpreter. */
+{
+    static const EnsembleImplMap prefixImplMap[] = {
+	{"all",		PrefixAllObjCmd,	NULL},
+	{"longest",	PrefixLongestObjCmd,	NULL},
+	{"match",	PrefixMatchObjCmd,	NULL},
+	{NULL}
+    };
+
+    return TclMakeEnsemble(interp, "tcl::prefix", prefixImplMap);
+}
+
+/*----------------------------------------------------------------------
+ *
+ * PrefixMatchObjCmd -
+ *
+ *	This function implements the 'prefix match' Tcl command. Refer
+ *	to the user documentation for details on what it does.
+ *
+ * Results:
+ *	Returns a standard Tcl result.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+PrefixMatchObjCmd(
+    ClientData clientData,		/* Not used. */
+    Tcl_Interp *interp,			/* Current interpreter. */
+    int objc,				/* Number of arguments. */
+    Tcl_Obj *const objv[])       	/* Argument objects. */
+{
+    int flags = 0, result, index;
+    int dummyLength, i, errorLength;
+    Tcl_Obj *errorPtr = NULL;
+    char *message = "option";
+    Tcl_Obj *tablePtr, *objPtr, *resultPtr;
+    static const char *matchOptions[] = {
+	"-error", "-exact", "-message", (char *) NULL
+    };
+    enum matchOptions {
+	PRFMATCH_ERROR, PRFMATCH_EXACT, PRFMATCH_MESSAGE
+    };  
+
+    if (objc < 3) {
+	Tcl_WrongNumArgs(interp, 1, objv, "?options? table string");
+	return TCL_ERROR;
+    }
+
+    for (i = 1; i < (objc - 2); i++) {
+	if (Tcl_GetIndexFromObj(interp, objv[i], matchOptions, "option", 0,
+		    &index) != TCL_OK) {
+	    return TCL_ERROR;
+	}
+	switch ((enum matchOptions) index) {
+	    case PRFMATCH_EXACT:
+		flags |= TCL_EXACT;
+		break;
+	    case PRFMATCH_MESSAGE:
+		if (i > (objc - 4)) {
+		    Tcl_AppendResult(interp, "missing message", NULL);
+		    return TCL_ERROR;
+		}
+		i++;
+		message = Tcl_GetString(objv[i]);
+		break;
+	    case PRFMATCH_ERROR:
+		if (i > (objc - 4)) {
+		    Tcl_AppendResult(interp, "missing error options", NULL);
+		    return TCL_ERROR;
+		}
+		i++;
+		result = Tcl_ListObjLength(interp, objv[i], &errorLength);
+		if (result != TCL_OK) {
+		    return TCL_ERROR;
+		}
+		if ((errorLength % 2) != 0) {
+		    Tcl_AppendResult(interp, "error options must have an even number of elements", NULL);
+		    return TCL_ERROR;
+		}		    
+		errorPtr = objv[i];
+		break;
+	}
+    }
+
+    tablePtr = objv[objc-2];
+    objPtr   = objv[objc-1];
+
+    /*
+     * Check that table is a valid list first, since we want to handle
+     * that error case regardless of level.
+     */
+
+    result = Tcl_ListObjLength(interp, tablePtr, &dummyLength);
+    if (result != TCL_OK) {
+	return result;
+    }
+
+    result = TclGetIndexFromObjList(interp, objPtr, tablePtr, message, flags,
+	    &index);
+    if (result != TCL_OK) {
+	if (errorPtr != NULL && errorLength == 0) {
+	    Tcl_ResetResult(interp);
+	    return TCL_OK;
+	} else if (errorPtr == NULL) {
+	    return TCL_ERROR;
+	} else {
+	    if (Tcl_IsShared(errorPtr)) {
+		errorPtr = Tcl_DuplicateObj(errorPtr);
+	    }
+	    Tcl_ListObjAppendElement(interp, errorPtr,
+		    Tcl_NewStringObj("-code", 5));
+	    Tcl_ListObjAppendElement(interp, errorPtr, Tcl_NewIntObj(result));
+
+	    return Tcl_SetReturnOptions(interp, errorPtr);
+	}
+    }
+
+    result = Tcl_ListObjIndex(interp, tablePtr, index, &resultPtr);
+    if (result != TCL_OK) {
+	return result;
+    }
+    Tcl_SetObjResult(interp, resultPtr);
+    return TCL_OK;
+}
+
+/*----------------------------------------------------------------------
+ *
+ * PrefixAllObjCmd -
+ *
+ *	This function implements the 'prefix all' Tcl command. Refer
+ *	to the user documentation for details on what it does.
+ *
+ * Results:
+ *	Returns a standard Tcl result.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+PrefixAllObjCmd(
+    ClientData clientData,		/* Not used. */
+    Tcl_Interp *interp,			/* Current interpreter. */
+    int objc,				/* Number of arguments. */
+    Tcl_Obj *const objv[])       	/* Argument objects. */
+{
+    int tableObjc, result, t, length, elemLength;
+    char *string, *elemString;
+    Tcl_Obj **tableObjv;
+    Tcl_Obj *resultPtr;
+
+    if (objc != 3) {
+	Tcl_WrongNumArgs(interp, 1, objv, "table string");
+	return TCL_ERROR;
+    }
+
+    result = Tcl_ListObjGetElements(interp, objv[1], &tableObjc, &tableObjv);
+    if (result != TCL_OK) {
+	return result;
+    }
+    resultPtr = Tcl_NewListObj(0, NULL);
+    string = Tcl_GetStringFromObj(objv[2], &length);
+
+    for (t = 0; t < tableObjc; t++) {
+	elemString = Tcl_GetStringFromObj(tableObjv[t], &elemLength);
+
+	/*
+	 * A prefix cannot match if it is longest.
+	 */
+
+	if (length <= elemLength) {
+	    if (TclpUtfNcmp2(elemString, string, length) == 0) {
+		Tcl_ListObjAppendElement(interp, resultPtr, tableObjv[t]);
+	    }
+	}
+    }
+
+    Tcl_SetObjResult(interp, resultPtr);
+    return TCL_OK;
+}
+
+/*----------------------------------------------------------------------
+ *
+ * PrefixLongestObjCmd -
+ *
+ *	This function implements the 'prefix longest' Tcl command. Refer
+ *	to the user documentation for details on what it does.
+ *
+ * Results:
+ *	Returns a standard Tcl result.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+PrefixLongestObjCmd(
+    ClientData clientData,		/* Not used. */
+    Tcl_Interp *interp,			/* Current interpreter. */
+    int objc,				/* Number of arguments. */
+    Tcl_Obj *const objv[])       	/* Argument objects. */
+{
+    int tableObjc, result, i, t, length, elemLength, resultLength;
+    char *string, *elemString, *resultString;
+    Tcl_Obj **tableObjv;
+
+    if (objc != 3) {
+	Tcl_WrongNumArgs(interp, 1, objv, "table string");
+	return TCL_ERROR;
+    }
+
+    result = Tcl_ListObjGetElements(interp, objv[1], &tableObjc, &tableObjv);
+    if (result != TCL_OK) {
+	return result;
+    }
+    string = Tcl_GetStringFromObj(objv[2], &length);
+
+    resultString = NULL;
+    resultLength = 0;
+
+    for (t = 0; t < tableObjc; t++) {
+	elemString = Tcl_GetStringFromObj(tableObjv[t], &elemLength);
+
+	/*
+	 * First check if the prefix string matches the element.
+	 * A prefix cannot match if it is longest.
+	 */
+
+	if ((length > elemLength) ||
+		TclpUtfNcmp2(elemString, string, length) != 0) {
+	    continue;
+	}
+
+	if (resultString == NULL) {
+	    /*
+	     * If this is the first match, the longest common substring this
+	     * far is the complete string.  The result is part of this string
+	     * so we only need to adjust the length later.
+	     */
+
+	    resultString = elemString;
+	    resultLength = elemLength;
+	} else {
+	    /*
+	     * Longest common substring cannot be longer than shortest
+	     * string.
+	     */
+
+	    if (elemLength < resultLength) {
+		resultLength = elemLength;
+	    }
+
+	    /*
+	     * Compare strings.
+	     */
+
+	    for (i = 0; i < resultLength; i++) {
+		if (resultString[i] != elemString[i]) {
+		    /*
+		     * Adjust in case we stopped in the middle of a UTF char.
+		     */
+
+		    resultLength = Tcl_UtfPrev(&resultString[i+1],
+			    resultString) - resultString;
+		    break;
+		}
+	    }
+	}
+    }
+    if (resultLength > 0) {
+	Tcl_SetObjResult(interp, Tcl_NewStringObj(resultString, resultLength));
+    }
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * Tcl_WrongNumArgs --
  *
  *	This function generates a "wrong # args" error message in an
diff --git a/generic/tclInt.h b/generic/tclInt.h
index cbb66b7..4704927 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -15,7 +15,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclInt.h,v 1.400 2008/09/28 13:46:11 msofer Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.401 2008/10/03 00:01:35 dkf Exp $
  */
 
 #ifndef _TCLINT
@@ -3035,6 +3035,7 @@ MODULE_SCOPE int	Tcl_PackageObjCmd(ClientData clientData,
 MODULE_SCOPE int	Tcl_PidObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_Command TclInitPrefixCmd(Tcl_Interp *interp);
 MODULE_SCOPE int	Tcl_PutsObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
diff --git a/tests/string.test b/tests/string.test
index c2ddfc8..27537d4 100644
--- a/tests/string.test
+++ b/tests/string.test
@@ -12,7 +12,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: string.test,v 1.74 2008/09/29 08:20:38 dkf Exp $
+# RCS: @(#) $Id: string.test,v 1.75 2008/10/03 00:01:35 dkf Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -24,6 +24,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
 testConstraint testobj [expr {[info commands testobj] != {}}]
 testConstraint testindexobj [expr {[info commands testindexobj] != {}}]
 
+# Used for constraining memory leak tests
+testConstraint memory [llength [info commands memory]]
+
 test string-1.1 {error conditions} {
     list [catch {string gorp a b} msg] $msg
 } {1 {unknown or ambiguous subcommand "gorp": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
@@ -1667,7 +1670,204 @@ test string-25.14 {string is list} {
     list [string is list -failindex x "\uabcd {b c}d e"] $x
 } {0 2}
 
+test string-26.1 {tcl::prefix, too few args} -body {
+    tcl::prefix match a
+} -returnCodes 1 -result {wrong # args: should be "tcl::prefix match ?options? table string"}
+test string-26.2 {tcl::prefix, bad args} -body {
+    tcl::prefix match a b c
+} -returnCodes 1 -result {bad option "a": must be -error, -exact, or -message}
+test string-26.3 {tcl::prefix, bad args} -body {
+    tcl::prefix match -error "{}x" -exact str1 str2
+} -returnCodes 1 -result {list element in braces followed by "x" instead of space}
+test string-26.3 {tcl::prefix, bad args} -body {
+    tcl::prefix match -error "x" -exact str1 str2
+} -returnCodes 1 -result {error options must have an even number of elements}
+test string-26.3 {tcl::prefix, bad args} -body {
+    tcl::prefix match -error str1 str2
+} -returnCodes 1 -result {missing error options}
+test string-26.4 {tcl::prefix, bad args} -body {
+    tcl::prefix match -message str1 str2
+} -returnCodes 1 -result {missing message}
+test string-26.5 {tcl::prefix} {
+    tcl::prefix match {apa bepa cepa depa} cepa
+} cepa
+test string-26.6 {tcl::prefix} {
+    tcl::prefix match {apa bepa cepa depa} be
+} bepa
+test string-26.7 {tcl::prefix} -body {
+    tcl::prefix match -exact {apa bepa cepa depa} be
+} -returnCodes 1 -result {bad option "be": must be apa, bepa, cepa, or depa}
+test string-26.8 {tcl::prefix} -body {
+    tcl::prefix match -message switch {apa bepa bear depa} be
+} -returnCodes 1 -result {ambiguous switch "be": must be apa, bepa, bear, or depa}
+test string-26.9 {tcl::prefix} -body {
+    tcl::prefix match -error {} {apa bepa bear depa} be
+} -returnCodes 0 -result {}
+test string-26.10 {tcl::prefix} -body {
+    tcl::prefix match -error {-level 1} {apa bepa bear depa} be
+} -returnCodes 2 -result {ambiguous option "be": must be apa, bepa, bear, or depa}
+test string-26.10 {tcl::prefix} -setup {
+    proc _testprefix {args} {
+        array set opts {-a x -b y -c y}
+        foreach {opt val} $args {
+            set opt [tcl::prefix match -error {-level 1} {-a -b -c} $opt]
+            set opts($opt) $val
+        }
+        array get opts
+    }
+} -body {
+    set a [catch {_testprefix -x u} result options]
+    dict get $options -errorinfo
+} -cleanup {
+    rename _testprefix {}
+} -result {bad option "-x": must be -a, -b, or -c
+    while executing
+"_testprefix -x u"}
+
+# Helper for memory stress tests
+# Repeat each body in a local space checking that memory does not increase
+proc MemStress {args} {
+    set res {}
+    foreach body $args {
+        set end 0
+        for {set i 0} {$i < 5} {incr i} { 
+            proc MemStress_Body {} $body
+            uplevel 1 MemStress_Body
+            rename MemStress_Body {}
+            set tmp $end
+            set end [lindex [lindex [split [memory info] "\n"] 3] 3]
+        }
+        lappend res [expr {$end - $tmp}]
+    }
+    return $res
+}
+
+test string-26.11 {tcl::prefix: testing for leaks} -body {
+    # This test is made to stress object reference management
+    MemStress {
+        set table {hejj miff gurk}
+        set item [lindex $table 1]
+        # If not careful, this can cause a circular reference
+        # that will cause a leak.
+        tcl::prefix match $table $item
+    } {
+        # A similar case with nested lists
+        set table2 {hejj {miff maff} gurk}
+        set item [lindex [lindex $table2 1] 0]
+        tcl::prefix match $table2 $item
+    } {
+        # A similar case with dict
+        set table3 {hejj {miff maff} gurk2}
+        set item [lindex [dict keys [lindex $table3 1]] 0]
+        tcl::prefix match $table3 $item
+    }
+} -constraints memory -result {0 0 0}
+
+test string-26.12 {tcl::prefix: testing for leaks} -body {
+    # This is a memory leak test in a form that might actually happen
+    # in real code.  The shared literal "miff" causes a connection
+    # between the item and the table.
+    MemStress {
+        proc stress1 {item} {
+            set table [list hejj miff gurk]
+            tcl::prefix match $table $item
+        }
+        proc stress2 {} {
+            stress1 miff
+        }
+        stress2
+        rename stress1 {}
+        rename stress2 {}
+    }
+} -constraints memory -result 0
+
+test string-26.13 {tcl::prefix: testing for leaks} -body {
+    # This test is made to stress object reference management
+    MemStress {
+        set table [list hejj miff]
+        set item $table
+        set error $table
+        # Use the same objects in all places
+        catch {
+            tcl::prefix match -error $error $table $item
+        }
+    }
+} -constraints memory -result {0}
+
+test string-27.1 {tcl::prefix all, too few args} -body {
+    tcl::prefix all a
+} -returnCodes 1 -result {wrong # args: should be "tcl::prefix all table string"}
+test string-27.2 {tcl::prefix all, bad args} -body {
+    tcl::prefix all a b c
+} -returnCodes 1 -result {wrong # args: should be "tcl::prefix all table string"}
+test string-27.3 {tcl::prefix all, bad args} -body {
+    tcl::prefix all "{}x" str2
+} -returnCodes 1 -result {list element in braces followed by "x" instead of space}
+test string-27.4 {tcl::prefix all} {
+    tcl::prefix all {apa bepa cepa depa} c
+} cepa
+test string-27.5 {tcl::prefix all} {
+    tcl::prefix all {apa bepa cepa depa} cepa
+} cepa
+test string-27.6 {tcl::prefix all} {
+    tcl::prefix all {apa bepa cepa depa} cepax
+} {}
+test string-27.7 {tcl::prefix all} {
+    tcl::prefix all {apa aska appa} a
+} {apa aska appa}
+test string-27.8 {tcl::prefix all} {
+    tcl::prefix all {apa aska appa} ap
+} {apa appa}
+test string-27.9 {tcl::prefix all} {
+    tcl::prefix all {apa aska appa} p
+} {}
+test string-27.10 {tcl::prefix all} {
+    tcl::prefix all {apa aska appa} {}
+} {apa aska appa}
+
+test string-28.1 {tcl::prefix longest, too few args} -body {
+    tcl::prefix longest a
+} -returnCodes 1 -result {wrong # args: should be "tcl::prefix longest table string"}
+test string-28.2 {tcl::prefix longest, bad args} -body {
+    tcl::prefix longest a b c
+} -returnCodes 1 -result {wrong # args: should be "tcl::prefix longest table string"}
+test string-28.3 {tcl::prefix longest, bad args} -body {
+    tcl::prefix longest "{}x" str2
+} -returnCodes 1 -result {list element in braces followed by "x" instead of space}
+test string-28.4 {tcl::prefix longest} {
+    tcl::prefix longest {apa bepa cepa depa} c
+} cepa
+test string-28.5 {tcl::prefix longest} {
+    tcl::prefix longest {apa bepa cepa depa} cepa
+} cepa
+test string-28.6 {tcl::prefix longest} {
+    tcl::prefix longest {apa bepa cepa depa} cepax
+} {}
+test string-28.7 {tcl::prefix longest} {
+    tcl::prefix longest {apa aska appa} a
+} a
+test string-28.8 {tcl::prefix longest} {
+    tcl::prefix longest {apa aska appa} ap
+} ap
+test string-28.9 {tcl::prefix longest} {
+    tcl::prefix longest {apa bska appa} a
+} ap
+test string-28.10 {tcl::prefix longest} {
+    tcl::prefix longest {apa bska appa} {}
+} {}
+test string-28.11 {tcl::prefix longest} {
+    tcl::prefix longest {{} bska appa} {}
+} {}
+test string-28.12 {tcl::prefix longest} {
+    tcl::prefix longest {apa {} appa} {}
+} {}
+test string-28.13 {tcl::prefix longest} {
+    # Test UTF8 handling
+    tcl::prefix longest {ax\x90 bep ax\x91} a
+} ax
+
 # cleanup
+rename MemStress {}
 ::tcltest::cleanupTests
 return