![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to tclCmdAH.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / worm / scsi / tcl|
Return to tclCmdAH.c CVS log | Up to [Research Unix] / researchv10no / cmd / worm / scsi / tcl |
1.1 ! root 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 1987 Regents of the University of California ! 9: * Permission to use, copy, modify, and distribute this ! 10: * software and its documentation for any purpose and without ! 11: * fee is hereby granted, provided that the above copyright ! 12: * notice appear in all copies. The University of California ! 13: * makes no representations about the suitability of this ! 14: * software for any purpose. It is provided "as is" without ! 15: * express or implied warranty. ! 16: */ ! 17: ! 18: #ifndef lint ! 19: static char rcsid[] = "$Header: /sprite/src/lib/tcl/RCS/tclCmdAH.c,v 1.45 90/04/18 17:09:19 ouster Exp $ SPRITE (Berkeley)"; ! 20: #pragma ref rcsid ! 21: #endif not lint ! 22: ! 23: #define _POSIX_SOURCE ! 24: ! 25: #include <ctype.h> ! 26: #include <errno.h> ! 27: #include <signal.h> ! 28: #include <stdio.h> ! 29: #include <stdlib.h> ! 30: #include <unistd.h> ! 31: #include <string.h> ! 32: #include <sys/types.h> ! 33: #include <fcntl.h> ! 34: #include <sys/stat.h> ! 35: #include <sys/wait.h> ! 36: #include "tclInt.h" ! 37: ! 38: extern long lseek(); ! 39: extern char *mktemp(); ! 40: ! 41: /* ! 42: *---------------------------------------------------------------------- ! 43: * ! 44: * Tcl_BreakCmd -- ! 45: * ! 46: * This procedure is invoked to process the "break" Tcl command. ! 47: * See the user documentation for details on what it does. ! 48: * ! 49: * Results: ! 50: * A standard Tcl result. ! 51: * ! 52: * Side effects: ! 53: * See the user documentation. ! 54: * ! 55: *---------------------------------------------------------------------- ! 56: */ ! 57: ! 58: /* ARGSUSED */ ! 59: int ! 60: Tcl_BreakCmd(dummy, interp, argc, argv) ! 61: ClientData dummy; /* Not used. */ ! 62: Tcl_Interp *interp; /* Current interpreter. */ ! 63: int argc; /* Number of arguments. */ ! 64: char **argv; /* Argument strings. */ ! 65: { ! 66: #pragma ref dummy ! 67: if (argc != 1) { ! 68: sprintf(interp->result, "too many args: should be \"%.50s\"", argv[0]); ! 69: return TCL_ERROR; ! 70: } ! 71: return TCL_BREAK; ! 72: } ! 73: ! 74: /* ! 75: *---------------------------------------------------------------------- ! 76: * ! 77: * Tcl_CaseCmd -- ! 78: * ! 79: * This procedure is invoked to process the "case" Tcl command. ! 80: * See the user documentation for details on what it does. ! 81: * ! 82: * Results: ! 83: * A standard Tcl result. ! 84: * ! 85: * Side effects: ! 86: * See the user documentation. ! 87: * ! 88: *---------------------------------------------------------------------- ! 89: */ ! 90: ! 91: /* ARGSUSED */ ! 92: int ! 93: Tcl_CaseCmd(dummy, interp, argc, argv) ! 94: ClientData dummy; /* Not used. */ ! 95: Tcl_Interp *interp; /* Current interpreter. */ ! 96: int argc; /* Number of arguments. */ ! 97: char **argv; /* Argument strings. */ ! 98: { ! 99: #pragma ref dummy ! 100: int i, result; ! 101: int body; ! 102: char *string; ! 103: ! 104: if (argc < 4) { ! 105: sprintf(interp->result, ! 106: "%s \"%.50s string [in] patList body ... [default body]\"", ! 107: "not enough args: should be", argv[0]); ! 108: return TCL_ERROR; ! 109: } ! 110: string = argv[1]; ! 111: body = NULL; ! 112: if (strcmp(argv[2], "in") == 0) { ! 113: i = 3; ! 114: } else { ! 115: i = 2; ! 116: } ! 117: for (; i < argc; i += 2) { ! 118: int patArgc, j; ! 119: char **patArgv; ! 120: register char *p; ! 121: ! 122: if (i == (argc-1)) { ! 123: sprintf(interp->result, "extra pattern with no body in \"%.50s\"", ! 124: argv[0]); ! 125: return TCL_ERROR; ! 126: } ! 127: ! 128: /* ! 129: * Check for special case of single pattern (no list) with ! 130: * no backslash sequences. ! 131: */ ! 132: ! 133: for (p = argv[i]; *p != 0; p++) { ! 134: if (isspace(*p) || (*p == '\\')) { ! 135: break; ! 136: } ! 137: } ! 138: if (*p == 0) { ! 139: if ((*argv[i] == 'd') && (strcmp(argv[i], "default") == 0)) { ! 140: body = i+1; ! 141: } ! 142: if (Tcl_StringMatch(string, argv[i])) { ! 143: body = i+1; ! 144: goto match; ! 145: } ! 146: continue; ! 147: } ! 148: ! 149: /* ! 150: * Break up pattern lists, then check each of the patterns ! 151: * in the list. ! 152: */ ! 153: ! 154: result = Tcl_SplitList(interp, argv[i], &patArgc, &patArgv); ! 155: if (result != TCL_OK) { ! 156: return result; ! 157: } ! 158: for (j = 0; j < patArgc; j++) { ! 159: if (Tcl_StringMatch(string, patArgv[j])) { ! 160: body = i+1; ! 161: break; ! 162: } ! 163: } ! 164: free((char *) patArgv); ! 165: if (j < patArgc) { ! 166: break; ! 167: } ! 168: } ! 169: ! 170: match: ! 171: if (body != NULL) { ! 172: result = Tcl_Eval(interp, argv[body], 0, (char **) NULL); ! 173: if (result == TCL_ERROR) { ! 174: char msg[100]; ! 175: sprintf(msg, " (\"%.50s\" arm line %d)", argv[i], ! 176: interp->errorLine); ! 177: Tcl_AddErrorInfo(interp, msg); ! 178: } ! 179: return result; ! 180: } ! 181: ! 182: /* ! 183: * Nothing matched: return nothing. ! 184: */ ! 185: return TCL_OK; ! 186: } ! 187: ! 188: /* ! 189: *---------------------------------------------------------------------- ! 190: * ! 191: * Tcl_CatchCmd -- ! 192: * ! 193: * This procedure is invoked to process the "catch" Tcl command. ! 194: * See the user documentation for details on what it does. ! 195: * ! 196: * Results: ! 197: * A standard Tcl result. ! 198: * ! 199: * Side effects: ! 200: * See the user documentation. ! 201: * ! 202: *---------------------------------------------------------------------- ! 203: */ ! 204: ! 205: /* ARGSUSED */ ! 206: int ! 207: Tcl_CatchCmd(dummy, interp, argc, argv) ! 208: ClientData dummy; /* Not used. */ ! 209: Tcl_Interp *interp; /* Current interpreter. */ ! 210: int argc; /* Number of arguments. */ ! 211: char **argv; /* Argument strings. */ ! 212: { ! 213: #pragma ref dummy ! 214: int result; ! 215: ! 216: if ((argc != 2) && (argc != 3)) { ! 217: sprintf(interp->result, ! 218: "wrong # args: should be \"%.50s command [varName]\"", ! 219: argv[0]); ! 220: return TCL_ERROR; ! 221: } ! 222: result = Tcl_Eval(interp, argv[1], 0, (char **) NULL); ! 223: if (argc == 3) { ! 224: Tcl_SetVar(interp, argv[2], interp->result, 0); ! 225: } ! 226: Tcl_Return(interp, (char *) NULL, TCL_STATIC); ! 227: sprintf(interp->result, "%d", result); ! 228: return TCL_OK; ! 229: } ! 230: ! 231: /* ! 232: *---------------------------------------------------------------------- ! 233: * ! 234: * Tcl_ConcatCmd -- ! 235: * ! 236: * This procedure is invoked to process the "concat" Tcl command. ! 237: * See the user documentation for details on what it does. ! 238: * ! 239: * Results: ! 240: * A standard Tcl result. ! 241: * ! 242: * Side effects: ! 243: * See the user documentation. ! 244: * ! 245: *---------------------------------------------------------------------- ! 246: */ ! 247: ! 248: /* ARGSUSED */ ! 249: int ! 250: Tcl_ConcatCmd(dummy, interp, argc, argv) ! 251: ClientData dummy; /* Not used. */ ! 252: Tcl_Interp *interp; /* Current interpreter. */ ! 253: int argc; /* Number of arguments. */ ! 254: char **argv; /* Argument strings. */ ! 255: { ! 256: #pragma ref dummy ! 257: if (argc == 1) { ! 258: sprintf(interp->result, ! 259: "not enough args: should be \"%.50s arg [arg ...]\"", ! 260: argv[0]); ! 261: return TCL_ERROR; ! 262: } ! 263: ! 264: interp->result = Tcl_Concat(argc-1, argv+1); ! 265: interp->dynamic = 1; ! 266: return TCL_OK; ! 267: } ! 268: ! 269: /* ! 270: *---------------------------------------------------------------------- ! 271: * ! 272: * Tcl_ContinueCmd -- ! 273: * ! 274: * This procedure is invoked to process the "continue" Tcl command. ! 275: * See the user documentation for details on what it does. ! 276: * ! 277: * Results: ! 278: * A standard Tcl result. ! 279: * ! 280: * Side effects: ! 281: * See the user documentation. ! 282: * ! 283: *---------------------------------------------------------------------- ! 284: */ ! 285: ! 286: /* ARGSUSED */ ! 287: int ! 288: Tcl_ContinueCmd(dummy, interp, argc, argv) ! 289: ClientData dummy; /* Not used. */ ! 290: Tcl_Interp *interp; /* Current interpreter. */ ! 291: int argc; /* Number of arguments. */ ! 292: char **argv; /* Argument strings. */ ! 293: { ! 294: #pragma ref dummy ! 295: if (argc != 1) { ! 296: sprintf(interp->result, "too many args: should be \"%.50s\"", argv[0]); ! 297: return TCL_ERROR; ! 298: } ! 299: return TCL_CONTINUE; ! 300: } ! 301: ! 302: /* ! 303: *---------------------------------------------------------------------- ! 304: * ! 305: * Tcl_ErrorCmd -- ! 306: * ! 307: * This procedure is invoked to process the "error" Tcl command. ! 308: * See the user documentation for details on what it does. ! 309: * ! 310: * Results: ! 311: * A standard Tcl result. ! 312: * ! 313: * Side effects: ! 314: * See the user documentation. ! 315: * ! 316: *---------------------------------------------------------------------- ! 317: */ ! 318: ! 319: /* ARGSUSED */ ! 320: int ! 321: Tcl_ErrorCmd(dummy, interp, argc, argv) ! 322: ClientData dummy; /* Not used. */ ! 323: Tcl_Interp *interp; /* Current interpreter. */ ! 324: int argc; /* Number of arguments. */ ! 325: char **argv; /* Argument strings. */ ! 326: { ! 327: #pragma ref dummy ! 328: Interp *iPtr = (Interp *) interp; ! 329: ! 330: if ((argc != 2) && (argc != 3)) { ! 331: sprintf(interp->result, "wrong # args: should be \"%.50s message [errorInfo]\"", ! 332: argv[0]); ! 333: return TCL_ERROR; ! 334: } ! 335: if (argc == 3) { ! 336: Tcl_AddErrorInfo(interp, argv[2]); ! 337: iPtr->flags |= ERR_ALREADY_LOGGED; ! 338: } ! 339: Tcl_Return(interp, argv[1], TCL_VOLATILE); ! 340: return TCL_ERROR; ! 341: } ! 342: ! 343: /* ! 344: *---------------------------------------------------------------------- ! 345: * ! 346: * Tcl_EvalCmd -- ! 347: * ! 348: * This procedure is invoked to process the "eval" Tcl command. ! 349: * See the user documentation for details on what it does. ! 350: * ! 351: * Results: ! 352: * A standard Tcl result. ! 353: * ! 354: * Side effects: ! 355: * See the user documentation. ! 356: * ! 357: *---------------------------------------------------------------------- ! 358: */ ! 359: ! 360: /* ARGSUSED */ ! 361: int ! 362: Tcl_EvalCmd(dummy, interp, argc, argv) ! 363: ClientData dummy; /* Not used. */ ! 364: Tcl_Interp *interp; /* Current interpreter. */ ! 365: int argc; /* Number of arguments. */ ! 366: char **argv; /* Argument strings. */ ! 367: { ! 368: #pragma ref dummy ! 369: int result; ! 370: char *cmd; ! 371: ! 372: if (argc < 2) { ! 373: sprintf(interp->result, ! 374: "not enough args: should be \"%.50s arg [arg ...]\"", ! 375: argv[0]); ! 376: return TCL_ERROR; ! 377: } ! 378: if (argc == 2) { ! 379: result = Tcl_Eval(interp, argv[1], 0, (char **) NULL); ! 380: } else { ! 381: ! 382: /* ! 383: * More than one argument: concatenate them together with spaces ! 384: * between, then evaluate the result. ! 385: */ ! 386: ! 387: cmd = Tcl_Concat(argc-1, argv+1); ! 388: result = Tcl_Eval(interp, cmd, 0, (char **) NULL); ! 389: free(cmd); ! 390: } ! 391: if (result == TCL_ERROR) { ! 392: char msg[60]; ! 393: sprintf(msg, " (\"eval\" body line %d)", interp->errorLine); ! 394: Tcl_AddErrorInfo(interp, msg); ! 395: } ! 396: return result; ! 397: } ! 398: ! 399: /* ! 400: *---------------------------------------------------------------------- ! 401: * ! 402: * Tcl_ExecCmd -- ! 403: * ! 404: * This procedure is invoked to process the "exec" Tcl command. ! 405: * See the user documentation for details on what it does. ! 406: * ! 407: * Results: ! 408: * A standard Tcl result. ! 409: * ! 410: * Side effects: ! 411: * See the user documentation. ! 412: * ! 413: *---------------------------------------------------------------------- ! 414: */ ! 415: ! 416: /* ARGSUSED */ ! 417: int ! 418: Tcl_ExecCmd(dummy, interp, argc, argv) ! 419: ClientData dummy; /* Not used. */ ! 420: Tcl_Interp *interp; /* Current interpreter. */ ! 421: int argc; /* Number of arguments. */ ! 422: char **argv; /* Argument strings. */ ! 423: { ! 424: #pragma ref dummy ! 425: char *input = ""; /* Points to the input remaining to ! 426: * send to the child process. */ ! 427: int inputSize; /* # of bytes of input. */ ! 428: #define MAX_PIPE_INPUT 4095 ! 429: #define TMP_FILE_NAME "/tmp/tcl.XXXXXX" ! 430: char *output = NULL; /* Output received from child. */ ! 431: int outputSize; /* Number of valid bytes at output. */ ! 432: int outputSpace; /* Total space available at output. */ ! 433: int stdIn[2], stdOut[2], count, result, i; ! 434: int pid = -1; /* -1 means child process doesn't ! 435: * exist (yet). Non-zero gives its ! 436: * id (0 only in child). */ ! 437: int status; ! 438: char *cmdName, *execName; ! 439: ! 440: /* ! 441: * Look through the arguments for a standard input specification ! 442: * ("< value" in two arguments). If found, collapse it out. ! 443: * Shuffle all the arguments back over the "exec" argument, so that ! 444: * there's room for a NULL argument at the end. ! 445: */ ! 446: ! 447: cmdName = argv[0]; ! 448: for (i = 1; i < argc; i++) { ! 449: argv[i-1] = argv[i]; ! 450: if ((argv[i][0] != '<') || (argv[i][1] != 0)) { ! 451: continue; ! 452: } ! 453: i++; ! 454: if (i >= argc) { ! 455: sprintf(interp->result, ! 456: "specified \"<\" but no input in \"%.50s\" command", ! 457: cmdName); ! 458: return TCL_ERROR; ! 459: } ! 460: input = argv[i]; ! 461: for (i++; i < argc; i++) { ! 462: argv[i-3] = argv[i]; ! 463: } ! 464: argc -= 2; ! 465: } ! 466: ! 467: argc -= 1; /* Drop "exec" argument. */ ! 468: argv[argc] = NULL; ! 469: if (argc < 1) { ! 470: sprintf(interp->result, "not enough arguments to \"%.50s\" command", ! 471: cmdName); ! 472: return TCL_ERROR; ! 473: } ! 474: execName = Tcl_TildeSubst(interp, argv[0]); ! 475: if (execName == NULL) { ! 476: return TCL_ERROR; ! 477: } ! 478: ! 479: /* ! 480: * Set up the input stream for child. Use a pipe if the amount of ! 481: * input data is small enough for us to write it to the pipe without ! 482: * overflowing the pipe and blocking. If there's too much input data, ! 483: * then write it to a temporary file. ! 484: */ ! 485: ! 486: stdIn[0] = stdIn[1] = stdOut[0] = stdOut[1] = -1; ! 487: inputSize = strlen(input); ! 488: if (inputSize <= MAX_PIPE_INPUT) { ! 489: if (pipe(stdIn) < 0) { ! 490: sprintf(interp->result, ! 491: "couldn't create input pipe for \"%.50s\" command: %.50s", ! 492: cmdName, strerror(errno)); ! 493: result = TCL_ERROR; ! 494: goto cleanup; ! 495: } ! 496: if (write(stdIn[1], input, inputSize) != inputSize) { ! 497: sprintf(interp->result, ! 498: "couldn't write pipe input for command: %.50s", ! 499: strerror(errno)); ! 500: result = TCL_ERROR; ! 501: goto cleanup; ! 502: } ! 503: close(stdIn[1]); ! 504: stdIn[1] = -1; ! 505: } else { ! 506: char tmp[L_tmpnam]; ! 507: tmpnam(tmp); ! 508: stdIn[0] = open(tmp, O_RDWR|O_CREAT, 0); ! 509: if (stdIn[0] < 0) { ! 510: sprintf(interp->result, ! 511: "couldn't create input file for \"%.50s\" command: %.50s", ! 512: cmdName, strerror(errno)); ! 513: result = TCL_ERROR; ! 514: goto cleanup; ! 515: } ! 516: if (write(stdIn[0], input, inputSize) != inputSize) { ! 517: sprintf(interp->result, ! 518: "couldn't write file input for command: %.50s", ! 519: strerror(errno)); ! 520: result = TCL_ERROR; ! 521: goto cleanup; ! 522: } ! 523: if ((lseek(stdIn[0], 0L, 0) == -1) || (unlink(tmp) == -1)) { ! 524: sprintf(interp->result, ! 525: "couldn't reset or close input file for command: %.50s", ! 526: strerror(errno)); ! 527: result = TCL_ERROR; ! 528: goto cleanup; ! 529: } ! 530: } ! 531: ! 532: /* ! 533: * Set up an output pipe from the child's stdout/stderr back to ! 534: * us, then fork the child. ! 535: */ ! 536: ! 537: if (pipe(stdOut) < 0) { ! 538: sprintf(interp->result, ! 539: "couldn't create output pipe for \"%.50s\" command", ! 540: cmdName); ! 541: result = TCL_ERROR; ! 542: goto cleanup; ! 543: } ! 544: pid = fork(); ! 545: if (pid == -1) { ! 546: sprintf(interp->result, ! 547: "couldn't fork child for \"%.50s\" command: %.50s", ! 548: cmdName, strerror(errno)); ! 549: result = TCL_ERROR; ! 550: goto cleanup; ! 551: } ! 552: if (pid == 0) { ! 553: char errSpace[100]; ! 554: ! 555: if ((dup2(stdIn[0], 0) == -1) || (dup2(stdOut[1], 1) == -1) ! 556: || (dup2(stdOut[1], 2) == -1)) { ! 557: char *err; ! 558: err = "forked process couldn't set up input/output"; ! 559: write(stdOut[1], err, strlen(err)); ! 560: _exit(1); ! 561: } ! 562: close(stdIn[0]); ! 563: close(stdOut[0]); ! 564: close(stdOut[1]); ! 565: execvp(execName, argv); ! 566: sprintf(errSpace, "couldn't find a \"%.50s\" to execute", argv[0]); ! 567: write(1, errSpace, strlen(errSpace)); ! 568: _exit(1); ! 569: } ! 570: ! 571: /* ! 572: * In the parent, read output from the child until end of file ! 573: * (this should mean that the child has completed and died). ! 574: */ ! 575: ! 576: close(stdIn[0]); ! 577: stdIn[0] = -1; ! 578: close(stdOut[1]); ! 579: stdOut[1] = -1; ! 580: outputSize = 0; ! 581: outputSpace = 0; ! 582: result = -1; ! 583: while (1) { ! 584: if ((outputSpace - outputSize) < 100) { ! 585: char *newOutput; ! 586: ! 587: if (outputSpace == 0) { ! 588: outputSpace = 200; ! 589: } else { ! 590: outputSpace = 2*outputSpace; ! 591: } ! 592: newOutput = (char *) malloc((unsigned) outputSpace); ! 593: if (output != 0) { ! 594: bcopy(output, newOutput, outputSize); ! 595: free(output); ! 596: } ! 597: output = newOutput; ! 598: } ! 599: count = read(stdOut[0], output+outputSize, ! 600: outputSpace-outputSize-1); ! 601: ! 602: if (count == 0) { ! 603: break; ! 604: } ! 605: if (count < 0) { ! 606: sprintf(interp->result, ! 607: "error reading stdout during \"%.50s\": %.50s", ! 608: cmdName, strerror(errno)); ! 609: result = TCL_ERROR; ! 610: goto cleanup; ! 611: } ! 612: outputSize += count; ! 613: } ! 614: ! 615: /* ! 616: * The command is supposedly done now. Terminate the result ! 617: * string and wait for the process really to complete. ! 618: */ ! 619: ! 620: output[outputSize] = 0; ! 621: interp->result = output; ! 622: interp->dynamic = 1; ! 623: ! 624: cleanup: ! 625: if (pid != -1) { ! 626: while (1) { ! 627: int child; ! 628: ! 629: child = wait(&status); ! 630: if (child == -1) { ! 631: sprintf(interp->result, ! 632: "child process disappeared mysteriously"); ! 633: result = TCL_ERROR; ! 634: break; ! 635: } ! 636: if (child == pid) { ! 637: break; ! 638: } ! 639: } ! 640: if (!WIFEXITED(status)) { ! 641: sprintf(interp->result, "command terminated abnormally"); ! 642: result = TCL_ERROR; ! 643: } ! 644: result = status; ! 645: } ! 646: if (stdIn[0] != -1) { ! 647: close(stdIn[0]); ! 648: } ! 649: if (stdIn[1] != -1) { ! 650: close(stdIn[1]); ! 651: } ! 652: if (stdOut[0] != -1) { ! 653: close(stdOut[0]); ! 654: } ! 655: if (stdOut[1] != -1) { ! 656: close(stdOut[1]); ! 657: } ! 658: return result; ! 659: } ! 660: ! 661: /* ! 662: *---------------------------------------------------------------------- ! 663: * ! 664: * Tcl_ExprCmd -- ! 665: * ! 666: * This procedure is invoked to process the "expr" Tcl command. ! 667: * See the user documentation for details on what it does. ! 668: * ! 669: * Results: ! 670: * A standard Tcl result. ! 671: * ! 672: * Side effects: ! 673: * See the user documentation. ! 674: * ! 675: *---------------------------------------------------------------------- ! 676: */ ! 677: ! 678: /* ARGSUSED */ ! 679: int ! 680: Tcl_ExprCmd(dummy, interp, argc, argv) ! 681: ClientData dummy; /* Not used. */ ! 682: Tcl_Interp *interp; /* Current interpreter. */ ! 683: int argc; /* Number of arguments. */ ! 684: char **argv; /* Argument strings. */ ! 685: { ! 686: #pragma ref dummy ! 687: int result, value; ! 688: ! 689: if (argc != 2) { ! 690: sprintf(interp->result, ! 691: "wrong # args: should be \"%.50s expression\"", argv[0]); ! 692: return TCL_ERROR; ! 693: } ! 694: ! 695: result = Tcl_Expr(interp, argv[1], &value); ! 696: if (result != TCL_OK) { ! 697: return result; ! 698: } ! 699: ! 700: /* ! 701: * Turn the integer result back into a string. ! 702: */ ! 703: ! 704: sprintf(interp->result, "%d", value); ! 705: return TCL_OK; ! 706: } ! 707: ! 708: /* ! 709: *---------------------------------------------------------------------- ! 710: * ! 711: * Tcl_FileCmd -- ! 712: * ! 713: * This procedure is invoked to process the "file" Tcl command. ! 714: * See the user documentation for details on what it does. ! 715: * ! 716: * Results: ! 717: * A standard Tcl result. ! 718: * ! 719: * Side effects: ! 720: * See the user documentation. ! 721: * ! 722: *---------------------------------------------------------------------- ! 723: */ ! 724: ! 725: /* ARGSUSED */ ! 726: int ! 727: Tcl_FileCmd(dummy, interp, argc, argv) ! 728: ClientData dummy; /* Not used. */ ! 729: Tcl_Interp *interp; /* Current interpreter. */ ! 730: int argc; /* Number of arguments. */ ! 731: char **argv; /* Argument strings. */ ! 732: { ! 733: #pragma ref dummy ! 734: char *p; ! 735: int length, mode, statOp; ! 736: struct stat statBuf; ! 737: char *fileName; ! 738: ! 739: if (argc != 3) { ! 740: sprintf(interp->result, ! 741: "wrong # args: should be \"%.50s name option\"", argv[0]); ! 742: return TCL_ERROR; ! 743: } ! 744: length = strlen(argv[2]); ! 745: ! 746: /* ! 747: * First handle operations on the file name. ! 748: */ ! 749: ! 750: fileName = Tcl_TildeSubst(interp, argv[1]); ! 751: if ((argv[2][0] == 'd') && (strncmp(argv[2], "dirname", length) == 0)) { ! 752: p = strrchr(fileName, '/'); ! 753: if (p == NULL) { ! 754: interp->result = "."; ! 755: } else if (p == fileName) { ! 756: interp->result = "/"; ! 757: } else { ! 758: *p = 0; ! 759: Tcl_Return(interp, fileName, TCL_VOLATILE); ! 760: *p = '/'; ! 761: } ! 762: return TCL_OK; ! 763: } else if ((argv[2][0] == 'r') && (length >= 2) ! 764: && (strncmp(argv[2], "rootname", length) == 0)) { ! 765: p = strrchr(fileName, '.'); ! 766: if (p == NULL) { ! 767: Tcl_Return(interp, fileName, TCL_VOLATILE); ! 768: } else { ! 769: *p = 0; ! 770: Tcl_Return(interp, fileName, TCL_VOLATILE); ! 771: *p = '.'; ! 772: } ! 773: return TCL_OK; ! 774: } else if ((argv[2][0] == 'e') && (length >= 3) ! 775: && (strncmp(argv[2], "extension", length) == 0)) { ! 776: char *lastSlash; ! 777: ! 778: p = strrchr(fileName, '.'); ! 779: lastSlash = strrchr(fileName, '/'); ! 780: if ((p != NULL) && ((lastSlash == NULL) || (lastSlash < p))) { ! 781: Tcl_Return(interp, p, TCL_VOLATILE); ! 782: } ! 783: return TCL_OK; ! 784: } else if ((argv[2][0] == 't') && (strncmp(argv[2], "tail", length) == 0)) { ! 785: p = strrchr(fileName, '/'); ! 786: if (p != NULL) { ! 787: Tcl_Return(interp, p+1, TCL_VOLATILE); ! 788: } else { ! 789: Tcl_Return(interp, fileName, TCL_VOLATILE); ! 790: } ! 791: return TCL_OK; ! 792: } ! 793: ! 794: /* ! 795: * Next, handle operations that can be satisfied with the "access" ! 796: * kernel call. ! 797: */ ! 798: ! 799: if (fileName == NULL) { ! 800: return TCL_ERROR; ! 801: } ! 802: if ((argv[2][0] == 'r') && (length >= 2) ! 803: && (strncmp(argv[2], "readable", length) == 0)) { ! 804: mode = R_OK; ! 805: checkAccess: ! 806: if (access(fileName, mode) == -1) { ! 807: interp->result = "0"; ! 808: } else { ! 809: interp->result = "1"; ! 810: } ! 811: return TCL_OK; ! 812: } else if ((argv[2][0] == 'w') ! 813: && (strncmp(argv[2], "writable", length) == 0)) { ! 814: mode = W_OK; ! 815: goto checkAccess; ! 816: } else if ((argv[2][0] == 'e') && (length >= 3) ! 817: && (strncmp(argv[2], "executable", length) == 0)) { ! 818: mode = X_OK; ! 819: goto checkAccess; ! 820: } else if ((argv[2][0] == 'e') && (length >= 3) ! 821: && (strncmp(argv[2], "exists", length) == 0)) { ! 822: mode = F_OK; ! 823: goto checkAccess; ! 824: } ! 825: ! 826: /* ! 827: * Lastly, check stuff that requires the file to be stat-ed. ! 828: */ ! 829: ! 830: if ((argv[2][0] == 'o') && (strncmp(argv[2], "owned", length) == 0)) { ! 831: statOp = 0; ! 832: } else if ((argv[2][0] == 'i') && (length >= 3) ! 833: && (strncmp(argv[2], "isfile", length) == 0)) { ! 834: statOp = 1; ! 835: } else if ((argv[2][0] == 'i') && (length >= 3) ! 836: && (strncmp(argv[2], "isdirectory", length) == 0)) { ! 837: statOp = 2; ! 838: } else { ! 839: sprintf(interp->result, "bad \"%.30s\" option \"%.30s\": must be dirname, executable, exists, extension, isdirectory, isfile, owned, readable, root, tail, or writable", ! 840: argv[0], argv[2]); ! 841: return TCL_ERROR; ! 842: } ! 843: if (stat(fileName, &statBuf) == -1) { ! 844: interp->result = "0"; ! 845: return TCL_OK; ! 846: } ! 847: switch (statOp) { ! 848: case 0: ! 849: mode = (geteuid() == statBuf.st_uid); ! 850: break; ! 851: case 1: ! 852: mode = S_ISREG(statBuf.st_mode); ! 853: break; ! 854: case 2: ! 855: mode = S_ISDIR(statBuf.st_mode); ! 856: break; ! 857: } ! 858: if (mode) { ! 859: interp->result = "1"; ! 860: } else { ! 861: interp->result = "0"; ! 862: } ! 863: return TCL_OK; ! 864: } ! 865: ! 866: /* ! 867: *---------------------------------------------------------------------- ! 868: * ! 869: * Tcl_ForCmd -- ! 870: * ! 871: * This procedure is invoked to process the "for" Tcl command. ! 872: * See the user documentation for details on what it does. ! 873: * ! 874: * Results: ! 875: * A standard Tcl result. ! 876: * ! 877: * Side effects: ! 878: * See the user documentation. ! 879: * ! 880: *---------------------------------------------------------------------- ! 881: */ ! 882: ! 883: /* ARGSUSED */ ! 884: int ! 885: Tcl_ForCmd(dummy, interp, argc, argv) ! 886: ClientData dummy; /* Not used. */ ! 887: Tcl_Interp *interp; /* Current interpreter. */ ! 888: int argc; /* Number of arguments. */ ! 889: char **argv; /* Argument strings. */ ! 890: { ! 891: #pragma ref dummy ! 892: int result, value; ! 893: ! 894: if (argc != 5) { ! 895: sprintf(interp->result, ! 896: "wrong # args: should be \"%.50s start test next command\"", ! 897: argv[0]); ! 898: return TCL_ERROR; ! 899: } ! 900: ! 901: result = Tcl_Eval(interp, argv[1], 0, (char **) NULL); ! 902: if (result != TCL_OK) { ! 903: if (result == TCL_ERROR) { ! 904: Tcl_AddErrorInfo(interp, " (\"for\" initial command)"); ! 905: } ! 906: return result; ! 907: } ! 908: while (1) { ! 909: result = Tcl_Expr(interp, argv[2], &value); ! 910: if (result != TCL_OK) { ! 911: return result; ! 912: } ! 913: if (!value) { ! 914: break; ! 915: } ! 916: result = Tcl_Eval(interp, argv[4], 0, (char **) NULL); ! 917: if (result == TCL_CONTINUE) { ! 918: result = TCL_OK; ! 919: } else if (result != TCL_OK) { ! 920: if (result == TCL_ERROR) { ! 921: char msg[60]; ! 922: sprintf(msg, " (\"for\" body line %d)", interp->errorLine); ! 923: Tcl_AddErrorInfo(interp, msg); ! 924: } ! 925: break; ! 926: } ! 927: result = Tcl_Eval(interp, argv[3], 0, (char **) NULL); ! 928: if (result == TCL_BREAK) { ! 929: break; ! 930: } else if (result != TCL_OK) { ! 931: if (result == TCL_ERROR) { ! 932: Tcl_AddErrorInfo(interp, " (\"for\" loop-end command)"); ! 933: } ! 934: return result; ! 935: } ! 936: } ! 937: if (result == TCL_BREAK) { ! 938: result = TCL_OK; ! 939: } ! 940: if (result == TCL_OK) { ! 941: Tcl_Return(interp, (char *) NULL, TCL_STATIC); ! 942: } ! 943: return result; ! 944: } ! 945: ! 946: /* ! 947: *---------------------------------------------------------------------- ! 948: * ! 949: * Tcl_ForeachCmd -- ! 950: * ! 951: * This procedure is invoked to process the "foreach" Tcl command. ! 952: * See the user documentation for details on what it does. ! 953: * ! 954: * Results: ! 955: * A standard Tcl result. ! 956: * ! 957: * Side effects: ! 958: * See the user documentation. ! 959: * ! 960: *---------------------------------------------------------------------- ! 961: */ ! 962: ! 963: /* ARGSUSED */ ! 964: int ! 965: Tcl_ForeachCmd(dummy, interp, argc, argv) ! 966: ClientData dummy; /* Not used. */ ! 967: Tcl_Interp *interp; /* Current interpreter. */ ! 968: int argc; /* Number of arguments. */ ! 969: char **argv; /* Argument strings. */ ! 970: { ! 971: #pragma ref dummy ! 972: int listArgc, i, result; ! 973: char **listArgv; ! 974: ! 975: if (argc != 4) { ! 976: sprintf(interp->result, ! 977: "wrong # args: should be \"%.50s varName list command\"", ! 978: argv[0]); ! 979: return TCL_ERROR; ! 980: } ! 981: ! 982: /* ! 983: * Break the list up into elements, and execute the command once ! 984: * for each value of the element. ! 985: */ ! 986: ! 987: result = Tcl_SplitList(interp, argv[2], &listArgc, &listArgv); ! 988: if (result != TCL_OK) { ! 989: return result; ! 990: } ! 991: for (i = 0; i < listArgc; i++) { ! 992: Tcl_SetVar(interp, argv[1], listArgv[i], 0); ! 993: ! 994: result = Tcl_Eval(interp, argv[3], 0, (char **) NULL); ! 995: if (result != TCL_OK) { ! 996: if (result == TCL_CONTINUE) { ! 997: result = TCL_OK; ! 998: } else if (result == TCL_BREAK) { ! 999: result = TCL_OK; ! 1000: break; ! 1001: } else if (result == TCL_ERROR) { ! 1002: char msg[100]; ! 1003: sprintf(msg, " (\"foreach\" body line %d)", interp->errorLine); ! 1004: Tcl_AddErrorInfo(interp, msg); ! 1005: break; ! 1006: } else { ! 1007: break; ! 1008: } ! 1009: } ! 1010: } ! 1011: free((char *) listArgv); ! 1012: if (result == TCL_OK) { ! 1013: Tcl_Return(interp, (char *) NULL, TCL_STATIC); ! 1014: } ! 1015: return result; ! 1016: } ! 1017: ! 1018: /* ! 1019: *---------------------------------------------------------------------- ! 1020: * ! 1021: * Tcl_FormatCmd -- ! 1022: * ! 1023: * This procedure is invoked to process the "format" Tcl command. ! 1024: * See the user documentation for details on what it does. ! 1025: * ! 1026: * Results: ! 1027: * A standard Tcl result. ! 1028: * ! 1029: * Side effects: ! 1030: * See the user documentation. ! 1031: * ! 1032: *---------------------------------------------------------------------- ! 1033: */ ! 1034: ! 1035: /* ARGSUSED */ ! 1036: int ! 1037: Tcl_FormatCmd(dummy, interp, argc, argv) ! 1038: ClientData dummy; /* Not used. */ ! 1039: Tcl_Interp *interp; /* Current interpreter. */ ! 1040: int argc; /* Number of arguments. */ ! 1041: char **argv; /* Argument strings. */ ! 1042: { ! 1043: #pragma ref dummy ! 1044: register char *format; /* Used to read characters from the format ! 1045: * string. */ ! 1046: char newFormat[40]; /* A new format specifier is generated here. */ ! 1047: int width; /* Field width from field specifier, or 0 if ! 1048: * no width given. */ ! 1049: int precision; /* Field precision from field specifier, or 0 ! 1050: * if no precision given. */ ! 1051: int size; /* Number of bytes needed for result of ! 1052: * conversion, based on type of conversion ! 1053: * ("e", "s", etc.) and width from above. */ ! 1054: char *oneWordValue; /* Used to hold value to pass to sprintf, if ! 1055: * it's a one-word value. */ ! 1056: double twoWordValue; /* Used to hold value to pass to sprintf if ! 1057: * it's a two-word value. */ ! 1058: int useTwoWords; /* 0 means use oneWordValue, 1 means use ! 1059: * twoWordValue. */ ! 1060: char *dst = interp->result; /* Where result is stored. Starts off at ! 1061: * interp->resultSpace, but may get dynamically ! 1062: * re-allocated if this isn't enough. */ ! 1063: int dstSize = 0; /* Number of non-null characters currently ! 1064: * stored at dst. */ ! 1065: int dstSpace = TCL_RESULT_SIZE; ! 1066: /* Total amount of storage space available ! 1067: * in dst (not including null terminator. */ ! 1068: int noPercent; /* Special case for speed: indicates there's ! 1069: * no field specifier, just a string to copy. */ ! 1070: char **curArg; /* Remainder of argv array. */ ! 1071: ! 1072: /* ! 1073: * This procedure is a bit nasty. The goal is to use sprintf to ! 1074: * do most of the dirty work. There are several problems: ! 1075: * 1. this procedure can't trust its arguments. ! 1076: * 2. we must be able to provide a large enough result area to hold ! 1077: * whatever's generated. This is hard to estimate. ! 1078: * 2. there's no way to move the arguments from argv to the call ! 1079: * to sprintf in a reasonable way. This is particularly nasty ! 1080: * because some of the arguments may be two-word values (doubles). ! 1081: * So, what happens here is to scan the format string one % group ! 1082: * at a time, making many individual calls to sprintf. ! 1083: */ ! 1084: ! 1085: if (argc < 2) { ! 1086: sprintf(interp->result, ! 1087: "too few args: should be \"%.50s formatString [arg arg ...]\"", ! 1088: argv[0]); ! 1089: return TCL_ERROR; ! 1090: } ! 1091: curArg = argv+2; ! 1092: argc -= 2; ! 1093: for (format = argv[1]; *format != 0; ) { ! 1094: register char *newPtr = newFormat; ! 1095: ! 1096: width = precision = useTwoWords = noPercent = 0; ! 1097: ! 1098: /* ! 1099: * Get rid of any characters before the next field specifier. ! 1100: * Collapse backslash sequences found along the way. ! 1101: */ ! 1102: ! 1103: if (*format != '%') { ! 1104: register char *p; ! 1105: int bsSize; ! 1106: ! 1107: oneWordValue = format; ! 1108: for (p = format; (*format != '%') && (*format != 0); p++) { ! 1109: if (*format == '\\') { ! 1110: *p = Tcl_Backslash(format, &bsSize); ! 1111: format += bsSize; ! 1112: } else { ! 1113: *p = *format; ! 1114: format++; ! 1115: } ! 1116: } ! 1117: size = p - oneWordValue; ! 1118: noPercent = 1; ! 1119: goto doField; ! 1120: } ! 1121: ! 1122: if (format[1] == '%') { ! 1123: oneWordValue = format; ! 1124: size = 1; ! 1125: noPercent = 1; ! 1126: format += 2; ! 1127: goto doField; ! 1128: } ! 1129: ! 1130: /* ! 1131: * Parse off a field specifier, compute how many characters ! 1132: * will be needed to store the result, and substitute for ! 1133: * "*" size specifiers. ! 1134: */ ! 1135: ! 1136: *newPtr = '%'; ! 1137: newPtr++; ! 1138: format++; ! 1139: if (*format == '-') { ! 1140: *newPtr = '-'; ! 1141: newPtr++; ! 1142: format++; ! 1143: } ! 1144: if (*format == '0') { ! 1145: *newPtr = '0'; ! 1146: newPtr++; ! 1147: format++; ! 1148: } ! 1149: if (isdigit(*format)) { ! 1150: width = atoi(format); ! 1151: do { ! 1152: format++; ! 1153: } while (isdigit(*format)); ! 1154: } else if (*format == '*') { ! 1155: if (argc <= 0) { ! 1156: goto notEnoughArgs; ! 1157: } ! 1158: width = atoi(*curArg); ! 1159: argc--; ! 1160: curArg++; ! 1161: format++; ! 1162: } ! 1163: if (width != 0) { ! 1164: sprintf(newPtr, "%d", width); ! 1165: while (*newPtr != 0) { ! 1166: newPtr++; ! 1167: } ! 1168: } ! 1169: if (*format == '.') { ! 1170: *newPtr = '.'; ! 1171: newPtr++; ! 1172: format++; ! 1173: } ! 1174: if (isdigit(*format)) { ! 1175: precision = atoi(format); ! 1176: do { ! 1177: format++; ! 1178: } while (isdigit(*format)); ! 1179: } else if (*format == '*') { ! 1180: if (argc <= 0) { ! 1181: goto notEnoughArgs; ! 1182: } ! 1183: precision = atoi(*curArg); ! 1184: argc--; ! 1185: curArg++; ! 1186: format++; ! 1187: } ! 1188: if (precision != 0) { ! 1189: sprintf(newPtr, "%d", precision); ! 1190: while (*newPtr != 0) { ! 1191: newPtr++; ! 1192: } ! 1193: } ! 1194: if (*format == '#') { ! 1195: *newPtr = '#'; ! 1196: newPtr++; ! 1197: format++; ! 1198: } ! 1199: if (*format == 'l') { ! 1200: format++; ! 1201: } ! 1202: *newPtr = *format; ! 1203: newPtr++; ! 1204: *newPtr = 0; ! 1205: if (argc <= 0) { ! 1206: goto notEnoughArgs; ! 1207: } ! 1208: switch (*format) { ! 1209: case 'D': ! 1210: case 'd': ! 1211: case 'O': ! 1212: case 'o': ! 1213: case 'X': ! 1214: case 'x': ! 1215: case 'U': ! 1216: case 'u': { ! 1217: char *end; ! 1218: ! 1219: oneWordValue = (char *) strtol(*curArg, &end, 0); ! 1220: if ((*curArg == 0) || (*end != 0)) { ! 1221: sprintf(interp->result, ! 1222: "expected integer but got \"%.50s\" instead", ! 1223: *curArg); ! 1224: goto fmtError; ! 1225: } ! 1226: size = 40; ! 1227: break; ! 1228: } ! 1229: case 's': ! 1230: oneWordValue = *curArg; ! 1231: size = strlen(*curArg); ! 1232: break; ! 1233: case 'c': { ! 1234: char *end; ! 1235: ! 1236: oneWordValue = (char *) strtol(*curArg, &end, 0); ! 1237: if ((*curArg == 0) || (*end != 0)) { ! 1238: sprintf(interp->result, ! 1239: "expected integer but got \"%.50s\" instead", ! 1240: *curArg); ! 1241: goto fmtError; ! 1242: } ! 1243: size = 1; ! 1244: break; ! 1245: } ! 1246: case 'F': ! 1247: case 'f': ! 1248: case 'E': ! 1249: case 'e': ! 1250: case 'G': ! 1251: case 'g': ! 1252: if (sscanf(*curArg, "%F", &twoWordValue) != 1) { ! 1253: sprintf(interp->result, ! 1254: "expected floating-point number but got \"%.50s\" instead", ! 1255: *curArg); ! 1256: goto fmtError; ! 1257: } ! 1258: useTwoWords = 1; ! 1259: size = 320; ! 1260: if (precision > 10) { ! 1261: size += precision; ! 1262: } ! 1263: break; ! 1264: case 0: ! 1265: interp->result = "format string ended in middle of field specifier"; ! 1266: goto fmtError; ! 1267: default: ! 1268: sprintf(interp->result, "bad field specifier \"%c\"", *format); ! 1269: goto fmtError; ! 1270: } ! 1271: argc--; ! 1272: curArg++; ! 1273: format++; ! 1274: ! 1275: /* ! 1276: * Make sure that there's enough space to hold the formatted ! 1277: * result, then format it. ! 1278: */ ! 1279: ! 1280: doField: ! 1281: if (width > size) { ! 1282: size = width; ! 1283: } ! 1284: if ((dstSize + size) > dstSpace) { ! 1285: char *newDst; ! 1286: int newSpace; ! 1287: ! 1288: newSpace = 2*(dstSize + size); ! 1289: newDst = (char *) malloc((unsigned) newSpace+1); ! 1290: if (dstSize != 0) { ! 1291: bcopy(dst, newDst, dstSize); ! 1292: } ! 1293: if (dstSpace != TCL_RESULT_SIZE) { ! 1294: free(dst); ! 1295: } ! 1296: dst = newDst; ! 1297: dstSpace = newSpace; ! 1298: } ! 1299: if (noPercent) { ! 1300: bcopy(oneWordValue, dst+dstSize, size); ! 1301: dstSize += size; ! 1302: dst[dstSize] = 0; ! 1303: } else { ! 1304: if (useTwoWords) { ! 1305: sprintf(dst+dstSize, newFormat, twoWordValue); ! 1306: } else { ! 1307: sprintf(dst+dstSize, newFormat, oneWordValue); ! 1308: } ! 1309: dstSize += strlen(dst+dstSize); ! 1310: } ! 1311: } ! 1312: ! 1313: interp->result = dst; ! 1314: interp->dynamic = !(dstSpace == TCL_RESULT_SIZE); ! 1315: return TCL_OK; ! 1316: ! 1317: notEnoughArgs: ! 1318: sprintf(interp->result, ! 1319: "invoked \"%.50s\" without enough arguments", argv[0]); ! 1320: fmtError: ! 1321: if (dstSpace != TCL_RESULT_SIZE) { ! 1322: free(dst); ! 1323: } ! 1324: return TCL_ERROR; ! 1325: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.