diff options
Diffstat (limited to 'generic/tclCmdIL.c')
| -rw-r--r-- | generic/tclCmdIL.c | 5117 |
1 files changed, 2464 insertions, 2653 deletions
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index b312026..21dbdc8 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -1,83 +1,62 @@ -/* +/* * 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). + * 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. + * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. + * 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 "tclPort.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. + * 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; - long intValue; - 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. */ + Tcl_Obj *objPtr; /* Object being sorted. */ + int count; /* number of same elements in list */ + 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. + * 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. */ + 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 index; /* If the -index option was specified, this + * holds the index of the list element + * to extract for comparison. If -index + * wasn't specified, this is -1. */ + Tcl_Interp *interp; /* The interpreter in which the sortis + * 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; /* @@ -85,120 +64,115 @@ typedef struct SortInfo { * 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 +#define SORTMODE_ASCII 0 +#define SORTMODE_INTEGER 1 +#define SORTMODE_REAL 2 +#define SORTMODE_COMMAND 3 +#define SORTMODE_DICTIONARY 4 /* - * Magic values for the index field of the SortInfo structure. Note that the - * index "end-1" will be translated to SORTIDX_END-1, etc. + * 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. */ +#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 int IfConditionCallback(ClientData data[], - Tcl_Interp *interp, int result); -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[]); +static void AppendLocals _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *listPtr, CONST char *pattern, + int includeLinks)); +static int DictionaryCompare _ANSI_ARGS_((char *left, + char *right)); +static int InfoArgsCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int InfoBodyCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int InfoCmdCountCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int InfoCommandsCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int InfoCompleteCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int InfoDefaultCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int InfoExistsCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +#ifdef TCL_TIP280 /* 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, +static int InfoFrameCmd _ANSI_ARGS_((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, NULL, NULL, NULL, 0}, - {"body", InfoBodyCmd, NULL, NULL, NULL, 0}, - {"cmdcount", InfoCmdCountCmd, NULL, NULL, NULL, 0}, - {"commands", InfoCommandsCmd, NULL, NULL, NULL, 0}, - {"complete", InfoCompleteCmd, NULL, NULL, NULL, 0}, - {"coroutine", TclInfoCoroutineCmd, NULL, NULL, NULL, 0}, - {"default", InfoDefaultCmd, NULL, NULL, NULL, 0}, - {"errorstack", InfoErrorStackCmd, NULL, NULL, NULL, 0}, - {"exists", TclInfoExistsCmd, TclCompileInfoExistsCmd, NULL, NULL, 0}, - {"frame", InfoFrameCmd, NULL, NULL, NULL, 0}, - {"functions", InfoFunctionsCmd, NULL, NULL, NULL, 0}, - {"globals", TclInfoGlobalsCmd, NULL, NULL, NULL, 0}, - {"hostname", InfoHostnameCmd, NULL, NULL, NULL, 0}, - {"level", InfoLevelCmd, NULL, NULL, NULL, 0}, - {"library", InfoLibraryCmd, NULL, NULL, NULL, 0}, - {"loaded", InfoLoadedCmd, NULL, NULL, NULL, 0}, - {"locals", TclInfoLocalsCmd, NULL, NULL, NULL, 0}, - {"nameofexecutable", InfoNameOfExecutableCmd, NULL, NULL, NULL, 0}, - {"patchlevel", InfoPatchLevelCmd, NULL, NULL, NULL, 0}, - {"procs", InfoProcsCmd, NULL, NULL, NULL, 0}, - {"script", InfoScriptCmd, NULL, NULL, NULL, 0}, - {"sharedlibextension", InfoSharedlibCmd, NULL, NULL, NULL, 0}, - {"tclversion", InfoTclVersionCmd, NULL, NULL, NULL, 0}, - {"vars", TclInfoVarsCmd, NULL, NULL, NULL, 0}, - {NULL, NULL, NULL, NULL, NULL, 0} -}; + Tcl_Obj *CONST objv[])); +#endif +static int InfoFunctionsCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int InfoGlobalsCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int InfoHostnameCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int InfoLevelCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int InfoLibraryCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int InfoLoadedCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int InfoLocalsCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int InfoNameOfExecutableCmd _ANSI_ARGS_(( + ClientData dummy, Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int InfoPatchLevelCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int InfoProcsCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int InfoScriptCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int InfoSharedlibCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int InfoTclVersionCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int InfoVarsCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static SortElement * MergeSort _ANSI_ARGS_((SortElement *headPt, + SortInfo *infoPtr)); +static SortElement * MergeLists _ANSI_ARGS_((SortElement *leftPtr, + SortElement *rightPtr, SortInfo *infoPtr)); +static int SortCompare _ANSI_ARGS_((Tcl_Obj *firstPtr, + Tcl_Obj *second, SortInfo *infoPtr)); /* *---------------------------------------------------------------------- * * Tcl_IfObjCmd -- * - * This procedure is invoked to process the "if" Tcl command. See the - * user documentation for details on what it does. + * 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}" + * 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. @@ -209,74 +183,51 @@ static const EnsembleImplMap defaultInfoMap[] = { *---------------------------------------------------------------------- */ + /* ARGSUSED */ 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_AppendResult(interp, "wrong # args: no expression after \"", - TclGetString(objv[0]), "\" argument", NULL); - 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) +Tcl_IfObjCmd(dummy, interp, objc, objv) + 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 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); - + int thenScriptIndex = 0; /* then script to be evaled after syntax check */ +#ifdef TCL_TIP280 + Interp* iPtr = (Interp*) interp; +#endif + int i, result, value; + char *clause; + i = 1; while (1) { + /* + * 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) { + clause = Tcl_GetString(objv[i-1]); + Tcl_AppendResult(interp, "wrong # args: no expression after \"", + clause, "\" argument", (char *) NULL); + return TCL_ERROR; + } + if (!thenScriptIndex) { + result = Tcl_ExprBooleanObj(interp, objv[i], &value); + if (result != TCL_OK) { + return result; + } + } i++; if (i >= objc) { - goto missingScript; + missingScript: + clause = Tcl_GetString(objv[i-1]); + Tcl_AppendResult(interp, "wrong # args: no script following \"", + clause, "\" argument", (char *) NULL); + return TCL_ERROR; } - clause = TclGetString(objv[i]); + clause = Tcl_GetString(objv[i]); if ((i < objc) && (strcmp(clause, "then") == 0)) { i++; } @@ -287,85 +238,68 @@ IfConditionCallback( thenScriptIndex = i; value = 0; } - + /* - * The expression evaluated to false. Skip the command, then see if - * there is an "else" or "elseif" clause. + * 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); +#ifndef TCL_TIP280 + return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0); +#else + /* TIP #280. Make invoking context available to branch */ + return TclEvalObjEx(interp, objv[thenScriptIndex], 0, + iPtr->cmdFramePtr,thenScriptIndex); +#endif } 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_AppendResult(interp, "wrong # args: ", - "no expression after \"", clause, "\" argument", NULL); - 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); + clause = Tcl_GetString(objv[i]); + if ((clause[0] == 'e') && (strcmp(clause, "elseif") == 0)) { + i++; + continue; } + break; } /* - * 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. + * 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; + Tcl_AppendResult(interp, + "wrong # args: no script following \"else\" argument", + (char *) NULL); + return TCL_ERROR; } } if (i < objc - 1) { - Tcl_AppendResult(interp, "wrong # args: ", - "extra words after \"else\" clause in \"if\" command", NULL); - Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); + Tcl_AppendResult(interp, + "wrong # args: extra words after \"else\" clause in \"if\" command", + (char *) NULL); return TCL_ERROR; } if (thenScriptIndex) { - /* - * TIP #280. Make invoking context available to branch/else. - */ - - return TclNREvalObjEx(interp, objv[thenScriptIndex], 0, - iPtr->cmdFramePtr, thenScriptIndex); +#ifndef TCL_TIP280 + return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0); +#else + /* TIP #280. Make invoking context available to branch/else */ + return TclEvalObjEx(interp, objv[thenScriptIndex], 0, + iPtr->cmdFramePtr,thenScriptIndex); +#endif } - return TclNREvalObjEx(interp, objv[i], 0, iPtr->cmdFramePtr, i); - - missingScript: - clause = TclGetString(objv[i-1]); - Tcl_AppendResult(interp, "wrong # args: no script following \"", clause, - "\" argument", NULL); - Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); - return TCL_ERROR; +#ifndef TCL_TIP280 + return Tcl_EvalObjEx(interp, objv[i], 0); +#else + return TclEvalObjEx(interp, objv[i], 0, iPtr->cmdFramePtr,i); +#endif } /* @@ -373,12 +307,12 @@ IfConditionCallback( * * Tcl_IncrObjCmd -- * - * This procedure is invoked to process the "incr" Tcl command. See the - * user documentation for details on what it does. + * 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" + * 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. @@ -389,30 +323,64 @@ IfConditionCallback( *---------------------------------------------------------------------- */ + /* ARGSUSED */ int -Tcl_IncrObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +Tcl_IncrObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - Tcl_Obj *newValuePtr, *incrPtr; - + long incrAmount; + Tcl_Obj *newValuePtr; + if ((objc != 2) && (objc != 3)) { - Tcl_WrongNumArgs(interp, 1, objv, "varName ?increment?"); + Tcl_WrongNumArgs(interp, 1, objv, "varName ?increment?"); return TCL_ERROR; } - if (objc == 3) { - incrPtr = objv[2]; + /* + * Calculate the amount to increment by. + */ + + if (objc == 2) { + incrAmount = 1; } else { - incrPtr = Tcl_NewIntObj(1); + if (Tcl_GetLongFromObj(interp, objv[2], &incrAmount) != TCL_OK) { + Tcl_AddErrorInfo(interp, "\n (reading increment)"); + return TCL_ERROR; + } + /* + * Need to be a bit cautious to ensure that [expr]-like rules + * are enforced for interpretation of wide integers, despite + * the fact that the underlying API itself is a 'long' only one. + */ + if (objv[2]->typePtr == &tclIntType) { + incrAmount = objv[2]->internalRep.longValue; + } else if (objv[2]->typePtr == &tclWideIntType) { + TclGetLongFromWide(incrAmount,objv[2]); + } else { + Tcl_WideInt wide; + + if (Tcl_GetWideIntFromObj(interp, objv[2], &wide) != TCL_OK) { + Tcl_AddErrorInfo(interp, "\n (reading increment)"); + return TCL_ERROR; + } + incrAmount = Tcl_WideAsLong(wide); + if ((wide <= Tcl_LongAsWide(LONG_MAX)) + && (wide >= Tcl_LongAsWide(LONG_MIN))) { + objv[2]->typePtr = &tclIntType; + objv[2]->internalRep.longValue = incrAmount; + } + } } - Tcl_IncrRefCount(incrPtr); - newValuePtr = TclIncrObjVar2(interp, objv[1], NULL, - incrPtr, TCL_LEAVE_ERR_MSG); - Tcl_DecrRefCount(incrPtr); + + /* + * Increment the variable's value. + */ + newValuePtr = TclIncrVar2(interp, objv[1], (Tcl_Obj *) NULL, incrAmount, + TCL_LEAVE_ERR_MSG); if (newValuePtr == NULL) { return TCL_ERROR; } @@ -423,31 +391,141 @@ Tcl_IncrObjCmd( */ Tcl_SetObjResult(interp, newValuePtr); - return TCL_OK; + return TCL_OK; } /* *---------------------------------------------------------------------- * - * TclInitInfoCmd -- + * Tcl_InfoObjCmd -- * - * This function is called to create the "info" Tcl command. See the user - * documentation for details on what it does. + * This procedure is invoked to process the "info" Tcl command. + * See the user documentation for details on what it does. * * Results: - * Handle for the info command, or NULL on failure. + * A standard Tcl result. * * Side effects: - * none + * See the user documentation. * *---------------------------------------------------------------------- */ -Tcl_Command -TclInitInfoCmd( - Tcl_Interp *interp) /* Current interpreter. */ + /* ARGSUSED */ +int +Tcl_InfoObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Arbitrary value passed to the command. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - return TclMakeEnsemble(interp, "info", defaultInfoMap); + static CONST char *subCmds[] = { + "args", "body", "cmdcount", "commands", + "complete", "default", "exists", +#ifdef TCL_TIP280 + "frame", +#endif + "functions", + "globals", "hostname", "level", "library", "loaded", + "locals", "nameofexecutable", "patchlevel", "procs", + "script", "sharedlibextension", "tclversion", "vars", + (char *) NULL}; + enum ISubCmdIdx { + IArgsIdx, IBodyIdx, ICmdCountIdx, ICommandsIdx, + ICompleteIdx, IDefaultIdx, IExistsIdx, +#ifdef TCL_TIP280 + IFrameIdx, +#endif + IFunctionsIdx, + IGlobalsIdx, IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx, + ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx, + IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx + }; + int index, result; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); + return TCL_ERROR; + } + + result = Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", 0, + (int *) &index); + if (result != TCL_OK) { + return result; + } + + switch (index) { + case IArgsIdx: + result = InfoArgsCmd(clientData, interp, objc, objv); + break; + case IBodyIdx: + result = InfoBodyCmd(clientData, interp, objc, objv); + break; + case ICmdCountIdx: + result = InfoCmdCountCmd(clientData, interp, objc, objv); + break; + case ICommandsIdx: + result = InfoCommandsCmd(clientData, interp, objc, objv); + break; + case ICompleteIdx: + result = InfoCompleteCmd(clientData, interp, objc, objv); + break; + case IDefaultIdx: + result = InfoDefaultCmd(clientData, interp, objc, objv); + break; + case IExistsIdx: + result = InfoExistsCmd(clientData, interp, objc, objv); + break; +#ifdef TCL_TIP280 + case IFrameIdx: + /* TIP #280 - New method 'frame' */ + result = InfoFrameCmd(clientData, interp, objc, objv); + break; +#endif + case IFunctionsIdx: + result = InfoFunctionsCmd(clientData, interp, objc, objv); + break; + case IGlobalsIdx: + result = InfoGlobalsCmd(clientData, interp, objc, objv); + break; + case IHostnameIdx: + result = InfoHostnameCmd(clientData, interp, objc, objv); + break; + case ILevelIdx: + result = InfoLevelCmd(clientData, interp, objc, objv); + break; + case ILibraryIdx: + result = InfoLibraryCmd(clientData, interp, objc, objv); + break; + case ILoadedIdx: + result = InfoLoadedCmd(clientData, interp, objc, objv); + break; + case ILocalsIdx: + result = InfoLocalsCmd(clientData, interp, objc, objv); + break; + case INameOfExecutableIdx: + result = InfoNameOfExecutableCmd(clientData, interp, objc, objv); + break; + case IPatchLevelIdx: + result = InfoPatchLevelCmd(clientData, interp, objc, objv); + break; + case IProcsIdx: + result = InfoProcsCmd(clientData, interp, objc, objv); + break; + case IScriptIdx: + result = InfoScriptCmd(clientData, interp, objc, objv); + break; + case ISharedLibExtensionIdx: + result = InfoSharedlibCmd(clientData, interp, objc, objv); + break; + case ITclVersionIdx: + result = InfoTclVersionCmd(clientData, interp, objc, objv); + break; + case IVarsIdx: + result = InfoVarsCmd(clientData, interp, objc, objv); + break; + } + return result; } /* @@ -455,58 +533,58 @@ TclInitInfoCmd( * * InfoArgsCmd -- * - * Called to implement the "info args" command that returns the argument - * list for a procedure. Handles the following syntax: + * Called to implement the "info args" command that returns the + * argument list for a procedure. Handles the following syntax: * - * info args procName + * info args procName * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * 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. + * 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. */ +InfoArgsCmd(dummy, interp, objc, objv) + 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; + char *name; Proc *procPtr; CompiledLocal *localPtr; Tcl_Obj *listObjPtr; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "procname"); - return TCL_ERROR; + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "procname"); + return TCL_ERROR; } - name = TclGetString(objv[1]); + name = Tcl_GetString(objv[2]); procPtr = TclFindProc(iPtr, name); if (procPtr == NULL) { - Tcl_AppendResult(interp, "\"", name, "\" isn't a procedure", NULL); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", name, NULL); - return TCL_ERROR; + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\"", name, "\" isn't a procedure", (char *) NULL); + return TCL_ERROR; } /* * Build a return list containing the arguments. */ - - listObjPtr = Tcl_NewListObj(0, NULL); + + listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; - localPtr = localPtr->nextPtr) { - if (TclIsVarArgument(localPtr)) { - Tcl_ListObjAppendElement(interp, listObjPtr, + localPtr = localPtr->nextPtr) { + if (TclIsVarArgument(localPtr)) { + Tcl_ListObjAppendElement(interp, listObjPtr, Tcl_NewStringObj(localPtr->name, -1)); - } + } } Tcl_SetObjResult(interp, listObjPtr); return TCL_OK; @@ -517,66 +595,65 @@ InfoArgsCmd( * * InfoBodyCmd -- * - * Called to implement the "info body" command that returns the body for - * a procedure. Handles the following syntax: + * Called to implement the "info body" command that returns the body + * for a procedure. Handles the following syntax: * - * info body procName + * info body procName * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * 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. + * 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. */ +InfoBodyCmd(dummy, interp, objc, objv) + 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; + char *name; Proc *procPtr; Tcl_Obj *bodyPtr, *resultPtr; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "procname"); - return TCL_ERROR; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "procname"); + return TCL_ERROR; } - name = TclGetString(objv[1]); + name = Tcl_GetString(objv[2]); procPtr = TclFindProc(iPtr, name); if (procPtr == NULL) { - Tcl_AppendResult(interp, "\"", name, "\" isn't a procedure", NULL); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", name, NULL); - return TCL_ERROR; + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\"", name, "\" isn't a procedure", (char *) 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. + * 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] + * The string rep might not be valid if the procedure has + * never been run before. [Bug #545644] */ - - TclGetString(bodyPtr); + (void) Tcl_GetString(bodyPtr); } resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length); - + Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } @@ -586,37 +663,37 @@ InfoBodyCmd( * * InfoCmdCountCmd -- * - * Called to implement the "info cmdcount" command that returns the - * number of commands that have been executed. Handles the following - * syntax: + * Called to implement the "info cmdcount" command that returns the + * number of commands that have been executed. Handles the following + * syntax: * - * info cmdcount + * info cmdcount * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * 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. + * 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. */ +InfoCmdCountCmd(dummy, interp, objc, objv) + 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; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewIntObj(iPtr->cmdCount)); + Tcl_SetIntObj(Tcl_GetObjResult(interp), iPtr->cmdCount); return TCL_OK; } @@ -625,74 +702,74 @@ InfoCmdCountCmd( * * 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: + * 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? + * info commands ?pattern? * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * 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. + * 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. */ +InfoCommandsCmd(dummy, interp, objc, objv) + 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; + 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); + Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); Tcl_Obj *listPtr, *elemObjPtr; - int specificNsInPattern = 0;/* Init. to avoid compiler warning. */ + 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. + * Get the pattern and find the "effective namespace" in which to + * list commands. */ - if (objc == 1) { - simplePattern = NULL; + if (objc == 2) { + simplePattern = NULL; nsPtr = currNsPtr; specificNsInPattern = 0; - } else if (objc == 2) { + } else if (objc == 3) { /* * 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. + * 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); + pattern = Tcl_GetString(objv[2]); + TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, + /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern); - if (nsPtr != NULL) { /* We successfully found the pattern's ns. */ + 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; + Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + return TCL_ERROR; } /* @@ -704,24 +781,24 @@ InfoCommandsCmd( } /* - * 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. + * 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); + listPtr = Tcl_NewListObj(0, (Tcl_Obj **) 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. + * 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); + cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); elemObjPtr = Tcl_NewObj(); Tcl_GetCommandFullName(interp, cmd, elemObjPtr); } else { @@ -729,50 +806,23 @@ InfoCommandsCmd( 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); - } + } else if ((nsPtr != globalNsPtr) && !specificNsInPattern) { + entryPtr = Tcl_FindHashEntry(&globalNsPtr->cmdTable, + simplePattern); if (entryPtr != NULL) { - cmdName = Tcl_GetHashKey(tablePtr, entryPtr); + cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, 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. - */ - + } else { entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); while (entryPtr != NULL) { cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); if ((simplePattern == NULL) - || Tcl_StringMatch(cmdName, simplePattern)) { + || Tcl_StringMatch(cmdName, simplePattern)) { if (specificNsInPattern) { - cmd = Tcl_GetHashValue(entryPtr); + cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); elemObjPtr = Tcl_NewObj(); Tcl_GetCommandFullName(interp, cmd, elemObjPtr); } else { @@ -785,19 +835,19 @@ InfoCommandsCmd( /* * 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. + * 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_StringMatch(cmdName, simplePattern)) { + if (Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(cmdName, -1)); } @@ -805,97 +855,8 @@ InfoCommandsCmd( 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; } @@ -905,36 +866,40 @@ InfoCommandsCmd( * * InfoCompleteCmd -- * - * Called to implement the "info complete" command that determines - * whether a string is a complete Tcl command. Handles the following - * syntax: + * Called to implement the "info complete" command that determines + * whether a string is a complete Tcl command. Handles the following + * syntax: * - * info complete command + * info complete command * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * 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. + * 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. */ +InfoCompleteCmd(dummy, interp, objc, objv) + 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; + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "command"); + return TCL_ERROR; + } + + if (TclObjCommandComplete(objv[2])) { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); + } else { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj( - TclObjCommandComplete(objv[1]))); return TCL_OK; } @@ -943,559 +908,513 @@ InfoCompleteCmd( * * InfoDefaultCmd -- * - * Called to implement the "info default" command that returns the - * default value for a procedure argument. Handles the following syntax: + * 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 + * info default procName arg varName * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * 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. + * 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. */ +InfoDefaultCmd(dummy, interp, objc, objv) + 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; + char *procName, *argName, *varName; Proc *procPtr; CompiledLocal *localPtr; Tcl_Obj *valueObjPtr; - if (objc != 4) { - Tcl_WrongNumArgs(interp, 1, objv, "procname arg varname"); - return TCL_ERROR; + if (objc != 5) { + Tcl_WrongNumArgs(interp, 2, objv, "procname arg varname"); + return TCL_ERROR; } - procName = TclGetString(objv[1]); - argName = TclGetString(objv[2]); + procName = Tcl_GetString(objv[2]); + argName = Tcl_GetString(objv[3]); procPtr = TclFindProc(iPtr, procName); if (procPtr == NULL) { - Tcl_AppendResult(interp, "\"", procName, "\" isn't a procedure",NULL); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", procName, - NULL); - return TCL_ERROR; + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\"", procName, "\" isn't a procedure", (char *) NULL); + return TCL_ERROR; } for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; - localPtr = localPtr->nextPtr) { - if (TclIsVarArgument(localPtr) + 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; - } + if (localPtr->defValuePtr != NULL) { + valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL, + localPtr->defValuePtr, 0); + if (valueObjPtr == NULL) { + defStoreError: + varName = Tcl_GetString(objv[4]); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "couldn't store default value in variable \"", + varName, "\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); + } else { + Tcl_Obj *nullObjPtr = Tcl_NewObj(); + Tcl_IncrRefCount(nullObjPtr); + valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL, + nullObjPtr, 0); + Tcl_DecrRefCount(nullObjPtr); /* free unneeded obj */ + if (valueObjPtr == NULL) { + goto defStoreError; + } + Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); + } + return TCL_OK; + } } - Tcl_AppendResult(interp, "procedure \"", procName, - "\" doesn't have an argument \"", argName, "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARGUMENT", argName, NULL); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "procedure \"", procName, "\" doesn't have an argument \"", + argName, "\"", (char *) NULL); return TCL_ERROR; } /* *---------------------------------------------------------------------- * - * InfoErrorStackCmd -- + * InfoExistsCmd -- * - * Called to implement the "info errorstack" command that returns information - * about the last error's call stack. Handles the following syntax: + * Called to implement the "info exists" command that determines + * whether a variable exists. Handles the following syntax: * - * info errorstack ?interp? + * info exists varName * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * 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. + * 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. */ +InfoExistsCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - const char *varName; + char *varName; Var *varPtr; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "varName"); - return TCL_ERROR; + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "varName"); + return TCL_ERROR; } - varName = TclGetString(objv[1]); + varName = Tcl_GetString(objv[2]); varPtr = TclVarTraceExists(interp, varName); - - Tcl_SetObjResult(interp, - Tcl_NewBooleanObj(varPtr && varPtr->value.objPtr)); + if ((varPtr != NULL) && !TclIsVarUndefined(varPtr)) { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); + } else { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); + } return TCL_OK; } +#ifdef TCL_TIP280 /* *---------------------------------------------------------------------- * * 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: + * 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? + * info frame ?number? * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * 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. + * 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. */ +InfoFrameCmd(dummy, interp, objc, objv) + 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, topLevel, code = TCL_OK; - CmdFrame *runPtr, *framePtr; - CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; - if (objc > 2) { - Tcl_WrongNumArgs(interp, 1, objv, "?number?"); - return TCL_ERROR; - } + if (objc == 2) { + /* just "info frame" */ + int levels = (iPtr->cmdFramePtr == NULL + ? 0 + : iPtr->cmdFramePtr->level); - topLevel = ((iPtr->cmdFramePtr == NULL) - ? 0 - : iPtr->cmdFramePtr->level); + Tcl_SetObjResult(interp, Tcl_NewIntObj (levels)); + return TCL_OK; - if (corPtr) { - /* - * A coroutine: must fix the level computations AND the cmdFrame chain, - * which is interrupted at the base. - */ - CmdFrame *lastPtr = NULL; + } else if (objc == 3) { + /* "info frame level" */ + int level; + CmdFrame *framePtr; - runPtr = iPtr->cmdFramePtr; + if (Tcl_GetIntFromObj(interp, objv[2], &level) != TCL_OK) { + return TCL_ERROR; + } + if (level <= 0) { + /* Relative adressing */ + + if (iPtr->cmdFramePtr == NULL) { + levelError: + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad level \"", + Tcl_GetString(objv[2]), + "\"", (char *) NULL); + return TCL_ERROR; + } + /* Convert to absolute. */ + + level += iPtr->cmdFramePtr->level; + } + for (framePtr = iPtr->cmdFramePtr; + framePtr != NULL; + framePtr = framePtr->nextPtr) { - /* TODO - deal with overflow */ - topLevel += corPtr->caller.cmdFramePtr->level; - while (runPtr) { - runPtr->level += corPtr->caller.cmdFramePtr->level; - lastPtr = runPtr; - runPtr = runPtr->nextPtr; - } - if (lastPtr) { - lastPtr->nextPtr = corPtr->caller.cmdFramePtr; - } else { - iPtr->cmdFramePtr = corPtr->caller.cmdFramePtr; - } - } + if (framePtr->level == level) { + break; + } + } + if (framePtr == NULL) { + goto levelError; + } - if (objc == 1) { /* - * Just "info frame". + * Pull the information and construct the dictionary to return, as + * list. Regarding use of the CmdFrame fields see tclInt.h, and its + * definition. */ - 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; - } + { + Tcl_Obj* lv [20]; /* Keep uptodate when more keys are added to the dict */ + int lc = 0; - if ((level > topLevel) || (level <= - topLevel)) { - levelError: - Tcl_AppendResult(interp, "bad level \"", TclGetString(objv[1]), "\"", - NULL); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_FRAME", - 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: - if (corPtr) { - - if (iPtr->cmdFramePtr == corPtr->caller.cmdFramePtr) { - iPtr->cmdFramePtr = NULL; - } else { - runPtr = iPtr->cmdFramePtr; - while (runPtr->nextPtr != corPtr->caller.cmdFramePtr) { - runPtr->level -= corPtr->caller.cmdFramePtr->level; - runPtr = runPtr->nextPtr; - } - runPtr->level = 1; - runPtr->nextPtr = NULL; - } - - } - return code; -} - -/* - *---------------------------------------------------------------------- - * - * TclInfoFrame -- - * - * Core of InfoFrameCmd, returns TIP280 dict for a given frame. - * - * Results: - * Returns TIP280 dict. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ + /* This array is indexed by the TCL_LOCATION_... values, except + * for _LAST. + */ -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; + static CONST char* typeString [TCL_LOCATION_LAST] = { + "eval", "eval", "eval", "precompiled", "source", "proc" + }; - /* - * Pull the information and construct the dictionary to return, as list. - * Regarding use of the CmdFrame fields see tclInt.h, and its definition. - */ + Proc* procPtr = framePtr->framePtr ? framePtr->framePtr->procPtr : NULL; -#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. */ - switch (framePtr->type) { - case TCL_LOCATION_EVAL: - /* - * Evaluation, dynamic script. Type, line, cmd, the latter through - * str. - */ + lv [lc ++] = Tcl_NewStringObj ("type",-1); + lv [lc ++] = Tcl_NewStringObj (typeString [framePtr->type],-1); + lv [lc ++] = Tcl_NewStringObj ("line",-1); + lv [lc ++] = Tcl_NewIntObj (framePtr->line[0]); + lv [lc ++] = Tcl_NewStringObj ("cmd",-1); + lv [lc ++] = Tcl_NewStringObj (framePtr->cmd.str.cmd, + framePtr->cmd.str.len); + break; - ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1)); - ADD_PAIR("line", Tcl_NewIntObj(framePtr->line[0])); - ADD_PAIR("cmd", Tcl_NewStringObj(framePtr->cmd.str.cmd, - framePtr->cmd.str.len)); - break; + case TCL_LOCATION_EVAL_LIST: + /* List optimized evaluation. Type, line, cmd, the latter + * through listPtr, possibly a frame. */ - case TCL_LOCATION_EVAL_LIST: - /* - * List optimized evaluation. Type, line, cmd, the latter through - * listPtr, possibly a frame. - */ + lv [lc ++] = Tcl_NewStringObj ("type",-1); + lv [lc ++] = Tcl_NewStringObj (typeString [framePtr->type],-1); + lv [lc ++] = Tcl_NewStringObj ("line",-1); + lv [lc ++] = Tcl_NewIntObj (1); - ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1)); - ADD_PAIR("line", Tcl_NewIntObj(1)); + /* We put a duplicate of the command list obj into the result + * to ensure that the 'pure List'-property of the command + * itself is not destroyed. Otherwise the query here would + * disable the list optimization path in Tcl_EvalObjEx. + */ - /* - * We put a duplicate of the command list obj into the result to - * ensure that the 'pure List'-property of the command itself is not - * destroyed. Otherwise the query here would disable the list - * optimization path in Tcl_EvalObjEx. - */ + lv [lc ++] = Tcl_NewStringObj ("cmd",-1); + lv [lc ++] = Tcl_DuplicateObj (framePtr->cmd.listPtr); + break; - ADD_PAIR("cmd", Tcl_DuplicateObj(framePtr->cmd.listPtr)); - break; + case TCL_LOCATION_PREBC: + /* Precompiled. Result contains the type as signal, nothing + * else */ - case TCL_LOCATION_PREBC: - /* - * Precompiled. Result contains the type as signal, nothing else. - */ + lv [lc ++] = Tcl_NewStringObj ("type",-1); + lv [lc ++] = Tcl_NewStringObj (typeString [framePtr->type],-1); + break; - 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. */ - case TCL_LOCATION_BC: { - /* - * Execution of bytecode. Talk to the BC engine to fill out the frame. - */ + CmdFrame f = *framePtr; - CmdFrame *fPtr = TclStackAlloc(interp, sizeof(CmdFrame)); + /* Note: Type BC => f.data.eval.path is not used. + * f.data.tebc.codePtr is used instead. + */ - *fPtr = *framePtr; + TclGetSrcInfoForPc (&f); + /* Now filled: cmd.str.(cmd,len), line */ + /* Possibly modified: type, path! */ - /* - * Note: - * Type BC => f.data.eval.path is not used. - * f.data.tebc.codePtr is used instead. - */ + lv [lc ++] = Tcl_NewStringObj ("type",-1); + lv [lc ++] = Tcl_NewStringObj (typeString [f.type],-1); + lv [lc ++] = Tcl_NewStringObj ("line",-1); + lv [lc ++] = Tcl_NewIntObj (f.line[0]); - TclGetSrcInfoForPc(fPtr); + if (f.type == TCL_LOCATION_SOURCE) { + lv [lc ++] = Tcl_NewStringObj ("file",-1); + lv [lc ++] = f.data.eval.path; + /* Death of reference by TclGetSrcInfoForPc */ + Tcl_DecrRefCount (f.data.eval.path); + } - /* - * Now filled: cmd.str.(cmd,len), line - * Possibly modified: type, path! - */ + lv [lc ++] = Tcl_NewStringObj ("cmd",-1); + lv [lc ++] = Tcl_NewStringObj (f.cmd.str.cmd, f.cmd.str.len); + break; + } - ADD_PAIR("type", Tcl_NewStringObj(typeString[fPtr->type], -1)); - if (fPtr->line) { - ADD_PAIR("line", Tcl_NewIntObj(fPtr->line[0])); - } + case TCL_LOCATION_SOURCE: + /* Evaluation of a script file */ + + lv [lc ++] = Tcl_NewStringObj ("type",-1); + lv [lc ++] = Tcl_NewStringObj (typeString [framePtr->type],-1); + lv [lc ++] = Tcl_NewStringObj ("line",-1); + lv [lc ++] = Tcl_NewIntObj (framePtr->line[0]); + lv [lc ++] = Tcl_NewStringObj ("file",-1); + lv [lc ++] = framePtr->data.eval.path; + /* Refcount framePtr->data.eval.path goes up when lv + * is converted into the result list object. + */ + lv [lc ++] = Tcl_NewStringObj ("cmd",-1); + lv [lc ++] = Tcl_NewStringObj (framePtr->cmd.str.cmd, + framePtr->cmd.str.len); + break; - if (fPtr->type == TCL_LOCATION_SOURCE) { - ADD_PAIR("file", fPtr->data.eval.path); + case TCL_LOCATION_PROC: + Tcl_Panic ("TCL_LOCATION_PROC found in standard frame"); + break; + } /* - * Death of reference by TclGetSrcInfoForPc. + * 'proc'. Common to all frame types. Conditional on having an + * associated Procedure CallFrame. */ - Tcl_DecrRefCount(fPtr->data.eval.path); - } - - ADD_PAIR("cmd", - Tcl_NewStringObj(fPtr->cmd.str.cmd, fPtr->cmd.str.len)); - 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", Tcl_NewStringObj(framePtr->cmd.str.cmd, - framePtr->cmd.str.len)); - break; + if (procPtr != NULL) { + Tcl_HashEntry* namePtr = procPtr->cmdPtr->hPtr; + /* + * ITcl seems to provide us with weird, maybe bogus Command + * structures (methods?) which may have no HashEntry pointing + * to the name information, or a HashEntry without owning + * HashTable. Therefore check again that our data is valid. + */ + if (namePtr && namePtr->tablePtr) { + char* procName = Tcl_GetHashKey (namePtr->tablePtr, namePtr); + char* nsName = procPtr->cmdPtr->nsPtr->fullName; - case TCL_LOCATION_PROC: - Tcl_Panic("TCL_LOCATION_PROC found in standard frame"); - break; - } + lv [lc ++] = Tcl_NewStringObj ("proc",-1); + lv [lc ++] = Tcl_NewStringObj (nsName,-1); - /* - * 'proc'. Common to all frame types. Conditional on having an associated - * Procedure CallFrame. - */ + if (strcmp (nsName, "::") != 0) { + Tcl_AppendToObj (lv [lc-1], "::", -1); + } + Tcl_AppendToObj (lv [lc-1], procName, -1); + } + } - if (procPtr != NULL) { - Tcl_HashEntry *namePtr = procPtr->cmdPtr->hPtr; + /* 'level'. Common to all frame types. Conditional on having an + * associated _visible_ CallFrame */ - if (namePtr) { - Tcl_Obj *procNameObj; + if ((framePtr->framePtr != NULL) && (iPtr->varFramePtr != NULL)) { + CallFrame* current = framePtr->framePtr; + CallFrame* top = iPtr->varFramePtr; + CallFrame* idx; - /* - * This is a regular command. - */ + for (idx = top; + idx != NULL; + idx = idx->callerVarPtr) { + if (idx == current) { + int c = framePtr->framePtr->level; + int t = iPtr->varFramePtr->level; - 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; + lv [lc ++] = Tcl_NewStringObj ("level",-1); + lv [lc ++] = Tcl_NewIntObj (t - c); + break; + } } } + + Tcl_SetObjResult(interp, Tcl_NewListObj (lc, lv)); + return TCL_OK; } } - /* - * 'level'. Common to all frame types. Conditional on having an associated - * _visible_ CallFrame. - */ + Tcl_WrongNumArgs(interp, 2, objv, "?number?"); - if ((framePtr->framePtr != NULL) && (iPtr->varFramePtr != NULL)) { - CallFrame *current = framePtr->framePtr; - CallFrame *top = iPtr->varFramePtr; - CallFrame *idx; + return TCL_ERROR; +} +#endif + +/* + *---------------------------------------------------------------------- + * + * 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. + * + *---------------------------------------------------------------------- + */ - for (idx=top ; idx!=NULL ; idx=idx->callerVarPtr) { - if (idx == current) { - int c = framePtr->framePtr->level; - int t = iPtr->varFramePtr->level; +static int +InfoFunctionsCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + char *pattern; + Tcl_Obj *listPtr; - ADD_PAIR("level", Tcl_NewIntObj(t - c)); - break; - } - } + if (objc == 2) { + pattern = NULL; + } else if (objc == 3) { + pattern = Tcl_GetString(objv[2]); + } else { + Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + return TCL_ERROR; } - return Tcl_NewListObj(lc, lv); + listPtr = Tcl_ListMathFuncs(interp, pattern); + if (listPtr == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; } /* *---------------------------------------------------------------------- * - * InfoFunctionsCmd -- + * InfoGlobalsCmd -- * - * Called to implement the "info functions" command that returns the list - * of math functions matching an optional pattern. Handles the following - * syntax: + * Called to implement the "info globals" command that returns the list + * of global variables matching an optional pattern. Handles the + * following syntax: * - * info functions ?pattern? + * info globals ?pattern? * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * 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. + * 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. */ +InfoGlobalsCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - const char *pattern; + char *varName, *pattern; + Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); + register Tcl_HashEntry *entryPtr; + Tcl_HashSearch search; + Var *varPtr; + Tcl_Obj *listPtr; - if (objc == 1) { - pattern = NULL; - } else if (objc == 2) { - pattern = TclGetString(objv[1]); + if (objc == 2) { + pattern = NULL; + } else if (objc == 3) { + pattern = Tcl_GetString(objv[2]); + /* + * Strip leading global-namespace qualifiers. [Bug 1057461] + */ + if (pattern[0] == ':' && pattern[1] == ':') { + while (*pattern == ':') { + pattern++; + } + } } else { - Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_ListMathFuncs(interp, pattern)); + /* + * Scan through the global :: namespace's variable table and create a + * list of all global variables that match the pattern. + */ + + listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + if (pattern != NULL && TclMatchIsTrivial(pattern)) { + entryPtr = Tcl_FindHashEntry(&globalNsPtr->varTable, pattern); + if (entryPtr != NULL) { + varPtr = (Var *) Tcl_GetHashValue(entryPtr); + if (!TclIsVarUndefined(varPtr)) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(pattern, -1)); + } + } + } else { + for (entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search); + entryPtr != NULL; + entryPtr = Tcl_NextHashEntry(&search)) { + varPtr = (Var *) Tcl_GetHashValue(entryPtr); + if (TclIsVarUndefined(varPtr)) { + continue; + } + varName = Tcl_GetHashKey(&globalNsPtr->varTable, entryPtr); + if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(varName, -1)); + } + } + } + Tcl_SetObjResult(interp, listPtr); return TCL_OK; } @@ -1504,43 +1423,43 @@ InfoFunctionsCmd( * * InfoHostnameCmd -- * - * Called to implement the "info hostname" command that returns the host - * name. Handles the following syntax: + * Called to implement the "info hostname" command that returns the + * host name. Handles the following syntax: * - * info hostname + * info hostname * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * 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. + * 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. */ +InfoHostnameCmd(dummy, interp, objc, objv) + 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; + CONST char *name; + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; } name = Tcl_GetHostName(); if (name) { - Tcl_SetObjResult(interp, Tcl_NewStringObj(name, -1)); + Tcl_SetStringObj(Tcl_GetObjResult(interp), name, -1); return TCL_OK; + } else { + Tcl_SetStringObj(Tcl_GetObjResult(interp), + "unable to determine name of host", -1); + return TCL_ERROR; } - Tcl_SetResult(interp, "unable to determine name of host", TCL_STATIC); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "HOSTNAME", "UNKNOWN", NULL); - return TCL_ERROR; } /* @@ -1548,71 +1467,71 @@ InfoHostnameCmd( * * InfoLevelCmd -- * - * Called to implement the "info level" command that returns information - * about the call stack. Handles the following syntax: + * Called to implement the "info level" command that returns + * information about the call stack. Handles the following syntax: * - * info level ?number? + * info level ?number? * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * 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. + * 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. */ +InfoLevelCmd(dummy, interp, objc, objv) + 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; + CallFrame *framePtr; + Tcl_Obj *listPtr; - 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; - } + if (objc == 2) { /* just "info level" */ + if (iPtr->varFramePtr == NULL) { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); + } else { + Tcl_SetIntObj(Tcl_GetObjResult(interp), iPtr->varFramePtr->level); + } + return TCL_OK; + } else if (objc == 3) { + if (Tcl_GetIntFromObj(interp, objv[2], &level) != TCL_OK) { + return TCL_ERROR; + } + if (level <= 0) { + if (iPtr->varFramePtr == NULL) { + levelError: + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad level \"", + Tcl_GetString(objv[2]), + "\"", (char *) NULL); + return TCL_ERROR; + } + level += iPtr->varFramePtr->level; + } + for (framePtr = iPtr->varFramePtr; framePtr != NULL; + framePtr = framePtr->callerVarPtr) { + if (framePtr->level == level) { + break; + } + } + if (framePtr == NULL) { + goto levelError; + } - Tcl_SetObjResult(interp, - Tcl_NewListObj(framePtr->objc, framePtr->objv)); - return TCL_OK; + listPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv); + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; } - Tcl_WrongNumArgs(interp, 1, objv, "?number?"); - return TCL_ERROR; - - levelError: - Tcl_AppendResult(interp, "bad level \"", TclGetString(objv[1]), "\"", - NULL); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_LEVEL", - TclGetString(objv[1]), NULL); + Tcl_WrongNumArgs(interp, 2, objv, "?number?"); return TCL_ERROR; } @@ -1621,43 +1540,43 @@ InfoLevelCmd( * * InfoLibraryCmd -- * - * Called to implement the "info library" command that returns the - * library directory for the Tcl installation. Handles the following - * syntax: + * Called to implement the "info library" command that returns the + * library directory for the Tcl installation. Handles the following + * syntax: * - * info library + * info library * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * 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. + * 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. */ +InfoLibraryCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - const char *libDirName; + CONST char *libDirName; - if (objc != 1) { - Tcl_WrongNumArgs(interp, 1, objv, NULL); - return TCL_ERROR; + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, 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_SetStringObj(Tcl_GetObjResult(interp), libDirName, -1); + return TCL_OK; } - Tcl_SetResult(interp, "no library has been specified for Tcl",TCL_STATIC); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", "tcl_library",NULL); + Tcl_SetStringObj(Tcl_GetObjResult(interp), + "no library has been specified for Tcl", -1); return TCL_ERROR; } @@ -1666,42 +1585,174 @@ InfoLibraryCmd( * * InfoLoadedCmd -- * - * Called to implement the "info loaded" command that returns the - * packages that have been loaded into an interpreter. Handles the - * following syntax: + * 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? + * info loaded ?interp? * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * 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. + * 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. */ +InfoLoadedCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - const char *interpName; + char *interpName; + int result; - if ((objc != 1) && (objc != 2)) { - Tcl_WrongNumArgs(interp, 1, objv, "?interp?"); - return TCL_ERROR; + if ((objc != 2) && (objc != 3)) { + Tcl_WrongNumArgs(interp, 2, objv, "?interp?"); + return TCL_ERROR; } - if (objc == 1) { /* Get loaded pkgs in all interpreters. */ + if (objc == 2) { /* get loaded pkgs in all interpreters */ interpName = NULL; - } else { /* Get pkgs just in specified interp. */ - interpName = TclGetString(objv[1]); + } else { /* get pkgs just in specified interp */ + interpName = Tcl_GetString(objv[2]); + } + result = TclGetLoadedPackages(interp, interpName); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * InfoLocalsCmd -- + * + * Called to implement the "info locals" command to return a list of + * local variables that match an optional pattern. Handles the + * following syntax: + * + * info locals ?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 +InfoLocalsCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Interp *iPtr = (Interp *) interp; + char *pattern; + Tcl_Obj *listPtr; + + if (objc == 2) { + pattern = NULL; + } else if (objc == 3) { + pattern = Tcl_GetString(objv[2]); + } else { + Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + return TCL_ERROR; + } + + if (iPtr->varFramePtr == NULL || !iPtr->varFramePtr->isProcCallFrame) { + return TCL_OK; + } + + /* + * Return a list containing names of first the compiled locals (i.e. the + * ones stored in the call frame), then the variables in the local hash + * table (if one exists). + */ + + listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + AppendLocals(interp, listPtr, pattern, 0); + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * AppendLocals -- + * + * Append the local variables for the current frame to the + * specified list object. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +AppendLocals(interp, listPtr, pattern, includeLinks) + Tcl_Interp *interp; /* Current interpreter. */ + Tcl_Obj *listPtr; /* List object to append names to. */ + CONST char *pattern; /* Pattern to match against. */ + int includeLinks; /* 1 if upvars should be included, else 0. */ +{ + Interp *iPtr = (Interp *) interp; + CompiledLocal *localPtr; + Var *varPtr; + int i, localVarCt; + char *varName; + Tcl_HashTable *localVarTablePtr; + register Tcl_HashEntry *entryPtr; + Tcl_HashSearch search; + + localPtr = iPtr->varFramePtr->procPtr->firstLocalPtr; + localVarCt = iPtr->varFramePtr->numCompiledLocals; + varPtr = iPtr->varFramePtr->compiledLocals; + localVarTablePtr = iPtr->varFramePtr->varTablePtr; + + for (i = 0; i < localVarCt; i++) { + /* + * Skip nameless (temporary) variables and undefined variables + */ + + if (!TclIsVarTemporary(localPtr) && !TclIsVarUndefined(varPtr) + && (includeLinks || !TclIsVarLink(varPtr))) { + varName = varPtr->name; + if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(varName, -1)); + } + } + varPtr++; + localPtr = localPtr->nextPtr; + } + + if (localVarTablePtr != NULL) { + for (entryPtr = Tcl_FirstHashEntry(localVarTablePtr, &search); + entryPtr != NULL; + entryPtr = Tcl_NextHashEntry(&search)) { + varPtr = (Var *) Tcl_GetHashValue(entryPtr); + if (!TclIsVarUndefined(varPtr) + && (includeLinks || !TclIsVarLink(varPtr))) { + varName = Tcl_GetHashKey(localVarTablePtr, entryPtr); + if ((pattern == NULL) + || Tcl_StringMatch(varName, pattern)) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(varName, -1)); + } + } + } } - return TclGetLoadedPackages(interp, interpName); } /* @@ -1709,34 +1760,41 @@ InfoLoadedCmd( * * InfoNameOfExecutableCmd -- * - * Called to implement the "info nameofexecutable" command that returns - * the name of the binary file running this application. Handles the - * following syntax: + * Called to implement the "info nameofexecutable" command that returns + * the name of the binary file running this application. Handles the + * following syntax: * - * info nameofexecutable + * info nameofexecutable * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * 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. + * 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. */ +InfoNameOfExecutableCmd(dummy, interp, objc, objv) + 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; + CONST char *nameOfExecutable; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + + nameOfExecutable = Tcl_GetNameOfExecutable(); + + if (nameOfExecutable != NULL) { + Tcl_SetStringObj(Tcl_GetObjResult(interp), nameOfExecutable, -1); } - Tcl_SetObjResult(interp, TclGetObjNameOfExecutable()); return TCL_OK; } @@ -1745,41 +1803,41 @@ InfoNameOfExecutableCmd( * * InfoPatchLevelCmd -- * - * Called to implement the "info patchlevel" command that returns the - * default value for an argument to a procedure. Handles the following - * syntax: + * Called to implement the "info patchlevel" command that returns the + * default value for an argument to a procedure. Handles the following + * syntax: * - * info patchlevel + * info patchlevel * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * 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. + * 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. */ +InfoPatchLevelCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - const char *patchlevel; + CONST char *patchlevel; - if (objc != 1) { - Tcl_WrongNumArgs(interp, 1, objv, NULL); - return TCL_ERROR; + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; } patchlevel = Tcl_GetVar(interp, "tcl_patchLevel", - (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); + (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); if (patchlevel != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj(patchlevel, -1)); - return TCL_OK; + Tcl_SetStringObj(Tcl_GetObjResult(interp), patchlevel, -1); + return TCL_OK; } return TCL_ERROR; } @@ -1789,75 +1847,76 @@ InfoPatchLevelCmd( * * 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: + * 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? + * info procs ?pattern? * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * 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. + * 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. */ +InfoProcsCmd(dummy, interp, objc, objv) + 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; + 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); + Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); Tcl_Obj *listPtr, *elemObjPtr; - int specificNsInPattern = 0;/* Init. to avoid compiler warning. */ + 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. + * Get the pattern and find the "effective namespace" in which to + * list procs. */ - if (objc == 1) { + if (objc == 2) { simplePattern = NULL; nsPtr = currNsPtr; specificNsInPattern = 0; - } else if (objc == 2) { + } else if (objc == 3) { /* * 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. + * 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); + pattern = Tcl_GetString(objv[2]); + TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, + /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, + &simplePattern); - if (nsPtr != NULL) { /* We successfully found the pattern's ns. */ + 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; + Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + return TCL_ERROR; } if (nsPtr == NULL) { @@ -1865,18 +1924,18 @@ InfoProcsCmd( } /* - * 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. + * 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); + listPtr = Tcl_NewListObj(0, (Tcl_Obj **) 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); + cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); if (!TclIsProc(cmdPtr)) { realCmdPtr = (Command *) @@ -1885,7 +1944,7 @@ InfoProcsCmd( goto simpleProcOK; } } else { - simpleProcOK: + simpleProcOK: if (specificNsInPattern) { elemObjPtr = Tcl_NewObj(); Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, @@ -1903,8 +1962,8 @@ InfoProcsCmd( while (entryPtr != NULL) { cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); if ((simplePattern == NULL) - || Tcl_StringMatch(cmdName, simplePattern)) { - cmdPtr = Tcl_GetHashValue(entryPtr); + || Tcl_StringMatch(cmdName, simplePattern)) { + cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); if (!TclIsProc(cmdPtr)) { realCmdPtr = (Command *) @@ -1913,7 +1972,7 @@ InfoProcsCmd( goto procOK; } } else { - procOK: + procOK: if (specificNsInPattern) { elemObjPtr = Tcl_NewObj(); Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, @@ -1929,36 +1988,35 @@ InfoProcsCmd( /* * 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. + * 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 "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); + || Tcl_StringMatch(cmdName, simplePattern)) { + if (Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) { + cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); realCmdPtr = (Command *) TclGetOriginalCommand( - (Tcl_Command) cmdPtr); + (Tcl_Command) cmdPtr); if (TclIsProc(cmdPtr) || ((realCmdPtr != NULL) && TclIsProc(realCmdPtr))) { Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewStringObj(cmdName, -1)); + Tcl_NewStringObj(cmdName, -1)); } } } @@ -1977,46 +2035,47 @@ InfoProcsCmd( * * InfoScriptCmd -- * - * Called to implement the "info script" command that returns the script - * file that is currently being evaluated. Handles the following syntax: + * Called to implement the "info script" command that returns the + * script file that is currently being evaluated. Handles the + * following syntax: * - * info script ?newName? + * info script ?newName? * * If newName is specified, it will set that as the internal name. * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * 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. + * 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. */ +InfoScriptCmd(dummy, interp, objc, objv) + 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) && (objc != 3)) { + Tcl_WrongNumArgs(interp, 2, objv, "?filename?"); + return TCL_ERROR; } - if (objc == 2) { + if (objc == 3) { if (iPtr->scriptFile != NULL) { Tcl_DecrRefCount(iPtr->scriptFile); } - iPtr->scriptFile = objv[1]; + iPtr->scriptFile = objv[2]; Tcl_IncrRefCount(iPtr->scriptFile); } if (iPtr->scriptFile != NULL) { - Tcl_SetObjResult(interp, iPtr->scriptFile); + Tcl_SetObjResult(interp, iPtr->scriptFile); } return TCL_OK; } @@ -2026,36 +2085,36 @@ InfoScriptCmd( * * InfoSharedlibCmd -- * - * Called to implement the "info sharedlibextension" command that returns - * the file extension used for shared libraries. Handles the following - * syntax: + * Called to implement the "info sharedlibextension" command that + * returns the file extension used for shared libraries. Handles the + * following syntax: * - * info sharedlibextension + * info sharedlibextension * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * 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. + * 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. */ +InfoSharedlibCmd(dummy, interp, objc, objv) + 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; + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; } - + #ifdef TCL_SHLIB_EXT - Tcl_SetObjResult(interp, Tcl_NewStringObj(TCL_SHLIB_EXT, -1)); + Tcl_SetStringObj(Tcl_GetObjResult(interp), TCL_SHLIB_EXT, -1); #endif return TCL_OK; } @@ -2065,40 +2124,40 @@ InfoSharedlibCmd( * * InfoTclVersionCmd -- * - * Called to implement the "info tclversion" command that returns the - * version number for this Tcl library. Handles the following syntax: + * Called to implement the "info tclversion" command that returns the + * version number for this Tcl library. Handles the following syntax: * - * info tclversion + * info tclversion * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * 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. + * 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. */ +InfoTclVersionCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - Tcl_Obj *version; + CONST char *version; - if (objc != 1) { - Tcl_WrongNumArgs(interp, 1, objv, NULL); - return TCL_ERROR; + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; } - version = Tcl_GetVar2Ex(interp, "tcl_version", NULL, - (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); + version = Tcl_GetVar(interp, "tcl_version", + (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); if (version != NULL) { - Tcl_SetObjResult(interp, version); - return TCL_OK; + Tcl_SetStringObj(Tcl_GetObjResult(interp), version, -1); + return TCL_OK; } return TCL_ERROR; } @@ -2106,10 +2165,204 @@ InfoTclVersionCmd( /* *---------------------------------------------------------------------- * + * InfoVarsCmd -- + * + * Called to implement the "info vars" command that returns the + * list of variables 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 variables are returned. + * Handles the following syntax: + * + * info vars ?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 +InfoVarsCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Interp *iPtr = (Interp *) interp; + char *varName, *pattern; + CONST char *simplePattern; + register Tcl_HashEntry *entryPtr; + Tcl_HashSearch search; + Var *varPtr; + 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. */ + + /* + * Get the pattern and find the "effective namespace" in which to + * list variables. We only use this effective namespace if there's + * no active Tcl procedure frame. + */ + + if (objc == 2) { + simplePattern = NULL; + nsPtr = currNsPtr; + specificNsInPattern = 0; + } else if (objc == 3) { + /* + * 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 variables there can be found. + */ + + Namespace *dummy1NsPtr, *dummy2NsPtr; + + pattern = Tcl_GetString(objv[2]); + TclGetNamespaceForQualName(interp, pattern, (Namespace *) 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, 2, objv, "?pattern?"); + return TCL_ERROR; + } + + /* + * If the namespace specified in the pattern wasn't found, just return. + */ + + if (nsPtr == NULL) { + return TCL_OK; + } + + listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + + if ((iPtr->varFramePtr == NULL) + || !iPtr->varFramePtr->isProcCallFrame + || specificNsInPattern) { + /* + * There is no frame pointer, the frame pointer was pushed only + * to activate a namespace, or we are in a procedure call frame + * but a specific namespace was specified. Create a list containing + * only the variables in the effective namespace's variable table. + */ + + if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) { + /* + * If we can just do hash lookups, that simplifies things + * a lot. + */ + + entryPtr = Tcl_FindHashEntry(&nsPtr->varTable, simplePattern); + if (entryPtr != NULL) { + varPtr = (Var *) Tcl_GetHashValue(entryPtr); + if (!TclIsVarUndefined(varPtr) + || (varPtr->flags & VAR_NAMESPACE_VAR)) { + if (specificNsInPattern) { + elemObjPtr = Tcl_NewObj(); + Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, + elemObjPtr); + } else { + elemObjPtr = Tcl_NewStringObj(simplePattern, -1); + } + Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); + } + } else if ((nsPtr != globalNsPtr) && !specificNsInPattern) { + entryPtr = Tcl_FindHashEntry(&globalNsPtr->varTable, + simplePattern); + if (entryPtr != NULL) { + varPtr = (Var *) Tcl_GetHashValue(entryPtr); + if (!TclIsVarUndefined(varPtr) + || (varPtr->flags & VAR_NAMESPACE_VAR)) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(simplePattern, -1)); + } + } + } + } else { + /* + * Have to scan the tables of variables. + */ + + entryPtr = Tcl_FirstHashEntry(&nsPtr->varTable, &search); + while (entryPtr != NULL) { + varPtr = (Var *) Tcl_GetHashValue(entryPtr); + if (!TclIsVarUndefined(varPtr) + || (varPtr->flags & VAR_NAMESPACE_VAR)) { + varName = Tcl_GetHashKey(&nsPtr->varTable, entryPtr); + if ((simplePattern == NULL) + || Tcl_StringMatch(varName, simplePattern)) { + if (specificNsInPattern) { + elemObjPtr = Tcl_NewObj(); + Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, + elemObjPtr); + } else { + elemObjPtr = Tcl_NewStringObj(varName, -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 (i.e., the pattern only specifies variable + * names), then add in all global :: variables that match + * the simple pattern. Of course, add in only those + * variables that aren't hidden by a variable in the + * effective namespace. + */ + + if ((nsPtr != globalNsPtr) && !specificNsInPattern) { + entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search); + while (entryPtr != NULL) { + varPtr = (Var *) Tcl_GetHashValue(entryPtr); + if (!TclIsVarUndefined(varPtr) + || (varPtr->flags & VAR_NAMESPACE_VAR)) { + varName = Tcl_GetHashKey(&globalNsPtr->varTable, + entryPtr); + if ((simplePattern == NULL) + || Tcl_StringMatch(varName, simplePattern)) { + if (Tcl_FindHashEntry(&nsPtr->varTable, + varName) == NULL) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(varName, -1)); + } + } + } + entryPtr = Tcl_NextHashEntry(&search); + } + } + } + } else if (((Interp *)interp)->varFramePtr->procPtr != NULL) { + AppendLocals(interp, listPtr, simplePattern, 1); + } + + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_JoinObjCmd -- * - * This procedure is invoked to process the "join" Tcl command. See the - * user documentation for details on what it does. + * 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. @@ -2120,52 +2373,62 @@ InfoTclVersionCmd( *---------------------------------------------------------------------- */ + /* ARGSUSED */ int -Tcl_JoinObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* The argument objects. */ +Tcl_JoinObjCmd(dummy, interp, objc, objv) + 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; + char *joinString, *bytes; + int joinLength, listLen, length, i, result; + Tcl_Obj **elemPtrs; + Tcl_Obj *resObjPtr; - if ((objc < 2) || (objc > 3)) { + if (objc == 2) { + joinString = " "; + joinLength = 1; + } else if (objc == 3) { + joinString = Tcl_GetStringFromObj(objv[2], &joinLength); + } else { 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. + * 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; + result = Tcl_ListObjGetElements(interp, objv[1], &listLen, &elemPtrs); + if (result != TCL_OK) { + return result; } - joinObjPtr = (objc == 2) ? Tcl_NewStringObj(" ", 1) : objv[2]; - Tcl_IncrRefCount(joinObjPtr); + /* + * Now concatenate strings to form the "joined" result. We append + * directly into the interpreter's result object. + */ + + resObjPtr = Tcl_GetObjResult(interp); - resObjPtr = Tcl_NewObj(); for (i = 0; i < listLen; i++) { + bytes = Tcl_GetStringFromObj(elemPtrs[i], &length); if (i > 0) { - Tcl_AppendObjToObj(resObjPtr, joinObjPtr); + Tcl_AppendToObj(resObjPtr, joinString, joinLength); } - Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]); + Tcl_AppendToObj(resObjPtr, bytes, length); } - Tcl_DecrRefCount(joinObjPtr); - Tcl_SetObjResult(interp, resObjPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * - * Tcl_LassignObjCmd -- + * Tcl_LindexObjCmd -- * - * This object-based procedure is invoked to process the "lassign" Tcl + * This object-based procedure is invoked to process the "lindex" Tcl * command. See the user documentation for details on what it does. * * Results: @@ -2177,119 +2440,342 @@ Tcl_JoinObjCmd( *---------------------------------------------------------------------- */ + /* ARGSUSED */ int -Tcl_LassignObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +Tcl_LindexObjCmd(dummy, interp, objc, objv) + 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; + + Tcl_Obj *elemPtr; /* Pointer to the element being extracted */ if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "list ?varName ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "list ?index...?"); return TCL_ERROR; } - listCopyPtr = TclListObjCopy(interp, objv[1]); - if (listCopyPtr == NULL) { + /* + * 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; + } else { + Tcl_SetObjResult(interp, elemPtr); + Tcl_DecrRefCount( elemPtr ); + return TCL_OK; } +} + +/* + *---------------------------------------------------------------------- + * + * TclLindexList -- + * + * This procedure handles the 'lindex' command when objc==3. + * + * Results: + * Returns a pointer to the object extracted, or NULL if an + * error occurred. + * + * Side effects: + * None. + * + * If objv[1] can be parsed as a list, TclLindexList handles extraction + * of the desired element locally. Otherwise, it invokes + * TclLindexFlat to treat objv[1] as a scalar. + * + * The reference count of the returned object includes one reference + * corresponding to the pointer returned. Thus, the calling code will + * usually do something like: + * Tcl_SetObjResult( interp, result ); + * Tcl_DecrRefCount( result ); + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclLindexList( interp, listPtr, argPtr ) + Tcl_Interp* interp; /* Tcl interpreter */ + Tcl_Obj* listPtr; /* List being unpacked */ + Tcl_Obj* argPtr; /* Index or index list */ +{ - TclListObjGetElements(NULL, listCopyPtr, &listObjc, &listObjv); + Tcl_Obj **elemPtrs; /* Elements of the list being manipulated. */ + int listLen; /* Length of the list being manipulated. */ + int index; /* Index into the list */ + int result; /* Result returned from a Tcl library call */ + int i; /* Current index number */ + Tcl_Obj** indices; /* Array of list indices */ + int indexCount; /* Size of the array of list indices */ + Tcl_Obj* oldListPtr; /* Temp location to preserve the list + * pointer when replacing it with a sublist */ - 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--; + /* + * Determine whether argPtr designates a list or a single index. + * We have to be careful about the order of the checks to avoid + * repeated shimmering; see TIP#22 and TIP#33 for the details. + */ + + if ( argPtr->typePtr != &tclListType + && TclGetIntForIndex( NULL , argPtr, 0, &index ) == TCL_OK ) { + + /* + * argPtr designates a single index. + */ + + return TclLindexFlat( interp, listPtr, 1, &argPtr ); + + } else if ( Tcl_ListObjGetElements( NULL, argPtr, &indexCount, &indices ) + != TCL_OK ) { + + /* + * argPtr designates something that is neither an index nor a + * well-formed list. Report the error via TclLindexFlat. + */ + + return TclLindexFlat( interp, listPtr, 1, &argPtr ); } - if (code == TCL_OK && objc > 0) { - Tcl_Obj *emptyObj; + /* + * Record the reference to the list that we are maintaining in + * the activation record. + */ + + Tcl_IncrRefCount( listPtr ); + + /* + * argPtr designates a list, and the 'else if' above has parsed it + * into indexCount and indices. + */ + + for ( i = 0; i < indexCount; ++i ) { + + /* + * Convert the current listPtr to a list if necessary. + */ + + result = Tcl_ListObjGetElements( interp, listPtr, + &listLen, &elemPtrs); + if (result != TCL_OK) { + Tcl_DecrRefCount( listPtr ); + return NULL; + } + + /* + * Get the index from indices[ i ] + */ + + result = TclGetIntForIndex( interp, indices[ i ], + /*endValue*/ (listLen - 1), + &index ); + if ( result != TCL_OK ) { + /* + * Index could not be parsed + */ + + Tcl_DecrRefCount( listPtr ); + return NULL; - 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; + } else if ( index < 0 + || index >= listLen ) { + /* + * Index is out of range + */ + Tcl_DecrRefCount( listPtr ); + listPtr = Tcl_NewObj(); + Tcl_IncrRefCount( listPtr ); + return listPtr; + } + + /* + * Make sure listPtr still refers to a list object. + * If it shared a Tcl_Obj structure with the arguments, then + * it might have just been converted to something else. + */ + + if (listPtr->typePtr != &tclListType) { + result = Tcl_ListObjGetElements(interp, listPtr, &listLen, + &elemPtrs); + if (result != TCL_OK) { + Tcl_DecrRefCount( listPtr ); + return NULL; } } - Tcl_DecrRefCount(emptyObj); - } + + /* + * Extract the pointer to the appropriate element + */ + + oldListPtr = listPtr; + listPtr = elemPtrs[ index ]; + Tcl_IncrRefCount( listPtr ); + Tcl_DecrRefCount( oldListPtr ); + + /* + * The work we did above may have caused the internal rep + * of *argPtr to change to something else. Get it back. + */ + + result = Tcl_ListObjGetElements( interp, argPtr, + &indexCount, &indices ); + if ( result != TCL_OK ) { + /* + * This can't happen unless some extension corrupted a Tcl_Obj. + */ + Tcl_DecrRefCount( listPtr ); + return NULL; + } + + } /* end for */ - if (code == TCL_OK && listObjc > 0) { - Tcl_SetObjResult(interp, Tcl_NewListObj(listObjc, listObjv)); - } + /* + * Return the last object extracted. Its reference count will include + * the reference being returned. + */ - Tcl_DecrRefCount(listCopyPtr); - return code; + return listPtr; } /* *---------------------------------------------------------------------- * - * Tcl_LindexObjCmd -- + * TclLindexFlat -- * - * This object-based procedure is invoked to process the "lindex" Tcl - * command. See the user documentation for details on what it does. + * This procedure handles the 'lindex' command, given that the + * arguments to the command are known to be a flat list. * * Results: - * A standard Tcl object result. + * Returns a standard Tcl result. * * Side effects: - * See the user documentation. + * None. + * + * This procedure is called from either tclExecute.c or + * Tcl_LindexObjCmd whenever either is presented with + * objc == 2 or objc >= 4. It is also called from TclLindexList + * for the objc==3 case once it is determined that objv[2] cannot + * be parsed as a list. * *---------------------------------------------------------------------- */ -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 * +TclLindexFlat( interp, listPtr, indexCount, indexArray ) + Tcl_Interp* interp; /* Tcl interpreter */ + Tcl_Obj* listPtr; /* Tcl object representing the list */ + int indexCount; /* Count of indices */ + Tcl_Obj* CONST indexArray[]; + /* Array of pointers to Tcl objects + * representing the indices in the + * list */ { - Tcl_Obj *elemPtr; /* Pointer to the element being extracted. */ - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "list ?index ...?"); - return TCL_ERROR; - } + int i; /* Current list index */ + int result; /* Result of Tcl library calls */ + int listLen; /* Length of the current list being + * processed */ + Tcl_Obj** elemPtrs; /* Array of pointers to the elements + * of the current list */ + int index; /* Parsed version of the current element + * of indexArray */ + Tcl_Obj* oldListPtr; /* Temporary to hold listPtr so that + * its ref count can be decremented. */ /* - * 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. + * Record the reference to the 'listPtr' object that we are + * maintaining in the C activation record. */ - if (objc == 3) { - elemPtr = TclLindexList(interp, objv[1], objv[2]); - } else { - elemPtr = TclLindexFlat(interp, objv[1], objc-2, objv+2); - } + Tcl_IncrRefCount( listPtr ); - /* - * Set the interpreter's object result to the last element extracted. - */ + for ( i = 0; i < indexCount; ++i ) { - if (elemPtr == NULL) { - return TCL_ERROR; + /* + * Convert the current listPtr to a list if necessary. + */ + + result = Tcl_ListObjGetElements(interp, listPtr, + &listLen, &elemPtrs); + if (result != TCL_OK) { + Tcl_DecrRefCount( listPtr ); + return NULL; + } + + /* + * Get the index from objv[i] + */ + + result = TclGetIntForIndex( interp, indexArray[ i ], + /*endValue*/ (listLen - 1), + &index ); + if ( result != TCL_OK ) { + + /* Index could not be parsed */ + + Tcl_DecrRefCount( listPtr ); + return NULL; + + } else if ( index < 0 + || index >= listLen ) { + + /* + * Index is out of range + */ + + Tcl_DecrRefCount( listPtr ); + listPtr = Tcl_NewObj(); + Tcl_IncrRefCount( listPtr ); + return listPtr; + } + + /* + * Make sure listPtr still refers to a list object. + * It might have been converted to something else above + * if objv[1] overlaps with one of the other parameters. + */ + + if (listPtr->typePtr != &tclListType) { + result = Tcl_ListObjGetElements(interp, listPtr, &listLen, + &elemPtrs); + if (result != TCL_OK) { + Tcl_DecrRefCount( listPtr ); + return NULL; + } + } + + /* + * Extract the pointer to the appropriate element + */ + + oldListPtr = listPtr; + listPtr = elemPtrs[ index ]; + Tcl_IncrRefCount( listPtr ); + Tcl_DecrRefCount( oldListPtr ); + } - Tcl_SetObjResult(interp, elemPtr); - Tcl_DecrRefCount(elemPtr); - return TCL_OK; + return listPtr; + } /* @@ -2301,8 +2787,8 @@ Tcl_LindexObjCmd( * 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. + * A new Tcl list object formed by inserting zero or more elements + * into a list. * * Side effects: * See the user documentation. @@ -2310,33 +2796,34 @@ Tcl_LindexObjCmd( *---------------------------------------------------------------------- */ + /* ARGSUSED */ 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_LinsertObjCmd(dummy, interp, objc, objv) + 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; + int index, isDuplicate, len, result; - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "list index ?element ...?"); + if (objc < 4) { + Tcl_WrongNumArgs(interp, 1, objv, "list index element ?element ...?"); return TCL_ERROR; } - result = TclListObjLength(interp, objv[1], &len); + result = Tcl_ListObjLength(interp, objv[1], &len); if (result != TCL_OK) { return result; } /* - * Get the index. "end" is interpreted to be the index after the last + * 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); + result = TclGetIntForIndex(interp, objv[2], /*end*/ len, &index); if (result != TCL_OK) { return result; } @@ -2345,25 +2832,33 @@ Tcl_LinsertObjCmd( } /* - * If the list object is unshared we can modify it directly. Otherwise we - * create a copy to modify: this is "copy on write". + * 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]; + isDuplicate = 0; if (Tcl_IsShared(listPtr)) { - listPtr = TclListObjCopy(NULL, listPtr); + listPtr = Tcl_DuplicateObj(listPtr); + isDuplicate = 1; } if ((objc == 4) && (index == len)) { /* * Special case: insert one element at the end of the list. */ - - Tcl_ListObjAppendElement(NULL, listPtr, objv[3]); - } else { - Tcl_ListObjReplace(NULL, listPtr, index, 0, (objc-3), &(objv[3])); + result = Tcl_ListObjAppendElement(interp, listPtr, objv[3]); + } else if (objc > 3) { + result = Tcl_ListObjReplace(interp, listPtr, index, 0, + (objc-3), &(objv[3])); } - + if (result != TCL_OK) { + if (isDuplicate) { + Tcl_DecrRefCount(listPtr); /* free unneeded obj */ + } + return result; + } + /* * Set the interpreter's object result. */ @@ -2377,8 +2872,8 @@ Tcl_LinsertObjCmd( * * Tcl_ListObjCmd -- * - * This procedure is invoked to process the "list" Tcl command. See the - * user documentation for details on what it does. + * 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. @@ -2389,21 +2884,21 @@ Tcl_LinsertObjCmd( *---------------------------------------------------------------------- */ + /* ARGSUSED */ 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. */ +Tcl_ListObjCmd(dummy, interp, objc, objv) + 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. + * Otherwise modify the interpreter's result object to be a list object. */ - + if (objc > 1) { - Tcl_SetObjResult(interp, Tcl_NewListObj(objc-1, &objv[1])); + Tcl_SetListObj(Tcl_GetObjResult(interp), (objc-1), &(objv[1])); } return TCL_OK; } @@ -2414,7 +2909,7 @@ Tcl_ListObjCmd( * Tcl_LlengthObjCmd -- * * This object-based procedure is invoked to process the "llength" Tcl - * command. See the user documentation for details on what it does. + * command. See the user documentation for details on what it does. * * Results: * A standard Tcl object result. @@ -2425,13 +2920,13 @@ Tcl_ListObjCmd( *---------------------------------------------------------------------- */ + /* ARGSUSED */ int -Tcl_LlengthObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - register Tcl_Obj *const objv[]) - /* Argument objects. */ +Tcl_LlengthObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + register Tcl_Obj *CONST objv[]; /* Argument objects. */ { int listLen, result; @@ -2440,17 +2935,17 @@ Tcl_LlengthObjCmd( return TCL_ERROR; } - result = TclListObjLength(interp, objv[1], &listLen); + result = Tcl_ListObjLength(interp, objv[1], &listLen); if (result != TCL_OK) { return result; } /* * Set the interpreter's object result to an integer object holding the - * length. + * length. */ - Tcl_SetObjResult(interp, Tcl_NewIntObj(listLen)); + Tcl_SetIntObj(Tcl_GetObjResult(interp), listLen); return TCL_OK; } @@ -2459,8 +2954,8 @@ Tcl_LlengthObjCmd( * * Tcl_LrangeObjCmd -- * - * This procedure is invoked to process the "lrange" Tcl command. See the - * user documentation for details on what it does. + * 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. @@ -2471,28 +2966,39 @@ Tcl_LlengthObjCmd( *---------------------------------------------------------------------- */ + /* ARGSUSED */ 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_LrangeObjCmd(notUsed, interp, objc, objv) + ClientData notUsed; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + register Tcl_Obj *CONST objv[]; /* Argument objects. */ { + Tcl_Obj *listPtr; Tcl_Obj **elemPtrs; - int listLen, first, last, result; + int listLen, first, last, numElems, result; if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "list first last"); return TCL_ERROR; } - result = TclListObjLength(interp, objv[1], &listLen); + /* + * Make sure the list argument is a list object and get its length and + * a pointer to its array of element pointers. + */ + + listPtr = objv[1]; + result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs); if (result != TCL_OK) { return result; } - result = TclGetIntForIndexM(interp, objv[2], /*endValue*/ listLen - 1, + /* + * Get the first and last indexes. + */ + + result = TclGetIntForIndex(interp, objv[2], /*endValue*/ (listLen - 1), &first); if (result != TCL_OK) { return result; @@ -2501,158 +3007,39 @@ Tcl_LrangeObjCmd( first = 0; } - result = TclGetIntForIndexM(interp, objv[3], /*endValue*/ listLen - 1, + result = TclGetIntForIndex(interp, objv[3], /*endValue*/ (listLen - 1), &last); if (result != TCL_OK) { return result; } if (last >= listLen) { - last = listLen - 1; + 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_Format(NULL, - "bad count \"%d\": must be integer >= 0", 1, objv+1)); - Tcl_SetErrorCode(interp, "TCL","OPERATION","LREPEAT","NEGARG", NULL); - return TCL_ERROR; + return TCL_OK; /* the result is an empty object */ } /* - * 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; + * Make sure listPtr still refers to a list object. It might have been + * converted to an int above if the argument objects were shared. + */ + + if (listPtr->typePtr != &tclListType) { + result = Tcl_ListObjGetElements(interp, listPtr, &listLen, + &elemPtrs); + if (result != TCL_OK) { + return result; + } } /* - * 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. + * Extract a range of fields. We modify the interpreter's result object + * to be a list object containing the specified elements. */ - CLANG_ASSERT(dataArray); - 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); + numElems = (last - first + 1); + Tcl_SetListObj(Tcl_GetObjResult(interp), numElems, &(elemPtrs[first])); return TCL_OK; } @@ -2661,12 +3048,12 @@ Tcl_LrepeatObjCmd( * * Tcl_LreplaceObjCmd -- * - * This object-based procedure is invoked to process the "lreplace" Tcl - * command. See the user documentation for details on what it does. + * 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. + * A new Tcl list object formed by replacing zero or more elements of + * a list. * * Side effects: * See the user documentation. @@ -2674,173 +3061,100 @@ Tcl_LrepeatObjCmd( *---------------------------------------------------------------------- */ + /* ARGSUSED */ int -Tcl_LreplaceObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +Tcl_LreplaceObjCmd(dummy, interp, objc, objv) + 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; + int isDuplicate, first, last, listLen, numToDelete, result; if (objc < 4) { Tcl_WrongNumArgs(interp, 1, objv, - "list first last ?element ...?"); + "list first last ?element element ...?"); return TCL_ERROR; } - result = TclListObjLength(interp, objv[1], &listLen); + result = Tcl_ListObjLength(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. + * 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); + result = TclGetIntForIndex(interp, objv[2], /*end*/ (listLen - 1), &first); if (result != TCL_OK) { return result; } - result = TclGetIntForIndexM(interp, objv[3], /*end*/ listLen-1, &last); + result = TclGetIntForIndex(interp, objv[3], /*end*/ (listLen - 1), &last); if (result != TCL_OK) { return result; } - if (first < 0) { - first = 0; + 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 + * 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_AppendResult(interp, "list doesn't contain element ", - TclGetString(objv[2]), NULL); - Tcl_SetErrorCode(interp, "TCL","OPERATION","LREPLACE","BADIDX", NULL); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "list doesn't contain element ", + Tcl_GetString(objv[2]), (int *) NULL); return TCL_ERROR; } if (last >= listLen) { - last = listLen - 1; + last = (listLen - 1); } if (first <= last) { - numToDelete = last - first + 1; + 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". + * 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]; + isDuplicate = 0; if (Tcl_IsShared(listPtr)) { - listPtr = TclListObjCopy(NULL, listPtr); + listPtr = Tcl_DuplicateObj(listPtr); + isDuplicate = 1; } - - /* - * 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. - */ - - Tcl_ListObjReplace(NULL, listPtr, first, numToDelete, objc-4, objv+4); - - /* - * 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 (objc > 4) { + result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete, + (objc-4), &(objv[4])); + } else { + result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete, + 0, NULL); } - if (TclListObjGetElements(interp, objv[1], &elemc, &elemv) != TCL_OK) { - return TCL_ERROR; + if (result != TCL_OK) { + if (isDuplicate) { + Tcl_DecrRefCount(listPtr); /* free unneeded obj */ + } + return result; } /* - * If the list is empty, just return it. [Bug 1876793] + * Set the interpreter's object result. */ - 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]); - } + Tcl_SetObjResult(interp, listPtr); return TCL_OK; } @@ -2849,8 +3163,8 @@ Tcl_LreverseObjCmd( * * Tcl_LsearchObjCmd -- * - * This procedure is invoked to process the "lsearch" Tcl command. See - * the user documentation for details on what it does. + * 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. @@ -2862,34 +3176,30 @@ Tcl_LreverseObjCmd( */ int -Tcl_LsearchObjCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument values. */ +Tcl_LsearchObjCmd(clientData, interp, objc, objv) + 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, patInt, objInt, offset; - int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase; + char *bytes, *patternBytes; + int i, match, mode, index, result, listc, length, elemLen; + int dataType, isIncreasing, lower, upper, patInt, objInt; + int offset, allMatches, inlineReturn, negatedMatch; double patDouble, objDouble; - SortInfo sortInfo; - Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr; - SortStrCmpFn_t strCmpFn = strcmp; + Tcl_Obj *patObj, **listv, *listPtr, *startPtr; 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 + static CONST char *options[] = { + "-all", "-ascii", "-decreasing", "-dictionary", + "-exact", "-glob", "-increasing", "-inline", + "-integer", "-not", "-real", "-regexp", + "-sorted", "-start", 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 + LSEARCH_ALL, LSEARCH_ASCII, LSEARCH_DECREASING, LSEARCH_DICTIONARY, + LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_INCREASING, LSEARCH_INLINE, + LSEARCH_INTEGER, LSEARCH_NOT, LSEARCH_REAL, LSEARCH_REGEXP, + LSEARCH_SORTED, LSEARCH_START }; enum datatypes { ASCII, DICTIONARY, INTEGER, REAL @@ -2897,41 +3207,29 @@ Tcl_LsearchObjCmd( 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"); + Tcl_WrongNumArgs(interp, 1, objv, "?options? 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) { + if (startPtr) { Tcl_DecrRefCount(startPtr); } - result = TCL_ERROR; - goto done; + return TCL_ERROR; } switch ((enum options) index) { case LSEARCH_ALL: /* -all */ @@ -2940,13 +3238,8 @@ Tcl_LsearchObjCmd( 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; @@ -2959,7 +3252,6 @@ Tcl_LsearchObjCmd( break; case LSEARCH_INCREASING: /* -increasing */ isIncreasing = 1; - sortInfo.isIncreasing = 1; break; case LSEARCH_INLINE: /* -inline */ inlineReturn = 1; @@ -2967,10 +3259,6 @@ Tcl_LsearchObjCmd( case LSEARCH_INTEGER: /* -integer */ dataType = INTEGER; break; - case LSEARCH_NOCASE: /* -nocase */ - strCmpFn = strcasecmp; - noCase = 1; - break; case LSEARCH_NOT: /* -not */ negatedMatch = 1; break; @@ -2983,182 +3271,87 @@ Tcl_LsearchObjCmd( 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 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) { + if (startPtr) { Tcl_DecrRefCount(startPtr); } if (i > objc-4) { Tcl_AppendResult(interp, "missing starting index", NULL); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); - result = TCL_ERROR; - goto done; + return TCL_ERROR; } 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. + * 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_AppendResult(interp, - "\"-index\" option must be followed by list index", - NULL); - 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_AppendResult(interp, - "-subindices cannot be used without -index option", NULL); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", - "BAD_OPTION_MIX", NULL); - return TCL_ERROR; } - if (bisect && (allMatches || negatedMatch)) { - Tcl_AppendResult(interp, - "-bisect is not compatible with -all or -not", NULL); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", - "BAD_OPTION_MIX", NULL); - return TCL_ERROR; - } - - if (mode == REGEXP) { + if ((enum modes) 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. + * 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)); + TCL_REG_ADVANCED | TCL_REG_NOSUB); 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. - */ + /* + * 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)); + regexp = Tcl_GetRegExpFromObj(interp, objv[objc - 1], + TCL_REG_ADVANCED); } if (regexp == NULL) { - if (startPtr != NULL) { + if (startPtr) { Tcl_DecrRefCount(startPtr); } - result = TCL_ERROR; - goto done; + 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. + * 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); + result = Tcl_ListObjGetElements(interp, objv[objc - 2], &listc, &listv); if (result != TCL_OK) { - if (startPtr != NULL) { + if (startPtr) { Tcl_DecrRefCount(startPtr); } - goto done; + return result; } /* * Get the user-specified start offset. */ - if (startPtr) { - result = TclGetIntForIndexM(interp, startPtr, listc-1, &offset); + result = TclGetIntForIndex(interp, startPtr, listc-1, &offset); Tcl_DecrRefCount(startPtr); if (result != TCL_OK) { - goto done; - } - if (offset < 0) { - offset = 0; + return result; } /* @@ -3167,9 +3360,6 @@ Tcl_LsearchObjCmd( */ if (offset > listc-1) { - if (sortInfo.indexc > 1) { - TclStackFree(interp, sortInfo.indexv); - } if (allMatches || inlineReturn) { Tcl_ResetResult(interp); } else { @@ -3177,89 +3367,71 @@ Tcl_LsearchObjCmd( } return TCL_OK; } + if (offset < 0) { + offset = 0; + } } patObj = objv[objc - 1]; patternBytes = NULL; - if (mode == EXACT || mode == SORTED) { + if ((enum modes) mode == EXACT || (enum modes) mode == SORTED) { switch ((enum datatypes) dataType) { case ASCII: case DICTIONARY: - patternBytes = TclGetStringFromObj(patObj, &length); + patternBytes = Tcl_GetStringFromObj(patObj, &length); break; case INTEGER: - result = TclGetIntFromObj(interp, patObj, &patInt); + result = Tcl_GetIntFromObj(interp, patObj, &patInt); if (result != TCL_OK) { - goto done; + return result; } - - /* - * List representation might have been shimmered; restore it. [Bug - * 1844789] - */ - - TclListObjGetElements(NULL, objv[objc - 2], &listc, &listv); + Tcl_ListObjGetElements(NULL, objv[objc - 2], &listc, &listv); break; case REAL: result = Tcl_GetDoubleFromObj(interp, patObj, &patDouble); if (result != TCL_OK) { - goto done; + return result; } - - /* - * List representation might have been shimmered; restore it. [Bug - * 1844789] - */ - - TclListObjGetElements(NULL, objv[objc - 2], &listc, &listv); + Tcl_ListObjGetElements(NULL, objv[objc - 2], &listc, &listv); break; } } else { - patternBytes = TclGetStringFromObj(patObj, &length); + patternBytes = Tcl_GetStringFromObj(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. + * 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 ((enum modes) 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. + * 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) { + while (lower + 1 != upper) { 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); + bytes = Tcl_GetString(listv[i]); + match = strcmp(patternBytes, bytes); break; case DICTIONARY: - bytes = TclGetString(itemPtr); + bytes = Tcl_GetString(listv[i]); match = DictionaryCompare(patternBytes, bytes); break; case INTEGER: - result = TclGetIntFromObj(interp, itemPtr, &objInt); + result = Tcl_GetIntFromObj(interp, listv[i], &objInt); if (result != TCL_OK) { - goto done; + return result; } if (patInt == objInt) { match = 0; @@ -3270,9 +3442,9 @@ Tcl_LsearchObjCmd( } break; case REAL: - result = Tcl_GetDoubleFromObj(interp, itemPtr, &objDouble); + result = Tcl_GetDoubleFromObj(interp, listv[i], &objDouble); if (result != TCL_OK) { - goto done; + return result; } if (patDouble == objDouble) { match = 0; @@ -3285,27 +3457,19 @@ Tcl_LsearchObjCmd( } 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 + * 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. + * comparisons (normal binary search might "get lucky" with + * an early comparison). */ - index = i; - if (bisect) { - lower = i; - } else { - upper = i; - } + upper = i; } else if (match > 0) { if (isIncreasing) { lower = i; @@ -3320,9 +3484,7 @@ Tcl_LsearchObjCmd( } } } - if (bisect && index < 0) { - index = lower; - } + } else { /* * We need to do a linear search, because (at least one) of: @@ -3330,128 +3492,83 @@ Tcl_LsearchObjCmd( * - our matching sense is negated * - we're building a list of all matched items */ - if (allMatches) { - listPtr = Tcl_NewListObj(0, NULL); + listPtr = Tcl_NewListObj(0, (Tcl_Obj **) 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) { + switch ((enum modes) mode) { case SORTED: case EXACT: switch ((enum datatypes) dataType) { case ASCII: - bytes = TclGetStringFromObj(itemPtr, &elemLen); + bytes = Tcl_GetStringFromObj(listv[i], &elemLen); if (length == elemLen) { - /* - * This split allows for more optimal compilation of - * memcmp/strcasecmp. - */ - - if (noCase) { - match = (strcasecmp(bytes, patternBytes) == 0); - } else { - match = (memcmp(bytes, patternBytes, - (size_t) length) == 0); - } + match = (memcmp(bytes, patternBytes, + (size_t) length) == 0); } break; - case DICTIONARY: - bytes = TclGetString(itemPtr); + bytes = Tcl_GetString(listv[i]); match = (DictionaryCompare(bytes, patternBytes) == 0); break; - case INTEGER: - result = TclGetIntFromObj(interp, itemPtr, &objInt); + result = Tcl_GetIntFromObj(interp, listv[i], &objInt); if (result != TCL_OK) { - if (listPtr != NULL) { + if (listPtr) { Tcl_DecrRefCount(listPtr); } - goto done; + return result; } match = (objInt == patInt); break; - case REAL: - result = Tcl_GetDoubleFromObj(interp,itemPtr, &objDouble); + result = Tcl_GetDoubleFromObj(interp, listv[i], + &objDouble); if (result != TCL_OK) { if (listPtr) { Tcl_DecrRefCount(listPtr); } - goto done; + return result; } match = (objDouble == patDouble); break; } break; - case GLOB: - match = Tcl_StringCaseMatch(TclGetString(itemPtr), - patternBytes, noCase); + match = Tcl_StringMatch(Tcl_GetString(listv[i]), + patternBytes); break; - case REGEXP: - match = Tcl_RegExpExecObj(interp, regexp, itemPtr, 0, 0, 0); + match = Tcl_RegExpExecObj(interp, regexp, listv[i], 0, 0, 0); if (match < 0) { Tcl_DecrRefCount(patObj); - if (listPtr != NULL) { + if (listPtr) { Tcl_DecrRefCount(listPtr); } - result = TCL_ERROR; - goto done; + return TCL_ERROR; } break; } - /* - * Invert match condition for -not. + * 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); + if (match != 0) { + if (!allMatches) { + index = i; + break; + } else if (inlineReturn) { + /* + * Note that these appends are not expected to fail. + */ + Tcl_ListObjAppendElement(interp, listPtr, listv[i]); } else { - itemPtr = listv[i]; + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewIntObj(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)); } } } @@ -3459,43 +3576,20 @@ Tcl_LsearchObjCmd( /* * 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)); - } + Tcl_SetIntObj(Tcl_GetObjResult(interp), index); } else if (index < 0) { /* - * Is this superfluous? The result should be a blank object by - * default... + * 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; + return TCL_OK; } /* @@ -3503,8 +3597,8 @@ Tcl_LsearchObjCmd( * * Tcl_LsetObjCmd -- * - * This procedure is invoked to process the "lset" Tcl command. See the - * user documentation for details on what it does. + * 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. @@ -3516,71 +3610,66 @@ Tcl_LsearchObjCmd( */ int -Tcl_LsetObjCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument values. */ +Tcl_LsetObjCmd( clientData, interp, objc, objv ) + 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. - */ + Tcl_Obj* listPtr; /* Pointer to the list being altered. */ + Tcl_Obj* finalValuePtr; /* Value finally assigned to the variable */ - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, - "listVar ?index? ?index ...? value"); + /* 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. - */ + /* Look up the list variable's value */ - listPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); - if (listPtr == NULL) { + listPtr = Tcl_ObjGetVar2( interp, objv[ 1 ], (Tcl_Obj*) 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. + /* + * 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]); + if ( objc == 4 ) { + finalValuePtr = TclLsetList( interp, listPtr, + objv[ 2 ], objv[ 3 ] ); } else { - finalValuePtr = TclLsetFlat(interp, listPtr, objc-3, objv+2, - objv[objc-1]); + finalValuePtr = TclLsetFlat( interp, listPtr, + objc-3, objv+2, objv[ objc-1 ] ); } /* * If substitution has failed, bail out. */ - if (finalValuePtr == NULL) { + if ( finalValuePtr == NULL ) { return TCL_ERROR; } - /* - * Finally, update the variable so that traces fire. - */ + /* 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) { + 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. - */ + /* Return the new value of the variable as the interpreter result. */ - Tcl_SetObjResult(interp, listPtr); + Tcl_SetObjResult( interp, listPtr ); return TCL_OK; + } /* @@ -3588,8 +3677,8 @@ Tcl_LsetObjCmd( * * Tcl_LsortObjCmd -- * - * This procedure is invoked to process the "lsort" Tcl command. See the - * user documentation for details on what it does. + * 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. @@ -3601,37 +3690,29 @@ Tcl_LsetObjCmd( */ int -Tcl_LsortObjCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument values. */ +Tcl_LsortObjCmd(clientData, interp, objc, objv) + 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, sortMode, indexc; - 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[] = { + int i, index, unique; + Tcl_Obj *resultPtr; + int length; + Tcl_Obj *cmdPtr, **listObjPtrs; + SortElement *elementArray; + SortElement *elementPtr; + SortInfo sortInfo; /* Information about this sort that + * needs to be passed to the + * comparison function */ + static CONST char *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 + "-index", "-integer", "-real", "-unique", (char *) NULL }; + resultPtr = Tcl_GetObjResult(interp); if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "?-option value ...? list"); + Tcl_WrongNumArgs(interp, 1, objv, "?options? list"); return TCL_ERROR; } @@ -3641,423 +3722,199 @@ Tcl_LsortObjCmd( sortInfo.isIncreasing = 1; sortInfo.sortMode = SORTMODE_ASCII; - sortInfo.indexv = NULL; - sortInfo.indexc = 0; - sortInfo.unique = 0; + sortInfo.index = SORTIDX_NONE; sortInfo.interp = interp; sortInfo.resultCode = TCL_OK; cmdPtr = NULL; - indices = 0; - group = 0; - groupSize = 1; - groupOffset = 0; - indexPtr = NULL; + unique = 0; 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; + if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, &index) + != TCL_OK) { + return TCL_ERROR; } - switch ((enum Lsort_Switches) index) { - case LSORT_ASCII: - sortInfo.sortMode = SORTMODE_ASCII; - break; - case LSORT_COMMAND: - if (i == objc-2) { - Tcl_AppendResult(interp, - "\"-command\" option must be followed " - "by comparison command", NULL); - 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_AppendResult(interp, "\"-index\" option must be " - "followed by list index", NULL); - 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; + switch (index) { + case 0: /* -ascii */ + sortInfo.sortMode = SORTMODE_ASCII; + break; + case 1: /* -command */ + if (i == (objc-2)) { + Tcl_AppendToObj(resultPtr, + "\"-command\" option must be followed by comparison command", + -1); + return TCL_ERROR; } - } - 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_AppendResult(interp, "\"-stride\" option must be ", - "followed by stride length", NULL); - 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_AppendResult(interp, "stride length must be at least 2", - NULL); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", - "BADSTRIDE", NULL); - sortInfo.resultCode = TCL_ERROR; - goto done2; - } - group = 1; - i++; - break; + sortInfo.sortMode = SORTMODE_COMMAND; + cmdPtr = objv[i+1]; + i++; + break; + case 2: /* -decreasing */ + sortInfo.isIncreasing = 0; + break; + case 3: /* -dictionary */ + sortInfo.sortMode = SORTMODE_DICTIONARY; + break; + case 4: /* -increasing */ + sortInfo.isIncreasing = 1; + break; + case 5: /* -index */ + if (i == (objc-2)) { + Tcl_AppendToObj(resultPtr, + "\"-index\" option must be followed by list index", + -1); + return TCL_ERROR; + } + if (TclGetIntForIndex(interp, objv[i+1], SORTIDX_END, + &sortInfo.index) != TCL_OK) { + return TCL_ERROR; + } + i++; + break; + case 6: /* -integer */ + sortInfo.sortMode = SORTMODE_INTEGER; + break; + case 7: /* -real */ + sortInfo.sortMode = SORTMODE_REAL; + break; + case 8: /* -unique */ + unique = 1; + 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] + * The existing command is a list. We want to flatten it, append + * two dummy arguments on the end, and replace these arguments + * later. */ - listObj = TclListObjCopy(interp, listObj); - if (listObj == NULL) { - sortInfo.resultCode = TCL_ERROR; - goto done2; - } + Tcl_Obj *newCommandPtr = Tcl_DuplicateObj(cmdPtr); + Tcl_Obj *newObjPtr = Tcl_NewObj(); - /* - * 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_DecrRefCount(newCommandPtr); Tcl_IncrRefCount(newObjPtr); - TclDecrRefCount(newObjPtr); - sortInfo.resultCode = TCL_ERROR; - goto done2; + Tcl_DecrRefCount(newObjPtr); + return TCL_ERROR; } Tcl_ListObjAppendElement(interp, newCommandPtr, Tcl_NewObj()); sortInfo.compareCmdPtr = newCommandPtr; } - sortInfo.resultCode = TclListObjGetElements(interp, listObj, + sortInfo.resultCode = Tcl_ListObjGetElements(interp, objv[objc-1], &length, &listObjPtrs); if (sortInfo.resultCode != TCL_OK || length <= 0) { goto done; } + elementArray = (SortElement *) ckalloc(length * sizeof(SortElement)); + for (i=0; i < length; i++){ + elementArray[i].objPtr = listObjPtrs[i]; + elementArray[i].count = 0; + elementArray[i].nextPtr = &elementArray[i+1]; - /* - * Check for sanity when grouping elements of the overall list together - * because of the -stride option. [TIP #326] - */ - - if (group) { - if (length % groupSize) { - Tcl_AppendResult(interp, - "list size must be a multiple of the stride length", - NULL); - 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_AppendResult(interp, "when used with \"-stride\", the " - "leading \"-index\" value must be within the group", - NULL); - 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 + * 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. Increment the reference counts of the elements + * to sort to prevent this. [Bug 1675116] */ - sortMode = SORTMODE_ASCII; + Tcl_IncrRefCount(elementArray[i].objPtr); } - - /* - * 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]; - } - + elementArray[length-1].nextPtr = NULL; + elementPtr = MergeSort(elementArray, &sortInfo); + if (sortInfo.resultCode == TCL_OK) { /* - * Determine the "value" of this object for sorting purposes + * Note: must clear the interpreter's result object: it could + * have been set by the -command script. */ - if (sortMode == SORTMODE_ASCII) { - elementArray[i].collationKey.strValuePtr = TclGetString(indexPtr); - } else if (sortMode == SORTMODE_INTEGER) { - long a; - - if (TclGetLongFromObj(sortInfo.interp, indexPtr, &a) != TCL_OK) { - sortInfo.resultCode = TCL_ERROR; - goto done1; - } - elementArray[i].collationKey.intValue = a; - } else if (sortInfo.sortMode == SORTMODE_REAL) { - double a; - - if (Tcl_GetDoubleFromObj(sortInfo.interp, indexPtr, - &a) != TCL_OK) { - sortInfo.resultCode = TCL_ERROR; - goto done1; + Tcl_ResetResult(interp); + resultPtr = Tcl_GetObjResult(interp); + if (unique) { + for (; elementPtr != NULL; elementPtr = elementPtr->nextPtr){ + if (elementPtr->count == 0) { + Tcl_ListObjAppendElement(interp, resultPtr, + elementPtr->objPtr); + } } - 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; + for (; elementPtr != NULL; elementPtr = elementPtr->nextPtr){ + Tcl_ListObjAppendElement(interp, resultPtr, + elementPtr->objPtr); + } } - subList[j] = elementPtr; } + for (i=0; i<length; i++) { + Tcl_DecrRefCount(elementArray[i].objPtr); + } + ckfree((char*) elementArray); - /* - * Merge all sublists - */ - - elementPtr = subList[0]; - for (j=1 ; j<NUM_LISTS ; j++) { - elementPtr = MergeLists(subList[j], elementPtr, &sortInfo); + done: + if (sortInfo.sortMode == SORTMODE_COMMAND) { + Tcl_DecrRefCount(sortInfo.compareCmdPtr); + sortInfo.compareCmdPtr = NULL; } + return sortInfo.resultCode; +} + +/* + *---------------------------------------------------------------------- + * + * MergeSort - + * + * This procedure sorts a linked list of SortElement structures + * use the merge-sort algorithm. + * + * Results: + * A pointer to the head of the list after sorting is returned. + * + * Side effects: + * None, unless a user-defined comparison command does something + * weird. + * + *---------------------------------------------------------------------- + */ +static SortElement * +MergeSort(headPtr, infoPtr) + SortElement *headPtr; /* First element on the list */ + SortInfo *infoPtr; /* Information needed by the + * comparison operator */ +{ /* - * Now store the sorted elements in the result list. + * The subList array below holds pointers to temporary lists built + * during the merge sort. Element i of the array holds a list of + * length 2**i. */ - 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); +# define NUM_LISTS 30 + SortElement *subList[NUM_LISTS]; + SortElement *elementPtr; + int i; - done: - if (sortInfo.sortMode == SORTMODE_COMMAND) { - TclDecrRefCount(sortInfo.compareCmdPtr); - TclDecrRefCount(listObj); - sortInfo.compareCmdPtr = NULL; + for(i = 0; i < NUM_LISTS; i++){ + subList[i] = NULL; } - done2: - if (allocatedIndexVector) { - TclStackFree(interp, sortInfo.indexv); + while (headPtr != NULL) { + elementPtr = headPtr; + headPtr = headPtr->nextPtr; + elementPtr->nextPtr = 0; + for (i = 0; (i < NUM_LISTS) && (subList[i] != NULL); i++){ + elementPtr = MergeLists(subList[i], elementPtr, infoPtr); + subList[i] = NULL; + } + if (i >= NUM_LISTS) { + i = NUM_LISTS-1; + } + subList[i] = elementPtr; } - return sortInfo.resultCode; + elementPtr = NULL; + for (i = 0; i < NUM_LISTS; i++){ + elementPtr = MergeLists(subList[i], elementPtr, infoPtr); + } + return elementPtr; } /* @@ -4069,93 +3926,65 @@ Tcl_LsortObjCmd( * into a single sorted list. * * Results: - * The unified list of SortElement structures. + * 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 + * None, unless 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. */ +MergeLists(leftPtr, rightPtr, infoPtr) + 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; + SortElement *headPtr; + SortElement *tailPtr; int cmp; if (leftPtr == NULL) { - return rightPtr; + return rightPtr; } if (rightPtr == NULL) { - return leftPtr; + return leftPtr; } - cmp = SortCompare(leftPtr, rightPtr, infoPtr); - if (cmp > 0 || (cmp == 0 && infoPtr->unique)) { - if (cmp == 0) { - infoPtr->numElements--; - leftPtr = leftPtr->nextPtr; - } + cmp = SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr); + if (cmp > 0) { tailPtr = rightPtr; rightPtr = rightPtr->nextPtr; } else { + if (cmp == 0) { + leftPtr->count++; + } 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; + while ((leftPtr != NULL) && (rightPtr != NULL)) { + cmp = SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr); + if (cmp > 0) { + tailPtr->nextPtr = rightPtr; + tailPtr = rightPtr; + rightPtr = rightPtr->nextPtr; + } else { + if (cmp == 0) { + leftPtr->count++; } + tailPtr->nextPtr = leftPtr; + tailPtr = leftPtr; + leftPtr = leftPtr->nextPtr; } } if (leftPtr != NULL) { - tailPtr->nextPtr = leftPtr; + tailPtr->nextPtr = leftPtr; } else { - tailPtr->nextPtr = rightPtr; + tailPtr->nextPtr = rightPtr; } return headPtr; } @@ -4169,99 +3998,163 @@ MergeLists( * 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. + * 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. + * 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. */ +SortCompare(objPtr1, objPtr2, infoPtr) + Tcl_Obj *objPtr1, *objPtr2; /* Values to be compared. */ + SortInfo *infoPtr; /* Information passed from the + * top-level "lsort" command */ { - int order = 0; + int order, listLen, index; + Tcl_Obj *objPtr; + char buffer[TCL_INTEGER_SPACE]; + + order = 0; + if (infoPtr->resultCode != TCL_OK) { + /* + * Once an error has occurred, skip any future comparisons + * so as to preserve the error message in sortInterp->result. + */ + + return order; + } + if (infoPtr->index != SORTIDX_NONE) { + /* + * The "-index" option was specified. Treat each object as a + * list, extract the requested element from each list, and + * compare the elements, not the lists. "end"-relative indices + * are signaled here with large negative values. + */ + + if (Tcl_ListObjLength(infoPtr->interp, objPtr1, &listLen) != TCL_OK) { + infoPtr->resultCode = TCL_ERROR; + return order; + } + if (infoPtr->index < SORTIDX_NONE) { + index = listLen + infoPtr->index + 1; + } else { + index = infoPtr->index; + } + + if (Tcl_ListObjIndex(infoPtr->interp, objPtr1, index, &objPtr) + != TCL_OK) { + infoPtr->resultCode = TCL_ERROR; + return order; + } + if (objPtr == NULL) { + objPtr = objPtr1; + missingElement: + TclFormatInt(buffer, infoPtr->index); + Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp), + "element ", buffer, " missing from sublist \"", + Tcl_GetString(objPtr), "\"", (char *) NULL); + infoPtr->resultCode = TCL_ERROR; + return order; + } + objPtr1 = objPtr; + + if (Tcl_ListObjLength(infoPtr->interp, objPtr2, &listLen) != TCL_OK) { + infoPtr->resultCode = TCL_ERROR; + return order; + } + if (infoPtr->index < SORTIDX_NONE) { + index = listLen + infoPtr->index + 1; + } else { + index = infoPtr->index; + } + if (Tcl_ListObjIndex(infoPtr->interp, objPtr2, index, &objPtr) + != TCL_OK) { + infoPtr->resultCode = TCL_ERROR; + return order; + } + if (objPtr == NULL) { + objPtr = objPtr2; + goto missingElement; + } + objPtr2 = objPtr; + } if (infoPtr->sortMode == SORTMODE_ASCII) { - order = strcmp(elemPtr1->collationKey.strValuePtr, - elemPtr2->collationKey.strValuePtr); - } else if (infoPtr->sortMode == SORTMODE_ASCII_NC) { - order = strcasecmp(elemPtr1->collationKey.strValuePtr, - elemPtr2->collationKey.strValuePtr); + order = strcmp(Tcl_GetString(objPtr1), Tcl_GetString(objPtr2)); } else if (infoPtr->sortMode == SORTMODE_DICTIONARY) { - order = DictionaryCompare(elemPtr1->collationKey.strValuePtr, - elemPtr2->collationKey.strValuePtr); + order = DictionaryCompare( + Tcl_GetString(objPtr1), Tcl_GetString(objPtr2)); } else if (infoPtr->sortMode == SORTMODE_INTEGER) { long a, b; - a = elemPtr1->collationKey.intValue; - b = elemPtr2->collationKey.intValue; - order = ((a >= b) - (a <= b)); + if ((Tcl_GetLongFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK) + || (Tcl_GetLongFromObj(infoPtr->interp, objPtr2, &b) + != TCL_OK)) { + infoPtr->resultCode = TCL_ERROR; + return order; + } + if (a > b) { + order = 1; + } else if (b > a) { + order = -1; + } } else if (infoPtr->sortMode == SORTMODE_REAL) { double a, b; - a = elemPtr1->collationKey.doubleValue; - b = elemPtr2->collationKey.doubleValue; - order = ((a >= b) - (a <= b)); + if ((Tcl_GetDoubleFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK) + || (Tcl_GetDoubleFromObj(infoPtr->interp, objPtr2, &b) + != TCL_OK)) { + infoPtr->resultCode = TCL_ERROR; + return order; + } + if (a > b) { + order = 1; + } else if (b > a) { + order = -1; + } } 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. + /* + * 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_ListObjLength(infoPtr->interp, infoPtr->compareCmdPtr, &objc); Tcl_ListObjReplace(infoPtr->interp, infoPtr->compareCmdPtr, objc - 2, 2, 2, paramObjv); - TclListObjGetElements(infoPtr->interp, infoPtr->compareCmdPtr, + Tcl_ListObjGetElements(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; + + if (infoPtr->resultCode != TCL_OK) { + Tcl_AddErrorInfo(infoPtr->interp, + "\n (-compare command)"); + return order; } /* * Parse the result of the command. */ - if (TclGetIntFromObj(infoPtr->interp, + if (Tcl_GetIntFromObj(infoPtr->interp, Tcl_GetObjResult(infoPtr->interp), &order) != TCL_OK) { Tcl_ResetResult(infoPtr->interp); - Tcl_AppendResult(infoPtr->interp, - "-compare command returned non-integer result", NULL); - Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT", - "COMPARISONFAILED", NULL); + Tcl_AppendToObj(Tcl_GetObjResult(infoPtr->interp), + "-compare command returned non-integer result", -1); infoPtr->resultCode = TCL_ERROR; - return 0; + return order; } } if (!infoPtr->isIncreasing) { @@ -4275,18 +4168,18 @@ SortCompare( * * 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(). + * 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. + * 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. @@ -4295,29 +4188,30 @@ SortCompare( */ static int -DictionaryCompare( - const char *left, const char *right) /* The strings to compare. */ +DictionaryCompare(left, right) + char *left, *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 */ + 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. + * 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]))) { + while ((*right == '0') && (isdigit(UCHAR(right[1])))) { right++; zeros--; } - while ((*left == '0') && isdigit(UCHAR(left[1]))) { + while ((*left == '0') && (isdigit(UCHAR(left[1])))) { left++; zeros++; } @@ -4326,10 +4220,10 @@ DictionaryCompare( } /* - * 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. + * 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; @@ -4339,13 +4233,13 @@ DictionaryCompare( } right++; left++; - if (!isdigit(UCHAR(*right))) { /* INTL: digit */ - if (isdigit(UCHAR(*left))) { /* INTL: digit */ + 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. + * The two numbers have the same length. See + * if their values are different. */ if (diff != 0) { @@ -4353,7 +4247,7 @@ DictionaryCompare( } break; } - } else if (!isdigit(UCHAR(*left))) { /* INTL: digit */ + } else if (!isdigit(UCHAR(*left))) { /* INTL: digit */ return -1; } } @@ -4361,7 +4255,7 @@ DictionaryCompare( } /* - * Convert character to Unicode for comparison purposes. If either + * Convert character to Unicode for comparison purposes. If either * string is at the terminating null, do a byte-wise comparison and * bail out immediately. */ @@ -4369,14 +4263,12 @@ DictionaryCompare( 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 + * 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). + * other interesting punctuations occur) */ - uniLeftLower = Tcl_UniCharToLower(uniLeft); uniRightLower = Tcl_UniCharToLower(uniRight); } else { @@ -4384,18 +4276,18 @@ DictionaryCompare( break; } - diff = uniLeftLower - uniRightLower; - if (diff) { + diff = uniLeftLower - uniRightLower; + if (diff) { return diff; - } - if (secondaryDiff == 0) { - if (Tcl_UniCharIsUpper(uniLeft) && Tcl_UniCharIsLower(uniRight)) { + } else 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; @@ -4404,91 +4296,10 @@ DictionaryCompare( } /* - *---------------------------------------------------------------------- - * - * SelectObjFromSublist -- - * - * This procedure is invoked from lsearch and SortCompare. It is used for - * implementing the -index option, for the lsort and lsearch commands. - * - * Results: - * Returns NULL if a failure occurs, and sets the result in the infoPtr. - * Otherwise returns the Tcl_Obj* to the item. - * - * Side effects: - * None. - * - * Note: - * No reference counting is done, as the result is only used internally - * and never passed directly to user code. - * - *---------------------------------------------------------------------- - */ - -static Tcl_Obj * -SelectObjFromSublist( - Tcl_Obj *objPtr, /* Obj to select sublist from. */ - SortInfo *infoPtr) /* Information passed from the top-level - * "lsearch" or "lsort" command. */ -{ - int i; - - /* - * Quick check for case when no "-index" option is there. - */ - - if (infoPtr->indexc == 0) { - return objPtr; - } - - /* - * Iterate over the indices, traversing through the nested sublists as we - * go. - */ - - for (i=0 ; i<infoPtr->indexc ; i++) { - int listLen, index; - Tcl_Obj *currentObj; - - if (TclListObjLength(infoPtr->interp, objPtr, &listLen) != TCL_OK) { - infoPtr->resultCode = TCL_ERROR; - return NULL; - } - index = infoPtr->indexv[i]; - - /* - * Adjust for end-based indexing. - */ - - if (index < SORTIDX_NONE) { - index += listLen + 1; - } - - if (Tcl_ListObjIndex(infoPtr->interp, objPtr, index, - ¤tObj) != TCL_OK) { - infoPtr->resultCode = TCL_ERROR; - return NULL; - } - if (currentObj == NULL) { - Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf( - "element %d missing from sublist \"%s\"", - index, TclGetString(objPtr))); - Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT", - "INDEXFAILED", NULL); - infoPtr->resultCode = TCL_ERROR; - return NULL; - } - objPtr = currentObj; - } - return objPtr; -} - -/* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 - * tab-width: 8 - * indent-tabs-mode: nil * End: */ + |