home *** CD-ROM | disk | FTP | other *** search
/ Source Code 1992 March / Source_Code_CD-ROM_Walnut_Creek_March_1992.iso / usenet / altsrcs / 0 / 0989 / tclCmdAH.c
Encoding:
C/C++ Source or Header  |  1990-12-28  |  30.4 KB  |  1,304 lines
  1. /* 
  2.  * tclCmdAH.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.  *    A to H.
  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/tclCmdAH.c,v 1.38 90/01/15 15:15:48 ouster Exp $ SPRITE (Berkeley)";
  20. #endif /* not lint */
  21.  
  22. #include <ctype.h>
  23. #include <errno.h>
  24. #include <signal.h>
  25. #include <stdio.h>
  26. #include <stdlib.h>
  27. #include <string.h>
  28. #include <sys/types.h>
  29. #include <sys/file.h>
  30. #include <sys/stat.h>
  31. #include <time.h>
  32.  
  33. #ifdef BSD
  34. # include <sys/resource.h>
  35. # include <sys/wait.h>
  36. # include <sys/errno.h>
  37. typedef union wait WAIT;
  38. #else
  39. # include <fcntl.h>
  40. # ifdef M_XENIX
  41. #  define F_OK 00
  42. #  define X_OK 01
  43. #  define W_OK 02
  44. #  define R_OK 04
  45. # else
  46. #  include <unistd.h>
  47. # endif
  48. extern int errno;
  49. #define WAIT int
  50. #define SIGCHLD SIGCLD
  51. #endif
  52.  
  53. #include "tclInt.h"
  54.  
  55. #define TMPFILENAME "/tmp/tcl.XXXXXX"
  56.  
  57. /*
  58.  *----------------------------------------------------------------------
  59.  *
  60.  * Tcl_BreakCmd --
  61.  *
  62.  *    This procedure is invoked to process the "break" Tcl command.
  63.  *    See the user documentation for details on what it does.
  64.  *
  65.  * Results:
  66.  *    A standard Tcl result.
  67.  *
  68.  * Side effects:
  69.  *    See the user documentation.
  70.  *
  71.  *----------------------------------------------------------------------
  72.  */
  73.  
  74.     /* ARGSUSED */
  75. int
  76. Tcl_BreakCmd(dummy, interp, argc, argv)
  77.     ClientData dummy;            /* Not used. */
  78.     Tcl_Interp *interp;            /* Current interpreter. */
  79.     int argc;                /* Number of arguments. */
  80.     char **argv;            /* Argument strings. */
  81. {
  82.     if (argc != 1) {
  83.     sprintf(interp->result, "too many args: should be \"%.50s\"", argv[0]);
  84.     return TCL_ERROR;
  85.     }
  86.     return TCL_BREAK;
  87. }
  88.  
  89. /*
  90.  *----------------------------------------------------------------------
  91.  *
  92.  * Tcl_CaseCmd --
  93.  *
  94.  *    This procedure is invoked to process the "case" Tcl command.
  95.  *    See the user documentation for details on what it does.
  96.  *
  97.  * Results:
  98.  *    A standard Tcl result.
  99.  *
  100.  * Side effects:
  101.  *    See the user documentation.
  102.  *
  103.  *----------------------------------------------------------------------
  104.  */
  105.  
  106.     /* ARGSUSED */
  107. int
  108. Tcl_CaseCmd(dummy, interp, argc, argv)
  109.     ClientData dummy;            /* Not used. */
  110.     Tcl_Interp *interp;            /* Current interpreter. */
  111.     int argc;                /* Number of arguments. */
  112.     char **argv;            /* Argument strings. */
  113. {
  114.     int i, result;
  115.     int body;
  116.     char *string;
  117.  
  118.     if (argc < 4) {
  119.     sprintf(interp->result,
  120.         "%s \"%.50s string [in] patList body ... [default body]\"",
  121.         "not enough args:  should be", argv[0]);
  122.     return TCL_ERROR;
  123.     }
  124.     string = argv[1];
  125.     body = NULL;
  126.     if (strcmp(argv[2], "in") == 0) {
  127.     i = 3;
  128.     } else {
  129.     i = 2;
  130.     }
  131.     for (; i < argc; i += 2) {
  132.     int patArgc, j;
  133.     char **patArgv;
  134.     register char *p;
  135.  
  136.     if (i == (argc-1)) {
  137.         sprintf(interp->result, "extra pattern with no body in \"%.50s\"",
  138.             argv[0]);
  139.         return TCL_ERROR;
  140.     }
  141.  
  142.     /*
  143.      * Check for special case of single pattern (no list) with
  144.      * no backslash sequences.
  145.      */
  146.  
  147.     for (p = argv[i]; *p != 0; p++) {
  148.         if (isspace(*p) || (*p == '\\')) {
  149.         break;
  150.         }
  151.     }
  152.     if (*p == 0) {
  153.         if ((*argv[i] == 'd') && (strcmp(argv[i], "default") == 0)) {
  154.         body = i+1;
  155.         }
  156.         if (Tcl_StringMatch(string, argv[i])) {
  157.         body = i+1;
  158.         goto match;
  159.         }
  160.         continue;
  161.     }
  162.  
  163.     /*
  164.      * Break up pattern lists, then check each of the patterns
  165.      * in the list.
  166.      */
  167.  
  168.     result = Tcl_SplitList(interp, argv[i], &patArgc, &patArgv);
  169.     if (result != TCL_OK) {
  170.         return result;
  171.     }
  172.     for (j = 0; j < patArgc; j++) {
  173.         if (Tcl_StringMatch(string, patArgv[j])) {
  174.         body = i+1;
  175.         break;
  176.         }
  177.     }
  178.     ckfree((char *) patArgv);
  179.     if (j < patArgc) {
  180.         break;
  181.     }
  182.     }
  183.  
  184.     match:
  185.     if (body != NULL) {
  186.     result = Tcl_Eval(interp, argv[body], 0, (char **) NULL);
  187.     if (result == TCL_ERROR) {
  188.         char msg[100];
  189.         sprintf(msg, " (\"%.50s\" arm line %d)", argv[i],
  190.             interp->errorLine);
  191.         Tcl_AddErrorInfo(interp, msg);
  192.     }
  193.     return result;
  194.     }
  195.  
  196.     /*
  197.      * Nothing matched:  return nothing.
  198.      */
  199.     return TCL_OK;
  200. }
  201.  
  202. /*
  203.  *----------------------------------------------------------------------
  204.  *
  205.  * Tcl_CatchCmd --
  206.  *
  207.  *    This procedure is invoked to process the "catch" Tcl command.
  208.  *    See the user documentation for details on what it does.
  209.  *
  210.  * Results:
  211.  *    A standard Tcl result.
  212.  *
  213.  * Side effects:
  214.  *    See the user documentation.
  215.  *
  216.  *----------------------------------------------------------------------
  217.  */
  218.  
  219.     /* ARGSUSED */
  220. int
  221. Tcl_CatchCmd(dummy, interp, argc, argv)
  222.     ClientData dummy;            /* Not used. */
  223.     Tcl_Interp *interp;            /* Current interpreter. */
  224.     int argc;                /* Number of arguments. */
  225.     char **argv;            /* Argument strings. */
  226. {
  227.     int result;
  228.  
  229.     if ((argc != 2) && (argc != 3)) {
  230.     sprintf(interp->result,
  231.         "wrong # args: should be \"%.50s command [varName]\"",
  232.         argv[0]);
  233.     return TCL_ERROR;
  234.     }
  235.     result = Tcl_Eval(interp, argv[1], 0, (char **) NULL);
  236.     if (argc == 3) {
  237.     Tcl_SetVar(interp, argv[2], interp->result, 0);
  238.     }
  239.     Tcl_Return(interp, (char *) NULL, TCL_STATIC);
  240.     sprintf(interp->result, "%d", result);
  241.     return TCL_OK;
  242. }
  243.  
  244. /*
  245.  *----------------------------------------------------------------------
  246.  *
  247.  * Tcl_ConcatCmd --
  248.  *
  249.  *    This procedure is invoked to process the "concat" Tcl command.
  250.  *    See the user documentation for details on what it does.
  251.  *
  252.  * Results:
  253.  *    A standard Tcl result.
  254.  *
  255.  * Side effects:
  256.  *    See the user documentation.
  257.  *
  258.  *----------------------------------------------------------------------
  259.  */
  260.  
  261.     /* ARGSUSED */
  262. int
  263. Tcl_ConcatCmd(dummy, interp, argc, argv)
  264.     ClientData dummy;            /* Not used. */
  265.     Tcl_Interp *interp;            /* Current interpreter. */
  266.     int argc;                /* Number of arguments. */
  267.     char **argv;            /* Argument strings. */
  268. {
  269.     if (argc == 1) {
  270.     return TCL_OK;
  271.     }
  272.  
  273.     interp->result = Tcl_Concat(argc-1, argv+1);
  274.     interp->dynamic = 1;
  275.     return TCL_OK;
  276. }
  277.  
  278. /*
  279.  *----------------------------------------------------------------------
  280.  *
  281.  * Tcl_ContinueCmd --
  282.  *
  283.  *    This procedure is invoked to process the "continue" Tcl command.
  284.  *    See the user documentation for details on what it does.
  285.  *
  286.  * Results:
  287.  *    A standard Tcl result.
  288.  *
  289.  * Side effects:
  290.  *    See the user documentation.
  291.  *
  292.  *----------------------------------------------------------------------
  293.  */
  294.  
  295.     /* ARGSUSED */
  296. int
  297. Tcl_ContinueCmd(dummy, interp, argc, argv)
  298.     ClientData dummy;            /* Not used. */
  299.     Tcl_Interp *interp;            /* Current interpreter. */
  300.     int argc;                /* Number of arguments. */
  301.     char **argv;            /* Argument strings. */
  302. {
  303.     if (argc != 1) {
  304.     sprintf(interp->result, "too many args: should be \"%.50s\"", argv[0]);
  305.     return TCL_ERROR;
  306.     }
  307.     return TCL_CONTINUE;
  308. }
  309.  
  310. /*
  311.  *----------------------------------------------------------------------
  312.  *
  313.  * Tcl_ErrorCmd --
  314.  *
  315.  *    This procedure is invoked to process the "error" Tcl command.
  316.  *    See the user documentation for details on what it does.
  317.  *
  318.  * Results:
  319.  *    A standard Tcl result.
  320.  *
  321.  * Side effects:
  322.  *    See the user documentation.
  323.  *
  324.  *----------------------------------------------------------------------
  325.  */
  326.  
  327.     /* ARGSUSED */
  328. int
  329. Tcl_ErrorCmd(dummy, interp, argc, argv)
  330.     ClientData dummy;            /* Not used. */
  331.     Tcl_Interp *interp;            /* Current interpreter. */
  332.     int argc;                /* Number of arguments. */
  333.     char **argv;            /* Argument strings. */
  334. {
  335.     if (argc != 2) {
  336.     sprintf(interp->result, "wrong # args: should be \"%.50s message\"",
  337.         argv[0]);
  338.     return TCL_ERROR;
  339.     }
  340.     Tcl_Return(interp, argv[1], TCL_VOLATILE);
  341.     return TCL_ERROR;
  342. }
  343.  
  344. /*
  345.  *----------------------------------------------------------------------
  346.  *
  347.  * Tcl_EvalCmd --
  348.  *
  349.  *    This procedure is invoked to process the "eval" Tcl command.
  350.  *    See the user documentation for details on what it does.
  351.  *
  352.  * Results:
  353.  *    A standard Tcl result.
  354.  *
  355.  * Side effects:
  356.  *    See the user documentation.
  357.  *
  358.  *----------------------------------------------------------------------
  359.  */
  360.  
  361.     /* ARGSUSED */
  362. int
  363. Tcl_EvalCmd(dummy, interp, argc, argv)
  364.     ClientData dummy;            /* Not used. */
  365.     Tcl_Interp *interp;            /* Current interpreter. */
  366.     int argc;                /* Number of arguments. */
  367.     char **argv;            /* Argument strings. */
  368. {
  369.     int result;
  370.     char *cmd;
  371.  
  372.     if (argc < 2) {
  373.     return TCL_OK;
  374.     }
  375.     if (argc == 2) {
  376.     result = Tcl_Eval(interp, argv[1], 0, (char **) NULL);
  377.     } else {
  378.     
  379.     /*
  380.      * More than one argument:  concatenate them together with spaces
  381.      * between, then evaluate the result.
  382.      */
  383.     
  384.     cmd = Tcl_Concat(argc-1, argv+1);
  385.     result = Tcl_Eval(interp, cmd, 0, (char **) NULL);
  386.     ckfree(cmd);
  387.     }
  388.     if (result == TCL_ERROR) {
  389.     char msg[60];
  390.     sprintf(msg, " (\"eval\" body line %d)", interp->errorLine);
  391.     Tcl_AddErrorInfo(interp, msg);
  392.     }
  393.     return result;
  394. }
  395.  
  396. /*
  397.  *----------------------------------------------------------------------
  398.  *
  399.  * Tcl_ExecCmd --
  400.  *
  401.  *    This procedure is invoked to process the "exec" Tcl command.
  402.  *    See the user documentation for details on what it does.
  403.  *
  404.  * Results:
  405.  *    A standard Tcl result.
  406.  *
  407.  * Side effects:
  408.  *    See the user documentation.
  409.  *
  410.  *----------------------------------------------------------------------
  411.  */
  412.  
  413.     /* ARGSUSED */
  414. int
  415. Tcl_ExecCmd(dummy, interp, argc, argv)
  416.     ClientData dummy;            /* Not used. */
  417.     Tcl_Interp *interp;            /* Current interpreter. */
  418.     int argc;                /* Number of arguments. */
  419.     char **argv;            /* Argument strings. */
  420. {
  421.     char *input = NULL;            /* Standard input for child. */
  422.     char *output = NULL;        /* Output received from child. */
  423.     int outputSize;            /* Number of valid bytes at output. */
  424.     int outputSpace;            /* Total space available at output. */
  425.     int stdIn, stdOut[2], count, result, i, deadPid, maxID;
  426.     int pid = -1;            /* -1 means child process doesn't
  427.                      * exist (yet).  Non-zero gives its
  428.                      * id. 0 only in child. */
  429.     WAIT status;
  430.     char *cmdName;
  431.  
  432.     /*
  433.      * Look through the arguments for a standard input specification
  434.      * ("< value" in two arguments).  If found, collapse it out.
  435.      * Shuffle all the arguments back over the "exec" argument, so that
  436.      * there's room for a NULL argument at the end.
  437.      */
  438.  
  439.     cmdName = argv[0];
  440.     for (i = 1; i < argc; i++) {
  441.     argv[i-1] = argv[i];
  442.     if ((argv[i][0] != '<') || (argv[i][1] != 0)) {
  443.         continue;
  444.     }
  445.     i++;
  446.     if (i >= argc) {
  447.         sprintf(interp->result,
  448.             "specified \"<\" but no input in \"%.50s\" command",
  449.             cmdName);
  450.         return TCL_ERROR;
  451.     }
  452.     input = argv[i];
  453.     for (i++; i < argc; i++) {
  454.         argv[i-3] = argv[i];
  455.     }
  456.     argc -= 2;
  457.     }
  458.  
  459.     argc -= 1;            /* Drop "exec" argument. */
  460.     argv[argc] = NULL;
  461.     if (argc < 1) {
  462.     sprintf(interp->result, "not enough arguments to \"%.50s\" command",
  463.         cmdName);
  464.     return TCL_ERROR;
  465.     }
  466.  
  467.     /*
  468.      * Create pipes for standard standard output/error, and
  469.      * start up the new process.
  470.      */
  471.  
  472.     stdIn = -1;
  473.     stdOut[0] = stdOut[1] = -1;
  474.     if (pipe(stdOut) < 0) {
  475.     sprintf(interp->result, "couldn't create pipe for \"%.50s\" command",
  476.         cmdName);
  477.     result = TCL_ERROR;
  478.     goto cleanup;
  479.     }
  480.  
  481.     /*
  482.      * To avoid hassles, I'm creating a temp file for the input string,
  483.      * automatically deleted (invsible). I hope /tmp isn't a network
  484.      * mount :->.
  485.      */
  486.     if(input) {
  487.     static char tmp[sizeof TMPFILENAME];
  488.     strcpy(tmp, TMPFILENAME);
  489.     mktemp(tmp);
  490.     if((stdIn = open(tmp, O_RDWR|O_CREAT, 0)) == -1) {
  491.         sprintf(interp->result,
  492.             "couldn't make temp file for \"%.50s\" command: %.50s",
  493.             cmdName, strerror(errno));
  494.         result = TCL_ERROR;
  495.         goto cleanup;
  496.     }
  497.     write(stdIn, input, strlen(input));
  498.     lseek(stdIn, 0L, 0);
  499.     unlink(tmp);
  500.     }
  501.  
  502.     pid = fork();
  503.     if (pid == -1) {
  504.     sprintf(interp->result,
  505.         "couldn't fork child for \"%.50s\" command: %.50s",
  506.         cmdName, strerror(errno));
  507.     result = TCL_ERROR;
  508.     goto cleanup;
  509.     }
  510.     if (pid == 0) {
  511.     char errSpace[100];
  512.  
  513.     if (( (stdIn != -1) && (dup2(stdIn, 0) == -1) )
  514.        || (dup2(stdOut[1], 1) == -1) || (dup2(stdOut[1], 2) == -1)) {
  515.         char *err;
  516.         err = "forked process couldn't set up input/output";
  517.         write(stdOut[1], err, strlen(err));
  518.         _exit(1);
  519.     }
  520.     if(stdIn != -1)
  521.         close(stdIn);
  522.     close(stdOut[0]);
  523.     close(stdOut[1]);
  524.     execvp(argv[0], argv);
  525.     sprintf(errSpace, "couldn't find a \"%.50s\" to execute", argv[0]);
  526.     write(1, errSpace, strlen(errSpace));
  527.     _exit(1);
  528.     }
  529.  
  530.     if(stdIn != -1)
  531.     close(stdIn);
  532.     stdIn = -1;
  533.     close(stdOut[1]);
  534.     stdOut[1] = -1;
  535.     /*
  536.      * In the parent, arrange to be signalled when the child dies, then
  537.      * funnel input and output to/from the process.
  538.      */
  539.  
  540.     outputSize = 0;
  541.     outputSpace = 0;
  542.  
  543.     result = -1;
  544.     while (1) {
  545.     if ((outputSpace - outputSize) < 100) {
  546.         char *newOutput;
  547.     
  548.         if (outputSpace == 0) {
  549.             outputSpace = 200;
  550.         } else {
  551.             outputSpace = 2*outputSpace;
  552.         }
  553.         newOutput = (char *) ckalloc((unsigned) outputSpace);
  554.         if (output != 0) {
  555.             bcopy(output, newOutput, outputSize);
  556.             ckfree(output);
  557.         }
  558.         output = newOutput;
  559.     }
  560.  
  561.     count = read(stdOut[0], output+outputSize,
  562.         outputSpace-outputSize-1);
  563.  
  564.     if (count == 0)
  565.         break;
  566.     if (count < 0) {
  567.         sprintf(interp->result,
  568.         "error reading stdout during \"%.50s\": %.50s",
  569.         cmdName, strerror(errno));
  570.         result = TCL_ERROR;
  571.         goto cleanup;
  572.     } else {
  573.         outputSize += count;
  574.     }
  575.     }
  576.     output[outputSize] = 0;
  577.     interp->result = output;
  578.     interp->dynamic = 1;
  579.  
  580. cleanup:
  581.     if(pid != -1) {
  582.         while(wait(&status) != pid)
  583.         fprintf(stderr, "Whoa!\n");
  584.     if(status&0xFF)
  585.         result = -1;
  586.     else
  587.         result = (status&0xFF) >> 8;
  588.     }
  589.     if (stdIn != -1) {
  590.     close(stdIn);
  591.     }
  592.     if (stdOut[0] != -1) {
  593.     close(stdOut[0]);
  594.     }
  595.     if (stdOut[1] != -1) {
  596.     close(stdOut[1]);
  597.     }
  598.     return result;
  599. }
  600.  
  601. /*
  602.  * Variable for communication between Tcl_ShellCmd and ShellHandlerProc:
  603.  * non-zero means a signal has arrived.
  604.  */
  605.  
  606. int execSignalled;
  607.  
  608. /*
  609.  * Procedure to receive signals during "exec" command:  just return.
  610.  */
  611.  
  612. void
  613. ExecHandlerProc()
  614. {
  615.     execSignalled = 1;
  616.     return;
  617. }
  618.  
  619. /*
  620.  *----------------------------------------------------------------------
  621.  *
  622.  * Tcl_ExprCmd --
  623.  *
  624.  *    This procedure is invoked to process the "expr" Tcl command.
  625.  *    See the user documentation for details on what it does.
  626.  *
  627.  * Results:
  628.  *    A standard Tcl result.
  629.  *
  630.  * Side effects:
  631.  *    See the user documentation.
  632.  *
  633.  *----------------------------------------------------------------------
  634.  */
  635.  
  636.     /* ARGSUSED */
  637. int
  638. Tcl_ExprCmd(dummy, interp, argc, argv)
  639.     ClientData dummy;            /* Not used. */
  640.     Tcl_Interp *interp;            /* Current interpreter. */
  641.     int argc;                /* Number of arguments. */
  642.     char **argv;            /* Argument strings. */
  643. {
  644.     int result, value;
  645.  
  646.     if (argc != 2) {
  647.     sprintf(interp->result,
  648.         "wrong # args: should be \"%.50s expression\"", argv[0]);
  649.     return TCL_ERROR;
  650.     }
  651.  
  652.     result = Tcl_Expr(interp, argv[1], &value);
  653.     if (result != TCL_OK) {
  654.     return result;
  655.     }
  656.  
  657.     /*
  658.      * Turn the integer result back into a string.
  659.      */
  660.  
  661.     sprintf(interp->result, "%d", value);
  662.     return TCL_OK;
  663. }
  664.  
  665. /*
  666.  *----------------------------------------------------------------------
  667.  *
  668.  * Tcl_FileCmd --
  669.  *
  670.  *    This procedure is invoked to process the "file" Tcl command.
  671.  *    See the user documentation for details on what it does.
  672.  *
  673.  * Results:
  674.  *    A standard Tcl result.
  675.  *
  676.  * Side effects:
  677.  *    See the user documentation.
  678.  *
  679.  *----------------------------------------------------------------------
  680.  */
  681.  
  682.     /* ARGSUSED */
  683. int
  684. Tcl_FileCmd(dummy, interp, argc, argv)
  685.     ClientData dummy;            /* Not used. */
  686.     Tcl_Interp *interp;            /* Current interpreter. */
  687.     int argc;                /* Number of arguments. */
  688.     char **argv;            /* Argument strings. */
  689. {
  690.     char *p;
  691.     int length, mode, statOp;
  692.     struct stat statBuf;
  693.  
  694.     if (argc != 3) {
  695.     sprintf(interp->result,
  696.         "wrong # args: should be \"%.50s name option\"", argv[0]);
  697.     return TCL_ERROR;
  698.     }
  699.     length = strlen(argv[2]);
  700.  
  701.     /*
  702.      * First handle operations on the file name.
  703.      */
  704.  
  705.     if ((argv[2][0] == 'd') && (strncmp(argv[2], "dirname", length) == 0)) {
  706.     p = strrchr(argv[1], '/');
  707.     if (p == NULL) {
  708.         interp->result = ".";
  709.     } else if (p == argv[1]) {
  710.         interp->result = "/";
  711.     } else {
  712.         *p = 0;
  713.         Tcl_Return(interp, argv[1], TCL_VOLATILE);
  714.         *p = '/';
  715.     }
  716.     return TCL_OK;
  717.     } else if ((argv[2][0] == 'r') && (length >= 2)
  718.         && (strncmp(argv[2], "rootname", length) == 0)) {
  719.     p = strrchr(argv[1], '.');
  720.     if (p == NULL) {
  721.         Tcl_Return(interp, argv[1], TCL_VOLATILE);
  722.     } else {
  723.         *p = 0;
  724.         Tcl_Return(interp, argv[1], TCL_VOLATILE);
  725.         *p = '.';
  726.     }
  727.     return TCL_OK;
  728.     } else if ((argv[2][0] == 'e') && (length >= 3)
  729.         && (strncmp(argv[2], "extension", length) == 0)) {
  730.     p = strrchr(argv[1], '.');
  731.     if (p != NULL) {
  732.         Tcl_Return(interp, p, TCL_VOLATILE);
  733.     }
  734.     return TCL_OK;
  735.     } else if ((argv[2][0] == 't') && (strncmp(argv[2], "tail", length) == 0)) {
  736.     p = strrchr(argv[1], '/');
  737.     if (p != NULL) {
  738.         Tcl_Return(interp, p+1, TCL_VOLATILE);
  739.     } else {
  740.         Tcl_Return(interp, argv[1], TCL_VOLATILE);
  741.     }
  742.     return TCL_OK;
  743.     }
  744.  
  745.     /*
  746.      * Next, handle operations that can be satisfied with the "access"
  747.      * kernel call.
  748.      */
  749.  
  750.     if ((argv[2][0] == 'r') && (length >= 2)
  751.         && (strncmp(argv[2], "readable", length) == 0)) {
  752.     mode = R_OK;
  753.     checkAccess:
  754.     if (access(argv[1], mode) == -1) {
  755.         interp->result = "0";
  756.     } else {
  757.         interp->result = "1";
  758.     }
  759.     return TCL_OK;
  760.     } else if ((argv[2][0] == 'w')
  761.         && (strncmp(argv[2], "writable", length) == 0)) {
  762.     mode = W_OK;
  763.     goto checkAccess;
  764.     } else if ((argv[2][0] == 'e') && (length >= 3)
  765.         && (strncmp(argv[2], "executable", length) == 0)) {
  766.     mode = X_OK;
  767.     goto checkAccess;
  768.     } else if ((argv[2][0] == 'e') && (length >= 3)
  769.         && (strncmp(argv[2], "exists", length) == 0)) {
  770.     mode = F_OK;
  771.     goto checkAccess;
  772.     }
  773.  
  774.     /*
  775.      * Lastly, check stuff that requires the file to be stat-ed.
  776.      */
  777.  
  778.     if ((argv[2][0] == 'o') && (strncmp(argv[2], "owned", length) == 0)) {
  779.     statOp = 0;
  780.     } else if ((argv[2][0] == 'i') && (length >= 3)
  781.         && (strncmp(argv[2], "isfile", length) == 0)) {
  782.     statOp = 1;
  783.     } else if ((argv[2][0] == 'i') && (length >= 3)
  784.         && (strncmp(argv[2], "isdirectory", length) == 0)) {
  785.     statOp = 2;
  786.     } else {
  787.     sprintf(interp->result, "bad \"%.30s\" option \"%.30s\": must be dirname, executable, exists, extension, isdirectory, isfile, owned, readable, root, tail, or writable",
  788.         argv[0], argv[2]);
  789.     return TCL_ERROR;
  790.     }
  791.     if (stat(argv[1], &statBuf) == -1) {
  792.     interp->result = "0";
  793.     return TCL_OK;
  794.     }
  795.     switch (statOp) {
  796.     case 0:
  797.         mode = (geteuid() == statBuf.st_uid);
  798.         break;
  799.     case 1:
  800.         mode = (statBuf.st_mode & S_IFMT) == S_IFREG;
  801.         break;
  802.     case 2:
  803.         mode = (statBuf.st_mode & S_IFMT) == S_IFDIR;
  804.         break;
  805.     }
  806.     if (mode) {
  807.     interp->result = "1";
  808.     } else {
  809.     interp->result = "0";
  810.     }
  811.     return TCL_OK;
  812. }
  813.  
  814. /*
  815.  *----------------------------------------------------------------------
  816.  *
  817.  * Tcl_ForCmd --
  818.  *
  819.  *    This procedure is invoked to process the "for" Tcl command.
  820.  *    See the user documentation for details on what it does.
  821.  *
  822.  * Results:
  823.  *    A standard Tcl result.
  824.  *
  825.  * Side effects:
  826.  *    See the user documentation.
  827.  *
  828.  *----------------------------------------------------------------------
  829.  */
  830.  
  831.     /* ARGSUSED */
  832. int
  833. Tcl_ForCmd(dummy, interp, argc, argv)
  834.     ClientData dummy;            /* Not used. */
  835.     Tcl_Interp *interp;            /* Current interpreter. */
  836.     int argc;                /* Number of arguments. */
  837.     char **argv;            /* Argument strings. */
  838. {
  839.     int result, value;
  840.  
  841.     if (argc != 5) {
  842.     sprintf(interp->result,
  843.         "wrong # args: should be \"%.50s start test next command\"",
  844.         argv[0]);
  845.     return TCL_ERROR;
  846.     }
  847.  
  848.     result = Tcl_Eval(interp, argv[1], 0, (char **) NULL);
  849.     if (result != TCL_OK) {
  850.     if (result == TCL_ERROR) {
  851.         Tcl_AddErrorInfo(interp, " (\"for\" initial command)");
  852.     }
  853.     return result;
  854.     }
  855.     while (1) {
  856.     result = Tcl_Expr(interp, argv[2], &value);
  857.     if (result != TCL_OK) {
  858.         return result;
  859.     }
  860.     if (!value) {
  861.         break;
  862.     }
  863.     result = Tcl_Eval(interp, argv[4], 0, (char **) NULL);
  864.     if (result == TCL_CONTINUE) {
  865.         result = TCL_OK;
  866.     } else if (result != TCL_OK) {
  867.         if (result == TCL_ERROR) {
  868.         char msg[60];
  869.         sprintf(msg, " (\"for\" body line %d)", interp->errorLine);
  870.         Tcl_AddErrorInfo(interp, msg);
  871.         }
  872.         break;
  873.     }
  874.     result = Tcl_Eval(interp, argv[3], 0, (char **) NULL);
  875.     if (result == TCL_BREAK) {
  876.         break;
  877.     } else if (result != TCL_OK) {
  878.         if (result == TCL_ERROR) {
  879.         Tcl_AddErrorInfo(interp, " (\"for\" loop-end command)");
  880.         }
  881.         return result;
  882.     }
  883.     }
  884.     if (result == TCL_BREAK) {
  885.     result = TCL_OK;
  886.     }
  887.     if (result == TCL_OK) {
  888.     Tcl_Return(interp, (char *) NULL, TCL_STATIC);
  889.     }
  890.     return result;
  891. }
  892.  
  893. /*
  894.  *----------------------------------------------------------------------
  895.  *
  896.  * Tcl_ForeachCmd --
  897.  *
  898.  *    This procedure is invoked to process the "foreach" Tcl command.
  899.  *    See the user documentation for details on what it does.
  900.  *
  901.  * Results:
  902.  *    A standard Tcl result.
  903.  *
  904.  * Side effects:
  905.  *    See the user documentation.
  906.  *
  907.  *----------------------------------------------------------------------
  908.  */
  909.  
  910.     /* ARGSUSED */
  911. int
  912. Tcl_ForeachCmd(dummy, interp, argc, argv)
  913.     ClientData dummy;            /* Not used. */
  914.     Tcl_Interp *interp;            /* Current interpreter. */
  915.     int argc;                /* Number of arguments. */
  916.     char **argv;            /* Argument strings. */
  917. {
  918.     int listArgc, i, result;
  919.     char **listArgv;
  920.  
  921.     if (argc != 4) {
  922.     sprintf(interp->result,
  923.         "wrong # args: should be \"%.50s varName list command\"",
  924.         argv[0]);
  925.     return TCL_ERROR;
  926.     }
  927.  
  928.     /*
  929.      * Break the list up into elements, and execute the command once
  930.      * for each value of the element.
  931.      */
  932.  
  933.     result = Tcl_SplitList(interp, argv[2], &listArgc, &listArgv);
  934.     if (result != TCL_OK) {
  935.     return result;
  936.     }
  937.     for (i = 0; i < listArgc; i++) {
  938.     Tcl_SetVar(interp, argv[1], listArgv[i], 0);
  939.  
  940.     result = Tcl_Eval(interp, argv[3], 0, (char **) NULL);
  941.     if (result != TCL_OK) {
  942.         if (result == TCL_CONTINUE) {
  943.         result = TCL_OK;
  944.         } else if (result == TCL_BREAK) {
  945.         result = TCL_OK;
  946.         break;
  947.         } else if (result == TCL_ERROR) {
  948.         char msg[100];
  949.         sprintf(msg, " (\"foreach\" body line %d)", interp->errorLine);
  950.         Tcl_AddErrorInfo(interp, msg);
  951.         break;
  952.         } else {
  953.         break;
  954.         }
  955.     }
  956.     }
  957.     ckfree((char *) listArgv);
  958.     if (result == TCL_OK) {
  959.     Tcl_Return(interp, (char *) NULL, TCL_STATIC);
  960.     }
  961.     return result;
  962. }
  963.  
  964. /*
  965.  *----------------------------------------------------------------------
  966.  *
  967.  * Tcl_FormatCmd --
  968.  *
  969.  *    This procedure is invoked to process the "format" Tcl command.
  970.  *    See the user documentation for details on what it does.
  971.  *
  972.  * Results:
  973.  *    A standard Tcl result.
  974.  *
  975.  * Side effects:
  976.  *    See the user documentation.
  977.  *
  978.  *----------------------------------------------------------------------
  979.  */
  980.  
  981.     /* ARGSUSED */
  982. int
  983. Tcl_FormatCmd(dummy, interp, argc, argv)
  984.     ClientData dummy;            /* Not used. */
  985.     Tcl_Interp *interp;            /* Current interpreter. */
  986.     int argc;                /* Number of arguments. */
  987.     char **argv;            /* Argument strings. */
  988. {
  989.     register char *format;    /* Used to read characters from the format
  990.                  * string. */
  991.     char newFormat[40];        /* A new format specifier is generated here. */
  992.     int width;            /* Field width from field specifier, or 0 if
  993.                  * no width given. */
  994.     int precision;        /* Field precision from field specifier, or 0
  995.                  * if no precision given. */
  996.     int size;            /* Number of bytes needed for result of
  997.                  * conversion, based on type of conversion
  998.                  * ("e", "s", etc.) and width from above. */
  999.     char *oneWordValue;        /* Used to hold value to pass to sprintf, if
  1000.                  * it's a one-word value. */
  1001.     double twoWordValue;    /* Used to hold value to pass to sprintf if
  1002.                  * it's a two-word value. */
  1003.     int useTwoWords;        /* 0 means use oneWordValue, 1 means use
  1004.                  * twoWordValue. */
  1005.     char *dst = interp->result;    /* Where result is stored.  Starts off at
  1006.                  * interp->resultSpace, but may get dynamically
  1007.                  * re-allocated if this isn't enough. */
  1008.     int dstSize = 0;        /* Number of non-null characters currently
  1009.                  * stored at dst. */
  1010.     int dstSpace = TCL_RESULT_SIZE;
  1011.                 /* Total amount of storage space available
  1012.                  * in dst (not including null terminator. */
  1013.     int noPercent;        /* Special case for speed:  indicates there's
  1014.                  * no field specifier, just a string to copy. */
  1015.     char **curArg;        /* Remainder of argv array. */
  1016.  
  1017.     /*
  1018.      * This procedure is a bit nasty.  The goal is to use sprintf to
  1019.      * do most of the dirty work.  There are several problems:
  1020.      * 1. this procedure can't trust its arguments.
  1021.      * 2. we must be able to provide a large enough result area to hold
  1022.      *    whatever's generated.  This is hard to estimate.
  1023.      * 2. there's no way to move the arguments from argv to the call
  1024.      *    to sprintf in a reasonable way.  This is particularly nasty
  1025.      *    because some of the arguments may be two-word values (doubles).
  1026.      * So, what happens here is to scan the format string one % group
  1027.      * at a time, making many individual calls to sprintf.
  1028.      */
  1029.  
  1030.     if (argc < 2) {
  1031.     sprintf(interp->result,
  1032.         "too few args: should be \"%.50s formatString arg arg ...\"",
  1033.         argv[0]);
  1034.     return TCL_ERROR;
  1035.     }
  1036.     curArg = argv+2;
  1037.     argc -= 2;
  1038.     for (format = argv[1]; *format != 0; ) {
  1039.     register char *newPtr = newFormat;
  1040.  
  1041.     width = precision = useTwoWords = noPercent = 0;
  1042.  
  1043.     /*
  1044.      * Get rid of any characters before the next field specifier.
  1045.      * Collapse backslash sequences found along the way.
  1046.      */
  1047.  
  1048.     if (*format != '%') {
  1049.         register char *p;
  1050.         int bsSize;
  1051.  
  1052.         oneWordValue = format;
  1053.         for (p = format; (*format != '%') && (*format != 0); p++) {
  1054.         if (*format == '\\') {
  1055.             *p = Tcl_Backslash(format, &bsSize);
  1056.             format += bsSize;
  1057.         } else {
  1058.             *p = *format;
  1059.             format++;
  1060.         }
  1061.         }
  1062.         size = p - oneWordValue;
  1063.         noPercent = 1;
  1064.         goto doField;
  1065.     }
  1066.  
  1067.     if (format[1] == '%') {
  1068.         oneWordValue = format;
  1069.         size = 1;
  1070.         noPercent = 1;
  1071.         format += 2;
  1072.         goto doField;
  1073.     }
  1074.  
  1075.     /*
  1076.      * Parse off a field specifier, compute how many characters
  1077.      * will be needed to store the result, and substitute for
  1078.      * "*" size specifiers.
  1079.      */
  1080.  
  1081.     *newPtr = '%';
  1082.     newPtr++;
  1083.     format++;
  1084.     if (*format == '-') {
  1085.         *newPtr = '-';
  1086.         newPtr++;
  1087.         format++;
  1088.     }
  1089.     if (*format == '0') {
  1090.         *newPtr = '0';
  1091.         newPtr++;
  1092.         format++;
  1093.     }
  1094.     if (isdigit(*format)) {
  1095.         width = atoi(format);
  1096.         do {
  1097.         format++;
  1098.         } while (isdigit(*format));
  1099.     } else if (*format == '*') {
  1100.         if (argc <= 0) {
  1101.         goto notEnoughArgs;
  1102.         }
  1103.         width = atoi(*curArg);
  1104.         argc--;
  1105.         curArg++;
  1106.         format++;
  1107.     }
  1108.     if (width != 0) {
  1109.         sprintf(newPtr, "%d", width);
  1110.         while (*newPtr != 0) {
  1111.         newPtr++;
  1112.         }
  1113.     }
  1114.     if (*format == '.') {
  1115.         *newPtr = '.';
  1116.         newPtr++;
  1117.         format++;
  1118.     }
  1119.     if (isdigit(*format)) {
  1120.         precision = atoi(format);
  1121.         do {
  1122.         format++;
  1123.         } while (isdigit(*format));
  1124.     } else if (*format == '*') {
  1125.         if (argc <= 0) {
  1126.         goto notEnoughArgs;
  1127.         }
  1128.         precision = atoi(*curArg);
  1129.         argc--;
  1130.         curArg++;
  1131.         format++;
  1132.     }
  1133.     if (precision != 0) {
  1134.         sprintf(newPtr, "%d", precision);
  1135.         while (*newPtr != 0) {
  1136.         newPtr++;
  1137.         }
  1138.     }
  1139.     if (*format == '#') {
  1140.         *newPtr = '#';
  1141.         newPtr++;
  1142.         format++;
  1143.     }
  1144.     if (*format == 'l') {
  1145.         format++;
  1146.     }
  1147.     *newPtr = *format;
  1148.     newPtr++;
  1149.     *newPtr = 0;
  1150.     if (argc <= 0) {
  1151.         goto notEnoughArgs;
  1152.     }
  1153.     switch (*format) {
  1154.         case 'D':
  1155.         case 'd':
  1156.         case 'O':
  1157.         case 'o':
  1158.         case 'X':
  1159.         case 'x':
  1160.         case 'U':
  1161.         case 'u': {
  1162.         char *end;
  1163.  
  1164.         oneWordValue = (char *) strtol(*curArg, &end, 0);
  1165.         if ((*curArg == 0) || (*end != 0)) {
  1166.             sprintf(interp->result,
  1167.                 "expected integer but got \"%.50s\" instead",
  1168.                 *curArg);
  1169.             goto fmtError;
  1170.         }
  1171.         size = 40;
  1172.         break;
  1173.         }
  1174.         case 's':
  1175.         oneWordValue = *curArg;
  1176.         size = strlen(*curArg);
  1177.         break;
  1178.         case 'c': {
  1179.         char *end;
  1180.  
  1181.         oneWordValue = (char *) strtol(*curArg, &end, 0);
  1182.         if ((*curArg == 0) || (*end != 0)) {
  1183.             sprintf(interp->result,
  1184.                 "expected integer but got \"%.50s\" instead",
  1185.                 *curArg);
  1186.             goto fmtError;
  1187.         }
  1188.         size = 1;
  1189.         break;
  1190.         }
  1191.         case 'F':
  1192.         case 'f':
  1193.         case 'E':
  1194.         case 'e':
  1195.         case 'G':
  1196.         case 'g':
  1197.         if (sscanf(*curArg, "%F", &twoWordValue) != 1) {
  1198.             sprintf(interp->result,
  1199.                 "expected floating-point number but got \"%.50s\" instead",
  1200.                 *curArg);
  1201.             goto fmtError;
  1202.         }
  1203.         useTwoWords = 1;
  1204.         size = 320;
  1205.         if (precision > 10) {
  1206.             size += precision;
  1207.         }
  1208.         break;
  1209.         case 0:
  1210.         interp->result = "format string ended in middle of field specifier";
  1211.         goto fmtError;
  1212.         default:
  1213.         sprintf(interp->result, "bad field specifier \"%c\"", *format);
  1214.         goto fmtError;
  1215.     }
  1216.     argc--;
  1217.     curArg++;
  1218.     format++;
  1219.  
  1220.     /*
  1221.      * Make sure that there's enough space to hold the formatted
  1222.      * result, then format it.
  1223.      */
  1224.  
  1225.     doField:
  1226.     if (width > size) {
  1227.         size = width;
  1228.     }
  1229.     if ((dstSize + size) > dstSpace) {
  1230.         char *newDst;
  1231.         int newSpace;
  1232.  
  1233.         newSpace = 2*(dstSize + size);
  1234.         newDst = (char *) ckalloc((unsigned) newSpace+1);
  1235.         if (dstSize != 0) {
  1236.         bcopy(dst, newDst, dstSize);
  1237.         }
  1238.         if (dstSpace != TCL_RESULT_SIZE) {
  1239.         ckfree(dst);
  1240.         }
  1241.         dst = newDst;
  1242.         dstSpace = newSpace;
  1243.     }
  1244.     if (noPercent) {
  1245.         bcopy(oneWordValue, dst+dstSize, size);
  1246.         dstSize += size;
  1247.         dst[dstSize] = 0;
  1248.     } else {
  1249.         if (useTwoWords) {
  1250.         sprintf(dst+dstSize, newFormat, twoWordValue);
  1251.         } else {
  1252.         sprintf(dst+dstSize, newFormat, oneWordValue);
  1253.         }
  1254.         dstSize += strlen(dst+dstSize);
  1255.     }
  1256.     }
  1257.  
  1258.     interp->result = dst;
  1259.     interp->dynamic = !(dstSpace == TCL_RESULT_SIZE);
  1260.     return TCL_OK;
  1261.  
  1262.     notEnoughArgs:
  1263.     sprintf(interp->result,
  1264.         "invoked \"%.50s\" without enough arguments", argv[0]);
  1265.     fmtError:
  1266.     if (dstSpace != TCL_RESULT_SIZE) {
  1267.     ckfree(dst);
  1268.     }
  1269.     return TCL_ERROR;
  1270. }
  1271.  
  1272. #ifdef GNU
  1273. /*
  1274.  * ----------------------------------------------------------------------------
  1275.  *
  1276.  * Tcl_GlobCmd --
  1277.  *
  1278.  *      Expands a pattern in a directory using csh rules.
  1279.  *    
  1280.  * Results:
  1281.  *    A standard Tcl result.
  1282.  *
  1283.  * Side effects:
  1284.  *      See the user documentation.
  1285.  *
  1286.  * ----------------------------------------------------------------------------
  1287.  */
  1288.  
  1289.      /* ARGSUSED */
  1290. int
  1291. Tcl_GlobCmd(dummy, interp, argc, argv)
  1292.     ClientData dummy;                   /* Not used. */
  1293.     Tcl_Interp *interp;                 /* Current interpreter. */
  1294.     int argc;                           /* Number of arguments. */
  1295.     char **argv;                        /* Argument strings. */
  1296. {
  1297.     if (argc == 1) {
  1298.     return TCL_OK;
  1299.     }
  1300.  
  1301.     return Tcl_Glob(interp, argc, argv);
  1302. }
  1303. #endif
  1304.