diff options
| -rw-r--r-- | ChangeLog | 6 | ||||
| -rw-r--r-- | doc/prefix.n | 93 | ||||
| -rw-r--r-- | generic/tclBasic.c | 3 | ||||
| -rw-r--r-- | generic/tclIndexObj.c | 415 | ||||
| -rw-r--r-- | generic/tclInt.h | 3 | ||||
| -rw-r--r-- | tests/string.test | 202 |
6 files changed, 710 insertions, 12 deletions
@@ -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 |