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