sl@0: /* sl@0: * tclCmdIL.c -- sl@0: * sl@0: * This file contains the top-level command routines for most of sl@0: * the Tcl built-in commands whose names begin with the letters sl@0: * I through L. It contains only commands in the generic core sl@0: * (i.e. those that don't depend much upon UNIX facilities). sl@0: * sl@0: * Copyright (c) 1987-1993 The Regents of the University of California. sl@0: * Copyright (c) 1993-1997 Lucent Technologies. sl@0: * Copyright (c) 1994-1997 Sun Microsystems, Inc. sl@0: * Copyright (c) 1998-1999 by Scriptics Corporation. sl@0: * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. sl@0: * sl@0: * See the file "license.terms" for information on usage and redistribution sl@0: * of this file, and for a DISCLAIMER OF ALL WARRANTIES. sl@0: * sl@0: * RCS: @(#) $Id: tclCmdIL.c,v 1.47.2.11 2007/03/10 14:57:38 dkf Exp $ sl@0: */ sl@0: sl@0: #include "tclInt.h" sl@0: #include "tclPort.h" sl@0: #include "tclRegexp.h" sl@0: sl@0: /* sl@0: * During execution of the "lsort" command, structures of the following sl@0: * type are used to arrange the objects being sorted into a collection sl@0: * of linked lists. sl@0: */ sl@0: sl@0: typedef struct SortElement { sl@0: Tcl_Obj *objPtr; /* Object being sorted. */ sl@0: int count; /* number of same elements in list */ sl@0: struct SortElement *nextPtr; /* Next element in the list, or sl@0: * NULL for end of list. */ sl@0: } SortElement; sl@0: sl@0: /* sl@0: * The "lsort" command needs to pass certain information down to the sl@0: * function that compares two list elements, and the comparison function sl@0: * needs to pass success or failure information back up to the top-level sl@0: * "lsort" command. The following structure is used to pass this sl@0: * information. sl@0: */ sl@0: sl@0: typedef struct SortInfo { sl@0: int isIncreasing; /* Nonzero means sort in increasing order. */ sl@0: int sortMode; /* The sort mode. One of SORTMODE_* sl@0: * values defined below */ sl@0: Tcl_Obj *compareCmdPtr; /* The Tcl comparison command when sortMode sl@0: * is SORTMODE_COMMAND. Pre-initialized to sl@0: * hold base of command.*/ sl@0: int index; /* If the -index option was specified, this sl@0: * holds the index of the list element sl@0: * to extract for comparison. If -index sl@0: * wasn't specified, this is -1. */ sl@0: Tcl_Interp *interp; /* The interpreter in which the sortis sl@0: * being done. */ sl@0: int resultCode; /* Completion code for the lsort command. sl@0: * If an error occurs during the sort this sl@0: * is changed from TCL_OK to TCL_ERROR. */ sl@0: } SortInfo; sl@0: sl@0: /* sl@0: * The "sortMode" field of the SortInfo structure can take on any of the sl@0: * following values. sl@0: */ sl@0: sl@0: #define SORTMODE_ASCII 0 sl@0: #define SORTMODE_INTEGER 1 sl@0: #define SORTMODE_REAL 2 sl@0: #define SORTMODE_COMMAND 3 sl@0: #define SORTMODE_DICTIONARY 4 sl@0: sl@0: /* sl@0: * Magic values for the index field of the SortInfo structure. sl@0: * Note that the index "end-1" will be translated to SORTIDX_END-1, etc. sl@0: */ sl@0: #define SORTIDX_NONE -1 /* Not indexed; use whole value. */ sl@0: #define SORTIDX_END -2 /* Indexed from end. */ sl@0: sl@0: /* sl@0: * Forward declarations for procedures defined in this file: sl@0: */ sl@0: sl@0: static void AppendLocals _ANSI_ARGS_((Tcl_Interp *interp, sl@0: Tcl_Obj *listPtr, CONST char *pattern, sl@0: int includeLinks)); sl@0: static int DictionaryCompare _ANSI_ARGS_((char *left, sl@0: char *right)); sl@0: static int InfoArgsCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static int InfoBodyCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static int InfoCmdCountCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static int InfoCommandsCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static int InfoCompleteCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static int InfoDefaultCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static int InfoExistsCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: #ifdef TCL_TIP280 sl@0: /* TIP #280 - New 'info' subcommand 'frame' */ sl@0: static int InfoFrameCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: #endif sl@0: static int InfoFunctionsCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static int InfoGlobalsCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static int InfoHostnameCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static int InfoLevelCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static int InfoLibraryCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static int InfoLoadedCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static int InfoLocalsCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static int InfoNameOfExecutableCmd _ANSI_ARGS_(( sl@0: ClientData dummy, Tcl_Interp *interp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static int InfoPatchLevelCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static int InfoProcsCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static int InfoScriptCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static int InfoSharedlibCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static int InfoTclVersionCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static int InfoVarsCmd _ANSI_ARGS_((ClientData dummy, sl@0: Tcl_Interp *interp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static SortElement * MergeSort _ANSI_ARGS_((SortElement *headPt, sl@0: SortInfo *infoPtr)); sl@0: static SortElement * MergeLists _ANSI_ARGS_((SortElement *leftPtr, sl@0: SortElement *rightPtr, SortInfo *infoPtr)); sl@0: static int SortCompare _ANSI_ARGS_((Tcl_Obj *firstPtr, sl@0: Tcl_Obj *second, SortInfo *infoPtr)); sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_IfObjCmd -- sl@0: * sl@0: * This procedure is invoked to process the "if" Tcl command. sl@0: * See the user documentation for details on what it does. sl@0: * sl@0: * With the bytecode compiler, this procedure is only called when sl@0: * a command name is computed at runtime, and is "if" or the name sl@0: * to which "if" was renamed: e.g., "set z if; $z 1 {puts foo}" sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * See the user documentation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: int sl@0: Tcl_IfObjCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: int thenScriptIndex = 0; /* then script to be evaled after syntax check */ sl@0: #ifdef TCL_TIP280 sl@0: Interp* iPtr = (Interp*) interp; sl@0: #endif sl@0: int i, result, value; sl@0: char *clause; sl@0: i = 1; sl@0: while (1) { sl@0: /* sl@0: * At this point in the loop, objv and objc refer to an expression sl@0: * to test, either for the main expression or an expression sl@0: * following an "elseif". The arguments after the expression must sl@0: * be "then" (optional) and a script to execute if the expression is sl@0: * true. sl@0: */ sl@0: sl@0: if (i >= objc) { sl@0: clause = Tcl_GetString(objv[i-1]); sl@0: Tcl_AppendResult(interp, "wrong # args: no expression after \"", sl@0: clause, "\" argument", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: if (!thenScriptIndex) { sl@0: result = Tcl_ExprBooleanObj(interp, objv[i], &value); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: } sl@0: i++; sl@0: if (i >= objc) { sl@0: missingScript: sl@0: clause = Tcl_GetString(objv[i-1]); sl@0: Tcl_AppendResult(interp, "wrong # args: no script following \"", sl@0: clause, "\" argument", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: clause = Tcl_GetString(objv[i]); sl@0: if ((i < objc) && (strcmp(clause, "then") == 0)) { sl@0: i++; sl@0: } sl@0: if (i >= objc) { sl@0: goto missingScript; sl@0: } sl@0: if (value) { sl@0: thenScriptIndex = i; sl@0: value = 0; sl@0: } sl@0: sl@0: /* sl@0: * The expression evaluated to false. Skip the command, then sl@0: * see if there is an "else" or "elseif" clause. sl@0: */ sl@0: sl@0: i++; sl@0: if (i >= objc) { sl@0: if (thenScriptIndex) { sl@0: #ifndef TCL_TIP280 sl@0: return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0); sl@0: #else sl@0: /* TIP #280. Make invoking context available to branch */ sl@0: return TclEvalObjEx(interp, objv[thenScriptIndex], 0, sl@0: iPtr->cmdFramePtr,thenScriptIndex); sl@0: #endif sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: clause = Tcl_GetString(objv[i]); sl@0: if ((clause[0] == 'e') && (strcmp(clause, "elseif") == 0)) { sl@0: i++; sl@0: continue; sl@0: } sl@0: break; sl@0: } sl@0: sl@0: /* sl@0: * Couldn't find a "then" or "elseif" clause to execute. Check now sl@0: * for an "else" clause. We know that there's at least one more sl@0: * argument when we get here. sl@0: */ sl@0: sl@0: if (strcmp(clause, "else") == 0) { sl@0: i++; sl@0: if (i >= objc) { sl@0: Tcl_AppendResult(interp, sl@0: "wrong # args: no script following \"else\" argument", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: if (i < objc - 1) { sl@0: Tcl_AppendResult(interp, sl@0: "wrong # args: extra words after \"else\" clause in \"if\" command", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: if (thenScriptIndex) { sl@0: #ifndef TCL_TIP280 sl@0: return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0); sl@0: #else sl@0: /* TIP #280. Make invoking context available to branch/else */ sl@0: return TclEvalObjEx(interp, objv[thenScriptIndex], 0, sl@0: iPtr->cmdFramePtr,thenScriptIndex); sl@0: #endif sl@0: } sl@0: #ifndef TCL_TIP280 sl@0: return Tcl_EvalObjEx(interp, objv[i], 0); sl@0: #else sl@0: return TclEvalObjEx(interp, objv[i], 0, iPtr->cmdFramePtr,i); sl@0: #endif sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_IncrObjCmd -- sl@0: * sl@0: * This procedure is invoked to process the "incr" Tcl command. sl@0: * See the user documentation for details on what it does. sl@0: * sl@0: * With the bytecode compiler, this procedure is only called when sl@0: * a command name is computed at runtime, and is "incr" or the name sl@0: * to which "incr" was renamed: e.g., "set z incr; $z i -1" sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * See the user documentation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: int sl@0: Tcl_IncrObjCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: long incrAmount; sl@0: Tcl_Obj *newValuePtr; sl@0: sl@0: if ((objc != 2) && (objc != 3)) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, "varName ?increment?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Calculate the amount to increment by. sl@0: */ sl@0: sl@0: if (objc == 2) { sl@0: incrAmount = 1; sl@0: } else { sl@0: if (Tcl_GetLongFromObj(interp, objv[2], &incrAmount) != TCL_OK) { sl@0: Tcl_AddErrorInfo(interp, "\n (reading increment)"); sl@0: return TCL_ERROR; sl@0: } sl@0: /* sl@0: * Need to be a bit cautious to ensure that [expr]-like rules sl@0: * are enforced for interpretation of wide integers, despite sl@0: * the fact that the underlying API itself is a 'long' only one. sl@0: */ sl@0: if (objv[2]->typePtr == &tclIntType) { sl@0: incrAmount = objv[2]->internalRep.longValue; sl@0: } else if (objv[2]->typePtr == &tclWideIntType) { sl@0: TclGetLongFromWide(incrAmount,objv[2]); sl@0: } else { sl@0: Tcl_WideInt wide; sl@0: sl@0: if (Tcl_GetWideIntFromObj(interp, objv[2], &wide) != TCL_OK) { sl@0: Tcl_AddErrorInfo(interp, "\n (reading increment)"); sl@0: return TCL_ERROR; sl@0: } sl@0: incrAmount = Tcl_WideAsLong(wide); sl@0: if ((wide <= Tcl_LongAsWide(LONG_MAX)) sl@0: && (wide >= Tcl_LongAsWide(LONG_MIN))) { sl@0: objv[2]->typePtr = &tclIntType; sl@0: objv[2]->internalRep.longValue = incrAmount; sl@0: } sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Increment the variable's value. sl@0: */ sl@0: sl@0: newValuePtr = TclIncrVar2(interp, objv[1], (Tcl_Obj *) NULL, incrAmount, sl@0: TCL_LEAVE_ERR_MSG); sl@0: if (newValuePtr == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Set the interpreter's object result to refer to the variable's new sl@0: * value object. sl@0: */ sl@0: sl@0: Tcl_SetObjResult(interp, newValuePtr); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_InfoObjCmd -- sl@0: * sl@0: * This procedure is invoked to process the "info" Tcl command. sl@0: * See the user documentation for details on what it does. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * See the user documentation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: int sl@0: Tcl_InfoObjCmd(clientData, interp, objc, objv) sl@0: ClientData clientData; /* Arbitrary value passed to the command. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: static CONST char *subCmds[] = { sl@0: "args", "body", "cmdcount", "commands", sl@0: "complete", "default", "exists", sl@0: #ifdef TCL_TIP280 sl@0: "frame", sl@0: #endif sl@0: "functions", sl@0: "globals", "hostname", "level", "library", "loaded", sl@0: "locals", "nameofexecutable", "patchlevel", "procs", sl@0: "script", "sharedlibextension", "tclversion", "vars", sl@0: (char *) NULL}; sl@0: enum ISubCmdIdx { sl@0: IArgsIdx, IBodyIdx, ICmdCountIdx, ICommandsIdx, sl@0: ICompleteIdx, IDefaultIdx, IExistsIdx, sl@0: #ifdef TCL_TIP280 sl@0: IFrameIdx, sl@0: #endif sl@0: IFunctionsIdx, sl@0: IGlobalsIdx, IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx, sl@0: ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx, sl@0: IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx sl@0: }; sl@0: int index, result; sl@0: sl@0: if (objc < 2) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: result = Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", 0, sl@0: (int *) &index); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: sl@0: switch (index) { sl@0: case IArgsIdx: sl@0: result = InfoArgsCmd(clientData, interp, objc, objv); sl@0: break; sl@0: case IBodyIdx: sl@0: result = InfoBodyCmd(clientData, interp, objc, objv); sl@0: break; sl@0: case ICmdCountIdx: sl@0: result = InfoCmdCountCmd(clientData, interp, objc, objv); sl@0: break; sl@0: case ICommandsIdx: sl@0: result = InfoCommandsCmd(clientData, interp, objc, objv); sl@0: break; sl@0: case ICompleteIdx: sl@0: result = InfoCompleteCmd(clientData, interp, objc, objv); sl@0: break; sl@0: case IDefaultIdx: sl@0: result = InfoDefaultCmd(clientData, interp, objc, objv); sl@0: break; sl@0: case IExistsIdx: sl@0: result = InfoExistsCmd(clientData, interp, objc, objv); sl@0: break; sl@0: #ifdef TCL_TIP280 sl@0: case IFrameIdx: sl@0: /* TIP #280 - New method 'frame' */ sl@0: result = InfoFrameCmd(clientData, interp, objc, objv); sl@0: break; sl@0: #endif sl@0: case IFunctionsIdx: sl@0: result = InfoFunctionsCmd(clientData, interp, objc, objv); sl@0: break; sl@0: case IGlobalsIdx: sl@0: result = InfoGlobalsCmd(clientData, interp, objc, objv); sl@0: break; sl@0: case IHostnameIdx: sl@0: result = InfoHostnameCmd(clientData, interp, objc, objv); sl@0: break; sl@0: case ILevelIdx: sl@0: result = InfoLevelCmd(clientData, interp, objc, objv); sl@0: break; sl@0: case ILibraryIdx: sl@0: result = InfoLibraryCmd(clientData, interp, objc, objv); sl@0: break; sl@0: case ILoadedIdx: sl@0: result = InfoLoadedCmd(clientData, interp, objc, objv); sl@0: break; sl@0: case ILocalsIdx: sl@0: result = InfoLocalsCmd(clientData, interp, objc, objv); sl@0: break; sl@0: case INameOfExecutableIdx: sl@0: result = InfoNameOfExecutableCmd(clientData, interp, objc, objv); sl@0: break; sl@0: case IPatchLevelIdx: sl@0: result = InfoPatchLevelCmd(clientData, interp, objc, objv); sl@0: break; sl@0: case IProcsIdx: sl@0: result = InfoProcsCmd(clientData, interp, objc, objv); sl@0: break; sl@0: case IScriptIdx: sl@0: result = InfoScriptCmd(clientData, interp, objc, objv); sl@0: break; sl@0: case ISharedLibExtensionIdx: sl@0: result = InfoSharedlibCmd(clientData, interp, objc, objv); sl@0: break; sl@0: case ITclVersionIdx: sl@0: result = InfoTclVersionCmd(clientData, interp, objc, objv); sl@0: break; sl@0: case IVarsIdx: sl@0: result = InfoVarsCmd(clientData, interp, objc, objv); sl@0: break; sl@0: } sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * InfoArgsCmd -- sl@0: * sl@0: * Called to implement the "info args" command that returns the sl@0: * argument list for a procedure. Handles the following syntax: sl@0: * sl@0: * info args procName sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if successful and TCL_ERROR if there is an error. sl@0: * sl@0: * Side effects: sl@0: * Returns a result in the interpreter's result object. If there is sl@0: * an error, the result is an error message. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: InfoArgsCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: register Interp *iPtr = (Interp *) interp; sl@0: char *name; sl@0: Proc *procPtr; sl@0: CompiledLocal *localPtr; sl@0: Tcl_Obj *listObjPtr; sl@0: sl@0: if (objc != 3) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "procname"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: name = Tcl_GetString(objv[2]); sl@0: procPtr = TclFindProc(iPtr, name); sl@0: if (procPtr == NULL) { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "\"", name, "\" isn't a procedure", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Build a return list containing the arguments. sl@0: */ sl@0: sl@0: listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); sl@0: for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; sl@0: localPtr = localPtr->nextPtr) { sl@0: if (TclIsVarArgument(localPtr)) { sl@0: Tcl_ListObjAppendElement(interp, listObjPtr, sl@0: Tcl_NewStringObj(localPtr->name, -1)); sl@0: } sl@0: } sl@0: Tcl_SetObjResult(interp, listObjPtr); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * InfoBodyCmd -- sl@0: * sl@0: * Called to implement the "info body" command that returns the body sl@0: * for a procedure. Handles the following syntax: sl@0: * sl@0: * info body procName sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if successful and TCL_ERROR if there is an error. sl@0: * sl@0: * Side effects: sl@0: * Returns a result in the interpreter's result object. If there is sl@0: * an error, the result is an error message. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: InfoBodyCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: register Interp *iPtr = (Interp *) interp; sl@0: char *name; sl@0: Proc *procPtr; sl@0: Tcl_Obj *bodyPtr, *resultPtr; sl@0: sl@0: if (objc != 3) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "procname"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: name = Tcl_GetString(objv[2]); sl@0: procPtr = TclFindProc(iPtr, name); sl@0: if (procPtr == NULL) { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "\"", name, "\" isn't a procedure", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Here we used to return procPtr->bodyPtr, except when the body was sl@0: * bytecompiled - in that case, the return was a copy of the body's sl@0: * string rep. In order to better isolate the implementation details sl@0: * of the compiler/engine subsystem, we now always return a copy of sl@0: * the string rep. It is important to return a copy so that later sl@0: * manipulations of the object do not invalidate the internal rep. sl@0: */ sl@0: sl@0: bodyPtr = procPtr->bodyPtr; sl@0: if (bodyPtr->bytes == NULL) { sl@0: /* sl@0: * The string rep might not be valid if the procedure has sl@0: * never been run before. [Bug #545644] sl@0: */ sl@0: (void) Tcl_GetString(bodyPtr); sl@0: } sl@0: resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length); sl@0: sl@0: Tcl_SetObjResult(interp, resultPtr); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * InfoCmdCountCmd -- sl@0: * sl@0: * Called to implement the "info cmdcount" command that returns the sl@0: * number of commands that have been executed. Handles the following sl@0: * syntax: sl@0: * sl@0: * info cmdcount sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if successful and TCL_ERROR if there is an error. sl@0: * sl@0: * Side effects: sl@0: * Returns a result in the interpreter's result object. If there is sl@0: * an error, the result is an error message. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: InfoCmdCountCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: sl@0: if (objc != 2) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: Tcl_SetIntObj(Tcl_GetObjResult(interp), iPtr->cmdCount); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * InfoCommandsCmd -- sl@0: * sl@0: * Called to implement the "info commands" command that returns the sl@0: * list of commands in the interpreter that match an optional pattern. sl@0: * The pattern, if any, consists of an optional sequence of namespace sl@0: * names separated by "::" qualifiers, which is followed by a sl@0: * glob-style pattern that restricts which commands are returned. sl@0: * Handles the following syntax: sl@0: * sl@0: * info commands ?pattern? sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if successful and TCL_ERROR if there is an error. sl@0: * sl@0: * Side effects: sl@0: * Returns a result in the interpreter's result object. If there is sl@0: * an error, the result is an error message. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: InfoCommandsCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: char *cmdName, *pattern; sl@0: CONST char *simplePattern; sl@0: register Tcl_HashEntry *entryPtr; sl@0: Tcl_HashSearch search; sl@0: Namespace *nsPtr; sl@0: Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); sl@0: Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); sl@0: Tcl_Obj *listPtr, *elemObjPtr; sl@0: int specificNsInPattern = 0; /* Init. to avoid compiler warning. */ sl@0: Tcl_Command cmd; sl@0: sl@0: /* sl@0: * Get the pattern and find the "effective namespace" in which to sl@0: * list commands. sl@0: */ sl@0: sl@0: if (objc == 2) { sl@0: simplePattern = NULL; sl@0: nsPtr = currNsPtr; sl@0: specificNsInPattern = 0; sl@0: } else if (objc == 3) { sl@0: /* sl@0: * From the pattern, get the effective namespace and the simple sl@0: * pattern (no namespace qualifiers or ::'s) at the end. If an sl@0: * error was found while parsing the pattern, return it. Otherwise, sl@0: * if the namespace wasn't found, just leave nsPtr NULL: we will sl@0: * return an empty list since no commands there can be found. sl@0: */ sl@0: sl@0: Namespace *dummy1NsPtr, *dummy2NsPtr; sl@0: sl@0: sl@0: pattern = Tcl_GetString(objv[2]); sl@0: TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, sl@0: /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern); sl@0: sl@0: if (nsPtr != NULL) { /* we successfully found the pattern's ns */ sl@0: specificNsInPattern = (strcmp(simplePattern, pattern) != 0); sl@0: } sl@0: } else { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Exit as quickly as possible if we couldn't find the namespace. sl@0: */ sl@0: sl@0: if (nsPtr == NULL) { sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: * Scan through the effective namespace's command table and create a sl@0: * list with all commands that match the pattern. If a specific sl@0: * namespace was requested in the pattern, qualify the command names sl@0: * with the namespace name. sl@0: */ sl@0: sl@0: listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); sl@0: sl@0: if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) { sl@0: /* sl@0: * Special case for when the pattern doesn't include any of sl@0: * glob's special characters. This lets us avoid scans of any sl@0: * hash tables. sl@0: */ sl@0: entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern); sl@0: if (entryPtr != NULL) { sl@0: if (specificNsInPattern) { sl@0: cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); sl@0: elemObjPtr = Tcl_NewObj(); sl@0: Tcl_GetCommandFullName(interp, cmd, elemObjPtr); sl@0: } else { sl@0: cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); sl@0: elemObjPtr = Tcl_NewStringObj(cmdName, -1); sl@0: } sl@0: Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); sl@0: } else if ((nsPtr != globalNsPtr) && !specificNsInPattern) { sl@0: entryPtr = Tcl_FindHashEntry(&globalNsPtr->cmdTable, sl@0: simplePattern); sl@0: if (entryPtr != NULL) { sl@0: cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr); sl@0: Tcl_ListObjAppendElement(interp, listPtr, sl@0: Tcl_NewStringObj(cmdName, -1)); sl@0: } sl@0: } sl@0: } else { sl@0: entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); sl@0: while (entryPtr != NULL) { sl@0: cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); sl@0: if ((simplePattern == NULL) sl@0: || Tcl_StringMatch(cmdName, simplePattern)) { sl@0: if (specificNsInPattern) { sl@0: cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); sl@0: elemObjPtr = Tcl_NewObj(); sl@0: Tcl_GetCommandFullName(interp, cmd, elemObjPtr); sl@0: } else { sl@0: elemObjPtr = Tcl_NewStringObj(cmdName, -1); sl@0: } sl@0: Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); sl@0: } sl@0: entryPtr = Tcl_NextHashEntry(&search); sl@0: } sl@0: sl@0: /* sl@0: * If the effective namespace isn't the global :: namespace, and a sl@0: * specific namespace wasn't requested in the pattern, then add in sl@0: * all global :: commands that match the simple pattern. Of course, sl@0: * we add in only those commands that aren't hidden by a command in sl@0: * the effective namespace. sl@0: */ sl@0: sl@0: if ((nsPtr != globalNsPtr) && !specificNsInPattern) { sl@0: entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search); sl@0: while (entryPtr != NULL) { sl@0: cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr); sl@0: if ((simplePattern == NULL) sl@0: || Tcl_StringMatch(cmdName, simplePattern)) { sl@0: if (Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) { sl@0: Tcl_ListObjAppendElement(interp, listPtr, sl@0: Tcl_NewStringObj(cmdName, -1)); sl@0: } sl@0: } sl@0: entryPtr = Tcl_NextHashEntry(&search); sl@0: } sl@0: } sl@0: } sl@0: sl@0: Tcl_SetObjResult(interp, listPtr); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * InfoCompleteCmd -- sl@0: * sl@0: * Called to implement the "info complete" command that determines sl@0: * whether a string is a complete Tcl command. Handles the following sl@0: * syntax: sl@0: * sl@0: * info complete command sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if successful and TCL_ERROR if there is an error. sl@0: * sl@0: * Side effects: sl@0: * Returns a result in the interpreter's result object. If there is sl@0: * an error, the result is an error message. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: InfoCompleteCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: if (objc != 3) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "command"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (TclObjCommandComplete(objv[2])) { sl@0: Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); sl@0: } else { sl@0: Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); sl@0: } sl@0: sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * InfoDefaultCmd -- sl@0: * sl@0: * Called to implement the "info default" command that returns the sl@0: * default value for a procedure argument. Handles the following sl@0: * syntax: sl@0: * sl@0: * info default procName arg varName sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if successful and TCL_ERROR if there is an error. sl@0: * sl@0: * Side effects: sl@0: * Returns a result in the interpreter's result object. If there is sl@0: * an error, the result is an error message. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: InfoDefaultCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: char *procName, *argName, *varName; sl@0: Proc *procPtr; sl@0: CompiledLocal *localPtr; sl@0: Tcl_Obj *valueObjPtr; sl@0: sl@0: if (objc != 5) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "procname arg varname"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: procName = Tcl_GetString(objv[2]); sl@0: argName = Tcl_GetString(objv[3]); sl@0: sl@0: procPtr = TclFindProc(iPtr, procName); sl@0: if (procPtr == NULL) { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "\"", procName, "\" isn't a procedure", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; sl@0: localPtr = localPtr->nextPtr) { sl@0: if (TclIsVarArgument(localPtr) sl@0: && (strcmp(argName, localPtr->name) == 0)) { sl@0: if (localPtr->defValuePtr != NULL) { sl@0: valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL, sl@0: localPtr->defValuePtr, 0); sl@0: if (valueObjPtr == NULL) { sl@0: defStoreError: sl@0: varName = Tcl_GetString(objv[4]); sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "couldn't store default value in variable \"", sl@0: varName, "\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); sl@0: } else { sl@0: Tcl_Obj *nullObjPtr = Tcl_NewObj(); sl@0: Tcl_IncrRefCount(nullObjPtr); sl@0: valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL, sl@0: nullObjPtr, 0); sl@0: Tcl_DecrRefCount(nullObjPtr); /* free unneeded obj */ sl@0: if (valueObjPtr == NULL) { sl@0: goto defStoreError; sl@0: } sl@0: Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: } sl@0: sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "procedure \"", procName, "\" doesn't have an argument \"", sl@0: argName, "\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * InfoExistsCmd -- sl@0: * sl@0: * Called to implement the "info exists" command that determines sl@0: * whether a variable exists. Handles the following syntax: sl@0: * sl@0: * info exists varName sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if successful and TCL_ERROR if there is an error. sl@0: * sl@0: * Side effects: sl@0: * Returns a result in the interpreter's result object. If there is sl@0: * an error, the result is an error message. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: InfoExistsCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: char *varName; sl@0: Var *varPtr; sl@0: sl@0: if (objc != 3) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "varName"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: varName = Tcl_GetString(objv[2]); sl@0: varPtr = TclVarTraceExists(interp, varName); sl@0: if ((varPtr != NULL) && !TclIsVarUndefined(varPtr)) { sl@0: Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); sl@0: } else { sl@0: Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: #ifdef TCL_TIP280 sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * InfoFrameCmd -- sl@0: * TIP #280 sl@0: * sl@0: * Called to implement the "info frame" command that returns the sl@0: * location of either the currently executing command, or its caller. sl@0: * Handles the following syntax: sl@0: * sl@0: * info frame ?number? sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if successful and TCL_ERROR if there is an error. sl@0: * sl@0: * Side effects: sl@0: * Returns a result in the interpreter's result object. If there is sl@0: * an error, the result is an error message. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: InfoFrameCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: sl@0: if (objc == 2) { sl@0: /* just "info frame" */ sl@0: int levels = (iPtr->cmdFramePtr == NULL sl@0: ? 0 sl@0: : iPtr->cmdFramePtr->level); sl@0: sl@0: Tcl_SetIntObj(Tcl_GetObjResult(interp), levels); sl@0: return TCL_OK; sl@0: sl@0: } else if (objc == 3) { sl@0: /* "info frame level" */ sl@0: int level; sl@0: CmdFrame *framePtr; sl@0: sl@0: if (Tcl_GetIntFromObj(interp, objv[2], &level) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (level <= 0) { sl@0: /* Relative adressing */ sl@0: sl@0: if (iPtr->cmdFramePtr == NULL) { sl@0: levelError: sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "bad level \"", sl@0: Tcl_GetString(objv[2]), sl@0: "\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: /* Convert to absolute. */ sl@0: sl@0: level += iPtr->cmdFramePtr->level; sl@0: } sl@0: for (framePtr = iPtr->cmdFramePtr; sl@0: framePtr != NULL; sl@0: framePtr = framePtr->nextPtr) { sl@0: sl@0: if (framePtr->level == level) { sl@0: break; sl@0: } sl@0: } sl@0: if (framePtr == NULL) { sl@0: goto levelError; sl@0: } sl@0: sl@0: /* sl@0: * Pull the information and construct the dictionary to return, as sl@0: * list. Regarding use of the CmdFrame fields see tclInt.h, and its sl@0: * definition. sl@0: */ sl@0: sl@0: { sl@0: Tcl_Obj* lv [20]; /* Keep uptodate when more keys are added to the dict */ sl@0: int lc = 0; sl@0: sl@0: /* This array is indexed by the TCL_LOCATION_... values, except sl@0: * for _LAST. sl@0: */ sl@0: sl@0: static CONST char* typeString [TCL_LOCATION_LAST] = { sl@0: "eval", "eval", "eval", "precompiled", "source", "proc" sl@0: }; sl@0: sl@0: switch (framePtr->type) { sl@0: case TCL_LOCATION_EVAL: sl@0: /* Evaluation, dynamic script. Type, line, cmd, the latter sl@0: * through str. */ sl@0: sl@0: lv [lc ++] = Tcl_NewStringObj ("type",-1); sl@0: lv [lc ++] = Tcl_NewStringObj (typeString [framePtr->type],-1); sl@0: lv [lc ++] = Tcl_NewStringObj ("line",-1); sl@0: lv [lc ++] = Tcl_NewIntObj (framePtr->line[0]); sl@0: lv [lc ++] = Tcl_NewStringObj ("cmd",-1); sl@0: lv [lc ++] = Tcl_NewStringObj (framePtr->cmd.str.cmd, sl@0: framePtr->cmd.str.len); sl@0: break; sl@0: sl@0: case TCL_LOCATION_EVAL_LIST: sl@0: /* List optimized evaluation. Type, line, cmd, the latter sl@0: * through listPtr, possibly a frame. */ sl@0: sl@0: lv [lc ++] = Tcl_NewStringObj ("type",-1); sl@0: lv [lc ++] = Tcl_NewStringObj (typeString [framePtr->type],-1); sl@0: lv [lc ++] = Tcl_NewStringObj ("line",-1); sl@0: lv [lc ++] = Tcl_NewIntObj (framePtr->line[0]); sl@0: sl@0: /* We put a duplicate of the command list obj into the result sl@0: * to ensure that the 'pure List'-property of the command sl@0: * itself is not destroyed. Otherwise the query here would sl@0: * disable the list optimization path in Tcl_EvalObjEx. sl@0: */ sl@0: sl@0: lv [lc ++] = Tcl_NewStringObj ("cmd",-1); sl@0: lv [lc ++] = Tcl_DuplicateObj (framePtr->cmd.listPtr); sl@0: break; sl@0: sl@0: case TCL_LOCATION_PREBC: sl@0: /* Precompiled. Result contains the type as signal, nothing sl@0: * else */ sl@0: sl@0: lv [lc ++] = Tcl_NewStringObj ("type",-1); sl@0: lv [lc ++] = Tcl_NewStringObj (typeString [framePtr->type],-1); sl@0: break; sl@0: sl@0: case TCL_LOCATION_BC: { sl@0: /* Execution of bytecode. Talk to the BC engine to fill out sl@0: * the frame. */ sl@0: sl@0: CmdFrame f = *framePtr; sl@0: Proc* procPtr = f.framePtr ? f.framePtr->procPtr : NULL; sl@0: sl@0: /* Note: Type BC => f.data.eval.path is not used. sl@0: * f.data.tebc.codePtr is used instead. sl@0: */ sl@0: sl@0: TclGetSrcInfoForPc (&f); sl@0: /* Now filled: cmd.str.(cmd,len), line */ sl@0: /* Possibly modified: type, path! */ sl@0: sl@0: lv [lc ++] = Tcl_NewStringObj ("type",-1); sl@0: lv [lc ++] = Tcl_NewStringObj (typeString [f.type],-1); sl@0: lv [lc ++] = Tcl_NewStringObj ("line",-1); sl@0: lv [lc ++] = Tcl_NewIntObj (f.line[0]); sl@0: sl@0: if (f.type == TCL_LOCATION_SOURCE) { sl@0: lv [lc ++] = Tcl_NewStringObj ("file",-1); sl@0: lv [lc ++] = f.data.eval.path; sl@0: /* Death of reference by TclGetSrcInfoForPc */ sl@0: Tcl_DecrRefCount (f.data.eval.path); sl@0: } sl@0: sl@0: lv [lc ++] = Tcl_NewStringObj ("cmd",-1); sl@0: lv [lc ++] = Tcl_NewStringObj (f.cmd.str.cmd, f.cmd.str.len); sl@0: sl@0: if (procPtr != NULL) { sl@0: Tcl_HashEntry* namePtr = procPtr->cmdPtr->hPtr; sl@0: char* procName = Tcl_GetHashKey (namePtr->tablePtr, namePtr); sl@0: char* nsName = procPtr->cmdPtr->nsPtr->fullName; sl@0: sl@0: lv [lc ++] = Tcl_NewStringObj ("proc",-1); sl@0: lv [lc ++] = Tcl_NewStringObj (nsName,-1); sl@0: sl@0: if (strcmp (nsName, "::") != 0) { sl@0: Tcl_AppendToObj (lv [lc-1], "::", -1); sl@0: } sl@0: Tcl_AppendToObj (lv [lc-1], procName, -1); sl@0: } sl@0: break; sl@0: } sl@0: sl@0: case TCL_LOCATION_SOURCE: sl@0: /* Evaluation of a script file */ sl@0: sl@0: lv [lc ++] = Tcl_NewStringObj ("type",-1); sl@0: lv [lc ++] = Tcl_NewStringObj (typeString [framePtr->type],-1); sl@0: lv [lc ++] = Tcl_NewStringObj ("line",-1); sl@0: lv [lc ++] = Tcl_NewIntObj (framePtr->line[0]); sl@0: lv [lc ++] = Tcl_NewStringObj ("file",-1); sl@0: lv [lc ++] = framePtr->data.eval.path; sl@0: /* Refcount framePtr->data.eval.path goes up when lv sl@0: * is converted into the result list object. sl@0: */ sl@0: lv [lc ++] = Tcl_NewStringObj ("cmd",-1); sl@0: lv [lc ++] = Tcl_NewStringObj (framePtr->cmd.str.cmd, sl@0: framePtr->cmd.str.len); sl@0: break; sl@0: sl@0: case TCL_LOCATION_PROC: sl@0: Tcl_Panic ("TCL_LOCATION_PROC found in standard frame"); sl@0: break; sl@0: } sl@0: sl@0: sl@0: /* 'level'. Common to all frame types. Conditional on having an sl@0: * associated _visible_ CallFrame */ sl@0: sl@0: if ((framePtr->framePtr != NULL) && (iPtr->varFramePtr != NULL)) { sl@0: CallFrame* current = framePtr->framePtr; sl@0: CallFrame* top = iPtr->varFramePtr; sl@0: CallFrame* idx; sl@0: sl@0: for (idx = top; sl@0: idx != NULL; sl@0: idx = idx->callerVarPtr) { sl@0: if (idx == current) { sl@0: int c = framePtr->framePtr->level; sl@0: int t = iPtr->varFramePtr->level; sl@0: sl@0: lv [lc ++] = Tcl_NewStringObj ("level",-1); sl@0: lv [lc ++] = Tcl_NewIntObj (t - c); sl@0: break; sl@0: } sl@0: } sl@0: } sl@0: sl@0: Tcl_SetObjResult(interp, Tcl_NewListObj (lc, lv)); sl@0: return TCL_OK; sl@0: } sl@0: } sl@0: sl@0: Tcl_WrongNumArgs(interp, 2, objv, "?number?"); sl@0: sl@0: return TCL_ERROR; sl@0: } sl@0: #endif sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * InfoFunctionsCmd -- sl@0: * sl@0: * Called to implement the "info functions" command that returns the sl@0: * list of math functions matching an optional pattern. Handles the sl@0: * following syntax: sl@0: * sl@0: * info functions ?pattern? sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if successful and TCL_ERROR if there is an error. sl@0: * sl@0: * Side effects: sl@0: * Returns a result in the interpreter's result object. If there is sl@0: * an error, the result is an error message. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: InfoFunctionsCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: char *pattern; sl@0: Tcl_Obj *listPtr; sl@0: sl@0: if (objc == 2) { sl@0: pattern = NULL; sl@0: } else if (objc == 3) { sl@0: pattern = Tcl_GetString(objv[2]); sl@0: } else { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: listPtr = Tcl_ListMathFuncs(interp, pattern); sl@0: if (listPtr == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_SetObjResult(interp, listPtr); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * InfoGlobalsCmd -- sl@0: * sl@0: * Called to implement the "info globals" command that returns the list sl@0: * of global variables matching an optional pattern. Handles the sl@0: * following syntax: sl@0: * sl@0: * info globals ?pattern? sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if successful and TCL_ERROR if there is an error. sl@0: * sl@0: * Side effects: sl@0: * Returns a result in the interpreter's result object. If there is sl@0: * an error, the result is an error message. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: InfoGlobalsCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: char *varName, *pattern; sl@0: Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); sl@0: register Tcl_HashEntry *entryPtr; sl@0: Tcl_HashSearch search; sl@0: Var *varPtr; sl@0: Tcl_Obj *listPtr; sl@0: sl@0: if (objc == 2) { sl@0: pattern = NULL; sl@0: } else if (objc == 3) { sl@0: pattern = Tcl_GetString(objv[2]); sl@0: /* sl@0: * Strip leading global-namespace qualifiers. [Bug 1057461] sl@0: */ sl@0: if (pattern[0] == ':' && pattern[1] == ':') { sl@0: while (*pattern == ':') { sl@0: pattern++; sl@0: } sl@0: } sl@0: } else { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Scan through the global :: namespace's variable table and create a sl@0: * list of all global variables that match the pattern. sl@0: */ sl@0: sl@0: listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); sl@0: if (pattern != NULL && TclMatchIsTrivial(pattern)) { sl@0: entryPtr = Tcl_FindHashEntry(&globalNsPtr->varTable, pattern); sl@0: if (entryPtr != NULL) { sl@0: varPtr = (Var *) Tcl_GetHashValue(entryPtr); sl@0: if (!TclIsVarUndefined(varPtr)) { sl@0: Tcl_ListObjAppendElement(interp, listPtr, sl@0: Tcl_NewStringObj(pattern, -1)); sl@0: } sl@0: } sl@0: } else { sl@0: for (entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search); sl@0: entryPtr != NULL; sl@0: entryPtr = Tcl_NextHashEntry(&search)) { sl@0: varPtr = (Var *) Tcl_GetHashValue(entryPtr); sl@0: if (TclIsVarUndefined(varPtr)) { sl@0: continue; sl@0: } sl@0: varName = Tcl_GetHashKey(&globalNsPtr->varTable, entryPtr); sl@0: if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { sl@0: Tcl_ListObjAppendElement(interp, listPtr, sl@0: Tcl_NewStringObj(varName, -1)); sl@0: } sl@0: } sl@0: } sl@0: Tcl_SetObjResult(interp, listPtr); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * InfoHostnameCmd -- sl@0: * sl@0: * Called to implement the "info hostname" command that returns the sl@0: * host name. Handles the following syntax: sl@0: * sl@0: * info hostname sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if successful and TCL_ERROR if there is an error. sl@0: * sl@0: * Side effects: sl@0: * Returns a result in the interpreter's result object. If there is sl@0: * an error, the result is an error message. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: InfoHostnameCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: CONST char *name; sl@0: if (objc != 2) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: name = Tcl_GetHostName(); sl@0: if (name) { sl@0: Tcl_SetStringObj(Tcl_GetObjResult(interp), name, -1); sl@0: return TCL_OK; sl@0: } else { sl@0: Tcl_SetStringObj(Tcl_GetObjResult(interp), sl@0: "unable to determine name of host", -1); sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * InfoLevelCmd -- sl@0: * sl@0: * Called to implement the "info level" command that returns sl@0: * information about the call stack. Handles the following syntax: sl@0: * sl@0: * info level ?number? sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if successful and TCL_ERROR if there is an error. sl@0: * sl@0: * Side effects: sl@0: * Returns a result in the interpreter's result object. If there is sl@0: * an error, the result is an error message. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: InfoLevelCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: int level; sl@0: CallFrame *framePtr; sl@0: Tcl_Obj *listPtr; sl@0: sl@0: if (objc == 2) { /* just "info level" */ sl@0: if (iPtr->varFramePtr == NULL) { sl@0: Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); sl@0: } else { sl@0: Tcl_SetIntObj(Tcl_GetObjResult(interp), iPtr->varFramePtr->level); sl@0: } sl@0: return TCL_OK; sl@0: } else if (objc == 3) { sl@0: if (Tcl_GetIntFromObj(interp, objv[2], &level) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (level <= 0) { sl@0: if (iPtr->varFramePtr == NULL) { sl@0: levelError: sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "bad level \"", sl@0: Tcl_GetString(objv[2]), sl@0: "\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: level += iPtr->varFramePtr->level; sl@0: } sl@0: for (framePtr = iPtr->varFramePtr; framePtr != NULL; sl@0: framePtr = framePtr->callerVarPtr) { sl@0: if (framePtr->level == level) { sl@0: break; sl@0: } sl@0: } sl@0: if (framePtr == NULL) { sl@0: goto levelError; sl@0: } sl@0: sl@0: listPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv); sl@0: Tcl_SetObjResult(interp, listPtr); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: Tcl_WrongNumArgs(interp, 2, objv, "?number?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * InfoLibraryCmd -- sl@0: * sl@0: * Called to implement the "info library" command that returns the sl@0: * library directory for the Tcl installation. Handles the following sl@0: * syntax: sl@0: * sl@0: * info library sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if successful and TCL_ERROR if there is an error. sl@0: * sl@0: * Side effects: sl@0: * Returns a result in the interpreter's result object. If there is sl@0: * an error, the result is an error message. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: InfoLibraryCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: CONST char *libDirName; sl@0: sl@0: if (objc != 2) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: libDirName = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY); sl@0: if (libDirName != NULL) { sl@0: Tcl_SetStringObj(Tcl_GetObjResult(interp), libDirName, -1); sl@0: return TCL_OK; sl@0: } sl@0: Tcl_SetStringObj(Tcl_GetObjResult(interp), sl@0: "no library has been specified for Tcl", -1); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * InfoLoadedCmd -- sl@0: * sl@0: * Called to implement the "info loaded" command that returns the sl@0: * packages that have been loaded into an interpreter. Handles the sl@0: * following syntax: sl@0: * sl@0: * info loaded ?interp? sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if successful and TCL_ERROR if there is an error. sl@0: * sl@0: * Side effects: sl@0: * Returns a result in the interpreter's result object. If there is sl@0: * an error, the result is an error message. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: InfoLoadedCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: char *interpName; sl@0: int result; sl@0: sl@0: if ((objc != 2) && (objc != 3)) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "?interp?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (objc == 2) { /* get loaded pkgs in all interpreters */ sl@0: interpName = NULL; sl@0: } else { /* get pkgs just in specified interp */ sl@0: interpName = Tcl_GetString(objv[2]); sl@0: } sl@0: result = TclGetLoadedPackages(interp, interpName); sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * InfoLocalsCmd -- sl@0: * sl@0: * Called to implement the "info locals" command to return a list of sl@0: * local variables that match an optional pattern. Handles the sl@0: * following syntax: sl@0: * sl@0: * info locals ?pattern? sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if successful and TCL_ERROR if there is an error. sl@0: * sl@0: * Side effects: sl@0: * Returns a result in the interpreter's result object. If there is sl@0: * an error, the result is an error message. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: InfoLocalsCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: char *pattern; sl@0: Tcl_Obj *listPtr; sl@0: sl@0: if (objc == 2) { sl@0: pattern = NULL; sl@0: } else if (objc == 3) { sl@0: pattern = Tcl_GetString(objv[2]); sl@0: } else { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (iPtr->varFramePtr == NULL || !iPtr->varFramePtr->isProcCallFrame) { sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: * Return a list containing names of first the compiled locals (i.e. the sl@0: * ones stored in the call frame), then the variables in the local hash sl@0: * table (if one exists). sl@0: */ sl@0: sl@0: listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); sl@0: AppendLocals(interp, listPtr, pattern, 0); sl@0: Tcl_SetObjResult(interp, listPtr); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * AppendLocals -- sl@0: * sl@0: * Append the local variables for the current frame to the sl@0: * specified list object. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: AppendLocals(interp, listPtr, pattern, includeLinks) sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: Tcl_Obj *listPtr; /* List object to append names to. */ sl@0: CONST char *pattern; /* Pattern to match against. */ sl@0: int includeLinks; /* 1 if upvars should be included, else 0. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: CompiledLocal *localPtr; sl@0: Var *varPtr; sl@0: int i, localVarCt; sl@0: char *varName; sl@0: Tcl_HashTable *localVarTablePtr; sl@0: register Tcl_HashEntry *entryPtr; sl@0: Tcl_HashSearch search; sl@0: sl@0: localPtr = iPtr->varFramePtr->procPtr->firstLocalPtr; sl@0: localVarCt = iPtr->varFramePtr->numCompiledLocals; sl@0: varPtr = iPtr->varFramePtr->compiledLocals; sl@0: localVarTablePtr = iPtr->varFramePtr->varTablePtr; sl@0: sl@0: for (i = 0; i < localVarCt; i++) { sl@0: /* sl@0: * Skip nameless (temporary) variables and undefined variables sl@0: */ sl@0: sl@0: if (!TclIsVarTemporary(localPtr) && !TclIsVarUndefined(varPtr) sl@0: && (includeLinks || !TclIsVarLink(varPtr))) { sl@0: varName = varPtr->name; sl@0: if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { sl@0: Tcl_ListObjAppendElement(interp, listPtr, sl@0: Tcl_NewStringObj(varName, -1)); sl@0: } sl@0: } sl@0: varPtr++; sl@0: localPtr = localPtr->nextPtr; sl@0: } sl@0: sl@0: if (localVarTablePtr != NULL) { sl@0: for (entryPtr = Tcl_FirstHashEntry(localVarTablePtr, &search); sl@0: entryPtr != NULL; sl@0: entryPtr = Tcl_NextHashEntry(&search)) { sl@0: varPtr = (Var *) Tcl_GetHashValue(entryPtr); sl@0: if (!TclIsVarUndefined(varPtr) sl@0: && (includeLinks || !TclIsVarLink(varPtr))) { sl@0: varName = Tcl_GetHashKey(localVarTablePtr, entryPtr); sl@0: if ((pattern == NULL) sl@0: || Tcl_StringMatch(varName, pattern)) { sl@0: Tcl_ListObjAppendElement(interp, listPtr, sl@0: Tcl_NewStringObj(varName, -1)); sl@0: } sl@0: } sl@0: } sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * InfoNameOfExecutableCmd -- sl@0: * sl@0: * Called to implement the "info nameofexecutable" command that returns sl@0: * the name of the binary file running this application. Handles the sl@0: * following syntax: sl@0: * sl@0: * info nameofexecutable sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if successful and TCL_ERROR if there is an error. sl@0: * sl@0: * Side effects: sl@0: * Returns a result in the interpreter's result object. If there is sl@0: * an error, the result is an error message. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: InfoNameOfExecutableCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: CONST char *nameOfExecutable; sl@0: sl@0: if (objc != 2) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: nameOfExecutable = Tcl_GetNameOfExecutable(); sl@0: sl@0: if (nameOfExecutable != NULL) { sl@0: Tcl_SetStringObj(Tcl_GetObjResult(interp), nameOfExecutable, -1); sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * InfoPatchLevelCmd -- sl@0: * sl@0: * Called to implement the "info patchlevel" command that returns the sl@0: * default value for an argument to a procedure. Handles the following sl@0: * syntax: sl@0: * sl@0: * info patchlevel sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if successful and TCL_ERROR if there is an error. sl@0: * sl@0: * Side effects: sl@0: * Returns a result in the interpreter's result object. If there is sl@0: * an error, the result is an error message. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: InfoPatchLevelCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: CONST char *patchlevel; sl@0: sl@0: if (objc != 2) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: patchlevel = Tcl_GetVar(interp, "tcl_patchLevel", sl@0: (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); sl@0: if (patchlevel != NULL) { sl@0: Tcl_SetStringObj(Tcl_GetObjResult(interp), patchlevel, -1); sl@0: return TCL_OK; sl@0: } sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * InfoProcsCmd -- sl@0: * sl@0: * Called to implement the "info procs" command that returns the sl@0: * list of procedures in the interpreter that match an optional pattern. sl@0: * The pattern, if any, consists of an optional sequence of namespace sl@0: * names separated by "::" qualifiers, which is followed by a sl@0: * glob-style pattern that restricts which commands are returned. sl@0: * Handles the following syntax: sl@0: * sl@0: * info procs ?pattern? sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if successful and TCL_ERROR if there is an error. sl@0: * sl@0: * Side effects: sl@0: * Returns a result in the interpreter's result object. If there is sl@0: * an error, the result is an error message. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: InfoProcsCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: char *cmdName, *pattern; sl@0: CONST char *simplePattern; sl@0: Namespace *nsPtr; sl@0: #ifdef INFO_PROCS_SEARCH_GLOBAL_NS sl@0: Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); sl@0: #endif sl@0: Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); sl@0: Tcl_Obj *listPtr, *elemObjPtr; sl@0: int specificNsInPattern = 0; /* Init. to avoid compiler warning. */ sl@0: register Tcl_HashEntry *entryPtr; sl@0: Tcl_HashSearch search; sl@0: Command *cmdPtr, *realCmdPtr; sl@0: sl@0: /* sl@0: * Get the pattern and find the "effective namespace" in which to sl@0: * list procs. sl@0: */ sl@0: sl@0: if (objc == 2) { sl@0: simplePattern = NULL; sl@0: nsPtr = currNsPtr; sl@0: specificNsInPattern = 0; sl@0: } else if (objc == 3) { sl@0: /* sl@0: * From the pattern, get the effective namespace and the simple sl@0: * pattern (no namespace qualifiers or ::'s) at the end. If an sl@0: * error was found while parsing the pattern, return it. Otherwise, sl@0: * if the namespace wasn't found, just leave nsPtr NULL: we will sl@0: * return an empty list since no commands there can be found. sl@0: */ sl@0: sl@0: Namespace *dummy1NsPtr, *dummy2NsPtr; sl@0: sl@0: pattern = Tcl_GetString(objv[2]); sl@0: TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, sl@0: /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, sl@0: &simplePattern); sl@0: sl@0: if (nsPtr != NULL) { /* we successfully found the pattern's ns */ sl@0: specificNsInPattern = (strcmp(simplePattern, pattern) != 0); sl@0: } sl@0: } else { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (nsPtr == NULL) { sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: * Scan through the effective namespace's command table and create a sl@0: * list with all procs that match the pattern. If a specific sl@0: * namespace was requested in the pattern, qualify the command names sl@0: * with the namespace name. sl@0: */ sl@0: sl@0: listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); sl@0: #ifndef INFO_PROCS_SEARCH_GLOBAL_NS sl@0: if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) { sl@0: entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern); sl@0: if (entryPtr != NULL) { sl@0: cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); sl@0: sl@0: if (!TclIsProc(cmdPtr)) { sl@0: realCmdPtr = (Command *) sl@0: TclGetOriginalCommand((Tcl_Command) cmdPtr); sl@0: if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) { sl@0: goto simpleProcOK; sl@0: } sl@0: } else { sl@0: simpleProcOK: sl@0: if (specificNsInPattern) { sl@0: elemObjPtr = Tcl_NewObj(); sl@0: Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, sl@0: elemObjPtr); sl@0: } else { sl@0: elemObjPtr = Tcl_NewStringObj(simplePattern, -1); sl@0: } sl@0: Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); sl@0: } sl@0: } sl@0: } else sl@0: #endif /* !INFO_PROCS_SEARCH_GLOBAL_NS */ sl@0: { sl@0: entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); sl@0: while (entryPtr != NULL) { sl@0: cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); sl@0: if ((simplePattern == NULL) sl@0: || Tcl_StringMatch(cmdName, simplePattern)) { sl@0: cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); sl@0: sl@0: if (!TclIsProc(cmdPtr)) { sl@0: realCmdPtr = (Command *) sl@0: TclGetOriginalCommand((Tcl_Command) cmdPtr); sl@0: if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) { sl@0: goto procOK; sl@0: } sl@0: } else { sl@0: procOK: sl@0: if (specificNsInPattern) { sl@0: elemObjPtr = Tcl_NewObj(); sl@0: Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, sl@0: elemObjPtr); sl@0: } else { sl@0: elemObjPtr = Tcl_NewStringObj(cmdName, -1); sl@0: } sl@0: Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); sl@0: } sl@0: } sl@0: entryPtr = Tcl_NextHashEntry(&search); sl@0: } sl@0: sl@0: /* sl@0: * If the effective namespace isn't the global :: namespace, and a sl@0: * specific namespace wasn't requested in the pattern, then add in sl@0: * all global :: procs that match the simple pattern. Of course, sl@0: * we add in only those procs that aren't hidden by a proc in sl@0: * the effective namespace. sl@0: */ sl@0: sl@0: #ifdef INFO_PROCS_SEARCH_GLOBAL_NS sl@0: /* sl@0: * If "info procs" worked like "info commands", returning the sl@0: * commands also seen in the global namespace, then you would sl@0: * include this code. As this could break backwards compatibilty sl@0: * with 8.0-8.2, we decided not to "fix" it in 8.3, leaving the sl@0: * behavior slightly different. sl@0: */ sl@0: if ((nsPtr != globalNsPtr) && !specificNsInPattern) { sl@0: entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search); sl@0: while (entryPtr != NULL) { sl@0: cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr); sl@0: if ((simplePattern == NULL) sl@0: || Tcl_StringMatch(cmdName, simplePattern)) { sl@0: if (Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) { sl@0: cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); sl@0: realCmdPtr = (Command *) TclGetOriginalCommand( sl@0: (Tcl_Command) cmdPtr); sl@0: sl@0: if (TclIsProc(cmdPtr) || ((realCmdPtr != NULL) sl@0: && TclIsProc(realCmdPtr))) { sl@0: Tcl_ListObjAppendElement(interp, listPtr, sl@0: Tcl_NewStringObj(cmdName, -1)); sl@0: } sl@0: } sl@0: } sl@0: entryPtr = Tcl_NextHashEntry(&search); sl@0: } sl@0: } sl@0: #endif sl@0: } sl@0: sl@0: Tcl_SetObjResult(interp, listPtr); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * InfoScriptCmd -- sl@0: * sl@0: * Called to implement the "info script" command that returns the sl@0: * script file that is currently being evaluated. Handles the sl@0: * following syntax: sl@0: * sl@0: * info script ?newName? sl@0: * sl@0: * If newName is specified, it will set that as the internal name. sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if successful and TCL_ERROR if there is an error. sl@0: * sl@0: * Side effects: sl@0: * Returns a result in the interpreter's result object. If there is sl@0: * an error, the result is an error message. It may change the sl@0: * internal script filename. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: InfoScriptCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: if ((objc != 2) && (objc != 3)) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "?filename?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (objc == 3) { sl@0: if (iPtr->scriptFile != NULL) { sl@0: Tcl_DecrRefCount(iPtr->scriptFile); sl@0: } sl@0: iPtr->scriptFile = objv[2]; sl@0: Tcl_IncrRefCount(iPtr->scriptFile); sl@0: } sl@0: if (iPtr->scriptFile != NULL) { sl@0: Tcl_SetObjResult(interp, iPtr->scriptFile); sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * InfoSharedlibCmd -- sl@0: * sl@0: * Called to implement the "info sharedlibextension" command that sl@0: * returns the file extension used for shared libraries. Handles the sl@0: * following syntax: sl@0: * sl@0: * info sharedlibextension sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if successful and TCL_ERROR if there is an error. sl@0: * sl@0: * Side effects: sl@0: * Returns a result in the interpreter's result object. If there is sl@0: * an error, the result is an error message. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: InfoSharedlibCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: if (objc != 2) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: #ifdef TCL_SHLIB_EXT sl@0: Tcl_SetStringObj(Tcl_GetObjResult(interp), TCL_SHLIB_EXT, -1); sl@0: #endif sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * InfoTclVersionCmd -- sl@0: * sl@0: * Called to implement the "info tclversion" command that returns the sl@0: * version number for this Tcl library. Handles the following syntax: sl@0: * sl@0: * info tclversion sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if successful and TCL_ERROR if there is an error. sl@0: * sl@0: * Side effects: sl@0: * Returns a result in the interpreter's result object. If there is sl@0: * an error, the result is an error message. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: InfoTclVersionCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: CONST char *version; sl@0: sl@0: if (objc != 2) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: version = Tcl_GetVar(interp, "tcl_version", sl@0: (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); sl@0: if (version != NULL) { sl@0: Tcl_SetStringObj(Tcl_GetObjResult(interp), version, -1); sl@0: return TCL_OK; sl@0: } sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * InfoVarsCmd -- sl@0: * sl@0: * Called to implement the "info vars" command that returns the sl@0: * list of variables in the interpreter that match an optional pattern. sl@0: * The pattern, if any, consists of an optional sequence of namespace sl@0: * names separated by "::" qualifiers, which is followed by a sl@0: * glob-style pattern that restricts which variables are returned. sl@0: * Handles the following syntax: sl@0: * sl@0: * info vars ?pattern? sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if successful and TCL_ERROR if there is an error. sl@0: * sl@0: * Side effects: sl@0: * Returns a result in the interpreter's result object. If there is sl@0: * an error, the result is an error message. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: InfoVarsCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: char *varName, *pattern; sl@0: CONST char *simplePattern; sl@0: register Tcl_HashEntry *entryPtr; sl@0: Tcl_HashSearch search; sl@0: Var *varPtr; sl@0: Namespace *nsPtr; sl@0: Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); sl@0: Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); sl@0: Tcl_Obj *listPtr, *elemObjPtr; sl@0: int specificNsInPattern = 0; /* Init. to avoid compiler warning. */ sl@0: sl@0: /* sl@0: * Get the pattern and find the "effective namespace" in which to sl@0: * list variables. We only use this effective namespace if there's sl@0: * no active Tcl procedure frame. sl@0: */ sl@0: sl@0: if (objc == 2) { sl@0: simplePattern = NULL; sl@0: nsPtr = currNsPtr; sl@0: specificNsInPattern = 0; sl@0: } else if (objc == 3) { sl@0: /* sl@0: * From the pattern, get the effective namespace and the simple sl@0: * pattern (no namespace qualifiers or ::'s) at the end. If an sl@0: * error was found while parsing the pattern, return it. Otherwise, sl@0: * if the namespace wasn't found, just leave nsPtr NULL: we will sl@0: * return an empty list since no variables there can be found. sl@0: */ sl@0: sl@0: Namespace *dummy1NsPtr, *dummy2NsPtr; sl@0: sl@0: pattern = Tcl_GetString(objv[2]); sl@0: TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, sl@0: /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, sl@0: &simplePattern); sl@0: sl@0: if (nsPtr != NULL) { /* we successfully found the pattern's ns */ sl@0: specificNsInPattern = (strcmp(simplePattern, pattern) != 0); sl@0: } sl@0: } else { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * If the namespace specified in the pattern wasn't found, just return. sl@0: */ sl@0: sl@0: if (nsPtr == NULL) { sl@0: return TCL_OK; sl@0: } sl@0: sl@0: listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); sl@0: sl@0: if ((iPtr->varFramePtr == NULL) sl@0: || !iPtr->varFramePtr->isProcCallFrame sl@0: || specificNsInPattern) { sl@0: /* sl@0: * There is no frame pointer, the frame pointer was pushed only sl@0: * to activate a namespace, or we are in a procedure call frame sl@0: * but a specific namespace was specified. Create a list containing sl@0: * only the variables in the effective namespace's variable table. sl@0: */ sl@0: sl@0: if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) { sl@0: /* sl@0: * If we can just do hash lookups, that simplifies things sl@0: * a lot. sl@0: */ sl@0: sl@0: entryPtr = Tcl_FindHashEntry(&nsPtr->varTable, simplePattern); sl@0: if (entryPtr != NULL) { sl@0: varPtr = (Var *) Tcl_GetHashValue(entryPtr); sl@0: if (!TclIsVarUndefined(varPtr) sl@0: || (varPtr->flags & VAR_NAMESPACE_VAR)) { sl@0: if (specificNsInPattern) { sl@0: elemObjPtr = Tcl_NewObj(); sl@0: Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, sl@0: elemObjPtr); sl@0: } else { sl@0: elemObjPtr = Tcl_NewStringObj(simplePattern, -1); sl@0: } sl@0: Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); sl@0: } sl@0: } else if ((nsPtr != globalNsPtr) && !specificNsInPattern) { sl@0: entryPtr = Tcl_FindHashEntry(&globalNsPtr->varTable, sl@0: simplePattern); sl@0: if (entryPtr != NULL) { sl@0: varPtr = (Var *) Tcl_GetHashValue(entryPtr); sl@0: if (!TclIsVarUndefined(varPtr) sl@0: || (varPtr->flags & VAR_NAMESPACE_VAR)) { sl@0: Tcl_ListObjAppendElement(interp, listPtr, sl@0: Tcl_NewStringObj(simplePattern, -1)); sl@0: } sl@0: } sl@0: } sl@0: } else { sl@0: /* sl@0: * Have to scan the tables of variables. sl@0: */ sl@0: sl@0: entryPtr = Tcl_FirstHashEntry(&nsPtr->varTable, &search); sl@0: while (entryPtr != NULL) { sl@0: varPtr = (Var *) Tcl_GetHashValue(entryPtr); sl@0: if (!TclIsVarUndefined(varPtr) sl@0: || (varPtr->flags & VAR_NAMESPACE_VAR)) { sl@0: varName = Tcl_GetHashKey(&nsPtr->varTable, entryPtr); sl@0: if ((simplePattern == NULL) sl@0: || Tcl_StringMatch(varName, simplePattern)) { sl@0: if (specificNsInPattern) { sl@0: elemObjPtr = Tcl_NewObj(); sl@0: Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, sl@0: elemObjPtr); sl@0: } else { sl@0: elemObjPtr = Tcl_NewStringObj(varName, -1); sl@0: } sl@0: Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); sl@0: } sl@0: } sl@0: entryPtr = Tcl_NextHashEntry(&search); sl@0: } sl@0: sl@0: /* sl@0: * If the effective namespace isn't the global :: sl@0: * namespace, and a specific namespace wasn't requested in sl@0: * the pattern (i.e., the pattern only specifies variable sl@0: * names), then add in all global :: variables that match sl@0: * the simple pattern. Of course, add in only those sl@0: * variables that aren't hidden by a variable in the sl@0: * effective namespace. sl@0: */ sl@0: sl@0: if ((nsPtr != globalNsPtr) && !specificNsInPattern) { sl@0: entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search); sl@0: while (entryPtr != NULL) { sl@0: varPtr = (Var *) Tcl_GetHashValue(entryPtr); sl@0: if (!TclIsVarUndefined(varPtr) sl@0: || (varPtr->flags & VAR_NAMESPACE_VAR)) { sl@0: varName = Tcl_GetHashKey(&globalNsPtr->varTable, sl@0: entryPtr); sl@0: if ((simplePattern == NULL) sl@0: || Tcl_StringMatch(varName, simplePattern)) { sl@0: if (Tcl_FindHashEntry(&nsPtr->varTable, sl@0: varName) == NULL) { sl@0: Tcl_ListObjAppendElement(interp, listPtr, sl@0: Tcl_NewStringObj(varName, -1)); sl@0: } sl@0: } sl@0: } sl@0: entryPtr = Tcl_NextHashEntry(&search); sl@0: } sl@0: } sl@0: } sl@0: } else if (((Interp *)interp)->varFramePtr->procPtr != NULL) { sl@0: AppendLocals(interp, listPtr, simplePattern, 1); sl@0: } sl@0: sl@0: Tcl_SetObjResult(interp, listPtr); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_JoinObjCmd -- sl@0: * sl@0: * This procedure is invoked to process the "join" Tcl command. sl@0: * See the user documentation for details on what it does. sl@0: * sl@0: * Results: sl@0: * A standard Tcl object result. sl@0: * sl@0: * Side effects: sl@0: * See the user documentation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: int sl@0: Tcl_JoinObjCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* The argument objects. */ sl@0: { sl@0: char *joinString, *bytes; sl@0: int joinLength, listLen, length, i, result; sl@0: Tcl_Obj **elemPtrs; sl@0: Tcl_Obj *resObjPtr; sl@0: sl@0: if (objc == 2) { sl@0: joinString = " "; sl@0: joinLength = 1; sl@0: } else if (objc == 3) { sl@0: joinString = Tcl_GetStringFromObj(objv[2], &joinLength); sl@0: } else { sl@0: Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Make sure the list argument is a list object and get its length and sl@0: * a pointer to its array of element pointers. sl@0: */ sl@0: sl@0: result = Tcl_ListObjGetElements(interp, objv[1], &listLen, &elemPtrs); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: * Now concatenate strings to form the "joined" result. We append sl@0: * directly into the interpreter's result object. sl@0: */ sl@0: sl@0: resObjPtr = Tcl_GetObjResult(interp); sl@0: sl@0: for (i = 0; i < listLen; i++) { sl@0: bytes = Tcl_GetStringFromObj(elemPtrs[i], &length); sl@0: if (i > 0) { sl@0: Tcl_AppendToObj(resObjPtr, joinString, joinLength); sl@0: } sl@0: Tcl_AppendToObj(resObjPtr, bytes, length); sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_LindexObjCmd -- sl@0: * sl@0: * This object-based procedure is invoked to process the "lindex" Tcl sl@0: * command. See the user documentation for details on what it does. sl@0: * sl@0: * Results: sl@0: * A standard Tcl object result. sl@0: * sl@0: * Side effects: sl@0: * See the user documentation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: int sl@0: Tcl_LindexObjCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: sl@0: Tcl_Obj *elemPtr; /* Pointer to the element being extracted */ sl@0: sl@0: if (objc < 2) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, "list ?index...?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * If objc == 3, then objv[ 2 ] may be either a single index or sl@0: * a list of indices: go to TclLindexList to determine which. sl@0: * If objc >= 4, or objc == 2, then objv[ 2 .. objc-2 ] are all sl@0: * single indices and processed as such in TclLindexFlat. sl@0: */ sl@0: sl@0: if ( objc == 3 ) { sl@0: sl@0: elemPtr = TclLindexList( interp, objv[ 1 ], objv[ 2 ] ); sl@0: sl@0: } else { sl@0: sl@0: elemPtr = TclLindexFlat( interp, objv[ 1 ], objc-2, objv+2 ); sl@0: sl@0: } sl@0: sl@0: /* sl@0: * Set the interpreter's object result to the last element extracted sl@0: */ sl@0: sl@0: if ( elemPtr == NULL ) { sl@0: return TCL_ERROR; sl@0: } else { sl@0: Tcl_SetObjResult(interp, elemPtr); sl@0: Tcl_DecrRefCount( elemPtr ); sl@0: return TCL_OK; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclLindexList -- sl@0: * sl@0: * This procedure handles the 'lindex' command when objc==3. sl@0: * sl@0: * Results: sl@0: * Returns a pointer to the object extracted, or NULL if an sl@0: * error occurred. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: * If objv[1] can be parsed as a list, TclLindexList handles extraction sl@0: * of the desired element locally. Otherwise, it invokes sl@0: * TclLindexFlat to treat objv[1] as a scalar. sl@0: * sl@0: * The reference count of the returned object includes one reference sl@0: * corresponding to the pointer returned. Thus, the calling code will sl@0: * usually do something like: sl@0: * Tcl_SetObjResult( interp, result ); sl@0: * Tcl_DecrRefCount( result ); sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: Tcl_Obj * sl@0: TclLindexList( interp, listPtr, argPtr ) sl@0: Tcl_Interp* interp; /* Tcl interpreter */ sl@0: Tcl_Obj* listPtr; /* List being unpacked */ sl@0: Tcl_Obj* argPtr; /* Index or index list */ sl@0: { sl@0: sl@0: Tcl_Obj **elemPtrs; /* Elements of the list being manipulated. */ sl@0: int listLen; /* Length of the list being manipulated. */ sl@0: int index; /* Index into the list */ sl@0: int result; /* Result returned from a Tcl library call */ sl@0: int i; /* Current index number */ sl@0: Tcl_Obj** indices; /* Array of list indices */ sl@0: int indexCount; /* Size of the array of list indices */ sl@0: Tcl_Obj* oldListPtr; /* Temp location to preserve the list sl@0: * pointer when replacing it with a sublist */ sl@0: sl@0: /* sl@0: * Determine whether argPtr designates a list or a single index. sl@0: * We have to be careful about the order of the checks to avoid sl@0: * repeated shimmering; see TIP#22 and TIP#33 for the details. sl@0: */ sl@0: sl@0: if ( argPtr->typePtr != &tclListType sl@0: && TclGetIntForIndex( NULL , argPtr, 0, &index ) == TCL_OK ) { sl@0: sl@0: /* sl@0: * argPtr designates a single index. sl@0: */ sl@0: sl@0: return TclLindexFlat( interp, listPtr, 1, &argPtr ); sl@0: sl@0: } else if ( Tcl_ListObjGetElements( NULL, argPtr, &indexCount, &indices ) sl@0: != TCL_OK ) { sl@0: sl@0: /* sl@0: * argPtr designates something that is neither an index nor a sl@0: * well-formed list. Report the error via TclLindexFlat. sl@0: */ sl@0: sl@0: return TclLindexFlat( interp, listPtr, 1, &argPtr ); sl@0: } sl@0: sl@0: /* sl@0: * Record the reference to the list that we are maintaining in sl@0: * the activation record. sl@0: */ sl@0: sl@0: Tcl_IncrRefCount( listPtr ); sl@0: sl@0: /* sl@0: * argPtr designates a list, and the 'else if' above has parsed it sl@0: * into indexCount and indices. sl@0: */ sl@0: sl@0: for ( i = 0; i < indexCount; ++i ) { sl@0: sl@0: /* sl@0: * Convert the current listPtr to a list if necessary. sl@0: */ sl@0: sl@0: result = Tcl_ListObjGetElements( interp, listPtr, sl@0: &listLen, &elemPtrs); sl@0: if (result != TCL_OK) { sl@0: Tcl_DecrRefCount( listPtr ); sl@0: return NULL; sl@0: } sl@0: sl@0: /* sl@0: * Get the index from indices[ i ] sl@0: */ sl@0: sl@0: result = TclGetIntForIndex( interp, indices[ i ], sl@0: /*endValue*/ (listLen - 1), sl@0: &index ); sl@0: if ( result != TCL_OK ) { sl@0: /* sl@0: * Index could not be parsed sl@0: */ sl@0: sl@0: Tcl_DecrRefCount( listPtr ); sl@0: return NULL; sl@0: sl@0: } else if ( index < 0 sl@0: || index >= listLen ) { sl@0: /* sl@0: * Index is out of range sl@0: */ sl@0: Tcl_DecrRefCount( listPtr ); sl@0: listPtr = Tcl_NewObj(); sl@0: Tcl_IncrRefCount( listPtr ); sl@0: return listPtr; sl@0: } sl@0: sl@0: /* sl@0: * Make sure listPtr still refers to a list object. sl@0: * If it shared a Tcl_Obj structure with the arguments, then sl@0: * it might have just been converted to something else. sl@0: */ sl@0: sl@0: if (listPtr->typePtr != &tclListType) { sl@0: result = Tcl_ListObjGetElements(interp, listPtr, &listLen, sl@0: &elemPtrs); sl@0: if (result != TCL_OK) { sl@0: Tcl_DecrRefCount( listPtr ); sl@0: return NULL; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Extract the pointer to the appropriate element sl@0: */ sl@0: sl@0: oldListPtr = listPtr; sl@0: listPtr = elemPtrs[ index ]; sl@0: Tcl_IncrRefCount( listPtr ); sl@0: Tcl_DecrRefCount( oldListPtr ); sl@0: sl@0: /* sl@0: * The work we did above may have caused the internal rep sl@0: * of *argPtr to change to something else. Get it back. sl@0: */ sl@0: sl@0: result = Tcl_ListObjGetElements( interp, argPtr, sl@0: &indexCount, &indices ); sl@0: if ( result != TCL_OK ) { sl@0: /* sl@0: * This can't happen unless some extension corrupted a Tcl_Obj. sl@0: */ sl@0: Tcl_DecrRefCount( listPtr ); sl@0: return NULL; sl@0: } sl@0: sl@0: } /* end for */ sl@0: sl@0: /* sl@0: * Return the last object extracted. Its reference count will include sl@0: * the reference being returned. sl@0: */ sl@0: sl@0: return listPtr; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclLindexFlat -- sl@0: * sl@0: * This procedure handles the 'lindex' command, given that the sl@0: * arguments to the command are known to be a flat list. sl@0: * sl@0: * Results: sl@0: * Returns a standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: * This procedure is called from either tclExecute.c or sl@0: * Tcl_LindexObjCmd whenever either is presented with sl@0: * objc == 2 or objc >= 4. It is also called from TclLindexList sl@0: * for the objc==3 case once it is determined that objv[2] cannot sl@0: * be parsed as a list. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: Tcl_Obj * sl@0: TclLindexFlat( interp, listPtr, indexCount, indexArray ) sl@0: Tcl_Interp* interp; /* Tcl interpreter */ sl@0: Tcl_Obj* listPtr; /* Tcl object representing the list */ sl@0: int indexCount; /* Count of indices */ sl@0: Tcl_Obj* CONST indexArray[]; sl@0: /* Array of pointers to Tcl objects sl@0: * representing the indices in the sl@0: * list */ sl@0: { sl@0: sl@0: int i; /* Current list index */ sl@0: int result; /* Result of Tcl library calls */ sl@0: int listLen; /* Length of the current list being sl@0: * processed */ sl@0: Tcl_Obj** elemPtrs; /* Array of pointers to the elements sl@0: * of the current list */ sl@0: int index; /* Parsed version of the current element sl@0: * of indexArray */ sl@0: Tcl_Obj* oldListPtr; /* Temporary to hold listPtr so that sl@0: * its ref count can be decremented. */ sl@0: sl@0: /* sl@0: * Record the reference to the 'listPtr' object that we are sl@0: * maintaining in the C activation record. sl@0: */ sl@0: sl@0: Tcl_IncrRefCount( listPtr ); sl@0: sl@0: for ( i = 0; i < indexCount; ++i ) { sl@0: sl@0: /* sl@0: * Convert the current listPtr to a list if necessary. sl@0: */ sl@0: sl@0: result = Tcl_ListObjGetElements(interp, listPtr, sl@0: &listLen, &elemPtrs); sl@0: if (result != TCL_OK) { sl@0: Tcl_DecrRefCount( listPtr ); sl@0: return NULL; sl@0: } sl@0: sl@0: /* sl@0: * Get the index from objv[i] sl@0: */ sl@0: sl@0: result = TclGetIntForIndex( interp, indexArray[ i ], sl@0: /*endValue*/ (listLen - 1), sl@0: &index ); sl@0: if ( result != TCL_OK ) { sl@0: sl@0: /* Index could not be parsed */ sl@0: sl@0: Tcl_DecrRefCount( listPtr ); sl@0: return NULL; sl@0: sl@0: } else if ( index < 0 sl@0: || index >= listLen ) { sl@0: sl@0: /* sl@0: * Index is out of range sl@0: */ sl@0: sl@0: Tcl_DecrRefCount( listPtr ); sl@0: listPtr = Tcl_NewObj(); sl@0: Tcl_IncrRefCount( listPtr ); sl@0: return listPtr; sl@0: } sl@0: sl@0: /* sl@0: * Make sure listPtr still refers to a list object. sl@0: * It might have been converted to something else above sl@0: * if objv[1] overlaps with one of the other parameters. sl@0: */ sl@0: sl@0: if (listPtr->typePtr != &tclListType) { sl@0: result = Tcl_ListObjGetElements(interp, listPtr, &listLen, sl@0: &elemPtrs); sl@0: if (result != TCL_OK) { sl@0: Tcl_DecrRefCount( listPtr ); sl@0: return NULL; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Extract the pointer to the appropriate element sl@0: */ sl@0: sl@0: oldListPtr = listPtr; sl@0: listPtr = elemPtrs[ index ]; sl@0: Tcl_IncrRefCount( listPtr ); sl@0: Tcl_DecrRefCount( oldListPtr ); sl@0: sl@0: } sl@0: sl@0: return listPtr; sl@0: sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_LinsertObjCmd -- sl@0: * sl@0: * This object-based procedure is invoked to process the "linsert" Tcl sl@0: * command. See the user documentation for details on what it does. sl@0: * sl@0: * Results: sl@0: * A new Tcl list object formed by inserting zero or more elements sl@0: * into a list. sl@0: * sl@0: * Side effects: sl@0: * See the user documentation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: int sl@0: Tcl_LinsertObjCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: register int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: Tcl_Obj *listPtr; sl@0: int index, isDuplicate, len, result; sl@0: sl@0: if (objc < 4) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, "list index element ?element ...?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: result = Tcl_ListObjLength(interp, objv[1], &len); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: * Get the index. "end" is interpreted to be the index after the last sl@0: * element, such that using it will cause any inserted elements to be sl@0: * appended to the list. sl@0: */ sl@0: sl@0: result = TclGetIntForIndex(interp, objv[2], /*end*/ len, &index); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: if (index > len) { sl@0: index = len; sl@0: } sl@0: sl@0: /* sl@0: * If the list object is unshared we can modify it directly. Otherwise sl@0: * we create a copy to modify: this is "copy on write". sl@0: */ sl@0: sl@0: listPtr = objv[1]; sl@0: isDuplicate = 0; sl@0: if (Tcl_IsShared(listPtr)) { sl@0: listPtr = Tcl_DuplicateObj(listPtr); sl@0: isDuplicate = 1; sl@0: } sl@0: sl@0: if ((objc == 4) && (index == len)) { sl@0: /* sl@0: * Special case: insert one element at the end of the list. sl@0: */ sl@0: result = Tcl_ListObjAppendElement(interp, listPtr, objv[3]); sl@0: } else if (objc > 3) { sl@0: result = Tcl_ListObjReplace(interp, listPtr, index, 0, sl@0: (objc-3), &(objv[3])); sl@0: } sl@0: if (result != TCL_OK) { sl@0: if (isDuplicate) { sl@0: Tcl_DecrRefCount(listPtr); /* free unneeded obj */ sl@0: } sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: * Set the interpreter's object result. sl@0: */ sl@0: sl@0: Tcl_SetObjResult(interp, listPtr); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_ListObjCmd -- sl@0: * sl@0: * This procedure is invoked to process the "list" Tcl command. sl@0: * See the user documentation for details on what it does. sl@0: * sl@0: * Results: sl@0: * A standard Tcl object result. sl@0: * sl@0: * Side effects: sl@0: * See the user documentation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: int sl@0: Tcl_ListObjCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: register int objc; /* Number of arguments. */ sl@0: register Tcl_Obj *CONST objv[]; /* The argument objects. */ sl@0: { sl@0: /* sl@0: * If there are no list elements, the result is an empty object. sl@0: * Otherwise modify the interpreter's result object to be a list object. sl@0: */ sl@0: sl@0: if (objc > 1) { sl@0: Tcl_SetListObj(Tcl_GetObjResult(interp), (objc-1), &(objv[1])); sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_LlengthObjCmd -- sl@0: * sl@0: * This object-based procedure is invoked to process the "llength" Tcl sl@0: * command. See the user documentation for details on what it does. sl@0: * sl@0: * Results: sl@0: * A standard Tcl object result. sl@0: * sl@0: * Side effects: sl@0: * See the user documentation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: int sl@0: Tcl_LlengthObjCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: register Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: int listLen, result; sl@0: sl@0: if (objc != 2) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, "list"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: result = Tcl_ListObjLength(interp, objv[1], &listLen); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: * Set the interpreter's object result to an integer object holding the sl@0: * length. sl@0: */ sl@0: sl@0: Tcl_SetIntObj(Tcl_GetObjResult(interp), listLen); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_LrangeObjCmd -- sl@0: * sl@0: * This procedure is invoked to process the "lrange" Tcl command. sl@0: * See the user documentation for details on what it does. sl@0: * sl@0: * Results: sl@0: * A standard Tcl object result. sl@0: * sl@0: * Side effects: sl@0: * See the user documentation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: int sl@0: Tcl_LrangeObjCmd(notUsed, interp, objc, objv) sl@0: ClientData notUsed; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: register Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: Tcl_Obj *listPtr; sl@0: Tcl_Obj **elemPtrs; sl@0: int listLen, first, last, numElems, result; sl@0: sl@0: if (objc != 4) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, "list first last"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Make sure the list argument is a list object and get its length and sl@0: * a pointer to its array of element pointers. sl@0: */ sl@0: sl@0: listPtr = objv[1]; sl@0: result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: * Get the first and last indexes. sl@0: */ sl@0: sl@0: result = TclGetIntForIndex(interp, objv[2], /*endValue*/ (listLen - 1), sl@0: &first); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: if (first < 0) { sl@0: first = 0; sl@0: } sl@0: sl@0: result = TclGetIntForIndex(interp, objv[3], /*endValue*/ (listLen - 1), sl@0: &last); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: if (last >= listLen) { sl@0: last = (listLen - 1); sl@0: } sl@0: sl@0: if (first > last) { sl@0: return TCL_OK; /* the result is an empty object */ sl@0: } sl@0: sl@0: /* sl@0: * Make sure listPtr still refers to a list object. It might have been sl@0: * converted to an int above if the argument objects were shared. sl@0: */ sl@0: sl@0: if (listPtr->typePtr != &tclListType) { sl@0: result = Tcl_ListObjGetElements(interp, listPtr, &listLen, sl@0: &elemPtrs); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Extract a range of fields. We modify the interpreter's result object sl@0: * to be a list object containing the specified elements. sl@0: */ sl@0: sl@0: numElems = (last - first + 1); sl@0: Tcl_SetListObj(Tcl_GetObjResult(interp), numElems, &(elemPtrs[first])); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_LreplaceObjCmd -- sl@0: * sl@0: * This object-based procedure is invoked to process the "lreplace" sl@0: * Tcl command. See the user documentation for details on what it does. sl@0: * sl@0: * Results: sl@0: * A new Tcl list object formed by replacing zero or more elements of sl@0: * a list. sl@0: * sl@0: * Side effects: sl@0: * See the user documentation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: int sl@0: Tcl_LreplaceObjCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: register Tcl_Obj *listPtr; sl@0: int isDuplicate, first, last, listLen, numToDelete, result; sl@0: sl@0: if (objc < 4) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, sl@0: "list first last ?element element ...?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: result = Tcl_ListObjLength(interp, objv[1], &listLen); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: * Get the first and last indexes. "end" is interpreted to be the index sl@0: * for the last element, such that using it will cause that element to sl@0: * be included for deletion. sl@0: */ sl@0: sl@0: result = TclGetIntForIndex(interp, objv[2], /*end*/ (listLen - 1), &first); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: sl@0: result = TclGetIntForIndex(interp, objv[3], /*end*/ (listLen - 1), &last); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: sl@0: if (first < 0) { sl@0: first = 0; sl@0: } sl@0: sl@0: /* sl@0: * Complain if the user asked for a start element that is greater than the sl@0: * list length. This won't ever trigger for the "end*" case as that will sl@0: * be properly constrained by TclGetIntForIndex because we use listLen-1 sl@0: * (to allow for replacing the last elem). sl@0: */ sl@0: sl@0: if ((first >= listLen) && (listLen > 0)) { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "list doesn't contain element ", sl@0: Tcl_GetString(objv[2]), (int *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: if (last >= listLen) { sl@0: last = (listLen - 1); sl@0: } sl@0: if (first <= last) { sl@0: numToDelete = (last - first + 1); sl@0: } else { sl@0: numToDelete = 0; sl@0: } sl@0: sl@0: /* sl@0: * If the list object is unshared we can modify it directly, otherwise sl@0: * we create a copy to modify: this is "copy on write". sl@0: */ sl@0: sl@0: listPtr = objv[1]; sl@0: isDuplicate = 0; sl@0: if (Tcl_IsShared(listPtr)) { sl@0: listPtr = Tcl_DuplicateObj(listPtr); sl@0: isDuplicate = 1; sl@0: } sl@0: if (objc > 4) { sl@0: result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete, sl@0: (objc-4), &(objv[4])); sl@0: } else { sl@0: result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete, sl@0: 0, NULL); sl@0: } sl@0: if (result != TCL_OK) { sl@0: if (isDuplicate) { sl@0: Tcl_DecrRefCount(listPtr); /* free unneeded obj */ sl@0: } sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: * Set the interpreter's object result. sl@0: */ sl@0: sl@0: Tcl_SetObjResult(interp, listPtr); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_LsearchObjCmd -- sl@0: * sl@0: * This procedure is invoked to process the "lsearch" Tcl command. sl@0: * See the user documentation for details on what it does. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * See the user documentation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: Tcl_LsearchObjCmd(clientData, interp, objc, objv) sl@0: ClientData clientData; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument values. */ sl@0: { sl@0: char *bytes, *patternBytes; sl@0: int i, match, mode, index, result, listc, length, elemLen; sl@0: int dataType, isIncreasing, lower, upper, patInt, objInt; sl@0: int offset, allMatches, inlineReturn, negatedMatch; sl@0: double patDouble, objDouble; sl@0: Tcl_Obj *patObj, **listv, *listPtr, *startPtr; sl@0: Tcl_RegExp regexp = NULL; sl@0: static CONST char *options[] = { sl@0: "-all", "-ascii", "-decreasing", "-dictionary", sl@0: "-exact", "-glob", "-increasing", "-inline", sl@0: "-integer", "-not", "-real", "-regexp", sl@0: "-sorted", "-start", NULL sl@0: }; sl@0: enum options { sl@0: LSEARCH_ALL, LSEARCH_ASCII, LSEARCH_DECREASING, LSEARCH_DICTIONARY, sl@0: LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_INCREASING, LSEARCH_INLINE, sl@0: LSEARCH_INTEGER, LSEARCH_NOT, LSEARCH_REAL, LSEARCH_REGEXP, sl@0: LSEARCH_SORTED, LSEARCH_START sl@0: }; sl@0: enum datatypes { sl@0: ASCII, DICTIONARY, INTEGER, REAL sl@0: }; sl@0: enum modes { sl@0: EXACT, GLOB, REGEXP, SORTED sl@0: }; sl@0: sl@0: mode = GLOB; sl@0: dataType = ASCII; sl@0: isIncreasing = 1; sl@0: allMatches = 0; sl@0: inlineReturn = 0; sl@0: negatedMatch = 0; sl@0: listPtr = NULL; sl@0: startPtr = NULL; sl@0: offset = 0; sl@0: sl@0: if (objc < 3) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, "?options? list pattern"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: for (i = 1; i < objc-2; i++) { sl@0: if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) sl@0: != TCL_OK) { sl@0: if (startPtr) { sl@0: Tcl_DecrRefCount(startPtr); sl@0: } sl@0: return TCL_ERROR; sl@0: } sl@0: switch ((enum options) index) { sl@0: case LSEARCH_ALL: /* -all */ sl@0: allMatches = 1; sl@0: break; sl@0: case LSEARCH_ASCII: /* -ascii */ sl@0: dataType = ASCII; sl@0: break; sl@0: case LSEARCH_DECREASING: /* -decreasing */ sl@0: isIncreasing = 0; sl@0: break; sl@0: case LSEARCH_DICTIONARY: /* -dictionary */ sl@0: dataType = DICTIONARY; sl@0: break; sl@0: case LSEARCH_EXACT: /* -increasing */ sl@0: mode = EXACT; sl@0: break; sl@0: case LSEARCH_GLOB: /* -glob */ sl@0: mode = GLOB; sl@0: break; sl@0: case LSEARCH_INCREASING: /* -increasing */ sl@0: isIncreasing = 1; sl@0: break; sl@0: case LSEARCH_INLINE: /* -inline */ sl@0: inlineReturn = 1; sl@0: break; sl@0: case LSEARCH_INTEGER: /* -integer */ sl@0: dataType = INTEGER; sl@0: break; sl@0: case LSEARCH_NOT: /* -not */ sl@0: negatedMatch = 1; sl@0: break; sl@0: case LSEARCH_REAL: /* -real */ sl@0: dataType = REAL; sl@0: break; sl@0: case LSEARCH_REGEXP: /* -regexp */ sl@0: mode = REGEXP; sl@0: break; sl@0: case LSEARCH_SORTED: /* -sorted */ sl@0: mode = SORTED; sl@0: break; sl@0: case LSEARCH_START: /* -start */ sl@0: /* sl@0: * If there was a previous -start option, release its saved sl@0: * index because it will either be replaced or there will be sl@0: * an error. sl@0: */ sl@0: if (startPtr) { sl@0: Tcl_DecrRefCount(startPtr); sl@0: } sl@0: if (i > objc-4) { sl@0: Tcl_AppendResult(interp, "missing starting index", NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: i++; sl@0: if (objv[i] == objv[objc - 2]) { sl@0: /* sl@0: * Take copy to prevent shimmering problems. Note sl@0: * that it does not matter if the index obj is also a sl@0: * component of the list being searched. We only need sl@0: * to copy where the list and the index are sl@0: * one-and-the-same. sl@0: */ sl@0: startPtr = Tcl_DuplicateObj(objv[i]); sl@0: } else { sl@0: startPtr = objv[i]; sl@0: Tcl_IncrRefCount(startPtr); sl@0: } sl@0: } sl@0: } sl@0: sl@0: if ((enum modes) mode == REGEXP) { sl@0: /* sl@0: * We can shimmer regexp/list if listv[i] == pattern, so get the sl@0: * regexp rep before the list rep. First time round, omit the interp sl@0: * and hope that the compilation will succeed. If it fails, we'll sl@0: * recompile in "expensive" mode with a place to put error messages. sl@0: */ sl@0: sl@0: regexp = Tcl_GetRegExpFromObj(NULL, objv[objc - 1], sl@0: TCL_REG_ADVANCED | TCL_REG_NOSUB); sl@0: if (regexp == NULL) { sl@0: /* sl@0: * Failed to compile the RE. Try again without the TCL_REG_NOSUB sl@0: * flag in case the RE had sub-expressions in it [Bug 1366683]. sl@0: * If this fails, an error message will be left in the sl@0: * interpreter. sl@0: */ sl@0: sl@0: regexp = Tcl_GetRegExpFromObj(interp, objv[objc - 1], sl@0: TCL_REG_ADVANCED); sl@0: } sl@0: sl@0: if (regexp == NULL) { sl@0: if (startPtr) { sl@0: Tcl_DecrRefCount(startPtr); sl@0: } sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Make sure the list argument is a list object and get its length and sl@0: * a pointer to its array of element pointers. sl@0: */ sl@0: sl@0: result = Tcl_ListObjGetElements(interp, objv[objc - 2], &listc, &listv); sl@0: if (result != TCL_OK) { sl@0: if (startPtr) { sl@0: Tcl_DecrRefCount(startPtr); sl@0: } sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: * Get the user-specified start offset. sl@0: */ sl@0: if (startPtr) { sl@0: result = TclGetIntForIndex(interp, startPtr, listc-1, &offset); sl@0: Tcl_DecrRefCount(startPtr); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: * If the search started past the end of the list, we just return a sl@0: * "did not match anything at all" result straight away. [Bug 1374778] sl@0: */ sl@0: sl@0: if (offset > listc-1) { sl@0: if (allMatches || inlineReturn) { sl@0: Tcl_ResetResult(interp); sl@0: } else { sl@0: Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: if (offset < 0) { sl@0: offset = 0; sl@0: } sl@0: } sl@0: sl@0: patObj = objv[objc - 1]; sl@0: patternBytes = NULL; sl@0: if ((enum modes) mode == EXACT || (enum modes) mode == SORTED) { sl@0: switch ((enum datatypes) dataType) { sl@0: case ASCII: sl@0: case DICTIONARY: sl@0: patternBytes = Tcl_GetStringFromObj(patObj, &length); sl@0: break; sl@0: case INTEGER: sl@0: result = Tcl_GetIntFromObj(interp, patObj, &patInt); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: break; sl@0: case REAL: sl@0: result = Tcl_GetDoubleFromObj(interp, patObj, &patDouble); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: break; sl@0: } sl@0: } else { sl@0: patternBytes = Tcl_GetStringFromObj(patObj, &length); sl@0: } sl@0: sl@0: /* sl@0: * Set default index value to -1, indicating failure; if we find the sl@0: * item in the course of our search, index will be set to the correct sl@0: * value. sl@0: */ sl@0: index = -1; sl@0: match = 0; sl@0: sl@0: if ((enum modes) mode == SORTED && !allMatches && !negatedMatch) { sl@0: /* sl@0: * If the data is sorted, we can do a more intelligent search. sl@0: * Note that there is no point in being smart when -all was sl@0: * specified; in that case, we have to look at all items anyway, sl@0: * and there is no sense in doing this when the match sense is sl@0: * inverted. sl@0: */ sl@0: lower = offset - 1; sl@0: upper = listc; sl@0: while (lower + 1 != upper) { sl@0: i = (lower + upper)/2; sl@0: switch ((enum datatypes) dataType) { sl@0: case ASCII: sl@0: bytes = Tcl_GetString(listv[i]); sl@0: match = strcmp(patternBytes, bytes); sl@0: break; sl@0: case DICTIONARY: sl@0: bytes = Tcl_GetString(listv[i]); sl@0: match = DictionaryCompare(patternBytes, bytes); sl@0: break; sl@0: case INTEGER: sl@0: result = Tcl_GetIntFromObj(interp, listv[i], &objInt); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: if (patInt == objInt) { sl@0: match = 0; sl@0: } else if (patInt < objInt) { sl@0: match = -1; sl@0: } else { sl@0: match = 1; sl@0: } sl@0: break; sl@0: case REAL: sl@0: result = Tcl_GetDoubleFromObj(interp, listv[i], &objDouble); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: if (patDouble == objDouble) { sl@0: match = 0; sl@0: } else if (patDouble < objDouble) { sl@0: match = -1; sl@0: } else { sl@0: match = 1; sl@0: } sl@0: break; sl@0: } sl@0: if (match == 0) { sl@0: /* sl@0: * Normally, binary search is written to stop when it sl@0: * finds a match. If there are duplicates of an element in sl@0: * the list, our first match might not be the first occurance. sl@0: * Consider: 0 0 0 1 1 1 2 2 2 sl@0: * To maintain consistancy with standard lsearch semantics, sl@0: * we must find the leftmost occurance of the pattern in the sl@0: * list. Thus we don't just stop searching here. This sl@0: * variation means that a search always makes log n sl@0: * comparisons (normal binary search might "get lucky" with sl@0: * an early comparison). sl@0: */ sl@0: index = i; sl@0: upper = i; sl@0: } else if (match > 0) { sl@0: if (isIncreasing) { sl@0: lower = i; sl@0: } else { sl@0: upper = i; sl@0: } sl@0: } else { sl@0: if (isIncreasing) { sl@0: upper = i; sl@0: } else { sl@0: lower = i; sl@0: } sl@0: } sl@0: } sl@0: sl@0: } else { sl@0: /* sl@0: * We need to do a linear search, because (at least one) of: sl@0: * - our matcher can only tell equal vs. not equal sl@0: * - our matching sense is negated sl@0: * - we're building a list of all matched items sl@0: */ sl@0: if (allMatches) { sl@0: listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); sl@0: } sl@0: for (i = offset; i < listc; i++) { sl@0: match = 0; sl@0: switch ((enum modes) mode) { sl@0: case SORTED: sl@0: case EXACT: sl@0: switch ((enum datatypes) dataType) { sl@0: case ASCII: sl@0: bytes = Tcl_GetStringFromObj(listv[i], &elemLen); sl@0: if (length == elemLen) { sl@0: match = (memcmp(bytes, patternBytes, sl@0: (size_t) length) == 0); sl@0: } sl@0: break; sl@0: case DICTIONARY: sl@0: bytes = Tcl_GetString(listv[i]); sl@0: match = (DictionaryCompare(bytes, patternBytes) == 0); sl@0: break; sl@0: case INTEGER: sl@0: result = Tcl_GetIntFromObj(interp, listv[i], &objInt); sl@0: if (result != TCL_OK) { sl@0: if (listPtr) { sl@0: Tcl_DecrRefCount(listPtr); sl@0: } sl@0: return result; sl@0: } sl@0: match = (objInt == patInt); sl@0: break; sl@0: case REAL: sl@0: result = Tcl_GetDoubleFromObj(interp, listv[i], sl@0: &objDouble); sl@0: if (result != TCL_OK) { sl@0: if (listPtr) { sl@0: Tcl_DecrRefCount(listPtr); sl@0: } sl@0: return result; sl@0: } sl@0: match = (objDouble == patDouble); sl@0: break; sl@0: } sl@0: break; sl@0: case GLOB: sl@0: match = Tcl_StringMatch(Tcl_GetString(listv[i]), sl@0: patternBytes); sl@0: break; sl@0: case REGEXP: sl@0: match = Tcl_RegExpExecObj(interp, regexp, listv[i], 0, 0, 0); sl@0: if (match < 0) { sl@0: Tcl_DecrRefCount(patObj); sl@0: if (listPtr) { sl@0: Tcl_DecrRefCount(listPtr); sl@0: } sl@0: return TCL_ERROR; sl@0: } sl@0: break; sl@0: } sl@0: /* sl@0: * Invert match condition for -not sl@0: */ sl@0: if (negatedMatch) { sl@0: match = !match; sl@0: } sl@0: if (match != 0) { sl@0: if (!allMatches) { sl@0: index = i; sl@0: break; sl@0: } else if (inlineReturn) { sl@0: /* sl@0: * Note that these appends are not expected to fail. sl@0: */ sl@0: Tcl_ListObjAppendElement(interp, listPtr, listv[i]); sl@0: } else { sl@0: Tcl_ListObjAppendElement(interp, listPtr, sl@0: Tcl_NewIntObj(i)); sl@0: } sl@0: } sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Return everything or a single value. sl@0: */ sl@0: if (allMatches) { sl@0: Tcl_SetObjResult(interp, listPtr); sl@0: } else if (!inlineReturn) { sl@0: Tcl_SetIntObj(Tcl_GetObjResult(interp), index); sl@0: } else if (index < 0) { sl@0: /* sl@0: * Is this superfluous? The result should be a blank object sl@0: * by default... sl@0: */ sl@0: Tcl_SetObjResult(interp, Tcl_NewObj()); sl@0: } else { sl@0: Tcl_SetObjResult(interp, listv[index]); sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_LsetObjCmd -- sl@0: * sl@0: * This procedure is invoked to process the "lset" Tcl command. sl@0: * See the user documentation for details on what it does. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * See the user documentation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: Tcl_LsetObjCmd( clientData, interp, objc, objv ) sl@0: ClientData clientData; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument values. */ sl@0: { sl@0: sl@0: Tcl_Obj* listPtr; /* Pointer to the list being altered. */ sl@0: Tcl_Obj* finalValuePtr; /* Value finally assigned to the variable */ sl@0: sl@0: /* Check parameter count */ sl@0: sl@0: if ( objc < 3 ) { sl@0: Tcl_WrongNumArgs( interp, 1, objv, "listVar index ?index...? value" ); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* Look up the list variable's value */ sl@0: sl@0: listPtr = Tcl_ObjGetVar2( interp, objv[ 1 ], (Tcl_Obj*) NULL, sl@0: TCL_LEAVE_ERR_MSG ); sl@0: if ( listPtr == NULL ) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Substitute the value in the value. Return either the value or sl@0: * else an unshared copy of it. sl@0: */ sl@0: sl@0: if ( objc == 4 ) { sl@0: finalValuePtr = TclLsetList( interp, listPtr, sl@0: objv[ 2 ], objv[ 3 ] ); sl@0: } else { sl@0: finalValuePtr = TclLsetFlat( interp, listPtr, sl@0: objc-3, objv+2, objv[ objc-1 ] ); sl@0: } sl@0: sl@0: /* sl@0: * If substitution has failed, bail out. sl@0: */ sl@0: sl@0: if ( finalValuePtr == NULL ) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* Finally, update the variable so that traces fire. */ sl@0: sl@0: listPtr = Tcl_ObjSetVar2( interp, objv[1], NULL, finalValuePtr, sl@0: TCL_LEAVE_ERR_MSG ); sl@0: Tcl_DecrRefCount( finalValuePtr ); sl@0: if ( listPtr == NULL ) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* Return the new value of the variable as the interpreter result. */ sl@0: sl@0: Tcl_SetObjResult( interp, listPtr ); sl@0: return TCL_OK; sl@0: sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_LsortObjCmd -- sl@0: * sl@0: * This procedure is invoked to process the "lsort" Tcl command. sl@0: * See the user documentation for details on what it does. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * See the user documentation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: Tcl_LsortObjCmd(clientData, interp, objc, objv) sl@0: ClientData clientData; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument values. */ sl@0: { sl@0: int i, index, unique; sl@0: Tcl_Obj *resultPtr; sl@0: int length; sl@0: Tcl_Obj *cmdPtr, **listObjPtrs; sl@0: SortElement *elementArray; sl@0: SortElement *elementPtr; sl@0: SortInfo sortInfo; /* Information about this sort that sl@0: * needs to be passed to the sl@0: * comparison function */ sl@0: static CONST char *switches[] = { sl@0: "-ascii", "-command", "-decreasing", "-dictionary", "-increasing", sl@0: "-index", "-integer", "-real", "-unique", (char *) NULL sl@0: }; sl@0: sl@0: resultPtr = Tcl_GetObjResult(interp); sl@0: if (objc < 2) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, "?options? list"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Parse arguments to set up the mode for the sort. sl@0: */ sl@0: sl@0: sortInfo.isIncreasing = 1; sl@0: sortInfo.sortMode = SORTMODE_ASCII; sl@0: sortInfo.index = SORTIDX_NONE; sl@0: sortInfo.interp = interp; sl@0: sortInfo.resultCode = TCL_OK; sl@0: cmdPtr = NULL; sl@0: unique = 0; sl@0: for (i = 1; i < objc-1; i++) { sl@0: if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, &index) sl@0: != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: switch (index) { sl@0: case 0: /* -ascii */ sl@0: sortInfo.sortMode = SORTMODE_ASCII; sl@0: break; sl@0: case 1: /* -command */ sl@0: if (i == (objc-2)) { sl@0: Tcl_AppendToObj(resultPtr, sl@0: "\"-command\" option must be followed by comparison command", sl@0: -1); sl@0: return TCL_ERROR; sl@0: } sl@0: sortInfo.sortMode = SORTMODE_COMMAND; sl@0: cmdPtr = objv[i+1]; sl@0: i++; sl@0: break; sl@0: case 2: /* -decreasing */ sl@0: sortInfo.isIncreasing = 0; sl@0: break; sl@0: case 3: /* -dictionary */ sl@0: sortInfo.sortMode = SORTMODE_DICTIONARY; sl@0: break; sl@0: case 4: /* -increasing */ sl@0: sortInfo.isIncreasing = 1; sl@0: break; sl@0: case 5: /* -index */ sl@0: if (i == (objc-2)) { sl@0: Tcl_AppendToObj(resultPtr, sl@0: "\"-index\" option must be followed by list index", sl@0: -1); sl@0: return TCL_ERROR; sl@0: } sl@0: if (TclGetIntForIndex(interp, objv[i+1], SORTIDX_END, sl@0: &sortInfo.index) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: i++; sl@0: break; sl@0: case 6: /* -integer */ sl@0: sortInfo.sortMode = SORTMODE_INTEGER; sl@0: break; sl@0: case 7: /* -real */ sl@0: sortInfo.sortMode = SORTMODE_REAL; sl@0: break; sl@0: case 8: /* -unique */ sl@0: unique = 1; sl@0: break; sl@0: } sl@0: } sl@0: if (sortInfo.sortMode == SORTMODE_COMMAND) { sl@0: /* sl@0: * The existing command is a list. We want to flatten it, append sl@0: * two dummy arguments on the end, and replace these arguments sl@0: * later. sl@0: */ sl@0: sl@0: Tcl_Obj *newCommandPtr = Tcl_DuplicateObj(cmdPtr); sl@0: Tcl_Obj *newObjPtr = Tcl_NewObj(); sl@0: sl@0: Tcl_IncrRefCount(newCommandPtr); sl@0: if (Tcl_ListObjAppendElement(interp, newCommandPtr, newObjPtr) sl@0: != TCL_OK) { sl@0: Tcl_DecrRefCount(newCommandPtr); sl@0: Tcl_IncrRefCount(newObjPtr); sl@0: Tcl_DecrRefCount(newObjPtr); sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_ListObjAppendElement(interp, newCommandPtr, Tcl_NewObj()); sl@0: sortInfo.compareCmdPtr = newCommandPtr; sl@0: } sl@0: sl@0: sortInfo.resultCode = Tcl_ListObjGetElements(interp, objv[objc-1], sl@0: &length, &listObjPtrs); sl@0: if (sortInfo.resultCode != TCL_OK || length <= 0) { sl@0: goto done; sl@0: } sl@0: elementArray = (SortElement *) ckalloc(length * sizeof(SortElement)); sl@0: for (i=0; i < length; i++){ sl@0: elementArray[i].objPtr = listObjPtrs[i]; sl@0: elementArray[i].count = 0; sl@0: elementArray[i].nextPtr = &elementArray[i+1]; sl@0: sl@0: /* sl@0: * When sorting using a command, we are reentrant and therefore might sl@0: * have the representation of the list being sorted shimmered out from sl@0: * underneath our feet. Increment the reference counts of the elements sl@0: * to sort to prevent this. [Bug 1675116] sl@0: */ sl@0: sl@0: Tcl_IncrRefCount(elementArray[i].objPtr); sl@0: } sl@0: elementArray[length-1].nextPtr = NULL; sl@0: elementPtr = MergeSort(elementArray, &sortInfo); sl@0: if (sortInfo.resultCode == TCL_OK) { sl@0: /* sl@0: * Note: must clear the interpreter's result object: it could sl@0: * have been set by the -command script. sl@0: */ sl@0: sl@0: Tcl_ResetResult(interp); sl@0: resultPtr = Tcl_GetObjResult(interp); sl@0: if (unique) { sl@0: for (; elementPtr != NULL; elementPtr = elementPtr->nextPtr){ sl@0: if (elementPtr->count == 0) { sl@0: Tcl_ListObjAppendElement(interp, resultPtr, sl@0: elementPtr->objPtr); sl@0: } sl@0: } sl@0: } else { sl@0: for (; elementPtr != NULL; elementPtr = elementPtr->nextPtr){ sl@0: Tcl_ListObjAppendElement(interp, resultPtr, sl@0: elementPtr->objPtr); sl@0: } sl@0: } sl@0: } sl@0: for (i=0; inextPtr; sl@0: elementPtr->nextPtr = 0; sl@0: for (i = 0; (i < NUM_LISTS) && (subList[i] != NULL); i++){ sl@0: elementPtr = MergeLists(subList[i], elementPtr, infoPtr); sl@0: subList[i] = NULL; sl@0: } sl@0: if (i >= NUM_LISTS) { sl@0: i = NUM_LISTS-1; sl@0: } sl@0: subList[i] = elementPtr; sl@0: } sl@0: elementPtr = NULL; sl@0: for (i = 0; i < NUM_LISTS; i++){ sl@0: elementPtr = MergeLists(subList[i], elementPtr, infoPtr); sl@0: } sl@0: return elementPtr; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * MergeLists - sl@0: * sl@0: * This procedure combines two sorted lists of SortElement structures sl@0: * into a single sorted list. sl@0: * sl@0: * Results: sl@0: * The unified list of SortElement structures. sl@0: * sl@0: * Side effects: sl@0: * None, unless a user-defined comparison command does something sl@0: * weird. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static SortElement * sl@0: MergeLists(leftPtr, rightPtr, infoPtr) sl@0: SortElement *leftPtr; /* First list to be merged; may be sl@0: * NULL. */ sl@0: SortElement *rightPtr; /* Second list to be merged; may be sl@0: * NULL. */ sl@0: SortInfo *infoPtr; /* Information needed by the sl@0: * comparison operator. */ sl@0: { sl@0: SortElement *headPtr; sl@0: SortElement *tailPtr; sl@0: int cmp; sl@0: sl@0: if (leftPtr == NULL) { sl@0: return rightPtr; sl@0: } sl@0: if (rightPtr == NULL) { sl@0: return leftPtr; sl@0: } sl@0: cmp = SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr); sl@0: if (cmp > 0) { sl@0: tailPtr = rightPtr; sl@0: rightPtr = rightPtr->nextPtr; sl@0: } else { sl@0: if (cmp == 0) { sl@0: leftPtr->count++; sl@0: } sl@0: tailPtr = leftPtr; sl@0: leftPtr = leftPtr->nextPtr; sl@0: } sl@0: headPtr = tailPtr; sl@0: while ((leftPtr != NULL) && (rightPtr != NULL)) { sl@0: cmp = SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr); sl@0: if (cmp > 0) { sl@0: tailPtr->nextPtr = rightPtr; sl@0: tailPtr = rightPtr; sl@0: rightPtr = rightPtr->nextPtr; sl@0: } else { sl@0: if (cmp == 0) { sl@0: leftPtr->count++; sl@0: } sl@0: tailPtr->nextPtr = leftPtr; sl@0: tailPtr = leftPtr; sl@0: leftPtr = leftPtr->nextPtr; sl@0: } sl@0: } sl@0: if (leftPtr != NULL) { sl@0: tailPtr->nextPtr = leftPtr; sl@0: } else { sl@0: tailPtr->nextPtr = rightPtr; sl@0: } sl@0: return headPtr; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * SortCompare -- sl@0: * sl@0: * This procedure is invoked by MergeLists to determine the proper sl@0: * ordering between two elements. sl@0: * sl@0: * Results: sl@0: * A negative results means the the first element comes before the sl@0: * second, and a positive results means that the second element sl@0: * should come first. A result of zero means the two elements sl@0: * are equal and it doesn't matter which comes first. sl@0: * sl@0: * Side effects: sl@0: * None, unless a user-defined comparison command does something sl@0: * weird. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: SortCompare(objPtr1, objPtr2, infoPtr) sl@0: Tcl_Obj *objPtr1, *objPtr2; /* Values to be compared. */ sl@0: SortInfo *infoPtr; /* Information passed from the sl@0: * top-level "lsort" command */ sl@0: { sl@0: int order, listLen, index; sl@0: Tcl_Obj *objPtr; sl@0: char buffer[TCL_INTEGER_SPACE]; sl@0: sl@0: order = 0; sl@0: if (infoPtr->resultCode != TCL_OK) { sl@0: /* sl@0: * Once an error has occurred, skip any future comparisons sl@0: * so as to preserve the error message in sortInterp->result. sl@0: */ sl@0: sl@0: return order; sl@0: } sl@0: if (infoPtr->index != SORTIDX_NONE) { sl@0: /* sl@0: * The "-index" option was specified. Treat each object as a sl@0: * list, extract the requested element from each list, and sl@0: * compare the elements, not the lists. "end"-relative indices sl@0: * are signaled here with large negative values. sl@0: */ sl@0: sl@0: if (Tcl_ListObjLength(infoPtr->interp, objPtr1, &listLen) != TCL_OK) { sl@0: infoPtr->resultCode = TCL_ERROR; sl@0: return order; sl@0: } sl@0: if (infoPtr->index < SORTIDX_NONE) { sl@0: index = listLen + infoPtr->index + 1; sl@0: } else { sl@0: index = infoPtr->index; sl@0: } sl@0: sl@0: if (Tcl_ListObjIndex(infoPtr->interp, objPtr1, index, &objPtr) sl@0: != TCL_OK) { sl@0: infoPtr->resultCode = TCL_ERROR; sl@0: return order; sl@0: } sl@0: if (objPtr == NULL) { sl@0: objPtr = objPtr1; sl@0: missingElement: sl@0: TclFormatInt(buffer, infoPtr->index); sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp), sl@0: "element ", buffer, " missing from sublist \"", sl@0: Tcl_GetString(objPtr), "\"", (char *) NULL); sl@0: infoPtr->resultCode = TCL_ERROR; sl@0: return order; sl@0: } sl@0: objPtr1 = objPtr; sl@0: sl@0: if (Tcl_ListObjLength(infoPtr->interp, objPtr2, &listLen) != TCL_OK) { sl@0: infoPtr->resultCode = TCL_ERROR; sl@0: return order; sl@0: } sl@0: if (infoPtr->index < SORTIDX_NONE) { sl@0: index = listLen + infoPtr->index + 1; sl@0: } else { sl@0: index = infoPtr->index; sl@0: } sl@0: sl@0: if (Tcl_ListObjIndex(infoPtr->interp, objPtr2, index, &objPtr) sl@0: != TCL_OK) { sl@0: infoPtr->resultCode = TCL_ERROR; sl@0: return order; sl@0: } sl@0: if (objPtr == NULL) { sl@0: objPtr = objPtr2; sl@0: goto missingElement; sl@0: } sl@0: objPtr2 = objPtr; sl@0: } sl@0: if (infoPtr->sortMode == SORTMODE_ASCII) { sl@0: order = strcmp(Tcl_GetString(objPtr1), Tcl_GetString(objPtr2)); sl@0: } else if (infoPtr->sortMode == SORTMODE_DICTIONARY) { sl@0: order = DictionaryCompare( sl@0: Tcl_GetString(objPtr1), Tcl_GetString(objPtr2)); sl@0: } else if (infoPtr->sortMode == SORTMODE_INTEGER) { sl@0: long a, b; sl@0: sl@0: if ((Tcl_GetLongFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK) sl@0: || (Tcl_GetLongFromObj(infoPtr->interp, objPtr2, &b) sl@0: != TCL_OK)) { sl@0: infoPtr->resultCode = TCL_ERROR; sl@0: return order; sl@0: } sl@0: if (a > b) { sl@0: order = 1; sl@0: } else if (b > a) { sl@0: order = -1; sl@0: } sl@0: } else if (infoPtr->sortMode == SORTMODE_REAL) { sl@0: double a, b; sl@0: sl@0: if ((Tcl_GetDoubleFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK) sl@0: || (Tcl_GetDoubleFromObj(infoPtr->interp, objPtr2, &b) sl@0: != TCL_OK)) { sl@0: infoPtr->resultCode = TCL_ERROR; sl@0: return order; sl@0: } sl@0: if (a > b) { sl@0: order = 1; sl@0: } else if (b > a) { sl@0: order = -1; sl@0: } sl@0: } else { sl@0: Tcl_Obj **objv, *paramObjv[2]; sl@0: int objc; sl@0: sl@0: paramObjv[0] = objPtr1; sl@0: paramObjv[1] = objPtr2; sl@0: sl@0: /* sl@0: * We made space in the command list for the two things to sl@0: * compare. Replace them and evaluate the result. sl@0: */ sl@0: sl@0: Tcl_ListObjLength(infoPtr->interp, infoPtr->compareCmdPtr, &objc); sl@0: Tcl_ListObjReplace(infoPtr->interp, infoPtr->compareCmdPtr, objc - 2, sl@0: 2, 2, paramObjv); sl@0: Tcl_ListObjGetElements(infoPtr->interp, infoPtr->compareCmdPtr, sl@0: &objc, &objv); sl@0: sl@0: infoPtr->resultCode = Tcl_EvalObjv(infoPtr->interp, objc, objv, 0); sl@0: sl@0: if (infoPtr->resultCode != TCL_OK) { sl@0: Tcl_AddErrorInfo(infoPtr->interp, sl@0: "\n (-compare command)"); sl@0: return order; sl@0: } sl@0: sl@0: /* sl@0: * Parse the result of the command. sl@0: */ sl@0: sl@0: if (Tcl_GetIntFromObj(infoPtr->interp, sl@0: Tcl_GetObjResult(infoPtr->interp), &order) != TCL_OK) { sl@0: Tcl_ResetResult(infoPtr->interp); sl@0: Tcl_AppendToObj(Tcl_GetObjResult(infoPtr->interp), sl@0: "-compare command returned non-integer result", -1); sl@0: infoPtr->resultCode = TCL_ERROR; sl@0: return order; sl@0: } sl@0: } sl@0: if (!infoPtr->isIncreasing) { sl@0: order = -order; sl@0: } sl@0: return order; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * DictionaryCompare sl@0: * sl@0: * This function compares two strings as if they were being used in sl@0: * an index or card catalog. The case of alphabetic characters is sl@0: * ignored, except to break ties. Thus "B" comes before "b" but sl@0: * after "a". Also, integers embedded in the strings compare in sl@0: * numerical order. In other words, "x10y" comes after "x9y", not sl@0: * before it as it would when using strcmp(). sl@0: * sl@0: * Results: sl@0: * A negative result means that the first element comes before the sl@0: * second, and a positive result means that the second element sl@0: * should come first. A result of zero means the two elements sl@0: * are equal and it doesn't matter which comes first. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: DictionaryCompare(left, right) sl@0: char *left, *right; /* The strings to compare */ sl@0: { sl@0: Tcl_UniChar uniLeft, uniRight, uniLeftLower, uniRightLower; sl@0: int diff, zeros; sl@0: int secondaryDiff = 0; sl@0: sl@0: while (1) { sl@0: if (isdigit(UCHAR(*right)) /* INTL: digit */ sl@0: && isdigit(UCHAR(*left))) { /* INTL: digit */ sl@0: /* sl@0: * There are decimal numbers embedded in the two sl@0: * strings. Compare them as numbers, rather than sl@0: * strings. If one number has more leading zeros than sl@0: * the other, the number with more leading zeros sorts sl@0: * later, but only as a secondary choice. sl@0: */ sl@0: sl@0: zeros = 0; sl@0: while ((*right == '0') && (isdigit(UCHAR(right[1])))) { sl@0: right++; sl@0: zeros--; sl@0: } sl@0: while ((*left == '0') && (isdigit(UCHAR(left[1])))) { sl@0: left++; sl@0: zeros++; sl@0: } sl@0: if (secondaryDiff == 0) { sl@0: secondaryDiff = zeros; sl@0: } sl@0: sl@0: /* sl@0: * The code below compares the numbers in the two sl@0: * strings without ever converting them to integers. It sl@0: * does this by first comparing the lengths of the sl@0: * numbers and then comparing the digit values. sl@0: */ sl@0: sl@0: diff = 0; sl@0: while (1) { sl@0: if (diff == 0) { sl@0: diff = UCHAR(*left) - UCHAR(*right); sl@0: } sl@0: right++; sl@0: left++; sl@0: if (!isdigit(UCHAR(*right))) { /* INTL: digit */ sl@0: if (isdigit(UCHAR(*left))) { /* INTL: digit */ sl@0: return 1; sl@0: } else { sl@0: /* sl@0: * The two numbers have the same length. See sl@0: * if their values are different. sl@0: */ sl@0: sl@0: if (diff != 0) { sl@0: return diff; sl@0: } sl@0: break; sl@0: } sl@0: } else if (!isdigit(UCHAR(*left))) { /* INTL: digit */ sl@0: return -1; sl@0: } sl@0: } sl@0: continue; sl@0: } sl@0: sl@0: /* sl@0: * Convert character to Unicode for comparison purposes. If either sl@0: * string is at the terminating null, do a byte-wise comparison and sl@0: * bail out immediately. sl@0: */ sl@0: sl@0: if ((*left != '\0') && (*right != '\0')) { sl@0: left += Tcl_UtfToUniChar(left, &uniLeft); sl@0: right += Tcl_UtfToUniChar(right, &uniRight); sl@0: /* sl@0: * Convert both chars to lower for the comparison, because sl@0: * dictionary sorts are case insensitve. Covert to lower, not sl@0: * upper, so chars between Z and a will sort before A (where most sl@0: * other interesting punctuations occur) sl@0: */ sl@0: uniLeftLower = Tcl_UniCharToLower(uniLeft); sl@0: uniRightLower = Tcl_UniCharToLower(uniRight); sl@0: } else { sl@0: diff = UCHAR(*left) - UCHAR(*right); sl@0: break; sl@0: } sl@0: sl@0: diff = uniLeftLower - uniRightLower; sl@0: if (diff) { sl@0: return diff; sl@0: } else if (secondaryDiff == 0) { sl@0: if (Tcl_UniCharIsUpper(uniLeft) && sl@0: Tcl_UniCharIsLower(uniRight)) { sl@0: secondaryDiff = -1; sl@0: } else if (Tcl_UniCharIsUpper(uniRight) sl@0: && Tcl_UniCharIsLower(uniLeft)) { sl@0: secondaryDiff = 1; sl@0: } sl@0: } sl@0: } sl@0: if (diff == 0) { sl@0: diff = secondaryDiff; sl@0: } sl@0: return diff; sl@0: } sl@0: sl@0: /* sl@0: * Local Variables: sl@0: * mode: c sl@0: * c-basic-offset: 4 sl@0: * fill-column: 78 sl@0: * End: sl@0: */ sl@0: