home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / tcltk805.zip / tcl805s.zip / tcl8.0.5 / os2 / tclCmdAH.c < prev    next >
C/C++ Source or Header  |  1999-04-23  |  55KB  |  1,978 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-1997 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.159 97/10/31 13:06:07
  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.  *    With the bytecode compiler, this procedure is only called when
  37.  *    a command name is computed at runtime, and is "break" or the name
  38.  *    to which "break" was renamed: e.g., "set z break; $z"
  39.  *
  40.  * Results:
  41.  *    A standard Tcl result.
  42.  *
  43.  * Side effects:
  44.  *    See the user documentation.
  45.  *
  46.  *----------------------------------------------------------------------
  47.  */
  48.  
  49.     /* ARGSUSED */
  50. int
  51. Tcl_BreakCmd(dummy, interp, argc, argv)
  52.     ClientData dummy;            /* Not used. */
  53.     Tcl_Interp *interp;            /* Current interpreter. */
  54.     int argc;                /* Number of arguments. */
  55.     char **argv;            /* Argument strings. */
  56. {
  57.     if (argc != 1) {
  58.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  59.         argv[0], "\"", (char *) NULL);
  60.     return TCL_ERROR;
  61.     }
  62.     return TCL_BREAK;
  63. }
  64.  
  65. /*
  66.  *----------------------------------------------------------------------
  67.  *
  68.  * Tcl_CaseObjCmd --
  69.  *
  70.  *    This procedure is invoked to process the "case" Tcl command.
  71.  *    See the user documentation for details on what it does.
  72.  *
  73.  * Results:
  74.  *    A standard Tcl object result.
  75.  *
  76.  * Side effects:
  77.  *    See the user documentation.
  78.  *
  79.  *----------------------------------------------------------------------
  80.  */
  81.  
  82.     /* ARGSUSED */
  83. int
  84. Tcl_CaseObjCmd(dummy, interp, objc, objv)
  85.     ClientData dummy;        /* Not used. */
  86.     Tcl_Interp *interp;        /* Current interpreter. */
  87.     int objc;            /* Number of arguments. */
  88.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  89. {
  90.     register int i;
  91.     int body, result;
  92.     char *string, *arg;
  93.     int argLen, caseObjc;
  94.     Tcl_Obj *CONST *caseObjv;
  95.     Tcl_Obj *armPtr;
  96.  
  97.     if (objc < 3) {
  98.     Tcl_WrongNumArgs(interp, 1, objv,
  99.         "string ?in? patList body ... ?default body?");
  100.     return TCL_ERROR;
  101.     }
  102.  
  103.     /*
  104.      * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE.
  105.      */
  106.     
  107.     string = Tcl_GetStringFromObj(objv[1], &argLen);
  108.     body = -1;
  109.  
  110.     arg = Tcl_GetStringFromObj(objv[2], &argLen);
  111.     if (strcmp(arg, "in") == 0) {
  112.     i = 3;
  113.     } else {
  114.     i = 2;
  115.     }
  116.     caseObjc = objc - i;
  117.     caseObjv = objv + i;
  118.  
  119.     /*
  120.      * If all of the pattern/command pairs are lumped into a single
  121.      * argument, split them out again.
  122.      * THIS FAILS IF THE ARG'S STRING REP CONTAINS A NULL
  123.      */
  124.  
  125.     if (caseObjc == 1) {
  126.     Tcl_Obj **newObjv;
  127.     
  128.     Tcl_ListObjGetElements(interp, caseObjv[0], &caseObjc, &newObjv);
  129.     caseObjv = newObjv;
  130.     }
  131.  
  132.     for (i = 0;  i < caseObjc;  i += 2) {
  133.     int patObjc, j;
  134.     char **patObjv;
  135.     char *pat;
  136.     register char *p;
  137.  
  138.     if (i == (caseObjc-1)) {
  139.         Tcl_ResetResult(interp);
  140.         Tcl_AppendToObj(Tcl_GetObjResult(interp),
  141.                 "extra case pattern with no body", -1);
  142.         return TCL_ERROR;
  143.     }
  144.  
  145.     /*
  146.      * Check for special case of single pattern (no list) with
  147.      * no backslash sequences.
  148.      */
  149.  
  150.     pat = Tcl_GetStringFromObj(caseObjv[i], &argLen);
  151.     for (p = pat;  *p != 0;  p++) {    /* FAILS IF NULL BYTE */
  152.         if (isspace(UCHAR(*p)) || (*p == '\\')) {
  153.         break;
  154.         }
  155.     }
  156.     if (*p == 0) {
  157.         if ((*pat == 'd') && (strcmp(pat, "default") == 0)) {
  158.         body = i+1;
  159.         }
  160.         if (Tcl_StringMatch(string, pat)) {
  161.         body = i+1;
  162.         goto match;
  163.         }
  164.         continue;
  165.     }
  166.  
  167.  
  168.     /*
  169.      * Break up pattern lists, then check each of the patterns
  170.      * in the list.
  171.      */
  172.  
  173.     result = Tcl_SplitList(interp, pat, &patObjc, &patObjv);
  174.     if (result != TCL_OK) {
  175.         return result;
  176.     }
  177.     for (j = 0; j < patObjc; j++) {
  178.         if (Tcl_StringMatch(string, patObjv[j])) {
  179.         body = i+1;
  180.         break;
  181.         }
  182.     }
  183.     ckfree((char *) patObjv);
  184.     if (j < patObjc) {
  185.         break;
  186.     }
  187.     }
  188.  
  189.     match:
  190.     if (body != -1) {
  191.     armPtr = caseObjv[body-1];
  192.     result = Tcl_EvalObj(interp, caseObjv[body]);
  193.     if (result == TCL_ERROR) {
  194.         char msg[100];
  195.         
  196.         arg = Tcl_GetStringFromObj(armPtr, &argLen);
  197.         sprintf(msg, "\n    (\"%.*s\" arm line %d)", argLen, arg,
  198.                 interp->errorLine);
  199.         Tcl_AddObjErrorInfo(interp, msg, -1);
  200.     }
  201.     return result;
  202.     }
  203.  
  204.     /*
  205.      * Nothing matched: return nothing.
  206.      */
  207.  
  208.     return TCL_OK;
  209. }
  210.  
  211. /*
  212.  *----------------------------------------------------------------------
  213.  *
  214.  * Tcl_CatchObjCmd --
  215.  *
  216.  *    This object-based procedure is invoked to process the "catch" Tcl 
  217.  *    command. See the user documentation for details on what it does.
  218.  *
  219.  * Results:
  220.  *    A standard Tcl object result.
  221.  *
  222.  * Side effects:
  223.  *    See the user documentation.
  224.  *
  225.  *----------------------------------------------------------------------
  226.  */
  227.  
  228.     /* ARGSUSED */
  229. int
  230. Tcl_CatchObjCmd(dummy, interp, objc, objv)
  231.     ClientData dummy;        /* Not used. */
  232.     Tcl_Interp *interp;        /* Current interpreter. */
  233.     int objc;            /* Number of arguments. */
  234.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  235. {
  236.     Tcl_Obj *varNamePtr = NULL;
  237.     int result;
  238.  
  239.     if ((objc != 2) && (objc != 3)) {
  240.     Tcl_WrongNumArgs(interp, 1, objv, "command ?varName?");
  241.     return TCL_ERROR;
  242.     }
  243.  
  244.     /*
  245.      * Save a pointer to the variable name object, if any, in case the
  246.      * Tcl_EvalObj reallocates the bytecode interpreter's evaluation
  247.      * stack rendering objv invalid.
  248.      */
  249.     
  250.     if (objc == 3) {
  251.     varNamePtr = objv[2];
  252.     }
  253.     
  254.     result = Tcl_EvalObj(interp, objv[1]);
  255.     
  256.     if (objc == 3) {
  257.     if (Tcl_ObjSetVar2(interp, varNamePtr, NULL,
  258.             Tcl_GetObjResult(interp), TCL_PARSE_PART1) == NULL) {
  259.         Tcl_ResetResult(interp);
  260.         Tcl_AppendToObj(Tcl_GetObjResult(interp),  
  261.                 "couldn't save command result in variable", -1);
  262.         return TCL_ERROR;
  263.     }
  264.     }
  265.  
  266.     /*
  267.      * Set the interpreter's object result to an integer object holding the
  268.      * integer Tcl_EvalObj result. Note that we don't bother generating a
  269.      * string representation. We reset the interpreter's object result
  270.      * to an unshared empty object and then set it to be an integer object.
  271.      */
  272.  
  273.     Tcl_ResetResult(interp);
  274.     Tcl_SetIntObj(Tcl_GetObjResult(interp), result);
  275.     return TCL_OK;
  276. }
  277.  
  278. /*
  279.  *----------------------------------------------------------------------
  280.  *
  281.  * Tcl_CdObjCmd --
  282.  *
  283.  *    This procedure is invoked to process the "cd" 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_CdObjCmd(dummy, interp, objc, objv)
  298.     ClientData dummy;        /* Not used. */
  299.     Tcl_Interp *interp;        /* Current interpreter. */
  300.     int objc;            /* Number of arguments. */
  301.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  302. {
  303.     char *dirName;
  304.     int dirLength;
  305.     Tcl_DString buffer;
  306.     int result;
  307.  
  308.     if (objc > 2) {
  309.     Tcl_WrongNumArgs(interp, 1, objv, "dirName");
  310.     return TCL_ERROR;
  311.     }
  312.  
  313.     if (objc == 2) {
  314.     dirName = Tcl_GetStringFromObj(objv[1], &dirLength);
  315.     } else {
  316.     dirName = "~";
  317.     }
  318.     dirName = Tcl_TranslateFileName(interp, dirName, &buffer);
  319.     if (dirName == NULL) {
  320.     return TCL_ERROR;
  321.     }
  322.     result = TclChdir(interp, dirName);
  323.     Tcl_DStringFree(&buffer);
  324.     return result;
  325. }
  326.  
  327. /*
  328.  *----------------------------------------------------------------------
  329.  *
  330.  * Tcl_ConcatObjCmd --
  331.  *
  332.  *    This object-based procedure is invoked to process the "concat" Tcl
  333.  *    command. See the user documentation for details on what it does/
  334.  *
  335.  * Results:
  336.  *    A standard Tcl object result.
  337.  *
  338.  * Side effects:
  339.  *    See the user documentation.
  340.  *
  341.  *----------------------------------------------------------------------
  342.  */
  343.  
  344.     /* ARGSUSED */
  345. int
  346. Tcl_ConcatObjCmd(dummy, interp, objc, objv)
  347.     ClientData dummy;        /* Not used. */
  348.     Tcl_Interp *interp;        /* Current interpreter. */
  349.     int objc;            /* Number of arguments. */
  350.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  351. {
  352.     if (objc >= 2) {
  353.     Tcl_SetObjResult(interp, Tcl_ConcatObj(objc-1, objv+1));
  354.     }
  355.     return TCL_OK;
  356. }
  357.  
  358. /*
  359.  *----------------------------------------------------------------------
  360.  *
  361.  * Tcl_ContinueCmd -
  362.  *
  363.  *    This procedure is invoked to process the "continue" Tcl command.
  364.  *    See the user documentation for details on what it does.
  365.  *
  366.  *    With the bytecode compiler, this procedure is only called when
  367.  *    a command name is computed at runtime, and is "continue" or the name
  368.  *    to which "continue" was renamed: e.g., "set z continue; $z"
  369.  *
  370.  * Results:
  371.  *    A standard Tcl result.
  372.  *
  373.  * Side effects:
  374.  *    See the user documentation.
  375.  *
  376.  *----------------------------------------------------------------------
  377.  */
  378.  
  379.     /* ARGSUSED */
  380. int
  381. Tcl_ContinueCmd(dummy, interp, argc, argv)
  382.     ClientData dummy;            /* Not used. */
  383.     Tcl_Interp *interp;            /* Current interpreter. */
  384.     int argc;                /* Number of arguments. */
  385.     char **argv;            /* Argument strings. */
  386. {
  387.     if (argc != 1) {
  388.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  389.         "\"", (char *) NULL);
  390.     return TCL_ERROR;
  391.     }
  392.     return TCL_CONTINUE;
  393. }
  394.  
  395. /*
  396.  *----------------------------------------------------------------------
  397.  *
  398.  * Tcl_ErrorObjCmd --
  399.  *
  400.  *    This procedure is invoked to process the "error" Tcl command.
  401.  *    See the user documentation for details on what it does.
  402.  *
  403.  * Results:
  404.  *    A standard Tcl object result.
  405.  *
  406.  * Side effects:
  407.  *    See the user documentation.
  408.  *
  409.  *----------------------------------------------------------------------
  410.  */
  411.  
  412.     /* ARGSUSED */
  413. int
  414. Tcl_ErrorObjCmd(dummy, interp, objc, objv)
  415.     ClientData dummy;        /* Not used. */
  416.     Tcl_Interp *interp;        /* Current interpreter. */
  417.     int objc;            /* Number of arguments. */
  418.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  419. {
  420.     Interp *iPtr = (Interp *) interp;
  421.     register Tcl_Obj *namePtr;
  422.     char *info;
  423.     int infoLen;
  424.  
  425.     if ((objc < 2) || (objc > 4)) {
  426.     Tcl_WrongNumArgs(interp, 1, objv, "message ?errorInfo? ?errorCode?");
  427.     return TCL_ERROR;
  428.     }
  429.     
  430.     if (objc >= 3) {        /* process the optional info argument */
  431.     info = Tcl_GetStringFromObj(objv[2], &infoLen);
  432.     if (*info != 0) {
  433.         Tcl_AddObjErrorInfo(interp, info, infoLen);
  434.         iPtr->flags |= ERR_ALREADY_LOGGED;
  435.     }
  436.     }
  437.     
  438.     if (objc == 4) {
  439.     namePtr = Tcl_NewStringObj("errorCode", -1);
  440.     Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL, objv[3],
  441.         TCL_GLOBAL_ONLY);
  442.     iPtr->flags |= ERROR_CODE_SET;
  443.     Tcl_DecrRefCount(namePtr); /* we're done with name object */
  444.     }
  445.     
  446.     Tcl_SetObjResult(interp, objv[1]);
  447.     return TCL_ERROR;
  448. }
  449.  
  450. /*
  451.  *----------------------------------------------------------------------
  452.  *
  453.  * Tcl_EvalObjCmd --
  454.  *
  455.  *    This object-based procedure is invoked to process the "eval" Tcl 
  456.  *    command. See the user documentation for details on what it does.
  457.  *
  458.  * Results:
  459.  *    A standard Tcl object result.
  460.  *
  461.  * Side effects:
  462.  *    See the user documentation.
  463.  *
  464.  *----------------------------------------------------------------------
  465.  */
  466.  
  467.     /* ARGSUSED */
  468. int
  469. Tcl_EvalObjCmd(dummy, interp, objc, objv)
  470.     ClientData dummy;        /* Not used. */
  471.     Tcl_Interp *interp;        /* Current interpreter. */
  472.     int objc;            /* Number of arguments. */
  473.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  474. {
  475.     int result;
  476.     register Tcl_Obj *objPtr;
  477.  
  478.     if (objc < 2) {
  479.     Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");
  480.     return TCL_ERROR;
  481.     }
  482.     
  483.     if (objc == 2) {
  484.     result = Tcl_EvalObj(interp, objv[1]);
  485.     } else {
  486.     /*
  487.      * More than one argument: concatenate them together with spaces
  488.      * between, then evaluate the result.
  489.      */
  490.     
  491.     objPtr = Tcl_ConcatObj(objc-1, objv+1);
  492.     result = Tcl_EvalObj(interp, objPtr);
  493.     Tcl_DecrRefCount(objPtr);  /* we're done with the object */
  494.     }
  495.     if (result == TCL_ERROR) {
  496.     char msg[60];
  497.     sprintf(msg, "\n    (\"eval\" body line %d)", interp->errorLine);
  498.     Tcl_AddObjErrorInfo(interp, msg, -1);
  499.     }
  500.     return result;
  501. }
  502.  
  503. /*
  504.  *----------------------------------------------------------------------
  505.  *
  506.  * Tcl_ExitObjCmd --
  507.  *
  508.  *    This procedure is invoked to process the "exit" Tcl command.
  509.  *    See the user documentation for details on what it does.
  510.  *
  511.  * Results:
  512.  *    A standard Tcl object result.
  513.  *
  514.  * Side effects:
  515.  *    See the user documentation.
  516.  *
  517.  *----------------------------------------------------------------------
  518.  */
  519.  
  520.     /* ARGSUSED */
  521. int
  522. Tcl_ExitObjCmd(dummy, interp, objc, objv)
  523.     ClientData dummy;        /* Not used. */
  524.     Tcl_Interp *interp;        /* Current interpreter. */
  525.     int objc;            /* Number of arguments. */
  526.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  527. {
  528.     int value;
  529.  
  530.     if ((objc != 1) && (objc != 2)) {
  531.     Tcl_WrongNumArgs(interp, 1, objv, "?returnCode?");
  532.     return TCL_ERROR;
  533.     }
  534.     
  535.     if (objc == 1) {
  536.     value = 0;
  537.     } else if (Tcl_GetIntFromObj(interp, objv[1], &value) != TCL_OK) {
  538.     return TCL_ERROR;
  539.     }
  540.     Tcl_Exit(value);
  541.     /*NOTREACHED*/
  542.     return TCL_OK;            /* Better not ever reach this! */
  543. }
  544.  
  545. /*
  546.  *----------------------------------------------------------------------
  547.  *
  548.  * Tcl_ExprObjCmd --
  549.  *
  550.  *    This object-based procedure is invoked to process the "expr" Tcl
  551.  *    command. See the user documentation for details on what it does.
  552.  *
  553.  *    With the bytecode compiler, this procedure is called in two
  554.  *    circumstances: 1) to execute expr commands that are too complicated
  555.  *    or too unsafe to try compiling directly into an inline sequence of
  556.  *    instructions, and 2) to execute commands where the command name is
  557.  *    computed at runtime and is "expr" or the name to which "expr" was
  558.  *    renamed (e.g., "set z expr; $z 2+3")
  559.  *
  560.  * Results:
  561.  *    A standard Tcl object result.
  562.  *
  563.  * Side effects:
  564.  *    See the user documentation.
  565.  *
  566.  *----------------------------------------------------------------------
  567.  */
  568.  
  569.     /* ARGSUSED */
  570. int
  571. Tcl_ExprObjCmd(dummy, interp, objc, objv)
  572.     ClientData dummy;        /* Not used. */
  573.     Tcl_Interp *interp;        /* Current interpreter. */
  574.     int objc;            /* Number of arguments. */
  575.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  576. {
  577.     register Tcl_Obj *objPtr;
  578.     Tcl_Obj *resultPtr;
  579.     register char *bytes;
  580.     int length, i, result;
  581.  
  582.     if (objc < 2) {
  583.     Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");
  584.     return TCL_ERROR;
  585.     }
  586.  
  587.     if (objc == 2) {
  588.     result = Tcl_ExprObj(interp, objv[1], &resultPtr);
  589.     if (result == TCL_OK) {
  590.         Tcl_SetObjResult(interp, resultPtr);
  591.         Tcl_DecrRefCount(resultPtr);  /* done with the result object */
  592.     }
  593.     return result;
  594.     }
  595.  
  596.     /*
  597.      * Create a new object holding the concatenated argument strings.
  598.      * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE.
  599.      */
  600.  
  601.     bytes = Tcl_GetStringFromObj(objv[1], &length);
  602.     objPtr = Tcl_NewStringObj(bytes, length);
  603.     Tcl_IncrRefCount(objPtr);
  604.     for (i = 2;  i < objc;  i++) {
  605.     Tcl_AppendToObj(objPtr, " ", 1);
  606.     bytes = Tcl_GetStringFromObj(objv[i], &length);
  607.     Tcl_AppendToObj(objPtr, bytes, length);
  608.     }
  609.  
  610.     /*
  611.      * Evaluate the concatenated string object.
  612.      */
  613.  
  614.     result = Tcl_ExprObj(interp, objPtr, &resultPtr);
  615.     if (result == TCL_OK) {
  616.     Tcl_SetObjResult(interp, resultPtr);
  617.     Tcl_DecrRefCount(resultPtr);  /* done with the result object */
  618.     }
  619.  
  620.     /*
  621.      * Free allocated resources.
  622.      */
  623.     
  624.     Tcl_DecrRefCount(objPtr);
  625.     return result;
  626. }
  627.  
  628. /*
  629.  *----------------------------------------------------------------------
  630.  *
  631.  * Tcl_FileObjCmd --
  632.  *
  633.  *    This procedure is invoked to process the "file" Tcl command.
  634.  *    See the user documentation for details on what it does.
  635.  *    PLEASE NOTE THAT THIS FAILS WITH FILENAMES AND PATHS WITH
  636.  *    EMBEDDED NULLS, WHICH COULD THEORETICALLY HAPPEN ON A MAC.
  637.  *
  638.  * Results:
  639.  *    A standard Tcl result.
  640.  *
  641.  * Side effects:
  642.  *    See the user documentation.
  643.  *
  644.  *----------------------------------------------------------------------
  645.  */
  646.  
  647.     /* ARGSUSED */
  648. int
  649. Tcl_FileObjCmd(dummy, interp, objc, objv)
  650.     ClientData dummy;        /* Not used. */
  651.     Tcl_Interp *interp;        /* Current interpreter. */
  652.     int objc;            /* Number of arguments. */
  653.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  654. {
  655.     char *fileName, *extension, *errorString;
  656.     int statOp = 0;        /* Init. to avoid compiler warning. */
  657.     int length;
  658.     int mode = 0;            /* Initialized only to prevent
  659.                      * compiler warning message. */
  660.     struct stat statBuf;
  661.     Tcl_DString buffer;
  662.     Tcl_Obj *resultPtr;
  663.     int index, result;
  664.  
  665. /*
  666.  * This list of constants should match the fileOption string array below.
  667.  */
  668.  
  669. enum {FILE_ATIME, FILE_ATTRIBUTES, FILE_COPY, FILE_DELETE, FILE_DIRNAME,
  670.     FILE_EXECUTABLE, FILE_EXISTS, FILE_EXTENSION, FILE_ISDIRECTORY,
  671.     FILE_ISFILE, FILE_JOIN, FILE_LSTAT, FILE_MTIME, FILE_MKDIR,
  672.     FILE_NATIVENAME, FILE_OWNED, FILE_PATHTYPE, FILE_READABLE,
  673.     FILE_READLINK, FILE_RENAME, FILE_ROOTNAME, FILE_SIZE, FILE_SPLIT,
  674.     FILE_STAT, FILE_TAIL, FILE_TYPE, FILE_VOLUMES, FILE_WRITABLE};
  675.  
  676.  
  677.     static char *fileOptions[] = {"atime", "attributes", "copy", "delete", 
  678.             "dirname", "executable", "exists", "extension", "isdirectory", 
  679.             "isfile", "join", "lstat", "mtime", "mkdir", "nativename", 
  680.             "owned", "pathtype", "readable", "readlink", "rename",
  681.             "rootname", "size", "split", "stat", "tail", "type", "volumes", 
  682.             "writable", (char *) NULL};
  683.  
  684.     if (objc < 2) {
  685.         Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
  686.         return TCL_ERROR;
  687.     }
  688.  
  689.     if (Tcl_GetIndexFromObj(interp, objv[1], fileOptions, "option", 0, &index)
  690.         != TCL_OK) {
  691.         return TCL_ERROR;
  692.     }
  693.     
  694.     result = TCL_OK;
  695.     /* 
  696.      * First, do the volumes command, since it is the only one that
  697.      * has objc == 2.
  698.      */
  699.     
  700.     if ( index == FILE_VOLUMES) {
  701.         if ( objc != 2 ) {
  702.         Tcl_WrongNumArgs(interp, 1, objv, "volumes");
  703.         return TCL_ERROR;
  704.     }
  705.     result = TclpListVolumes(interp);
  706.     return result;
  707.     }
  708.     
  709.     if (objc < 3) {
  710.     Tcl_WrongNumArgs(interp, 2, objv, "name ?arg ...?");
  711.     return TCL_ERROR;
  712.     }
  713.  
  714.     Tcl_DStringInit(&buffer);
  715.     resultPtr = Tcl_GetObjResult(interp);
  716.     
  717.  
  718.     /*
  719.      * Handle operations on the file name.
  720.      */
  721.     
  722.     switch (index) {
  723.         case FILE_ATTRIBUTES:
  724.             result = TclFileAttrsCmd(interp, objc - 2, objv + 2);
  725.             goto done;
  726.         case FILE_DIRNAME:    {
  727.             int pargc;
  728.         char **pargv;
  729.  
  730.         if (objc != 3) {
  731.             errorString = "dirname name";
  732.             goto not3Args;
  733.         }
  734.  
  735.         fileName = Tcl_GetStringFromObj(objv[2], &length);
  736.  
  737.         /*
  738.          * If there is only one element, and it starts with a tilde,
  739.          * perform tilde substitution and resplit the path.
  740.          */
  741.  
  742.         Tcl_SplitPath(fileName, &pargc, &pargv);
  743.         if ((pargc == 1) && (*fileName == '~')) {
  744.             ckfree((char*) pargv);
  745.             fileName = Tcl_TranslateFileName(interp, fileName, &buffer);
  746.             if (fileName == NULL) {
  747.             result = TCL_ERROR;
  748.             goto done;
  749.             }
  750.             Tcl_SplitPath(fileName, &pargc, &pargv);
  751.             Tcl_DStringSetLength(&buffer, 0);
  752.         }
  753.  
  754.         /*
  755.          * Return all but the last component.  If there is only one
  756.          * component, return it if the path was non-relative, otherwise
  757.          * return the current directory.
  758.          */
  759.  
  760.         if (pargc > 1) {
  761.             Tcl_JoinPath(pargc-1, pargv, &buffer);
  762.             Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&buffer),
  763.                 buffer.length);
  764.         } else if ((pargc == 0)
  765.             || (Tcl_GetPathType(pargv[0]) == TCL_PATH_RELATIVE)) {
  766.         Tcl_SetStringObj(resultPtr, (tclPlatform == TCL_PLATFORM_MAC)
  767.             ? ":" : ".", 1);
  768.         } else {
  769.             Tcl_SetStringObj(resultPtr, pargv[0], -1);        }
  770.         ckfree((char *)pargv);
  771.         goto done;
  772.     }
  773.         case FILE_TAIL: {
  774.         int pargc;
  775.         char **pargv;
  776.  
  777.         if (objc != 3) {
  778.             errorString = "tail name";
  779.             goto not3Args;
  780.         }
  781.         
  782.         fileName = Tcl_GetStringFromObj(objv[2], &length);
  783.  
  784.         /*
  785.          * If there is only one element, and it starts with a tilde,
  786.          * perform tilde substitution and resplit the path.
  787.          */
  788.  
  789.         Tcl_SplitPath(fileName, &pargc, &pargv);
  790.         if ((pargc == 1) && (*fileName == '~')) {
  791.             ckfree((char*) pargv);
  792.             fileName = Tcl_TranslateFileName(interp, fileName, &buffer);
  793.             if (fileName == NULL) {
  794.             result = TCL_ERROR;
  795.             goto done;
  796.             }
  797.             Tcl_SplitPath(fileName, &pargc, &pargv);
  798.             Tcl_DStringSetLength(&buffer, 0);
  799.         }
  800.  
  801.         /*
  802.          * Return the last component, unless it is the only component,
  803.          * and it is the root of an absolute path.
  804.          */
  805.  
  806.         if (pargc > 0) {
  807.             if ((pargc > 1)
  808.                 || (Tcl_GetPathType(pargv[0]) == TCL_PATH_RELATIVE)) {
  809.             Tcl_SetStringObj(resultPtr, pargv[pargc - 1], -1);
  810.             }
  811.         }
  812.         ckfree((char *)pargv);
  813.         goto done;
  814.     }
  815.     case FILE_ROOTNAME: {
  816.         char *fileName;
  817.         
  818.         if (objc != 3) {
  819.             errorString = "rootname name";
  820.             goto not3Args;
  821.         }
  822.         
  823.         fileName = Tcl_GetStringFromObj(objv[2], &length);
  824.         extension = TclGetExtension(fileName);
  825.         if (extension == NULL) {
  826.             Tcl_SetObjResult(interp, objv[2]);
  827.         } else {
  828.             Tcl_SetStringObj(resultPtr, fileName,
  829.             (int) (length - strlen(extension)));
  830.         }
  831.         goto done;
  832.     }
  833.     case FILE_EXTENSION:
  834.         if (objc != 3) {
  835.             errorString = "extension name";
  836.             goto not3Args;
  837.         }
  838.         extension = TclGetExtension(Tcl_GetStringFromObj(objv[2],&length));
  839.  
  840.         if (extension != NULL) {
  841.             Tcl_SetStringObj(resultPtr, extension, (int)strlen(extension));
  842.         }
  843.         goto done;
  844.     case FILE_PATHTYPE:
  845.         if (objc != 3) {
  846.             errorString = "pathtype name";
  847.             goto not3Args;
  848.         }
  849.         switch (Tcl_GetPathType(Tcl_GetStringFromObj(objv[2], &length))) {
  850.             case TCL_PATH_ABSOLUTE:
  851.                 Tcl_SetStringObj(resultPtr, "absolute", -1);
  852.             break;
  853.             case TCL_PATH_RELATIVE:
  854.                 Tcl_SetStringObj(resultPtr, "relative", -1);
  855.                 break;
  856.             case TCL_PATH_VOLUME_RELATIVE:
  857.             Tcl_SetStringObj(resultPtr, "volumerelative", -1);
  858.             break;
  859.         }
  860.         goto done;
  861.     case FILE_SPLIT: {
  862.         int pargc, i;
  863.         char **pargvList;
  864.         Tcl_Obj *listObjPtr;
  865.         
  866.         if (objc != 3) {
  867.                 errorString = "split name";
  868.             goto not3Args;
  869.         }
  870.         
  871.         Tcl_SplitPath(Tcl_GetStringFromObj(objv[2], &length), &pargc,
  872.                 &pargvList);
  873.         listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
  874.         for (i = 0; i < pargc; i++) {
  875.             Tcl_ListObjAppendElement(interp, listObjPtr,
  876.             Tcl_NewStringObj(pargvList[i], -1));
  877.         }
  878.         ckfree((char *) pargvList);
  879.         Tcl_SetObjResult(interp, listObjPtr);
  880.         goto done;
  881.     }
  882.     case FILE_JOIN: {
  883.         char **pargv = (char **) ckalloc((objc - 2) * sizeof(char *));
  884.         int i;
  885.         
  886.         for (i = 2; i < objc; i++) {
  887.             pargv[i - 2] = Tcl_GetStringFromObj(objv[i], &length);
  888.         }
  889.         Tcl_JoinPath(objc - 2, pargv, &buffer);
  890.         Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&buffer), 
  891.                     buffer.length);
  892.         ckfree((char *) pargv);
  893.         Tcl_DStringFree(&buffer);
  894.         goto done;
  895.     }
  896.     case FILE_RENAME: {
  897.         char **pargv = (char **) ckalloc(objc * sizeof(char *));
  898.         int i;
  899.         
  900.         for (i = 0; i < objc; i++) {
  901.             pargv[i] = Tcl_GetStringFromObj(objv[i], &length);
  902.         }
  903.         result = TclFileRenameCmd(interp, objc, pargv);
  904.         ckfree((char *) pargv);
  905.         goto done;
  906.     }
  907.     case FILE_MKDIR: {
  908.         char **pargv = (char **) ckalloc(objc * sizeof(char *));
  909.         int i;
  910.         
  911.         for (i = 0; i < objc; i++) {
  912.             pargv[i] = Tcl_GetStringFromObj(objv[i], &length);
  913.         }
  914.         result = TclFileMakeDirsCmd(interp, objc, pargv);
  915.         ckfree((char *) pargv);
  916.         goto done;
  917.     }
  918.     case FILE_DELETE: {
  919.         char **pargv = (char **) ckalloc(objc * sizeof(char *));
  920.         int i;
  921.         
  922.         for (i = 0; i < objc; i++) {
  923.             pargv[i] = Tcl_GetStringFromObj(objv[i], &length);
  924.         }
  925.         result = TclFileDeleteCmd(interp, objc, pargv);
  926.         ckfree((char *) pargv);
  927.         goto done;
  928.     }
  929.     case FILE_COPY: {
  930.         char **pargv = (char **) ckalloc(objc * sizeof(char *));
  931.         int i;
  932.         
  933.         for (i = 0; i < objc; i++) {
  934.             pargv[i] = Tcl_GetStringFromObj(objv[i], &length);
  935.         }
  936.         result = TclFileCopyCmd(interp, objc, pargv);
  937.         ckfree((char *) pargv);
  938.         goto done;
  939.     }
  940.     case FILE_NATIVENAME:
  941.         fileName = Tcl_TranslateFileName(interp,
  942.                 Tcl_GetStringFromObj(objv[2], &length), &buffer);
  943.         if (fileName == NULL) {
  944.         result = TCL_ERROR ;
  945.         } else {
  946.         Tcl_SetStringObj(resultPtr, fileName, -1);
  947.         }
  948.         goto done;
  949.     }
  950.  
  951.     /*
  952.      * Next, handle operations that can be satisfied with the "access"
  953.      * kernel call.
  954.      */
  955.  
  956.     fileName = Tcl_TranslateFileName(interp,
  957.         Tcl_GetStringFromObj(objv[2], &length), &buffer);
  958.     
  959.     switch (index) {
  960.         case FILE_READABLE:
  961.             if (objc != 3) {
  962.             errorString = "readable name";
  963.             goto not3Args;
  964.         }
  965.         mode = R_OK;
  966. checkAccess:
  967.         /*
  968.          * The result might have been set within Tcl_TranslateFileName
  969.          * (like no such user "blah" for file exists ~blah)
  970.          * but we don't want to flag an error in that case.
  971.          */
  972.         if (fileName == NULL) {
  973.         Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0));
  974.         } else {
  975.         Tcl_SetBooleanObj(resultPtr, (TclAccess(fileName, mode) != -1));
  976.         }
  977.         goto done;
  978.       case FILE_WRITABLE:
  979.         if (objc != 3) {
  980.             errorString = "writable name";
  981.             goto not3Args;
  982.         }
  983.         mode = W_OK;
  984.         goto checkAccess;
  985.       case FILE_EXECUTABLE:
  986.         if (objc != 3) {
  987.             errorString = "executable name";
  988.             goto not3Args;
  989.         }
  990.         mode = X_OK;
  991.         goto checkAccess;
  992.       case FILE_EXISTS:
  993.         if (objc != 3) {
  994.             errorString = "exists name";
  995.             goto not3Args;
  996.         }
  997.         mode = F_OK;
  998.         goto checkAccess;
  999.     }
  1000.  
  1001.     
  1002.     /*
  1003.      * Lastly, check stuff that requires the file to be stat-ed.
  1004.      */
  1005.  
  1006.     if (fileName == NULL) {
  1007.     result = TCL_ERROR;
  1008.     goto done;
  1009.     }
  1010.     
  1011.     switch (index) {
  1012.         case FILE_ATIME:
  1013.             if (objc != 3) {
  1014.             errorString = "atime name";
  1015.             goto not3Args;
  1016.         }
  1017.         
  1018.         if (TclStat(fileName, &statBuf) == -1) {
  1019.             goto badStat;
  1020.         }
  1021.         Tcl_SetLongObj(resultPtr, (long) statBuf.st_atime);
  1022.         goto done;
  1023.         case FILE_ISDIRECTORY:
  1024.             if (objc != 3) {
  1025.                 errorString = "isdirectory name";
  1026.                 goto not3Args;
  1027.             }
  1028.             statOp = 2;
  1029.             break;
  1030.         case FILE_ISFILE:
  1031.             if (objc != 3) {
  1032.                 errorString = "isfile name";
  1033.                 goto not3Args;
  1034.             }
  1035.             statOp = 1;
  1036.             break;
  1037.         case FILE_LSTAT:
  1038.             if (objc != 4) {
  1039.                 Tcl_WrongNumArgs(interp, 1, objv, "lstat name varName");
  1040.                 result = TCL_ERROR;
  1041.                 goto done;
  1042.             }
  1043.             
  1044.             if (lstat(fileName, &statBuf) == -1) {
  1045.                 Tcl_AppendStringsToObj(resultPtr, "couldn't lstat \"",
  1046.                     Tcl_GetStringFromObj(objv[2], &length), "\": ",
  1047.                     Tcl_PosixError(interp), (char *) NULL);
  1048.                 result = TCL_ERROR;
  1049.                 goto done;
  1050.             }
  1051.             result = StoreStatData(interp, Tcl_GetStringFromObj(objv[3],
  1052.                     &length), &statBuf);
  1053.             goto done;
  1054.     case FILE_MTIME:
  1055.         if (objc != 3) {
  1056.             errorString = "mtime name";
  1057.             goto not3Args;
  1058.         }
  1059.         if (TclStat(fileName, &statBuf) == -1) {
  1060.             goto badStat;
  1061.         }
  1062.         Tcl_SetLongObj(resultPtr, (long) statBuf.st_mtime);
  1063.         goto done;
  1064.     case FILE_OWNED:
  1065.         if (objc != 3) {
  1066.             errorString = "owned name";
  1067.             goto not3Args;
  1068.         }                    
  1069.             statOp = 0;
  1070.             break;
  1071.     case FILE_READLINK: {
  1072.         char linkValue[MAXPATHLEN + 1];
  1073.         int linkLength;
  1074.         
  1075.         if (objc != 3) {
  1076.             errorString = "readlink name";
  1077.             goto not3Args;
  1078.         }
  1079.  
  1080.         /*
  1081.          * If S_IFLNK isn't defined it means that the machine doesn't
  1082.          * support symbolic links, so the file can't possibly be a
  1083.          * symbolic link.  Generate an EINVAL error, which is what
  1084.          * happens on machines that do support symbolic links when
  1085.          * you invoke readlink on a file that isn't a symbolic link.
  1086.          */
  1087.  
  1088. #ifndef S_IFLNK
  1089.         linkLength = -1;
  1090.         errno = EINVAL;
  1091. #else
  1092.         linkLength = readlink(fileName, linkValue, sizeof(linkValue) - 1);
  1093. #endif /* S_IFLNK */
  1094.         if (linkLength == -1) {
  1095.             Tcl_AppendStringsToObj(resultPtr, "couldn't readlink \"", 
  1096.                 Tcl_GetStringFromObj(objv[2], &length), "\": ", 
  1097.                 Tcl_PosixError(interp), (char *) NULL);
  1098.             result = TCL_ERROR;
  1099.             goto done;
  1100.         }
  1101.         linkValue[linkLength] = 0;
  1102.         Tcl_SetStringObj(resultPtr, linkValue, linkLength);
  1103.         goto done;
  1104.     }
  1105.     case FILE_SIZE:
  1106.         if (objc != 3) {
  1107.             errorString = "size name";
  1108.             goto not3Args;
  1109.         }
  1110.         if (TclStat(fileName, &statBuf) == -1) {
  1111.             goto badStat;
  1112.         }
  1113.         Tcl_SetLongObj(resultPtr, (long) statBuf.st_size);
  1114.         goto done;
  1115.     case FILE_STAT:
  1116.         if (objc != 4) {
  1117.             Tcl_WrongNumArgs(interp, 1, objv, "stat name varName");
  1118.             result = TCL_ERROR;
  1119.             goto done;
  1120.         }
  1121.  
  1122.         if (TclStat(fileName, &statBuf) == -1) {
  1123. badStat:
  1124.         Tcl_AppendStringsToObj(resultPtr, "couldn't stat \"", 
  1125.             Tcl_GetStringFromObj(objv[2], &length),
  1126.                 "\": ", Tcl_PosixError(interp), (char *) NULL);
  1127.             result = TCL_ERROR;
  1128.             goto done;
  1129.         }
  1130.         result = StoreStatData(interp, Tcl_GetStringFromObj(objv[3],
  1131.                 &length), &statBuf);
  1132.         goto done;
  1133.     case FILE_TYPE:
  1134.         if (objc != 3) {
  1135.             errorString = "type name";
  1136.             goto not3Args;
  1137.         }
  1138.         if (lstat(fileName, &statBuf) == -1) {
  1139.             goto badStat;
  1140.         }
  1141.         errorString = GetTypeFromMode((int) statBuf.st_mode);
  1142.         Tcl_SetStringObj(resultPtr, errorString, -1);
  1143.         goto done;
  1144.     }
  1145.  
  1146.     if (TclStat(fileName, &statBuf) == -1) {
  1147.         Tcl_SetBooleanObj(resultPtr, 0);
  1148.     goto done;
  1149.     }
  1150.     switch (statOp) {
  1151.     case 0:
  1152.             /*
  1153.              * For Windows, OS/2 and Macintosh, there are no user ids
  1154.              * associated with a file, so we always return 1.
  1155.              */
  1156.  
  1157. #if (defined(__WIN32__) || defined(MAC_TCL) || defined(__OS2__))
  1158.         mode = 1;
  1159. #else
  1160.         mode = (geteuid() == statBuf.st_uid);
  1161. #endif
  1162.         break;
  1163.     case 1:
  1164.         mode = S_ISREG(statBuf.st_mode);
  1165.         break;
  1166.     case 2:
  1167.         mode = S_ISDIR(statBuf.st_mode);
  1168.         break;
  1169.     }
  1170.     Tcl_SetBooleanObj(resultPtr, mode);
  1171.  
  1172. done:
  1173.     Tcl_DStringFree(&buffer);
  1174.     return result;
  1175.  
  1176. not3Args:
  1177.     Tcl_WrongNumArgs(interp, 1, objv, errorString);
  1178.     result = TCL_ERROR;
  1179.     goto done;
  1180. }
  1181.  
  1182. /*
  1183.  *----------------------------------------------------------------------
  1184.  *
  1185.  * StoreStatData --
  1186.  *
  1187.  *    This is a utility procedure that breaks out the fields of a
  1188.  *    "stat" structure and stores them in textual form into the
  1189.  *    elements of an associative array.
  1190.  *
  1191.  * Results:
  1192.  *    Returns a standard Tcl return value.  If an error occurs then
  1193.  *    a message is left in interp->result.
  1194.  *
  1195.  * Side effects:
  1196.  *    Elements of the associative array given by "varName" are modified.
  1197.  *
  1198.  *----------------------------------------------------------------------
  1199.  */
  1200.  
  1201. static int
  1202. StoreStatData(interp, varName, statPtr)
  1203.     Tcl_Interp *interp;            /* Interpreter for error reports. */
  1204.     char *varName;            /* Name of associative array variable
  1205.                      * in which to store stat results. */
  1206.     struct stat *statPtr;        /* Pointer to buffer containing
  1207.                      * stat data to store in varName. */
  1208. {
  1209.     char string[30];
  1210.  
  1211.     sprintf(string, "%ld", (long) statPtr->st_dev);
  1212.     if (Tcl_SetVar2(interp, varName, "dev", string, TCL_LEAVE_ERR_MSG)
  1213.         == NULL) {
  1214.     return TCL_ERROR;
  1215.     }
  1216.     sprintf(string, "%ld", (long) statPtr->st_ino);
  1217.     if (Tcl_SetVar2(interp, varName, "ino", string, TCL_LEAVE_ERR_MSG)
  1218.         == NULL) {
  1219.     return TCL_ERROR;
  1220.     }
  1221.     sprintf(string, "%ld", (long) statPtr->st_mode);
  1222.     if (Tcl_SetVar2(interp, varName, "mode", string, TCL_LEAVE_ERR_MSG)
  1223.         == NULL) {
  1224.     return TCL_ERROR;
  1225.     }
  1226.     sprintf(string, "%ld", (long) statPtr->st_nlink);
  1227.     if (Tcl_SetVar2(interp, varName, "nlink", string, TCL_LEAVE_ERR_MSG)
  1228.         == NULL) {
  1229.     return TCL_ERROR;
  1230.     }
  1231.     sprintf(string, "%ld", (long) statPtr->st_uid);
  1232.     if (Tcl_SetVar2(interp, varName, "uid", string, TCL_LEAVE_ERR_MSG)
  1233.         == NULL) {
  1234.     return TCL_ERROR;
  1235.     }
  1236.     sprintf(string, "%ld", (long) statPtr->st_gid);
  1237.     if (Tcl_SetVar2(interp, varName, "gid", string, TCL_LEAVE_ERR_MSG)
  1238.         == NULL) {
  1239.     return TCL_ERROR;
  1240.     }
  1241.     sprintf(string, "%lu", (unsigned long) statPtr->st_size);
  1242.     if (Tcl_SetVar2(interp, varName, "size", string, TCL_LEAVE_ERR_MSG)
  1243.         == NULL) {
  1244.     return TCL_ERROR;
  1245.     }
  1246.     sprintf(string, "%ld", (long) statPtr->st_atime);
  1247.     if (Tcl_SetVar2(interp, varName, "atime", string, TCL_LEAVE_ERR_MSG)
  1248.         == NULL) {
  1249.     return TCL_ERROR;
  1250.     }
  1251.     sprintf(string, "%ld", (long) statPtr->st_mtime);
  1252.     if (Tcl_SetVar2(interp, varName, "mtime", string, TCL_LEAVE_ERR_MSG)
  1253.         == NULL) {
  1254.     return TCL_ERROR;
  1255.     }
  1256.     sprintf(string, "%ld", (long) statPtr->st_ctime);
  1257.     if (Tcl_SetVar2(interp, varName, "ctime", string, TCL_LEAVE_ERR_MSG)
  1258.         == NULL) {
  1259.     return TCL_ERROR;
  1260.     }
  1261.     if (Tcl_SetVar2(interp, varName, "type",
  1262.         GetTypeFromMode((int) statPtr->st_mode), TCL_LEAVE_ERR_MSG) 
  1263.             == NULL) {
  1264.     return TCL_ERROR;
  1265.     }
  1266.     return TCL_OK;
  1267. }
  1268.  
  1269. /*
  1270.  *----------------------------------------------------------------------
  1271.  *
  1272.  * GetTypeFromMode --
  1273.  *
  1274.  *    Given a mode word, returns a string identifying the type of a
  1275.  *    file.
  1276.  *
  1277.  * Results:
  1278.  *    A static text string giving the file type from mode.
  1279.  *
  1280.  * Side effects:
  1281.  *    None.
  1282.  *
  1283.  *----------------------------------------------------------------------
  1284.  */
  1285.  
  1286. static char *
  1287. GetTypeFromMode(mode)
  1288.     int mode;
  1289. {
  1290.     if (S_ISREG(mode)) {
  1291.     return "file";
  1292.     } else if (S_ISDIR(mode)) {
  1293.     return "directory";
  1294.     } else if (S_ISCHR(mode)) {
  1295.     return "characterSpecial";
  1296.     } else if (S_ISBLK(mode)) {
  1297.     return "blockSpecial";
  1298.     } else if (S_ISFIFO(mode)) {
  1299.     return "fifo";
  1300. #ifdef S_ISLNK
  1301.     } else if (S_ISLNK(mode)) {
  1302.     return "link";
  1303. #endif
  1304. #ifdef S_ISSOCK
  1305.     } else if (S_ISSOCK(mode)) {
  1306.     return "socket";
  1307. #endif
  1308.     }
  1309.     return "unknown";
  1310. }
  1311.  
  1312. /*
  1313.  *----------------------------------------------------------------------
  1314.  *
  1315.  * Tcl_ForCmd --
  1316.  *
  1317.  *      This procedure is invoked to process the "for" Tcl command.
  1318.  *      See the user documentation for details on what it does.
  1319.  *
  1320.  *    With the bytecode compiler, this procedure is only called when
  1321.  *    a command name is computed at runtime, and is "for" or the name
  1322.  *    to which "for" was renamed: e.g.,
  1323.  *    "set z for; $z {set i 0} {$i<100} {incr i} {puts $i}"
  1324.  *
  1325.  * Results:
  1326.  *      A standard Tcl result.
  1327.  *
  1328.  * Side effects:
  1329.  *      See the user documentation.
  1330.  *
  1331.  *----------------------------------------------------------------------
  1332.  */
  1333.  
  1334.         /* ARGSUSED */
  1335. int
  1336. Tcl_ForCmd(dummy, interp, argc, argv)
  1337.     ClientData dummy;                   /* Not used. */
  1338.     Tcl_Interp *interp;                 /* Current interpreter. */
  1339.     int argc;                           /* Number of arguments. */
  1340.     char **argv;                        /* Argument strings. */
  1341. {
  1342.     int result, value;
  1343.  
  1344.     if (argc != 5) {
  1345.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1346.                 " start test next command\"", (char *) NULL);
  1347.         return TCL_ERROR;
  1348.     }
  1349.  
  1350.     result = Tcl_Eval(interp, argv[1]);
  1351.     if (result != TCL_OK) {
  1352.         if (result == TCL_ERROR) {
  1353.             Tcl_AddErrorInfo(interp, "\n    (\"for\" initial command)");
  1354.         }
  1355.         return result;
  1356.     }
  1357.     while (1) {
  1358.         result = Tcl_ExprBoolean(interp, argv[2], &value);
  1359.         if (result != TCL_OK) {
  1360.             return result;
  1361.         }
  1362.         if (!value) {
  1363.             break;
  1364.         }
  1365.         result = Tcl_Eval(interp, argv[4]);
  1366.         if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
  1367.             if (result == TCL_ERROR) {
  1368.                 char msg[60];
  1369.                 sprintf(msg, "\n    (\"for\" body line %d)",interp->errorLine);
  1370.                 Tcl_AddErrorInfo(interp, msg);
  1371.             }
  1372.             break;
  1373.         }
  1374.         result = Tcl_Eval(interp, argv[3]);
  1375.     if (result == TCL_BREAK) {
  1376.             break;
  1377.         } else if (result != TCL_OK) {
  1378.             if (result == TCL_ERROR) {
  1379.                 Tcl_AddErrorInfo(interp, "\n    (\"for\" loop-end command)");
  1380.             }
  1381.             return result;
  1382.         }
  1383.     }
  1384.     if (result == TCL_BREAK) {
  1385.         result = TCL_OK;
  1386.     }
  1387.     if (result == TCL_OK) {
  1388.         Tcl_ResetResult(interp);
  1389.     }
  1390.     return result;
  1391. }
  1392.  
  1393. /*
  1394.  *----------------------------------------------------------------------
  1395.  *
  1396.  * Tcl_ForeachObjCmd --
  1397.  *
  1398.  *    This object-based procedure is invoked to process the "foreach" Tcl
  1399.  *    command.  See the user documentation for details on what it does.
  1400.  *
  1401.  * Results:
  1402.  *    A standard Tcl object result.
  1403.  *
  1404.  * Side effects:
  1405.  *    See the user documentation.
  1406.  *
  1407.  *----------------------------------------------------------------------
  1408.  */
  1409.  
  1410.     /* ARGSUSED */
  1411. int
  1412. Tcl_ForeachObjCmd(dummy, interp, objc, objv)
  1413.     ClientData dummy;        /* Not used. */
  1414.     Tcl_Interp *interp;        /* Current interpreter. */
  1415.     int objc;            /* Number of arguments. */
  1416.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  1417. {
  1418.     int result = TCL_OK;
  1419.     int i;            /* i selects a value list */
  1420.     int j, maxj;        /* Number of loop iterations */
  1421.     int v;            /* v selects a loop variable */
  1422.     int numLists;        /* Count of value lists */
  1423.     Tcl_Obj *bodyPtr;
  1424.  
  1425.     /*
  1426.      * We copy the argument object pointers into a local array to avoid
  1427.      * the problem that "objv" might become invalid. It is a pointer into
  1428.      * the evaluation stack and that stack might be grown and reallocated
  1429.      * if the loop body requires a large amount of stack space.
  1430.      */
  1431.     
  1432. #define NUM_ARGS 9
  1433.     Tcl_Obj *(argObjStorage[NUM_ARGS]);
  1434.     Tcl_Obj **argObjv = argObjStorage;
  1435.     
  1436. #define STATIC_LIST_SIZE 4
  1437.     int indexArray[STATIC_LIST_SIZE];      /* Array of value list indices */
  1438.     int varcListArray[STATIC_LIST_SIZE];  /* # loop variables per list */
  1439.     Tcl_Obj **varvListArray[STATIC_LIST_SIZE]; /* Array of var name lists */
  1440.     int argcListArray[STATIC_LIST_SIZE];  /* Array of value list sizes */
  1441.     Tcl_Obj **argvListArray[STATIC_LIST_SIZE]; /* Array of value lists */
  1442.  
  1443.     int *index = indexArray;
  1444.     int *varcList = varcListArray;
  1445.     Tcl_Obj ***varvList = varvListArray;
  1446.     int *argcList = argcListArray;
  1447.     Tcl_Obj ***argvList = argvListArray;
  1448.  
  1449.     if (objc < 4 || (objc%2 != 0)) {
  1450.     Tcl_WrongNumArgs(interp, 1, objv,
  1451.         "varList list ?varList list ...? command");
  1452.     return TCL_ERROR;
  1453.     }
  1454.  
  1455.     /*
  1456.      * Create the object argument array "argObjv". Make sure argObjv is
  1457.      * large enough to hold the objc arguments.
  1458.      */
  1459.  
  1460.     if (objc > NUM_ARGS) {
  1461.     argObjv = (Tcl_Obj **) ckalloc(objc * sizeof(Tcl_Obj *));
  1462.     }
  1463.     for (i = 0;  i < objc;  i++) {
  1464.     argObjv[i] = objv[i];
  1465.     }
  1466.  
  1467.     /*
  1468.      * Manage numList parallel value lists.
  1469.      * argvList[i] is a value list counted by argcList[i]
  1470.      * varvList[i] is the list of variables associated with the value list
  1471.      * varcList[i] is the number of variables associated with the value list
  1472.      * index[i] is the current pointer into the value list argvList[i]
  1473.      */
  1474.  
  1475.     numLists = (objc-2)/2;
  1476.     if (numLists > STATIC_LIST_SIZE) {
  1477.     index = (int *) ckalloc(numLists * sizeof(int));
  1478.     varcList = (int *) ckalloc(numLists * sizeof(int));
  1479.     varvList = (Tcl_Obj ***) ckalloc(numLists * sizeof(Tcl_Obj **));
  1480.     argcList = (int *) ckalloc(numLists * sizeof(int));
  1481.     argvList = (Tcl_Obj ***) ckalloc(numLists * sizeof(Tcl_Obj **));
  1482.     }
  1483.     for (i = 0;  i < numLists;  i++) {
  1484.     index[i] = 0;
  1485.     varcList[i] = 0;
  1486.     varvList[i] = (Tcl_Obj **) NULL;
  1487.     argcList[i] = 0;
  1488.     argvList[i] = (Tcl_Obj **) NULL;
  1489.     }
  1490.  
  1491.     /*
  1492.      * Break up the value lists and variable lists into elements
  1493.      * THIS FAILS IF THE OBJECT'S STRING REP HAS A NULL BYTE.
  1494.      */
  1495.  
  1496.     maxj = 0;
  1497.     for (i = 0;  i < numLists;  i++) {
  1498.     result = Tcl_ListObjGetElements(interp, argObjv[1+i*2],
  1499.             &varcList[i], &varvList[i]);
  1500.     if (result != TCL_OK) {
  1501.         goto done;
  1502.     }
  1503.     if (varcList[i] < 1) {
  1504.         Tcl_AppendToObj(Tcl_GetObjResult(interp),
  1505.                 "foreach varlist is empty", -1);
  1506.         result = TCL_ERROR;
  1507.         goto done;
  1508.     }
  1509.     
  1510.     result = Tcl_ListObjGetElements(interp, argObjv[2+i*2],
  1511.             &argcList[i], &argvList[i]);
  1512.     if (result != TCL_OK) {
  1513.         goto done;
  1514.     }
  1515.     
  1516.     j = argcList[i] / varcList[i];
  1517.     if ((argcList[i] % varcList[i]) != 0) {
  1518.         j++;
  1519.     }
  1520.     if (j > maxj) {
  1521.         maxj = j;
  1522.     }
  1523.     }
  1524.  
  1525.     /*
  1526.      * Iterate maxj times through the lists in parallel
  1527.      * If some value lists run out of values, set loop vars to ""
  1528.      */
  1529.     
  1530.     bodyPtr = argObjv[objc-1];
  1531.     for (j = 0;  j < maxj;  j++) {
  1532.     for (i = 0;  i < numLists;  i++) {
  1533.         /*
  1534.          * If a variable or value list object has been converted to
  1535.          * another kind of Tcl object, convert it back to a list object
  1536.          * and refetch the pointer to its element array.
  1537.          */
  1538.  
  1539.         if (argObjv[1+i*2]->typePtr != &tclListType) {
  1540.         result = Tcl_ListObjGetElements(interp, argObjv[1+i*2],
  1541.                 &varcList[i], &varvList[i]);
  1542.         if (result != TCL_OK) {
  1543.             panic("Tcl_ForeachObjCmd: could not reconvert variable list %d to a list object\n", i);
  1544.         }
  1545.         }
  1546.         if (argObjv[2+i*2]->typePtr != &tclListType) {
  1547.         result = Tcl_ListObjGetElements(interp, argObjv[2+i*2],
  1548.                     &argcList[i], &argvList[i]);
  1549.         if (result != TCL_OK) {
  1550.             panic("Tcl_ForeachObjCmd: could not reconvert value list %d to a list object\n", i);
  1551.         }
  1552.         }
  1553.         
  1554.         for (v = 0;  v < varcList[i];  v++) {
  1555.         int k = index[i]++;
  1556.         Tcl_Obj *valuePtr, *varValuePtr;
  1557.         int isEmptyObj = 0;
  1558.         
  1559.         if (k < argcList[i]) {
  1560.             valuePtr = argvList[i][k];
  1561.         } else {
  1562.             valuePtr = Tcl_NewObj(); /* empty string */
  1563.             isEmptyObj = 1;
  1564.         }
  1565.         varValuePtr = Tcl_ObjSetVar2(interp, varvList[i][v], NULL,
  1566.             valuePtr, TCL_PARSE_PART1);
  1567.         if (varValuePtr == NULL) {
  1568.             if (isEmptyObj) {
  1569.             Tcl_DecrRefCount(valuePtr);
  1570.             }
  1571.             Tcl_ResetResult(interp);
  1572.             Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  1573.             "couldn't set loop variable: \"",
  1574.             Tcl_GetStringFromObj(varvList[i][v], (int *) NULL),
  1575.             "\"", (char *) NULL);
  1576.             result = TCL_ERROR;
  1577.             goto done;
  1578.         }
  1579.  
  1580.         }
  1581.     }
  1582.  
  1583.     result = Tcl_EvalObj(interp, bodyPtr);
  1584.     if (result != TCL_OK) {
  1585.         if (result == TCL_CONTINUE) {
  1586.         result = TCL_OK;
  1587.         } else if (result == TCL_BREAK) {
  1588.         result = TCL_OK;
  1589.         break;
  1590.         } else if (result == TCL_ERROR) {
  1591.         char msg[100];
  1592.         sprintf(msg, "\n    (\"foreach\" body line %d)",
  1593.             interp->errorLine);
  1594.         Tcl_AddObjErrorInfo(interp, msg, -1);
  1595.         break;
  1596.         } else {
  1597.         break;
  1598.         }
  1599.     }
  1600.     }
  1601.     if (result == TCL_OK) {
  1602.     Tcl_ResetResult(interp);
  1603.     }
  1604.  
  1605.     done:
  1606.     if (numLists > STATIC_LIST_SIZE) {
  1607.     ckfree((char *) index);
  1608.     ckfree((char *) varcList);
  1609.     ckfree((char *) argcList);
  1610.     ckfree((char *) varvList);
  1611.     ckfree((char *) argvList);
  1612.     }
  1613.     if (argObjv != argObjStorage) {
  1614.     ckfree((char *) argObjv);
  1615.     }
  1616.     return result;
  1617. #undef STATIC_LIST_SIZE
  1618. #undef NUM_ARGS
  1619. }
  1620.  
  1621. /*
  1622.  *----------------------------------------------------------------------
  1623.  *
  1624.  * Tcl_FormatObjCmd --
  1625.  *
  1626.  *    This procedure is invoked to process the "format" Tcl command.
  1627.  *    See the user documentation for details on what it does.
  1628.  *
  1629.  * Results:
  1630.  *    A standard Tcl result.
  1631.  *
  1632.  * Side effects:
  1633.  *    See the user documentation.
  1634.  *
  1635.  *----------------------------------------------------------------------
  1636.  */
  1637.  
  1638.     /* ARGSUSED */
  1639. int
  1640. Tcl_FormatObjCmd(dummy, interp, objc, objv)
  1641.     ClientData dummy;        /* Not used. */
  1642.     Tcl_Interp *interp;        /* Current interpreter. */
  1643.     int objc;            /* Number of arguments. */
  1644.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  1645. {
  1646.     register char *format;    /* Used to read characters from the format
  1647.                  * string. */
  1648.     int formatLen;              /* The length of the format string */
  1649.     char *endPtr;               /* Points to the last char in format array */
  1650.     char newFormat[40];        /* A new format specifier is generated here. */
  1651.     int width;            /* Field width from field specifier, or 0 if
  1652.                  * no width given. */
  1653.     int precision;        /* Field precision from field specifier, or 0
  1654.                  * if no precision given. */
  1655.     int size;            /* Number of bytes needed for result of
  1656.                  * conversion, based on type of conversion
  1657.                  * ("e", "s", etc.), width, and precision. */
  1658.     int intValue;        /* Used to hold value to pass to sprintf, if
  1659.                  * it's a one-word integer or char value */
  1660.     char *ptrValue = NULL;    /* Used to hold value to pass to sprintf, if
  1661.                  * it's a one-word value. */
  1662.     double doubleValue;        /* Used to hold value to pass to sprintf if
  1663.                  * it's a double value. */
  1664.     int whichValue;        /* Indicates which of intValue, ptrValue,
  1665.                  * or doubleValue has the value to pass to
  1666.                  * sprintf, according to the following
  1667.                  * definitions: */
  1668. #   define INT_VALUE 0
  1669. #   define PTR_VALUE 1
  1670. #   define DOUBLE_VALUE 2
  1671. #   define MAX_FLOAT_SIZE 320
  1672.     
  1673.     Tcl_Obj *resultPtr;      /* Where result is stored finally. */
  1674.     char staticBuf[MAX_FLOAT_SIZE + 1];
  1675.                                 /* A static buffer to copy the format results 
  1676.                  * into */
  1677.     char *dst = staticBuf;      /* The buffer that sprintf writes into each
  1678.                  * time the format processes a specifier */
  1679.     int dstSize = MAX_FLOAT_SIZE;
  1680.                                 /* The size of the dst buffer */
  1681.     int noPercent;        /* Special case for speed:  indicates there's
  1682.                  * no field specifier, just a string to copy.*/
  1683.     int objIndex;        /* Index of argument to substitute next. */
  1684.     int gotXpg = 0;        /* Non-zero means that an XPG3 %n$-style
  1685.                  * specifier has been seen. */
  1686.     int gotSequential = 0;    /* Non-zero means that a regular sequential
  1687.                  * (non-XPG3) conversion specifier has been
  1688.                  * seen. */
  1689.     int useShort;        /* Value to be printed is short (half word). */
  1690.     char *end;            /* Used to locate end of numerical fields. */
  1691.  
  1692.     /*
  1693.      * This procedure is a bit nasty.  The goal is to use sprintf to
  1694.      * do most of the dirty work.  There are several problems:
  1695.      * 1. this procedure can't trust its arguments.
  1696.      * 2. we must be able to provide a large enough result area to hold
  1697.      *    whatever's generated.  This is hard to estimate.
  1698.      * 2. there's no way to move the arguments from objv to the call
  1699.      *    to sprintf in a reasonable way.  This is particularly nasty
  1700.      *    because some of the arguments may be two-word values (doubles).
  1701.      * So, what happens here is to scan the format string one % group
  1702.      * at a time, making many individual calls to sprintf.
  1703.      */
  1704.  
  1705.     if (objc < 2) {
  1706.         Tcl_WrongNumArgs(interp, 1, objv,
  1707.         "formatString ?arg arg ...?");
  1708.     return TCL_ERROR;
  1709.     }
  1710.  
  1711.     format = Tcl_GetStringFromObj(objv[1], &formatLen);
  1712.     endPtr = format + formatLen;
  1713.     resultPtr = Tcl_NewObj();
  1714.     objIndex = 2;
  1715.  
  1716.     while (format < endPtr) {
  1717.     register char *newPtr = newFormat;
  1718.  
  1719.     width = precision = noPercent = useShort = 0;
  1720.     whichValue = PTR_VALUE;
  1721.  
  1722.     /*
  1723.      * Get rid of any characters before the next field specifier.
  1724.      */
  1725.     if (*format != '%') {
  1726.         ptrValue = format;
  1727.         while ((*format != '%') && (format < endPtr)) {
  1728.         format++;
  1729.         }
  1730.         size = format - ptrValue;
  1731.         noPercent = 1;
  1732.         goto doField;
  1733.     }
  1734.  
  1735.     if (format[1] == '%') {
  1736.         ptrValue = format;
  1737.         size = 1;
  1738.         noPercent = 1;
  1739.         format += 2;
  1740.         goto doField;
  1741.     }
  1742.  
  1743.     /*
  1744.      * Parse off a field specifier, compute how many characters
  1745.      * will be needed to store the result, and substitute for
  1746.      * "*" size specifiers.
  1747.      */
  1748.     *newPtr = '%';
  1749.     newPtr++;
  1750.     format++;
  1751.     if (isdigit(UCHAR(*format))) {
  1752.         int tmp;
  1753.  
  1754.         /*
  1755.          * Check for an XPG3-style %n$ specification.  Note: there
  1756.          * must not be a mixture of XPG3 specs and non-XPG3 specs
  1757.          * in the same format string.
  1758.          */
  1759.  
  1760.         tmp = strtoul(format, &end, 10);
  1761.         if (*end != '$') {
  1762.         goto notXpg;
  1763.         }
  1764.         format = end+1;
  1765.         gotXpg = 1;
  1766.         if (gotSequential) {
  1767.         goto mixedXPG;
  1768.         }
  1769.         objIndex = tmp+1;
  1770.         if ((objIndex < 2) || (objIndex >= objc)) {
  1771.         goto badIndex;
  1772.         }
  1773.         goto xpgCheckDone;
  1774.     }
  1775.  
  1776.     notXpg:
  1777.     gotSequential = 1;
  1778.     if (gotXpg) {
  1779.         goto mixedXPG;
  1780.     }
  1781.  
  1782.     xpgCheckDone:
  1783.     while ((*format == '-') || (*format == '#') || (*format == '0')
  1784.         || (*format == ' ') || (*format == '+')) {
  1785.         *newPtr = *format;
  1786.         newPtr++;
  1787.         format++;
  1788.     }
  1789.     if (isdigit(UCHAR(*format))) {
  1790.         width = strtoul(format, &end, 10);
  1791.         format = end;
  1792.     } else if (*format == '*') {
  1793.         if (objIndex >= objc) {
  1794.         goto badIndex;
  1795.         }
  1796.         if (Tcl_GetIntFromObj(interp, objv[objIndex], 
  1797.                     &width) != TCL_OK) {
  1798.         goto fmtError;
  1799.         }
  1800.         objIndex++;
  1801.         format++;
  1802.     }
  1803.     if (width > 100000) {
  1804.         /*
  1805.          * Don't allow arbitrarily large widths:  could cause core
  1806.          * dump when we try to allocate a zillion bytes of memory
  1807.          * below.
  1808.          */
  1809.  
  1810.         width = 100000;
  1811.     } else if (width < 0) {
  1812.         width = 0;
  1813.     }
  1814.     if (width != 0) {
  1815.         TclFormatInt(newPtr, width);
  1816.         while (*newPtr != 0) {
  1817.         newPtr++;
  1818.         }
  1819.     }
  1820.     if (*format == '.') {
  1821.         *newPtr = '.';
  1822.         newPtr++;
  1823.         format++;
  1824.     }
  1825.     if (isdigit(UCHAR(*format))) {
  1826.         precision = strtoul(format, &end, 10);
  1827.         format = end;
  1828.     } else if (*format == '*') {
  1829.         if (objIndex >= objc) {
  1830.         goto badIndex;
  1831.         }
  1832.         if (Tcl_GetIntFromObj(interp, objv[objIndex], 
  1833.                     &precision) != TCL_OK) {
  1834.         goto fmtError;
  1835.         }
  1836.         objIndex++;
  1837.         format++;
  1838.     }
  1839.     if (precision != 0) {
  1840.         TclFormatInt(newPtr, precision);
  1841.         while (*newPtr != 0) {
  1842.         newPtr++;
  1843.         }
  1844.     }
  1845.     if (*format == 'l') {
  1846.         format++;
  1847.     } else if (*format == 'h') {
  1848.         useShort = 1;
  1849.         *newPtr = 'h';
  1850.         newPtr++;
  1851.         format++;
  1852.     }
  1853.     *newPtr = *format;
  1854.     newPtr++;
  1855.     *newPtr = 0;
  1856.     if (objIndex >= objc) {
  1857.         goto badIndex;
  1858.     }
  1859.     switch (*format) {
  1860.         case 'i':
  1861.         newPtr[-1] = 'd';
  1862.         case 'd':
  1863.         case 'o':
  1864.         case 'u':
  1865.         case 'x':
  1866.         case 'X':
  1867.         if (Tcl_GetIntFromObj(interp, objv[objIndex], 
  1868.                 (int *) &intValue) != TCL_OK) {
  1869.             goto fmtError;
  1870.         }
  1871.         whichValue = INT_VALUE;
  1872.         size = 40 + precision;
  1873.         break;
  1874.         case 's':
  1875.         ptrValue = Tcl_GetStringFromObj(objv[objIndex], &size);
  1876.         break;
  1877.         case 'c':
  1878.         if (Tcl_GetIntFromObj(interp, objv[objIndex], 
  1879.                         (int *) &intValue) != TCL_OK) {
  1880.             goto fmtError;
  1881.         }
  1882.         whichValue = INT_VALUE;
  1883.         size = 1;
  1884.         break;
  1885.         case 'e':
  1886.         case 'E':
  1887.         case 'f':
  1888.         case 'g':
  1889.         case 'G':
  1890.         if (Tcl_GetDoubleFromObj(interp, objv[objIndex], 
  1891.             &doubleValue) != TCL_OK) {
  1892.             goto fmtError;
  1893.         }
  1894.         whichValue = DOUBLE_VALUE;
  1895.         size = MAX_FLOAT_SIZE;
  1896.         if (precision > 10) {
  1897.             size += precision;
  1898.         }
  1899.         break;
  1900.         case 0:
  1901.         Tcl_SetResult(interp,
  1902.                 "format string ended in middle of field specifier",
  1903.             TCL_STATIC);
  1904.         goto fmtError;
  1905.         default:
  1906.         {
  1907.             char buf[40];
  1908.             sprintf(buf, "bad field specifier \"%c\"", *format);
  1909.             Tcl_SetResult(interp, buf, TCL_VOLATILE);
  1910.             goto fmtError;
  1911.         }
  1912.     }
  1913.     objIndex++;
  1914.     format++;
  1915.  
  1916.     /*
  1917.      * Make sure that there's enough space to hold the formatted
  1918.      * result, then format it.
  1919.      */
  1920.  
  1921.     doField:
  1922.     if (width > size) {
  1923.         size = width;
  1924.     }
  1925.     if (noPercent) {
  1926.         Tcl_AppendToObj(resultPtr, ptrValue, size);
  1927.     } else {
  1928.         if (size > dstSize) {
  1929.             if (dst != staticBuf) {
  1930.             ckfree(dst);
  1931.         }
  1932.         dst = (char *) ckalloc((unsigned) (size + 1));
  1933.         dstSize = size;
  1934.         }
  1935.  
  1936.         if (whichValue == DOUBLE_VALUE) {
  1937.             sprintf(dst, newFormat, doubleValue);
  1938.         } else if (whichValue == INT_VALUE) {
  1939.         if (useShort) {
  1940.             sprintf(dst, newFormat, (short) intValue);
  1941.         } else {
  1942.             sprintf(dst, newFormat, intValue);
  1943.         }
  1944.         } else {
  1945.             sprintf(dst, newFormat, ptrValue);
  1946.         }
  1947.         Tcl_AppendToObj(resultPtr, dst, -1);
  1948.     }
  1949.     }
  1950.  
  1951.     Tcl_SetObjResult(interp, resultPtr);
  1952.     if(dst != staticBuf) {
  1953.         ckfree(dst);
  1954.     }
  1955.     return TCL_OK;
  1956.  
  1957.     mixedXPG:
  1958.     Tcl_SetResult(interp, 
  1959.             "cannot mix \"%\" and \"%n$\" conversion specifiers", TCL_STATIC);
  1960.     goto fmtError;
  1961.  
  1962.     badIndex:
  1963.     if (gotXpg) {
  1964.         Tcl_SetResult(interp, 
  1965.                 "\"%n$\" argument index out of range", TCL_STATIC);
  1966.     } else {
  1967.         Tcl_SetResult(interp, 
  1968.                 "not enough arguments for all format specifiers", TCL_STATIC);
  1969.     }
  1970.  
  1971.     fmtError:
  1972.     if(dst != staticBuf) {
  1973.         ckfree(dst);
  1974.     }
  1975.     Tcl_DecrRefCount(resultPtr);
  1976.     return TCL_ERROR;
  1977. }
  1978.