home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / tkisrc04.zip / tcl / os2 / tclCmdAH.c < prev    next >
C/C++ Source or Header  |  1998-08-07  |  44KB  |  1,680 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 (c) 1987-1993 The Regents of the University of California.
  9.  * Copyright (c) 1994-1996 Sun Microsystems, Inc.
  10.  *
  11.  * See the file "license.terms" for information on usage and redistribution
  12.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  13.  *
  14.  * SCCS: @(#) tclCmdAH.c 1.107 96/04/09 17:14:39
  15.  */
  16.  
  17. #include "tclInt.h"
  18. #include "tclPort.h"
  19.  
  20. /*
  21.  * Prototypes for local procedures defined in this file:
  22.  */
  23.  
  24. static char *        GetTypeFromMode _ANSI_ARGS_((int mode));
  25. static int        StoreStatData _ANSI_ARGS_((Tcl_Interp *interp,
  26.                 char *varName, struct stat *statPtr));
  27.  
  28. /*
  29.  *----------------------------------------------------------------------
  30.  *
  31.  * Tcl_BreakCmd --
  32.  *
  33.  *    This procedure is invoked to process the "break" Tcl command.
  34.  *    See the user documentation for details on what it does.
  35.  *
  36.  * Results:
  37.  *    A standard Tcl result.
  38.  *
  39.  * Side effects:
  40.  *    See the user documentation.
  41.  *
  42.  *----------------------------------------------------------------------
  43.  */
  44.  
  45.     /* ARGSUSED */
  46. int
  47. Tcl_BreakCmd(dummy, interp, argc, argv)
  48.     ClientData dummy;            /* Not used. */
  49.     Tcl_Interp *interp;            /* Current interpreter. */
  50.     int argc;                /* Number of arguments. */
  51.     char **argv;            /* Argument strings. */
  52. {
  53.     if (argc != 1) {
  54.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  55.         argv[0], "\"", (char *) NULL);
  56.     return TCL_ERROR;
  57.     }
  58.     return TCL_BREAK;
  59. }
  60.  
  61. /*
  62.  *----------------------------------------------------------------------
  63.  *
  64.  * Tcl_CaseCmd --
  65.  *
  66.  *    This procedure is invoked to process the "case" Tcl command.
  67.  *    See the user documentation for details on what it does.
  68.  *
  69.  * Results:
  70.  *    A standard Tcl result.
  71.  *
  72.  * Side effects:
  73.  *    See the user documentation.
  74.  *
  75.  *----------------------------------------------------------------------
  76.  */
  77.  
  78.     /* ARGSUSED */
  79. int
  80. Tcl_CaseCmd(dummy, interp, argc, argv)
  81.     ClientData dummy;            /* Not used. */
  82.     Tcl_Interp *interp;            /* Current interpreter. */
  83.     int argc;                /* Number of arguments. */
  84.     char **argv;            /* Argument strings. */
  85. {
  86.     int i, result;
  87.     int body;
  88.     char *string;
  89.     int caseArgc, splitArgs;
  90.     char **caseArgv;
  91.  
  92.     if (argc < 3) {
  93.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  94.         argv[0], " string ?in? patList body ... ?default body?\"",
  95.         (char *) NULL);
  96.     return TCL_ERROR;
  97.     }
  98.     string = argv[1];
  99.     body = -1;
  100.     if (strcmp(argv[2], "in") == 0) {
  101.     i = 3;
  102.     } else {
  103.     i = 2;
  104.     }
  105.     caseArgc = argc - i;
  106.     caseArgv = argv + i;
  107.  
  108.     /*
  109.      * If all of the pattern/command pairs are lumped into a single
  110.      * argument, split them out again.
  111.      */
  112.  
  113.     splitArgs = 0;
  114.     if (caseArgc == 1) {
  115.     result = Tcl_SplitList(interp, caseArgv[0], &caseArgc, &caseArgv);
  116.     if (result != TCL_OK) {
  117.         return result;
  118.     }
  119.     splitArgs = 1;
  120.     }
  121.  
  122.     for (i = 0; i < caseArgc; i += 2) {
  123.     int patArgc, j;
  124.     char **patArgv;
  125.     register char *p;
  126.  
  127.     if (i == (caseArgc-1)) {
  128.         interp->result = "extra case pattern with no body";
  129.         result = TCL_ERROR;
  130.         goto cleanup;
  131.     }
  132.  
  133.     /*
  134.      * Check for special case of single pattern (no list) with
  135.      * no backslash sequences.
  136.      */
  137.  
  138.     for (p = caseArgv[i]; *p != 0; p++) {
  139.         if (isspace(UCHAR(*p)) || (*p == '\\')) {
  140.         break;
  141.         }
  142.     }
  143.     if (*p == 0) {
  144.         if ((*caseArgv[i] == 'd')
  145.             && (strcmp(caseArgv[i], "default") == 0)) {
  146.         body = i+1;
  147.         }
  148.         if (Tcl_StringMatch(string, caseArgv[i])) {
  149.         body = i+1;
  150.         goto match;
  151.         }
  152.         continue;
  153.     }
  154.  
  155.     /*
  156.      * Break up pattern lists, then check each of the patterns
  157.      * in the list.
  158.      */
  159.  
  160.     result = Tcl_SplitList(interp, caseArgv[i], &patArgc, &patArgv);
  161.     if (result != TCL_OK) {
  162.         goto cleanup;
  163.     }
  164.     for (j = 0; j < patArgc; j++) {
  165.         if (Tcl_StringMatch(string, patArgv[j])) {
  166.         body = i+1;
  167.         break;
  168.         }
  169.     }
  170.     ckfree((char *) patArgv);
  171.     if (j < patArgc) {
  172.         break;
  173.     }
  174.     }
  175.  
  176.     match:
  177.     if (body != -1) {
  178.     result = Tcl_Eval(interp, caseArgv[body]);
  179.     if (result == TCL_ERROR) {
  180.         char msg[100];
  181.         sprintf(msg, "\n    (\"%.50s\" arm line %d)", caseArgv[body-1],
  182.             interp->errorLine);
  183.         Tcl_AddErrorInfo(interp, msg);
  184.     }
  185.     goto cleanup;
  186.     }
  187.  
  188.     /*
  189.      * Nothing matched:  return nothing.
  190.      */
  191.  
  192.     result = TCL_OK;
  193.  
  194.     cleanup:
  195.     if (splitArgs) {
  196.     ckfree((char *) caseArgv);
  197.     }
  198.     return result;
  199. }
  200.  
  201. /*
  202.  *----------------------------------------------------------------------
  203.  *
  204.  * Tcl_CatchCmd --
  205.  *
  206.  *    This procedure is invoked to process the "catch" Tcl command.
  207.  *    See the user documentation for details on what it does.
  208.  *
  209.  * Results:
  210.  *    A standard Tcl result.
  211.  *
  212.  * Side effects:
  213.  *    See the user documentation.
  214.  *
  215.  *----------------------------------------------------------------------
  216.  */
  217.  
  218.     /* ARGSUSED */
  219. int
  220. Tcl_CatchCmd(dummy, interp, argc, argv)
  221.     ClientData dummy;            /* Not used. */
  222.     Tcl_Interp *interp;            /* Current interpreter. */
  223.     int argc;                /* Number of arguments. */
  224.     char **argv;            /* Argument strings. */
  225. {
  226.     int result;
  227.  
  228.     if ((argc != 2) && (argc != 3)) {
  229.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  230.         argv[0], " command ?varName?\"", (char *) NULL);
  231.     return TCL_ERROR;
  232.     }
  233.     result = Tcl_Eval(interp, argv[1]);
  234.     if (argc == 3) {
  235.     if (Tcl_SetVar(interp, argv[2], interp->result, 0) == NULL) {
  236.         Tcl_SetResult(interp, "couldn't save command result in variable",
  237.             TCL_STATIC);
  238.         return TCL_ERROR;
  239.     }
  240.     }
  241.     Tcl_ResetResult(interp);
  242.     sprintf(interp->result, "%d", result);
  243.     return TCL_OK;
  244. }
  245.  
  246. /*
  247.  *----------------------------------------------------------------------
  248.  *
  249.  * Tcl_CdCmd --
  250.  *
  251.  *    This procedure is invoked to process the "cd" Tcl command.
  252.  *    See the user documentation for details on what it does.
  253.  *
  254.  * Results:
  255.  *    A standard Tcl result.
  256.  *
  257.  * Side effects:
  258.  *    See the user documentation.
  259.  *
  260.  *----------------------------------------------------------------------
  261.  */
  262.  
  263.     /* ARGSUSED */
  264. int
  265. Tcl_CdCmd(dummy, interp, argc, argv)
  266.     ClientData dummy;            /* Not used. */
  267.     Tcl_Interp *interp;            /* Current interpreter. */
  268.     int argc;                /* Number of arguments. */
  269.     char **argv;            /* Argument strings. */
  270. {
  271.     char *dirName;
  272.     Tcl_DString buffer;
  273.     int result;
  274.  
  275.     if (argc > 2) {
  276.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  277.         " dirName\"", (char *) NULL);
  278.     return TCL_ERROR;
  279.     }
  280.  
  281.     if (argc == 2) {
  282.     dirName = argv[1];
  283.     } else {
  284.     dirName = "~";
  285.     }
  286.     dirName = Tcl_TranslateFileName(interp, dirName, &buffer);
  287.     if (dirName == NULL) {
  288.     return TCL_ERROR;
  289.     }
  290.     result = TclChdir(interp, dirName);
  291.     Tcl_DStringFree(&buffer);
  292.     return result;
  293. }
  294.  
  295. /*
  296.  *----------------------------------------------------------------------
  297.  *
  298.  * Tcl_ConcatCmd --
  299.  *
  300.  *    This procedure is invoked to process the "concat" Tcl command.
  301.  *    See the user documentation for details on what it does.
  302.  *
  303.  * Results:
  304.  *    A standard Tcl result.
  305.  *
  306.  * Side effects:
  307.  *    See the user documentation.
  308.  *
  309.  *----------------------------------------------------------------------
  310.  */
  311.  
  312.     /* ARGSUSED */
  313. int
  314. Tcl_ConcatCmd(dummy, interp, argc, argv)
  315.     ClientData dummy;            /* Not used. */
  316.     Tcl_Interp *interp;            /* Current interpreter. */
  317.     int argc;                /* Number of arguments. */
  318.     char **argv;            /* Argument strings. */
  319. {
  320.     if (argc >= 2) {
  321.     interp->result = Tcl_Concat(argc-1, argv+1);
  322.     interp->freeProc = TCL_DYNAMIC;
  323.     }
  324.     return TCL_OK;
  325. }
  326.  
  327. /*
  328.  *----------------------------------------------------------------------
  329.  *
  330.  * Tcl_ContinueCmd --
  331.  *
  332.  *    This procedure is invoked to process the "continue" Tcl command.
  333.  *    See the user documentation for details on what it does.
  334.  *
  335.  * Results:
  336.  *    A standard Tcl result.
  337.  *
  338.  * Side effects:
  339.  *    See the user documentation.
  340.  *
  341.  *----------------------------------------------------------------------
  342.  */
  343.  
  344.     /* ARGSUSED */
  345. int
  346. Tcl_ContinueCmd(dummy, interp, argc, argv)
  347.     ClientData dummy;            /* Not used. */
  348.     Tcl_Interp *interp;            /* Current interpreter. */
  349.     int argc;                /* Number of arguments. */
  350.     char **argv;            /* Argument strings. */
  351. {
  352.     if (argc != 1) {
  353.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  354.         "\"", (char *) NULL);
  355.     return TCL_ERROR;
  356.     }
  357.     return TCL_CONTINUE;
  358. }
  359.  
  360. /*
  361.  *----------------------------------------------------------------------
  362.  *
  363.  * Tcl_ErrorCmd --
  364.  *
  365.  *    This procedure is invoked to process the "error" Tcl command.
  366.  *    See the user documentation for details on what it does.
  367.  *
  368.  * Results:
  369.  *    A standard Tcl result.
  370.  *
  371.  * Side effects:
  372.  *    See the user documentation.
  373.  *
  374.  *----------------------------------------------------------------------
  375.  */
  376.  
  377.     /* ARGSUSED */
  378. int
  379. Tcl_ErrorCmd(dummy, interp, argc, argv)
  380.     ClientData dummy;            /* Not used. */
  381.     Tcl_Interp *interp;            /* Current interpreter. */
  382.     int argc;                /* Number of arguments. */
  383.     char **argv;            /* Argument strings. */
  384. {
  385.     Interp *iPtr = (Interp *) interp;
  386.  
  387.     if ((argc < 2) || (argc > 4)) {
  388.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  389.         " message ?errorInfo? ?errorCode?\"", (char *) NULL);
  390.     return TCL_ERROR;
  391.     }
  392.     if ((argc >= 3) && (argv[2][0] != 0)) {
  393.     Tcl_AddErrorInfo(interp, argv[2]);
  394.     iPtr->flags |= ERR_ALREADY_LOGGED;
  395.     }
  396.     if (argc == 4) {
  397.     Tcl_SetVar2(interp, "errorCode", (char *) NULL, argv[3],
  398.         TCL_GLOBAL_ONLY);
  399.     iPtr->flags |= ERROR_CODE_SET;
  400.     }
  401.     Tcl_SetResult(interp, argv[1], TCL_VOLATILE);
  402.     return TCL_ERROR;
  403. }
  404.  
  405. /*
  406.  *----------------------------------------------------------------------
  407.  *
  408.  * Tcl_EvalCmd --
  409.  *
  410.  *    This procedure is invoked to process the "eval" Tcl command.
  411.  *    See the user documentation for details on what it does.
  412.  *
  413.  * Results:
  414.  *    A standard Tcl result.
  415.  *
  416.  * Side effects:
  417.  *    See the user documentation.
  418.  *
  419.  *----------------------------------------------------------------------
  420.  */
  421.  
  422.     /* ARGSUSED */
  423. int
  424. Tcl_EvalCmd(dummy, interp, argc, argv)
  425.     ClientData dummy;            /* Not used. */
  426.     Tcl_Interp *interp;            /* Current interpreter. */
  427.     int argc;                /* Number of arguments. */
  428.     char **argv;            /* Argument strings. */
  429. {
  430.     int result;
  431.     char *cmd;
  432.  
  433.     if (argc < 2) {
  434.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  435.         " arg ?arg ...?\"", (char *) NULL);
  436.     return TCL_ERROR;
  437.     }
  438.     if (argc == 2) {
  439.     result = Tcl_Eval(interp, argv[1]);
  440.     } else {
  441.     
  442.     /*
  443.      * More than one argument:  concatenate them together with spaces
  444.      * between, then evaluate the result.
  445.      */
  446.     
  447.     cmd = Tcl_Concat(argc-1, argv+1);
  448.     result = Tcl_Eval(interp, cmd);
  449.     ckfree(cmd);
  450.     }
  451.     if (result == TCL_ERROR) {
  452.     char msg[60];
  453.     sprintf(msg, "\n    (\"eval\" body line %d)", interp->errorLine);
  454.     Tcl_AddErrorInfo(interp, msg);
  455.     }
  456.     return result;
  457. }
  458.  
  459. /*
  460.  *----------------------------------------------------------------------
  461.  *
  462.  * Tcl_ExitCmd --
  463.  *
  464.  *    This procedure is invoked to process the "exit" Tcl command.
  465.  *    See the user documentation for details on what it does.
  466.  *
  467.  * Results:
  468.  *    A standard Tcl result.
  469.  *
  470.  * Side effects:
  471.  *    See the user documentation.
  472.  *
  473.  *----------------------------------------------------------------------
  474.  */
  475.  
  476.     /* ARGSUSED */
  477. int
  478. Tcl_ExitCmd(dummy, interp, argc, argv)
  479.     ClientData dummy;            /* Not used. */
  480.     Tcl_Interp *interp;            /* Current interpreter. */
  481.     int argc;                /* Number of arguments. */
  482.     char **argv;            /* Argument strings. */
  483. {
  484.     int value;
  485.  
  486.     if ((argc != 1) && (argc != 2)) {
  487.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  488.         " ?returnCode?\"", (char *) NULL);
  489.     return TCL_ERROR;
  490.     }
  491.     if (argc == 1) {
  492.     value = 0;
  493.     } else if (Tcl_GetInt(interp, argv[1], &value) != TCL_OK) {
  494.     return TCL_ERROR;
  495.     }
  496.     Tcl_Exit(value);
  497.     /*NOTREACHED*/
  498.     return TCL_OK;            /* Better not ever reach this! */
  499. }
  500.  
  501. /*
  502.  *----------------------------------------------------------------------
  503.  *
  504.  * Tcl_ExprCmd --
  505.  *
  506.  *    This procedure is invoked to process the "expr" Tcl command.
  507.  *    See the user documentation for details on what it does.
  508.  *
  509.  * Results:
  510.  *    A standard Tcl result.
  511.  *
  512.  * Side effects:
  513.  *    See the user documentation.
  514.  *
  515.  *----------------------------------------------------------------------
  516.  */
  517.  
  518.     /* ARGSUSED */
  519. int
  520. Tcl_ExprCmd(dummy, interp, argc, argv)
  521.     ClientData dummy;            /* Not used. */
  522.     Tcl_Interp *interp;            /* Current interpreter. */
  523.     int argc;                /* Number of arguments. */
  524.     char **argv;            /* Argument strings. */
  525. {
  526.     Tcl_DString buffer;
  527.     int i, result;
  528.  
  529.     if (argc < 2) {
  530.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  531.         " arg ?arg ...?\"", (char *) NULL);
  532.     return TCL_ERROR;
  533.     }
  534.  
  535.     if (argc == 2) {
  536.     return Tcl_ExprString(interp, argv[1]);
  537.     }
  538.     Tcl_DStringInit(&buffer);
  539.     Tcl_DStringAppend(&buffer, argv[1], -1);
  540.     for (i = 2; i < argc; i++) {
  541.     Tcl_DStringAppend(&buffer, " ", 1);
  542.     Tcl_DStringAppend(&buffer, argv[i], -1);
  543.     }
  544.     result = Tcl_ExprString(interp, buffer.string);
  545.     Tcl_DStringFree(&buffer);
  546.     return result;
  547. }
  548.  
  549. /*
  550.  *----------------------------------------------------------------------
  551.  *
  552.  * Tcl_FileCmd --
  553.  *
  554.  *    This procedure is invoked to process the "file" Tcl command.
  555.  *    See the user documentation for details on what it does.
  556.  *
  557.  * Results:
  558.  *    A standard Tcl result.
  559.  *
  560.  * Side effects:
  561.  *    See the user documentation.
  562.  *
  563.  *----------------------------------------------------------------------
  564.  */
  565.  
  566.     /* ARGSUSED */
  567. int
  568. Tcl_FileCmd(dummy, interp, argc, argv)
  569.     ClientData dummy;            /* Not used. */
  570.     Tcl_Interp *interp;            /* Current interpreter. */
  571.     int argc;                /* Number of arguments. */
  572.     char **argv;            /* Argument strings. */
  573. {
  574.     char *fileName, *extension;
  575.     int c, statOp, result;
  576.     size_t length;
  577.     int mode = 0;            /* Initialized only to prevent
  578.                      * compiler warning message. */
  579.     struct stat statBuf;
  580.     Tcl_DString buffer;
  581.  
  582.     if (argc < 3) {
  583.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  584.         " option name ?arg ...?\"", (char *) NULL);
  585.     return TCL_ERROR;
  586.     }
  587.     c = argv[1][0];
  588.     length = strlen(argv[1]);
  589.     result = TCL_OK;
  590.     Tcl_DStringInit(&buffer);
  591.  
  592.     /*
  593.      * First handle operations on the file name.
  594.      */
  595.  
  596.     if ((c == 'd') && (strncmp(argv[1], "dirname", length) == 0)) {
  597.     int pargc;
  598.     char **pargv;
  599.  
  600.     if (argc != 3) {
  601.         argv[1] = "dirname";
  602.         goto not3Args;
  603.     }
  604.  
  605.     fileName = argv[2];
  606.  
  607.     /*
  608.      * If there is only one element, and it starts with a tilde,
  609.      * perform tilde substitution and resplit the path.
  610.      */
  611.  
  612.     Tcl_SplitPath(fileName, &pargc, &pargv);
  613.     if ((pargc == 1) && (*fileName == '~')) {
  614.         ckfree((char*) pargv);
  615.         fileName = Tcl_TranslateFileName(interp, fileName, &buffer);
  616.         if (fileName == NULL) {
  617.         result = TCL_ERROR;
  618.         goto done;
  619.         }
  620.         Tcl_SplitPath(fileName, &pargc, &pargv);
  621.         Tcl_DStringSetLength(&buffer, 0);
  622.     }
  623.  
  624.     /*
  625.      * Return all but the last component.  If there is only one
  626.      * component, return it if the path was non-relative, otherwise
  627.      * return the current directory.
  628.      */
  629.  
  630.     if (pargc > 1) {
  631.         Tcl_JoinPath(pargc-1, pargv, &buffer);
  632.         Tcl_DStringResult(interp, &buffer);
  633.     } else if ((pargc == 0)
  634.         || (Tcl_GetPathType(pargv[0]) == TCL_PATH_RELATIVE)) {
  635.         Tcl_SetResult(interp,
  636.             (tclPlatform == TCL_PLATFORM_MAC) ? ":" : ".", TCL_STATIC);
  637.     } else {
  638.         Tcl_SetResult(interp, pargv[0], TCL_VOLATILE);
  639.     }
  640.     ckfree((char *)pargv);
  641.     goto done;
  642.  
  643.     } else if ((c == 't') && (strncmp(argv[1], "tail", length) == 0)
  644.     && (length >= 2)) {
  645.     int pargc;
  646.     char **pargv;
  647.  
  648.     if (argc != 3) {
  649.         argv[1] = "tail";
  650.         goto not3Args;
  651.     }
  652.  
  653.     Tcl_SplitPath(argv[2], &pargc, &pargv);
  654.     if (pargc > 0) {
  655.         if ((pargc > 1)
  656.             || (Tcl_GetPathType(pargv[0]) == TCL_PATH_RELATIVE)) {
  657.         Tcl_SetResult(interp, pargv[pargc-1], TCL_VOLATILE);
  658.         }
  659.     }
  660.     ckfree((char *)pargv);
  661.     goto done;
  662.  
  663.     } else if ((c == 'r') && (strncmp(argv[1], "rootname", length) == 0)
  664.         && (length >= 2)) {
  665.     char tmp;
  666.     if (argc != 3) {
  667.         argv[1] = "rootname";
  668.         goto not3Args;
  669.     }
  670.     extension = TclGetExtension(argv[2]);
  671.     if (extension == NULL) {
  672.         Tcl_SetResult(interp, argv[2], TCL_VOLATILE);
  673.     } else {
  674.         tmp = *extension;
  675.         *extension = 0;
  676.         Tcl_SetResult(interp, argv[2], TCL_VOLATILE);
  677.         *extension = tmp;
  678.     }
  679.     goto done;
  680.     } else if ((c == 'e') && (strncmp(argv[1], "extension", length) == 0)
  681.         && (length >= 3)) {
  682.     if (argc != 3) {
  683.         argv[1] = "extension";
  684.         goto not3Args;
  685.     }
  686.     extension = TclGetExtension(argv[2]);
  687.  
  688.     if (extension != NULL) {
  689.         Tcl_SetResult(interp, extension, TCL_VOLATILE);
  690.     }
  691.     goto done;
  692.     } else if ((c == 'p') && (strncmp(argv[1], "pathtype", length) == 0)) {
  693.     if (argc != 3) {
  694.         argv[1] = "pathtype";
  695.         goto not3Args;
  696.     }
  697.     switch (Tcl_GetPathType(argv[2])) {
  698.         case TCL_PATH_ABSOLUTE:
  699.         Tcl_SetResult(interp, "absolute", TCL_STATIC);
  700.         break;
  701.         case TCL_PATH_RELATIVE:
  702.         Tcl_SetResult(interp, "relative", TCL_STATIC);
  703.         break;
  704.         case TCL_PATH_VOLUME_RELATIVE:
  705.         Tcl_SetResult(interp, "volumerelative", TCL_STATIC);
  706.         break;
  707.     }
  708.     goto done;
  709.     } else if ((c == 's') && (strncmp(argv[1], "split", length) == 0)
  710.     && (length >= 2)) {
  711.     int pargc, i;
  712.     char **pargvList;
  713.  
  714.     if (argc != 3) {
  715.         argv[1] = "split";
  716.         goto not3Args;
  717.     }
  718.  
  719.     Tcl_SplitPath(argv[2], &pargc, &pargvList);
  720.     for (i = 0; i < pargc; i++) {
  721.         Tcl_AppendElement(interp, pargvList[i]);
  722.     }
  723.     ckfree((char *) pargvList);
  724.     goto done;
  725.     } else if ((c == 'j') && (strncmp(argv[1], "join", length) == 0)) {
  726.     Tcl_JoinPath(argc-2, argv+2, &buffer);
  727.     Tcl_DStringResult(interp, &buffer);
  728.     goto done;
  729.     }
  730.  
  731.     /*
  732.      * Next, handle operations that can be satisfied with the "access"
  733.      * kernel call.
  734.      */
  735.  
  736.     fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
  737.     if (fileName == NULL) {
  738.     result = TCL_ERROR;
  739.     goto done;
  740.     }
  741.     if ((c == 'r') && (strncmp(argv[1], "readable", length) == 0)
  742.         && (length >= 5)) {
  743.     if (argc != 3) {
  744.         argv[1] = "readable";
  745.         goto not3Args;
  746.     }
  747.     mode = R_OK;
  748.     checkAccess:
  749.     if (access(fileName, mode) == -1) {
  750.         interp->result = "0";
  751.     } else {
  752.         interp->result = "1";
  753.     }
  754.     goto done;
  755.     } else if ((c == 'w') && (strncmp(argv[1], "writable", length) == 0)) {
  756.     if (argc != 3) {
  757.         argv[1] = "writable";
  758.         goto not3Args;
  759.     }
  760.     mode = W_OK;
  761.     goto checkAccess;
  762.     } else if ((c == 'e') && (strncmp(argv[1], "executable", length) == 0)
  763.         && (length >= 3)) {
  764.     if (argc != 3) {
  765.         argv[1] = "executable";
  766.         goto not3Args;
  767.     }
  768.     mode = X_OK;
  769.     goto checkAccess;
  770.     } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0)
  771.         && (length >= 3)) {
  772.     if (argc != 3) {
  773.         argv[1] = "exists";
  774.         goto not3Args;
  775.     }
  776.     mode = F_OK;
  777.     goto checkAccess;
  778.     }
  779.  
  780.     /*
  781.      * Lastly, check stuff that requires the file to be stat-ed.
  782.      */
  783.  
  784.     if ((c == 'a') && (strncmp(argv[1], "atime", length) == 0)) {
  785.     if (argc != 3) {
  786.         argv[1] = "atime";
  787.         goto not3Args;
  788.     }
  789.     if (stat(fileName, &statBuf) == -1) {
  790.         goto badStat;
  791.     }
  792.     sprintf(interp->result, "%ld", (long) statBuf.st_atime);
  793.     goto done;
  794.     } else if ((c == 'i') && (strncmp(argv[1], "isdirectory", length) == 0)
  795.         && (length >= 3)) {
  796.     if (argc != 3) {
  797.         argv[1] = "isdirectory";
  798.         goto not3Args;
  799.     }
  800.     statOp = 2;
  801.     } else if ((c == 'i') && (strncmp(argv[1], "isfile", length) == 0)
  802.         && (length >= 3)) {
  803.     if (argc != 3) {
  804.         argv[1] = "isfile";
  805.         goto not3Args;
  806.     }
  807.     statOp = 1;
  808.     } else if ((c == 'l') && (strncmp(argv[1], "lstat", length) == 0)) {
  809.     if (argc != 4) {
  810.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  811.             " lstat name varName\"", (char *) NULL);
  812.         result = TCL_ERROR;
  813.         goto done;
  814.     }
  815.  
  816.     if (lstat(fileName, &statBuf) == -1) {
  817.         Tcl_AppendResult(interp, "couldn't lstat \"", argv[2],
  818.             "\": ", Tcl_PosixError(interp), (char *) NULL);
  819.         result = TCL_ERROR;
  820.         goto done;
  821.     }
  822.     result = StoreStatData(interp, argv[3], &statBuf);
  823.     goto done;
  824.     } else if ((c == 'm') && (strncmp(argv[1], "mtime", length) == 0)) {
  825.     if (argc != 3) {
  826.         argv[1] = "mtime";
  827.         goto not3Args;
  828.     }
  829.     if (stat(fileName, &statBuf) == -1) {
  830.         goto badStat;
  831.     }
  832.     sprintf(interp->result, "%ld", (long) statBuf.st_mtime);
  833.     goto done;
  834.     } else if ((c == 'o') && (strncmp(argv[1], "owned", length) == 0)) {
  835.     if (argc != 3) {
  836.         argv[1] = "owned";
  837.         goto not3Args;
  838.     }
  839.     statOp = 0;
  840.     } else if ((c == 'r') && (strncmp(argv[1], "readlink", length) == 0)
  841.         && (length >= 5)) {
  842.     char linkValue[MAXPATHLEN+1];
  843.     int linkLength;
  844.  
  845.     if (argc != 3) {
  846.         argv[1] = "readlink";
  847.         goto not3Args;
  848.     }
  849.  
  850.     /*
  851.      * If S_IFLNK isn't defined it means that the machine doesn't
  852.      * support symbolic links, so the file can't possibly be a
  853.      * symbolic link.  Generate an EINVAL error, which is what
  854.      * happens on machines that do support symbolic links when
  855.      * you invoke readlink on a file that isn't a symbolic link.
  856.      */
  857.  
  858. #ifndef S_IFLNK
  859.     linkLength = -1;
  860.     errno = EINVAL;
  861. #else
  862.     linkLength = readlink(fileName, linkValue, sizeof(linkValue) - 1);
  863. #endif /* S_IFLNK */
  864.     if (linkLength == -1) {
  865.         Tcl_AppendResult(interp, "couldn't readlink \"", argv[2],
  866.             "\": ", Tcl_PosixError(interp), (char *) NULL);
  867.         result = TCL_ERROR;
  868.         goto done;
  869.     }
  870.     linkValue[linkLength] = 0;
  871.     Tcl_SetResult(interp, linkValue, TCL_VOLATILE);
  872.     goto done;
  873.     } else if ((c == 's') && (strncmp(argv[1], "size", length) == 0)
  874.         && (length >= 2)) {
  875.     if (argc != 3) {
  876.         argv[1] = "size";
  877.         goto not3Args;
  878.     }
  879.     if (stat(fileName, &statBuf) == -1) {
  880.         goto badStat;
  881.     }
  882.     sprintf(interp->result, "%lu", (unsigned long) statBuf.st_size);
  883.     goto done;
  884.     } else if ((c == 's') && (strncmp(argv[1], "stat", length) == 0)
  885.         && (length >= 2)) {
  886.     if (argc != 4) {
  887.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  888.             " stat name varName\"", (char *) NULL);
  889.         result = TCL_ERROR;
  890.         goto done;
  891.     }
  892.  
  893.     if (stat(fileName, &statBuf) == -1) {
  894.         badStat:
  895.         Tcl_AppendResult(interp, "couldn't stat \"", argv[2],
  896.             "\": ", Tcl_PosixError(interp), (char *) NULL);
  897.         result = TCL_ERROR;
  898.         goto done;
  899.     }
  900.     result = StoreStatData(interp, argv[3], &statBuf);
  901.     goto done;
  902.     } else if ((c == 't') && (strncmp(argv[1], "type", length) == 0)
  903.         && (length >= 2)) {
  904.     if (argc != 3) {
  905.         argv[1] = "type";
  906.         goto not3Args;
  907.     }
  908.     if (lstat(fileName, &statBuf) == -1) {
  909.         goto badStat;
  910.     }
  911.     interp->result = GetTypeFromMode((int) statBuf.st_mode);
  912.     goto done;
  913.     } else {
  914.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  915.         "\": should be atime, dirname, executable, exists, ",
  916.         "extension, isdirectory, isfile, join, ",
  917.         "lstat, mtime, owned, pathtype, readable, readlink, ",
  918.         "root, size, split, stat, tail, type, ",
  919.         "or writable",
  920.         (char *) NULL);
  921.     result = TCL_ERROR;
  922.     goto done;
  923.     }
  924.     if (stat(fileName, &statBuf) == -1) {
  925.     interp->result = "0";
  926.     goto done;
  927.     }
  928.     switch (statOp) {
  929.     case 0:
  930.         /*
  931.          * For Windows and Macintosh, there are no user ids 
  932.          * associated with a file, so we always return 1.
  933.          */
  934.  
  935. #if (defined(__WIN32__) || defined(MAC_TCL)) /*MM* add { */ \
  936.     || defined(__IBMC__) /*MM* } */
  937.         mode = 1;
  938. #else
  939.         mode = (geteuid() == statBuf.st_uid);
  940. #endif
  941.         break;
  942.     case 1:
  943.         mode = S_ISREG(statBuf.st_mode);
  944.         break;
  945.     case 2:
  946.         mode = S_ISDIR(statBuf.st_mode);
  947.         break;
  948.     }
  949.     if (mode) {
  950.     interp->result = "1";
  951.     } else {
  952.     interp->result = "0";
  953.     }
  954.  
  955.     done:
  956.     Tcl_DStringFree(&buffer);
  957.     return result;
  958.  
  959.     not3Args:
  960.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  961.         " ", argv[1], " name\"", (char *) NULL);
  962.     result = TCL_ERROR;
  963.     goto done;
  964. }
  965.  
  966. /*
  967.  *----------------------------------------------------------------------
  968.  *
  969.  * StoreStatData --
  970.  *
  971.  *    This is a utility procedure that breaks out the fields of a
  972.  *    "stat" structure and stores them in textual form into the
  973.  *    elements of an associative array.
  974.  *
  975.  * Results:
  976.  *    Returns a standard Tcl return value.  If an error occurs then
  977.  *    a message is left in interp->result.
  978.  *
  979.  * Side effects:
  980.  *    Elements of the associative array given by "varName" are modified.
  981.  *
  982.  *----------------------------------------------------------------------
  983.  */
  984.  
  985. static int
  986. StoreStatData(interp, varName, statPtr)
  987.     Tcl_Interp *interp;            /* Interpreter for error reports. */
  988.     char *varName;            /* Name of associative array variable
  989.                      * in which to store stat results. */
  990.     struct stat *statPtr;        /* Pointer to buffer containing
  991.                      * stat data to store in varName. */
  992. {
  993.     char string[30];
  994.  
  995.     sprintf(string, "%ld", (long) statPtr->st_dev);
  996.     if (Tcl_SetVar2(interp, varName, "dev", string, TCL_LEAVE_ERR_MSG)
  997.         == NULL) {
  998.     return TCL_ERROR;
  999.     }
  1000.     sprintf(string, "%ld", (long) statPtr->st_ino);
  1001.     if (Tcl_SetVar2(interp, varName, "ino", string, TCL_LEAVE_ERR_MSG)
  1002.         == NULL) {
  1003.     return TCL_ERROR;
  1004.     }
  1005.     sprintf(string, "%ld", (long) statPtr->st_mode);
  1006.     if (Tcl_SetVar2(interp, varName, "mode", string, TCL_LEAVE_ERR_MSG)
  1007.         == NULL) {
  1008.     return TCL_ERROR;
  1009.     }
  1010.     sprintf(string, "%ld", (long) statPtr->st_nlink);
  1011.     if (Tcl_SetVar2(interp, varName, "nlink", string, TCL_LEAVE_ERR_MSG)
  1012.         == NULL) {
  1013.     return TCL_ERROR;
  1014.     }
  1015.     sprintf(string, "%ld", (long) statPtr->st_uid);
  1016.     if (Tcl_SetVar2(interp, varName, "uid", string, TCL_LEAVE_ERR_MSG)
  1017.         == NULL) {
  1018.     return TCL_ERROR;
  1019.     }
  1020.     sprintf(string, "%ld", (long) statPtr->st_gid);
  1021.     if (Tcl_SetVar2(interp, varName, "gid", string, TCL_LEAVE_ERR_MSG)
  1022.         == NULL) {
  1023.     return TCL_ERROR;
  1024.     }
  1025.     sprintf(string, "%lu", (unsigned long) statPtr->st_size);
  1026.     if (Tcl_SetVar2(interp, varName, "size", string, TCL_LEAVE_ERR_MSG)
  1027.         == NULL) {
  1028.     return TCL_ERROR;
  1029.     }
  1030.     sprintf(string, "%ld", (long) statPtr->st_atime);
  1031.     if (Tcl_SetVar2(interp, varName, "atime", string, TCL_LEAVE_ERR_MSG)
  1032.         == NULL) {
  1033.     return TCL_ERROR;
  1034.     }
  1035.     sprintf(string, "%ld", (long) statPtr->st_mtime);
  1036.     if (Tcl_SetVar2(interp, varName, "mtime", string, TCL_LEAVE_ERR_MSG)
  1037.         == NULL) {
  1038.     return TCL_ERROR;
  1039.     }
  1040.     sprintf(string, "%ld", (long) statPtr->st_ctime);
  1041.     if (Tcl_SetVar2(interp, varName, "ctime", string, TCL_LEAVE_ERR_MSG)
  1042.         == NULL) {
  1043.     return TCL_ERROR;
  1044.     }
  1045.     if (Tcl_SetVar2(interp, varName, "type",
  1046.         GetTypeFromMode((int) statPtr->st_mode), TCL_LEAVE_ERR_MSG) == NULL) {
  1047.     return TCL_ERROR;
  1048.     }
  1049.     return TCL_OK;
  1050. }
  1051.  
  1052. /*
  1053.  *----------------------------------------------------------------------
  1054.  *
  1055.  * GetTypeFromMode --
  1056.  *
  1057.  *    Given a mode word, returns a string identifying the type of a
  1058.  *    file.
  1059.  *
  1060.  * Results:
  1061.  *    A static text string giving the file type from mode.
  1062.  *
  1063.  * Side effects:
  1064.  *    None.
  1065.  *
  1066.  *----------------------------------------------------------------------
  1067.  */
  1068.  
  1069. static char *
  1070. GetTypeFromMode(mode)
  1071.     int mode;
  1072. {
  1073.     if (S_ISREG(mode)) {
  1074.     return "file";
  1075.     } else if (S_ISDIR(mode)) {
  1076.     return "directory";
  1077.     } else if (S_ISCHR(mode)) {
  1078.     return "characterSpecial";
  1079.     } else if (S_ISBLK(mode)) {
  1080.     return "blockSpecial";
  1081.     } else if (S_ISFIFO(mode)) {
  1082.     return "fifo";
  1083.     } else if (S_ISLNK(mode)) {
  1084.     return "link";
  1085.     } else if (S_ISSOCK(mode)) {
  1086.     return "socket";
  1087.     }
  1088.     return "unknown";
  1089. }
  1090.  
  1091. /*
  1092.  *----------------------------------------------------------------------
  1093.  *
  1094.  * Tcl_ForCmd --
  1095.  *
  1096.  *    This procedure is invoked to process the "for" Tcl command.
  1097.  *    See the user documentation for details on what it does.
  1098.  *
  1099.  * Results:
  1100.  *    A standard Tcl result.
  1101.  *
  1102.  * Side effects:
  1103.  *    See the user documentation.
  1104.  *
  1105.  *----------------------------------------------------------------------
  1106.  */
  1107.  
  1108.     /* ARGSUSED */
  1109. int
  1110. Tcl_ForCmd(dummy, interp, argc, argv)
  1111.     ClientData dummy;            /* Not used. */
  1112.     Tcl_Interp *interp;            /* Current interpreter. */
  1113.     int argc;                /* Number of arguments. */
  1114.     char **argv;            /* Argument strings. */
  1115. {
  1116.     int result, value;
  1117.  
  1118.     if (argc != 5) {
  1119.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1120.         " start test next command\"", (char *) NULL);
  1121.     return TCL_ERROR;
  1122.     }
  1123.  
  1124.     result = Tcl_Eval(interp, argv[1]);
  1125.     if (result != TCL_OK) {
  1126.     if (result == TCL_ERROR) {
  1127.         Tcl_AddErrorInfo(interp, "\n    (\"for\" initial command)");
  1128.     }
  1129.     return result;
  1130.     }
  1131.     while (1) {
  1132.     result = Tcl_ExprBoolean(interp, argv[2], &value);
  1133.     if (result != TCL_OK) {
  1134.         return result;
  1135.     }
  1136.     if (!value) {
  1137.         break;
  1138.     }
  1139.     result = Tcl_Eval(interp, argv[4]);
  1140.     if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
  1141.         if (result == TCL_ERROR) {
  1142.         char msg[60];
  1143.         sprintf(msg, "\n    (\"for\" body line %d)", interp->errorLine);
  1144.         Tcl_AddErrorInfo(interp, msg);
  1145.         }
  1146.         break;
  1147.     }
  1148.     result = Tcl_Eval(interp, argv[3]);
  1149.     if (result == TCL_BREAK) {
  1150.         break;
  1151.     } else if (result != TCL_OK) {
  1152.         if (result == TCL_ERROR) {
  1153.         Tcl_AddErrorInfo(interp, "\n    (\"for\" loop-end command)");
  1154.         }
  1155.         return result;
  1156.     }
  1157.     }
  1158.     if (result == TCL_BREAK) {
  1159.     result = TCL_OK;
  1160.     }
  1161.     if (result == TCL_OK) {
  1162.     Tcl_ResetResult(interp);
  1163.     }
  1164.     return result;
  1165. }
  1166.  
  1167. /*
  1168.  *----------------------------------------------------------------------
  1169.  *
  1170.  * Tcl_ForeachCmd --
  1171.  *
  1172.  *    This procedure is invoked to process the "foreach" Tcl command.
  1173.  *    See the user documentation for details on what it does.
  1174.  *
  1175.  * Results:
  1176.  *    A standard Tcl result.
  1177.  *
  1178.  * Side effects:
  1179.  *    See the user documentation.
  1180.  *
  1181.  *----------------------------------------------------------------------
  1182.  */
  1183.  
  1184.     /* ARGSUSED */
  1185. int
  1186. Tcl_ForeachCmd(dummy, interp, argc, argv)
  1187.     ClientData dummy;            /* Not used. */
  1188.     Tcl_Interp *interp;            /* Current interpreter. */
  1189.     int argc;                /* Number of arguments. */
  1190.     char **argv;            /* Argument strings. */
  1191. {
  1192.     int result = TCL_OK;
  1193.     int i;            /* i selects a value list */
  1194.     int j, maxj;        /* Number of loop iterations */
  1195.     int v;            /* v selects a loop variable */
  1196.     int numLists;        /* Count of value lists */
  1197. #define STATIC_SIZE 4
  1198.     int indexArray[STATIC_SIZE];    /* Array of value list indices */
  1199.     int varcListArray[STATIC_SIZE];    /* Number of loop variables per list */
  1200.     char **varvListArray[STATIC_SIZE];    /* Array of variable name lists */
  1201.     int argcListArray[STATIC_SIZE];    /* Array of value list sizes */
  1202.     char **argvListArray[STATIC_SIZE];    /* Array of value lists */
  1203.  
  1204.     int *index = indexArray;
  1205.     int *varcList = varcListArray;
  1206.     char ***varvList = varvListArray;
  1207.     int *argcList = argcListArray;
  1208.     char ***argvList = argvListArray;
  1209.  
  1210.     if (argc < 4 || (argc%2 != 0)) {
  1211.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1212.         " varList list ?varList list ...? command\"", (char *) NULL);
  1213.     return TCL_ERROR;
  1214.     }
  1215.  
  1216.     /*
  1217.      * Manage numList parallel value lists.
  1218.      * argvList[i] is a value list counted by argcList[i]
  1219.      * varvList[i] is the list of variables associated with the value list
  1220.      * varcList[i] is the number of variables associated with the value list
  1221.      * index[i] is the current pointer into the value list argvList[i]
  1222.      */
  1223.  
  1224.     numLists = (argc-2)/2;
  1225.     if (numLists > STATIC_SIZE) {
  1226.     index = (int *) ckalloc(numLists * sizeof(int));
  1227.     varcList = (int *) ckalloc(numLists * sizeof(int));
  1228.     varvList = (char ***) ckalloc(numLists * sizeof(char **));
  1229.     argcList = (int *) ckalloc(numLists * sizeof(int));
  1230.     argvList = (char ***) ckalloc(numLists * sizeof(char **));
  1231.     }
  1232.     for (i=0 ; i<numLists ; i++) {
  1233.     index[i] = 0;
  1234.     varcList[i] = 0;
  1235.     varvList[i] = (char **)NULL;
  1236.     argcList[i] = 0;
  1237.     argvList[i] = (char **)NULL;
  1238.     }
  1239.  
  1240.     /*
  1241.      * Break up the value lists and variable lists into elements
  1242.      */
  1243.  
  1244.     maxj = 0;
  1245.     for (i=0 ; i<numLists ; i++) {
  1246.     result = Tcl_SplitList(interp, argv[1+i*2], &varcList[i], &varvList[i]);
  1247.     if (result != TCL_OK) {
  1248.         goto errorReturn;
  1249.     }
  1250.     result = Tcl_SplitList(interp, argv[2+i*2], &argcList[i], &argvList[i]);
  1251.     if (result != TCL_OK) {
  1252.         goto errorReturn;
  1253.     }
  1254.     j = argcList[i] / varcList[i];
  1255.     if ((argcList[i] % varcList[i]) != 0) {
  1256.         j++;
  1257.     }
  1258.     if (j > maxj) {
  1259.         maxj = j;
  1260.     }
  1261.     }
  1262.  
  1263.     /*
  1264.      * Iterate maxj times through the lists in parallel
  1265.      * If some value lists run out of values, set loop vars to ""
  1266.      */
  1267.     for (j = 0; j < maxj; j++) {
  1268.     for (i=0 ; i<numLists ; i++) {
  1269.         for (v=0 ; v<varcList[i] ; v++) {
  1270.         int k = index[i]++;
  1271.         char *value = "";
  1272.         if (k < argcList[i]) {
  1273.             value = argvList[i][k];
  1274.         }
  1275.         if (Tcl_SetVar(interp, varvList[i][v], value, 0) == NULL) {
  1276.             Tcl_AppendResult(interp, "couldn't set loop variable: \"",
  1277.                 varvList[i][v], "\"", (char *)NULL);
  1278.             result = TCL_ERROR;
  1279.             goto errorReturn;
  1280.         }
  1281.         }
  1282.     }
  1283.  
  1284.     result = Tcl_Eval(interp, argv[argc-1]);
  1285.     if (result != TCL_OK) {
  1286.         if (result == TCL_CONTINUE) {
  1287.         result = TCL_OK;
  1288.         } else if (result == TCL_BREAK) {
  1289.         result = TCL_OK;
  1290.         break;
  1291.         } else if (result == TCL_ERROR) {
  1292.         char msg[100];
  1293.         sprintf(msg, "\n    (\"foreach\" body line %d)",
  1294.             interp->errorLine);
  1295.         Tcl_AddErrorInfo(interp, msg);
  1296.         break;
  1297.         } else {
  1298.         break;
  1299.         }
  1300.     }
  1301.     }
  1302.     if (result == TCL_OK) {
  1303.     Tcl_ResetResult(interp);
  1304.     }
  1305. errorReturn:
  1306.     for (i=0 ; i<numLists ; i++) {
  1307.     if (argvList[i] != (char **)NULL) {
  1308.         ckfree((char *) argvList[i]);
  1309.     }
  1310.     if (varvList[i] != (char **)NULL) {
  1311.         ckfree((char *) varvList[i]);
  1312.     }
  1313.     }
  1314.     if (numLists > STATIC_SIZE) {
  1315.     ckfree((char *) index);
  1316.     ckfree((char *) varcList);
  1317.     ckfree((char *) argcList);
  1318.     ckfree((char *) varvList);
  1319.     ckfree((char *) argvList);
  1320.     }
  1321. #undef STATIC_SIZE
  1322.     return result;
  1323. }
  1324.  
  1325. /*
  1326.  *----------------------------------------------------------------------
  1327.  *
  1328.  * Tcl_FormatCmd --
  1329.  *
  1330.  *    This procedure is invoked to process the "format" Tcl command.
  1331.  *    See the user documentation for details on what it does.
  1332.  *
  1333.  * Results:
  1334.  *    A standard Tcl result.
  1335.  *
  1336.  * Side effects:
  1337.  *    See the user documentation.
  1338.  *
  1339.  *----------------------------------------------------------------------
  1340.  */
  1341.  
  1342.     /* ARGSUSED */
  1343. int
  1344. Tcl_FormatCmd(dummy, interp, argc, argv)
  1345.     ClientData dummy;            /* Not used. */
  1346.     Tcl_Interp *interp;            /* Current interpreter. */
  1347.     int argc;                /* Number of arguments. */
  1348.     char **argv;            /* Argument strings. */
  1349. {
  1350.     register char *format;    /* Used to read characters from the format
  1351.                  * string. */
  1352.     char newFormat[40];        /* A new format specifier is generated here. */
  1353.     int width;            /* Field width from field specifier, or 0 if
  1354.                  * no width given. */
  1355.     int precision;        /* Field precision from field specifier, or 0
  1356.                  * if no precision given. */
  1357.     int size;            /* Number of bytes needed for result of
  1358.                  * conversion, based on type of conversion
  1359.                  * ("e", "s", etc.), width, and precision. */
  1360.     int intValue;        /* Used to hold value to pass to sprintf, if
  1361.                  * it's a one-word integer or char value */
  1362.     char *ptrValue = NULL;    /* Used to hold value to pass to sprintf, if
  1363.                  * it's a one-word value. */
  1364.     double doubleValue;        /* Used to hold value to pass to sprintf if
  1365.                  * it's a double value. */
  1366.     int whichValue;        /* Indicates which of intValue, ptrValue,
  1367.                  * or doubleValue has the value to pass to
  1368.                  * sprintf, according to the following
  1369.                  * definitions: */
  1370. #   define INT_VALUE 0
  1371. #   define PTR_VALUE 1
  1372. #   define DOUBLE_VALUE 2
  1373.     char *dst = interp->result;    /* Where result is stored.  Starts off at
  1374.                  * interp->resultSpace, but may get dynamically
  1375.                  * re-allocated if this isn't enough. */
  1376.     int dstSize = 0;        /* Number of non-null characters currently
  1377.                  * stored at dst. */
  1378.     int dstSpace = TCL_RESULT_SIZE;
  1379.                 /* Total amount of storage space available
  1380.                  * in dst (not including null terminator. */
  1381.     int noPercent;        /* Special case for speed:  indicates there's
  1382.                  * no field specifier, just a string to copy. */
  1383.     int argIndex;        /* Index of argument to substitute next. */
  1384.     int gotXpg = 0;        /* Non-zero means that an XPG3 %n$-style
  1385.                  * specifier has been seen. */
  1386.     int gotSequential = 0;    /* Non-zero means that a regular sequential
  1387.                  * (non-XPG3) conversion specifier has been
  1388.                  * seen. */
  1389.     int useShort;        /* Value to be printed is short (half word). */
  1390.     char *end;            /* Used to locate end of numerical fields. */
  1391.  
  1392.     /*
  1393.      * This procedure is a bit nasty.  The goal is to use sprintf to
  1394.      * do most of the dirty work.  There are several problems:
  1395.      * 1. this procedure can't trust its arguments.
  1396.      * 2. we must be able to provide a large enough result area to hold
  1397.      *    whatever's generated.  This is hard to estimate.
  1398.      * 2. there's no way to move the arguments from argv to the call
  1399.      *    to sprintf in a reasonable way.  This is particularly nasty
  1400.      *    because some of the arguments may be two-word values (doubles).
  1401.      * So, what happens here is to scan the format string one % group
  1402.      * at a time, making many individual calls to sprintf.
  1403.      */
  1404.  
  1405.     if (argc < 2) {
  1406.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1407.         " formatString ?arg arg ...?\"", (char *) NULL);
  1408.     return TCL_ERROR;
  1409.     }
  1410.     argIndex = 2;
  1411.     for (format = argv[1]; *format != 0; ) {
  1412.     register char *newPtr = newFormat;
  1413.  
  1414.     width = precision = noPercent = useShort = 0;
  1415.     whichValue = PTR_VALUE;
  1416.  
  1417.     /*
  1418.      * Get rid of any characters before the next field specifier.
  1419.      */
  1420.  
  1421.     if (*format != '%') {
  1422.         register char *p;
  1423.  
  1424.         ptrValue = p = format;
  1425.         while ((*format != '%') && (*format != 0)) {
  1426.         *p = *format;
  1427.         p++;
  1428.         format++;
  1429.         }
  1430.         size = p - ptrValue;
  1431.         noPercent = 1;
  1432.         goto doField;
  1433.     }
  1434.  
  1435.     if (format[1] == '%') {
  1436.         ptrValue = format;
  1437.         size = 1;
  1438.         noPercent = 1;
  1439.         format += 2;
  1440.         goto doField;
  1441.     }
  1442.  
  1443.     /*
  1444.      * Parse off a field specifier, compute how many characters
  1445.      * will be needed to store the result, and substitute for
  1446.      * "*" size specifiers.
  1447.      */
  1448.  
  1449.     *newPtr = '%';
  1450.     newPtr++;
  1451.     format++;
  1452.     if (isdigit(UCHAR(*format))) {
  1453.         int tmp;
  1454.  
  1455.         /*
  1456.          * Check for an XPG3-style %n$ specification.  Note: there
  1457.          * must not be a mixture of XPG3 specs and non-XPG3 specs
  1458.          * in the same format string.
  1459.          */
  1460.  
  1461.         tmp = strtoul(format, &end, 10);
  1462.         if (*end != '$') {
  1463.         goto notXpg;
  1464.         }
  1465.         format = end+1;
  1466.         gotXpg = 1;
  1467.         if (gotSequential) {
  1468.         goto mixedXPG;
  1469.         }
  1470.         argIndex = tmp+1;
  1471.         if ((argIndex < 2) || (argIndex >= argc)) {
  1472.         goto badIndex;
  1473.         }
  1474.         goto xpgCheckDone;
  1475.     }
  1476.  
  1477.     notXpg:
  1478.     gotSequential = 1;
  1479.     if (gotXpg) {
  1480.         goto mixedXPG;
  1481.     }
  1482.  
  1483.     xpgCheckDone:
  1484.     while ((*format == '-') || (*format == '#') || (*format == '0')
  1485.         || (*format == ' ') || (*format == '+')) {
  1486.         *newPtr = *format;
  1487.         newPtr++;
  1488.         format++;
  1489.     }
  1490.     if (isdigit(UCHAR(*format))) {
  1491.         width = strtoul(format, &end, 10);
  1492.         format = end;
  1493.     } else if (*format == '*') {
  1494.         if (argIndex >= argc) {
  1495.         goto badIndex;
  1496.         }
  1497.         if (Tcl_GetInt(interp, argv[argIndex], &width) != TCL_OK) {
  1498.         goto fmtError;
  1499.         }
  1500.         argIndex++;
  1501.         format++;
  1502.     }
  1503.     if (width > 1000) {
  1504.         /*
  1505.          * Don't allow arbitrarily large widths:  could cause core
  1506.          * dump when we try to allocate a zillion bytes of memory
  1507.          * below.
  1508.          */
  1509.  
  1510.         width = 1000;
  1511.     } else if (width < 0) {
  1512.         width = 0;
  1513.     }
  1514.     if (width != 0) {
  1515.         sprintf(newPtr, "%d", width);
  1516.         while (*newPtr != 0) {
  1517.         newPtr++;
  1518.         }
  1519.     }
  1520.     if (*format == '.') {
  1521.         *newPtr = '.';
  1522.         newPtr++;
  1523.         format++;
  1524.     }
  1525.     if (isdigit(UCHAR(*format))) {
  1526.         precision = strtoul(format, &end, 10);
  1527.         format = end;
  1528.     } else if (*format == '*') {
  1529.         if (argIndex >= argc) {
  1530.         goto badIndex;
  1531.         }
  1532.         if (Tcl_GetInt(interp, argv[argIndex], &precision) != TCL_OK) {
  1533.         goto fmtError;
  1534.         }
  1535.         argIndex++;
  1536.         format++;
  1537.     }
  1538.     if (precision != 0) {
  1539.         sprintf(newPtr, "%d", precision);
  1540.         while (*newPtr != 0) {
  1541.         newPtr++;
  1542.         }
  1543.     }
  1544.     if (*format == 'l') {
  1545.         format++;
  1546.     } else if (*format == 'h') {
  1547.         useShort = 1;
  1548.         *newPtr = 'h';
  1549.         newPtr++;
  1550.         format++;
  1551.     }
  1552.     *newPtr = *format;
  1553.     newPtr++;
  1554.     *newPtr = 0;
  1555.     if (argIndex >= argc) {
  1556.         goto badIndex;
  1557.     }
  1558.     switch (*format) {
  1559.         case 'i':
  1560.         newPtr[-1] = 'd';
  1561.         case 'd':
  1562.         case 'o':
  1563.         case 'u':
  1564.         case 'x':
  1565.         case 'X':
  1566.         if (Tcl_GetInt(interp, argv[argIndex], (int *) &intValue)
  1567.             != TCL_OK) {
  1568.             goto fmtError;
  1569.         }
  1570.         whichValue = INT_VALUE;
  1571.         size = 40 + precision;
  1572.         break;
  1573.         case 's':
  1574.         ptrValue = argv[argIndex];
  1575.         size = strlen(argv[argIndex]);
  1576.         break;
  1577.         case 'c':
  1578.         if (Tcl_GetInt(interp, argv[argIndex], (int *) &intValue)
  1579.             != TCL_OK) {
  1580.             goto fmtError;
  1581.         }
  1582.         whichValue = INT_VALUE;
  1583.         size = 1;
  1584.         break;
  1585.         case 'e':
  1586.         case 'E':
  1587.         case 'f':
  1588.         case 'g':
  1589.         case 'G':
  1590.         if (Tcl_GetDouble(interp, argv[argIndex], &doubleValue)
  1591.             != TCL_OK) {
  1592.             goto fmtError;
  1593.         }
  1594.         whichValue = DOUBLE_VALUE;
  1595.         size = 320;
  1596.         if (precision > 10) {
  1597.             size += precision;
  1598.         }
  1599.         break;
  1600.         case 0:
  1601.         interp->result =
  1602.             "format string ended in middle of field specifier";
  1603.         goto fmtError;
  1604.         default:
  1605.         sprintf(interp->result, "bad field specifier \"%c\"", *format);
  1606.         goto fmtError;
  1607.     }
  1608.     argIndex++;
  1609.     format++;
  1610.  
  1611.     /*
  1612.      * Make sure that there's enough space to hold the formatted
  1613.      * result, then format it.
  1614.      */
  1615.  
  1616.     doField:
  1617.     if (width > size) {
  1618.         size = width;
  1619.     }
  1620.     if ((dstSize + size) > dstSpace) {
  1621.         char *newDst;
  1622.         int newSpace;
  1623.  
  1624.         newSpace = 2*(dstSize + size);
  1625.         newDst = (char *) ckalloc((unsigned) newSpace+1);
  1626.         if (dstSize != 0) {
  1627.         memcpy((VOID *) newDst, (VOID *) dst, (size_t) dstSize);
  1628.         }
  1629.         if (dstSpace != TCL_RESULT_SIZE) {
  1630.         ckfree(dst);
  1631.         }
  1632.         dst = newDst;
  1633.         dstSpace = newSpace;
  1634.     }
  1635.     if (noPercent) {
  1636.         memcpy((VOID *) (dst+dstSize), (VOID *) ptrValue, (size_t) size);
  1637.         dstSize += size;
  1638.         dst[dstSize] = 0;
  1639.     } else {
  1640.         if (whichValue == DOUBLE_VALUE) {
  1641.         sprintf(dst+dstSize, newFormat, doubleValue);
  1642.         } else if (whichValue == INT_VALUE) {
  1643.         if (useShort) {
  1644.             sprintf(dst+dstSize, newFormat, (short) intValue);
  1645.         } else {
  1646.             sprintf(dst+dstSize, newFormat, intValue);
  1647.         }
  1648.         } else {
  1649.         sprintf(dst+dstSize, newFormat, ptrValue);
  1650.         }
  1651.         dstSize += strlen(dst+dstSize);
  1652.     }
  1653.     }
  1654.  
  1655.     interp->result = dst;
  1656.     if (dstSpace != TCL_RESULT_SIZE) {
  1657.     interp->freeProc = TCL_DYNAMIC;
  1658.     } else {
  1659.     interp->freeProc = 0;
  1660.     }
  1661.     return TCL_OK;
  1662.  
  1663.     mixedXPG:
  1664.     interp->result = "cannot mix \"%\" and \"%n$\" conversion specifiers";
  1665.     goto fmtError;
  1666.  
  1667.     badIndex:
  1668.     if (gotXpg) {
  1669.     interp->result = "\"%n$\" argument index out of range";
  1670.     } else {
  1671.     interp->result = "not enough arguments for all format specifiers";
  1672.     }
  1673.  
  1674.     fmtError:
  1675.     if (dstSpace != TCL_RESULT_SIZE) {
  1676.     ckfree(dst);
  1677.     }
  1678.     return TCL_ERROR;
  1679. }
  1680.