![[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.