home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tcl8.0 / generic / tclCmdAH.c < prev    next >
Encoding:
C/C++ Source or Header  |  1997-08-15  |  51.2 KB  |  1,977 lines  |  [TEXT/CWIE]
  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.156 97/08/12 18:10:15
  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.     }
  594.  
  595.     /*
  596.      * Create a new object holding the concatenated argument strings.
  597.      * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE.
  598.      */
  599.  
  600.     bytes = Tcl_GetStringFromObj(objv[1], &length);
  601.     objPtr = Tcl_NewStringObj(bytes, length);
  602.     Tcl_IncrRefCount(objPtr);
  603.     for (i = 2;  i < objc;  i++) {
  604.     Tcl_AppendToObj(objPtr, " ", 1);
  605.     bytes = Tcl_GetStringFromObj(objv[i], &length);
  606.     Tcl_AppendToObj(objPtr, bytes, length);
  607.     }
  608.  
  609.     /*
  610.      * Evaluate the concatenated string object.
  611.      */
  612.  
  613.     result = Tcl_ExprObj(interp, objPtr, &resultPtr);
  614.     if (result == TCL_OK) {
  615.     Tcl_SetObjResult(interp, resultPtr);
  616.     Tcl_DecrRefCount(resultPtr);  /* done with the result object */
  617.     }
  618.  
  619.     /*
  620.      * Free allocated resources.
  621.      */
  622.     
  623.     Tcl_DecrRefCount(objPtr);
  624.     return result;
  625. }
  626.  
  627. /*
  628.  *----------------------------------------------------------------------
  629.  *
  630.  * Tcl_FileObjCmd --
  631.  *
  632.  *    This procedure is invoked to process the "file" Tcl command.
  633.  *    See the user documentation for details on what it does.
  634.  *    PLEASE NOTE THAT THIS FAILS WITH FILENAMES AND PATHS WITH
  635.  *    EMBEDDED NULLS, WHICH COULD THEORETICALLY HAPPEN ON A MAC.
  636.  *
  637.  * Results:
  638.  *    A standard Tcl result.
  639.  *
  640.  * Side effects:
  641.  *    See the user documentation.
  642.  *
  643.  *----------------------------------------------------------------------
  644.  */
  645.  
  646.     /* ARGSUSED */
  647. int
  648. Tcl_FileObjCmd(dummy, interp, objc, objv)
  649.     ClientData dummy;        /* Not used. */
  650.     Tcl_Interp *interp;        /* Current interpreter. */
  651.     int objc;            /* Number of arguments. */
  652.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  653. {
  654.     char *fileName, *extension, *errorString;
  655.     int statOp = 0;        /* Init. to avoid compiler warning. */
  656.     int length;
  657.     int mode = 0;            /* Initialized only to prevent
  658.                      * compiler warning message. */
  659.     struct stat statBuf;
  660.     Tcl_DString buffer;
  661.     Tcl_Obj *resultPtr;
  662.     int index, result;
  663.  
  664. /*
  665.  * This list of constants should match the fileOption string array below.
  666.  */
  667.  
  668. enum {FILE_ATIME, FILE_ATTRIBUTES, FILE_COPY, FILE_DELETE, FILE_DIRNAME,
  669.     FILE_EXECUTABLE, FILE_EXISTS, FILE_EXTENSION, FILE_ISDIRECTORY,
  670.     FILE_ISFILE, FILE_JOIN, FILE_LSTAT, FILE_MTIME, FILE_MKDIR,
  671.     FILE_NATIVENAME, FILE_OWNED, FILE_PATHTYPE, FILE_READABLE,
  672.     FILE_READLINK, FILE_RENAME, FILE_ROOTNAME, FILE_SIZE, FILE_SPLIT,
  673.     FILE_STAT, FILE_TAIL, FILE_TYPE, FILE_VOLUMES, FILE_WRITABLE};
  674.  
  675.  
  676.     static char *fileOptions[] = {"atime", "attributes", "copy", "delete", 
  677.             "dirname", "executable", "exists", "extension", "isdirectory", 
  678.             "isfile", "join", "lstat", "mtime", "mkdir", "nativename", 
  679.             "owned", "pathtype", "readable", "readlink", "rename",
  680.             "rootname", "size", "split", "stat", "tail", "type", "volumes", 
  681.             "writable", (char *) NULL};
  682.  
  683.     if (objc < 2) {
  684.         Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
  685.         return TCL_ERROR;
  686.     }
  687.  
  688.     if (Tcl_GetIndexFromObj(interp, objv[1], fileOptions, "option", 0, &index)
  689.         != TCL_OK) {
  690.         return TCL_ERROR;
  691.     }
  692.     
  693.     result = TCL_OK;
  694.     /* 
  695.      * First, do the volumes command, since it is the only one that
  696.      * has objc == 2.
  697.      */
  698.     
  699.     if ( index == FILE_VOLUMES) {
  700.         if ( objc != 2 ) {
  701.         Tcl_WrongNumArgs(interp, 1, objv, "volumes");
  702.         return TCL_ERROR;
  703.     }
  704.     result = TclpListVolumes(interp);
  705.     return result;
  706.     }
  707.     
  708.     if (objc < 3) {
  709.     Tcl_WrongNumArgs(interp, 2, objv, "name ?arg ...?");
  710.     return TCL_ERROR;
  711.     }
  712.  
  713.     Tcl_DStringInit(&buffer);
  714.     resultPtr = Tcl_GetObjResult(interp);
  715.     
  716.  
  717.     /*
  718.      * Handle operations on the file name.
  719.      */
  720.     
  721.     switch (index) {
  722.         case FILE_ATTRIBUTES:
  723.             result = TclFileAttrsCmd(interp, objc - 2, objv + 2);
  724.             goto done;
  725.         case FILE_DIRNAME:    {
  726.             int pargc;
  727.         char **pargv;
  728.  
  729.         if (objc != 3) {
  730.             errorString = "dirname name";
  731.             goto not3Args;
  732.         }
  733.  
  734.         fileName = Tcl_GetStringFromObj(objv[2], &length);
  735.  
  736.         /*
  737.          * If there is only one element, and it starts with a tilde,
  738.          * perform tilde substitution and resplit the path.
  739.          */
  740.  
  741.         Tcl_SplitPath(fileName, &pargc, &pargv);
  742.         if ((pargc == 1) && (*fileName == '~')) {
  743.             ckfree((char*) pargv);
  744.             fileName = Tcl_TranslateFileName(interp, fileName, &buffer);
  745.             if (fileName == NULL) {
  746.             result = TCL_ERROR;
  747.             goto done;
  748.             }
  749.             Tcl_SplitPath(fileName, &pargc, &pargv);
  750.             Tcl_DStringSetLength(&buffer, 0);
  751.         }
  752.  
  753.         /*
  754.          * Return all but the last component.  If there is only one
  755.          * component, return it if the path was non-relative, otherwise
  756.          * return the current directory.
  757.          */
  758.  
  759.         if (pargc > 1) {
  760.             Tcl_JoinPath(pargc-1, pargv, &buffer);
  761.             Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&buffer),
  762.                 buffer.length);
  763.         } else if ((pargc == 0)
  764.             || (Tcl_GetPathType(pargv[0]) == TCL_PATH_RELATIVE)) {
  765.         Tcl_SetStringObj(resultPtr, (tclPlatform == TCL_PLATFORM_MAC)
  766.             ? ":" : ".", 1);
  767.         } else {
  768.             Tcl_SetStringObj(resultPtr, pargv[0], -1);        }
  769.         ckfree((char *)pargv);
  770.         goto done;
  771.     }
  772.         case FILE_TAIL: {
  773.         int pargc;
  774.         char **pargv;
  775.  
  776.         if (objc != 3) {
  777.             errorString = "tail name";
  778.             goto not3Args;
  779.         }
  780.         
  781.         fileName = Tcl_GetStringFromObj(objv[2], &length);
  782.  
  783.         /*
  784.          * If there is only one element, and it starts with a tilde,
  785.          * perform tilde substitution and resplit the path.
  786.          */
  787.  
  788.         Tcl_SplitPath(fileName, &pargc, &pargv);
  789.         if ((pargc == 1) && (*fileName == '~')) {
  790.             ckfree((char*) pargv);
  791.             fileName = Tcl_TranslateFileName(interp, fileName, &buffer);
  792.             if (fileName == NULL) {
  793.             result = TCL_ERROR;
  794.             goto done;
  795.             }
  796.             Tcl_SplitPath(fileName, &pargc, &pargv);
  797.             Tcl_DStringSetLength(&buffer, 0);
  798.         }
  799.  
  800.         /*
  801.          * Return the last component, unless it is the only component,
  802.          * and it is the root of an absolute path.
  803.          */
  804.  
  805.         if (pargc > 0) {
  806.             if ((pargc > 1)
  807.                 || (Tcl_GetPathType(pargv[0]) == TCL_PATH_RELATIVE)) {
  808.             Tcl_SetStringObj(resultPtr, pargv[pargc - 1], -1);
  809.             }
  810.         }
  811.         ckfree((char *)pargv);
  812.         goto done;
  813.     }
  814.     case FILE_ROOTNAME: {
  815.         char *fileName;
  816.         
  817.         if (objc != 3) {
  818.             errorString = "rootname name";
  819.             goto not3Args;
  820.         }
  821.         
  822.         fileName = Tcl_GetStringFromObj(objv[2], &length);
  823.         extension = TclGetExtension(fileName);
  824.         if (extension == NULL) {
  825.             Tcl_SetObjResult(interp, objv[2]);
  826.         } else {
  827.             Tcl_SetStringObj(resultPtr, fileName,
  828.             (int) (length - strlen(extension)));
  829.         }
  830.         goto done;
  831.     }
  832.     case FILE_EXTENSION:
  833.         if (objc != 3) {
  834.             errorString = "extension name";
  835.             goto not3Args;
  836.         }
  837.         extension = TclGetExtension(Tcl_GetStringFromObj(objv[2],&length));
  838.  
  839.         if (extension != NULL) {
  840.             Tcl_SetStringObj(resultPtr, extension, (int)strlen(extension));
  841.         }
  842.         goto done;
  843.     case FILE_PATHTYPE:
  844.         if (objc != 3) {
  845.             errorString = "pathtype name";
  846.             goto not3Args;
  847.         }
  848.         switch (Tcl_GetPathType(Tcl_GetStringFromObj(objv[2], &length))) {
  849.             case TCL_PATH_ABSOLUTE:
  850.                 Tcl_SetStringObj(resultPtr, "absolute", -1);
  851.             break;
  852.             case TCL_PATH_RELATIVE:
  853.                 Tcl_SetStringObj(resultPtr, "relative", -1);
  854.                 break;
  855.             case TCL_PATH_VOLUME_RELATIVE:
  856.             Tcl_SetStringObj(resultPtr, "volumerelative", -1);
  857.             break;
  858.         }
  859.         goto done;
  860.     case FILE_SPLIT: {
  861.         int pargc, i;
  862.         char **pargvList;
  863.         Tcl_Obj *listObjPtr;
  864.         
  865.         if (objc != 3) {
  866.                 errorString = "split name";
  867.             goto not3Args;
  868.         }
  869.         
  870.         Tcl_SplitPath(Tcl_GetStringFromObj(objv[2], &length), &pargc,
  871.                 &pargvList);
  872.         listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
  873.         for (i = 0; i < pargc; i++) {
  874.             Tcl_ListObjAppendElement(interp, listObjPtr,
  875.             Tcl_NewStringObj(pargvList[i], -1));
  876.         }
  877.         ckfree((char *) pargvList);
  878.         Tcl_SetObjResult(interp, listObjPtr);
  879.         goto done;
  880.     }
  881.     case FILE_JOIN: {
  882.         char **pargv = (char **) ckalloc((objc - 2) * sizeof(char *));
  883.         int i;
  884.         
  885.         for (i = 2; i < objc; i++) {
  886.             pargv[i - 2] = Tcl_GetStringFromObj(objv[i], &length);
  887.         }
  888.         Tcl_JoinPath(objc - 2, pargv, &buffer);
  889.         Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&buffer), 
  890.                     buffer.length);
  891.         ckfree((char *) pargv);
  892.         Tcl_DStringFree(&buffer);
  893.         goto done;
  894.     }
  895.     case FILE_RENAME: {
  896.         char **pargv = (char **) ckalloc(objc * sizeof(char *));
  897.         int i;
  898.         
  899.         for (i = 0; i < objc; i++) {
  900.             pargv[i] = Tcl_GetStringFromObj(objv[i], &length);
  901.         }
  902.         result = TclFileRenameCmd(interp, objc, pargv);
  903.         ckfree((char *) pargv);
  904.         goto done;
  905.     }
  906.     case FILE_MKDIR: {
  907.         char **pargv = (char **) ckalloc(objc * sizeof(char *));
  908.         int i;
  909.         
  910.         for (i = 0; i < objc; i++) {
  911.             pargv[i] = Tcl_GetStringFromObj(objv[i], &length);
  912.         }
  913.         result = TclFileMakeDirsCmd(interp, objc, pargv);
  914.         ckfree((char *) pargv);
  915.         goto done;
  916.     }
  917.     case FILE_DELETE: {
  918.         char **pargv = (char **) ckalloc(objc * sizeof(char *));
  919.         int i;
  920.         
  921.         for (i = 0; i < objc; i++) {
  922.             pargv[i] = Tcl_GetStringFromObj(objv[i], &length);
  923.         }
  924.         result = TclFileDeleteCmd(interp, objc, pargv);
  925.         ckfree((char *) pargv);
  926.         goto done;
  927.     }
  928.     case FILE_COPY: {
  929.         char **pargv = (char **) ckalloc(objc * sizeof(char *));
  930.         int i;
  931.         
  932.         for (i = 0; i < objc; i++) {
  933.             pargv[i] = Tcl_GetStringFromObj(objv[i], &length);
  934.         }
  935.         result = TclFileCopyCmd(interp, objc, pargv);
  936.         ckfree((char *) pargv);
  937.         goto done;
  938.     }
  939.     case FILE_NATIVENAME:
  940.         fileName = Tcl_TranslateFileName(interp,
  941.                 Tcl_GetStringFromObj(objv[2], &length), &buffer);
  942.         if (fileName == NULL) {
  943.         result = TCL_ERROR ;
  944.         } else {
  945.         Tcl_SetStringObj(resultPtr, fileName, -1);
  946.         }
  947.         goto done;
  948.     }
  949.  
  950.     /*
  951.      * Next, handle operations that can be satisfied with the "access"
  952.      * kernel call.
  953.      */
  954.  
  955.     fileName = Tcl_TranslateFileName(interp,
  956.         Tcl_GetStringFromObj(objv[2], &length), &buffer);
  957.     
  958.     switch (index) {
  959.         case FILE_READABLE:
  960.             if (objc != 3) {
  961.             errorString = "readable name";
  962.             goto not3Args;
  963.         }
  964.         mode = R_OK;
  965. checkAccess:
  966.         /*
  967.          * The result might have been set within Tcl_TranslateFileName
  968.          * (like no such user "blah" for file exists ~blah)
  969.          * but we don't want to flag an error in that case.
  970.          */
  971.         if (fileName == NULL) {
  972.         Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0));
  973.         } else {
  974.         Tcl_SetBooleanObj(resultPtr, (access(fileName, mode) != -1));
  975.         }
  976.         goto done;
  977.       case FILE_WRITABLE:
  978.         if (objc != 3) {
  979.             errorString = "writable name";
  980.             goto not3Args;
  981.         }
  982.         mode = W_OK;
  983.         goto checkAccess;
  984.       case FILE_EXECUTABLE:
  985.         if (objc != 3) {
  986.             errorString = "executable name";
  987.             goto not3Args;
  988.         }
  989.         mode = X_OK;
  990.         goto checkAccess;
  991.       case FILE_EXISTS:
  992.         if (objc != 3) {
  993.             errorString = "exists name";
  994.             goto not3Args;
  995.         }
  996.         mode = F_OK;
  997.         goto checkAccess;
  998.     }
  999.  
  1000.     
  1001.     /*
  1002.      * Lastly, check stuff that requires the file to be stat-ed.
  1003.      */
  1004.  
  1005.     if (fileName == NULL) {
  1006.     result = TCL_ERROR;
  1007.     goto done;
  1008.     }
  1009.     
  1010.     switch (index) {
  1011.         case FILE_ATIME:
  1012.             if (objc != 3) {
  1013.             errorString = "atime name";
  1014.             goto not3Args;
  1015.         }
  1016.         
  1017.         if (stat(fileName, &statBuf) == -1) {
  1018.             goto badStat;
  1019.         }
  1020.         Tcl_SetLongObj(resultPtr, (long) statBuf.st_atime);
  1021.         goto done;
  1022.         case FILE_ISDIRECTORY:
  1023.             if (objc != 3) {
  1024.                 errorString = "isdirectory name";
  1025.                 goto not3Args;
  1026.             }
  1027.             statOp = 2;
  1028.             break;
  1029.         case FILE_ISFILE:
  1030.             if (objc != 3) {
  1031.                 errorString = "isfile name";
  1032.                 goto not3Args;
  1033.             }
  1034.             statOp = 1;
  1035.             break;
  1036.         case FILE_LSTAT:
  1037.             if (objc != 4) {
  1038.                 Tcl_WrongNumArgs(interp, 1, objv, "lstat name varName");
  1039.                 result = TCL_ERROR;
  1040.                 goto done;
  1041.             }
  1042.             
  1043.             if (lstat(fileName, &statBuf) == -1) {
  1044.                 Tcl_AppendStringsToObj(resultPtr, "couldn't lstat \"",
  1045.                     Tcl_GetStringFromObj(objv[2], &length), "\": ",
  1046.                     Tcl_PosixError(interp), (char *) NULL);
  1047.                 result = TCL_ERROR;
  1048.                 goto done;
  1049.             }
  1050.             result = StoreStatData(interp, Tcl_GetStringFromObj(objv[3],
  1051.                     &length), &statBuf);
  1052.             goto done;
  1053.     case FILE_MTIME:
  1054.         if (objc != 3) {
  1055.             errorString = "mtime name";
  1056.             goto not3Args;
  1057.         }
  1058.         if (stat(fileName, &statBuf) == -1) {
  1059.             goto badStat;
  1060.         }
  1061.         Tcl_SetLongObj(resultPtr, (long) statBuf.st_mtime);
  1062.         goto done;
  1063.     case FILE_OWNED:
  1064.         if (objc != 3) {
  1065.             errorString = "owned name";
  1066.             goto not3Args;
  1067.         }                    
  1068.             statOp = 0;
  1069.             break;
  1070.     case FILE_READLINK: {
  1071.         char linkValue[MAXPATHLEN + 1];
  1072.         int linkLength;
  1073.         
  1074.         if (objc != 3) {
  1075.             errorString = "readlink name";
  1076.             goto not3Args;
  1077.         }
  1078.  
  1079.         /*
  1080.          * If S_IFLNK isn't defined it means that the machine doesn't
  1081.          * support symbolic links, so the file can't possibly be a
  1082.          * symbolic link.  Generate an EINVAL error, which is what
  1083.          * happens on machines that do support symbolic links when
  1084.          * you invoke readlink on a file that isn't a symbolic link.
  1085.          */
  1086.  
  1087. #ifndef S_IFLNK
  1088.         linkLength = -1;
  1089.         errno = EINVAL;
  1090. #else
  1091.         linkLength = readlink(fileName, linkValue, sizeof(linkValue) - 1);
  1092. #endif /* S_IFLNK */
  1093.         if (linkLength == -1) {
  1094.             Tcl_AppendStringsToObj(resultPtr, "couldn't readlink \"", 
  1095.                 Tcl_GetStringFromObj(objv[2], &length), "\": ", 
  1096.                 Tcl_PosixError(interp), (char *) NULL);
  1097.             result = TCL_ERROR;
  1098.             goto done;
  1099.         }
  1100.         linkValue[linkLength] = 0;
  1101.         Tcl_SetStringObj(resultPtr, linkValue, linkLength);
  1102.         goto done;
  1103.     }
  1104.     case FILE_SIZE:
  1105.         if (objc != 3) {
  1106.             errorString = "size name";
  1107.             goto not3Args;
  1108.         }
  1109.         if (stat(fileName, &statBuf) == -1) {
  1110.             goto badStat;
  1111.         }
  1112.         Tcl_SetLongObj(resultPtr, (long) statBuf.st_size);
  1113.         goto done;
  1114.     case FILE_STAT:
  1115.         if (objc != 4) {
  1116.             Tcl_WrongNumArgs(interp, 1, objv, "stat name varName");
  1117.             result = TCL_ERROR;
  1118.             goto done;
  1119.         }
  1120.  
  1121.         if (stat(fileName, &statBuf) == -1) {
  1122. badStat:
  1123.         Tcl_AppendStringsToObj(resultPtr, "couldn't stat \"", 
  1124.             Tcl_GetStringFromObj(objv[2], &length),
  1125.                 "\": ", Tcl_PosixError(interp), (char *) NULL);
  1126.             result = TCL_ERROR;
  1127.             goto done;
  1128.         }
  1129.         result = StoreStatData(interp, Tcl_GetStringFromObj(objv[3],
  1130.                 &length), &statBuf);
  1131.         goto done;
  1132.     case FILE_TYPE:
  1133.         if (objc != 3) {
  1134.             errorString = "type name";
  1135.             goto not3Args;
  1136.         }
  1137.         if (lstat(fileName, &statBuf) == -1) {
  1138.             goto badStat;
  1139.         }
  1140.         errorString = GetTypeFromMode((int) statBuf.st_mode);
  1141.         Tcl_SetStringObj(resultPtr, errorString, -1);
  1142.         goto done;
  1143.     }
  1144.  
  1145.     if (stat(fileName, &statBuf) == -1) {
  1146.         Tcl_SetBooleanObj(resultPtr, 0);
  1147.     goto done;
  1148.     }
  1149.     switch (statOp) {
  1150.     case 0:
  1151.         /*
  1152.          * For Windows and Macintosh, there are no user ids 
  1153.          * associated with a file, so we always return 1.
  1154.          */
  1155.  
  1156. #if (defined(__WIN32__) || defined(MAC_TCL))
  1157.         mode = 1;
  1158. #else
  1159.         mode = (geteuid() == statBuf.st_uid);
  1160. #endif
  1161.         break;
  1162.     case 1:
  1163.         mode = S_ISREG(statBuf.st_mode);
  1164.         break;
  1165.     case 2:
  1166.         mode = S_ISDIR(statBuf.st_mode);
  1167.         break;
  1168.     }
  1169.     Tcl_SetBooleanObj(resultPtr, mode);
  1170.  
  1171. done:
  1172.     Tcl_DStringFree(&buffer);
  1173.     return result;
  1174.  
  1175. not3Args:
  1176.     Tcl_WrongNumArgs(interp, 1, objv, errorString);
  1177.     result = TCL_ERROR;
  1178.     goto done;
  1179. }
  1180.  
  1181. /*
  1182.  *----------------------------------------------------------------------
  1183.  *
  1184.  * StoreStatData --
  1185.  *
  1186.  *    This is a utility procedure that breaks out the fields of a
  1187.  *    "stat" structure and stores them in textual form into the
  1188.  *    elements of an associative array.
  1189.  *
  1190.  * Results:
  1191.  *    Returns a standard Tcl return value.  If an error occurs then
  1192.  *    a message is left in interp->result.
  1193.  *
  1194.  * Side effects:
  1195.  *    Elements of the associative array given by "varName" are modified.
  1196.  *
  1197.  *----------------------------------------------------------------------
  1198.  */
  1199.  
  1200. static int
  1201. StoreStatData(interp, varName, statPtr)
  1202.     Tcl_Interp *interp;            /* Interpreter for error reports. */
  1203.     char *varName;            /* Name of associative array variable
  1204.                      * in which to store stat results. */
  1205.     struct stat *statPtr;        /* Pointer to buffer containing
  1206.                      * stat data to store in varName. */
  1207. {
  1208.     char string[30];
  1209.  
  1210.     sprintf(string, "%ld", (long) statPtr->st_dev);
  1211.     if (Tcl_SetVar2(interp, varName, "dev", string, TCL_LEAVE_ERR_MSG)
  1212.         == NULL) {
  1213.     return TCL_ERROR;
  1214.     }
  1215.     sprintf(string, "%ld", (long) statPtr->st_ino);
  1216.     if (Tcl_SetVar2(interp, varName, "ino", string, TCL_LEAVE_ERR_MSG)
  1217.         == NULL) {
  1218.     return TCL_ERROR;
  1219.     }
  1220.     sprintf(string, "%ld", (long) statPtr->st_mode);
  1221.     if (Tcl_SetVar2(interp, varName, "mode", string, TCL_LEAVE_ERR_MSG)
  1222.         == NULL) {
  1223.     return TCL_ERROR;
  1224.     }
  1225.     sprintf(string, "%ld", (long) statPtr->st_nlink);
  1226.     if (Tcl_SetVar2(interp, varName, "nlink", string, TCL_LEAVE_ERR_MSG)
  1227.         == NULL) {
  1228.     return TCL_ERROR;
  1229.     }
  1230.     sprintf(string, "%ld", (long) statPtr->st_uid);
  1231.     if (Tcl_SetVar2(interp, varName, "uid", string, TCL_LEAVE_ERR_MSG)
  1232.         == NULL) {
  1233.     return TCL_ERROR;
  1234.     }
  1235.     sprintf(string, "%ld", (long) statPtr->st_gid);
  1236.     if (Tcl_SetVar2(interp, varName, "gid", string, TCL_LEAVE_ERR_MSG)
  1237.         == NULL) {
  1238.     return TCL_ERROR;
  1239.     }
  1240.     sprintf(string, "%lu", (unsigned long) statPtr->st_size);
  1241.     if (Tcl_SetVar2(interp, varName, "size", string, TCL_LEAVE_ERR_MSG)
  1242.         == NULL) {
  1243.     return TCL_ERROR;
  1244.     }
  1245.     sprintf(string, "%ld", (long) statPtr->st_atime);
  1246.     if (Tcl_SetVar2(interp, varName, "atime", string, TCL_LEAVE_ERR_MSG)
  1247.         == NULL) {
  1248.     return TCL_ERROR;
  1249.     }
  1250.     sprintf(string, "%ld", (long) statPtr->st_mtime);
  1251.     if (Tcl_SetVar2(interp, varName, "mtime", string, TCL_LEAVE_ERR_MSG)
  1252.         == NULL) {
  1253.     return TCL_ERROR;
  1254.     }
  1255.     sprintf(string, "%ld", (long) statPtr->st_ctime);
  1256.     if (Tcl_SetVar2(interp, varName, "ctime", string, TCL_LEAVE_ERR_MSG)
  1257.         == NULL) {
  1258.     return TCL_ERROR;
  1259.     }
  1260.     if (Tcl_SetVar2(interp, varName, "type",
  1261.         GetTypeFromMode((int) statPtr->st_mode), TCL_LEAVE_ERR_MSG) 
  1262.             == NULL) {
  1263.     return TCL_ERROR;
  1264.     }
  1265.     return TCL_OK;
  1266. }
  1267.  
  1268. /*
  1269.  *----------------------------------------------------------------------
  1270.  *
  1271.  * GetTypeFromMode --
  1272.  *
  1273.  *    Given a mode word, returns a string identifying the type of a
  1274.  *    file.
  1275.  *
  1276.  * Results:
  1277.  *    A static text string giving the file type from mode.
  1278.  *
  1279.  * Side effects:
  1280.  *    None.
  1281.  *
  1282.  *----------------------------------------------------------------------
  1283.  */
  1284.  
  1285. static char *
  1286. GetTypeFromMode(mode)
  1287.     int mode;
  1288. {
  1289.     if (S_ISREG(mode)) {
  1290.     return "file";
  1291.     } else if (S_ISDIR(mode)) {
  1292.     return "directory";
  1293.     } else if (S_ISCHR(mode)) {
  1294.     return "characterSpecial";
  1295.     } else if (S_ISBLK(mode)) {
  1296.     return "blockSpecial";
  1297.     } else if (S_ISFIFO(mode)) {
  1298.     return "fifo";
  1299. #ifdef S_ISLNK
  1300.     } else if (S_ISLNK(mode)) {
  1301.     return "link";
  1302. #endif
  1303. #ifdef S_ISSOCK
  1304.     } else if (S_ISSOCK(mode)) {
  1305.     return "socket";
  1306. #endif
  1307.     }
  1308.     return "unknown";
  1309. }
  1310.  
  1311. /*
  1312.  *----------------------------------------------------------------------
  1313.  *
  1314.  * Tcl_ForCmd --
  1315.  *
  1316.  *      This procedure is invoked to process the "for" Tcl command.
  1317.  *      See the user documentation for details on what it does.
  1318.  *
  1319.  *    With the bytecode compiler, this procedure is only called when
  1320.  *    a command name is computed at runtime, and is "for" or the name
  1321.  *    to which "for" was renamed: e.g.,
  1322.  *    "set z for; $z {set i 0} {$i<100} {incr i} {puts $i}"
  1323.  *
  1324.  * Results:
  1325.  *      A standard Tcl result.
  1326.  *
  1327.  * Side effects:
  1328.  *      See the user documentation.
  1329.  *
  1330.  *----------------------------------------------------------------------
  1331.  */
  1332.  
  1333.         /* ARGSUSED */
  1334. int
  1335. Tcl_ForCmd(dummy, interp, argc, argv)
  1336.     ClientData dummy;                   /* Not used. */
  1337.     Tcl_Interp *interp;                 /* Current interpreter. */
  1338.     int argc;                           /* Number of arguments. */
  1339.     char **argv;                        /* Argument strings. */
  1340. {
  1341.     int result, value;
  1342.  
  1343.     if (argc != 5) {
  1344.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1345.                 " start test next command\"", (char *) NULL);
  1346.         return TCL_ERROR;
  1347.     }
  1348.  
  1349.     result = Tcl_Eval(interp, argv[1]);
  1350.     if (result != TCL_OK) {
  1351.         if (result == TCL_ERROR) {
  1352.             Tcl_AddErrorInfo(interp, "\n    (\"for\" initial command)");
  1353.         }
  1354.         return result;
  1355.     }
  1356.     while (1) {
  1357.         result = Tcl_ExprBoolean(interp, argv[2], &value);
  1358.         if (result != TCL_OK) {
  1359.             return result;
  1360.         }
  1361.         if (!value) {
  1362.             break;
  1363.         }
  1364.         result = Tcl_Eval(interp, argv[4]);
  1365.         if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
  1366.             if (result == TCL_ERROR) {
  1367.                 char msg[60];
  1368.                 sprintf(msg, "\n    (\"for\" body line %d)",interp->errorLine);
  1369.                 Tcl_AddErrorInfo(interp, msg);
  1370.             }
  1371.             break;
  1372.         }
  1373.         result = Tcl_Eval(interp, argv[3]);
  1374.     if (result == TCL_BREAK) {
  1375.             break;
  1376.         } else if (result != TCL_OK) {
  1377.             if (result == TCL_ERROR) {
  1378.                 Tcl_AddErrorInfo(interp, "\n    (\"for\" loop-end command)");
  1379.             }
  1380.             return result;
  1381.         }
  1382.     }
  1383.     if (result == TCL_BREAK) {
  1384.         result = TCL_OK;
  1385.     }
  1386.     if (result == TCL_OK) {
  1387.         Tcl_ResetResult(interp);
  1388.     }
  1389.     return result;
  1390. }
  1391.  
  1392. /*
  1393.  *----------------------------------------------------------------------
  1394.  *
  1395.  * Tcl_ForeachObjCmd --
  1396.  *
  1397.  *    This object-based procedure is invoked to process the "foreach" Tcl
  1398.  *    command.  See the user documentation for details on what it does.
  1399.  *
  1400.  * Results:
  1401.  *    A standard Tcl object result.
  1402.  *
  1403.  * Side effects:
  1404.  *    See the user documentation.
  1405.  *
  1406.  *----------------------------------------------------------------------
  1407.  */
  1408.  
  1409.     /* ARGSUSED */
  1410. int
  1411. Tcl_ForeachObjCmd(dummy, interp, objc, objv)
  1412.     ClientData dummy;        /* Not used. */
  1413.     Tcl_Interp *interp;        /* Current interpreter. */
  1414.     int objc;            /* Number of arguments. */
  1415.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  1416. {
  1417.     int result = TCL_OK;
  1418.     int i;            /* i selects a value list */
  1419.     int j, maxj;        /* Number of loop iterations */
  1420.     int v;            /* v selects a loop variable */
  1421.     int numLists;        /* Count of value lists */
  1422.     Tcl_Obj *bodyPtr;
  1423.  
  1424.     /*
  1425.      * We copy the argument object pointers into a local array to avoid
  1426.      * the problem that "objv" might become invalid. It is a pointer into
  1427.      * the evaluation stack and that stack might be grown and reallocated
  1428.      * if the loop body requires a large amount of stack space.
  1429.      */
  1430.     
  1431. #define NUM_ARGS 9
  1432.     Tcl_Obj *(argObjStorage[NUM_ARGS]);
  1433.     Tcl_Obj **argObjv = argObjStorage;
  1434.     
  1435. #define STATIC_LIST_SIZE 4
  1436.     int indexArray[STATIC_LIST_SIZE];      /* Array of value list indices */
  1437.     int varcListArray[STATIC_LIST_SIZE];  /* # loop variables per list */
  1438.     Tcl_Obj **varvListArray[STATIC_LIST_SIZE]; /* Array of var name lists */
  1439.     int argcListArray[STATIC_LIST_SIZE];  /* Array of value list sizes */
  1440.     Tcl_Obj **argvListArray[STATIC_LIST_SIZE]; /* Array of value lists */
  1441.  
  1442.     int *index = indexArray;
  1443.     int *varcList = varcListArray;
  1444.     Tcl_Obj ***varvList = varvListArray;
  1445.     int *argcList = argcListArray;
  1446.     Tcl_Obj ***argvList = argvListArray;
  1447.  
  1448.     if (objc < 4 || (objc%2 != 0)) {
  1449.     Tcl_WrongNumArgs(interp, 1, objv,
  1450.         "varList list ?varList list ...? command");
  1451.     return TCL_ERROR;
  1452.     }
  1453.  
  1454.     /*
  1455.      * Create the object argument array "argObjv". Make sure argObjv is
  1456.      * large enough to hold the objc arguments.
  1457.      */
  1458.  
  1459.     if (objc > NUM_ARGS) {
  1460.     argObjv = (Tcl_Obj **) ckalloc(objc * sizeof(Tcl_Obj *));
  1461.     }
  1462.     for (i = 0;  i < objc;  i++) {
  1463.     argObjv[i] = objv[i];
  1464.     }
  1465.  
  1466.     /*
  1467.      * Manage numList parallel value lists.
  1468.      * argvList[i] is a value list counted by argcList[i]
  1469.      * varvList[i] is the list of variables associated with the value list
  1470.      * varcList[i] is the number of variables associated with the value list
  1471.      * index[i] is the current pointer into the value list argvList[i]
  1472.      */
  1473.  
  1474.     numLists = (objc-2)/2;
  1475.     if (numLists > STATIC_LIST_SIZE) {
  1476.     index = (int *) ckalloc(numLists * sizeof(int));
  1477.     varcList = (int *) ckalloc(numLists * sizeof(int));
  1478.     varvList = (Tcl_Obj ***) ckalloc(numLists * sizeof(Tcl_Obj **));
  1479.     argcList = (int *) ckalloc(numLists * sizeof(int));
  1480.     argvList = (Tcl_Obj ***) ckalloc(numLists * sizeof(Tcl_Obj **));
  1481.     }
  1482.     for (i = 0;  i < numLists;  i++) {
  1483.     index[i] = 0;
  1484.     varcList[i] = 0;
  1485.     varvList[i] = (Tcl_Obj **) NULL;
  1486.     argcList[i] = 0;
  1487.     argvList[i] = (Tcl_Obj **) NULL;
  1488.     }
  1489.  
  1490.     /*
  1491.      * Break up the value lists and variable lists into elements
  1492.      * THIS FAILS IF THE OBJECT'S STRING REP HAS A NULL BYTE.
  1493.      */
  1494.  
  1495.     maxj = 0;
  1496.     for (i = 0;  i < numLists;  i++) {
  1497.     result = Tcl_ListObjGetElements(interp, argObjv[1+i*2],
  1498.             &varcList[i], &varvList[i]);
  1499.     if (result != TCL_OK) {
  1500.         goto done;
  1501.     }
  1502.     if (varcList[i] < 1) {
  1503.         Tcl_AppendToObj(Tcl_GetObjResult(interp),
  1504.                 "foreach varlist is empty", -1);
  1505.         result = TCL_ERROR;
  1506.         goto done;
  1507.     }
  1508.     
  1509.     result = Tcl_ListObjGetElements(interp, argObjv[2+i*2],
  1510.             &argcList[i], &argvList[i]);
  1511.     if (result != TCL_OK) {
  1512.         goto done;
  1513.     }
  1514.     
  1515.     j = argcList[i] / varcList[i];
  1516.     if ((argcList[i] % varcList[i]) != 0) {
  1517.         j++;
  1518.     }
  1519.     if (j > maxj) {
  1520.         maxj = j;
  1521.     }
  1522.     }
  1523.  
  1524.     /*
  1525.      * Iterate maxj times through the lists in parallel
  1526.      * If some value lists run out of values, set loop vars to ""
  1527.      */
  1528.     
  1529.     bodyPtr = argObjv[objc-1];
  1530.     for (j = 0;  j < maxj;  j++) {
  1531.     for (i = 0;  i < numLists;  i++) {
  1532.         /*
  1533.          * If a variable or value list object has been converted to
  1534.          * another kind of Tcl object, convert it back to a list object
  1535.          * and refetch the pointer to its element array.
  1536.          */
  1537.  
  1538.         if (argObjv[1+i*2]->typePtr != &tclListType) {
  1539.         result = Tcl_ListObjGetElements(interp, argObjv[1+i*2],
  1540.                 &varcList[i], &varvList[i]);
  1541.         if (result != TCL_OK) {
  1542.             panic("Tcl_ForeachObjCmd: could not reconvert variable list %d to a list object\n", i);
  1543.         }
  1544.         }
  1545.         if (argObjv[2+i*2]->typePtr != &tclListType) {
  1546.         result = Tcl_ListObjGetElements(interp, argObjv[2+i*2],
  1547.                     &argcList[i], &argvList[i]);
  1548.         if (result != TCL_OK) {
  1549.             panic("Tcl_ForeachObjCmd: could not reconvert value list %d to a list object\n", i);
  1550.         }
  1551.         }
  1552.         
  1553.         for (v = 0;  v < varcList[i];  v++) {
  1554.         int k = index[i]++;
  1555.         Tcl_Obj *valuePtr, *varValuePtr;
  1556.         int isEmptyObj = 0;
  1557.         
  1558.         if (k < argcList[i]) {
  1559.             valuePtr = argvList[i][k];
  1560.         } else {
  1561.             valuePtr = Tcl_NewObj(); /* empty string */
  1562.             isEmptyObj = 1;
  1563.         }
  1564.         varValuePtr = Tcl_ObjSetVar2(interp, varvList[i][v], NULL,
  1565.             valuePtr, TCL_PARSE_PART1);
  1566.         if (varValuePtr == NULL) {
  1567.             if (isEmptyObj) {
  1568.             Tcl_DecrRefCount(valuePtr);
  1569.             }
  1570.             Tcl_ResetResult(interp);
  1571.             Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  1572.             "couldn't set loop variable: \"",
  1573.             Tcl_GetStringFromObj(varvList[i][v], (int *) NULL),
  1574.             "\"", (char *) NULL);
  1575.             result = TCL_ERROR;
  1576.             goto done;
  1577.         }
  1578.  
  1579.         }
  1580.     }
  1581.  
  1582.     result = Tcl_EvalObj(interp, bodyPtr);
  1583.     if (result != TCL_OK) {
  1584.         if (result == TCL_CONTINUE) {
  1585.         result = TCL_OK;
  1586.         } else if (result == TCL_BREAK) {
  1587.         result = TCL_OK;
  1588.         break;
  1589.         } else if (result == TCL_ERROR) {
  1590.         char msg[100];
  1591.         sprintf(msg, "\n    (\"foreach\" body line %d)",
  1592.             interp->errorLine);
  1593.         Tcl_AddObjErrorInfo(interp, msg, -1);
  1594.         break;
  1595.         } else {
  1596.         break;
  1597.         }
  1598.     }
  1599.     }
  1600.     if (result == TCL_OK) {
  1601.     Tcl_ResetResult(interp);
  1602.     }
  1603.  
  1604.     done:
  1605.     if (numLists > STATIC_LIST_SIZE) {
  1606.     ckfree((char *) index);
  1607.     ckfree((char *) varcList);
  1608.     ckfree((char *) argcList);
  1609.     ckfree((char *) varvList);
  1610.     ckfree((char *) argvList);
  1611.     }
  1612.     if (argObjv != argObjStorage) {
  1613.     ckfree((char *) argObjv);
  1614.     }
  1615.     return result;
  1616. #undef STATIC_LIST_SIZE
  1617. #undef NUM_ARGS
  1618. }
  1619.  
  1620. /*
  1621.  *----------------------------------------------------------------------
  1622.  *
  1623.  * Tcl_FormatObjCmd --
  1624.  *
  1625.  *    This procedure is invoked to process the "format" Tcl command.
  1626.  *    See the user documentation for details on what it does.
  1627.  *
  1628.  * Results:
  1629.  *    A standard Tcl result.
  1630.  *
  1631.  * Side effects:
  1632.  *    See the user documentation.
  1633.  *
  1634.  *----------------------------------------------------------------------
  1635.  */
  1636.  
  1637.     /* ARGSUSED */
  1638. int
  1639. Tcl_FormatObjCmd(dummy, interp, objc, objv)
  1640.     ClientData dummy;        /* Not used. */
  1641.     Tcl_Interp *interp;        /* Current interpreter. */
  1642.     int objc;            /* Number of arguments. */
  1643.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  1644. {
  1645.     register char *format;    /* Used to read characters from the format
  1646.                  * string. */
  1647.     int formatLen;              /* The length of the format string */
  1648.     char *endPtr;               /* Points to the last char in format array */
  1649.     char newFormat[40];        /* A new format specifier is generated here. */
  1650.     int width;            /* Field width from field specifier, or 0 if
  1651.                  * no width given. */
  1652.     int precision;        /* Field precision from field specifier, or 0
  1653.                  * if no precision given. */
  1654.     int size;            /* Number of bytes needed for result of
  1655.                  * conversion, based on type of conversion
  1656.                  * ("e", "s", etc.), width, and precision. */
  1657.     int intValue;        /* Used to hold value to pass to sprintf, if
  1658.                  * it's a one-word integer or char value */
  1659.     char *ptrValue = NULL;    /* Used to hold value to pass to sprintf, if
  1660.                  * it's a one-word value. */
  1661.     double doubleValue;        /* Used to hold value to pass to sprintf if
  1662.                  * it's a double value. */
  1663.     int whichValue;        /* Indicates which of intValue, ptrValue,
  1664.                  * or doubleValue has the value to pass to
  1665.                  * sprintf, according to the following
  1666.                  * definitions: */
  1667. #   define INT_VALUE 0
  1668. #   define PTR_VALUE 1
  1669. #   define DOUBLE_VALUE 2
  1670. #   define MAX_FLOAT_SIZE 320
  1671.     
  1672.     Tcl_Obj *resultPtr;      /* Where result is stored finally. */
  1673.     char staticBuf[MAX_FLOAT_SIZE];
  1674.                                 /* A static buffer to copy the format results 
  1675.                  * into */
  1676.     char *dst = staticBuf;      /* The buffer that sprintf writes into each
  1677.                  * time the format processes a specifier */
  1678.     int dstSize = MAX_FLOAT_SIZE;
  1679.                                 /* The size of the dst buffer */
  1680.     int noPercent;        /* Special case for speed:  indicates there's
  1681.                  * no field specifier, just a string to copy.*/
  1682.     int objIndex;        /* Index of argument to substitute next. */
  1683.     int gotXpg = 0;        /* Non-zero means that an XPG3 %n$-style
  1684.                  * specifier has been seen. */
  1685.     int gotSequential = 0;    /* Non-zero means that a regular sequential
  1686.                  * (non-XPG3) conversion specifier has been
  1687.                  * seen. */
  1688.     int useShort;        /* Value to be printed is short (half word). */
  1689.     char *end;            /* Used to locate end of numerical fields. */
  1690.  
  1691.     /*
  1692.      * This procedure is a bit nasty.  The goal is to use sprintf to
  1693.      * do most of the dirty work.  There are several problems:
  1694.      * 1. this procedure can't trust its arguments.
  1695.      * 2. we must be able to provide a large enough result area to hold
  1696.      *    whatever's generated.  This is hard to estimate.
  1697.      * 2. there's no way to move the arguments from objv to the call
  1698.      *    to sprintf in a reasonable way.  This is particularly nasty
  1699.      *    because some of the arguments may be two-word values (doubles).
  1700.      * So, what happens here is to scan the format string one % group
  1701.      * at a time, making many individual calls to sprintf.
  1702.      */
  1703.  
  1704.     if (objc < 2) {
  1705.         Tcl_WrongNumArgs(interp, 1, objv,
  1706.         "formatString ?arg arg ...?");
  1707.     return TCL_ERROR;
  1708.     }
  1709.  
  1710.     format = Tcl_GetStringFromObj(objv[1], &formatLen);
  1711.     endPtr = format + formatLen;
  1712.     resultPtr = Tcl_NewObj();
  1713.     objIndex = 2;
  1714.  
  1715.     while (format < endPtr) {
  1716.     register char *newPtr = newFormat;
  1717.  
  1718.     width = precision = noPercent = useShort = 0;
  1719.     whichValue = PTR_VALUE;
  1720.  
  1721.     /*
  1722.      * Get rid of any characters before the next field specifier.
  1723.      */
  1724.     if (*format != '%') {
  1725.         ptrValue = format;
  1726.         while ((*format != '%') && (format < endPtr)) {
  1727.         format++;
  1728.         }
  1729.         size = format - ptrValue;
  1730.         noPercent = 1;
  1731.         goto doField;
  1732.     }
  1733.  
  1734.     if (format[1] == '%') {
  1735.         ptrValue = format;
  1736.         size = 1;
  1737.         noPercent = 1;
  1738.         format += 2;
  1739.         goto doField;
  1740.     }
  1741.  
  1742.     /*
  1743.      * Parse off a field specifier, compute how many characters
  1744.      * will be needed to store the result, and substitute for
  1745.      * "*" size specifiers.
  1746.      */
  1747.     *newPtr = '%';
  1748.     newPtr++;
  1749.     format++;
  1750.     if (isdigit(UCHAR(*format))) {
  1751.         int tmp;
  1752.  
  1753.         /*
  1754.          * Check for an XPG3-style %n$ specification.  Note: there
  1755.          * must not be a mixture of XPG3 specs and non-XPG3 specs
  1756.          * in the same format string.
  1757.          */
  1758.  
  1759.         tmp = strtoul(format, &end, 10);
  1760.         if (*end != '$') {
  1761.         goto notXpg;
  1762.         }
  1763.         format = end+1;
  1764.         gotXpg = 1;
  1765.         if (gotSequential) {
  1766.         goto mixedXPG;
  1767.         }
  1768.         objIndex = tmp+1;
  1769.         if ((objIndex < 2) || (objIndex >= objc)) {
  1770.         goto badIndex;
  1771.         }
  1772.         goto xpgCheckDone;
  1773.     }
  1774.  
  1775.     notXpg:
  1776.     gotSequential = 1;
  1777.     if (gotXpg) {
  1778.         goto mixedXPG;
  1779.     }
  1780.  
  1781.     xpgCheckDone:
  1782.     while ((*format == '-') || (*format == '#') || (*format == '0')
  1783.         || (*format == ' ') || (*format == '+')) {
  1784.         *newPtr = *format;
  1785.         newPtr++;
  1786.         format++;
  1787.     }
  1788.     if (isdigit(UCHAR(*format))) {
  1789.         width = strtoul(format, &end, 10);
  1790.         format = end;
  1791.     } else if (*format == '*') {
  1792.         if (objIndex >= objc) {
  1793.         goto badIndex;
  1794.         }
  1795.         if (Tcl_GetIntFromObj(interp, objv[objIndex], 
  1796.                     &width) != TCL_OK) {
  1797.         goto fmtError;
  1798.         }
  1799.         objIndex++;
  1800.         format++;
  1801.     }
  1802.     if (width > 100000) {
  1803.         /*
  1804.          * Don't allow arbitrarily large widths:  could cause core
  1805.          * dump when we try to allocate a zillion bytes of memory
  1806.          * below.
  1807.          */
  1808.  
  1809.         width = 100000;
  1810.     } else if (width < 0) {
  1811.         width = 0;
  1812.     }
  1813.     if (width != 0) {
  1814.         TclFormatInt(newPtr, width);
  1815.         while (*newPtr != 0) {
  1816.         newPtr++;
  1817.         }
  1818.     }
  1819.     if (*format == '.') {
  1820.         *newPtr = '.';
  1821.         newPtr++;
  1822.         format++;
  1823.     }
  1824.     if (isdigit(UCHAR(*format))) {
  1825.         precision = strtoul(format, &end, 10);
  1826.         format = end;
  1827.     } else if (*format == '*') {
  1828.         if (objIndex >= objc) {
  1829.         goto badIndex;
  1830.         }
  1831.         if (Tcl_GetIntFromObj(interp, objv[objIndex], 
  1832.                     &precision) != TCL_OK) {
  1833.         goto fmtError;
  1834.         }
  1835.         objIndex++;
  1836.         format++;
  1837.     }
  1838.     if (precision != 0) {
  1839.         TclFormatInt(newPtr, precision);
  1840.         while (*newPtr != 0) {
  1841.         newPtr++;
  1842.         }
  1843.     }
  1844.     if (*format == 'l') {
  1845.         format++;
  1846.     } else if (*format == 'h') {
  1847.         useShort = 1;
  1848.         *newPtr = 'h';
  1849.         newPtr++;
  1850.         format++;
  1851.     }
  1852.     *newPtr = *format;
  1853.     newPtr++;
  1854.     *newPtr = 0;
  1855.     if (objIndex >= objc) {
  1856.         goto badIndex;
  1857.     }
  1858.     switch (*format) {
  1859.         case 'i':
  1860.         newPtr[-1] = 'd';
  1861.         case 'd':
  1862.         case 'o':
  1863.         case 'u':
  1864.         case 'x':
  1865.         case 'X':
  1866.         if (Tcl_GetIntFromObj(interp, objv[objIndex], 
  1867.                 (int *) &intValue) != TCL_OK) {
  1868.             goto fmtError;
  1869.         }
  1870.         whichValue = INT_VALUE;
  1871.         size = 40 + precision;
  1872.         break;
  1873.         case 's':
  1874.         ptrValue = Tcl_GetStringFromObj(objv[objIndex], &size);
  1875.         break;
  1876.         case 'c':
  1877.         if (Tcl_GetIntFromObj(interp, objv[objIndex], 
  1878.                         (int *) &intValue) != TCL_OK) {
  1879.             goto fmtError;
  1880.         }
  1881.         whichValue = INT_VALUE;
  1882.         size = 1;
  1883.         break;
  1884.         case 'e':
  1885.         case 'E':
  1886.         case 'f':
  1887.         case 'g':
  1888.         case 'G':
  1889.         if (Tcl_GetDoubleFromObj(interp, objv[objIndex], 
  1890.             &doubleValue) != TCL_OK) {
  1891.             goto fmtError;
  1892.         }
  1893.         whichValue = DOUBLE_VALUE;
  1894.         size = MAX_FLOAT_SIZE;
  1895.         if (precision > 10) {
  1896.             size += precision;
  1897.         }
  1898.         break;
  1899.         case 0:
  1900.         Tcl_SetResult(interp,
  1901.                 "format string ended in middle of field specifier",
  1902.             TCL_STATIC);
  1903.         goto fmtError;
  1904.         default:
  1905.         {
  1906.             char buf[40];
  1907.             sprintf(buf, "bad field specifier \"%c\"", *format);
  1908.             Tcl_SetResult(interp, buf, TCL_VOLATILE);
  1909.             goto fmtError;
  1910.         }
  1911.     }
  1912.     objIndex++;
  1913.     format++;
  1914.  
  1915.     /*
  1916.      * Make sure that there's enough space to hold the formatted
  1917.      * result, then format it.
  1918.      */
  1919.  
  1920.     doField:
  1921.     if (width > size) {
  1922.         size = width;
  1923.     }
  1924.     if (noPercent) {
  1925.         Tcl_AppendToObj(resultPtr, ptrValue, size);
  1926.     } else {
  1927.         if (size > dstSize) {
  1928.             if (dst != staticBuf) {
  1929.             ckfree(dst);
  1930.         }
  1931.         dst = (char *) ckalloc((unsigned) (size + 1));
  1932.         dstSize = size;
  1933.         }
  1934.  
  1935.         if (whichValue == DOUBLE_VALUE) {
  1936.             sprintf(dst, newFormat, doubleValue);
  1937.         } else if (whichValue == INT_VALUE) {
  1938.         if (useShort) {
  1939.             sprintf(dst, newFormat, (short) intValue);
  1940.         } else {
  1941.             sprintf(dst, newFormat, intValue);
  1942.         }
  1943.         } else {
  1944.             sprintf(dst, newFormat, ptrValue);
  1945.         }
  1946.         Tcl_AppendToObj(resultPtr, dst, -1);
  1947.     }
  1948.     }
  1949.  
  1950.     Tcl_SetObjResult(interp, resultPtr);
  1951.     if(dst != staticBuf) {
  1952.         ckfree(dst);
  1953.     }
  1954.     return TCL_OK;
  1955.  
  1956.     mixedXPG:
  1957.     Tcl_SetResult(interp, 
  1958.             "cannot mix \"%\" and \"%n$\" conversion specifiers", TCL_STATIC);
  1959.     goto fmtError;
  1960.  
  1961.     badIndex:
  1962.     if (gotXpg) {
  1963.         Tcl_SetResult(interp, 
  1964.                 "\"%n$\" argument index out of range", TCL_STATIC);
  1965.     } else {
  1966.         Tcl_SetResult(interp, 
  1967.                 "not enough arguments for all format specifiers", TCL_STATIC);
  1968.     }
  1969.  
  1970.     fmtError:
  1971.     if(dst != staticBuf) {
  1972.         ckfree(dst);
  1973.     }
  1974.     Tcl_DecrRefCount(resultPtr);
  1975.     return TCL_ERROR;
  1976. }
  1977.