diff options
Diffstat (limited to 'contrib/tcl/generic/tclCmdIL.c')
| -rw-r--r-- | contrib/tcl/generic/tclCmdIL.c | 1487 |
1 files changed, 1487 insertions, 0 deletions
diff --git a/contrib/tcl/generic/tclCmdIL.c b/contrib/tcl/generic/tclCmdIL.c new file mode 100644 index 0000000..9998e19 --- /dev/null +++ b/contrib/tcl/generic/tclCmdIL.c @@ -0,0 +1,1487 @@ +/* + * 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) 1994-1995 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.119 96/03/22 12:10:14 + */ + +#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; + +/* + * The variables below are used to implement the "lsort" command. + * Unfortunately, this use of static variables prevents "lsort" + * from being thread-safe, but there's no alternative given the + * current implementation of qsort. In a threaded environment + * these variables should be made thread-local if possible, or else + * "lsort" needs internal mutual exclusion. + */ + +static Tcl_Interp *sortInterp = NULL; /* Interpreter for "lsort" command. + * NULL means no lsort is active. */ +static enum {ASCII, INTEGER, REAL, COMMAND} sortMode; + /* Mode for sorting: compare as strings, + * compare as numbers, or call + * user-defined command for + * comparison. */ +static Tcl_DString sortCmd; /* Holds command if mode is COMMAND. + * pre-initialized to hold base of + * command. */ +static int sortIncreasing; /* 0 means sort in decreasing order, + * 1 means increasing order. */ +static int sortCode; /* Anything other than TCL_OK means a + * problem occurred while sorting; this + * executing a comparison command, so + * the sort was aborted. */ + +/* + * Forward declarations for procedures defined in this file: + */ + +static int SortCompareProc _ANSI_ARGS_((CONST VOID *first, + CONST VOID *second)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_IfCmd -- + * + * This procedure is invoked to process the "if" 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_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. + * + * 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; + } + sprintf(newString, "%d", value); + result = Tcl_SetVar(interp, argv[1], newString, TCL_LEAVE_ERR_MSG); + if (result == NULL) { + return TCL_ERROR; + } + interp->result = result; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_InfoCmd -- + * + * 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_InfoCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + register Interp *iPtr = (Interp *) interp; + size_t length; + int c; + Arg *argPtr; + Proc *procPtr; + Var *varPtr; + Command *cmdPtr; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option ?arg arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + c = argv[1][0]; + length = strlen(argv[1]); + if ((c == 'a') && (strncmp(argv[1], "args", length)) == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " args procname\"", (char *) NULL); + return TCL_ERROR; + } + procPtr = TclFindProc(iPtr, argv[2]); + if (procPtr == NULL) { + infoNoSuchProc: + Tcl_AppendResult(interp, "\"", argv[2], + "\" isn't a procedure", (char *) NULL); + return TCL_ERROR; + } + for (argPtr = procPtr->argPtr; argPtr != NULL; + argPtr = argPtr->nextPtr) { + Tcl_AppendElement(interp, argPtr->name); + } + return TCL_OK; + } else if ((c == 'b') && (strncmp(argv[1], "body", length)) == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " body procname\"", (char *) NULL); + return TCL_ERROR; + } + procPtr = TclFindProc(iPtr, argv[2]); + if (procPtr == NULL) { + goto infoNoSuchProc; + } + iPtr->result = procPtr->command; + return TCL_OK; + } else if ((c == 'c') && (strncmp(argv[1], "cmdcount", length) == 0) + && (length >= 2)) { + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " cmdcount\"", (char *) NULL); + return TCL_ERROR; + } + sprintf(iPtr->result, "%d", iPtr->cmdCount); + return TCL_OK; + } else if ((c == 'c') && (strncmp(argv[1], "commands", length) == 0) + && (length >= 4)) { + if (argc > 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " commands ?pattern?\"", (char *) NULL); + return TCL_ERROR; + } + for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr); + if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) { + continue; + } + Tcl_AppendElement(interp, name); + } + return TCL_OK; + } else if ((c == 'c') && (strncmp(argv[1], "complete", length) == 0) + && (length >= 4)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " complete command\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_CommandComplete(argv[2])) { + interp->result = "1"; + } else { + interp->result = "0"; + } + return TCL_OK; + } else if ((c == 'd') && (strncmp(argv[1], "default", length)) == 0) { + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " default procname arg varname\"", + (char *) NULL); + return TCL_ERROR; + } + procPtr = TclFindProc(iPtr, argv[2]); + if (procPtr == NULL) { + goto infoNoSuchProc; + } + for (argPtr = procPtr->argPtr; ; argPtr = argPtr->nextPtr) { + if (argPtr == NULL) { + Tcl_AppendResult(interp, "procedure \"", argv[2], + "\" doesn't have an argument \"", argv[3], + "\"", (char *) NULL); + return TCL_ERROR; + } + if (strcmp(argv[3], argPtr->name) == 0) { + if (argPtr->defValue != NULL) { + if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4], + argPtr->defValue, 0) == NULL) { + defStoreError: + Tcl_AppendResult(interp, + "couldn't store default value in variable \"", + argv[4], "\"", (char *) NULL); + return TCL_ERROR; + } + iPtr->result = "1"; + } else { + if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4], "", 0) + == NULL) { + goto defStoreError; + } + iPtr->result = "0"; + } + return TCL_OK; + } + } + } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0)) { + char *p; + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " exists varName\"", (char *) NULL); + return TCL_ERROR; + } + p = Tcl_GetVar((Tcl_Interp *) iPtr, argv[2], 0); + + /* + * The code below handles the special case where the name is for + * an array: Tcl_GetVar will reject this since you can't read + * an array variable without an index. + */ + + if (p == NULL) { + Tcl_HashEntry *hPtr; + Var *varPtr; + + if (strchr(argv[2], '(') != NULL) { + noVar: + iPtr->result = "0"; + return TCL_OK; + } + if (iPtr->varFramePtr == NULL) { + hPtr = Tcl_FindHashEntry(&iPtr->globalTable, argv[2]); + } else { + hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, argv[2]); + } + if (hPtr == NULL) { + goto noVar; + } + varPtr = (Var *) Tcl_GetHashValue(hPtr); + if (varPtr->flags & VAR_UPVAR) { + varPtr = varPtr->value.upvarPtr; + } + if (!(varPtr->flags & VAR_ARRAY)) { + goto noVar; + } + } + iPtr->result = "1"; + return TCL_OK; + } else if ((c == 'g') && (strncmp(argv[1], "globals", length) == 0)) { + char *name; + + if (argc > 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " globals ?pattern?\"", (char *) NULL); + return TCL_ERROR; + } + for (hPtr = Tcl_FirstHashEntry(&iPtr->globalTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + varPtr = (Var *) Tcl_GetHashValue(hPtr); + if (varPtr->flags & VAR_UNDEFINED) { + continue; + } + name = Tcl_GetHashKey(&iPtr->globalTable, hPtr); + if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) { + continue; + } + Tcl_AppendElement(interp, name); + } + return TCL_OK; + } else if ((c == 'h') && (strncmp(argv[1], "hostname", length) == 0)) { + if (argc > 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " hostname\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_AppendResult(interp, Tcl_GetHostName(), NULL); + return TCL_OK; + } else if ((c == 'l') && (strncmp(argv[1], "level", length) == 0) + && (length >= 2)) { + if (argc == 2) { + if (iPtr->varFramePtr == NULL) { + iPtr->result = "0"; + } else { + sprintf(iPtr->result, "%d", iPtr->varFramePtr->level); + } + return TCL_OK; + } else if (argc == 3) { + int level; + CallFrame *framePtr; + + if (Tcl_GetInt(interp, argv[2], &level) != TCL_OK) { + return TCL_ERROR; + } + if (level <= 0) { + if (iPtr->varFramePtr == NULL) { + levelError: + Tcl_AppendResult(interp, "bad level \"", argv[2], + "\"", (char *) NULL); + return TCL_ERROR; + } + level += iPtr->varFramePtr->level; + } + for (framePtr = iPtr->varFramePtr; framePtr != NULL; + framePtr = framePtr->callerVarPtr) { + if (framePtr->level == level) { + break; + } + } + if (framePtr == NULL) { + goto levelError; + } + iPtr->result = Tcl_Merge(framePtr->argc, framePtr->argv); + iPtr->freeProc = TCL_DYNAMIC; + return TCL_OK; + } + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " level [number]\"", (char *) NULL); + return TCL_ERROR; + } else if ((c == 'l') && (strncmp(argv[1], "library", length) == 0) + && (length >= 2)) { + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " library\"", (char *) NULL); + return TCL_ERROR; + } + interp->result = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY); + if (interp->result == NULL) { + interp->result = "no library has been specified for Tcl"; + return TCL_ERROR; + } + return TCL_OK; + } else if ((c == 'l') && (strncmp(argv[1], "loaded", length) == 0) + && (length >= 3)) { + if ((argc != 2) && (argc != 3)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " loaded ?interp?\"", (char *) NULL); + return TCL_ERROR; + } + return TclGetLoadedPackages(interp, argv[2]); + } else if ((c == 'l') && (strncmp(argv[1], "locals", length) == 0) + && (length >= 3)) { + char *name; + + if (argc > 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " locals ?pattern?\"", (char *) NULL); + return TCL_ERROR; + } + if (iPtr->varFramePtr == NULL) { + return TCL_OK; + } + for (hPtr = Tcl_FirstHashEntry(&iPtr->varFramePtr->varTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + varPtr = (Var *) Tcl_GetHashValue(hPtr); + if (varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR)) { + continue; + } + name = Tcl_GetHashKey(&iPtr->varFramePtr->varTable, hPtr); + if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) { + continue; + } + Tcl_AppendElement(interp, name); + } + return TCL_OK; + } else if ((c == 'n') && (strncmp(argv[1], "nameofexecutable", + length) == 0)) { + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " nameofexecutable\"", (char *) NULL); + return TCL_ERROR; + } + if (tclExecutableName != NULL) { + interp->result = tclExecutableName; + } + return TCL_OK; + } else if ((c == 'p') && (strncmp(argv[1], "patchlevel", length) == 0) + && (length >= 2)) { + char *value; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " patchlevel\"", (char *) NULL); + return TCL_ERROR; + } + value = Tcl_GetVar(interp, "tcl_patchLevel", + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG); + if (value == NULL) { + return TCL_ERROR; + } + interp->result = value; + return TCL_OK; + } else if ((c == 'p') && (strncmp(argv[1], "procs", length) == 0) + && (length >= 2)) { + if (argc > 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " procs ?pattern?\"", (char *) NULL); + return TCL_ERROR; + } + for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr); + + cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + if (!TclIsProc(cmdPtr)) { + continue; + } + if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) { + continue; + } + Tcl_AppendElement(interp, name); + } + return TCL_OK; + } else if ((c == 's') && (strncmp(argv[1], "script", length) == 0) + && (length >= 2)) { + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " script\"", (char *) NULL); + return TCL_ERROR; + } + if (iPtr->scriptFile != NULL) { + /* + * Can't depend on iPtr->scriptFile to be non-volatile: + * if this command is returned as the result of the script, + * then iPtr->scriptFile will go away. + */ + + Tcl_SetResult(interp, iPtr->scriptFile, TCL_VOLATILE); + } + return TCL_OK; + } else if ((c == 's') && (strncmp(argv[1], "sharedlibextension", + length) == 0) && (length >= 2)) { + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " sharedlibextension\"", (char *) NULL); + return TCL_ERROR; + } +#ifdef TCL_SHLIB_EXT + interp->result = TCL_SHLIB_EXT; +#endif + return TCL_OK; + } else if ((c == 't') && (strncmp(argv[1], "tclversion", length) == 0)) { + char *value; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " tclversion\"", (char *) NULL); + return TCL_ERROR; + } + value = Tcl_GetVar(interp, "tcl_version", + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG); + if (value == NULL) { + return TCL_ERROR; + } + interp->result = value; + return TCL_OK; + } else if ((c == 'v') && (strncmp(argv[1], "vars", length)) == 0) { + Tcl_HashTable *tablePtr; + char *name; + + if (argc > 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " vars ?pattern?\"", (char *) NULL); + return TCL_ERROR; + } + if (iPtr->varFramePtr == NULL) { + tablePtr = &iPtr->globalTable; + } else { + tablePtr = &iPtr->varFramePtr->varTable; + } + for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + varPtr = (Var *) Tcl_GetHashValue(hPtr); + if (varPtr->flags & VAR_UNDEFINED) { + continue; + } + name = Tcl_GetHashKey(tablePtr, hPtr); + if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) { + continue; + } + Tcl_AppendElement(interp, name); + } + return TCL_OK; + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be args, body, cmdcount, commands, ", + "complete, default, ", + "exists, globals, hostname, level, library, loaded, locals, ", + "nameofexecutable, patchlevel, procs, script, ", + "sharedlibextension, tclversion, or vars", + (char *) NULL); + return TCL_ERROR; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_JoinCmd -- + * + * This procedure is invoked to process the "join" 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_JoinCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + char *joinString; + char **listArgv; + int listArgc, i; + + if (argc == 2) { + joinString = " "; + } else if (argc == 3) { + joinString = argv[2]; + } else { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " list ?joinString?\"", (char *) NULL); + return TCL_ERROR; + } + + if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) { + return TCL_ERROR; + } + for (i = 0; i < listArgc; i++) { + if (i == 0) { + Tcl_AppendResult(interp, listArgv[0], (char *) NULL); + } else { + Tcl_AppendResult(interp, joinString, listArgv[i], (char *) NULL); + } + } + ckfree((char *) listArgv); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LindexCmd -- + * + * This procedure is invoked to process the "lindex" 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_LindexCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + char *p, *element, *next; + int index, size, parenthesized, result, returnLast; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " list index\"", (char *) NULL); + return TCL_ERROR; + } + if ((*argv[2] == 'e') && (strncmp(argv[2], "end", strlen(argv[2])) == 0)) { + returnLast = 1; + index = INT_MAX; + } else { + returnLast = 0; + if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) { + return TCL_ERROR; + } + } + if (index < 0) { + return TCL_OK; + } + for (p = argv[1] ; index >= 0; index--) { + result = TclFindElement(interp, p, &element, &next, &size, + &parenthesized); + if (result != TCL_OK) { + return result; + } + if ((*next == 0) && returnLast) { + break; + } + p = next; + } + if (size == 0) { + return TCL_OK; + } + if (size >= TCL_RESULT_SIZE) { + interp->result = (char *) ckalloc((unsigned) size+1); + interp->freeProc = TCL_DYNAMIC; + } + if (parenthesized) { + memcpy((VOID *) interp->result, (VOID *) element, (size_t) size); + interp->result[size] = 0; + } else { + TclCopyAndCollapse(size, element, interp->result); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LinsertCmd -- + * + * This procedure is invoked to process the "linsert" 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_LinsertCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + char *p, *element, savedChar; + int i, index, count, result, size; + + if (argc < 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " list index element ?element ...?\"", (char *) NULL); + return TCL_ERROR; + } + if ((*argv[2] == 'e') && (strncmp(argv[2], "end", strlen(argv[2])) == 0)) { + index = INT_MAX; + } else if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Skip over the first "index" elements of the list, then add + * all of those elements to the result. + */ + + size = 0; + element = argv[1]; + for (count = 0, p = argv[1]; (count < index) && (*p != 0); count++) { + result = TclFindElement(interp, p, &element, &p, &size, (int *) NULL); + if (result != TCL_OK) { + return result; + } + } + if (*p == 0) { + Tcl_AppendResult(interp, argv[1], (char *) NULL); + } else { + char *end; + + end = element+size; + if (element != argv[1]) { + while ((*end != 0) && !isspace(UCHAR(*end))) { + end++; + } + } + savedChar = *end; + *end = 0; + Tcl_AppendResult(interp, argv[1], (char *) NULL); + *end = savedChar; + } + + /* + * Add the new list elements. + */ + + for (i = 3; i < argc; i++) { + Tcl_AppendElement(interp, argv[i]); + } + + /* + * Append the remainder of the original list. + */ + + if (*p != 0) { + Tcl_AppendResult(interp, " ", p, (char *) NULL); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ListCmd -- + * + * This procedure is invoked to process the "list" 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_ListCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + if (argc >= 2) { + interp->result = Tcl_Merge(argc-1, argv+1); + interp->freeProc = TCL_DYNAMIC; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LlengthCmd -- + * + * This procedure is invoked to process the "llength" 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_LlengthCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int count, result; + char *element, *p; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " list\"", (char *) NULL); + return TCL_ERROR; + } + for (count = 0, p = argv[1]; *p != 0 ; count++) { + result = TclFindElement(interp, p, &element, &p, (int *) NULL, + (int *) NULL); + if (result != TCL_OK) { + return result; + } + if (*element == 0) { + break; + } + } + sprintf(interp->result, "%d", count); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LrangeCmd -- + * + * This procedure is invoked to process the "lrange" 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_LrangeCmd(notUsed, interp, argc, argv) + ClientData notUsed; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int first, last, result; + char *begin, *end, c, *dummy, *next; + int count, firstIsEnd; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " list first last\"", (char *) NULL); + return TCL_ERROR; + } + if ((*argv[2] == 'e') && (strncmp(argv[2], "end", strlen(argv[2])) == 0)) { + firstIsEnd = 1; + first = INT_MAX; + } else { + firstIsEnd = 0; + if (Tcl_GetInt(interp, argv[2], &first) != TCL_OK) { + return TCL_ERROR; + } + } + if (first < 0) { + first = 0; + } + if ((*argv[3] == 'e') && (strncmp(argv[3], "end", strlen(argv[3])) == 0)) { + last = INT_MAX; + } else { + if (Tcl_GetInt(interp, argv[3], &last) != TCL_OK) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "expected integer or \"end\" but got \"", + argv[3], "\"", (char *) NULL); + return TCL_ERROR; + } + } + if ((first > last) && !firstIsEnd) { + return TCL_OK; + } + + /* + * Extract a range of fields. + */ + + for (count = 0, begin = argv[1]; count < first; begin = next, count++) { + result = TclFindElement(interp, begin, &dummy, &next, (int *) NULL, + (int *) NULL); + if (result != TCL_OK) { + return result; + } + if (*next == 0) { + if (firstIsEnd) { + first = count; + } else { + begin = next; + } + break; + } + } + for (count = first, end = begin; (count <= last) && (*end != 0); + count++) { + result = TclFindElement(interp, end, &dummy, &end, (int *) NULL, + (int *) NULL); + if (result != TCL_OK) { + return result; + } + } + if (end == begin) { + return TCL_OK; + } + + /* + * Chop off trailing spaces. + */ + + while (isspace(UCHAR(end[-1]))) { + end--; + } + c = *end; + *end = 0; + Tcl_SetResult(interp, begin, TCL_VOLATILE); + *end = c; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LreplaceCmd -- + * + * This procedure is invoked to process the "lreplace" 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_LreplaceCmd(notUsed, interp, argc, argv) + ClientData notUsed; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + char *p1, *p2, *element, savedChar, *dummy, *next; + int i, first, last, count, result, size, firstIsEnd; + + if (argc < 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " list first last ?element element ...?\"", (char *) NULL); + return TCL_ERROR; + } + if ((*argv[2] == 'e') && (strncmp(argv[2], "end", strlen(argv[2])) == 0)) { + firstIsEnd = 1; + first = INT_MAX; + } else { + firstIsEnd = 0; + if (Tcl_GetInt(interp, argv[2], &first) != TCL_OK) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad index \"", argv[2], + "\": must be integer or \"end\"", (char *) NULL); + return TCL_ERROR; + } + } + if ((*argv[3] == 'e') && (strncmp(argv[3], "end", strlen(argv[3])) == 0)) { + last = INT_MAX; + } else { + if (Tcl_GetInt(interp, argv[3], &last) != TCL_OK) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad index \"", argv[3], + "\": must be integer or \"end\"", (char *) NULL); + return TCL_ERROR; + } + } + if (first < 0) { + first = 0; + } + + /* + * Skip over the elements of the list before "first". + */ + + size = 0; + element = argv[1]; + for (count = 0, p1 = argv[1]; (count < first) && (*p1 != 0); count++) { + result = TclFindElement(interp, p1, &element, &next, &size, + (int *) NULL); + if (result != TCL_OK) { + return result; + } + if ((*next == 0) && firstIsEnd) { + break; + } + p1 = next; + } + if (*p1 == 0) { + Tcl_AppendResult(interp, "list doesn't contain element ", + argv[2], (char *) NULL); + return TCL_ERROR; + } + + /* + * Skip over the elements of the list up through "last". + */ + + for (p2 = p1 ; (count <= last) && (*p2 != 0); count++) { + result = TclFindElement(interp, p2, &dummy, &p2, (int *) NULL, + (int *) NULL); + if (result != TCL_OK) { + return result; + } + } + + /* + * Add the elements before "first" to the result. Drop any terminating + * white space, since a separator will be added below, if needed. + */ + + while ((p1 != argv[1]) && (isspace(UCHAR(p1[-1])))) { + p1--; + } + savedChar = *p1; + *p1 = 0; + Tcl_AppendResult(interp, argv[1], (char *) NULL); + *p1 = savedChar; + + /* + * Add the new list elements. + */ + + for (i = 4; i < argc; i++) { + Tcl_AppendElement(interp, argv[i]); + } + + /* + * Append the remainder of the original list. + */ + + if (*p2 != 0) { + if (*interp->result == 0) { + Tcl_SetResult(interp, p2, TCL_VOLATILE); + } else { + Tcl_AppendResult(interp, " ", p2, (char *) NULL); + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LsearchCmd -- + * + * 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. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_LsearchCmd(notUsed, interp, argc, argv) + ClientData notUsed; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ +#define EXACT 0 +#define GLOB 1 +#define REGEXP 2 + int listArgc; + char **listArgv; + int i, match, mode, index; + + mode = GLOB; + if (argc == 4) { + if (strcmp(argv[1], "-exact") == 0) { + mode = EXACT; + } else if (strcmp(argv[1], "-glob") == 0) { + mode = GLOB; + } else if (strcmp(argv[1], "-regexp") == 0) { + mode = REGEXP; + } else { + Tcl_AppendResult(interp, "bad search mode \"", argv[1], + "\": must be -exact, -glob, or -regexp", (char *) NULL); + return TCL_ERROR; + } + } else if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?mode? list pattern\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_SplitList(interp, argv[argc-2], &listArgc, &listArgv) != TCL_OK) { + return TCL_ERROR; + } + index = -1; + for (i = 0; i < listArgc; i++) { + match = 0; + switch (mode) { + case EXACT: + match = (strcmp(listArgv[i], argv[argc-1]) == 0); + break; + case GLOB: + match = Tcl_StringMatch(listArgv[i], argv[argc-1]); + break; + case REGEXP: + match = Tcl_RegExpMatch(interp, listArgv[i], argv[argc-1]); + if (match < 0) { + ckfree((char *) listArgv); + return TCL_ERROR; + } + break; + } + if (match) { + index = i; + break; + } + } + sprintf(interp->result, "%d", index); + ckfree((char *) listArgv); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LsortCmd -- + * + * 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. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_LsortCmd(notUsed, interp, argc, argv) + ClientData notUsed; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int listArgc, i, c; + size_t length; + char **listArgv; + char *command = NULL; /* Initialization needed only to + * prevent compiler warning. */ + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?-ascii? ?-integer? ?-real? ?-increasing? ?-decreasing?", + " ?-command string? list\"", (char *) NULL); + return TCL_ERROR; + } + + if (sortInterp != NULL) { + interp->result = "can't invoke \"lsort\" recursively"; + return TCL_ERROR; + } + + /* + * Parse arguments to set up the mode for the sort. + */ + + sortInterp = interp; + sortMode = ASCII; + sortIncreasing = 1; + sortCode = TCL_OK; + for (i = 1; i < argc-1; i++) { + length = strlen(argv[i]); + if (length < 2) { + badSwitch: + Tcl_AppendResult(interp, "bad switch \"", argv[i], + "\": must be -ascii, -integer, -real, -increasing", + " -decreasing, or -command", (char *) NULL); + sortCode = TCL_ERROR; + goto done; + } + c = argv[i][1]; + if ((c == 'a') && (strncmp(argv[i], "-ascii", length) == 0)) { + sortMode = ASCII; + } else if ((c == 'c') && (strncmp(argv[i], "-command", length) == 0)) { + if (i == argc-2) { + Tcl_AppendResult(interp, "\"-command\" must be", + " followed by comparison command", (char *) NULL); + sortCode = TCL_ERROR; + goto done; + } + sortMode = COMMAND; + command = argv[i+1]; + i++; + } else if ((c == 'd') + && (strncmp(argv[i], "-decreasing", length) == 0)) { + sortIncreasing = 0; + } else if ((c == 'i') && (length >= 4) + && (strncmp(argv[i], "-increasing", length) == 0)) { + sortIncreasing = 1; + } else if ((c == 'i') && (length >= 4) + && (strncmp(argv[i], "-integer", length) == 0)) { + sortMode = INTEGER; + } else if ((c == 'r') + && (strncmp(argv[i], "-real", length) == 0)) { + sortMode = REAL; + } else { + goto badSwitch; + } + } + if (sortMode == COMMAND) { + Tcl_DStringInit(&sortCmd); + Tcl_DStringAppend(&sortCmd, command, -1); + } + + if (Tcl_SplitList(interp, argv[argc-1], &listArgc, &listArgv) != TCL_OK) { + sortCode = TCL_ERROR; + goto done; + } + qsort((VOID *) listArgv, (size_t) listArgc, sizeof (char *), + SortCompareProc); + if (sortCode == TCL_OK) { + Tcl_ResetResult(interp); + interp->result = Tcl_Merge(listArgc, listArgv); + interp->freeProc = TCL_DYNAMIC; + } + if (sortMode == COMMAND) { + Tcl_DStringFree(&sortCmd); + } + ckfree((char *) listArgv); + + done: + sortInterp = NULL; + return sortCode; +} + +/* + *---------------------------------------------------------------------- + * + * SortCompareProc -- + * + * This procedure is invoked by qsort to determine the proper + * ordering between two elements. + * + * Results: + * < 0 means first is "smaller" than "second", > 0 means "first" + * is larger than "second", and 0 means they should be treated + * as equal. + * + * Side effects: + * None, unless a user-defined comparison command does something + * weird. + * + *---------------------------------------------------------------------- + */ + +static int +SortCompareProc(first, second) + CONST VOID *first, *second; /* Elements to be compared. */ +{ + int order; + char *firstString = *((char **) first); + char *secondString = *((char **) second); + + order = 0; + if (sortCode != TCL_OK) { + /* + * Once an error has occurred, skip any future comparisons + * so as to preserve the error message in sortInterp->result. + */ + + return order; + } + if (sortMode == ASCII) { + order = strcmp(firstString, secondString); + } else if (sortMode == INTEGER) { + int a, b; + + if ((Tcl_GetInt(sortInterp, firstString, &a) != TCL_OK) + || (Tcl_GetInt(sortInterp, secondString, &b) != TCL_OK)) { + Tcl_AddErrorInfo(sortInterp, + "\n (converting list element from string to integer)"); + sortCode = TCL_ERROR; + return order; + } + if (a > b) { + order = 1; + } else if (b > a) { + order = -1; + } + } else if (sortMode == REAL) { + double a, b; + + if ((Tcl_GetDouble(sortInterp, firstString, &a) != TCL_OK) + || (Tcl_GetDouble(sortInterp, secondString, &b) != TCL_OK)) { + Tcl_AddErrorInfo(sortInterp, + "\n (converting list element from string to real)"); + sortCode = TCL_ERROR; + return order; + } + if (a > b) { + order = 1; + } else if (b > a) { + order = -1; + } + } else { + int oldLength; + char *end; + + /* + * Generate and evaluate a command to determine which string comes + * first. + */ + + oldLength = Tcl_DStringLength(&sortCmd); + Tcl_DStringAppendElement(&sortCmd, firstString); + Tcl_DStringAppendElement(&sortCmd, secondString); + sortCode = Tcl_Eval(sortInterp, Tcl_DStringValue(&sortCmd)); + Tcl_DStringTrunc(&sortCmd, oldLength); + if (sortCode != TCL_OK) { + Tcl_AddErrorInfo(sortInterp, + "\n (user-defined comparison command)"); + return order; + } + + /* + * Parse the result of the command. + */ + + order = strtol(sortInterp->result, &end, 0); + if ((end == sortInterp->result) || (*end != 0)) { + Tcl_ResetResult(sortInterp); + Tcl_AppendResult(sortInterp, + "comparison command returned non-numeric result", + (char *) NULL); + sortCode = TCL_ERROR; + return order; + } + } + if (!sortIncreasing) { + order = -order; + } + return order; +} |
