Fork me on GitHub

source: git/external/tcl/tclCmdMZ.c@ 7bb13cd

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

move branches/ModularDelphes to trunk
  • Property mode set to 100644
File size: 35.1 KB
Line 
1/*
2 * tclCmdMZ.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 * M to Z. It contains only commands in the generic core (i.e.
7 * those that don't depend much upon UNIX facilities).
8 *
9 * Copyright (c) 1987-1993 The Regents of the University of California.
10 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
11 *
12 * See the file "license.terms" for information on usage and redistribution
13 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
14 *
15 * RCS: @(#) $Id: tclCmdMZ.c,v 1.1 2008-06-04 13:58:04 demin Exp $
16 */
17
18#include "tclInt.h"
19#include "tclPort.h"
20#include "tclCompile.h"
21
22/*
23 * Structure used to hold information about variable traces:
24 */
25
26typedef struct {
27 int flags; /* Operations for which Tcl command is
28 * to be invoked. */
29 char *errMsg; /* Error message returned from Tcl command,
30 * or NULL. Malloc'ed. */
31 int length; /* Number of non-NULL chars. in command. */
32 char command[4]; /* Space for Tcl command to invoke. Actual
33 * size will be as large as necessary to
34 * hold command. This field must be the
35 * last in the structure, so that it can
36 * be larger than 4 bytes. */
37} TraceVarInfo;
38
39/*
40 * Forward declarations for procedures defined in this file:
41 */
42
43static char * TraceVarProc _ANSI_ARGS_((ClientData clientData,
44 Tcl_Interp *interp, char *name1, char *name2,
45 int flags));
46
47
48/*
49 *----------------------------------------------------------------------
50 *
51 * Tcl_ReturnObjCmd --
52 *
53 * This object-based procedure is invoked to process the "return" Tcl
54 * command. See the user documentation for details on what it does.
55 *
56 * Results:
57 * A standard Tcl object result.
58 *
59 * Side effects:
60 * See the user documentation.
61 *
62 *----------------------------------------------------------------------
63 */
64
65 /* ARGSUSED */
66int
67Tcl_ReturnObjCmd(dummy, interp, objc, objv)
68 ClientData dummy; /* Not used. */
69 Tcl_Interp *interp; /* Current interpreter. */
70 int objc; /* Number of arguments. */
71 Tcl_Obj *CONST objv[]; /* Argument objects. */
72{
73 Interp *iPtr = (Interp *) interp;
74 int optionLen, argLen, code, result;
75
76 if (iPtr->errorInfo != NULL) {
77 ckfree(iPtr->errorInfo);
78 iPtr->errorInfo = NULL;
79 }
80 if (iPtr->errorCode != NULL) {
81 ckfree(iPtr->errorCode);
82 iPtr->errorCode = NULL;
83 }
84 code = TCL_OK;
85
86 /*
87 * THIS FAILS IF AN OBJECT CONTAINS AN EMBEDDED NULL.
88 */
89
90 for (objv++, objc--; objc > 1; objv += 2, objc -= 2) {
91 char *option = Tcl_GetStringFromObj(objv[0], &optionLen);
92 char *arg = Tcl_GetStringFromObj(objv[1], &argLen);
93
94 if (strcmp(option, "-code") == 0) {
95 register int c = arg[0];
96 if ((c == 'o') && (strcmp(arg, "ok") == 0)) {
97 code = TCL_OK;
98 } else if ((c == 'e') && (strcmp(arg, "error") == 0)) {
99 code = TCL_ERROR;
100 } else if ((c == 'r') && (strcmp(arg, "return") == 0)) {
101 code = TCL_RETURN;
102 } else if ((c == 'b') && (strcmp(arg, "break") == 0)) {
103 code = TCL_BREAK;
104 } else if ((c == 'c') && (strcmp(arg, "continue") == 0)) {
105 code = TCL_CONTINUE;
106 } else {
107 result = Tcl_GetIntFromObj((Tcl_Interp *) NULL, objv[1],
108 &code);
109 if (result != TCL_OK) {
110 Tcl_ResetResult(interp);
111 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
112 "bad completion code \"",
113 Tcl_GetStringFromObj(objv[1], (int *) NULL),
114 "\": must be ok, error, return, break, ",
115 "continue, or an integer", (char *) NULL);
116 return result;
117 }
118 }
119 } else if (strcmp(option, "-errorinfo") == 0) {
120 iPtr->errorInfo =
121 (char *) ckalloc((unsigned) (strlen(arg) + 1));
122 strcpy(iPtr->errorInfo, arg);
123 } else if (strcmp(option, "-errorcode") == 0) {
124 iPtr->errorCode =
125 (char *) ckalloc((unsigned) (strlen(arg) + 1));
126 strcpy(iPtr->errorCode, arg);
127 } else {
128 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
129 "bad option \"", option,
130 "\": must be -code, -errorcode, or -errorinfo",
131 (char *) NULL);
132 return TCL_ERROR;
133 }
134 }
135
136 if (objc == 1) {
137 /*
138 * Set the interpreter's object result. An inline version of
139 * Tcl_SetObjResult.
140 */
141
142 Tcl_SetObjResult(interp, objv[0]);
143 }
144 iPtr->returnCode = code;
145 return TCL_RETURN;
146}
147
148
149/*
150 *----------------------------------------------------------------------
151 *
152 * Tcl_ScanCmd --
153 *
154 * This procedure is invoked to process the "scan" Tcl command.
155 * See the user documentation for details on what it does.
156 *
157 * Results:
158 * A standard Tcl result.
159 *
160 * Side effects:
161 * See the user documentation.
162 *
163 *----------------------------------------------------------------------
164 */
165
166 /* ARGSUSED */
167int
168Tcl_ScanCmd(dummy, interp, argc, argv)
169 ClientData dummy; /* Not used. */
170 Tcl_Interp *interp; /* Current interpreter. */
171 int argc; /* Number of arguments. */
172 char **argv; /* Argument strings. */
173{
174# define MAX_FIELDS 20
175 typedef struct {
176 char fmt; /* Format for field. */
177 int size; /* How many bytes to allow for
178 * field. */
179 char *location; /* Where field will be stored. */
180 } Field;
181 Field fields[MAX_FIELDS]; /* Info about all the fields in the
182 * format string. */
183 register Field *curField;
184 int numFields = 0; /* Number of fields actually
185 * specified. */
186 int suppress; /* Current field is assignment-
187 * suppressed. */
188 int totalSize = 0; /* Number of bytes needed to store
189 * all results combined. */
190 char *results; /* Where scanned output goes.
191 * Malloced; NULL means not allocated
192 * yet. */
193 int numScanned; /* sscanf's result. */
194 register char *fmt;
195 int i, widthSpecified, length, code;
196 char buf[40];
197
198 /*
199 * The variables below are used to hold a copy of the format
200 * string, so that we can replace format specifiers like "%f"
201 * and "%F" with specifiers like "%lf"
202 */
203
204# define STATIC_SIZE 5
205 char copyBuf[STATIC_SIZE], *fmtCopy;
206 register char *dst;
207
208 if (argc < 3) {
209 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
210 " string format ?varName varName ...?\"", (char *) NULL);
211 return TCL_ERROR;
212 }
213
214 /*
215 * This procedure operates in four stages:
216 * 1. Scan the format string, collecting information about each field.
217 * 2. Allocate an array to hold all of the scanned fields.
218 * 3. Call sscanf to do all the dirty work, and have it store the
219 * parsed fields in the array.
220 * 4. Pick off the fields from the array and assign them to variables.
221 */
222
223 code = TCL_OK;
224 results = NULL;
225 length = strlen(argv[2]) * 2 + 1;
226 if (length < STATIC_SIZE) {
227 fmtCopy = copyBuf;
228 } else {
229 fmtCopy = (char *) ckalloc((unsigned) length);
230 }
231 dst = fmtCopy;
232 for (fmt = argv[2]; *fmt != 0; fmt++) {
233 *dst = *fmt;
234 dst++;
235 if (*fmt != '%') {
236 continue;
237 }
238 fmt++;
239 if (*fmt == '%') {
240 *dst = *fmt;
241 dst++;
242 continue;
243 }
244 if (*fmt == '*') {
245 suppress = 1;
246 *dst = *fmt;
247 dst++;
248 fmt++;
249 } else {
250 suppress = 0;
251 }
252 widthSpecified = 0;
253 while (isdigit(UCHAR(*fmt))) {
254 widthSpecified = 1;
255 *dst = *fmt;
256 dst++;
257 fmt++;
258 }
259 if ((*fmt == 'l') || (*fmt == 'h') || (*fmt == 'L')) {
260 fmt++;
261 }
262 *dst = *fmt;
263 dst++;
264 if (suppress) {
265 continue;
266 }
267 if (numFields == MAX_FIELDS) {
268 Tcl_SetResult(interp, "too many fields to scan", TCL_STATIC);
269 code = TCL_ERROR;
270 goto done;
271 }
272 curField = &fields[numFields];
273 numFields++;
274 switch (*fmt) {
275 case 'd':
276 case 'i':
277 case 'o':
278 case 'x':
279 curField->fmt = 'd';
280 curField->size = sizeof(int);
281 break;
282
283 case 'u':
284 curField->fmt = 'u';
285 curField->size = sizeof(int);
286 break;
287
288 case 's':
289 curField->fmt = 's';
290 curField->size = strlen(argv[1]) + 1;
291 break;
292
293 case 'c':
294 if (widthSpecified) {
295 Tcl_SetResult(interp,
296 "field width may not be specified in %c conversion",
297 TCL_STATIC);
298 code = TCL_ERROR;
299 goto done;
300 }
301 curField->fmt = 'c';
302 curField->size = sizeof(int);
303 break;
304
305 case 'e':
306 case 'f':
307 case 'g':
308 dst[-1] = 'l';
309 dst[0] = 'f';
310 dst++;
311 curField->fmt = 'f';
312 curField->size = sizeof(double);
313 break;
314
315 case '[':
316 curField->fmt = 's';
317 curField->size = strlen(argv[1]) + 1;
318 do {
319 fmt++;
320 if (*fmt == 0) {
321 Tcl_SetResult(interp,
322 "unmatched [ in format string", TCL_STATIC);
323 code = TCL_ERROR;
324 goto done;
325 }
326 *dst = *fmt;
327 dst++;
328 } while (*fmt != ']');
329 break;
330
331 default:
332 {
333 char buf[50];
334
335 sprintf(buf, "bad scan conversion character \"%c\"", *fmt);
336 Tcl_SetResult(interp, buf, TCL_VOLATILE);
337 code = TCL_ERROR;
338 goto done;
339 }
340 }
341 curField->size = TCL_ALIGN(curField->size);
342 totalSize += curField->size;
343 }
344 *dst = 0;
345
346 if (numFields != (argc-3)) {
347 Tcl_SetResult(interp,
348 "different numbers of variable names and field specifiers",
349 TCL_STATIC);
350 code = TCL_ERROR;
351 goto done;
352 }
353
354 /*
355 * Step 2:
356 */
357
358 results = (char *) ckalloc((unsigned) totalSize);
359 for (i = 0, totalSize = 0, curField = fields;
360 i < numFields; i++, curField++) {
361 curField->location = results + totalSize;
362 totalSize += curField->size;
363 }
364
365 /*
366 * Fill in the remaining fields with NULL; the only purpose of
367 * this is to keep some memory analyzers, like Purify, from
368 * complaining.
369 */
370
371 for ( ; i < MAX_FIELDS; i++, curField++) {
372 curField->location = NULL;
373 }
374
375 /*
376 * Step 3:
377 */
378
379 numScanned = sscanf(argv[1], fmtCopy,
380 fields[0].location, fields[1].location, fields[2].location,
381 fields[3].location, fields[4].location, fields[5].location,
382 fields[6].location, fields[7].location, fields[8].location,
383 fields[9].location, fields[10].location, fields[11].location,
384 fields[12].location, fields[13].location, fields[14].location,
385 fields[15].location, fields[16].location, fields[17].location,
386 fields[18].location, fields[19].location);
387
388 /*
389 * Step 4:
390 */
391
392 if (numScanned < numFields) {
393 numFields = numScanned;
394 }
395 for (i = 0, curField = fields; i < numFields; i++, curField++) {
396 switch (curField->fmt) {
397 char string[TCL_DOUBLE_SPACE];
398
399 case 'd':
400 TclFormatInt(string, *((int *) curField->location));
401 if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
402 storeError:
403 Tcl_AppendResult(interp,
404 "couldn't set variable \"", argv[i+3], "\"",
405 (char *) NULL);
406 code = TCL_ERROR;
407 goto done;
408 }
409 break;
410
411 case 'u':
412 sprintf(string, "%u", *((int *) curField->location));
413 if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
414 goto storeError;
415 }
416 break;
417
418 case 'c':
419 TclFormatInt(string, *((char *) curField->location) & 0xff);
420 if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
421 goto storeError;
422 }
423 break;
424
425 case 's':
426 if (Tcl_SetVar(interp, argv[i+3], curField->location, 0)
427 == NULL) {
428 goto storeError;
429 }
430 break;
431
432 case 'f':
433 Tcl_PrintDouble((Tcl_Interp *) NULL,
434 *((double *) curField->location), string);
435 if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
436 goto storeError;
437 }
438 break;
439 }
440 }
441 TclFormatInt(buf, numScanned);
442 Tcl_SetResult(interp, buf, TCL_VOLATILE);
443 done:
444 if (results != NULL) {
445 ckfree(results);
446 }
447 if (fmtCopy != copyBuf) {
448 ckfree(fmtCopy);
449 }
450 return code;
451}
452
453/*
454 *----------------------------------------------------------------------
455 *
456 * Tcl_SplitObjCmd --
457 *
458 * This procedure is invoked to process the "split" Tcl command.
459 * See the user documentation for details on what it does.
460 *
461 * Results:
462 * A standard Tcl result.
463 *
464 * Side effects:
465 * See the user documentation.
466 *
467 *----------------------------------------------------------------------
468 */
469
470 /* ARGSUSED */
471int
472Tcl_SplitObjCmd(dummy, interp, objc, objv)
473 ClientData dummy; /* Not used. */
474 Tcl_Interp *interp; /* Current interpreter. */
475 int objc; /* Number of arguments. */
476 Tcl_Obj *CONST objv[]; /* Argument objects. */
477{
478 register char *p, *p2;
479 char *splitChars, *string, *elementStart;
480 int splitCharLen, stringLen, i, j;
481 Tcl_Obj *listPtr;
482
483 if (objc == 2) {
484 splitChars = " \n\t\r";
485 splitCharLen = 4;
486 } else if (objc == 3) {
487 splitChars = Tcl_GetStringFromObj(objv[2], &splitCharLen);
488 } else {
489 Tcl_WrongNumArgs(interp, 1, objv, "string ?splitChars?");
490 return TCL_ERROR;
491 }
492
493 string = Tcl_GetStringFromObj(objv[1], &stringLen);
494 listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
495
496 /*
497 * Handle the special case of splitting on every character.
498 */
499
500 if (splitCharLen == 0) {
501 for (i = 0, p = string; i < stringLen; i++, p++) {
502 Tcl_ListObjAppendElement(interp, listPtr,
503 Tcl_NewStringObj(p, 1));
504 }
505 } else {
506 /*
507 * Normal case: split on any of a given set of characters.
508 * Discard instances of the split characters.
509 */
510
511 for (i = 0, p = elementStart = string; i < stringLen; i++, p++) {
512 for (j = 0, p2 = splitChars; j < splitCharLen; j++, p2++) {
513 if (*p2 == *p) {
514 Tcl_ListObjAppendElement(interp, listPtr,
515 Tcl_NewStringObj(elementStart, (p-elementStart)));
516 elementStart = p+1;
517 break;
518 }
519 }
520 }
521 if (p != string) {
522 int remainingChars = stringLen - (elementStart-string);
523 Tcl_ListObjAppendElement(interp, listPtr,
524 Tcl_NewStringObj(elementStart, remainingChars));
525 }
526 }
527
528 Tcl_SetObjResult(interp, listPtr);
529 return TCL_OK;
530}
531
532
533/*
534 *----------------------------------------------------------------------
535 *
536 * Tcl_StringObjCmd --
537 *
538 * This procedure is invoked to process the "string" Tcl command.
539 * See the user documentation for details on what it does.
540 *
541 * Results:
542 * A standard Tcl result.
543 *
544 * Side effects:
545 * See the user documentation.
546 *
547 *----------------------------------------------------------------------
548 */
549
550 /* ARGSUSED */
551int
552Tcl_StringObjCmd(dummy, interp, objc, objv)
553 ClientData dummy; /* Not used. */
554 Tcl_Interp *interp; /* Current interpreter. */
555 int objc; /* Number of arguments. */
556 Tcl_Obj *CONST objv[]; /* Argument objects. */
557{
558 int index, left, right;
559 Tcl_Obj *resultPtr;
560 char *string1, *string2;
561 int length1, length2;
562 static char *options[] = {
563 "compare", "first", "index", "last",
564 "length", "match", "range", "tolower",
565 "toupper", "trim", "trimleft", "trimright",
566 "wordend", "wordstart", NULL
567 };
568 enum options {
569 STR_COMPARE, STR_FIRST, STR_INDEX, STR_LAST,
570 STR_LENGTH, STR_MATCH, STR_RANGE, STR_TOLOWER,
571 STR_TOUPPER, STR_TRIM, STR_TRIMLEFT, STR_TRIMRIGHT,
572 STR_WORDEND, STR_WORDSTART
573 };
574
575 if (objc < 2) {
576 Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
577 return TCL_ERROR;
578 }
579
580 if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
581 &index) != TCL_OK) {
582 return TCL_ERROR;
583 }
584
585 resultPtr = Tcl_GetObjResult(interp);
586 switch ((enum options) index) {
587 case STR_COMPARE: {
588 int match, length;
589
590 if (objc != 4) {
591 Tcl_WrongNumArgs(interp, 2, objv, "string1 string2");
592 return TCL_ERROR;
593 }
594
595 string1 = Tcl_GetStringFromObj(objv[2], &length1);
596 string2 = Tcl_GetStringFromObj(objv[3], &length2);
597
598 length = (length1 < length2) ? length1 : length2;
599 match = memcmp(string1, string2, (unsigned) length);
600 if (match == 0) {
601 match = length1 - length2;
602 }
603 Tcl_SetIntObj(resultPtr, (match > 0) ? 1 : (match < 0) ? -1 : 0);
604 break;
605 }
606 case STR_FIRST: {
607 register char *p, *end;
608 int match;
609
610 if (objc != 4) {
611 badFirstLastArgs:
612 Tcl_WrongNumArgs(interp, 2, objv, "string1 string2");
613 return TCL_ERROR;
614 }
615
616 match = -1;
617 string1 = Tcl_GetStringFromObj(objv[2], &length1);
618 string2 = Tcl_GetStringFromObj(objv[3], &length2);
619 if (length1 > 0) {
620 end = string2 + length2 - length1 + 1;
621 for (p = string2; p < end; p++) {
622 /*
623 * Scan forward to find the first character.
624 */
625
626 p = memchr(p, *string1, (unsigned) (end - p));
627 if (p == NULL) {
628 break;
629 }
630 if (memcmp(string1, p, (unsigned) length1) == 0) {
631 match = p - string2;
632 break;
633 }
634 }
635 }
636 Tcl_SetIntObj(resultPtr, match);
637 break;
638 }
639 case STR_INDEX: {
640 int index;
641
642 if (objc != 4) {
643 Tcl_WrongNumArgs(interp, 2, objv, "string charIndex");
644 return TCL_ERROR;
645 }
646
647 string1 = Tcl_GetStringFromObj(objv[2], &length1);
648 if (Tcl_GetIntFromObj(interp, objv[3], &index) != TCL_OK) {
649 return TCL_ERROR;
650 }
651 if ((index >= 0) && (index < length1)) {
652 Tcl_SetStringObj(resultPtr, string1 + index, 1);
653 }
654 break;
655 }
656 case STR_LAST: {
657 register char *p;
658 int match;
659
660 if (objc != 4) {
661 goto badFirstLastArgs;
662 }
663
664 match = -1;
665 string1 = Tcl_GetStringFromObj(objv[2], &length1);
666 string2 = Tcl_GetStringFromObj(objv[3], &length2);
667 if (length1 > 0) {
668 for (p = string2 + length2 - length1; p >= string2; p--) {
669 /*
670 * Scan backwards to find the first character.
671 */
672
673 while ((p != string2) && (*p != *string1)) {
674 p--;
675 }
676 if (memcmp(string1, p, (unsigned) length1) == 0) {
677 match = p - string2;
678 break;
679 }
680 }
681 }
682 Tcl_SetIntObj(resultPtr, match);
683 break;
684 }
685 case STR_LENGTH: {
686 if (objc != 3) {
687 Tcl_WrongNumArgs(interp, 2, objv, "string");
688 return TCL_ERROR;
689 }
690
691 (void) Tcl_GetStringFromObj(objv[2], &length1);
692 Tcl_SetIntObj(resultPtr, length1);
693 break;
694 }
695 case STR_MATCH: {
696 if (objc != 4) {
697 Tcl_WrongNumArgs(interp, 2, objv, "pattern string");
698 return TCL_ERROR;
699 }
700
701 string1 = Tcl_GetStringFromObj(objv[2], &length1);
702 string2 = Tcl_GetStringFromObj(objv[3], &length2);
703 Tcl_SetBooleanObj(resultPtr, Tcl_StringMatch(string2, string1));
704 break;
705 }
706 case STR_RANGE: {
707 int first, last;
708
709 if (objc != 5) {
710 Tcl_WrongNumArgs(interp, 2, objv, "string first last");
711 return TCL_ERROR;
712 }
713
714 string1 = Tcl_GetStringFromObj(objv[2], &length1);
715 if (TclGetIntForIndex(interp, objv[3], length1 - 1,
716 &first) != TCL_OK) {
717 return TCL_ERROR;
718 }
719 if (TclGetIntForIndex(interp, objv[4], length1 - 1,
720 &last) != TCL_OK) {
721 return TCL_ERROR;
722 }
723 if (first < 0) {
724 first = 0;
725 }
726 if (last >= length1 - 1) {
727 last = length1 - 1;
728 }
729 if (last >= first) {
730 Tcl_SetStringObj(resultPtr, string1 + first, last - first + 1);
731 }
732 break;
733 }
734 case STR_TOLOWER: {
735 register char *p, *end;
736
737 if (objc != 3) {
738 Tcl_WrongNumArgs(interp, 2, objv, "string");
739 return TCL_ERROR;
740 }
741
742 string1 = Tcl_GetStringFromObj(objv[2], &length1);
743
744 /*
745 * Since I know resultPtr is not a shared object, I can reach
746 * in and diddle the bytes in its string rep to convert them in
747 * place to lower case.
748 */
749
750 Tcl_SetStringObj(resultPtr, string1, length1);
751 string1 = Tcl_GetStringFromObj(resultPtr, &length1);
752 end = string1 + length1;
753 for (p = string1; p < end; p++) {
754 if (isupper(UCHAR(*p))) {
755 *p = (char) tolower(UCHAR(*p));
756 }
757 }
758 break;
759 }
760 case STR_TOUPPER: {
761 register char *p, *end;
762
763 if (objc != 3) {
764 Tcl_WrongNumArgs(interp, 2, objv, "string");
765 return TCL_ERROR;
766 }
767
768 string1 = Tcl_GetStringFromObj(objv[2], &length1);
769
770 /*
771 * Since I know resultPtr is not a shared object, I can reach
772 * in and diddle the bytes in its string rep to convert them in
773 * place to upper case.
774 */
775
776 Tcl_SetStringObj(resultPtr, string1, length1);
777 string1 = Tcl_GetStringFromObj(resultPtr, &length1);
778 end = string1 + length1;
779 for (p = string1; p < end; p++) {
780 if (islower(UCHAR(*p))) {
781 *p = (char) toupper(UCHAR(*p));
782 }
783 }
784 break;
785 }
786 case STR_TRIM: {
787 char ch;
788 register char *p, *end;
789 char *check, *checkEnd;
790
791 left = 1;
792 right = 1;
793
794 trim:
795 if (objc == 4) {
796 string2 = Tcl_GetStringFromObj(objv[3], &length2);
797 } else if (objc == 3) {
798 string2 = " \t\n\r";
799 length2 = strlen(string2);
800 } else {
801 Tcl_WrongNumArgs(interp, 2, objv, "string ?chars?");
802 return TCL_ERROR;
803 }
804 string1 = Tcl_GetStringFromObj(objv[2], &length1);
805 checkEnd = string2 + length2;
806
807 if (left) {
808 end = string1 + length1;
809 for (p = string1; p < end; p++) {
810 ch = *p;
811 for (check = string2; ; check++) {
812 if (check >= checkEnd) {
813 p = end;
814 break;
815 }
816 if (ch == *check) {
817 length1--;
818 string1++;
819 break;
820 }
821 }
822 }
823 }
824 if (right) {
825 end = string1;
826 for (p = string1 + length1; p > end; ) {
827 p--;
828 ch = *p;
829 for (check = string2; ; check++) {
830 if (check >= checkEnd) {
831 p = end;
832 break;
833 }
834 if (ch == *check) {
835 length1--;
836 break;
837 }
838 }
839 }
840 }
841 Tcl_SetStringObj(resultPtr, string1, length1);
842 break;
843 }
844 case STR_TRIMLEFT: {
845 left = 1;
846 right = 0;
847 goto trim;
848 }
849 case STR_TRIMRIGHT: {
850 left = 0;
851 right = 1;
852 goto trim;
853 }
854 case STR_WORDEND: {
855 int cur, c;
856
857 if (objc != 4) {
858 Tcl_WrongNumArgs(interp, 2, objv, "string index");
859 return TCL_ERROR;
860 }
861
862 string1 = Tcl_GetStringFromObj(objv[2], &length1);
863 if (Tcl_GetIntFromObj(interp, objv[3], &index) != TCL_OK) {
864 return TCL_ERROR;
865 }
866 if (index < 0) {
867 index = 0;
868 }
869 cur = length1;
870 if (index < length1) {
871 for (cur = index; cur < length1; cur++) {
872 c = UCHAR(string1[cur]);
873 if (!isalnum(c) && (c != '_')) {
874 break;
875 }
876 }
877 if (cur == index) {
878 cur = index + 1;
879 }
880 }
881 Tcl_SetIntObj(resultPtr, cur);
882 break;
883 }
884 case STR_WORDSTART: {
885 int cur, c;
886
887 if (objc != 4) {
888 Tcl_WrongNumArgs(interp, 2, objv, "string index");
889 return TCL_ERROR;
890 }
891
892 string1 = Tcl_GetStringFromObj(objv[2], &length1);
893 if (Tcl_GetIntFromObj(interp, objv[3], &index) != TCL_OK) {
894 return TCL_ERROR;
895 }
896 if (index >= length1) {
897 index = length1 - 1;
898 }
899 cur = 0;
900 if (index > 0) {
901 for (cur = index; cur >= 0; cur--) {
902 c = UCHAR(string1[cur]);
903 if (!isalnum(c) && (c != '_')) {
904 break;
905 }
906 }
907 if (cur != index) {
908 cur += 1;
909 }
910 }
911 Tcl_SetIntObj(resultPtr, cur);
912 break;
913 }
914 }
915 return TCL_OK;
916}
917
918
919/*
920 *----------------------------------------------------------------------
921 *
922 * Tcl_SubstCmd --
923 *
924 * This procedure is invoked to process the "subst" Tcl command.
925 * See the user documentation for details on what it does. This
926 * command is an almost direct copy of an implementation by
927 * Andrew Payne.
928 *
929 * Results:
930 * A standard Tcl result.
931 *
932 * Side effects:
933 * See the user documentation.
934 *
935 *----------------------------------------------------------------------
936 */
937
938 /* ARGSUSED */
939int
940Tcl_SubstCmd(dummy, interp, argc, argv)
941 ClientData dummy; /* Not used. */
942 Tcl_Interp *interp; /* Current interpreter. */
943 int argc; /* Number of arguments. */
944 char **argv; /* Argument strings. */
945{
946 Interp *iPtr = (Interp *) interp;
947 Tcl_DString result;
948 char *p, *old, *value;
949 int code, count, doVars, doCmds, doBackslashes, i;
950 size_t length;
951 char c;
952
953 /*
954 * Parse command-line options.
955 */
956
957 doVars = doCmds = doBackslashes = 1;
958 for (i = 1; i < (argc-1); i++) {
959 p = argv[i];
960 if (*p != '-') {
961 break;
962 }
963 length = strlen(p);
964 if (length < 4) {
965 badSwitch:
966 Tcl_AppendResult(interp, "bad switch \"", p,
967 "\": must be -nobackslashes, -nocommands, ",
968 "or -novariables", (char *) NULL);
969 return TCL_ERROR;
970 }
971 if ((p[3] == 'b') && (strncmp(p, "-nobackslashes", length) == 0)) {
972 doBackslashes = 0;
973 } else if ((p[3] == 'c') && (strncmp(p, "-nocommands", length) == 0)) {
974 doCmds = 0;
975 } else if ((p[3] == 'v') && (strncmp(p, "-novariables", length) == 0)) {
976 doVars = 0;
977 } else {
978 goto badSwitch;
979 }
980 }
981 if (i != (argc-1)) {
982 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
983 " ?-nobackslashes? ?-nocommands? ?-novariables? string\"",
984 (char *) NULL);
985 return TCL_ERROR;
986 }
987
988 /*
989 * Scan through the string one character at a time, performing
990 * command, variable, and backslash substitutions.
991 */
992
993 Tcl_DStringInit(&result);
994 old = p = argv[i];
995 while (*p != 0) {
996 switch (*p) {
997 case '\\':
998 if (doBackslashes) {
999 if (p != old) {
1000 Tcl_DStringAppend(&result, old, p-old);
1001 }
1002 c = Tcl_Backslash(p, &count);
1003 Tcl_DStringAppend(&result, &c, 1);
1004 p += count;
1005 old = p;
1006 } else {
1007 p++;
1008 }
1009 break;
1010
1011 case '$':
1012 if (doVars) {
1013 if (p != old) {
1014 Tcl_DStringAppend(&result, old, p-old);
1015 }
1016 value = Tcl_ParseVar(interp, p, &p);
1017 if (value == NULL) {
1018 Tcl_DStringFree(&result);
1019 return TCL_ERROR;
1020 }
1021 Tcl_DStringAppend(&result, value, -1);
1022 old = p;
1023 } else {
1024 p++;
1025 }
1026 break;
1027
1028 case '[':
1029 if (doCmds) {
1030 if (p != old) {
1031 Tcl_DStringAppend(&result, old, p-old);
1032 }
1033 iPtr->evalFlags = TCL_BRACKET_TERM;
1034 code = Tcl_Eval(interp, p+1);
1035 if (code == TCL_ERROR) {
1036 Tcl_DStringFree(&result);
1037 return code;
1038 }
1039 old = p = (p+1 + iPtr->termOffset+1);
1040 Tcl_DStringAppend(&result, iPtr->result, -1);
1041 Tcl_ResetResult(interp);
1042 } else {
1043 p++;
1044 }
1045 break;
1046
1047 default:
1048 p++;
1049 break;
1050 }
1051 }
1052 if (p != old) {
1053 Tcl_DStringAppend(&result, old, p-old);
1054 }
1055 Tcl_DStringResult(interp, &result);
1056 return TCL_OK;
1057}
1058
1059/*
1060 *----------------------------------------------------------------------
1061 *
1062 * Tcl_TraceCmd --
1063 *
1064 * This procedure is invoked to process the "trace" Tcl command.
1065 * See the user documentation for details on what it does.
1066 *
1067 * Results:
1068 * A standard Tcl result.
1069 *
1070 * Side effects:
1071 * See the user documentation.
1072 *
1073 *----------------------------------------------------------------------
1074 */
1075
1076 /* ARGSUSED */
1077int
1078Tcl_TraceCmd(dummy, interp, argc, argv)
1079 ClientData dummy; /* Not used. */
1080 Tcl_Interp *interp; /* Current interpreter. */
1081 int argc; /* Number of arguments. */
1082 char **argv; /* Argument strings. */
1083{
1084 int c;
1085 size_t length;
1086
1087 if (argc < 2) {
1088 Tcl_AppendResult(interp, "too few args: should be \"",
1089 argv[0], " option [arg arg ...]\"", (char *) NULL);
1090 return TCL_ERROR;
1091 }
1092 c = argv[1][1];
1093 length = strlen(argv[1]);
1094 if ((c == 'a') && (strncmp(argv[1], "variable", length) == 0)
1095 && (length >= 2)) {
1096 char *p;
1097 int flags, length;
1098 TraceVarInfo *tvarPtr;
1099
1100 if (argc != 5) {
1101 Tcl_AppendResult(interp, "wrong # args: should be \"",
1102 argv[0], " variable name ops command\"", (char *) NULL);
1103 return TCL_ERROR;
1104 }
1105
1106 flags = 0;
1107 for (p = argv[3] ; *p != 0; p++) {
1108 if (*p == 'r') {
1109 flags |= TCL_TRACE_READS;
1110 } else if (*p == 'w') {
1111 flags |= TCL_TRACE_WRITES;
1112 } else if (*p == 'u') {
1113 flags |= TCL_TRACE_UNSETS;
1114 } else {
1115 goto badOps;
1116 }
1117 }
1118 if (flags == 0) {
1119 goto badOps;
1120 }
1121
1122 length = strlen(argv[4]);
1123 tvarPtr = (TraceVarInfo *) ckalloc((unsigned)
1124 (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + length + 1));
1125 tvarPtr->flags = flags;
1126 tvarPtr->errMsg = NULL;
1127 tvarPtr->length = length;
1128 flags |= TCL_TRACE_UNSETS;
1129 strcpy(tvarPtr->command, argv[4]);
1130 if (Tcl_TraceVar(interp, argv[2], flags, TraceVarProc,
1131 (ClientData) tvarPtr) != TCL_OK) {
1132 ckfree((char *) tvarPtr);
1133 return TCL_ERROR;
1134 }
1135 } else if ((c == 'd') && (strncmp(argv[1], "vdelete", length)
1136 && (length >= 2)) == 0) {
1137 char *p;
1138 int flags, length;
1139 TraceVarInfo *tvarPtr;
1140 ClientData clientData;
1141
1142 if (argc != 5) {
1143 Tcl_AppendResult(interp, "wrong # args: should be \"",
1144 argv[0], " vdelete name ops command\"", (char *) NULL);
1145 return TCL_ERROR;
1146 }
1147
1148 flags = 0;
1149 for (p = argv[3] ; *p != 0; p++) {
1150 if (*p == 'r') {
1151 flags |= TCL_TRACE_READS;
1152 } else if (*p == 'w') {
1153 flags |= TCL_TRACE_WRITES;
1154 } else if (*p == 'u') {
1155 flags |= TCL_TRACE_UNSETS;
1156 } else {
1157 goto badOps;
1158 }
1159 }
1160 if (flags == 0) {
1161 goto badOps;
1162 }
1163
1164 /*
1165 * Search through all of our traces on this variable to
1166 * see if there's one with the given command. If so, then
1167 * delete the first one that matches.
1168 */
1169
1170 length = strlen(argv[4]);
1171 clientData = 0;
1172 while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0,
1173 TraceVarProc, clientData)) != 0) {
1174 tvarPtr = (TraceVarInfo *) clientData;
1175 if ((tvarPtr->length == length) && (tvarPtr->flags == flags)
1176 && (strncmp(argv[4], tvarPtr->command,
1177 (size_t) length) == 0)) {
1178 Tcl_UntraceVar(interp, argv[2], flags | TCL_TRACE_UNSETS,
1179 TraceVarProc, clientData);
1180 if (tvarPtr->errMsg != NULL) {
1181 ckfree(tvarPtr->errMsg);
1182 }
1183 ckfree((char *) tvarPtr);
1184 break;
1185 }
1186 }
1187 } else if ((c == 'i') && (strncmp(argv[1], "vinfo", length) == 0)
1188 && (length >= 2)) {
1189 ClientData clientData;
1190 char ops[4], *p;
1191 char *prefix = "{";
1192
1193 if (argc != 3) {
1194 Tcl_AppendResult(interp, "wrong # args: should be \"",
1195 argv[0], " vinfo name\"", (char *) NULL);
1196 return TCL_ERROR;
1197 }
1198 clientData = 0;
1199 while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0,
1200 TraceVarProc, clientData)) != 0) {
1201 TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
1202 p = ops;
1203 if (tvarPtr->flags & TCL_TRACE_READS) {
1204 *p = 'r';
1205 p++;
1206 }
1207 if (tvarPtr->flags & TCL_TRACE_WRITES) {
1208 *p = 'w';
1209 p++;
1210 }
1211 if (tvarPtr->flags & TCL_TRACE_UNSETS) {
1212 *p = 'u';
1213 p++;
1214 }
1215 *p = '\0';
1216 Tcl_AppendResult(interp, prefix, (char *) NULL);
1217 Tcl_AppendElement(interp, ops);
1218 Tcl_AppendElement(interp, tvarPtr->command);
1219 Tcl_AppendResult(interp, "}", (char *) NULL);
1220 prefix = " {";
1221 }
1222 } else {
1223 Tcl_AppendResult(interp, "bad option \"", argv[1],
1224 "\": should be variable, vdelete, or vinfo",
1225 (char *) NULL);
1226 return TCL_ERROR;
1227 }
1228 return TCL_OK;
1229
1230 badOps:
1231 Tcl_AppendResult(interp, "bad operations \"", argv[3],
1232 "\": should be one or more of rwu", (char *) NULL);
1233 return TCL_ERROR;
1234}
1235
1236
1237/*
1238 *----------------------------------------------------------------------
1239 *
1240 * TraceVarProc --
1241 *
1242 * This procedure is called to handle variable accesses that have
1243 * been traced using the "trace" command.
1244 *
1245 * Results:
1246 * Normally returns NULL. If the trace command returns an error,
1247 * then this procedure returns an error string.
1248 *
1249 * Side effects:
1250 * Depends on the command associated with the trace.
1251 *
1252 *----------------------------------------------------------------------
1253 */
1254
1255 /* ARGSUSED */
1256static char *
1257TraceVarProc(clientData, interp, name1, name2, flags)
1258 ClientData clientData; /* Information about the variable trace. */
1259 Tcl_Interp *interp; /* Interpreter containing variable. */
1260 char *name1; /* Name of variable or array. */
1261 char *name2; /* Name of element within array; NULL means
1262 * scalar variable is being referenced. */
1263 int flags; /* OR-ed bits giving operation and other
1264 * information. */
1265{
1266 Interp *iPtr = (Interp *) interp;
1267 TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
1268 char *result;
1269 int code;
1270 Interp dummy;
1271 Tcl_DString cmd;
1272 Tcl_Obj *saveObjPtr, *oldObjResultPtr;
1273
1274 result = NULL;
1275 if (tvarPtr->errMsg != NULL) {
1276 ckfree(tvarPtr->errMsg);
1277 tvarPtr->errMsg = NULL;
1278 }
1279 if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) {
1280
1281 /*
1282 * Generate a command to execute by appending list elements
1283 * for the two variable names and the operation. The five
1284 * extra characters are for three space, the opcode character,
1285 * and the terminating null.
1286 */
1287
1288 if (name2 == NULL) {
1289 name2 = "";
1290 }
1291 Tcl_DStringInit(&cmd);
1292 Tcl_DStringAppend(&cmd, tvarPtr->command, tvarPtr->length);
1293 Tcl_DStringAppendElement(&cmd, name1);
1294 Tcl_DStringAppendElement(&cmd, name2);
1295 if (flags & TCL_TRACE_READS) {
1296 Tcl_DStringAppend(&cmd, " r", 2);
1297 } else if (flags & TCL_TRACE_WRITES) {
1298 Tcl_DStringAppend(&cmd, " w", 2);
1299 } else if (flags & TCL_TRACE_UNSETS) {
1300 Tcl_DStringAppend(&cmd, " u", 2);
1301 }
1302
1303 /*
1304 * Execute the command. Be careful to save and restore both the
1305 * string and object results from the interpreter used for
1306 * the command. We discard any object result the command returns.
1307 */
1308
1309 dummy.objResultPtr = Tcl_NewObj();
1310 Tcl_IncrRefCount(dummy.objResultPtr);
1311 if (interp->freeProc == 0) {
1312 dummy.freeProc = (Tcl_FreeProc *) 0;
1313 dummy.result = "";
1314 Tcl_SetResult((Tcl_Interp *) &dummy, interp->result,
1315 TCL_VOLATILE);
1316 } else {
1317 dummy.freeProc = interp->freeProc;
1318 dummy.result = interp->result;
1319 interp->freeProc = (Tcl_FreeProc *) 0;
1320 }
1321
1322 saveObjPtr = Tcl_GetObjResult(interp);
1323 Tcl_IncrRefCount(saveObjPtr);
1324
1325 code = Tcl_Eval(interp, Tcl_DStringValue(&cmd));
1326 if (code != TCL_OK) { /* copy error msg to result */
1327 tvarPtr->errMsg = (char *)
1328 ckalloc((unsigned) (strlen(interp->result) + 1));
1329 strcpy(tvarPtr->errMsg, interp->result);
1330 result = tvarPtr->errMsg;
1331 Tcl_ResetResult(interp); /* must clear error state. */
1332 }
1333
1334 /*
1335 * Restore the interpreter's string result.
1336 */
1337
1338 Tcl_SetResult(interp, dummy.result,
1339 (dummy.freeProc == 0) ? TCL_VOLATILE : dummy.freeProc);
1340
1341 /*
1342 * Restore the interpreter's object result from saveObjPtr.
1343 */
1344
1345 oldObjResultPtr = iPtr->objResultPtr;
1346 iPtr->objResultPtr = saveObjPtr; /* was incremented above */
1347 Tcl_DecrRefCount(oldObjResultPtr);
1348
1349 Tcl_DecrRefCount(dummy.objResultPtr);
1350 dummy.objResultPtr = NULL;
1351 Tcl_DStringFree(&cmd);
1352 }
1353 if (flags & TCL_TRACE_DESTROYED) {
1354 result = NULL;
1355 if (tvarPtr->errMsg != NULL) {
1356 ckfree(tvarPtr->errMsg);
1357 }
1358 ckfree((char *) tvarPtr);
1359 }
1360 return result;
1361}
1362
1363
1364/*
1365 *----------------------------------------------------------------------
1366 *
1367 * Tcl_WhileCmd --
1368 *
1369 * This procedure is invoked to process the "while" Tcl command.
1370 * See the user documentation for details on what it does.
1371 *
1372 * With the bytecode compiler, this procedure is only called when
1373 * a command name is computed at runtime, and is "while" or the name
1374 * to which "while" was renamed: e.g., "set z while; $z {$i<100} {}"
1375 *
1376 * Results:
1377 * A standard Tcl result.
1378 *
1379 * Side effects:
1380 * See the user documentation.
1381 *
1382 *----------------------------------------------------------------------
1383 */
1384
1385 /* ARGSUSED */
1386int
1387Tcl_WhileCmd(dummy, interp, argc, argv)
1388 ClientData dummy; /* Not used. */
1389 Tcl_Interp *interp; /* Current interpreter. */
1390 int argc; /* Number of arguments. */
1391 char **argv; /* Argument strings. */
1392{
1393 int result, value;
1394
1395 if (argc != 3) {
1396 Tcl_AppendResult(interp, "wrong # args: should be \"",
1397 argv[0], " test command\"", (char *) NULL);
1398 return TCL_ERROR;
1399 }
1400
1401 while (1) {
1402 result = Tcl_ExprBoolean(interp, argv[1], &value);
1403 if (result != TCL_OK) {
1404 return result;
1405 }
1406 if (!value) {
1407 break;
1408 }
1409 result = Tcl_Eval(interp, argv[2]);
1410 if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
1411 if (result == TCL_ERROR) {
1412 char msg[60];
1413 sprintf(msg, "\n (\"while\" body line %d)",
1414 interp->errorLine);
1415 Tcl_AddErrorInfo(interp, msg);
1416 }
1417 break;
1418 }
1419 }
1420 if (result == TCL_BREAK) {
1421 result = TCL_OK;
1422 }
1423 if (result == TCL_OK) {
1424 Tcl_ResetResult(interp);
1425 }
1426 return result;
1427}
1428
Note: See TracBrowser for help on using the repository browser.