![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to tclCmdIZ.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10dc / cmd / worm / scsi / tcl|
Return to tclCmdIZ.c CVS log | Up to [Research Unix] / researchv10dc / cmd / worm / scsi / tcl |
1.1 ! root 1: /* ! 2: * tclCmdIZ.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: * I to Z. ! 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/tclCmdIZ.c,v 1.36 90/04/18 17:09:07 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 <stdio.h> ! 28: #include <stdlib.h> ! 29: #include <string.h> ! 30: #include <sys/types.h> ! 31: #include <fcntl.h> ! 32: #include <sys/stat.h> ! 33: #include <sys/times.h> ! 34: #include "tclInt.h" ! 35: ! 36: /* ! 37: *---------------------------------------------------------------------- ! 38: * ! 39: * Tcl_IfCmd -- ! 40: * ! 41: * This procedure is invoked to process the "if" Tcl command. ! 42: * See the user documentation for details on what it does. ! 43: * ! 44: * Results: ! 45: * A standard Tcl result. ! 46: * ! 47: * Side effects: ! 48: * See the user documentation. ! 49: * ! 50: *---------------------------------------------------------------------- ! 51: */ ! 52: ! 53: /* ARGSUSED */ ! 54: int ! 55: Tcl_IfCmd(dummy, interp, argc, argv) ! 56: ClientData dummy; /* Not used. */ ! 57: Tcl_Interp *interp; /* Current interpreter. */ ! 58: int argc; /* Number of arguments. */ ! 59: char **argv; /* Argument strings. */ ! 60: { ! 61: #pragma ref dummy ! 62: char *condition, *ifPart, *elsePart, *cmd, *name; ! 63: int result, value; ! 64: ! 65: name = argv[0]; ! 66: if (argc < 3) { ! 67: ifSyntax: ! 68: sprintf(interp->result, "wrong # args: should be \"%.50s bool [then] command [[else] command]\"", ! 69: name); ! 70: return TCL_ERROR; ! 71: } ! 72: condition = argv[1]; ! 73: argc -= 2; ! 74: argv += 2; ! 75: if ((**argv == 't') && (strncmp(*argv, "then", strlen(*argv)) == 0)) { ! 76: argc--; ! 77: argv++; ! 78: } ! 79: if (argc < 1) { ! 80: goto ifSyntax; ! 81: } ! 82: ifPart = *argv; ! 83: argv++; ! 84: argc--; ! 85: if (argc == 0) { ! 86: elsePart = ""; ! 87: } else { ! 88: if ((**argv == 'e') && (strncmp(*argv, "else", strlen(*argv)) == 0)) { ! 89: argc--; ! 90: argv++; ! 91: } ! 92: if (argc != 1) { ! 93: goto ifSyntax; ! 94: } ! 95: elsePart = *argv; ! 96: } ! 97: ! 98: cmd = ifPart; ! 99: result = Tcl_Expr(interp, condition, &value); ! 100: if (result != TCL_OK) { ! 101: return result; ! 102: } ! 103: if (value == 0) { ! 104: cmd = elsePart; ! 105: } ! 106: result = Tcl_Eval(interp, cmd, 0, (char **) NULL); ! 107: if (result == TCL_ERROR) { ! 108: char msg[60]; ! 109: sprintf(msg, " (\"if\" body line %d)", interp->errorLine); ! 110: Tcl_AddErrorInfo(interp, msg); ! 111: } ! 112: return result; ! 113: } ! 114: ! 115: /* ! 116: *---------------------------------------------------------------------- ! 117: * ! 118: * Tcl_IndexCmd -- ! 119: * ! 120: * This procedure is invoked to process the "index" Tcl command. ! 121: * See the user documentation for details on what it does. ! 122: * ! 123: * Results: ! 124: * A standard Tcl result. ! 125: * ! 126: * Side effects: ! 127: * See the user documentation. ! 128: * ! 129: *---------------------------------------------------------------------- ! 130: */ ! 131: ! 132: /* ARGSUSED */ ! 133: int ! 134: Tcl_IndexCmd(dummy, interp, argc, argv) ! 135: ClientData dummy; /* Not used. */ ! 136: Tcl_Interp *interp; /* Current interpreter. */ ! 137: int argc; /* Number of arguments. */ ! 138: char **argv; /* Argument strings. */ ! 139: { ! 140: #pragma ref dummy ! 141: char *p, *element; ! 142: int index, size, parenthesized, result; ! 143: ! 144: if (argc < 3) { ! 145: indexSyntax: ! 146: sprintf(interp->result, ! 147: "wrong # args: should be \"%.50s value index [chars]\"", ! 148: argv[0]); ! 149: return TCL_ERROR; ! 150: } ! 151: p = argv[1]; ! 152: index = atoi(argv[2]); ! 153: if (!isdigit(*argv[2]) || (index < 0)) { ! 154: sprintf(interp->result, "bad index \"%.50s\"", argv[2]); ! 155: return TCL_ERROR; ! 156: } ! 157: if (argc == 3) { ! 158: for ( ; index >= 0; index--) { ! 159: result = TclFindElement(interp, p, &element, &p, &size, ! 160: &parenthesized); ! 161: if (result != TCL_OK) { ! 162: return result; ! 163: } ! 164: } ! 165: if (size >= TCL_RESULT_SIZE) { ! 166: interp->result = (char *) malloc((unsigned) size+1); ! 167: interp->dynamic = 1; ! 168: } ! 169: if (parenthesized) { ! 170: bcopy(element, interp->result, size); ! 171: interp->result[size] = 0; ! 172: } else { ! 173: TclCopyAndCollapse(size, element, interp->result); ! 174: } ! 175: } else if (argc == 4) { ! 176: if (strncmp(argv[3], "chars", strlen(argv[3])) != 0) { ! 177: sprintf(interp->result, "bad argument \"%s\": must be \"chars\"", ! 178: argv[3]); ! 179: return TCL_ERROR; ! 180: } ! 181: size = strlen(p); ! 182: if (index < size) { ! 183: interp->result[0] = p[index]; ! 184: interp->result[1] = 0; ! 185: } ! 186: } else { ! 187: goto indexSyntax; ! 188: } ! 189: return TCL_OK; ! 190: } ! 191: ! 192: /* ! 193: *---------------------------------------------------------------------- ! 194: * ! 195: * Tcl_InfoCmd -- ! 196: * ! 197: * This procedure is invoked to process the "info" Tcl command. ! 198: * See the user documentation for details on what it does. ! 199: * ! 200: * Results: ! 201: * A standard Tcl result. ! 202: * ! 203: * Side effects: ! 204: * See the user documentation. ! 205: * ! 206: *---------------------------------------------------------------------- ! 207: */ ! 208: ! 209: /* ARGSUSED */ ! 210: int ! 211: Tcl_InfoCmd(dummy, interp, argc, argv) ! 212: ClientData dummy; /* Not used. */ ! 213: Tcl_Interp *interp; /* Current interpreter. */ ! 214: int argc; /* Number of arguments. */ ! 215: char **argv; /* Argument strings. */ ! 216: { ! 217: #pragma ref dummy ! 218: register Interp *iPtr = (Interp *) interp; ! 219: Proc *procPtr; ! 220: Var *varPtr; ! 221: Command *cmdPtr; ! 222: int length; ! 223: char c; ! 224: ! 225: /* ! 226: * When collecting a list of things (e.g. args or vars) "flag" tells ! 227: * what kind of thing is being collected, according to the definitions ! 228: * below. ! 229: */ ! 230: ! 231: int flag; ! 232: # define VARS 0 ! 233: # define LOCALS 1 ! 234: # define PROCS 2 ! 235: # define CMDS 3 ! 236: ! 237: # define ARG_SIZE 20 ! 238: char *argSpace[ARG_SIZE]; ! 239: int argSize; ! 240: char *pattern; ! 241: ! 242: if (argc < 2) { ! 243: sprintf(iPtr->result, ! 244: "too few args: should be \"%.50s option [arg arg ...]\"", ! 245: argv[0]); ! 246: return TCL_ERROR; ! 247: } ! 248: c = argv[1][0]; ! 249: length = strlen(argv[1]); ! 250: if ((c == 'a') && (strncmp(argv[1], "args", length)) == 0) { ! 251: if (argc != 3) { ! 252: sprintf(iPtr->result, ! 253: "wrong # args: should be \"%.50s args procname\"", ! 254: argv[0]); ! 255: return TCL_ERROR; ! 256: } ! 257: procPtr = TclFindProc(iPtr, argv[2]); ! 258: if (procPtr == NULL) { ! 259: infoNoSuchProc: ! 260: sprintf(iPtr->result, ! 261: "info requested on \"%s\", which isn't a procedure", ! 262: argv[2]); ! 263: return TCL_ERROR; ! 264: } ! 265: flag = VARS; ! 266: varPtr = procPtr->argPtr; ! 267: argc = 0; /* Prevent pattern matching. */ ! 268: } else if ((c == 'b') && (strncmp(argv[1], "body", length)) == 0) { ! 269: if (argc != 3) { ! 270: sprintf(iPtr->result, ! 271: "wrong # args: should be \"%.50s body procname\"", ! 272: argv[0]); ! 273: return TCL_ERROR; ! 274: } ! 275: procPtr = TclFindProc(iPtr, argv[2]); ! 276: if (procPtr == NULL) { ! 277: goto infoNoSuchProc; ! 278: } ! 279: iPtr->result = procPtr->command; ! 280: return TCL_OK; ! 281: } else if ((c == 'c') && (strncmp(argv[1], "cmdcount", length) == 0) ! 282: && (length >= 2)) { ! 283: if (argc != 2) { ! 284: sprintf(iPtr->result, ! 285: "wrong # args: should be \"%.50s cmdcount\"", ! 286: argv[0]); ! 287: return TCL_ERROR; ! 288: } ! 289: sprintf(iPtr->result, "%d", iPtr->cmdCount); ! 290: return TCL_OK; ! 291: } else if ((c == 'c') && (strncmp(argv[1], "commands", length) == 0) ! 292: && (length >= 2)){ ! 293: if (argc > 3) { ! 294: sprintf(iPtr->result, ! 295: "wrong # args: should be \"%.50s commands [pattern]\"", ! 296: argv[0]); ! 297: return TCL_ERROR; ! 298: } ! 299: flag = CMDS; ! 300: cmdPtr = iPtr->commandPtr; ! 301: } else if ((c == 'd') && (strncmp(argv[1], "default", length)) == 0) { ! 302: if (argc != 5) { ! 303: sprintf(iPtr->result, "wrong # args: should be \"%.50s default procname arg varname\"", ! 304: argv[0]); ! 305: return TCL_ERROR; ! 306: } ! 307: procPtr = TclFindProc(iPtr, argv[2]); ! 308: if (procPtr == NULL) { ! 309: goto infoNoSuchProc; ! 310: } ! 311: for (varPtr = procPtr->argPtr; ; varPtr = varPtr->nextPtr) { ! 312: if (varPtr == NULL) { ! 313: sprintf(iPtr->result, ! 314: "procedure \"%s\" doesn't have an argument \"%s\"", ! 315: argv[2], argv[3]); ! 316: return TCL_ERROR; ! 317: } ! 318: if (strcmp(argv[3], varPtr->name) == 0) { ! 319: if (varPtr->value != NULL) { ! 320: Tcl_SetVar((Tcl_Interp *) iPtr, argv[4], varPtr->value, 0); ! 321: iPtr->result = "1"; ! 322: } else { ! 323: Tcl_SetVar((Tcl_Interp *) iPtr, argv[4], "", 0); ! 324: iPtr->result = "0"; ! 325: } ! 326: return TCL_OK; ! 327: } ! 328: } ! 329: } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0)) { ! 330: char *p; ! 331: if (argc != 3) { ! 332: sprintf(iPtr->result, ! 333: "wrong # args: should be \"%.50s exists varName\"", ! 334: argv[0]); ! 335: return TCL_ERROR; ! 336: } ! 337: p = Tcl_GetVar((Tcl_Interp *) iPtr, argv[2], 0); ! 338: if (p != NULL) { ! 339: iPtr->result[0] = '1'; ! 340: } else { ! 341: iPtr->result[0] = '0'; ! 342: } ! 343: iPtr->result[1] = 0; ! 344: return TCL_OK; ! 345: } else if ((c == 'g') && (strncmp(argv[1], "globals", length) == 0)) { ! 346: if (argc > 3) { ! 347: sprintf(iPtr->result, ! 348: "wrong # args: should be \"%.50s globals [pattern]\"", ! 349: argv[0]); ! 350: return TCL_ERROR; ! 351: } ! 352: flag = VARS; ! 353: varPtr = iPtr->globalPtr; ! 354: } else if ((c == 'l') && (strncmp(argv[1], "locals", length) == 0) ! 355: && (length >= 2)) { ! 356: if (argc > 3) { ! 357: sprintf(iPtr->result, ! 358: "wrong # args: should be \"%.50s locals [pattern]\"", ! 359: argv[0]); ! 360: return TCL_ERROR; ! 361: } ! 362: flag = LOCALS; ! 363: if (iPtr->varFramePtr == NULL) { ! 364: varPtr = NULL; ! 365: } else { ! 366: varPtr = iPtr->varFramePtr->varPtr; ! 367: } ! 368: } else if ((c == 'l') && (strncmp(argv[1], "level", length) == 0) ! 369: && (length >= 2)) { ! 370: if (argc == 2) { ! 371: if (iPtr->varFramePtr == NULL) { ! 372: iPtr->result = "0"; ! 373: } else { ! 374: sprintf(iPtr->result, "%d", iPtr->varFramePtr->level); ! 375: } ! 376: return TCL_OK; ! 377: } else if (argc == 3) { ! 378: int level; ! 379: char *end; ! 380: CallFrame *framePtr; ! 381: ! 382: level = strtol(argv[2], &end, 10); ! 383: if ((end == argv[2]) || (*end != '\0')) { ! 384: levelError: ! 385: sprintf(iPtr->result, "bad level \"%.50s\"", argv[1]); ! 386: return TCL_ERROR; ! 387: } ! 388: if (level <= 0) { ! 389: if (iPtr->varFramePtr == NULL) { ! 390: goto levelError; ! 391: } ! 392: level += iPtr->varFramePtr->level; ! 393: } ! 394: if (level == 0) { ! 395: return TCL_OK; ! 396: } ! 397: for (framePtr = iPtr->varFramePtr; framePtr != NULL; ! 398: framePtr = framePtr->callerVarPtr) { ! 399: if (framePtr->level == level) { ! 400: break; ! 401: } ! 402: } ! 403: if (framePtr == NULL) { ! 404: goto levelError; ! 405: } ! 406: iPtr->result = Tcl_Merge(framePtr->argc, framePtr->argv); ! 407: iPtr->dynamic = 1; ! 408: return TCL_OK; ! 409: } ! 410: sprintf(iPtr->result, ! 411: "wrong # args: should be \"%.50s level [number]\"", ! 412: argv[0]); ! 413: return TCL_ERROR; ! 414: } else if ((c == 'p') && (strncmp(argv[1], "procs", length)) == 0) { ! 415: if (argc > 3) { ! 416: sprintf(iPtr->result, ! 417: "wrong # args: should be \"%.50s procs [pattern]\"", ! 418: argv[0]); ! 419: return TCL_ERROR; ! 420: } ! 421: flag = PROCS; ! 422: cmdPtr = iPtr->commandPtr; ! 423: } else if ((c == 't') && (strncmp(argv[1], "tclversion", length) == 0)) { ! 424: ! 425: /* ! 426: * Note: TCL_VERSION below is expected to be set with a "-D" ! 427: * switch in the Makefile. ! 428: */ ! 429: ! 430: strcpy(iPtr->result, TCL_VERSION); ! 431: return TCL_OK; ! 432: } else if ((c == 'v') && (strncmp(argv[1], "vars", length)) == 0) { ! 433: if (argc > 3) { ! 434: sprintf(iPtr->result, ! 435: "wrong # args: should be \"%.50s vars [pattern]\"", ! 436: argv[0]); ! 437: return TCL_ERROR; ! 438: } ! 439: flag = VARS; ! 440: if (iPtr->varFramePtr == NULL) { ! 441: varPtr = iPtr->globalPtr; ! 442: } else { ! 443: varPtr = iPtr->varFramePtr->varPtr; ! 444: } ! 445: } else { ! 446: sprintf(iPtr->result, "bad \"%.50s\" option \"%.50s\": must be args, body, commands, cmdcount, default, exists, globals, level, locals, procs, tclversion, or vars", ! 447: argv[0], argv[1]); ! 448: return TCL_ERROR; ! 449: } ! 450: ! 451: /* ! 452: * At this point we have to assemble a list of something or other. ! 453: * Collect them in an expandable argv-argc array. ! 454: */ ! 455: ! 456: if (argc == 3) { ! 457: pattern = argv[2]; ! 458: } else { ! 459: pattern = NULL; ! 460: } ! 461: argv = argSpace; ! 462: argSize = ARG_SIZE; ! 463: argc = 0; ! 464: while (1) { ! 465: /* ! 466: * Increase the size of the argument array if necessary to ! 467: * accommodate another string. ! 468: */ ! 469: ! 470: if (argc == argSize) { ! 471: char **newArgs; ! 472: ! 473: argSize *= 2; ! 474: newArgs = (char **) malloc((unsigned) argSize*sizeof(char *)); ! 475: bcopy((char *) argv, (char *) newArgs, argc*sizeof(char *)); ! 476: if (argv != argSpace) { ! 477: free((char *) argv); ! 478: } ! 479: argv = newArgs; ! 480: } ! 481: ! 482: if ((flag == PROCS) || (flag == CMDS)) { ! 483: if (flag == PROCS) { ! 484: for ( ; cmdPtr != NULL; cmdPtr = cmdPtr->nextPtr) { ! 485: if (TclIsProc(cmdPtr)) { ! 486: break; ! 487: } ! 488: } ! 489: } ! 490: if (cmdPtr == NULL) { ! 491: break; ! 492: } ! 493: argv[argc] = cmdPtr->name; ! 494: cmdPtr = cmdPtr->nextPtr; ! 495: } else { ! 496: if (flag == LOCALS) { ! 497: for ( ; varPtr != NULL; varPtr = varPtr->nextPtr) { ! 498: if (!(varPtr->flags & VAR_GLOBAL)) { ! 499: break; ! 500: } ! 501: } ! 502: } ! 503: if (varPtr == NULL) { ! 504: break; ! 505: } ! 506: argv[argc] = varPtr->name; ! 507: varPtr = varPtr->nextPtr; ! 508: } ! 509: if ((pattern == NULL) || Tcl_StringMatch(argv[argc], pattern)) { ! 510: argc++; ! 511: } ! 512: } ! 513: ! 514: iPtr->result = Tcl_Merge(argc, argv); ! 515: iPtr->dynamic = 1; ! 516: if (argv != argSpace) { ! 517: free((char *) argv); ! 518: } ! 519: return TCL_OK; ! 520: } ! 521: ! 522: /* ! 523: *---------------------------------------------------------------------- ! 524: * ! 525: * Tcl_LengthCmd -- ! 526: * ! 527: * This procedure is invoked to process the "length" Tcl command. ! 528: * See the user documentation for details on what it does. ! 529: * ! 530: * Results: ! 531: * A standard Tcl result. ! 532: * ! 533: * Side effects: ! 534: * See the user documentation. ! 535: * ! 536: *---------------------------------------------------------------------- ! 537: */ ! 538: ! 539: /* ARGSUSED */ ! 540: int ! 541: Tcl_LengthCmd(dummy, interp, argc, argv) ! 542: ClientData dummy; /* Not used. */ ! 543: Tcl_Interp *interp; /* Current interpreter. */ ! 544: int argc; /* Number of arguments. */ ! 545: char **argv; /* Argument strings. */ ! 546: { ! 547: #pragma ref dummy ! 548: int count; ! 549: char *p; ! 550: ! 551: if (argc < 2) { ! 552: lengthSyntax: ! 553: sprintf(interp->result, ! 554: "wrong # args: should be \"%.50s value [chars]\"", argv[0]); ! 555: return TCL_ERROR; ! 556: } ! 557: p = argv[1]; ! 558: if (argc == 2) { ! 559: char *element; ! 560: int result; ! 561: ! 562: for (count = 0; *p != 0 ; count++) { ! 563: result = TclFindElement(interp, p, &element, &p, (int *) NULL, ! 564: (int *) NULL); ! 565: if (result != TCL_OK) { ! 566: return result; ! 567: } ! 568: if (*element == 0) { ! 569: break; ! 570: } ! 571: } ! 572: } else if ((argc == 3) ! 573: && (strncmp(argv[2], "chars", strlen(argv[2])) == 0)) { ! 574: count = strlen(p); ! 575: } else { ! 576: goto lengthSyntax; ! 577: } ! 578: sprintf(interp->result, "%d", count); ! 579: return TCL_OK; ! 580: } ! 581: ! 582: /* ! 583: *---------------------------------------------------------------------- ! 584: * ! 585: * Tcl_ListCmd -- ! 586: * ! 587: * This procedure is invoked to process the "list" Tcl command. ! 588: * See the user documentation for details on what it does. ! 589: * ! 590: * Results: ! 591: * A standard Tcl result. ! 592: * ! 593: * Side effects: ! 594: * See the user documentation. ! 595: * ! 596: *---------------------------------------------------------------------- ! 597: */ ! 598: ! 599: /* ARGSUSED */ ! 600: int ! 601: Tcl_ListCmd(dummy, interp, argc, argv) ! 602: ClientData dummy; /* Not used. */ ! 603: Tcl_Interp *interp; /* Current interpreter. */ ! 604: int argc; /* Number of arguments. */ ! 605: char **argv; /* Argument strings. */ ! 606: { ! 607: #pragma ref dummy ! 608: if (argc < 2) { ! 609: sprintf(interp->result, ! 610: "not enough args: should be \"%.50s arg [arg ...]\"", ! 611: argv[0]); ! 612: return TCL_ERROR; ! 613: } ! 614: interp->result = Tcl_Merge(argc-1, argv+1); ! 615: interp->dynamic = 1; ! 616: return TCL_OK; ! 617: } ! 618: ! 619: /* ! 620: *---------------------------------------------------------------------- ! 621: * ! 622: * Tcl_PrintCmd -- ! 623: * ! 624: * This procedure is invoked to process the "print" Tcl command. ! 625: * See the user documentation for details on what it does. ! 626: * ! 627: * Results: ! 628: * A standard Tcl result. ! 629: * ! 630: * Side effects: ! 631: * See the user documentation. ! 632: * ! 633: *---------------------------------------------------------------------- ! 634: */ ! 635: ! 636: /* ARGSUSED */ ! 637: int ! 638: Tcl_PrintCmd(notUsed, interp, argc, argv) ! 639: ClientData notUsed; /* Not used. */ ! 640: Tcl_Interp *interp; /* Current interpreter. */ ! 641: int argc; /* Number of arguments. */ ! 642: char **argv; /* Argument strings. */ ! 643: { ! 644: #pragma ref notUsed ! 645: FILE *f; ! 646: int result; ! 647: ! 648: if ((argc < 2) || (argc > 4)) { ! 649: sprintf(interp->result, ! 650: "wrong # args: should be \"%.50s string [file [append]]\"", ! 651: argv[0]); ! 652: return TCL_ERROR; ! 653: } ! 654: ! 655: if (argc == 2) { ! 656: f = stdout; ! 657: } else { ! 658: if (argc == 4) { ! 659: if (strncmp(argv[3], "append", strlen(argv[3])) != 0) { ! 660: sprintf(interp->result, ! 661: "bad option \"%.50s\": must be \"append\"", ! 662: argv[3]); ! 663: return TCL_ERROR; ! 664: } ! 665: f = fopen(argv[2], "a"); ! 666: } else { ! 667: f = fopen(argv[2], "w"); ! 668: } ! 669: if (f == NULL) { ! 670: sprintf(interp->result, "couldn't open \"%.50s\": %.80s", ! 671: argv[2], strerror(errno)); ! 672: return TCL_ERROR; ! 673: } ! 674: } ! 675: fputs(argv[1], f); ! 676: if (argc == 2) { ! 677: result = fflush(stdout); ! 678: } else { ! 679: result = fclose(f); ! 680: } ! 681: if (result == EOF) { ! 682: sprintf(interp->result, "I/O error while writing: %.50s", ! 683: strerror(errno)); ! 684: return TCL_ERROR; ! 685: } ! 686: return TCL_OK; ! 687: } ! 688: ! 689: /* ! 690: *---------------------------------------------------------------------- ! 691: * ! 692: * Tcl_RangeCmd -- ! 693: * ! 694: * This procedure is invoked to process the "range" Tcl command. ! 695: * See the user documentation for details on what it does. ! 696: * ! 697: * Results: ! 698: * A standard Tcl result. ! 699: * ! 700: * Side effects: ! 701: * See the user documentation. ! 702: * ! 703: *---------------------------------------------------------------------- ! 704: */ ! 705: ! 706: /* ARGSUSED */ ! 707: int ! 708: Tcl_RangeCmd(notUsed, interp, argc, argv) ! 709: ClientData notUsed; /* Not used. */ ! 710: Tcl_Interp *interp; /* Current interpreter. */ ! 711: int argc; /* Number of arguments. */ ! 712: char **argv; /* Argument strings. */ ! 713: { ! 714: #pragma ref notUsed ! 715: int first, last, result; ! 716: char *begin, *end, c, *dummy; ! 717: int count; ! 718: ! 719: if (argc < 4) { ! 720: rangeSyntax: ! 721: sprintf(interp->result, "wrong #/type of args: should be \"%.50s value first last [chars]\"", ! 722: argv[0]); ! 723: return TCL_ERROR; ! 724: } ! 725: first = atoi(argv[2]); ! 726: if (!isdigit(*argv[2]) || (first < 0)) { ! 727: sprintf(interp->result, "bad range specifier \"%.50s\"", argv[2]); ! 728: return TCL_ERROR; ! 729: } ! 730: if ((*argv[3] == 'e') && (strncmp(argv[3], "end", strlen(argv[3])) == 0)) { ! 731: last = -1; ! 732: } else { ! 733: last = atoi(argv[3]); ! 734: if (!isdigit(*argv[3]) || (last < 0)) { ! 735: sprintf(interp->result, "bad range specifier \"%.50s\"", argv[3]); ! 736: return TCL_ERROR; ! 737: } ! 738: } ! 739: ! 740: if (argc == 5) { ! 741: count = strlen(argv[4]); ! 742: if ((count == 0) || (strncmp(argv[4], "chars", count) != 0)) { ! 743: goto rangeSyntax; ! 744: } ! 745: ! 746: /* ! 747: * Extract a range of characters. ! 748: */ ! 749: ! 750: count = strlen(argv[1]); ! 751: if (first >= count) { ! 752: interp->result = ""; ! 753: return TCL_OK; ! 754: } ! 755: begin = argv[1] + first; ! 756: if ((last == -1) || (last >= count)) { ! 757: last = count; ! 758: } else if (last < first) { ! 759: interp->result = ""; ! 760: return TCL_OK; ! 761: } ! 762: end = argv[1] + last + 1; ! 763: } else { ! 764: if (argc != 4) { ! 765: goto rangeSyntax; ! 766: } ! 767: ! 768: /* ! 769: * Extract a range of fields. ! 770: */ ! 771: ! 772: for (count = 0, begin = argv[1]; count < first; count++) { ! 773: result = TclFindElement(interp, begin, &dummy, &begin, (int *) NULL, ! 774: (int *) NULL); ! 775: if (result != TCL_OK) { ! 776: return result; ! 777: } ! 778: if (*begin == 0) { ! 779: break; ! 780: } ! 781: } ! 782: if (last == -1) { ! 783: Tcl_Return(interp, begin, TCL_VOLATILE); ! 784: return TCL_OK; ! 785: } ! 786: if (last < first) { ! 787: interp->result = ""; ! 788: return TCL_OK; ! 789: } ! 790: for (count = first, end = begin; (count <= last) && (*end != 0); ! 791: count++) { ! 792: result = TclFindElement(interp, end, &dummy, &end, (int *) NULL, ! 793: (int *) NULL); ! 794: if (result != TCL_OK) { ! 795: return result; ! 796: } ! 797: } ! 798: ! 799: /* ! 800: * Chop off trailing spaces. ! 801: */ ! 802: ! 803: while (isspace(end[-1])) { ! 804: end--; ! 805: } ! 806: } ! 807: c = *end; ! 808: *end = 0; ! 809: Tcl_Return(interp, begin, TCL_VOLATILE); ! 810: *end = c; ! 811: return TCL_OK; ! 812: } ! 813: ! 814: /* ! 815: *---------------------------------------------------------------------- ! 816: * ! 817: * Tcl_RenameCmd -- ! 818: * ! 819: * This procedure is invoked to process the "rename" Tcl command. ! 820: * See the user documentation for details on what it does. ! 821: * ! 822: * Results: ! 823: * A standard Tcl result. ! 824: * ! 825: * Side effects: ! 826: * See the user documentation. ! 827: * ! 828: *---------------------------------------------------------------------- ! 829: */ ! 830: ! 831: /* ARGSUSED */ ! 832: int ! 833: Tcl_RenameCmd(dummy, interp, argc, argv) ! 834: ClientData dummy; /* Not used. */ ! 835: Tcl_Interp *interp; /* Current interpreter. */ ! 836: int argc; /* Number of arguments. */ ! 837: char **argv; /* Argument strings. */ ! 838: { ! 839: #pragma ref dummy ! 840: register Command *oldPtr, *newPtr; ! 841: Interp *iPtr = (Interp *) interp; ! 842: ! 843: if (argc != 3) { ! 844: sprintf(interp->result, ! 845: "wrong # args: should be \"%.50s oldName newName\"", ! 846: argv[0]); ! 847: return TCL_ERROR; ! 848: } ! 849: if (argv[2][0] == '\0') { ! 850: Tcl_DeleteCommand(interp, argv[1]); ! 851: return TCL_OK; ! 852: } ! 853: newPtr = TclFindCmd(iPtr, argv[2], 0); ! 854: if (newPtr != NULL) { ! 855: sprintf(interp->result, "can't rename to \"%.50s\": already exists", ! 856: argv[2]); ! 857: return TCL_ERROR; ! 858: } ! 859: oldPtr = TclFindCmd(iPtr, argv[1], 0); ! 860: if (oldPtr == NULL) { ! 861: sprintf(interp->result, ! 862: "can't rename \"%.50s\": command doesn't exist", ! 863: argv[1]); ! 864: return TCL_ERROR; ! 865: } ! 866: iPtr->commandPtr = oldPtr->nextPtr; ! 867: newPtr = (Command *) malloc(CMD_SIZE(strlen(argv[2]))); ! 868: newPtr->proc = oldPtr->proc; ! 869: newPtr->clientData = oldPtr->clientData; ! 870: newPtr->deleteProc = oldPtr->deleteProc; ! 871: newPtr->nextPtr = iPtr->commandPtr; ! 872: iPtr->commandPtr = newPtr; ! 873: strcpy(newPtr->name, argv[2]); ! 874: free((char *) oldPtr); ! 875: return TCL_OK; ! 876: } ! 877: ! 878: /* ! 879: *---------------------------------------------------------------------- ! 880: * ! 881: * Tcl_ReturnCmd -- ! 882: * ! 883: * This procedure is invoked to process the "return" Tcl command. ! 884: * See the user documentation for details on what it does. ! 885: * ! 886: * Results: ! 887: * A standard Tcl result. ! 888: * ! 889: * Side effects: ! 890: * See the user documentation. ! 891: * ! 892: *---------------------------------------------------------------------- ! 893: */ ! 894: ! 895: /* ARGSUSED */ ! 896: int ! 897: Tcl_ReturnCmd(dummy, interp, argc, argv) ! 898: ClientData dummy; /* Not used. */ ! 899: Tcl_Interp *interp; /* Current interpreter. */ ! 900: int argc; /* Number of arguments. */ ! 901: char **argv; /* Argument strings. */ ! 902: { ! 903: #pragma ref dummy ! 904: if (argc > 2) { ! 905: sprintf(interp->result, "too many args: should be \"%.50s [value]\"", ! 906: argv[0]); ! 907: return TCL_ERROR; ! 908: } ! 909: if (argc == 2) { ! 910: Tcl_Return(interp, argv[1], TCL_VOLATILE); ! 911: } ! 912: return TCL_RETURN; ! 913: } ! 914: ! 915: /* ! 916: *---------------------------------------------------------------------- ! 917: * ! 918: * Tcl_ScanCmd -- ! 919: * ! 920: * This procedure is invoked to process the "scan" Tcl command. ! 921: * See the user documentation for details on what it does. ! 922: * ! 923: * Results: ! 924: * A standard Tcl result. ! 925: * ! 926: * Side effects: ! 927: * See the user documentation. ! 928: * ! 929: *---------------------------------------------------------------------- ! 930: */ ! 931: ! 932: /* ARGSUSED */ ! 933: int ! 934: Tcl_ScanCmd(dummy, interp, argc, argv) ! 935: ClientData dummy; /* Not used. */ ! 936: Tcl_Interp *interp; /* Current interpreter. */ ! 937: int argc; /* Number of arguments. */ ! 938: char **argv; /* Argument strings. */ ! 939: { ! 940: #pragma ref dummy ! 941: int arg1Length; /* Number of bytes in argument to be ! 942: * scanned. This gives an upper limit ! 943: * on string field sizes. */ ! 944: # define MAX_FIELDS 20 ! 945: typedef struct { ! 946: char fmt; /* Format for field. */ ! 947: int size; /* How many bytes to allow for ! 948: * field. */ ! 949: char *location; /* Where field will be stored. */ ! 950: } Field; ! 951: Field fields[MAX_FIELDS]; /* Info about all the fields in the ! 952: * format string. */ ! 953: register Field *curField; ! 954: int numFields = 0; /* Number of fields actually ! 955: * specified. */ ! 956: int suppress; /* Current field is assignment- ! 957: * suppressed. */ ! 958: int totalSize = 0; /* Number of bytes needed to store ! 959: * all results combined. */ ! 960: char *results; /* Where scanned output goes. */ ! 961: int numScanned; /* sscanf's result. */ ! 962: register char *fmt; ! 963: int i; ! 964: ! 965: if (argc < 3) { ! 966: sprintf(interp->result, ! 967: "too few args: should be \"%.50s string format varName ...\"", ! 968: argv[0]); ! 969: return TCL_ERROR; ! 970: } ! 971: ! 972: /* ! 973: * This procedure operates in four stages: ! 974: * 1. Scan the format string, collecting information about each field. ! 975: * 2. Allocate an array to hold all of the scanned fields. ! 976: * 3. Call sscanf to do all the dirty work, and have it store the ! 977: * parsed fields in the array. ! 978: * 4. Pick off the fields from the array and assign them to variables. ! 979: */ ! 980: ! 981: arg1Length = (strlen(argv[1]) + 4) & ~03; ! 982: for (fmt = argv[2]; *fmt != 0; fmt++) { ! 983: if (*fmt != '%') { ! 984: continue; ! 985: } ! 986: fmt++; ! 987: if (*fmt == '*') { ! 988: suppress = 1; ! 989: fmt++; ! 990: } else { ! 991: suppress = 0; ! 992: } ! 993: while (isdigit(*fmt)) { ! 994: fmt++; ! 995: } ! 996: if (suppress) { ! 997: continue; ! 998: } ! 999: if (numFields == MAX_FIELDS) { ! 1000: sprintf(interp->result, ! 1001: "can't have more than %d fields in \"%.50s\"", MAX_FIELDS, ! 1002: argv[0]); ! 1003: return TCL_ERROR; ! 1004: } ! 1005: curField = &fields[numFields]; ! 1006: numFields++; ! 1007: switch (*fmt) { ! 1008: case 'D': ! 1009: case 'O': ! 1010: case 'X': ! 1011: case 'd': ! 1012: case 'o': ! 1013: case 'x': ! 1014: curField->fmt = 'd'; ! 1015: curField->size = sizeof(int); ! 1016: break; ! 1017: ! 1018: case 's': ! 1019: curField->fmt = 's'; ! 1020: curField->size = arg1Length; ! 1021: break; ! 1022: ! 1023: case 'c': ! 1024: curField->fmt = 'c'; ! 1025: curField->size = sizeof(int); ! 1026: break; ! 1027: ! 1028: case 'E': ! 1029: case 'F': ! 1030: curField->fmt = 'F'; ! 1031: curField->size = 8; ! 1032: break; ! 1033: ! 1034: case 'e': ! 1035: case 'f': ! 1036: curField->fmt = 'f'; ! 1037: curField->size = 4; ! 1038: break; ! 1039: ! 1040: case '[': ! 1041: curField->fmt = 's'; ! 1042: curField->size = arg1Length; ! 1043: do { ! 1044: fmt++; ! 1045: } while (*fmt != ']'); ! 1046: break; ! 1047: ! 1048: default: ! 1049: sprintf(interp->result, "bad scan conversion character \"%c\"", ! 1050: *fmt); ! 1051: return TCL_ERROR; ! 1052: } ! 1053: totalSize += curField->size; ! 1054: } ! 1055: ! 1056: if (numFields != (argc-3)) { ! 1057: interp->result = ! 1058: "different numbers of variable names and field specifiers"; ! 1059: return TCL_ERROR; ! 1060: } ! 1061: ! 1062: /* ! 1063: * Step 2: ! 1064: */ ! 1065: ! 1066: results = (char *) malloc((unsigned) totalSize); ! 1067: for (i = 0, totalSize = 0, curField = fields; ! 1068: i < numFields; i++, curField++) { ! 1069: curField->location = results + totalSize; ! 1070: totalSize += curField->size; ! 1071: } ! 1072: ! 1073: /* ! 1074: * Step 3: ! 1075: */ ! 1076: ! 1077: numScanned = sscanf(argv[1], argv[2], ! 1078: fields[0].location, fields[1].location, fields[2].location, ! 1079: fields[3].location, fields[4].location); ! 1080: ! 1081: /* ! 1082: * Step 4: ! 1083: */ ! 1084: ! 1085: if (numScanned < numFields) { ! 1086: numFields = numScanned; ! 1087: } ! 1088: for (i = 0, curField = fields; i < numFields; i++, curField++) { ! 1089: switch (curField->fmt) { ! 1090: char string[30]; ! 1091: ! 1092: case 'd': ! 1093: sprintf(string, "%d", *((int *) curField->location)); ! 1094: Tcl_SetVar(interp, argv[i+3], string, 0); ! 1095: break; ! 1096: ! 1097: case 'c': ! 1098: sprintf(string, "%d", *((char *) curField->location) & 0xff); ! 1099: Tcl_SetVar(interp, argv[i+3], string, 0); ! 1100: break; ! 1101: ! 1102: case 's': ! 1103: Tcl_SetVar(interp, argv[i+3], curField->location, 0); ! 1104: break; ! 1105: ! 1106: case 'F': ! 1107: sprintf(string, "%g", *((double *) curField->location)); ! 1108: Tcl_SetVar(interp, argv[i+3], string, 0); ! 1109: break; ! 1110: ! 1111: case 'f': ! 1112: sprintf(string, "%g", *((float *) curField->location)); ! 1113: Tcl_SetVar(interp, argv[i+3], string, 0); ! 1114: break; ! 1115: } ! 1116: } ! 1117: free(results); ! 1118: sprintf(interp->result, "%d", numScanned); ! 1119: return TCL_OK; ! 1120: } ! 1121: ! 1122: /* ! 1123: *---------------------------------------------------------------------- ! 1124: * ! 1125: * Tcl_SourceCmd -- ! 1126: * ! 1127: * This procedure is invoked to process the "source" Tcl command. ! 1128: * See the user documentation for details on what it does. ! 1129: * ! 1130: * Results: ! 1131: * A standard Tcl result. ! 1132: * ! 1133: * Side effects: ! 1134: * See the user documentation. ! 1135: * ! 1136: *---------------------------------------------------------------------- ! 1137: */ ! 1138: ! 1139: /* ARGSUSED */ ! 1140: int ! 1141: Tcl_SourceCmd(dummy, interp, argc, argv) ! 1142: ClientData dummy; /* Not used. */ ! 1143: Tcl_Interp *interp; /* Current interpreter. */ ! 1144: int argc; /* Number of arguments. */ ! 1145: char **argv; /* Argument strings. */ ! 1146: { ! 1147: #pragma ref dummy ! 1148: int fileId, result; ! 1149: struct stat statBuf; ! 1150: char *cmdBuffer, *end; ! 1151: char *fileName; ! 1152: ! 1153: if (argc != 2) { ! 1154: sprintf(interp->result, "wrong # args: should be \"%.50s fileName\"", ! 1155: argv[0]); ! 1156: return TCL_ERROR; ! 1157: } ! 1158: fileName = Tcl_TildeSubst(interp, argv[1]); ! 1159: if (fileName == NULL) { ! 1160: return TCL_ERROR; ! 1161: } ! 1162: fileId = open(fileName, O_RDONLY, 0); ! 1163: if (fileId < 0) { ! 1164: sprintf(interp->result, "couldn't read file \"%.50s\"", argv[1]); ! 1165: return TCL_ERROR; ! 1166: } ! 1167: if (fstat(fileId, &statBuf) == -1) { ! 1168: sprintf(interp->result, "couldn't stat file \"%.50s\"", argv[1]); ! 1169: close(fileId); ! 1170: return TCL_ERROR; ! 1171: } ! 1172: cmdBuffer = (char *) malloc((unsigned) statBuf.st_size+1); ! 1173: if (read(fileId, cmdBuffer, (int) statBuf.st_size) != statBuf.st_size) { ! 1174: sprintf(interp->result, "error in reading file \"%.50s\"", argv[1]); ! 1175: close(fileId); ! 1176: return TCL_ERROR; ! 1177: } ! 1178: close(fileId); ! 1179: cmdBuffer[statBuf.st_size] = 0; ! 1180: result = Tcl_Eval(interp, cmdBuffer, 0, &end); ! 1181: if (result == TCL_RETURN) { ! 1182: result = TCL_OK; ! 1183: } ! 1184: if (result == TCL_ERROR) { ! 1185: char msg[100]; ! 1186: ! 1187: /* ! 1188: * Record information telling where the error occurred. ! 1189: */ ! 1190: ! 1191: sprintf(msg, " (file \"%.50s\" line %d)", argv[1], interp->errorLine); ! 1192: Tcl_AddErrorInfo(interp, msg); ! 1193: } ! 1194: free(cmdBuffer); ! 1195: return result; ! 1196: } ! 1197: ! 1198: /* ! 1199: *---------------------------------------------------------------------- ! 1200: * ! 1201: * Tcl_StringCmd -- ! 1202: * ! 1203: * This procedure is invoked to process the "string" Tcl command. ! 1204: * See the user documentation for details on what it does. ! 1205: * ! 1206: * Results: ! 1207: * A standard Tcl result. ! 1208: * ! 1209: * Side effects: ! 1210: * See the user documentation. ! 1211: * ! 1212: *---------------------------------------------------------------------- ! 1213: */ ! 1214: ! 1215: /* ARGSUSED */ ! 1216: int ! 1217: Tcl_StringCmd(dummy, interp, argc, argv) ! 1218: ClientData dummy; /* Not used. */ ! 1219: Tcl_Interp *interp; /* Current interpreter. */ ! 1220: int argc; /* Number of arguments. */ ! 1221: char **argv; /* Argument strings. */ ! 1222: { ! 1223: #pragma ref dummy ! 1224: int length; ! 1225: register char *p, c; ! 1226: int match; ! 1227: int first; ! 1228: ! 1229: if (argc != 4) { ! 1230: sprintf(interp->result, ! 1231: "wrong # args: should be \"%.50s option a b\"", ! 1232: argv[0]); ! 1233: return TCL_ERROR; ! 1234: } ! 1235: length = strlen(argv[1]); ! 1236: if (strncmp(argv[1], "compare", length) == 0) { ! 1237: match = strcmp(argv[2], argv[3]); ! 1238: if (match > 0) { ! 1239: interp->result = "1"; ! 1240: } else if (match < 0) { ! 1241: interp->result = "-1"; ! 1242: } else { ! 1243: interp->result = "0"; ! 1244: } ! 1245: return TCL_OK; ! 1246: } ! 1247: if (strncmp(argv[1], "first", length) == 0) { ! 1248: first = 1; ! 1249: } else if (strncmp(argv[1], "last", length) == 0) { ! 1250: first = 0; ! 1251: } else if (strncmp(argv[1], "match", length) == 0) { ! 1252: if (Tcl_StringMatch(argv[3], argv[2]) != 0) { ! 1253: interp->result = "1"; ! 1254: } else { ! 1255: interp->result = "0"; ! 1256: } ! 1257: return TCL_OK; ! 1258: } else { ! 1259: sprintf(interp->result, ! 1260: "bad \"%.50s\" option \"%.50s\": must be compare, first, or last", ! 1261: argv[0], argv[1]); ! 1262: return TCL_ERROR; ! 1263: } ! 1264: match = -1; ! 1265: c = *argv[2]; ! 1266: length = strlen(argv[2]); ! 1267: for (p = argv[3]; *p != 0; p++) { ! 1268: if (*p != c) { ! 1269: continue; ! 1270: } ! 1271: if (strncmp(argv[2], p, length) == 0) { ! 1272: match = p-argv[3]; ! 1273: if (first) { ! 1274: break; ! 1275: } ! 1276: } ! 1277: } ! 1278: sprintf(interp->result, "%d", match); ! 1279: return TCL_OK; ! 1280: } ! 1281: ! 1282: /* ! 1283: *---------------------------------------------------------------------- ! 1284: * ! 1285: * Tcl_TimeCmd -- ! 1286: * ! 1287: * This procedure is invoked to process the "time" Tcl command. ! 1288: * See the user documentation for details on what it does. ! 1289: * ! 1290: * Results: ! 1291: * A standard Tcl result. ! 1292: * ! 1293: * Side effects: ! 1294: * See the user documentation. ! 1295: * ! 1296: *---------------------------------------------------------------------- ! 1297: */ ! 1298: ! 1299: /* ARGSUSED */ ! 1300: int ! 1301: Tcl_TimeCmd(dummy, interp, argc, argv) ! 1302: ClientData dummy; /* Not used. */ ! 1303: Tcl_Interp *interp; /* Current interpreter. */ ! 1304: int argc; /* Number of arguments. */ ! 1305: char **argv; /* Argument strings. */ ! 1306: { ! 1307: #pragma ref dummy ! 1308: int count, i, result; ! 1309: struct tms start, stop; ! 1310: int micros; ! 1311: double timePer; ! 1312: ! 1313: if (argc == 2) { ! 1314: count = 1; ! 1315: } else if (argc == 3) { ! 1316: if (sscanf(argv[2], "%d", &count) != 1) { ! 1317: sprintf(interp->result, "bad count \"%.50s\" given to \"%.50s\"", ! 1318: argv[2], argv[0]); ! 1319: return TCL_ERROR; ! 1320: } ! 1321: } else { ! 1322: sprintf(interp->result, ! 1323: "wrong # args: should be \"%.50s command [count]\"", ! 1324: argv[0]); ! 1325: return TCL_ERROR; ! 1326: } ! 1327: times(&start); ! 1328: for (i = count ; i > 0; i--) { ! 1329: result = Tcl_Eval(interp, argv[1], 0, (char **) NULL); ! 1330: if (result != TCL_OK) { ! 1331: if (result == TCL_ERROR) { ! 1332: char msg[60]; ! 1333: sprintf(msg, " (\"time\" body line %d)", interp->errorLine); ! 1334: Tcl_AddErrorInfo(interp, msg); ! 1335: } ! 1336: return result; ! 1337: } ! 1338: } ! 1339: times(&stop); ! 1340: micros = (stop.tms_utime - start.tms_utime)*1000000; ! 1341: timePer = micros; ! 1342: Tcl_Return(interp, (char *) NULL, TCL_STATIC); ! 1343: sprintf(interp->result, "%.0f microseconds per iteration", timePer/count); ! 1344: return TCL_OK; ! 1345: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.