diff -r 000000000000 -r bde4ae8d615e os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclCmdIL.c --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclCmdIL.c Fri Jun 15 03:10:57 2012 +0200 @@ -0,0 +1,4292 @@ +/* + * tclCmdIL.c -- + * + * This file contains the top-level command routines for most of + * the Tcl built-in commands whose names begin with the letters + * I through L. It contains only commands in the generic core + * (i.e. those that don't depend much upon UNIX facilities). + * + * Copyright (c) 1987-1993 The Regents of the University of California. + * Copyright (c) 1993-1997 Lucent Technologies. + * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 1998-1999 by Scriptics Corporation. + * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id: tclCmdIL.c,v 1.47.2.11 2007/03/10 14:57:38 dkf Exp $ + */ + +#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. + */ + +typedef struct SortElement { + Tcl_Obj *objPtr; /* Object being sorted. */ + int count; /* number of same elements in list */ + struct SortElement *nextPtr; /* Next element in the list, or + * NULL for end of list. */ +} SortElement; + +/* + * 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 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; + +/* + * The "sortMode" field of the SortInfo structure can take on any of the + * following values. + */ + +#define SORTMODE_ASCII 0 +#define SORTMODE_INTEGER 1 +#define SORTMODE_REAL 2 +#define SORTMODE_COMMAND 3 +#define SORTMODE_DICTIONARY 4 + +/* + * Magic values for the index field of the SortInfo structure. + * Note that the index "end-1" will be translated to SORTIDX_END-1, etc. + */ +#define SORTIDX_NONE -1 /* Not indexed; use whole value. */ +#define SORTIDX_END -2 /* Indexed from end. */ + +/* + * Forward declarations for procedures defined in this file: + */ + +static 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 _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + 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. + * + * With the bytecode compiler, this procedure is only called when + * a command name is computed at runtime, and is "if" or the name + * to which "if" was renamed: e.g., "set z if; $z 1 {puts foo}" + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +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. */ +{ + 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) { + missingScript: + clause = Tcl_GetString(objv[i-1]); + Tcl_AppendResult(interp, "wrong # args: no script following \"", + clause, "\" argument", (char *) NULL); + return TCL_ERROR; + } + clause = Tcl_GetString(objv[i]); + if ((i < objc) && (strcmp(clause, "then") == 0)) { + i++; + } + if (i >= objc) { + goto missingScript; + } + if (value) { + thenScriptIndex = i; + value = 0; + } + + /* + * The expression evaluated to false. Skip the command, then + * see if there is an "else" or "elseif" clause. + */ + + i++; + if (i >= objc) { + if (thenScriptIndex) { +#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 = 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. + */ + + if (strcmp(clause, "else") == 0) { + i++; + if (i >= objc) { + 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", + (char *) NULL); + return TCL_ERROR; + } + if (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 + } +#ifndef TCL_TIP280 + return Tcl_EvalObjEx(interp, objv[i], 0); +#else + return TclEvalObjEx(interp, objv[i], 0, iPtr->cmdFramePtr,i); +#endif +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_IncrObjCmd -- + * + * This procedure is invoked to process the "incr" Tcl command. + * See the user documentation for details on what it does. + * + * With the bytecode compiler, this procedure is only called when + * a command name is computed at runtime, and is "incr" or the name + * to which "incr" was renamed: e.g., "set z incr; $z i -1" + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +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. */ +{ + long incrAmount; + Tcl_Obj *newValuePtr; + + if ((objc != 2) && (objc != 3)) { + Tcl_WrongNumArgs(interp, 1, objv, "varName ?increment?"); + return TCL_ERROR; + } + + /* + * Calculate the amount to increment by. + */ + + if (objc == 2) { + incrAmount = 1; + } else { + 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; + } + } + } + + /* + * Increment the variable's value. + */ + + newValuePtr = TclIncrVar2(interp, objv[1], (Tcl_Obj *) NULL, incrAmount, + TCL_LEAVE_ERR_MSG); + if (newValuePtr == NULL) { + return TCL_ERROR; + } + + /* + * Set the interpreter's object result to refer to the variable's new + * value object. + */ + + Tcl_SetObjResult(interp, newValuePtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_InfoObjCmd -- + * + * This procedure is invoked to process the "info" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* 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. */ +{ + 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; +} + +/* + *---------------------------------------------------------------------- + * + * InfoArgsCmd -- + * + * Called to implement the "info args" command that returns the + * argument list for a procedure. Handles the following syntax: + * + * info args procName + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoArgsCmd(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; + char *name; + Proc *procPtr; + CompiledLocal *localPtr; + Tcl_Obj *listObjPtr; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "procname"); + return TCL_ERROR; + } + + name = Tcl_GetString(objv[2]); + procPtr = TclFindProc(iPtr, name); + if (procPtr == NULL) { + 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, (Tcl_Obj **) NULL); + for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; + localPtr = localPtr->nextPtr) { + if (TclIsVarArgument(localPtr)) { + Tcl_ListObjAppendElement(interp, listObjPtr, + Tcl_NewStringObj(localPtr->name, -1)); + } + } + Tcl_SetObjResult(interp, listObjPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InfoBodyCmd -- + * + * Called to implement the "info body" command that returns the body + * for a procedure. Handles the following syntax: + * + * info body procName + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoBodyCmd(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; + char *name; + Proc *procPtr; + Tcl_Obj *bodyPtr, *resultPtr; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "procname"); + return TCL_ERROR; + } + + name = Tcl_GetString(objv[2]); + procPtr = TclFindProc(iPtr, name); + if (procPtr == NULL) { + 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. + */ + + bodyPtr = procPtr->bodyPtr; + if (bodyPtr->bytes == NULL) { + /* + * The string rep might not be valid if the procedure has + * never been run before. [Bug #545644] + */ + (void) Tcl_GetString(bodyPtr); + } + resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length); + + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InfoCmdCountCmd -- + * + * Called to implement the "info cmdcount" command that returns the + * number of commands that have been executed. Handles the following + * syntax: + * + * info cmdcount + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoCmdCountCmd(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 != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + + Tcl_SetIntObj(Tcl_GetObjResult(interp), iPtr->cmdCount); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InfoCommandsCmd -- + * + * Called to implement the "info commands" command that returns the + * list of commands in the interpreter that match an optional pattern. + * The pattern, if any, consists of an optional sequence of namespace + * names separated by "::" qualifiers, which is followed by a + * glob-style pattern that restricts which commands are returned. + * Handles the following syntax: + * + * info commands ?pattern? + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoCommandsCmd(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 *cmdName, *pattern; + CONST char *simplePattern; + register Tcl_HashEntry *entryPtr; + Tcl_HashSearch search; + Namespace *nsPtr; + Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); + Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + Tcl_Obj *listPtr, *elemObjPtr; + int specificNsInPattern = 0; /* Init. to avoid compiler warning. */ + Tcl_Command cmd; + + /* + * Get the pattern and find the "effective namespace" in which to + * list commands. + */ + + 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 commands 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; + } + + /* + * Exit as quickly as possible if we couldn't find the namespace. + */ + + if (nsPtr == NULL) { + return TCL_OK; + } + + /* + * Scan through the effective namespace's command table and create a + * list with all commands that match the pattern. If a specific + * namespace was requested in the pattern, qualify the command names + * with the namespace name. + */ + + listPtr = Tcl_NewListObj(0, (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. + */ + entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern); + if (entryPtr != NULL) { + if (specificNsInPattern) { + cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); + elemObjPtr = Tcl_NewObj(); + Tcl_GetCommandFullName(interp, cmd, elemObjPtr); + } else { + cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); + elemObjPtr = Tcl_NewStringObj(cmdName, -1); + } + Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); + } else if ((nsPtr != globalNsPtr) && !specificNsInPattern) { + entryPtr = Tcl_FindHashEntry(&globalNsPtr->cmdTable, + simplePattern); + if (entryPtr != NULL) { + cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr); + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(cmdName, -1)); + } + } + } else { + entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); + while (entryPtr != NULL) { + cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); + if ((simplePattern == NULL) + || Tcl_StringMatch(cmdName, simplePattern)) { + if (specificNsInPattern) { + cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); + elemObjPtr = Tcl_NewObj(); + Tcl_GetCommandFullName(interp, cmd, elemObjPtr); + } else { + elemObjPtr = Tcl_NewStringObj(cmdName, -1); + } + Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); + } + entryPtr = Tcl_NextHashEntry(&search); + } + + /* + * If the effective namespace isn't the global :: namespace, and a + * specific namespace wasn't requested in the pattern, then add in + * all global :: commands that match the simple pattern. Of course, + * we add in only those commands that aren't hidden by a command in + * the effective namespace. + */ + + if ((nsPtr != globalNsPtr) && !specificNsInPattern) { + entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search); + while (entryPtr != NULL) { + cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr); + if ((simplePattern == NULL) + || Tcl_StringMatch(cmdName, simplePattern)) { + if (Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(cmdName, -1)); + } + } + entryPtr = Tcl_NextHashEntry(&search); + } + } + } + + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InfoCompleteCmd -- + * + * Called to implement the "info complete" command that determines + * whether a string is a complete Tcl command. Handles the following + * syntax: + * + * info complete command + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoCompleteCmd(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 != 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); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InfoDefaultCmd -- + * + * Called to implement the "info default" command that returns the + * default value for a procedure argument. Handles the following + * syntax: + * + * info default procName arg varName + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoDefaultCmd(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 *procName, *argName, *varName; + Proc *procPtr; + CompiledLocal *localPtr; + Tcl_Obj *valueObjPtr; + + if (objc != 5) { + Tcl_WrongNumArgs(interp, 2, objv, "procname arg varname"); + return TCL_ERROR; + } + + procName = Tcl_GetString(objv[2]); + argName = Tcl_GetString(objv[3]); + + procPtr = TclFindProc(iPtr, procName); + if (procPtr == NULL) { + 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) + && (strcmp(argName, localPtr->name) == 0)) { + 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_AppendStringsToObj(Tcl_GetObjResult(interp), + "procedure \"", procName, "\" doesn't have an argument \"", + argName, "\"", (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * InfoExistsCmd -- + * + * 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. + * + *---------------------------------------------------------------------- + */ + +static int +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. */ +{ + char *varName; + Var *varPtr; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "varName"); + return TCL_ERROR; + } + + varName = Tcl_GetString(objv[2]); + varPtr = TclVarTraceExists(interp, varName); + 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: + * + * info frame ?number? + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoFrameCmd(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 == 2) { + /* just "info frame" */ + int levels = (iPtr->cmdFramePtr == NULL + ? 0 + : iPtr->cmdFramePtr->level); + + Tcl_SetIntObj(Tcl_GetObjResult(interp), levels); + return TCL_OK; + + } else if (objc == 3) { + /* "info frame level" */ + int level; + CmdFrame *framePtr; + + 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) { + + if (framePtr->level == level) { + break; + } + } + if (framePtr == NULL) { + goto levelError; + } + + /* + * Pull the information and construct the dictionary to return, as + * list. Regarding use of the CmdFrame fields see tclInt.h, and its + * definition. + */ + + { + 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* typeString [TCL_LOCATION_LAST] = { + "eval", "eval", "eval", "precompiled", "source", "proc" + }; + + 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; + + 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 (framePtr->line[0]); + + /* 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; + + 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; + + case TCL_LOCATION_BC: { + /* Execution of bytecode. Talk to the BC engine to fill out + * the frame. */ + + CmdFrame f = *framePtr; + Proc* procPtr = f.framePtr ? f.framePtr->procPtr : NULL; + + /* Note: Type BC => f.data.eval.path is not used. + * f.data.tebc.codePtr is used instead. + */ + + TclGetSrcInfoForPc (&f); + /* Now filled: cmd.str.(cmd,len), line */ + /* Possibly modified: type, path! */ + + 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]); + + 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); + } + + lv [lc ++] = Tcl_NewStringObj ("cmd",-1); + lv [lc ++] = Tcl_NewStringObj (f.cmd.str.cmd, f.cmd.str.len); + + if (procPtr != NULL) { + Tcl_HashEntry* namePtr = procPtr->cmdPtr->hPtr; + char* procName = Tcl_GetHashKey (namePtr->tablePtr, namePtr); + char* nsName = procPtr->cmdPtr->nsPtr->fullName; + + lv [lc ++] = Tcl_NewStringObj ("proc",-1); + lv [lc ++] = Tcl_NewStringObj (nsName,-1); + + if (strcmp (nsName, "::") != 0) { + Tcl_AppendToObj (lv [lc-1], "::", -1); + } + Tcl_AppendToObj (lv [lc-1], procName, -1); + } + break; + } + + 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; + + case TCL_LOCATION_PROC: + Tcl_Panic ("TCL_LOCATION_PROC found in standard frame"); + break; + } + + + /* 'level'. Common to all frame types. Conditional on having an + * associated _visible_ CallFrame */ + + if ((framePtr->framePtr != NULL) && (iPtr->varFramePtr != NULL)) { + CallFrame* current = framePtr->framePtr; + CallFrame* top = iPtr->varFramePtr; + CallFrame* idx; + + for (idx = top; + idx != NULL; + idx = idx->callerVarPtr) { + if (idx == current) { + int c = framePtr->framePtr->level; + int t = iPtr->varFramePtr->level; + + lv [lc ++] = Tcl_NewStringObj ("level",-1); + lv [lc ++] = Tcl_NewIntObj (t - c); + break; + } + } + } + + Tcl_SetObjResult(interp, Tcl_NewListObj (lc, lv)); + return TCL_OK; + } + } + + Tcl_WrongNumArgs(interp, 2, objv, "?number?"); + + 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. + * + *---------------------------------------------------------------------- + */ + +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; + + if (objc == 2) { + pattern = NULL; + } else if (objc == 3) { + pattern = Tcl_GetString(objv[2]); + } else { + Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + return TCL_ERROR; + } + + listPtr = Tcl_ListMathFuncs(interp, pattern); + if (listPtr == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InfoGlobalsCmd -- + * + * Called to implement the "info globals" command that returns the list + * of global variables matching an optional pattern. Handles the + * following syntax: + * + * info globals ?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 +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. */ +{ + char *varName, *pattern; + Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); + register Tcl_HashEntry *entryPtr; + Tcl_HashSearch search; + Var *varPtr; + Tcl_Obj *listPtr; + + 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, 2, objv, "?pattern?"); + return TCL_ERROR; + } + + /* + * 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; +} + +/* + *---------------------------------------------------------------------- + * + * InfoHostnameCmd -- + * + * Called to implement the "info hostname" command that returns the + * host name. Handles the following syntax: + * + * info hostname + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoHostnameCmd(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 != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + + name = Tcl_GetHostName(); + if (name) { + 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; + } +} + +/* + *---------------------------------------------------------------------- + * + * InfoLevelCmd -- + * + * Called to implement the "info level" command that returns + * information about the call stack. Handles the following syntax: + * + * info level ?number? + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoLevelCmd(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 == 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; + } + + listPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv); + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; + } + + Tcl_WrongNumArgs(interp, 2, objv, "?number?"); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * InfoLibraryCmd -- + * + * Called to implement the "info library" command that returns the + * library directory for the Tcl installation. Handles the following + * syntax: + * + * info library + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoLibraryCmd(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; + + 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_SetStringObj(Tcl_GetObjResult(interp), libDirName, -1); + return TCL_OK; + } + Tcl_SetStringObj(Tcl_GetObjResult(interp), + "no library has been specified for Tcl", -1); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * InfoLoadedCmd -- + * + * Called to implement the "info loaded" command that returns the + * packages that have been loaded into an interpreter. Handles the + * following syntax: + * + * info loaded ?interp? + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoLoadedCmd(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 *interpName; + int result; + + if ((objc != 2) && (objc != 3)) { + Tcl_WrongNumArgs(interp, 2, objv, "?interp?"); + return TCL_ERROR; + } + + if (objc == 2) { /* get loaded pkgs in all interpreters */ + interpName = NULL; + } 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)); + } + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * InfoNameOfExecutableCmd -- + * + * Called to implement the "info nameofexecutable" command that returns + * the name of the binary file running this application. Handles the + * following syntax: + * + * info nameofexecutable + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoNameOfExecutableCmd(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 *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); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InfoPatchLevelCmd -- + * + * Called to implement the "info patchlevel" command that returns the + * default value for an argument to a procedure. Handles the following + * syntax: + * + * info patchlevel + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoPatchLevelCmd(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; + + 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)); + if (patchlevel != NULL) { + Tcl_SetStringObj(Tcl_GetObjResult(interp), patchlevel, -1); + return TCL_OK; + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * InfoProcsCmd -- + * + * Called to implement the "info procs" command that returns the + * list of procedures in the interpreter that match an optional pattern. + * The pattern, if any, consists of an optional sequence of namespace + * names separated by "::" qualifiers, which is followed by a + * glob-style pattern that restricts which commands are returned. + * Handles the following syntax: + * + * info procs ?pattern? + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoProcsCmd(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 *cmdName, *pattern; + CONST char *simplePattern; + Namespace *nsPtr; +#ifdef INFO_PROCS_SEARCH_GLOBAL_NS + Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); +#endif + Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + Tcl_Obj *listPtr, *elemObjPtr; + int specificNsInPattern = 0; /* Init. to avoid compiler warning. */ + register Tcl_HashEntry *entryPtr; + Tcl_HashSearch search; + Command *cmdPtr, *realCmdPtr; + + /* + * Get the pattern and find the "effective namespace" in which to + * list procs. + */ + + if (objc == 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 commands 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 (nsPtr == NULL) { + return TCL_OK; + } + + /* + * Scan through the effective namespace's command table and create a + * list with all procs that match the pattern. If a specific + * namespace was requested in the pattern, qualify the command names + * with the namespace name. + */ + + listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); +#ifndef INFO_PROCS_SEARCH_GLOBAL_NS + if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) { + entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern); + if (entryPtr != NULL) { + cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); + + if (!TclIsProc(cmdPtr)) { + realCmdPtr = (Command *) + TclGetOriginalCommand((Tcl_Command) cmdPtr); + if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) { + goto simpleProcOK; + } + } else { + simpleProcOK: + if (specificNsInPattern) { + elemObjPtr = Tcl_NewObj(); + Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, + elemObjPtr); + } else { + elemObjPtr = Tcl_NewStringObj(simplePattern, -1); + } + Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); + } + } + } else +#endif /* !INFO_PROCS_SEARCH_GLOBAL_NS */ + { + entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); + while (entryPtr != NULL) { + cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); + if ((simplePattern == NULL) + || Tcl_StringMatch(cmdName, simplePattern)) { + cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); + + if (!TclIsProc(cmdPtr)) { + realCmdPtr = (Command *) + TclGetOriginalCommand((Tcl_Command) cmdPtr); + if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) { + goto procOK; + } + } else { + procOK: + if (specificNsInPattern) { + elemObjPtr = Tcl_NewObj(); + Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, + elemObjPtr); + } else { + elemObjPtr = Tcl_NewStringObj(cmdName, -1); + } + Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); + } + } + entryPtr = Tcl_NextHashEntry(&search); + } + + /* + * If the effective namespace isn't the global :: namespace, and a + * specific namespace wasn't requested in the pattern, then add in + * all global :: procs that match the simple pattern. Of course, + * we add in only those procs that aren't hidden by a proc in + * the effective namespace. + */ + +#ifdef INFO_PROCS_SEARCH_GLOBAL_NS + /* + * If "info procs" worked like "info commands", returning the + * commands also seen in the global namespace, then you would + * include this code. As this could break backwards compatibilty + * with 8.0-8.2, we decided not to "fix" it in 8.3, leaving the + * behavior slightly different. + */ + if ((nsPtr != globalNsPtr) && !specificNsInPattern) { + entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search); + while (entryPtr != NULL) { + cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr); + if ((simplePattern == NULL) + || Tcl_StringMatch(cmdName, simplePattern)) { + if (Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) { + cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); + realCmdPtr = (Command *) TclGetOriginalCommand( + (Tcl_Command) cmdPtr); + + if (TclIsProc(cmdPtr) || ((realCmdPtr != NULL) + && TclIsProc(realCmdPtr))) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(cmdName, -1)); + } + } + } + entryPtr = Tcl_NextHashEntry(&search); + } + } +#endif + } + + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InfoScriptCmd -- + * + * Called to implement the "info script" command that returns the + * script file that is currently being evaluated. Handles the + * following syntax: + * + * info script ?newName? + * + * If newName is specified, it will set that as the internal name. + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. It may change the + * internal script filename. + * + *---------------------------------------------------------------------- + */ + +static int +InfoScriptCmd(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 != 2) && (objc != 3)) { + Tcl_WrongNumArgs(interp, 2, objv, "?filename?"); + return TCL_ERROR; + } + + if (objc == 3) { + if (iPtr->scriptFile != NULL) { + Tcl_DecrRefCount(iPtr->scriptFile); + } + iPtr->scriptFile = objv[2]; + Tcl_IncrRefCount(iPtr->scriptFile); + } + if (iPtr->scriptFile != NULL) { + Tcl_SetObjResult(interp, iPtr->scriptFile); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InfoSharedlibCmd -- + * + * Called to implement the "info sharedlibextension" command that + * returns the file extension used for shared libraries. Handles the + * following syntax: + * + * info sharedlibextension + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoSharedlibCmd(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, 2, objv, NULL); + return TCL_ERROR; + } + +#ifdef TCL_SHLIB_EXT + Tcl_SetStringObj(Tcl_GetObjResult(interp), TCL_SHLIB_EXT, -1); +#endif + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InfoTclVersionCmd -- + * + * Called to implement the "info tclversion" command that returns the + * version number for this Tcl library. Handles the following syntax: + * + * info tclversion + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoTclVersionCmd(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 *version; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + + version = Tcl_GetVar(interp, "tcl_version", + (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); + if (version != NULL) { + Tcl_SetStringObj(Tcl_GetObjResult(interp), version, -1); + return TCL_OK; + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * 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. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +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. */ +{ + char *joinString, *bytes; + int joinLength, listLen, length, i, result; + Tcl_Obj **elemPtrs; + Tcl_Obj *resObjPtr; + + 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. + */ + + result = Tcl_ListObjGetElements(interp, objv[1], &listLen, &elemPtrs); + if (result != TCL_OK) { + return result; + } + + /* + * Now concatenate strings to form the "joined" result. We append + * directly into the interpreter's result object. + */ + + resObjPtr = Tcl_GetObjResult(interp); + + for (i = 0; i < listLen; i++) { + bytes = Tcl_GetStringFromObj(elemPtrs[i], &length); + if (i > 0) { + Tcl_AppendToObj(resObjPtr, joinString, joinLength); + } + Tcl_AppendToObj(resObjPtr, bytes, length); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LindexObjCmd -- + * + * This object-based procedure is invoked to process the "lindex" Tcl + * command. See the user documentation for details on what it does. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +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 *elemPtr; /* Pointer to the element being extracted */ + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "list ?index...?"); + return TCL_ERROR; + } + + /* + * If objc == 3, then objv[ 2 ] may be either a single index or + * a list of indices: go to TclLindexList to determine which. + * If objc >= 4, or objc == 2, then objv[ 2 .. objc-2 ] are all + * single indices and processed as such in TclLindexFlat. + */ + + if ( objc == 3 ) { + + elemPtr = TclLindexList( interp, objv[ 1 ], objv[ 2 ] ); + + } else { + + elemPtr = TclLindexFlat( interp, objv[ 1 ], objc-2, objv+2 ); + + } + + /* + * Set the interpreter's object result to the last element extracted + */ + + if ( elemPtr == NULL ) { + return TCL_ERROR; + } 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 */ +{ + + 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 */ + + /* + * 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 ); + } + + /* + * 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; + + } 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; + } + } + + /* + * 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 */ + + /* + * Return the last object extracted. Its reference count will include + * the reference being returned. + */ + + return listPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclLindexFlat -- + * + * This procedure handles the 'lindex' command, given that the + * arguments to the command are known to be a flat list. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * 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. + * + *---------------------------------------------------------------------- + */ + +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 */ +{ + + 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. */ + + /* + * Record the reference to the 'listPtr' object that we are + * maintaining in the C activation record. + */ + + Tcl_IncrRefCount( listPtr ); + + 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 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 ); + + } + + return listPtr; + +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LinsertObjCmd -- + * + * This object-based procedure is invoked to process the "linsert" Tcl + * command. See the user documentation for details on what it does. + * + * Results: + * A new Tcl list object formed by inserting zero or more elements + * into a list. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +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, isDuplicate, len, result; + + if (objc < 4) { + Tcl_WrongNumArgs(interp, 1, objv, "list index element ?element ...?"); + return TCL_ERROR; + } + + 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 + * element, such that using it will cause any inserted elements to be + * appended to the list. + */ + + result = TclGetIntForIndex(interp, objv[2], /*end*/ len, &index); + if (result != TCL_OK) { + return result; + } + if (index > len) { + index = len; + } + + /* + * If the list object is unshared we can modify it directly. Otherwise + * we create a copy to modify: this is "copy on write". + */ + + listPtr = objv[1]; + isDuplicate = 0; + if (Tcl_IsShared(listPtr)) { + listPtr = Tcl_DuplicateObj(listPtr); + isDuplicate = 1; + } + + if ((objc == 4) && (index == len)) { + /* + * Special case: insert one element at the end of the list. + */ + 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. + */ + + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ListObjCmd -- + * + * This procedure is invoked to process the "list" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +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 modify the interpreter's result object to be a list object. + */ + + if (objc > 1) { + Tcl_SetListObj(Tcl_GetObjResult(interp), (objc-1), &(objv[1])); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LlengthObjCmd -- + * + * This object-based procedure is invoked to process the "llength" Tcl + * command. See the user documentation for details on what it does. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +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; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "list"); + return TCL_ERROR; + } + + 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. + */ + + Tcl_SetIntObj(Tcl_GetObjResult(interp), listLen); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LrangeObjCmd -- + * + * This procedure is invoked to process the "lrange" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +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, numElems, result; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "list first last"); + 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. + */ + + listPtr = objv[1]; + result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs); + if (result != TCL_OK) { + return result; + } + + /* + * Get the first and last indexes. + */ + + result = TclGetIntForIndex(interp, objv[2], /*endValue*/ (listLen - 1), + &first); + if (result != TCL_OK) { + return result; + } + if (first < 0) { + first = 0; + } + + result = TclGetIntForIndex(interp, objv[3], /*endValue*/ (listLen - 1), + &last); + if (result != TCL_OK) { + return result; + } + if (last >= listLen) { + last = (listLen - 1); + } + + if (first > last) { + return TCL_OK; /* the result is an empty object */ + } + + /* + * 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; + } + } + + /* + * Extract a range of fields. We modify the interpreter's result object + * to be a list object containing the specified elements. + */ + + numElems = (last - first + 1); + Tcl_SetListObj(Tcl_GetObjResult(interp), numElems, &(elemPtrs[first])); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LreplaceObjCmd -- + * + * This object-based procedure is invoked to process the "lreplace" + * Tcl command. See the user documentation for details on what it does. + * + * Results: + * A new Tcl list object formed by replacing zero or more elements of + * a list. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +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 isDuplicate, first, last, listLen, numToDelete, result; + + if (objc < 4) { + Tcl_WrongNumArgs(interp, 1, objv, + "list first last ?element element ...?"); + return TCL_ERROR; + } + + 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. + */ + + result = TclGetIntForIndex(interp, objv[2], /*end*/ (listLen - 1), &first); + if (result != TCL_OK) { + return result; + } + + result = TclGetIntForIndex(interp, objv[3], /*end*/ (listLen - 1), &last); + if (result != TCL_OK) { + return result; + } + + if (first < 0) { + first = 0; + } + + /* + * Complain if the user asked for a start element that is greater than the + * list length. This won't ever trigger for the "end*" case as that will + * be properly constrained by TclGetIntForIndex because we use listLen-1 + * (to allow for replacing the last elem). + */ + + if ((first >= listLen) && (listLen > 0)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "list doesn't contain element ", + Tcl_GetString(objv[2]), (int *) NULL); + return TCL_ERROR; + } + if (last >= listLen) { + last = (listLen - 1); + } + if (first <= last) { + numToDelete = (last - first + 1); + } else { + numToDelete = 0; + } + + /* + * If the list object is unshared we can modify it directly, otherwise + * we create a copy to modify: this is "copy on write". + */ + + listPtr = objv[1]; + isDuplicate = 0; + if (Tcl_IsShared(listPtr)) { + listPtr = Tcl_DuplicateObj(listPtr); + isDuplicate = 1; + } + 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 (result != TCL_OK) { + if (isDuplicate) { + Tcl_DecrRefCount(listPtr); /* free unneeded obj */ + } + return result; + } + + /* + * Set the interpreter's object result. + */ + + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LsearchObjCmd -- + * + * This procedure is invoked to process the "lsearch" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_LsearchObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument values. */ +{ + 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; + Tcl_Obj *patObj, **listv, *listPtr, *startPtr; + Tcl_RegExp regexp = 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_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 + }; + enum modes { + EXACT, GLOB, REGEXP, SORTED + }; + + mode = GLOB; + dataType = ASCII; + isIncreasing = 1; + allMatches = 0; + inlineReturn = 0; + negatedMatch = 0; + listPtr = NULL; + startPtr = NULL; + offset = 0; + + if (objc < 3) { + 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) { + Tcl_DecrRefCount(startPtr); + } + return TCL_ERROR; + } + switch ((enum options) index) { + case LSEARCH_ALL: /* -all */ + allMatches = 1; + break; + case LSEARCH_ASCII: /* -ascii */ + dataType = ASCII; + break; + case LSEARCH_DECREASING: /* -decreasing */ + isIncreasing = 0; + break; + case LSEARCH_DICTIONARY: /* -dictionary */ + dataType = DICTIONARY; + break; + case LSEARCH_EXACT: /* -increasing */ + mode = EXACT; + break; + case LSEARCH_GLOB: /* -glob */ + mode = GLOB; + break; + case LSEARCH_INCREASING: /* -increasing */ + isIncreasing = 1; + break; + case LSEARCH_INLINE: /* -inline */ + inlineReturn = 1; + break; + case LSEARCH_INTEGER: /* -integer */ + dataType = INTEGER; + break; + case LSEARCH_NOT: /* -not */ + negatedMatch = 1; + break; + case LSEARCH_REAL: /* -real */ + dataType = REAL; + break; + case LSEARCH_REGEXP: /* -regexp */ + mode = REGEXP; + break; + case LSEARCH_SORTED: /* -sorted */ + mode = SORTED; + break; + case LSEARCH_START: /* -start */ + /* + * If there was a previous -start option, release its saved + * index because it will either be replaced or there will be + * an error. + */ + if (startPtr) { + Tcl_DecrRefCount(startPtr); + } + if (i > objc-4) { + Tcl_AppendResult(interp, "missing starting index", NULL); + 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. + */ + startPtr = Tcl_DuplicateObj(objv[i]); + } else { + startPtr = objv[i]; + Tcl_IncrRefCount(startPtr); + } + } + } + + 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. + */ + + regexp = Tcl_GetRegExpFromObj(NULL, objv[objc - 1], + 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. + */ + + regexp = Tcl_GetRegExpFromObj(interp, objv[objc - 1], + TCL_REG_ADVANCED); + } + + if (regexp == NULL) { + if (startPtr) { + Tcl_DecrRefCount(startPtr); + } + 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. + */ + + result = Tcl_ListObjGetElements(interp, objv[objc - 2], &listc, &listv); + if (result != TCL_OK) { + if (startPtr) { + Tcl_DecrRefCount(startPtr); + } + return result; + } + + /* + * Get the user-specified start offset. + */ + if (startPtr) { + result = TclGetIntForIndex(interp, startPtr, listc-1, &offset); + Tcl_DecrRefCount(startPtr); + if (result != TCL_OK) { + return result; + } + + /* + * If the search started past the end of the list, we just return a + * "did not match anything at all" result straight away. [Bug 1374778] + */ + + if (offset > listc-1) { + if (allMatches || inlineReturn) { + Tcl_ResetResult(interp); + } else { + Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); + } + return TCL_OK; + } + if (offset < 0) { + offset = 0; + } + } + + patObj = objv[objc - 1]; + patternBytes = NULL; + if ((enum modes) mode == EXACT || (enum modes) mode == SORTED) { + switch ((enum datatypes) dataType) { + case ASCII: + case DICTIONARY: + patternBytes = Tcl_GetStringFromObj(patObj, &length); + break; + case INTEGER: + result = Tcl_GetIntFromObj(interp, patObj, &patInt); + if (result != TCL_OK) { + return result; + } + break; + case REAL: + result = Tcl_GetDoubleFromObj(interp, patObj, &patDouble); + if (result != TCL_OK) { + return result; + } + break; + } + } else { + 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. + */ + index = -1; + match = 0; + + 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. + */ + lower = offset - 1; + upper = listc; + while (lower + 1 != upper) { + i = (lower + upper)/2; + switch ((enum datatypes) dataType) { + case ASCII: + bytes = Tcl_GetString(listv[i]); + match = strcmp(patternBytes, bytes); + break; + case DICTIONARY: + bytes = Tcl_GetString(listv[i]); + match = DictionaryCompare(patternBytes, bytes); + break; + case INTEGER: + result = Tcl_GetIntFromObj(interp, listv[i], &objInt); + if (result != TCL_OK) { + return result; + } + if (patInt == objInt) { + match = 0; + } else if (patInt < objInt) { + match = -1; + } else { + match = 1; + } + break; + case REAL: + result = Tcl_GetDoubleFromObj(interp, listv[i], &objDouble); + if (result != TCL_OK) { + return result; + } + if (patDouble == objDouble) { + match = 0; + } else if (patDouble < objDouble) { + match = -1; + } else { + match = 1; + } + break; + } + if (match == 0) { + /* + * Normally, binary search is written to stop when it + * finds a match. If there are duplicates of an element in + * the list, our first match might not be the first occurance. + * Consider: 0 0 0 1 1 1 2 2 2 + * To maintain consistancy with standard lsearch semantics, + * we must find the leftmost occurance of the pattern in the + * list. Thus we don't just stop searching here. This + * variation means that a search always makes log n + * comparisons (normal binary search might "get lucky" with + * an early comparison). + */ + index = i; + upper = i; + } else if (match > 0) { + if (isIncreasing) { + lower = i; + } else { + upper = i; + } + } else { + if (isIncreasing) { + upper = i; + } else { + lower = i; + } + } + } + + } else { + /* + * We need to do a linear search, because (at least one) of: + * - our matcher can only tell equal vs. not equal + * - our matching sense is negated + * - we're building a list of all matched items + */ + if (allMatches) { + listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + } + for (i = offset; i < listc; i++) { + match = 0; + switch ((enum modes) mode) { + case SORTED: + case EXACT: + switch ((enum datatypes) dataType) { + case ASCII: + bytes = Tcl_GetStringFromObj(listv[i], &elemLen); + if (length == elemLen) { + match = (memcmp(bytes, patternBytes, + (size_t) length) == 0); + } + break; + case DICTIONARY: + bytes = Tcl_GetString(listv[i]); + match = (DictionaryCompare(bytes, patternBytes) == 0); + break; + case INTEGER: + result = Tcl_GetIntFromObj(interp, listv[i], &objInt); + if (result != TCL_OK) { + if (listPtr) { + Tcl_DecrRefCount(listPtr); + } + return result; + } + match = (objInt == patInt); + break; + case REAL: + result = Tcl_GetDoubleFromObj(interp, listv[i], + &objDouble); + if (result != TCL_OK) { + if (listPtr) { + Tcl_DecrRefCount(listPtr); + } + return result; + } + match = (objDouble == patDouble); + break; + } + break; + case GLOB: + match = Tcl_StringMatch(Tcl_GetString(listv[i]), + patternBytes); + break; + case REGEXP: + match = Tcl_RegExpExecObj(interp, regexp, listv[i], 0, 0, 0); + if (match < 0) { + Tcl_DecrRefCount(patObj); + if (listPtr) { + Tcl_DecrRefCount(listPtr); + } + return TCL_ERROR; + } + break; + } + /* + * Invert match condition for -not + */ + if (negatedMatch) { + match = !match; + } + if (match != 0) { + if (!allMatches) { + index = i; + break; + } else if (inlineReturn) { + /* + * Note that these appends are not expected to fail. + */ + Tcl_ListObjAppendElement(interp, listPtr, listv[i]); + } else { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewIntObj(i)); + } + } + } + } + + /* + * Return everything or a single value. + */ + if (allMatches) { + Tcl_SetObjResult(interp, listPtr); + } else if (!inlineReturn) { + Tcl_SetIntObj(Tcl_GetObjResult(interp), index); + } else if (index < 0) { + /* + * Is this superfluous? The result should be a blank object + * by default... + */ + Tcl_SetObjResult(interp, Tcl_NewObj()); + } else { + Tcl_SetObjResult(interp, listv[index]); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LsetObjCmd -- + * + * This procedure is invoked to process the "lset" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_LsetObjCmd( clientData, 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 */ + + if ( objc < 3 ) { + Tcl_WrongNumArgs( interp, 1, objv, "listVar index ?index...? value" ); + return TCL_ERROR; + } + + /* Look up the list variable's value */ + + listPtr = Tcl_ObjGetVar2( interp, objv[ 1 ], (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. + */ + + if ( objc == 4 ) { + finalValuePtr = TclLsetList( interp, listPtr, + objv[ 2 ], objv[ 3 ] ); + } else { + finalValuePtr = TclLsetFlat( interp, listPtr, + objc-3, objv+2, objv[ objc-1 ] ); + } + + /* + * If substitution has failed, bail out. + */ + + if ( finalValuePtr == NULL ) { + return TCL_ERROR; + } + + /* Finally, update the variable so that traces fire. */ + + listPtr = Tcl_ObjSetVar2( interp, objv[1], NULL, finalValuePtr, + TCL_LEAVE_ERR_MSG ); + Tcl_DecrRefCount( finalValuePtr ); + if ( listPtr == NULL ) { + return TCL_ERROR; + } + + /* Return the new value of the variable as the interpreter result. */ + + Tcl_SetObjResult( interp, listPtr ); + return TCL_OK; + +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LsortObjCmd -- + * + * This procedure is invoked to process the "lsort" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_LsortObjCmd(clientData, 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, 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", "-integer", "-real", "-unique", (char *) NULL + }; + + resultPtr = Tcl_GetObjResult(interp); + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?options? list"); + return TCL_ERROR; + } + + /* + * Parse arguments to set up the mode for the sort. + */ + + sortInfo.isIncreasing = 1; + sortInfo.sortMode = SORTMODE_ASCII; + sortInfo.index = SORTIDX_NONE; + sortInfo.interp = interp; + sortInfo.resultCode = TCL_OK; + cmdPtr = NULL; + unique = 0; + for (i = 1; i < objc-1; i++) { + if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, &index) + != TCL_OK) { + return TCL_ERROR; + } + 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; + } + 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 (sortInfo.sortMode == SORTMODE_COMMAND) { + /* + * The existing command is a list. We want to flatten it, append + * two dummy arguments on the end, and replace these arguments + * later. + */ + + Tcl_Obj *newCommandPtr = Tcl_DuplicateObj(cmdPtr); + Tcl_Obj *newObjPtr = Tcl_NewObj(); + + Tcl_IncrRefCount(newCommandPtr); + if (Tcl_ListObjAppendElement(interp, newCommandPtr, newObjPtr) + != TCL_OK) { + Tcl_DecrRefCount(newCommandPtr); + Tcl_IncrRefCount(newObjPtr); + Tcl_DecrRefCount(newObjPtr); + return TCL_ERROR; + } + Tcl_ListObjAppendElement(interp, newCommandPtr, Tcl_NewObj()); + sortInfo.compareCmdPtr = newCommandPtr; + } + + 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]; + + /* + * 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] + */ + + Tcl_IncrRefCount(elementArray[i].objPtr); + } + elementArray[length-1].nextPtr = NULL; + elementPtr = MergeSort(elementArray, &sortInfo); + if (sortInfo.resultCode == TCL_OK) { + /* + * Note: must clear the interpreter's result object: it could + * have been set by the -command script. + */ + + 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); + } + } + } else { + for (; elementPtr != NULL; elementPtr = elementPtr->nextPtr){ + Tcl_ListObjAppendElement(interp, resultPtr, + elementPtr->objPtr); + } + } + } + for (i=0; inextPtr; + 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; + } + elementPtr = NULL; + for (i = 0; i < NUM_LISTS; i++){ + elementPtr = MergeLists(subList[i], elementPtr, infoPtr); + } + return elementPtr; +} + +/* + *---------------------------------------------------------------------- + * + * MergeLists - + * + * This procedure combines two sorted lists of SortElement structures + * into a single sorted list. + * + * Results: + * The unified list of SortElement structures. + * + * Side effects: + * None, unless a user-defined comparison command does something + * weird. + * + *---------------------------------------------------------------------- + */ + +static SortElement * +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; + SortElement *tailPtr; + int cmp; + + if (leftPtr == NULL) { + return rightPtr; + } + if (rightPtr == NULL) { + return leftPtr; + } + 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; + 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; + } else { + tailPtr->nextPtr = rightPtr; + } + return headPtr; +} + +/* + *---------------------------------------------------------------------- + * + * SortCompare -- + * + * This procedure is invoked by MergeLists to determine the proper + * ordering between two elements. + * + * Results: + * A negative results means the the first element comes before the + * second, and a positive results means that the second element + * should come first. A result of zero means the two elements + * are equal and it doesn't matter which comes first. + * + * Side effects: + * None, unless a user-defined comparison command does something + * weird. + * + *---------------------------------------------------------------------- + */ + +static int +SortCompare(objPtr1, objPtr2, infoPtr) + Tcl_Obj *objPtr1, *objPtr2; /* Values to be compared. */ + SortInfo *infoPtr; /* Information passed from the + * top-level "lsort" command */ +{ + 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(Tcl_GetString(objPtr1), Tcl_GetString(objPtr2)); + } else if (infoPtr->sortMode == SORTMODE_DICTIONARY) { + order = DictionaryCompare( + Tcl_GetString(objPtr1), Tcl_GetString(objPtr2)); + } else if (infoPtr->sortMode == SORTMODE_INTEGER) { + long 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; + + 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; + + 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. + */ + + Tcl_ListObjLength(infoPtr->interp, infoPtr->compareCmdPtr, &objc); + Tcl_ListObjReplace(infoPtr->interp, infoPtr->compareCmdPtr, objc - 2, + 2, 2, paramObjv); + 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 order; + } + + /* + * Parse the result of the command. + */ + + if (Tcl_GetIntFromObj(infoPtr->interp, + Tcl_GetObjResult(infoPtr->interp), &order) != TCL_OK) { + Tcl_ResetResult(infoPtr->interp); + Tcl_AppendToObj(Tcl_GetObjResult(infoPtr->interp), + "-compare command returned non-integer result", -1); + infoPtr->resultCode = TCL_ERROR; + return order; + } + } + if (!infoPtr->isIncreasing) { + order = -order; + } + return order; +} + +/* + *---------------------------------------------------------------------- + * + * DictionaryCompare + * + * This function compares two strings as if they were being used in + * an index or card catalog. The case of alphabetic characters is + * ignored, except to break ties. Thus "B" comes before "b" but + * after "a". Also, integers embedded in the strings compare in + * numerical order. In other words, "x10y" comes after "x9y", not + * before it as it would when using strcmp(). + * + * Results: + * A negative result means that the first element comes before the + * second, and a positive result means that the second element + * should come first. A result of zero means the two elements + * are equal and it doesn't matter which comes first. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +DictionaryCompare(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 */ + /* + * There are decimal numbers embedded in the two + * strings. Compare them as numbers, rather than + * strings. If one number has more leading zeros than + * the other, the number with more leading zeros sorts + * later, but only as a secondary choice. + */ + + zeros = 0; + while ((*right == '0') && (isdigit(UCHAR(right[1])))) { + right++; + zeros--; + } + while ((*left == '0') && (isdigit(UCHAR(left[1])))) { + left++; + zeros++; + } + if (secondaryDiff == 0) { + secondaryDiff = zeros; + } + + /* + * The code below compares the numbers in the two + * strings without ever converting them to integers. It + * does this by first comparing the lengths of the + * numbers and then comparing the digit values. + */ + + diff = 0; + while (1) { + if (diff == 0) { + diff = UCHAR(*left) - UCHAR(*right); + } + right++; + left++; + if (!isdigit(UCHAR(*right))) { /* INTL: digit */ + if (isdigit(UCHAR(*left))) { /* INTL: digit */ + return 1; + } else { + /* + * The two numbers have the same length. See + * if their values are different. + */ + + if (diff != 0) { + return diff; + } + break; + } + } else if (!isdigit(UCHAR(*left))) { /* INTL: digit */ + return -1; + } + } + continue; + } + + /* + * Convert character to Unicode for comparison purposes. If either + * string is at the terminating null, do a byte-wise comparison and + * bail out immediately. + */ + + if ((*left != '\0') && (*right != '\0')) { + left += Tcl_UtfToUniChar(left, &uniLeft); + right += Tcl_UtfToUniChar(right, &uniRight); + /* + * Convert both chars to lower for the comparison, because + * dictionary sorts are case insensitve. Covert to lower, not + * upper, so chars between Z and a will sort before A (where most + * other interesting punctuations occur) + */ + uniLeftLower = Tcl_UniCharToLower(uniLeft); + uniRightLower = Tcl_UniCharToLower(uniRight); + } else { + diff = UCHAR(*left) - UCHAR(*right); + break; + } + + diff = uniLeftLower - uniRightLower; + if (diff) { + return diff; + } 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; + } + return diff; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ +