![[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 [Micropolis - Activity] / micropolis / src / tcl|
Return to tclcmdah.c CVS log | Up to [Micropolis - Activity] / micropolis / src / 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-1991 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: /user6/ouster/tcl/RCS/tclCmdAH.c,v 1.76 92/07/06 09:49:41 ouster Exp $ SPRITE (Berkeley)"; ! 20: #endif ! 21: ! 22: #include "tclint.h" ! 23: ! 24: ! 25: /* ! 26: *---------------------------------------------------------------------- ! 27: * ! 28: * Tcl_BreakCmd -- ! 29: * ! 30: * This procedure is invoked to process the "break" Tcl command. ! 31: * See the user documentation for details on what it does. ! 32: * ! 33: * Results: ! 34: * A standard Tcl result. ! 35: * ! 36: * Side effects: ! 37: * See the user documentation. ! 38: * ! 39: *---------------------------------------------------------------------- ! 40: */ ! 41: ! 42: /* ARGSUSED */ ! 43: int ! 44: Tcl_BreakCmd(dummy, interp, argc, argv) ! 45: ClientData dummy; /* Not used. */ ! 46: Tcl_Interp *interp; /* Current interpreter. */ ! 47: int argc; /* Number of arguments. */ ! 48: char **argv; /* Argument strings. */ ! 49: { ! 50: if (argc != 1) { ! 51: Tcl_AppendResult(interp, "wrong # args: should be \"", ! 52: argv[0], "\"", (char *) NULL); ! 53: return TCL_ERROR; ! 54: } ! 55: return TCL_BREAK; ! 56: } ! 57: ! 58: /* ! 59: *---------------------------------------------------------------------- ! 60: * ! 61: * Tcl_CaseCmd -- ! 62: * ! 63: * This procedure is invoked to process the "case" Tcl command. ! 64: * See the user documentation for details on what it does. ! 65: * ! 66: * Results: ! 67: * A standard Tcl result. ! 68: * ! 69: * Side effects: ! 70: * See the user documentation. ! 71: * ! 72: *---------------------------------------------------------------------- ! 73: */ ! 74: ! 75: /* ARGSUSED */ ! 76: int ! 77: Tcl_CaseCmd(dummy, interp, argc, argv) ! 78: ClientData dummy; /* Not used. */ ! 79: Tcl_Interp *interp; /* Current interpreter. */ ! 80: int argc; /* Number of arguments. */ ! 81: char **argv; /* Argument strings. */ ! 82: { ! 83: int i, result; ! 84: int body; ! 85: char *string; ! 86: int caseArgc, splitArgs; ! 87: char **caseArgv; ! 88: ! 89: if (argc < 3) { ! 90: Tcl_AppendResult(interp, "wrong # args: should be \"", ! 91: argv[0], " string ?in? patList body ... ?default body?\"", ! 92: (char *) NULL); ! 93: return TCL_ERROR; ! 94: } ! 95: string = argv[1]; ! 96: body = -1; ! 97: if (strcmp(argv[2], "in") == 0) { ! 98: i = 3; ! 99: } else { ! 100: i = 2; ! 101: } ! 102: caseArgc = argc - i; ! 103: caseArgv = argv + i; ! 104: ! 105: /* ! 106: * If all of the pattern/command pairs are lumped into a single ! 107: * argument, split them out again. ! 108: */ ! 109: ! 110: splitArgs = 0; ! 111: if (caseArgc == 1) { ! 112: result = Tcl_SplitList(interp, caseArgv[0], &caseArgc, &caseArgv); ! 113: if (result != TCL_OK) { ! 114: return result; ! 115: } ! 116: splitArgs = 1; ! 117: } ! 118: ! 119: for (i = 0; i < caseArgc; i += 2) { ! 120: int patArgc, j; ! 121: char **patArgv; ! 122: register char *p; ! 123: ! 124: if (i == (caseArgc-1)) { ! 125: interp->result = "extra case pattern with no body"; ! 126: result = TCL_ERROR; ! 127: goto cleanup; ! 128: } ! 129: ! 130: /* ! 131: * Check for special case of single pattern (no list) with ! 132: * no backslash sequences. ! 133: */ ! 134: ! 135: for (p = caseArgv[i]; *p != 0; p++) { ! 136: if (isspace(*p) || (*p == '\\')) { ! 137: break; ! 138: } ! 139: } ! 140: if (*p == 0) { ! 141: if ((*caseArgv[i] == 'd') ! 142: && (strcmp(caseArgv[i], "default") == 0)) { ! 143: body = i+1; ! 144: } ! 145: if (Tcl_StringMatch(string, caseArgv[i])) { ! 146: body = i+1; ! 147: goto match; ! 148: } ! 149: continue; ! 150: } ! 151: ! 152: /* ! 153: * Break up pattern lists, then check each of the patterns ! 154: * in the list. ! 155: */ ! 156: ! 157: result = Tcl_SplitList(interp, caseArgv[i], &patArgc, &patArgv); ! 158: if (result != TCL_OK) { ! 159: goto cleanup; ! 160: } ! 161: for (j = 0; j < patArgc; j++) { ! 162: if (Tcl_StringMatch(string, patArgv[j])) { ! 163: body = i+1; ! 164: break; ! 165: } ! 166: } ! 167: ckfree((char *) patArgv); ! 168: if (j < patArgc) { ! 169: break; ! 170: } ! 171: } ! 172: ! 173: match: ! 174: if (body != -1) { ! 175: result = Tcl_Eval(interp, caseArgv[body], 0, (char **) NULL); ! 176: if (result == TCL_ERROR) { ! 177: char msg[100]; ! 178: sprintf(msg, "\n (\"%.50s\" arm line %d)", caseArgv[body-1], ! 179: interp->errorLine); ! 180: Tcl_AddErrorInfo(interp, msg); ! 181: } ! 182: goto cleanup; ! 183: } ! 184: ! 185: /* ! 186: * Nothing matched: return nothing. ! 187: */ ! 188: ! 189: result = TCL_OK; ! 190: ! 191: cleanup: ! 192: if (splitArgs) { ! 193: ckfree((char *) caseArgv); ! 194: } ! 195: return result; ! 196: } ! 197: ! 198: /* ! 199: *---------------------------------------------------------------------- ! 200: * ! 201: * Tcl_CatchCmd -- ! 202: * ! 203: * This procedure is invoked to process the "catch" Tcl command. ! 204: * See the user documentation for details on what it does. ! 205: * ! 206: * Results: ! 207: * A standard Tcl result. ! 208: * ! 209: * Side effects: ! 210: * See the user documentation. ! 211: * ! 212: *---------------------------------------------------------------------- ! 213: */ ! 214: ! 215: /* ARGSUSED */ ! 216: int ! 217: Tcl_CatchCmd(dummy, interp, argc, argv) ! 218: ClientData dummy; /* Not used. */ ! 219: Tcl_Interp *interp; /* Current interpreter. */ ! 220: int argc; /* Number of arguments. */ ! 221: char **argv; /* Argument strings. */ ! 222: { ! 223: int result; ! 224: ! 225: if ((argc != 2) && (argc != 3)) { ! 226: Tcl_AppendResult(interp, "wrong # args: should be \"", ! 227: argv[0], " command ?varName?\"", (char *) NULL); ! 228: return TCL_ERROR; ! 229: } ! 230: result = Tcl_Eval(interp, argv[1], 0, (char **) NULL); ! 231: if (argc == 3) { ! 232: if (Tcl_SetVar(interp, argv[2], interp->result, 0) == NULL) { ! 233: Tcl_SetResult(interp, "couldn't save command result in variable", ! 234: TCL_STATIC); ! 235: return TCL_ERROR; ! 236: } ! 237: } ! 238: Tcl_ResetResult(interp); ! 239: sprintf(interp->result, "%d", result); ! 240: return TCL_OK; ! 241: } ! 242: ! 243: /* ! 244: *---------------------------------------------------------------------- ! 245: * ! 246: * Tcl_ConcatCmd -- ! 247: * ! 248: * This procedure is invoked to process the "concat" Tcl command. ! 249: * See the user documentation for details on what it does. ! 250: * ! 251: * Results: ! 252: * A standard Tcl result. ! 253: * ! 254: * Side effects: ! 255: * See the user documentation. ! 256: * ! 257: *---------------------------------------------------------------------- ! 258: */ ! 259: ! 260: /* ARGSUSED */ ! 261: int ! 262: Tcl_ConcatCmd(dummy, interp, argc, argv) ! 263: ClientData dummy; /* Not used. */ ! 264: Tcl_Interp *interp; /* Current interpreter. */ ! 265: int argc; /* Number of arguments. */ ! 266: char **argv; /* Argument strings. */ ! 267: { ! 268: if (argc == 1) { ! 269: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], ! 270: " arg ?arg ...?\"", (char *) NULL); ! 271: return TCL_ERROR; ! 272: } ! 273: ! 274: interp->result = Tcl_Concat(argc-1, argv+1); ! 275: interp->freeProc = (Tcl_FreeProc *) free; ! 276: return TCL_OK; ! 277: } ! 278: ! 279: /* ! 280: *---------------------------------------------------------------------- ! 281: * ! 282: * Tcl_ContinueCmd -- ! 283: * ! 284: * This procedure is invoked to process the "continue" Tcl command. ! 285: * See the user documentation for details on what it does. ! 286: * ! 287: * Results: ! 288: * A standard Tcl result. ! 289: * ! 290: * Side effects: ! 291: * See the user documentation. ! 292: * ! 293: *---------------------------------------------------------------------- ! 294: */ ! 295: ! 296: /* ARGSUSED */ ! 297: int ! 298: Tcl_ContinueCmd(dummy, interp, argc, argv) ! 299: ClientData dummy; /* Not used. */ ! 300: Tcl_Interp *interp; /* Current interpreter. */ ! 301: int argc; /* Number of arguments. */ ! 302: char **argv; /* Argument strings. */ ! 303: { ! 304: if (argc != 1) { ! 305: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], ! 306: "\"", (char *) NULL); ! 307: return TCL_ERROR; ! 308: } ! 309: return TCL_CONTINUE; ! 310: } ! 311: ! 312: /* ! 313: *---------------------------------------------------------------------- ! 314: * ! 315: * Tcl_ErrorCmd -- ! 316: * ! 317: * This procedure is invoked to process the "error" Tcl command. ! 318: * See the user documentation for details on what it does. ! 319: * ! 320: * Results: ! 321: * A standard Tcl result. ! 322: * ! 323: * Side effects: ! 324: * See the user documentation. ! 325: * ! 326: *---------------------------------------------------------------------- ! 327: */ ! 328: ! 329: /* ARGSUSED */ ! 330: int ! 331: Tcl_ErrorCmd(dummy, interp, argc, argv) ! 332: ClientData dummy; /* Not used. */ ! 333: Tcl_Interp *interp; /* Current interpreter. */ ! 334: int argc; /* Number of arguments. */ ! 335: char **argv; /* Argument strings. */ ! 336: { ! 337: Interp *iPtr = (Interp *) interp; ! 338: ! 339: if ((argc < 2) || (argc > 4)) { ! 340: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], ! 341: " message ?errorInfo? ?errorCode?\"", (char *) NULL); ! 342: return TCL_ERROR; ! 343: } ! 344: if ((argc >= 3) && (argv[2][0] != 0)) { ! 345: Tcl_AddErrorInfo(interp, argv[2]); ! 346: iPtr->flags |= ERR_ALREADY_LOGGED; ! 347: } ! 348: if (argc == 4) { ! 349: Tcl_SetVar2(interp, "errorCode", (char *) NULL, argv[3], ! 350: TCL_GLOBAL_ONLY); ! 351: iPtr->flags |= ERROR_CODE_SET; ! 352: } ! 353: Tcl_SetResult(interp, argv[1], TCL_VOLATILE); ! 354: return TCL_ERROR; ! 355: } ! 356: ! 357: /* ! 358: *---------------------------------------------------------------------- ! 359: * ! 360: * Tcl_EvalCmd -- ! 361: * ! 362: * This procedure is invoked to process the "eval" Tcl command. ! 363: * See the user documentation for details on what it does. ! 364: * ! 365: * Results: ! 366: * A standard Tcl result. ! 367: * ! 368: * Side effects: ! 369: * See the user documentation. ! 370: * ! 371: *---------------------------------------------------------------------- ! 372: */ ! 373: ! 374: /* ARGSUSED */ ! 375: int ! 376: Tcl_EvalCmd(dummy, interp, argc, argv) ! 377: ClientData dummy; /* Not used. */ ! 378: Tcl_Interp *interp; /* Current interpreter. */ ! 379: int argc; /* Number of arguments. */ ! 380: char **argv; /* Argument strings. */ ! 381: { ! 382: int result; ! 383: char *cmd; ! 384: ! 385: if (argc < 2) { ! 386: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], ! 387: " arg ?arg ...?\"", (char *) NULL); ! 388: return TCL_ERROR; ! 389: } ! 390: if (argc == 2) { ! 391: result = Tcl_Eval(interp, argv[1], 0, (char **) NULL); ! 392: } else { ! 393: ! 394: /* ! 395: * More than one argument: concatenate them together with spaces ! 396: * between, then evaluate the result. ! 397: */ ! 398: ! 399: cmd = Tcl_Concat(argc-1, argv+1); ! 400: result = Tcl_Eval(interp, cmd, 0, (char **) NULL); ! 401: ckfree(cmd); ! 402: } ! 403: if (result == TCL_ERROR) { ! 404: char msg[60]; ! 405: sprintf(msg, "\n (\"eval\" body line %d)", interp->errorLine); ! 406: Tcl_AddErrorInfo(interp, msg); ! 407: } ! 408: return result; ! 409: } ! 410: ! 411: /* ! 412: *---------------------------------------------------------------------- ! 413: * ! 414: * Tcl_ExprCmd -- ! 415: * ! 416: * This procedure is invoked to process the "expr" Tcl command. ! 417: * See the user documentation for details on what it does. ! 418: * ! 419: * Results: ! 420: * A standard Tcl result. ! 421: * ! 422: * Side effects: ! 423: * See the user documentation. ! 424: * ! 425: *---------------------------------------------------------------------- ! 426: */ ! 427: ! 428: /* ARGSUSED */ ! 429: int ! 430: Tcl_ExprCmd(dummy, interp, argc, argv) ! 431: ClientData dummy; /* Not used. */ ! 432: Tcl_Interp *interp; /* Current interpreter. */ ! 433: int argc; /* Number of arguments. */ ! 434: char **argv; /* Argument strings. */ ! 435: { ! 436: if (argc != 2) { ! 437: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], ! 438: " expression\"", (char *) NULL); ! 439: return TCL_ERROR; ! 440: } ! 441: ! 442: return Tcl_ExprString(interp, argv[1]); ! 443: } ! 444: ! 445: /* ! 446: *---------------------------------------------------------------------- ! 447: * ! 448: * Tcl_ForCmd -- ! 449: * ! 450: * This procedure is invoked to process the "for" Tcl command. ! 451: * See the user documentation for details on what it does. ! 452: * ! 453: * Results: ! 454: * A standard Tcl result. ! 455: * ! 456: * Side effects: ! 457: * See the user documentation. ! 458: * ! 459: *---------------------------------------------------------------------- ! 460: */ ! 461: ! 462: /* ARGSUSED */ ! 463: int ! 464: Tcl_ForCmd(dummy, interp, argc, argv) ! 465: ClientData dummy; /* Not used. */ ! 466: Tcl_Interp *interp; /* Current interpreter. */ ! 467: int argc; /* Number of arguments. */ ! 468: char **argv; /* Argument strings. */ ! 469: { ! 470: int result, value; ! 471: ! 472: if (argc != 5) { ! 473: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], ! 474: " start test next command\"", (char *) NULL); ! 475: return TCL_ERROR; ! 476: } ! 477: ! 478: result = Tcl_Eval(interp, argv[1], 0, (char **) NULL); ! 479: if (result != TCL_OK) { ! 480: if (result == TCL_ERROR) { ! 481: Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)"); ! 482: } ! 483: return result; ! 484: } ! 485: while (1) { ! 486: result = Tcl_ExprBoolean(interp, argv[2], &value); ! 487: if (result != TCL_OK) { ! 488: return result; ! 489: } ! 490: if (!value) { ! 491: break; ! 492: } ! 493: result = Tcl_Eval(interp, argv[4], 0, (char **) NULL); ! 494: if (result == TCL_CONTINUE) { ! 495: result = TCL_OK; ! 496: } else if (result != TCL_OK) { ! 497: if (result == TCL_ERROR) { ! 498: char msg[60]; ! 499: sprintf(msg, "\n (\"for\" body line %d)", interp->errorLine); ! 500: Tcl_AddErrorInfo(interp, msg); ! 501: } ! 502: break; ! 503: } ! 504: result = Tcl_Eval(interp, argv[3], 0, (char **) NULL); ! 505: if (result == TCL_BREAK) { ! 506: break; ! 507: } else if (result != TCL_OK) { ! 508: if (result == TCL_ERROR) { ! 509: Tcl_AddErrorInfo(interp, "\n (\"for\" loop-end command)"); ! 510: } ! 511: return result; ! 512: } ! 513: } ! 514: if (result == TCL_BREAK) { ! 515: result = TCL_OK; ! 516: } ! 517: if (result == TCL_OK) { ! 518: Tcl_ResetResult(interp); ! 519: } ! 520: return result; ! 521: } ! 522: ! 523: /* ! 524: *---------------------------------------------------------------------- ! 525: * ! 526: * Tcl_ForeachCmd -- ! 527: * ! 528: * This procedure is invoked to process the "foreach" Tcl command. ! 529: * See the user documentation for details on what it does. ! 530: * ! 531: * Results: ! 532: * A standard Tcl result. ! 533: * ! 534: * Side effects: ! 535: * See the user documentation. ! 536: * ! 537: *---------------------------------------------------------------------- ! 538: */ ! 539: ! 540: /* ARGSUSED */ ! 541: int ! 542: Tcl_ForeachCmd(dummy, interp, argc, argv) ! 543: ClientData dummy; /* Not used. */ ! 544: Tcl_Interp *interp; /* Current interpreter. */ ! 545: int argc; /* Number of arguments. */ ! 546: char **argv; /* Argument strings. */ ! 547: { ! 548: int listArgc, i, result; ! 549: char **listArgv; ! 550: ! 551: if (argc != 4) { ! 552: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], ! 553: " varName list command\"", (char *) NULL); ! 554: return TCL_ERROR; ! 555: } ! 556: ! 557: /* ! 558: * Break the list up into elements, and execute the command once ! 559: * for each value of the element. ! 560: */ ! 561: ! 562: result = Tcl_SplitList(interp, argv[2], &listArgc, &listArgv); ! 563: if (result != TCL_OK) { ! 564: return result; ! 565: } ! 566: for (i = 0; i < listArgc; i++) { ! 567: if (Tcl_SetVar(interp, argv[1], listArgv[i], 0) == NULL) { ! 568: Tcl_SetResult(interp, "couldn't set loop variable", TCL_STATIC); ! 569: result = TCL_ERROR; ! 570: break; ! 571: } ! 572: ! 573: result = Tcl_Eval(interp, argv[3], 0, (char **) NULL); ! 574: if (result != TCL_OK) { ! 575: if (result == TCL_CONTINUE) { ! 576: result = TCL_OK; ! 577: } else if (result == TCL_BREAK) { ! 578: result = TCL_OK; ! 579: break; ! 580: } else if (result == TCL_ERROR) { ! 581: char msg[100]; ! 582: sprintf(msg, "\n (\"foreach\" body line %d)", ! 583: interp->errorLine); ! 584: Tcl_AddErrorInfo(interp, msg); ! 585: break; ! 586: } else { ! 587: break; ! 588: } ! 589: } ! 590: } ! 591: ckfree((char *) listArgv); ! 592: if (result == TCL_OK) { ! 593: Tcl_ResetResult(interp); ! 594: } ! 595: return result; ! 596: } ! 597: ! 598: /* ! 599: *---------------------------------------------------------------------- ! 600: * ! 601: * Tcl_FormatCmd -- ! 602: * ! 603: * This procedure is invoked to process the "format" Tcl command. ! 604: * See the user documentation for details on what it does. ! 605: * ! 606: * Results: ! 607: * A standard Tcl result. ! 608: * ! 609: * Side effects: ! 610: * See the user documentation. ! 611: * ! 612: *---------------------------------------------------------------------- ! 613: */ ! 614: ! 615: /* ARGSUSED */ ! 616: int ! 617: Tcl_FormatCmd(dummy, interp, argc, argv) ! 618: ClientData dummy; /* Not used. */ ! 619: Tcl_Interp *interp; /* Current interpreter. */ ! 620: int argc; /* Number of arguments. */ ! 621: char **argv; /* Argument strings. */ ! 622: { ! 623: register char *format; /* Used to read characters from the format ! 624: * string. */ ! 625: char newFormat[40]; /* A new format specifier is generated here. */ ! 626: int width; /* Field width from field specifier, or 0 if ! 627: * no width given. */ ! 628: int precision; /* Field precision from field specifier, or 0 ! 629: * if no precision given. */ ! 630: int size; /* Number of bytes needed for result of ! 631: * conversion, based on type of conversion ! 632: * ("e", "s", etc.) and width from above. */ ! 633: char *oneWordValue = NULL; /* Used to hold value to pass to sprintf, if ! 634: * it's a one-word value. */ ! 635: double twoWordValue; /* Used to hold value to pass to sprintf if ! 636: * it's a two-word value. */ ! 637: int useTwoWords; /* 0 means use oneWordValue, 1 means use ! 638: * twoWordValue. */ ! 639: char *dst = interp->result; /* Where result is stored. Starts off at ! 640: * interp->resultSpace, but may get dynamically ! 641: * re-allocated if this isn't enough. */ ! 642: int dstSize = 0; /* Number of non-null characters currently ! 643: * stored at dst. */ ! 644: int dstSpace = TCL_RESULT_SIZE; ! 645: /* Total amount of storage space available ! 646: * in dst (not including null terminator. */ ! 647: int noPercent; /* Special case for speed: indicates there's ! 648: * no field specifier, just a string to copy. */ ! 649: char **curArg; /* Remainder of argv array. */ ! 650: int useShort; /* Value to be printed is short (half word). */ ! 651: ! 652: /* ! 653: * This procedure is a bit nasty. The goal is to use sprintf to ! 654: * do most of the dirty work. There are several problems: ! 655: * 1. this procedure can't trust its arguments. ! 656: * 2. we must be able to provide a large enough result area to hold ! 657: * whatever's generated. This is hard to estimate. ! 658: * 2. there's no way to move the arguments from argv to the call ! 659: * to sprintf in a reasonable way. This is particularly nasty ! 660: * because some of the arguments may be two-word values (doubles). ! 661: * So, what happens here is to scan the format string one % group ! 662: * at a time, making many individual calls to sprintf. ! 663: */ ! 664: ! 665: if (argc < 2) { ! 666: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], ! 667: " formatString ?arg arg ...?\"", (char *) NULL); ! 668: return TCL_ERROR; ! 669: } ! 670: curArg = argv+2; ! 671: argc -= 2; ! 672: for (format = argv[1]; *format != 0; ) { ! 673: register char *newPtr = newFormat; ! 674: ! 675: width = precision = useTwoWords = noPercent = useShort = 0; ! 676: ! 677: /* ! 678: * Get rid of any characters before the next field specifier. ! 679: * Collapse backslash sequences found along the way. ! 680: */ ! 681: ! 682: if (*format != '%') { ! 683: register char *p; ! 684: int bsSize; ! 685: ! 686: oneWordValue = p = format; ! 687: while ((*format != '%') && (*format != 0)) { ! 688: if (*format == '\\') { ! 689: *p = Tcl_Backslash(format, &bsSize); ! 690: if (*p != 0) { ! 691: p++; ! 692: } ! 693: format += bsSize; ! 694: } else { ! 695: *p = *format; ! 696: p++; ! 697: format++; ! 698: } ! 699: } ! 700: size = p - oneWordValue; ! 701: noPercent = 1; ! 702: goto doField; ! 703: } ! 704: ! 705: if (format[1] == '%') { ! 706: oneWordValue = format; ! 707: size = 1; ! 708: noPercent = 1; ! 709: format += 2; ! 710: goto doField; ! 711: } ! 712: ! 713: /* ! 714: * Parse off a field specifier, compute how many characters ! 715: * will be needed to store the result, and substitute for ! 716: * "*" size specifiers. ! 717: */ ! 718: ! 719: *newPtr = '%'; ! 720: newPtr++; ! 721: format++; ! 722: while ((*format == '-') || (*format == '#')) { ! 723: *newPtr = *format; ! 724: newPtr++; ! 725: format++; ! 726: } ! 727: if (*format == '0') { ! 728: *newPtr = '0'; ! 729: newPtr++; ! 730: format++; ! 731: } ! 732: if (isdigit(*format)) { ! 733: width = atoi(format); ! 734: do { ! 735: format++; ! 736: } while (isdigit(*format)); ! 737: } else if (*format == '*') { ! 738: if (argc <= 0) { ! 739: goto notEnoughArgs; ! 740: } ! 741: if (Tcl_GetInt(interp, *curArg, &width) != TCL_OK) { ! 742: goto fmtError; ! 743: } ! 744: argc--; ! 745: curArg++; ! 746: format++; ! 747: } ! 748: if (width != 0) { ! 749: sprintf(newPtr, "%d", width); ! 750: while (*newPtr != 0) { ! 751: newPtr++; ! 752: } ! 753: } ! 754: if (*format == '.') { ! 755: *newPtr = '.'; ! 756: newPtr++; ! 757: format++; ! 758: } ! 759: if (isdigit(*format)) { ! 760: precision = atoi(format); ! 761: do { ! 762: format++; ! 763: } while (isdigit(*format)); ! 764: } else if (*format == '*') { ! 765: if (argc <= 0) { ! 766: goto notEnoughArgs; ! 767: } ! 768: if (Tcl_GetInt(interp, *curArg, &precision) != TCL_OK) { ! 769: goto fmtError; ! 770: } ! 771: argc--; ! 772: curArg++; ! 773: format++; ! 774: } ! 775: if (precision != 0) { ! 776: sprintf(newPtr, "%d", precision); ! 777: while (*newPtr != 0) { ! 778: newPtr++; ! 779: } ! 780: } ! 781: if (*format == 'l') { ! 782: format++; ! 783: } else if (*format == 'h') { ! 784: useShort = 1; ! 785: *newPtr = 'h'; ! 786: newPtr++; ! 787: format++; ! 788: } ! 789: *newPtr = *format; ! 790: newPtr++; ! 791: *newPtr = 0; ! 792: if (argc <= 0) { ! 793: goto notEnoughArgs; ! 794: } ! 795: switch (*format) { ! 796: case 'D': ! 797: case 'O': ! 798: case 'U': ! 799: if (!useShort) { ! 800: newPtr++; ! 801: } else { ! 802: useShort = 0; ! 803: } ! 804: newPtr[-1] = tolower(*format); ! 805: newPtr[-2] = 'l'; ! 806: *newPtr = 0; ! 807: case 'd': ! 808: case 'o': ! 809: case 'u': ! 810: case 'x': ! 811: case 'X': ! 812: if (Tcl_GetInt(interp, *curArg, (int *) &oneWordValue) ! 813: != TCL_OK) { ! 814: goto fmtError; ! 815: } ! 816: size = 40; ! 817: break; ! 818: case 's': ! 819: oneWordValue = *curArg; ! 820: size = strlen(*curArg); ! 821: break; ! 822: case 'c': ! 823: if (Tcl_GetInt(interp, *curArg, (int *) &oneWordValue) ! 824: != TCL_OK) { ! 825: goto fmtError; ! 826: } ! 827: size = 1; ! 828: break; ! 829: case 'F': ! 830: newPtr[-1] = tolower(newPtr[-1]); ! 831: case 'e': ! 832: case 'E': ! 833: case 'f': ! 834: case 'g': ! 835: case 'G': ! 836: if (Tcl_GetDouble(interp, *curArg, &twoWordValue) != TCL_OK) { ! 837: goto fmtError; ! 838: } ! 839: useTwoWords = 1; ! 840: size = 320; ! 841: if (precision > 10) { ! 842: size += precision; ! 843: } ! 844: break; ! 845: case 0: ! 846: interp->result = ! 847: "format string ended in middle of field specifier"; ! 848: goto fmtError; ! 849: default: ! 850: sprintf(interp->result, "bad field specifier \"%c\"", *format); ! 851: goto fmtError; ! 852: } ! 853: argc--; ! 854: curArg++; ! 855: format++; ! 856: ! 857: /* ! 858: * Make sure that there's enough space to hold the formatted ! 859: * result, then format it. ! 860: */ ! 861: ! 862: doField: ! 863: if (width > size) { ! 864: size = width; ! 865: } ! 866: if ((dstSize + size) > dstSpace) { ! 867: char *newDst; ! 868: int newSpace; ! 869: ! 870: newSpace = 2*(dstSize + size); ! 871: newDst = (char *) ckalloc((unsigned) newSpace+1); ! 872: if (dstSize != 0) { ! 873: memcpy((VOID *) newDst, (VOID *) dst, dstSize); ! 874: } ! 875: if (dstSpace != TCL_RESULT_SIZE) { ! 876: ckfree(dst); ! 877: } ! 878: dst = newDst; ! 879: dstSpace = newSpace; ! 880: } ! 881: if (noPercent) { ! 882: memcpy((VOID *) (dst+dstSize), (VOID *) oneWordValue, size); ! 883: dstSize += size; ! 884: dst[dstSize] = 0; ! 885: } else { ! 886: if (useTwoWords) { ! 887: sprintf(dst+dstSize, newFormat, twoWordValue); ! 888: } else if (useShort) { ! 889: int tmp = (int)oneWordValue; ! 890: sprintf(dst+dstSize, newFormat, (short)tmp); ! 891: } else { ! 892: sprintf(dst+dstSize, newFormat, oneWordValue); ! 893: } ! 894: dstSize += strlen(dst+dstSize); ! 895: } ! 896: } ! 897: ! 898: interp->result = dst; ! 899: if (dstSpace != TCL_RESULT_SIZE) { ! 900: interp->freeProc = (Tcl_FreeProc *) free; ! 901: } else { ! 902: interp->freeProc = 0; ! 903: } ! 904: return TCL_OK; ! 905: ! 906: notEnoughArgs: ! 907: interp->result = "not enough arguments for all format specifiers"; ! 908: fmtError: ! 909: if (dstSpace != TCL_RESULT_SIZE) { ! 910: ckfree(dst); ! 911: } ! 912: return TCL_ERROR; ! 913: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.