Attachment "tip195.patch" to
ticket [1040206fff]
added by
pspjuth
2008-09-20 05:54:19.
diff -Nur -x .git tclmaster/doc/prefix.n tcl/doc/prefix.n
--- tclmaster/doc/prefix.n 1970-01-01 01:00:00.000000000 +0100
+++ tcl/doc/prefix.n 2008-09-19 20:55:13.000000000 +0200
@@ -0,0 +1,93 @@
+'\"
+'\" Copyright (c) 2008 Peter Spjuth <[email protected]>
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+'\" RCS: @(#) $Id: tm.n,v 1.16 2008/06/25 18:18:37 dgp 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 -Nur -x .git tclmaster/generic/tclBasic.c tcl/generic/tclBasic.c
--- tclmaster/generic/tclBasic.c 2008-09-17 20:57:49.000000000 +0200
+++ tcl/generic/tclBasic.c 2008-09-19 20:55:13.000000000 +0200
@@ -750,6 +750,7 @@
TclInitDictCmd(interp);
TclInitInfoCmd(interp);
TclInitStringCmd(interp);
+ TclInitPrefixCmd(interp);
/*
* Register "clock" subcommands. These *do* go through
diff -Nur -x .git tclmaster/generic/tclIndexObj.c tcl/generic/tclIndexObj.c
--- tclmaster/generic/tclIndexObj.c 2008-01-06 17:07:08.000000000 +0100
+++ tcl/generic/tclIndexObj.c 2008-09-20 00:35:32.000000000 +0200
@@ -23,6 +23,15 @@
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[]);
/*
* The structure below defines the index Tcl object type by means of functions
@@ -46,9 +55,9 @@
*/
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;
/*
@@ -72,7 +81,7 @@
*
* 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
@@ -127,6 +136,92 @@
/*
*----------------------------------------------------------------------
*
+ * 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
@@ -135,7 +230,7 @@
*
* 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
@@ -246,8 +341,8 @@
objPtr->typePtr = &indexType;
}
indexRep->tablePtr = (void *) tablePtr;
- indexRep->offset = offset;
- indexRep->index = index;
+ indexRep->offset = offset;
+ indexRep->index = index;
*indexPtr = index;
return TCL_OK;
@@ -336,7 +431,7 @@
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);
@@ -402,6 +497,308 @@
/*
*----------------------------------------------------------------------
*
+ * 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 -Nur -x .git tclmaster/generic/tclInt.h tcl/generic/tclInt.h
--- tclmaster/generic/tclInt.h 2008-09-19 20:54:59.000000000 +0200
+++ tcl/generic/tclInt.h 2008-09-20 00:39:33.000000000 +0200
@@ -3032,6 +3032,7 @@
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 -Nur -x .git tclmaster/tests/string.test tcl/tests/string.test
--- tclmaster/tests/string.test 2008-08-06 20:40:46.000000000 +0200
+++ tcl/tests/string.test 2008-09-19 20:55:13.000000000 +0200
@@ -24,6 +24,9 @@
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}}
@@ -1658,7 +1661,204 @@
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
