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