summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog11
-rw-r--r--doc/lsearch.n38
-rw-r--r--doc/lsort.n35
-rw-r--r--generic/tclCmdIL.c598
-rw-r--r--tests/cmdIL.test33
-rw-r--r--tests/lsearch.test78
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 <fellowsd@cs.man.ac.uk>
+
+ 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 <vincentdarley@users.sourceforge.net>
* 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,
+ &currentObj) != 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 ; i<indexCount ; i++) {
+ /*
+ * Convert the current object to a list if necessary.
+ */
+
+ result = Tcl_ListObjGetElements(infoPtr->interp, 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}
generated by cgit v0.12 at 2024-11-14 16:02:31 (GMT)