summaryrefslogtreecommitdiffstats
path: root/tcl8.6/generic/tclCmdIL.c
diff options
context:
space:
mode:
Diffstat (limited to 'tcl8.6/generic/tclCmdIL.c')
-rw-r--r--tcl8.6/generic/tclCmdIL.c4533
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,
+ &currentObj) != 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:
+ */