1/* 2 * tclCmdAH.c -- 3 * 4 * This file contains the top-level command routines for most of the Tcl 5 * built-in commands whose names begin with the letters A to H. 6 * 7 * Copyright (c) 1987-1993 The Regents of the University of California. 8 * Copyright (c) 1994-1997 Sun Microsystems, Inc. 9 * 10 * See the file "license.terms" for information on usage and redistribution of 11 * this file, and for a DISCLAIMER OF ALL WARRANTIES. 12 * 13 * RCS: @(#) $Id: tclCmdAH.c,v 1.93.2.2 2009/12/28 13:53:40 dkf Exp $ 14 */ 15 16#include "tclInt.h" 17#include <locale.h> 18 19/* 20 * Prototypes for local procedures defined in this file: 21 */ 22 23static int CheckAccess(Tcl_Interp *interp, Tcl_Obj *pathPtr, 24 int mode); 25static int EncodingDirsObjCmd(ClientData dummy, 26 Tcl_Interp *interp, int objc, 27 Tcl_Obj *CONST objv[]); 28static int GetStatBuf(Tcl_Interp *interp, Tcl_Obj *pathPtr, 29 Tcl_FSStatProc *statProc, Tcl_StatBuf *statPtr); 30static char * GetTypeFromMode(int mode); 31static int StoreStatData(Tcl_Interp *interp, Tcl_Obj *varName, 32 Tcl_StatBuf *statPtr); 33 34/* 35 *---------------------------------------------------------------------- 36 * 37 * Tcl_BreakObjCmd -- 38 * 39 * This procedure is invoked to process the "break" Tcl command. See the 40 * user documentation for details on what it does. 41 * 42 * With the bytecode compiler, this procedure is only called when a 43 * command name is computed at runtime, and is "break" or the name to 44 * 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( 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. See the 76 * user documentation for details on what it does. THIS COMMAND IS 77 * OBSOLETE AND DEPRECATED. SLATED FOR REMOVAL IN TCL 9.0. 78 * 79 * Results: 80 * A standard Tcl object result. 81 * 82 * Side effects: 83 * See the user documentation. 84 * 85 *---------------------------------------------------------------------- 86 */ 87 88 /* ARGSUSED */ 89int 90Tcl_CaseObjCmd( 91 ClientData dummy, /* Not used. */ 92 Tcl_Interp *interp, /* Current interpreter. */ 93 int objc, /* Number of arguments. */ 94 Tcl_Obj *CONST objv[]) /* Argument objects. */ 95{ 96 register int i; 97 int body, result, caseObjc; 98 char *stringPtr, *arg; 99 Tcl_Obj *CONST *caseObjv; 100 Tcl_Obj *armPtr; 101 102 if (objc < 3) { 103 Tcl_WrongNumArgs(interp, 1, objv, 104 "string ?in? patList body ... ?default body?"); 105 return TCL_ERROR; 106 } 107 108 stringPtr = TclGetString(objv[1]); 109 body = -1; 110 111 arg = TclGetString(objv[2]); 112 if (strcmp(arg, "in") == 0) { 113 i = 3; 114 } else { 115 i = 2; 116 } 117 caseObjc = objc - i; 118 caseObjv = objv + i; 119 120 /* 121 * If all of the pattern/command pairs are lumped into a single argument, 122 * split them out again. 123 */ 124 125 if (caseObjc == 1) { 126 Tcl_Obj **newObjv; 127 128 TclListObjGetElements(interp, caseObjv[0], &caseObjc, &newObjv); 129 caseObjv = newObjv; 130 } 131 132 for (i = 0; i < caseObjc; i += 2) { 133 int patObjc, j; 134 CONST char **patObjv; 135 char *pat; 136 unsigned char *p; 137 138 if (i == (caseObjc - 1)) { 139 Tcl_ResetResult(interp); 140 Tcl_AppendResult(interp, "extra case pattern with no body", NULL); 141 return TCL_ERROR; 142 } 143 144 /* 145 * Check for special case of single pattern (no list) with no 146 * backslash sequences. 147 */ 148 149 pat = TclGetString(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(stringPtr, pat)) { 160 body = i + 1; 161 goto match; 162 } 163 continue; 164 } 165 166 /* 167 * Break up pattern lists, then check each of the patterns in the 168 * list. 169 */ 170 171 result = Tcl_SplitList(interp, pat, &patObjc, &patObjv); 172 if (result != TCL_OK) { 173 return result; 174 } 175 for (j = 0; j < patObjc; j++) { 176 if (Tcl_StringMatch(stringPtr, patObjv[j])) { 177 body = i + 1; 178 break; 179 } 180 } 181 ckfree((char *) patObjv); 182 if (j < patObjc) { 183 break; 184 } 185 } 186 187 match: 188 if (body != -1) { 189 armPtr = caseObjv[body - 1]; 190 result = Tcl_EvalObjEx(interp, caseObjv[body], 0); 191 if (result == TCL_ERROR) { 192 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( 193 "\n (\"%.50s\" arm line %d)", 194 TclGetString(armPtr), interp->errorLine)); 195 } 196 return result; 197 } 198 199 /* 200 * Nothing matched: return nothing. 201 */ 202 203 return TCL_OK; 204} 205 206/* 207 *---------------------------------------------------------------------- 208 * 209 * Tcl_CatchObjCmd -- 210 * 211 * This object-based procedure is invoked to process the "catch" Tcl 212 * command. See the user documentation for details on what it does. 213 * 214 * Results: 215 * A standard Tcl object result. 216 * 217 * Side effects: 218 * See the user documentation. 219 * 220 *---------------------------------------------------------------------- 221 */ 222 223 /* ARGSUSED */ 224int 225Tcl_CatchObjCmd( 226 ClientData dummy, /* Not used. */ 227 Tcl_Interp *interp, /* Current interpreter. */ 228 int objc, /* Number of arguments. */ 229 Tcl_Obj *CONST objv[]) /* Argument objects. */ 230{ 231 Tcl_Obj *varNamePtr = NULL; 232 Tcl_Obj *optionVarNamePtr = NULL; 233 int result; 234 Interp *iPtr = (Interp *) interp; 235 236 if ((objc < 2) || (objc > 4)) { 237 Tcl_WrongNumArgs(interp, 1, objv, 238 "script ?resultVarName? ?optionVarName?"); 239 return TCL_ERROR; 240 } 241 242 if (objc >= 3) { 243 varNamePtr = objv[2]; 244 } 245 if (objc == 4) { 246 optionVarNamePtr = objv[3]; 247 } 248 249 /* 250 * TIP #280. Make invoking context available to caught script. 251 */ 252 253 result = TclEvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr, 1); 254 255 /* 256 * We disable catch in interpreters where the limit has been exceeded. 257 */ 258 259 if (Tcl_LimitExceeded(interp)) { 260 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( 261 "\n (\"catch\" body line %d)", interp->errorLine)); 262 return TCL_ERROR; 263 } 264 265 if (objc >= 3) { 266 if (NULL == Tcl_ObjSetVar2(interp, varNamePtr, NULL, 267 Tcl_GetObjResult(interp), 0)) { 268 Tcl_ResetResult(interp); 269 Tcl_AppendResult(interp, 270 "couldn't save command result in variable", NULL); 271 return TCL_ERROR; 272 } 273 } 274 if (objc == 4) { 275 Tcl_Obj *options = Tcl_GetReturnOptions(interp, result); 276 if (NULL == Tcl_ObjSetVar2(interp, optionVarNamePtr, NULL, 277 options, 0)) { 278 Tcl_ResetResult(interp); 279 Tcl_AppendResult(interp, 280 "couldn't save return options in variable", NULL); 281 return TCL_ERROR; 282 } 283 } 284 285 Tcl_ResetResult(interp); 286 Tcl_SetObjResult(interp, Tcl_NewIntObj(result)); 287 return TCL_OK; 288} 289 290/* 291 *---------------------------------------------------------------------- 292 * 293 * Tcl_CdObjCmd -- 294 * 295 * This procedure is invoked to process the "cd" Tcl command. See the 296 * user documentation for details on what it does. 297 * 298 * Results: 299 * A standard Tcl result. 300 * 301 * Side effects: 302 * See the user documentation. 303 * 304 *---------------------------------------------------------------------- 305 */ 306 307 /* ARGSUSED */ 308int 309Tcl_CdObjCmd( 310 ClientData dummy, /* Not used. */ 311 Tcl_Interp *interp, /* Current interpreter. */ 312 int objc, /* Number of arguments. */ 313 Tcl_Obj *CONST objv[]) /* Argument objects. */ 314{ 315 Tcl_Obj *dir; 316 int result; 317 318 if (objc > 2) { 319 Tcl_WrongNumArgs(interp, 1, objv, "?dirName?"); 320 return TCL_ERROR; 321 } 322 323 if (objc == 2) { 324 dir = objv[1]; 325 } else { 326 TclNewLiteralStringObj(dir, "~"); 327 Tcl_IncrRefCount(dir); 328 } 329 if (Tcl_FSConvertToPathType(interp, dir) != TCL_OK) { 330 result = TCL_ERROR; 331 } else { 332 result = Tcl_FSChdir(dir); 333 if (result != TCL_OK) { 334 Tcl_AppendResult(interp, "couldn't change working directory to \"", 335 TclGetString(dir), "\": ", Tcl_PosixError(interp), NULL); 336 result = TCL_ERROR; 337 } 338 } 339 if (objc != 2) { 340 Tcl_DecrRefCount(dir); 341 } 342 return result; 343} 344 345/* 346 *---------------------------------------------------------------------- 347 * 348 * Tcl_ConcatObjCmd -- 349 * 350 * This object-based procedure is invoked to process the "concat" Tcl 351 * command. See the user documentation for details on what it does. 352 * 353 * Results: 354 * A standard Tcl object result. 355 * 356 * Side effects: 357 * See the user documentation. 358 * 359 *---------------------------------------------------------------------- 360 */ 361 362 /* ARGSUSED */ 363int 364Tcl_ConcatObjCmd( 365 ClientData dummy, /* Not used. */ 366 Tcl_Interp *interp, /* Current interpreter. */ 367 int objc, /* Number of arguments. */ 368 Tcl_Obj *CONST objv[]) /* Argument objects. */ 369{ 370 if (objc >= 2) { 371 Tcl_SetObjResult(interp, Tcl_ConcatObj(objc-1, objv+1)); 372 } 373 return TCL_OK; 374} 375 376/* 377 *---------------------------------------------------------------------- 378 * 379 * Tcl_ContinueObjCmd -- 380 * 381 * This procedure is invoked to process the "continue" Tcl command. See 382 * the user documentation for details on what it does. 383 * 384 * With the bytecode compiler, this procedure is only called when a 385 * command name is computed at runtime, and is "continue" or the name to 386 * which "continue" was renamed: e.g., "set z continue; $z" 387 * 388 * Results: 389 * A standard Tcl result. 390 * 391 * Side effects: 392 * See the user documentation. 393 * 394 *---------------------------------------------------------------------- 395 */ 396 397 /* ARGSUSED */ 398int 399Tcl_ContinueObjCmd( 400 ClientData dummy, /* Not used. */ 401 Tcl_Interp *interp, /* Current interpreter. */ 402 int objc, /* Number of arguments. */ 403 Tcl_Obj *CONST objv[]) /* Argument objects. */ 404{ 405 if (objc != 1) { 406 Tcl_WrongNumArgs(interp, 1, objv, NULL); 407 return TCL_ERROR; 408 } 409 return TCL_CONTINUE; 410} 411 412/* 413 *---------------------------------------------------------------------- 414 * 415 * Tcl_EncodingObjCmd -- 416 * 417 * This command manipulates encodings. 418 * 419 * Results: 420 * A standard Tcl result. 421 * 422 * Side effects: 423 * See the user documentation. 424 * 425 *---------------------------------------------------------------------- 426 */ 427 428int 429Tcl_EncodingObjCmd( 430 ClientData dummy, /* Not used. */ 431 Tcl_Interp *interp, /* Current interpreter. */ 432 int objc, /* Number of arguments. */ 433 Tcl_Obj *CONST objv[]) /* Argument objects. */ 434{ 435 int index; 436 437 static CONST char *optionStrings[] = { 438 "convertfrom", "convertto", "dirs", "names", "system", 439 NULL 440 }; 441 enum options { 442 ENC_CONVERTFROM, ENC_CONVERTTO, ENC_DIRS, ENC_NAMES, ENC_SYSTEM 443 }; 444 445 if (objc < 2) { 446 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); 447 return TCL_ERROR; 448 } 449 if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, 450 &index) != TCL_OK) { 451 return TCL_ERROR; 452 } 453 454 switch ((enum options) index) { 455 case ENC_CONVERTTO: 456 case ENC_CONVERTFROM: { 457 Tcl_Obj *data; 458 Tcl_DString ds; 459 Tcl_Encoding encoding; 460 int length; 461 char *stringPtr; 462 463 if (objc == 3) { 464 encoding = Tcl_GetEncoding(interp, NULL); 465 data = objv[2]; 466 } else if (objc == 4) { 467 if (Tcl_GetEncodingFromObj(interp, objv[2], &encoding) != TCL_OK) { 468 return TCL_ERROR; 469 } 470 data = objv[3]; 471 } else { 472 Tcl_WrongNumArgs(interp, 2, objv, "?encoding? data"); 473 return TCL_ERROR; 474 } 475 476 if ((enum options) index == ENC_CONVERTFROM) { 477 /* 478 * Treat the string as binary data. 479 */ 480 481 stringPtr = (char *) Tcl_GetByteArrayFromObj(data, &length); 482 Tcl_ExternalToUtfDString(encoding, stringPtr, length, &ds); 483 484 /* 485 * Note that we cannot use Tcl_DStringResult here because it will 486 * truncate the string at the first null byte. 487 */ 488 489 Tcl_SetObjResult(interp, Tcl_NewStringObj( 490 Tcl_DStringValue(&ds), Tcl_DStringLength(&ds))); 491 Tcl_DStringFree(&ds); 492 } else { 493 /* 494 * Store the result as binary data. 495 */ 496 497 stringPtr = TclGetStringFromObj(data, &length); 498 Tcl_UtfToExternalDString(encoding, stringPtr, length, &ds); 499 Tcl_SetObjResult(interp, Tcl_NewByteArrayObj( 500 (unsigned char *) Tcl_DStringValue(&ds), 501 Tcl_DStringLength(&ds))); 502 Tcl_DStringFree(&ds); 503 } 504 505 Tcl_FreeEncoding(encoding); 506 break; 507 } 508 case ENC_DIRS: 509 return EncodingDirsObjCmd(dummy, interp, objc-1, objv+1); 510 case ENC_NAMES: 511 if (objc > 2) { 512 Tcl_WrongNumArgs(interp, 2, objv, NULL); 513 return TCL_ERROR; 514 } 515 Tcl_GetEncodingNames(interp); 516 break; 517 case ENC_SYSTEM: 518 if (objc > 3) { 519 Tcl_WrongNumArgs(interp, 2, objv, "?encoding?"); 520 return TCL_ERROR; 521 } 522 if (objc == 2) { 523 Tcl_SetObjResult(interp, Tcl_NewStringObj( 524 Tcl_GetEncodingName(NULL), -1)); 525 } else { 526 return Tcl_SetSystemEncoding(interp, TclGetString(objv[2])); 527 } 528 break; 529 } 530 return TCL_OK; 531} 532 533/* 534 *---------------------------------------------------------------------- 535 * 536 * EncodingDirsObjCmd -- 537 * 538 * This command manipulates the encoding search path. 539 * 540 * Results: 541 * A standard Tcl result. 542 * 543 * Side effects: 544 * Can set the encoding search path. 545 * 546 *---------------------------------------------------------------------- 547 */ 548 549int 550EncodingDirsObjCmd( 551 ClientData dummy, /* Not used. */ 552 Tcl_Interp *interp, /* Current interpreter. */ 553 int objc, /* Number of arguments. */ 554 Tcl_Obj *CONST objv[]) /* Argument objects. */ 555{ 556 if (objc > 2) { 557 Tcl_WrongNumArgs(interp, 1, objv, "?dirList?"); 558 return TCL_ERROR; 559 } 560 if (objc == 1) { 561 Tcl_SetObjResult(interp, Tcl_GetEncodingSearchPath()); 562 return TCL_OK; 563 } 564 if (Tcl_SetEncodingSearchPath(objv[1]) == TCL_ERROR) { 565 Tcl_AppendResult(interp, "expected directory list but got \"", 566 TclGetString(objv[1]), "\"", NULL); 567 return TCL_ERROR; 568 } 569 Tcl_SetObjResult(interp, objv[1]); 570 return TCL_OK; 571} 572 573/* 574 *---------------------------------------------------------------------- 575 * 576 * Tcl_ErrorObjCmd -- 577 * 578 * This procedure is invoked to process the "error" Tcl command. See the 579 * user documentation for details on what it does. 580 * 581 * Results: 582 * A standard Tcl object result. 583 * 584 * Side effects: 585 * See the user documentation. 586 * 587 *---------------------------------------------------------------------- 588 */ 589 590 /* ARGSUSED */ 591int 592Tcl_ErrorObjCmd( 593 ClientData dummy, /* Not used. */ 594 Tcl_Interp *interp, /* Current interpreter. */ 595 int objc, /* Number of arguments. */ 596 Tcl_Obj *CONST objv[]) /* Argument objects. */ 597{ 598 Tcl_Obj *options, *optName; 599 600 if ((objc < 2) || (objc > 4)) { 601 Tcl_WrongNumArgs(interp, 1, objv, "message ?errorInfo? ?errorCode?"); 602 return TCL_ERROR; 603 } 604 605 TclNewLiteralStringObj(options, "-code error -level 0"); 606 607 if (objc >= 3) { /* Process the optional info argument */ 608 TclNewLiteralStringObj(optName, "-errorinfo"); 609 Tcl_ListObjAppendElement(NULL, options, optName); 610 Tcl_ListObjAppendElement(NULL, options, objv[2]); 611 } 612 613 if (objc >= 4) { /* Process the optional code argument */ 614 TclNewLiteralStringObj(optName, "-errorcode"); 615 Tcl_ListObjAppendElement(NULL, options, optName); 616 Tcl_ListObjAppendElement(NULL, options, objv[3]); 617 } 618 619 Tcl_SetObjResult(interp, objv[1]); 620 return Tcl_SetReturnOptions(interp, options); 621} 622 623/* 624 *---------------------------------------------------------------------- 625 * 626 * Tcl_EvalObjCmd -- 627 * 628 * This object-based procedure is invoked to process the "eval" Tcl 629 * command. See the user documentation for details on what it does. 630 * 631 * Results: 632 * A standard Tcl object result. 633 * 634 * Side effects: 635 * See the user documentation. 636 * 637 *---------------------------------------------------------------------- 638 */ 639 640 /* ARGSUSED */ 641int 642Tcl_EvalObjCmd( 643 ClientData dummy, /* Not used. */ 644 Tcl_Interp *interp, /* Current interpreter. */ 645 int objc, /* Number of arguments. */ 646 Tcl_Obj *CONST objv[]) /* Argument objects. */ 647{ 648 int result; 649 register Tcl_Obj *objPtr; 650 Interp *iPtr = (Interp *) interp; 651 652 if (objc < 2) { 653 Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?"); 654 return TCL_ERROR; 655 } 656 657 if (objc == 2) { 658 /* 659 * TIP #280. Make argument location available to eval'd script. 660 */ 661 662 CmdFrame* invoker = iPtr->cmdFramePtr; 663 int word = 1; 664 TclArgumentGet (interp, objv[1], &invoker, &word); 665 666 result = TclEvalObjEx(interp, objv[1], TCL_EVAL_DIRECT, 667 invoker, word); 668 } else { 669 /* 670 * More than one argument: concatenate them together with spaces 671 * between, then evaluate the result. Tcl_EvalObjEx will delete the 672 * object when it decrements its refcount after eval'ing it. 673 */ 674 675 objPtr = Tcl_ConcatObj(objc-1, objv+1); 676 677 /* 678 * TIP #280. Make invoking context available to eval'd script. 679 */ 680 681 result = TclEvalObjEx(interp, objPtr, TCL_EVAL_DIRECT, NULL, 0); 682 } 683 if (result == TCL_ERROR) { 684 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( 685 "\n (\"eval\" body line %d)", interp->errorLine)); 686 } 687 return result; 688} 689 690/* 691 *---------------------------------------------------------------------- 692 * 693 * Tcl_ExitObjCmd -- 694 * 695 * This procedure is invoked to process the "exit" Tcl command. See the 696 * user documentation for details on what it does. 697 * 698 * Results: 699 * A standard Tcl object result. 700 * 701 * Side effects: 702 * See the user documentation. 703 * 704 *---------------------------------------------------------------------- 705 */ 706 707 /* ARGSUSED */ 708int 709Tcl_ExitObjCmd( 710 ClientData dummy, /* Not used. */ 711 Tcl_Interp *interp, /* Current interpreter. */ 712 int objc, /* Number of arguments. */ 713 Tcl_Obj *CONST objv[]) /* Argument objects. */ 714{ 715 int value; 716 717 if ((objc != 1) && (objc != 2)) { 718 Tcl_WrongNumArgs(interp, 1, objv, "?returnCode?"); 719 return TCL_ERROR; 720 } 721 722 if (objc == 1) { 723 value = 0; 724 } else if (Tcl_GetIntFromObj(interp, objv[1], &value) != TCL_OK) { 725 return TCL_ERROR; 726 } 727 Tcl_Exit(value); 728 /*NOTREACHED*/ 729 return TCL_OK; /* Better not ever reach this! */ 730} 731 732/* 733 *---------------------------------------------------------------------- 734 * 735 * Tcl_ExprObjCmd -- 736 * 737 * This object-based procedure is invoked to process the "expr" Tcl 738 * command. See the user documentation for details on what it does. 739 * 740 * With the bytecode compiler, this procedure is called in two 741 * circumstances: 1) to execute expr commands that are too complicated or 742 * too unsafe to try compiling directly into an inline sequence of 743 * instructions, and 2) to execute commands where the command name is 744 * computed at runtime and is "expr" or the name to which "expr" was 745 * renamed (e.g., "set z expr; $z 2+3") 746 * 747 * Results: 748 * A standard Tcl object result. 749 * 750 * Side effects: 751 * See the user documentation. 752 * 753 *---------------------------------------------------------------------- 754 */ 755 756 /* ARGSUSED */ 757int 758Tcl_ExprObjCmd( 759 ClientData dummy, /* Not used. */ 760 Tcl_Interp *interp, /* Current interpreter. */ 761 int objc, /* Number of arguments. */ 762 Tcl_Obj *CONST objv[]) /* Argument objects. */ 763{ 764 Tcl_Obj *resultPtr; 765 int result; 766 767 if (objc < 2) { 768 Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?"); 769 return TCL_ERROR; 770 } 771 772 if (objc == 2) { 773 result = Tcl_ExprObj(interp, objv[1], &resultPtr); 774 } else { 775 Tcl_Obj *objPtr = Tcl_ConcatObj(objc-1, objv+1); 776 Tcl_IncrRefCount(objPtr); 777 result = Tcl_ExprObj(interp, objPtr, &resultPtr); 778 Tcl_DecrRefCount(objPtr); 779 } 780 781 if (result == TCL_OK) { 782 Tcl_SetObjResult(interp, resultPtr); 783 Tcl_DecrRefCount(resultPtr); /* Done with the result object */ 784 } 785 786 return result; 787} 788 789/* 790 *---------------------------------------------------------------------- 791 * 792 * Tcl_FileObjCmd -- 793 * 794 * This procedure is invoked to process the "file" Tcl command. See the 795 * user documentation for details on what it does. PLEASE NOTE THAT THIS 796 * FAILS WITH FILENAMES AND PATHS WITH EMBEDDED NULLS. With the 797 * object-based Tcl_FS APIs, the above NOTE may no longer be true. In any 798 * case this assertion should be tested. 799 * 800 * Results: 801 * A standard Tcl result. 802 * 803 * Side effects: 804 * See the user documentation. 805 * 806 *---------------------------------------------------------------------- 807 */ 808 809 /* ARGSUSED */ 810int 811Tcl_FileObjCmd( 812 ClientData dummy, /* Not used. */ 813 Tcl_Interp *interp, /* Current interpreter. */ 814 int objc, /* Number of arguments. */ 815 Tcl_Obj *CONST objv[]) /* Argument objects. */ 816{ 817 int index, value; 818 Tcl_StatBuf buf; 819 struct utimbuf tval; 820 821 /* 822 * This list of constants should match the fileOption string array below. 823 */ 824 825 static CONST char *fileOptions[] = { 826 "atime", "attributes", "channels", "copy", 827 "delete", 828 "dirname", "executable", "exists", "extension", 829 "isdirectory", "isfile", "join", "link", 830 "lstat", "mtime", "mkdir", "nativename", 831 "normalize", "owned", 832 "pathtype", "readable", "readlink", "rename", 833 "rootname", "separator", "size", "split", 834 "stat", "system", 835 "tail", "type", "volumes", "writable", 836 NULL 837 }; 838 enum options { 839 FCMD_ATIME, FCMD_ATTRIBUTES, FCMD_CHANNELS, FCMD_COPY, 840 FCMD_DELETE, 841 FCMD_DIRNAME, FCMD_EXECUTABLE, FCMD_EXISTS, FCMD_EXTENSION, 842 FCMD_ISDIRECTORY, FCMD_ISFILE, FCMD_JOIN, FCMD_LINK, 843 FCMD_LSTAT, FCMD_MTIME, FCMD_MKDIR, FCMD_NATIVENAME, 844 FCMD_NORMALIZE, FCMD_OWNED, 845 FCMD_PATHTYPE, FCMD_READABLE, FCMD_READLINK, FCMD_RENAME, 846 FCMD_ROOTNAME, FCMD_SEPARATOR, FCMD_SIZE, FCMD_SPLIT, 847 FCMD_STAT, FCMD_SYSTEM, 848 FCMD_TAIL, FCMD_TYPE, FCMD_VOLUMES, FCMD_WRITABLE 849 }; 850 851 if (objc < 2) { 852 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); 853 return TCL_ERROR; 854 } 855 if (Tcl_GetIndexFromObj(interp, objv[1], fileOptions, "option", 0, 856 &index) != TCL_OK) { 857 return TCL_ERROR; 858 } 859 860 switch ((enum options) index) { 861 862 case FCMD_ATIME: 863 case FCMD_MTIME: 864 if ((objc < 3) || (objc > 4)) { 865 Tcl_WrongNumArgs(interp, 2, objv, "name ?time?"); 866 return TCL_ERROR; 867 } 868 if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { 869 return TCL_ERROR; 870 } 871 if (objc == 4) { 872 /* 873 * Need separate variable for reading longs from an object on 874 * 64-bit platforms. [Bug #698146] 875 */ 876 877 long newTime; 878 879 if (TclGetLongFromObj(interp, objv[3], &newTime) != TCL_OK) { 880 return TCL_ERROR; 881 } 882 883 if (index == FCMD_ATIME) { 884 tval.actime = newTime; 885 tval.modtime = buf.st_mtime; 886 } else { /* index == FCMD_MTIME */ 887 tval.actime = buf.st_atime; 888 tval.modtime = newTime; 889 } 890 891 if (Tcl_FSUtime(objv[2], &tval) != 0) { 892 Tcl_AppendResult(interp, "could not set ", 893 (index == FCMD_ATIME ? "access" : "modification"), 894 " time for file \"", TclGetString(objv[2]), "\": ", 895 Tcl_PosixError(interp), NULL); 896 return TCL_ERROR; 897 } 898 899 /* 900 * Do another stat to ensure that the we return the new recognized 901 * atime - hopefully the same as the one we sent in. However, fs's 902 * like FAT don't even know what atime is. 903 */ 904 905 if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { 906 return TCL_ERROR; 907 } 908 } 909 910 Tcl_SetObjResult(interp, Tcl_NewLongObj((long) 911 (index == FCMD_ATIME ? buf.st_atime : buf.st_mtime))); 912 return TCL_OK; 913 case FCMD_ATTRIBUTES: 914 return TclFileAttrsCmd(interp, objc, objv); 915 case FCMD_CHANNELS: 916 if ((objc < 2) || (objc > 3)) { 917 Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); 918 return TCL_ERROR; 919 } 920 return Tcl_GetChannelNamesEx(interp, 921 ((objc == 2) ? NULL : TclGetString(objv[2]))); 922 case FCMD_COPY: 923 return TclFileCopyCmd(interp, objc, objv); 924 case FCMD_DELETE: 925 return TclFileDeleteCmd(interp, objc, objv); 926 case FCMD_DIRNAME: { 927 Tcl_Obj *dirPtr; 928 929 if (objc != 3) { 930 goto only3Args; 931 } 932 dirPtr = TclPathPart(interp, objv[2], TCL_PATH_DIRNAME); 933 if (dirPtr == NULL) { 934 return TCL_ERROR; 935 } else { 936 Tcl_SetObjResult(interp, dirPtr); 937 Tcl_DecrRefCount(dirPtr); 938 return TCL_OK; 939 } 940 } 941 case FCMD_EXECUTABLE: 942 if (objc != 3) { 943 goto only3Args; 944 } 945 return CheckAccess(interp, objv[2], X_OK); 946 case FCMD_EXISTS: 947 if (objc != 3) { 948 goto only3Args; 949 } 950 return CheckAccess(interp, objv[2], F_OK); 951 case FCMD_EXTENSION: { 952 Tcl_Obj *ext; 953 954 if (objc != 3) { 955 goto only3Args; 956 } 957 ext = TclPathPart(interp, objv[2], TCL_PATH_EXTENSION); 958 if (ext != NULL) { 959 Tcl_SetObjResult(interp, ext); 960 Tcl_DecrRefCount(ext); 961 return TCL_OK; 962 } else { 963 return TCL_ERROR; 964 } 965 } 966 case FCMD_ISDIRECTORY: 967 if (objc != 3) { 968 goto only3Args; 969 } 970 value = 0; 971 if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { 972 value = S_ISDIR(buf.st_mode); 973 } 974 Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); 975 return TCL_OK; 976 case FCMD_ISFILE: 977 if (objc != 3) { 978 goto only3Args; 979 } 980 value = 0; 981 if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { 982 value = S_ISREG(buf.st_mode); 983 } 984 Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); 985 return TCL_OK; 986 case FCMD_OWNED: 987 if (objc != 3) { 988 goto only3Args; 989 } 990 value = 0; 991 if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { 992 /* 993 * For Windows, there are no user ids associated with a file, so 994 * we always return 1. 995 */ 996 997#if defined(__WIN32__) 998 value = 1; 999#else 1000 value = (geteuid() == buf.st_uid); 1001#endif 1002 } 1003 Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); 1004 return TCL_OK; 1005 case FCMD_JOIN: { 1006 Tcl_Obj *resObj; 1007 1008 if (objc < 3) { 1009 Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?"); 1010 return TCL_ERROR; 1011 } 1012 resObj = Tcl_FSJoinToPath(NULL, objc - 2, objv + 2); 1013 Tcl_SetObjResult(interp, resObj); 1014 return TCL_OK; 1015 } 1016 case FCMD_LINK: { 1017 Tcl_Obj *contents; 1018 int index; 1019 1020 if (objc < 3 || objc > 5) { 1021 Tcl_WrongNumArgs(interp, 2, objv, "?-linktype? linkname ?target?"); 1022 return TCL_ERROR; 1023 } 1024 1025 /* 1026 * Index of the 'source' argument. 1027 */ 1028 1029 if (objc == 5) { 1030 index = 3; 1031 } else { 1032 index = 2; 1033 } 1034 1035 if (objc > 3) { 1036 int linkAction; 1037 if (objc == 5) { 1038 /* 1039 * We have a '-linktype' argument. 1040 */ 1041 1042 static CONST char *linkTypes[] = { 1043 "-symbolic", "-hard", NULL 1044 }; 1045 if (Tcl_GetIndexFromObj(interp, objv[2], linkTypes, "switch", 1046 0, &linkAction) != TCL_OK) { 1047 return TCL_ERROR; 1048 } 1049 if (linkAction == 0) { 1050 linkAction = TCL_CREATE_SYMBOLIC_LINK; 1051 } else { 1052 linkAction = TCL_CREATE_HARD_LINK; 1053 } 1054 } else { 1055 linkAction = TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK; 1056 } 1057 if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) { 1058 return TCL_ERROR; 1059 } 1060 1061 /* 1062 * Create link from source to target. 1063 */ 1064 1065 contents = Tcl_FSLink(objv[index], objv[index+1], linkAction); 1066 if (contents == NULL) { 1067 /* 1068 * We handle three common error cases specially, and for all 1069 * other errors, we use the standard posix error message. 1070 */ 1071 1072 if (errno == EEXIST) { 1073 Tcl_AppendResult(interp, "could not create new link \"", 1074 TclGetString(objv[index]), 1075 "\": that path already exists", NULL); 1076 } else if (errno == ENOENT) { 1077 /* 1078 * There are two cases here: either the target doesn't 1079 * exist, or the directory of the src doesn't exist. 1080 */ 1081 1082 int access; 1083 Tcl_Obj *dirPtr = TclPathPart(interp, objv[index], 1084 TCL_PATH_DIRNAME); 1085 1086 if (dirPtr == NULL) { 1087 return TCL_ERROR; 1088 } 1089 access = Tcl_FSAccess(dirPtr, F_OK); 1090 Tcl_DecrRefCount(dirPtr); 1091 if (access != 0) { 1092 Tcl_AppendResult(interp, 1093 "could not create new link \"", 1094 TclGetString(objv[index]), 1095 "\": no such file or directory", NULL); 1096 } else { 1097 Tcl_AppendResult(interp, 1098 "could not create new link \"", 1099 TclGetString(objv[index]), "\": target \"", 1100 TclGetString(objv[index+1]), 1101 "\" doesn't exist", NULL); 1102 } 1103 } else { 1104 Tcl_AppendResult(interp, 1105 "could not create new link \"", 1106 TclGetString(objv[index]), "\" pointing to \"", 1107 TclGetString(objv[index+1]), "\": ", 1108 Tcl_PosixError(interp), NULL); 1109 } 1110 return TCL_ERROR; 1111 } 1112 } else { 1113 if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) { 1114 return TCL_ERROR; 1115 } 1116 1117 /* 1118 * Read link 1119 */ 1120 1121 contents = Tcl_FSLink(objv[index], NULL, 0); 1122 if (contents == NULL) { 1123 Tcl_AppendResult(interp, "could not read link \"", 1124 TclGetString(objv[index]), "\": ", 1125 Tcl_PosixError(interp), NULL); 1126 return TCL_ERROR; 1127 } 1128 } 1129 Tcl_SetObjResult(interp, contents); 1130 if (objc == 3) { 1131 /* 1132 * If we are reading a link, we need to free this result refCount. 1133 * If we are creating a link, this will just be objv[index+1], and 1134 * so we don't own it. 1135 */ 1136 1137 Tcl_DecrRefCount(contents); 1138 } 1139 return TCL_OK; 1140 } 1141 case FCMD_LSTAT: 1142 if (objc != 4) { 1143 Tcl_WrongNumArgs(interp, 2, objv, "name varName"); 1144 return TCL_ERROR; 1145 } 1146 if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) { 1147 return TCL_ERROR; 1148 } 1149 return StoreStatData(interp, objv[3], &buf); 1150 case FCMD_STAT: 1151 if (objc != 4) { 1152 Tcl_WrongNumArgs(interp, 2, objv, "name varName"); 1153 return TCL_ERROR; 1154 } 1155 if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { 1156 return TCL_ERROR; 1157 } 1158 return StoreStatData(interp, objv[3], &buf); 1159 case FCMD_SIZE: 1160 if (objc != 3) { 1161 goto only3Args; 1162 } 1163 if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { 1164 return TCL_ERROR; 1165 } 1166 Tcl_SetObjResult(interp, 1167 Tcl_NewWideIntObj((Tcl_WideInt) buf.st_size)); 1168 return TCL_OK; 1169 case FCMD_TYPE: 1170 if (objc != 3) { 1171 goto only3Args; 1172 } 1173 if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) { 1174 return TCL_ERROR; 1175 } 1176 Tcl_SetObjResult(interp, Tcl_NewStringObj( 1177 GetTypeFromMode((unsigned short) buf.st_mode), -1)); 1178 return TCL_OK; 1179 case FCMD_MKDIR: 1180 if (objc < 3) { 1181 Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?"); 1182 return TCL_ERROR; 1183 } 1184 return TclFileMakeDirsCmd(interp, objc, objv); 1185 case FCMD_NATIVENAME: { 1186 CONST char *fileName; 1187 Tcl_DString ds; 1188 1189 if (objc != 3) { 1190 goto only3Args; 1191 } 1192 fileName = TclGetString(objv[2]); 1193 fileName = Tcl_TranslateFileName(interp, fileName, &ds); 1194 if (fileName == NULL) { 1195 return TCL_ERROR; 1196 } 1197 Tcl_SetObjResult(interp, Tcl_NewStringObj(fileName, 1198 Tcl_DStringLength(&ds))); 1199 Tcl_DStringFree(&ds); 1200 return TCL_OK; 1201 } 1202 case FCMD_NORMALIZE: { 1203 Tcl_Obj *fileName; 1204 1205 if (objc != 3) { 1206 Tcl_WrongNumArgs(interp, 2, objv, "filename"); 1207 return TCL_ERROR; 1208 } 1209 1210 fileName = Tcl_FSGetNormalizedPath(interp, objv[2]); 1211 if (fileName == NULL) { 1212 return TCL_ERROR; 1213 } 1214 Tcl_SetObjResult(interp, fileName); 1215 return TCL_OK; 1216 } 1217 case FCMD_PATHTYPE: { 1218 Tcl_Obj *typeName; 1219 1220 if (objc != 3) { 1221 goto only3Args; 1222 } 1223 1224 switch (Tcl_FSGetPathType(objv[2])) { 1225 case TCL_PATH_ABSOLUTE: 1226 TclNewLiteralStringObj(typeName, "absolute"); 1227 break; 1228 case TCL_PATH_RELATIVE: 1229 TclNewLiteralStringObj(typeName, "relative"); 1230 break; 1231 case TCL_PATH_VOLUME_RELATIVE: 1232 TclNewLiteralStringObj(typeName, "volumerelative"); 1233 break; 1234 default: 1235 return TCL_OK; 1236 } 1237 Tcl_SetObjResult(interp, typeName); 1238 return TCL_OK; 1239 } 1240 case FCMD_READABLE: 1241 if (objc != 3) { 1242 goto only3Args; 1243 } 1244 return CheckAccess(interp, objv[2], R_OK); 1245 case FCMD_READLINK: { 1246 Tcl_Obj *contents; 1247 1248 if (objc != 3) { 1249 goto only3Args; 1250 } 1251 1252 if (Tcl_FSConvertToPathType(interp, objv[2]) != TCL_OK) { 1253 return TCL_ERROR; 1254 } 1255 1256 contents = Tcl_FSLink(objv[2], NULL, 0); 1257 1258 if (contents == NULL) { 1259 Tcl_AppendResult(interp, "could not readlink \"", 1260 TclGetString(objv[2]), "\": ", Tcl_PosixError(interp), 1261 NULL); 1262 return TCL_ERROR; 1263 } 1264 Tcl_SetObjResult(interp, contents); 1265 Tcl_DecrRefCount(contents); 1266 return TCL_OK; 1267 } 1268 case FCMD_RENAME: 1269 return TclFileRenameCmd(interp, objc, objv); 1270 case FCMD_ROOTNAME: { 1271 Tcl_Obj *root; 1272 1273 if (objc != 3) { 1274 goto only3Args; 1275 } 1276 root = TclPathPart(interp, objv[2], TCL_PATH_ROOT); 1277 if (root != NULL) { 1278 Tcl_SetObjResult(interp, root); 1279 Tcl_DecrRefCount(root); 1280 return TCL_OK; 1281 } else { 1282 return TCL_ERROR; 1283 } 1284 } 1285 case FCMD_SEPARATOR: 1286 if ((objc < 2) || (objc > 3)) { 1287 Tcl_WrongNumArgs(interp, 2, objv, "?name?"); 1288 return TCL_ERROR; 1289 } 1290 if (objc == 2) { 1291 char *separator = NULL; /* lint */ 1292 1293 switch (tclPlatform) { 1294 case TCL_PLATFORM_UNIX: 1295 separator = "/"; 1296 break; 1297 case TCL_PLATFORM_WINDOWS: 1298 separator = "\\"; 1299 break; 1300 } 1301 Tcl_SetObjResult(interp, Tcl_NewStringObj(separator, 1)); 1302 } else { 1303 Tcl_Obj *separatorObj = Tcl_FSPathSeparator(objv[2]); 1304 1305 if (separatorObj == NULL) { 1306 Tcl_SetResult(interp, "Unrecognised path", TCL_STATIC); 1307 return TCL_ERROR; 1308 } 1309 Tcl_SetObjResult(interp, separatorObj); 1310 } 1311 return TCL_OK; 1312 case FCMD_SPLIT: { 1313 Tcl_Obj *res; 1314 1315 if (objc != 3) { 1316 goto only3Args; 1317 } 1318 res = Tcl_FSSplitPath(objv[2], NULL); 1319 if (res == NULL) { 1320 /* How can the interp be NULL here?! DKF */ 1321 if (interp != NULL) { 1322 Tcl_AppendResult(interp, "could not read \"", 1323 TclGetString(objv[2]), 1324 "\": no such file or directory", NULL); 1325 } 1326 return TCL_ERROR; 1327 } 1328 Tcl_SetObjResult(interp, res); 1329 return TCL_OK; 1330 } 1331 case FCMD_SYSTEM: { 1332 Tcl_Obj *fsInfo; 1333 1334 if (objc != 3) { 1335 goto only3Args; 1336 } 1337 fsInfo = Tcl_FSFileSystemInfo(objv[2]); 1338 if (fsInfo == NULL) { 1339 Tcl_SetResult(interp, "Unrecognised path", TCL_STATIC); 1340 return TCL_ERROR; 1341 } 1342 Tcl_SetObjResult(interp, fsInfo); 1343 return TCL_OK; 1344 } 1345 case FCMD_TAIL: { 1346 Tcl_Obj *dirPtr; 1347 1348 if (objc != 3) { 1349 goto only3Args; 1350 } 1351 dirPtr = TclPathPart(interp, objv[2], TCL_PATH_TAIL); 1352 if (dirPtr == NULL) { 1353 return TCL_ERROR; 1354 } 1355 Tcl_SetObjResult(interp, dirPtr); 1356 Tcl_DecrRefCount(dirPtr); 1357 return TCL_OK; 1358 } 1359 case FCMD_VOLUMES: 1360 if (objc != 2) { 1361 Tcl_WrongNumArgs(interp, 2, objv, NULL); 1362 return TCL_ERROR; 1363 } 1364 Tcl_SetObjResult(interp, Tcl_FSListVolumes()); 1365 return TCL_OK; 1366 case FCMD_WRITABLE: 1367 if (objc != 3) { 1368 goto only3Args; 1369 } 1370 return CheckAccess(interp, objv[2], W_OK); 1371 } 1372 1373 only3Args: 1374 Tcl_WrongNumArgs(interp, 2, objv, "name"); 1375 return TCL_ERROR; 1376} 1377 1378/* 1379 *--------------------------------------------------------------------------- 1380 * 1381 * CheckAccess -- 1382 * 1383 * Utility procedure used by Tcl_FileObjCmd() to query file attributes 1384 * available through the access() system call. 1385 * 1386 * Results: 1387 * Always returns TCL_OK. Sets interp's result to boolean true or false 1388 * depending on whether the file has the specified attribute. 1389 * 1390 * Side effects: 1391 * None. 1392 * 1393 *--------------------------------------------------------------------------- 1394 */ 1395 1396static int 1397CheckAccess( 1398 Tcl_Interp *interp, /* Interp for status return. Must not be 1399 * NULL. */ 1400 Tcl_Obj *pathPtr, /* Name of file to check. */ 1401 int mode) /* Attribute to check; passed as argument to 1402 * access(). */ 1403{ 1404 int value; 1405 1406 if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) { 1407 value = 0; 1408 } else { 1409 value = (Tcl_FSAccess(pathPtr, mode) == 0); 1410 } 1411 Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); 1412 1413 return TCL_OK; 1414} 1415 1416/* 1417 *--------------------------------------------------------------------------- 1418 * 1419 * GetStatBuf -- 1420 * 1421 * Utility procedure used by Tcl_FileObjCmd() to query file attributes 1422 * available through the stat() or lstat() system call. 1423 * 1424 * Results: 1425 * The return value is TCL_OK if the specified file exists and can be 1426 * stat'ed, TCL_ERROR otherwise. If TCL_ERROR is returned, an error 1427 * message is left in interp's result. If TCL_OK is returned, *statPtr is 1428 * filled with information about the specified file. 1429 * 1430 * Side effects: 1431 * None. 1432 * 1433 *--------------------------------------------------------------------------- 1434 */ 1435 1436static int 1437GetStatBuf( 1438 Tcl_Interp *interp, /* Interp for error return. May be NULL. */ 1439 Tcl_Obj *pathPtr, /* Path name to examine. */ 1440 Tcl_FSStatProc *statProc, /* Either stat() or lstat() depending on 1441 * desired behavior. */ 1442 Tcl_StatBuf *statPtr) /* Filled with info about file obtained by 1443 * calling (*statProc)(). */ 1444{ 1445 int status; 1446 1447 if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) { 1448 return TCL_ERROR; 1449 } 1450 1451 status = (*statProc)(pathPtr, statPtr); 1452 1453 if (status < 0) { 1454 if (interp != NULL) { 1455 Tcl_AppendResult(interp, "could not read \"", 1456 TclGetString(pathPtr), "\": ", 1457 Tcl_PosixError(interp), NULL); 1458 } 1459 return TCL_ERROR; 1460 } 1461 return TCL_OK; 1462} 1463 1464/* 1465 *---------------------------------------------------------------------- 1466 * 1467 * StoreStatData -- 1468 * 1469 * This is a utility procedure that breaks out the fields of a "stat" 1470 * structure and stores them in textual form into the elements of an 1471 * associative array. 1472 * 1473 * Results: 1474 * Returns a standard Tcl return value. If an error occurs then a message 1475 * is left in interp's result. 1476 * 1477 * Side effects: 1478 * Elements of the associative array given by "varName" are modified. 1479 * 1480 *---------------------------------------------------------------------- 1481 */ 1482 1483static int 1484StoreStatData( 1485 Tcl_Interp *interp, /* Interpreter for error reports. */ 1486 Tcl_Obj *varName, /* Name of associative array variable in which 1487 * to store stat results. */ 1488 Tcl_StatBuf *statPtr) /* Pointer to buffer containing stat data to 1489 * store in varName. */ 1490{ 1491 Tcl_Obj *field, *value; 1492 register unsigned short mode; 1493 1494 /* 1495 * Assume Tcl_ObjSetVar2() does not keep a copy of the field name! 1496 * 1497 * Might be a better idea to call Tcl_SetVar2Ex() instead, except we want 1498 * to have an object (i.e. possibly cached) array variable name but a 1499 * string element name, so no API exists. Messy. 1500 */ 1501 1502#define STORE_ARY(fieldName, object) \ 1503 TclNewLiteralStringObj(field, fieldName); \ 1504 Tcl_IncrRefCount(field); \ 1505 value = (object); \ 1506 if (Tcl_ObjSetVar2(interp,varName,field,value,TCL_LEAVE_ERR_MSG)==NULL) { \ 1507 TclDecrRefCount(field); \ 1508 return TCL_ERROR; \ 1509 } \ 1510 TclDecrRefCount(field); 1511 1512 /* 1513 * Watch out porters; the inode is meant to be an *unsigned* value, so the 1514 * cast might fail when there isn't a real arithmentic 'long long' type... 1515 */ 1516 1517 STORE_ARY("dev", Tcl_NewLongObj((long)statPtr->st_dev)); 1518 STORE_ARY("ino", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_ino)); 1519 STORE_ARY("nlink", Tcl_NewLongObj((long)statPtr->st_nlink)); 1520 STORE_ARY("uid", Tcl_NewLongObj((long)statPtr->st_uid)); 1521 STORE_ARY("gid", Tcl_NewLongObj((long)statPtr->st_gid)); 1522 STORE_ARY("size", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_size)); 1523#ifdef HAVE_STRUCT_STAT_ST_BLOCKS 1524 STORE_ARY("blocks", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_blocks)); 1525#endif 1526#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE 1527 STORE_ARY("blksize", Tcl_NewLongObj((long)statPtr->st_blksize)); 1528#endif 1529 STORE_ARY("atime", Tcl_NewLongObj((long)statPtr->st_atime)); 1530 STORE_ARY("mtime", Tcl_NewLongObj((long)statPtr->st_mtime)); 1531 STORE_ARY("ctime", Tcl_NewLongObj((long)statPtr->st_ctime)); 1532 mode = (unsigned short) statPtr->st_mode; 1533 STORE_ARY("mode", Tcl_NewIntObj(mode)); 1534 STORE_ARY("type", Tcl_NewStringObj(GetTypeFromMode(mode), -1)); 1535#undef STORE_ARY 1536 1537 return TCL_OK; 1538} 1539 1540/* 1541 *---------------------------------------------------------------------- 1542 * 1543 * GetTypeFromMode -- 1544 * 1545 * Given a mode word, returns a string identifying the type of a file. 1546 * 1547 * Results: 1548 * A static text string giving the file type from mode. 1549 * 1550 * Side effects: 1551 * None. 1552 * 1553 *---------------------------------------------------------------------- 1554 */ 1555 1556static char * 1557GetTypeFromMode( 1558 int mode) 1559{ 1560 if (S_ISREG(mode)) { 1561 return "file"; 1562 } else if (S_ISDIR(mode)) { 1563 return "directory"; 1564 } else if (S_ISCHR(mode)) { 1565 return "characterSpecial"; 1566 } else if (S_ISBLK(mode)) { 1567 return "blockSpecial"; 1568 } else if (S_ISFIFO(mode)) { 1569 return "fifo"; 1570#ifdef S_ISLNK 1571 } else if (S_ISLNK(mode)) { 1572 return "link"; 1573#endif 1574#ifdef S_ISSOCK 1575 } else if (S_ISSOCK(mode)) { 1576 return "socket"; 1577#endif 1578 } 1579 return "unknown"; 1580} 1581 1582/* 1583 *---------------------------------------------------------------------- 1584 * 1585 * Tcl_ForObjCmd -- 1586 * 1587 * This procedure is invoked to process the "for" Tcl command. See the 1588 * user documentation for details on what it does. 1589 * 1590 * With the bytecode compiler, this procedure is only called when a 1591 * command name is computed at runtime, and is "for" or the name to which 1592 * "for" was renamed: e.g., 1593 * "set z for; $z {set i 0} {$i<100} {incr i} {puts $i}" 1594 * 1595 * Results: 1596 * A standard Tcl result. 1597 * 1598 * Side effects: 1599 * See the user documentation. 1600 * 1601 *---------------------------------------------------------------------- 1602 */ 1603 1604 /* ARGSUSED */ 1605int 1606Tcl_ForObjCmd( 1607 ClientData dummy, /* Not used. */ 1608 Tcl_Interp *interp, /* Current interpreter. */ 1609 int objc, /* Number of arguments. */ 1610 Tcl_Obj *CONST objv[]) /* Argument objects. */ 1611{ 1612 int result, value; 1613 Interp *iPtr = (Interp *) interp; 1614 1615 if (objc != 5) { 1616 Tcl_WrongNumArgs(interp, 1, objv, "start test next command"); 1617 return TCL_ERROR; 1618 } 1619 1620 /* 1621 * TIP #280. Make invoking context available to initial script. 1622 */ 1623 1624 result = TclEvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr, 1); 1625 if (result != TCL_OK) { 1626 if (result == TCL_ERROR) { 1627 Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)"); 1628 } 1629 return result; 1630 } 1631 while (1) { 1632 /* 1633 * We need to reset the result before passing it off to 1634 * Tcl_ExprBooleanObj. Otherwise, any error message will be appended 1635 * to the result of the last evaluation. 1636 */ 1637 1638 Tcl_ResetResult(interp); 1639 result = Tcl_ExprBooleanObj(interp, objv[2], &value); 1640 if (result != TCL_OK) { 1641 return result; 1642 } 1643 if (!value) { 1644 break; 1645 } 1646 1647 /* 1648 * TIP #280. Make invoking context available to loop body. 1649 */ 1650 1651 result = TclEvalObjEx(interp, objv[4], 0, iPtr->cmdFramePtr, 4); 1652 if ((result != TCL_OK) && (result != TCL_CONTINUE)) { 1653 if (result == TCL_ERROR) { 1654 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( 1655 "\n (\"for\" body line %d)", interp->errorLine)); 1656 } 1657 break; 1658 } 1659 1660 /* 1661 * TIP #280. Make invoking context available to next script. 1662 */ 1663 1664 result = TclEvalObjEx(interp, objv[3], 0, iPtr->cmdFramePtr, 3); 1665 if (result == TCL_BREAK) { 1666 break; 1667 } else if (result != TCL_OK) { 1668 if (result == TCL_ERROR) { 1669 Tcl_AddErrorInfo(interp, "\n (\"for\" loop-end command)"); 1670 } 1671 return result; 1672 } 1673 } 1674 if (result == TCL_BREAK) { 1675 result = TCL_OK; 1676 } 1677 if (result == TCL_OK) { 1678 Tcl_ResetResult(interp); 1679 } 1680 return result; 1681} 1682 1683/* 1684 *---------------------------------------------------------------------- 1685 * 1686 * Tcl_ForeachObjCmd -- 1687 * 1688 * This object-based procedure is invoked to process the "foreach" Tcl 1689 * command. See the user documentation for details on what it does. 1690 * 1691 * Results: 1692 * A standard Tcl object result. 1693 * 1694 * Side effects: 1695 * See the user documentation. 1696 * 1697 *---------------------------------------------------------------------- 1698 */ 1699 1700 /* ARGSUSED */ 1701int 1702Tcl_ForeachObjCmd( 1703 ClientData dummy, /* Not used. */ 1704 Tcl_Interp *interp, /* Current interpreter. */ 1705 int objc, /* Number of arguments. */ 1706 Tcl_Obj *CONST objv[]) /* Argument objects. */ 1707{ 1708 int result = TCL_OK; 1709 int i; /* i selects a value list */ 1710 int j, maxj; /* Number of loop iterations */ 1711 int v; /* v selects a loop variable */ 1712 int numLists = (objc-2)/2; /* Count of value lists */ 1713 Tcl_Obj *bodyPtr; 1714 Interp *iPtr = (Interp *) interp; 1715 1716 int *index; /* Array of value list indices */ 1717 int *varcList; /* # loop variables per list */ 1718 Tcl_Obj ***varvList; /* Array of var name lists */ 1719 Tcl_Obj **vCopyList; /* Copies of var name list arguments */ 1720 int *argcList; /* Array of value list sizes */ 1721 Tcl_Obj ***argvList; /* Array of value lists */ 1722 Tcl_Obj **aCopyList; /* Copies of value list arguments */ 1723 1724 if (objc < 4 || (objc%2 != 0)) { 1725 Tcl_WrongNumArgs(interp, 1, objv, 1726 "varList list ?varList list ...? command"); 1727 return TCL_ERROR; 1728 } 1729 1730 /* 1731 * Manage numList parallel value lists. 1732 * argvList[i] is a value list counted by argcList[i]l; 1733 * varvList[i] is the list of variables associated with the value list; 1734 * varcList[i] is the number of variables associated with the value list; 1735 * index[i] is the current pointer into the value list argvList[i]. 1736 */ 1737 1738 index = (int *) TclStackAlloc(interp, 3 * numLists * sizeof(int)); 1739 varcList = index + numLists; 1740 argcList = varcList + numLists; 1741 memset(index, 0, 3 * numLists * sizeof(int)); 1742 1743 varvList = (Tcl_Obj ***) 1744 TclStackAlloc(interp, 2 * numLists * sizeof(Tcl_Obj **)); 1745 argvList = varvList + numLists; 1746 memset(varvList, 0, 2 * numLists * sizeof(Tcl_Obj **)); 1747 1748 vCopyList = (Tcl_Obj **) 1749 TclStackAlloc(interp, 2 * numLists * sizeof(Tcl_Obj *)); 1750 aCopyList = vCopyList + numLists; 1751 memset(vCopyList, 0, 2 * numLists * sizeof(Tcl_Obj *)); 1752 1753 /* 1754 * Break up the value lists and variable lists into elements. 1755 */ 1756 1757 maxj = 0; 1758 for (i=0 ; i<numLists ; i++) { 1759 1760 vCopyList[i] = TclListObjCopy(interp, objv[1+i*2]); 1761 if (vCopyList[i] == NULL) { 1762 result = TCL_ERROR; 1763 goto done; 1764 } 1765 TclListObjGetElements(NULL, vCopyList[i], &varcList[i], &varvList[i]); 1766 if (varcList[i] < 1) { 1767 Tcl_AppendResult(interp, "foreach varlist is empty", NULL); 1768 result = TCL_ERROR; 1769 goto done; 1770 } 1771 1772 aCopyList[i] = TclListObjCopy(interp, objv[2+i*2]); 1773 if (aCopyList[i] == NULL) { 1774 result = TCL_ERROR; 1775 goto done; 1776 } 1777 TclListObjGetElements(NULL, aCopyList[i], &argcList[i], &argvList[i]); 1778 1779 j = argcList[i] / varcList[i]; 1780 if ((argcList[i] % varcList[i]) != 0) { 1781 j++; 1782 } 1783 if (j > maxj) { 1784 maxj = j; 1785 } 1786 } 1787 1788 /* 1789 * Iterate maxj times through the lists in parallel. If some value lists 1790 * run out of values, set loop vars to "" 1791 */ 1792 1793 bodyPtr = objv[objc-1]; 1794 for (j=0 ; j<maxj ; j++) { 1795 for (i=0 ; i<numLists ; i++) { 1796 for (v=0 ; v<varcList[i] ; v++) { 1797 int k = index[i]++; 1798 Tcl_Obj *valuePtr, *varValuePtr; 1799 1800 if (k < argcList[i]) { 1801 valuePtr = argvList[i][k]; 1802 } else { 1803 valuePtr = Tcl_NewObj(); /* Empty string */ 1804 } 1805 varValuePtr = Tcl_ObjSetVar2(interp, varvList[i][v], NULL, 1806 valuePtr, TCL_LEAVE_ERR_MSG); 1807 if (varValuePtr == NULL) { 1808 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( 1809 "\n (setting foreach loop variable \"%s\")", 1810 TclGetString(varvList[i][v]))); 1811 result = TCL_ERROR; 1812 goto done; 1813 } 1814 } 1815 } 1816 1817 /* 1818 * TIP #280. Make invoking context available to loop body. 1819 */ 1820 1821 result = TclEvalObjEx(interp, bodyPtr, 0, iPtr->cmdFramePtr, objc-1); 1822 if (result != TCL_OK) { 1823 if (result == TCL_CONTINUE) { 1824 result = TCL_OK; 1825 } else if (result == TCL_BREAK) { 1826 result = TCL_OK; 1827 break; 1828 } else if (result == TCL_ERROR) { 1829 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( 1830 "\n (\"foreach\" body line %d)", 1831 interp->errorLine)); 1832 break; 1833 } else { 1834 break; 1835 } 1836 } 1837 } 1838 if (result == TCL_OK) { 1839 Tcl_ResetResult(interp); 1840 } 1841 1842 done: 1843 for (i=0 ; i<numLists ; i++) { 1844 if (vCopyList[i]) { 1845 Tcl_DecrRefCount(vCopyList[i]); 1846 } 1847 if (aCopyList[i]) { 1848 Tcl_DecrRefCount(aCopyList[i]); 1849 } 1850 } 1851 TclStackFree(interp, vCopyList); /* Tcl_Obj * arrays */ 1852 TclStackFree(interp, varvList); /* Tcl_Obj ** arrays */ 1853 TclStackFree(interp, index); /* int arrays */ 1854 return result; 1855} 1856 1857/* 1858 *---------------------------------------------------------------------- 1859 * 1860 * Tcl_FormatObjCmd -- 1861 * 1862 * This procedure is invoked to process the "format" Tcl command. See 1863 * the user documentation for details on what it does. 1864 * 1865 * Results: 1866 * A standard Tcl result. 1867 * 1868 * Side effects: 1869 * See the user documentation. 1870 * 1871 *---------------------------------------------------------------------- 1872 */ 1873 1874 /* ARGSUSED */ 1875int 1876Tcl_FormatObjCmd( 1877 ClientData dummy, /* Not used. */ 1878 Tcl_Interp *interp, /* Current interpreter. */ 1879 int objc, /* Number of arguments. */ 1880 Tcl_Obj *CONST objv[]) /* Argument objects. */ 1881{ 1882 Tcl_Obj *resultPtr; /* Where result is stored finally. */ 1883 1884 if (objc < 2) { 1885 Tcl_WrongNumArgs(interp, 1, objv, "formatString ?arg arg ...?"); 1886 return TCL_ERROR; 1887 } 1888 1889 resultPtr = Tcl_Format(interp, TclGetString(objv[1]), objc-2, objv+2); 1890 if (resultPtr == NULL) { 1891 return TCL_ERROR; 1892 } 1893 Tcl_SetObjResult(interp, resultPtr); 1894 return TCL_OK; 1895} 1896 1897/* 1898 * Local Variables: 1899 * mode: c 1900 * c-basic-offset: 4 1901 * fill-column: 78 1902 * End: 1903 */ 1904