Fork me on GitHub

source: git/external/tcl/tclCmdAH.c@ d7d2da3

ImprovedOutputFile Timing dual_readout llp 3.0.6
Last change on this file since d7d2da3 was d7d2da3, checked in by pavel <pavel@…>, 12 years ago

move branches/ModularDelphes to trunk
  • Property mode set to 100644
File size: 30.9 KB
RevLine 
[d7d2da3]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 (c) 1987-1993 The Regents of the University of California.
9 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
10 *
11 * See the file "license.terms" for information on usage and redistribution
12 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
13 *
14 * RCS: @(#) $Id: tclCmdAH.c,v 1.1 2008-06-04 13:58:04 demin Exp $
15 */
16
17#include "tclInt.h"
18#include "tclPort.h"
19
20/*
21 *----------------------------------------------------------------------
22 *
23 * Tcl_BreakCmd --
24 *
25 * This procedure is invoked to process the "break" Tcl command.
26 * See the user documentation for details on what it does.
27 *
28 * With the bytecode compiler, this procedure is only called when
29 * a command name is computed at runtime, and is "break" or the name
30 * to which "break" was renamed: e.g., "set z break; $z"
31 *
32 * Results:
33 * A standard Tcl result.
34 *
35 * Side effects:
36 * See the user documentation.
37 *
38 *----------------------------------------------------------------------
39 */
40
41 /* ARGSUSED */
42int
43Tcl_BreakCmd(dummy, interp, argc, argv)
44 ClientData dummy; /* Not used. */
45 Tcl_Interp *interp; /* Current interpreter. */
46 int argc; /* Number of arguments. */
47 char **argv; /* Argument strings. */
48{
49 if (argc != 1) {
50 Tcl_AppendResult(interp, "wrong # args: should be \"",
51 argv[0], "\"", (char *) NULL);
52 return TCL_ERROR;
53 }
54 return TCL_BREAK;
55}
56
57
58/*
59 *----------------------------------------------------------------------
60 *
61 * Tcl_CaseObjCmd --
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 object result.
68 *
69 * Side effects:
70 * See the user documentation.
71 *
72 *----------------------------------------------------------------------
73 */
74
75 /* ARGSUSED */
76int
77Tcl_CaseObjCmd(dummy, interp, objc, objv)
78 ClientData dummy; /* Not used. */
79 Tcl_Interp *interp; /* Current interpreter. */
80 int objc; /* Number of arguments. */
81 Tcl_Obj *CONST objv[]; /* Argument objects. */
82{
83 register int i;
84 int body, result;
85 char *string, *arg;
86 int argLen, caseObjc;
87 Tcl_Obj *CONST *caseObjv;
88 Tcl_Obj *armPtr;
89
90 if (objc < 3) {
91 Tcl_WrongNumArgs(interp, 1, objv,
92 "string ?in? patList body ... ?default body?");
93 return TCL_ERROR;
94 }
95
96 /*
97 * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE.
98 */
99
100 string = Tcl_GetStringFromObj(objv[1], &argLen);
101 body = -1;
102
103 arg = Tcl_GetStringFromObj(objv[2], &argLen);
104 if (strcmp(arg, "in") == 0) {
105 i = 3;
106 } else {
107 i = 2;
108 }
109 caseObjc = objc - i;
110 caseObjv = objv + i;
111
112 /*
113 * If all of the pattern/command pairs are lumped into a single
114 * argument, split them out again.
115 * THIS FAILS IF THE ARG'S STRING REP CONTAINS A NULL
116 */
117
118 if (caseObjc == 1) {
119 Tcl_Obj **newObjv;
120
121 Tcl_ListObjGetElements(interp, caseObjv[0], &caseObjc, &newObjv);
122 caseObjv = newObjv;
123 }
124
125 for (i = 0; i < caseObjc; i += 2) {
126 int patObjc, j;
127 char **patObjv;
128 char *pat;
129 register char *p;
130
131 if (i == (caseObjc-1)) {
132 Tcl_ResetResult(interp);
133 Tcl_AppendToObj(Tcl_GetObjResult(interp),
134 "extra case pattern with no body", -1);
135 return TCL_ERROR;
136 }
137
138 /*
139 * Check for special case of single pattern (no list) with
140 * no backslash sequences.
141 */
142
143 pat = Tcl_GetStringFromObj(caseObjv[i], &argLen);
144 for (p = pat; *p != 0; p++) { /* FAILS IF NULL BYTE */
145 if (isspace(UCHAR(*p)) || (*p == '\\')) {
146 break;
147 }
148 }
149 if (*p == 0) {
150 if ((*pat == 'd') && (strcmp(pat, "default") == 0)) {
151 body = i+1;
152 }
153 if (Tcl_StringMatch(string, pat)) {
154 body = i+1;
155 goto match;
156 }
157 continue;
158 }
159
160
161 /*
162 * Break up pattern lists, then check each of the patterns
163 * in the list.
164 */
165
166 result = Tcl_SplitList(interp, pat, &patObjc, &patObjv);
167 if (result != TCL_OK) {
168 return result;
169 }
170 for (j = 0; j < patObjc; j++) {
171 if (Tcl_StringMatch(string, patObjv[j])) {
172 body = i+1;
173 break;
174 }
175 }
176 ckfree((char *) patObjv);
177 if (j < patObjc) {
178 break;
179 }
180 }
181
182 match:
183 if (body != -1) {
184 armPtr = caseObjv[body-1];
185 result = Tcl_EvalObj(interp, caseObjv[body]);
186 if (result == TCL_ERROR) {
187 char msg[100];
188
189 arg = Tcl_GetStringFromObj(armPtr, &argLen);
190 sprintf(msg, "\n (\"%.*s\" arm line %d)", argLen, arg,
191 interp->errorLine);
192 Tcl_AddObjErrorInfo(interp, msg, -1);
193 }
194 return result;
195 }
196
197 /*
198 * Nothing matched: return nothing.
199 */
200
201 return TCL_OK;
202}
203
204
205/*
206 *----------------------------------------------------------------------
207 *
208 * Tcl_CatchObjCmd --
209 *
210 * This object-based procedure is invoked to process the "catch" Tcl
211 * command. See the user documentation for details on what it does.
212 *
213 * Results:
214 * A standard Tcl object result.
215 *
216 * Side effects:
217 * See the user documentation.
218 *
219 *----------------------------------------------------------------------
220 */
221
222 /* ARGSUSED */
223int
224Tcl_CatchObjCmd(dummy, interp, objc, objv)
225 ClientData dummy; /* Not used. */
226 Tcl_Interp *interp; /* Current interpreter. */
227 int objc; /* Number of arguments. */
228 Tcl_Obj *CONST objv[]; /* Argument objects. */
229{
230 Tcl_Obj *varNamePtr = NULL;
231 int result;
232
233 if ((objc != 2) && (objc != 3)) {
234 Tcl_WrongNumArgs(interp, 1, objv, "command ?varName?");
235 return TCL_ERROR;
236 }
237
238 /*
239 * Save a pointer to the variable name object, if any, in case the
240 * Tcl_EvalObj reallocates the bytecode interpreter's evaluation
241 * stack rendering objv invalid.
242 */
243
244 if (objc == 3) {
245 varNamePtr = objv[2];
246 }
247
248 result = Tcl_EvalObj(interp, objv[1]);
249
250 if (objc == 3) {
251 if (Tcl_ObjSetVar2(interp, varNamePtr, NULL,
252 Tcl_GetObjResult(interp), TCL_PARSE_PART1) == NULL) {
253 Tcl_ResetResult(interp);
254 Tcl_AppendToObj(Tcl_GetObjResult(interp),
255 "couldn't save command result in variable", -1);
256 return TCL_ERROR;
257 }
258 }
259
260 /*
261 * Set the interpreter's object result to an integer object holding the
262 * integer Tcl_EvalObj result. Note that we don't bother generating a
263 * string representation. We reset the interpreter's object result
264 * to an unshared empty object and then set it to be an integer object.
265 */
266
267 Tcl_ResetResult(interp);
268 Tcl_SetIntObj(Tcl_GetObjResult(interp), result);
269 return TCL_OK;
270}
271
272/*
273 *----------------------------------------------------------------------
274 *
275 * Tcl_ConcatObjCmd --
276 *
277 * This object-based procedure is invoked to process the "concat" Tcl
278 * command. See the user documentation for details on what it does/
279 *
280 * Results:
281 * A standard Tcl object result.
282 *
283 * Side effects:
284 * See the user documentation.
285 *
286 *----------------------------------------------------------------------
287 */
288
289 /* ARGSUSED */
290int
291Tcl_ConcatObjCmd(dummy, interp, objc, objv)
292 ClientData dummy; /* Not used. */
293 Tcl_Interp *interp; /* Current interpreter. */
294 int objc; /* Number of arguments. */
295 Tcl_Obj *CONST objv[]; /* Argument objects. */
296{
297 if (objc >= 2) {
298 Tcl_SetObjResult(interp, Tcl_ConcatObj(objc-1, objv+1));
299 }
300 return TCL_OK;
301}
302
303
304/*
305 *----------------------------------------------------------------------
306 *
307 * Tcl_ContinueCmd -
308 *
309 * This procedure is invoked to process the "continue" Tcl command.
310 * See the user documentation for details on what it does.
311 *
312 * With the bytecode compiler, this procedure is only called when
313 * a command name is computed at runtime, and is "continue" or the name
314 * to which "continue" was renamed: e.g., "set z continue; $z"
315 *
316 * Results:
317 * A standard Tcl result.
318 *
319 * Side effects:
320 * See the user documentation.
321 *
322 *----------------------------------------------------------------------
323 */
324
325 /* ARGSUSED */
326int
327Tcl_ContinueCmd(dummy, interp, argc, argv)
328 ClientData dummy; /* Not used. */
329 Tcl_Interp *interp; /* Current interpreter. */
330 int argc; /* Number of arguments. */
331 char **argv; /* Argument strings. */
332{
333 if (argc != 1) {
334 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
335 "\"", (char *) NULL);
336 return TCL_ERROR;
337 }
338 return TCL_CONTINUE;
339}
340
341
342/*
343 *----------------------------------------------------------------------
344 *
345 * Tcl_ErrorObjCmd --
346 *
347 * This procedure is invoked to process the "error" Tcl command.
348 * See the user documentation for details on what it does.
349 *
350 * Results:
351 * A standard Tcl object result.
352 *
353 * Side effects:
354 * See the user documentation.
355 *
356 *----------------------------------------------------------------------
357 */
358
359 /* ARGSUSED */
360int
361Tcl_ErrorObjCmd(dummy, interp, objc, objv)
362 ClientData dummy; /* Not used. */
363 Tcl_Interp *interp; /* Current interpreter. */
364 int objc; /* Number of arguments. */
365 Tcl_Obj *CONST objv[]; /* Argument objects. */
366{
367 Interp *iPtr = (Interp *) interp;
368 register Tcl_Obj *namePtr;
369 char *info;
370 int infoLen;
371
372 if ((objc < 2) || (objc > 4)) {
373 Tcl_WrongNumArgs(interp, 1, objv, "message ?errorInfo? ?errorCode?");
374 return TCL_ERROR;
375 }
376
377 if (objc >= 3) { /* process the optional info argument */
378 info = Tcl_GetStringFromObj(objv[2], &infoLen);
379 if (*info != 0) {
380 Tcl_AddObjErrorInfo(interp, info, infoLen);
381 iPtr->flags |= ERR_ALREADY_LOGGED;
382 }
383 }
384
385 if (objc == 4) {
386 namePtr = Tcl_NewStringObj("errorCode", -1);
387 Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL, objv[3],
388 TCL_GLOBAL_ONLY);
389 iPtr->flags |= ERROR_CODE_SET;
390 Tcl_DecrRefCount(namePtr); /* we're done with name object */
391 }
392
393 Tcl_SetObjResult(interp, objv[1]);
394 return TCL_ERROR;
395}
396
397
398/*
399 *----------------------------------------------------------------------
400 *
401 * Tcl_EvalObjCmd --
402 *
403 * This object-based procedure is invoked to process the "eval" Tcl
404 * command. See the user documentation for details on what it does.
405 *
406 * Results:
407 * A standard Tcl object result.
408 *
409 * Side effects:
410 * See the user documentation.
411 *
412 *----------------------------------------------------------------------
413 */
414
415 /* ARGSUSED */
416int
417Tcl_EvalObjCmd(dummy, interp, objc, objv)
418 ClientData dummy; /* Not used. */
419 Tcl_Interp *interp; /* Current interpreter. */
420 int objc; /* Number of arguments. */
421 Tcl_Obj *CONST objv[]; /* Argument objects. */
422{
423 int result;
424 register Tcl_Obj *objPtr;
425
426 if (objc < 2) {
427 Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");
428 return TCL_ERROR;
429 }
430
431 if (objc == 2) {
432 result = Tcl_EvalObj(interp, objv[1]);
433 } else {
434 /*
435 * More than one argument: concatenate them together with spaces
436 * between, then evaluate the result.
437 */
438
439 objPtr = Tcl_ConcatObj(objc-1, objv+1);
440 result = Tcl_EvalObj(interp, objPtr);
441 Tcl_DecrRefCount(objPtr); /* we're done with the object */
442 }
443 if (result == TCL_ERROR) {
444 char msg[60];
445 sprintf(msg, "\n (\"eval\" body line %d)", interp->errorLine);
446 Tcl_AddObjErrorInfo(interp, msg, -1);
447 }
448 return result;
449}
450
451/*
452 *----------------------------------------------------------------------
453 *
454 * Tcl_ExprObjCmd --
455 *
456 * This object-based procedure is invoked to process the "expr" Tcl
457 * command. See the user documentation for details on what it does.
458 *
459 * With the bytecode compiler, this procedure is called in two
460 * circumstances: 1) to execute expr commands that are too complicated
461 * or too unsafe to try compiling directly into an inline sequence of
462 * instructions, and 2) to execute commands where the command name is
463 * computed at runtime and is "expr" or the name to which "expr" was
464 * renamed (e.g., "set z expr; $z 2+3")
465 *
466 * Results:
467 * A standard Tcl object result.
468 *
469 * Side effects:
470 * See the user documentation.
471 *
472 *----------------------------------------------------------------------
473 */
474
475 /* ARGSUSED */
476int
477Tcl_ExprObjCmd(dummy, interp, objc, objv)
478 ClientData dummy; /* Not used. */
479 Tcl_Interp *interp; /* Current interpreter. */
480 int objc; /* Number of arguments. */
481 Tcl_Obj *CONST objv[]; /* Argument objects. */
482{
483 register Tcl_Obj *objPtr;
484 Tcl_Obj *resultPtr;
485 register char *bytes;
486 int length, i, result;
487
488 if (objc < 2) {
489 Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");
490 return TCL_ERROR;
491 }
492
493 if (objc == 2) {
494 result = Tcl_ExprObj(interp, objv[1], &resultPtr);
495 if (result == TCL_OK) {
496 Tcl_SetObjResult(interp, resultPtr);
497 Tcl_DecrRefCount(resultPtr); /* done with the result object */
498 }
499 return result;
500 }
501
502 /*
503 * Create a new object holding the concatenated argument strings.
504 * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE.
505 */
506
507 bytes = Tcl_GetStringFromObj(objv[1], &length);
508 objPtr = Tcl_NewStringObj(bytes, length);
509 Tcl_IncrRefCount(objPtr);
510 for (i = 2; i < objc; i++) {
511 Tcl_AppendToObj(objPtr, " ", 1);
512 bytes = Tcl_GetStringFromObj(objv[i], &length);
513 Tcl_AppendToObj(objPtr, bytes, length);
514 }
515
516 /*
517 * Evaluate the concatenated string object.
518 */
519
520 result = Tcl_ExprObj(interp, objPtr, &resultPtr);
521 if (result == TCL_OK) {
522 Tcl_SetObjResult(interp, resultPtr);
523 Tcl_DecrRefCount(resultPtr); /* done with the result object */
524 }
525
526 /*
527 * Free allocated resources.
528 */
529
530 Tcl_DecrRefCount(objPtr);
531 return result;
532}
533
534
535/*
536 *----------------------------------------------------------------------
537 *
538 * Tcl_ForCmd --
539 *
540 * This procedure is invoked to process the "for" Tcl command.
541 * See the user documentation for details on what it does.
542 *
543 * With the bytecode compiler, this procedure is only called when
544 * a command name is computed at runtime, and is "for" or the name
545 * to which "for" was renamed: e.g.,
546 * "set z for; $z {set i 0} {$i<100} {incr i} {puts $i}"
547 *
548 * Results:
549 * A standard Tcl result.
550 *
551 * Side effects:
552 * See the user documentation.
553 *
554 *----------------------------------------------------------------------
555 */
556
557 /* ARGSUSED */
558int
559Tcl_ForCmd(dummy, interp, argc, argv)
560 ClientData dummy; /* Not used. */
561 Tcl_Interp *interp; /* Current interpreter. */
562 int argc; /* Number of arguments. */
563 char **argv; /* Argument strings. */
564{
565 int result, value;
566
567 if (argc != 5) {
568 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
569 " start test next command\"", (char *) NULL);
570 return TCL_ERROR;
571 }
572
573 result = Tcl_Eval(interp, argv[1]);
574 if (result != TCL_OK) {
575 if (result == TCL_ERROR) {
576 Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)");
577 }
578 return result;
579 }
580 while (1) {
581 result = Tcl_ExprBoolean(interp, argv[2], &value);
582 if (result != TCL_OK) {
583 return result;
584 }
585 if (!value) {
586 break;
587 }
588 result = Tcl_Eval(interp, argv[4]);
589 if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
590 if (result == TCL_ERROR) {
591 char msg[60];
592 sprintf(msg, "\n (\"for\" body line %d)",interp->errorLine);
593 Tcl_AddErrorInfo(interp, msg);
594 }
595 break;
596 }
597 result = Tcl_Eval(interp, argv[3]);
598 if (result == TCL_BREAK) {
599 break;
600 } else if (result != TCL_OK) {
601 if (result == TCL_ERROR) {
602 Tcl_AddErrorInfo(interp, "\n (\"for\" loop-end command)");
603 }
604 return result;
605 }
606 }
607 if (result == TCL_BREAK) {
608 result = TCL_OK;
609 }
610 if (result == TCL_OK) {
611 Tcl_ResetResult(interp);
612 }
613 return result;
614}
615
616
617/*
618 *----------------------------------------------------------------------
619 *
620 * Tcl_ForeachObjCmd --
621 *
622 * This object-based procedure is invoked to process the "foreach" Tcl
623 * command. See the user documentation for details on what it does.
624 *
625 * Results:
626 * A standard Tcl object result.
627 *
628 * Side effects:
629 * See the user documentation.
630 *
631 *----------------------------------------------------------------------
632 */
633
634 /* ARGSUSED */
635int
636Tcl_ForeachObjCmd(dummy, interp, objc, objv)
637 ClientData dummy; /* Not used. */
638 Tcl_Interp *interp; /* Current interpreter. */
639 int objc; /* Number of arguments. */
640 Tcl_Obj *CONST objv[]; /* Argument objects. */
641{
642 int result = TCL_OK;
643 int i; /* i selects a value list */
644 int j, maxj; /* Number of loop iterations */
645 int v; /* v selects a loop variable */
646 int numLists; /* Count of value lists */
647 Tcl_Obj *bodyPtr;
648
649 /*
650 * We copy the argument object pointers into a local array to avoid
651 * the problem that "objv" might become invalid. It is a pointer into
652 * the evaluation stack and that stack might be grown and reallocated
653 * if the loop body requires a large amount of stack space.
654 */
655
656#define NUM_ARGS 9
657 Tcl_Obj *(argObjStorage[NUM_ARGS]);
658 Tcl_Obj **argObjv = argObjStorage;
659
660#define STATIC_LIST_SIZE 4
661 int indexArray[STATIC_LIST_SIZE]; /* Array of value list indices */
662 int varcListArray[STATIC_LIST_SIZE]; /* # loop variables per list */
663 Tcl_Obj **varvListArray[STATIC_LIST_SIZE]; /* Array of var name lists */
664 int argcListArray[STATIC_LIST_SIZE]; /* Array of value list sizes */
665 Tcl_Obj **argvListArray[STATIC_LIST_SIZE]; /* Array of value lists */
666
667 int *index = indexArray;
668 int *varcList = varcListArray;
669 Tcl_Obj ***varvList = varvListArray;
670 int *argcList = argcListArray;
671 Tcl_Obj ***argvList = argvListArray;
672
673 if (objc < 4 || (objc%2 != 0)) {
674 Tcl_WrongNumArgs(interp, 1, objv,
675 "varList list ?varList list ...? command");
676 return TCL_ERROR;
677 }
678
679 /*
680 * Create the object argument array "argObjv". Make sure argObjv is
681 * large enough to hold the objc arguments.
682 */
683
684 if (objc > NUM_ARGS) {
685 argObjv = (Tcl_Obj **) ckalloc(objc * sizeof(Tcl_Obj *));
686 }
687 for (i = 0; i < objc; i++) {
688 argObjv[i] = objv[i];
689 }
690
691 /*
692 * Manage numList parallel value lists.
693 * argvList[i] is a value list counted by argcList[i]
694 * varvList[i] is the list of variables associated with the value list
695 * varcList[i] is the number of variables associated with the value list
696 * index[i] is the current pointer into the value list argvList[i]
697 */
698
699 numLists = (objc-2)/2;
700 if (numLists > STATIC_LIST_SIZE) {
701 index = (int *) ckalloc(numLists * sizeof(int));
702 varcList = (int *) ckalloc(numLists * sizeof(int));
703 varvList = (Tcl_Obj ***) ckalloc(numLists * sizeof(Tcl_Obj **));
704 argcList = (int *) ckalloc(numLists * sizeof(int));
705 argvList = (Tcl_Obj ***) ckalloc(numLists * sizeof(Tcl_Obj **));
706 }
707 for (i = 0; i < numLists; i++) {
708 index[i] = 0;
709 varcList[i] = 0;
710 varvList[i] = (Tcl_Obj **) NULL;
711 argcList[i] = 0;
712 argvList[i] = (Tcl_Obj **) NULL;
713 }
714
715 /*
716 * Break up the value lists and variable lists into elements
717 * THIS FAILS IF THE OBJECT'S STRING REP HAS A NULL BYTE.
718 */
719
720 maxj = 0;
721 for (i = 0; i < numLists; i++) {
722 result = Tcl_ListObjGetElements(interp, argObjv[1+i*2],
723 &varcList[i], &varvList[i]);
724 if (result != TCL_OK) {
725 goto done;
726 }
727 if (varcList[i] < 1) {
728 Tcl_AppendToObj(Tcl_GetObjResult(interp),
729 "foreach varlist is empty", -1);
730 result = TCL_ERROR;
731 goto done;
732 }
733
734 result = Tcl_ListObjGetElements(interp, argObjv[2+i*2],
735 &argcList[i], &argvList[i]);
736 if (result != TCL_OK) {
737 goto done;
738 }
739
740 j = argcList[i] / varcList[i];
741 if ((argcList[i] % varcList[i]) != 0) {
742 j++;
743 }
744 if (j > maxj) {
745 maxj = j;
746 }
747 }
748
749 /*
750 * Iterate maxj times through the lists in parallel
751 * If some value lists run out of values, set loop vars to ""
752 */
753
754 bodyPtr = argObjv[objc-1];
755 for (j = 0; j < maxj; j++) {
756 for (i = 0; i < numLists; i++) {
757 /*
758 * If a variable or value list object has been converted to
759 * another kind of Tcl object, convert it back to a list object
760 * and refetch the pointer to its element array.
761 */
762
763 if (argObjv[1+i*2]->typePtr != &tclListType) {
764 result = Tcl_ListObjGetElements(interp, argObjv[1+i*2],
765 &varcList[i], &varvList[i]);
766 if (result != TCL_OK) {
767 panic("Tcl_ForeachObjCmd: could not reconvert variable list %d to a list object\n", i);
768 }
769 }
770 if (argObjv[2+i*2]->typePtr != &tclListType) {
771 result = Tcl_ListObjGetElements(interp, argObjv[2+i*2],
772 &argcList[i], &argvList[i]);
773 if (result != TCL_OK) {
774 panic("Tcl_ForeachObjCmd: could not reconvert value list %d to a list object\n", i);
775 }
776 }
777
778 for (v = 0; v < varcList[i]; v++) {
779 int k = index[i]++;
780 Tcl_Obj *valuePtr, *varValuePtr;
781 int isEmptyObj = 0;
782
783 if (k < argcList[i]) {
784 valuePtr = argvList[i][k];
785 } else {
786 valuePtr = Tcl_NewObj(); /* empty string */
787 isEmptyObj = 1;
788 }
789 varValuePtr = Tcl_ObjSetVar2(interp, varvList[i][v], NULL,
790 valuePtr, TCL_PARSE_PART1);
791 if (varValuePtr == NULL) {
792 if (isEmptyObj) {
793 Tcl_DecrRefCount(valuePtr);
794 }
795 Tcl_ResetResult(interp);
796 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
797 "couldn't set loop variable: \"",
798 Tcl_GetStringFromObj(varvList[i][v], (int *) NULL),
799 "\"", (char *) NULL);
800 result = TCL_ERROR;
801 goto done;
802 }
803
804 }
805 }
806
807 result = Tcl_EvalObj(interp, bodyPtr);
808 if (result != TCL_OK) {
809 if (result == TCL_CONTINUE) {
810 result = TCL_OK;
811 } else if (result == TCL_BREAK) {
812 result = TCL_OK;
813 break;
814 } else if (result == TCL_ERROR) {
815 char msg[100];
816 sprintf(msg, "\n (\"foreach\" body line %d)",
817 interp->errorLine);
818 Tcl_AddObjErrorInfo(interp, msg, -1);
819 break;
820 } else {
821 break;
822 }
823 }
824 }
825 if (result == TCL_OK) {
826 Tcl_ResetResult(interp);
827 }
828
829 done:
830 if (numLists > STATIC_LIST_SIZE) {
831 ckfree((char *) index);
832 ckfree((char *) varcList);
833 ckfree((char *) argcList);
834 ckfree((char *) varvList);
835 ckfree((char *) argvList);
836 }
837 if (argObjv != argObjStorage) {
838 ckfree((char *) argObjv);
839 }
840 return result;
841#undef STATIC_LIST_SIZE
842#undef NUM_ARGS
843}
844
845
846/*
847 *----------------------------------------------------------------------
848 *
849 * Tcl_FormatObjCmd --
850 *
851 * This procedure is invoked to process the "format" Tcl command.
852 * See the user documentation for details on what it does.
853 *
854 * Results:
855 * A standard Tcl result.
856 *
857 * Side effects:
858 * See the user documentation.
859 *
860 *----------------------------------------------------------------------
861 */
862
863 /* ARGSUSED */
864int
865Tcl_FormatObjCmd(dummy, interp, objc, objv)
866 ClientData dummy; /* Not used. */
867 Tcl_Interp *interp; /* Current interpreter. */
868 int objc; /* Number of arguments. */
869 Tcl_Obj *CONST objv[]; /* Argument objects. */
870{
871 register char *format; /* Used to read characters from the format
872 * string. */
873 int formatLen; /* The length of the format string */
874 char *endPtr; /* Points to the last char in format array */
875 char newFormat[40]; /* A new format specifier is generated here. */
876 int width; /* Field width from field specifier, or 0 if
877 * no width given. */
878 int precision; /* Field precision from field specifier, or 0
879 * if no precision given. */
880 int size; /* Number of bytes needed for result of
881 * conversion, based on type of conversion
882 * ("e", "s", etc.), width, and precision. */
883 int intValue; /* Used to hold value to pass to sprintf, if
884 * it's a one-word integer or char value */
885 char *ptrValue = NULL; /* Used to hold value to pass to sprintf, if
886 * it's a one-word value. */
887 double doubleValue; /* Used to hold value to pass to sprintf if
888 * it's a double value. */
889 int whichValue; /* Indicates which of intValue, ptrValue,
890 * or doubleValue has the value to pass to
891 * sprintf, according to the following
892 * definitions: */
893# define INT_VALUE 0
894# define PTR_VALUE 1
895# define DOUBLE_VALUE 2
896# define MAX_FLOAT_SIZE 320
897
898 Tcl_Obj *resultPtr; /* Where result is stored finally. */
899 char staticBuf[MAX_FLOAT_SIZE + 1];
900 /* A static buffer to copy the format results
901 * into */
902 char *dst = staticBuf; /* The buffer that sprintf writes into each
903 * time the format processes a specifier */
904 int dstSize = MAX_FLOAT_SIZE;
905 /* The size of the dst buffer */
906 int noPercent; /* Special case for speed: indicates there's
907 * no field specifier, just a string to copy.*/
908 int objIndex; /* Index of argument to substitute next. */
909 int gotXpg = 0; /* Non-zero means that an XPG3 %n$-style
910 * specifier has been seen. */
911 int gotSequential = 0; /* Non-zero means that a regular sequential
912 * (non-XPG3) conversion specifier has been
913 * seen. */
914 int useShort; /* Value to be printed is short (half word). */
915 char *end; /* Used to locate end of numerical fields. */
916
917 /*
918 * This procedure is a bit nasty. The goal is to use sprintf to
919 * do most of the dirty work. There are several problems:
920 * 1. this procedure can't trust its arguments.
921 * 2. we must be able to provide a large enough result area to hold
922 * whatever's generated. This is hard to estimate.
923 * 2. there's no way to move the arguments from objv to the call
924 * to sprintf in a reasonable way. This is particularly nasty
925 * because some of the arguments may be two-word values (doubles).
926 * So, what happens here is to scan the format string one % group
927 * at a time, making many individual calls to sprintf.
928 */
929
930 if (objc < 2) {
931 Tcl_WrongNumArgs(interp, 1, objv,
932 "formatString ?arg arg ...?");
933 return TCL_ERROR;
934 }
935
936 format = Tcl_GetStringFromObj(objv[1], &formatLen);
937 endPtr = format + formatLen;
938 resultPtr = Tcl_NewObj();
939 objIndex = 2;
940
941 while (format < endPtr) {
942 register char *newPtr = newFormat;
943
944 width = precision = noPercent = useShort = 0;
945 whichValue = PTR_VALUE;
946
947 /*
948 * Get rid of any characters before the next field specifier.
949 */
950 if (*format != '%') {
951 ptrValue = format;
952 while ((*format != '%') && (format < endPtr)) {
953 format++;
954 }
955 size = format - ptrValue;
956 noPercent = 1;
957 goto doField;
958 }
959
960 if (format[1] == '%') {
961 ptrValue = format;
962 size = 1;
963 noPercent = 1;
964 format += 2;
965 goto doField;
966 }
967
968 /*
969 * Parse off a field specifier, compute how many characters
970 * will be needed to store the result, and substitute for
971 * "*" size specifiers.
972 */
973 *newPtr = '%';
974 newPtr++;
975 format++;
976 if (isdigit(UCHAR(*format))) {
977 int tmp;
978
979 /*
980 * Check for an XPG3-style %n$ specification. Note: there
981 * must not be a mixture of XPG3 specs and non-XPG3 specs
982 * in the same format string.
983 */
984
985 tmp = strtoul(format, &end, 10);
986 if (*end != '$') {
987 goto notXpg;
988 }
989 format = end+1;
990 gotXpg = 1;
991 if (gotSequential) {
992 goto mixedXPG;
993 }
994 objIndex = tmp+1;
995 if ((objIndex < 2) || (objIndex >= objc)) {
996 goto badIndex;
997 }
998 goto xpgCheckDone;
999 }
1000
1001 notXpg:
1002 gotSequential = 1;
1003 if (gotXpg) {
1004 goto mixedXPG;
1005 }
1006
1007 xpgCheckDone:
1008 while ((*format == '-') || (*format == '#') || (*format == '0')
1009 || (*format == ' ') || (*format == '+')) {
1010 *newPtr = *format;
1011 newPtr++;
1012 format++;
1013 }
1014 if (isdigit(UCHAR(*format))) {
1015 width = strtoul(format, &end, 10);
1016 format = end;
1017 } else if (*format == '*') {
1018 if (objIndex >= objc) {
1019 goto badIndex;
1020 }
1021 if (Tcl_GetIntFromObj(interp, objv[objIndex],
1022 &width) != TCL_OK) {
1023 goto fmtError;
1024 }
1025 objIndex++;
1026 format++;
1027 }
1028 if (width > 100000) {
1029 /*
1030 * Don't allow arbitrarily large widths: could cause core
1031 * dump when we try to allocate a zillion bytes of memory
1032 * below.
1033 */
1034
1035 width = 100000;
1036 } else if (width < 0) {
1037 width = 0;
1038 }
1039 if (width != 0) {
1040 TclFormatInt(newPtr, width);
1041 while (*newPtr != 0) {
1042 newPtr++;
1043 }
1044 }
1045 if (*format == '.') {
1046 *newPtr = '.';
1047 newPtr++;
1048 format++;
1049 }
1050 if (isdigit(UCHAR(*format))) {
1051 precision = strtoul(format, &end, 10);
1052 format = end;
1053 } else if (*format == '*') {
1054 if (objIndex >= objc) {
1055 goto badIndex;
1056 }
1057 if (Tcl_GetIntFromObj(interp, objv[objIndex],
1058 &precision) != TCL_OK) {
1059 goto fmtError;
1060 }
1061 objIndex++;
1062 format++;
1063 }
1064 if (precision != 0) {
1065 TclFormatInt(newPtr, precision);
1066 while (*newPtr != 0) {
1067 newPtr++;
1068 }
1069 }
1070 if (*format == 'l') {
1071 format++;
1072 } else if (*format == 'h') {
1073 useShort = 1;
1074 *newPtr = 'h';
1075 newPtr++;
1076 format++;
1077 }
1078 *newPtr = *format;
1079 newPtr++;
1080 *newPtr = 0;
1081 if (objIndex >= objc) {
1082 goto badIndex;
1083 }
1084 switch (*format) {
1085 case 'i':
1086 newPtr[-1] = 'd';
1087 case 'd':
1088 case 'o':
1089 case 'u':
1090 case 'x':
1091 case 'X':
1092 if (Tcl_GetIntFromObj(interp, objv[objIndex],
1093 (int *) &intValue) != TCL_OK) {
1094 goto fmtError;
1095 }
1096 whichValue = INT_VALUE;
1097 size = 40 + precision;
1098 break;
1099 case 's':
1100 ptrValue = Tcl_GetStringFromObj(objv[objIndex], &size);
1101 break;
1102 case 'c':
1103 if (Tcl_GetIntFromObj(interp, objv[objIndex],
1104 (int *) &intValue) != TCL_OK) {
1105 goto fmtError;
1106 }
1107 whichValue = INT_VALUE;
1108 size = 1;
1109 break;
1110 case 'e':
1111 case 'E':
1112 case 'f':
1113 case 'g':
1114 case 'G':
1115 if (Tcl_GetDoubleFromObj(interp, objv[objIndex],
1116 &doubleValue) != TCL_OK) {
1117 goto fmtError;
1118 }
1119 whichValue = DOUBLE_VALUE;
1120 size = MAX_FLOAT_SIZE;
1121 if (precision > 10) {
1122 size += precision;
1123 }
1124 break;
1125 case 0:
1126 Tcl_SetResult(interp,
1127 "format string ended in middle of field specifier",
1128 TCL_STATIC);
1129 goto fmtError;
1130 default:
1131 {
1132 char buf[40];
1133 sprintf(buf, "bad field specifier \"%c\"", *format);
1134 Tcl_SetResult(interp, buf, TCL_VOLATILE);
1135 goto fmtError;
1136 }
1137 }
1138 objIndex++;
1139 format++;
1140
1141 /*
1142 * Make sure that there's enough space to hold the formatted
1143 * result, then format it.
1144 */
1145
1146 doField:
1147 if (width > size) {
1148 size = width;
1149 }
1150 if (noPercent) {
1151 Tcl_AppendToObj(resultPtr, ptrValue, size);
1152 } else {
1153 if (size > dstSize) {
1154 if (dst != staticBuf) {
1155 ckfree(dst);
1156 }
1157 dst = (char *) ckalloc((unsigned) (size + 1));
1158 dstSize = size;
1159 }
1160
1161 if (whichValue == DOUBLE_VALUE) {
1162 sprintf(dst, newFormat, doubleValue);
1163 } else if (whichValue == INT_VALUE) {
1164 if (useShort) {
1165 sprintf(dst, newFormat, (short) intValue);
1166 } else {
1167 sprintf(dst, newFormat, intValue);
1168 }
1169 } else {
1170 sprintf(dst, newFormat, ptrValue);
1171 }
1172 Tcl_AppendToObj(resultPtr, dst, -1);
1173 }
1174 }
1175
1176 Tcl_SetObjResult(interp, resultPtr);
1177 if(dst != staticBuf) {
1178 ckfree(dst);
1179 }
1180 return TCL_OK;
1181
1182 mixedXPG:
1183 Tcl_SetResult(interp,
1184 "cannot mix \"%\" and \"%n$\" conversion specifiers", TCL_STATIC);
1185 goto fmtError;
1186
1187 badIndex:
1188 if (gotXpg) {
1189 Tcl_SetResult(interp,
1190 "\"%n$\" argument index out of range", TCL_STATIC);
1191 } else {
1192 Tcl_SetResult(interp,
1193 "not enough arguments for all format specifiers", TCL_STATIC);
1194 }
1195
1196 fmtError:
1197 if(dst != staticBuf) {
1198 ckfree(dst);
1199 }
1200 Tcl_DecrRefCount(resultPtr);
1201 return TCL_ERROR;
1202}
Note: See TracBrowser for help on using the repository browser.