diff options
Diffstat (limited to 'tcl8.6/generic/tclCmdIL.c')
| -rw-r--r-- | tcl8.6/generic/tclCmdIL.c | 4533 |
1 files changed, 4533 insertions, 0 deletions
diff --git a/tcl8.6/generic/tclCmdIL.c b/tcl8.6/generic/tclCmdIL.c new file mode 100644 index 0000000..0a1b4fe --- /dev/null +++ b/tcl8.6/generic/tclCmdIL.c @@ -0,0 +1,4533 @@ +/* + * tclCmdIL.c -- + * + * This file contains the top-level command routines for most of the Tcl + * built-in commands whose names begin with the letters I through L. It + * contains only commands in the generic core (i.e., those that don't + * depend much upon UNIX facilities). + * + * Copyright (c) 1987-1993 The Regents of the University of California. + * Copyright (c) 1993-1997 Lucent Technologies. + * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 1998-1999 by Scriptics Corporation. + * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. + * Copyright (c) 2005 Donal K. Fellows. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "tclInt.h" +#include "tclRegexp.h" + +/* + * During execution of the "lsort" command, structures of the following type + * are used to arrange the objects being sorted into a collection of linked + * lists. + */ + +typedef struct SortElement { + union { /* The value that we sorting by. */ + const char *strValuePtr; + Tcl_WideInt wideValue; + double doubleValue; + Tcl_Obj *objValuePtr; + } collationKey; + union { /* Object being sorted, or its index. */ + Tcl_Obj *objPtr; + int index; + } payload; + struct SortElement *nextPtr;/* Next element in the list, or NULL for end + * of list. */ +} SortElement; + +/* + * These function pointer types are used with the "lsearch" and "lsort" + * commands to facilitate the "-nocase" option. + */ + +typedef int (*SortStrCmpFn_t) (const char *, const char *); +typedef int (*SortMemCmpFn_t) (const void *, const void *, size_t); + +/* + * The "lsort" command needs to pass certain information down to the function + * that compares two list elements, and the comparison function needs to pass + * success or failure information back up to the top-level "lsort" command. + * The following structure is used to pass this information. + */ + +typedef struct SortInfo { + int isIncreasing; /* Nonzero means sort in increasing order. */ + int sortMode; /* The sort mode. One of SORTMODE_* values + * defined below. */ + Tcl_Obj *compareCmdPtr; /* The Tcl comparison command when sortMode is + * SORTMODE_COMMAND. Pre-initialized to hold + * base of command. */ + int *indexv; /* If the -index option was specified, this + * holds the indexes contained in the list + * supplied as an argument to that option. + * NULL if no indexes supplied, and points to + * singleIndex field when only one + * supplied. */ + int indexc; /* Number of indexes in indexv array. */ + int singleIndex; /* Static space for common index case. */ + int unique; + int numElements; + Tcl_Interp *interp; /* The interpreter in which the sort is being + * done. */ + int resultCode; /* Completion code for the lsort command. If + * an error occurs during the sort this is + * changed from TCL_OK to TCL_ERROR. */ +} SortInfo; + +/* + * The "sortMode" field of the SortInfo structure can take on any of the + * following values. + */ + +#define SORTMODE_ASCII 0 +#define SORTMODE_INTEGER 1 +#define SORTMODE_REAL 2 +#define SORTMODE_COMMAND 3 +#define SORTMODE_DICTIONARY 4 +#define SORTMODE_ASCII_NC 8 + +/* + * Magic values for the index field of the SortInfo structure. Note that the + * index "end-1" will be translated to SORTIDX_END-1, etc. + */ + +#define SORTIDX_NONE -1 /* Not indexed; use whole value. */ +#define SORTIDX_END -2 /* Indexed from end. */ + +/* + * Forward declarations for procedures defined in this file: + */ + +static int DictionaryCompare(const char *left, const char *right); +static Tcl_NRPostProc IfConditionCallback; +static int InfoArgsCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int InfoBodyCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int InfoCmdCountCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int InfoCommandsCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int InfoCompleteCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int InfoDefaultCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +/* TIP #348 - New 'info' subcommand 'errorstack' */ +static int InfoErrorStackCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +/* TIP #280 - New 'info' subcommand 'frame' */ +static int InfoFrameCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int InfoFunctionsCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int InfoHostnameCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int InfoLevelCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int InfoLibraryCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int InfoLoadedCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int InfoNameOfExecutableCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int InfoPatchLevelCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int InfoProcsCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int InfoScriptCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int InfoSharedlibCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int InfoTclVersionCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static SortElement * MergeLists(SortElement *leftPtr, SortElement *rightPtr, + SortInfo *infoPtr); +static int SortCompare(SortElement *firstPtr, SortElement *second, + SortInfo *infoPtr); +static Tcl_Obj * SelectObjFromSublist(Tcl_Obj *firstPtr, + SortInfo *infoPtr); + +/* + * Array of values describing how to implement each standard subcommand of the + * "info" command. + */ + +static const EnsembleImplMap defaultInfoMap[] = { + {"args", InfoArgsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"body", InfoBodyCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"cmdcount", InfoCmdCountCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, + {"commands", InfoCommandsCmd, TclCompileInfoCommandsCmd, NULL, NULL, 0}, + {"complete", InfoCompleteCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"coroutine", TclInfoCoroutineCmd, TclCompileInfoCoroutineCmd, NULL, NULL, 0}, + {"default", InfoDefaultCmd, TclCompileBasic3ArgCmd, NULL, NULL, 0}, + {"errorstack", InfoErrorStackCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"exists", TclInfoExistsCmd, TclCompileInfoExistsCmd, NULL, NULL, 0}, + {"frame", InfoFrameCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"functions", InfoFunctionsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"globals", TclInfoGlobalsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"hostname", InfoHostnameCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, + {"level", InfoLevelCmd, TclCompileInfoLevelCmd, NULL, NULL, 0}, + {"library", InfoLibraryCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, + {"loaded", InfoLoadedCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"locals", TclInfoLocalsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"nameofexecutable", InfoNameOfExecutableCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, + {"patchlevel", InfoPatchLevelCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, + {"procs", InfoProcsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"script", InfoScriptCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"sharedlibextension", InfoSharedlibCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, + {"tclversion", InfoTclVersionCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, + {"vars", TclInfoVarsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, NULL, 0} +}; + +/* + *---------------------------------------------------------------------- + * + * Tcl_IfObjCmd -- + * + * This procedure is invoked to process the "if" Tcl command. See the + * user documentation for details on what it does. + * + * With the bytecode compiler, this procedure is only called when a + * command name is computed at runtime, and is "if" or the name to which + * "if" was renamed: e.g., "set z if; $z 1 {puts foo}" + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_IfObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + return Tcl_NRCallObjProc(interp, TclNRIfObjCmd, dummy, objc, objv); +} + +int +TclNRIfObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Obj *boolObj; + + if (objc <= 1) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: no expression after \"%s\" argument", + TclGetString(objv[0]))); + Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); + return TCL_ERROR; + } + + /* + * At this point, objv[1] refers to the main expression to test. The + * arguments after the expression must be "then" (optional) and a script + * to execute if the expression is true. + */ + + TclNewObj(boolObj); + Tcl_NRAddCallback(interp, IfConditionCallback, INT2PTR(objc), + (ClientData) objv, INT2PTR(1), boolObj); + return Tcl_NRExprObj(interp, objv[1], boolObj); +} + +static int +IfConditionCallback( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + int objc = PTR2INT(data[0]); + Tcl_Obj *const *objv = data[1]; + int i = PTR2INT(data[2]); + Tcl_Obj *boolObj = data[3]; + int value, thenScriptIndex = 0; + const char *clause; + + if (result != TCL_OK) { + TclDecrRefCount(boolObj); + return result; + } + if (Tcl_GetBooleanFromObj(interp, boolObj, &value) != TCL_OK) { + TclDecrRefCount(boolObj); + return TCL_ERROR; + } + TclDecrRefCount(boolObj); + + while (1) { + i++; + if (i >= objc) { + goto missingScript; + } + clause = TclGetString(objv[i]); + if ((i < objc) && (strcmp(clause, "then") == 0)) { + i++; + } + if (i >= objc) { + goto missingScript; + } + if (value) { + thenScriptIndex = i; + value = 0; + } + + /* + * The expression evaluated to false. Skip the command, then see if + * there is an "else" or "elseif" clause. + */ + + i++; + if (i >= objc) { + if (thenScriptIndex) { + /* + * TIP #280. Make invoking context available to branch. + */ + + return TclNREvalObjEx(interp, objv[thenScriptIndex], 0, + iPtr->cmdFramePtr, thenScriptIndex); + } + return TCL_OK; + } + clause = TclGetString(objv[i]); + if ((clause[0] != 'e') || (strcmp(clause, "elseif") != 0)) { + break; + } + i++; + + /* + * At this point in the loop, objv and objc refer to an expression to + * test, either for the main expression or an expression following an + * "elseif". The arguments after the expression must be "then" + * (optional) and a script to execute if the expression is true. + */ + + if (i >= objc) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: no expression after \"%s\" argument", + clause)); + Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); + return TCL_ERROR; + } + if (!thenScriptIndex) { + TclNewObj(boolObj); + Tcl_NRAddCallback(interp, IfConditionCallback, data[0], data[1], + INT2PTR(i), boolObj); + return Tcl_NRExprObj(interp, objv[i], boolObj); + } + } + + /* + * Couldn't find a "then" or "elseif" clause to execute. Check now for an + * "else" clause. We know that there's at least one more argument when we + * get here. + */ + + if (strcmp(clause, "else") == 0) { + i++; + if (i >= objc) { + goto missingScript; + } + } + if (i < objc - 1) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "wrong # args: extra words after \"else\" clause in \"if\" command", + -1)); + Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); + return TCL_ERROR; + } + if (thenScriptIndex) { + /* + * TIP #280. Make invoking context available to branch/else. + */ + + return TclNREvalObjEx(interp, objv[thenScriptIndex], 0, + iPtr->cmdFramePtr, thenScriptIndex); + } + return TclNREvalObjEx(interp, objv[i], 0, iPtr->cmdFramePtr, i); + + missingScript: + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: no script following \"%s\" argument", + TclGetString(objv[i-1]))); + Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_IncrObjCmd -- + * + * This procedure is invoked to process the "incr" Tcl command. See the + * user documentation for details on what it does. + * + * With the bytecode compiler, this procedure is only called when a + * command name is computed at runtime, and is "incr" or the name to + * which "incr" was renamed: e.g., "set z incr; $z i -1" + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_IncrObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Obj *newValuePtr, *incrPtr; + + if ((objc != 2) && (objc != 3)) { + Tcl_WrongNumArgs(interp, 1, objv, "varName ?increment?"); + return TCL_ERROR; + } + + if (objc == 3) { + incrPtr = objv[2]; + } else { + incrPtr = Tcl_NewIntObj(1); + } + Tcl_IncrRefCount(incrPtr); + newValuePtr = TclIncrObjVar2(interp, objv[1], NULL, + incrPtr, TCL_LEAVE_ERR_MSG); + Tcl_DecrRefCount(incrPtr); + + if (newValuePtr == NULL) { + return TCL_ERROR; + } + + /* + * Set the interpreter's object result to refer to the variable's new + * value object. + */ + + Tcl_SetObjResult(interp, newValuePtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclInitInfoCmd -- + * + * This function is called to create the "info" Tcl command. See the user + * documentation for details on what it does. + * + * Results: + * Handle for the info command, or NULL on failure. + * + * Side effects: + * none + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +TclInitInfoCmd( + Tcl_Interp *interp) /* Current interpreter. */ +{ + return TclMakeEnsemble(interp, "info", defaultInfoMap); +} + +/* + *---------------------------------------------------------------------- + * + * InfoArgsCmd -- + * + * Called to implement the "info args" command that returns the argument + * list for a procedure. Handles the following syntax: + * + * info args procName + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoArgsCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + register Interp *iPtr = (Interp *) interp; + const char *name; + Proc *procPtr; + CompiledLocal *localPtr; + Tcl_Obj *listObjPtr; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "procname"); + return TCL_ERROR; + } + + name = TclGetString(objv[1]); + procPtr = TclFindProc(iPtr, name); + if (procPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't a procedure", name)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", name, NULL); + return TCL_ERROR; + } + + /* + * Build a return list containing the arguments. + */ + + listObjPtr = Tcl_NewListObj(0, NULL); + for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; + localPtr = localPtr->nextPtr) { + if (TclIsVarArgument(localPtr)) { + Tcl_ListObjAppendElement(interp, listObjPtr, + Tcl_NewStringObj(localPtr->name, -1)); + } + } + Tcl_SetObjResult(interp, listObjPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InfoBodyCmd -- + * + * Called to implement the "info body" command that returns the body for + * a procedure. Handles the following syntax: + * + * info body procName + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoBodyCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + register Interp *iPtr = (Interp *) interp; + const char *name; + Proc *procPtr; + Tcl_Obj *bodyPtr, *resultPtr; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "procname"); + return TCL_ERROR; + } + + name = TclGetString(objv[1]); + procPtr = TclFindProc(iPtr, name); + if (procPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't a procedure", name)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", name, NULL); + return TCL_ERROR; + } + + /* + * Here we used to return procPtr->bodyPtr, except when the body was + * bytecompiled - in that case, the return was a copy of the body's string + * rep. In order to better isolate the implementation details of the + * compiler/engine subsystem, we now always return a copy of the string + * rep. It is important to return a copy so that later manipulations of + * the object do not invalidate the internal rep. + */ + + bodyPtr = procPtr->bodyPtr; + if (bodyPtr->bytes == NULL) { + /* + * The string rep might not be valid if the procedure has never been + * run before. [Bug #545644] + */ + + TclGetString(bodyPtr); + } + resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length); + + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InfoCmdCountCmd -- + * + * Called to implement the "info cmdcount" command that returns the + * number of commands that have been executed. Handles the following + * syntax: + * + * info cmdcount + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoCmdCountCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Interp *iPtr = (Interp *) interp; + + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return TCL_ERROR; + } + + Tcl_SetObjResult(interp, Tcl_NewIntObj(iPtr->cmdCount)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InfoCommandsCmd -- + * + * Called to implement the "info commands" command that returns the list + * of commands in the interpreter that match an optional pattern. The + * pattern, if any, consists of an optional sequence of namespace names + * separated by "::" qualifiers, which is followed by a glob-style + * pattern that restricts which commands are returned. Handles the + * following syntax: + * + * info commands ?pattern? + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoCommandsCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + const char *cmdName, *pattern; + const char *simplePattern; + register Tcl_HashEntry *entryPtr; + Tcl_HashSearch search; + Namespace *nsPtr; + Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); + Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + Tcl_Obj *listPtr, *elemObjPtr; + int specificNsInPattern = 0;/* Init. to avoid compiler warning. */ + Tcl_Command cmd; + int i; + + /* + * Get the pattern and find the "effective namespace" in which to list + * commands. + */ + + if (objc == 1) { + simplePattern = NULL; + nsPtr = currNsPtr; + specificNsInPattern = 0; + } else if (objc == 2) { + /* + * From the pattern, get the effective namespace and the simple + * pattern (no namespace qualifiers or ::'s) at the end. If an error + * was found while parsing the pattern, return it. Otherwise, if the + * namespace wasn't found, just leave nsPtr NULL: we will return an + * empty list since no commands there can be found. + */ + + Namespace *dummy1NsPtr, *dummy2NsPtr; + + pattern = TclGetString(objv[1]); + TclGetNamespaceForQualName(interp, pattern, NULL, 0, &nsPtr, + &dummy1NsPtr, &dummy2NsPtr, &simplePattern); + + if (nsPtr != NULL) { /* We successfully found the pattern's ns. */ + specificNsInPattern = (strcmp(simplePattern, pattern) != 0); + } + } else { + Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); + return TCL_ERROR; + } + + /* + * Exit as quickly as possible if we couldn't find the namespace. + */ + + if (nsPtr == NULL) { + return TCL_OK; + } + + /* + * Scan through the effective namespace's command table and create a list + * with all commands that match the pattern. If a specific namespace was + * requested in the pattern, qualify the command names with the namespace + * name. + */ + + listPtr = Tcl_NewListObj(0, NULL); + + if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) { + /* + * Special case for when the pattern doesn't include any of glob's + * special characters. This lets us avoid scans of any hash tables. + */ + + entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern); + if (entryPtr != NULL) { + if (specificNsInPattern) { + cmd = Tcl_GetHashValue(entryPtr); + elemObjPtr = Tcl_NewObj(); + Tcl_GetCommandFullName(interp, cmd, elemObjPtr); + } else { + cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); + elemObjPtr = Tcl_NewStringObj(cmdName, -1); + } + Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; + } + if ((nsPtr != globalNsPtr) && !specificNsInPattern) { + Tcl_HashTable *tablePtr = NULL; /* Quell warning. */ + + for (i=0 ; i<nsPtr->commandPathLength ; i++) { + Namespace *pathNsPtr = nsPtr->commandPathArray[i].nsPtr; + + if (pathNsPtr == NULL) { + continue; + } + tablePtr = &pathNsPtr->cmdTable; + entryPtr = Tcl_FindHashEntry(tablePtr, simplePattern); + if (entryPtr != NULL) { + break; + } + } + if (entryPtr == NULL) { + tablePtr = &globalNsPtr->cmdTable; + entryPtr = Tcl_FindHashEntry(tablePtr, simplePattern); + } + if (entryPtr != NULL) { + cmdName = Tcl_GetHashKey(tablePtr, entryPtr); + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(cmdName, -1)); + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; + } + } + } else if (nsPtr->commandPathLength == 0 || specificNsInPattern) { + /* + * The pattern is non-trivial, but either there is no explicit path or + * there is an explicit namespace in the pattern. In both cases, the + * old matching scheme is perfect. + */ + + entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); + while (entryPtr != NULL) { + cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); + if ((simplePattern == NULL) + || Tcl_StringMatch(cmdName, simplePattern)) { + if (specificNsInPattern) { + cmd = Tcl_GetHashValue(entryPtr); + elemObjPtr = Tcl_NewObj(); + Tcl_GetCommandFullName(interp, cmd, elemObjPtr); + } else { + elemObjPtr = Tcl_NewStringObj(cmdName, -1); + } + Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); + } + entryPtr = Tcl_NextHashEntry(&search); + } + + /* + * If the effective namespace isn't the global :: namespace, and a + * specific namespace wasn't requested in the pattern, then add in all + * global :: commands that match the simple pattern. Of course, we add + * in only those commands that aren't hidden by a command in the + * effective namespace. + */ + + if ((nsPtr != globalNsPtr) && !specificNsInPattern) { + entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search); + while (entryPtr != NULL) { + cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr); + if ((simplePattern == NULL) + || Tcl_StringMatch(cmdName, simplePattern)) { + if (Tcl_FindHashEntry(&nsPtr->cmdTable,cmdName) == NULL) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(cmdName, -1)); + } + } + entryPtr = Tcl_NextHashEntry(&search); + } + } + } else { + /* + * The pattern is non-trivial (can match more than one command name), + * there is an explicit path, and there is no explicit namespace in + * the pattern. This means that we have to traverse the path to + * discover all the commands defined. + */ + + Tcl_HashTable addedCommandsTable; + int isNew; + int foundGlobal = (nsPtr == globalNsPtr); + + /* + * We keep a hash of the objects already added to the result list. + */ + + Tcl_InitObjHashTable(&addedCommandsTable); + + entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); + while (entryPtr != NULL) { + cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); + if ((simplePattern == NULL) + || Tcl_StringMatch(cmdName, simplePattern)) { + elemObjPtr = Tcl_NewStringObj(cmdName, -1); + Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); + (void) Tcl_CreateHashEntry(&addedCommandsTable, + elemObjPtr, &isNew); + } + entryPtr = Tcl_NextHashEntry(&search); + } + + /* + * Search the path next. + */ + + for (i=0 ; i<nsPtr->commandPathLength ; i++) { + Namespace *pathNsPtr = nsPtr->commandPathArray[i].nsPtr; + + if (pathNsPtr == NULL) { + continue; + } + if (pathNsPtr == globalNsPtr) { + foundGlobal = 1; + } + entryPtr = Tcl_FirstHashEntry(&pathNsPtr->cmdTable, &search); + while (entryPtr != NULL) { + cmdName = Tcl_GetHashKey(&pathNsPtr->cmdTable, entryPtr); + if ((simplePattern == NULL) + || Tcl_StringMatch(cmdName, simplePattern)) { + elemObjPtr = Tcl_NewStringObj(cmdName, -1); + (void) Tcl_CreateHashEntry(&addedCommandsTable, + elemObjPtr, &isNew); + if (isNew) { + Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); + } else { + TclDecrRefCount(elemObjPtr); + } + } + entryPtr = Tcl_NextHashEntry(&search); + } + } + + /* + * If the effective namespace isn't the global :: namespace, and a + * specific namespace wasn't requested in the pattern, then add in all + * global :: commands that match the simple pattern. Of course, we add + * in only those commands that aren't hidden by a command in the + * effective namespace. + */ + + if (!foundGlobal) { + entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search); + while (entryPtr != NULL) { + cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr); + if ((simplePattern == NULL) + || Tcl_StringMatch(cmdName, simplePattern)) { + elemObjPtr = Tcl_NewStringObj(cmdName, -1); + if (Tcl_FindHashEntry(&addedCommandsTable, + (char *) elemObjPtr) == NULL) { + Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); + } else { + TclDecrRefCount(elemObjPtr); + } + } + entryPtr = Tcl_NextHashEntry(&search); + } + } + + Tcl_DeleteHashTable(&addedCommandsTable); + } + + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InfoCompleteCmd -- + * + * Called to implement the "info complete" command that determines + * whether a string is a complete Tcl command. Handles the following + * syntax: + * + * info complete command + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoCompleteCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "command"); + return TCL_ERROR; + } + + Tcl_SetObjResult(interp, Tcl_NewBooleanObj( + TclObjCommandComplete(objv[1]))); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InfoDefaultCmd -- + * + * Called to implement the "info default" command that returns the + * default value for a procedure argument. Handles the following syntax: + * + * info default procName arg varName + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoDefaultCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Interp *iPtr = (Interp *) interp; + const char *procName, *argName; + Proc *procPtr; + CompiledLocal *localPtr; + Tcl_Obj *valueObjPtr; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "procname arg varname"); + return TCL_ERROR; + } + + procName = TclGetString(objv[1]); + argName = TclGetString(objv[2]); + + procPtr = TclFindProc(iPtr, procName); + if (procPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't a procedure", procName)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", procName, + NULL); + return TCL_ERROR; + } + + for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; + localPtr = localPtr->nextPtr) { + if (TclIsVarArgument(localPtr) + && (strcmp(argName, localPtr->name) == 0)) { + if (localPtr->defValuePtr != NULL) { + valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL, + localPtr->defValuePtr, TCL_LEAVE_ERR_MSG); + if (valueObjPtr == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); + } else { + Tcl_Obj *nullObjPtr = Tcl_NewObj(); + + valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL, + nullObjPtr, TCL_LEAVE_ERR_MSG); + if (valueObjPtr == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); + } + return TCL_OK; + } + } + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "procedure \"%s\" doesn't have an argument \"%s\"", + procName, argName)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARGUMENT", argName, NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * InfoErrorStackCmd -- + * + * Called to implement the "info errorstack" command that returns information + * about the last error's call stack. Handles the following syntax: + * + * info errorstack ?interp? + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoErrorStackCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Interp *target; + Interp *iPtr; + + if ((objc != 1) && (objc != 2)) { + Tcl_WrongNumArgs(interp, 1, objv, "?interp?"); + return TCL_ERROR; + } + + target = interp; + if (objc == 2) { + target = Tcl_GetSlave(interp, Tcl_GetString(objv[1])); + if (target == NULL) { + return TCL_ERROR; + } + } + + iPtr = (Interp *) target; + Tcl_SetObjResult(interp, iPtr->errorStack); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclInfoExistsCmd -- + * + * Called to implement the "info exists" command that determines whether + * a variable exists. Handles the following syntax: + * + * info exists varName + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +int +TclInfoExistsCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + const char *varName; + Var *varPtr; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "varName"); + return TCL_ERROR; + } + + varName = TclGetString(objv[1]); + varPtr = TclVarTraceExists(interp, varName); + + Tcl_SetObjResult(interp, + Tcl_NewBooleanObj(varPtr && varPtr->value.objPtr)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InfoFrameCmd -- + * TIP #280 + * + * Called to implement the "info frame" command that returns the location + * of either the currently executing command, or its caller. Handles the + * following syntax: + * + * info frame ?number? + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoFrameCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Interp *iPtr = (Interp *) interp; + int level, code = TCL_OK; + CmdFrame *framePtr, **cmdFramePtrPtr = &iPtr->cmdFramePtr; + CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; + int topLevel = 0; + + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?number?"); + return TCL_ERROR; + } + + while (corPtr) { + while (*cmdFramePtrPtr) { + topLevel++; + cmdFramePtrPtr = &((*cmdFramePtrPtr)->nextPtr); + } + if (corPtr->caller.cmdFramePtr) { + *cmdFramePtrPtr = corPtr->caller.cmdFramePtr; + } + corPtr = corPtr->callerEEPtr->corPtr; + } + topLevel += (*cmdFramePtrPtr)->level; + + if (topLevel != iPtr->cmdFramePtr->level) { + framePtr = iPtr->cmdFramePtr; + while (framePtr) { + framePtr->level = topLevel--; + framePtr = framePtr->nextPtr; + } + if (topLevel) { + Tcl_Panic("Broken frame level calculation"); + } + topLevel = iPtr->cmdFramePtr->level; + } + + if (objc == 1) { + /* + * Just "info frame". + */ + + Tcl_SetObjResult(interp, Tcl_NewIntObj(topLevel)); + goto done; + } + + /* + * We've got "info frame level" and must parse the level first. + */ + + if (TclGetIntFromObj(interp, objv[1], &level) != TCL_OK) { + code = TCL_ERROR; + goto done; + } + + if ((level > topLevel) || (level <= - topLevel)) { + levelError: + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad level \"%s\"", TclGetString(objv[1]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", + TclGetString(objv[1]), NULL); + code = TCL_ERROR; + goto done; + } + + /* + * Let us convert to relative so that we know how many levels to go back + */ + + if (level > 0) { + level -= topLevel; + } + + framePtr = iPtr->cmdFramePtr; + while (++level <= 0) { + framePtr = framePtr->nextPtr; + if (!framePtr) { + goto levelError; + } + } + + Tcl_SetObjResult(interp, TclInfoFrame(interp, framePtr)); + + done: + cmdFramePtrPtr = &iPtr->cmdFramePtr; + corPtr = iPtr->execEnvPtr->corPtr; + while (corPtr) { + CmdFrame *endPtr = corPtr->caller.cmdFramePtr; + + if (endPtr) { + if (*cmdFramePtrPtr == endPtr) { + *cmdFramePtrPtr = NULL; + } else { + CmdFrame *runPtr = *cmdFramePtrPtr; + + while (runPtr->nextPtr != endPtr) { + runPtr->level -= endPtr->level; + runPtr = runPtr->nextPtr; + } + runPtr->level = 1; + runPtr->nextPtr = NULL; + } + cmdFramePtrPtr = &corPtr->caller.cmdFramePtr; + } + corPtr = corPtr->callerEEPtr->corPtr; + } + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TclInfoFrame -- + * + * Core of InfoFrameCmd, returns TIP280 dict for a given frame. + * + * Results: + * Returns TIP280 dict. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclInfoFrame( + Tcl_Interp *interp, /* Current interpreter. */ + CmdFrame *framePtr) /* Frame to get info for. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_Obj *tmpObj; + Tcl_Obj *lv[20]; /* Keep uptodate when more keys are added to + * the dict. */ + int lc = 0; + /* + * This array is indexed by the TCL_LOCATION_... values, except + * for _LAST. + */ + static const char *const typeString[TCL_LOCATION_LAST] = { + "eval", "eval", "eval", "precompiled", "source", "proc" + }; + Proc *procPtr = framePtr->framePtr ? framePtr->framePtr->procPtr : NULL; + int needsFree = -1; + + /* + * Pull the information and construct the dictionary to return, as list. + * Regarding use of the CmdFrame fields see tclInt.h, and its definition. + */ + +#define ADD_PAIR(name, value) \ + TclNewLiteralStringObj(tmpObj, name); \ + lv[lc++] = tmpObj; \ + lv[lc++] = (value) + + switch (framePtr->type) { + case TCL_LOCATION_EVAL: + /* + * Evaluation, dynamic script. Type, line, cmd, the latter through + * str. + */ + + ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1)); + if (framePtr->line) { + ADD_PAIR("line", Tcl_NewIntObj(framePtr->line[0])); + } else { + ADD_PAIR("line", Tcl_NewIntObj(1)); + } + ADD_PAIR("cmd", TclGetSourceFromFrame(framePtr, 0, NULL)); + break; + + case TCL_LOCATION_PREBC: + /* + * Precompiled. Result contains the type as signal, nothing else. + */ + + ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1)); + break; + + case TCL_LOCATION_BC: { + /* + * Execution of bytecode. Talk to the BC engine to fill out the frame. + */ + + CmdFrame *fPtr = TclStackAlloc(interp, sizeof(CmdFrame)); + + *fPtr = *framePtr; + + /* + * Note: + * Type BC => f.data.eval.path is not used. + * f.data.tebc.codePtr is used instead. + */ + + TclGetSrcInfoForPc(fPtr); + + /* + * Now filled: cmd.str.(cmd,len), line + * Possibly modified: type, path! + */ + + ADD_PAIR("type", Tcl_NewStringObj(typeString[fPtr->type], -1)); + if (fPtr->line) { + ADD_PAIR("line", Tcl_NewIntObj(fPtr->line[0])); + } + + if (fPtr->type == TCL_LOCATION_SOURCE) { + ADD_PAIR("file", fPtr->data.eval.path); + + /* + * Death of reference by TclGetSrcInfoForPc. + */ + + Tcl_DecrRefCount(fPtr->data.eval.path); + } + + ADD_PAIR("cmd", TclGetSourceFromFrame(fPtr, 0, NULL)); + if (fPtr->cmdObj && framePtr->cmdObj == NULL) { + needsFree = lc - 1; + } + TclStackFree(interp, fPtr); + break; + } + + case TCL_LOCATION_SOURCE: + /* + * Evaluation of a script file. + */ + + ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1)); + ADD_PAIR("line", Tcl_NewIntObj(framePtr->line[0])); + ADD_PAIR("file", framePtr->data.eval.path); + + /* + * Refcount framePtr->data.eval.path goes up when lv is converted into + * the result list object. + */ + + ADD_PAIR("cmd", TclGetSourceFromFrame(framePtr, 0, NULL)); + break; + + case TCL_LOCATION_PROC: + Tcl_Panic("TCL_LOCATION_PROC found in standard frame"); + break; + } + + /* + * 'proc'. Common to all frame types. Conditional on having an associated + * Procedure CallFrame. + */ + + if (procPtr != NULL) { + Tcl_HashEntry *namePtr = procPtr->cmdPtr->hPtr; + + if (namePtr) { + Tcl_Obj *procNameObj; + + /* + * This is a regular command. + */ + + TclNewObj(procNameObj); + Tcl_GetCommandFullName(interp, (Tcl_Command) procPtr->cmdPtr, + procNameObj); + ADD_PAIR("proc", procNameObj); + } else if (procPtr->cmdPtr->clientData) { + ExtraFrameInfo *efiPtr = procPtr->cmdPtr->clientData; + int i; + + /* + * This is a non-standard command. Luckily, it's told us how to + * render extra information about its frame. + */ + + for (i=0 ; i<efiPtr->length ; i++) { + lv[lc++] = Tcl_NewStringObj(efiPtr->fields[i].name, -1); + if (efiPtr->fields[i].proc) { + lv[lc++] = + efiPtr->fields[i].proc(efiPtr->fields[i].clientData); + } else { + lv[lc++] = efiPtr->fields[i].clientData; + } + } + } + } + + /* + * 'level'. Common to all frame types. Conditional on having an associated + * _visible_ CallFrame. + */ + + if ((framePtr->framePtr != NULL) && (iPtr->varFramePtr != NULL)) { + CallFrame *current = framePtr->framePtr; + CallFrame *top = iPtr->varFramePtr; + CallFrame *idx; + + for (idx=top ; idx!=NULL ; idx=idx->callerVarPtr) { + if (idx == current) { + int c = framePtr->framePtr->level; + int t = iPtr->varFramePtr->level; + + ADD_PAIR("level", Tcl_NewIntObj(t - c)); + break; + } + } + } + + tmpObj = Tcl_NewListObj(lc, lv); + if (needsFree >= 0) { + Tcl_DecrRefCount(lv[needsFree]); + } + return tmpObj; +} + +/* + *---------------------------------------------------------------------- + * + * InfoFunctionsCmd -- + * + * Called to implement the "info functions" command that returns the list + * of math functions matching an optional pattern. Handles the following + * syntax: + * + * info functions ?pattern? + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoFunctionsCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Obj *script; + int code; + + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); + return TCL_ERROR; + } + + script = Tcl_NewStringObj( +" ::apply [::list {{pattern *}} {\n" +" ::set cmds {}\n" +" ::foreach cmd [::info commands ::tcl::mathfunc::$pattern] {\n" +" ::lappend cmds [::namespace tail $cmd]\n" +" }\n" +" ::foreach cmd [::info commands tcl::mathfunc::$pattern] {\n" +" ::set cmd [::namespace tail $cmd]\n" +" ::if {$cmd ni $cmds} {\n" +" ::lappend cmds $cmd\n" +" }\n" +" }\n" +" ::return $cmds\n" +" } [::namespace current]] ", -1); + + if (objc == 2) { + Tcl_Obj *arg = Tcl_NewListObj(1, &(objv[1])); + + Tcl_AppendObjToObj(script, arg); + Tcl_DecrRefCount(arg); + } + + Tcl_IncrRefCount(script); + code = Tcl_EvalObjEx(interp, script, 0); + + Tcl_DecrRefCount(script); + + return code; +} + +/* + *---------------------------------------------------------------------- + * + * InfoHostnameCmd -- + * + * Called to implement the "info hostname" command that returns the host + * name. Handles the following syntax: + * + * info hostname + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoHostnameCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + const char *name; + + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return TCL_ERROR; + } + + name = Tcl_GetHostName(); + if (name) { + Tcl_SetObjResult(interp, Tcl_NewStringObj(name, -1)); + return TCL_OK; + } + + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unable to determine name of host", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "HOSTNAME", "UNKNOWN", NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * InfoLevelCmd -- + * + * Called to implement the "info level" command that returns information + * about the call stack. Handles the following syntax: + * + * info level ?number? + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoLevelCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Interp *iPtr = (Interp *) interp; + + if (objc == 1) { /* Just "info level" */ + Tcl_SetObjResult(interp, Tcl_NewIntObj(iPtr->varFramePtr->level)); + return TCL_OK; + } + + if (objc == 2) { + int level; + CallFrame *framePtr, *rootFramePtr = iPtr->rootFramePtr; + + if (TclGetIntFromObj(interp, objv[1], &level) != TCL_OK) { + return TCL_ERROR; + } + if (level <= 0) { + if (iPtr->varFramePtr == rootFramePtr) { + goto levelError; + } + level += iPtr->varFramePtr->level; + } + for (framePtr=iPtr->varFramePtr ; framePtr!=rootFramePtr; + framePtr=framePtr->callerVarPtr) { + if (framePtr->level == level) { + break; + } + } + if (framePtr == rootFramePtr) { + goto levelError; + } + + Tcl_SetObjResult(interp, + Tcl_NewListObj(framePtr->objc, framePtr->objv)); + return TCL_OK; + } + + Tcl_WrongNumArgs(interp, 1, objv, "?number?"); + return TCL_ERROR; + + levelError: + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad level \"%s\"", TclGetString(objv[1]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", + TclGetString(objv[1]), NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * InfoLibraryCmd -- + * + * Called to implement the "info library" command that returns the + * library directory for the Tcl installation. Handles the following + * syntax: + * + * info library + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoLibraryCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + const char *libDirName; + + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return TCL_ERROR; + } + + libDirName = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY); + if (libDirName != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj(libDirName, -1)); + return TCL_OK; + } + + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "no library has been specified for Tcl", -1)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", "tcl_library",NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * InfoLoadedCmd -- + * + * Called to implement the "info loaded" command that returns the + * packages that have been loaded into an interpreter. Handles the + * following syntax: + * + * info loaded ?interp? + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoLoadedCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + const char *interpName; + + if ((objc != 1) && (objc != 2)) { + Tcl_WrongNumArgs(interp, 1, objv, "?interp?"); + return TCL_ERROR; + } + + if (objc == 1) { /* Get loaded pkgs in all interpreters. */ + interpName = NULL; + } else { /* Get pkgs just in specified interp. */ + interpName = TclGetString(objv[1]); + } + return TclGetLoadedPackages(interp, interpName); +} + +/* + *---------------------------------------------------------------------- + * + * InfoNameOfExecutableCmd -- + * + * Called to implement the "info nameofexecutable" command that returns + * the name of the binary file running this application. Handles the + * following syntax: + * + * info nameofexecutable + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoNameOfExecutableCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, TclGetObjNameOfExecutable()); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InfoPatchLevelCmd -- + * + * Called to implement the "info patchlevel" command that returns the + * default value for an argument to a procedure. Handles the following + * syntax: + * + * info patchlevel + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoPatchLevelCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + const char *patchlevel; + + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return TCL_ERROR; + } + + patchlevel = Tcl_GetVar(interp, "tcl_patchLevel", + (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); + if (patchlevel != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj(patchlevel, -1)); + return TCL_OK; + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * InfoProcsCmd -- + * + * Called to implement the "info procs" command that returns the list of + * procedures in the interpreter that match an optional pattern. The + * pattern, if any, consists of an optional sequence of namespace names + * separated by "::" qualifiers, which is followed by a glob-style + * pattern that restricts which commands are returned. Handles the + * following syntax: + * + * info procs ?pattern? + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoProcsCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + const char *cmdName, *pattern; + const char *simplePattern; + Namespace *nsPtr; +#ifdef INFO_PROCS_SEARCH_GLOBAL_NS + Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); +#endif + Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + Tcl_Obj *listPtr, *elemObjPtr; + int specificNsInPattern = 0;/* Init. to avoid compiler warning. */ + register Tcl_HashEntry *entryPtr; + Tcl_HashSearch search; + Command *cmdPtr, *realCmdPtr; + + /* + * Get the pattern and find the "effective namespace" in which to list + * procs. + */ + + if (objc == 1) { + simplePattern = NULL; + nsPtr = currNsPtr; + specificNsInPattern = 0; + } else if (objc == 2) { + /* + * From the pattern, get the effective namespace and the simple + * pattern (no namespace qualifiers or ::'s) at the end. If an error + * was found while parsing the pattern, return it. Otherwise, if the + * namespace wasn't found, just leave nsPtr NULL: we will return an + * empty list since no commands there can be found. + */ + + Namespace *dummy1NsPtr, *dummy2NsPtr; + + pattern = TclGetString(objv[1]); + TclGetNamespaceForQualName(interp, pattern, NULL, /*flags*/ 0, &nsPtr, + &dummy1NsPtr, &dummy2NsPtr, &simplePattern); + + if (nsPtr != NULL) { /* We successfully found the pattern's ns. */ + specificNsInPattern = (strcmp(simplePattern, pattern) != 0); + } + } else { + Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); + return TCL_ERROR; + } + + if (nsPtr == NULL) { + return TCL_OK; + } + + /* + * Scan through the effective namespace's command table and create a list + * with all procs that match the pattern. If a specific namespace was + * requested in the pattern, qualify the command names with the namespace + * name. + */ + + listPtr = Tcl_NewListObj(0, NULL); +#ifndef INFO_PROCS_SEARCH_GLOBAL_NS + if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) { + entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern); + if (entryPtr != NULL) { + cmdPtr = Tcl_GetHashValue(entryPtr); + + if (!TclIsProc(cmdPtr)) { + realCmdPtr = (Command *) + TclGetOriginalCommand((Tcl_Command) cmdPtr); + if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) { + goto simpleProcOK; + } + } else { + simpleProcOK: + if (specificNsInPattern) { + elemObjPtr = Tcl_NewObj(); + Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, + elemObjPtr); + } else { + elemObjPtr = Tcl_NewStringObj(simplePattern, -1); + } + Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); + } + } + } else +#endif /* !INFO_PROCS_SEARCH_GLOBAL_NS */ + { + entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); + while (entryPtr != NULL) { + cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); + if ((simplePattern == NULL) + || Tcl_StringMatch(cmdName, simplePattern)) { + cmdPtr = Tcl_GetHashValue(entryPtr); + + if (!TclIsProc(cmdPtr)) { + realCmdPtr = (Command *) + TclGetOriginalCommand((Tcl_Command) cmdPtr); + if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) { + goto procOK; + } + } else { + procOK: + if (specificNsInPattern) { + elemObjPtr = Tcl_NewObj(); + Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, + elemObjPtr); + } else { + elemObjPtr = Tcl_NewStringObj(cmdName, -1); + } + Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); + } + } + entryPtr = Tcl_NextHashEntry(&search); + } + + /* + * If the effective namespace isn't the global :: namespace, and a + * specific namespace wasn't requested in the pattern, then add in all + * global :: procs that match the simple pattern. Of course, we add in + * only those procs that aren't hidden by a proc in the effective + * namespace. + */ + +#ifdef INFO_PROCS_SEARCH_GLOBAL_NS + /* + * If "info procs" worked like "info commands", returning the commands + * also seen in the global namespace, then you would include this + * code. As this could break backwards compatibilty with 8.0-8.2, we + * decided not to "fix" it in 8.3, leaving the behavior slightly + * different. + */ + + if ((nsPtr != globalNsPtr) && !specificNsInPattern) { + entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search); + while (entryPtr != NULL) { + cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr); + if ((simplePattern == NULL) + || Tcl_StringMatch(cmdName, simplePattern)) { + if (Tcl_FindHashEntry(&nsPtr->cmdTable,cmdName) == NULL) { + cmdPtr = Tcl_GetHashValue(entryPtr); + realCmdPtr = (Command *) TclGetOriginalCommand( + (Tcl_Command) cmdPtr); + + if (TclIsProc(cmdPtr) || ((realCmdPtr != NULL) + && TclIsProc(realCmdPtr))) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(cmdName, -1)); + } + } + } + entryPtr = Tcl_NextHashEntry(&search); + } + } +#endif + } + + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InfoScriptCmd -- + * + * Called to implement the "info script" command that returns the script + * file that is currently being evaluated. Handles the following syntax: + * + * info script ?newName? + * + * If newName is specified, it will set that as the internal name. + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. It may change the internal + * script filename. + * + *---------------------------------------------------------------------- + */ + +static int +InfoScriptCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Interp *iPtr = (Interp *) interp; + if ((objc != 1) && (objc != 2)) { + Tcl_WrongNumArgs(interp, 1, objv, "?filename?"); + return TCL_ERROR; + } + + if (objc == 2) { + if (iPtr->scriptFile != NULL) { + Tcl_DecrRefCount(iPtr->scriptFile); + } + iPtr->scriptFile = objv[1]; + Tcl_IncrRefCount(iPtr->scriptFile); + } + if (iPtr->scriptFile != NULL) { + Tcl_SetObjResult(interp, iPtr->scriptFile); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InfoSharedlibCmd -- + * + * Called to implement the "info sharedlibextension" command that returns + * the file extension used for shared libraries. Handles the following + * syntax: + * + * info sharedlibextension + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoSharedlibCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return TCL_ERROR; + } + +#ifdef TCL_SHLIB_EXT + Tcl_SetObjResult(interp, Tcl_NewStringObj(TCL_SHLIB_EXT, -1)); +#endif + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InfoTclVersionCmd -- + * + * Called to implement the "info tclversion" command that returns the + * version number for this Tcl library. Handles the following syntax: + * + * info tclversion + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoTclVersionCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Obj *version; + + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return TCL_ERROR; + } + + version = Tcl_GetVar2Ex(interp, "tcl_version", NULL, + (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); + if (version != NULL) { + Tcl_SetObjResult(interp, version); + return TCL_OK; + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_JoinObjCmd -- + * + * This procedure is invoked to process the "join" Tcl command. See the + * user documentation for details on what it does. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_JoinObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ +{ + int listLen, i; + Tcl_Obj *resObjPtr, *joinObjPtr, **elemPtrs; + + if ((objc < 2) || (objc > 3)) { + Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?"); + return TCL_ERROR; + } + + /* + * Make sure the list argument is a list object and get its length and a + * pointer to its array of element pointers. + */ + + if (TclListObjGetElements(interp, objv[1], &listLen, + &elemPtrs) != TCL_OK) { + return TCL_ERROR; + } + + joinObjPtr = (objc == 2) ? Tcl_NewStringObj(" ", 1) : objv[2]; + Tcl_IncrRefCount(joinObjPtr); + + resObjPtr = Tcl_NewObj(); + for (i = 0; i < listLen; i++) { + if (i > 0) { + Tcl_AppendObjToObj(resObjPtr, joinObjPtr); + } + Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]); + } + Tcl_DecrRefCount(joinObjPtr); + Tcl_SetObjResult(interp, resObjPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LassignObjCmd -- + * + * This object-based procedure is invoked to process the "lassign" Tcl + * command. See the user documentation for details on what it does. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_LassignObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Obj *listCopyPtr; + Tcl_Obj **listObjv; /* The contents of the list. */ + int listObjc; /* The length of the list. */ + int code = TCL_OK; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "list ?varName ...?"); + return TCL_ERROR; + } + + listCopyPtr = TclListObjCopy(interp, objv[1]); + if (listCopyPtr == NULL) { + return TCL_ERROR; + } + + TclListObjGetElements(NULL, listCopyPtr, &listObjc, &listObjv); + + objc -= 2; + objv += 2; + while (code == TCL_OK && objc > 0 && listObjc > 0) { + if (Tcl_ObjSetVar2(interp, *objv++, NULL, *listObjv++, + TCL_LEAVE_ERR_MSG) == NULL) { + code = TCL_ERROR; + } + objc--; + listObjc--; + } + + if (code == TCL_OK && objc > 0) { + Tcl_Obj *emptyObj; + + TclNewObj(emptyObj); + Tcl_IncrRefCount(emptyObj); + while (code == TCL_OK && objc-- > 0) { + if (Tcl_ObjSetVar2(interp, *objv++, NULL, emptyObj, + TCL_LEAVE_ERR_MSG) == NULL) { + code = TCL_ERROR; + } + } + Tcl_DecrRefCount(emptyObj); + } + + if (code == TCL_OK && listObjc > 0) { + Tcl_SetObjResult(interp, Tcl_NewListObj(listObjc, listObjv)); + } + + Tcl_DecrRefCount(listCopyPtr); + return code; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LindexObjCmd -- + * + * This object-based procedure is invoked to process the "lindex" Tcl + * command. See the user documentation for details on what it does. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_LindexObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + + Tcl_Obj *elemPtr; /* Pointer to the element being extracted. */ + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "list ?index ...?"); + return TCL_ERROR; + } + + /* + * If objc==3, then objv[2] may be either a single index or a list of + * indices: go to TclLindexList to determine which. If objc>=4, or + * objc==2, then objv[2 .. objc-2] are all single indices and processed as + * such in TclLindexFlat. + */ + + if (objc == 3) { + elemPtr = TclLindexList(interp, objv[1], objv[2]); + } else { + elemPtr = TclLindexFlat(interp, objv[1], objc-2, objv+2); + } + + /* + * Set the interpreter's object result to the last element extracted. + */ + + if (elemPtr == NULL) { + return TCL_ERROR; + } + + Tcl_SetObjResult(interp, elemPtr); + Tcl_DecrRefCount(elemPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LinsertObjCmd -- + * + * This object-based procedure is invoked to process the "linsert" Tcl + * command. See the user documentation for details on what it does. + * + * Results: + * A new Tcl list object formed by inserting zero or more elements into a + * list. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_LinsertObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + register int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Obj *listPtr; + int index, len, result; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "list index ?element ...?"); + return TCL_ERROR; + } + + result = TclListObjLength(interp, objv[1], &len); + if (result != TCL_OK) { + return result; + } + + /* + * Get the index. "end" is interpreted to be the index after the last + * element, such that using it will cause any inserted elements to be + * appended to the list. + */ + + result = TclGetIntForIndexM(interp, objv[2], /*end*/ len, &index); + if (result != TCL_OK) { + return result; + } + if (index > len) { + index = len; + } + + /* + * If the list object is unshared we can modify it directly. Otherwise we + * create a copy to modify: this is "copy on write". + */ + + listPtr = objv[1]; + if (Tcl_IsShared(listPtr)) { + listPtr = TclListObjCopy(NULL, listPtr); + } + + if ((objc == 4) && (index == len)) { + /* + * Special case: insert one element at the end of the list. + */ + + Tcl_ListObjAppendElement(NULL, listPtr, objv[3]); + } else { + if (TCL_OK != Tcl_ListObjReplace(interp, listPtr, index, 0, + (objc-3), &(objv[3]))) { + return TCL_ERROR; + } + } + + /* + * Set the interpreter's object result. + */ + + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ListObjCmd -- + * + * This procedure is invoked to process the "list" Tcl command. See the + * user documentation for details on what it does. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ListObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + register int objc, /* Number of arguments. */ + register Tcl_Obj *const objv[]) + /* The argument objects. */ +{ + /* + * If there are no list elements, the result is an empty object. + * Otherwise set the interpreter's result object to be a list object. + */ + + if (objc > 1) { + Tcl_SetObjResult(interp, Tcl_NewListObj(objc-1, &objv[1])); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LlengthObjCmd -- + * + * This object-based procedure is invoked to process the "llength" Tcl + * command. See the user documentation for details on what it does. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_LlengthObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + register Tcl_Obj *const objv[]) + /* Argument objects. */ +{ + int listLen, result; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "list"); + return TCL_ERROR; + } + + result = TclListObjLength(interp, objv[1], &listLen); + if (result != TCL_OK) { + return result; + } + + /* + * Set the interpreter's object result to an integer object holding the + * length. + */ + + Tcl_SetObjResult(interp, Tcl_NewIntObj(listLen)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LrangeObjCmd -- + * + * This procedure is invoked to process the "lrange" Tcl command. See the + * user documentation for details on what it does. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_LrangeObjCmd( + ClientData notUsed, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + register Tcl_Obj *const objv[]) + /* Argument objects. */ +{ + Tcl_Obj **elemPtrs; + int listLen, first, last, result; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "list first last"); + return TCL_ERROR; + } + + result = TclListObjLength(interp, objv[1], &listLen); + if (result != TCL_OK) { + return result; + } + + result = TclGetIntForIndexM(interp, objv[2], /*endValue*/ listLen - 1, + &first); + if (result != TCL_OK) { + return result; + } + if (first < 0) { + first = 0; + } + + result = TclGetIntForIndexM(interp, objv[3], /*endValue*/ listLen - 1, + &last); + if (result != TCL_OK) { + return result; + } + if (last >= listLen) { + last = listLen - 1; + } + + if (first > last) { + /* + * Returning an empty list is easy. + */ + + return TCL_OK; + } + + result = TclListObjGetElements(interp, objv[1], &listLen, &elemPtrs); + if (result != TCL_OK) { + return result; + } + + if (Tcl_IsShared(objv[1]) || + ((ListRepPtr(objv[1])->refCount > 1))) { + Tcl_SetObjResult(interp, Tcl_NewListObj(last - first + 1, + &elemPtrs[first])); + } else { + /* + * In-place is possible. + */ + + if (last < (listLen - 1)) { + Tcl_ListObjReplace(interp, objv[1], last + 1, listLen - 1 - last, + 0, NULL); + } + + /* + * This one is not conditioned on (first > 0) in order to preserve the + * string-canonizing effect of [lrange 0 end]. + */ + + Tcl_ListObjReplace(interp, objv[1], 0, first, 0, NULL); + Tcl_SetObjResult(interp, objv[1]); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LrepeatObjCmd -- + * + * This procedure is invoked to process the "lrepeat" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_LrepeatObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + register int objc, /* Number of arguments. */ + register Tcl_Obj *const objv[]) + /* The argument objects. */ +{ + int elementCount, i, totalElems; + Tcl_Obj *listPtr, **dataArray = NULL; + + /* + * Check arguments for legality: + * lrepeat count ?value ...? + */ + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "count ?value ...?"); + return TCL_ERROR; + } + if (TCL_OK != TclGetIntFromObj(interp, objv[1], &elementCount)) { + return TCL_ERROR; + } + if (elementCount < 0) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad count \"%d\": must be integer >= 0", elementCount)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREPEAT", "NEGARG", + NULL); + return TCL_ERROR; + } + + /* + * Skip forward to the interesting arguments now we've finished parsing. + */ + + objc -= 2; + objv += 2; + + /* Final sanity check. Do not exceed limits on max list length. */ + + if (elementCount && objc > LIST_MAX/elementCount) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "max length of a Tcl list (%d elements) exceeded", LIST_MAX)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + return TCL_ERROR; + } + totalElems = objc * elementCount; + + /* + * Get an empty list object that is allocated large enough to hold each + * init value elementCount times. + */ + + listPtr = Tcl_NewListObj(totalElems, NULL); + if (totalElems) { + List *listRepPtr = ListRepPtr(listPtr); + + listRepPtr->elemCount = elementCount*objc; + dataArray = &listRepPtr->elements; + } + + /* + * Set the elements. Note that we handle the common degenerate case of a + * single value being repeated separately to permit the compiler as much + * room as possible to optimize a loop that might be run a very large + * number of times. + */ + + CLANG_ASSERT(dataArray || totalElems == 0 ); + if (objc == 1) { + register Tcl_Obj *tmpPtr = objv[0]; + + tmpPtr->refCount += elementCount; + for (i=0 ; i<elementCount ; i++) { + dataArray[i] = tmpPtr; + } + } else { + int j, k = 0; + + for (i=0 ; i<elementCount ; i++) { + for (j=0 ; j<objc ; j++) { + Tcl_IncrRefCount(objv[j]); + dataArray[k++] = objv[j]; + } + } + } + + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LreplaceObjCmd -- + * + * This object-based procedure is invoked to process the "lreplace" Tcl + * command. See the user documentation for details on what it does. + * + * Results: + * A new Tcl list object formed by replacing zero or more elements of a + * list. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_LreplaceObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + register Tcl_Obj *listPtr; + int first, last, listLen, numToDelete, result; + + if (objc < 4) { + Tcl_WrongNumArgs(interp, 1, objv, + "list first last ?element ...?"); + return TCL_ERROR; + } + + result = TclListObjLength(interp, objv[1], &listLen); + if (result != TCL_OK) { + return result; + } + + /* + * Get the first and last indexes. "end" is interpreted to be the index + * for the last element, such that using it will cause that element to be + * included for deletion. + */ + + result = TclGetIntForIndexM(interp, objv[2], /*end*/ listLen-1, &first); + if (result != TCL_OK) { + return result; + } + + result = TclGetIntForIndexM(interp, objv[3], /*end*/ listLen-1, &last); + if (result != TCL_OK) { + return result; + } + + if (first < 0) { + first = 0; + } + + /* + * Complain if the user asked for a start element that is greater than the + * list length. This won't ever trigger for the "end-*" case as that will + * be properly constrained by TclGetIntForIndex because we use listLen-1 + * (to allow for replacing the last elem). + */ + + if ((first > listLen) && (listLen > 0)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "list doesn't contain element %s", TclGetString(objv[2]))); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREPLACE", "BADIDX", + NULL); + return TCL_ERROR; + } + if (last >= listLen) { + last = listLen - 1; + } + if (first <= last) { + numToDelete = last - first + 1; + } else { + numToDelete = 0; + } + + /* + * If the list object is unshared we can modify it directly, otherwise we + * create a copy to modify: this is "copy on write". + */ + + listPtr = objv[1]; + if (Tcl_IsShared(listPtr)) { + listPtr = TclListObjCopy(NULL, listPtr); + } + + /* + * Note that we call Tcl_ListObjReplace even when numToDelete == 0 and + * objc == 4. In this case, the list value of listPtr is not changed (no + * elements are removed or added), but by making the call we are assured + * we end up with a list in canonical form. Resist any temptation to + * optimize this case away. + */ + + if (TCL_OK != Tcl_ListObjReplace(interp, listPtr, first, numToDelete, + objc-4, objv+4)) { + return TCL_ERROR; + } + + /* + * Set the interpreter's object result. + */ + + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LreverseObjCmd -- + * + * This procedure is invoked to process the "lreverse" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_LreverseObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument values. */ +{ + Tcl_Obj **elemv; + int elemc, i, j; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "list"); + return TCL_ERROR; + } + if (TclListObjGetElements(interp, objv[1], &elemc, &elemv) != TCL_OK) { + return TCL_ERROR; + } + + /* + * If the list is empty, just return it. [Bug 1876793] + */ + + if (!elemc) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; + } + + if (Tcl_IsShared(objv[1]) + || (ListRepPtr(objv[1])->refCount > 1)) { /* Bug 1675044 */ + Tcl_Obj *resultObj, **dataArray; + List *listRepPtr; + + resultObj = Tcl_NewListObj(elemc, NULL); + listRepPtr = ListRepPtr(resultObj); + listRepPtr->elemCount = elemc; + dataArray = &listRepPtr->elements; + + for (i=0,j=elemc-1 ; i<elemc ; i++,j--) { + dataArray[j] = elemv[i]; + Tcl_IncrRefCount(elemv[i]); + } + + Tcl_SetObjResult(interp, resultObj); + } else { + + /* + * Not shared, so swap "in place". This relies on Tcl_LOGE above + * returning a pointer to the live array of Tcl_Obj values. + */ + + for (i=0,j=elemc-1 ; i<j ; i++,j--) { + Tcl_Obj *tmp = elemv[i]; + + elemv[i] = elemv[j]; + elemv[j] = tmp; + } + TclInvalidateStringRep(objv[1]); + Tcl_SetObjResult(interp, objv[1]); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LsearchObjCmd -- + * + * This procedure is invoked to process the "lsearch" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_LsearchObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument values. */ +{ + const char *bytes, *patternBytes; + int i, match, index, result, listc, length, elemLen, bisect; + int dataType, isIncreasing, lower, upper, offset; + Tcl_WideInt patWide, objWide; + int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase; + double patDouble, objDouble; + SortInfo sortInfo; + Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr; + SortStrCmpFn_t strCmpFn = strcmp; + Tcl_RegExp regexp = NULL; + static const char *const options[] = { + "-all", "-ascii", "-bisect", "-decreasing", "-dictionary", + "-exact", "-glob", "-increasing", "-index", + "-inline", "-integer", "-nocase", "-not", + "-real", "-regexp", "-sorted", "-start", + "-subindices", NULL + }; + enum options { + LSEARCH_ALL, LSEARCH_ASCII, LSEARCH_BISECT, LSEARCH_DECREASING, + LSEARCH_DICTIONARY, LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_INCREASING, + LSEARCH_INDEX, LSEARCH_INLINE, LSEARCH_INTEGER, LSEARCH_NOCASE, + LSEARCH_NOT, LSEARCH_REAL, LSEARCH_REGEXP, LSEARCH_SORTED, + LSEARCH_START, LSEARCH_SUBINDICES + }; + enum datatypes { + ASCII, DICTIONARY, INTEGER, REAL + }; + enum modes { + EXACT, GLOB, REGEXP, SORTED + }; + enum modes mode; + + mode = GLOB; + dataType = ASCII; + isIncreasing = 1; + allMatches = 0; + inlineReturn = 0; + returnSubindices = 0; + negatedMatch = 0; + bisect = 0; + listPtr = NULL; + startPtr = NULL; + offset = 0; + noCase = 0; + sortInfo.compareCmdPtr = NULL; + sortInfo.isIncreasing = 1; + sortInfo.sortMode = 0; + sortInfo.interp = interp; + sortInfo.resultCode = TCL_OK; + sortInfo.indexv = NULL; + sortInfo.indexc = 0; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "?-option value ...? list pattern"); + return TCL_ERROR; + } + + for (i = 1; i < objc-2; i++) { + if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) + != TCL_OK) { + if (startPtr != NULL) { + Tcl_DecrRefCount(startPtr); + } + result = TCL_ERROR; + goto done; + } + switch ((enum options) index) { + case LSEARCH_ALL: /* -all */ + allMatches = 1; + break; + case LSEARCH_ASCII: /* -ascii */ + dataType = ASCII; + break; + case LSEARCH_BISECT: /* -bisect */ + mode = SORTED; + bisect = 1; + break; + case LSEARCH_DECREASING: /* -decreasing */ + isIncreasing = 0; + sortInfo.isIncreasing = 0; + break; + case LSEARCH_DICTIONARY: /* -dictionary */ + dataType = DICTIONARY; + break; + case LSEARCH_EXACT: /* -increasing */ + mode = EXACT; + break; + case LSEARCH_GLOB: /* -glob */ + mode = GLOB; + break; + case LSEARCH_INCREASING: /* -increasing */ + isIncreasing = 1; + sortInfo.isIncreasing = 1; + break; + case LSEARCH_INLINE: /* -inline */ + inlineReturn = 1; + break; + case LSEARCH_INTEGER: /* -integer */ + dataType = INTEGER; + break; + case LSEARCH_NOCASE: /* -nocase */ + strCmpFn = TclUtfCasecmp; + noCase = 1; + break; + case LSEARCH_NOT: /* -not */ + negatedMatch = 1; + break; + case LSEARCH_REAL: /* -real */ + dataType = REAL; + break; + case LSEARCH_REGEXP: /* -regexp */ + mode = REGEXP; + break; + 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 != NULL) { + Tcl_DecrRefCount(startPtr); + } + if (i > objc-4) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "missing starting index", -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); + result = TCL_ERROR; + goto done; + } + 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. + */ + + startPtr = Tcl_DuplicateObj(objv[i]); + } else { + startPtr = objv[i]; + Tcl_IncrRefCount(startPtr); + } + break; + case LSEARCH_INDEX: { /* -index */ + Tcl_Obj **indices; + int j; + + if (sortInfo.indexc > 1) { + TclStackFree(interp, sortInfo.indexv); + } + if (i > objc-4) { + if (startPtr != NULL) { + Tcl_DecrRefCount(startPtr); + } + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\"-index\" option must be followed by list index", + -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); + return TCL_ERROR; + } + + /* + * Store the extracted indices for processing by sublist + * extraction. Note that we don't do this using objects because + * that has shimmering problems. + */ + + i++; + if (TclListObjGetElements(interp, objv[i], + &sortInfo.indexc, &indices) != TCL_OK) { + if (startPtr != NULL) { + Tcl_DecrRefCount(startPtr); + } + return TCL_ERROR; + } + switch (sortInfo.indexc) { + case 0: + sortInfo.indexv = NULL; + break; + case 1: + sortInfo.indexv = &sortInfo.singleIndex; + break; + default: + sortInfo.indexv = + TclStackAlloc(interp, sizeof(int) * sortInfo.indexc); + } + + /* + * Fill the array by parsing each index. We don't know whether + * their scale is sensible yet, but we at least perform the + * syntactic check here. + */ + + for (j=0 ; j<sortInfo.indexc ; j++) { + if (TclGetIntForIndexM(interp, indices[j], SORTIDX_END, + &sortInfo.indexv[j]) != TCL_OK) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (-index option item number %d)", j)); + result = TCL_ERROR; + goto done; + } + } + break; + } + } + } + + /* + * Subindices only make sense if asked for with -index option set. + */ + + if (returnSubindices && sortInfo.indexc==0) { + if (startPtr != NULL) { + Tcl_DecrRefCount(startPtr); + } + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "-subindices cannot be used without -index option", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", + "BAD_OPTION_MIX", NULL); + return TCL_ERROR; + } + + if (bisect && (allMatches || negatedMatch)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "-bisect is not compatible with -all or -not", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", + "BAD_OPTION_MIX", NULL); + return TCL_ERROR; + } + + if (mode == REGEXP) { + /* + * We can shimmer regexp/list if listv[i] == pattern, so get the + * regexp rep before the list rep. First time round, omit the interp + * and hope that the compilation will succeed. If it fails, we'll + * recompile in "expensive" mode with a place to put error messages. + */ + + regexp = Tcl_GetRegExpFromObj(NULL, objv[objc - 1], + TCL_REG_ADVANCED | TCL_REG_NOSUB | + (noCase ? TCL_REG_NOCASE : 0)); + if (regexp == NULL) { + /* + * Failed to compile the RE. Try again without the TCL_REG_NOSUB + * flag in case the RE had sub-expressions in it [Bug 1366683]. If + * this fails, an error message will be left in the interpreter. + */ + + regexp = Tcl_GetRegExpFromObj(interp, objv[objc - 1], + TCL_REG_ADVANCED | (noCase ? TCL_REG_NOCASE : 0)); + } + + if (regexp == NULL) { + if (startPtr != NULL) { + Tcl_DecrRefCount(startPtr); + } + result = TCL_ERROR; + goto done; + } + } + + /* + * Make sure the list argument is a list object and get its length and a + * pointer to its array of element pointers. + */ + + result = TclListObjGetElements(interp, objv[objc - 2], &listc, &listv); + if (result != TCL_OK) { + if (startPtr != NULL) { + Tcl_DecrRefCount(startPtr); + } + goto done; + } + + /* + * Get the user-specified start offset. + */ + + if (startPtr) { + result = TclGetIntForIndexM(interp, startPtr, listc-1, &offset); + Tcl_DecrRefCount(startPtr); + if (result != TCL_OK) { + goto done; + } + if (offset < 0) { + offset = 0; + } + + /* + * If the search started past the end of the list, we just return a + * "did not match anything at all" result straight away. [Bug 1374778] + */ + + if (offset > listc-1) { + if (sortInfo.indexc > 1) { + TclStackFree(interp, sortInfo.indexv); + } + if (allMatches || inlineReturn) { + Tcl_ResetResult(interp); + } else { + Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); + } + return TCL_OK; + } + } + + patObj = objv[objc - 1]; + patternBytes = NULL; + if (mode == EXACT || mode == SORTED) { + switch ((enum datatypes) dataType) { + case ASCII: + case DICTIONARY: + patternBytes = TclGetStringFromObj(patObj, &length); + break; + case INTEGER: + result = TclGetWideIntFromObj(interp, patObj, &patWide); + if (result != TCL_OK) { + goto done; + } + + /* + * List representation might have been shimmered; restore it. [Bug + * 1844789] + */ + + TclListObjGetElements(NULL, objv[objc - 2], &listc, &listv); + break; + case REAL: + result = Tcl_GetDoubleFromObj(interp, patObj, &patDouble); + if (result != TCL_OK) { + goto done; + } + + /* + * List representation might have been shimmered; restore it. [Bug + * 1844789] + */ + + TclListObjGetElements(NULL, objv[objc - 2], &listc, &listv); + break; + } + } else { + patternBytes = TclGetStringFromObj(patObj, &length); + } + + /* + * Set default index value to -1, indicating failure; if we find the item + * in the course of our search, index will be set to the correct value. + */ + + index = -1; + match = 0; + + if (mode == SORTED && !allMatches && !negatedMatch) { + /* + * If the data is sorted, we can do a more intelligent search. Note + * that there is no point in being smart when -all was specified; in + * that case, we have to look at all items anyway, and there is no + * sense in doing this when the match sense is inverted. + */ + + lower = offset - 1; + upper = listc; + while (lower + 1 != upper && sortInfo.resultCode == TCL_OK) { + i = (lower + upper)/2; + if (sortInfo.indexc != 0) { + itemPtr = SelectObjFromSublist(listv[i], &sortInfo); + if (sortInfo.resultCode != TCL_OK) { + result = sortInfo.resultCode; + goto done; + } + } else { + itemPtr = listv[i]; + } + switch ((enum datatypes) dataType) { + case ASCII: + bytes = TclGetString(itemPtr); + match = strCmpFn(patternBytes, bytes); + break; + case DICTIONARY: + bytes = TclGetString(itemPtr); + match = DictionaryCompare(patternBytes, bytes); + break; + case INTEGER: + result = TclGetWideIntFromObj(interp, itemPtr, &objWide); + if (result != TCL_OK) { + goto done; + } + if (patWide == objWide) { + match = 0; + } else if (patWide < objWide) { + match = -1; + } else { + match = 1; + } + break; + case REAL: + result = Tcl_GetDoubleFromObj(interp, itemPtr, &objDouble); + if (result != TCL_OK) { + goto done; + } + if (patDouble == objDouble) { + match = 0; + } else if (patDouble < objDouble) { + match = -1; + } else { + match = 1; + } + break; + } + if (match == 0) { + /* + * Normally, binary search is written to stop when it finds a + * match. If there are duplicates of an element in the list, + * our first match might not be the first occurance. + * Consider: 0 0 0 1 1 1 2 2 2 + * + * To maintain consistancy with standard lsearch semantics, we + * must find the leftmost occurance of the pattern in the + * list. Thus we don't just stop searching here. This + * variation means that a search always makes log n + * comparisons (normal binary search might "get lucky" with an + * early comparison). + * + * In bisect mode though, we want the last of equals. + */ + + index = i; + if (bisect) { + lower = i; + } else { + upper = i; + } + } else if (match > 0) { + if (isIncreasing) { + lower = i; + } else { + upper = i; + } + } else { + if (isIncreasing) { + upper = i; + } else { + lower = i; + } + } + } + if (bisect && index < 0) { + index = lower; + } + } else { + /* + * We need to do a linear search, because (at least one) of: + * - our matcher can only tell equal vs. not equal + * - our matching sense is negated + * - we're building a list of all matched items + */ + + if (allMatches) { + listPtr = Tcl_NewListObj(0, NULL); + } + for (i = offset; i < listc; i++) { + match = 0; + if (sortInfo.indexc != 0) { + itemPtr = SelectObjFromSublist(listv[i], &sortInfo); + if (sortInfo.resultCode != TCL_OK) { + if (listPtr != NULL) { + Tcl_DecrRefCount(listPtr); + } + result = sortInfo.resultCode; + goto done; + } + } else { + itemPtr = listv[i]; + } + + switch (mode) { + case SORTED: + case EXACT: + switch ((enum datatypes) dataType) { + case ASCII: + bytes = TclGetStringFromObj(itemPtr, &elemLen); + if (length == elemLen) { + /* + * This split allows for more optimal compilation of + * memcmp/strcasecmp. + */ + + if (noCase) { + match = (TclUtfCasecmp(bytes, patternBytes) == 0); + } else { + match = (memcmp(bytes, patternBytes, + (size_t) length) == 0); + } + } + break; + + case DICTIONARY: + bytes = TclGetString(itemPtr); + match = (DictionaryCompare(bytes, patternBytes) == 0); + break; + + case INTEGER: + result = TclGetWideIntFromObj(interp, itemPtr, &objWide); + if (result != TCL_OK) { + if (listPtr != NULL) { + Tcl_DecrRefCount(listPtr); + } + goto done; + } + match = (objWide == patWide); + break; + + case REAL: + result = Tcl_GetDoubleFromObj(interp,itemPtr, &objDouble); + if (result != TCL_OK) { + if (listPtr) { + Tcl_DecrRefCount(listPtr); + } + goto done; + } + match = (objDouble == patDouble); + break; + } + break; + + case GLOB: + match = Tcl_StringCaseMatch(TclGetString(itemPtr), + patternBytes, noCase); + break; + + case REGEXP: + match = Tcl_RegExpExecObj(interp, regexp, itemPtr, 0, 0, 0); + if (match < 0) { + Tcl_DecrRefCount(patObj); + if (listPtr != NULL) { + Tcl_DecrRefCount(listPtr); + } + result = TCL_ERROR; + goto done; + } + break; + } + + /* + * Invert match condition for -not. + */ + + if (negatedMatch) { + match = !match; + } + if (!match) { + continue; + } + if (!allMatches) { + index = i; + break; + } else if (inlineReturn) { + /* + * Note that these appends are not expected to fail. + */ + + if (returnSubindices && (sortInfo.indexc != 0)) { + itemPtr = SelectObjFromSublist(listv[i], &sortInfo); + } else { + itemPtr = listv[i]; + } + Tcl_ListObjAppendElement(interp, listPtr, itemPtr); + } else if (returnSubindices) { + int j; + + itemPtr = Tcl_NewIntObj(i); + for (j=0 ; j<sortInfo.indexc ; j++) { + Tcl_ListObjAppendElement(interp, itemPtr, + Tcl_NewIntObj(sortInfo.indexv[j])); + } + Tcl_ListObjAppendElement(interp, listPtr, itemPtr); + } else { + Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewIntObj(i)); + } + } + } + + /* + * Return everything or a single value. + */ + + if (allMatches) { + Tcl_SetObjResult(interp, listPtr); + } else if (!inlineReturn) { + if (returnSubindices) { + int j; + + itemPtr = Tcl_NewIntObj(index); + for (j=0 ; j<sortInfo.indexc ; j++) { + Tcl_ListObjAppendElement(interp, itemPtr, + Tcl_NewIntObj(sortInfo.indexv[j])); + } + Tcl_SetObjResult(interp, itemPtr); + } else { + Tcl_SetObjResult(interp, Tcl_NewIntObj(index)); + } + } else if (index < 0) { + /* + * Is this superfluous? The result should be a blank object by + * default... + */ + + Tcl_SetObjResult(interp, Tcl_NewObj()); + } else { + Tcl_SetObjResult(interp, listv[index]); + } + result = TCL_OK; + + /* + * Cleanup the index list array. + */ + + done: + if (sortInfo.indexc > 1) { + TclStackFree(interp, sortInfo.indexv); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LsetObjCmd -- + * + * This procedure is invoked to process the "lset" Tcl command. See the + * user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_LsetObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument values. */ +{ + Tcl_Obj *listPtr; /* Pointer to the list being altered. */ + Tcl_Obj *finalValuePtr; /* Value finally assigned to the variable. */ + + /* + * Check parameter count. + */ + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, + "listVar ?index? ?index ...? value"); + return TCL_ERROR; + } + + /* + * Look up the list variable's value. + */ + + listPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); + if (listPtr == NULL) { + return TCL_ERROR; + } + + /* + * Substitute the value in the value. Return either the value or else an + * unshared copy of it. + */ + + if (objc == 4) { + finalValuePtr = TclLsetList(interp, listPtr, objv[2], objv[3]); + } else { + finalValuePtr = TclLsetFlat(interp, listPtr, objc-3, objv+2, + objv[objc-1]); + } + + /* + * If substitution has failed, bail out. + */ + + if (finalValuePtr == NULL) { + return TCL_ERROR; + } + + /* + * Finally, update the variable so that traces fire. + */ + + listPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, finalValuePtr, + TCL_LEAVE_ERR_MSG); + Tcl_DecrRefCount(finalValuePtr); + if (listPtr == NULL) { + return TCL_ERROR; + } + + /* + * Return the new value of the variable as the interpreter result. + */ + + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LsortObjCmd -- + * + * This procedure is invoked to process the "lsort" Tcl command. See the + * user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_LsortObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument values. */ +{ + int i, j, index, indices, length, nocase = 0, indexc; + int sortMode = SORTMODE_ASCII; + int group, groupSize, groupOffset, idx, allocatedIndexVector = 0; + Tcl_Obj *resultPtr, *cmdPtr, **listObjPtrs, *listObj, *indexPtr; + SortElement *elementArray, *elementPtr; + SortInfo sortInfo; /* Information about this sort that needs to + * be passed to the comparison function. */ +# define NUM_LISTS 30 + SortElement *subList[NUM_LISTS+1]; + /* This array holds pointers to temporary + * lists built during the merge sort. Element + * i of the array holds a list of length + * 2**i. */ + static const char *const switches[] = { + "-ascii", "-command", "-decreasing", "-dictionary", "-increasing", + "-index", "-indices", "-integer", "-nocase", "-real", "-stride", + "-unique", NULL + }; + enum Lsort_Switches { + LSORT_ASCII, LSORT_COMMAND, LSORT_DECREASING, LSORT_DICTIONARY, + LSORT_INCREASING, LSORT_INDEX, LSORT_INDICES, LSORT_INTEGER, + LSORT_NOCASE, LSORT_REAL, LSORT_STRIDE, LSORT_UNIQUE + }; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?-option value ...? list"); + return TCL_ERROR; + } + + /* + * Parse arguments to set up the mode for the sort. + */ + + sortInfo.isIncreasing = 1; + sortInfo.sortMode = SORTMODE_ASCII; + sortInfo.indexv = NULL; + sortInfo.indexc = 0; + sortInfo.unique = 0; + sortInfo.interp = interp; + sortInfo.resultCode = TCL_OK; + cmdPtr = NULL; + indices = 0; + group = 0; + groupSize = 1; + groupOffset = 0; + indexPtr = NULL; + for (i = 1; i < objc-1; i++) { + if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, + &index) != TCL_OK) { + sortInfo.resultCode = TCL_ERROR; + goto done2; + } + switch ((enum Lsort_Switches) index) { + case LSORT_ASCII: + sortInfo.sortMode = SORTMODE_ASCII; + break; + case LSORT_COMMAND: + if (i == objc-2) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\"-command\" option must be followed " + "by comparison command", -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); + sortInfo.resultCode = TCL_ERROR; + goto done2; + } + sortInfo.sortMode = SORTMODE_COMMAND; + cmdPtr = objv[i+1]; + i++; + break; + case LSORT_DECREASING: + sortInfo.isIncreasing = 0; + break; + case LSORT_DICTIONARY: + sortInfo.sortMode = SORTMODE_DICTIONARY; + break; + case LSORT_INCREASING: + sortInfo.isIncreasing = 1; + break; + case LSORT_INDEX: { + int indexc, dummy; + Tcl_Obj **indexv; + + if (i == objc-2) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\"-index\" option must be followed by list index", + -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); + sortInfo.resultCode = TCL_ERROR; + goto done2; + } + if (TclListObjGetElements(interp, objv[i+1], &indexc, + &indexv) != TCL_OK) { + sortInfo.resultCode = TCL_ERROR; + goto done2; + } + + /* + * Check each of the indices for syntactic correctness. Note that + * we do not store the converted values here because we do not + * know if this is the only -index option yet and so we can't + * allocate any space; that happens after the scan through all the + * options is done. + */ + + for (j=0 ; j<indexc ; j++) { + if (TclGetIntForIndexM(interp, indexv[j], SORTIDX_END, + &dummy) != TCL_OK) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (-index option item number %d)", j)); + sortInfo.resultCode = TCL_ERROR; + goto done2; + } + } + indexPtr = objv[i+1]; + i++; + break; + } + case LSORT_INTEGER: + sortInfo.sortMode = SORTMODE_INTEGER; + break; + case LSORT_NOCASE: + nocase = 1; + break; + case LSORT_REAL: + sortInfo.sortMode = SORTMODE_REAL; + break; + case LSORT_UNIQUE: + sortInfo.unique = 1; + break; + case LSORT_INDICES: + indices = 1; + break; + case LSORT_STRIDE: + if (i == objc-2) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\"-stride\" option must be " + "followed by stride length", -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); + sortInfo.resultCode = TCL_ERROR; + goto done2; + } + if (Tcl_GetIntFromObj(interp, objv[i+1], &groupSize) != TCL_OK) { + sortInfo.resultCode = TCL_ERROR; + goto done2; + } + if (groupSize < 2) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "stride length must be at least 2", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", + "BADSTRIDE", NULL); + sortInfo.resultCode = TCL_ERROR; + goto done2; + } + group = 1; + i++; + break; + } + } + if (nocase && (sortInfo.sortMode == SORTMODE_ASCII)) { + sortInfo.sortMode = SORTMODE_ASCII_NC; + } + + /* + * Now extract the -index list for real, if present. No failures are + * expected here; the values are all of the right type or convertible to + * it. + */ + + if (indexPtr) { + Tcl_Obj **indexv; + + TclListObjGetElements(interp, indexPtr, &sortInfo.indexc, &indexv); + switch (sortInfo.indexc) { + case 0: + sortInfo.indexv = NULL; + break; + case 1: + sortInfo.indexv = &sortInfo.singleIndex; + break; + default: + sortInfo.indexv = + TclStackAlloc(interp, sizeof(int) * sortInfo.indexc); + allocatedIndexVector = 1; /* Cannot use indexc field, as it + * might be decreased by 1 later. */ + } + for (j=0 ; j<sortInfo.indexc ; j++) { + TclGetIntForIndexM(interp, indexv[j], SORTIDX_END, + &sortInfo.indexv[j]); + } + } + + listObj = objv[objc-1]; + + if (sortInfo.sortMode == SORTMODE_COMMAND) { + Tcl_Obj *newCommandPtr, *newObjPtr; + + /* + * When sorting using a command, we are reentrant and therefore might + * have the representation of the list being sorted shimmered out from + * underneath our feet. Take a copy (cheap) to prevent this. [Bug + * 1675116] + */ + + listObj = TclListObjCopy(interp, listObj); + if (listObj == NULL) { + sortInfo.resultCode = TCL_ERROR; + goto done2; + } + + /* + * The existing command is a list. We want to flatten it, append two + * dummy arguments on the end, and replace these arguments later. + */ + + newCommandPtr = Tcl_DuplicateObj(cmdPtr); + TclNewObj(newObjPtr); + Tcl_IncrRefCount(newCommandPtr); + if (Tcl_ListObjAppendElement(interp, newCommandPtr, newObjPtr) + != TCL_OK) { + TclDecrRefCount(newCommandPtr); + TclDecrRefCount(listObj); + Tcl_IncrRefCount(newObjPtr); + TclDecrRefCount(newObjPtr); + sortInfo.resultCode = TCL_ERROR; + goto done2; + } + Tcl_ListObjAppendElement(interp, newCommandPtr, Tcl_NewObj()); + sortInfo.compareCmdPtr = newCommandPtr; + } + + sortInfo.resultCode = TclListObjGetElements(interp, listObj, + &length, &listObjPtrs); + if (sortInfo.resultCode != TCL_OK || length <= 0) { + goto done; + } + + /* + * Check for sanity when grouping elements of the overall list together + * because of the -stride option. [TIP #326] + */ + + if (group) { + if (length % groupSize) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "list size must be a multiple of the stride length", + -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", "BADSTRIDE", + NULL); + sortInfo.resultCode = TCL_ERROR; + goto done; + } + length = length / groupSize; + if (sortInfo.indexc > 0) { + /* + * Use the first value in the list supplied to -index as the + * offset of the element within each group by which to sort. + */ + + groupOffset = sortInfo.indexv[0]; + if (groupOffset <= SORTIDX_END) { + groupOffset = (groupOffset - SORTIDX_END) + groupSize - 1; + } + if (groupOffset < 0 || groupOffset >= groupSize) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "when used with \"-stride\", the leading \"-index\"" + " value must be within the group", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", + "BADINDEX", NULL); + sortInfo.resultCode = TCL_ERROR; + goto done; + } + if (sortInfo.indexc == 1) { + sortInfo.indexc = 0; + sortInfo.indexv = NULL; + } else { + sortInfo.indexc--; + + /* + * Do not shrink the actual memory block used; that doesn't + * work with TclStackAlloc-allocated memory. [Bug 2918962] + */ + + for (i = 0; i < sortInfo.indexc; i++) { + sortInfo.indexv[i] = sortInfo.indexv[i+1]; + } + } + } + } + + sortInfo.numElements = length; + + indexc = sortInfo.indexc; + sortMode = sortInfo.sortMode; + if ((sortMode == SORTMODE_ASCII_NC) + || (sortMode == SORTMODE_DICTIONARY)) { + /* + * For this function's purpose all string-based modes are equivalent + */ + + sortMode = SORTMODE_ASCII; + } + + /* + * Initialize the sublists. After the following loop, subList[i] will + * contain a sorted sublist of length 2**i. Use one extra subList at the + * end, always at NULL, to indicate the end of the lists. + */ + + for (j=0 ; j<=NUM_LISTS ; j++) { + subList[j] = NULL; + } + + /* + * The following loop creates a SortElement for each list element and + * begins sorting it into the sublists as it appears. + */ + + elementArray = TclStackAlloc(interp, length * sizeof(SortElement)); + + for (i=0; i < length; i++){ + idx = groupSize * i + groupOffset; + if (indexc) { + /* + * If this is an indexed sort, retrieve the corresponding element + */ + indexPtr = SelectObjFromSublist(listObjPtrs[idx], &sortInfo); + if (sortInfo.resultCode != TCL_OK) { + goto done1; + } + } else { + indexPtr = listObjPtrs[idx]; + } + + /* + * Determine the "value" of this object for sorting purposes + */ + + if (sortMode == SORTMODE_ASCII) { + elementArray[i].collationKey.strValuePtr = TclGetString(indexPtr); + } else if (sortMode == SORTMODE_INTEGER) { + Tcl_WideInt a; + + if (TclGetWideIntFromObj(sortInfo.interp, indexPtr, &a) != TCL_OK) { + sortInfo.resultCode = TCL_ERROR; + goto done1; + } + elementArray[i].collationKey.wideValue = a; + } else if (sortMode == SORTMODE_REAL) { + double a; + + if (Tcl_GetDoubleFromObj(sortInfo.interp, indexPtr, + &a) != TCL_OK) { + sortInfo.resultCode = TCL_ERROR; + goto done1; + } + elementArray[i].collationKey.doubleValue = a; + } else { + elementArray[i].collationKey.objValuePtr = indexPtr; + } + + /* + * Determine the representation of this element in the result: either + * the objPtr itself, or its index in the original list. + */ + + if (indices || group) { + elementArray[i].payload.index = idx; + } else { + elementArray[i].payload.objPtr = listObjPtrs[idx]; + } + + /* + * Merge this element in the pre-existing sublists (and merge together + * sublists when we have two of the same size). + */ + + elementArray[i].nextPtr = NULL; + elementPtr = &elementArray[i]; + for (j=0 ; subList[j] ; j++) { + elementPtr = MergeLists(subList[j], elementPtr, &sortInfo); + subList[j] = NULL; + } + if (j >= NUM_LISTS) { + j = NUM_LISTS-1; + } + subList[j] = elementPtr; + } + + /* + * Merge all sublists + */ + + elementPtr = subList[0]; + for (j=1 ; j<NUM_LISTS ; j++) { + elementPtr = MergeLists(subList[j], elementPtr, &sortInfo); + } + + /* + * Now store the sorted elements in the result list. + */ + + if (sortInfo.resultCode == TCL_OK) { + List *listRepPtr; + Tcl_Obj **newArray, *objPtr; + + resultPtr = Tcl_NewListObj(sortInfo.numElements * groupSize, NULL); + listRepPtr = ListRepPtr(resultPtr); + newArray = &listRepPtr->elements; + if (group) { + for (i=0; elementPtr!=NULL ; elementPtr=elementPtr->nextPtr) { + idx = elementPtr->payload.index; + for (j = 0; j < groupSize; j++) { + if (indices) { + objPtr = Tcl_NewIntObj(idx + j - groupOffset); + newArray[i++] = objPtr; + Tcl_IncrRefCount(objPtr); + } else { + objPtr = listObjPtrs[idx + j - groupOffset]; + newArray[i++] = objPtr; + Tcl_IncrRefCount(objPtr); + } + } + } + } else if (indices) { + for (i=0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) { + objPtr = Tcl_NewIntObj(elementPtr->payload.index); + newArray[i++] = objPtr; + Tcl_IncrRefCount(objPtr); + } + } else { + for (i=0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) { + objPtr = elementPtr->payload.objPtr; + newArray[i++] = objPtr; + Tcl_IncrRefCount(objPtr); + } + } + listRepPtr->elemCount = i; + Tcl_SetObjResult(interp, resultPtr); + } + + done1: + TclStackFree(interp, elementArray); + + done: + if (sortMode == SORTMODE_COMMAND) { + TclDecrRefCount(sortInfo.compareCmdPtr); + TclDecrRefCount(listObj); + sortInfo.compareCmdPtr = NULL; + } + done2: + if (allocatedIndexVector) { + TclStackFree(interp, sortInfo.indexv); + } + return sortInfo.resultCode; +} + +/* + *---------------------------------------------------------------------- + * + * MergeLists - + * + * This procedure combines two sorted lists of SortElement structures + * into a single sorted list. + * + * Results: + * The unified list of SortElement structures. + * + * Side effects: + * If infoPtr->unique is set then infoPtr->numElements may be updated. + * Possibly others, if a user-defined comparison command does something + * weird. + * + * Note: + * If infoPtr->unique is set, the merge assumes that there are no + * "repeated" elements in each of the left and right lists. In that case, + * if any element of the left list is equivalent to one in the right list + * it is omitted from the merged list. + * + * This simplified mechanism works because of the special way our + * MergeSort creates the sublists to be merged and will fail to eliminate + * all repeats in the general case where they are already present in + * either the left or right list. A general code would need to skip + * adjacent initial repeats in the left and right lists before comparing + * their initial elements, at each step. + * + *---------------------------------------------------------------------- + */ + +static SortElement * +MergeLists( + SortElement *leftPtr, /* First list to be merged; may be NULL. */ + SortElement *rightPtr, /* Second list to be merged; may be NULL. */ + SortInfo *infoPtr) /* Information needed by the comparison + * operator. */ +{ + SortElement *headPtr, *tailPtr; + int cmp; + + if (leftPtr == NULL) { + return rightPtr; + } + if (rightPtr == NULL) { + return leftPtr; + } + cmp = SortCompare(leftPtr, rightPtr, infoPtr); + if (cmp > 0 || (cmp == 0 && infoPtr->unique)) { + if (cmp == 0) { + infoPtr->numElements--; + leftPtr = leftPtr->nextPtr; + } + tailPtr = rightPtr; + rightPtr = rightPtr->nextPtr; + } else { + tailPtr = leftPtr; + leftPtr = leftPtr->nextPtr; + } + headPtr = tailPtr; + if (!infoPtr->unique) { + while ((leftPtr != NULL) && (rightPtr != NULL)) { + cmp = SortCompare(leftPtr, rightPtr, infoPtr); + if (cmp > 0) { + tailPtr->nextPtr = rightPtr; + tailPtr = rightPtr; + rightPtr = rightPtr->nextPtr; + } else { + tailPtr->nextPtr = leftPtr; + tailPtr = leftPtr; + leftPtr = leftPtr->nextPtr; + } + } + } else { + while ((leftPtr != NULL) && (rightPtr != NULL)) { + cmp = SortCompare(leftPtr, rightPtr, infoPtr); + if (cmp >= 0) { + if (cmp == 0) { + infoPtr->numElements--; + leftPtr = leftPtr->nextPtr; + } + tailPtr->nextPtr = rightPtr; + tailPtr = rightPtr; + rightPtr = rightPtr->nextPtr; + } else { + tailPtr->nextPtr = leftPtr; + tailPtr = leftPtr; + leftPtr = leftPtr->nextPtr; + } + } + } + if (leftPtr != NULL) { + tailPtr->nextPtr = leftPtr; + } else { + tailPtr->nextPtr = rightPtr; + } + return headPtr; +} + +/* + *---------------------------------------------------------------------- + * + * SortCompare -- + * + * This procedure is invoked by MergeLists to determine the proper + * ordering between two elements. + * + * Results: + * A negative results means the the first element comes before the + * second, and a positive results means that the second element should + * come first. A result of zero means the two elements are equal and it + * doesn't matter which comes first. + * + * Side effects: + * None, unless a user-defined comparison command does something weird. + * + *---------------------------------------------------------------------- + */ + +static int +SortCompare( + SortElement *elemPtr1, SortElement *elemPtr2, + /* Values to be compared. */ + SortInfo *infoPtr) /* Information passed from the top-level + * "lsort" command. */ +{ + int order = 0; + + if (infoPtr->sortMode == SORTMODE_ASCII) { + order = strcmp(elemPtr1->collationKey.strValuePtr, + elemPtr2->collationKey.strValuePtr); + } else if (infoPtr->sortMode == SORTMODE_ASCII_NC) { + order = TclUtfCasecmp(elemPtr1->collationKey.strValuePtr, + elemPtr2->collationKey.strValuePtr); + } else if (infoPtr->sortMode == SORTMODE_DICTIONARY) { + order = DictionaryCompare(elemPtr1->collationKey.strValuePtr, + elemPtr2->collationKey.strValuePtr); + } else if (infoPtr->sortMode == SORTMODE_INTEGER) { + Tcl_WideInt a, b; + + a = elemPtr1->collationKey.wideValue; + b = elemPtr2->collationKey.wideValue; + order = ((a >= b) - (a <= b)); + } else if (infoPtr->sortMode == SORTMODE_REAL) { + double a, b; + + a = elemPtr1->collationKey.doubleValue; + b = elemPtr2->collationKey.doubleValue; + order = ((a >= b) - (a <= b)); + } else { + Tcl_Obj **objv, *paramObjv[2]; + int objc; + Tcl_Obj *objPtr1, *objPtr2; + + if (infoPtr->resultCode != TCL_OK) { + /* + * Once an error has occurred, skip any future comparisons so as + * to preserve the error message in sortInterp->result. + */ + + return 0; + } + + + objPtr1 = elemPtr1->collationKey.objValuePtr; + objPtr2 = elemPtr2->collationKey.objValuePtr; + + paramObjv[0] = objPtr1; + paramObjv[1] = objPtr2; + + /* + * We made space in the command list for the two things to compare. + * Replace them and evaluate the result. + */ + + TclListObjLength(infoPtr->interp, infoPtr->compareCmdPtr, &objc); + Tcl_ListObjReplace(infoPtr->interp, infoPtr->compareCmdPtr, objc - 2, + 2, 2, paramObjv); + TclListObjGetElements(infoPtr->interp, infoPtr->compareCmdPtr, + &objc, &objv); + + infoPtr->resultCode = Tcl_EvalObjv(infoPtr->interp, objc, objv, 0); + + if (infoPtr->resultCode != TCL_OK) { + Tcl_AddErrorInfo(infoPtr->interp, "\n (-compare command)"); + return 0; + } + + /* + * Parse the result of the command. + */ + + if (TclGetIntFromObj(infoPtr->interp, + Tcl_GetObjResult(infoPtr->interp), &order) != TCL_OK) { + Tcl_SetObjResult(infoPtr->interp, Tcl_NewStringObj( + "-compare command returned non-integer result", -1)); + Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT", + "COMPARISONFAILED", NULL); + infoPtr->resultCode = TCL_ERROR; + return 0; + } + } + if (!infoPtr->isIncreasing) { + order = -order; + } + return order; +} + +/* + *---------------------------------------------------------------------- + * + * DictionaryCompare + * + * This function compares two strings as if they were being used in an + * index or card catalog. The case of alphabetic characters is ignored, + * except to break ties. Thus "B" comes before "b" but after "a". Also, + * integers embedded in the strings compare in numerical order. In other + * words, "x10y" comes after "x9y", not * before it as it would when + * using strcmp(). + * + * Results: + * A negative result means that the first element comes before the + * second, and a positive result means that the second element should + * come first. A result of zero means the two elements are equal and it + * doesn't matter which comes first. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +DictionaryCompare( + const char *left, const char *right) /* The strings to compare. */ +{ + Tcl_UniChar uniLeft, uniRight, uniLeftLower, uniRightLower; + int diff, zeros; + int secondaryDiff = 0; + + while (1) { + if (isdigit(UCHAR(*right)) /* INTL: digit */ + && isdigit(UCHAR(*left))) { /* INTL: digit */ + /* + * There are decimal numbers embedded in the two strings. Compare + * them as numbers, rather than strings. If one number has more + * leading zeros than the other, the number with more leading + * zeros sorts later, but only as a secondary choice. + */ + + zeros = 0; + while ((*right == '0') && isdigit(UCHAR(right[1]))) { + right++; + zeros--; + } + while ((*left == '0') && isdigit(UCHAR(left[1]))) { + left++; + zeros++; + } + if (secondaryDiff == 0) { + secondaryDiff = zeros; + } + + /* + * The code below compares the numbers in the two strings without + * ever converting them to integers. It does this by first + * comparing the lengths of the numbers and then comparing the + * digit values. + */ + + diff = 0; + while (1) { + if (diff == 0) { + diff = UCHAR(*left) - UCHAR(*right); + } + right++; + left++; + if (!isdigit(UCHAR(*right))) { /* INTL: digit */ + if (isdigit(UCHAR(*left))) { /* INTL: digit */ + return 1; + } else { + /* + * The two numbers have the same length. See if their + * values are different. + */ + + if (diff != 0) { + return diff; + } + break; + } + } else if (!isdigit(UCHAR(*left))) { /* INTL: digit */ + return -1; + } + } + continue; + } + + /* + * Convert character to Unicode for comparison purposes. If either + * string is at the terminating null, do a byte-wise comparison and + * bail out immediately. + */ + + if ((*left != '\0') && (*right != '\0')) { + left += Tcl_UtfToUniChar(left, &uniLeft); + right += Tcl_UtfToUniChar(right, &uniRight); + + /* + * Convert both chars to lower for the comparison, because + * dictionary sorts are case insensitve. Covert to lower, not + * upper, so chars between Z and a will sort before A (where most + * other interesting punctuations occur). + */ + + uniLeftLower = Tcl_UniCharToLower(uniLeft); + uniRightLower = Tcl_UniCharToLower(uniRight); + } else { + diff = UCHAR(*left) - UCHAR(*right); + break; + } + + diff = uniLeftLower - uniRightLower; + if (diff) { + return diff; + } + if (secondaryDiff == 0) { + if (Tcl_UniCharIsUpper(uniLeft) && Tcl_UniCharIsLower(uniRight)) { + secondaryDiff = -1; + } else if (Tcl_UniCharIsUpper(uniRight) + && Tcl_UniCharIsLower(uniLeft)) { + secondaryDiff = 1; + } + } + } + if (diff == 0) { + diff = secondaryDiff; + } + 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( + Tcl_Obj *objPtr, /* Obj to select sublist from. */ + SortInfo *infoPtr) /* Information passed from the top-level + * "lsearch" or "lsort" command. */ +{ + int i; + + /* + * Quick check for case when no "-index" option is there. + */ + + if (infoPtr->indexc == 0) { + return objPtr; + } + + /* + * Iterate over the indices, traversing through the nested sublists as we + * go. + */ + + for (i=0 ; i<infoPtr->indexc ; i++) { + int listLen, index; + Tcl_Obj *currentObj; + + if (TclListObjLength(infoPtr->interp, objPtr, &listLen) != TCL_OK) { + infoPtr->resultCode = TCL_ERROR; + return NULL; + } + index = infoPtr->indexv[i]; + + /* + * Adjust for end-based indexing. + */ + + if (index < SORTIDX_NONE) { + index += listLen + 1; + } + + if (Tcl_ListObjIndex(infoPtr->interp, objPtr, index, + ¤tObj) != TCL_OK) { + infoPtr->resultCode = TCL_ERROR; + return NULL; + } + if (currentObj == NULL) { + Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf( + "element %d missing from sublist \"%s\"", + index, TclGetString(objPtr))); + Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT", + "INDEXFAILED", NULL); + infoPtr->resultCode = TCL_ERROR; + return NULL; + } + objPtr = currentObj; + } + return objPtr; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * tab-width: 8 + * End: + */ |