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, 0 insertions, 4533 deletions
diff --git a/tcl8.6/generic/tclCmdIL.c b/tcl8.6/generic/tclCmdIL.c
deleted file mode 100644
index 0a1b4fe..0000000
--- a/tcl8.6/generic/tclCmdIL.c
+++ /dev/null
@@ -1,4533 +0,0 @@
-/*
- * 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:
- */