summaryrefslogtreecommitdiffstats
path: root/generic/tclCmdIL.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclCmdIL.c')
-rw-r--r--generic/tclCmdIL.c2926
1 files changed, 2926 insertions, 0 deletions
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
new file mode 100644
index 0000000..44e4270
--- /dev/null
+++ b/generic/tclCmdIL.c
@@ -0,0 +1,2926 @@
+/*
+ * 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.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclCmdIL.c 1.173 97/11/18 13:55:01
+ */
+
+#include "tclInt.h"
+#include "tclPort.h"
+
+/*
+ * The following variable holds the full path name of the binary
+ * from which this application was executed, or NULL if it isn't
+ * know. The value of the variable is set by the procedure
+ * Tcl_FindExecutable. The storage space is dynamically allocated.
+ */
+
+char *tclExecutableName = NULL;
+
+/*
+ * 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. */
+ 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_DString compareCmd; /* 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 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_IfCmd --
+ *
+ * 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_IfCmd(dummy, interp, argc, argv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int argc; /* Number of arguments. */
+ char **argv; /* Argument strings. */
+{
+ int i, result, value;
+
+ i = 1;
+ while (1) {
+ /*
+ * At this point in the loop, argv and argc 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 >= argc) {
+ Tcl_AppendResult(interp, "wrong # args: no expression after \"",
+ argv[i-1], "\" argument", (char *) NULL);
+ return TCL_ERROR;
+ }
+ result = Tcl_ExprBoolean(interp, argv[i], &value);
+ if (result != TCL_OK) {
+ return result;
+ }
+ i++;
+ if ((i < argc) && (strcmp(argv[i], "then") == 0)) {
+ i++;
+ }
+ if (i >= argc) {
+ Tcl_AppendResult(interp, "wrong # args: no script following \"",
+ argv[i-1], "\" argument", (char *) NULL);
+ return TCL_ERROR;
+ }
+ if (value) {
+ return Tcl_Eval(interp, argv[i]);
+ }
+
+ /*
+ * The expression evaluated to false. Skip the command, then
+ * see if there is an "else" or "elseif" clause.
+ */
+
+ i++;
+ if (i >= argc) {
+ return TCL_OK;
+ }
+ if ((argv[i][0] == 'e') && (strcmp(argv[i], "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(argv[i], "else") == 0) {
+ i++;
+ if (i >= argc) {
+ Tcl_AppendResult(interp,
+ "wrong # args: no script following \"else\" argument",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+ }
+ return Tcl_Eval(interp, argv[i]);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_IncrCmd --
+ *
+ * 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_IncrCmd(dummy, interp, argc, argv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int argc; /* Number of arguments. */
+ char **argv; /* Argument strings. */
+{
+ int value;
+ char *oldString, *result;
+ char newString[30];
+
+ if ((argc != 2) && (argc != 3)) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " varName ?increment?\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ oldString = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG);
+ if (oldString == NULL) {
+ return TCL_ERROR;
+ }
+ if (Tcl_GetInt(interp, oldString, &value) != TCL_OK) {
+ Tcl_AddErrorInfo(interp,
+ "\n (reading value of variable to increment)");
+ return TCL_ERROR;
+ }
+ if (argc == 2) {
+ value += 1;
+ } else {
+ int increment;
+
+ if (Tcl_GetInt(interp, argv[2], &increment) != TCL_OK) {
+ Tcl_AddErrorInfo(interp,
+ "\n (reading increment)");
+ return TCL_ERROR;
+ }
+ value += increment;
+ }
+ TclFormatInt(newString, value);
+ result = Tcl_SetVar(interp, argv[1], newString, TCL_LEAVE_ERR_MSG);
+ if (result == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Copy the result since the variable's value might change.
+ */
+
+ Tcl_SetResult(interp, result, TCL_VOLATILE);
+ 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
+ } index;
+ int 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 is successful and TCL_ERROR is 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_GetStringFromObj(objv[2], (int *) NULL);
+ 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 (localPtr->isArg) {
+ 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 is successful and TCL_ERROR is 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;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "procname");
+ return TCL_ERROR;
+ }
+
+ name = Tcl_GetStringFromObj(objv[2], (int *) NULL);
+ procPtr = TclFindProc(iPtr, name);
+ if (procPtr == NULL) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "\"", name, "\" isn't a procedure", (char *) NULL);
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, procPtr->bodyPtr);
+ 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 is successful and TCL_ERROR is 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 is successful and TCL_ERROR is 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;
+ int result;
+
+ /*
+ * 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_GetStringFromObj(objv[2], (int *) NULL);
+ result = TclGetNamespaceForQualName(interp, pattern,
+ (Namespace *) NULL, /*flags*/ TCL_LEAVE_ERR_MSG,
+ &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern);
+ if (result != TCL_OK) {
+ return TCL_ERROR;
+ }
+ 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 is successful and TCL_ERROR is 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. */
+{
+ char *command;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "command");
+ return TCL_ERROR;
+ }
+
+ command = Tcl_GetStringFromObj(objv[2], (int *) NULL);
+ if (Tcl_CommandComplete(command)) {
+ 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 is successful and TCL_ERROR is 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_GetStringFromObj(objv[2], (int *) NULL);
+ argName = Tcl_GetStringFromObj(objv[3], (int *) NULL);
+
+ 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 ((localPtr->isArg) && (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_GetStringFromObj(objv[4], (int *) NULL);
+ 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 is successful and TCL_ERROR is 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, *arrayPtr;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "varName");
+ return TCL_ERROR;
+ }
+
+ varName = Tcl_GetStringFromObj(objv[2], (int *) NULL);
+ varPtr = TclLookupVar(interp, varName, (char *) NULL,
+ TCL_PARSE_PART1, "access",
+ /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
+ 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 is successful and TCL_ERROR is 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_GetStringFromObj(objv[2], (int *) NULL);
+ } 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 is successful and TCL_ERROR is 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 is successful and TCL_ERROR is 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_GetStringFromObj(objv[2], (int *) NULL),
+ "\"", (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 is successful and TCL_ERROR is 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 is successful and TCL_ERROR is 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_GetStringFromObj(objv[2], (int *) NULL);
+ }
+ 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 is successful and TCL_ERROR is 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;
+ Var *varPtr;
+ char *varName, *pattern;
+ int i, localVarCt;
+ Tcl_HashTable *localVarTablePtr;
+ register Tcl_HashEntry *entryPtr;
+ Tcl_HashSearch search;
+ Tcl_Obj *listPtr;
+
+ if (objc == 2) {
+ pattern = NULL;
+ } else if (objc == 3) {
+ pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
+ } else {
+ Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
+ return TCL_ERROR;
+ }
+
+ if (iPtr->varFramePtr == NULL) {
+ return TCL_OK;
+ }
+ localVarTablePtr = iPtr->varFramePtr->varTablePtr;
+
+ /*
+ * 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);
+
+ localVarCt = iPtr->varFramePtr->numCompiledLocals;
+ for (i = 0, varPtr = iPtr->varFramePtr->compiledLocals;
+ i < localVarCt;
+ i++, varPtr++) {
+ if (!TclIsVarUndefined(varPtr)) {
+ varName = varPtr->name;
+ if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
+ Tcl_ListObjAppendElement(interp, listPtr,
+ Tcl_NewStringObj(varName, -1));
+ }
+ }
+ }
+
+ if (localVarTablePtr != NULL) {
+ for (entryPtr = Tcl_FirstHashEntry(localVarTablePtr, &search);
+ entryPtr != NULL;
+ entryPtr = Tcl_NextHashEntry(&search)) {
+ varPtr = (Var *) Tcl_GetHashValue(entryPtr);
+ if (!TclIsVarUndefined(varPtr) && !TclIsVarLink(varPtr)) {
+ varName = Tcl_GetHashKey(localVarTablePtr, entryPtr);
+ if ((pattern == NULL)
+ || Tcl_StringMatch(varName, pattern)) {
+ Tcl_ListObjAppendElement(interp, listPtr,
+ Tcl_NewStringObj(varName, -1));
+ }
+ }
+ }
+ }
+
+ Tcl_SetObjResult(interp, listPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 is successful and TCL_ERROR is 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. */
+{
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ if (tclExecutableName != NULL) {
+ Tcl_SetStringObj(Tcl_GetObjResult(interp), tclExecutableName, -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 is successful and TCL_ERROR is 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
+ * procedures in the current namespace that match an optional pattern.
+ * Handles the following syntax:
+ *
+ * info procs ?pattern?
+ *
+ * Results:
+ * Returns TCL_OK is successful and TCL_ERROR is 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;
+ Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
+ register Tcl_HashEntry *entryPtr;
+ Tcl_HashSearch search;
+ Command *cmdPtr;
+ Tcl_Obj *listPtr;
+
+ if (objc == 2) {
+ pattern = NULL;
+ } else if (objc == 3) {
+ pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
+ } else {
+ Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Scan through the current namespace's command table and return a list
+ * of all procs that match the pattern.
+ */
+
+ listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+ for (entryPtr = Tcl_FirstHashEntry(&currNsPtr->cmdTable, &search);
+ entryPtr != NULL;
+ entryPtr = Tcl_NextHashEntry(&search)) {
+ cmdName = Tcl_GetHashKey(&currNsPtr->cmdTable, entryPtr);
+ cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
+ if (TclIsProc(cmdPtr)) {
+ if ((pattern == NULL) || Tcl_StringMatch(cmdName, pattern)) {
+ Tcl_ListObjAppendElement(interp, listPtr,
+ Tcl_NewStringObj(cmdName, -1));
+ }
+ }
+ }
+ 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 is successful and TCL_ERROR is 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 is successful and TCL_ERROR is 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 is successful and TCL_ERROR is 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 is successful and TCL_ERROR is 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, *localVarPtr;
+ 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. */
+ int i, result;
+
+ /*
+ * 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_GetStringFromObj(objv[2], (int *) NULL);
+ result = TclGetNamespaceForQualName(interp, pattern,
+ (Namespace *) NULL, /*flags*/ TCL_LEAVE_ERR_MSG,
+ &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern);
+ if (result != TCL_OK) {
+ return TCL_ERROR;
+ }
+ 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 {
+ /*
+ * We're in a local call frame and no specific namespace was
+ * specific. Create a list that starts with the compiled locals
+ * (i.e. the ones stored in the call frame).
+ */
+
+ CallFrame *varFramePtr = iPtr->varFramePtr;
+ int localVarCt = varFramePtr->numCompiledLocals;
+ Tcl_HashTable *varTablePtr = varFramePtr->varTablePtr;
+
+ for (i = 0, localVarPtr = iPtr->varFramePtr->compiledLocals;
+ i < localVarCt;
+ i++, localVarPtr++) {
+ if (!TclIsVarUndefined(localVarPtr)) {
+ varName = localVarPtr->name;
+ if ((simplePattern == NULL)
+ || Tcl_StringMatch(varName, simplePattern)) {
+ Tcl_ListObjAppendElement(interp, listPtr,
+ Tcl_NewStringObj(varName, -1));
+ }
+ }
+ }
+
+ /*
+ * Now add in the variables in the call frame's variable hash
+ * table (if one exists).
+ */
+
+ if (varTablePtr != NULL) {
+ for (entryPtr = Tcl_FirstHashEntry(varTablePtr, &search);
+ entryPtr != NULL;
+ entryPtr = Tcl_NextHashEntry(&search)) {
+ varPtr = (Var *) Tcl_GetHashValue(entryPtr);
+ if (!TclIsVarUndefined(varPtr)) {
+ varName = Tcl_GetHashKey(varTablePtr, entryPtr);
+ if ((simplePattern == NULL)
+ || Tcl_StringMatch(varName, simplePattern)) {
+ Tcl_ListObjAppendElement(interp, listPtr,
+ Tcl_NewStringObj(varName, -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 = TclGetIntForIndex(interp, objv[2], /*endValue*/ INT_MAX,
+ &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_GetStringFromObj(objv[2], (int *) NULL), (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. */
+{
+#define EXACT 0
+#define GLOB 1
+#define REGEXP 2
+ char *bytes, *patternBytes;
+ int i, match, mode, index, result, listLen, length, elemLen;
+ Tcl_Obj **elemPtrs;
+ static char *switches[] =
+ {"-exact", "-glob", "-regexp", (char *) NULL};
+
+ mode = GLOB;
+ if (objc == 4) {
+ if (Tcl_GetIndexFromObj(interp, objv[1], switches,
+ "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], &listLen, &elemPtrs);
+ if (result != TCL_OK) {
+ return result;
+ }
+
+ patternBytes = Tcl_GetStringFromObj(objv[objc-1], &length);
+
+ index = -1;
+ for (i = 0; i < listLen; i++) {
+ match = 0;
+ bytes = Tcl_GetStringFromObj(elemPtrs[i], &elemLen);
+ switch (mode) {
+ case EXACT:
+ if (length == elemLen) {
+ match = (memcmp(bytes, patternBytes,
+ (size_t) length) == 0);
+ }
+ break;
+ case GLOB:
+ /*
+ * WARNING: will not work with data containing NULLs.
+ */
+ match = Tcl_StringMatch(bytes, patternBytes);
+ break;
+ case REGEXP:
+ /*
+ * WARNING: will not work with data containing NULLs.
+ */
+ match = Tcl_RegExpMatch(interp, bytes, patternBytes);
+ if (match < 0) {
+ return TCL_ERROR;
+ }
+ break;
+ }
+ if (match) {
+ 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, dummy;
+ 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", (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;
+ 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;
+ }
+ }
+ if (sortInfo.sortMode == SORTMODE_COMMAND) {
+ Tcl_DStringInit(&sortInfo.compareCmd);
+ Tcl_DStringAppend(&sortInfo.compareCmd,
+ Tcl_GetStringFromObj(cmdPtr, &dummy), -1);
+ }
+
+ 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].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);
+ for (; elementPtr != NULL; elementPtr = elementPtr->nextPtr){
+ Tcl_ListObjAppendElement(interp, resultPtr, elementPtr->objPtr);
+ }
+ }
+ ckfree((char*) elementArray);
+
+ done:
+ if (sortInfo.sortMode == SORTMODE_COMMAND) {
+ Tcl_DStringFree(&sortInfo.compareCmd);
+ }
+ 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;
+
+ if (leftPtr == NULL) {
+ return rightPtr;
+ }
+ if (rightPtr == NULL) {
+ return leftPtr;
+ }
+ if (SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr) > 0) {
+ tailPtr = rightPtr;
+ rightPtr = rightPtr->nextPtr;
+ } else {
+ tailPtr = leftPtr;
+ leftPtr = leftPtr->nextPtr;
+ }
+ headPtr = tailPtr;
+ while ((leftPtr != NULL) && (rightPtr != NULL)) {
+ if (SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr) > 0) {
+ tailPtr->nextPtr = rightPtr;
+ tailPtr = rightPtr;
+ rightPtr = rightPtr->nextPtr;
+ } else {
+ 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, dummy, listLen, index;
+ Tcl_Obj *objPtr;
+ char buffer[30];
+
+ 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:
+ sprintf(buffer, "%d", infoPtr->index);
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp),
+ "element ", buffer, " missing from sublist \"",
+ Tcl_GetStringFromObj(objPtr, (int *) NULL),
+ "\"", (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_GetStringFromObj(objPtr1, &dummy),
+ Tcl_GetStringFromObj(objPtr2, &dummy));
+ } else if (infoPtr->sortMode == SORTMODE_DICTIONARY) {
+ order = DictionaryCompare(
+ Tcl_GetStringFromObj(objPtr1, &dummy),
+ Tcl_GetStringFromObj(objPtr2, &dummy));
+ } else if (infoPtr->sortMode == SORTMODE_INTEGER) {
+ int a, b;
+
+ if ((Tcl_GetIntFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK)
+ || (Tcl_GetIntFromObj(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 {
+ int oldLength;
+
+ /*
+ * Generate and evaluate a command to determine which string comes
+ * first.
+ */
+
+ oldLength = Tcl_DStringLength(&infoPtr->compareCmd);
+ Tcl_DStringAppendElement(&infoPtr->compareCmd,
+ Tcl_GetStringFromObj(objPtr1, &dummy));
+ Tcl_DStringAppendElement(&infoPtr->compareCmd,
+ Tcl_GetStringFromObj(objPtr2, &dummy));
+ infoPtr->resultCode = Tcl_Eval(infoPtr->interp,
+ Tcl_DStringValue(&infoPtr->compareCmd));
+ Tcl_DStringTrunc(&infoPtr->compareCmd, oldLength);
+ 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 */
+{
+ int diff, zeros;
+ int secondaryDiff = 0;
+
+ while (1) {
+ if (isdigit(UCHAR(*right)) && isdigit(UCHAR(*left))) {
+ /*
+ * 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') && (*(right + 1) != '\0')) {
+ right++;
+ zeros--;
+ }
+ while ((*left == '0') && (*(left + 1) != '\0')) {
+ 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 = *left - *right;
+ }
+ right++;
+ left++;
+ if (!isdigit(UCHAR(*right))) {
+ if (isdigit(UCHAR(*left))) {
+ 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))) {
+ return -1;
+ }
+ }
+ continue;
+ }
+ diff = *left - *right;
+ if (diff) {
+ if (isupper(UCHAR(*left)) && islower(UCHAR(*right))) {
+ diff = tolower(*left) - *right;
+ if (diff) {
+ return diff;
+ } else if (secondaryDiff == 0) {
+ secondaryDiff = -1;
+ }
+ } else if (isupper(UCHAR(*right)) && islower(UCHAR(*left))) {
+ diff = *left - tolower(UCHAR(*right));
+ if (diff) {
+ return diff;
+ } else if (secondaryDiff == 0) {
+ secondaryDiff = 1;
+ }
+ } else {
+ return diff;
+ }
+ }
+ if (*left == 0) {
+ break;
+ }
+ left++;
+ right++;
+ }
+ if (diff == 0) {
+ diff = secondaryDiff;
+ }
+ return diff;
+}