home *** CD-ROM | disk | FTP | other *** search
/ Source Code 1992 March / Source_Code_CD-ROM_Walnut_Creek_March_1992.iso / usenet / altsrcs / 0 / 0992 / tclCmdIZ.c
C/C++ Source or Header  |  1990-12-28  |  32KB  |  1,332 lines
  1. /* 
  2.  * tclCmdIZ.c --
  3.  *
  4.  *    This file contains the top-level command routines for most of
  5.  *    the Tcl built-in commands whose names begin with the letters
  6.  *    I to Z.
  7.  *
  8.  * Copyright 1987 Regents of the University of California
  9.  * Permission to use, copy, modify, and distribute this
  10.  * software and its documentation for any purpose and without
  11.  * fee is hereby granted, provided that the above copyright
  12.  * notice appear in all copies.  The University of California
  13.  * makes no representations about the suitability of this
  14.  * software for any purpose.  It is provided "as is" without
  15.  * express or implied warranty.
  16.  */
  17.  
  18. #ifndef lint
  19. static char rcsid[] = "$Header: /sprite/src/lib/tcl/RCS/tclCmdIZ.c,v 1.30 90/01/31 09:21:58 ouster Exp $ SPRITE (Berkeley)";
  20. #endif /* not lint */
  21.  
  22. #include <ctype.h>
  23. #include <errno.h>
  24. #include <stdio.h>
  25. #include <stdlib.h>
  26. #include <string.h>
  27. #ifdef M_XENIX
  28. # include <sys/param.h>
  29. #else
  30. # include <sys/types.h>
  31. #endif
  32. #include <sys/file.h>
  33. #include <sys/stat.h>
  34. #ifdef BSD
  35. # include <sys/time.h>
  36. #else
  37. extern int errno;
  38. # ifndef M_XENIX
  39. #  include <sys/param.h>
  40. # endif
  41. # include <sys/times.h>
  42. # include <fcntl.h>
  43. #endif
  44. #include "tclInt.h"
  45.  
  46. /*
  47.  *----------------------------------------------------------------------
  48.  *
  49.  * Tcl_IfCmd --
  50.  *
  51.  *    This procedure is invoked to process the "if" Tcl command.
  52.  *    See the user documentation for details on what it does.
  53.  *
  54.  * Results:
  55.  *    A standard Tcl result.
  56.  *
  57.  * Side effects:
  58.  *    See the user documentation.
  59.  *
  60.  *----------------------------------------------------------------------
  61.  */
  62.  
  63.     /* ARGSUSED */
  64. int
  65. Tcl_IfCmd(dummy, interp, argc, argv)
  66.     ClientData dummy;            /* Not used. */
  67.     Tcl_Interp *interp;            /* Current interpreter. */
  68.     int argc;                /* Number of arguments. */
  69.     char **argv;            /* Argument strings. */
  70. {
  71.     char *condition, *ifPart, *elsePart, *cmd, *name;
  72.     int result, value;
  73.  
  74.     name = argv[0];
  75.     if (argc < 3) {
  76.     ifSyntax:
  77.     sprintf(interp->result, "wrong # args:  should be \"%.50s bool [then] command [[else] command]\"",
  78.         name);
  79.     return TCL_ERROR;
  80.     }
  81.     condition = argv[1];
  82.     argc -= 2;
  83.     argv += 2;
  84.     if ((**argv == 't') && (strncmp(*argv, "then", strlen(*argv)) == 0)) {
  85.     argc--;
  86.     argv++;
  87.     }
  88.     if (argc < 1) {
  89.     goto ifSyntax;
  90.     }
  91.     ifPart = *argv;
  92.     argv++;
  93.     argc--;
  94.     if (argc == 0) {
  95.     elsePart = "";
  96.     } else {
  97.     if ((**argv == 'e') && (strncmp(*argv, "else", strlen(*argv)) == 0)) {
  98.         argc--;
  99.         argv++;
  100.     }
  101.     if (argc != 1) {
  102.         goto ifSyntax;
  103.     }
  104.     elsePart = *argv;
  105.     }
  106.  
  107.     cmd = ifPart;
  108.     result = Tcl_Expr(interp, condition, &value);
  109.     if (result != TCL_OK) {
  110.     return result;
  111.     }
  112.     if (value == 0) {
  113.     cmd = elsePart;
  114.     }
  115.     result = Tcl_Eval(interp, cmd, 0, (char **) NULL);
  116.     if (result == TCL_ERROR) {
  117.     char msg[60];
  118.     sprintf(msg, " (\"if\" body line %d)", interp->errorLine);
  119.     Tcl_AddErrorInfo(interp, msg);
  120.     }
  121.     return result;
  122. }
  123.  
  124. /*
  125.  *----------------------------------------------------------------------
  126.  *
  127.  * Tcl_IndexCmd --
  128.  *
  129.  *    This procedure is invoked to process the "strchr" Tcl command.
  130.  *    See the user documentation for details on what it does.
  131.  *
  132.  * Results:
  133.  *    A standard Tcl result.
  134.  *
  135.  * Side effects:
  136.  *    See the user documentation.
  137.  *
  138.  *----------------------------------------------------------------------
  139.  */
  140.  
  141.     /* ARGSUSED */
  142. int
  143. Tcl_IndexCmd(dummy, interp, argc, argv)
  144.     ClientData dummy;            /* Not used. */
  145.     Tcl_Interp *interp;            /* Current interpreter. */
  146.     int argc;                /* Number of arguments. */
  147.     char **argv;            /* Argument strings. */
  148. {
  149.     char *p, *element;
  150.     int strchr, size, parenthesized, result;
  151.  
  152.     if (argc < 3) {
  153.     strchrSyntax:
  154.     sprintf(interp->result,
  155.         "wrong # args:  should be \"%.50s value strchr [chars]\"",
  156.         argv[0]);
  157.     return TCL_ERROR;
  158.     }
  159.     p = argv[1];
  160.     strchr = atoi(argv[2]);
  161.     if (!isdigit(*argv[2]) || (strchr < 0)) {
  162.     badIndex:
  163.     sprintf(interp->result, "bad strchr \"%.50s\"", argv[2]);
  164.     return TCL_ERROR;
  165.     }
  166.     if (argc == 3) {
  167.     for ( ; strchr >= 0; strchr--) {
  168.         result = TclFindElement(interp, p, &element, &p, &size,
  169.             &parenthesized);
  170.         if (result != TCL_OK) {
  171.         return result;
  172.         }
  173.     }
  174.     if (size >= TCL_RESULT_SIZE) {
  175.         interp->result = (char *) ckalloc((unsigned) size+1);
  176.         interp->dynamic = 1;
  177.     }
  178.     if (parenthesized) {
  179.         bcopy(element, interp->result, size);
  180.         interp->result[size] = 0;
  181.     } else {
  182.         TclCopyAndCollapse(size, element, interp->result);
  183.     }
  184.     } else if ((argc == 4)
  185.         && (strncmp(argv[3], "chars", strlen(argv[3])) == 0)) {
  186.     size = strlen(p);
  187.     if (strchr >= size) {
  188.         goto badIndex;
  189.     }
  190.     interp->result[0] = p[strchr];
  191.     interp->result[1] = 0;
  192.     } else {
  193.     goto strchrSyntax;
  194.     }
  195.     return TCL_OK;
  196. }
  197.  
  198. /*
  199.  *----------------------------------------------------------------------
  200.  *
  201.  * Tcl_InfoCmd --
  202.  *
  203.  *    This procedure is invoked to process the "info" Tcl command.
  204.  *    See the user documentation for details on what it does.
  205.  *
  206.  * Results:
  207.  *    A standard Tcl result.
  208.  *
  209.  * Side effects:
  210.  *    See the user documentation.
  211.  *
  212.  *----------------------------------------------------------------------
  213.  */
  214.  
  215.     /* ARGSUSED */
  216. int
  217. Tcl_InfoCmd(dummy, interp, argc, argv)
  218.     ClientData dummy;            /* Not used. */
  219.     Tcl_Interp *interp;            /* Current interpreter. */
  220.     int argc;                /* Number of arguments. */
  221.     char **argv;            /* Argument strings. */
  222. {
  223.     register Interp *iPtr = (Interp *) interp;
  224.     Proc *procPtr;
  225.     Var *varPtr;
  226.     Command *cmdPtr;
  227.     int length;
  228.     char c;
  229.  
  230.     /*
  231.      * When collecting a list of things (e.g. args or vars) "flag" tells
  232.      * what kind of thing is being collected, according to the definitions
  233.      * below.
  234.      */
  235.  
  236.     int flag;
  237. #   define VARS 0
  238. #   define LOCALS 1
  239. #   define PROCS 2
  240. #   define CMDS 3
  241.  
  242. #   define ARG_SIZE 20
  243.     char *argSpace[ARG_SIZE];
  244.     int argSize;
  245.     char *pattern;
  246.  
  247.     if (argc < 2) {
  248.     sprintf(iPtr->result,
  249.         "too few args:  should be \"%.50s option [arg arg ...]\"",
  250.         argv[0]);
  251.     return TCL_ERROR;
  252.     }
  253.     c = argv[1][0];
  254.     length = strlen(argv[1]);
  255.     if ((c == 'a') && (strncmp(argv[1], "args", length)) == 0) {
  256.     if (argc != 3) {
  257.         sprintf(iPtr->result,
  258.             "wrong # args: should be \"%.50s args procname\"",
  259.             argv[0]);
  260.         return TCL_ERROR;
  261.     }
  262.     procPtr = TclFindProc(iPtr, argv[2]);
  263.     if (procPtr == NULL) {
  264.         infoNoSuchProc:
  265.         sprintf(iPtr->result,
  266.             "info requested on \"%s\", which isn't a procedure",
  267.             argv[2]);
  268.         return TCL_ERROR;
  269.     }
  270.     flag = VARS;
  271.     varPtr = procPtr->argPtr;
  272.     argc = 0;            /* Prevent pattern matching. */
  273.     } else if ((c == 'b') && (strncmp(argv[1], "body", length)) == 0) {
  274.     if (argc != 3) {
  275.         sprintf(iPtr->result,
  276.             "wrong # args: should be \"%.50s body procname\"",
  277.             argv[0]);
  278.         return TCL_ERROR;
  279.     }
  280.     procPtr = TclFindProc(iPtr, argv[2]);
  281.     if (procPtr == NULL) {
  282.         goto infoNoSuchProc;
  283.     }
  284.     iPtr->result = procPtr->command;
  285.     return TCL_OK;
  286.     } else if ((c == 'c') && (strncmp(argv[1], "cmdcount", length) == 0)
  287.         && (length >= 2)) {
  288.     if (argc != 2) {
  289.         sprintf(iPtr->result,
  290.             "wrong # args: should be \"%.50s cmdcount\"",
  291.             argv[0]);
  292.         return TCL_ERROR;
  293.     }
  294.     sprintf(iPtr->result, "%d", iPtr->cmdCount);
  295.     return TCL_OK;
  296.     } else if ((c == 'c') && (strncmp(argv[1], "commands", length) == 0)
  297.         && (length >= 2)){
  298.     if (argc > 3) {
  299.         sprintf(iPtr->result,
  300.             "wrong # args: should be \"%.50s commands [pattern]\"",
  301.             argv[0]);
  302.         return TCL_ERROR;
  303.     }
  304.     flag = CMDS;
  305.     cmdPtr = iPtr->commandPtr;
  306.     } else if ((c == 'd') && (strncmp(argv[1], "default", length)) == 0) {
  307.     if (argc != 5) {
  308.         sprintf(iPtr->result, "wrong # args: should be \"%.50s default procname arg varname\"",
  309.             argv[0]);
  310.         return TCL_ERROR;
  311.     }
  312.     procPtr = TclFindProc(iPtr, argv[2]);
  313.     if (procPtr == NULL) {
  314.         goto infoNoSuchProc;
  315.     }
  316.     for (varPtr = procPtr->argPtr; ; varPtr = varPtr->nextPtr) {
  317.         if (varPtr == NULL) {
  318.         sprintf(iPtr->result,
  319.             "procedure \"%s\" doesn't have an argument \"%s\"",
  320.             argv[2], argv[3]);
  321.         return TCL_ERROR;
  322.         }
  323.         if (strcmp(argv[3], varPtr->name) == 0) {
  324.         if (varPtr->value != NULL) {
  325.             Tcl_SetVar((Tcl_Interp *) iPtr, argv[4], varPtr->value, 0);
  326.             iPtr->result = "1";
  327.         } else {
  328.             Tcl_SetVar((Tcl_Interp *) iPtr, argv[4], "", 0);
  329.             iPtr->result = "0";
  330.         }
  331.         return TCL_OK;
  332.         }
  333.     }
  334.     } else if ((c == 'g') && (strncmp(argv[1], "globals", length) == 0)) {
  335.     if (argc > 3) {
  336.         sprintf(iPtr->result,
  337.             "wrong # args: should be \"%.50s globals [pattern]\"",
  338.             argv[0]);
  339.         return TCL_ERROR;
  340.     }
  341.     flag = VARS;
  342.     varPtr = iPtr->globalPtr;
  343.     } else if ((c == 'l') && (strncmp(argv[1], "locals", length) == 0)
  344.          && (length >= 2)) {
  345.     if (argc > 3) {
  346.         sprintf(iPtr->result,
  347.             "wrong # args: should be \"%.50s locals [pattern]\"",
  348.             argv[0]);
  349.         return TCL_ERROR;
  350.     }
  351.     flag = LOCALS;
  352.     if (iPtr->varFramePtr == NULL) {
  353.         varPtr = NULL;
  354.     } else {
  355.         varPtr = iPtr->varFramePtr->varPtr;
  356.     }
  357.     } else if ((c == 'l') && (strncmp(argv[1], "level", length) == 0)
  358.         && (length >= 2)) {
  359.     if (argc == 2) {
  360.         if (iPtr->varFramePtr == NULL) {
  361.         iPtr->result = "0";
  362.         } else {
  363.         sprintf(iPtr->result, "%d", iPtr->varFramePtr->level);
  364.         }
  365.         return TCL_OK;
  366.     } else if (argc == 3) {
  367.         int level;
  368.         char *end;
  369.         CallFrame *framePtr;
  370.  
  371.         level = strtol(argv[2], &end, 10);
  372.         if ((end == argv[2]) || (*end != '\0')) {
  373.         levelError:
  374.         sprintf(iPtr->result, "bad level \"%.50s\"", argv[1]);
  375.         return TCL_ERROR;
  376.         }
  377.         if (level <= 0) {
  378.         if (iPtr->varFramePtr == NULL) {
  379.             goto levelError;
  380.         }
  381.         level += iPtr->varFramePtr->level;
  382.         }
  383.         if (level == 0) {
  384.         return TCL_OK;
  385.         }
  386.         for (framePtr = iPtr->varFramePtr; framePtr != NULL;
  387.             framePtr = framePtr->callerVarPtr) {
  388.         if (framePtr->level == level) {
  389.             break;
  390.         }
  391.         }
  392.         if (framePtr == NULL) {
  393.         goto levelError;
  394.         }
  395.         iPtr->result = Tcl_Merge(framePtr->argc, framePtr->argv);
  396.         iPtr->dynamic = 1;
  397.         return TCL_OK;
  398.     }
  399.     sprintf(iPtr->result,
  400.         "wrong # args: should be \"%.50s level [number]\"",
  401.         argv[0]);
  402.     return TCL_ERROR;
  403.     } else if ((c == 'p') && (strncmp(argv[1], "procs", length)) == 0) {
  404.     if (argc > 3) {
  405.         sprintf(iPtr->result,
  406.             "wrong # args: should be \"%.50s procs [pattern]\"",
  407.             argv[0]);
  408.         return TCL_ERROR;
  409.     }
  410.     flag = PROCS;
  411.     cmdPtr = iPtr->commandPtr;
  412.     } else if ((c == 't') && (strncmp(argv[1], "tclversion", length) == 0)) {
  413.  
  414.     /*
  415.      * Note:  TCL_VERSION below is expected to be set with a "-D"
  416.      * switch in the Makefile.
  417.      */
  418.  
  419.     strcpy(iPtr->result, TCL_VERSION);
  420.     return TCL_OK;
  421.     } else if ((c == 'v') && (strncmp(argv[1], "vars", length)) == 0) {
  422.     if (argc > 3) {
  423.         sprintf(iPtr->result,
  424.             "wrong # args: should be \"%.50s vars [pattern]\"",
  425.             argv[0]);
  426.         return TCL_ERROR;
  427.     }
  428.     flag = VARS;
  429.     if (iPtr->varFramePtr == NULL) {
  430.         varPtr = iPtr->globalPtr;
  431.     } else {
  432.         varPtr = iPtr->varFramePtr->varPtr;
  433.     }
  434.     } else {
  435.     sprintf(iPtr->result, "bad \"%.50s\" option \"%.50s\": must be args, body, commands, cmdcount, default, globals, level, locals, procs, tclversion, or vars",
  436.         argv[0], argv[1]);
  437.     return TCL_ERROR;
  438.     }
  439.  
  440.     /*
  441.      * At this point we have to assemble a list of something or other.
  442.      * Collect them in an expandable argv-argc array.
  443.      */
  444.  
  445.     if (argc == 3) {
  446.     pattern = argv[2];
  447.     } else {
  448.     pattern = NULL;
  449.     }
  450.     argv = argSpace;
  451.     argSize = ARG_SIZE;
  452.     argc = 0;
  453.     while (1) {
  454.     /*
  455.      * Increase the size of the argument array if necessary to
  456.      * accommodate another string.
  457.      */
  458.  
  459.     if (argc == argSize) {
  460.         char **newArgs;
  461.  
  462.         argSize *= 2;
  463.         newArgs = (char **) ckalloc((unsigned) argSize*sizeof(char *));
  464.         bcopy((char *) argv, (char *) newArgs, argc*sizeof(char *));
  465.         if (argv != argSpace) {
  466.         ckfree((char *) argv);
  467.         }
  468.         argv = newArgs;
  469.     }
  470.  
  471.     if ((flag == PROCS) || (flag == CMDS)) {
  472.         if (flag == PROCS) {
  473.         for ( ; cmdPtr != NULL; cmdPtr = cmdPtr->nextPtr) {
  474.             if (TclIsProc(cmdPtr)) {
  475.             break;
  476.             }
  477.         }
  478.         }
  479.         if (cmdPtr == NULL) {
  480.         break;
  481.         }
  482.         argv[argc] = cmdPtr->name;
  483.         cmdPtr = cmdPtr->nextPtr;
  484.     } else {
  485.         if (flag == LOCALS) {
  486.         for ( ; varPtr != NULL; varPtr = varPtr->nextPtr) {
  487.             if (!(varPtr->flags & VAR_GLOBAL)) {
  488.             break;
  489.             }
  490.         }
  491.         }
  492.         if (varPtr == NULL) {
  493.         break;
  494.         }
  495.         argv[argc] = varPtr->name;
  496.         varPtr = varPtr->nextPtr;
  497.     }
  498.     if ((pattern == NULL)  || Tcl_StringMatch(argv[argc], pattern)) {
  499.         argc++;
  500.     }
  501.     }
  502.  
  503.     iPtr->result = Tcl_Merge(argc, argv);
  504.     iPtr->dynamic = 1;
  505.     if (argv != argSpace) {
  506.     ckfree((char *) argv);
  507.     }
  508.     return TCL_OK;
  509. }
  510.  
  511. /*
  512.  *----------------------------------------------------------------------
  513.  *
  514.  * Tcl_LengthCmd --
  515.  *
  516.  *    This procedure is invoked to process the "length" Tcl command.
  517.  *    See the user documentation for details on what it does.
  518.  *
  519.  * Results:
  520.  *    A standard Tcl result.
  521.  *
  522.  * Side effects:
  523.  *    See the user documentation.
  524.  *
  525.  *----------------------------------------------------------------------
  526.  */
  527.  
  528.     /* ARGSUSED */
  529. int
  530. Tcl_LengthCmd(dummy, interp, argc, argv)
  531.     ClientData dummy;            /* Not used. */
  532.     Tcl_Interp *interp;            /* Current interpreter. */
  533.     int argc;                /* Number of arguments. */
  534.     char **argv;            /* Argument strings. */
  535. {
  536.     int count;
  537.     char *p;
  538.  
  539.     if (argc < 2) {
  540.     lengthSyntax:
  541.     sprintf(interp->result,
  542.         "wrong # args: should be \"%.50s value [chars]\"", argv[0]);
  543.     return TCL_ERROR;
  544.     }
  545.     p = argv[1];
  546.     if (argc == 2) {
  547.     char *element;
  548.     int result;
  549.  
  550.     for (count = 0; *p != 0 ; count++) {
  551.         result = TclFindElement(interp, p, &element, &p, (int *) NULL,
  552.             (int *) NULL);
  553.         if (result != TCL_OK) {
  554.         return result;
  555.         }
  556.         if (*element == 0) {
  557.         break;
  558.         }
  559.     }
  560.     } else if ((argc == 3)
  561.         && (strncmp(argv[2], "chars", strlen(argv[2])) == 0)) {
  562.     count = strlen(p);
  563.     } else {
  564.     goto lengthSyntax;
  565.     }
  566.     sprintf(interp->result, "%d", count);
  567.     return TCL_OK;
  568. }
  569.  
  570. /*
  571.  *----------------------------------------------------------------------
  572.  *
  573.  * Tcl_ListCmd --
  574.  *
  575.  *    This procedure is invoked to process the "list" Tcl command.
  576.  *    See the user documentation for details on what it does.
  577.  *
  578.  * Results:
  579.  *    A standard Tcl result.
  580.  *
  581.  * Side effects:
  582.  *    See the user documentation.
  583.  *
  584.  *----------------------------------------------------------------------
  585.  */
  586.  
  587.     /* ARGSUSED */
  588. int
  589. Tcl_ListCmd(dummy, interp, argc, argv)
  590.     ClientData dummy;            /* Not used. */
  591.     Tcl_Interp *interp;            /* Current interpreter. */
  592.     int argc;                /* Number of arguments. */
  593.     char **argv;            /* Argument strings. */
  594. {
  595.     interp->result = Tcl_Merge(argc-1, argv+1);
  596.     interp->dynamic = 1;
  597.     return TCL_OK;
  598. }
  599.  
  600. /*
  601.  *----------------------------------------------------------------------
  602.  *
  603.  * Tcl_PrintCmd --
  604.  *
  605.  *    This procedure is invoked to process the "print" Tcl command.
  606.  *    See the user documentation for details on what it does.
  607.  *
  608.  * Results:
  609.  *    A standard Tcl result.
  610.  *
  611.  * Side effects:
  612.  *    See the user documentation.
  613.  *
  614.  *----------------------------------------------------------------------
  615.  */
  616.  
  617.     /* ARGSUSED */
  618. int
  619. Tcl_PrintCmd(notUsed, interp, argc, argv)
  620.     ClientData notUsed;            /* Not used. */
  621.     Tcl_Interp *interp;            /* Current interpreter. */
  622.     int argc;                /* Number of arguments. */
  623.     char **argv;            /* Argument strings. */
  624. {
  625.     FILE *f;
  626.     int result;
  627.  
  628.     if ((argc < 2) || (argc > 4)) {
  629.     sprintf(interp->result,
  630.         "wrong # args: should be \"%.50s string [file [append]]\"",
  631.         argv[0]);
  632.     return TCL_ERROR;
  633.     }
  634.  
  635.     if (argc == 2) {
  636.     f = stdout;
  637.     } else {
  638.     if (argc == 4) {
  639.         if (strncmp(argv[3], "append", strlen(argv[3])) != 0) {
  640.         sprintf(interp->result,
  641.             "bad option \"%.50s\":  must be \"append\"",
  642.             argv[3]);
  643.         return TCL_ERROR;
  644.         }
  645.         f = fopen(argv[2], "a");
  646.     } else {
  647.         f = fopen(argv[2], "w");
  648.     }
  649.     if (f == NULL) {
  650.         sprintf(interp->result, "couldn't open \"%.50s\": %.80s",
  651.             argv[2], strerror(errno));
  652.         return TCL_ERROR;
  653.     }
  654.     }
  655.     fputs(argv[1], f);
  656.     if (argc == 2) {
  657.     result = fflush(stdout);
  658.     } else {
  659.     result = fclose(f);
  660.     }
  661.     if (result == EOF) {
  662.     sprintf(interp->result, "I/O error while writing: %.50s",
  663.         strerror(errno));
  664.     return TCL_ERROR;
  665.     }
  666.     return TCL_OK;
  667. }
  668.  
  669. /*
  670.  *----------------------------------------------------------------------
  671.  *
  672.  * Tcl_RangeCmd --
  673.  *
  674.  *    This procedure is invoked to process the "range" Tcl command.
  675.  *    See the user documentation for details on what it does.
  676.  *
  677.  * Results:
  678.  *    A standard Tcl result.
  679.  *
  680.  * Side effects:
  681.  *    See the user documentation.
  682.  *
  683.  *----------------------------------------------------------------------
  684.  */
  685.  
  686.     /* ARGSUSED */
  687. int
  688. Tcl_RangeCmd(notUsed, interp, argc, argv)
  689.     ClientData notUsed;            /* Not used. */
  690.     Tcl_Interp *interp;            /* Current interpreter. */
  691.     int argc;                /* Number of arguments. */
  692.     char **argv;            /* Argument strings. */
  693. {
  694.     int first, last, result;
  695.     char *begin, *end, c, *dummy;
  696.     int count;
  697.  
  698.     if (argc < 4) {
  699.     rangeSyntax:
  700.     sprintf(interp->result, "wrong #/type of args: should be \"%.50s value first last [chars]\"",
  701.         argv[0]);
  702.     return TCL_ERROR;
  703.     }
  704.     first = atoi(argv[2]);
  705.     if (!isdigit(*argv[2]) || (first < 0)) {
  706.     sprintf(interp->result, "bad range specifier \"%.50s\"", argv[2]);
  707.     return TCL_ERROR;
  708.     }
  709.     if ((*argv[3] == 'e') && (strncmp(argv[3], "end", strlen(argv[3])) == 0)) {
  710.     last = -1;
  711.     } else {
  712.     last = atoi(argv[3]);
  713.     if (!isdigit(*argv[3]) || (last < 0)) {
  714.         sprintf(interp->result, "bad range specifier \"%.50s\"", argv[3]);
  715.         return TCL_ERROR;
  716.     }
  717.     }
  718.  
  719.     if (argc == 5) {
  720.     count = strlen(argv[4]);
  721.     if ((count == 0) || (strncmp(argv[4], "chars", count) != 0)) {
  722.         goto rangeSyntax;
  723.     }
  724.  
  725.     /*
  726.      * Extract a range of characters.
  727.      */
  728.  
  729.     count = strlen(argv[1]);
  730.     if (first >= count) {
  731.         interp->result = "";
  732.         return TCL_OK;
  733.     }
  734.     begin = argv[1] + first;
  735.     if ((last == -1) || (last >= count)) {
  736.         last = count;
  737.     } else if (last < first) {
  738.         interp->result = "";
  739.         return TCL_OK;
  740.     }
  741.     end = argv[1] + last + 1;
  742.     } else {
  743.     if (argc != 4) {
  744.         goto rangeSyntax;
  745.     }
  746.  
  747.     /*
  748.      * Extract a range of fields.
  749.      */
  750.  
  751.     for (count = 0, begin = argv[1]; count < first; count++) {
  752.         result = TclFindElement(interp, begin, &dummy, &begin, (int *) NULL,
  753.             (int *) NULL);
  754.         if (result != TCL_OK) {
  755.         return result;
  756.         }
  757.         if (*begin == 0) {
  758.         break;
  759.         }
  760.     }
  761.     if (last == -1) {
  762.         Tcl_Return(interp, begin, TCL_VOLATILE);
  763.         return TCL_OK;
  764.     }
  765.     if (last < first) {
  766.         interp->result = "";
  767.         return TCL_OK;
  768.     }
  769.     for (count = first, end = begin; (count <= last) && (*end != 0);
  770.         count++) {
  771.         result = TclFindElement(interp, end, &dummy, &end, (int *) NULL,
  772.             (int *) NULL);
  773.         if (result != TCL_OK) {
  774.         return result;
  775.         }
  776.     }
  777.  
  778.     /*
  779.      * Chop off trailing spaces.
  780.      */
  781.  
  782.     while (isspace(end[-1])) {
  783.         end--;
  784.     }
  785.     }
  786.     c = *end;
  787.     *end = 0;
  788.     Tcl_Return(interp, begin, TCL_VOLATILE);
  789.     *end = c;
  790.     return TCL_OK;
  791. }
  792.  
  793. /*
  794.  *----------------------------------------------------------------------
  795.  *
  796.  * Tcl_RenameCmd --
  797.  *
  798.  *    This procedure is invoked to process the "rename" Tcl command.
  799.  *    See the user documentation for details on what it does.
  800.  *
  801.  * Results:
  802.  *    A standard Tcl result.
  803.  *
  804.  * Side effects:
  805.  *    See the user documentation.
  806.  *
  807.  *----------------------------------------------------------------------
  808.  */
  809.  
  810.     /* ARGSUSED */
  811. int
  812. Tcl_RenameCmd(dummy, interp, argc, argv)
  813.     ClientData dummy;            /* Not used. */
  814.     Tcl_Interp *interp;            /* Current interpreter. */
  815.     int argc;                /* Number of arguments. */
  816.     char **argv;            /* Argument strings. */
  817. {
  818.     register Command *oldPtr, *newPtr;
  819.     Interp *iPtr = (Interp *) interp;
  820.  
  821.     if (argc != 3) {
  822.     sprintf(interp->result,
  823.         "wrong # args: should be \"%.50s oldName newName\"",
  824.         argv[0]);
  825.     return TCL_ERROR;
  826.     }
  827.     if (argv[2][0] == '\0') {
  828.     Tcl_DeleteCommand(interp, argv[1]);
  829.     return TCL_OK;
  830.     }
  831.     newPtr = TclFindCmd(iPtr, argv[2], 0);
  832.     if (newPtr != NULL) {
  833.     sprintf(interp->result, "can't rename to \"%.50s\": already exists",
  834.         argv[2]);
  835.     return TCL_ERROR;
  836.     }
  837.     oldPtr = TclFindCmd(iPtr, argv[1], 0);
  838.     if (oldPtr == NULL) {
  839.     sprintf(interp->result,
  840.         "can't rename \"%.50s\":  command doesn't exist",
  841.         argv[1]);
  842.     return TCL_ERROR;
  843.     }
  844.     iPtr->commandPtr = oldPtr->nextPtr;
  845.     newPtr = (Command *) ckalloc(CMD_SIZE(strlen(argv[2])));
  846.     newPtr->proc = oldPtr->proc;
  847.     newPtr->clientData = oldPtr->clientData;
  848.     newPtr->deleteProc = oldPtr->deleteProc;
  849.     newPtr->nextPtr = iPtr->commandPtr;
  850.     iPtr->commandPtr = newPtr;
  851.     strcpy(newPtr->name, argv[2]);
  852.     ckfree((char *) oldPtr);
  853.     return TCL_OK;
  854. }
  855.  
  856. /*
  857.  *----------------------------------------------------------------------
  858.  *
  859.  * Tcl_ReturnCmd --
  860.  *
  861.  *    This procedure is invoked to process the "return" Tcl command.
  862.  *    See the user documentation for details on what it does.
  863.  *
  864.  * Results:
  865.  *    A standard Tcl result.
  866.  *
  867.  * Side effects:
  868.  *    See the user documentation.
  869.  *
  870.  *----------------------------------------------------------------------
  871.  */
  872.  
  873.     /* ARGSUSED */
  874. int
  875. Tcl_ReturnCmd(dummy, interp, argc, argv)
  876.     ClientData dummy;            /* Not used. */
  877.     Tcl_Interp *interp;            /* Current interpreter. */
  878.     int argc;                /* Number of arguments. */
  879.     char **argv;            /* Argument strings. */
  880. {
  881.     if (argc > 2) {
  882.     sprintf(interp->result, "too many args: should be \"%.50s [value]\"",
  883.         argv[0]);
  884.     return TCL_ERROR;
  885.     }
  886.     if (argc == 2) {
  887.     Tcl_Return(interp, argv[1], TCL_VOLATILE);
  888.     }
  889.     return TCL_RETURN;
  890. }
  891.  
  892. /*
  893.  *----------------------------------------------------------------------
  894.  *
  895.  * Tcl_ScanCmd --
  896.  *
  897.  *    This procedure is invoked to process the "scan" Tcl command.
  898.  *    See the user documentation for details on what it does.
  899.  *
  900.  * Results:
  901.  *    A standard Tcl result.
  902.  *
  903.  * Side effects:
  904.  *    See the user documentation.
  905.  *
  906.  *----------------------------------------------------------------------
  907.  */
  908.  
  909.     /* ARGSUSED */
  910. int
  911. Tcl_ScanCmd(dummy, interp, argc, argv)
  912.     ClientData dummy;            /* Not used. */
  913.     Tcl_Interp *interp;            /* Current interpreter. */
  914.     int argc;                /* Number of arguments. */
  915.     char **argv;            /* Argument strings. */
  916. {
  917.     int arg1Length;            /* Number of bytes in argument to be
  918.                      * scanned.  This gives an upper limit
  919.                      * on string field sizes. */
  920. #   define MAX_FIELDS 20
  921.     typedef struct {
  922.     char fmt;            /* Format for field. */
  923.     int size;            /* How many bytes to allow for
  924.                      * field. */
  925.     char *location;            /* Where field will be stored. */
  926.     } Field;
  927.     Field fields[MAX_FIELDS];        /* Info about all the fields in the
  928.                      * format string. */
  929.     register Field *curField;
  930.     int numFields = 0;            /* Number of fields actually
  931.                      * specified. */
  932.     int suppress;            /* Current field is assignment-
  933.                      * suppressed. */
  934.     int totalSize = 0;            /* Number of bytes needed to store
  935.                      * all results combined. */
  936.     char *results;            /* Where scanned output goes.  */
  937.     int numScanned;            /* sscanf's result. */
  938.     register char *fmt;
  939.     int i;
  940.  
  941.     if (argc < 3) {
  942.     sprintf(interp->result,
  943.         "too few args: should be \"%.50s string format varName ...\"",
  944.         argv[0]);
  945.     return TCL_ERROR;
  946.     }
  947.  
  948.     /*
  949.      * This procedure operates in four stages:
  950.      * 1. Scan the format string, collecting information about each field.
  951.      * 2. Allocate an array to hold all of the scanned fields.
  952.      * 3. Call sscanf to do all the dirty work, and have it store the
  953.      *    parsed fields in the array.
  954.      * 4. Pick off the fields from the array and assign them to variables.
  955.      */
  956.  
  957.     arg1Length = (strlen(argv[1]) + 4) & ~03;
  958.     for (fmt = argv[2]; *fmt != 0; fmt++) {
  959.     if (*fmt != '%') {
  960.         continue;
  961.     }
  962.     fmt++;
  963.     if (*fmt == '*') {
  964.         suppress = 1;
  965.         fmt++;
  966.     } else {
  967.         suppress = 0;
  968.     }
  969.     while (isdigit(*fmt)) {
  970.         fmt++;
  971.     }
  972.     if (suppress) {
  973.         continue;
  974.     }
  975.     if (numFields == MAX_FIELDS) {
  976.         sprintf(interp->result,
  977.             "can't have more than %d fields in \"%.50s\"", MAX_FIELDS,
  978.             argv[0]);
  979.         return TCL_ERROR;
  980.     }
  981.     curField = &fields[numFields];
  982.     numFields++;
  983.     switch (*fmt) {
  984.         case 'D':
  985.         case 'O':
  986.         case 'X':
  987.         case 'd':
  988.         case 'o':
  989.         case 'x':
  990.         curField->fmt = 'd';
  991.         curField->size = sizeof(int);
  992.         break;
  993.  
  994.         case 's':
  995.         curField->fmt = 's';
  996.         curField->size = arg1Length;
  997.         break;
  998.  
  999.         case 'c':
  1000.         curField->fmt = 'c';
  1001.         curField->size = sizeof(int);
  1002.         break;
  1003.  
  1004.         case 'E':
  1005.         case 'F':
  1006.         curField->fmt = 'F';
  1007.         curField->size = 8;
  1008.         break;
  1009.  
  1010.         case 'e':
  1011.         case 'f':
  1012.         curField->fmt = 'f';
  1013.         curField->size = 4;
  1014.         break;
  1015.  
  1016.         case '[':
  1017.         curField->fmt = 's';
  1018.         curField->size = arg1Length;
  1019.         do {
  1020.             fmt++;
  1021.         } while (*fmt != ']');
  1022.         break;
  1023.  
  1024.         default:
  1025.         sprintf(interp->result, "bad scan conversion character \"%c\"",
  1026.             *fmt);
  1027.         return TCL_ERROR;
  1028.     }
  1029.     totalSize += curField->size;
  1030.     }
  1031.  
  1032.     if (numFields != (argc-3)) {
  1033.     interp->result =
  1034.         "different numbers of variable names and field specifiers";
  1035.     return TCL_ERROR;
  1036.     }
  1037.  
  1038.     /*
  1039.      * Step 2:
  1040.      */
  1041.  
  1042.     results = (char *) ckalloc((unsigned) totalSize);
  1043.     for (i = 0, totalSize = 0, curField = fields;
  1044.         i < numFields; i++, curField++) {
  1045.     curField->location = results + totalSize;
  1046.     totalSize += curField->size;
  1047.     }
  1048.  
  1049.     /*
  1050.      * Step 3:
  1051.      */
  1052.  
  1053.     numScanned = sscanf(argv[1], argv[2],
  1054.         fields[0].location, fields[1].location, fields[2].location,
  1055.         fields[3].location, fields[4].location);
  1056.  
  1057.     /*
  1058.      * Step 4:
  1059.      */
  1060.  
  1061.     if (numScanned < numFields) {
  1062.     numFields = numScanned;
  1063.     }
  1064.     for (i = 0, curField = fields; i < numFields; i++, curField++) {
  1065.     switch (curField->fmt) {
  1066.         char string[30];
  1067.  
  1068.         case 'd':
  1069.         sprintf(string, "%d", *((int *) curField->location));
  1070.         Tcl_SetVar(interp, argv[i+3], string, 0);
  1071.         break;
  1072.  
  1073.         case 'c':
  1074.         sprintf(string, "%d", *((char *) curField->location) & 0xff);
  1075.         Tcl_SetVar(interp, argv[i+3], string, 0);
  1076.         break;
  1077.  
  1078.         case 's':
  1079.         Tcl_SetVar(interp, argv[i+3], curField->location, 0);
  1080.         break;
  1081.  
  1082.         case 'F':
  1083.         sprintf(string, "%g", *((double *) curField->location));
  1084.         Tcl_SetVar(interp, argv[i+3], string, 0);
  1085.         break;
  1086.  
  1087.         case 'f':
  1088.         sprintf(string, "%g", *((float *) curField->location));
  1089.         Tcl_SetVar(interp, argv[i+3], string, 0);
  1090.         break;
  1091.     }
  1092.     }
  1093.     ckfree(results);
  1094.     sprintf(interp->result, "%d", numScanned);
  1095.     return TCL_OK;
  1096. }
  1097.  
  1098. /*
  1099.  *----------------------------------------------------------------------
  1100.  *
  1101.  * Tcl_SourceCmd --
  1102.  *
  1103.  *    This procedure is invoked to process the "source" Tcl command.
  1104.  *    See the user documentation for details on what it does.
  1105.  *
  1106.  * Results:
  1107.  *    A standard Tcl result.
  1108.  *
  1109.  * Side effects:
  1110.  *    See the user documentation.
  1111.  *
  1112.  *----------------------------------------------------------------------
  1113.  */
  1114.  
  1115.     /* ARGSUSED */
  1116. int
  1117. Tcl_SourceCmd(dummy, interp, argc, argv)
  1118.     ClientData dummy;            /* Not used. */
  1119.     Tcl_Interp *interp;            /* Current interpreter. */
  1120.     int argc;                /* Number of arguments. */
  1121.     char **argv;            /* Argument strings. */
  1122. {
  1123.     int fileId, result;
  1124.     struct stat statBuf;
  1125.     char *cmdBuffer, *end;
  1126.  
  1127.     if (argc != 2) {
  1128.     sprintf(interp->result, "wrong # args: should be \"%.50s fileName\"",
  1129.         argv[0]);
  1130.     return TCL_ERROR;
  1131.     }
  1132.     fileId = open(argv[1], O_RDONLY, 0);
  1133.     if (fileId < 0) {
  1134.     sprintf(interp->result, "couldn't read file \"%.50s\"", argv[1]);
  1135.     return TCL_ERROR;
  1136.     }
  1137.     if (fstat(fileId, &statBuf) == -1) {
  1138.     sprintf(interp->result, "couldn't stat file \"%.50s\"", argv[1]);
  1139.     close(fileId);
  1140.     return TCL_ERROR;
  1141.     }
  1142.     cmdBuffer = (char *) ckalloc((unsigned) statBuf.st_size+1);
  1143.     if (read(fileId, cmdBuffer, (int) statBuf.st_size) != statBuf.st_size) {
  1144.     sprintf(interp->result, "error in reading file \"%.50s\"", argv[1]);
  1145.     close(fileId);
  1146.     return TCL_ERROR;
  1147.     }
  1148.     close(fileId);
  1149.     cmdBuffer[statBuf.st_size] = 0;
  1150.     result = Tcl_Eval(interp, cmdBuffer, 0, &end);
  1151.     if (result == TCL_RETURN) {
  1152.     result = TCL_OK;
  1153.     }
  1154.     if (result == TCL_ERROR) {
  1155.     char msg[100];
  1156.  
  1157.     /*
  1158.      * Record information telling where the error occurred.
  1159.      */
  1160.  
  1161.     sprintf(msg, " (file \"%.50s\" line %d)", argv[1], interp->errorLine);
  1162.     Tcl_AddErrorInfo(interp, msg);
  1163.     }
  1164.     ckfree(cmdBuffer);
  1165.     return result;
  1166. }
  1167.  
  1168. /*
  1169.  *----------------------------------------------------------------------
  1170.  *
  1171.  * Tcl_StringCmd --
  1172.  *
  1173.  *    This procedure is invoked to process the "string" Tcl command.
  1174.  *    See the user documentation for details on what it does.
  1175.  *
  1176.  * Results:
  1177.  *    A standard Tcl result.
  1178.  *
  1179.  * Side effects:
  1180.  *    See the user documentation.
  1181.  *
  1182.  *----------------------------------------------------------------------
  1183.  */
  1184.  
  1185.     /* ARGSUSED */
  1186. int
  1187. Tcl_StringCmd(dummy, interp, argc, argv)
  1188.     ClientData dummy;            /* Not used. */
  1189.     Tcl_Interp *interp;            /* Current interpreter. */
  1190.     int argc;                /* Number of arguments. */
  1191.     char **argv;            /* Argument strings. */
  1192. {
  1193.     int length;
  1194.     register char *p, c;
  1195.     int match;
  1196.     int first;
  1197.  
  1198.     if (argc != 4) {
  1199.     sprintf(interp->result,
  1200.         "wrong # args: should be \"%.50s option a b\"",
  1201.         argv[0]);
  1202.     return TCL_ERROR;
  1203.     }
  1204.     length = strlen(argv[1]);
  1205.     if (strncmp(argv[1], "compare", length) == 0) {
  1206.     match = strcmp(argv[2], argv[3]);
  1207.     if (match > 0) {
  1208.         interp->result = "1";
  1209.     } else if (match < 0) {
  1210.         interp->result = "-1";
  1211.     } else {
  1212.         interp->result = "0";
  1213.     }
  1214.     return TCL_OK;
  1215.     }
  1216.     if (strncmp(argv[1], "first", length) == 0) {
  1217.     first = 1;
  1218.     } else if (strncmp(argv[1], "last", length) == 0) {
  1219.     first = 0;
  1220.     } else if (strncmp(argv[1], "match", length) == 0) {
  1221.     if (Tcl_StringMatch(argv[3], argv[2]) != 0) {
  1222.         interp->result = "1";
  1223.     } else {
  1224.         interp->result = "0";
  1225.     }
  1226.     return TCL_OK;
  1227.     } else {
  1228.     sprintf(interp->result,
  1229.         "bad \"%.50s\" option \"%.50s\": must be compare, first, or last",
  1230.         argv[0], argv[1]);
  1231.     return TCL_ERROR;
  1232.     }
  1233.     match = -1;
  1234.     c = *argv[2];
  1235.     length = strlen(argv[2]);
  1236.     for (p = argv[3]; *p != 0; p++) {
  1237.     if (*p != c) {
  1238.         continue;
  1239.     }
  1240.     if (strncmp(argv[2], p, length) == 0) {
  1241.         match = p-argv[3];
  1242.         if (first) {
  1243.         break;
  1244.         }
  1245.     }
  1246.     }
  1247.     sprintf(interp->result, "%d", match);
  1248.     return TCL_OK;
  1249. }
  1250.  
  1251. /*
  1252.  *----------------------------------------------------------------------
  1253.  *
  1254.  * Tcl_TimeCmd --
  1255.  *
  1256.  *    This procedure is invoked to process the "time" Tcl command.
  1257.  *    See the user documentation for details on what it does.
  1258.  *
  1259.  * Results:
  1260.  *    A standard Tcl result.
  1261.  *
  1262.  * Side effects:
  1263.  *    See the user documentation.
  1264.  *
  1265.  *----------------------------------------------------------------------
  1266.  */
  1267.  
  1268.     /* ARGSUSED */
  1269. int
  1270. Tcl_TimeCmd(dummy, interp, argc, argv)
  1271.     ClientData dummy;            /* Not used. */
  1272.     Tcl_Interp *interp;            /* Current interpreter. */
  1273.     int argc;                /* Number of arguments. */
  1274.     char **argv;            /* Argument strings. */
  1275. {
  1276.     int count, i, result;
  1277. #ifdef BSD
  1278.     struct timeval start, stop;
  1279.     struct timezone tz;
  1280.     int micros;
  1281. #else
  1282.     struct tms dummy2;
  1283.     long start, stop;
  1284.     long ticks;
  1285. #endif
  1286.     double timePer;
  1287.  
  1288.     if (argc == 2) {
  1289.     count = 1;
  1290.     } else if (argc == 3) {
  1291.     if (sscanf(argv[2], "%d", &count) != 1) {
  1292.         sprintf(interp->result, "bad count \"%.50s\" given to \"%.50s\"",
  1293.             argv[2], argv[0]);
  1294.         return TCL_ERROR;
  1295.     }
  1296.     } else {
  1297.     sprintf(interp->result,
  1298.         "wrong # args: should be \"%.50s command [count]\"",
  1299.         argv[0]);
  1300.     return TCL_ERROR;
  1301.     }
  1302. #ifdef BSD
  1303.     gettimeofday(&start, &tz);
  1304. #else
  1305.     start = times(&dummy2);
  1306. #endif
  1307.     for (i = count ; i > 0; i--) {
  1308.     result = Tcl_Eval(interp, argv[1], 0, (char **) NULL);
  1309.     if (result != TCL_OK) {
  1310.         if (result == TCL_ERROR) {
  1311.         char msg[60];
  1312.         sprintf(msg, " (\"time\" body line %d)", interp->errorLine);
  1313.         Tcl_AddErrorInfo(interp, msg);
  1314.         }
  1315.         return result;
  1316.     }
  1317.     }
  1318. #ifdef BSD
  1319.     gettimeofday(&stop, &tz);
  1320.     micros = (stop.tv_sec - start.tv_sec)*1000000
  1321.         + (stop.tv_usec - start.tv_usec);
  1322.     timePer = micros;
  1323. #else
  1324.     stop = times(&dummy2);
  1325.     ticks = stop-start;
  1326.     timePer = ((double)ticks * 1000000.0) / HZ;
  1327. #endif
  1328.     Tcl_Return(interp, (char *) NULL, TCL_STATIC);
  1329.     sprintf(interp->result, "%.0f microseconds per iteration", timePer/count);
  1330.     return TCL_OK;
  1331. }
  1332.