/[dtapublic]/projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclcmdil.c
ViewVC logotype

Diff of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclcmdil.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

to_be_filed/sf_code/esrgpcpj/shared/tcl_base/tclcmdil.c revision 29 by dashley, Sat Oct 8 07:08:47 2016 UTC projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclcmdil.c revision 71 by dashley, Sat Nov 5 11:07:06 2016 UTC
# Line 1  Line 1 
 /* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tcl_base/tclcmdil.c,v 1.1.1.1 2001/06/13 04:34:54 dtashley Exp $ */  
   
 /*  
  * tclCmdIL.c --  
  *  
  *      This file contains the top-level command routines for most of  
  *      the Tcl built-in commands whose names begin with the letters  
  *      I through L.  It contains only commands in the generic core  
  *      (i.e. those that don't depend much upon UNIX facilities).  
  *  
  * Copyright (c) 1987-1993 The Regents of the University of California.  
  * Copyright (c) 1993-1997 Lucent Technologies.  
  * Copyright (c) 1994-1997 Sun Microsystems, Inc.  
  * Copyright (c) 1998-1999 by Scriptics Corporation.  
  *  
  * See the file "license.terms" for information on usage and redistribution  
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.  
  *  
  * RCS: @(#) $Id: tclcmdil.c,v 1.1.1.1 2001/06/13 04:34:54 dtashley Exp $  
  */  
   
 #include "tclInt.h"  
 #include "tclPort.h"  
 #include "tclCompile.h"  
 #include "tclRegexp.h"  
   
 /*  
  * During execution of the "lsort" command, structures of the following  
  * type are used to arrange the objects being sorted into a collection  
  * of linked lists.  
  */  
   
 typedef struct SortElement {  
     Tcl_Obj *objPtr;                    /* Object being sorted. */  
     int count;                          /* number of same elements in list */  
     struct SortElement *nextPtr;        /* Next element in the list, or  
                                          * NULL for end of list. */  
 } SortElement;  
   
 /*  
  * The "lsort" command needs to pass certain information down to the  
  * function that compares two list elements, and the comparison function  
  * needs to pass success or failure information back up to the top-level  
  * "lsort" command.  The following structure is used to pass this  
  * information.  
  */  
   
 typedef struct SortInfo {  
     int isIncreasing;           /* Nonzero means sort in increasing order. */  
     int sortMode;               /* The sort mode.  One of SORTMODE_*  
                                  * values defined below */  
     Tcl_Obj *compareCmdPtr;     /* The Tcl comparison command when sortMode  
                                  * is SORTMODE_COMMAND.  Pre-initialized to  
                                  * hold base of command.*/  
     int index;                  /* If the -index option was specified, this  
                                  * holds the index of the list element  
                                  * to extract for comparison.  If -index  
                                  * wasn't specified, this is -1. */  
     Tcl_Interp *interp;         /* The interpreter in which the sortis  
                                  * being done. */  
     int resultCode;             /* Completion code for the lsort command.  
                                  * If an error occurs during the sort this  
                                  * is changed from TCL_OK to  TCL_ERROR. */  
 } SortInfo;  
   
 /*  
  * The "sortMode" field of the SortInfo structure can take on any of the  
  * following values.  
  */  
   
 #define SORTMODE_ASCII      0  
 #define SORTMODE_INTEGER    1  
 #define SORTMODE_REAL       2  
 #define SORTMODE_COMMAND    3  
 #define SORTMODE_DICTIONARY 4  
   
 /*  
  * Forward declarations for procedures defined in this file:  
  */  
   
 static void             AppendLocals _ANSI_ARGS_((Tcl_Interp *interp,  
                             Tcl_Obj *listPtr, char *pattern,  
                             int includeLinks));  
 static int              DictionaryCompare _ANSI_ARGS_((char *left,  
                             char *right));  
 static int              InfoArgsCmd _ANSI_ARGS_((ClientData dummy,  
                             Tcl_Interp *interp, int objc,  
                             Tcl_Obj *CONST objv[]));  
 static int              InfoBodyCmd _ANSI_ARGS_((ClientData dummy,  
                             Tcl_Interp *interp, int objc,  
                             Tcl_Obj *CONST objv[]));  
 static int              InfoCmdCountCmd _ANSI_ARGS_((ClientData dummy,  
                             Tcl_Interp *interp, int objc,  
                             Tcl_Obj *CONST objv[]));  
 static int              InfoCommandsCmd _ANSI_ARGS_((ClientData dummy,  
                             Tcl_Interp *interp, int objc,  
                             Tcl_Obj *CONST objv[]));  
 static int              InfoCompleteCmd _ANSI_ARGS_((ClientData dummy,  
                             Tcl_Interp *interp, int objc,  
                             Tcl_Obj *CONST objv[]));  
 static int              InfoDefaultCmd _ANSI_ARGS_((ClientData dummy,  
                             Tcl_Interp *interp, int objc,  
                             Tcl_Obj *CONST objv[]));  
 static int              InfoExistsCmd _ANSI_ARGS_((ClientData dummy,  
                             Tcl_Interp *interp, int objc,  
                             Tcl_Obj *CONST objv[]));  
 static int              InfoGlobalsCmd _ANSI_ARGS_((ClientData dummy,  
                             Tcl_Interp *interp, int objc,  
                             Tcl_Obj *CONST objv[]));  
 static int              InfoHostnameCmd _ANSI_ARGS_((ClientData dummy,  
                             Tcl_Interp *interp, int objc,  
                             Tcl_Obj *CONST objv[]));  
 static int              InfoLevelCmd _ANSI_ARGS_((ClientData dummy,  
                             Tcl_Interp *interp, int objc,  
                             Tcl_Obj *CONST objv[]));  
 static int              InfoLibraryCmd _ANSI_ARGS_((ClientData dummy,  
                             Tcl_Interp *interp, int objc,  
                             Tcl_Obj *CONST objv[]));  
 static int              InfoLoadedCmd _ANSI_ARGS_((ClientData dummy,  
                             Tcl_Interp *interp, int objc,  
                             Tcl_Obj *CONST objv[]));  
 static int              InfoLocalsCmd _ANSI_ARGS_((ClientData dummy,  
                             Tcl_Interp *interp, int objc,  
                             Tcl_Obj *CONST objv[]));  
 static int              InfoNameOfExecutableCmd _ANSI_ARGS_((  
                             ClientData dummy, Tcl_Interp *interp, int objc,  
                             Tcl_Obj *CONST objv[]));  
 static int              InfoPatchLevelCmd _ANSI_ARGS_((ClientData dummy,  
                             Tcl_Interp *interp, int objc,  
                             Tcl_Obj *CONST objv[]));  
 static int              InfoProcsCmd _ANSI_ARGS_((ClientData dummy,  
                             Tcl_Interp *interp, int objc,  
                             Tcl_Obj *CONST objv[]));  
 static int              InfoScriptCmd _ANSI_ARGS_((ClientData dummy,  
                             Tcl_Interp *interp, int objc,  
                             Tcl_Obj *CONST objv[]));  
 static int              InfoSharedlibCmd _ANSI_ARGS_((ClientData dummy,  
                             Tcl_Interp *interp, int objc,  
                             Tcl_Obj *CONST objv[]));  
 static int              InfoTclVersionCmd _ANSI_ARGS_((ClientData dummy,  
                             Tcl_Interp *interp, int objc,  
                             Tcl_Obj *CONST objv[]));  
 static int              InfoVarsCmd _ANSI_ARGS_((ClientData dummy,  
                             Tcl_Interp *interp, int objc,  
                             Tcl_Obj *CONST objv[]));  
 static SortElement *    MergeSort _ANSI_ARGS_((SortElement *headPt,  
                             SortInfo *infoPtr));  
 static SortElement *    MergeLists _ANSI_ARGS_((SortElement *leftPtr,  
                             SortElement *rightPtr, SortInfo *infoPtr));  
 static int              SortCompare _ANSI_ARGS_((Tcl_Obj *firstPtr,  
                             Tcl_Obj *second, SortInfo *infoPtr));  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * Tcl_IfObjCmd --  
  *  
  *      This procedure is invoked to process the "if" Tcl command.  
  *      See the user documentation for details on what it does.  
  *  
  *      With the bytecode compiler, this procedure is only called when  
  *      a command name is computed at runtime, and is "if" or the name  
  *      to which "if" was renamed: e.g., "set z if; $z 1 {puts foo}"  
  *  
  * Results:  
  *      A standard Tcl result.  
  *  
  * Side effects:  
  *      See the user documentation.  
  *  
  *----------------------------------------------------------------------  
  */  
   
         /* ARGSUSED */  
 int  
 Tcl_IfObjCmd(dummy, interp, objc, objv)  
     ClientData dummy;                   /* Not used. */  
     Tcl_Interp *interp;                 /* Current interpreter. */  
     int objc;                           /* Number of arguments. */  
     Tcl_Obj *CONST objv[];              /* Argument objects. */  
 {  
     int thenScriptIndex = 0;    /* then script to be evaled after syntax check */  
     int i, result, value;  
     char *clause;  
     i = 1;  
     while (1) {  
         /*  
          * At this point in the loop, objv and objc refer to an expression  
          * to test, either for the main expression or an expression  
          * following an "elseif".  The arguments after the expression must  
          * be "then" (optional) and a script to execute if the expression is  
          * true.  
          */  
   
         if (i >= objc) {  
             clause = Tcl_GetString(objv[i-1]);  
             Tcl_AppendResult(interp, "wrong # args: no expression after \"",  
                     clause, "\" argument", (char *) NULL);  
             return TCL_ERROR;  
         }  
         if (!thenScriptIndex) {  
             result = Tcl_ExprBooleanObj(interp, objv[i], &value);  
             if (result != TCL_OK) {  
                 return result;  
             }  
         }  
         i++;  
         if (i >= objc) {  
             missingScript:  
             clause = Tcl_GetString(objv[i-1]);  
             Tcl_AppendResult(interp, "wrong # args: no script following \"",  
                     clause, "\" argument", (char *) NULL);  
             return TCL_ERROR;  
         }  
         clause = Tcl_GetString(objv[i]);  
         if ((i < objc) && (strcmp(clause, "then") == 0)) {  
             i++;  
         }  
         if (i >= objc) {  
             goto missingScript;  
         }  
         if (value) {  
             thenScriptIndex = i;  
             value = 0;  
         }  
           
         /*  
          * The expression evaluated to false.  Skip the command, then  
          * see if there is an "else" or "elseif" clause.  
          */  
   
         i++;  
         if (i >= objc) {  
             if (thenScriptIndex) {  
                 return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0);  
             }  
             return TCL_OK;  
         }  
         clause = Tcl_GetString(objv[i]);  
         if ((clause[0] == 'e') && (strcmp(clause, "elseif") == 0)) {  
             i++;  
             continue;  
         }  
         break;  
     }  
   
     /*  
      * Couldn't find a "then" or "elseif" clause to execute.  Check now  
      * for an "else" clause.  We know that there's at least one more  
      * argument when we get here.  
      */  
   
     if (strcmp(clause, "else") == 0) {  
         i++;  
         if (i >= objc) {  
             Tcl_AppendResult(interp,  
                     "wrong # args: no script following \"else\" argument",  
                     (char *) NULL);  
             return TCL_ERROR;  
         }  
     }  
     if (i < objc - 1) {  
         Tcl_AppendResult(interp,  
                 "wrong # args: extra words after \"else\" clause in \"if\" command",  
                 (char *) NULL);  
         return TCL_ERROR;  
     }  
     if (thenScriptIndex) {  
         return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0);  
     }  
     return Tcl_EvalObjEx(interp, objv[i], 0);  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * Tcl_IncrObjCmd --  
  *  
  *      This procedure is invoked to process the "incr" Tcl command.  
  *      See the user documentation for details on what it does.  
  *  
  *      With the bytecode compiler, this procedure is only called when  
  *      a command name is computed at runtime, and is "incr" or the name  
  *      to which "incr" was renamed: e.g., "set z incr; $z i -1"  
  *  
  * Results:  
  *      A standard Tcl result.  
  *  
  * Side effects:  
  *      See the user documentation.  
  *  
  *----------------------------------------------------------------------  
  */  
   
     /* ARGSUSED */  
 int  
 Tcl_IncrObjCmd(dummy, interp, objc, objv)  
     ClientData dummy;                   /* Not used. */  
     Tcl_Interp *interp;                 /* Current interpreter. */  
     int objc;                           /* Number of arguments. */  
     Tcl_Obj *CONST objv[];              /* Argument objects. */  
 {  
     long incrAmount;  
     Tcl_Obj *newValuePtr;  
       
     if ((objc != 2) && (objc != 3)) {  
         Tcl_WrongNumArgs(interp, 1, objv, "varName ?increment?");  
         return TCL_ERROR;  
     }  
   
     /*  
      * Calculate the amount to increment by.  
      */  
       
     if (objc == 2) {  
         incrAmount = 1;  
     } else {  
         if (Tcl_GetLongFromObj(interp, objv[2], &incrAmount) != TCL_OK) {  
             Tcl_AddErrorInfo(interp, "\n    (reading increment)");  
             return TCL_ERROR;  
         }  
     }  
       
     /*  
      * Increment the variable's value.  
      */  
   
     newValuePtr = TclIncrVar2(interp, objv[1], (Tcl_Obj *) NULL, incrAmount,  
             TCL_LEAVE_ERR_MSG);  
     if (newValuePtr == NULL) {  
         return TCL_ERROR;  
     }  
   
     /*  
      * Set the interpreter's object result to refer to the variable's new  
      * value object.  
      */  
   
     Tcl_SetObjResult(interp, newValuePtr);  
     return TCL_OK;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * Tcl_InfoObjCmd --  
  *  
  *      This procedure is invoked to process the "info" Tcl command.  
  *      See the user documentation for details on what it does.  
  *  
  * Results:  
  *      A standard Tcl result.  
  *  
  * Side effects:  
  *      See the user documentation.  
  *  
  *----------------------------------------------------------------------  
  */  
   
         /* ARGSUSED */  
 int  
 Tcl_InfoObjCmd(clientData, interp, objc, objv)  
     ClientData clientData;      /* Arbitrary value passed to the command. */  
     Tcl_Interp *interp;         /* Current interpreter. */  
     int objc;                   /* Number of arguments. */  
     Tcl_Obj *CONST objv[];      /* Argument objects. */  
 {  
     static char *subCmds[] = {  
             "args", "body", "cmdcount", "commands",  
              "complete", "default", "exists", "globals",  
              "hostname", "level", "library", "loaded",  
              "locals", "nameofexecutable", "patchlevel", "procs",  
              "script", "sharedlibextension", "tclversion", "vars",  
              (char *) NULL};  
     enum ISubCmdIdx {  
             IArgsIdx, IBodyIdx, ICmdCountIdx, ICommandsIdx,  
             ICompleteIdx, IDefaultIdx, IExistsIdx, IGlobalsIdx,  
             IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx,  
             ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx,  
             IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx  
     };  
     int index, result;  
   
     if (objc < 2) {  
         Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");  
         return TCL_ERROR;  
     }  
       
     result = Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", 0,  
             (int *) &index);  
     if (result != TCL_OK) {  
         return result;  
     }  
   
     switch (index) {  
         case IArgsIdx:  
             result = InfoArgsCmd(clientData, interp, objc, objv);  
             break;  
         case IBodyIdx:  
             result = InfoBodyCmd(clientData, interp, objc, objv);  
             break;  
         case ICmdCountIdx:  
             result = InfoCmdCountCmd(clientData, interp, objc, objv);  
             break;  
         case ICommandsIdx:  
             result = InfoCommandsCmd(clientData, interp, objc, objv);  
             break;  
         case ICompleteIdx:  
             result = InfoCompleteCmd(clientData, interp, objc, objv);  
             break;  
         case IDefaultIdx:  
             result = InfoDefaultCmd(clientData, interp, objc, objv);  
             break;  
         case IExistsIdx:  
             result = InfoExistsCmd(clientData, interp, objc, objv);  
             break;  
         case IGlobalsIdx:  
             result = InfoGlobalsCmd(clientData, interp, objc, objv);  
             break;  
         case IHostnameIdx:  
             result = InfoHostnameCmd(clientData, interp, objc, objv);  
             break;  
         case ILevelIdx:  
             result = InfoLevelCmd(clientData, interp, objc, objv);  
             break;  
         case ILibraryIdx:  
             result = InfoLibraryCmd(clientData, interp, objc, objv);  
             break;  
         case ILoadedIdx:  
             result = InfoLoadedCmd(clientData, interp, objc, objv);  
             break;  
         case ILocalsIdx:  
             result = InfoLocalsCmd(clientData, interp, objc, objv);  
             break;  
         case INameOfExecutableIdx:  
             result = InfoNameOfExecutableCmd(clientData, interp, objc, objv);  
             break;  
         case IPatchLevelIdx:  
             result = InfoPatchLevelCmd(clientData, interp, objc, objv);  
             break;  
         case IProcsIdx:  
             result = InfoProcsCmd(clientData, interp, objc, objv);  
             break;  
         case IScriptIdx:  
             result = InfoScriptCmd(clientData, interp, objc, objv);  
             break;  
         case ISharedLibExtensionIdx:  
             result = InfoSharedlibCmd(clientData, interp, objc, objv);  
             break;  
         case ITclVersionIdx:  
             result = InfoTclVersionCmd(clientData, interp, objc, objv);  
             break;  
         case IVarsIdx:  
             result = InfoVarsCmd(clientData, interp, objc, objv);  
             break;  
     }  
     return result;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * InfoArgsCmd --  
  *  
  *      Called to implement the "info args" command that returns the  
  *      argument list for a procedure. Handles the following syntax:  
  *  
  *          info args procName  
  *  
  * Results:  
  *      Returns TCL_OK if successful and TCL_ERROR if there is an error.  
  *  
  * Side effects:  
  *      Returns a result in the interpreter's result object. If there is  
  *      an error, the result is an error message.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 static int  
 InfoArgsCmd(dummy, interp, objc, objv)  
     ClientData dummy;           /* Not used. */  
     Tcl_Interp *interp;         /* Current interpreter. */  
     int objc;                   /* Number of arguments. */  
     Tcl_Obj *CONST objv[];      /* Argument objects. */  
 {  
     register Interp *iPtr = (Interp *) interp;  
     char *name;  
     Proc *procPtr;  
     CompiledLocal *localPtr;  
     Tcl_Obj *listObjPtr;  
   
     if (objc != 3) {  
         Tcl_WrongNumArgs(interp, 2, objv, "procname");  
         return TCL_ERROR;  
     }  
   
     name = Tcl_GetString(objv[2]);  
     procPtr = TclFindProc(iPtr, name);  
     if (procPtr == NULL) {  
         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),  
                 "\"", name, "\" isn't a procedure", (char *) NULL);  
         return TCL_ERROR;  
     }  
   
     /*  
      * Build a return list containing the arguments.  
      */  
       
     listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);  
     for (localPtr = procPtr->firstLocalPtr;  localPtr != NULL;  
             localPtr = localPtr->nextPtr) {  
         if (TclIsVarArgument(localPtr)) {  
             Tcl_ListObjAppendElement(interp, listObjPtr,  
                     Tcl_NewStringObj(localPtr->name, -1));  
         }  
     }  
     Tcl_SetObjResult(interp, listObjPtr);  
     return TCL_OK;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * InfoBodyCmd --  
  *  
  *      Called to implement the "info body" command that returns the body  
  *      for a procedure. Handles the following syntax:  
  *  
  *          info body procName  
  *  
  * Results:  
  *      Returns TCL_OK if successful and TCL_ERROR if there is an error.  
  *  
  * Side effects:  
  *      Returns a result in the interpreter's result object. If there is  
  *      an error, the result is an error message.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 static int  
 InfoBodyCmd(dummy, interp, objc, objv)  
     ClientData dummy;           /* Not used. */  
     Tcl_Interp *interp;         /* Current interpreter. */  
     int objc;                   /* Number of arguments. */  
     Tcl_Obj *CONST objv[];      /* Argument objects. */  
 {  
     register Interp *iPtr = (Interp *) interp;  
     char *name;  
     Proc *procPtr;  
     Tcl_Obj *bodyPtr, *resultPtr;  
       
     if (objc != 3) {  
         Tcl_WrongNumArgs(interp, 2, objv, "procname");  
         return TCL_ERROR;  
     }  
   
     name = Tcl_GetString(objv[2]);  
     procPtr = TclFindProc(iPtr, name);  
     if (procPtr == NULL) {  
         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),  
                 "\"", name, "\" isn't a procedure", (char *) NULL);  
         return TCL_ERROR;  
     }  
   
     /*  
      * We should not return a bytecompiled body.  If it is precompiled,  
      * then the bodyPtr's string representation is bogus, since sources  
      * are not available.  If it was just a bytecompiled body, then it  
      * is likely to not be of any use to the caller, as it was compiled  
      * for a separate procedure context [Bug: 3412], and noone else can  
      * reasonably use it.  
      * In order to make sure that later manipulations of the object do not  
      * invalidate the internal representation, we make a copy of the string  
      * representation and return that one, instead.  
      */  
   
     bodyPtr = procPtr->bodyPtr;  
     resultPtr = bodyPtr;  
     if (bodyPtr->typePtr == &tclByteCodeType) {  
         resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length);  
     }  
       
     Tcl_SetObjResult(interp, resultPtr);  
     return TCL_OK;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * InfoCmdCountCmd --  
  *  
  *      Called to implement the "info cmdcount" command that returns the  
  *      number of commands that have been executed. Handles the following  
  *      syntax:  
  *  
  *          info cmdcount  
  *  
  * Results:  
  *      Returns TCL_OK if successful and TCL_ERROR if there is an error.  
  *  
  * Side effects:  
  *      Returns a result in the interpreter's result object. If there is  
  *      an error, the result is an error message.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 static int  
 InfoCmdCountCmd(dummy, interp, objc, objv)  
     ClientData dummy;           /* Not used. */  
     Tcl_Interp *interp;         /* Current interpreter. */  
     int objc;                   /* Number of arguments. */  
     Tcl_Obj *CONST objv[];      /* Argument objects. */  
 {  
     Interp *iPtr = (Interp *) interp;  
       
     if (objc != 2) {  
         Tcl_WrongNumArgs(interp, 2, objv, NULL);  
         return TCL_ERROR;  
     }  
   
     Tcl_SetIntObj(Tcl_GetObjResult(interp), iPtr->cmdCount);  
     return TCL_OK;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * InfoCommandsCmd --  
  *  
  *      Called to implement the "info commands" command that returns the  
  *      list of commands in the interpreter that match an optional pattern.  
  *      The pattern, if any, consists of an optional sequence of namespace  
  *      names separated by "::" qualifiers, which is followed by a  
  *      glob-style pattern that restricts which commands are returned.  
  *      Handles the following syntax:  
  *  
  *          info commands ?pattern?  
  *  
  * Results:  
  *      Returns TCL_OK if successful and TCL_ERROR if there is an error.  
  *  
  * Side effects:  
  *      Returns a result in the interpreter's result object. If there is  
  *      an error, the result is an error message.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 static int  
 InfoCommandsCmd(dummy, interp, objc, objv)  
     ClientData dummy;           /* Not used. */  
     Tcl_Interp *interp;         /* Current interpreter. */  
     int objc;                   /* Number of arguments. */  
     Tcl_Obj *CONST objv[];      /* Argument objects. */  
 {  
     char *cmdName, *pattern, *simplePattern;  
     register Tcl_HashEntry *entryPtr;  
     Tcl_HashSearch search;  
     Namespace *nsPtr;  
     Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);  
     Namespace *currNsPtr   = (Namespace *) Tcl_GetCurrentNamespace(interp);  
     Tcl_Obj *listPtr, *elemObjPtr;  
     int specificNsInPattern = 0;  /* Init. to avoid compiler warning. */  
     Tcl_Command cmd;  
   
     /*  
      * Get the pattern and find the "effective namespace" in which to  
      * list commands.  
      */  
   
     if (objc == 2) {  
         simplePattern = NULL;  
         nsPtr = currNsPtr;  
         specificNsInPattern = 0;  
     } else if (objc == 3) {  
         /*  
          * From the pattern, get the effective namespace and the simple  
          * pattern (no namespace qualifiers or ::'s) at the end. If an  
          * error was found while parsing the pattern, return it. Otherwise,  
          * if the namespace wasn't found, just leave nsPtr NULL: we will  
          * return an empty list since no commands there can be found.  
          */  
   
         Namespace *dummy1NsPtr, *dummy2NsPtr;  
           
   
         pattern = Tcl_GetString(objv[2]);  
         TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL,  
            /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern);  
   
         if (nsPtr != NULL) {    /* we successfully found the pattern's ns */  
             specificNsInPattern = (strcmp(simplePattern, pattern) != 0);  
         }  
     } else {  
         Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");  
         return TCL_ERROR;  
     }  
   
     /*  
      * Scan through the effective namespace's command table and create a  
      * list with all commands that match the pattern. If a specific  
      * namespace was requested in the pattern, qualify the command names  
      * with the namespace name.  
      */  
   
     listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);  
   
     if (nsPtr != NULL) {  
         entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);  
         while (entryPtr != NULL) {  
             cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);  
             if ((simplePattern == NULL)  
                     || Tcl_StringMatch(cmdName, simplePattern)) {  
                 if (specificNsInPattern) {  
                     cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr);  
                     elemObjPtr = Tcl_NewObj();  
                     Tcl_GetCommandFullName(interp, cmd, elemObjPtr);  
                 } else {  
                     elemObjPtr = Tcl_NewStringObj(cmdName, -1);  
                 }  
                 Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);  
             }  
             entryPtr = Tcl_NextHashEntry(&search);  
         }  
   
         /*  
          * If the effective namespace isn't the global :: namespace, and a  
          * specific namespace wasn't requested in the pattern, then add in  
          * all global :: commands that match the simple pattern. Of course,  
          * we add in only those commands that aren't hidden by a command in  
          * the effective namespace.  
          */  
           
         if ((nsPtr != globalNsPtr) && !specificNsInPattern) {  
             entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);  
             while (entryPtr != NULL) {  
                 cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);  
                 if ((simplePattern == NULL)  
                         || Tcl_StringMatch(cmdName, simplePattern)) {  
                     if (Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) {  
                         Tcl_ListObjAppendElement(interp, listPtr,  
                                 Tcl_NewStringObj(cmdName, -1));  
                     }  
                 }  
                 entryPtr = Tcl_NextHashEntry(&search);  
             }  
         }  
     }  
       
     Tcl_SetObjResult(interp, listPtr);  
     return TCL_OK;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * InfoCompleteCmd --  
  *  
  *      Called to implement the "info complete" command that determines  
  *      whether a string is a complete Tcl command. Handles the following  
  *      syntax:  
  *  
  *          info complete command  
  *  
  * Results:  
  *      Returns TCL_OK if successful and TCL_ERROR if there is an error.  
  *  
  * Side effects:  
  *      Returns a result in the interpreter's result object. If there is  
  *      an error, the result is an error message.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 static int  
 InfoCompleteCmd(dummy, interp, objc, objv)  
     ClientData dummy;           /* Not used. */  
     Tcl_Interp *interp;         /* Current interpreter. */  
     int objc;                   /* Number of arguments. */  
     Tcl_Obj *CONST objv[];      /* Argument objects. */  
 {  
     if (objc != 3) {  
         Tcl_WrongNumArgs(interp, 2, objv, "command");  
         return TCL_ERROR;  
     }  
   
     if (TclObjCommandComplete(objv[2])) {  
         Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);  
     } else {  
         Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);  
     }  
   
     return TCL_OK;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * InfoDefaultCmd --  
  *  
  *      Called to implement the "info default" command that returns the  
  *      default value for a procedure argument. Handles the following  
  *      syntax:  
  *  
  *          info default procName arg varName  
  *  
  * Results:  
  *      Returns TCL_OK if successful and TCL_ERROR if there is an error.  
  *  
  * Side effects:  
  *      Returns a result in the interpreter's result object. If there is  
  *      an error, the result is an error message.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 static int  
 InfoDefaultCmd(dummy, interp, objc, objv)  
     ClientData dummy;           /* Not used. */  
     Tcl_Interp *interp;         /* Current interpreter. */  
     int objc;                   /* Number of arguments. */  
     Tcl_Obj *CONST objv[];      /* Argument objects. */  
 {  
     Interp *iPtr = (Interp *) interp;  
     char *procName, *argName, *varName;  
     Proc *procPtr;  
     CompiledLocal *localPtr;  
     Tcl_Obj *valueObjPtr;  
   
     if (objc != 5) {  
         Tcl_WrongNumArgs(interp, 2, objv, "procname arg varname");  
         return TCL_ERROR;  
     }  
   
     procName = Tcl_GetString(objv[2]);  
     argName = Tcl_GetString(objv[3]);  
   
     procPtr = TclFindProc(iPtr, procName);  
     if (procPtr == NULL) {  
         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),  
                 "\"", procName, "\" isn't a procedure", (char *) NULL);  
         return TCL_ERROR;  
     }  
   
     for (localPtr = procPtr->firstLocalPtr;  localPtr != NULL;  
             localPtr = localPtr->nextPtr) {  
         if (TclIsVarArgument(localPtr)  
                 && (strcmp(argName, localPtr->name) == 0)) {  
             if (localPtr->defValuePtr != NULL) {  
                 valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL,  
                         localPtr->defValuePtr, 0);  
                 if (valueObjPtr == NULL) {  
                     defStoreError:  
                     varName = Tcl_GetString(objv[4]);  
                     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),  
                             "couldn't store default value in variable \"",  
                             varName, "\"", (char *) NULL);  
                     return TCL_ERROR;  
                 }  
                 Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);  
             } else {  
                 Tcl_Obj *nullObjPtr = Tcl_NewObj();  
                 valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL,  
                         nullObjPtr, 0);  
                 if (valueObjPtr == NULL) {  
                     Tcl_DecrRefCount(nullObjPtr); /* free unneeded obj */  
                     goto defStoreError;  
                 }  
                 Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);  
             }  
             return TCL_OK;  
         }  
     }  
   
     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),  
             "procedure \"", procName, "\" doesn't have an argument \"",  
             argName, "\"", (char *) NULL);  
     return TCL_ERROR;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * InfoExistsCmd --  
  *  
  *      Called to implement the "info exists" command that determines  
  *      whether a variable exists. Handles the following syntax:  
  *  
  *          info exists varName  
  *  
  * Results:  
  *      Returns TCL_OK if successful and TCL_ERROR if there is an error.  
  *  
  * Side effects:  
  *      Returns a result in the interpreter's result object. If there is  
  *      an error, the result is an error message.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 static int  
 InfoExistsCmd(dummy, interp, objc, objv)  
     ClientData dummy;           /* Not used. */  
     Tcl_Interp *interp;         /* Current interpreter. */  
     int objc;                   /* Number of arguments. */  
     Tcl_Obj *CONST objv[];      /* Argument objects. */  
 {  
     char *varName;  
     Var *varPtr;  
   
     if (objc != 3) {  
         Tcl_WrongNumArgs(interp, 2, objv, "varName");  
         return TCL_ERROR;  
     }  
   
     varName = Tcl_GetString(objv[2]);  
     varPtr = TclVarTraceExists(interp, varName);  
     if ((varPtr != NULL) && !TclIsVarUndefined(varPtr)) {  
         Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);  
     } else {  
         Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);  
     }  
     return TCL_OK;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * InfoGlobalsCmd --  
  *  
  *      Called to implement the "info globals" command that returns the list  
  *      of global variables matching an optional pattern. Handles the  
  *      following syntax:  
  *  
  *          info globals ?pattern?  
  *  
  * Results:  
  *      Returns TCL_OK if successful and TCL_ERROR if there is an error.  
  *  
  * Side effects:  
  *      Returns a result in the interpreter's result object. If there is  
  *      an error, the result is an error message.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 static int  
 InfoGlobalsCmd(dummy, interp, objc, objv)  
     ClientData dummy;           /* Not used. */  
     Tcl_Interp *interp;         /* Current interpreter. */  
     int objc;                   /* Number of arguments. */  
     Tcl_Obj *CONST objv[];      /* Argument objects. */  
 {  
     char *varName, *pattern;  
     Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);  
     register Tcl_HashEntry *entryPtr;  
     Tcl_HashSearch search;  
     Var *varPtr;  
     Tcl_Obj *listPtr;  
   
     if (objc == 2) {  
         pattern = NULL;  
     } else if (objc == 3) {  
         pattern = Tcl_GetString(objv[2]);  
     } else {  
         Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");  
         return TCL_ERROR;  
     }  
   
     /*  
      * Scan through the global :: namespace's variable table and create a  
      * list of all global variables that match the pattern.  
      */  
       
     listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);  
     for (entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search);  
             entryPtr != NULL;  
             entryPtr = Tcl_NextHashEntry(&search)) {  
         varPtr = (Var *) Tcl_GetHashValue(entryPtr);  
         if (TclIsVarUndefined(varPtr)) {  
             continue;  
         }  
         varName = Tcl_GetHashKey(&globalNsPtr->varTable, entryPtr);  
         if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {  
             Tcl_ListObjAppendElement(interp, listPtr,  
                     Tcl_NewStringObj(varName, -1));  
         }  
     }  
     Tcl_SetObjResult(interp, listPtr);  
     return TCL_OK;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * InfoHostnameCmd --  
  *  
  *      Called to implement the "info hostname" command that returns the  
  *      host name. Handles the following syntax:  
  *  
  *          info hostname  
  *  
  * Results:  
  *      Returns TCL_OK if successful and TCL_ERROR if there is an error.  
  *  
  * Side effects:  
  *      Returns a result in the interpreter's result object. If there is  
  *      an error, the result is an error message.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 static int  
 InfoHostnameCmd(dummy, interp, objc, objv)  
     ClientData dummy;           /* Not used. */  
     Tcl_Interp *interp;         /* Current interpreter. */  
     int objc;                   /* Number of arguments. */  
     Tcl_Obj *CONST objv[];      /* Argument objects. */  
 {  
     char *name;  
     if (objc != 2) {  
         Tcl_WrongNumArgs(interp, 2, objv, NULL);  
         return TCL_ERROR;  
     }  
   
     name = Tcl_GetHostName();  
     if (name) {  
         Tcl_SetStringObj(Tcl_GetObjResult(interp), name, -1);  
         return TCL_OK;  
     } else {  
         Tcl_SetStringObj(Tcl_GetObjResult(interp),  
                 "unable to determine name of host", -1);  
         return TCL_ERROR;  
     }  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * InfoLevelCmd --  
  *  
  *      Called to implement the "info level" command that returns  
  *      information about the call stack. Handles the following syntax:  
  *  
  *          info level ?number?  
  *  
  * Results:  
  *      Returns TCL_OK if successful and TCL_ERROR if there is an error.  
  *  
  * Side effects:  
  *      Returns a result in the interpreter's result object. If there is  
  *      an error, the result is an error message.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 static int  
 InfoLevelCmd(dummy, interp, objc, objv)  
     ClientData dummy;           /* Not used. */  
     Tcl_Interp *interp;         /* Current interpreter. */  
     int objc;                   /* Number of arguments. */  
     Tcl_Obj *CONST objv[];      /* Argument objects. */  
 {  
     Interp *iPtr = (Interp *) interp;  
     int level;  
     CallFrame *framePtr;  
     Tcl_Obj *listPtr;  
   
     if (objc == 2) {            /* just "info level" */  
         if (iPtr->varFramePtr == NULL) {  
             Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);  
         } else {  
             Tcl_SetIntObj(Tcl_GetObjResult(interp), iPtr->varFramePtr->level);  
         }  
         return TCL_OK;  
     } else if (objc == 3) {  
         if (Tcl_GetIntFromObj(interp, objv[2], &level) != TCL_OK) {  
             return TCL_ERROR;  
         }  
         if (level <= 0) {  
             if (iPtr->varFramePtr == NULL) {  
                 levelError:  
                 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),  
                         "bad level \"",  
                         Tcl_GetString(objv[2]),  
                         "\"", (char *) NULL);  
                 return TCL_ERROR;  
             }  
             level += iPtr->varFramePtr->level;  
         }  
         for (framePtr = iPtr->varFramePtr;  framePtr != NULL;  
                 framePtr = framePtr->callerVarPtr) {  
             if (framePtr->level == level) {  
                 break;  
             }  
         }  
         if (framePtr == NULL) {  
             goto levelError;  
         }  
   
         listPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv);  
         Tcl_SetObjResult(interp, listPtr);  
         return TCL_OK;  
     }  
   
     Tcl_WrongNumArgs(interp, 2, objv, "?number?");  
     return TCL_ERROR;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * InfoLibraryCmd --  
  *  
  *      Called to implement the "info library" command that returns the  
  *      library directory for the Tcl installation. Handles the following  
  *      syntax:  
  *  
  *          info library  
  *  
  * Results:  
  *      Returns TCL_OK if successful and TCL_ERROR if there is an error.  
  *  
  * Side effects:  
  *      Returns a result in the interpreter's result object. If there is  
  *      an error, the result is an error message.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 static int  
 InfoLibraryCmd(dummy, interp, objc, objv)  
     ClientData dummy;           /* Not used. */  
     Tcl_Interp *interp;         /* Current interpreter. */  
     int objc;                   /* Number of arguments. */  
     Tcl_Obj *CONST objv[];      /* Argument objects. */  
 {  
     char *libDirName;  
   
     if (objc != 2) {  
         Tcl_WrongNumArgs(interp, 2, objv, NULL);  
         return TCL_ERROR;  
     }  
   
     libDirName = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);  
     if (libDirName != NULL) {  
         Tcl_SetStringObj(Tcl_GetObjResult(interp), libDirName, -1);  
         return TCL_OK;  
     }  
     Tcl_SetStringObj(Tcl_GetObjResult(interp),  
             "no library has been specified for Tcl", -1);  
     return TCL_ERROR;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * InfoLoadedCmd --  
  *  
  *      Called to implement the "info loaded" command that returns the  
  *      packages that have been loaded into an interpreter. Handles the  
  *      following syntax:  
  *  
  *          info loaded ?interp?  
  *  
  * Results:  
  *      Returns TCL_OK if successful and TCL_ERROR if there is an error.  
  *  
  * Side effects:  
  *      Returns a result in the interpreter's result object. If there is  
  *      an error, the result is an error message.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 static int  
 InfoLoadedCmd(dummy, interp, objc, objv)  
     ClientData dummy;           /* Not used. */  
     Tcl_Interp *interp;         /* Current interpreter. */  
     int objc;                   /* Number of arguments. */  
     Tcl_Obj *CONST objv[];      /* Argument objects. */  
 {  
     char *interpName;  
     int result;  
   
     if ((objc != 2) && (objc != 3)) {  
         Tcl_WrongNumArgs(interp, 2, objv, "?interp?");  
         return TCL_ERROR;  
     }  
   
     if (objc == 2) {            /* get loaded pkgs in all interpreters */  
         interpName = NULL;  
     } else {                    /* get pkgs just in specified interp */  
         interpName = Tcl_GetString(objv[2]);  
     }  
     result = TclGetLoadedPackages(interp, interpName);  
     return result;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * InfoLocalsCmd --  
  *  
  *      Called to implement the "info locals" command to return a list of  
  *      local variables that match an optional pattern. Handles the  
  *      following syntax:  
  *  
  *          info locals ?pattern?  
  *  
  * Results:  
  *      Returns TCL_OK if successful and TCL_ERROR if there is an error.  
  *  
  * Side effects:  
  *      Returns a result in the interpreter's result object. If there is  
  *      an error, the result is an error message.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 static int  
 InfoLocalsCmd(dummy, interp, objc, objv)  
     ClientData dummy;           /* Not used. */  
     Tcl_Interp *interp;         /* Current interpreter. */  
     int objc;                   /* Number of arguments. */  
     Tcl_Obj *CONST objv[];      /* Argument objects. */  
 {  
     Interp *iPtr = (Interp *) interp;  
     char *pattern;  
     Tcl_Obj *listPtr;  
   
     if (objc == 2) {  
         pattern = NULL;  
     } else if (objc == 3) {  
         pattern = Tcl_GetString(objv[2]);  
     } else {  
         Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");  
         return TCL_ERROR;  
     }  
       
     if (iPtr->varFramePtr == NULL || !iPtr->varFramePtr->isProcCallFrame) {  
         return TCL_OK;  
     }  
   
     /*  
      * Return a list containing names of first the compiled locals (i.e. the  
      * ones stored in the call frame), then the variables in the local hash  
      * table (if one exists).  
      */  
       
     listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);  
     AppendLocals(interp, listPtr, pattern, 0);  
     Tcl_SetObjResult(interp, listPtr);  
     return TCL_OK;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * AppendLocals --  
  *  
  *      Append the local variables for the current frame to the  
  *      specified list object.  
  *  
  * Results:  
  *      None.  
  *  
  * Side effects:  
  *      None.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 static void  
 AppendLocals(interp, listPtr, pattern, includeLinks)  
     Tcl_Interp *interp;         /* Current interpreter. */  
     Tcl_Obj *listPtr;           /* List object to append names to. */  
     char *pattern;              /* Pattern to match against. */  
     int includeLinks;           /* 1 if upvars should be included, else 0. */  
 {  
     Interp *iPtr = (Interp *) interp;  
     CompiledLocal *localPtr;  
     Var *varPtr;  
     int i, localVarCt;  
     char *varName;  
     Tcl_HashTable *localVarTablePtr;  
     register Tcl_HashEntry *entryPtr;  
     Tcl_HashSearch search;  
   
     localPtr = iPtr->varFramePtr->procPtr->firstLocalPtr;  
     localVarCt = iPtr->varFramePtr->numCompiledLocals;  
     varPtr = iPtr->varFramePtr->compiledLocals;  
     localVarTablePtr = iPtr->varFramePtr->varTablePtr;  
   
     for (i = 0; i < localVarCt; i++) {  
         /*  
          * Skip nameless (temporary) variables and undefined variables  
          */  
   
         if (!TclIsVarTemporary(localPtr) && !TclIsVarUndefined(varPtr)) {  
             varName = varPtr->name;  
             if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {  
                 Tcl_ListObjAppendElement(interp, listPtr,  
                         Tcl_NewStringObj(varName, -1));  
             }  
         }  
         varPtr++;  
         localPtr = localPtr->nextPtr;  
     }  
       
     if (localVarTablePtr != NULL) {  
         for (entryPtr = Tcl_FirstHashEntry(localVarTablePtr, &search);  
                 entryPtr != NULL;  
                 entryPtr = Tcl_NextHashEntry(&search)) {  
             varPtr = (Var *) Tcl_GetHashValue(entryPtr);  
             if (!TclIsVarUndefined(varPtr)  
                     && (includeLinks || !TclIsVarLink(varPtr))) {  
                 varName = Tcl_GetHashKey(localVarTablePtr, entryPtr);  
                 if ((pattern == NULL)  
                         || Tcl_StringMatch(varName, pattern)) {  
                     Tcl_ListObjAppendElement(interp, listPtr,  
                             Tcl_NewStringObj(varName, -1));  
                 }  
             }  
         }  
     }  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * InfoNameOfExecutableCmd --  
  *  
  *      Called to implement the "info nameofexecutable" command that returns  
  *      the name of the binary file running this application. Handles the  
  *      following syntax:  
  *  
  *          info nameofexecutable  
  *  
  * Results:  
  *      Returns TCL_OK if successful and TCL_ERROR if there is an error.  
  *  
  * Side effects:  
  *      Returns a result in the interpreter's result object. If there is  
  *      an error, the result is an error message.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 static int  
 InfoNameOfExecutableCmd(dummy, interp, objc, objv)  
     ClientData dummy;           /* Not used. */  
     Tcl_Interp *interp;         /* Current interpreter. */  
     int objc;                   /* Number of arguments. */  
     Tcl_Obj *CONST objv[];      /* Argument objects. */  
 {  
     CONST char *nameOfExecutable;  
   
     if (objc != 2) {  
         Tcl_WrongNumArgs(interp, 2, objv, NULL);  
         return TCL_ERROR;  
     }  
   
     nameOfExecutable = Tcl_GetNameOfExecutable();  
       
     if (nameOfExecutable != NULL) {  
         Tcl_SetStringObj(Tcl_GetObjResult(interp), (char *)nameOfExecutable, -1);  
     }  
     return TCL_OK;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * InfoPatchLevelCmd --  
  *  
  *      Called to implement the "info patchlevel" command that returns the  
  *      default value for an argument to a procedure. Handles the following  
  *      syntax:  
  *  
  *          info patchlevel  
  *  
  * Results:  
  *      Returns TCL_OK if successful and TCL_ERROR if there is an error.  
  *  
  * Side effects:  
  *      Returns a result in the interpreter's result object. If there is  
  *      an error, the result is an error message.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 static int  
 InfoPatchLevelCmd(dummy, interp, objc, objv)  
     ClientData dummy;           /* Not used. */  
     Tcl_Interp *interp;         /* Current interpreter. */  
     int objc;                   /* Number of arguments. */  
     Tcl_Obj *CONST objv[];      /* Argument objects. */  
 {  
     char *patchlevel;  
   
     if (objc != 2) {  
         Tcl_WrongNumArgs(interp, 2, objv, NULL);  
         return TCL_ERROR;  
     }  
   
     patchlevel = Tcl_GetVar(interp, "tcl_patchLevel",  
             (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));  
     if (patchlevel != NULL) {  
         Tcl_SetStringObj(Tcl_GetObjResult(interp), patchlevel, -1);  
         return TCL_OK;  
     }  
     return TCL_ERROR;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * InfoProcsCmd --  
  *  
  *      Called to implement the "info procs" command that returns the  
  *      list of procedures in the interpreter that match an optional pattern.  
  *      The pattern, if any, consists of an optional sequence of namespace  
  *      names separated by "::" qualifiers, which is followed by a  
  *      glob-style pattern that restricts which commands are returned.  
  *      Handles the following syntax:  
  *  
  *          info procs ?pattern?  
  *  
  * Results:  
  *      Returns TCL_OK if successful and TCL_ERROR if there is an error.  
  *  
  * Side effects:  
  *      Returns a result in the interpreter's result object. If there is  
  *      an error, the result is an error message.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 static int  
 InfoProcsCmd(dummy, interp, objc, objv)  
     ClientData dummy;           /* Not used. */  
     Tcl_Interp *interp;         /* Current interpreter. */  
     int objc;                   /* Number of arguments. */  
     Tcl_Obj *CONST objv[];      /* Argument objects. */  
 {  
     char *cmdName, *pattern, *simplePattern;  
     Namespace *nsPtr;  
 #ifdef INFO_PROCS_SEARCH_GLOBAL_NS  
     Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);  
 #endif  
     Namespace *currNsPtr   = (Namespace *) Tcl_GetCurrentNamespace(interp);  
     Tcl_Obj *listPtr, *elemObjPtr;  
     int specificNsInPattern = 0;  /* Init. to avoid compiler warning. */  
     register Tcl_HashEntry *entryPtr;  
     Tcl_HashSearch search;  
     Command *cmdPtr, *realCmdPtr;  
   
     /*  
      * Get the pattern and find the "effective namespace" in which to  
      * list procs.  
      */  
   
     if (objc == 2) {  
         simplePattern = NULL;  
         nsPtr = currNsPtr;  
         specificNsInPattern = 0;  
     } else if (objc == 3) {  
         /*  
          * From the pattern, get the effective namespace and the simple  
          * pattern (no namespace qualifiers or ::'s) at the end. If an  
          * error was found while parsing the pattern, return it. Otherwise,  
          * if the namespace wasn't found, just leave nsPtr NULL: we will  
          * return an empty list since no commands there can be found.  
          */  
   
         Namespace *dummy1NsPtr, *dummy2NsPtr;  
   
         pattern = Tcl_GetString(objv[2]);  
         TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL,  
                 /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr,  
                 &simplePattern);  
   
         if (nsPtr != NULL) {    /* we successfully found the pattern's ns */  
             specificNsInPattern = (strcmp(simplePattern, pattern) != 0);  
         }  
     } else {  
         Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");  
         return TCL_ERROR;  
     }  
   
     /*  
      * Scan through the effective namespace's command table and create a  
      * list with all procs that match the pattern. If a specific  
      * namespace was requested in the pattern, qualify the command names  
      * with the namespace name.  
      */  
   
     listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);  
     if (nsPtr != NULL) {  
         entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);  
         while (entryPtr != NULL) {  
             cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);  
             if ((simplePattern == NULL)  
                     || Tcl_StringMatch(cmdName, simplePattern)) {  
                 cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);  
   
                 if (specificNsInPattern) {  
                     elemObjPtr = Tcl_NewObj();  
                     Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr,  
                             elemObjPtr);  
                 } else {  
                     elemObjPtr = Tcl_NewStringObj(cmdName, -1);  
                 }  
   
                 realCmdPtr = (Command *)  
                     TclGetOriginalCommand((Tcl_Command) cmdPtr);  
   
                 if (TclIsProc(cmdPtr)  
                         || ((realCmdPtr != NULL) && TclIsProc(realCmdPtr))) {  
                     Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);  
                 }  
             }  
             entryPtr = Tcl_NextHashEntry(&search);  
         }  
   
         /*  
          * If the effective namespace isn't the global :: namespace, and a  
          * specific namespace wasn't requested in the pattern, then add in  
          * all global :: procs that match the simple pattern. Of course,  
          * we add in only those procs that aren't hidden by a proc in  
          * the effective namespace.  
          */  
   
 #ifdef INFO_PROCS_SEARCH_GLOBAL_NS  
         /*  
          * If "info procs" worked like "info commands", returning the  
          * commands also seen in the global namespace, then you would  
          * include this code.  As this could break backwards compatibilty  
          * with 8.0-8.2, we decided not to "fix" it in 8.3, leaving the  
          * behavior slightly different.  
          */  
         if ((nsPtr != globalNsPtr) && !specificNsInPattern) {  
             entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);  
             while (entryPtr != NULL) {  
                 cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);  
                 if ((simplePattern == NULL)  
                         || Tcl_StringMatch(cmdName, simplePattern)) {  
                     if (Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) {  
                         cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);  
                         realCmdPtr = (Command *) TclGetOriginalCommand(  
                                 (Tcl_Command) cmdPtr);  
   
                         if (TclIsProc(cmdPtr) || ((realCmdPtr != NULL)  
                                 && TclIsProc(realCmdPtr))) {  
                             Tcl_ListObjAppendElement(interp, listPtr,  
                                     Tcl_NewStringObj(cmdName, -1));  
                         }  
                     }  
                 }  
                 entryPtr = Tcl_NextHashEntry(&search);  
             }  
         }  
 #endif  
     }  
   
     Tcl_SetObjResult(interp, listPtr);  
     return TCL_OK;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * InfoScriptCmd --  
  *  
  *      Called to implement the "info script" command that returns the  
  *      script file that is currently being evaluated. Handles the  
  *      following syntax:  
  *  
  *          info script  
  *  
  * Results:  
  *      Returns TCL_OK if successful and TCL_ERROR if there is an error.  
  *  
  * Side effects:  
  *      Returns a result in the interpreter's result object. If there is  
  *      an error, the result is an error message.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 static int  
 InfoScriptCmd(dummy, interp, objc, objv)  
     ClientData dummy;           /* Not used. */  
     Tcl_Interp *interp;         /* Current interpreter. */  
     int objc;                   /* Number of arguments. */  
     Tcl_Obj *CONST objv[];      /* Argument objects. */  
 {  
     Interp *iPtr = (Interp *) interp;  
     if (objc != 2) {  
         Tcl_WrongNumArgs(interp, 2, objv, NULL);  
         return TCL_ERROR;  
     }  
   
     if (iPtr->scriptFile != NULL) {  
         Tcl_SetStringObj(Tcl_GetObjResult(interp), iPtr->scriptFile, -1);  
     }  
     return TCL_OK;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * InfoSharedlibCmd --  
  *  
  *      Called to implement the "info sharedlibextension" command that  
  *      returns the file extension used for shared libraries. Handles the  
  *      following syntax:  
  *  
  *          info sharedlibextension  
  *  
  * Results:  
  *      Returns TCL_OK if successful and TCL_ERROR if there is an error.  
  *  
  * Side effects:  
  *      Returns a result in the interpreter's result object. If there is  
  *      an error, the result is an error message.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 static int  
 InfoSharedlibCmd(dummy, interp, objc, objv)  
     ClientData dummy;           /* Not used. */  
     Tcl_Interp *interp;         /* Current interpreter. */  
     int objc;                   /* Number of arguments. */  
     Tcl_Obj *CONST objv[];      /* Argument objects. */  
 {  
     if (objc != 2) {  
         Tcl_WrongNumArgs(interp, 2, objv, NULL);  
         return TCL_ERROR;  
     }  
       
 #ifdef TCL_SHLIB_EXT  
     Tcl_SetStringObj(Tcl_GetObjResult(interp), TCL_SHLIB_EXT, -1);  
 #endif  
     return TCL_OK;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * InfoTclVersionCmd --  
  *  
  *      Called to implement the "info tclversion" command that returns the  
  *      version number for this Tcl library. Handles the following syntax:  
  *  
  *          info tclversion  
  *  
  * Results:  
  *      Returns TCL_OK if successful and TCL_ERROR if there is an error.  
  *  
  * Side effects:  
  *      Returns a result in the interpreter's result object. If there is  
  *      an error, the result is an error message.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 static int  
 InfoTclVersionCmd(dummy, interp, objc, objv)  
     ClientData dummy;           /* Not used. */  
     Tcl_Interp *interp;         /* Current interpreter. */  
     int objc;                   /* Number of arguments. */  
     Tcl_Obj *CONST objv[];      /* Argument objects. */  
 {  
     char *version;  
   
     if (objc != 2) {  
         Tcl_WrongNumArgs(interp, 2, objv, NULL);  
         return TCL_ERROR;  
     }  
   
     version = Tcl_GetVar(interp, "tcl_version",  
         (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));  
     if (version != NULL) {  
         Tcl_SetStringObj(Tcl_GetObjResult(interp), version, -1);  
         return TCL_OK;  
     }  
     return TCL_ERROR;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * InfoVarsCmd --  
  *  
  *      Called to implement the "info vars" command that returns the  
  *      list of variables in the interpreter that match an optional pattern.  
  *      The pattern, if any, consists of an optional sequence of namespace  
  *      names separated by "::" qualifiers, which is followed by a  
  *      glob-style pattern that restricts which variables are returned.  
  *      Handles the following syntax:  
  *  
  *          info vars ?pattern?  
  *  
  * Results:  
  *      Returns TCL_OK if successful and TCL_ERROR if there is an error.  
  *  
  * Side effects:  
  *      Returns a result in the interpreter's result object. If there is  
  *      an error, the result is an error message.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 static int  
 InfoVarsCmd(dummy, interp, objc, objv)  
     ClientData dummy;           /* Not used. */  
     Tcl_Interp *interp;         /* Current interpreter. */  
     int objc;                   /* Number of arguments. */  
     Tcl_Obj *CONST objv[];      /* Argument objects. */  
 {  
     Interp *iPtr = (Interp *) interp;  
     char *varName, *pattern, *simplePattern;  
     register Tcl_HashEntry *entryPtr;  
     Tcl_HashSearch search;  
     Var *varPtr;  
     Namespace *nsPtr;  
     Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);  
     Namespace *currNsPtr   = (Namespace *) Tcl_GetCurrentNamespace(interp);  
     Tcl_Obj *listPtr, *elemObjPtr;  
     int specificNsInPattern = 0;  /* Init. to avoid compiler warning. */  
   
     /*  
      * Get the pattern and find the "effective namespace" in which to  
      * list variables. We only use this effective namespace if there's  
      * no active Tcl procedure frame.  
      */  
   
     if (objc == 2) {  
         simplePattern = NULL;  
         nsPtr = currNsPtr;  
         specificNsInPattern = 0;  
     } else if (objc == 3) {  
         /*  
          * From the pattern, get the effective namespace and the simple  
          * pattern (no namespace qualifiers or ::'s) at the end. If an  
          * error was found while parsing the pattern, return it. Otherwise,  
          * if the namespace wasn't found, just leave nsPtr NULL: we will  
          * return an empty list since no variables there can be found.  
          */  
   
         Namespace *dummy1NsPtr, *dummy2NsPtr;  
   
         pattern = Tcl_GetString(objv[2]);  
         TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL,  
                 /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr,  
                 &simplePattern);  
   
         if (nsPtr != NULL) {    /* we successfully found the pattern's ns */  
             specificNsInPattern = (strcmp(simplePattern, pattern) != 0);  
         }  
     } else {  
         Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");  
         return TCL_ERROR;  
     }  
   
     /*  
      * If the namespace specified in the pattern wasn't found, just return.  
      */  
   
     if (nsPtr == NULL) {  
         return TCL_OK;  
     }  
       
     listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);  
       
     if ((iPtr->varFramePtr == NULL)  
             || !iPtr->varFramePtr->isProcCallFrame  
             || specificNsInPattern) {  
         /*  
          * There is no frame pointer, the frame pointer was pushed only  
          * to activate a namespace, or we are in a procedure call frame  
          * but a specific namespace was specified. Create a list containing  
          * only the variables in the effective namespace's variable table.  
          */  
           
         entryPtr = Tcl_FirstHashEntry(&nsPtr->varTable, &search);  
         while (entryPtr != NULL) {  
             varPtr = (Var *) Tcl_GetHashValue(entryPtr);  
             if (!TclIsVarUndefined(varPtr)  
                     || (varPtr->flags & VAR_NAMESPACE_VAR)) {  
                 varName = Tcl_GetHashKey(&nsPtr->varTable, entryPtr);  
                 if ((simplePattern == NULL)  
                         || Tcl_StringMatch(varName, simplePattern)) {  
                     if (specificNsInPattern) {  
                         elemObjPtr = Tcl_NewObj();  
                         Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr,  
                                 elemObjPtr);  
                     } else {  
                         elemObjPtr = Tcl_NewStringObj(varName, -1);  
                     }  
                     Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);  
                 }  
             }  
             entryPtr = Tcl_NextHashEntry(&search);  
         }  
   
         /*  
          * If the effective namespace isn't the global :: namespace, and a  
          * specific namespace wasn't requested in the pattern (i.e., the  
          * pattern only specifies variable names), then add in all global ::  
          * variables that match the simple pattern. Of course, add in only  
          * those variables that aren't hidden by a variable in the effective  
          * namespace.  
          */  
   
         if ((nsPtr != globalNsPtr) && !specificNsInPattern) {  
             entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search);  
             while (entryPtr != NULL) {  
                 varPtr = (Var *) Tcl_GetHashValue(entryPtr);  
                 if (!TclIsVarUndefined(varPtr)  
                         || (varPtr->flags & VAR_NAMESPACE_VAR)) {  
                     varName = Tcl_GetHashKey(&globalNsPtr->varTable,  
                             entryPtr);  
                     if ((simplePattern == NULL)  
                             || Tcl_StringMatch(varName, simplePattern)) {  
                         if (Tcl_FindHashEntry(&nsPtr->varTable, varName) == NULL) {  
                             Tcl_ListObjAppendElement(interp, listPtr,  
                                     Tcl_NewStringObj(varName, -1));  
                         }  
                     }  
                 }  
                 entryPtr = Tcl_NextHashEntry(&search);  
             }  
         }  
     } else if (((Interp *)interp)->varFramePtr->procPtr != NULL) {  
         AppendLocals(interp, listPtr, simplePattern, 1);  
     }  
       
     Tcl_SetObjResult(interp, listPtr);  
     return TCL_OK;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * Tcl_JoinObjCmd --  
  *  
  *      This procedure is invoked to process the "join" Tcl command.  
  *      See the user documentation for details on what it does.  
  *  
  * Results:  
  *      A standard Tcl object result.  
  *  
  * Side effects:  
  *      See the user documentation.  
  *  
  *----------------------------------------------------------------------  
  */  
   
         /* ARGSUSED */  
 int  
 Tcl_JoinObjCmd(dummy, interp, objc, objv)  
     ClientData dummy;           /* Not used. */  
     Tcl_Interp *interp;         /* Current interpreter. */  
     int objc;                   /* Number of arguments. */  
     Tcl_Obj *CONST objv[];      /* The argument objects. */  
 {  
     char *joinString, *bytes;  
     int joinLength, listLen, length, i, result;  
     Tcl_Obj **elemPtrs;  
     Tcl_Obj *resObjPtr;  
   
     if (objc == 2) {  
         joinString = " ";  
         joinLength = 1;  
     } else if (objc == 3) {  
         joinString = Tcl_GetStringFromObj(objv[2], &joinLength);  
     } else {  
         Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?");  
         return TCL_ERROR;  
     }  
   
     /*  
      * Make sure the list argument is a list object and get its length and  
      * a pointer to its array of element pointers.  
      */  
   
     result = Tcl_ListObjGetElements(interp, objv[1], &listLen, &elemPtrs);  
     if (result != TCL_OK) {  
         return result;  
     }  
   
     /*  
      * Now concatenate strings to form the "joined" result. We append  
      * directly into the interpreter's result object.  
      */  
   
     resObjPtr = Tcl_GetObjResult(interp);  
   
     for (i = 0;  i < listLen;  i++) {  
         bytes = Tcl_GetStringFromObj(elemPtrs[i], &length);  
         if (i > 0) {  
             Tcl_AppendToObj(resObjPtr, joinString, joinLength);  
         }  
         Tcl_AppendToObj(resObjPtr, bytes, length);  
     }  
     return TCL_OK;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * Tcl_LindexObjCmd --  
  *  
  *      This object-based procedure is invoked to process the "lindex" Tcl  
  *      command. See the user documentation for details on what it does.  
  *  
  * Results:  
  *      A standard Tcl object result.  
  *  
  * Side effects:  
  *      See the user documentation.  
  *  
  *----------------------------------------------------------------------  
  */  
   
     /* ARGSUSED */  
 int  
 Tcl_LindexObjCmd(dummy, interp, objc, objv)  
     ClientData dummy;           /* Not used. */  
     Tcl_Interp *interp;         /* Current interpreter. */  
     int objc;                   /* Number of arguments. */  
     Tcl_Obj *CONST objv[];      /* Argument objects. */  
 {  
     Tcl_Obj *listPtr;  
     Tcl_Obj **elemPtrs;  
     int listLen, index, result;  
   
     if (objc != 3) {  
         Tcl_WrongNumArgs(interp, 1, objv, "list index");  
         return TCL_ERROR;  
     }  
   
     /*  
      * Convert the first argument to a list if necessary.  
      */  
   
     listPtr = objv[1];  
     result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs);  
     if (result != TCL_OK) {  
         return result;  
     }  
   
     /*  
      * Get the index from objv[2].  
      */  
   
     result = TclGetIntForIndex(interp, objv[2], /*endValue*/ (listLen - 1),  
             &index);  
     if (result != TCL_OK) {  
         return result;  
     }  
     if ((index < 0) || (index >= listLen)) {  
         /*  
          * The index is out of range: the result is an empty string object.  
          */  
           
         return TCL_OK;  
     }  
   
     /*  
      * Make sure listPtr still refers to a list object. It might have been  
      * converted to an int above if the argument objects were shared.  
      */  
   
     if (listPtr->typePtr != &tclListType) {  
         result = Tcl_ListObjGetElements(interp, listPtr, &listLen,  
                 &elemPtrs);  
         if (result != TCL_OK) {  
             return result;  
         }  
     }  
   
     /*  
      * Set the interpreter's object result to the index-th list element.  
      */  
   
     Tcl_SetObjResult(interp, elemPtrs[index]);  
     return TCL_OK;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * Tcl_LinsertObjCmd --  
  *  
  *      This object-based procedure is invoked to process the "linsert" Tcl  
  *      command. See the user documentation for details on what it does.  
  *  
  * Results:  
  *      A new Tcl list object formed by inserting zero or more elements  
  *      into a list.  
  *  
  * Side effects:  
  *      See the user documentation.  
  *  
  *----------------------------------------------------------------------  
  */  
   
         /* ARGSUSED */  
 int  
 Tcl_LinsertObjCmd(dummy, interp, objc, objv)  
     ClientData dummy;           /* Not used. */  
     Tcl_Interp *interp;         /* Current interpreter. */  
     register int objc;          /* Number of arguments. */  
     Tcl_Obj *CONST objv[];      /* Argument objects. */  
 {  
     Tcl_Obj *listPtr, *resultPtr;  
     Tcl_ObjType *typePtr;  
     int index, isDuplicate, len, result;  
     
     if (objc < 4) {  
         Tcl_WrongNumArgs(interp, 1, objv, "list index element ?element ...?");  
         return TCL_ERROR;  
     }  
   
     /*  
      * Get the index first since, if a conversion to int is needed, it  
      * will invalidate the list's internal representation.  
      */  
   
     result = Tcl_ListObjLength(interp, objv[1], &len);  
     if (result != TCL_OK) {  
         return result;  
     }  
   
     result = TclGetIntForIndex(interp, objv[2], /*endValue*/ len, &index);  
     if (result != TCL_OK) {  
         return result;  
     }  
   
     /*  
      * If the list object is unshared we can modify it directly. Otherwise  
      * we create a copy to modify: this is "copy on write". We create the  
      * duplicate directly in the interpreter's object result.  
      */  
       
     listPtr = objv[1];  
     isDuplicate = 0;  
     if (Tcl_IsShared(listPtr)) {  
         /*  
          * The following code must reflect the logic in Tcl_DuplicateObj()  
          * except that it must duplicate the list object directly into the  
          * interpreter's result.  
          */  
           
         Tcl_ResetResult(interp);  
         resultPtr = Tcl_GetObjResult(interp);  
         typePtr = listPtr->typePtr;  
         if (listPtr->bytes == NULL) {  
             resultPtr->bytes = NULL;  
         } else if (listPtr->bytes != tclEmptyStringRep) {  
             len = listPtr->length;  
             TclInitStringRep(resultPtr, listPtr->bytes, len);  
         }  
         if (typePtr != NULL) {  
             if (typePtr->dupIntRepProc == NULL) {  
                 resultPtr->internalRep = listPtr->internalRep;  
                 resultPtr->typePtr = typePtr;  
             } else {  
                 (*typePtr->dupIntRepProc)(listPtr, resultPtr);  
             }  
         }  
         listPtr = resultPtr;  
         isDuplicate = 1;  
     }  
       
     if ((objc == 4) && (index == INT_MAX)) {  
         /*  
          * Special case: insert one element at the end of the list.  
          */  
   
         result = Tcl_ListObjAppendElement(interp, listPtr, objv[3]);  
     } else if (objc > 3) {  
         result = Tcl_ListObjReplace(interp, listPtr, index, 0,  
                                     (objc-3), &(objv[3]));  
     }  
     if (result != TCL_OK) {  
         return result;  
     }  
       
     /*  
      * Set the interpreter's object result.  
      */  
   
     if (!isDuplicate) {  
         Tcl_SetObjResult(interp, listPtr);  
     }  
     return TCL_OK;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * Tcl_ListObjCmd --  
  *  
  *      This procedure is invoked to process the "list" Tcl command.  
  *      See the user documentation for details on what it does.  
  *  
  * Results:  
  *      A standard Tcl object result.  
  *  
  * Side effects:  
  *      See the user documentation.  
  *  
  *----------------------------------------------------------------------  
  */  
   
         /* ARGSUSED */  
 int  
 Tcl_ListObjCmd(dummy, interp, objc, objv)  
     ClientData dummy;                   /* Not used. */  
     Tcl_Interp *interp;                 /* Current interpreter. */  
     register int objc;                  /* Number of arguments. */  
     register Tcl_Obj *CONST objv[];     /* The argument objects. */  
 {  
     /*  
      * If there are no list elements, the result is an empty object.  
      * Otherwise modify the interpreter's result object to be a list object.  
      */  
       
     if (objc > 1) {  
         Tcl_SetListObj(Tcl_GetObjResult(interp), (objc-1), &(objv[1]));  
     }  
     return TCL_OK;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * Tcl_LlengthObjCmd --  
  *  
  *      This object-based procedure is invoked to process the "llength" Tcl  
  *      command.  See the user documentation for details on what it does.  
  *  
  * Results:  
  *      A standard Tcl object result.  
  *  
  * Side effects:  
  *      See the user documentation.  
  *  
  *----------------------------------------------------------------------  
  */  
   
         /* ARGSUSED */  
 int  
 Tcl_LlengthObjCmd(dummy, interp, objc, objv)  
     ClientData dummy;                   /* Not used. */  
     Tcl_Interp *interp;                 /* Current interpreter. */  
     int objc;                           /* Number of arguments. */  
     register Tcl_Obj *CONST objv[];     /* Argument objects. */  
 {  
     int listLen, result;  
   
     if (objc != 2) {  
         Tcl_WrongNumArgs(interp, 1, objv, "list");  
         return TCL_ERROR;  
     }  
   
     result = Tcl_ListObjLength(interp, objv[1], &listLen);  
     if (result != TCL_OK) {  
         return result;  
     }  
   
     /*  
      * Set the interpreter's object result to an integer object holding the  
      * length.  
      */  
   
     Tcl_SetIntObj(Tcl_GetObjResult(interp), listLen);  
     return TCL_OK;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * Tcl_LrangeObjCmd --  
  *  
  *      This procedure is invoked to process the "lrange" Tcl command.  
  *      See the user documentation for details on what it does.  
  *  
  * Results:  
  *      A standard Tcl object result.  
  *  
  * Side effects:  
  *      See the user documentation.  
  *  
  *----------------------------------------------------------------------  
  */  
   
         /* ARGSUSED */  
 int  
 Tcl_LrangeObjCmd(notUsed, interp, objc, objv)  
     ClientData notUsed;                 /* Not used. */  
     Tcl_Interp *interp;                 /* Current interpreter. */  
     int objc;                           /* Number of arguments. */  
     register Tcl_Obj *CONST objv[];     /* Argument objects. */  
 {  
     Tcl_Obj *listPtr;  
     Tcl_Obj **elemPtrs;  
     int listLen, first, last, numElems, result;  
   
     if (objc != 4) {  
         Tcl_WrongNumArgs(interp, 1, objv, "list first last");  
         return TCL_ERROR;  
     }  
   
     /*  
      * Make sure the list argument is a list object and get its length and  
      * a pointer to its array of element pointers.  
      */  
   
     listPtr = objv[1];  
     result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs);  
     if (result != TCL_OK) {  
         return result;  
     }  
   
     /*  
      * Get the first and last indexes.  
      */  
   
     result = TclGetIntForIndex(interp, objv[2], /*endValue*/ (listLen - 1),  
             &first);  
     if (result != TCL_OK) {  
         return result;  
     }  
     if (first < 0) {  
         first = 0;  
     }  
   
     result = TclGetIntForIndex(interp, objv[3], /*endValue*/ (listLen - 1),  
             &last);  
     if (result != TCL_OK) {  
         return result;  
     }  
     if (last >= listLen) {  
         last = (listLen - 1);  
     }  
       
     if (first > last) {  
         return TCL_OK;          /* the result is an empty object */  
     }  
   
     /*  
      * Make sure listPtr still refers to a list object. It might have been  
      * converted to an int above if the argument objects were shared.  
      */    
   
     if (listPtr->typePtr != &tclListType) {  
         result = Tcl_ListObjGetElements(interp, listPtr, &listLen,  
                 &elemPtrs);  
         if (result != TCL_OK) {  
             return result;  
         }  
     }  
   
     /*  
      * Extract a range of fields. We modify the interpreter's result object  
      * to be a list object containing the specified elements.  
      */  
   
     numElems = (last - first + 1);  
     Tcl_SetListObj(Tcl_GetObjResult(interp), numElems, &(elemPtrs[first]));  
     return TCL_OK;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * Tcl_LreplaceObjCmd --  
  *  
  *      This object-based procedure is invoked to process the "lreplace"  
  *      Tcl command. See the user documentation for details on what it does.  
  *  
  * Results:  
  *      A new Tcl list object formed by replacing zero or more elements of  
  *      a list.  
  *  
  * Side effects:  
  *      See the user documentation.  
  *  
  *----------------------------------------------------------------------  
  */  
   
         /* ARGSUSED */  
 int  
 Tcl_LreplaceObjCmd(dummy, interp, objc, objv)  
     ClientData dummy;           /* Not used. */  
     Tcl_Interp *interp;         /* Current interpreter. */  
     int objc;                   /* Number of arguments. */  
     Tcl_Obj *CONST objv[];      /* Argument objects. */  
 {  
     register Tcl_Obj *listPtr;  
     int createdNewObj, first, last, listLen, numToDelete;  
     int firstArgLen, result;  
     char *firstArg;  
   
     if (objc < 4) {  
         Tcl_WrongNumArgs(interp, 1, objv,  
                 "list first last ?element element ...?");  
         return TCL_ERROR;  
     }  
   
     /*  
      * If the list object is unshared we can modify it directly, otherwise  
      * we create a copy to modify: this is "copy on write".  
      */  
       
     listPtr = objv[1];  
     createdNewObj = 0;  
     if (Tcl_IsShared(listPtr)) {  
         listPtr = Tcl_DuplicateObj(listPtr);  
         createdNewObj = 1;  
     }  
     result = Tcl_ListObjLength(interp, listPtr, &listLen);  
     if (result != TCL_OK) {  
         errorReturn:  
         if (createdNewObj) {  
             Tcl_DecrRefCount(listPtr); /* free unneeded obj */  
         }  
         return result;  
     }  
   
     /*  
      * Get the first and last indexes.  
      */  
   
     result = TclGetIntForIndex(interp, objv[2], /*endValue*/ (listLen - 1),  
             &first);  
     if (result != TCL_OK) {  
         goto errorReturn;  
     }  
     firstArg = Tcl_GetStringFromObj(objv[2], &firstArgLen);  
   
     result = TclGetIntForIndex(interp, objv[3], /*endValue*/ (listLen - 1),  
             &last);  
     if (result != TCL_OK) {  
         goto errorReturn;  
     }  
   
     if (first < 0)  {  
         first = 0;  
     }  
     if ((first >= listLen) && (listLen > 0)  
             && (strncmp(firstArg, "end", (unsigned) firstArgLen) != 0)) {  
         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),  
                 "list doesn't contain element ",  
                 Tcl_GetString(objv[2]), (int *) NULL);  
         result = TCL_ERROR;  
         goto errorReturn;  
     }  
     if (last >= listLen) {  
         last = (listLen - 1);  
     }  
     if (first <= last) {  
         numToDelete = (last - first + 1);  
     } else {  
         numToDelete = 0;  
     }  
   
     if (objc > 4) {  
         result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete,  
                 (objc-4), &(objv[4]));  
     } else {  
         result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete,  
                 0, NULL);  
     }  
     if (result != TCL_OK) {  
         goto errorReturn;  
     }  
   
     /*  
      * Set the interpreter's object result.  
      */  
   
     Tcl_SetObjResult(interp, listPtr);  
     return TCL_OK;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * Tcl_LsearchObjCmd --  
  *  
  *      This procedure is invoked to process the "lsearch" Tcl command.  
  *      See the user documentation for details on what it does.  
  *  
  * Results:  
  *      A standard Tcl result.  
  *  
  * Side effects:  
  *      See the user documentation.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 int  
 Tcl_LsearchObjCmd(clientData, interp, objc, objv)  
     ClientData clientData;      /* Not used. */  
     Tcl_Interp *interp;         /* Current interpreter. */  
     int objc;                   /* Number of arguments. */  
     Tcl_Obj *CONST objv[];      /* Argument values. */  
 {  
     char *bytes, *patternBytes;  
     int i, match, mode, index, result, listc, length, elemLen;  
     Tcl_Obj *patObj, **listv;  
     static char *options[] = {  
         "-exact",       "-glob",        "-regexp",      NULL  
     };  
     enum options {  
         LSEARCH_EXACT,  LSEARCH_GLOB,   LSEARCH_REGEXP  
     };  
   
     mode = LSEARCH_GLOB;  
     if (objc == 4) {  
         if (Tcl_GetIndexFromObj(interp, objv[1], options, "search mode", 0,  
                 &mode) != TCL_OK) {  
             return TCL_ERROR;  
         }  
     } else if (objc != 3) {  
         Tcl_WrongNumArgs(interp, 1, objv, "?mode? list pattern");  
         return TCL_ERROR;  
     }  
   
     /*  
      * Make sure the list argument is a list object and get its length and  
      * a pointer to its array of element pointers.  
      */  
   
     result = Tcl_ListObjGetElements(interp, objv[objc - 2], &listc, &listv);  
     if (result != TCL_OK) {  
         return result;  
     }  
   
     patObj = objv[objc - 1];  
     patternBytes = Tcl_GetStringFromObj(patObj, &length);  
   
     index = -1;  
     for (i = 0; i < listc; i++) {  
         match = 0;  
         switch ((enum options) mode) {  
             case LSEARCH_EXACT: {  
                 bytes = Tcl_GetStringFromObj(listv[i], &elemLen);  
                 if (length == elemLen) {  
                     match = (memcmp(bytes, patternBytes,  
                             (size_t) length) == 0);  
                 }  
                 break;  
             }  
             case LSEARCH_GLOB: {  
                 match = Tcl_StringMatch(Tcl_GetString(listv[i]), patternBytes);  
                 break;  
             }  
             case LSEARCH_REGEXP: {  
                 match = Tcl_RegExpMatchObj(interp, listv[i], patObj);  
                 if (match < 0) {  
                     return TCL_ERROR;  
                 }  
                 break;  
             }  
         }  
         if (match != 0) {  
             index = i;  
             break;  
         }  
     }  
     Tcl_SetIntObj(Tcl_GetObjResult(interp), index);  
     return TCL_OK;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * Tcl_LsortObjCmd --  
  *  
  *      This procedure is invoked to process the "lsort" Tcl command.  
  *      See the user documentation for details on what it does.  
  *  
  * Results:  
  *      A standard Tcl result.  
  *  
  * Side effects:  
  *      See the user documentation.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 int  
 Tcl_LsortObjCmd(clientData, interp, objc, objv)  
     ClientData clientData;      /* Not used. */  
     Tcl_Interp *interp;         /* Current interpreter. */  
     int objc;                   /* Number of arguments. */  
     Tcl_Obj *CONST objv[];      /* Argument values. */  
 {  
     int i, index, unique;  
     Tcl_Obj *resultPtr;  
     int length;  
     Tcl_Obj *cmdPtr, **listObjPtrs;  
     SortElement *elementArray;  
     SortElement *elementPtr;          
     SortInfo sortInfo;                  /* Information about this sort that  
                                          * needs to be passed to the  
                                          * comparison function */  
     static char *switches[] = {  
         "-ascii", "-command", "-decreasing", "-dictionary", "-increasing",  
         "-index", "-integer", "-real", "-unique", (char *) NULL  
     };  
   
     resultPtr = Tcl_GetObjResult(interp);  
     if (objc < 2) {  
         Tcl_WrongNumArgs(interp, 1, objv, "?options? list");  
         return TCL_ERROR;  
     }  
   
     /*  
      * Parse arguments to set up the mode for the sort.  
      */  
   
     sortInfo.isIncreasing = 1;  
     sortInfo.sortMode = SORTMODE_ASCII;  
     sortInfo.index = -1;  
     sortInfo.interp = interp;  
     sortInfo.resultCode = TCL_OK;  
     cmdPtr = NULL;  
     unique = 0;  
     for (i = 1; i < objc-1; i++) {  
         if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, &index)  
                 != TCL_OK) {  
             return TCL_ERROR;  
         }  
         switch (index) {  
             case 0:                     /* -ascii */  
                 sortInfo.sortMode = SORTMODE_ASCII;  
                 break;  
             case 1:                     /* -command */  
                 if (i == (objc-2)) {  
                     Tcl_AppendToObj(resultPtr,  
                             "\"-command\" option must be followed by comparison command",  
                             -1);  
                     return TCL_ERROR;  
                 }  
                 sortInfo.sortMode = SORTMODE_COMMAND;  
                 cmdPtr = objv[i+1];  
                 i++;  
                 break;  
             case 2:                     /* -decreasing */  
                 sortInfo.isIncreasing = 0;  
                 break;  
             case 3:                     /* -dictionary */  
                 sortInfo.sortMode = SORTMODE_DICTIONARY;  
                 break;  
             case 4:                     /* -increasing */  
                 sortInfo.isIncreasing = 1;  
                 break;  
             case 5:                     /* -index */  
                 if (i == (objc-2)) {  
                     Tcl_AppendToObj(resultPtr,  
                             "\"-index\" option must be followed by list index",  
                             -1);  
                     return TCL_ERROR;  
                 }  
                 if (TclGetIntForIndex(interp, objv[i+1], -2, &sortInfo.index)  
                         != TCL_OK) {  
                     return TCL_ERROR;  
                 }  
                 cmdPtr = objv[i+1];  
                 i++;  
                 break;  
             case 6:                     /* -integer */  
                 sortInfo.sortMode = SORTMODE_INTEGER;  
                 break;  
             case 7:                     /* -real */  
                 sortInfo.sortMode = SORTMODE_REAL;  
                 break;  
             case 8:                     /* -unique */  
                 unique = 1;  
                 break;  
         }  
     }  
     if (sortInfo.sortMode == SORTMODE_COMMAND) {  
         /*  
          * The existing command is a list. We want to flatten it, append  
          * two dummy arguments on the end, and replace these arguments  
          * later.  
          */  
   
         Tcl_Obj *newCommandPtr = Tcl_DuplicateObj(cmdPtr);  
         Tcl_Obj *newObjPtr = Tcl_NewObj();  
   
         Tcl_IncrRefCount(newCommandPtr);  
         if (Tcl_ListObjAppendElement(interp, newCommandPtr, newObjPtr)  
                 != TCL_OK) {  
             Tcl_DecrRefCount(newCommandPtr);  
             Tcl_IncrRefCount(newObjPtr);  
             Tcl_DecrRefCount(newObjPtr);  
             return TCL_ERROR;  
         }  
         Tcl_ListObjAppendElement(interp, newCommandPtr, Tcl_NewObj());  
         sortInfo.compareCmdPtr = newCommandPtr;  
     }  
   
     sortInfo.resultCode = Tcl_ListObjGetElements(interp, objv[objc-1],  
             &length, &listObjPtrs);  
     if (sortInfo.resultCode != TCL_OK) {  
         goto done;  
     }  
     if (length <= 0) {  
         return TCL_OK;  
     }  
     elementArray = (SortElement *) ckalloc(length * sizeof(SortElement));  
     for (i=0; i < length; i++){  
         elementArray[i].objPtr = listObjPtrs[i];  
         elementArray[i].count = 0;  
         elementArray[i].nextPtr = &elementArray[i+1];  
     }  
     elementArray[length-1].nextPtr = NULL;  
     elementPtr = MergeSort(elementArray, &sortInfo);  
     if (sortInfo.resultCode == TCL_OK) {  
         /*  
          * Note: must clear the interpreter's result object: it could  
          * have been set by the -command script.  
          */  
   
         Tcl_ResetResult(interp);  
         resultPtr = Tcl_GetObjResult(interp);  
         if (unique) {  
             for (; elementPtr != NULL; elementPtr = elementPtr->nextPtr){  
                 if (elementPtr->count == 0) {  
                     Tcl_ListObjAppendElement(interp, resultPtr,  
                             elementPtr->objPtr);  
                 }  
             }  
         } else {  
             for (; elementPtr != NULL; elementPtr = elementPtr->nextPtr){  
                 Tcl_ListObjAppendElement(interp, resultPtr,  
                         elementPtr->objPtr);  
             }  
         }  
     }  
     ckfree((char*) elementArray);  
   
     done:  
     if (sortInfo.sortMode == SORTMODE_COMMAND) {  
         Tcl_DecrRefCount(sortInfo.compareCmdPtr);  
         sortInfo.compareCmdPtr = NULL;  
     }  
     return sortInfo.resultCode;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * MergeSort -  
  *  
  *      This procedure sorts a linked list of SortElement structures  
  *      use the merge-sort algorithm.  
  *  
  * Results:  
  *      A pointer to the head of the list after sorting is returned.  
  *  
  * Side effects:  
  *      None, unless a user-defined comparison command does something  
  *      weird.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 static SortElement *  
 MergeSort(headPtr, infoPtr)  
     SortElement *headPtr;               /* First element on the list */  
     SortInfo *infoPtr;                  /* Information needed by the  
                                          * comparison operator */  
 {  
     /*  
      * The subList array below holds pointers to temporary lists built  
      * during the merge sort.  Element i of the array holds a list of  
      * length 2**i.  
      */  
   
 #   define NUM_LISTS 30  
     SortElement *subList[NUM_LISTS];  
     SortElement *elementPtr;  
     int i;  
   
     for(i = 0; i < NUM_LISTS; i++){  
         subList[i] = NULL;  
     }  
     while (headPtr != NULL) {  
         elementPtr = headPtr;  
         headPtr = headPtr->nextPtr;  
         elementPtr->nextPtr = 0;  
         for (i = 0; (i < NUM_LISTS) && (subList[i] != NULL); i++){  
             elementPtr = MergeLists(subList[i], elementPtr, infoPtr);  
             subList[i] = NULL;  
         }  
         if (i >= NUM_LISTS) {  
             i = NUM_LISTS-1;  
         }  
         subList[i] = elementPtr;  
     }  
     elementPtr = NULL;  
     for (i = 0; i < NUM_LISTS; i++){  
         elementPtr = MergeLists(subList[i], elementPtr, infoPtr);  
     }  
     return elementPtr;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * MergeLists -  
  *  
  *      This procedure combines two sorted lists of SortElement structures  
  *      into a single sorted list.  
  *  
  * Results:  
  *      The unified list of SortElement structures.  
  *  
  * Side effects:  
  *      None, unless a user-defined comparison command does something  
  *      weird.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 static SortElement *  
 MergeLists(leftPtr, rightPtr, infoPtr)  
     SortElement *leftPtr;               /* First list to be merged; may be  
                                          * NULL. */  
     SortElement *rightPtr;              /* Second list to be merged; may be  
                                          * NULL. */  
     SortInfo *infoPtr;                  /* Information needed by the  
                                          * comparison operator. */  
 {  
     SortElement *headPtr;  
     SortElement *tailPtr;  
     int cmp;  
   
     if (leftPtr == NULL) {  
         return rightPtr;  
     }  
     if (rightPtr == NULL) {  
         return leftPtr;  
     }  
     cmp = SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr);  
     if (cmp > 0) {  
         tailPtr = rightPtr;  
         rightPtr = rightPtr->nextPtr;  
     } else {  
         if (cmp == 0) {  
             leftPtr->count++;  
         }  
         tailPtr = leftPtr;  
         leftPtr = leftPtr->nextPtr;  
     }  
     headPtr = tailPtr;  
     while ((leftPtr != NULL) && (rightPtr != NULL)) {  
         cmp = SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr);  
         if (cmp > 0) {  
             tailPtr->nextPtr = rightPtr;  
             tailPtr = rightPtr;  
             rightPtr = rightPtr->nextPtr;  
         } else {  
             if (cmp == 0) {  
                 leftPtr->count++;  
             }  
             tailPtr->nextPtr = leftPtr;  
             tailPtr = leftPtr;  
             leftPtr = leftPtr->nextPtr;  
         }  
     }  
     if (leftPtr != NULL) {  
        tailPtr->nextPtr = leftPtr;  
     } else {  
        tailPtr->nextPtr = rightPtr;  
     }  
     return headPtr;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * SortCompare --  
  *  
  *      This procedure is invoked by MergeLists to determine the proper  
  *      ordering between two elements.  
  *  
  * Results:  
  *      A negative results means the the first element comes before the  
  *      second, and a positive results means that the second element  
  *      should come first.  A result of zero means the two elements  
  *      are equal and it doesn't matter which comes first.  
  *  
  * Side effects:  
  *      None, unless a user-defined comparison command does something  
  *      weird.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 static int  
 SortCompare(objPtr1, objPtr2, infoPtr)  
     Tcl_Obj *objPtr1, *objPtr2;         /* Values to be compared. */  
     SortInfo *infoPtr;                  /* Information passed from the  
                                          * top-level "lsort" command */  
 {  
     int order, listLen, index;  
     Tcl_Obj *objPtr;  
     char buffer[TCL_INTEGER_SPACE];  
   
     order = 0;  
     if (infoPtr->resultCode != TCL_OK) {  
         /*  
          * Once an error has occurred, skip any future comparisons  
          * so as to preserve the error message in sortInterp->result.  
          */  
   
         return order;  
     }  
     if (infoPtr->index != -1) {  
         /*  
          * The "-index" option was specified.  Treat each object as a  
          * list, extract the requested element from each list, and  
          * compare the elements, not the lists.  The special index "end"  
          * is signaled here with a large negative index.  
          */  
   
         if (Tcl_ListObjLength(infoPtr->interp, objPtr1, &listLen) != TCL_OK) {  
             infoPtr->resultCode = TCL_ERROR;  
             return order;  
         }  
         if (infoPtr->index < -1) {  
             index = listLen - 1;  
         } else {  
             index = infoPtr->index;  
         }  
   
         if (Tcl_ListObjIndex(infoPtr->interp, objPtr1, index, &objPtr)  
                 != TCL_OK) {  
             infoPtr->resultCode = TCL_ERROR;  
             return order;  
         }  
         if (objPtr == NULL) {  
             objPtr = objPtr1;  
             missingElement:  
             TclFormatInt(buffer, infoPtr->index);  
             Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp),  
                         "element ", buffer, " missing from sublist \"",  
                         Tcl_GetString(objPtr), "\"", (char *) NULL);  
             infoPtr->resultCode = TCL_ERROR;  
             return order;  
         }  
         objPtr1 = objPtr;  
   
         if (Tcl_ListObjLength(infoPtr->interp, objPtr2, &listLen) != TCL_OK) {  
             infoPtr->resultCode = TCL_ERROR;  
             return order;  
         }  
         if (infoPtr->index < -1) {  
             index = listLen - 1;  
         } else {  
             index = infoPtr->index;  
         }  
   
         if (Tcl_ListObjIndex(infoPtr->interp, objPtr2, index, &objPtr)  
                 != TCL_OK) {  
             infoPtr->resultCode = TCL_ERROR;  
             return order;  
         }  
         if (objPtr == NULL) {  
             objPtr = objPtr2;  
             goto missingElement;  
         }  
         objPtr2 = objPtr;  
     }  
     if (infoPtr->sortMode == SORTMODE_ASCII) {  
         order = strcmp(Tcl_GetString(objPtr1), Tcl_GetString(objPtr2));  
     } else if (infoPtr->sortMode == SORTMODE_DICTIONARY) {  
         order = DictionaryCompare(  
                 Tcl_GetString(objPtr1), Tcl_GetString(objPtr2));  
     } else if (infoPtr->sortMode == SORTMODE_INTEGER) {  
         long a, b;  
   
         if ((Tcl_GetLongFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK)  
                 || (Tcl_GetLongFromObj(infoPtr->interp, objPtr2, &b)  
                 != TCL_OK)) {  
             infoPtr->resultCode = TCL_ERROR;  
             return order;  
         }  
         if (a > b) {  
             order = 1;  
         } else if (b > a) {  
             order = -1;  
         }  
     } else if (infoPtr->sortMode == SORTMODE_REAL) {  
         double a, b;  
   
         if ((Tcl_GetDoubleFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK)  
               || (Tcl_GetDoubleFromObj(infoPtr->interp, objPtr2, &b)  
                       != TCL_OK)) {  
             infoPtr->resultCode = TCL_ERROR;  
             return order;  
         }  
         if (a > b) {  
             order = 1;  
         } else if (b > a) {  
             order = -1;  
         }  
     } else {  
         Tcl_Obj **objv, *paramObjv[2];  
         int objc;  
   
         paramObjv[0] = objPtr1;  
         paramObjv[1] = objPtr2;  
   
         /*  
          * We made space in the command list for the two things to  
          * compare. Replace them and evaluate the result.  
          */  
   
         Tcl_ListObjLength(infoPtr->interp, infoPtr->compareCmdPtr, &objc);  
         Tcl_ListObjReplace(infoPtr->interp, infoPtr->compareCmdPtr, objc - 2,  
                 2, 2, paramObjv);  
         Tcl_ListObjGetElements(infoPtr->interp, infoPtr->compareCmdPtr,  
                 &objc, &objv);  
   
         infoPtr->resultCode = Tcl_EvalObjv(infoPtr->interp, objc, objv, 0);  
     
         if (infoPtr->resultCode != TCL_OK) {  
             Tcl_AddErrorInfo(infoPtr->interp,  
                     "\n    (-compare command)");  
             return order;  
         }  
   
         /*  
          * Parse the result of the command.  
          */  
   
         if (Tcl_GetIntFromObj(infoPtr->interp,  
                 Tcl_GetObjResult(infoPtr->interp), &order) != TCL_OK) {  
             Tcl_ResetResult(infoPtr->interp);  
             Tcl_AppendToObj(Tcl_GetObjResult(infoPtr->interp),  
                     "-compare command returned non-numeric result", -1);  
             infoPtr->resultCode = TCL_ERROR;  
             return order;  
         }  
     }  
     if (!infoPtr->isIncreasing) {  
         order = -order;  
     }  
     return order;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * DictionaryCompare  
  *  
  *      This function compares two strings as if they were being used in  
  *      an index or card catalog.  The case of alphabetic characters is  
  *      ignored, except to break ties.  Thus "B" comes before "b" but  
  *      after "a".  Also, integers embedded in the strings compare in  
  *      numerical order.  In other words, "x10y" comes after "x9y", not  
  *      before it as it would when using strcmp().  
  *  
  * Results:  
  *      A negative result means that the first element comes before the  
  *      second, and a positive result means that the second element  
  *      should come first.  A result of zero means the two elements  
  *      are equal and it doesn't matter which comes first.  
  *  
  * Side effects:  
  *      None.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 static int  
 DictionaryCompare(left, right)  
     char *left, *right;          /* The strings to compare */  
 {  
     Tcl_UniChar uniLeft, uniRight, uniLeftLower, uniRightLower;  
     int diff, zeros;  
     int secondaryDiff = 0;  
   
     while (1) {  
         if (isdigit(UCHAR(*right)) /* INTL: digit */  
                 && isdigit(UCHAR(*left))) { /* INTL: digit */  
             /*  
              * There are decimal numbers embedded in the two  
              * strings.  Compare them as numbers, rather than  
              * strings.  If one number has more leading zeros than  
              * the other, the number with more leading zeros sorts  
              * later, but only as a secondary choice.  
              */  
   
             zeros = 0;  
             while ((*right == '0') && (isdigit(UCHAR(right[1])))) {  
                 right++;  
                 zeros--;  
             }  
             while ((*left == '0') && (isdigit(UCHAR(left[1])))) {  
                 left++;  
                 zeros++;  
             }  
             if (secondaryDiff == 0) {  
                 secondaryDiff = zeros;  
             }  
   
             /*  
              * The code below compares the numbers in the two  
              * strings without ever converting them to integers.  It  
              * does this by first comparing the lengths of the  
              * numbers and then comparing the digit values.  
              */  
   
             diff = 0;  
             while (1) {  
                 if (diff == 0) {  
                     diff = UCHAR(*left) - UCHAR(*right);  
                 }  
                 right++;  
                 left++;  
                 if (!isdigit(UCHAR(*right))) { /* INTL: digit */  
                     if (isdigit(UCHAR(*left))) { /* INTL: digit */  
                         return 1;  
                     } else {  
                         /*  
                          * The two numbers have the same length. See  
                          * if their values are different.  
                          */  
   
                         if (diff != 0) {  
                             return diff;  
                         }  
                         break;  
                     }  
                 } else if (!isdigit(UCHAR(*left))) { /* INTL: digit */  
                     return -1;  
                 }  
             }  
             continue;  
         }  
   
         /*  
          * Convert character to Unicode for comparison purposes.  If either  
          * string is at the terminating null, do a byte-wise comparison and  
          * bail out immediately.  
          */  
   
         if ((*left != '\0') && (*right != '\0')) {  
             left += Tcl_UtfToUniChar(left, &uniLeft);  
             right += Tcl_UtfToUniChar(right, &uniRight);  
             /*  
              * Convert both chars to lower for the comparison, because  
              * dictionary sorts are case insensitve.  Covert to lower, not  
              * upper, so chars between Z and a will sort before A (where most  
              * other interesting punctuations occur)  
              */  
             uniLeftLower = Tcl_UniCharToLower(uniLeft);  
             uniRightLower = Tcl_UniCharToLower(uniRight);  
         } else {  
             diff = UCHAR(*left) - UCHAR(*right);  
             break;  
         }  
   
         diff = uniLeftLower - uniRightLower;  
         if (diff) {  
             return diff;  
         } else if (secondaryDiff == 0) {  
             if (Tcl_UniCharIsUpper(uniLeft) &&  
                     Tcl_UniCharIsLower(uniRight)) {  
                 secondaryDiff = -1;  
             } else if (Tcl_UniCharIsUpper(uniRight)  
                     && Tcl_UniCharIsLower(uniLeft)) {  
                 secondaryDiff = 1;  
             }  
         }  
     }  
     if (diff == 0) {  
         diff = secondaryDiff;  
     }  
     return diff;  
 }  
   
   
 /* $History: tclcmdil.c $  
  *  
  * *****************  Version 1  *****************  
  * User: Dtashley     Date: 1/02/01    Time: 1:28a  
  * Created in $/IjuScripter, IjuConsole/Source/Tcl Base  
  * Initial check-in.  
  */  
   
 /* End of TCLCMDIL.C */  
1    /* $Header$ */
2    /*
3     * tclCmdIL.c --
4     *
5     *      This file contains the top-level command routines for most of
6     *      the Tcl built-in commands whose names begin with the letters
7     *      I through L.  It contains only commands in the generic core
8     *      (i.e. those that don't depend much upon UNIX facilities).
9     *
10     * Copyright (c) 1987-1993 The Regents of the University of California.
11     * Copyright (c) 1993-1997 Lucent Technologies.
12     * Copyright (c) 1994-1997 Sun Microsystems, Inc.
13     * Copyright (c) 1998-1999 by Scriptics Corporation.
14     *
15     * See the file "license.terms" for information on usage and redistribution
16     * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
17     *
18     * RCS: @(#) $Id: tclcmdil.c,v 1.1.1.1 2001/06/13 04:34:54 dtashley Exp $
19     */
20    
21    #include "tclInt.h"
22    #include "tclPort.h"
23    #include "tclCompile.h"
24    #include "tclRegexp.h"
25    
26    /*
27     * During execution of the "lsort" command, structures of the following
28     * type are used to arrange the objects being sorted into a collection
29     * of linked lists.
30     */
31    
32    typedef struct SortElement {
33        Tcl_Obj *objPtr;                    /* Object being sorted. */
34        int count;                          /* number of same elements in list */
35        struct SortElement *nextPtr;        /* Next element in the list, or
36                                             * NULL for end of list. */
37    } SortElement;
38    
39    /*
40     * The "lsort" command needs to pass certain information down to the
41     * function that compares two list elements, and the comparison function
42     * needs to pass success or failure information back up to the top-level
43     * "lsort" command.  The following structure is used to pass this
44     * information.
45     */
46    
47    typedef struct SortInfo {
48        int isIncreasing;           /* Nonzero means sort in increasing order. */
49        int sortMode;               /* The sort mode.  One of SORTMODE_*
50                                     * values defined below */
51        Tcl_Obj *compareCmdPtr;     /* The Tcl comparison command when sortMode
52                                     * is SORTMODE_COMMAND.  Pre-initialized to
53                                     * hold base of command.*/
54        int index;                  /* If the -index option was specified, this
55                                     * holds the index of the list element
56                                     * to extract for comparison.  If -index
57                                     * wasn't specified, this is -1. */
58        Tcl_Interp *interp;         /* The interpreter in which the sortis
59                                     * being done. */
60        int resultCode;             /* Completion code for the lsort command.
61                                     * If an error occurs during the sort this
62                                     * is changed from TCL_OK to  TCL_ERROR. */
63    } SortInfo;
64    
65    /*
66     * The "sortMode" field of the SortInfo structure can take on any of the
67     * following values.
68     */
69    
70    #define SORTMODE_ASCII      0
71    #define SORTMODE_INTEGER    1
72    #define SORTMODE_REAL       2
73    #define SORTMODE_COMMAND    3
74    #define SORTMODE_DICTIONARY 4
75    
76    /*
77     * Forward declarations for procedures defined in this file:
78     */
79    
80    static void             AppendLocals _ANSI_ARGS_((Tcl_Interp *interp,
81                                Tcl_Obj *listPtr, char *pattern,
82                                int includeLinks));
83    static int              DictionaryCompare _ANSI_ARGS_((char *left,
84                                char *right));
85    static int              InfoArgsCmd _ANSI_ARGS_((ClientData dummy,
86                                Tcl_Interp *interp, int objc,
87                                Tcl_Obj *CONST objv[]));
88    static int              InfoBodyCmd _ANSI_ARGS_((ClientData dummy,
89                                Tcl_Interp *interp, int objc,
90                                Tcl_Obj *CONST objv[]));
91    static int              InfoCmdCountCmd _ANSI_ARGS_((ClientData dummy,
92                                Tcl_Interp *interp, int objc,
93                                Tcl_Obj *CONST objv[]));
94    static int              InfoCommandsCmd _ANSI_ARGS_((ClientData dummy,
95                                Tcl_Interp *interp, int objc,
96                                Tcl_Obj *CONST objv[]));
97    static int              InfoCompleteCmd _ANSI_ARGS_((ClientData dummy,
98                                Tcl_Interp *interp, int objc,
99                                Tcl_Obj *CONST objv[]));
100    static int              InfoDefaultCmd _ANSI_ARGS_((ClientData dummy,
101                                Tcl_Interp *interp, int objc,
102                                Tcl_Obj *CONST objv[]));
103    static int              InfoExistsCmd _ANSI_ARGS_((ClientData dummy,
104                                Tcl_Interp *interp, int objc,
105                                Tcl_Obj *CONST objv[]));
106    static int              InfoGlobalsCmd _ANSI_ARGS_((ClientData dummy,
107                                Tcl_Interp *interp, int objc,
108                                Tcl_Obj *CONST objv[]));
109    static int              InfoHostnameCmd _ANSI_ARGS_((ClientData dummy,
110                                Tcl_Interp *interp, int objc,
111                                Tcl_Obj *CONST objv[]));
112    static int              InfoLevelCmd _ANSI_ARGS_((ClientData dummy,
113                                Tcl_Interp *interp, int objc,
114                                Tcl_Obj *CONST objv[]));
115    static int              InfoLibraryCmd _ANSI_ARGS_((ClientData dummy,
116                                Tcl_Interp *interp, int objc,
117                                Tcl_Obj *CONST objv[]));
118    static int              InfoLoadedCmd _ANSI_ARGS_((ClientData dummy,
119                                Tcl_Interp *interp, int objc,
120                                Tcl_Obj *CONST objv[]));
121    static int              InfoLocalsCmd _ANSI_ARGS_((ClientData dummy,
122                                Tcl_Interp *interp, int objc,
123                                Tcl_Obj *CONST objv[]));
124    static int              InfoNameOfExecutableCmd _ANSI_ARGS_((
125                                ClientData dummy, Tcl_Interp *interp, int objc,
126                                Tcl_Obj *CONST objv[]));
127    static int              InfoPatchLevelCmd _ANSI_ARGS_((ClientData dummy,
128                                Tcl_Interp *interp, int objc,
129                                Tcl_Obj *CONST objv[]));
130    static int              InfoProcsCmd _ANSI_ARGS_((ClientData dummy,
131                                Tcl_Interp *interp, int objc,
132                                Tcl_Obj *CONST objv[]));
133    static int              InfoScriptCmd _ANSI_ARGS_((ClientData dummy,
134                                Tcl_Interp *interp, int objc,
135                                Tcl_Obj *CONST objv[]));
136    static int              InfoSharedlibCmd _ANSI_ARGS_((ClientData dummy,
137                                Tcl_Interp *interp, int objc,
138                                Tcl_Obj *CONST objv[]));
139    static int              InfoTclVersionCmd _ANSI_ARGS_((ClientData dummy,
140                                Tcl_Interp *interp, int objc,
141                                Tcl_Obj *CONST objv[]));
142    static int              InfoVarsCmd _ANSI_ARGS_((ClientData dummy,
143                                Tcl_Interp *interp, int objc,
144                                Tcl_Obj *CONST objv[]));
145    static SortElement *    MergeSort _ANSI_ARGS_((SortElement *headPt,
146                                SortInfo *infoPtr));
147    static SortElement *    MergeLists _ANSI_ARGS_((SortElement *leftPtr,
148                                SortElement *rightPtr, SortInfo *infoPtr));
149    static int              SortCompare _ANSI_ARGS_((Tcl_Obj *firstPtr,
150                                Tcl_Obj *second, SortInfo *infoPtr));
151    
152    /*
153     *----------------------------------------------------------------------
154     *
155     * Tcl_IfObjCmd --
156     *
157     *      This procedure is invoked to process the "if" Tcl command.
158     *      See the user documentation for details on what it does.
159     *
160     *      With the bytecode compiler, this procedure is only called when
161     *      a command name is computed at runtime, and is "if" or the name
162     *      to which "if" was renamed: e.g., "set z if; $z 1 {puts foo}"
163     *
164     * Results:
165     *      A standard Tcl result.
166     *
167     * Side effects:
168     *      See the user documentation.
169     *
170     *----------------------------------------------------------------------
171     */
172    
173            /* ARGSUSED */
174    int
175    Tcl_IfObjCmd(dummy, interp, objc, objv)
176        ClientData dummy;                   /* Not used. */
177        Tcl_Interp *interp;                 /* Current interpreter. */
178        int objc;                           /* Number of arguments. */
179        Tcl_Obj *CONST objv[];              /* Argument objects. */
180    {
181        int thenScriptIndex = 0;    /* then script to be evaled after syntax check */
182        int i, result, value;
183        char *clause;
184        i = 1;
185        while (1) {
186            /*
187             * At this point in the loop, objv and objc refer to an expression
188             * to test, either for the main expression or an expression
189             * following an "elseif".  The arguments after the expression must
190             * be "then" (optional) and a script to execute if the expression is
191             * true.
192             */
193    
194            if (i >= objc) {
195                clause = Tcl_GetString(objv[i-1]);
196                Tcl_AppendResult(interp, "wrong # args: no expression after \"",
197                        clause, "\" argument", (char *) NULL);
198                return TCL_ERROR;
199            }
200            if (!thenScriptIndex) {
201                result = Tcl_ExprBooleanObj(interp, objv[i], &value);
202                if (result != TCL_OK) {
203                    return result;
204                }
205            }
206            i++;
207            if (i >= objc) {
208                missingScript:
209                clause = Tcl_GetString(objv[i-1]);
210                Tcl_AppendResult(interp, "wrong # args: no script following \"",
211                        clause, "\" argument", (char *) NULL);
212                return TCL_ERROR;
213            }
214            clause = Tcl_GetString(objv[i]);
215            if ((i < objc) && (strcmp(clause, "then") == 0)) {
216                i++;
217            }
218            if (i >= objc) {
219                goto missingScript;
220            }
221            if (value) {
222                thenScriptIndex = i;
223                value = 0;
224            }
225            
226            /*
227             * The expression evaluated to false.  Skip the command, then
228             * see if there is an "else" or "elseif" clause.
229             */
230    
231            i++;
232            if (i >= objc) {
233                if (thenScriptIndex) {
234                    return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0);
235                }
236                return TCL_OK;
237            }
238            clause = Tcl_GetString(objv[i]);
239            if ((clause[0] == 'e') && (strcmp(clause, "elseif") == 0)) {
240                i++;
241                continue;
242            }
243            break;
244        }
245    
246        /*
247         * Couldn't find a "then" or "elseif" clause to execute.  Check now
248         * for an "else" clause.  We know that there's at least one more
249         * argument when we get here.
250         */
251    
252        if (strcmp(clause, "else") == 0) {
253            i++;
254            if (i >= objc) {
255                Tcl_AppendResult(interp,
256                        "wrong # args: no script following \"else\" argument",
257                        (char *) NULL);
258                return TCL_ERROR;
259            }
260        }
261        if (i < objc - 1) {
262            Tcl_AppendResult(interp,
263                    "wrong # args: extra words after \"else\" clause in \"if\" command",
264                    (char *) NULL);
265            return TCL_ERROR;
266        }
267        if (thenScriptIndex) {
268            return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0);
269        }
270        return Tcl_EvalObjEx(interp, objv[i], 0);
271    }
272    
273    /*
274     *----------------------------------------------------------------------
275     *
276     * Tcl_IncrObjCmd --
277     *
278     *      This procedure is invoked to process the "incr" Tcl command.
279     *      See the user documentation for details on what it does.
280     *
281     *      With the bytecode compiler, this procedure is only called when
282     *      a command name is computed at runtime, and is "incr" or the name
283     *      to which "incr" was renamed: e.g., "set z incr; $z i -1"
284     *
285     * Results:
286     *      A standard Tcl result.
287     *
288     * Side effects:
289     *      See the user documentation.
290     *
291     *----------------------------------------------------------------------
292     */
293    
294        /* ARGSUSED */
295    int
296    Tcl_IncrObjCmd(dummy, interp, objc, objv)
297        ClientData dummy;                   /* Not used. */
298        Tcl_Interp *interp;                 /* Current interpreter. */
299        int objc;                           /* Number of arguments. */
300        Tcl_Obj *CONST objv[];              /* Argument objects. */
301    {
302        long incrAmount;
303        Tcl_Obj *newValuePtr;
304        
305        if ((objc != 2) && (objc != 3)) {
306            Tcl_WrongNumArgs(interp, 1, objv, "varName ?increment?");
307            return TCL_ERROR;
308        }
309    
310        /*
311         * Calculate the amount to increment by.
312         */
313        
314        if (objc == 2) {
315            incrAmount = 1;
316        } else {
317            if (Tcl_GetLongFromObj(interp, objv[2], &incrAmount) != TCL_OK) {
318                Tcl_AddErrorInfo(interp, "\n    (reading increment)");
319                return TCL_ERROR;
320            }
321        }
322        
323        /*
324         * Increment the variable's value.
325         */
326    
327        newValuePtr = TclIncrVar2(interp, objv[1], (Tcl_Obj *) NULL, incrAmount,
328                TCL_LEAVE_ERR_MSG);
329        if (newValuePtr == NULL) {
330            return TCL_ERROR;
331        }
332    
333        /*
334         * Set the interpreter's object result to refer to the variable's new
335         * value object.
336         */
337    
338        Tcl_SetObjResult(interp, newValuePtr);
339        return TCL_OK;
340    }
341    
342    /*
343     *----------------------------------------------------------------------
344     *
345     * Tcl_InfoObjCmd --
346     *
347     *      This procedure is invoked to process the "info" Tcl command.
348     *      See the user documentation for details on what it does.
349     *
350     * Results:
351     *      A standard Tcl result.
352     *
353     * Side effects:
354     *      See the user documentation.
355     *
356     *----------------------------------------------------------------------
357     */
358    
359            /* ARGSUSED */
360    int
361    Tcl_InfoObjCmd(clientData, interp, objc, objv)
362        ClientData clientData;      /* Arbitrary value passed to the command. */
363        Tcl_Interp *interp;         /* Current interpreter. */
364        int objc;                   /* Number of arguments. */
365        Tcl_Obj *CONST objv[];      /* Argument objects. */
366    {
367        static char *subCmds[] = {
368                "args", "body", "cmdcount", "commands",
369                 "complete", "default", "exists", "globals",
370                 "hostname", "level", "library", "loaded",
371                 "locals", "nameofexecutable", "patchlevel", "procs",
372                 "script", "sharedlibextension", "tclversion", "vars",
373                 (char *) NULL};
374        enum ISubCmdIdx {
375                IArgsIdx, IBodyIdx, ICmdCountIdx, ICommandsIdx,
376                ICompleteIdx, IDefaultIdx, IExistsIdx, IGlobalsIdx,
377                IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx,
378                ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx,
379                IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx
380        };
381        int index, result;
382    
383        if (objc < 2) {
384            Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
385            return TCL_ERROR;
386        }
387        
388        result = Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", 0,
389                (int *) &index);
390        if (result != TCL_OK) {
391            return result;
392        }
393    
394        switch (index) {
395            case IArgsIdx:
396                result = InfoArgsCmd(clientData, interp, objc, objv);
397                break;
398            case IBodyIdx:
399                result = InfoBodyCmd(clientData, interp, objc, objv);
400                break;
401            case ICmdCountIdx:
402                result = InfoCmdCountCmd(clientData, interp, objc, objv);
403                break;
404            case ICommandsIdx:
405                result = InfoCommandsCmd(clientData, interp, objc, objv);
406                break;
407            case ICompleteIdx:
408                result = InfoCompleteCmd(clientData, interp, objc, objv);
409                break;
410            case IDefaultIdx:
411                result = InfoDefaultCmd(clientData, interp, objc, objv);
412                break;
413            case IExistsIdx:
414                result = InfoExistsCmd(clientData, interp, objc, objv);
415                break;
416            case IGlobalsIdx:
417                result = InfoGlobalsCmd(clientData, interp, objc, objv);
418                break;
419            case IHostnameIdx:
420                result = InfoHostnameCmd(clientData, interp, objc, objv);
421                break;
422            case ILevelIdx:
423                result = InfoLevelCmd(clientData, interp, objc, objv);
424                break;
425            case ILibraryIdx:
426                result = InfoLibraryCmd(clientData, interp, objc, objv);
427                break;
428            case ILoadedIdx:
429                result = InfoLoadedCmd(clientData, interp, objc, objv);
430                break;
431            case ILocalsIdx:
432                result = InfoLocalsCmd(clientData, interp, objc, objv);
433                break;
434            case INameOfExecutableIdx:
435                result = InfoNameOfExecutableCmd(clientData, interp, objc, objv);
436                break;
437            case IPatchLevelIdx:
438                result = InfoPatchLevelCmd(clientData, interp, objc, objv);
439                break;
440            case IProcsIdx:
441                result = InfoProcsCmd(clientData, interp, objc, objv);
442                break;
443            case IScriptIdx:
444                result = InfoScriptCmd(clientData, interp, objc, objv);
445                break;
446            case ISharedLibExtensionIdx:
447                result = InfoSharedlibCmd(clientData, interp, objc, objv);
448                break;
449            case ITclVersionIdx:
450                result = InfoTclVersionCmd(clientData, interp, objc, objv);
451                break;
452            case IVarsIdx:
453                result = InfoVarsCmd(clientData, interp, objc, objv);
454                break;
455        }
456        return result;
457    }
458    
459    /*
460     *----------------------------------------------------------------------
461     *
462     * InfoArgsCmd --
463     *
464     *      Called to implement the "info args" command that returns the
465     *      argument list for a procedure. Handles the following syntax:
466     *
467     *          info args procName
468     *
469     * Results:
470     *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
471     *
472     * Side effects:
473     *      Returns a result in the interpreter's result object. If there is
474     *      an error, the result is an error message.
475     *
476     *----------------------------------------------------------------------
477     */
478    
479    static int
480    InfoArgsCmd(dummy, interp, objc, objv)
481        ClientData dummy;           /* Not used. */
482        Tcl_Interp *interp;         /* Current interpreter. */
483        int objc;                   /* Number of arguments. */
484        Tcl_Obj *CONST objv[];      /* Argument objects. */
485    {
486        register Interp *iPtr = (Interp *) interp;
487        char *name;
488        Proc *procPtr;
489        CompiledLocal *localPtr;
490        Tcl_Obj *listObjPtr;
491    
492        if (objc != 3) {
493            Tcl_WrongNumArgs(interp, 2, objv, "procname");
494            return TCL_ERROR;
495        }
496    
497        name = Tcl_GetString(objv[2]);
498        procPtr = TclFindProc(iPtr, name);
499        if (procPtr == NULL) {
500            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
501                    "\"", name, "\" isn't a procedure", (char *) NULL);
502            return TCL_ERROR;
503        }
504    
505        /*
506         * Build a return list containing the arguments.
507         */
508        
509        listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
510        for (localPtr = procPtr->firstLocalPtr;  localPtr != NULL;
511                localPtr = localPtr->nextPtr) {
512            if (TclIsVarArgument(localPtr)) {
513                Tcl_ListObjAppendElement(interp, listObjPtr,
514                        Tcl_NewStringObj(localPtr->name, -1));
515            }
516        }
517        Tcl_SetObjResult(interp, listObjPtr);
518        return TCL_OK;
519    }
520    
521    /*
522     *----------------------------------------------------------------------
523     *
524     * InfoBodyCmd --
525     *
526     *      Called to implement the "info body" command that returns the body
527     *      for a procedure. Handles the following syntax:
528     *
529     *          info body procName
530     *
531     * Results:
532     *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
533     *
534     * Side effects:
535     *      Returns a result in the interpreter's result object. If there is
536     *      an error, the result is an error message.
537     *
538     *----------------------------------------------------------------------
539     */
540    
541    static int
542    InfoBodyCmd(dummy, interp, objc, objv)
543        ClientData dummy;           /* Not used. */
544        Tcl_Interp *interp;         /* Current interpreter. */
545        int objc;                   /* Number of arguments. */
546        Tcl_Obj *CONST objv[];      /* Argument objects. */
547    {
548        register Interp *iPtr = (Interp *) interp;
549        char *name;
550        Proc *procPtr;
551        Tcl_Obj *bodyPtr, *resultPtr;
552        
553        if (objc != 3) {
554            Tcl_WrongNumArgs(interp, 2, objv, "procname");
555            return TCL_ERROR;
556        }
557    
558        name = Tcl_GetString(objv[2]);
559        procPtr = TclFindProc(iPtr, name);
560        if (procPtr == NULL) {
561            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
562                    "\"", name, "\" isn't a procedure", (char *) NULL);
563            return TCL_ERROR;
564        }
565    
566        /*
567         * We should not return a bytecompiled body.  If it is precompiled,
568         * then the bodyPtr's string representation is bogus, since sources
569         * are not available.  If it was just a bytecompiled body, then it
570         * is likely to not be of any use to the caller, as it was compiled
571         * for a separate procedure context [Bug: 3412], and noone else can
572         * reasonably use it.
573         * In order to make sure that later manipulations of the object do not
574         * invalidate the internal representation, we make a copy of the string
575         * representation and return that one, instead.
576         */
577    
578        bodyPtr = procPtr->bodyPtr;
579        resultPtr = bodyPtr;
580        if (bodyPtr->typePtr == &tclByteCodeType) {
581            resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length);
582        }
583        
584        Tcl_SetObjResult(interp, resultPtr);
585        return TCL_OK;
586    }
587    
588    /*
589     *----------------------------------------------------------------------
590     *
591     * InfoCmdCountCmd --
592     *
593     *      Called to implement the "info cmdcount" command that returns the
594     *      number of commands that have been executed. Handles the following
595     *      syntax:
596     *
597     *          info cmdcount
598     *
599     * Results:
600     *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
601     *
602     * Side effects:
603     *      Returns a result in the interpreter's result object. If there is
604     *      an error, the result is an error message.
605     *
606     *----------------------------------------------------------------------
607     */
608    
609    static int
610    InfoCmdCountCmd(dummy, interp, objc, objv)
611        ClientData dummy;           /* Not used. */
612        Tcl_Interp *interp;         /* Current interpreter. */
613        int objc;                   /* Number of arguments. */
614        Tcl_Obj *CONST objv[];      /* Argument objects. */
615    {
616        Interp *iPtr = (Interp *) interp;
617        
618        if (objc != 2) {
619            Tcl_WrongNumArgs(interp, 2, objv, NULL);
620            return TCL_ERROR;
621        }
622    
623        Tcl_SetIntObj(Tcl_GetObjResult(interp), iPtr->cmdCount);
624        return TCL_OK;
625    }
626    
627    /*
628     *----------------------------------------------------------------------
629     *
630     * InfoCommandsCmd --
631     *
632     *      Called to implement the "info commands" command that returns the
633     *      list of commands in the interpreter that match an optional pattern.
634     *      The pattern, if any, consists of an optional sequence of namespace
635     *      names separated by "::" qualifiers, which is followed by a
636     *      glob-style pattern that restricts which commands are returned.
637     *      Handles the following syntax:
638     *
639     *          info commands ?pattern?
640     *
641     * Results:
642     *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
643     *
644     * Side effects:
645     *      Returns a result in the interpreter's result object. If there is
646     *      an error, the result is an error message.
647     *
648     *----------------------------------------------------------------------
649     */
650    
651    static int
652    InfoCommandsCmd(dummy, interp, objc, objv)
653        ClientData dummy;           /* Not used. */
654        Tcl_Interp *interp;         /* Current interpreter. */
655        int objc;                   /* Number of arguments. */
656        Tcl_Obj *CONST objv[];      /* Argument objects. */
657    {
658        char *cmdName, *pattern, *simplePattern;
659        register Tcl_HashEntry *entryPtr;
660        Tcl_HashSearch search;
661        Namespace *nsPtr;
662        Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
663        Namespace *currNsPtr   = (Namespace *) Tcl_GetCurrentNamespace(interp);
664        Tcl_Obj *listPtr, *elemObjPtr;
665        int specificNsInPattern = 0;  /* Init. to avoid compiler warning. */
666        Tcl_Command cmd;
667    
668        /*
669         * Get the pattern and find the "effective namespace" in which to
670         * list commands.
671         */
672    
673        if (objc == 2) {
674            simplePattern = NULL;
675            nsPtr = currNsPtr;
676            specificNsInPattern = 0;
677        } else if (objc == 3) {
678            /*
679             * From the pattern, get the effective namespace and the simple
680             * pattern (no namespace qualifiers or ::'s) at the end. If an
681             * error was found while parsing the pattern, return it. Otherwise,
682             * if the namespace wasn't found, just leave nsPtr NULL: we will
683             * return an empty list since no commands there can be found.
684             */
685    
686            Namespace *dummy1NsPtr, *dummy2NsPtr;
687            
688    
689            pattern = Tcl_GetString(objv[2]);
690            TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL,
691               /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern);
692    
693            if (nsPtr != NULL) {    /* we successfully found the pattern's ns */
694                specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
695            }
696        } else {
697            Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
698            return TCL_ERROR;
699        }
700    
701        /*
702         * Scan through the effective namespace's command table and create a
703         * list with all commands that match the pattern. If a specific
704         * namespace was requested in the pattern, qualify the command names
705         * with the namespace name.
706         */
707    
708        listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
709    
710        if (nsPtr != NULL) {
711            entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
712            while (entryPtr != NULL) {
713                cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
714                if ((simplePattern == NULL)
715                        || Tcl_StringMatch(cmdName, simplePattern)) {
716                    if (specificNsInPattern) {
717                        cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr);
718                        elemObjPtr = Tcl_NewObj();
719                        Tcl_GetCommandFullName(interp, cmd, elemObjPtr);
720                    } else {
721                        elemObjPtr = Tcl_NewStringObj(cmdName, -1);
722                    }
723                    Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
724                }
725                entryPtr = Tcl_NextHashEntry(&search);
726            }
727    
728            /*
729             * If the effective namespace isn't the global :: namespace, and a
730             * specific namespace wasn't requested in the pattern, then add in
731             * all global :: commands that match the simple pattern. Of course,
732             * we add in only those commands that aren't hidden by a command in
733             * the effective namespace.
734             */
735            
736            if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
737                entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
738                while (entryPtr != NULL) {
739                    cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
740                    if ((simplePattern == NULL)
741                            || Tcl_StringMatch(cmdName, simplePattern)) {
742                        if (Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) {
743                            Tcl_ListObjAppendElement(interp, listPtr,
744                                    Tcl_NewStringObj(cmdName, -1));
745                        }
746                    }
747                    entryPtr = Tcl_NextHashEntry(&search);
748                }
749            }
750        }
751        
752        Tcl_SetObjResult(interp, listPtr);
753        return TCL_OK;
754    }
755    
756    /*
757     *----------------------------------------------------------------------
758     *
759     * InfoCompleteCmd --
760     *
761     *      Called to implement the "info complete" command that determines
762     *      whether a string is a complete Tcl command. Handles the following
763     *      syntax:
764     *
765     *          info complete command
766     *
767     * Results:
768     *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
769     *
770     * Side effects:
771     *      Returns a result in the interpreter's result object. If there is
772     *      an error, the result is an error message.
773     *
774     *----------------------------------------------------------------------
775     */
776    
777    static int
778    InfoCompleteCmd(dummy, interp, objc, objv)
779        ClientData dummy;           /* Not used. */
780        Tcl_Interp *interp;         /* Current interpreter. */
781        int objc;                   /* Number of arguments. */
782        Tcl_Obj *CONST objv[];      /* Argument objects. */
783    {
784        if (objc != 3) {
785            Tcl_WrongNumArgs(interp, 2, objv, "command");
786            return TCL_ERROR;
787        }
788    
789        if (TclObjCommandComplete(objv[2])) {
790            Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
791        } else {
792            Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
793        }
794    
795        return TCL_OK;
796    }
797    
798    /*
799     *----------------------------------------------------------------------
800     *
801     * InfoDefaultCmd --
802     *
803     *      Called to implement the "info default" command that returns the
804     *      default value for a procedure argument. Handles the following
805     *      syntax:
806     *
807     *          info default procName arg varName
808     *
809     * Results:
810     *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
811     *
812     * Side effects:
813     *      Returns a result in the interpreter's result object. If there is
814     *      an error, the result is an error message.
815     *
816     *----------------------------------------------------------------------
817     */
818    
819    static int
820    InfoDefaultCmd(dummy, interp, objc, objv)
821        ClientData dummy;           /* Not used. */
822        Tcl_Interp *interp;         /* Current interpreter. */
823        int objc;                   /* Number of arguments. */
824        Tcl_Obj *CONST objv[];      /* Argument objects. */
825    {
826        Interp *iPtr = (Interp *) interp;
827        char *procName, *argName, *varName;
828        Proc *procPtr;
829        CompiledLocal *localPtr;
830        Tcl_Obj *valueObjPtr;
831    
832        if (objc != 5) {
833            Tcl_WrongNumArgs(interp, 2, objv, "procname arg varname");
834            return TCL_ERROR;
835        }
836    
837        procName = Tcl_GetString(objv[2]);
838        argName = Tcl_GetString(objv[3]);
839    
840        procPtr = TclFindProc(iPtr, procName);
841        if (procPtr == NULL) {
842            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
843                    "\"", procName, "\" isn't a procedure", (char *) NULL);
844            return TCL_ERROR;
845        }
846    
847        for (localPtr = procPtr->firstLocalPtr;  localPtr != NULL;
848                localPtr = localPtr->nextPtr) {
849            if (TclIsVarArgument(localPtr)
850                    && (strcmp(argName, localPtr->name) == 0)) {
851                if (localPtr->defValuePtr != NULL) {
852                    valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL,
853                            localPtr->defValuePtr, 0);
854                    if (valueObjPtr == NULL) {
855                        defStoreError:
856                        varName = Tcl_GetString(objv[4]);
857                        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
858                                "couldn't store default value in variable \"",
859                                varName, "\"", (char *) NULL);
860                        return TCL_ERROR;
861                    }
862                    Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
863                } else {
864                    Tcl_Obj *nullObjPtr = Tcl_NewObj();
865                    valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL,
866                            nullObjPtr, 0);
867                    if (valueObjPtr == NULL) {
868                        Tcl_DecrRefCount(nullObjPtr); /* free unneeded obj */
869                        goto defStoreError;
870                    }
871                    Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
872                }
873                return TCL_OK;
874            }
875        }
876    
877        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
878                "procedure \"", procName, "\" doesn't have an argument \"",
879                argName, "\"", (char *) NULL);
880        return TCL_ERROR;
881    }
882    
883    /*
884     *----------------------------------------------------------------------
885     *
886     * InfoExistsCmd --
887     *
888     *      Called to implement the "info exists" command that determines
889     *      whether a variable exists. Handles the following syntax:
890     *
891     *          info exists varName
892     *
893     * Results:
894     *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
895     *
896     * Side effects:
897     *      Returns a result in the interpreter's result object. If there is
898     *      an error, the result is an error message.
899     *
900     *----------------------------------------------------------------------
901     */
902    
903    static int
904    InfoExistsCmd(dummy, interp, objc, objv)
905        ClientData dummy;           /* Not used. */
906        Tcl_Interp *interp;         /* Current interpreter. */
907        int objc;                   /* Number of arguments. */
908        Tcl_Obj *CONST objv[];      /* Argument objects. */
909    {
910        char *varName;
911        Var *varPtr;
912    
913        if (objc != 3) {
914            Tcl_WrongNumArgs(interp, 2, objv, "varName");
915            return TCL_ERROR;
916        }
917    
918        varName = Tcl_GetString(objv[2]);
919        varPtr = TclVarTraceExists(interp, varName);
920        if ((varPtr != NULL) && !TclIsVarUndefined(varPtr)) {
921            Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
922        } else {
923            Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
924        }
925        return TCL_OK;
926    }
927    
928    /*
929     *----------------------------------------------------------------------
930     *
931     * InfoGlobalsCmd --
932     *
933     *      Called to implement the "info globals" command that returns the list
934     *      of global variables matching an optional pattern. Handles the
935     *      following syntax:
936     *
937     *          info globals ?pattern?
938     *
939     * Results:
940     *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
941     *
942     * Side effects:
943     *      Returns a result in the interpreter's result object. If there is
944     *      an error, the result is an error message.
945     *
946     *----------------------------------------------------------------------
947     */
948    
949    static int
950    InfoGlobalsCmd(dummy, interp, objc, objv)
951        ClientData dummy;           /* Not used. */
952        Tcl_Interp *interp;         /* Current interpreter. */
953        int objc;                   /* Number of arguments. */
954        Tcl_Obj *CONST objv[];      /* Argument objects. */
955    {
956        char *varName, *pattern;
957        Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
958        register Tcl_HashEntry *entryPtr;
959        Tcl_HashSearch search;
960        Var *varPtr;
961        Tcl_Obj *listPtr;
962    
963        if (objc == 2) {
964            pattern = NULL;
965        } else if (objc == 3) {
966            pattern = Tcl_GetString(objv[2]);
967        } else {
968            Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
969            return TCL_ERROR;
970        }
971    
972        /*
973         * Scan through the global :: namespace's variable table and create a
974         * list of all global variables that match the pattern.
975         */
976        
977        listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
978        for (entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search);
979                entryPtr != NULL;
980                entryPtr = Tcl_NextHashEntry(&search)) {
981            varPtr = (Var *) Tcl_GetHashValue(entryPtr);
982            if (TclIsVarUndefined(varPtr)) {
983                continue;
984            }
985            varName = Tcl_GetHashKey(&globalNsPtr->varTable, entryPtr);
986            if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
987                Tcl_ListObjAppendElement(interp, listPtr,
988                        Tcl_NewStringObj(varName, -1));
989            }
990        }
991        Tcl_SetObjResult(interp, listPtr);
992        return TCL_OK;
993    }
994    
995    /*
996     *----------------------------------------------------------------------
997     *
998     * InfoHostnameCmd --
999     *
1000     *      Called to implement the "info hostname" command that returns the
1001     *      host name. Handles the following syntax:
1002     *
1003     *          info hostname
1004     *
1005     * Results:
1006     *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
1007     *
1008     * Side effects:
1009     *      Returns a result in the interpreter's result object. If there is
1010     *      an error, the result is an error message.
1011     *
1012     *----------------------------------------------------------------------
1013     */
1014    
1015    static int
1016    InfoHostnameCmd(dummy, interp, objc, objv)
1017        ClientData dummy;           /* Not used. */
1018        Tcl_Interp *interp;         /* Current interpreter. */
1019        int objc;                   /* Number of arguments. */
1020        Tcl_Obj *CONST objv[];      /* Argument objects. */
1021    {
1022        char *name;
1023        if (objc != 2) {
1024            Tcl_WrongNumArgs(interp, 2, objv, NULL);
1025            return TCL_ERROR;
1026        }
1027    
1028        name = Tcl_GetHostName();
1029        if (name) {
1030            Tcl_SetStringObj(Tcl_GetObjResult(interp), name, -1);
1031            return TCL_OK;
1032        } else {
1033            Tcl_SetStringObj(Tcl_GetObjResult(interp),
1034                    "unable to determine name of host", -1);
1035            return TCL_ERROR;
1036        }
1037    }
1038    
1039    /*
1040     *----------------------------------------------------------------------
1041     *
1042     * InfoLevelCmd --
1043     *
1044     *      Called to implement the "info level" command that returns
1045     *      information about the call stack. Handles the following syntax:
1046     *
1047     *          info level ?number?
1048     *
1049     * Results:
1050     *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
1051     *
1052     * Side effects:
1053     *      Returns a result in the interpreter's result object. If there is
1054     *      an error, the result is an error message.
1055     *
1056     *----------------------------------------------------------------------
1057     */
1058    
1059    static int
1060    InfoLevelCmd(dummy, interp, objc, objv)
1061        ClientData dummy;           /* Not used. */
1062        Tcl_Interp *interp;         /* Current interpreter. */
1063        int objc;                   /* Number of arguments. */
1064        Tcl_Obj *CONST objv[];      /* Argument objects. */
1065    {
1066        Interp *iPtr = (Interp *) interp;
1067        int level;
1068        CallFrame *framePtr;
1069        Tcl_Obj *listPtr;
1070    
1071        if (objc == 2) {            /* just "info level" */
1072            if (iPtr->varFramePtr == NULL) {
1073                Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
1074            } else {
1075                Tcl_SetIntObj(Tcl_GetObjResult(interp), iPtr->varFramePtr->level);
1076            }
1077            return TCL_OK;
1078        } else if (objc == 3) {
1079            if (Tcl_GetIntFromObj(interp, objv[2], &level) != TCL_OK) {
1080                return TCL_ERROR;
1081            }
1082            if (level <= 0) {
1083                if (iPtr->varFramePtr == NULL) {
1084                    levelError:
1085                    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1086                            "bad level \"",
1087                            Tcl_GetString(objv[2]),
1088                            "\"", (char *) NULL);
1089                    return TCL_ERROR;
1090                }
1091                level += iPtr->varFramePtr->level;
1092            }
1093            for (framePtr = iPtr->varFramePtr;  framePtr != NULL;
1094                    framePtr = framePtr->callerVarPtr) {
1095                if (framePtr->level == level) {
1096                    break;
1097                }
1098            }
1099            if (framePtr == NULL) {
1100                goto levelError;
1101            }
1102    
1103            listPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv);
1104            Tcl_SetObjResult(interp, listPtr);
1105            return TCL_OK;
1106        }
1107    
1108        Tcl_WrongNumArgs(interp, 2, objv, "?number?");
1109        return TCL_ERROR;
1110    }
1111    
1112    /*
1113     *----------------------------------------------------------------------
1114     *
1115     * InfoLibraryCmd --
1116     *
1117     *      Called to implement the "info library" command that returns the
1118     *      library directory for the Tcl installation. Handles the following
1119     *      syntax:
1120     *
1121     *          info library
1122     *
1123     * Results:
1124     *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
1125     *
1126     * Side effects:
1127     *      Returns a result in the interpreter's result object. If there is
1128     *      an error, the result is an error message.
1129     *
1130     *----------------------------------------------------------------------
1131     */
1132    
1133    static int
1134    InfoLibraryCmd(dummy, interp, objc, objv)
1135        ClientData dummy;           /* Not used. */
1136        Tcl_Interp *interp;         /* Current interpreter. */
1137        int objc;                   /* Number of arguments. */
1138        Tcl_Obj *CONST objv[];      /* Argument objects. */
1139    {
1140        char *libDirName;
1141    
1142        if (objc != 2) {
1143            Tcl_WrongNumArgs(interp, 2, objv, NULL);
1144            return TCL_ERROR;
1145        }
1146    
1147        libDirName = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
1148        if (libDirName != NULL) {
1149            Tcl_SetStringObj(Tcl_GetObjResult(interp), libDirName, -1);
1150            return TCL_OK;
1151        }
1152        Tcl_SetStringObj(Tcl_GetObjResult(interp),
1153                "no library has been specified for Tcl", -1);
1154        return TCL_ERROR;
1155    }
1156    
1157    /*
1158     *----------------------------------------------------------------------
1159     *
1160     * InfoLoadedCmd --
1161     *
1162     *      Called to implement the "info loaded" command that returns the
1163     *      packages that have been loaded into an interpreter. Handles the
1164     *      following syntax:
1165     *
1166     *          info loaded ?interp?
1167     *
1168     * Results:
1169     *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
1170     *
1171     * Side effects:
1172     *      Returns a result in the interpreter's result object. If there is
1173     *      an error, the result is an error message.
1174     *
1175     *----------------------------------------------------------------------
1176     */
1177    
1178    static int
1179    InfoLoadedCmd(dummy, interp, objc, objv)
1180        ClientData dummy;           /* Not used. */
1181        Tcl_Interp *interp;         /* Current interpreter. */
1182        int objc;                   /* Number of arguments. */
1183        Tcl_Obj *CONST objv[];      /* Argument objects. */
1184    {
1185        char *interpName;
1186        int result;
1187    
1188        if ((objc != 2) && (objc != 3)) {
1189            Tcl_WrongNumArgs(interp, 2, objv, "?interp?");
1190            return TCL_ERROR;
1191        }
1192    
1193        if (objc == 2) {            /* get loaded pkgs in all interpreters */
1194            interpName = NULL;
1195        } else {                    /* get pkgs just in specified interp */
1196            interpName = Tcl_GetString(objv[2]);
1197        }
1198        result = TclGetLoadedPackages(interp, interpName);
1199        return result;
1200    }
1201    
1202    /*
1203     *----------------------------------------------------------------------
1204     *
1205     * InfoLocalsCmd --
1206     *
1207     *      Called to implement the "info locals" command to return a list of
1208     *      local variables that match an optional pattern. Handles the
1209     *      following syntax:
1210     *
1211     *          info locals ?pattern?
1212     *
1213     * Results:
1214     *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
1215     *
1216     * Side effects:
1217     *      Returns a result in the interpreter's result object. If there is
1218     *      an error, the result is an error message.
1219     *
1220     *----------------------------------------------------------------------
1221     */
1222    
1223    static int
1224    InfoLocalsCmd(dummy, interp, objc, objv)
1225        ClientData dummy;           /* Not used. */
1226        Tcl_Interp *interp;         /* Current interpreter. */
1227        int objc;                   /* Number of arguments. */
1228        Tcl_Obj *CONST objv[];      /* Argument objects. */
1229    {
1230        Interp *iPtr = (Interp *) interp;
1231        char *pattern;
1232        Tcl_Obj *listPtr;
1233    
1234        if (objc == 2) {
1235            pattern = NULL;
1236        } else if (objc == 3) {
1237            pattern = Tcl_GetString(objv[2]);
1238        } else {
1239            Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
1240            return TCL_ERROR;
1241        }
1242        
1243        if (iPtr->varFramePtr == NULL || !iPtr->varFramePtr->isProcCallFrame) {
1244            return TCL_OK;
1245        }
1246    
1247        /*
1248         * Return a list containing names of first the compiled locals (i.e. the
1249         * ones stored in the call frame), then the variables in the local hash
1250         * table (if one exists).
1251         */
1252        
1253        listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
1254        AppendLocals(interp, listPtr, pattern, 0);
1255        Tcl_SetObjResult(interp, listPtr);
1256        return TCL_OK;
1257    }
1258    
1259    /*
1260     *----------------------------------------------------------------------
1261     *
1262     * AppendLocals --
1263     *
1264     *      Append the local variables for the current frame to the
1265     *      specified list object.
1266     *
1267     * Results:
1268     *      None.
1269     *
1270     * Side effects:
1271     *      None.
1272     *
1273     *----------------------------------------------------------------------
1274     */
1275    
1276    static void
1277    AppendLocals(interp, listPtr, pattern, includeLinks)
1278        Tcl_Interp *interp;         /* Current interpreter. */
1279        Tcl_Obj *listPtr;           /* List object to append names to. */
1280        char *pattern;              /* Pattern to match against. */
1281        int includeLinks;           /* 1 if upvars should be included, else 0. */
1282    {
1283        Interp *iPtr = (Interp *) interp;
1284        CompiledLocal *localPtr;
1285        Var *varPtr;
1286        int i, localVarCt;
1287        char *varName;
1288        Tcl_HashTable *localVarTablePtr;
1289        register Tcl_HashEntry *entryPtr;
1290        Tcl_HashSearch search;
1291    
1292        localPtr = iPtr->varFramePtr->procPtr->firstLocalPtr;
1293        localVarCt = iPtr->varFramePtr->numCompiledLocals;
1294        varPtr = iPtr->varFramePtr->compiledLocals;
1295        localVarTablePtr = iPtr->varFramePtr->varTablePtr;
1296    
1297        for (i = 0; i < localVarCt; i++) {
1298            /*
1299             * Skip nameless (temporary) variables and undefined variables
1300             */
1301    
1302            if (!TclIsVarTemporary(localPtr) && !TclIsVarUndefined(varPtr)) {
1303                varName = varPtr->name;
1304                if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
1305                    Tcl_ListObjAppendElement(interp, listPtr,
1306                            Tcl_NewStringObj(varName, -1));
1307                }
1308            }
1309            varPtr++;
1310            localPtr = localPtr->nextPtr;
1311        }
1312        
1313        if (localVarTablePtr != NULL) {
1314            for (entryPtr = Tcl_FirstHashEntry(localVarTablePtr, &search);
1315                    entryPtr != NULL;
1316                    entryPtr = Tcl_NextHashEntry(&search)) {
1317                varPtr = (Var *) Tcl_GetHashValue(entryPtr);
1318                if (!TclIsVarUndefined(varPtr)
1319                        && (includeLinks || !TclIsVarLink(varPtr))) {
1320                    varName = Tcl_GetHashKey(localVarTablePtr, entryPtr);
1321                    if ((pattern == NULL)
1322                            || Tcl_StringMatch(varName, pattern)) {
1323                        Tcl_ListObjAppendElement(interp, listPtr,
1324                                Tcl_NewStringObj(varName, -1));
1325                    }
1326                }
1327            }
1328        }
1329    }
1330    
1331    /*
1332     *----------------------------------------------------------------------
1333     *
1334     * InfoNameOfExecutableCmd --
1335     *
1336     *      Called to implement the "info nameofexecutable" command that returns
1337     *      the name of the binary file running this application. Handles the
1338     *      following syntax:
1339     *
1340     *          info nameofexecutable
1341     *
1342     * Results:
1343     *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
1344     *
1345     * Side effects:
1346     *      Returns a result in the interpreter's result object. If there is
1347     *      an error, the result is an error message.
1348     *
1349     *----------------------------------------------------------------------
1350     */
1351    
1352    static int
1353    InfoNameOfExecutableCmd(dummy, interp, objc, objv)
1354        ClientData dummy;           /* Not used. */
1355        Tcl_Interp *interp;         /* Current interpreter. */
1356        int objc;                   /* Number of arguments. */
1357        Tcl_Obj *CONST objv[];      /* Argument objects. */
1358    {
1359        CONST char *nameOfExecutable;
1360    
1361        if (objc != 2) {
1362            Tcl_WrongNumArgs(interp, 2, objv, NULL);
1363            return TCL_ERROR;
1364        }
1365    
1366        nameOfExecutable = Tcl_GetNameOfExecutable();
1367        
1368        if (nameOfExecutable != NULL) {
1369            Tcl_SetStringObj(Tcl_GetObjResult(interp), (char *)nameOfExecutable, -1);
1370        }
1371        return TCL_OK;
1372    }
1373    
1374    /*
1375     *----------------------------------------------------------------------
1376     *
1377     * InfoPatchLevelCmd --
1378     *
1379     *      Called to implement the "info patchlevel" command that returns the
1380     *      default value for an argument to a procedure. Handles the following
1381     *      syntax:
1382     *
1383     *          info patchlevel
1384     *
1385     * Results:
1386     *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
1387     *
1388     * Side effects:
1389     *      Returns a result in the interpreter's result object. If there is
1390     *      an error, the result is an error message.
1391     *
1392     *----------------------------------------------------------------------
1393     */
1394    
1395    static int
1396    InfoPatchLevelCmd(dummy, interp, objc, objv)
1397        ClientData dummy;           /* Not used. */
1398        Tcl_Interp *interp;         /* Current interpreter. */
1399        int objc;                   /* Number of arguments. */
1400        Tcl_Obj *CONST objv[];      /* Argument objects. */
1401    {
1402        char *patchlevel;
1403    
1404        if (objc != 2) {
1405            Tcl_WrongNumArgs(interp, 2, objv, NULL);
1406            return TCL_ERROR;
1407        }
1408    
1409        patchlevel = Tcl_GetVar(interp, "tcl_patchLevel",
1410                (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
1411        if (patchlevel != NULL) {
1412            Tcl_SetStringObj(Tcl_GetObjResult(interp), patchlevel, -1);
1413            return TCL_OK;
1414        }
1415        return TCL_ERROR;
1416    }
1417    
1418    /*
1419     *----------------------------------------------------------------------
1420     *
1421     * InfoProcsCmd --
1422     *
1423     *      Called to implement the "info procs" command that returns the
1424     *      list of procedures in the interpreter that match an optional pattern.
1425     *      The pattern, if any, consists of an optional sequence of namespace
1426     *      names separated by "::" qualifiers, which is followed by a
1427     *      glob-style pattern that restricts which commands are returned.
1428     *      Handles the following syntax:
1429     *
1430     *          info procs ?pattern?
1431     *
1432     * Results:
1433     *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
1434     *
1435     * Side effects:
1436     *      Returns a result in the interpreter's result object. If there is
1437     *      an error, the result is an error message.
1438     *
1439     *----------------------------------------------------------------------
1440     */
1441    
1442    static int
1443    InfoProcsCmd(dummy, interp, objc, objv)
1444        ClientData dummy;           /* Not used. */
1445        Tcl_Interp *interp;         /* Current interpreter. */
1446        int objc;                   /* Number of arguments. */
1447        Tcl_Obj *CONST objv[];      /* Argument objects. */
1448    {
1449        char *cmdName, *pattern, *simplePattern;
1450        Namespace *nsPtr;
1451    #ifdef INFO_PROCS_SEARCH_GLOBAL_NS
1452        Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
1453    #endif
1454        Namespace *currNsPtr   = (Namespace *) Tcl_GetCurrentNamespace(interp);
1455        Tcl_Obj *listPtr, *elemObjPtr;
1456        int specificNsInPattern = 0;  /* Init. to avoid compiler warning. */
1457        register Tcl_HashEntry *entryPtr;
1458        Tcl_HashSearch search;
1459        Command *cmdPtr, *realCmdPtr;
1460    
1461        /*
1462         * Get the pattern and find the "effective namespace" in which to
1463         * list procs.
1464         */
1465    
1466        if (objc == 2) {
1467            simplePattern = NULL;
1468            nsPtr = currNsPtr;
1469            specificNsInPattern = 0;
1470        } else if (objc == 3) {
1471            /*
1472             * From the pattern, get the effective namespace and the simple
1473             * pattern (no namespace qualifiers or ::'s) at the end. If an
1474             * error was found while parsing the pattern, return it. Otherwise,
1475             * if the namespace wasn't found, just leave nsPtr NULL: we will
1476             * return an empty list since no commands there can be found.
1477             */
1478    
1479            Namespace *dummy1NsPtr, *dummy2NsPtr;
1480    
1481            pattern = Tcl_GetString(objv[2]);
1482            TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL,
1483                    /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr,
1484                    &simplePattern);
1485    
1486            if (nsPtr != NULL) {    /* we successfully found the pattern's ns */
1487                specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
1488            }
1489        } else {
1490            Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
1491            return TCL_ERROR;
1492        }
1493    
1494        /*
1495         * Scan through the effective namespace's command table and create a
1496         * list with all procs that match the pattern. If a specific
1497         * namespace was requested in the pattern, qualify the command names
1498         * with the namespace name.
1499         */
1500    
1501        listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
1502        if (nsPtr != NULL) {
1503            entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
1504            while (entryPtr != NULL) {
1505                cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
1506                if ((simplePattern == NULL)
1507                        || Tcl_StringMatch(cmdName, simplePattern)) {
1508                    cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
1509    
1510                    if (specificNsInPattern) {
1511                        elemObjPtr = Tcl_NewObj();
1512                        Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr,
1513                                elemObjPtr);
1514                    } else {
1515                        elemObjPtr = Tcl_NewStringObj(cmdName, -1);
1516                    }
1517    
1518                    realCmdPtr = (Command *)
1519                        TclGetOriginalCommand((Tcl_Command) cmdPtr);
1520    
1521                    if (TclIsProc(cmdPtr)
1522                            || ((realCmdPtr != NULL) && TclIsProc(realCmdPtr))) {
1523                        Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
1524                    }
1525                }
1526                entryPtr = Tcl_NextHashEntry(&search);
1527            }
1528    
1529            /*
1530             * If the effective namespace isn't the global :: namespace, and a
1531             * specific namespace wasn't requested in the pattern, then add in
1532             * all global :: procs that match the simple pattern. Of course,
1533             * we add in only those procs that aren't hidden by a proc in
1534             * the effective namespace.
1535             */
1536    
1537    #ifdef INFO_PROCS_SEARCH_GLOBAL_NS
1538            /*
1539             * If "info procs" worked like "info commands", returning the
1540             * commands also seen in the global namespace, then you would
1541             * include this code.  As this could break backwards compatibilty
1542             * with 8.0-8.2, we decided not to "fix" it in 8.3, leaving the
1543             * behavior slightly different.
1544             */
1545            if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
1546                entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
1547                while (entryPtr != NULL) {
1548                    cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
1549                    if ((simplePattern == NULL)
1550                            || Tcl_StringMatch(cmdName, simplePattern)) {
1551                        if (Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) {
1552                            cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
1553                            realCmdPtr = (Command *) TclGetOriginalCommand(
1554                                    (Tcl_Command) cmdPtr);
1555    
1556                            if (TclIsProc(cmdPtr) || ((realCmdPtr != NULL)
1557                                    && TclIsProc(realCmdPtr))) {
1558                                Tcl_ListObjAppendElement(interp, listPtr,
1559                                        Tcl_NewStringObj(cmdName, -1));
1560                            }
1561                        }
1562                    }
1563                    entryPtr = Tcl_NextHashEntry(&search);
1564                }
1565            }
1566    #endif
1567        }
1568    
1569        Tcl_SetObjResult(interp, listPtr);
1570        return TCL_OK;
1571    }
1572    
1573    /*
1574     *----------------------------------------------------------------------
1575     *
1576     * InfoScriptCmd --
1577     *
1578     *      Called to implement the "info script" command that returns the
1579     *      script file that is currently being evaluated. Handles the
1580     *      following syntax:
1581     *
1582     *          info script
1583     *
1584     * Results:
1585     *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
1586     *
1587     * Side effects:
1588     *      Returns a result in the interpreter's result object. If there is
1589     *      an error, the result is an error message.
1590     *
1591     *----------------------------------------------------------------------
1592     */
1593    
1594    static int
1595    InfoScriptCmd(dummy, interp, objc, objv)
1596        ClientData dummy;           /* Not used. */
1597        Tcl_Interp *interp;         /* Current interpreter. */
1598        int objc;                   /* Number of arguments. */
1599        Tcl_Obj *CONST objv[];      /* Argument objects. */
1600    {
1601        Interp *iPtr = (Interp *) interp;
1602        if (objc != 2) {
1603            Tcl_WrongNumArgs(interp, 2, objv, NULL);
1604            return TCL_ERROR;
1605        }
1606    
1607        if (iPtr->scriptFile != NULL) {
1608            Tcl_SetStringObj(Tcl_GetObjResult(interp), iPtr->scriptFile, -1);
1609        }
1610        return TCL_OK;
1611    }
1612    
1613    /*
1614     *----------------------------------------------------------------------
1615     *
1616     * InfoSharedlibCmd --
1617     *
1618     *      Called to implement the "info sharedlibextension" command that
1619     *      returns the file extension used for shared libraries. Handles the
1620     *      following syntax:
1621     *
1622     *          info sharedlibextension
1623     *
1624     * Results:
1625     *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
1626     *
1627     * Side effects:
1628     *      Returns a result in the interpreter's result object. If there is
1629     *      an error, the result is an error message.
1630     *
1631     *----------------------------------------------------------------------
1632     */
1633    
1634    static int
1635    InfoSharedlibCmd(dummy, interp, objc, objv)
1636        ClientData dummy;           /* Not used. */
1637        Tcl_Interp *interp;         /* Current interpreter. */
1638        int objc;                   /* Number of arguments. */
1639        Tcl_Obj *CONST objv[];      /* Argument objects. */
1640    {
1641        if (objc != 2) {
1642            Tcl_WrongNumArgs(interp, 2, objv, NULL);
1643            return TCL_ERROR;
1644        }
1645        
1646    #ifdef TCL_SHLIB_EXT
1647        Tcl_SetStringObj(Tcl_GetObjResult(interp), TCL_SHLIB_EXT, -1);
1648    #endif
1649        return TCL_OK;
1650    }
1651    
1652    /*
1653     *----------------------------------------------------------------------
1654     *
1655     * InfoTclVersionCmd --
1656     *
1657     *      Called to implement the "info tclversion" command that returns the
1658     *      version number for this Tcl library. Handles the following syntax:
1659     *
1660     *          info tclversion