Usenet 1994 January/usenetsourcesnewsgroupsinfomagicjanuary1994.iso/sources/misc/volume25/tcl/part20

Text File | 1991-11-15 | 31.9 KB | 1,197 lines

Newsgroups: comp.sources.misc
From: [e-mail] (Karl Lehenbauer)
Subject:  v25i088:  tcl - tool command language, version 6.1, Part20/33
Message-ID: <[e-mail]>
X-Md4-Signature: 622600ff92f14e7f0e366ae3380f4c4d
Date: Fri, 15 Nov 1991 22:49:22 GMT
Approved: [e-mail]

Submitted-by: [e-mail] (Karl Lehenbauer)
Posting-number: Volume 25, Issue 88
Archive-name: tcl/part20
Environment: UNIX

#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#        "End of archive 20 (of 33)."
# Contents:  tcl6.1/tclCmdIL.c
# Wrapped by karl@one on Tue Nov 12 19:44:27 1991
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'tcl6.1/tclCmdIL.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'tcl6.1/tclCmdIL.c'\"
else
echo shar: Extracting \"'tcl6.1/tclCmdIL.c'\" \(29320 characters\)
sed "s/^X//" >'tcl6.1/tclCmdIL.c' <<'END_OF_FILE'
X/*
X * tclCmdIL.c --
X *
X *    This file contains the top-level command routines for most of
X *    the Tcl built-in commands whose names begin with the letters
X *    I through L.  It contains only commands in the generic core
X *    (i.e. those that don't depend much upon UNIX facilities).
X *
X * Copyright 1987-1991 Regents of the University of California
X * Permission to use, copy, modify, and distribute this
X * software and its documentation for any purpose and without
X * fee is hereby granted, provided that the above copyright
X * notice appear in all copies.  The University of California
X * makes no representations about the suitability of this
X * software for any purpose.  It is provided "as is" without
X * express or implied warranty.
X */
X
X#ifndef lint
Xstatic char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclCmdIL.c,v 1.82 91/10/31 16:41:50 ouster Exp $ SPRITE (Berkeley)";
X#endif
X
X#include "tclInt.h"
X
X/*
X * Forward declarations for procedures defined in this file:
X */
X
Xstatic int        SortCompareProc _ANSI_ARGS_((CONST char *first,
X                CONST char *second));
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_IfCmd --
X *
X *    This procedure is invoked to process the "if" Tcl command.
X *    See the user documentation for details on what it does.
X *
X * Results:
X *    A standard Tcl result.
X *
X * Side effects:
X *    See the user documentation.
X *
X *----------------------------------------------------------------------
X */
X
X    /* ARGSUSED */
Xint
XTcl_IfCmd(dummy, interp, argc, argv)
X    ClientData dummy;            /* Not used. */
X    Tcl_Interp *interp;            /* Current interpreter. */
X    int argc;                /* Number of arguments. */
X    char **argv;            /* Argument strings. */
X{
X    char *condition, *ifPart, *elsePart, *cmd, *name;
X    char *clause;
X    int result, value;
X
X    name = argv[0];
X    if (argc < 3) {
X    ifSyntax:
X    Tcl_AppendResult(interp, "wrong # args: should be \"", name,
X        " bool ?then? command ?else? ?command?\"", (char *) NULL);
X    return TCL_ERROR;
X    }
X    condition = argv[1];
X    argc -= 2;
X    argv += 2;
X    if ((**argv == 't') && (strncmp(*argv, "then", strlen(*argv)) == 0)) {
X    argc--;
X    argv++;
X    }
X    if (argc < 1) {
X    goto ifSyntax;
X    }
X    ifPart = *argv;
X    argv++;
X    argc--;
X    if (argc == 0) {
X    elsePart = "";
X    } else {
X    if ((**argv == 'e') && (strncmp(*argv, "else", strlen(*argv)) == 0)) {
X        argc--;
X        argv++;
X    }
X    if (argc != 1) {
X        goto ifSyntax;
X    }
X    elsePart = *argv;
X    }
X
X    cmd = ifPart;
X    clause = "\"then\" clause";
X    result = Tcl_ExprBoolean(interp, condition, &value);
X    if (result != TCL_OK) {
X    if (result == TCL_ERROR) {
X        char msg[60];
X        sprintf(msg, "\n    (\"if\" test line %d)", interp->errorLine);
X        Tcl_AddErrorInfo(interp, msg);
X    }
X    return result;
X    }
X    if (value == 0) {
X    cmd = elsePart;
X    clause = "\"else\" clause";
X    }
X    if (*cmd == 0) {
X    return TCL_OK;
X    }
X    result = Tcl_Eval(interp, cmd, 0, (char **) NULL);
X    if (result == TCL_ERROR) {
X    char msg[60];
X    sprintf(msg, "\n    (%s line %d)", clause, interp->errorLine);
X    Tcl_AddErrorInfo(interp, msg);
X    }
X    return result;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_IncrCmd --
X *
X *    This procedure is invoked to process the "incr" Tcl command.
X *    See the user documentation for details on what it does.
X *
X * Results:
X *    A standard Tcl result.
X *
X * Side effects:
X *    See the user documentation.
X *
X *----------------------------------------------------------------------
X */
X
X    /* ARGSUSED */
Xint
XTcl_IncrCmd(dummy, interp, argc, argv)
X    ClientData dummy;            /* Not used. */
X    Tcl_Interp *interp;            /* Current interpreter. */
X    int argc;                /* Number of arguments. */
X    char **argv;            /* Argument strings. */
X{
X    int value;
X    char *oldString, *result;
X    char newString[30];
X
X    if ((argc != 2) && (argc != 3)) {
X    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X        " varName ?increment?\"", (char *) NULL);
X    return TCL_ERROR;
X    }
X
X    oldString = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG);
X    if (oldString == NULL) {
X    return TCL_ERROR;
X    }
X    if (Tcl_GetInt(interp, oldString, &value) != TCL_OK) {
X    Tcl_AddErrorInfo(interp,
X        "\n    (reading value of variable to increment)");
X    return TCL_ERROR;
X    }
X    if (argc == 2) {
X    value += 1;
X    } else {
X    int increment;
X
X    if (Tcl_GetInt(interp, argv[2], &increment) != TCL_OK) {
X        Tcl_AddErrorInfo(interp,
X            "\n    (reading increment)");
X        return TCL_ERROR;
X    }
X    value += increment;
X    }
X    sprintf(newString, "%d", value);
X    result = Tcl_SetVar(interp, argv[1], newString, TCL_LEAVE_ERR_MSG);
X    if (result == NULL) {
X    return TCL_ERROR;
X    }
X    interp->result = result;
X    return TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_InfoCmd --
X *
X *    This procedure is invoked to process the "info" Tcl command.
X *    See the user documentation for details on what it does.
X *
X * Results:
X *    A standard Tcl result.
X *
X * Side effects:
X *    See the user documentation.
X *
X *----------------------------------------------------------------------
X */
X
X    /* ARGSUSED */
Xint
XTcl_InfoCmd(dummy, interp, argc, argv)
X    ClientData dummy;            /* Not used. */
X    Tcl_Interp *interp;            /* Current interpreter. */
X    int argc;                /* Number of arguments. */
X    char **argv;            /* Argument strings. */
X{
X    register Interp *iPtr = (Interp *) interp;
X    int length;
X    char c;
X    Arg *argPtr;
X    Proc *procPtr;
X    Var *varPtr;
X    Command *cmdPtr;
X    Tcl_HashEntry *hPtr;
X    Tcl_HashSearch search;
X
X    if (argc < 2) {
X    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X        " option ?arg arg ...?\"", (char *) NULL);
X    return TCL_ERROR;
X    }
X    c = argv[1][0];
X    length = strlen(argv[1]);
X    if ((c == 'a') && (strncmp(argv[1], "args", length)) == 0) {
X    if (argc != 3) {
X        Tcl_AppendResult(interp, "wrong # args: should be \"",
X            argv[0], " args procname\"", (char *) NULL);
X        return TCL_ERROR;
X    }
X    procPtr = TclFindProc(iPtr, argv[2]);
X    if (procPtr == NULL) {
X        infoNoSuchProc:
X        Tcl_AppendResult(interp, "\"", argv[2],
X            "\" isn't a procedure", (char *) NULL);
X        return TCL_ERROR;
X    }
X    for (argPtr = procPtr->argPtr; argPtr != NULL;
X        argPtr = argPtr->nextPtr) {
X        Tcl_AppendElement(interp, argPtr->name, 0);
X    }
X    return TCL_OK;
X    } else if ((c == 'b') && (strncmp(argv[1], "body", length)) == 0) {
X    if (argc != 3) {
X        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X            " body procname\"", (char *) NULL);
X        return TCL_ERROR;
X    }
X    procPtr = TclFindProc(iPtr, argv[2]);
X    if (procPtr == NULL) {
X        goto infoNoSuchProc;
X    }
X    iPtr->result = procPtr->command;
X    return TCL_OK;
X    } else if ((c == 'c') && (strncmp(argv[1], "cmdcount", length) == 0)
X        && (length >= 2)) {
X    if (argc != 2) {
X        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X            " cmdcount\"", (char *) NULL);
X        return TCL_ERROR;
X    }
X    sprintf(iPtr->result, "%d", iPtr->cmdCount);
X    return TCL_OK;
X    } else if ((c == 'c') && (strncmp(argv[1], "commands", length) == 0)
X        && (length >= 2)){
X    if (argc > 3) {
X        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X            " commands [pattern]\"", (char *) NULL);
X        return TCL_ERROR;
X    }
X    for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
X        hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
X        char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr);
X        if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
X        continue;
X        }
X        Tcl_AppendElement(interp, name, 0);
X    }
X    return TCL_OK;
X    } else if ((c == 'd') && (strncmp(argv[1], "default", length)) == 0) {
X    if (argc != 5) {
X        Tcl_AppendResult(interp, "wrong # args: should be \"",
X            argv[0], " default procname arg varname\"",
X            (char *) NULL);
X        return TCL_ERROR;
X    }
X    procPtr = TclFindProc(iPtr, argv[2]);
X    if (procPtr == NULL) {
X        goto infoNoSuchProc;
X    }
X    for (argPtr = procPtr->argPtr; ; argPtr = argPtr->nextPtr) {
X        if (argPtr == NULL) {
X        Tcl_AppendResult(interp, "procedure \"", argv[2],
X            "\" doesn't have an argument \"", argv[3],
X            "\"", (char *) NULL);
X        return TCL_ERROR;
X        }
X        if (strcmp(argv[3], argPtr->name) == 0) {
X        if (argPtr->defValue != NULL) {
X            if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4],
X                argPtr->defValue, 0) == NULL) {
X            defStoreError:
X            Tcl_AppendResult(interp,
X                "couldn't store default value in variable \"",
X                argv[4], "\"", (char *) NULL);
X            return TCL_ERROR;
X            }
X            iPtr->result = "1";
X        } else {
X            if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4], "", 0)
X                == NULL) {
X            goto defStoreError;
X            }
X            iPtr->result = "0";
X        }
X        return TCL_OK;
X        }
X    }
X    } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0)) {
X    char *p;
X    if (argc != 3) {
X        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X            " exists varName\"", (char *) NULL);
X        return TCL_ERROR;
X    }
X    p = Tcl_GetVar((Tcl_Interp *) iPtr, argv[2], 0);
X
X    /*
X     * The code below handles the special case where the name is for
X     * an array:  Tcl_GetVar will reject this since you can't read
X     * an array variable without an index.
X     */
X
X    if (p == NULL) {
X        Tcl_HashEntry *hPtr;
X        Var *varPtr;
X
X        if (strchr(argv[2], '(') != NULL) {
X        noVar:
X        iPtr->result = "0";
X        return TCL_OK;
X        }
X        if (iPtr->varFramePtr == NULL) {
X        hPtr = Tcl_FindHashEntry(&iPtr->globalTable, argv[2]);
X        } else {
X        hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, argv[2]);
X        }
X        if (hPtr == NULL) {
X        goto noVar;
X        }
X        varPtr = (Var *) Tcl_GetHashValue(hPtr);
X        if (varPtr->flags & VAR_UPVAR) {
X        varPtr = (Var *) Tcl_GetHashValue(varPtr->value.upvarPtr);
X        }
X        if (!(varPtr->flags & VAR_ARRAY)) {
X        goto noVar;
X        }
X    }
X    iPtr->result = "1";
X    return TCL_OK;
X    } else if ((c == 'g') && (strncmp(argv[1], "globals", length) == 0)) {
X    char *name;
X
X    if (argc > 3) {
X        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X            " globals [pattern]\"", (char *) NULL);
X        return TCL_ERROR;
X    }
X    for (hPtr = Tcl_FirstHashEntry(&iPtr->globalTable, &search);
X        hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
X        varPtr = (Var *) Tcl_GetHashValue(hPtr);
X        if (varPtr->flags & VAR_UNDEFINED) {
X        continue;
X        }
X        name = Tcl_GetHashKey(&iPtr->globalTable, hPtr);
X        if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
X        continue;
X        }
X        Tcl_AppendElement(interp, name, 0);
X    }
X    return TCL_OK;
X    } else if ((c == 'l') && (strncmp(argv[1], "level", length) == 0)
X        && (length >= 2)) {
X    if (argc == 2) {
X        if (iPtr->varFramePtr == NULL) {
X        iPtr->result = "0";
X        } else {
X        sprintf(iPtr->result, "%d", iPtr->varFramePtr->level);
X        }
X        return TCL_OK;
X    } else if (argc == 3) {
X        int level;
X        CallFrame *framePtr;
X
X        if (Tcl_GetInt(interp, argv[2], &level) != TCL_OK) {
X        return TCL_ERROR;
X        }
X        if (level <= 0) {
X        if (iPtr->varFramePtr == NULL) {
X            levelError:
X            Tcl_AppendResult(interp, "bad level \"", argv[2],
X                "\"", (char *) NULL);
X            return TCL_ERROR;
X        }
X        level += iPtr->varFramePtr->level;
X        }
X        for (framePtr = iPtr->varFramePtr; framePtr != NULL;
X            framePtr = framePtr->callerVarPtr) {
X        if (framePtr->level == level) {
X            break;
X        }
X        }
X        if (framePtr == NULL) {
X        goto levelError;
X        }
X        iPtr->result = Tcl_Merge(framePtr->argc, framePtr->argv);
X        iPtr->freeProc = (Tcl_FreeProc *) free;
X        return TCL_OK;
X    }
X    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X        " level [number]\"", (char *) NULL);
X    return TCL_ERROR;
X    } else if ((c == 'l') && (strncmp(argv[1], "library", length) == 0)
X        && (length >= 2)) {
X    if (argc != 2) {
X        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X            " library\"", (char *) NULL);
X        return TCL_ERROR;
X    }
X#ifdef TCL_LIBRARY
X    interp->result = TCL_LIBRARY;
X    return TCL_OK;
X#else
X    interp->result = "there is no Tcl library at this installation";
X    return TCL_ERROR;
X#endif
X    } else if ((c == 'l') && (strncmp(argv[1], "locals", length) == 0)
X        && (length >= 2)) {
X    char *name;
X
X    if (argc > 3) {
X        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X            " locals [pattern]\"", (char *) NULL);
X        return TCL_ERROR;
X    }
X    if (iPtr->varFramePtr == NULL) {
X        return TCL_OK;
X    }
X    for (hPtr = Tcl_FirstHashEntry(&iPtr->varFramePtr->varTable, &search);
X        hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
X        varPtr = (Var *) Tcl_GetHashValue(hPtr);
X        if (varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR)) {
X        continue;
X        }
X        name = Tcl_GetHashKey(&iPtr->varFramePtr->varTable, hPtr);
X        if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
X        continue;
X        }
X        Tcl_AppendElement(interp, name, 0);
X    }
X    return TCL_OK;
X    } else if ((c == 'p') && (strncmp(argv[1], "procs", length)) == 0) {
X    if (argc > 3) {
X        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X            " procs [pattern]\"", (char *) NULL);
X        return TCL_ERROR;
X    }
X    for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
X        hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
X        char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr);
X
X        cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
X        if (!TclIsProc(cmdPtr)) {
X        continue;
X        }
X        if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
X        continue;
X        }
X        Tcl_AppendElement(interp, name, 0);
X    }
X    return TCL_OK;
X    } else if ((c == 's') && (strncmp(argv[1], "script", length) == 0)) {
X    if (argc != 2) {
X        Tcl_AppendResult(interp, "wrong # args: should be \"",
X            argv[0], " script\"", (char *) NULL);
X        return TCL_ERROR;
X    }
X    if (iPtr->scriptFile != NULL) {
X        interp->result = iPtr->scriptFile;
X    }
X    return TCL_OK;
X    } else if ((c == 't') && (strncmp(argv[1], "tclversion", length) == 0)) {
X    if (argc != 2) {
X        Tcl_AppendResult(interp, "wrong # args: should be \"",
X            argv[0], " tclversion\"", (char *) NULL);
X        return TCL_ERROR;
X    }
X
X    /*
X     * Note:  TCL_VERSION below is expected to be set with a "-D"
X     * switch in the Makefile.
X     */
X
X    strcpy(iPtr->result, TCL_VERSION);
X    return TCL_OK;
X    } else if ((c == 'v') && (strncmp(argv[1], "vars", length)) == 0) {
X    Tcl_HashTable *tablePtr;
X    char *name;
X
X    if (argc > 3) {
X        Tcl_AppendResult(interp, "wrong # args: should be \"",
X            argv[0], " vars [pattern]\"", (char *) NULL);
X        return TCL_ERROR;
X    }
X    if (iPtr->varFramePtr == NULL) {
X        tablePtr = &iPtr->globalTable;
X    } else {
X        tablePtr = &iPtr->varFramePtr->varTable;
X    }
X    for (hPtr = Tcl_FirstHashEntry(tablePtr, &search);
X        hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
X        varPtr = (Var *) Tcl_GetHashValue(hPtr);
X        if (varPtr->flags & VAR_UNDEFINED) {
X        continue;
X        }
X        name = Tcl_GetHashKey(tablePtr, hPtr);
X        if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
X        continue;
X        }
X        Tcl_AppendElement(interp, name, 0);
X    }
X    return TCL_OK;
X    } else {
X    Tcl_AppendResult(interp, "bad option \"", argv[1],
X        "\": should be args, body, commands, cmdcount, default, ",
X        "exists, globals, level, library, locals, procs, ",
X        "script, tclversion, or vars",
X        (char *) NULL);
X    return TCL_ERROR;
X    }
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_JoinCmd --
X *
X *    This procedure is invoked to process the "join" Tcl command.
X *    See the user documentation for details on what it does.
X *
X * Results:
X *    A standard Tcl result.
X *
X * Side effects:
X *    See the user documentation.
X *
X *----------------------------------------------------------------------
X */
X
X    /* ARGSUSED */
Xint
XTcl_JoinCmd(dummy, interp, argc, argv)
X    ClientData dummy;            /* Not used. */
X    Tcl_Interp *interp;            /* Current interpreter. */
X    int argc;                /* Number of arguments. */
X    char **argv;            /* Argument strings. */
X{
X    char *joinString;
X    char **listArgv;
X    int listArgc, i;
X
X    if (argc == 2) {
X    joinString = " ";
X    } else if (argc == 3) {
X    joinString = argv[2];
X    } else {
X    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X        " list ?joinString?\"", (char *) NULL);
X    return TCL_ERROR;
X    }
X
X    if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) {
X    return TCL_ERROR;
X    }
X    for (i = 0; i < listArgc; i++) {
X    if (i == 0) {
X        Tcl_AppendResult(interp, listArgv[0], (char *) NULL);
X    } else  {
X        Tcl_AppendResult(interp, joinString, listArgv[i], (char *) NULL);
X    }
X    }
X    ckfree((char *) listArgv);
X    return TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_LindexCmd --
X *
X *    This procedure is invoked to process the "lindex" Tcl command.
X *    See the user documentation for details on what it does.
X *
X * Results:
X *    A standard Tcl result.
X *
X * Side effects:
X *    See the user documentation.
X *
X *----------------------------------------------------------------------
X */
X
X    /* ARGSUSED */
Xint
XTcl_LindexCmd(dummy, interp, argc, argv)
X    ClientData dummy;            /* Not used. */
X    Tcl_Interp *interp;            /* Current interpreter. */
X    int argc;                /* Number of arguments. */
X    char **argv;            /* Argument strings. */
X{
X    char *p, *element;
X    int index, size, parenthesized, result;
X
X    if (argc != 3) {
X    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X        " list index\"", (char *) NULL);
X    return TCL_ERROR;
X    }
X    if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) {
X    return TCL_ERROR;
X    }
X    if (index < 0) {
X    return TCL_OK;
X    }
X    for (p = argv[1] ; index >= 0; index--) {
X    result = TclFindElement(interp, p, &element, &p, &size,
X        &parenthesized);
X    if (result != TCL_OK) {
X        return result;
X    }
X    }
X    if (size == 0) {
X    return TCL_OK;
X    }
X    if (size >= TCL_RESULT_SIZE) {
X    interp->result = (char *) ckalloc((unsigned) size+1);
X    interp->freeProc = (Tcl_FreeProc *) free;
X    }
X    if (parenthesized) {
X    memcpy((VOID *) interp->result, (VOID *) element, size);
X    interp->result[size] = 0;
X    } else {
X    TclCopyAndCollapse(size, element, interp->result);
X    }
X    return TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_LinsertCmd --
X *
X *    This procedure is invoked to process the "linsert" Tcl command.
X *    See the user documentation for details on what it does.
X *
X * Results:
X *    A standard Tcl result.
X *
X * Side effects:
X *    See the user documentation.
X *
X *----------------------------------------------------------------------
X */
X
X    /* ARGSUSED */
Xint
XTcl_LinsertCmd(dummy, interp, argc, argv)
X    ClientData dummy;            /* Not used. */
X    Tcl_Interp *interp;            /* Current interpreter. */
X    int argc;                /* Number of arguments. */
X    char **argv;            /* Argument strings. */
X{
X    char *p, *element, savedChar;
X    int i, index, count, result, size, brace;
X
X    if (argc < 4) {
X    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X        " list index element ?element ...?\"", (char *) NULL);
X    return TCL_ERROR;
X    }
X    if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) {
X    return TCL_ERROR;
X    }
X
X    /*
X     * Skip over the first "index" elements of the list, then add
X     * all of those elements to the result.
X     */
X
X    size = 0;
X    brace = 0;
X    element = argv[1];
X    for (count = 0, p = argv[1]; (count < index) && (*p != 0); count++) {
X    result = TclFindElement(interp, p, &element, &p, &size, &brace);
X    if (result != TCL_OK) {
X        return result;
X    }
X    }
X    if (*p == 0) {
X    Tcl_AppendResult(interp, argv[1], (char *) NULL);
X    } else {
X    char *end;
X
X    end = element+size;
X    if (brace) {
X        end++;
X    }
X    savedChar = *end;
X    *end = 0;
X    Tcl_AppendResult(interp, argv[1], (char *) NULL);
X    *end = savedChar;
X    }
X
X    /*
X     * Add the new list elements.
X     */
X
X    for (i = 3; i < argc; i++) {
X    Tcl_AppendElement(interp, argv[i], 0);
X    }
X
X    /*
X     * Append the remainder of the original list.
X     */
X
X    if (*p != 0) {
X    Tcl_AppendResult(interp, " ", p, (char *) NULL);
X    }
X    return TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_ListCmd --
X *
X *    This procedure is invoked to process the "list" Tcl command.
X *    See the user documentation for details on what it does.
X *
X * Results:
X *    A standard Tcl result.
X *
X * Side effects:
X *    See the user documentation.
X *
X *----------------------------------------------------------------------
X */
X
X    /* ARGSUSED */
Xint
XTcl_ListCmd(dummy, interp, argc, argv)
X    ClientData dummy;            /* Not used. */
X    Tcl_Interp *interp;            /* Current interpreter. */
X    int argc;                /* Number of arguments. */
X    char **argv;            /* Argument strings. */
X{
X    if (argc < 2) {
X    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X        " arg ?arg ...?\"", (char *) NULL);
X    return TCL_ERROR;
X    }
X    interp->result = Tcl_Merge(argc-1, argv+1);
X    interp->freeProc = (Tcl_FreeProc *) free;
X    return TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_LlengthCmd --
X *
X *    This procedure is invoked to process the "llength" Tcl command.
X *    See the user documentation for details on what it does.
X *
X * Results:
X *    A standard Tcl result.
X *
X * Side effects:
X *    See the user documentation.
X *
X *----------------------------------------------------------------------
X */
X
X    /* ARGSUSED */
Xint
XTcl_LlengthCmd(dummy, interp, argc, argv)
X    ClientData dummy;            /* Not used. */
X    Tcl_Interp *interp;            /* Current interpreter. */
X    int argc;                /* Number of arguments. */
X    char **argv;            /* Argument strings. */
X{
X    int count, result;
X    char *element, *p;
X
X    if (argc != 2) {
X    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X        " list\"", (char *) NULL);
X    return TCL_ERROR;
X    }
X    for (count = 0, p = argv[1]; *p != 0 ; count++) {
X    result = TclFindElement(interp, p, &element, &p, (int *) NULL,
X        (int *) NULL);
X    if (result != TCL_OK) {
X        return result;
X    }
X    if (*element == 0) {
X        break;
X    }
X    }
X    sprintf(interp->result, "%d", count);
X    return TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_LrangeCmd --
X *
X *    This procedure is invoked to process the "lrange" Tcl command.
X *    See the user documentation for details on what it does.
X *
X * Results:
X *    A standard Tcl result.
X *
X * Side effects:
X *    See the user documentation.
X *
X *----------------------------------------------------------------------
X */
X
X    /* ARGSUSED */
Xint
XTcl_LrangeCmd(notUsed, interp, argc, argv)
X    ClientData notUsed;            /* Not used. */
X    Tcl_Interp *interp;            /* Current interpreter. */
X    int argc;                /* Number of arguments. */
X    char **argv;            /* Argument strings. */
X{
X    int first, last, result;
X    char *begin, *end, c, *dummy;
X    int count;
X
X    if (argc != 4) {
X    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X        " list first last\"", (char *) NULL);
X    return TCL_ERROR;
X    }
X    if (Tcl_GetInt(interp, argv[2], &first) != TCL_OK) {
X    return TCL_ERROR;
X    }
X    if (first < 0) {
X    first = 0;
X    }
X    if ((*argv[3] == 'e') && (strncmp(argv[3], "end", strlen(argv[3])) == 0)) {
X    last = 1000000;
X    } else {
X    if (Tcl_GetInt(interp, argv[3], &last) != TCL_OK) {
X        Tcl_ResetResult(interp);
X        Tcl_AppendResult(interp,
X            "expected integer or \"end\" but got \"",
X            argv[3], "\"", (char *) NULL);
X        return TCL_ERROR;
X    }
X    }
X    if (first > last) {
X    return TCL_OK;
X    }
X
X    /*
X     * Extract a range of fields.
X     */
X
X    for (count = 0, begin = argv[1]; count < first; count++) {
X    result = TclFindElement(interp, begin, &dummy, &begin, (int *) NULL,
X        (int *) NULL);
X    if (result != TCL_OK) {
X        return result;
X    }
X    if (*begin == 0) {
X        break;
X    }
X    }
X    for (count = first, end = begin; (count <= last) && (*end != 0);
X        count++) {
X    result = TclFindElement(interp, end, &dummy, &end, (int *) NULL,
X        (int *) NULL);
X    if (result != TCL_OK) {
X        return result;
X    }
X    }
X
X    /*
X     * Chop off trailing spaces.
X     */
X
X    while (isspace(end[-1])) {
X    end--;
X    }
X    c = *end;
X    *end = 0;
X    Tcl_SetResult(interp, begin, TCL_VOLATILE);
X    *end = c;
X    return TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_LreplaceCmd --
X *
X *    This procedure is invoked to process the "lreplace" Tcl command.
X *    See the user documentation for details on what it does.
X *
X * Results:
X *    A standard Tcl result.
X *
X * Side effects:
X *    See the user documentation.
X *
X *----------------------------------------------------------------------
X */
X
X    /* ARGSUSED */
Xint
XTcl_LreplaceCmd(notUsed, interp, argc, argv)
X    ClientData notUsed;            /* Not used. */
X    Tcl_Interp *interp;            /* Current interpreter. */
X    int argc;                /* Number of arguments. */
X    char **argv;            /* Argument strings. */
X{
X    char *p1, *p2, *element, savedChar, *dummy;
X    int i, first, last, count, result, size, brace;
X
X    if (argc < 4) {
X    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X        " list first last ?element element ...?\"", (char *) NULL);
X    return TCL_ERROR;
X    }
X    if (Tcl_GetInt(interp, argv[2], &first) != TCL_OK) {
X    return TCL_ERROR;
X    }
X    if (TclGetListIndex(interp, argv[3], &last) != TCL_OK) {
X    return TCL_ERROR;
X    }
X    if (first < 0) {
X    first = 0;
X    }
X    if (last < 0) {
X    last = 0;
X    }
X    if (first > last) {
X    Tcl_AppendResult(interp, "first index must not be greater than second",
X        (char *) NULL);
X    return TCL_ERROR;
X    }
X
X    /*
X     * Skip over the elements of the list before "first".
X     */
X
X    size = 0;
X    brace = 0;
X    element = argv[1];
X    for (count = 0, p1 = argv[1]; (count < first) && (*p1 != 0); count++) {
X    result = TclFindElement(interp, p1, &element, &p1, &size, &brace);
X    if (result != TCL_OK) {
X        return result;
X    }
X    }
X    if (*p1 == 0) {
X    Tcl_AppendResult(interp, "list doesn't contain element ",
X        argv[2], (char *) NULL);
X    return TCL_ERROR;
X    }
X
X    /*
X     * Skip over the elements of the list up through "last".
X     */
X
X    for (p2 = p1 ; (count <= last) && (*p2 != 0); count++) {
X    result = TclFindElement(interp, p2, &dummy, &p2, (int *) NULL,
X        (int *) NULL);
X    if (result != TCL_OK) {
X        return result;
X    }
X    }
X
X    /*
X     * Add the elements up through "first" to the result.
X     */
X
X    p1 = element+size;
X    if (brace) {
X    p1++;
X    }
X    savedChar = *p1;
X    *p1 = 0;
X    Tcl_AppendResult(interp, argv[1], (char *) NULL);
X    *p1 = savedChar;
X
X    /*
X     * Add the new list elements.
X     */
X
X    for (i = 4; i < argc; i++) {
X    Tcl_AppendElement(interp, argv[i], 0);
X    }
X
X    /*
X     * Append the remainder of the original list.
X     */
X
X    if (*p2 != 0) {
X    if (*interp->result == 0) {
X        Tcl_SetResult(interp, p2, TCL_VOLATILE);
X    } else {
X        Tcl_AppendResult(interp, " ", p2, (char *) NULL);
X    }
X    }
X    return TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_LsearchCmd --
X *
X *    This procedure is invoked to process the "lsearch" Tcl command.
X *    See the user documentation for details on what it does.
X *
X * Results:
X *    A standard Tcl result.
X *
X * Side effects:
X *    See the user documentation.
X *
X *----------------------------------------------------------------------
X */
X
X    /* ARGSUSED */
Xint
XTcl_LsearchCmd(notUsed, interp, argc, argv)
X    ClientData notUsed;            /* Not used. */
X    Tcl_Interp *interp;            /* Current interpreter. */
X    int argc;                /* Number of arguments. */
X    char **argv;            /* Argument strings. */
X{
X    int listArgc;
X    char **listArgv;
X    int i, match;
X
X    if (argc != 3) {
X    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X        " list pattern\"", (char *) NULL);
X    return TCL_ERROR;
X    }
X    if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) {
X    return TCL_ERROR;
X    }
X    match = -1;
X    for (i = 0; i < listArgc; i++) {
X    if (Tcl_StringMatch(listArgv[i], argv[2])) {
X        match = i;
X        break;
X    }
X    }
X    sprintf(interp->result, "%d", match);
X    ckfree((char *) listArgv);
X    return TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_LsortCmd --
X *
X *    This procedure is invoked to process the "lsort" Tcl command.
X *    See the user documentation for details on what it does.
X *
X * Results:
X *    A standard Tcl result.
X *
X * Side effects:
X *    See the user documentation.
X *
X *----------------------------------------------------------------------
X */
X
X    /* ARGSUSED */
Xint
XTcl_LsortCmd(notUsed, interp, argc, argv)
X    ClientData notUsed;            /* Not used. */
X    Tcl_Interp *interp;            /* Current interpreter. */
X    int argc;                /* Number of arguments. */
X    char **argv;            /* Argument strings. */
X{
X    int listArgc;
X    char **listArgv;
X
X    if (argc != 2) {
X    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X        " list\"", (char *) NULL);
X    return TCL_ERROR;
X    }
X    if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) {
X    return TCL_ERROR;
X    }
X    qsort((char *) listArgv, listArgc, sizeof (char *), SortCompareProc);
X    interp->result = Tcl_Merge(listArgc, listArgv);
X    interp->freeProc = (Tcl_FreeProc *) free;
X    ckfree((char *) listArgv);
X    return TCL_OK;
X}
X
X/*
X * The procedure below is called back by qsort to determine
X * the proper ordering between two elements.
X */
X
Xstatic int
XSortCompareProc(first, second)
X    CONST char *first, *second;        /* Elements to be compared. */
X{
X    return strcmp(*((char **) first), *((char **) second));
X}
END_OF_FILE
if test 29320 -ne `wc -c <'tcl6.1/tclCmdIL.c'`; then
    echo shar: \"'tcl6.1/tclCmdIL.c'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tclCmdIL.c'
fi
echo shar: End of archive 20 \(of 33\).
cp /dev/null ark20isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 ; do
    if test ! -f ark${I}isdone ; then
    MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 33 archives.
    rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
    echo You still need to unpack the following archives:
    echo "        " ${MISSING}
fi
##  End of shell archive.
exit 0

exit 0 # Just in case...
--
Kent Landfield                   INTERNET: [e-mail]
Sterling Software, IMD           UUCP:     uunet!sparky!kent
Phone:    [phone]         FAX:      [phone]
Please send comp.sources.misc-related mail to [e-mail].