/* * 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.7 2005/10/23 22:01:29 msofer 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[])); 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 */ 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) { return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0); } 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) { return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0); } return Tcl_EvalObjEx(interp, objv[i], 0); } /* *---------------------------------------------------------------------- * * 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", "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, 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; 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; } /* *---------------------------------------------------------------------- * * 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. */ regexp = Tcl_GetRegExpFromObj(interp, objv[objc - 1], TCL_REG_ADVANCED | TCL_REG_NOSUB); 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 (offset > listc-1) { offset = listc-1; } 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]; } 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); } } } ckfree((char*) elementArray); done: if (sortInfo.sortMode == SORTMODE_COMMAND) { Tcl_DecrRefCount(sortInfo.compareCmdPtr); sortInfo.compareCmdPtr = NULL; } return sortInfo.resultCode; } /* *---------------------------------------------------------------------- * * MergeSort - * * This procedure sorts a linked list of SortElement structures * use the merge-sort algorithm. * * Results: * A pointer to the head of the list after sorting is returned. * * Side effects: * None, unless a user-defined comparison command does something * weird. * *---------------------------------------------------------------------- */ static SortElement * MergeSort(headPtr, infoPtr) SortElement *headPtr; /* First element on the list */ SortInfo *infoPtr; /* Information needed by the * comparison operator */ { /* * The subList array below holds pointers to temporary lists built * during the merge sort. Element i of the array holds a list of * length 2**i. */ # define NUM_LISTS 30 SortElement *subList[NUM_LISTS]; SortElement *elementPtr; int i; for(i = 0; i < NUM_LISTS; i++){ subList[i] = NULL; } while (headPtr != NULL) { elementPtr = headPtr; headPtr = headPtr->nextPtr; elementPtr->nextPtr = 0; for (i = 0; (i < NUM_LISTS) && (subList[i] != NULL); i++){ elementPtr = MergeLists(subList[i], elementPtr, infoPtr); subList[i] = NULL; } if (i >= NUM_LISTS) { i = NUM_LISTS-1; } subList[i] = elementPtr; } 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; }