From 53f461a314e8fda45504e3e1d7a51595d470604e Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 14 Oct 2003 13:38:56 +0000 Subject: TIP#127 Implementation. Thanks to Michael Schlenker for his implementation work --- ChangeLog | 11 + doc/lsearch.n | 38 ++-- doc/lsort.n | 35 ++-- generic/tclCmdIL.c | 598 +++++++++++++++++++++++++++++++++++++++-------------- tests/cmdIL.test | 33 ++- tests/lsearch.test | 78 ++++++- 6 files changed, 601 insertions(+), 192 deletions(-) diff --git a/ChangeLog b/ChangeLog index 25c702e..a65ae8f 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,14 @@ +2003-10-14 Donal K. Fellows + + TIP#127 IMPLEMENTATION FROM JOE MICHAEL SCHLENKER + + * generic/tclCmdIL.c (SelectObjFromSublist): Element selection engine. + * generic/tclCmdIL.c (Tcl_LsearchObjCmd, Tcl_LsortObjCmd): + * tests/lsearch.test: Set up and use of element selection engine, + * tests/cmdIL.test: plus tests and documentation. + * doc/lsearch.n: Based on [Patch 693836] + * doc/lsort.n: + 2003-10-13 Vince Darley * generic/tcl.h: diff --git a/doc/lsearch.n b/doc/lsearch.n index 302a1f5..b2129aa 100644 --- a/doc/lsearch.n +++ b/doc/lsearch.n @@ -6,10 +6,10 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: lsearch.n,v 1.14 2003/03/17 14:21:40 dkf Exp $ +'\" RCS: @(#) $Id: lsearch.n,v 1.15 2003/10/14 13:38:57 dkf Exp $ '\" .so man.macros -.TH lsearch n 8.4 Tcl "Tcl Built-In Commands" +.TH lsearch n 8.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -23,18 +23,14 @@ lsearch \- See if a list contains a particular element This command searches the elements of \fIlist\fR to see if one of them matches \fIpattern\fR. If so, the command returns the index of the first matching element -.VS 8.4 (unless the options \fB\-all\fR or \fB\-inline\fR are specified.) -.VE 8.4 If not, the command returns \fB\-1\fR. The \fIoption\fR arguments indicates how the elements of the list are to be matched against \fIpattern\fR and it must have one of the following values: .TP \fB\-all\fR -.VS 8.4 Changes the result to be the list of all matching indices (or all matching values if \fB\-inline\fR is specified as well.) -.VE 8.4 .TP \fB\-ascii\fR The list elements are to be examined as Unicode strings (the name is @@ -61,22 +57,26 @@ element using the same rules as the \fBstring match\fR command. The list elements are sorted in increasing order. This option is only meaningful when used with \fB\-sorted\fR. .TP +\fB\-index\fR\0\fIindexList\fR +.VS 8.5 +This option is designed for use when searching within nested lists. +The \fIindexList\fR gives a path of indices (much as might be used +with the \fBlsearch\fR command) within each element to allow the +location of the term being matched against. +.VE 8.5 +.TP \fB\-inline\fR -.VS 8.4 The matching value is returned instead of its index (or an empty string if no value matches.) If \fB\-all\fR is also specified, then the result of the command is the list of all values that matched. -.VE 8.4 .TP \fB\-integer\fR The list elements are to be compared as integers. This option is only meaningful when used with \fB\-exact\fR or \fB\-sorted\fR. .TP \fB\-not\fR -.VS 8.4 This negates the sense of the match, returning the index of the first non-matching value in the list. -.VE 8.4 .TP \fB\-real\fR The list elements are to be compared as floating-point values. This @@ -96,13 +96,20 @@ option is mutually exclusive with \fB\-glob\fR and \fB\-regexp\fR, and is treated exactly like \fB-exact\fR when either \fB\-all\fR, or \fB\-not\fR is specified. .TP -\fB\-start\fR \fIindex\fR -.VS 8.4 +\fB\-start\fR\0\fIindex\fR The list is searched starting at position \fIindex\fR. If \fIindex\fR has the value \fBend\fR, it refers to the last element in the list, and \fBend\-\fIinteger\fR refers to the last element in the list minus the specified integer offset. -.VE 8.4 +.TP +\fB\-subindices\fR +.VS 8.5 +If this option is given, the index result from this command (or every +index result when \fB\-all\fR is also specified) will be a complete +path (suitable for use with \fBlindex\fR or \fBlset\fR) within the +overall list to the term found. This option has no effect unless the +\fI\-index\fR is also specified, and is just a convenience short-cut. +.VE 8.5 .PP If \fIoption\fR is omitted then it defaults to \fB\-glob\fR. If more than one of \fB\-exact\fR, \fB\-glob\fR, \fB\-regexp\fR, and @@ -113,7 +120,6 @@ last takes precedence. If more than one of \fB\-increasing\fR and \fB\-decreasing\fR is specified, the option specified last takes precedence. -.VS 8.4 .SH EXAMPLES .CS lsearch {a b c d e} c => 2 @@ -123,14 +129,12 @@ lsearch -inline -not {a20 b35 c47} b* => a20 lsearch -all -inline -not {a20 b35 c47} b* => a20 c47 lsearch -all -not {a20 b35 c47} b* => 0 2 lsearch -start 3 {a b c a b c} c => 5 +lsearch -index 1 -all {{a abc} {b bcd} {c cde}} *bc* => {a abc} {b bcd} .CE -.VE 8.4 .SH "SEE ALSO" -.VS 8.4 foreach(n), list(n), lappend(n), lindex(n), linsert(n), llength(n), lset(n), lsort(n), lrange(n), lreplace(n) -.VE .SH KEYWORDS list, match, pattern, regular expression, search, string diff --git a/doc/lsort.n b/doc/lsort.n index 1af8dc6..217c094 100644 --- a/doc/lsort.n +++ b/doc/lsort.n @@ -7,7 +7,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: lsort.n,v 1.13 2003/03/17 14:21:41 dkf Exp $ +'\" RCS: @(#) $Id: lsort.n,v 1.14 2003/10/14 13:38:58 dkf Exp $ '\" .so man.macros .TH lsort n 8.3 Tcl "Tcl Built-In Commands" @@ -65,32 +65,39 @@ This is the default. \fB\-decreasing\fR Sort the list in decreasing order (``largest'' items first). .TP 20 -\fB\-index\0\fIindex\fR +\fB\-index\0\fIindexList\fR If this option is specified, each of the elements of \fIlist\fR must itself be a proper Tcl sublist. Instead of sorting based on whole -sublists, \fBlsort\fR will extract the \fIindex\fR'th element from -each sublist and sort based on the given element. The keyword -\fBend\fP is allowed for the \fIindex\fP to sort on the last sublist -element, -.VS 8.4 -and \fBend-\fIindex\fR sorts on a sublist element offset from -the end. -.VE +sublists, \fBlsort\fR will extract the \fIindexList\fR'th element from +each sublist +.VS 8.5 +(as if the overall element and the \fIindexList\fR were passed to +\fBlindex\fR) and sort based on the given element. The keyword +\fBend\fP is allowed for each element of the \fIindexList\fR to sort +on the last sublist element, and \fBend-\fIindex\fR sorts on a sublist +element offset from the end. +.VE 8.5 For example, .RS .CS lsort -integer -index 1 {{First 24} {Second 18} {Third 30}} .CE returns \fB{Second 18} {First 24} {Third 30}\fR, and -.VS 8.4 '\" '\" This example is from the test suite! '\" .CS lsort -index end-1 {{a 1 e i} {b 2 3 f g} {c 4 5 6 d h}} .CE -returns \fB{c 4 5 6 d h} {a 1 e i} {b 2 3 f g}\fR. -.VE +returns \fB{c 4 5 6 d h} {a 1 e i} {b 2 3 f g}\fR, +.VS 8.5 +and +.CS +lsort -index {0 1} {{{b i g} 12345} {{d e m o} 34512} {{c o d e} 54321}} +.CE +returns \fB{{d e m o} 34512} {{b i g} 12345} {{c o d e} 54321}\fR +(because \fBe\fR sorts before \fBi\fR which sorts before \fBo\fR.) +.VE 8.5 This option is much more efficient than using \fB\-command\fR to achieve the same effect. .RE @@ -186,10 +193,8 @@ More complex sorting using a comparison function: .CE .SH "SEE ALSO" -.VS 8.4 list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), lset(n), lrange(n), lreplace(n) -.VE .SH KEYWORDS element, list, order, sort diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 467241d..e9e8685 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -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: tclCmdIL.c,v 1.52 2003/08/11 13:26:13 dkf Exp $ + * RCS: @(#) $Id: tclCmdIL.c,v 1.53 2003/10/14 13:38:58 dkf Exp $ */ #include "tclInt.h" @@ -31,7 +31,7 @@ typedef struct SortElement { Tcl_Obj *objPtr; /* Object being sorted. */ int count; /* number of same elements in list */ - struct SortElement *nextPtr; /* Next element in the list, or + struct SortElement *nextPtr; /* Next element in the list, or * NULL for end of list. */ } SortElement; @@ -50,8 +50,8 @@ typedef struct SortInfo { Tcl_Obj *compareCmdPtr; /* The Tcl comparison command when sortMode * is SORTMODE_COMMAND. Pre-initialized to * hold base of command.*/ - int index; /* If the -index option was specified, this - * holds the index of the list element + Tcl_Obj *indexObj; /* If the -index option was specified, this + * holds the index Obj of the list element * to extract for comparison. If -index * wasn't specified, this is -1. */ Tcl_Interp *interp; /* The interpreter in which the sortis @@ -157,6 +157,9 @@ static SortElement * MergeLists _ANSI_ARGS_((SortElement *leftPtr, SortElement *rightPtr, SortInfo *infoPtr)); static int SortCompare _ANSI_ARGS_((Tcl_Obj *firstPtr, Tcl_Obj *second, SortInfo *infoPtr)); +static Tcl_Obj * SelectObjFromSublist _ANSI_ARGS_((Tcl_Obj *firstPtr, + SortInfo *infoPtr)); + /* *---------------------------------------------------------------------- @@ -504,7 +507,7 @@ Tcl_InfoObjCmd(clientData, interp, objc, objv) * Called to implement the "info args" command that returns the * argument list for a procedure. Handles the following syntax: * - * info args procName + * info args procName * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. @@ -566,7 +569,7 @@ InfoArgsCmd(dummy, interp, objc, objv) * Called to implement the "info body" command that returns the body * for a procedure. Handles the following syntax: * - * info body procName + * info body procName * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. @@ -635,7 +638,7 @@ InfoBodyCmd(dummy, interp, objc, objv) * number of commands that have been executed. Handles the following * syntax: * - * info cmdcount + * info cmdcount * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. @@ -677,7 +680,7 @@ InfoCmdCountCmd(dummy, interp, objc, objv) * glob-style pattern that restricts which commands are returned. * Handles the following syntax: * - * info commands ?pattern? + * info commands ?pattern? * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. @@ -753,7 +756,7 @@ InfoCommandsCmd(dummy, interp, objc, objv) while (entryPtr != NULL) { cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); if ((simplePattern == NULL) - || Tcl_StringMatch(cmdName, simplePattern)) { + || Tcl_StringMatch(cmdName, simplePattern)) { if (specificNsInPattern) { cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); elemObjPtr = Tcl_NewObj(); @@ -779,7 +782,7 @@ InfoCommandsCmd(dummy, interp, objc, objv) while (entryPtr != NULL) { cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr); if ((simplePattern == NULL) - || Tcl_StringMatch(cmdName, simplePattern)) { + || Tcl_StringMatch(cmdName, simplePattern)) { if (Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(cmdName, -1)); @@ -803,7 +806,7 @@ InfoCommandsCmd(dummy, interp, objc, objv) * whether a string is a complete Tcl command. Handles the following * syntax: * - * info complete command + * info complete command * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. @@ -845,7 +848,7 @@ InfoCompleteCmd(dummy, interp, objc, objv) * default value for a procedure argument. Handles the following * syntax: * - * info default procName arg varName + * info default procName arg varName * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. @@ -896,7 +899,7 @@ InfoDefaultCmd(dummy, interp, objc, objv) defStoreError: varName = Tcl_GetString(objv[4]); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "couldn't store default value in variable \"", + "couldn't store default value in variable \"", varName, "\"", (char *) NULL); return TCL_ERROR; } @@ -929,7 +932,7 @@ InfoDefaultCmd(dummy, interp, objc, objv) * Called to implement the "info exists" command that determines * whether a variable exists. Handles the following syntax: * - * info exists varName + * info exists varName * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. @@ -975,7 +978,7 @@ InfoExistsCmd(dummy, interp, objc, objv) * list of math functions matching an optional pattern. Handles the * following syntax: * - * info functions ?pattern? + * info functions ?pattern? * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. @@ -1023,7 +1026,7 @@ InfoFunctionsCmd(dummy, interp, objc, objv) * of global variables matching an optional pattern. Handles the * following syntax: * - * info globals ?pattern? + * info globals ?pattern? * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. @@ -1089,7 +1092,7 @@ InfoGlobalsCmd(dummy, interp, objc, objv) * Called to implement the "info hostname" command that returns the * host name. Handles the following syntax: * - * info hostname + * info hostname * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. @@ -1133,7 +1136,7 @@ InfoHostnameCmd(dummy, interp, objc, objv) * Called to implement the "info level" command that returns * information about the call stack. Handles the following syntax: * - * info level ?number? + * info level ?number? * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. @@ -1207,7 +1210,7 @@ InfoLevelCmd(dummy, interp, objc, objv) * library directory for the Tcl installation. Handles the following * syntax: * - * info library + * info library * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. @@ -1252,7 +1255,7 @@ InfoLibraryCmd(dummy, interp, objc, objv) * packages that have been loaded into an interpreter. Handles the * following syntax: * - * info loaded ?interp? + * info loaded ?interp? * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. @@ -1297,7 +1300,7 @@ InfoLoadedCmd(dummy, interp, objc, objv) * local variables that match an optional pattern. Handles the * following syntax: * - * info locals ?pattern? + * info locals ?pattern? * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. @@ -1389,11 +1392,11 @@ AppendLocals(interp, listPtr, pattern, includeLinks) */ if (!TclIsVarTemporary(localPtr) && !TclIsVarUndefined(varPtr) - && (includeLinks || !TclIsVarLink(varPtr))) { + && (includeLinks || !TclIsVarLink(varPtr))) { varName = varPtr->name; if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewStringObj(varName, -1)); + Tcl_NewStringObj(varName, -1)); } } varPtr++; @@ -1402,14 +1405,14 @@ AppendLocals(interp, listPtr, pattern, includeLinks) if (localVarTablePtr != NULL) { for (entryPtr = Tcl_FirstHashEntry(localVarTablePtr, &search); - entryPtr != NULL; + entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&search)) { varPtr = (Var *) Tcl_GetHashValue(entryPtr); if (!TclIsVarUndefined(varPtr) && (includeLinks || !TclIsVarLink(varPtr))) { varName = Tcl_GetHashKey(localVarTablePtr, entryPtr); if ((pattern == NULL) - || Tcl_StringMatch(varName, pattern)) { + || Tcl_StringMatch(varName, pattern)) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(varName, -1)); } @@ -1427,7 +1430,7 @@ AppendLocals(interp, listPtr, pattern, includeLinks) * the name of the binary file running this application. Handles the * following syntax: * - * info nameofexecutable + * info nameofexecutable * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. @@ -1470,7 +1473,7 @@ InfoNameOfExecutableCmd(dummy, interp, objc, objv) * default value for an argument to a procedure. Handles the following * syntax: * - * info patchlevel + * info patchlevel * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. @@ -1517,7 +1520,7 @@ InfoPatchLevelCmd(dummy, interp, objc, objv) * glob-style pattern that restricts which commands are returned. * Handles the following syntax: * - * info procs ?pattern? + * info procs ?pattern? * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. @@ -1595,14 +1598,14 @@ InfoProcsCmd(dummy, interp, objc, objv) while (entryPtr != NULL) { cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); if ((simplePattern == NULL) - || Tcl_StringMatch(cmdName, simplePattern)) { + || Tcl_StringMatch(cmdName, simplePattern)) { cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); realCmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); if (TclIsProc(cmdPtr) - || ((realCmdPtr != NULL) && TclIsProc(realCmdPtr))) { + || ((realCmdPtr != NULL) && TclIsProc(realCmdPtr))) { if (specificNsInPattern) { elemObjPtr = Tcl_NewObj(); Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, @@ -1638,16 +1641,16 @@ InfoProcsCmd(dummy, interp, objc, objv) while (entryPtr != NULL) { cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr); if ((simplePattern == NULL) - || Tcl_StringMatch(cmdName, simplePattern)) { + || Tcl_StringMatch(cmdName, simplePattern)) { if (Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) { cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); realCmdPtr = (Command *) TclGetOriginalCommand( - (Tcl_Command) cmdPtr); + (Tcl_Command) cmdPtr); if (TclIsProc(cmdPtr) || ((realCmdPtr != NULL) && TclIsProc(realCmdPtr))) { Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewStringObj(cmdName, -1)); + Tcl_NewStringObj(cmdName, -1)); } } } @@ -1670,7 +1673,7 @@ InfoProcsCmd(dummy, interp, objc, objv) * script file that is currently being evaluated. Handles the * following syntax: * - * info script ?newName? + * info script ?newName? * * If newName is specified, it will set that as the internal name. * @@ -1720,7 +1723,7 @@ InfoScriptCmd(dummy, interp, objc, objv) * returns the file extension used for shared libraries. Handles the * following syntax: * - * info sharedlibextension + * info sharedlibextension * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. @@ -1758,7 +1761,7 @@ InfoSharedlibCmd(dummy, interp, objc, objv) * Called to implement the "info tclversion" command that returns the * version number for this Tcl library. Handles the following syntax: * - * info tclversion + * info tclversion * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. @@ -1805,7 +1808,7 @@ InfoTclVersionCmd(dummy, interp, objc, objv) * glob-style pattern that restricts which variables are returned. * Handles the following syntax: * - * info vars ?pattern? + * info vars ?pattern? * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. @@ -1897,11 +1900,11 @@ InfoVarsCmd(dummy, interp, objc, objv) || (varPtr->flags & VAR_NAMESPACE_VAR)) { varName = Tcl_GetHashKey(&nsPtr->varTable, entryPtr); if ((simplePattern == NULL) - || Tcl_StringMatch(varName, simplePattern)) { + || Tcl_StringMatch(varName, simplePattern)) { if (specificNsInPattern) { elemObjPtr = Tcl_NewObj(); Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, - elemObjPtr); + elemObjPtr); } else { elemObjPtr = Tcl_NewStringObj(varName, -1); } @@ -1925,14 +1928,14 @@ InfoVarsCmd(dummy, interp, objc, objv) while (entryPtr != NULL) { varPtr = (Var *) Tcl_GetHashValue(entryPtr); if (!TclIsVarUndefined(varPtr) - || (varPtr->flags & VAR_NAMESPACE_VAR)) { - varName = Tcl_GetHashKey(&globalNsPtr->varTable, - entryPtr); + || (varPtr->flags & VAR_NAMESPACE_VAR)) { + varName = Tcl_GetHashKey(&globalNsPtr->varTable, entryPtr); if ((simplePattern == NULL) - || Tcl_StringMatch(varName, simplePattern)) { - if (Tcl_FindHashEntry(&nsPtr->varTable, varName) == NULL) { + || Tcl_StringMatch(varName, simplePattern)) { + if (Tcl_FindHashEntry(&nsPtr->varTable, + varName) == NULL) { Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewStringObj(varName, -1)); + Tcl_NewStringObj(varName, -1)); } } } @@ -2173,13 +2176,12 @@ TclLindexList( interp, listPtr, argPtr ) } /* - * Get the index from indices[ i ] + * Get the index from indices[i] */ - result = TclGetIntForIndex( interp, indices[ i ], - /*endValue*/ (listLen - 1), - &index ); - if ( result != TCL_OK ) { + result = TclGetIntForIndex(interp, indices[i], /*endValue*/ listLen-1, + &index); + if (result != TCL_OK) { /* * Index could not be parsed */ @@ -2864,21 +2866,23 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) char *bytes, *patternBytes; int i, match, mode, index, result, listc, length, elemLen; int dataType, isIncreasing, lower, upper, patInt, objInt; - int offset, allMatches, inlineReturn, negatedMatch; + int offset, allMatches, inlineReturn, negatedMatch, returnSubindices; double patDouble, objDouble; - Tcl_Obj *patObj, **listv, *listPtr, *startPtr; + SortInfo sortInfo; + Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr; Tcl_RegExp regexp = NULL; static CONST char *options[] = { - "-all", "-ascii", "-decreasing", "-dictionary", - "-exact", "-glob", "-increasing", "-inline", - "-integer", "-not", "-real", "-regexp", - "-sorted", "-start", NULL + "-all", "-ascii", "-decreasing", "-dictionary", + "-exact", "-glob", "-increasing", "-index", + "-inline", "-integer", "-not", "-real", + "-regexp", "-sorted", "-start", "-subindices", + NULL }; enum options { LSEARCH_ALL, LSEARCH_ASCII, LSEARCH_DECREASING, LSEARCH_DICTIONARY, - LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_INCREASING, LSEARCH_INLINE, - LSEARCH_INTEGER, LSEARCH_NOT, LSEARCH_REAL, LSEARCH_REGEXP, - LSEARCH_SORTED, LSEARCH_START + LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_INCREASING, LSEARCH_INDEX, + LSEARCH_INLINE, LSEARCH_INTEGER, LSEARCH_NOT, LSEARCH_REAL, + LSEARCH_REGEXP, LSEARCH_SORTED, LSEARCH_START, LSEARCH_SUBINDICES }; enum datatypes { ASCII, DICTIONARY, INTEGER, REAL @@ -2892,10 +2896,17 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) isIncreasing = 1; allMatches = 0; inlineReturn = 0; + returnSubindices = 0; negatedMatch = 0; listPtr = NULL; startPtr = NULL; offset = 0; + sortInfo.compareCmdPtr = NULL; + sortInfo.isIncreasing = 0; + sortInfo.sortMode = 0; + sortInfo.interp = interp; + sortInfo.resultCode = TCL_OK; + sortInfo.indexObj = NULL; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "?options? list pattern"); @@ -2905,9 +2916,12 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) for (i = 1; i < objc-2; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) != TCL_OK) { - if (startPtr) { + if (startPtr != NULL) { Tcl_DecrRefCount(startPtr); } + if (sortInfo.indexObj != NULL) { + Tcl_DecrRefCount(sortInfo.indexObj); + } return TCL_ERROR; } switch ((enum options) index) { @@ -2950,16 +2964,22 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) case LSEARCH_SORTED: /* -sorted */ mode = SORTED; break; + case LSEARCH_SUBINDICES: /* -subindices */ + returnSubindices = 1; + break; case LSEARCH_START: /* -start */ /* * If there was a previous -start option, release its saved * index because it will either be replaced or there will be * an error. */ - if (startPtr) { + if (startPtr != NULL) { Tcl_DecrRefCount(startPtr); } if (i > objc-4) { + if (sortInfo.indexObj != NULL) { + Tcl_DecrRefCount(sortInfo.indexObj); + } Tcl_AppendResult(interp, "missing starting index", NULL); return TCL_ERROR; } @@ -2977,7 +2997,57 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) startPtr = objv[i]; Tcl_IncrRefCount(startPtr); } + break; + case LSEARCH_INDEX: /* -index */ + if (i > objc-4) { + if (startPtr != NULL) { + Tcl_DecrRefCount(startPtr); + } + if (sortInfo.indexObj != NULL) { + Tcl_DecrRefCount(sortInfo.indexObj); + } + Tcl_AppendResult(interp, + "\"-index\" option must be followed by list index", + NULL); + return TCL_ERROR; + } + + /* + * Store pointer to index for processing by sublist + * extraction. + */ + if (sortInfo.indexObj != NULL) { + Tcl_DecrRefCount(sortInfo.indexObj); + } + i++; + if (objv[i] == objv[objc - 2]) { + /* + * Take copy to prevent shimmering problems. Note + * that it does not matter if the index obj is also a + * component of the list being searched. We only need + * to copy where the list and the index are + * one-and-the-same. + */ + sortInfo.indexObj = Tcl_DuplicateObj(objv[i]); + } else { + sortInfo.indexObj = objv[i]; + Tcl_IncrRefCount(sortInfo.indexObj); + } + break; + } + } + + /* + * Subindices only make sense if asked for with -index option set. + */ + + if (returnSubindices && sortInfo.indexObj==NULL) { + if (startPtr != NULL) { + Tcl_DecrRefCount(startPtr); } + Tcl_AppendResult(interp, + "-subindices cannot be used without -index option", NULL); + return TCL_ERROR; } if ((enum modes) mode == REGEXP) { @@ -2988,9 +3058,12 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) regexp = Tcl_GetRegExpFromObj(interp, objv[objc - 1], TCL_REG_ADVANCED | TCL_REG_NOSUB); if (regexp == NULL) { - if (startPtr) { + if (startPtr != NULL) { Tcl_DecrRefCount(startPtr); } + if (sortInfo.indexObj != NULL) { + Tcl_DecrRefCount(sortInfo.indexObj); + } return TCL_ERROR; } } @@ -3002,9 +3075,12 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) result = Tcl_ListObjGetElements(interp, objv[objc - 2], &listc, &listv); if (result != TCL_OK) { - if (startPtr) { + if (startPtr != NULL) { Tcl_DecrRefCount(startPtr); } + if (sortInfo.indexObj != NULL) { + Tcl_DecrRefCount(sortInfo.indexObj); + } return result; } @@ -3015,6 +3091,9 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) result = TclGetIntForIndex(interp, startPtr, listc-1, &offset); Tcl_DecrRefCount(startPtr); if (result != TCL_OK) { + if (sortInfo.indexObj != NULL) { + Tcl_DecrRefCount(sortInfo.indexObj); + } return result; } if (offset > listc-1) { @@ -3036,12 +3115,18 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) case INTEGER: result = Tcl_GetIntFromObj(interp, patObj, &patInt); if (result != TCL_OK) { + if (sortInfo.indexObj != NULL) { + Tcl_DecrRefCount(sortInfo.indexObj); + } return result; } break; case REAL: result = Tcl_GetDoubleFromObj(interp, patObj, &patDouble); if (result != TCL_OK) { + if (sortInfo.indexObj != NULL) { + Tcl_DecrRefCount(sortInfo.indexObj); + } return result; } break; @@ -3068,20 +3153,30 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) */ lower = offset - 1; upper = listc; - while (lower + 1 != upper) { + while (lower + 1 != upper && sortInfo.resultCode == TCL_OK) { i = (lower + upper)/2; + itemPtr = SelectObjFromSublist(listv[i], &sortInfo); + if (sortInfo.resultCode != TCL_OK) { + if (sortInfo.indexObj != NULL) { + Tcl_DecrRefCount(sortInfo.indexObj); + } + return sortInfo.resultCode; + } switch ((enum datatypes) dataType) { case ASCII: - bytes = Tcl_GetString(listv[i]); + bytes = Tcl_GetString(itemPtr); match = strcmp(patternBytes, bytes); break; case DICTIONARY: - bytes = Tcl_GetString(listv[i]); + bytes = Tcl_GetString(itemPtr); match = DictionaryCompare(patternBytes, bytes); break; case INTEGER: - result = Tcl_GetIntFromObj(interp, listv[i], &objInt); + result = Tcl_GetIntFromObj(interp, itemPtr, &objInt); if (result != TCL_OK) { + if (sortInfo.indexObj != NULL) { + Tcl_DecrRefCount(sortInfo.indexObj); + } return result; } if (patInt == objInt) { @@ -3093,8 +3188,11 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) } break; case REAL: - result = Tcl_GetDoubleFromObj(interp, listv[i], &objDouble); + result = Tcl_GetDoubleFromObj(interp, itemPtr, &objDouble); if (result != TCL_OK) { + if (sortInfo.indexObj != NULL) { + Tcl_DecrRefCount(sortInfo.indexObj); + } return result; } if (patDouble == objDouble) { @@ -3148,55 +3246,75 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) } for (i = offset; i < listc; i++) { match = 0; + itemPtr = SelectObjFromSublist(listv[i], &sortInfo); + if (sortInfo.resultCode != TCL_OK) { + if (listPtr != NULL) { + Tcl_DecrRefCount(listPtr); + } + if (sortInfo.indexObj != NULL) { + Tcl_DecrRefCount(sortInfo.indexObj); + } + return sortInfo.resultCode; + } switch ((enum modes) mode) { case SORTED: case EXACT: switch ((enum datatypes) dataType) { case ASCII: - bytes = Tcl_GetStringFromObj(listv[i], &elemLen); + bytes = Tcl_GetStringFromObj(itemPtr, &elemLen); if (length == elemLen) { match = (memcmp(bytes, patternBytes, (size_t) length) == 0); } break; case DICTIONARY: - bytes = Tcl_GetString(listv[i]); + bytes = Tcl_GetString(itemPtr); match = (DictionaryCompare(bytes, patternBytes) == 0); break; + case INTEGER: - result = Tcl_GetIntFromObj(interp, listv[i], &objInt); + result = Tcl_GetIntFromObj(interp, itemPtr, &objInt); if (result != TCL_OK) { - if (listPtr) { + if (listPtr != NULL) { Tcl_DecrRefCount(listPtr); } + if (sortInfo.indexObj != NULL) { + Tcl_DecrRefCount(sortInfo.indexObj); + } return result; } match = (objInt == patInt); break; + case REAL: - result = Tcl_GetDoubleFromObj(interp, listv[i], - &objDouble); + result = Tcl_GetDoubleFromObj(interp, itemPtr, &objDouble); if (result != TCL_OK) { if (listPtr) { Tcl_DecrRefCount(listPtr); } + if (sortInfo.indexObj != NULL) { + Tcl_DecrRefCount(sortInfo.indexObj); + } return result; } match = (objDouble == patDouble); break; } break; + case GLOB: - match = Tcl_StringMatch(Tcl_GetString(listv[i]), - patternBytes); + match = Tcl_StringMatch(Tcl_GetString(itemPtr), patternBytes); break; case REGEXP: - match = Tcl_RegExpExecObj(interp, regexp, listv[i], 0, 0, 0); + match = Tcl_RegExpExecObj(interp, regexp, itemPtr, 0, 0, 0); if (match < 0) { Tcl_DecrRefCount(patObj); - if (listPtr) { + if (listPtr != NULL) { Tcl_DecrRefCount(listPtr); } + if (sortInfo.indexObj != NULL) { + Tcl_DecrRefCount(sortInfo.indexObj); + } return TCL_ERROR; } break; @@ -3207,19 +3325,28 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) if (negatedMatch) { match = !match; } - if (match != 0) { - if (!allMatches) { - index = i; - break; - } else if (inlineReturn) { - /* - * Note that these appends are not expected to fail. - */ - Tcl_ListObjAppendElement(interp, listPtr, listv[i]); + if (!match) { + continue; + } + if (!allMatches) { + index = i; + break; + } else if (inlineReturn) { + /* + * Note that these appends are not expected to fail. + */ + if (returnSubindices) { + itemPtr = SelectObjFromSublist(listv[i], &sortInfo); } else { - Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewIntObj(i)); + itemPtr = listv[i]; } + Tcl_ListObjAppendElement(interp, listPtr, itemPtr); + } else if (returnSubindices) { + itemPtr = Tcl_NewIntObj(i); + Tcl_ListObjAppendList(interp, itemPtr, sortInfo.indexObj); + Tcl_ListObjAppendElement(interp, listPtr, itemPtr); + } else { + Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewIntObj(i)); } } } @@ -3230,7 +3357,13 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) if (allMatches) { Tcl_SetObjResult(interp, listPtr); } else if (!inlineReturn) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), index); + if (returnSubindices) { + itemPtr = Tcl_NewIntObj(index); + Tcl_ListObjAppendList(interp, itemPtr, sortInfo.indexObj); + Tcl_SetObjResult(interp, itemPtr); + } else { + Tcl_SetIntObj(Tcl_GetObjResult(interp), index); + } } else if (index < 0) { /* * Is this superfluous? The result should be a blank object @@ -3240,6 +3373,12 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) } else { Tcl_SetObjResult(interp, listv[index]); } + /* + * Cleanup the index list reference + */ + if (sortInfo.indexObj != NULL) { + Tcl_DecrRefCount(sortInfo.indexObj); + } return TCL_OK; } @@ -3373,7 +3512,7 @@ Tcl_LsortObjCmd(clientData, interp, objc, objv) sortInfo.isIncreasing = 1; sortInfo.sortMode = SORTMODE_ASCII; - sortInfo.index = SORTIDX_NONE; + sortInfo.indexObj = NULL; sortInfo.interp = interp; sortInfo.resultCode = TCL_OK; cmdPtr = NULL; @@ -3414,10 +3553,8 @@ Tcl_LsortObjCmd(clientData, interp, objc, objv) -1); return TCL_ERROR; } - if (TclGetIntForIndex(interp, objv[i+1], SORTIDX_END, - &sortInfo.index) != TCL_OK) { - return TCL_ERROR; - } + sortInfo.indexObj = objv[i+1]; + Tcl_IncrRefCount(sortInfo.indexObj); i++; break; case 6: /* -integer */ @@ -3495,6 +3632,9 @@ Tcl_LsortObjCmd(clientData, interp, objc, objv) Tcl_DecrRefCount(sortInfo.compareCmdPtr); sortInfo.compareCmdPtr = NULL; } + if (sortInfo.indexObj != NULL) { + Tcl_DecrRefCount(sortInfo.indexObj); + } return sortInfo.resultCode; } @@ -3655,75 +3795,26 @@ SortCompare(objPtr1, objPtr2, infoPtr) SortInfo *infoPtr; /* Information passed from the * top-level "lsort" command */ { - int order, listLen, index; - Tcl_Obj *objPtr; - char buffer[TCL_INTEGER_SPACE]; + int order; order = 0; if (infoPtr->resultCode != TCL_OK) { /* - * Once an error has occurred, skip any future comparisons - * so as to preserve the error message in sortInterp->result. + * Once an error has occurred, skip any future comparisons so + * as to preserve the error message in sortInterp->result. */ - return order; } - if (infoPtr->index != SORTIDX_NONE) { - /* - * The "-index" option was specified. Treat each object as a - * list, extract the requested element from each list, and - * compare the elements, not the lists. "end"-relative indices - * are signaled here with large negative values. - */ - if (Tcl_ListObjLength(infoPtr->interp, objPtr1, &listLen) != TCL_OK) { - infoPtr->resultCode = TCL_ERROR; - return order; - } - if (infoPtr->index < SORTIDX_NONE) { - index = listLen + infoPtr->index + 1; - } else { - index = infoPtr->index; - } - - if (Tcl_ListObjIndex(infoPtr->interp, objPtr1, index, &objPtr) - != TCL_OK) { - infoPtr->resultCode = TCL_ERROR; - return order; - } - if (objPtr == NULL) { - objPtr = objPtr1; - missingElement: - TclFormatInt(buffer, infoPtr->index); - Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp), - "element ", buffer, " missing from sublist \"", - Tcl_GetString(objPtr), "\"", (char *) NULL); - infoPtr->resultCode = TCL_ERROR; - return order; - } - objPtr1 = objPtr; - - if (Tcl_ListObjLength(infoPtr->interp, objPtr2, &listLen) != TCL_OK) { - infoPtr->resultCode = TCL_ERROR; - return order; - } - if (infoPtr->index < SORTIDX_NONE) { - index = listLen + infoPtr->index + 1; - } else { - index = infoPtr->index; - } - - if (Tcl_ListObjIndex(infoPtr->interp, objPtr2, index, &objPtr) - != TCL_OK) { - infoPtr->resultCode = TCL_ERROR; - return order; - } - if (objPtr == NULL) { - objPtr = objPtr2; - goto missingElement; - } - objPtr2 = objPtr; + objPtr1 = SelectObjFromSublist(objPtr1,infoPtr); + if (infoPtr->resultCode != TCL_OK) { + return order; + } + objPtr2 = SelectObjFromSublist(objPtr2,infoPtr); + if (infoPtr->resultCode != TCL_OK) { + return order; } + if (infoPtr->sortMode == SORTMODE_ASCII) { order = strcmp(Tcl_GetString(objPtr1), Tcl_GetString(objPtr2)); } else if (infoPtr->sortMode == SORTMODE_DICTIONARY) { @@ -3933,3 +4024,200 @@ DictionaryCompare(left, right) } return diff; } + +/* + *---------------------------------------------------------------------- + * + * SelectObjFromSublist -- + * + * This procedure is invoked from lsearch and SortCompare. It is + * used for implementing the -index option, for the lsort and + * lsearch commands. + * + * Results: + * Returns NULL if a failure occurs, and sets the result in the + * infoPtr. Otherwise returns the Tcl_Obj* to the item. + * + * Side effects: + * None. + * + * Note: + * No reference counting is done, as the result is only used + * internally and never passed directly to user code. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Obj* +SelectObjFromSublist(objPtr, infoPtr) + Tcl_Obj *objPtr; /* Obj to select sublist from. */ + SortInfo *infoPtr; /* Information passed from the + * top-level "lsearch" or "lsort" + * command. */ +{ + int listLen, index, baseIndex, result, i; + Tcl_Obj *currentObj; /* Current object being processed. */ + Tcl_Obj **indices; /* Array of list indices. */ + Tcl_Obj **elemPtrs; /* Elements of the list being + * manipulated. */ + int indexCount; /* Size of the indices array. */ + char buffer[TCL_INTEGER_SPACE]; + + /* + * Quick check for case when no "-index" option is there. + */ + + if (infoPtr->indexObj == NULL) { + return objPtr; + } + + /* + * The "-index" option was specified. Treat each object as a + * list, extract the requested element from each list. + */ + + /* + * Detect if we have only one index or a list of indices. + */ + + if (infoPtr->indexObj->typePtr != &tclListType + && TclGetIntForIndex(NULL, infoPtr->indexObj, SORTIDX_END, + &baseIndex) == TCL_OK) { + /* + * Flat case, only one index given + */ + + if (Tcl_ListObjLength(infoPtr->interp, objPtr, &listLen) != TCL_OK) { + infoPtr->resultCode = TCL_ERROR; + return NULL; + } + + if (baseIndex < SORTIDX_NONE) { + index = listLen + baseIndex + 1; + } else { + index = baseIndex; + } + + if (Tcl_ListObjIndex(infoPtr->interp, objPtr, index, + ¤tObj) != TCL_OK) { + infoPtr->resultCode = TCL_ERROR; + return NULL; + } + + if (currentObj == NULL) { + TclFormatInt(buffer, index); + Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp), + "element ", buffer, " missing from sublist \"", + Tcl_GetString(objPtr), "\"", (char *) NULL); + infoPtr->resultCode = TCL_ERROR; + return NULL; + } + + /* + * currentObj contains element, we are done + */ + + return currentObj; + } + + /* + * Non flat case, index should be a list of indices. + */ + + if (Tcl_ListObjGetElements(NULL, infoPtr->indexObj, &indexCount, + &indices) != TCL_OK) { + /* + * infoPtr->indexObj designates something that is neither an + * index nor a well-formed list. Report the error.. + */ + + Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp), + "argument \"", Tcl_GetString(infoPtr->indexObj), + "\" given to -index is invalid", (char *) NULL); + infoPtr->resultCode = TCL_ERROR; + return NULL; + } + + /* + * infoPtr designates a list, and we've parsed it into indexCount + * and indices. + */ + + currentObj = objPtr; + for (i=0 ; iinterp, currentObj, + &listLen, &elemPtrs); + if (result != TCL_OK) { + infoPtr->resultCode = result; + return NULL; + } + + /* + * Get the index from indices[i], taking care of any end-x + * notation. + */ + + result = TclGetIntForIndex(infoPtr->interp, indices[i], SORTIDX_END, + &baseIndex); + if (result != TCL_OK) { + infoPtr->resultCode = result; + return NULL; + } + if (baseIndex < SORTIDX_NONE) { + index = listLen + baseIndex + 1; + } else { + index = baseIndex; + } + if (index >= listLen || index < 0) { + TclFormatInt(buffer, index); + Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp), + "element ", buffer, " missing from sublist \"", + Tcl_GetString(currentObj), "\"", (char *) NULL); + infoPtr->resultCode = TCL_ERROR; + return NULL; + } + + /* + * Make sure listPtr still refers to a list object. If it + * shared a Tcl_Obj structure with the arguments, then it + * might have just been converted to something else. + */ + + if (currentObj->typePtr != &tclListType) { + result = Tcl_ListObjGetElements(infoPtr->interp, currentObj, + &listLen, &elemPtrs); + if (result != TCL_OK) { + infoPtr->resultCode = result; + return NULL; + } + } + + /* + * Extract the pointer to the appropriate element. + */ + + currentObj = elemPtrs[index]; + + /* + * The work we did above may have caused the internal rep + * of *argPtr to change to something else. Get it back. + */ + + result = Tcl_ListObjGetElements(infoPtr->interp, infoPtr->indexObj, + &indexCount, &indices); + if (result != TCL_OK) { + /* + * This can't happen unless some extension corrupted a + * Tcl_Obj. + */ + infoPtr->resultCode = result; + return NULL; + } + } + + return currentObj; +} diff --git a/tests/cmdIL.test b/tests/cmdIL.test index 01094b1..199fbd5 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.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: cmdIL.test,v 1.15 2003/07/15 15:42:05 dkf Exp $ +# RCS: @(#) $Id: cmdIL.test,v 1.16 2003/10/14 13:38:58 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -356,6 +356,37 @@ test cmdIL-4.33 {DictionaryCompare procedure, chars between Z and a in ASCII} { lsort -dictionary [list AA ! c CC `] } [list ! ` AA c CC] +test cmdIL-5.1 {lsort with list style index} { + lsort -ascii -decreasing -index {0 1} { + {{Jim Alpha} 20000410} + {{Joe Bravo} 19990320} + {{Jacky Charlie} 19390911} + } +} {{{Jacky Charlie} 19390911} {{Joe Bravo} 19990320} {{Jim Alpha} 20000410}} +test cmdIL-5.2 {lsort with list style index} { + lsort -decreasing -index {0 1} { + {{Jim Alpha} 20000410} + {{Joe Bravo} 19990320} + {{Jacky Charlie} 19390911} + } +} {{{Jacky Charlie} 19390911} {{Joe Bravo} 19990320} {{Jim Alpha} 20000410}} +test cmdIL-5.3 {lsort with list style index} { + lsort -integer -increasing -index {1 end} { + {{Jim Alpha} 20000410} + {{Joe Bravo} 19990320} + {{Jacky Charlie} 19390911} + } +} {{{Jacky Charlie} 19390911} {{Joe Bravo} 19990320} {{Jim Alpha} 20000410}} +test cmdIL-5.4 {lsort with list style index} { + lsort -integer -index {1 end-1} { + {the {0 1 2 3 4 5} quick} + {brown {0 1 2 3 4} fox} + {jumps {30 31 2 33} over} + {the {0 1 2} lazy} + {dogs {0 1}} + } +} {{dogs {0 1}} {the {0 1 2} lazy} {jumps {30 31 2 33} over} {brown {0 1 2 3 4} fox} {the {0 1 2 3 4 5} quick}} + # cleanup ::tcltest::cleanupTests return diff --git a/tests/lsearch.test b/tests/lsearch.test index b1ab6fc..61b45f6 100644 --- a/tests/lsearch.test +++ b/tests/lsearch.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: lsearch.test,v 1.11 2003/03/27 13:19:15 dkf Exp $ +# RCS: @(#) $Id: lsearch.test,v 1.12 2003/10/14 13:38:58 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -61,7 +61,7 @@ test lsearch-2.9 {search modes} { } 1 test lsearch-2.10 {search modes} { list [catch {lsearch -glib {b.x bx xy bcx} b.x} msg] $msg -} {1 {bad option "-glib": must be -all, -ascii, -decreasing, -dictionary, -exact, -glob, -increasing, -inline, -integer, -not, -real, -regexp, -sorted, or -start}} +} {1 {bad option "-glib": must be -all, -ascii, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -not, -real, -regexp, -sorted, -start, or -subindices}} test lsearch-3.1 {lsearch errors} { list [catch lsearch msg] $msg @@ -71,13 +71,19 @@ test lsearch-3.2 {lsearch errors} { } {1 {wrong # args: should be "lsearch ?options? list pattern"}} test lsearch-3.3 {lsearch errors} { list [catch {lsearch a b c} msg] $msg -} {1 {bad option "a": must be -all, -ascii, -decreasing, -dictionary, -exact, -glob, -increasing, -inline, -integer, -not, -real, -regexp, -sorted, or -start}} +} {1 {bad option "a": must be -all, -ascii, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -not, -real, -regexp, -sorted, -start, or -subindices}} test lsearch-3.4 {lsearch errors} { list [catch {lsearch a b c d} msg] $msg -} {1 {bad option "a": must be -all, -ascii, -decreasing, -dictionary, -exact, -glob, -increasing, -inline, -integer, -not, -real, -regexp, -sorted, or -start}} +} {1 {bad option "a": must be -all, -ascii, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -not, -real, -regexp, -sorted, -start, or -subindices}} test lsearch-3.5 {lsearch errors} { list [catch {lsearch "\{" b} msg] $msg } {1 {unmatched open brace in list}} +test lsearch-3.6 {lsearch errors} { + list [catch {lsearch -index a b} msg] $msg +} {1 {"-index" option must be followed by list index}} +test lsearch-3.7 {lsearch errors} { + list [catch {lsearch -subindices -exact a b} msg] $msg +} {1 {-subindices cannot be used without -index option}} test lsearch-4.1 {binary data} { lsearch -exact [list foo one\000two bar] bar @@ -350,6 +356,70 @@ test lsearch-16.1 {lsearch -regexp shared object} { lsearch -regexp $str $str } 0 +test lsearch-17.1 {lsearch -index option, basic functionality} { + lsearch -index 1 {{a c} {a b} {a a}} a +} 2 +test lsearch-17.2 {lsearch -index option, basic functionality} { + lsearch -index 1 -exact {{a c} {a b} {a a}} a +} 2 +test lsearch-17.3 {lsearch -index option, basic functionality} { + lsearch -index 1 -glob {{ab cb} {ab bb} {ab ab}} b* +} 1 +test lsearch-17.4 {lsearch -index option, basic functionality} { + lsearch -index 1 -regexp {{ab cb} {ab bb} {ab ab}} {[cb]b} +} 0 +test lsearch-17.5 {lsearch -index option, basic functionality} { + lsearch -all -index 0 -exact {{a c} {a b} {d a}} a +} {0 1} +test lsearch-17.6 {lsearch -index option, basic functionality} { + lsearch -all -index 1 -glob {{ab cb} {ab bb} {db bx}} b* +} {1 2} +test lsearch-17.7 {lsearch -index option, basic functionality} { + lsearch -all -index 1 -regexp {{ab cb} {ab bb} {ab ab}} {[cb]b} +} {0 1} + +test lsearch-18.1 {lsearch -index option, list as index basic functionality} { + lsearch -index {0 0} {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a +} 1 +test lsearch-18.2 {lsearch -index option, list as index basic functionality} { + lsearch -index {2 0} -exact {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a +} 0 +test lsearch-18.3 {lsearch -index option, list as index basic functionality} { + lsearch -index {1 1} -glob {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} b* +} 0 +test lsearch-18.4 {lsearch -index option, list as index basic functionality} { + lsearch -index {0 1} -regexp {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} {[cb]b} +} 0 +test lsearch-18.5 {lsearch -index option, list as index basic functionality} { + lsearch -all -index {0 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a +} {0 1} + +test lsearch-19.1 {lsearch -sunindices option} { + lsearch -subindices -index {0 0} {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a +} {1 0 0} +test lsearch-19.2 {lsearch -sunindices option} { + lsearch -subindices -index {2 0} -exact {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a +} {0 2 0} +test lsearch-19.3 {lsearch -sunindices option} { + lsearch -subindices -index {1 1} -glob {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} b* +} {0 1 1} +test lsearch-19.4 {lsearch -sunindices option} { + lsearch -subindices -index {0 1} -regexp {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} {[cb]b} +} {0 0 1} +test lsearch-19.5 {lsearch -sunindices option} { + lsearch -subindices -all -index {0 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a +} {{0 0 0} {1 0 0}} + +test lsearch-20.1 {lsearch -index option, index larger than sublists} { + list [catch {lsearch -index 2 {{a c} {a b} {a a}} a} msg] $msg +} {1 {element 2 missing from sublist "a c"}} +test lsearch-20.2 {lsearch -index option, malformed index} { + list [catch {lsearch -index foo {{a c} {a b} {a a}} a} msg] $msg +} {1 {bad index "foo": must be integer or end?-integer?}} +test lsearch-20.3 {lsearch -index option, malformed index} { + list [catch {lsearch -index \{ {{a c} {a b} {a a}} a} msg] $msg +} [list 1 "argument \"\{\" given to -index is invalid"] + # cleanup catch {unset res} catch {unset increasingIntegers} -- cgit v0.12