os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclCmdAH.c
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclCmdAH.c Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,2457 @@
1.4 +/*
1.5 + * tclCmdAH.c --
1.6 + *
1.7 + * This file contains the top-level command routines for most of
1.8 + * the Tcl built-in commands whose names begin with the letters
1.9 + * A to H.
1.10 + *
1.11 + * Copyright (c) 1987-1993 The Regents of the University of California.
1.12 + * Copyright (c) 1994-1997 Sun Microsystems, Inc.
1.13 + * Portions Copyright (c) 2007 Nokia Corporation and/or its subsidiaries. All rights reserved.
1.14 + *
1.15 + * See the file "license.terms" for information on usage and redistribution
1.16 + * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.17 + *
1.18 + * RCS: @(#) $Id: tclCmdAH.c,v 1.27.2.16 2006/11/28 22:20:00 andreas_kupries Exp $
1.19 + */
1.20 +
1.21 +#include "tclInt.h"
1.22 +#include "tclPort.h"
1.23 +#include <locale.h>
1.24 +#if defined(__SYMBIAN32__)
1.25 +#include "tclSymbianGlobals.h"
1.26 +#endif
1.27 +
1.28 +/*
1.29 + * Prototypes for local procedures defined in this file:
1.30 + */
1.31 +
1.32 +static int CheckAccess _ANSI_ARGS_((Tcl_Interp *interp,
1.33 + Tcl_Obj *objPtr, int mode));
1.34 +static int GetStatBuf _ANSI_ARGS_((Tcl_Interp *interp,
1.35 + Tcl_Obj *objPtr, Tcl_FSStatProc *statProc,
1.36 + Tcl_StatBuf *statPtr));
1.37 +static char * GetTypeFromMode _ANSI_ARGS_((int mode));
1.38 +static int StoreStatData _ANSI_ARGS_((Tcl_Interp *interp,
1.39 + char *varName, Tcl_StatBuf *statPtr));
1.40 +
1.41 +/*
1.42 + *----------------------------------------------------------------------
1.43 + *
1.44 + * Tcl_BreakObjCmd --
1.45 + *
1.46 + * This procedure is invoked to process the "break" Tcl command.
1.47 + * See the user documentation for details on what it does.
1.48 + *
1.49 + * With the bytecode compiler, this procedure is only called when
1.50 + * a command name is computed at runtime, and is "break" or the name
1.51 + * to which "break" was renamed: e.g., "set z break; $z"
1.52 + *
1.53 + * Results:
1.54 + * A standard Tcl result.
1.55 + *
1.56 + * Side effects:
1.57 + * See the user documentation.
1.58 + *
1.59 + *----------------------------------------------------------------------
1.60 + */
1.61 +
1.62 + /* ARGSUSED */
1.63 +int
1.64 +Tcl_BreakObjCmd(dummy, interp, objc, objv)
1.65 + ClientData dummy; /* Not used. */
1.66 + Tcl_Interp *interp; /* Current interpreter. */
1.67 + int objc; /* Number of arguments. */
1.68 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.69 +{
1.70 + if (objc != 1) {
1.71 + Tcl_WrongNumArgs(interp, 1, objv, NULL);
1.72 + return TCL_ERROR;
1.73 + }
1.74 + return TCL_BREAK;
1.75 +}
1.76 +
1.77 +/*
1.78 + *----------------------------------------------------------------------
1.79 + *
1.80 + * Tcl_CaseObjCmd --
1.81 + *
1.82 + * This procedure is invoked to process the "case" Tcl command.
1.83 + * See the user documentation for details on what it does.
1.84 + *
1.85 + * Results:
1.86 + * A standard Tcl object result.
1.87 + *
1.88 + * Side effects:
1.89 + * See the user documentation.
1.90 + *
1.91 + *----------------------------------------------------------------------
1.92 + */
1.93 +
1.94 + /* ARGSUSED */
1.95 +int
1.96 +Tcl_CaseObjCmd(dummy, interp, objc, objv)
1.97 + ClientData dummy; /* Not used. */
1.98 + Tcl_Interp *interp; /* Current interpreter. */
1.99 + int objc; /* Number of arguments. */
1.100 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.101 +{
1.102 + register int i;
1.103 + int body, result, caseObjc;
1.104 + char *string, *arg;
1.105 + Tcl_Obj *CONST *caseObjv;
1.106 + Tcl_Obj *armPtr;
1.107 +
1.108 + if (objc < 3) {
1.109 + Tcl_WrongNumArgs(interp, 1, objv,
1.110 + "string ?in? patList body ... ?default body?");
1.111 + return TCL_ERROR;
1.112 + }
1.113 +
1.114 + string = Tcl_GetString(objv[1]);
1.115 + body = -1;
1.116 +
1.117 + arg = Tcl_GetString(objv[2]);
1.118 + if (strcmp(arg, "in") == 0) {
1.119 + i = 3;
1.120 + } else {
1.121 + i = 2;
1.122 + }
1.123 + caseObjc = objc - i;
1.124 + caseObjv = objv + i;
1.125 +
1.126 + /*
1.127 + * If all of the pattern/command pairs are lumped into a single
1.128 + * argument, split them out again.
1.129 + */
1.130 +
1.131 + if (caseObjc == 1) {
1.132 + Tcl_Obj **newObjv;
1.133 +
1.134 + Tcl_ListObjGetElements(interp, caseObjv[0], &caseObjc, &newObjv);
1.135 + caseObjv = newObjv;
1.136 + }
1.137 +
1.138 + for (i = 0; i < caseObjc; i += 2) {
1.139 + int patObjc, j;
1.140 + CONST char **patObjv;
1.141 + char *pat;
1.142 + unsigned char *p;
1.143 +
1.144 + if (i == (caseObjc - 1)) {
1.145 + Tcl_ResetResult(interp);
1.146 + Tcl_AppendToObj(Tcl_GetObjResult(interp),
1.147 + "extra case pattern with no body", -1);
1.148 + return TCL_ERROR;
1.149 + }
1.150 +
1.151 + /*
1.152 + * Check for special case of single pattern (no list) with
1.153 + * no backslash sequences.
1.154 + */
1.155 +
1.156 + pat = Tcl_GetString(caseObjv[i]);
1.157 + for (p = (unsigned char *) pat; *p != '\0'; p++) {
1.158 + if (isspace(*p) || (*p == '\\')) { /* INTL: ISO space, UCHAR */
1.159 + break;
1.160 + }
1.161 + }
1.162 + if (*p == '\0') {
1.163 + if ((*pat == 'd') && (strcmp(pat, "default") == 0)) {
1.164 + body = i + 1;
1.165 + }
1.166 + if (Tcl_StringMatch(string, pat)) {
1.167 + body = i + 1;
1.168 + goto match;
1.169 + }
1.170 + continue;
1.171 + }
1.172 +
1.173 +
1.174 + /*
1.175 + * Break up pattern lists, then check each of the patterns
1.176 + * in the list.
1.177 + */
1.178 +
1.179 + result = Tcl_SplitList(interp, pat, &patObjc, &patObjv);
1.180 + if (result != TCL_OK) {
1.181 + return result;
1.182 + }
1.183 + for (j = 0; j < patObjc; j++) {
1.184 + if (Tcl_StringMatch(string, patObjv[j])) {
1.185 + body = i + 1;
1.186 + break;
1.187 + }
1.188 + }
1.189 + ckfree((char *) patObjv);
1.190 + if (j < patObjc) {
1.191 + break;
1.192 + }
1.193 + }
1.194 +
1.195 + match:
1.196 + if (body != -1) {
1.197 + armPtr = caseObjv[body - 1];
1.198 + result = Tcl_EvalObjEx(interp, caseObjv[body], 0);
1.199 + if (result == TCL_ERROR) {
1.200 + char msg[100 + TCL_INTEGER_SPACE];
1.201 +
1.202 + arg = Tcl_GetString(armPtr);
1.203 + sprintf(msg,
1.204 + "\n (\"%.50s\" arm line %d)", arg,
1.205 + interp->errorLine);
1.206 + Tcl_AddObjErrorInfo(interp, msg, -1);
1.207 + }
1.208 + return result;
1.209 + }
1.210 +
1.211 + /*
1.212 + * Nothing matched: return nothing.
1.213 + */
1.214 +
1.215 + return TCL_OK;
1.216 +}
1.217 +
1.218 +/*
1.219 + *----------------------------------------------------------------------
1.220 + *
1.221 + * Tcl_CatchObjCmd --
1.222 + *
1.223 + * This object-based procedure is invoked to process the "catch" Tcl
1.224 + * command. See the user documentation for details on what it does.
1.225 + *
1.226 + * Results:
1.227 + * A standard Tcl object result.
1.228 + *
1.229 + * Side effects:
1.230 + * See the user documentation.
1.231 + *
1.232 + *----------------------------------------------------------------------
1.233 + */
1.234 +
1.235 + /* ARGSUSED */
1.236 +int
1.237 +Tcl_CatchObjCmd(dummy, interp, objc, objv)
1.238 + ClientData dummy; /* Not used. */
1.239 + Tcl_Interp *interp; /* Current interpreter. */
1.240 + int objc; /* Number of arguments. */
1.241 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.242 +{
1.243 + Tcl_Obj *varNamePtr = NULL;
1.244 + int result;
1.245 +#ifdef TCL_TIP280
1.246 + Interp* iPtr = (Interp*) interp;
1.247 +#endif
1.248 +
1.249 + if ((objc != 2) && (objc != 3)) {
1.250 + Tcl_WrongNumArgs(interp, 1, objv, "command ?varName?");
1.251 + return TCL_ERROR;
1.252 + }
1.253 +
1.254 + if (objc == 3) {
1.255 + varNamePtr = objv[2];
1.256 + }
1.257 +
1.258 +#ifndef TCL_TIP280
1.259 + result = Tcl_EvalObjEx(interp, objv[1], 0);
1.260 +#else
1.261 + /* TIP #280. Make invoking context available to caught script */
1.262 + result = TclEvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr,1);
1.263 +#endif
1.264 +
1.265 + if (objc == 3) {
1.266 + if (Tcl_ObjSetVar2(interp, varNamePtr, NULL,
1.267 + Tcl_GetObjResult(interp), 0) == NULL) {
1.268 + Tcl_ResetResult(interp);
1.269 + Tcl_AppendToObj(Tcl_GetObjResult(interp),
1.270 + "couldn't save command result in variable", -1);
1.271 + return TCL_ERROR;
1.272 + }
1.273 + }
1.274 +
1.275 + /*
1.276 + * Set the interpreter's object result to an integer object holding the
1.277 + * integer Tcl_EvalObj result. Note that we don't bother generating a
1.278 + * string representation. We reset the interpreter's object result
1.279 + * to an unshared empty object and then set it to be an integer object.
1.280 + */
1.281 +
1.282 + Tcl_ResetResult(interp);
1.283 + Tcl_SetIntObj(Tcl_GetObjResult(interp), result);
1.284 + return TCL_OK;
1.285 +}
1.286 +
1.287 +/*
1.288 + *----------------------------------------------------------------------
1.289 + *
1.290 + * Tcl_CdObjCmd --
1.291 + *
1.292 + * This procedure is invoked to process the "cd" Tcl command.
1.293 + * See the user documentation for details on what it does.
1.294 + *
1.295 + * Results:
1.296 + * A standard Tcl result.
1.297 + *
1.298 + * Side effects:
1.299 + * See the user documentation.
1.300 + *
1.301 + *----------------------------------------------------------------------
1.302 + */
1.303 +
1.304 + /* ARGSUSED */
1.305 +int
1.306 +Tcl_CdObjCmd(dummy, interp, objc, objv)
1.307 + ClientData dummy; /* Not used. */
1.308 + Tcl_Interp *interp; /* Current interpreter. */
1.309 + int objc; /* Number of arguments. */
1.310 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.311 +{
1.312 + Tcl_Obj *dir;
1.313 + int result;
1.314 +
1.315 + if (objc > 2) {
1.316 + Tcl_WrongNumArgs(interp, 1, objv, "?dirName?");
1.317 + return TCL_ERROR;
1.318 + }
1.319 +
1.320 + if (objc == 2) {
1.321 + dir = objv[1];
1.322 + } else {
1.323 + dir = Tcl_NewStringObj("~",1);
1.324 + Tcl_IncrRefCount(dir);
1.325 + }
1.326 + if (Tcl_FSConvertToPathType(interp, dir) != TCL_OK) {
1.327 + result = TCL_ERROR;
1.328 + } else {
1.329 + result = Tcl_FSChdir(dir);
1.330 + if (result != TCL_OK) {
1.331 + Tcl_AppendResult(interp, "couldn't change working directory to \"",
1.332 + Tcl_GetString(dir), "\": ", Tcl_PosixError(interp), (char *) NULL);
1.333 + result = TCL_ERROR;
1.334 + }
1.335 + }
1.336 + if (objc != 2) {
1.337 + Tcl_DecrRefCount(dir);
1.338 + }
1.339 + return result;
1.340 +}
1.341 +
1.342 +/*
1.343 + *----------------------------------------------------------------------
1.344 + *
1.345 + * Tcl_ConcatObjCmd --
1.346 + *
1.347 + * This object-based procedure is invoked to process the "concat" Tcl
1.348 + * command. See the user documentation for details on what it does.
1.349 + *
1.350 + * Results:
1.351 + * A standard Tcl object result.
1.352 + *
1.353 + * Side effects:
1.354 + * See the user documentation.
1.355 + *
1.356 + *----------------------------------------------------------------------
1.357 + */
1.358 +
1.359 + /* ARGSUSED */
1.360 +int
1.361 +Tcl_ConcatObjCmd(dummy, interp, objc, objv)
1.362 + ClientData dummy; /* Not used. */
1.363 + Tcl_Interp *interp; /* Current interpreter. */
1.364 + int objc; /* Number of arguments. */
1.365 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.366 +{
1.367 + if (objc >= 2) {
1.368 + Tcl_SetObjResult(interp, Tcl_ConcatObj(objc-1, objv+1));
1.369 + }
1.370 + return TCL_OK;
1.371 +}
1.372 +
1.373 +/*
1.374 + *----------------------------------------------------------------------
1.375 + *
1.376 + * Tcl_ContinueObjCmd -
1.377 + *
1.378 + * This procedure is invoked to process the "continue" Tcl command.
1.379 + * See the user documentation for details on what it does.
1.380 + *
1.381 + * With the bytecode compiler, this procedure is only called when
1.382 + * a command name is computed at runtime, and is "continue" or the name
1.383 + * to which "continue" was renamed: e.g., "set z continue; $z"
1.384 + *
1.385 + * Results:
1.386 + * A standard Tcl result.
1.387 + *
1.388 + * Side effects:
1.389 + * See the user documentation.
1.390 + *
1.391 + *----------------------------------------------------------------------
1.392 + */
1.393 +
1.394 + /* ARGSUSED */
1.395 +int
1.396 +Tcl_ContinueObjCmd(dummy, interp, objc, objv)
1.397 + ClientData dummy; /* Not used. */
1.398 + Tcl_Interp *interp; /* Current interpreter. */
1.399 + int objc; /* Number of arguments. */
1.400 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.401 +{
1.402 + if (objc != 1) {
1.403 + Tcl_WrongNumArgs(interp, 1, objv, NULL);
1.404 + return TCL_ERROR;
1.405 + }
1.406 + return TCL_CONTINUE;
1.407 +}
1.408 +
1.409 +/*
1.410 + *----------------------------------------------------------------------
1.411 + *
1.412 + * Tcl_EncodingObjCmd --
1.413 + *
1.414 + * This command manipulates encodings.
1.415 + *
1.416 + * Results:
1.417 + * A standard Tcl result.
1.418 + *
1.419 + * Side effects:
1.420 + * See the user documentation.
1.421 + *
1.422 + *----------------------------------------------------------------------
1.423 + */
1.424 +
1.425 +int
1.426 +Tcl_EncodingObjCmd(dummy, interp, objc, objv)
1.427 + ClientData dummy; /* Not used. */
1.428 + Tcl_Interp *interp; /* Current interpreter. */
1.429 + int objc; /* Number of arguments. */
1.430 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.431 +{
1.432 + int index, length;
1.433 + Tcl_Encoding encoding;
1.434 + char *string;
1.435 + Tcl_DString ds;
1.436 + Tcl_Obj *resultPtr;
1.437 +
1.438 + static CONST char *optionStrings[] = {
1.439 + "convertfrom", "convertto", "names", "system",
1.440 + NULL
1.441 + };
1.442 + enum options {
1.443 + ENC_CONVERTFROM, ENC_CONVERTTO, ENC_NAMES, ENC_SYSTEM
1.444 + };
1.445 +
1.446 + if (objc < 2) {
1.447 + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
1.448 + return TCL_ERROR;
1.449 + }
1.450 + if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
1.451 + &index) != TCL_OK) {
1.452 + return TCL_ERROR;
1.453 + }
1.454 +
1.455 + switch ((enum options) index) {
1.456 + case ENC_CONVERTTO:
1.457 + case ENC_CONVERTFROM: {
1.458 + Tcl_Obj *data;
1.459 + if (objc == 3) {
1.460 + encoding = Tcl_GetEncoding(interp, NULL);
1.461 + data = objv[2];
1.462 + } else if (objc == 4) {
1.463 + if (TclGetEncodingFromObj(interp, objv[2], &encoding)
1.464 + != TCL_OK) {
1.465 + return TCL_ERROR;
1.466 + }
1.467 + data = objv[3];
1.468 + } else {
1.469 + Tcl_WrongNumArgs(interp, 2, objv, "?encoding? data");
1.470 + return TCL_ERROR;
1.471 + }
1.472 +
1.473 + if ((enum options) index == ENC_CONVERTFROM) {
1.474 + /*
1.475 + * Treat the string as binary data.
1.476 + */
1.477 +
1.478 + string = (char *) Tcl_GetByteArrayFromObj(data, &length);
1.479 + Tcl_ExternalToUtfDString(encoding, string, length, &ds);
1.480 +
1.481 + /*
1.482 + * Note that we cannot use Tcl_DStringResult here because
1.483 + * it will truncate the string at the first null byte.
1.484 + */
1.485 +
1.486 + Tcl_SetStringObj(Tcl_GetObjResult(interp),
1.487 + Tcl_DStringValue(&ds), Tcl_DStringLength(&ds));
1.488 + Tcl_DStringFree(&ds);
1.489 + } else {
1.490 + /*
1.491 + * Store the result as binary data.
1.492 + */
1.493 +
1.494 + string = Tcl_GetStringFromObj(data, &length);
1.495 + Tcl_UtfToExternalDString(encoding, string, length, &ds);
1.496 + resultPtr = Tcl_GetObjResult(interp);
1.497 + Tcl_SetByteArrayObj(resultPtr,
1.498 + (unsigned char *) Tcl_DStringValue(&ds),
1.499 + Tcl_DStringLength(&ds));
1.500 + Tcl_DStringFree(&ds);
1.501 + }
1.502 +
1.503 + Tcl_FreeEncoding(encoding);
1.504 + break;
1.505 + }
1.506 + case ENC_NAMES: {
1.507 + if (objc > 2) {
1.508 + Tcl_WrongNumArgs(interp, 2, objv, NULL);
1.509 + return TCL_ERROR;
1.510 + }
1.511 + Tcl_GetEncodingNames(interp);
1.512 + break;
1.513 + }
1.514 + case ENC_SYSTEM: {
1.515 + if (objc > 3) {
1.516 + Tcl_WrongNumArgs(interp, 2, objv, "?encoding?");
1.517 + return TCL_ERROR;
1.518 + }
1.519 + if (objc == 2) {
1.520 + Tcl_SetStringObj(Tcl_GetObjResult(interp),
1.521 + Tcl_GetEncodingName(NULL), -1);
1.522 + } else {
1.523 + return Tcl_SetSystemEncoding(interp,
1.524 + Tcl_GetStringFromObj(objv[2], NULL));
1.525 + }
1.526 + break;
1.527 + }
1.528 + }
1.529 + return TCL_OK;
1.530 +}
1.531 +
1.532 +/*
1.533 + *----------------------------------------------------------------------
1.534 + *
1.535 + * Tcl_ErrorObjCmd --
1.536 + *
1.537 + * This procedure is invoked to process the "error" Tcl command.
1.538 + * See the user documentation for details on what it does.
1.539 + *
1.540 + * Results:
1.541 + * A standard Tcl object result.
1.542 + *
1.543 + * Side effects:
1.544 + * See the user documentation.
1.545 + *
1.546 + *----------------------------------------------------------------------
1.547 + */
1.548 +
1.549 + /* ARGSUSED */
1.550 +int
1.551 +Tcl_ErrorObjCmd(dummy, interp, objc, objv)
1.552 + ClientData dummy; /* Not used. */
1.553 + Tcl_Interp *interp; /* Current interpreter. */
1.554 + int objc; /* Number of arguments. */
1.555 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.556 +{
1.557 + Interp *iPtr = (Interp *) interp;
1.558 + char *info;
1.559 + int infoLen;
1.560 +
1.561 + if ((objc < 2) || (objc > 4)) {
1.562 + Tcl_WrongNumArgs(interp, 1, objv, "message ?errorInfo? ?errorCode?");
1.563 + return TCL_ERROR;
1.564 + }
1.565 +
1.566 + if (objc >= 3) { /* process the optional info argument */
1.567 + info = Tcl_GetStringFromObj(objv[2], &infoLen);
1.568 + if (infoLen > 0) {
1.569 + Tcl_AddObjErrorInfo(interp, info, infoLen);
1.570 + iPtr->flags |= ERR_ALREADY_LOGGED;
1.571 + }
1.572 + }
1.573 +
1.574 + if (objc == 4) {
1.575 + Tcl_SetVar2Ex(interp, "errorCode", NULL, objv[3], TCL_GLOBAL_ONLY);
1.576 + iPtr->flags |= ERROR_CODE_SET;
1.577 + }
1.578 +
1.579 + Tcl_SetObjResult(interp, objv[1]);
1.580 + return TCL_ERROR;
1.581 +}
1.582 +
1.583 +/*
1.584 + *----------------------------------------------------------------------
1.585 + *
1.586 + * Tcl_EvalObjCmd --
1.587 + *
1.588 + * This object-based procedure is invoked to process the "eval" Tcl
1.589 + * command. See the user documentation for details on what it does.
1.590 + *
1.591 + * Results:
1.592 + * A standard Tcl object result.
1.593 + *
1.594 + * Side effects:
1.595 + * See the user documentation.
1.596 + *
1.597 + *----------------------------------------------------------------------
1.598 + */
1.599 +
1.600 + /* ARGSUSED */
1.601 +int
1.602 +Tcl_EvalObjCmd(dummy, interp, objc, objv)
1.603 + ClientData dummy; /* Not used. */
1.604 + Tcl_Interp *interp; /* Current interpreter. */
1.605 + int objc; /* Number of arguments. */
1.606 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.607 +{
1.608 + int result;
1.609 + register Tcl_Obj *objPtr;
1.610 +#ifdef TCL_TIP280
1.611 + Interp* iPtr = (Interp*) interp;
1.612 +#endif
1.613 +
1.614 + if (objc < 2) {
1.615 + Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");
1.616 + return TCL_ERROR;
1.617 + }
1.618 +
1.619 + if (objc == 2) {
1.620 +#ifndef TCL_TIP280
1.621 + result = Tcl_EvalObjEx(interp, objv[1], TCL_EVAL_DIRECT);
1.622 +#else
1.623 + /* TIP #280. Make invoking context available to eval'd script */
1.624 + result = TclEvalObjEx(interp, objv[1], TCL_EVAL_DIRECT,
1.625 + iPtr->cmdFramePtr,1);
1.626 +#endif
1.627 + } else {
1.628 + /*
1.629 + * More than one argument: concatenate them together with spaces
1.630 + * between, then evaluate the result. Tcl_EvalObjEx will delete
1.631 + * the object when it decrements its refcount after eval'ing it.
1.632 + */
1.633 + objPtr = Tcl_ConcatObj(objc-1, objv+1);
1.634 +#ifndef TCL_TIP280
1.635 + result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
1.636 +#else
1.637 + /* TIP #280. Make invoking context available to eval'd script */
1.638 + result = TclEvalObjEx(interp, objPtr, TCL_EVAL_DIRECT, NULL, 0);
1.639 +#endif
1.640 + }
1.641 + if (result == TCL_ERROR) {
1.642 + char msg[32 + TCL_INTEGER_SPACE];
1.643 +
1.644 + sprintf(msg, "\n (\"eval\" body line %d)", interp->errorLine);
1.645 + Tcl_AddObjErrorInfo(interp, msg, -1);
1.646 + }
1.647 + return result;
1.648 +}
1.649 +
1.650 +/*
1.651 + *----------------------------------------------------------------------
1.652 + *
1.653 + * Tcl_ExitObjCmd --
1.654 + *
1.655 + * This procedure is invoked to process the "exit" Tcl command.
1.656 + * See the user documentation for details on what it does.
1.657 + *
1.658 + * Results:
1.659 + * A standard Tcl object result.
1.660 + *
1.661 + * Side effects:
1.662 + * See the user documentation.
1.663 + *
1.664 + *----------------------------------------------------------------------
1.665 + */
1.666 +
1.667 + /* ARGSUSED */
1.668 +int
1.669 +Tcl_ExitObjCmd(dummy, interp, objc, objv)
1.670 + ClientData dummy; /* Not used. */
1.671 + Tcl_Interp *interp; /* Current interpreter. */
1.672 + int objc; /* Number of arguments. */
1.673 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.674 +{
1.675 + int value;
1.676 +
1.677 + if ((objc != 1) && (objc != 2)) {
1.678 + Tcl_WrongNumArgs(interp, 1, objv, "?returnCode?");
1.679 + return TCL_ERROR;
1.680 + }
1.681 +
1.682 + if (objc == 1) {
1.683 + value = 0;
1.684 + } else if (Tcl_GetIntFromObj(interp, objv[1], &value) != TCL_OK) {
1.685 + return TCL_ERROR;
1.686 + }
1.687 + Tcl_Exit(value);
1.688 + /*NOTREACHED*/
1.689 + return TCL_OK; /* Better not ever reach this! */
1.690 +}
1.691 +
1.692 +/*
1.693 + *----------------------------------------------------------------------
1.694 + *
1.695 + * Tcl_ExprObjCmd --
1.696 + *
1.697 + * This object-based procedure is invoked to process the "expr" Tcl
1.698 + * command. See the user documentation for details on what it does.
1.699 + *
1.700 + * With the bytecode compiler, this procedure is called in two
1.701 + * circumstances: 1) to execute expr commands that are too complicated
1.702 + * or too unsafe to try compiling directly into an inline sequence of
1.703 + * instructions, and 2) to execute commands where the command name is
1.704 + * computed at runtime and is "expr" or the name to which "expr" was
1.705 + * renamed (e.g., "set z expr; $z 2+3")
1.706 + *
1.707 + * Results:
1.708 + * A standard Tcl object result.
1.709 + *
1.710 + * Side effects:
1.711 + * See the user documentation.
1.712 + *
1.713 + *----------------------------------------------------------------------
1.714 + */
1.715 +
1.716 + /* ARGSUSED */
1.717 +int
1.718 +Tcl_ExprObjCmd(dummy, interp, objc, objv)
1.719 + ClientData dummy; /* Not used. */
1.720 + Tcl_Interp *interp; /* Current interpreter. */
1.721 + int objc; /* Number of arguments. */
1.722 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.723 +{
1.724 + register Tcl_Obj *objPtr;
1.725 + Tcl_Obj *resultPtr;
1.726 + register char *bytes;
1.727 + int length, i, result;
1.728 +
1.729 + if (objc < 2) {
1.730 + Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");
1.731 + return TCL_ERROR;
1.732 + }
1.733 +
1.734 + if (objc == 2) {
1.735 + result = Tcl_ExprObj(interp, objv[1], &resultPtr);
1.736 + if (result == TCL_OK) {
1.737 + Tcl_SetObjResult(interp, resultPtr);
1.738 + Tcl_DecrRefCount(resultPtr); /* done with the result object */
1.739 + }
1.740 + return result;
1.741 + }
1.742 +
1.743 + /*
1.744 + * Create a new object holding the concatenated argument strings.
1.745 + */
1.746 +
1.747 + /*** QUESTION: Do we need to copy the slow way? ***/
1.748 + bytes = Tcl_GetStringFromObj(objv[1], &length);
1.749 + objPtr = Tcl_NewStringObj(bytes, length);
1.750 + Tcl_IncrRefCount(objPtr);
1.751 + for (i = 2; i < objc; i++) {
1.752 + Tcl_AppendToObj(objPtr, " ", 1);
1.753 + bytes = Tcl_GetStringFromObj(objv[i], &length);
1.754 + Tcl_AppendToObj(objPtr, bytes, length);
1.755 + }
1.756 +
1.757 + /*
1.758 + * Evaluate the concatenated string object.
1.759 + */
1.760 +
1.761 + result = Tcl_ExprObj(interp, objPtr, &resultPtr);
1.762 + if (result == TCL_OK) {
1.763 + Tcl_SetObjResult(interp, resultPtr);
1.764 + Tcl_DecrRefCount(resultPtr); /* done with the result object */
1.765 + }
1.766 +
1.767 + /*
1.768 + * Free allocated resources.
1.769 + */
1.770 +
1.771 + Tcl_DecrRefCount(objPtr);
1.772 + return result;
1.773 +}
1.774 +
1.775 +/*
1.776 + *----------------------------------------------------------------------
1.777 + *
1.778 + * Tcl_FileObjCmd --
1.779 + *
1.780 + * This procedure is invoked to process the "file" Tcl command.
1.781 + * See the user documentation for details on what it does.
1.782 + * PLEASE NOTE THAT THIS FAILS WITH FILENAMES AND PATHS WITH
1.783 + * EMBEDDED NULLS, WHICH COULD THEORETICALLY HAPPEN ON A MAC.
1.784 + * With the object-based Tcl_FS APIs, the above NOTE may no
1.785 + * longer be true. In any case this assertion should be tested.
1.786 + *
1.787 + * Results:
1.788 + * A standard Tcl result.
1.789 + *
1.790 + * Side effects:
1.791 + * See the user documentation.
1.792 + *
1.793 + *----------------------------------------------------------------------
1.794 + */
1.795 +
1.796 + /* ARGSUSED */
1.797 +int
1.798 +Tcl_FileObjCmd(dummy, interp, objc, objv)
1.799 + ClientData dummy; /* Not used. */
1.800 + Tcl_Interp *interp; /* Current interpreter. */
1.801 + int objc; /* Number of arguments. */
1.802 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.803 +{
1.804 + int index;
1.805 +
1.806 +/*
1.807 + * This list of constants should match the fileOption string array below.
1.808 + */
1.809 +
1.810 + static CONST char *fileOptions[] = {
1.811 + "atime", "attributes", "channels", "copy",
1.812 + "delete",
1.813 + "dirname", "executable", "exists", "extension",
1.814 + "isdirectory", "isfile", "join", "link",
1.815 + "lstat", "mtime", "mkdir", "nativename",
1.816 + "normalize", "owned",
1.817 + "pathtype", "readable", "readlink", "rename",
1.818 + "rootname", "separator", "size", "split",
1.819 + "stat", "system",
1.820 + "tail", "type", "volumes", "writable",
1.821 + (char *) NULL
1.822 + };
1.823 + enum options {
1.824 + FCMD_ATIME, FCMD_ATTRIBUTES, FCMD_CHANNELS, FCMD_COPY,
1.825 + FCMD_DELETE,
1.826 + FCMD_DIRNAME, FCMD_EXECUTABLE, FCMD_EXISTS, FCMD_EXTENSION,
1.827 + FCMD_ISDIRECTORY, FCMD_ISFILE, FCMD_JOIN, FCMD_LINK,
1.828 + FCMD_LSTAT, FCMD_MTIME, FCMD_MKDIR, FCMD_NATIVENAME,
1.829 + FCMD_NORMALIZE, FCMD_OWNED,
1.830 + FCMD_PATHTYPE, FCMD_READABLE, FCMD_READLINK, FCMD_RENAME,
1.831 + FCMD_ROOTNAME, FCMD_SEPARATOR, FCMD_SIZE, FCMD_SPLIT,
1.832 + FCMD_STAT, FCMD_SYSTEM,
1.833 + FCMD_TAIL, FCMD_TYPE, FCMD_VOLUMES, FCMD_WRITABLE
1.834 + };
1.835 +
1.836 + if (objc < 2) {
1.837 + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
1.838 + return TCL_ERROR;
1.839 + }
1.840 + if (Tcl_GetIndexFromObj(interp, objv[1], fileOptions, "option", 0,
1.841 + &index) != TCL_OK) {
1.842 + return TCL_ERROR;
1.843 + }
1.844 +
1.845 + switch ((enum options) index) {
1.846 + case FCMD_ATIME: {
1.847 + Tcl_StatBuf buf;
1.848 + struct utimbuf tval;
1.849 +
1.850 + if ((objc < 3) || (objc > 4)) {
1.851 + Tcl_WrongNumArgs(interp, 2, objv, "name ?time?");
1.852 + return TCL_ERROR;
1.853 + }
1.854 + if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
1.855 + return TCL_ERROR;
1.856 + }
1.857 + if (objc == 4) {
1.858 + long newTime;
1.859 +
1.860 + if (Tcl_GetLongFromObj(interp, objv[3], &newTime) != TCL_OK) {
1.861 + return TCL_ERROR;
1.862 + }
1.863 + tval.actime = newTime;
1.864 + tval.modtime = buf.st_mtime;
1.865 + if (Tcl_FSUtime(objv[2], &tval) != 0) {
1.866 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.867 + "could not set access time for file \"",
1.868 + Tcl_GetString(objv[2]), "\": ",
1.869 + Tcl_PosixError(interp), (char *) NULL);
1.870 + return TCL_ERROR;
1.871 + }
1.872 + /*
1.873 + * Do another stat to ensure that the we return the
1.874 + * new recognized atime - hopefully the same as the
1.875 + * one we sent in. However, fs's like FAT don't
1.876 + * even know what atime is.
1.877 + */
1.878 + if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
1.879 + return TCL_ERROR;
1.880 + }
1.881 + }
1.882 + Tcl_SetLongObj(Tcl_GetObjResult(interp), (long) buf.st_atime);
1.883 + return TCL_OK;
1.884 + }
1.885 + case FCMD_ATTRIBUTES: {
1.886 + return TclFileAttrsCmd(interp, objc, objv);
1.887 + }
1.888 + case FCMD_CHANNELS: {
1.889 + if ((objc < 2) || (objc > 3)) {
1.890 + Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
1.891 + return TCL_ERROR;
1.892 + }
1.893 + return Tcl_GetChannelNamesEx(interp,
1.894 + ((objc == 2) ? NULL : Tcl_GetString(objv[2])));
1.895 + }
1.896 + case FCMD_COPY: {
1.897 + return TclFileCopyCmd(interp, objc, objv);
1.898 + }
1.899 + case FCMD_DELETE: {
1.900 + return TclFileDeleteCmd(interp, objc, objv);
1.901 + }
1.902 + case FCMD_DIRNAME: {
1.903 + Tcl_Obj *dirPtr;
1.904 + if (objc != 3) {
1.905 + goto only3Args;
1.906 + }
1.907 + dirPtr = TclFileDirname(interp, objv[2]);
1.908 + if (dirPtr == NULL) {
1.909 + return TCL_ERROR;
1.910 + } else {
1.911 + Tcl_SetObjResult(interp, dirPtr);
1.912 + Tcl_DecrRefCount(dirPtr);
1.913 + return TCL_OK;
1.914 + }
1.915 + }
1.916 + case FCMD_EXECUTABLE: {
1.917 + if (objc != 3) {
1.918 + goto only3Args;
1.919 + }
1.920 + return CheckAccess(interp, objv[2], X_OK);
1.921 + }
1.922 + case FCMD_EXISTS: {
1.923 + if (objc != 3) {
1.924 + goto only3Args;
1.925 + }
1.926 + return CheckAccess(interp, objv[2], F_OK);
1.927 + }
1.928 + case FCMD_EXTENSION: {
1.929 + char *fileName, *extension;
1.930 + if (objc != 3) {
1.931 + goto only3Args;
1.932 + }
1.933 + fileName = Tcl_GetString(objv[2]);
1.934 + extension = TclGetExtension(fileName);
1.935 + if (extension != NULL) {
1.936 + Tcl_SetStringObj(Tcl_GetObjResult(interp), extension, -1);
1.937 + }
1.938 + return TCL_OK;
1.939 + }
1.940 + case FCMD_ISDIRECTORY: {
1.941 + int value;
1.942 + Tcl_StatBuf buf;
1.943 +
1.944 + if (objc != 3) {
1.945 + goto only3Args;
1.946 + }
1.947 + value = 0;
1.948 + if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) {
1.949 + value = S_ISDIR(buf.st_mode);
1.950 + }
1.951 + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value);
1.952 + return TCL_OK;
1.953 + }
1.954 + case FCMD_ISFILE: {
1.955 + int value;
1.956 + Tcl_StatBuf buf;
1.957 +
1.958 + if (objc != 3) {
1.959 + goto only3Args;
1.960 + }
1.961 + value = 0;
1.962 + if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) {
1.963 + value = S_ISREG(buf.st_mode);
1.964 + }
1.965 + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value);
1.966 + return TCL_OK;
1.967 + }
1.968 + case FCMD_JOIN: {
1.969 + Tcl_Obj *resObj;
1.970 +
1.971 + if (objc < 3) {
1.972 + Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?");
1.973 + return TCL_ERROR;
1.974 + }
1.975 + resObj = Tcl_FSJoinToPath(NULL, objc - 2, objv + 2);
1.976 + Tcl_SetObjResult(interp, resObj);
1.977 + return TCL_OK;
1.978 + }
1.979 + case FCMD_LINK: {
1.980 + Tcl_Obj *contents;
1.981 + int index;
1.982 +
1.983 + if (objc < 3 || objc > 5) {
1.984 + Tcl_WrongNumArgs(interp, 2, objv,
1.985 + "?-linktype? linkname ?target?");
1.986 + return TCL_ERROR;
1.987 + }
1.988 +
1.989 + /* Index of the 'source' argument */
1.990 + if (objc == 5) {
1.991 + index = 3;
1.992 + } else {
1.993 + index = 2;
1.994 + }
1.995 +
1.996 + if (objc > 3) {
1.997 + int linkAction;
1.998 + if (objc == 5) {
1.999 + /* We have a '-linktype' argument */
1.1000 + static CONST char *linkTypes[] = {
1.1001 + "-symbolic", "-hard", NULL
1.1002 + };
1.1003 + if (Tcl_GetIndexFromObj(interp, objv[2], linkTypes,
1.1004 + "switch", 0, &linkAction) != TCL_OK) {
1.1005 + return TCL_ERROR;
1.1006 + }
1.1007 + if (linkAction == 0) {
1.1008 + linkAction = TCL_CREATE_SYMBOLIC_LINK;
1.1009 + } else {
1.1010 + linkAction = TCL_CREATE_HARD_LINK;
1.1011 + }
1.1012 + } else {
1.1013 + linkAction = TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK;
1.1014 + }
1.1015 + if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
1.1016 + return TCL_ERROR;
1.1017 + }
1.1018 + /* Create link from source to target */
1.1019 + contents = Tcl_FSLink(objv[index], objv[index+1], linkAction);
1.1020 + if (contents == NULL) {
1.1021 + /*
1.1022 + * We handle two common error cases specially, and
1.1023 + * for all other errors, we use the standard posix
1.1024 + * error message.
1.1025 + */
1.1026 + if (errno == EEXIST) {
1.1027 + Tcl_AppendResult(interp, "could not create new link \"",
1.1028 + Tcl_GetString(objv[index]),
1.1029 + "\": that path already exists", (char *) NULL);
1.1030 + } else if (errno == ENOENT) {
1.1031 + Tcl_AppendResult(interp, "could not create new link \"",
1.1032 + Tcl_GetString(objv[index]),
1.1033 + "\" since target \"",
1.1034 + Tcl_GetString(objv[index+1]),
1.1035 + "\" doesn't exist",
1.1036 + (char *) NULL);
1.1037 + } else {
1.1038 + Tcl_AppendResult(interp, "could not create new link \"",
1.1039 + Tcl_GetString(objv[index]), "\" pointing to \"",
1.1040 + Tcl_GetString(objv[index+1]), "\": ",
1.1041 + Tcl_PosixError(interp), (char *) NULL);
1.1042 + }
1.1043 + return TCL_ERROR;
1.1044 + }
1.1045 + } else {
1.1046 + if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
1.1047 + return TCL_ERROR;
1.1048 + }
1.1049 + /* Read link */
1.1050 + contents = Tcl_FSLink(objv[index], NULL, 0);
1.1051 + if (contents == NULL) {
1.1052 + Tcl_AppendResult(interp, "could not read link \"",
1.1053 + Tcl_GetString(objv[index]), "\": ",
1.1054 + Tcl_PosixError(interp), (char *) NULL);
1.1055 + return TCL_ERROR;
1.1056 + }
1.1057 + }
1.1058 + Tcl_SetObjResult(interp, contents);
1.1059 + if (objc == 3) {
1.1060 + /*
1.1061 + * If we are reading a link, we need to free this
1.1062 + * result refCount. If we are creating a link, this
1.1063 + * will just be objv[index+1], and so we don't own it.
1.1064 + */
1.1065 + Tcl_DecrRefCount(contents);
1.1066 + }
1.1067 + return TCL_OK;
1.1068 + }
1.1069 + case FCMD_LSTAT: {
1.1070 + char *varName;
1.1071 + Tcl_StatBuf buf;
1.1072 +
1.1073 + if (objc != 4) {
1.1074 + Tcl_WrongNumArgs(interp, 2, objv, "name varName");
1.1075 + return TCL_ERROR;
1.1076 + }
1.1077 + if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) {
1.1078 + return TCL_ERROR;
1.1079 + }
1.1080 + varName = Tcl_GetString(objv[3]);
1.1081 + return StoreStatData(interp, varName, &buf);
1.1082 + }
1.1083 + case FCMD_MTIME: {
1.1084 + Tcl_StatBuf buf;
1.1085 + struct utimbuf tval;
1.1086 +
1.1087 + if ((objc < 3) || (objc > 4)) {
1.1088 + Tcl_WrongNumArgs(interp, 2, objv, "name ?time?");
1.1089 + return TCL_ERROR;
1.1090 + }
1.1091 + if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
1.1092 + return TCL_ERROR;
1.1093 + }
1.1094 + if (objc == 4) {
1.1095 + long newTime;
1.1096 +
1.1097 + if (Tcl_GetLongFromObj(interp, objv[3], &newTime) != TCL_OK) {
1.1098 + return TCL_ERROR;
1.1099 + }
1.1100 + tval.actime = buf.st_atime;
1.1101 + tval.modtime = newTime;
1.1102 + if (Tcl_FSUtime(objv[2], &tval) != 0) {
1.1103 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.1104 + "could not set modification time for file \"",
1.1105 + Tcl_GetString(objv[2]), "\": ",
1.1106 + Tcl_PosixError(interp), (char *) NULL);
1.1107 + return TCL_ERROR;
1.1108 + }
1.1109 + /*
1.1110 + * Do another stat to ensure that the we return the
1.1111 + * new recognized atime - hopefully the same as the
1.1112 + * one we sent in. However, fs's like FAT don't
1.1113 + * even know what atime is.
1.1114 + */
1.1115 + if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
1.1116 + return TCL_ERROR;
1.1117 + }
1.1118 + }
1.1119 + Tcl_SetLongObj(Tcl_GetObjResult(interp), (long) buf.st_mtime);
1.1120 + return TCL_OK;
1.1121 + }
1.1122 + case FCMD_MKDIR: {
1.1123 + if (objc < 3) {
1.1124 + Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?");
1.1125 + return TCL_ERROR;
1.1126 + }
1.1127 + return TclFileMakeDirsCmd(interp, objc, objv);
1.1128 + }
1.1129 + case FCMD_NATIVENAME: {
1.1130 + CONST char *fileName;
1.1131 + Tcl_DString ds;
1.1132 +
1.1133 + if (objc != 3) {
1.1134 + goto only3Args;
1.1135 + }
1.1136 + fileName = Tcl_GetString(objv[2]);
1.1137 + fileName = Tcl_TranslateFileName(interp, fileName, &ds);
1.1138 + if (fileName == NULL) {
1.1139 + return TCL_ERROR;
1.1140 + }
1.1141 + Tcl_SetStringObj(Tcl_GetObjResult(interp), fileName,
1.1142 + Tcl_DStringLength(&ds));
1.1143 + Tcl_DStringFree(&ds);
1.1144 + return TCL_OK;
1.1145 + }
1.1146 + case FCMD_NORMALIZE: {
1.1147 + Tcl_Obj *fileName;
1.1148 +
1.1149 + if (objc != 3) {
1.1150 + Tcl_WrongNumArgs(interp, 2, objv, "filename");
1.1151 + return TCL_ERROR;
1.1152 + }
1.1153 +
1.1154 + fileName = Tcl_FSGetNormalizedPath(interp, objv[2]);
1.1155 + if (fileName == NULL) {
1.1156 + return TCL_ERROR;
1.1157 + }
1.1158 + Tcl_SetObjResult(interp, fileName);
1.1159 + return TCL_OK;
1.1160 + }
1.1161 + case FCMD_OWNED: {
1.1162 + int value;
1.1163 + Tcl_StatBuf buf;
1.1164 +
1.1165 + if (objc != 3) {
1.1166 + goto only3Args;
1.1167 + }
1.1168 + value = 0;
1.1169 + if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) {
1.1170 + /*
1.1171 + * For Windows and Macintosh, there are no user ids
1.1172 + * associated with a file, so we always return 1.
1.1173 + */
1.1174 +
1.1175 +#if (defined(__WIN32__) || defined(MAC_TCL))
1.1176 + value = 1;
1.1177 +#else
1.1178 + value = (geteuid() == buf.st_uid);
1.1179 +#endif
1.1180 + }
1.1181 + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value);
1.1182 + return TCL_OK;
1.1183 + }
1.1184 + case FCMD_PATHTYPE: {
1.1185 + if (objc != 3) {
1.1186 + goto only3Args;
1.1187 + }
1.1188 + switch (Tcl_FSGetPathType(objv[2])) {
1.1189 + case TCL_PATH_ABSOLUTE:
1.1190 + Tcl_SetStringObj(Tcl_GetObjResult(interp), "absolute", -1);
1.1191 + break;
1.1192 + case TCL_PATH_RELATIVE:
1.1193 + Tcl_SetStringObj(Tcl_GetObjResult(interp), "relative", -1);
1.1194 + break;
1.1195 + case TCL_PATH_VOLUME_RELATIVE:
1.1196 + Tcl_SetStringObj(Tcl_GetObjResult(interp),
1.1197 + "volumerelative", -1);
1.1198 + break;
1.1199 + }
1.1200 + return TCL_OK;
1.1201 + }
1.1202 + case FCMD_READABLE: {
1.1203 + if (objc != 3) {
1.1204 + goto only3Args;
1.1205 + }
1.1206 + return CheckAccess(interp, objv[2], R_OK);
1.1207 + }
1.1208 + case FCMD_READLINK: {
1.1209 + Tcl_Obj *contents;
1.1210 +
1.1211 + if (objc != 3) {
1.1212 + goto only3Args;
1.1213 + }
1.1214 +
1.1215 + if (Tcl_FSConvertToPathType(interp, objv[2]) != TCL_OK) {
1.1216 + return TCL_ERROR;
1.1217 + }
1.1218 +
1.1219 + contents = Tcl_FSLink(objv[2], NULL, 0);
1.1220 +
1.1221 + if (contents == NULL) {
1.1222 + Tcl_AppendResult(interp, "could not readlink \"",
1.1223 + Tcl_GetString(objv[2]), "\": ",
1.1224 + Tcl_PosixError(interp), (char *) NULL);
1.1225 + return TCL_ERROR;
1.1226 + }
1.1227 + Tcl_SetObjResult(interp, contents);
1.1228 + Tcl_DecrRefCount(contents);
1.1229 + return TCL_OK;
1.1230 + }
1.1231 + case FCMD_RENAME: {
1.1232 + return TclFileRenameCmd(interp, objc, objv);
1.1233 + }
1.1234 + case FCMD_ROOTNAME: {
1.1235 + int length;
1.1236 + char *fileName, *extension;
1.1237 +
1.1238 + if (objc != 3) {
1.1239 + goto only3Args;
1.1240 + }
1.1241 + fileName = Tcl_GetStringFromObj(objv[2], &length);
1.1242 + extension = TclGetExtension(fileName);
1.1243 + if (extension == NULL) {
1.1244 + Tcl_SetObjResult(interp, objv[2]);
1.1245 + } else {
1.1246 + Tcl_SetStringObj(Tcl_GetObjResult(interp), fileName,
1.1247 + (int) (length - strlen(extension)));
1.1248 + }
1.1249 + return TCL_OK;
1.1250 + }
1.1251 + case FCMD_SEPARATOR: {
1.1252 + if ((objc < 2) || (objc > 3)) {
1.1253 + Tcl_WrongNumArgs(interp, 2, objv, "?name?");
1.1254 + return TCL_ERROR;
1.1255 + }
1.1256 + if (objc == 2) {
1.1257 + char *separator = NULL; /* lint */
1.1258 + switch (tclPlatform) {
1.1259 + case TCL_PLATFORM_UNIX:
1.1260 + separator = "/";
1.1261 + break;
1.1262 + case TCL_PLATFORM_WINDOWS:
1.1263 + separator = "\\";
1.1264 + break;
1.1265 + case TCL_PLATFORM_MAC:
1.1266 + separator = ":";
1.1267 + break;
1.1268 + }
1.1269 + Tcl_SetObjResult(interp, Tcl_NewStringObj(separator,1));
1.1270 + } else {
1.1271 + Tcl_Obj *separatorObj = Tcl_FSPathSeparator(objv[2]);
1.1272 + if (separatorObj != NULL) {
1.1273 + Tcl_SetObjResult(interp, separatorObj);
1.1274 + } else {
1.1275 + Tcl_SetObjResult(interp,
1.1276 + Tcl_NewStringObj("Unrecognised path",-1));
1.1277 + return TCL_ERROR;
1.1278 + }
1.1279 + }
1.1280 + return TCL_OK;
1.1281 + }
1.1282 + case FCMD_SIZE: {
1.1283 + Tcl_StatBuf buf;
1.1284 +
1.1285 + if (objc != 3) {
1.1286 + goto only3Args;
1.1287 + }
1.1288 + if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
1.1289 + return TCL_ERROR;
1.1290 + }
1.1291 + Tcl_SetWideIntObj(Tcl_GetObjResult(interp),
1.1292 + (Tcl_WideInt) buf.st_size);
1.1293 + return TCL_OK;
1.1294 + }
1.1295 + case FCMD_SPLIT: {
1.1296 + if (objc != 3) {
1.1297 + goto only3Args;
1.1298 + }
1.1299 + Tcl_SetObjResult(interp, Tcl_FSSplitPath(objv[2], NULL));
1.1300 + return TCL_OK;
1.1301 + }
1.1302 + case FCMD_STAT: {
1.1303 + char *varName;
1.1304 + Tcl_StatBuf buf;
1.1305 +
1.1306 + if (objc != 4) {
1.1307 + Tcl_WrongNumArgs(interp, 1, objv, "stat name varName");
1.1308 + return TCL_ERROR;
1.1309 + }
1.1310 + if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
1.1311 + return TCL_ERROR;
1.1312 + }
1.1313 + varName = Tcl_GetString(objv[3]);
1.1314 + return StoreStatData(interp, varName, &buf);
1.1315 + }
1.1316 + case FCMD_SYSTEM: {
1.1317 + Tcl_Obj* fsInfo;
1.1318 + if (objc != 3) {
1.1319 + goto only3Args;
1.1320 + }
1.1321 + fsInfo = Tcl_FSFileSystemInfo(objv[2]);
1.1322 + if (fsInfo != NULL) {
1.1323 + Tcl_SetObjResult(interp, fsInfo);
1.1324 + return TCL_OK;
1.1325 + } else {
1.1326 + Tcl_SetObjResult(interp,
1.1327 + Tcl_NewStringObj("Unrecognised path",-1));
1.1328 + return TCL_ERROR;
1.1329 + }
1.1330 + }
1.1331 + case FCMD_TAIL: {
1.1332 + int splitElements;
1.1333 + Tcl_Obj *splitPtr;
1.1334 +
1.1335 + if (objc != 3) {
1.1336 + goto only3Args;
1.1337 + }
1.1338 + /*
1.1339 + * The behaviour we want here is slightly different to
1.1340 + * the standard Tcl_FSSplitPath in the handling of home
1.1341 + * directories; Tcl_FSSplitPath preserves the "~" while
1.1342 + * this code computes the actual full path name, if we
1.1343 + * had just a single component.
1.1344 + */
1.1345 + splitPtr = Tcl_FSSplitPath(objv[2], &splitElements);
1.1346 + if ((splitElements == 1) && (Tcl_GetString(objv[2])[0] == '~')) {
1.1347 + Tcl_DecrRefCount(splitPtr);
1.1348 + splitPtr = Tcl_FSGetNormalizedPath(interp, objv[2]);
1.1349 + if (splitPtr == NULL) {
1.1350 + return TCL_ERROR;
1.1351 + }
1.1352 + splitPtr = Tcl_FSSplitPath(splitPtr, &splitElements);
1.1353 + }
1.1354 +
1.1355 + /*
1.1356 + * Return the last component, unless it is the only component,
1.1357 + * and it is the root of an absolute path.
1.1358 + */
1.1359 +
1.1360 + if (splitElements > 0) {
1.1361 + if ((splitElements > 1)
1.1362 + || (Tcl_FSGetPathType(objv[2]) == TCL_PATH_RELATIVE)) {
1.1363 +
1.1364 + Tcl_Obj *tail = NULL;
1.1365 + Tcl_ListObjIndex(NULL, splitPtr, splitElements-1, &tail);
1.1366 + Tcl_SetObjResult(interp, tail);
1.1367 + }
1.1368 + }
1.1369 + Tcl_DecrRefCount(splitPtr);
1.1370 + return TCL_OK;
1.1371 + }
1.1372 + case FCMD_TYPE: {
1.1373 + Tcl_StatBuf buf;
1.1374 +
1.1375 + if (objc != 3) {
1.1376 + goto only3Args;
1.1377 + }
1.1378 + if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) {
1.1379 + return TCL_ERROR;
1.1380 + }
1.1381 + Tcl_SetStringObj(Tcl_GetObjResult(interp),
1.1382 + GetTypeFromMode((unsigned short) buf.st_mode), -1);
1.1383 + return TCL_OK;
1.1384 + }
1.1385 + case FCMD_VOLUMES: {
1.1386 + if (objc != 2) {
1.1387 + Tcl_WrongNumArgs(interp, 2, objv, NULL);
1.1388 + return TCL_ERROR;
1.1389 + }
1.1390 + Tcl_SetObjResult(interp, Tcl_FSListVolumes());
1.1391 + return TCL_OK;
1.1392 + }
1.1393 + case FCMD_WRITABLE: {
1.1394 + if (objc != 3) {
1.1395 + goto only3Args;
1.1396 + }
1.1397 + return CheckAccess(interp, objv[2], W_OK);
1.1398 + }
1.1399 + }
1.1400 +
1.1401 + only3Args:
1.1402 + Tcl_WrongNumArgs(interp, 2, objv, "name");
1.1403 + return TCL_ERROR;
1.1404 +}
1.1405 +
1.1406 +/*
1.1407 + *---------------------------------------------------------------------------
1.1408 + *
1.1409 + * CheckAccess --
1.1410 + *
1.1411 + * Utility procedure used by Tcl_FileObjCmd() to query file
1.1412 + * attributes available through the access() system call.
1.1413 + *
1.1414 + * Results:
1.1415 + * Always returns TCL_OK. Sets interp's result to boolean true or
1.1416 + * false depending on whether the file has the specified attribute.
1.1417 + *
1.1418 + * Side effects:
1.1419 + * None.
1.1420 + *
1.1421 + *---------------------------------------------------------------------------
1.1422 + */
1.1423 +
1.1424 +static int
1.1425 +CheckAccess(interp, objPtr, mode)
1.1426 + Tcl_Interp *interp; /* Interp for status return. Must not be
1.1427 + * NULL. */
1.1428 + Tcl_Obj *objPtr; /* Name of file to check. */
1.1429 + int mode; /* Attribute to check; passed as argument to
1.1430 + * access(). */
1.1431 +{
1.1432 + int value;
1.1433 +
1.1434 + if (Tcl_FSConvertToPathType(interp, objPtr) != TCL_OK) {
1.1435 + value = 0;
1.1436 + } else {
1.1437 + value = (Tcl_FSAccess(objPtr, mode) == 0);
1.1438 + }
1.1439 + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value);
1.1440 +
1.1441 + return TCL_OK;
1.1442 +}
1.1443 +
1.1444 +/*
1.1445 + *---------------------------------------------------------------------------
1.1446 + *
1.1447 + * GetStatBuf --
1.1448 + *
1.1449 + * Utility procedure used by Tcl_FileObjCmd() to query file
1.1450 + * attributes available through the stat() or lstat() system call.
1.1451 + *
1.1452 + * Results:
1.1453 + * The return value is TCL_OK if the specified file exists and can
1.1454 + * be stat'ed, TCL_ERROR otherwise. If TCL_ERROR is returned, an
1.1455 + * error message is left in interp's result. If TCL_OK is returned,
1.1456 + * *statPtr is filled with information about the specified file.
1.1457 + *
1.1458 + * Side effects:
1.1459 + * None.
1.1460 + *
1.1461 + *---------------------------------------------------------------------------
1.1462 + */
1.1463 +
1.1464 +static int
1.1465 +GetStatBuf(interp, objPtr, statProc, statPtr)
1.1466 + Tcl_Interp *interp; /* Interp for error return. May be NULL. */
1.1467 + Tcl_Obj *objPtr; /* Path name to examine. */
1.1468 + Tcl_FSStatProc *statProc; /* Either stat() or lstat() depending on
1.1469 + * desired behavior. */
1.1470 + Tcl_StatBuf *statPtr; /* Filled with info about file obtained by
1.1471 + * calling (*statProc)(). */
1.1472 +{
1.1473 + int status;
1.1474 +
1.1475 + if (Tcl_FSConvertToPathType(interp, objPtr) != TCL_OK) {
1.1476 + return TCL_ERROR;
1.1477 + }
1.1478 +
1.1479 + status = (*statProc)(objPtr, statPtr);
1.1480 +
1.1481 + if (status < 0) {
1.1482 + if (interp != NULL) {
1.1483 + Tcl_AppendResult(interp, "could not read \"",
1.1484 + Tcl_GetString(objPtr), "\": ",
1.1485 + Tcl_PosixError(interp), (char *) NULL);
1.1486 + }
1.1487 + return TCL_ERROR;
1.1488 + }
1.1489 + return TCL_OK;
1.1490 +}
1.1491 +
1.1492 +/*
1.1493 + *----------------------------------------------------------------------
1.1494 + *
1.1495 + * StoreStatData --
1.1496 + *
1.1497 + * This is a utility procedure that breaks out the fields of a
1.1498 + * "stat" structure and stores them in textual form into the
1.1499 + * elements of an associative array.
1.1500 + *
1.1501 + * Results:
1.1502 + * Returns a standard Tcl return value. If an error occurs then
1.1503 + * a message is left in interp's result.
1.1504 + *
1.1505 + * Side effects:
1.1506 + * Elements of the associative array given by "varName" are modified.
1.1507 + *
1.1508 + *----------------------------------------------------------------------
1.1509 + */
1.1510 +
1.1511 +static int
1.1512 +StoreStatData(interp, varName, statPtr)
1.1513 + Tcl_Interp *interp; /* Interpreter for error reports. */
1.1514 + char *varName; /* Name of associative array variable
1.1515 + * in which to store stat results. */
1.1516 + Tcl_StatBuf *statPtr; /* Pointer to buffer containing
1.1517 + * stat data to store in varName. */
1.1518 +{
1.1519 + Tcl_Obj *var = Tcl_NewStringObj(varName, -1);
1.1520 + Tcl_Obj *field = Tcl_NewObj();
1.1521 + Tcl_Obj *value;
1.1522 + register unsigned short mode;
1.1523 +
1.1524 + /*
1.1525 + * Assume Tcl_ObjSetVar2() does not keep a copy of the field name!
1.1526 + */
1.1527 +#define STORE_ARY(fieldName, object) \
1.1528 + Tcl_SetStringObj(field, (fieldName), -1); \
1.1529 + value = (object); \
1.1530 + if (Tcl_ObjSetVar2(interp,var,field,value,TCL_LEAVE_ERR_MSG) == NULL) { \
1.1531 + Tcl_DecrRefCount(var); \
1.1532 + Tcl_DecrRefCount(field); \
1.1533 + Tcl_DecrRefCount(value); \
1.1534 + return TCL_ERROR; \
1.1535 + }
1.1536 +
1.1537 + Tcl_IncrRefCount(var);
1.1538 + Tcl_IncrRefCount(field);
1.1539 + STORE_ARY("dev", Tcl_NewLongObj((long)statPtr->st_dev));
1.1540 + /*
1.1541 + * Watch out porters; the inode is meant to be an *unsigned* value,
1.1542 + * so the cast might fail when there isn't a real arithmentic 'long
1.1543 + * long' type...
1.1544 + */
1.1545 + STORE_ARY("ino", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_ino));
1.1546 + STORE_ARY("nlink", Tcl_NewLongObj((long)statPtr->st_nlink));
1.1547 + STORE_ARY("uid", Tcl_NewLongObj((long)statPtr->st_uid));
1.1548 + STORE_ARY("gid", Tcl_NewLongObj((long)statPtr->st_gid));
1.1549 + STORE_ARY("size", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_size));
1.1550 +#ifdef HAVE_ST_BLOCKS
1.1551 + STORE_ARY("blocks",Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_blocks));
1.1552 +#endif
1.1553 + STORE_ARY("atime", Tcl_NewLongObj((long)statPtr->st_atime));
1.1554 + STORE_ARY("mtime", Tcl_NewLongObj((long)statPtr->st_mtime));
1.1555 + STORE_ARY("ctime", Tcl_NewLongObj((long)statPtr->st_ctime));
1.1556 + mode = (unsigned short) statPtr->st_mode;
1.1557 + STORE_ARY("mode", Tcl_NewIntObj(mode));
1.1558 + STORE_ARY("type", Tcl_NewStringObj(GetTypeFromMode(mode), -1));
1.1559 +#undef STORE_ARY
1.1560 + Tcl_DecrRefCount(var);
1.1561 + Tcl_DecrRefCount(field);
1.1562 + return TCL_OK;
1.1563 +}
1.1564 +
1.1565 +/*
1.1566 + *----------------------------------------------------------------------
1.1567 + *
1.1568 + * GetTypeFromMode --
1.1569 + *
1.1570 + * Given a mode word, returns a string identifying the type of a
1.1571 + * file.
1.1572 + *
1.1573 + * Results:
1.1574 + * A static text string giving the file type from mode.
1.1575 + *
1.1576 + * Side effects:
1.1577 + * None.
1.1578 + *
1.1579 + *----------------------------------------------------------------------
1.1580 + */
1.1581 +
1.1582 +static char *
1.1583 +GetTypeFromMode(mode)
1.1584 + int mode;
1.1585 +{
1.1586 + if (S_ISREG(mode)) {
1.1587 + return "file";
1.1588 + } else if (S_ISDIR(mode)) {
1.1589 + return "directory";
1.1590 + } else if (S_ISCHR(mode)) {
1.1591 + return "characterSpecial";
1.1592 + } else if (S_ISBLK(mode)) {
1.1593 + return "blockSpecial";
1.1594 + } else if (S_ISFIFO(mode)) {
1.1595 + return "fifo";
1.1596 +#ifdef S_ISLNK
1.1597 + } else if (S_ISLNK(mode)) {
1.1598 + return "link";
1.1599 +#endif
1.1600 +#ifdef S_ISSOCK
1.1601 + } else if (S_ISSOCK(mode)) {
1.1602 + return "socket";
1.1603 +#endif
1.1604 + }
1.1605 + return "unknown";
1.1606 +}
1.1607 +
1.1608 +/*
1.1609 + *----------------------------------------------------------------------
1.1610 + *
1.1611 + * Tcl_ForObjCmd --
1.1612 + *
1.1613 + * This procedure is invoked to process the "for" Tcl command.
1.1614 + * See the user documentation for details on what it does.
1.1615 + *
1.1616 + * With the bytecode compiler, this procedure is only called when
1.1617 + * a command name is computed at runtime, and is "for" or the name
1.1618 + * to which "for" was renamed: e.g.,
1.1619 + * "set z for; $z {set i 0} {$i<100} {incr i} {puts $i}"
1.1620 + *
1.1621 + * Results:
1.1622 + * A standard Tcl result.
1.1623 + *
1.1624 + * Side effects:
1.1625 + * See the user documentation.
1.1626 + *
1.1627 + *----------------------------------------------------------------------
1.1628 + */
1.1629 +
1.1630 + /* ARGSUSED */
1.1631 +int
1.1632 +Tcl_ForObjCmd(dummy, interp, objc, objv)
1.1633 + ClientData dummy; /* Not used. */
1.1634 + Tcl_Interp *interp; /* Current interpreter. */
1.1635 + int objc; /* Number of arguments. */
1.1636 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.1637 +{
1.1638 + int result, value;
1.1639 +#ifdef TCL_TIP280
1.1640 + Interp* iPtr = (Interp*) interp;
1.1641 +#endif
1.1642 +
1.1643 + if (objc != 5) {
1.1644 + Tcl_WrongNumArgs(interp, 1, objv, "start test next command");
1.1645 + return TCL_ERROR;
1.1646 + }
1.1647 +
1.1648 +#ifndef TCL_TIP280
1.1649 + result = Tcl_EvalObjEx(interp, objv[1], 0);
1.1650 +#else
1.1651 + /* TIP #280. Make invoking context available to initial script */
1.1652 + result = TclEvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr,1);
1.1653 +#endif
1.1654 + if (result != TCL_OK) {
1.1655 + if (result == TCL_ERROR) {
1.1656 + Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)");
1.1657 + }
1.1658 + return result;
1.1659 + }
1.1660 + while (1) {
1.1661 + /*
1.1662 + * We need to reset the result before passing it off to
1.1663 + * Tcl_ExprBooleanObj. Otherwise, any error message will be appended
1.1664 + * to the result of the last evaluation.
1.1665 + */
1.1666 +
1.1667 + Tcl_ResetResult(interp);
1.1668 + result = Tcl_ExprBooleanObj(interp, objv[2], &value);
1.1669 + if (result != TCL_OK) {
1.1670 + return result;
1.1671 + }
1.1672 + if (!value) {
1.1673 + break;
1.1674 + }
1.1675 +#ifndef TCL_TIP280
1.1676 + result = Tcl_EvalObjEx(interp, objv[4], 0);
1.1677 +#else
1.1678 + /* TIP #280. Make invoking context available to loop body */
1.1679 + result = TclEvalObjEx(interp, objv[4], 0, iPtr->cmdFramePtr,4);
1.1680 +#endif
1.1681 + if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
1.1682 + if (result == TCL_ERROR) {
1.1683 + char msg[32 + TCL_INTEGER_SPACE];
1.1684 +
1.1685 + sprintf(msg, "\n (\"for\" body line %d)",interp->errorLine);
1.1686 + Tcl_AddErrorInfo(interp, msg);
1.1687 + }
1.1688 + break;
1.1689 + }
1.1690 +#ifndef TCL_TIP280
1.1691 + result = Tcl_EvalObjEx(interp, objv[3], 0);
1.1692 +#else
1.1693 + /* TIP #280. Make invoking context available to next script */
1.1694 + result = TclEvalObjEx(interp, objv[3], 0, iPtr->cmdFramePtr,3);
1.1695 +#endif
1.1696 + if (result == TCL_BREAK) {
1.1697 + break;
1.1698 + } else if (result != TCL_OK) {
1.1699 + if (result == TCL_ERROR) {
1.1700 + Tcl_AddErrorInfo(interp, "\n (\"for\" loop-end command)");
1.1701 + }
1.1702 + return result;
1.1703 + }
1.1704 + }
1.1705 + if (result == TCL_BREAK) {
1.1706 + result = TCL_OK;
1.1707 + }
1.1708 + if (result == TCL_OK) {
1.1709 + Tcl_ResetResult(interp);
1.1710 + }
1.1711 + return result;
1.1712 +}
1.1713 +
1.1714 +/*
1.1715 + *----------------------------------------------------------------------
1.1716 + *
1.1717 + * Tcl_ForeachObjCmd --
1.1718 + *
1.1719 + * This object-based procedure is invoked to process the "foreach" Tcl
1.1720 + * command. See the user documentation for details on what it does.
1.1721 + *
1.1722 + * Results:
1.1723 + * A standard Tcl object result.
1.1724 + *
1.1725 + * Side effects:
1.1726 + * See the user documentation.
1.1727 + *
1.1728 + *----------------------------------------------------------------------
1.1729 + */
1.1730 +
1.1731 + /* ARGSUSED */
1.1732 +int
1.1733 +Tcl_ForeachObjCmd(dummy, interp, objc, objv)
1.1734 + ClientData dummy; /* Not used. */
1.1735 + Tcl_Interp *interp; /* Current interpreter. */
1.1736 + int objc; /* Number of arguments. */
1.1737 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.1738 +{
1.1739 + int result = TCL_OK;
1.1740 + int i; /* i selects a value list */
1.1741 + int j, maxj; /* Number of loop iterations */
1.1742 + int v; /* v selects a loop variable */
1.1743 + int numLists; /* Count of value lists */
1.1744 + Tcl_Obj *bodyPtr;
1.1745 +
1.1746 + /*
1.1747 + * We copy the argument object pointers into a local array to avoid
1.1748 + * the problem that "objv" might become invalid. It is a pointer into
1.1749 + * the evaluation stack and that stack might be grown and reallocated
1.1750 + * if the loop body requires a large amount of stack space.
1.1751 + */
1.1752 +
1.1753 +#define NUM_ARGS 9
1.1754 + Tcl_Obj *(argObjStorage[NUM_ARGS]);
1.1755 + Tcl_Obj **argObjv = argObjStorage;
1.1756 +
1.1757 +#define STATIC_LIST_SIZE 4
1.1758 + int indexArray[STATIC_LIST_SIZE];
1.1759 + int varcListArray[STATIC_LIST_SIZE];
1.1760 + Tcl_Obj **varvListArray[STATIC_LIST_SIZE];
1.1761 + int argcListArray[STATIC_LIST_SIZE];
1.1762 + Tcl_Obj **argvListArray[STATIC_LIST_SIZE];
1.1763 +
1.1764 + int *index = indexArray; /* Array of value list indices */
1.1765 + int *varcList = varcListArray; /* # loop variables per list */
1.1766 + Tcl_Obj ***varvList = varvListArray; /* Array of var name lists */
1.1767 + int *argcList = argcListArray; /* Array of value list sizes */
1.1768 + Tcl_Obj ***argvList = argvListArray; /* Array of value lists */
1.1769 +#ifdef TCL_TIP280
1.1770 + Interp* iPtr = (Interp*) interp;
1.1771 +#endif
1.1772 +
1.1773 + if (objc < 4 || (objc%2 != 0)) {
1.1774 + Tcl_WrongNumArgs(interp, 1, objv,
1.1775 + "varList list ?varList list ...? command");
1.1776 + return TCL_ERROR;
1.1777 + }
1.1778 +
1.1779 + /*
1.1780 + * Create the object argument array "argObjv". Make sure argObjv is
1.1781 + * large enough to hold the objc arguments.
1.1782 + */
1.1783 +
1.1784 + if (objc > NUM_ARGS) {
1.1785 + argObjv = (Tcl_Obj **) ckalloc(objc * sizeof(Tcl_Obj *));
1.1786 + }
1.1787 + for (i = 0; i < objc; i++) {
1.1788 + argObjv[i] = objv[i];
1.1789 + }
1.1790 +
1.1791 + /*
1.1792 + * Manage numList parallel value lists.
1.1793 + * argvList[i] is a value list counted by argcList[i]
1.1794 + * varvList[i] is the list of variables associated with the value list
1.1795 + * varcList[i] is the number of variables associated with the value list
1.1796 + * index[i] is the current pointer into the value list argvList[i]
1.1797 + */
1.1798 +
1.1799 + numLists = (objc-2)/2;
1.1800 + if (numLists > STATIC_LIST_SIZE) {
1.1801 + index = (int *) ckalloc(numLists * sizeof(int));
1.1802 + varcList = (int *) ckalloc(numLists * sizeof(int));
1.1803 + varvList = (Tcl_Obj ***) ckalloc(numLists * sizeof(Tcl_Obj **));
1.1804 + argcList = (int *) ckalloc(numLists * sizeof(int));
1.1805 + argvList = (Tcl_Obj ***) ckalloc(numLists * sizeof(Tcl_Obj **));
1.1806 + }
1.1807 + for (i = 0; i < numLists; i++) {
1.1808 + index[i] = 0;
1.1809 + varcList[i] = 0;
1.1810 + varvList[i] = (Tcl_Obj **) NULL;
1.1811 + argcList[i] = 0;
1.1812 + argvList[i] = (Tcl_Obj **) NULL;
1.1813 + }
1.1814 +
1.1815 + /*
1.1816 + * Break up the value lists and variable lists into elements
1.1817 + */
1.1818 +
1.1819 + maxj = 0;
1.1820 + for (i = 0; i < numLists; i++) {
1.1821 + result = Tcl_ListObjGetElements(interp, argObjv[1+i*2],
1.1822 + &varcList[i], &varvList[i]);
1.1823 + if (result != TCL_OK) {
1.1824 + goto done;
1.1825 + }
1.1826 + if (varcList[i] < 1) {
1.1827 + Tcl_AppendToObj(Tcl_GetObjResult(interp),
1.1828 + "foreach varlist is empty", -1);
1.1829 + result = TCL_ERROR;
1.1830 + goto done;
1.1831 + }
1.1832 +
1.1833 + result = Tcl_ListObjGetElements(interp, argObjv[2+i*2],
1.1834 + &argcList[i], &argvList[i]);
1.1835 + if (result != TCL_OK) {
1.1836 + goto done;
1.1837 + }
1.1838 +
1.1839 + j = argcList[i] / varcList[i];
1.1840 + if ((argcList[i] % varcList[i]) != 0) {
1.1841 + j++;
1.1842 + }
1.1843 + if (j > maxj) {
1.1844 + maxj = j;
1.1845 + }
1.1846 + }
1.1847 +
1.1848 + /*
1.1849 + * Iterate maxj times through the lists in parallel
1.1850 + * If some value lists run out of values, set loop vars to ""
1.1851 + */
1.1852 +
1.1853 + bodyPtr = argObjv[objc-1];
1.1854 + for (j = 0; j < maxj; j++) {
1.1855 + for (i = 0; i < numLists; i++) {
1.1856 + /*
1.1857 + * Refetch the list members; we assume that the sizes are
1.1858 + * the same, but the array of elements might be different
1.1859 + * if the internal rep of the objects has been lost and
1.1860 + * recreated (it is too difficult to accurately tell when
1.1861 + * this happens, which can lead to some wierd crashes,
1.1862 + * like Bug #494348...)
1.1863 + */
1.1864 +
1.1865 + result = Tcl_ListObjGetElements(interp, argObjv[1+i*2],
1.1866 + &varcList[i], &varvList[i]);
1.1867 + if (result != TCL_OK) {
1.1868 + panic("Tcl_ForeachObjCmd: could not reconvert variable list %d to a list object\n", i);
1.1869 + }
1.1870 + result = Tcl_ListObjGetElements(interp, argObjv[2+i*2],
1.1871 + &argcList[i], &argvList[i]);
1.1872 + if (result != TCL_OK) {
1.1873 + panic("Tcl_ForeachObjCmd: could not reconvert value list %d to a list object\n", i);
1.1874 + }
1.1875 +
1.1876 + for (v = 0; v < varcList[i]; v++) {
1.1877 + int k = index[i]++;
1.1878 + Tcl_Obj *valuePtr, *varValuePtr;
1.1879 +
1.1880 + if (k < argcList[i]) {
1.1881 + valuePtr = argvList[i][k];
1.1882 + } else {
1.1883 + valuePtr = Tcl_NewObj(); /* empty string */
1.1884 + }
1.1885 + Tcl_IncrRefCount(valuePtr);
1.1886 + varValuePtr = Tcl_ObjSetVar2(interp, varvList[i][v],
1.1887 + NULL, valuePtr, 0);
1.1888 + Tcl_DecrRefCount(valuePtr);
1.1889 + if (varValuePtr == NULL) {
1.1890 + Tcl_ResetResult(interp);
1.1891 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.1892 + "couldn't set loop variable: \"",
1.1893 + Tcl_GetString(varvList[i][v]), "\"", (char *) NULL);
1.1894 + result = TCL_ERROR;
1.1895 + goto done;
1.1896 + }
1.1897 +
1.1898 + }
1.1899 + }
1.1900 +
1.1901 +#ifndef TCL_TIP280
1.1902 + result = Tcl_EvalObjEx(interp, bodyPtr, 0);
1.1903 +#else
1.1904 + /* TIP #280. Make invoking context available to loop body */
1.1905 + result = TclEvalObjEx(interp, bodyPtr, 0, iPtr->cmdFramePtr,objc-1);
1.1906 +#endif
1.1907 + if (result != TCL_OK) {
1.1908 + if (result == TCL_CONTINUE) {
1.1909 + result = TCL_OK;
1.1910 + } else if (result == TCL_BREAK) {
1.1911 + result = TCL_OK;
1.1912 + break;
1.1913 + } else if (result == TCL_ERROR) {
1.1914 + char msg[32 + TCL_INTEGER_SPACE];
1.1915 +
1.1916 + sprintf(msg, "\n (\"foreach\" body line %d)",
1.1917 + interp->errorLine);
1.1918 + Tcl_AddObjErrorInfo(interp, msg, -1);
1.1919 + break;
1.1920 + } else {
1.1921 + break;
1.1922 + }
1.1923 + }
1.1924 + }
1.1925 + if (result == TCL_OK) {
1.1926 + Tcl_ResetResult(interp);
1.1927 + }
1.1928 +
1.1929 + done:
1.1930 + if (numLists > STATIC_LIST_SIZE) {
1.1931 + ckfree((char *) index);
1.1932 + ckfree((char *) varcList);
1.1933 + ckfree((char *) argcList);
1.1934 + ckfree((char *) varvList);
1.1935 + ckfree((char *) argvList);
1.1936 + }
1.1937 + if (argObjv != argObjStorage) {
1.1938 + ckfree((char *) argObjv);
1.1939 + }
1.1940 + return result;
1.1941 +#undef STATIC_LIST_SIZE
1.1942 +#undef NUM_ARGS
1.1943 +}
1.1944 +
1.1945 +/*
1.1946 + *----------------------------------------------------------------------
1.1947 + *
1.1948 + * Tcl_FormatObjCmd --
1.1949 + *
1.1950 + * This procedure is invoked to process the "format" Tcl command.
1.1951 + * See the user documentation for details on what it does.
1.1952 + *
1.1953 + * Results:
1.1954 + * A standard Tcl result.
1.1955 + *
1.1956 + * Side effects:
1.1957 + * See the user documentation.
1.1958 + *
1.1959 + *----------------------------------------------------------------------
1.1960 + */
1.1961 +
1.1962 + /* ARGSUSED */
1.1963 +int
1.1964 +Tcl_FormatObjCmd(dummy, interp, objc, objv)
1.1965 + ClientData dummy; /* Not used. */
1.1966 + Tcl_Interp *interp; /* Current interpreter. */
1.1967 + int objc; /* Number of arguments. */
1.1968 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.1969 +{
1.1970 + char *format; /* Used to read characters from the format
1.1971 + * string. */
1.1972 + int formatLen; /* The length of the format string */
1.1973 + char *endPtr; /* Points to the last char in format array */
1.1974 + char newFormat[43]; /* A new format specifier is generated here. */
1.1975 + int width; /* Field width from field specifier, or 0 if
1.1976 + * no width given. */
1.1977 + int precision; /* Field precision from field specifier, or 0
1.1978 + * if no precision given. */
1.1979 + int size; /* Number of bytes needed for result of
1.1980 + * conversion, based on type of conversion
1.1981 + * ("e", "s", etc.), width, and precision. */
1.1982 + long intValue; /* Used to hold value to pass to sprintf, if
1.1983 + * it's a one-word integer or char value */
1.1984 + char *ptrValue = NULL; /* Used to hold value to pass to sprintf, if
1.1985 + * it's a one-word value. */
1.1986 + double doubleValue; /* Used to hold value to pass to sprintf if
1.1987 + * it's a double value. */
1.1988 + Tcl_WideInt wideValue; /* Used to hold value to pass to sprintf if
1.1989 + * it's a 'long long' value. */
1.1990 + int whichValue; /* Indicates which of intValue, ptrValue,
1.1991 + * or doubleValue has the value to pass to
1.1992 + * sprintf, according to the following
1.1993 + * definitions: */
1.1994 +# define INT_VALUE 0
1.1995 +# define CHAR_VALUE 1
1.1996 +# define PTR_VALUE 2
1.1997 +# define DOUBLE_VALUE 3
1.1998 +# define STRING_VALUE 4
1.1999 +# define WIDE_VALUE 5
1.2000 +# define MAX_FLOAT_SIZE 320
1.2001 +
1.2002 + Tcl_Obj *resultPtr; /* Where result is stored finally. */
1.2003 + char staticBuf[MAX_FLOAT_SIZE + 1];
1.2004 + /* A static buffer to copy the format results
1.2005 + * into */
1.2006 + char *dst = staticBuf; /* The buffer that sprintf writes into each
1.2007 + * time the format processes a specifier */
1.2008 + int dstSize = MAX_FLOAT_SIZE;
1.2009 + /* The size of the dst buffer */
1.2010 + int noPercent; /* Special case for speed: indicates there's
1.2011 + * no field specifier, just a string to copy.*/
1.2012 + int objIndex; /* Index of argument to substitute next. */
1.2013 + int gotXpg = 0; /* Non-zero means that an XPG3 %n$-style
1.2014 + * specifier has been seen. */
1.2015 + int gotSequential = 0; /* Non-zero means that a regular sequential
1.2016 + * (non-XPG3) conversion specifier has been
1.2017 + * seen. */
1.2018 + int useShort; /* Value to be printed is short (half word). */
1.2019 + char *end; /* Used to locate end of numerical fields. */
1.2020 + int stringLen = 0; /* Length of string in characters rather
1.2021 + * than bytes. Used for %s substitution. */
1.2022 + int gotMinus; /* Non-zero indicates that a minus flag has
1.2023 + * been seen in the current field. */
1.2024 + int gotPrecision; /* Non-zero indicates that a precision has
1.2025 + * been set for the current field. */
1.2026 + int gotZero; /* Non-zero indicates that a zero flag has
1.2027 + * been seen in the current field. */
1.2028 + int useWide; /* Value to be printed is Tcl_WideInt. */
1.2029 +
1.2030 + /*
1.2031 + * This procedure is a bit nasty. The goal is to use sprintf to
1.2032 + * do most of the dirty work. There are several problems:
1.2033 + * 1. this procedure can't trust its arguments.
1.2034 + * 2. we must be able to provide a large enough result area to hold
1.2035 + * whatever's generated. This is hard to estimate.
1.2036 + * 3. there's no way to move the arguments from objv to the call
1.2037 + * to sprintf in a reasonable way. This is particularly nasty
1.2038 + * because some of the arguments may be two-word values (doubles
1.2039 + * and wide-ints).
1.2040 + * So, what happens here is to scan the format string one % group
1.2041 + * at a time, making many individual calls to sprintf.
1.2042 + */
1.2043 +
1.2044 + if (objc < 2) {
1.2045 + Tcl_WrongNumArgs(interp, 1, objv, "formatString ?arg arg ...?");
1.2046 + return TCL_ERROR;
1.2047 + }
1.2048 +
1.2049 + format = Tcl_GetStringFromObj(objv[1], &formatLen);
1.2050 + endPtr = format + formatLen;
1.2051 + resultPtr = Tcl_NewObj();
1.2052 + objIndex = 2;
1.2053 +
1.2054 + while (format < endPtr) {
1.2055 + register char *newPtr = newFormat;
1.2056 +
1.2057 + width = precision = noPercent = useShort = 0;
1.2058 + gotZero = gotMinus = gotPrecision = 0;
1.2059 + useWide = 0;
1.2060 + whichValue = PTR_VALUE;
1.2061 +
1.2062 + /*
1.2063 + * Get rid of any characters before the next field specifier.
1.2064 + */
1.2065 + if (*format != '%') {
1.2066 + ptrValue = format;
1.2067 + while ((*format != '%') && (format < endPtr)) {
1.2068 + format++;
1.2069 + }
1.2070 + size = format - ptrValue;
1.2071 + noPercent = 1;
1.2072 + goto doField;
1.2073 + }
1.2074 +
1.2075 + if (format[1] == '%') {
1.2076 + ptrValue = format;
1.2077 + size = 1;
1.2078 + noPercent = 1;
1.2079 + format += 2;
1.2080 + goto doField;
1.2081 + }
1.2082 +
1.2083 + /*
1.2084 + * Parse off a field specifier, compute how many characters
1.2085 + * will be needed to store the result, and substitute for
1.2086 + * "*" size specifiers.
1.2087 + */
1.2088 + *newPtr = '%';
1.2089 + newPtr++;
1.2090 + format++;
1.2091 + if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */
1.2092 + int tmp;
1.2093 +
1.2094 + /*
1.2095 + * Check for an XPG3-style %n$ specification. Note: there
1.2096 + * must not be a mixture of XPG3 specs and non-XPG3 specs
1.2097 + * in the same format string.
1.2098 + */
1.2099 +
1.2100 + tmp = strtoul(format, &end, 10); /* INTL: "C" locale. */
1.2101 + if (*end != '$') {
1.2102 + goto notXpg;
1.2103 + }
1.2104 + format = end+1;
1.2105 + gotXpg = 1;
1.2106 + if (gotSequential) {
1.2107 + goto mixedXPG;
1.2108 + }
1.2109 + objIndex = tmp+1;
1.2110 + if ((objIndex < 2) || (objIndex >= objc)) {
1.2111 + goto badIndex;
1.2112 + }
1.2113 + goto xpgCheckDone;
1.2114 + }
1.2115 +
1.2116 + notXpg:
1.2117 + gotSequential = 1;
1.2118 + if (gotXpg) {
1.2119 + goto mixedXPG;
1.2120 + }
1.2121 +
1.2122 + xpgCheckDone:
1.2123 + while ((*format == '-') || (*format == '#') || (*format == '0')
1.2124 + || (*format == ' ') || (*format == '+')) {
1.2125 + if (*format == '-') {
1.2126 + gotMinus = 1;
1.2127 + }
1.2128 + if (*format == '0') {
1.2129 + /*
1.2130 + * This will be handled by sprintf for numbers, but we
1.2131 + * need to do the char/string ones ourselves
1.2132 + */
1.2133 + gotZero = 1;
1.2134 + }
1.2135 + *newPtr = *format;
1.2136 + newPtr++;
1.2137 + format++;
1.2138 + }
1.2139 + if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */
1.2140 + width = strtoul(format, &end, 10); /* INTL: Tcl source. */
1.2141 + format = end;
1.2142 + } else if (*format == '*') {
1.2143 + if (objIndex >= objc) {
1.2144 + goto badIndex;
1.2145 + }
1.2146 + if (Tcl_GetIntFromObj(interp, /* INTL: Tcl source. */
1.2147 + objv[objIndex], &width) != TCL_OK) {
1.2148 + goto fmtError;
1.2149 + }
1.2150 + if (width < 0) {
1.2151 + width = -width;
1.2152 + *newPtr = '-';
1.2153 + gotMinus = 1;
1.2154 + newPtr++;
1.2155 + }
1.2156 + objIndex++;
1.2157 + format++;
1.2158 + }
1.2159 + if (width > 100000) {
1.2160 + /*
1.2161 + * Don't allow arbitrarily large widths: could cause core
1.2162 + * dump when we try to allocate a zillion bytes of memory
1.2163 + * below.
1.2164 + */
1.2165 +
1.2166 + width = 100000;
1.2167 + } else if (width < 0) {
1.2168 + width = 0;
1.2169 + }
1.2170 + if (width != 0) {
1.2171 + TclFormatInt(newPtr, width); /* INTL: printf format. */
1.2172 + while (*newPtr != 0) {
1.2173 + newPtr++;
1.2174 + }
1.2175 + }
1.2176 + if (*format == '.') {
1.2177 + *newPtr = '.';
1.2178 + newPtr++;
1.2179 + format++;
1.2180 + gotPrecision = 1;
1.2181 + }
1.2182 + if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */
1.2183 + precision = strtoul(format, &end, 10); /* INTL: "C" locale. */
1.2184 + format = end;
1.2185 + } else if (*format == '*') {
1.2186 + if (objIndex >= objc) {
1.2187 + goto badIndex;
1.2188 + }
1.2189 + if (Tcl_GetIntFromObj(interp, /* INTL: Tcl source. */
1.2190 + objv[objIndex], &precision) != TCL_OK) {
1.2191 + goto fmtError;
1.2192 + }
1.2193 + objIndex++;
1.2194 + format++;
1.2195 + }
1.2196 + if (gotPrecision) {
1.2197 + TclFormatInt(newPtr, precision); /* INTL: printf format. */
1.2198 + while (*newPtr != 0) {
1.2199 + newPtr++;
1.2200 + }
1.2201 + }
1.2202 + if (*format == 'l') {
1.2203 + useWide = 1;
1.2204 + /*
1.2205 + * Only add a 'll' modifier for integer values as it makes
1.2206 + * some libc's go into spasm otherwise. [Bug #702622]
1.2207 + */
1.2208 + switch (format[1]) {
1.2209 + case 'i':
1.2210 + case 'd':
1.2211 + case 'o':
1.2212 + case 'u':
1.2213 + case 'x':
1.2214 + case 'X':
1.2215 + strcpy(newPtr, TCL_LL_MODIFIER);
1.2216 + newPtr += TCL_LL_MODIFIER_SIZE;
1.2217 + }
1.2218 + format++;
1.2219 + } else if (*format == 'h') {
1.2220 + useShort = 1;
1.2221 + *newPtr = 'h';
1.2222 + newPtr++;
1.2223 + format++;
1.2224 + }
1.2225 + *newPtr = *format;
1.2226 + newPtr++;
1.2227 + *newPtr = 0;
1.2228 + if (objIndex >= objc) {
1.2229 + goto badIndex;
1.2230 + }
1.2231 + switch (*format) {
1.2232 + case 'i':
1.2233 + newPtr[-1] = 'd';
1.2234 + case 'd':
1.2235 + case 'o':
1.2236 + case 'u':
1.2237 + case 'x':
1.2238 + case 'X':
1.2239 + if (useWide) {
1.2240 + if (Tcl_GetWideIntFromObj(interp, /* INTL: Tcl source. */
1.2241 + objv[objIndex], &wideValue) != TCL_OK) {
1.2242 + goto fmtError;
1.2243 + }
1.2244 + whichValue = WIDE_VALUE;
1.2245 + size = 40 + precision;
1.2246 + break;
1.2247 + }
1.2248 + if (Tcl_GetLongFromObj(interp, /* INTL: Tcl source. */
1.2249 + objv[objIndex], &intValue) != TCL_OK) {
1.2250 + if (Tcl_GetWideIntFromObj(interp, /* INTL: Tcl source. */
1.2251 + objv[objIndex], &wideValue) != TCL_OK) {
1.2252 + goto fmtError;
1.2253 + }
1.2254 + intValue = Tcl_WideAsLong(wideValue);
1.2255 + }
1.2256 +
1.2257 +#if (LONG_MAX > INT_MAX)
1.2258 + if (!useShort) {
1.2259 + /*
1.2260 + * Add the 'l' for long format type because we are on an
1.2261 + * LP64 archtecture and we are really going to pass a long
1.2262 + * argument to sprintf.
1.2263 + *
1.2264 + * Do not add this if we're going to pass in a short (i.e.
1.2265 + * if we've got an 'h' modifier already in the string); some
1.2266 + * libc implementations of sprintf() do not like it at all.
1.2267 + * [Bug 1154163]
1.2268 + */
1.2269 + newPtr++;
1.2270 + *newPtr = 0;
1.2271 + newPtr[-1] = newPtr[-2];
1.2272 + newPtr[-2] = 'l';
1.2273 + }
1.2274 +#endif /* LONG_MAX > INT_MAX */
1.2275 + whichValue = INT_VALUE;
1.2276 + size = 40 + precision;
1.2277 + break;
1.2278 + case 's':
1.2279 + /*
1.2280 + * Compute the length of the string in characters and add
1.2281 + * any additional space required by the field width. All
1.2282 + * of the extra characters will be spaces, so one byte per
1.2283 + * character is adequate.
1.2284 + */
1.2285 +
1.2286 + whichValue = STRING_VALUE;
1.2287 + ptrValue = Tcl_GetStringFromObj(objv[objIndex], &size);
1.2288 + stringLen = Tcl_NumUtfChars(ptrValue, size);
1.2289 + if (gotPrecision && (precision < stringLen)) {
1.2290 + stringLen = precision;
1.2291 + }
1.2292 + size = Tcl_UtfAtIndex(ptrValue, stringLen) - ptrValue;
1.2293 + if (width > stringLen) {
1.2294 + size += (width - stringLen);
1.2295 + }
1.2296 + break;
1.2297 + case 'c':
1.2298 + if (Tcl_GetLongFromObj(interp, /* INTL: Tcl source. */
1.2299 + objv[objIndex], &intValue) != TCL_OK) {
1.2300 + goto fmtError;
1.2301 + }
1.2302 + whichValue = CHAR_VALUE;
1.2303 + size = width + TCL_UTF_MAX;
1.2304 + break;
1.2305 + case 'e':
1.2306 + case 'E':
1.2307 + case 'f':
1.2308 + case 'g':
1.2309 + case 'G':
1.2310 + if (Tcl_GetDoubleFromObj(interp, /* INTL: Tcl source. */
1.2311 + objv[objIndex], &doubleValue) != TCL_OK) {
1.2312 + goto fmtError;
1.2313 + }
1.2314 + whichValue = DOUBLE_VALUE;
1.2315 + size = MAX_FLOAT_SIZE;
1.2316 + if (precision > 10) {
1.2317 + size += precision;
1.2318 + }
1.2319 + break;
1.2320 + case 0:
1.2321 + Tcl_SetResult(interp,
1.2322 + "format string ended in middle of field specifier",
1.2323 + TCL_STATIC);
1.2324 + goto fmtError;
1.2325 + default:
1.2326 + {
1.2327 + char buf[40];
1.2328 +
1.2329 + sprintf(buf, "bad field specifier \"%c\"", *format);
1.2330 + Tcl_SetResult(interp, buf, TCL_VOLATILE);
1.2331 + goto fmtError;
1.2332 + }
1.2333 + }
1.2334 + objIndex++;
1.2335 + format++;
1.2336 +
1.2337 + /*
1.2338 + * Make sure that there's enough space to hold the formatted
1.2339 + * result, then format it.
1.2340 + */
1.2341 +
1.2342 + doField:
1.2343 + if (width > size) {
1.2344 + size = width;
1.2345 + }
1.2346 + if (noPercent) {
1.2347 + Tcl_AppendToObj(resultPtr, ptrValue, size);
1.2348 + } else {
1.2349 + if (size > dstSize) {
1.2350 + if (dst != staticBuf) {
1.2351 + ckfree(dst);
1.2352 + }
1.2353 + dst = (char *) ckalloc((unsigned) (size + 1));
1.2354 + dstSize = size;
1.2355 + }
1.2356 + switch (whichValue) {
1.2357 + case DOUBLE_VALUE:
1.2358 + sprintf(dst, newFormat, doubleValue); /* INTL: user locale. */
1.2359 + break;
1.2360 + case WIDE_VALUE:
1.2361 + sprintf(dst, newFormat, wideValue);
1.2362 + break;
1.2363 + case INT_VALUE:
1.2364 + if (useShort) {
1.2365 + sprintf(dst, newFormat, (short) intValue);
1.2366 + } else {
1.2367 + sprintf(dst, newFormat, intValue);
1.2368 + }
1.2369 + break;
1.2370 + case CHAR_VALUE: {
1.2371 + char *ptr;
1.2372 + char padChar = (gotZero ? '0' : ' ');
1.2373 + ptr = dst;
1.2374 + if (!gotMinus) {
1.2375 + for ( ; --width > 0; ptr++) {
1.2376 + *ptr = padChar;
1.2377 + }
1.2378 + }
1.2379 + ptr += Tcl_UniCharToUtf(intValue, ptr);
1.2380 + for ( ; --width > 0; ptr++) {
1.2381 + *ptr = padChar;
1.2382 + }
1.2383 + *ptr = '\0';
1.2384 + break;
1.2385 + }
1.2386 + case STRING_VALUE: {
1.2387 + char *ptr;
1.2388 + char padChar = (gotZero ? '0' : ' ');
1.2389 + int pad;
1.2390 +
1.2391 + ptr = dst;
1.2392 + if (width > stringLen) {
1.2393 + pad = width - stringLen;
1.2394 + } else {
1.2395 + pad = 0;
1.2396 + }
1.2397 +
1.2398 + if (!gotMinus) {
1.2399 + while (pad > 0) {
1.2400 + *ptr++ = padChar;
1.2401 + pad--;
1.2402 + }
1.2403 + }
1.2404 +
1.2405 + size = Tcl_UtfAtIndex(ptrValue, stringLen) - ptrValue;
1.2406 + if (size) {
1.2407 + memcpy(ptr, ptrValue, (size_t) size);
1.2408 + ptr += size;
1.2409 + }
1.2410 + while (pad > 0) {
1.2411 + *ptr++ = padChar;
1.2412 + pad--;
1.2413 + }
1.2414 + *ptr = '\0';
1.2415 + break;
1.2416 + }
1.2417 + default:
1.2418 + sprintf(dst, newFormat, ptrValue);
1.2419 + break;
1.2420 + }
1.2421 + Tcl_AppendToObj(resultPtr, dst, -1);
1.2422 + }
1.2423 + }
1.2424 +
1.2425 + Tcl_SetObjResult(interp, resultPtr);
1.2426 + if (dst != staticBuf) {
1.2427 + ckfree(dst);
1.2428 + }
1.2429 + return TCL_OK;
1.2430 +
1.2431 + mixedXPG:
1.2432 + Tcl_SetResult(interp,
1.2433 + "cannot mix \"%\" and \"%n$\" conversion specifiers", TCL_STATIC);
1.2434 + goto fmtError;
1.2435 +
1.2436 + badIndex:
1.2437 + if (gotXpg) {
1.2438 + Tcl_SetResult(interp,
1.2439 + "\"%n$\" argument index out of range", TCL_STATIC);
1.2440 + } else {
1.2441 + Tcl_SetResult(interp,
1.2442 + "not enough arguments for all format specifiers", TCL_STATIC);
1.2443 + }
1.2444 +
1.2445 + fmtError:
1.2446 + if (dst != staticBuf) {
1.2447 + ckfree(dst);
1.2448 + }
1.2449 + Tcl_DecrRefCount(resultPtr);
1.2450 + return TCL_ERROR;
1.2451 +}
1.2452 +
1.2453 +/*
1.2454 + * Local Variables:
1.2455 + * mode: c
1.2456 + * c-basic-offset: 4
1.2457 + * fill-column: 78
1.2458 + * End:
1.2459 + */
1.2460 +