开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > Windows编程 > 通讯编程 > 查看源码
tclCmdAH.c
资源名称：ns-allinone-2.33.tar.gz　[点击查看]
上传用户：rrhhcc
上传日期：2015-12-11
资源大小：54129k
文件大小：63k
源码类别：

通讯编程

开发平台：

Visual C++

tclCmdAH.c：源码内容
  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.  * RCS: @(#) $Id: tclCmdAH.c,v 1.27.2.16 2006/11/28 22:20:00 andreas_kupries Exp $
  15.  */
  17. #include "tclInt.h"
  18. #include "tclPort.h"
  19. #include <locale.h>
  21. /*
  22.  * Prototypes for local procedures defined in this file:
  23.  */
  25. static int CheckAccess _ANSI_ARGS_((Tcl_Interp *interp,
  26.     Tcl_Obj *objPtr, int mode));
  27. static int GetStatBuf _ANSI_ARGS_((Tcl_Interp *interp,
  28.     Tcl_Obj *objPtr, Tcl_FSStatProc *statProc,
  29.     Tcl_StatBuf *statPtr));
  30. static char * GetTypeFromMode _ANSI_ARGS_((int mode));
  31. static int StoreStatData _ANSI_ARGS_((Tcl_Interp *interp,
  32.     char *varName, Tcl_StatBuf *statPtr));
  34. /*
  35.  *----------------------------------------------------------------------
  36.  *
  37.  * Tcl_BreakObjCmd --
  38.  *
  39.  * This procedure is invoked to process the "break" Tcl command.
  40.  * See the user documentation for details on what it does.
  41.  *
  42.  * With the bytecode compiler, this procedure is only called when
  43.  * a command name is computed at runtime, and is "break" or the name
  44.  * to which "break" was renamed: e.g., "set z break; $z"
  45.  *
  46.  * Results:
  47.  * A standard Tcl result.
  48.  *
  49.  * Side effects:
  50.  * See the user documentation.
  51.  *
  52.  *----------------------------------------------------------------------
  53.  */
  55. /* ARGSUSED */
  56. int
  57. Tcl_BreakObjCmd(dummy, interp, objc, objv)
  58.     ClientData dummy; /* Not used. */
  59.     Tcl_Interp *interp; /* Current interpreter. */
  60.     int objc; /* Number of arguments. */
  61.     Tcl_Obj *CONST objv[]; /* Argument objects. */
  62. {
  63.     if (objc != 1) {
  64. Tcl_WrongNumArgs(interp, 1, objv, NULL);
  65. return TCL_ERROR;
  66.     }
  67.     return TCL_BREAK;
  68. }
  70. /*
  71.  *----------------------------------------------------------------------
  72.  *
  73.  * Tcl_CaseObjCmd --
  74.  *
  75.  * This procedure is invoked to process the "case" Tcl command.
  76.  * See the user documentation for details on what it does.
  77.  *
  78.  * Results:
  79.  * A standard Tcl object result.
  80.  *
  81.  * Side effects:
  82.  * See the user documentation.
  83.  *
  84.  *----------------------------------------------------------------------
  85.  */
  87. /* ARGSUSED */
  88. int
  89. Tcl_CaseObjCmd(dummy, interp, objc, objv)
  90.     ClientData dummy; /* Not used. */
  91.     Tcl_Interp *interp; /* Current interpreter. */
  92.     int objc; /* Number of arguments. */
  93.     Tcl_Obj *CONST objv[]; /* Argument objects. */
  94. {
  95.     register int i;
  96.     int body, result, caseObjc;
  97.     char *string, *arg;
  98.     Tcl_Obj *CONST *caseObjv;
  99.     Tcl_Obj *armPtr;
  101.     if (objc < 3) {
  102. Tcl_WrongNumArgs(interp, 1, objv,
  103. "string ?in? patList body ... ?default body?");
  104. return TCL_ERROR;
  105.     }
  107.     string = Tcl_GetString(objv[1]);
  108.     body = -1;
  110.     arg = Tcl_GetString(objv[2]);
  111.     if (strcmp(arg, "in") == 0) {
  112. i = 3;
  113.     } else {
  114. i = 2;
  115.     }
  116.     caseObjc = objc - i;
  117.     caseObjv = objv + i;
  119.     /*
  120.      * If all of the pattern/command pairs are lumped into a single
  121.      * argument, split them out again.
  122.      */
  124.     if (caseObjc == 1) {
  125. Tcl_Obj **newObjv;
  127. Tcl_ListObjGetElements(interp, caseObjv[0], &caseObjc, &newObjv);
  128. caseObjv = newObjv;
  129.     }
  131.     for (i = 0;  i < caseObjc;  i += 2) {
  132. int patObjc, j;
  133. CONST char **patObjv;
  134. char *pat;
  135. unsigned char *p;
  137. if (i == (caseObjc - 1)) {
  138.     Tcl_ResetResult(interp);
  139.     Tcl_AppendToObj(Tcl_GetObjResult(interp),
  140.             "extra case pattern with no body", -1);
  141.     return TCL_ERROR;
  142. }
  144. /*
  145.  * Check for special case of single pattern (no list) with
  146.  * no backslash sequences.
  147.  */
  149. pat = Tcl_GetString(caseObjv[i]);
  150. for (p = (unsigned char *) pat; *p != ''; p++) {
  151.     if (isspace(*p) || (*p == '\')) { /* INTL: ISO space, UCHAR */
  152. break;
  153.     }
  154. }
  155. if (*p == '') {
  156.     if ((*pat == 'd') && (strcmp(pat, "default") == 0)) {
  157. body = i + 1;
  158.     }
  159.     if (Tcl_StringMatch(string, pat)) {
  160. body = i + 1;
  161. goto match;
  162.     }
  163.     continue;
  164. }
  167. /*
  168.  * Break up pattern lists, then check each of the patterns
  169.  * in the list.
  170.  */
  172. result = Tcl_SplitList(interp, pat, &patObjc, &patObjv);
  173. if (result != TCL_OK) {
  174.     return result;
  175. }
  176. for (j = 0; j < patObjc; j++) {
  177.     if (Tcl_StringMatch(string, patObjv[j])) {
  178. body = i + 1;
  179. break;
  180.     }
  181. }
  182. ckfree((char *) patObjv);
  183. if (j < patObjc) {
  184.     break;
  185. }
  186.     }
  188.     match:
  189.     if (body != -1) {
  190. armPtr = caseObjv[body - 1];
  191. result = Tcl_EvalObjEx(interp, caseObjv[body], 0);
  192. if (result == TCL_ERROR) {
  193.     char msg[100 + TCL_INTEGER_SPACE];
  194.     
  195.     arg = Tcl_GetString(armPtr);
  196.     sprintf(msg,
  197.     "n    ("%.50s" arm line %d)", arg,
  198.             interp->errorLine);
  199.     Tcl_AddObjErrorInfo(interp, msg, -1);
  200. }
  201. return result;
  202.     }
  204.     /*
  205.      * Nothing matched: return nothing.
  206.      */
  208.     return TCL_OK;
  209. }
  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.  */
  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. #ifdef TCL_TIP280
  239.     Interp* iPtr = (Interp*) interp;
  240. #endif
  242.     if ((objc != 2) && (objc != 3)) {
  243. Tcl_WrongNumArgs(interp, 1, objv, "command ?varName?");
  244. return TCL_ERROR;
  245.     }
  247.     if (objc == 3) {
  248. varNamePtr = objv[2];
  249.     }
  251. #ifndef TCL_TIP280
  252.     result = Tcl_EvalObjEx(interp, objv[1], 0);
  253. #else
  254.     /* TIP #280. Make invoking context available to caught script */
  255.     result = TclEvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr,1);
  256. #endif
  257.     
  258.     if (objc == 3) {
  259. if (Tcl_ObjSetVar2(interp, varNamePtr, NULL,
  260. Tcl_GetObjResult(interp), 0) == NULL) {
  261.     Tcl_ResetResult(interp);
  262.     Tcl_AppendToObj(Tcl_GetObjResult(interp),  
  263.             "couldn't save command result in variable", -1);
  264.     return TCL_ERROR;
  265. }
  266.     }
  268.     /*
  269.      * Set the interpreter's object result to an integer object holding the
  270.      * integer Tcl_EvalObj result. Note that we don't bother generating a
  271.      * string representation. We reset the interpreter's object result
  272.      * to an unshared empty object and then set it to be an integer object.
  273.      */
  275.     Tcl_ResetResult(interp);
  276.     Tcl_SetIntObj(Tcl_GetObjResult(interp), result);
  277.     return TCL_OK;
  278. }
  280. /*
  281.  *----------------------------------------------------------------------
  282.  *
  283.  * Tcl_CdObjCmd --
  284.  *
  285.  * This procedure is invoked to process the "cd" Tcl command.
  286.  * See the user documentation for details on what it does.
  287.  *
  288.  * Results:
  289.  * A standard Tcl result.
  290.  *
  291.  * Side effects:
  292.  * See the user documentation.
  293.  *
  294.  *----------------------------------------------------------------------
  295.  */
  297. /* ARGSUSED */
  298. int
  299. Tcl_CdObjCmd(dummy, interp, objc, objv)
  300.     ClientData dummy; /* Not used. */
  301.     Tcl_Interp *interp; /* Current interpreter. */
  302.     int objc; /* Number of arguments. */
  303.     Tcl_Obj *CONST objv[]; /* Argument objects. */
  304. {
  305.     Tcl_Obj *dir;
  306.     int result;
  308.     if (objc > 2) {
  309. Tcl_WrongNumArgs(interp, 1, objv, "?dirName?");
  310. return TCL_ERROR;
  311.     }
  313.     if (objc == 2) {
  314. dir = objv[1];
  315.     } else {
  316. dir = Tcl_NewStringObj("~",1);
  317. Tcl_IncrRefCount(dir);
  318.     }
  319.     if (Tcl_FSConvertToPathType(interp, dir) != TCL_OK) {
  320. result = TCL_ERROR;
  321.     } else {
  322. result = Tcl_FSChdir(dir);
  323. if (result != TCL_OK) {
  324.     Tcl_AppendResult(interp, "couldn't change working directory to "",
  325.     Tcl_GetString(dir), "": ", Tcl_PosixError(interp), (char *) NULL);
  326.     result = TCL_ERROR;
  327. }
  328.     }
  329.     if (objc != 2) {
  330. Tcl_DecrRefCount(dir);
  331.     }
  332.     return result;
  333. }
  335. /*
  336.  *----------------------------------------------------------------------
  337.  *
  338.  * Tcl_ConcatObjCmd --
  339.  *
  340.  * This object-based procedure is invoked to process the "concat" Tcl
  341.  * command. See the user documentation for details on what it does.
  342.  *
  343.  * Results:
  344.  * A standard Tcl object result.
  345.  *
  346.  * Side effects:
  347.  * See the user documentation.
  348.  *
  349.  *----------------------------------------------------------------------
  350.  */
  352. /* ARGSUSED */
  353. int
  354. Tcl_ConcatObjCmd(dummy, interp, objc, objv)
  355.     ClientData dummy; /* Not used. */
  356.     Tcl_Interp *interp; /* Current interpreter. */
  357.     int objc; /* Number of arguments. */
  358.     Tcl_Obj *CONST objv[]; /* Argument objects. */
  359. {
  360.     if (objc >= 2) {
  361. Tcl_SetObjResult(interp, Tcl_ConcatObj(objc-1, objv+1));
  362.     }
  363.     return TCL_OK;
  364. }
  366. /*
  367.  *----------------------------------------------------------------------
  368.  *
  369.  * Tcl_ContinueObjCmd -
  370.  *
  371.  * This procedure is invoked to process the "continue" Tcl command.
  372.  * See the user documentation for details on what it does.
  373.  *
  374.  * With the bytecode compiler, this procedure is only called when
  375.  * a command name is computed at runtime, and is "continue" or the name
  376.  * to which "continue" was renamed: e.g., "set z continue; $z"
  377.  *
  378.  * Results:
  379.  * A standard Tcl result.
  380.  *
  381.  * Side effects:
  382.  * See the user documentation.
  383.  *
  384.  *----------------------------------------------------------------------
  385.  */
  387. /* ARGSUSED */
  388. int
  389. Tcl_ContinueObjCmd(dummy, interp, objc, objv)
  390.     ClientData dummy; /* Not used. */
  391.     Tcl_Interp *interp; /* Current interpreter. */
  392.     int objc; /* Number of arguments. */
  393.     Tcl_Obj *CONST objv[]; /* Argument objects. */
  394. {
  395.     if (objc != 1) {
  396. Tcl_WrongNumArgs(interp, 1, objv, NULL);
  397. return TCL_ERROR;
  398.     }
  399.     return TCL_CONTINUE;
  400. }
  402. /*
  403.  *----------------------------------------------------------------------
  404.  *
  405.  * Tcl_EncodingObjCmd --
  406.  *
  407.  * This command manipulates encodings.
  408.  *
  409.  * Results:
  410.  * A standard Tcl result.
  411.  *
  412.  * Side effects:
  413.  * See the user documentation.
  414.  *
  415.  *----------------------------------------------------------------------
  416.  */
  418. int
  419. Tcl_EncodingObjCmd(dummy, interp, objc, objv)
  420.     ClientData dummy; /* Not used. */
  421.     Tcl_Interp *interp; /* Current interpreter. */
  422.     int objc; /* Number of arguments. */
  423.     Tcl_Obj *CONST objv[]; /* Argument objects. */
  424. {
  425.     int index, length;
  426.     Tcl_Encoding encoding;
  427.     char *string;
  428.     Tcl_DString ds;
  429.     Tcl_Obj *resultPtr;
  431.     static CONST char *optionStrings[] = {
  432. "convertfrom", "convertto", "names", "system",
  433. NULL
  434.     };
  435.     enum options {
  436. ENC_CONVERTFROM, ENC_CONVERTTO, ENC_NAMES, ENC_SYSTEM
  437.     };
  439.     if (objc < 2) {
  440.      Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
  441.         return TCL_ERROR;
  442.     }
  443.     if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
  444.     &index) != TCL_OK) {
  445. return TCL_ERROR;
  446.     }
  448.     switch ((enum options) index) {
  449. case ENC_CONVERTTO:
  450. case ENC_CONVERTFROM: {
  451.     Tcl_Obj *data;
  452.     if (objc == 3) {
  453. encoding = Tcl_GetEncoding(interp, NULL);
  454. data = objv[2];
  455.     } else if (objc == 4) {
  456. if (TclGetEncodingFromObj(interp, objv[2], &encoding)
  457. != TCL_OK) {
  458.     return TCL_ERROR;
  459. }
  460. data = objv[3];
  461.     } else {
  462. Tcl_WrongNumArgs(interp, 2, objv, "?encoding? data");
  463. return TCL_ERROR;
  464.     }
  465.     
  466.     if ((enum options) index == ENC_CONVERTFROM) {
  467. /*
  468.  * Treat the string as binary data.
  469.  */
  471. string = (char *) Tcl_GetByteArrayFromObj(data, &length);
  472. Tcl_ExternalToUtfDString(encoding, string, length, &ds);
  474. /*
  475.  * Note that we cannot use Tcl_DStringResult here because
  476.  * it will truncate the string at the first null byte.
  477.  */
  479. Tcl_SetStringObj(Tcl_GetObjResult(interp),
  480. Tcl_DStringValue(&ds), Tcl_DStringLength(&ds));
  481. Tcl_DStringFree(&ds);
  482.     } else {
  483. /*
  484.  * Store the result as binary data.
  485.  */
  487. string = Tcl_GetStringFromObj(data, &length);
  488. Tcl_UtfToExternalDString(encoding, string, length, &ds);
  489. resultPtr = Tcl_GetObjResult(interp);
  490. Tcl_SetByteArrayObj(resultPtr, 
  491. (unsigned char *) Tcl_DStringValue(&ds),
  492. Tcl_DStringLength(&ds));
  493. Tcl_DStringFree(&ds);
  494.     }
  496.     Tcl_FreeEncoding(encoding);
  497.     break;
  498. }
  499. case ENC_NAMES: {
  500.     if (objc > 2) {
  501. Tcl_WrongNumArgs(interp, 2, objv, NULL);
  502. return TCL_ERROR;
  503.     }
  504.     Tcl_GetEncodingNames(interp);
  505.     break;
  506. }
  507. case ENC_SYSTEM: {
  508.     if (objc > 3) {
  509. Tcl_WrongNumArgs(interp, 2, objv, "?encoding?");
  510. return TCL_ERROR;
  511.     }
  512.     if (objc == 2) {
  513. Tcl_SetStringObj(Tcl_GetObjResult(interp),
  514. Tcl_GetEncodingName(NULL), -1);
  515.     } else {
  516.         return Tcl_SetSystemEncoding(interp,
  517. Tcl_GetStringFromObj(objv[2], NULL));
  518.     }
  519.     break;
  520. }
  521.     }
  522.     return TCL_OK;
  523. }
  525. /*
  526.  *----------------------------------------------------------------------
  527.  *
  528.  * Tcl_ErrorObjCmd --
  529.  *
  530.  * This procedure is invoked to process the "error" Tcl command.
  531.  * See the user documentation for details on what it does.
  532.  *
  533.  * Results:
  534.  * A standard Tcl object result.
  535.  *
  536.  * Side effects:
  537.  * See the user documentation.
  538.  *
  539.  *----------------------------------------------------------------------
  540.  */
  542. /* ARGSUSED */
  543. int
  544. Tcl_ErrorObjCmd(dummy, interp, objc, objv)
  545.     ClientData dummy; /* Not used. */
  546.     Tcl_Interp *interp; /* Current interpreter. */
  547.     int objc; /* Number of arguments. */
  548.     Tcl_Obj *CONST objv[]; /* Argument objects. */
  549. {
  550.     Interp *iPtr = (Interp *) interp;
  551.     char *info;
  552.     int infoLen;
  554.     if ((objc < 2) || (objc > 4)) {
  555. Tcl_WrongNumArgs(interp, 1, objv, "message ?errorInfo? ?errorCode?");
  556. return TCL_ERROR;
  557.     }
  558.     
  559.     if (objc >= 3) { /* process the optional info argument */
  560. info = Tcl_GetStringFromObj(objv[2], &infoLen);
  561. if (infoLen > 0) {
  562.     Tcl_AddObjErrorInfo(interp, info, infoLen);
  563.     iPtr->flags |= ERR_ALREADY_LOGGED;
  564. }
  565.     }
  566.     
  567.     if (objc == 4) {
  568. Tcl_SetVar2Ex(interp, "errorCode", NULL, objv[3], TCL_GLOBAL_ONLY);
  569. iPtr->flags |= ERROR_CODE_SET;
  570.     }
  571.     
  572.     Tcl_SetObjResult(interp, objv[1]);
  573.     return TCL_ERROR;
  574. }
  576. /*
  577.  *----------------------------------------------------------------------
  578.  *
  579.  * Tcl_EvalObjCmd --
  580.  *
  581.  * This object-based procedure is invoked to process the "eval" Tcl 
  582.  * command. See the user documentation for details on what it does.
  583.  *
  584.  * Results:
  585.  * A standard Tcl object result.
  586.  *
  587.  * Side effects:
  588.  * See the user documentation.
  589.  *
  590.  *----------------------------------------------------------------------
  591.  */
  593. /* ARGSUSED */
  594. int
  595. Tcl_EvalObjCmd(dummy, interp, objc, objv)
  596.     ClientData dummy; /* Not used. */
  597.     Tcl_Interp *interp; /* Current interpreter. */
  598.     int objc; /* Number of arguments. */
  599.     Tcl_Obj *CONST objv[]; /* Argument objects. */
  600. {
  601.     int result;
  602.     register Tcl_Obj *objPtr;
  603. #ifdef TCL_TIP280
  604.     Interp* iPtr = (Interp*) interp;
  605. #endif
  607.     if (objc < 2) {
  608. Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");
  609. return TCL_ERROR;
  610.     }
  611.     
  612.     if (objc == 2) {
  613. #ifndef TCL_TIP280
  614. result = Tcl_EvalObjEx(interp, objv[1], TCL_EVAL_DIRECT);
  615. #else
  616. /* TIP #280. Make invoking context available to eval'd script */
  617. result = TclEvalObjEx(interp, objv[1], TCL_EVAL_DIRECT,
  618.       iPtr->cmdFramePtr,1);
  619. #endif
  620.     } else {
  621. /*
  622.  * More than one argument: concatenate them together with spaces
  623.  * between, then evaluate the result.  Tcl_EvalObjEx will delete
  624.  * the object when it decrements its refcount after eval'ing it.
  625.  */
  626.      objPtr = Tcl_ConcatObj(objc-1, objv+1);
  627. #ifndef TCL_TIP280
  628. result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
  629. #else
  630. /* TIP #280. Make invoking context available to eval'd script */
  631. result = TclEvalObjEx(interp, objPtr, TCL_EVAL_DIRECT, NULL, 0);
  632. #endif
  633.     }
  634.     if (result == TCL_ERROR) {
  635. char msg[32 + TCL_INTEGER_SPACE];
  637. sprintf(msg, "n    ("eval" body line %d)", interp->errorLine);
  638. Tcl_AddObjErrorInfo(interp, msg, -1);
  639.     }
  640.     return result;
  641. }
  643. /*
  644.  *----------------------------------------------------------------------
  645.  *
  646.  * Tcl_ExitObjCmd --
  647.  *
  648.  * This procedure is invoked to process the "exit" Tcl command.
  649.  * See the user documentation for details on what it does.
  650.  *
  651.  * Results:
  652.  * A standard Tcl object result.
  653.  *
  654.  * Side effects:
  655.  * See the user documentation.
  656.  *
  657.  *----------------------------------------------------------------------
  658.  */
  660. /* ARGSUSED */
  661. int
  662. Tcl_ExitObjCmd(dummy, interp, objc, objv)
  663.     ClientData dummy; /* Not used. */
  664.     Tcl_Interp *interp; /* Current interpreter. */
  665.     int objc; /* Number of arguments. */
  666.     Tcl_Obj *CONST objv[]; /* Argument objects. */
  667. {
  668.     int value;
  670.     if ((objc != 1) && (objc != 2)) {
  671. Tcl_WrongNumArgs(interp, 1, objv, "?returnCode?");
  672. return TCL_ERROR;
  673.     }
  674.     
  675.     if (objc == 1) {
  676. value = 0;
  677.     } else if (Tcl_GetIntFromObj(interp, objv[1], &value) != TCL_OK) {
  678. return TCL_ERROR;
  679.     }
  680.     Tcl_Exit(value);
  681.     /*NOTREACHED*/
  682.     return TCL_OK; /* Better not ever reach this! */
  683. }
  685. /*
  686.  *----------------------------------------------------------------------
  687.  *
  688.  * Tcl_ExprObjCmd --
  689.  *
  690.  * This object-based procedure is invoked to process the "expr" Tcl
  691.  * command. See the user documentation for details on what it does.
  692.  *
  693.  * With the bytecode compiler, this procedure is called in two
  694.  * circumstances: 1) to execute expr commands that are too complicated
  695.  * or too unsafe to try compiling directly into an inline sequence of
  696.  * instructions, and 2) to execute commands where the command name is
  697.  * computed at runtime and is "expr" or the name to which "expr" was
  698.  * renamed (e.g., "set z expr; $z 2+3")
  699.  *
  700.  * Results:
  701.  * A standard Tcl object result.
  702.  *
  703.  * Side effects:
  704.  * See the user documentation.
  705.  *
  706.  *----------------------------------------------------------------------
  707.  */
  709. /* ARGSUSED */
  710. int
  711. Tcl_ExprObjCmd(dummy, interp, objc, objv)
  712.     ClientData dummy; /* Not used. */
  713.     Tcl_Interp *interp; /* Current interpreter. */
  714.     int objc; /* Number of arguments. */
  715.     Tcl_Obj *CONST objv[]; /* Argument objects. */
  716. {  
  717.     register Tcl_Obj *objPtr;
  718.     Tcl_Obj *resultPtr;
  719.     register char *bytes;
  720.     int length, i, result;
  722.     if (objc < 2) {
  723. Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");
  724. return TCL_ERROR;
  725.     }
  727.     if (objc == 2) {
  728. result = Tcl_ExprObj(interp, objv[1], &resultPtr);
  729. if (result == TCL_OK) {
  730.     Tcl_SetObjResult(interp, resultPtr);
  731.     Tcl_DecrRefCount(resultPtr);  /* done with the result object */
  732. }
  733. return result;
  734.     }
  736.     /*
  737.      * Create a new object holding the concatenated argument strings.
  738.      */
  740.     /*** QUESTION: Do we need to copy the slow way? ***/
  741.     bytes = Tcl_GetStringFromObj(objv[1], &length);
  742.     objPtr = Tcl_NewStringObj(bytes, length);
  743.     Tcl_IncrRefCount(objPtr);
  744.     for (i = 2;  i < objc;  i++) {
  745. Tcl_AppendToObj(objPtr, " ", 1);
  746. bytes = Tcl_GetStringFromObj(objv[i], &length);
  747. Tcl_AppendToObj(objPtr, bytes, length);
  748.     }
  750.     /*
  751.      * Evaluate the concatenated string object.
  752.      */
  754.     result = Tcl_ExprObj(interp, objPtr, &resultPtr);
  755.     if (result == TCL_OK) {
  756. Tcl_SetObjResult(interp, resultPtr);
  757. Tcl_DecrRefCount(resultPtr);  /* done with the result object */
  758.     }
  760.     /*
  761.      * Free allocated resources.
  762.      */
  763.     
  764.     Tcl_DecrRefCount(objPtr);
  765.     return result;
  766. }
  768. /*
  769.  *----------------------------------------------------------------------
  770.  *
  771.  * Tcl_FileObjCmd --
  772.  *
  773.  * This procedure is invoked to process the "file" Tcl command.
  774.  * See the user documentation for details on what it does.
  775.  * PLEASE NOTE THAT THIS FAILS WITH FILENAMES AND PATHS WITH
  776.  * EMBEDDED NULLS, WHICH COULD THEORETICALLY HAPPEN ON A MAC.
  777.  *      With the object-based Tcl_FS APIs, the above NOTE may no
  778.  *      longer be true.  In any case this assertion should be tested.
  779.  *
  780.  * Results:
  781.  * A standard Tcl result.
  782.  *
  783.  * Side effects:
  784.  * See the user documentation.
  785.  *
  786.  *----------------------------------------------------------------------
  787.  */
  789. /* ARGSUSED */
  790. int
  791. Tcl_FileObjCmd(dummy, interp, objc, objv)
  792.     ClientData dummy; /* Not used. */
  793.     Tcl_Interp *interp; /* Current interpreter. */
  794.     int objc; /* Number of arguments. */
  795.     Tcl_Obj *CONST objv[]; /* Argument objects. */
  796. {
  797.     int index;
  799. /*
  800.  * This list of constants should match the fileOption string array below.
  801.  */
  803.     static CONST char *fileOptions[] = {
  804. "atime", "attributes", "channels", "copy",
  805. "delete",
  806. "dirname", "executable", "exists", "extension",
  807. "isdirectory", "isfile", "join", "link",
  808. "lstat",        "mtime", "mkdir", "nativename",
  809. "normalize",    "owned",
  810. "pathtype", "readable", "readlink", "rename",
  811. "rootname", "separator",    "size", "split",
  812. "stat",         "system", 
  813. "tail", "type", "volumes", "writable",
  814. (char *) NULL
  815.     };
  816.     enum options {
  817. FCMD_ATIME, FCMD_ATTRIBUTES, FCMD_CHANNELS, FCMD_COPY,
  818. FCMD_DELETE,
  819. FCMD_DIRNAME, FCMD_EXECUTABLE, FCMD_EXISTS, FCMD_EXTENSION,
  820. FCMD_ISDIRECTORY, FCMD_ISFILE, FCMD_JOIN, FCMD_LINK, 
  821. FCMD_LSTAT,     FCMD_MTIME, FCMD_MKDIR, FCMD_NATIVENAME, 
  822. FCMD_NORMALIZE, FCMD_OWNED,
  823. FCMD_PATHTYPE, FCMD_READABLE, FCMD_READLINK, FCMD_RENAME,
  824. FCMD_ROOTNAME, FCMD_SEPARATOR, FCMD_SIZE, FCMD_SPLIT,
  825. FCMD_STAT,      FCMD_SYSTEM, 
  826. FCMD_TAIL, FCMD_TYPE, FCMD_VOLUMES, FCMD_WRITABLE
  827.     };
  829.     if (objc < 2) {
  830.      Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
  831.         return TCL_ERROR;
  832.     }
  833.     if (Tcl_GetIndexFromObj(interp, objv[1], fileOptions, "option", 0,
  834.     &index) != TCL_OK) {
  835.      return TCL_ERROR;
  836.     }
  838.     switch ((enum options) index) {
  839.      case FCMD_ATIME: {
  840.     Tcl_StatBuf buf;
  841.     struct utimbuf tval;
  843.     if ((objc < 3) || (objc > 4)) {
  844. Tcl_WrongNumArgs(interp, 2, objv, "name ?time?");
  845. return TCL_ERROR;
  846.     }
  847.     if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
  848. return TCL_ERROR;
  849.     }
  850.     if (objc == 4) {
  851. long newTime;
  853. if (Tcl_GetLongFromObj(interp, objv[3], &newTime) != TCL_OK) {
  854.     return TCL_ERROR;
  855. }
  856. tval.actime = newTime;
  857. tval.modtime = buf.st_mtime;
  858. if (Tcl_FSUtime(objv[2], &tval) != 0) {
  859.     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  860.     "could not set access time for file "",
  861.     Tcl_GetString(objv[2]), "": ",
  862.     Tcl_PosixError(interp), (char *) NULL);
  863.     return TCL_ERROR;
  864. }
  865. /*
  866.  * Do another stat to ensure that the we return the
  867.  * new recognized atime - hopefully the same as the
  868.  * one we sent in.  However, fs's like FAT don't
  869.  * even know what atime is.
  870.  */
  871. if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
  872.     return TCL_ERROR;
  873. }
  874.     }
  875.     Tcl_SetLongObj(Tcl_GetObjResult(interp), (long) buf.st_atime);
  876.     return TCL_OK;
  877. }
  878. case FCMD_ATTRIBUTES: {
  879.             return TclFileAttrsCmd(interp, objc, objv);
  880. }
  881. case FCMD_CHANNELS: {
  882.     if ((objc < 2) || (objc > 3)) {
  883. Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
  884. return TCL_ERROR;
  885.     }
  886.     return Tcl_GetChannelNamesEx(interp,
  887.     ((objc == 2) ? NULL : Tcl_GetString(objv[2])));
  888. }
  889. case FCMD_COPY: {
  890.     return TclFileCopyCmd(interp, objc, objv);
  891. }     
  892. case FCMD_DELETE: {
  893.     return TclFileDeleteCmd(interp, objc, objv);
  894. }
  895.      case FCMD_DIRNAME: {
  896.     Tcl_Obj *dirPtr;
  897.     if (objc != 3) {
  898. goto only3Args;
  899.     }
  900.     dirPtr = TclFileDirname(interp, objv[2]);
  901.     if (dirPtr == NULL) {
  902.         return TCL_ERROR;
  903.     } else {
  904. Tcl_SetObjResult(interp, dirPtr);
  905. Tcl_DecrRefCount(dirPtr);
  906. return TCL_OK;
  907.     }
  908. }
  909. case FCMD_EXECUTABLE: {
  910.     if (objc != 3) {
  911. goto only3Args;
  912.     }
  913.     return CheckAccess(interp, objv[2], X_OK);
  914. }
  915. case FCMD_EXISTS: {
  916.     if (objc != 3) {
  917. goto only3Args;
  918.     }
  919.     return CheckAccess(interp, objv[2], F_OK);
  920. }
  921. case FCMD_EXTENSION: {
  922.     char *fileName, *extension;
  923.     if (objc != 3) {
  924.      goto only3Args;
  925.     }
  926.     fileName = Tcl_GetString(objv[2]);
  927.     extension = TclGetExtension(fileName);
  928.     if (extension != NULL) {
  929.      Tcl_SetStringObj(Tcl_GetObjResult(interp), extension, -1);
  930.     }
  931.     return TCL_OK;
  932. }
  933.      case FCMD_ISDIRECTORY: {
  934.     int value;
  935.     Tcl_StatBuf buf;
  937.     if (objc != 3) {
  938. goto only3Args;
  939.     }
  940.     value = 0;
  941.     if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) {
  942. value = S_ISDIR(buf.st_mode);
  943.     }
  944.     Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value);
  945.     return TCL_OK;
  946. }
  947.      case FCMD_ISFILE: {
  948.     int value;
  949.     Tcl_StatBuf buf;
  950.     
  951.          if (objc != 3) {
  952.           goto only3Args;
  953.          }
  954.     value = 0;
  955.     if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) {
  956. value = S_ISREG(buf.st_mode);
  957.     }
  958.     Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value);
  959.     return TCL_OK;
  960. }
  961. case FCMD_JOIN: {
  962.     Tcl_Obj *resObj;
  964.     if (objc < 3) {
  965. Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?");
  966. return TCL_ERROR;
  967.     }
  968.     resObj = Tcl_FSJoinToPath(NULL, objc - 2, objv + 2);
  969.     Tcl_SetObjResult(interp, resObj);
  970.     return TCL_OK;
  971. }
  972. case FCMD_LINK: {
  973.     Tcl_Obj *contents;
  974.     int index;
  975.     
  976.     if (objc < 3 || objc > 5) {
  977. Tcl_WrongNumArgs(interp, 2, objv, 
  978.  "?-linktype? linkname ?target?");
  979. return TCL_ERROR;
  980.     }
  981.     
  982.     /* Index of the 'source' argument */
  983.     if (objc == 5) {
  984. index = 3;
  985.     } else {
  986. index = 2;
  987.     }
  988.     
  989.     if (objc > 3) {
  990. int linkAction;
  991. if (objc == 5) {
  992.     /* We have a '-linktype' argument */
  993.     static CONST char *linkTypes[] = {
  994. "-symbolic", "-hard", NULL
  995.     };
  996.     if (Tcl_GetIndexFromObj(interp, objv[2], linkTypes, 
  997.      "switch", 0, &linkAction) != TCL_OK) {
  998. return TCL_ERROR;
  999.     }
  1000.     if (linkAction == 0) {
  1001.         linkAction = TCL_CREATE_SYMBOLIC_LINK;
  1002.     } else {
  1003. linkAction = TCL_CREATE_HARD_LINK;
  1004.     }
  1005. } else {
  1006.     linkAction = TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK;
  1007. }
  1008. if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
  1009.     return TCL_ERROR;
  1010. }
  1011. /* Create link from source to target */
  1012. contents = Tcl_FSLink(objv[index], objv[index+1], linkAction);
  1013. if (contents == NULL) {
  1014.     /* 
  1015.      * We handle two common error cases specially, and
  1016.      * for all other errors, we use the standard posix
  1017.      * error message.
  1018.      */
  1019.     if (errno == EEXIST) {
  1020. Tcl_AppendResult(interp, "could not create new link "", 
  1021. Tcl_GetString(objv[index]), 
  1022. "": that path already exists", (char *) NULL);
  1023.     } else if (errno == ENOENT) {
  1024. Tcl_AppendResult(interp, "could not create new link "", 
  1025. Tcl_GetString(objv[index]), 
  1026. "" since target "", 
  1027. Tcl_GetString(objv[index+1]), 
  1028. "" doesn't exist", 
  1029. (char *) NULL);
  1030.     } else {
  1031. Tcl_AppendResult(interp, "could not create new link "", 
  1032. Tcl_GetString(objv[index]), "" pointing to "", 
  1033. Tcl_GetString(objv[index+1]), "": ", 
  1034. Tcl_PosixError(interp), (char *) NULL);
  1035.     }
  1036.     return TCL_ERROR;
  1037. }
  1038.     } else {
  1039. if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
  1040.     return TCL_ERROR;
  1041. }
  1042. /* Read link */
  1043. contents = Tcl_FSLink(objv[index], NULL, 0);
  1044. if (contents == NULL) {
  1045.     Tcl_AppendResult(interp, "could not read link "", 
  1046.     Tcl_GetString(objv[index]), "": ", 
  1047.     Tcl_PosixError(interp), (char *) NULL);
  1048.     return TCL_ERROR;
  1049. }
  1050.     }
  1051.     Tcl_SetObjResult(interp, contents);
  1052.     if (objc == 3) {
  1053. /* 
  1054.  * If we are reading a link, we need to free this
  1055.  * result refCount.  If we are creating a link, this
  1056.  * will just be objv[index+1], and so we don't own it.
  1057.  */
  1058. Tcl_DecrRefCount(contents);
  1059.     }
  1060.     return TCL_OK;
  1061. }
  1062.      case FCMD_LSTAT: {
  1063.     char *varName;
  1064.     Tcl_StatBuf buf;
  1066.          if (objc != 4) {
  1067.           Tcl_WrongNumArgs(interp, 2, objv, "name varName");
  1068.           return TCL_ERROR;
  1069.          }
  1070.     if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) {
  1071. return TCL_ERROR;
  1072.     }
  1073.     varName = Tcl_GetString(objv[3]);
  1074.     return StoreStatData(interp, varName, &buf);
  1075. }
  1076. case FCMD_MTIME: {
  1077.     Tcl_StatBuf buf;
  1078.     struct utimbuf tval;
  1080.     if ((objc < 3) || (objc > 4)) {
  1081. Tcl_WrongNumArgs(interp, 2, objv, "name ?time?");
  1082. return TCL_ERROR;
  1083.     }
  1084.     if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
  1085. return TCL_ERROR;
  1086.     }
  1087.     if (objc == 4) {
  1088. long newTime;
  1090. if (Tcl_GetLongFromObj(interp, objv[3], &newTime) != TCL_OK) {
  1091.     return TCL_ERROR;
  1092. }
  1093. tval.actime = buf.st_atime;
  1094. tval.modtime = newTime;
  1095. if (Tcl_FSUtime(objv[2], &tval) != 0) {
  1096.     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  1097.     "could not set modification time for file "",
  1098.     Tcl_GetString(objv[2]), "": ",
  1099.     Tcl_PosixError(interp), (char *) NULL);
  1100.     return TCL_ERROR;
  1101. }
  1102. /*
  1103.  * Do another stat to ensure that the we return the
  1104.  * new recognized atime - hopefully the same as the
  1105.  * one we sent in.  However, fs's like FAT don't
  1106.  * even know what atime is.
  1107.  */
  1108. if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
  1109.     return TCL_ERROR;
  1110. }
  1111.     }
  1112.     Tcl_SetLongObj(Tcl_GetObjResult(interp), (long) buf.st_mtime);
  1113.     return TCL_OK;
  1114. }
  1115. case FCMD_MKDIR: {
  1116.     if (objc < 3) {
  1117. Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?");
  1118. return TCL_ERROR;
  1119.     }
  1120.     return TclFileMakeDirsCmd(interp, objc, objv);
  1121. }
  1122. case FCMD_NATIVENAME: {
  1123.     CONST char *fileName;
  1124.     Tcl_DString ds;
  1126.     if (objc != 3) {
  1127. goto only3Args;
  1128.     }
  1129.     fileName = Tcl_GetString(objv[2]);
  1130.     fileName = Tcl_TranslateFileName(interp, fileName, &ds);
  1131.     if (fileName == NULL) {
  1132. return TCL_ERROR;
  1133.     }
  1134.     Tcl_SetStringObj(Tcl_GetObjResult(interp), fileName, 
  1135.      Tcl_DStringLength(&ds));
  1136.     Tcl_DStringFree(&ds);
  1137.     return TCL_OK;
  1138. }
  1139. case FCMD_NORMALIZE: {
  1140.     Tcl_Obj *fileName;
  1142.     if (objc != 3) {
  1143. Tcl_WrongNumArgs(interp, 2, objv, "filename");
  1144. return TCL_ERROR;
  1145.     }
  1147.     fileName = Tcl_FSGetNormalizedPath(interp, objv[2]);
  1148.     if (fileName == NULL) {
  1149. return TCL_ERROR;
  1150.     }
  1151.     Tcl_SetObjResult(interp, fileName);
  1152.     return TCL_OK;
  1153. }
  1154. case FCMD_OWNED: {
  1155.     int value;
  1156.     Tcl_StatBuf buf;
  1157.     
  1158.     if (objc != 3) {
  1159. goto only3Args;
  1160.     }
  1161.     value = 0;
  1162.     if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) {
  1163. /*
  1164.  * For Windows and Macintosh, there are no user ids 
  1165.  * associated with a file, so we always return 1.
  1166.  */
  1168. #if (defined(__WIN32__) || defined(MAC_TCL))
  1169. value = 1;
  1170. #else
  1171. value = (geteuid() == buf.st_uid);
  1172. #endif
  1173.     }     
  1174.     Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value);
  1175.     return TCL_OK;
  1176. }
  1177. case FCMD_PATHTYPE: {
  1178.     if (objc != 3) {
  1179. goto only3Args;
  1180.     }
  1181.     switch (Tcl_FSGetPathType(objv[2])) {
  1182.      case TCL_PATH_ABSOLUTE:
  1183.          Tcl_SetStringObj(Tcl_GetObjResult(interp), "absolute", -1);
  1184.     break;
  1185.      case TCL_PATH_RELATIVE:
  1186.          Tcl_SetStringObj(Tcl_GetObjResult(interp), "relative", -1);
  1187.          break;
  1188.      case TCL_PATH_VOLUME_RELATIVE:
  1189.     Tcl_SetStringObj(Tcl_GetObjResult(interp), 
  1190.      "volumerelative", -1);
  1191.     break;
  1192.     }
  1193.     return TCL_OK;
  1194. }
  1195.      case FCMD_READABLE: {
  1196.     if (objc != 3) {
  1197. goto only3Args;
  1198.     }
  1199.     return CheckAccess(interp, objv[2], R_OK);
  1200. }
  1201. case FCMD_READLINK: {
  1202.     Tcl_Obj *contents;
  1204.     if (objc != 3) {
  1205. goto only3Args;
  1206.     }
  1207.     
  1208.     if (Tcl_FSConvertToPathType(interp, objv[2]) != TCL_OK) {
  1209. return TCL_ERROR;
  1210.     }
  1212.     contents = Tcl_FSLink(objv[2], NULL, 0);
  1214.     if (contents == NULL) {
  1215.      Tcl_AppendResult(interp, "could not readlink "", 
  1216.      Tcl_GetString(objv[2]), "": ", 
  1217.      Tcl_PosixError(interp), (char *) NULL);
  1218.      return TCL_ERROR;
  1219.     }
  1220.     Tcl_SetObjResult(interp, contents);
  1221.     Tcl_DecrRefCount(contents);
  1222.     return TCL_OK;
  1223. }
  1224. case FCMD_RENAME: {
  1225.     return TclFileRenameCmd(interp, objc, objv);
  1226. }
  1227. case FCMD_ROOTNAME: {
  1228.     int length;
  1229.     char *fileName, *extension;
  1230.     
  1231.     if (objc != 3) {
  1232. goto only3Args;
  1233.     }
  1234.     fileName = Tcl_GetStringFromObj(objv[2], &length);
  1235.     extension = TclGetExtension(fileName);
  1236.     if (extension == NULL) {
  1237.      Tcl_SetObjResult(interp, objv[2]);
  1238.     } else {
  1239.         Tcl_SetStringObj(Tcl_GetObjResult(interp), fileName,
  1240. (int) (length - strlen(extension)));
  1241.     }
  1242.     return TCL_OK;
  1243. }
  1244. case FCMD_SEPARATOR: {
  1245.     if ((objc < 2) || (objc > 3)) {
  1246. Tcl_WrongNumArgs(interp, 2, objv, "?name?");
  1247. return TCL_ERROR;
  1248.     }
  1249.     if (objc == 2) {
  1250.         char *separator = NULL; /* lint */
  1251. switch (tclPlatform) {
  1252.     case TCL_PLATFORM_UNIX:
  1253. separator = "/";
  1254. break;
  1255.     case TCL_PLATFORM_WINDOWS:
  1256. separator = "\";
  1257. break;
  1258.     case TCL_PLATFORM_MAC:
  1259. separator = ":";
  1260. break;
  1261. }
  1262. Tcl_SetObjResult(interp, Tcl_NewStringObj(separator,1));
  1263.     } else {
  1264. Tcl_Obj *separatorObj = Tcl_FSPathSeparator(objv[2]);
  1265. if (separatorObj != NULL) {
  1266.     Tcl_SetObjResult(interp, separatorObj);
  1267. } else {
  1268.     Tcl_SetObjResult(interp, 
  1269.     Tcl_NewStringObj("Unrecognised path",-1));
  1270.     return TCL_ERROR;
  1271. }
  1272.     }
  1273.     return TCL_OK;
  1274. }
  1275. case FCMD_SIZE: {
  1276.     Tcl_StatBuf buf;
  1277.     
  1278.     if (objc != 3) {
  1279. goto only3Args;
  1280.     }
  1281.     if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
  1282. return TCL_ERROR;
  1283.     }
  1284.     Tcl_SetWideIntObj(Tcl_GetObjResult(interp),
  1285.     (Tcl_WideInt) buf.st_size);
  1286.     return TCL_OK;
  1287. }
  1288. case FCMD_SPLIT: {
  1289.     if (objc != 3) {
  1290. goto only3Args;
  1291.     }
  1292.     Tcl_SetObjResult(interp, Tcl_FSSplitPath(objv[2], NULL));
  1293.     return TCL_OK;
  1294. }
  1295. case FCMD_STAT: {
  1296.     char *varName;
  1297.     Tcl_StatBuf buf;
  1298.     
  1299.     if (objc != 4) {
  1300.      Tcl_WrongNumArgs(interp, 1, objv, "stat name varName");
  1301. return TCL_ERROR;
  1302.     }
  1303.     if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
  1304. return TCL_ERROR;
  1305.     }
  1306.     varName = Tcl_GetString(objv[3]);
  1307.     return StoreStatData(interp, varName, &buf);
  1308. }
  1309. case FCMD_SYSTEM: {
  1310.     Tcl_Obj* fsInfo;
  1311.     if (objc != 3) {
  1312. goto only3Args;
  1313.     }
  1314.     fsInfo = Tcl_FSFileSystemInfo(objv[2]);
  1315.     if (fsInfo != NULL) {
  1316. Tcl_SetObjResult(interp, fsInfo);
  1317. return TCL_OK;
  1318.     } else {
  1319. Tcl_SetObjResult(interp, 
  1320.  Tcl_NewStringObj("Unrecognised path",-1));
  1321. return TCL_ERROR;
  1322.     }
  1323. }
  1324.      case FCMD_TAIL: {
  1325.     int splitElements;
  1326.     Tcl_Obj *splitPtr;
  1328.     if (objc != 3) {
  1329. goto only3Args;
  1330.     }
  1331.     /* 
  1332.      * The behaviour we want here is slightly different to
  1333.      * the standard Tcl_FSSplitPath in the handling of home
  1334.      * directories; Tcl_FSSplitPath preserves the "~" while 
  1335.      * this code computes the actual full path name, if we
  1336.      * had just a single component.
  1337.      */     
  1338.     splitPtr = Tcl_FSSplitPath(objv[2], &splitElements);
  1339.     if ((splitElements == 1) && (Tcl_GetString(objv[2])[0] == '~')) {
  1340. Tcl_DecrRefCount(splitPtr);
  1341. splitPtr = Tcl_FSGetNormalizedPath(interp, objv[2]);
  1342. if (splitPtr == NULL) {
  1343.     return TCL_ERROR;
  1344. }
  1345. splitPtr = Tcl_FSSplitPath(splitPtr, &splitElements);
  1346.     }
  1348.     /*
  1349.      * Return the last component, unless it is the only component,
  1350.      * and it is the root of an absolute path.
  1351.      */
  1353.     if (splitElements > 0) {
  1354.      if ((splitElements > 1)
  1355.   || (Tcl_FSGetPathType(objv[2]) == TCL_PATH_RELATIVE)) {
  1356.     
  1357.     Tcl_Obj *tail = NULL;
  1358.     Tcl_ListObjIndex(NULL, splitPtr, splitElements-1, &tail);
  1359.     Tcl_SetObjResult(interp, tail);
  1360.      }
  1361.     }
  1362.     Tcl_DecrRefCount(splitPtr);
  1363.     return TCL_OK;
  1364. }
  1365. case FCMD_TYPE: {
  1366.     Tcl_StatBuf buf;
  1368.     if (objc != 3) {
  1369.      goto only3Args;
  1370.     }
  1371.     if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) {
  1372. return TCL_ERROR;
  1373.     }
  1374.     Tcl_SetStringObj(Tcl_GetObjResult(interp), 
  1375.     GetTypeFromMode((unsigned short) buf.st_mode), -1);
  1376.     return TCL_OK;
  1377. }
  1378. case FCMD_VOLUMES: {
  1379.     if (objc != 2) {
  1380. Tcl_WrongNumArgs(interp, 2, objv, NULL);
  1381. return TCL_ERROR;
  1382.     }
  1383.     Tcl_SetObjResult(interp, Tcl_FSListVolumes());
  1384.     return TCL_OK;
  1385. }
  1386. case FCMD_WRITABLE: {
  1387.     if (objc != 3) {
  1388.      goto only3Args;
  1389.     }
  1390.     return CheckAccess(interp, objv[2], W_OK);
  1391. }
  1392.     }
  1394.     only3Args:
  1395.     Tcl_WrongNumArgs(interp, 2, objv, "name");
  1396.     return TCL_ERROR;
  1397. }
  1399. /*
  1400.  *---------------------------------------------------------------------------
  1401.  *
  1402.  * CheckAccess --
  1403.  *
  1404.  * Utility procedure used by Tcl_FileObjCmd() to query file
  1405.  * attributes available through the access() system call.
  1406.  *
  1407.  * Results:
  1408.  * Always returns TCL_OK.  Sets interp's result to boolean true or
  1409.  * false depending on whether the file has the specified attribute.
  1410.  *
  1411.  * Side effects:
  1412.  * None.
  1413.  *
  1414.  *---------------------------------------------------------------------------
  1415.  */
  1416.   
  1417. static int
  1418. CheckAccess(interp, objPtr, mode)
  1419.     Tcl_Interp *interp; /* Interp for status return.  Must not be
  1420.  * NULL. */
  1421.     Tcl_Obj *objPtr; /* Name of file to check. */
  1422.     int mode; /* Attribute to check; passed as argument to
  1423.  * access(). */
  1424. {
  1425.     int value;
  1426.     
  1427.     if (Tcl_FSConvertToPathType(interp, objPtr) != TCL_OK) {
  1428. value = 0;
  1429.     } else {
  1430. value = (Tcl_FSAccess(objPtr, mode) == 0);
  1431.     }
  1432.     Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value);
  1434.     return TCL_OK;
  1435. }
  1437. /*
  1438.  *---------------------------------------------------------------------------
  1439.  *
  1440.  * GetStatBuf --
  1441.  *
  1442.  * Utility procedure used by Tcl_FileObjCmd() to query file
  1443.  * attributes available through the stat() or lstat() system call.
  1444.  *
  1445.  * Results:
  1446.  * The return value is TCL_OK if the specified file exists and can
  1447.  * be stat'ed, TCL_ERROR otherwise.  If TCL_ERROR is returned, an
  1448.  * error message is left in interp's result.  If TCL_OK is returned,
  1449.  * *statPtr is filled with information about the specified file.
  1450.  *
  1451.  * Side effects:
  1452.  * None.
  1453.  *
  1454.  *---------------------------------------------------------------------------
  1455.  */
  1457. static int
  1458. GetStatBuf(interp, objPtr, statProc, statPtr)
  1459.     Tcl_Interp *interp; /* Interp for error return.  May be NULL. */
  1460.     Tcl_Obj *objPtr; /* Path name to examine. */
  1461.     Tcl_FSStatProc *statProc; /* Either stat() or lstat() depending on
  1462.  * desired behavior. */
  1463.     Tcl_StatBuf *statPtr; /* Filled with info about file obtained by
  1464.  * calling (*statProc)(). */
  1465. {
  1466.     int status;
  1467.     
  1468.     if (Tcl_FSConvertToPathType(interp, objPtr) != TCL_OK) {
  1469. return TCL_ERROR;
  1470.     }
  1472.     status = (*statProc)(objPtr, statPtr);
  1473.     
  1474.     if (status < 0) {
  1475. if (interp != NULL) {
  1476.     Tcl_AppendResult(interp, "could not read "",
  1477.     Tcl_GetString(objPtr), "": ",
  1478.     Tcl_PosixError(interp), (char *) NULL);
  1479. }
  1480. return TCL_ERROR;
  1481.     }
  1482.     return TCL_OK;
  1483. }
  1485. /*
  1486.  *----------------------------------------------------------------------
  1487.  *
  1488.  * StoreStatData --
  1489.  *
  1490.  * This is a utility procedure that breaks out the fields of a
  1491.  * "stat" structure and stores them in textual form into the
  1492.  * elements of an associative array.
  1493.  *
  1494.  * Results:
  1495.  * Returns a standard Tcl return value.  If an error occurs then
  1496.  * a message is left in interp's result.
  1497.  *
  1498.  * Side effects:
  1499.  * Elements of the associative array given by "varName" are modified.
  1500.  *
  1501.  *----------------------------------------------------------------------
  1502.  */
  1504. static int
  1505. StoreStatData(interp, varName, statPtr)
  1506.     Tcl_Interp *interp; /* Interpreter for error reports. */
  1507.     char *varName; /* Name of associative array variable
  1508.  * in which to store stat results. */
  1509.     Tcl_StatBuf *statPtr; /* Pointer to buffer containing
  1510.  * stat data to store in varName. */
  1511. {
  1512.     Tcl_Obj *var = Tcl_NewStringObj(varName, -1);
  1513.     Tcl_Obj *field = Tcl_NewObj();
  1514.     Tcl_Obj *value;
  1515.     register unsigned short mode;
  1517.     /*
  1518.      * Assume Tcl_ObjSetVar2() does not keep a copy of the field name!
  1519.      */
  1520. #define STORE_ARY(fieldName, object) 
  1521.     Tcl_SetStringObj(field, (fieldName), -1); 
  1522.     value = (object); 
  1523.     if (Tcl_ObjSetVar2(interp,var,field,value,TCL_LEAVE_ERR_MSG) == NULL) { 
  1524. Tcl_DecrRefCount(var); 
  1525. Tcl_DecrRefCount(field); 
  1526. Tcl_DecrRefCount(value); 
  1527. return TCL_ERROR; 
  1528.     }
  1530.     Tcl_IncrRefCount(var);
  1531.     Tcl_IncrRefCount(field);
  1532.     STORE_ARY("dev",   Tcl_NewLongObj((long)statPtr->st_dev));
  1533.     /*
  1534.      * Watch out porters; the inode is meant to be an *unsigned* value,
  1535.      * so the cast might fail when there isn't a real arithmentic 'long
  1536.      * long' type...
  1537.      */
  1538.     STORE_ARY("ino",   Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_ino));
  1539.     STORE_ARY("nlink", Tcl_NewLongObj((long)statPtr->st_nlink));
  1540.     STORE_ARY("uid",   Tcl_NewLongObj((long)statPtr->st_uid));
  1541.     STORE_ARY("gid",   Tcl_NewLongObj((long)statPtr->st_gid));
  1542.     STORE_ARY("size",  Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_size));
  1543. #ifdef HAVE_ST_BLOCKS
  1544.     STORE_ARY("blocks",Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_blocks));
  1545. #endif
  1546.     STORE_ARY("atime", Tcl_NewLongObj((long)statPtr->st_atime));
  1547.     STORE_ARY("mtime", Tcl_NewLongObj((long)statPtr->st_mtime));
  1548.     STORE_ARY("ctime", Tcl_NewLongObj((long)statPtr->st_ctime));
  1549.     mode = (unsigned short) statPtr->st_mode;
  1550.     STORE_ARY("mode",  Tcl_NewIntObj(mode));
  1551.     STORE_ARY("type",  Tcl_NewStringObj(GetTypeFromMode(mode), -1));
  1552. #undef STORE_ARY
  1553.     Tcl_DecrRefCount(var);
  1554.     Tcl_DecrRefCount(field);
  1555.     return TCL_OK;
  1556. }
  1558. /*
  1559.  *----------------------------------------------------------------------
  1560.  *
  1561.  * GetTypeFromMode --
  1562.  *
  1563.  * Given a mode word, returns a string identifying the type of a
  1564.  * file.
  1565.  *
  1566.  * Results:
  1567.  * A static text string giving the file type from mode.
  1568.  *
  1569.  * Side effects:
  1570.  * None.
  1571.  *
  1572.  *----------------------------------------------------------------------
  1573.  */
  1575. static char *
  1576. GetTypeFromMode(mode)
  1577.     int mode;
  1578. {
  1579.     if (S_ISREG(mode)) {
  1580. return "file";
  1581.     } else if (S_ISDIR(mode)) {
  1582. return "directory";
  1583.     } else if (S_ISCHR(mode)) {
  1584. return "characterSpecial";
  1585.     } else if (S_ISBLK(mode)) {
  1586. return "blockSpecial";
  1587.     } else if (S_ISFIFO(mode)) {
  1588. return "fifo";
  1589. #ifdef S_ISLNK
  1590.     } else if (S_ISLNK(mode)) {
  1591. return "link";
  1592. #endif
  1593. #ifdef S_ISSOCK
  1594.     } else if (S_ISSOCK(mode)) {
  1595. return "socket";
  1596. #endif
  1597.     }
  1598.     return "unknown";
  1599. }
  1601. /*
  1602.  *----------------------------------------------------------------------
  1603.  *
  1604.  * Tcl_ForObjCmd --
  1605.  *
  1606.  *      This procedure is invoked to process the "for" Tcl command.
  1607.  *      See the user documentation for details on what it does.
  1608.  *
  1609.  * With the bytecode compiler, this procedure is only called when
  1610.  * a command name is computed at runtime, and is "for" or the name
  1611.  * to which "for" was renamed: e.g.,
  1612.  * "set z for; $z {set i 0} {$i<100} {incr i} {puts $i}"
  1613.  *
  1614.  * Results:
  1615.  *      A standard Tcl result.
  1616.  *
  1617.  * Side effects:
  1618.  *      See the user documentation.
  1619.  *
  1620.  *----------------------------------------------------------------------
  1621.  */
  1623.         /* ARGSUSED */
  1624. int
  1625. Tcl_ForObjCmd(dummy, interp, objc, objv)
  1626.     ClientData dummy;                   /* Not used. */
  1627.     Tcl_Interp *interp;                 /* Current interpreter. */
  1628.     int objc;                           /* Number of arguments. */
  1629.     Tcl_Obj *CONST objv[]; /* Argument objects. */
  1630. {
  1631.     int result, value;
  1632. #ifdef TCL_TIP280
  1633.     Interp* iPtr = (Interp*) interp;
  1634. #endif
  1636.     if (objc != 5) {
  1637.         Tcl_WrongNumArgs(interp, 1, objv, "start test next command");
  1638.         return TCL_ERROR;
  1639.     }
  1641. #ifndef TCL_TIP280
  1642.     result = Tcl_EvalObjEx(interp, objv[1], 0);
  1643. #else
  1644.     /* TIP #280. Make invoking context available to initial script */
  1645.     result = TclEvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr,1);
  1646. #endif
  1647.     if (result != TCL_OK) {
  1648.         if (result == TCL_ERROR) {
  1649.             Tcl_AddErrorInfo(interp, "n    ("for" initial command)");
  1650.         }
  1651.         return result;
  1652.     }
  1653.     while (1) {
  1654. /*
  1655.  * We need to reset the result before passing it off to
  1656.  * Tcl_ExprBooleanObj.  Otherwise, any error message will be appended
  1657.  * to the result of the last evaluation.
  1658.  */
  1660. Tcl_ResetResult(interp);
  1661.         result = Tcl_ExprBooleanObj(interp, objv[2], &value);
  1662.         if (result != TCL_OK) {
  1663.             return result;
  1664.         }
  1665.         if (!value) {
  1666.             break;
  1667.         }
  1668. #ifndef TCL_TIP280
  1669.         result = Tcl_EvalObjEx(interp, objv[4], 0);
  1670. #else
  1671. /* TIP #280. Make invoking context available to loop body */
  1672.         result = TclEvalObjEx(interp, objv[4], 0, iPtr->cmdFramePtr,4);
  1673. #endif
  1674.         if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
  1675.             if (result == TCL_ERROR) {
  1676.                 char msg[32 + TCL_INTEGER_SPACE];
  1678.                 sprintf(msg, "n    ("for" body line %d)",interp->errorLine);
  1679.                 Tcl_AddErrorInfo(interp, msg);
  1680.             }
  1681.             break;
  1682.         }
  1683. #ifndef TCL_TIP280
  1684.         result = Tcl_EvalObjEx(interp, objv[3], 0);
  1685. #else
  1686. /* TIP #280. Make invoking context available to next script */
  1687.         result = TclEvalObjEx(interp, objv[3], 0, iPtr->cmdFramePtr,3);
  1688. #endif
  1689. if (result == TCL_BREAK) {
  1690.             break;
  1691.         } else if (result != TCL_OK) {
  1692.             if (result == TCL_ERROR) {
  1693.                 Tcl_AddErrorInfo(interp, "n    ("for" loop-end command)");
  1694.             }
  1695.             return result;
  1696.         }
  1697.     }
  1698.     if (result == TCL_BREAK) {
  1699.         result = TCL_OK;
  1700.     }
  1701.     if (result == TCL_OK) {
  1702.         Tcl_ResetResult(interp);
  1703.     }
  1704.     return result;
  1705. }
  1707. /*
  1708.  *----------------------------------------------------------------------
  1709.  *
  1710.  * Tcl_ForeachObjCmd --
  1711.  *
  1712.  * This object-based procedure is invoked to process the "foreach" Tcl
  1713.  * command.  See the user documentation for details on what it does.
  1714.  *
  1715.  * Results:
  1716.  * A standard Tcl object result.
  1717.  *
  1718.  * Side effects:
  1719.  * See the user documentation.
  1720.  *
  1721.  *----------------------------------------------------------------------
  1722.  */
  1724. /* ARGSUSED */
  1725. int
  1726. Tcl_ForeachObjCmd(dummy, interp, objc, objv)
  1727.     ClientData dummy; /* Not used. */
  1728.     Tcl_Interp *interp; /* Current interpreter. */
  1729.     int objc; /* Number of arguments. */
  1730.     Tcl_Obj *CONST objv[]; /* Argument objects. */
  1731. {
  1732.     int result = TCL_OK;
  1733.     int i; /* i selects a value list */
  1734.     int j, maxj; /* Number of loop iterations */
  1735.     int v; /* v selects a loop variable */
  1736.     int numLists; /* Count of value lists */
  1737.     Tcl_Obj *bodyPtr;
  1739.     /*
  1740.      * We copy the argument object pointers into a local array to avoid
  1741.      * the problem that "objv" might become invalid. It is a pointer into
  1742.      * the evaluation stack and that stack might be grown and reallocated
  1743.      * if the loop body requires a large amount of stack space.
  1744.      */
  1745.     
  1746. #define NUM_ARGS 9
  1747.     Tcl_Obj *(argObjStorage[NUM_ARGS]);
  1748.     Tcl_Obj **argObjv = argObjStorage;
  1749.     
  1750. #define STATIC_LIST_SIZE 4
  1751.     int indexArray[STATIC_LIST_SIZE];
  1752.     int varcListArray[STATIC_LIST_SIZE];
  1753.     Tcl_Obj **varvListArray[STATIC_LIST_SIZE];
  1754.     int argcListArray[STATIC_LIST_SIZE];
  1755.     Tcl_Obj **argvListArray[STATIC_LIST_SIZE];
  1757.     int *index = indexArray;    /* Array of value list indices */
  1758.     int *varcList = varcListArray;    /* # loop variables per list */
  1759.     Tcl_Obj ***varvList = varvListArray;   /* Array of var name lists */
  1760.     int *argcList = argcListArray;    /* Array of value list sizes */
  1761.     Tcl_Obj ***argvList = argvListArray;   /* Array of value lists */
  1762. #ifdef TCL_TIP280
  1763.     Interp* iPtr = (Interp*) interp;
  1764. #endif
  1766.     if (objc < 4 || (objc%2 != 0)) {
  1767. Tcl_WrongNumArgs(interp, 1, objv,
  1768. "varList list ?varList list ...? command");
  1769. return TCL_ERROR;
  1770.     }
  1772.     /*
  1773.      * Create the object argument array "argObjv". Make sure argObjv is
  1774.      * large enough to hold the objc arguments.
  1775.      */
  1777.     if (objc > NUM_ARGS) {
  1778. argObjv = (Tcl_Obj **) ckalloc(objc * sizeof(Tcl_Obj *));
  1779.     }
  1780.     for (i = 0;  i < objc;  i++) {
  1781. argObjv[i] = objv[i];
  1782.     }
  1784.     /*
  1785.      * Manage numList parallel value lists.
  1786.      * argvList[i] is a value list counted by argcList[i]
  1787.      * varvList[i] is the list of variables associated with the value list
  1788.      * varcList[i] is the number of variables associated with the value list
  1789.      * index[i] is the current pointer into the value list argvList[i]
  1790.      */
  1792.     numLists = (objc-2)/2;
  1793.     if (numLists > STATIC_LIST_SIZE) {
  1794. index = (int *) ckalloc(numLists * sizeof(int));
  1795. varcList = (int *) ckalloc(numLists * sizeof(int));
  1796. varvList = (Tcl_Obj ***) ckalloc(numLists * sizeof(Tcl_Obj **));
  1797. argcList = (int *) ckalloc(numLists * sizeof(int));
  1798. argvList = (Tcl_Obj ***) ckalloc(numLists * sizeof(Tcl_Obj **));
  1799.     }
  1800.     for (i = 0;  i < numLists;  i++) {
  1801. index[i] = 0;
  1802. varcList[i] = 0;
  1803. varvList[i] = (Tcl_Obj **) NULL;
  1804. argcList[i] = 0;
  1805. argvList[i] = (Tcl_Obj **) NULL;
  1806.     }
  1808.     /*
  1809.      * Break up the value lists and variable lists into elements
  1810.      */
  1812.     maxj = 0;
  1813.     for (i = 0;  i < numLists;  i++) {
  1814. result = Tcl_ListObjGetElements(interp, argObjv[1+i*2],
  1815.         &varcList[i], &varvList[i]);
  1816. if (result != TCL_OK) {
  1817.     goto done;
  1818. }
  1819. if (varcList[i] < 1) {
  1820.     Tcl_AppendToObj(Tcl_GetObjResult(interp),
  1821.             "foreach varlist is empty", -1);
  1822.     result = TCL_ERROR;
  1823.     goto done;
  1824. }
  1826. result = Tcl_ListObjGetElements(interp, argObjv[2+i*2],
  1827.         &argcList[i], &argvList[i]);
  1828. if (result != TCL_OK) {
  1829.     goto done;
  1830. }
  1832. j = argcList[i] / varcList[i];
  1833. if ((argcList[i] % varcList[i]) != 0) {
  1834.     j++;
  1835. }
  1836. if (j > maxj) {
  1837.     maxj = j;
  1838. }
  1839.     }
  1841.     /*
  1842.      * Iterate maxj times through the lists in parallel
  1843.      * If some value lists run out of values, set loop vars to ""
  1844.      */
  1845.     
  1846.     bodyPtr = argObjv[objc-1];
  1847.     for (j = 0;  j < maxj;  j++) {
  1848. for (i = 0;  i < numLists;  i++) {
  1849.     /*
  1850.      * Refetch the list members; we assume that the sizes are
  1851.      * the same, but the array of elements might be different
  1852.      * if the internal rep of the objects has been lost and
  1853.      * recreated (it is too difficult to accurately tell when
  1854.      * this happens, which can lead to some wierd crashes,
  1855.      * like Bug #494348...)
  1856.      */
  1858.     result = Tcl_ListObjGetElements(interp, argObjv[1+i*2],
  1859.     &varcList[i], &varvList[i]);
  1860.     if (result != TCL_OK) {
  1861. panic("Tcl_ForeachObjCmd: could not reconvert variable list %d to a list objectn", i);
  1862.     }
  1863.     result = Tcl_ListObjGetElements(interp, argObjv[2+i*2],
  1864.     &argcList[i], &argvList[i]);
  1865.     if (result != TCL_OK) {
  1866. panic("Tcl_ForeachObjCmd: could not reconvert value list %d to a list objectn", i);
  1867.     }
  1868.     
  1869.     for (v = 0;  v < varcList[i];  v++) {
  1870. int k = index[i]++;
  1871. Tcl_Obj *valuePtr, *varValuePtr;
  1873. if (k < argcList[i]) {
  1874.     valuePtr = argvList[i][k];
  1875. } else {
  1876.     valuePtr = Tcl_NewObj(); /* empty string */
  1877. }
  1878. Tcl_IncrRefCount(valuePtr);
  1879. varValuePtr = Tcl_ObjSetVar2(interp, varvList[i][v],
  1880. NULL, valuePtr, 0);
  1881. Tcl_DecrRefCount(valuePtr);
  1882. if (varValuePtr == NULL) {
  1883.     Tcl_ResetResult(interp);
  1884.     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  1885. "couldn't set loop variable: "",
  1886. Tcl_GetString(varvList[i][v]), """, (char *) NULL);
  1887.     result = TCL_ERROR;
  1888.     goto done;
  1889. }
  1891.     }
  1892. }
  1894. #ifndef TCL_TIP280
  1895. result = Tcl_EvalObjEx(interp, bodyPtr, 0);
  1896. #else
  1897. /* TIP #280. Make invoking context available to loop body */
  1898. result = TclEvalObjEx(interp, bodyPtr, 0, iPtr->cmdFramePtr,objc-1);
  1899. #endif
  1900. if (result != TCL_OK) {
  1901.     if (result == TCL_CONTINUE) {
  1902. result = TCL_OK;
  1903.     } else if (result == TCL_BREAK) {
  1904. result = TCL_OK;
  1905. break;
  1906.     } else if (result == TCL_ERROR) {
  1907.                 char msg[32 + TCL_INTEGER_SPACE];
  1909. sprintf(msg, "n    ("foreach" body line %d)",
  1910. interp->errorLine);
  1911. Tcl_AddObjErrorInfo(interp, msg, -1);
  1912. break;
  1913.     } else {
  1914. break;
  1915.     }
  1916. }
  1917.     }
  1918.     if (result == TCL_OK) {
  1919. Tcl_ResetResult(interp);
  1920.     }
  1922.     done:
  1923.     if (numLists > STATIC_LIST_SIZE) {
  1924. ckfree((char *) index);
  1925. ckfree((char *) varcList);
  1926. ckfree((char *) argcList);
  1927. ckfree((char *) varvList);
  1928. ckfree((char *) argvList);
  1929.     }
  1930.     if (argObjv != argObjStorage) {
  1931. ckfree((char *) argObjv);
  1932.     }
  1933.     return result;
  1934. #undef STATIC_LIST_SIZE
  1935. #undef NUM_ARGS
  1936. }
  1938. /*
  1939.  *----------------------------------------------------------------------
  1940.  *
  1941.  * Tcl_FormatObjCmd --
  1942.  *
  1943.  * This procedure is invoked to process the "format" Tcl command.
  1944.  * See the user documentation for details on what it does.
  1945.  *
  1946.  * Results:
  1947.  * A standard Tcl result.
  1948.  *
  1949.  * Side effects:
  1950.  * See the user documentation.
  1951.  *
  1952.  *----------------------------------------------------------------------
  1953.  */
  1955. /* ARGSUSED */
  1956. int
  1957. Tcl_FormatObjCmd(dummy, interp, objc, objv)
  1958.     ClientData dummy;     /* Not used. */
  1959.     Tcl_Interp *interp; /* Current interpreter. */
  1960.     int objc; /* Number of arguments. */
  1961.     Tcl_Obj *CONST objv[]; /* Argument objects. */
  1962. {
  1963.     char *format; /* Used to read characters from the format
  1964.  * string. */
  1965.     int formatLen; /* The length of the format string */
  1966.     char *endPtr; /* Points to the last char in format array */
  1967.     char newFormat[43]; /* A new format specifier is generated here. */
  1968.     int width; /* Field width from field specifier, or 0 if
  1969.  * no width given. */
  1970.     int precision; /* Field precision from field specifier, or 0
  1971.  * if no precision given. */
  1972.     int size; /* Number of bytes needed for result of
  1973.  * conversion, based on type of conversion
  1974.  * ("e", "s", etc.), width, and precision. */
  1975.     long intValue; /* Used to hold value to pass to sprintf, if
  1976.  * it's a one-word integer or char value */
  1977.     char *ptrValue = NULL; /* Used to hold value to pass to sprintf, if
  1978.  * it's a one-word value. */
  1979.     double doubleValue; /* Used to hold value to pass to sprintf if
  1980.  * it's a double value. */
  1981.     Tcl_WideInt wideValue; /* Used to hold value to pass to sprintf if
  1982.  * it's a 'long long' value. */
  1983.     int whichValue; /* Indicates which of intValue, ptrValue,
  1984.  * or doubleValue has the value to pass to
  1985.  * sprintf, according to the following
  1986.  * definitions: */
  1987. #   define INT_VALUE 0
  1988. #   define CHAR_VALUE 1
  1989. #   define PTR_VALUE 2
  1990. #   define DOUBLE_VALUE 3
  1991. #   define STRING_VALUE 4
  1992. #   define WIDE_VALUE 5
  1993. #   define MAX_FLOAT_SIZE 320
  1995.     Tcl_Obj *resultPtr;   /* Where result is stored finally. */
  1996.     char staticBuf[MAX_FLOAT_SIZE + 1];
  1997. /* A static buffer to copy the format results 
  1998.  * into */
  1999.     char *dst = staticBuf;      /* The buffer that sprintf writes into each
  2000.  * time the format processes a specifier */
  2001.     int dstSize = MAX_FLOAT_SIZE;
  2002. /* The size of the dst buffer */
  2003.     int noPercent; /* Special case for speed:  indicates there's
  2004.  * no field specifier, just a string to copy.*/
  2005.     int objIndex; /* Index of argument to substitute next. */
  2006.     int gotXpg = 0; /* Non-zero means that an XPG3 %n$-style
  2007.  * specifier has been seen. */
  2008.     int gotSequential = 0; /* Non-zero means that a regular sequential
  2009.  * (non-XPG3) conversion specifier has been
  2010.  * seen. */
  2011.     int useShort; /* Value to be printed is short (half word). */
  2012.     char *end; /* Used to locate end of numerical fields. */
  2013.     int stringLen = 0; /* Length of string in characters rather
  2014.  * than bytes.  Used for %s substitution. */
  2015.     int gotMinus; /* Non-zero indicates that a minus flag has
  2016.  * been seen in the current field. */
  2017.     int gotPrecision; /* Non-zero indicates that a precision has
  2018.  * been set for the current field. */
  2019.     int gotZero; /* Non-zero indicates that a zero flag has
  2020.  * been seen in the current field. */
  2021.     int useWide; /* Value to be printed is Tcl_WideInt. */
  2023.     /*
  2024.      * This procedure is a bit nasty.  The goal is to use sprintf to
  2025.      * do most of the dirty work.  There are several problems:
  2026.      * 1. this procedure can't trust its arguments.
  2027.      * 2. we must be able to provide a large enough result area to hold
  2028.      *    whatever's generated.  This is hard to estimate.
  2029.      * 3. there's no way to move the arguments from objv to the call
  2030.      *    to sprintf in a reasonable way.  This is particularly nasty
  2031.      *    because some of the arguments may be two-word values (doubles
  2032.      *    and wide-ints).
  2033.      * So, what happens here is to scan the format string one % group
  2034.      * at a time, making many individual calls to sprintf.
  2035.      */
  2037.     if (objc < 2) {
  2038. Tcl_WrongNumArgs(interp, 1, objv, "formatString ?arg arg ...?");
  2039. return TCL_ERROR;
  2040.     }
  2042.     format = Tcl_GetStringFromObj(objv[1], &formatLen);
  2043.     endPtr = format + formatLen;
  2044.     resultPtr = Tcl_NewObj();
  2045.     objIndex = 2;
  2047.     while (format < endPtr) {
  2048. register char *newPtr = newFormat;
  2050. width = precision = noPercent = useShort = 0;
  2051. gotZero = gotMinus = gotPrecision = 0;
  2052. useWide = 0;
  2053. whichValue = PTR_VALUE;
  2055. /*
  2056.  * Get rid of any characters before the next field specifier.
  2057.  */
  2058. if (*format != '%') {
  2059.     ptrValue = format;
  2060.     while ((*format != '%') && (format < endPtr)) {
  2061. format++;
  2062.     }
  2063.     size = format - ptrValue;
  2064.     noPercent = 1;
  2065.     goto doField;
  2066. }
  2068. if (format[1] == '%') {
  2069.     ptrValue = format;
  2070.     size = 1;
  2071.     noPercent = 1;
  2072.     format += 2;
  2073.     goto doField;
  2074. }
  2076. /*
  2077.  * Parse off a field specifier, compute how many characters
  2078.  * will be needed to store the result, and substitute for
  2079.  * "*" size specifiers.
  2080.  */
  2081. *newPtr = '%';
  2082. newPtr++;
  2083. format++;
  2084. if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */
  2085.     int tmp;
  2087.     /*
  2088.      * Check for an XPG3-style %n$ specification.  Note: there
  2089.      * must not be a mixture of XPG3 specs and non-XPG3 specs
  2090.      * in the same format string.
  2091.      */
  2093.     tmp = strtoul(format, &end, 10); /* INTL: "C" locale. */
  2094.     if (*end != '$') {
  2095. goto notXpg;
  2096.     }
  2097.     format = end+1;
  2098.     gotXpg = 1;
  2099.     if (gotSequential) {
  2100. goto mixedXPG;
  2101.     }
  2102.     objIndex = tmp+1;
  2103.     if ((objIndex < 2) || (objIndex >= objc)) {
  2104. goto badIndex;
  2105.     }
  2106.     goto xpgCheckDone;
  2107. }
  2109. notXpg:
  2110. gotSequential = 1;
  2111. if (gotXpg) {
  2112.     goto mixedXPG;
  2113. }
  2115. xpgCheckDone:
  2116. while ((*format == '-') || (*format == '#') || (*format == '0')
  2117. || (*format == ' ') || (*format == '+')) {
  2118.     if (*format == '-') {
  2119. gotMinus = 1;
  2120.     }
  2121.     if (*format == '0') {
  2122. /*
  2123.  * This will be handled by sprintf for numbers, but we
  2124.  * need to do the char/string ones ourselves
  2125.  */
  2126. gotZero = 1;
  2127.     }
  2128.     *newPtr = *format;
  2129.     newPtr++;
  2130.     format++;
  2131. }
  2132. if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */
  2133.     width = strtoul(format, &end, 10); /* INTL: Tcl source. */
  2134.     format = end;
  2135. } else if (*format == '*') {
  2136.     if (objIndex >= objc) {
  2137. goto badIndex;
  2138.     }
  2139.     if (Tcl_GetIntFromObj(interp, /* INTL: Tcl source. */
  2140.     objv[objIndex], &width) != TCL_OK) {
  2141. goto fmtError;
  2142.     }
  2143.     if (width < 0) {
  2144. width = -width;
  2145. *newPtr = '-';
  2146. gotMinus = 1;
  2147. newPtr++;
  2148.     }
  2149.     objIndex++;
  2150.     format++;
  2151. }
  2152. if (width > 100000) {
  2153.     /*
  2154.      * Don't allow arbitrarily large widths:  could cause core
  2155.      * dump when we try to allocate a zillion bytes of memory
  2156.      * below.
  2157.      */
  2159.     width = 100000;
  2160. } else if (width < 0) {
  2161.     width = 0;
  2162. }
  2163. if (width != 0) {
  2164.     TclFormatInt(newPtr, width); /* INTL: printf format. */
  2165.     while (*newPtr != 0) {
  2166. newPtr++;
  2167.     }
  2168. }
  2169. if (*format == '.') {
  2170.     *newPtr = '.';
  2171.     newPtr++;
  2172.     format++;
  2173.     gotPrecision = 1;
  2174. }
  2175. if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */
  2176.     precision = strtoul(format, &end, 10);  /* INTL: "C" locale. */
  2177.     format = end;
  2178. } else if (*format == '*') {
  2179.     if (objIndex >= objc) {
  2180. goto badIndex;
  2181.     }
  2182.     if (Tcl_GetIntFromObj(interp, /* INTL: Tcl source. */
  2183.     objv[objIndex], &precision) != TCL_OK) {
  2184. goto fmtError;
  2185.     }
  2186.     objIndex++;
  2187.     format++;
  2188. }
  2189. if (gotPrecision) {
  2190.     TclFormatInt(newPtr, precision); /* INTL: printf format. */
  2191.     while (*newPtr != 0) {
  2192. newPtr++;
  2193.     }
  2194. }
  2195. if (*format == 'l') {
  2196.     useWide = 1;
  2197.     /*
  2198.      * Only add a 'll' modifier for integer values as it makes
  2199.      * some libc's go into spasm otherwise.  [Bug #702622]
  2200.      */
  2201.     switch (format[1]) {
  2202.     case 'i':
  2203.     case 'd':
  2204.     case 'o':
  2205.     case 'u':
  2206.     case 'x':
  2207.     case 'X':
  2208. strcpy(newPtr, TCL_LL_MODIFIER);
  2209. newPtr += TCL_LL_MODIFIER_SIZE;
  2210.     }
  2211.     format++;
  2212. } else if (*format == 'h') {
  2213.     useShort = 1;
  2214.     *newPtr = 'h';
  2215.     newPtr++;
  2216.     format++;
  2217. }
  2218. *newPtr = *format;
  2219. newPtr++;
  2220. *newPtr = 0;
  2221. if (objIndex >= objc) {
  2222.     goto badIndex;
  2223. }
  2224. switch (*format) {
  2225. case 'i':
  2226.     newPtr[-1] = 'd';
  2227. case 'd':
  2228. case 'o':
  2229. case 'u':
  2230. case 'x':
  2231. case 'X':
  2232.     if (useWide) {
  2233. if (Tcl_GetWideIntFromObj(interp, /* INTL: Tcl source. */
  2234. objv[objIndex], &wideValue) != TCL_OK) {
  2235.     goto fmtError;
  2236. }
  2237. whichValue = WIDE_VALUE;
  2238. size = 40 + precision;
  2239. break;
  2240.     }
  2241.     if (Tcl_GetLongFromObj(interp, /* INTL: Tcl source. */
  2242.     objv[objIndex], &intValue) != TCL_OK) {
  2243. if (Tcl_GetWideIntFromObj(interp, /* INTL: Tcl source. */
  2244. objv[objIndex], &wideValue) != TCL_OK) {
  2245.     goto fmtError;
  2246. }
  2247. intValue = Tcl_WideAsLong(wideValue);
  2248.     }
  2250. #if (LONG_MAX > INT_MAX)
  2251.     if (!useShort) {
  2252. /*
  2253.  * Add the 'l' for long format type because we are on an
  2254.  * LP64 archtecture and we are really going to pass a long
  2255.  * argument to sprintf.
  2256.  *
  2257.  * Do not add this if we're going to pass in a short (i.e.
  2258.  * if we've got an 'h' modifier already in the string); some
  2259.  * libc implementations of sprintf() do not like it at all.
  2260.  * [Bug 1154163]
  2261.  */
  2262. newPtr++;
  2263. *newPtr = 0;
  2264. newPtr[-1] = newPtr[-2];
  2265. newPtr[-2] = 'l';
  2266.     }
  2267. #endif /* LONG_MAX > INT_MAX */
  2268.     whichValue = INT_VALUE;
  2269.     size = 40 + precision;
  2270.     break;
  2271. case 's':
  2272.     /*
  2273.      * Compute the length of the string in characters and add
  2274.      * any additional space required by the field width.  All
  2275.      * of the extra characters will be spaces, so one byte per
  2276.      * character is adequate.
  2277.      */
  2279.     whichValue = STRING_VALUE;
  2280.     ptrValue = Tcl_GetStringFromObj(objv[objIndex], &size);
  2281.     stringLen = Tcl_NumUtfChars(ptrValue, size);
  2282.     if (gotPrecision && (precision < stringLen)) {
  2283. stringLen = precision;
  2284.     }
  2285.     size = Tcl_UtfAtIndex(ptrValue, stringLen) - ptrValue;
  2286.     if (width > stringLen) {
  2287. size += (width - stringLen);
  2288.     }
  2289.     break;
  2290. case 'c':
  2291.     if (Tcl_GetLongFromObj(interp, /* INTL: Tcl source. */
  2292.     objv[objIndex], &intValue) != TCL_OK) {
  2293. goto fmtError;
  2294.     }
  2295.     whichValue = CHAR_VALUE;
  2296.     size = width + TCL_UTF_MAX;
  2297.     break;
  2298. case 'e':
  2299. case 'E':
  2300. case 'f':
  2301. case 'g':
  2302. case 'G':
  2303.     if (Tcl_GetDoubleFromObj(interp, /* INTL: Tcl source. */
  2304.     objv[objIndex], &doubleValue) != TCL_OK) {
  2305. goto fmtError;
  2306.     }
  2307.     whichValue = DOUBLE_VALUE;
  2308.     size = MAX_FLOAT_SIZE;
  2309.     if (precision > 10) {
  2310. size += precision;
  2311.     }
  2312.     break;
  2313. case 0:
  2314.     Tcl_SetResult(interp,
  2315.     "format string ended in middle of field specifier",
  2316.     TCL_STATIC);
  2317.     goto fmtError;
  2318. default:
  2319. {
  2320.     char buf[40];
  2322.     sprintf(buf, "bad field specifier "%c"", *format);
  2323.     Tcl_SetResult(interp, buf, TCL_VOLATILE);
  2324.     goto fmtError;
  2325. }
  2326. }
  2327. objIndex++;
  2328. format++;
  2330. /*
  2331.  * Make sure that there's enough space to hold the formatted
  2332.  * result, then format it.
  2333.  */
  2335. doField:
  2336. if (width > size) {
  2337.     size = width;
  2338. }
  2339. if (noPercent) {
  2340.     Tcl_AppendToObj(resultPtr, ptrValue, size);
  2341. } else {
  2342.     if (size > dstSize) {
  2343.         if (dst != staticBuf) {
  2344.     ckfree(dst);
  2345. }
  2346. dst = (char *) ckalloc((unsigned) (size + 1));
  2347. dstSize = size;
  2348.     }
  2349.     switch (whichValue) {
  2350.     case DOUBLE_VALUE:
  2351. sprintf(dst, newFormat, doubleValue); /* INTL: user locale. */
  2352. break;
  2353.     case WIDE_VALUE:
  2354. sprintf(dst, newFormat, wideValue);
  2355. break;
  2356.     case INT_VALUE:
  2357. if (useShort) {
  2358.     sprintf(dst, newFormat, (short) intValue);
  2359. } else {
  2360.     sprintf(dst, newFormat, intValue);
  2361. }
  2362. break;
  2363.     case CHAR_VALUE: {
  2364. char *ptr;
  2365. char padChar = (gotZero ? '0' : ' ');
  2366. ptr = dst;
  2367. if (!gotMinus) {
  2368.     for ( ; --width > 0; ptr++) {
  2369. *ptr = padChar;
  2370.     }
  2371. }
  2372. ptr += Tcl_UniCharToUtf(intValue, ptr);
  2373. for ( ; --width > 0; ptr++) {
  2374.     *ptr = padChar;
  2375. }
  2376. *ptr = '';
  2377. break;
  2378.     }
  2379.     case STRING_VALUE: {
  2380. char *ptr;
  2381. char padChar = (gotZero ? '0' : ' ');
  2382. int pad;
  2384. ptr = dst;
  2385. if (width > stringLen) {
  2386.     pad = width - stringLen;
  2387. } else {
  2388.     pad = 0;
  2389. }
  2391. if (!gotMinus) {
  2392.     while (pad > 0) {
  2393. *ptr++ = padChar;
  2394. pad--;
  2395.     }
  2396. }
  2398. size = Tcl_UtfAtIndex(ptrValue, stringLen) - ptrValue; 
  2399. if (size) {
  2400.     memcpy(ptr, ptrValue, (size_t) size);
  2401.     ptr += size;
  2402. }
  2403. while (pad > 0) {
  2404.     *ptr++ = padChar;
  2405.     pad--;
  2406. }
  2407. *ptr = '';
  2408. break;
  2409.     }
  2410.     default:
  2411. sprintf(dst, newFormat, ptrValue);
  2412. break;
  2413.     }
  2414.     Tcl_AppendToObj(resultPtr, dst, -1);
  2415. }
  2416.     }
  2418.     Tcl_SetObjResult(interp, resultPtr);
  2419.     if (dst != staticBuf) {
  2420. ckfree(dst);
  2421.     }
  2422.     return TCL_OK;
  2424.     mixedXPG:
  2425.     Tcl_SetResult(interp, 
  2426.     "cannot mix "%" and "%n$" conversion specifiers", TCL_STATIC);
  2427.     goto fmtError;
  2429.     badIndex:
  2430.     if (gotXpg) {
  2431. Tcl_SetResult(interp, 
  2432. ""%n$" argument index out of range", TCL_STATIC);
  2433.     } else {
  2434. Tcl_SetResult(interp, 
  2435. "not enough arguments for all format specifiers", TCL_STATIC);
  2436.     }
  2438.     fmtError:
  2439.     if (dst != staticBuf) {
  2440. ckfree(dst);
  2441.     }
  2442.     Tcl_DecrRefCount(resultPtr);
  2443.     return TCL_ERROR;
  2444. }
  2446. /*
  2447.  * Local Variables:
  2448.  * mode: c
  2449.  * c-basic-offset: 4
  2450.  * fill-column: 78
  2451.  * End:
  2452.  */