diff options
Diffstat (limited to 'contrib/tcl/generic/tclCmdIL.c')
| -rw-r--r-- | contrib/tcl/generic/tclCmdIL.c | 2926 |
1 files changed, 0 insertions, 2926 deletions
diff --git a/contrib/tcl/generic/tclCmdIL.c b/contrib/tcl/generic/tclCmdIL.c deleted file mode 100644 index 44e4270c167e..000000000000 --- a/contrib/tcl/generic/tclCmdIL.c +++ /dev/null @@ -1,2926 +0,0 @@ -/* - * 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; -} |