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