![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to tclutil.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 tclutil.c CVS log | Up to [Micropolis - Activity] / micropolis / src / tcl |
1.1 root 1: /*
2: * tclUtil.c --
3: *
4: * This file contains utility procedures that are used by many Tcl
5: * commands.
6: *
7: * Copyright 1987-1991 Regents of the University of California
8: * Permission to use, copy, modify, and distribute this
9: * software and its documentation for any purpose and without
10: * fee is hereby granted, provided that the above copyright
11: * notice appear in all copies. The University of California
12: * makes no representations about the suitability of this
13: * software for any purpose. It is provided "as is" without
14: * express or implied warranty.
15: */
16:
17: #ifndef lint
18: static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclUtil.c,v 1.63 92/07/02 08:50:54 ouster Exp $ SPRITE (Berkeley)";
19: #endif
20:
21: #include "tclint.h"
22:
23: /*
24: * The following values are used in the flags returned by Tcl_ScanElement
25: * and used by Tcl_ConvertElement. The value TCL_DONT_USE_BRACES is also
26: * defined in tcl.h; make sure its value doesn't overlap with any of the
27: * values below.
28: *
29: * TCL_DONT_USE_BRACES - 1 means the string mustn't be enclosed in
30: * braces (e.g. it contains unmatched braces,
31: * or ends in a backslash character, or user
32: * just doesn't want braces); handle all
33: * special characters by adding backslashes.
34: * USE_BRACES - 1 means the string contains a special
35: * character that can be handled simply by
36: * enclosing the entire argument in braces.
37: * BRACES_UNMATCHED - 1 means that braces aren't properly matched
38: * in the argument.
39: */
40:
41: #define USE_BRACES 2
42: #define BRACES_UNMATCHED 4
43:
44: /*
45: * The variable below is set to NULL before invoking regexp functions
46: * and checked after those functions. If an error occurred then regerror
47: * will set the variable to point to a (static) error message. This
48: * mechanism unfortunately does not support multi-threading, but then
49: * neither does the rest of the regexp facilities.
50: */
51:
52: char *tclRegexpError = NULL;
53:
54: /*
55: * Function prototypes for local procedures in this file:
56: */
57:
58: static void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr,
59: int newSpace));
60:
61: /*
62: *----------------------------------------------------------------------
63: *
64: * TclFindElement --
65: *
66: * Given a pointer into a Tcl list, locate the first (or next)
67: * element in the list.
68: *
69: * Results:
70: * The return value is normally TCL_OK, which means that the
71: * element was successfully located. If TCL_ERROR is returned
72: * it means that list didn't have proper list structure;
73: * interp->result contains a more detailed error message.
74: *
75: * If TCL_OK is returned, then *elementPtr will be set to point
76: * to the first element of list, and *nextPtr will be set to point
77: * to the character just after any white space following the last
78: * character that's part of the element. If this is the last argument
79: * in the list, then *nextPtr will point to the NULL character at the
80: * end of list. If sizePtr is non-NULL, *sizePtr is filled in with
81: * the number of characters in the element. If the element is in
82: * braces, then *elementPtr will point to the character after the
83: * opening brace and *sizePtr will not include either of the braces.
84: * If there isn't an element in the list, *sizePtr will be zero, and
85: * both *elementPtr and *termPtr will refer to the null character at
86: * the end of list. Note: this procedure does NOT collapse backslash
87: * sequences.
88: *
89: * Side effects:
90: * None.
91: *
92: *----------------------------------------------------------------------
93: */
94:
95: int
96: TclFindElement(interp, list, elementPtr, nextPtr, sizePtr, bracePtr)
97: Tcl_Interp *interp; /* Interpreter to use for error reporting. */
98: register char *list; /* String containing Tcl list with zero
99: * or more elements (possibly in braces). */
100: char **elementPtr; /* Fill in with location of first significant
101: * character in first element of list. */
102: char **nextPtr; /* Fill in with location of character just
103: * after all white space following end of
104: * argument (i.e. next argument or end of
105: * list). */
106: int *sizePtr; /* If non-zero, fill in with size of
107: * element. */
108: int *bracePtr; /* If non-zero fill in with non-zero/zero
109: * to indicate that arg was/wasn't
110: * in braces. */
111: {
112: register char *p;
113: int openBraces = 0;
114: int inQuotes = 0;
115: int size;
116:
117: /*
118: * Skim off leading white space and check for an opening brace or
119: * quote. Note: use of "isascii" below and elsewhere in this
120: * procedure is a temporary workaround (7/27/90) because Mx uses characters
121: * with the high-order bit set for some things. This should probably
122: * be changed back eventually, or all of Tcl should call isascii.
123: */
124:
125: while (isascii(*list) && isspace(*list)) {
126: list++;
127: }
128: if (*list == '{') {
129: openBraces = 1;
130: list++;
131: } else if (*list == '"') {
132: inQuotes = 1;
133: list++;
134: }
135: if (bracePtr != 0) {
136: *bracePtr = openBraces;
137: }
138: p = list;
139:
140: /*
141: * Find the end of the element (either a space or a close brace or
142: * the end of the string).
143: */
144:
145: while (1) {
146: switch (*p) {
147:
148: /*
149: * Open brace: don't treat specially unless the element is
150: * in braces. In this case, keep a nesting count.
151: */
152:
153: case '{':
154: if (openBraces != 0) {
155: openBraces++;
156: }
157: break;
158:
159: /*
160: * Close brace: if element is in braces, keep nesting
161: * count and quit when the last close brace is seen.
162: */
163:
164: case '}':
165: if (openBraces == 1) {
166: char *p2;
167:
168: size = p - list;
169: p++;
170: if ((isascii(*p) && isspace(*p)) || (*p == 0)) {
171: goto done;
172: }
173: for (p2 = p; (*p2 != 0) && (!isspace(*p2)) && (p2 < p+20);
174: p2++) {
175: /* null body */
176: }
177: Tcl_ResetResult(interp);
178: sprintf(interp->result,
179: "list element in braces followed by \"%.*s\" instead of space",
180: p2-p, p);
181: return TCL_ERROR;
182: } else if (openBraces != 0) {
183: openBraces--;
184: }
185: break;
186:
187: /*
188: * Backslash: skip over everything up to the end of the
189: * backslash sequence.
190: */
191:
192: case '\\': {
193: int size;
194:
195: (void) Tcl_Backslash(p, &size);
196: p += size - 1;
197: break;
198: }
199:
200: /*
201: * Space: ignore if element is in braces or quotes; otherwise
202: * terminate element.
203: */
204:
205: case ' ':
206: case '\f':
207: case '\n':
208: case '\r':
209: case '\t':
210: case '\v':
211: if ((openBraces == 0) && !inQuotes) {
212: size = p - list;
213: goto done;
214: }
215: break;
216:
217: /*
218: * Double-quote: if element is in quotes then terminate it.
219: */
220:
221: case '"':
222: if (inQuotes) {
223: char *p2;
224:
225: size = p-list;
226: p++;
227: if ((isascii(*p) && isspace(*p)) || (*p == 0)) {
228: goto done;
229: }
230: for (p2 = p; (*p2 != 0) && (!isspace(*p2)) && (p2 < p+20);
231: p2++) {
232: /* null body */
233: }
234: Tcl_ResetResult(interp);
235: sprintf(interp->result,
236: "list element in quotes followed by \"%.*s\" %s",
237: p2-p, p, "instead of space");
238: return TCL_ERROR;
239: }
240: break;
241:
242: /*
243: * End of list: terminate element.
244: */
245:
246: case 0:
247: if (openBraces != 0) {
248: Tcl_SetResult(interp, "unmatched open brace in list",
249: TCL_STATIC);
250: return TCL_ERROR;
251: } else if (inQuotes) {
252: Tcl_SetResult(interp, "unmatched open quote in list",
253: TCL_STATIC);
254: return TCL_ERROR;
255: }
256: size = p - list;
257: goto done;
258:
259: }
260: p++;
261: }
262:
263: done:
264: while (isascii(*p) && isspace(*p)) {
265: p++;
266: }
267: *elementPtr = list;
268: *nextPtr = p;
269: if (sizePtr != 0) {
270: *sizePtr = size;
271: }
272: return TCL_OK;
273: }
274:
275: /*
276: *----------------------------------------------------------------------
277: *
278: * TclCopyAndCollapse --
279: *
280: * Copy a string and eliminate any backslashes that aren't in braces.
281: *
282: * Results:
283: * There is no return value. Count chars. get copied from src
284: * to dst. Along the way, if backslash sequences are found outside
285: * braces, the backslashes are eliminated in the copy.
286: * After scanning count chars. from source, a null character is
287: * placed at the end of dst.
288: *
289: * Side effects:
290: * None.
291: *
292: *----------------------------------------------------------------------
293: */
294:
295: void
296: TclCopyAndCollapse(count, src, dst)
297: int count; /* Total number of characters to copy
298: * from src. */
299: register char *src; /* Copy from here... */
300: register char *dst; /* ... to here. */
301: {
302: register char c;
303: int numRead;
304:
305: for (c = *src; count > 0; src++, c = *src, count--) {
306: if (c == '\\') {
307: *dst = Tcl_Backslash(src, &numRead);
308: if (*dst != 0) {
309: dst++;
310: }
311: src += numRead-1;
312: count -= numRead-1;
313: } else {
314: *dst = c;
315: dst++;
316: }
317: }
318: *dst = 0;
319: }
320:
321: /*
322: *----------------------------------------------------------------------
323: *
324: * Tcl_SplitList --
325: *
326: * Splits a list up into its constituent fields.
327: *
328: * Results
329: * The return value is normally TCL_OK, which means that
330: * the list was successfully split up. If TCL_ERROR is
331: * returned, it means that "list" didn't have proper list
332: * structure; interp->result will contain a more detailed
333: * error message.
334: *
335: * *argvPtr will be filled in with the address of an array
336: * whose elements point to the elements of list, in order.
337: * *argcPtr will get filled in with the number of valid elements
338: * in the array. A single block of memory is dynamically allocated
339: * to hold both the argv array and a copy of the list (with
340: * backslashes and braces removed in the standard way).
341: * The caller must eventually free this memory by calling free()
342: * on *argvPtr. Note: *argvPtr and *argcPtr are only modified
343: * if the procedure returns normally.
344: *
345: * Side effects:
346: * Memory is allocated.
347: *
348: *----------------------------------------------------------------------
349: */
350:
351: int
352: Tcl_SplitList(interp, list, argcPtr, argvPtr)
353: Tcl_Interp *interp; /* Interpreter to use for error reporting. */
354: char *list; /* Pointer to string with list structure. */
355: int *argcPtr; /* Pointer to location to fill in with
356: * the number of elements in the list. */
357: char ***argvPtr; /* Pointer to place to store pointer to array
358: * of pointers to list elements. */
359: {
360: char **argv;
361: register char *p;
362: int size, i, result, elSize, brace;
363: char *element;
364:
365: /*
366: * Figure out how much space to allocate. There must be enough
367: * space for both the array of pointers and also for a copy of
368: * the list. To estimate the number of pointers needed, count
369: * the number of space characters in the list.
370: */
371:
372: for (size = 1, p = list; *p != 0; p++) {
373: if (isspace(*p)) {
374: size++;
375: }
376: }
377: size++; /* Leave space for final NULL pointer. */
378: argv = (char **) ckalloc((unsigned)
379: ((size * sizeof(char *)) + (p - list) + 1));
380: for (i = 0, p = ((char *) argv) + size*sizeof(char *);
381: *list != 0; i++) {
382: result = TclFindElement(interp, list, &element, &list, &elSize, &brace);
383: if (result != TCL_OK) {
384: ckfree((char *) argv);
385: return result;
386: }
387: if (*element == 0) {
388: break;
389: }
390: if (i >= size) {
391: ckfree((char *) argv);
392: Tcl_SetResult(interp, "internal error in Tcl_SplitList",
393: TCL_STATIC);
394: return TCL_ERROR;
395: }
396: argv[i] = p;
397: if (brace) {
398: strncpy(p, element, elSize);
399: p += elSize;
400: *p = 0;
401: p++;
402: } else {
403: TclCopyAndCollapse(elSize, element, p);
404: p += elSize+1;
405: }
406: }
407:
408: argv[i] = NULL;
409: *argvPtr = argv;
410: *argcPtr = i;
411: return TCL_OK;
412: }
413:
414: /*
415: *----------------------------------------------------------------------
416: *
417: * Tcl_ScanElement --
418: *
419: * This procedure is a companion procedure to Tcl_ConvertElement.
420: * It scans a string to see what needs to be done to it (e.g.
421: * add backslashes or enclosing braces) to make the string into
422: * a valid Tcl list element.
423: *
424: * Results:
425: * The return value is an overestimate of the number of characters
426: * that will be needed by Tcl_ConvertElement to produce a valid
427: * list element from string. The word at *flagPtr is filled in
428: * with a value needed by Tcl_ConvertElement when doing the actual
429: * conversion.
430: *
431: * Side effects:
432: * None.
433: *
434: *----------------------------------------------------------------------
435: */
436:
437: int
438: Tcl_ScanElement(string, flagPtr)
439: char *string; /* String to convert to Tcl list element. */
440: int *flagPtr; /* Where to store information to guide
441: * Tcl_ConvertElement. */
442: {
443: int flags, nestingLevel;
444: register char *p;
445:
446: /*
447: * This procedure and Tcl_ConvertElement together do two things:
448: *
449: * 1. They produce a proper list, one that will yield back the
450: * argument strings when evaluated or when disassembled with
451: * Tcl_SplitList. This is the most important thing.
452: *
453: * 2. They try to produce legible output, which means minimizing the
454: * use of backslashes (using braces instead). However, there are
455: * some situations where backslashes must be used (e.g. an element
456: * like "{abc": the leading brace will have to be backslashed. For
457: * each element, one of three things must be done:
458: *
459: * (a) Use the element as-is (it doesn't contain anything special
460: * characters). This is the most desirable option.
461: *
462: * (b) Enclose the element in braces, but leave the contents alone.
463: * This happens if the element contains embedded space, or if it
464: * contains characters with special interpretation ($, [, ;, or \),
465: * or if it starts with a brace or double-quote, or if there are
466: * no characters in the element.
467: *
468: * (c) Don't enclose the element in braces, but add backslashes to
469: * prevent special interpretation of special characters. This is a
470: * last resort used when the argument would normally fall under case
471: * (b) but contains unmatched braces. It also occurs if the last
472: * character of the argument is a backslash.
473: *
474: * The procedure figures out how many bytes will be needed to store
475: * the result (actually, it overestimates). It also collects information
476: * about the element in the form of a flags word.
477: */
478:
479: nestingLevel = 0;
480: flags = 0;
481: p = string;
482: if ((*p == '{') || (*p == '"') || (*p == 0)) {
483: flags |= USE_BRACES;
484: }
485: for ( ; *p != 0; p++) {
486: switch (*p) {
487: case '{':
488: nestingLevel++;
489: break;
490: case '}':
491: nestingLevel--;
492: if (nestingLevel < 0) {
493: flags |= TCL_DONT_USE_BRACES|BRACES_UNMATCHED;
494: }
495: break;
496: case '[':
497: case '$':
498: case ';':
499: case ' ':
500: case '\f':
501: case '\n':
502: case '\r':
503: case '\t':
504: case '\v':
505: flags |= USE_BRACES;
506: break;
507: case '\\':
508: if (p[1] == 0) {
509: flags = TCL_DONT_USE_BRACES;
510: } else {
511: int size;
512:
513: (void) Tcl_Backslash(p, &size);
514: p += size-1;
515: flags |= USE_BRACES;
516: }
517: break;
518: }
519: }
520: if (nestingLevel != 0) {
521: flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED;
522: }
523: *flagPtr = flags;
524:
525: /*
526: * Allow enough space to backslash every character plus leave
527: * two spaces for braces.
528: */
529:
530: return 2*(p-string) + 2;
531: }
532:
533: /*
534: *----------------------------------------------------------------------
535: *
536: * Tcl_ConvertElement --
537: *
538: * This is a companion procedure to Tcl_ScanElement. Given the
539: * information produced by Tcl_ScanElement, this procedure converts
540: * a string to a list element equal to that string.
541: *
542: * Results:
543: * Information is copied to *dst in the form of a list element
544: * identical to src (i.e. if Tcl_SplitList is applied to dst it
545: * will produce a string identical to src). The return value is
546: * a count of the number of characters copied (not including the
547: * terminating NULL character).
548: *
549: * Side effects:
550: * None.
551: *
552: *----------------------------------------------------------------------
553: */
554:
555: int
556: Tcl_ConvertElement(src, dst, flags)
557: register char *src; /* Source information for list element. */
558: char *dst; /* Place to put list-ified element. */
559: int flags; /* Flags produced by Tcl_ScanElement. */
560: {
561: register char *p = dst;
562:
563: /*
564: * See the comment block at the beginning of the Tcl_ScanElement
565: * code for details of how this works.
566: */
567:
568: if ((flags & USE_BRACES) && !(flags & TCL_DONT_USE_BRACES)) {
569: *p = '{';
570: p++;
571: for ( ; *src != 0; src++, p++) {
572: *p = *src;
573: }
574: *p = '}';
575: p++;
576: } else if (*src == 0) {
577: /*
578: * If string is empty but can't use braces, then use special
579: * backslash sequence that maps to empty string.
580: */
581:
582: p[0] = '\\';
583: p[1] = '0';
584: p += 2;
585: } else {
586: for (; *src != 0 ; src++) {
587: switch (*src) {
588: case ']':
589: case '[':
590: case '$':
591: case ';':
592: case ' ':
593: case '\\':
594: case '"':
595: *p = '\\';
596: p++;
597: break;
598: case '{':
599: case '}':
600: if (flags & BRACES_UNMATCHED) {
601: *p = '\\';
602: p++;
603: }
604: break;
605: case '\f':
606: *p = '\\';
607: p++;
608: *p = 'f';
609: p++;
610: continue;
611: case '\n':
612: *p = '\\';
613: p++;
614: *p = 'n';
615: p++;
616: continue;
617: case '\r':
618: *p = '\\';
619: p++;
620: *p = 'r';
621: p++;
622: continue;
623: case '\t':
624: *p = '\\';
625: p++;
626: *p = 't';
627: p++;
628: continue;
629: case '\v':
630: *p = '\\';
631: p++;
632: *p = 'v';
633: p++;
634: continue;
635: }
636: *p = *src;
637: p++;
638: }
639: }
640: *p = '\0';
641: return p-dst;
642: }
643:
644: /*
645: *----------------------------------------------------------------------
646: *
647: * Tcl_Merge --
648: *
649: * Given a collection of strings, merge them together into a
650: * single string that has proper Tcl list structured (i.e.
651: * Tcl_SplitList may be used to retrieve strings equal to the
652: * original elements, and Tcl_Eval will parse the string back
653: * into its original elements).
654: *
655: * Results:
656: * The return value is the address of a dynamically-allocated
657: * string containing the merged list.
658: *
659: * Side effects:
660: * None.
661: *
662: *----------------------------------------------------------------------
663: */
664:
665: char *
666: Tcl_Merge(argc, argv)
667: int argc; /* How many strings to merge. */
668: char **argv; /* Array of string values. */
669: {
670: # define LOCAL_SIZE 20
671: int localFlags[LOCAL_SIZE], *flagPtr;
672: int numChars;
673: char *result;
674: register char *dst;
675: int i;
676:
677: /*
678: * Pass 1: estimate space, gather flags.
679: */
680:
681: if (argc <= LOCAL_SIZE) {
682: flagPtr = localFlags;
683: } else {
684: flagPtr = (int *) ckalloc((unsigned) argc*sizeof(int));
685: }
686: numChars = 1;
687: for (i = 0; i < argc; i++) {
688: numChars += Tcl_ScanElement(argv[i], &flagPtr[i]) + 1;
689: }
690:
691: /*
692: * Pass two: copy into the result area.
693: */
694:
695: result = (char *) ckalloc((unsigned) numChars);
696: dst = result;
697: for (i = 0; i < argc; i++) {
698: numChars = Tcl_ConvertElement(argv[i], dst, flagPtr[i]);
699: dst += numChars;
700: *dst = ' ';
701: dst++;
702: }
703: if (dst == result) {
704: *dst = 0;
705: } else {
706: dst[-1] = 0;
707: }
708:
709: if (flagPtr != localFlags) {
710: ckfree((char *) flagPtr);
711: }
712: return result;
713: }
714:
715: /*
716: *----------------------------------------------------------------------
717: *
718: * Tcl_Concat --
719: *
720: * Concatenate a set of strings into a single large string.
721: *
722: * Results:
723: * The return value is dynamically-allocated string containing
724: * a concatenation of all the strings in argv, with spaces between
725: * the original argv elements.
726: *
727: * Side effects:
728: * Memory is allocated for the result; the caller is responsible
729: * for freeing the memory.
730: *
731: *----------------------------------------------------------------------
732: */
733:
734: char *
735: Tcl_Concat(argc, argv)
736: int argc; /* Number of strings to concatenate. */
737: char **argv; /* Array of strings to concatenate. */
738: {
739: int totalSize, i;
740: register char *p;
741: char *result;
742:
743: for (totalSize = 1, i = 0; i < argc; i++) {
744: totalSize += strlen(argv[i]) + 1;
745: }
746: result = (char *) ckalloc((unsigned) totalSize);
747: if (argc == 0) {
748: *result = '\0';
749: return result;
750: }
751: for (p = result, i = 0; i < argc; i++) {
752: char *element;
753: int length;
754:
755: /*
756: * Clip white space off the front and back of the string
757: * to generate a neater result, and ignore any empty
758: * elements.
759: */
760:
761: element = argv[i];
762: while (isspace(*element)) {
763: element++;
764: }
765: for (length = strlen(element);
766: (length > 0) && (isspace(element[length-1]));
767: length--) {
768: /* Null loop body. */
769: }
770: if (length == 0) {
771: continue;
772: }
773: (void) strncpy(p, element, length);
774: p += length;
775: *p = ' ';
776: p++;
777: }
778: if (p != result) {
779: p[-1] = 0;
780: } else {
781: *p = 0;
782: }
783: return result;
784: }
785:
786: /*
787: *----------------------------------------------------------------------
788: *
789: * Tcl_StringMatch --
790: *
791: * See if a particular string matches a particular pattern.
792: *
793: * Results:
794: * The return value is 1 if string matches pattern, and
795: * 0 otherwise. The matching operation permits the following
796: * special characters in the pattern: *?\[] (see the manual
797: * entry for details on what these mean).
798: *
799: * Side effects:
800: * None.
801: *
802: *----------------------------------------------------------------------
803: */
804:
805: int
806: Tcl_StringMatch(string, pattern)
807: register char *string; /* String. */
808: register char *pattern; /* Pattern, which may contain
809: * special characters. */
810: {
811: char c2;
812:
813: while (1) {
814: /* See if we're at the end of both the pattern and the string.
815: * If so, we succeeded. If we're at the end of the pattern
816: * but not at the end of the string, we failed.
817: */
818:
819: if (*pattern == 0) {
820: if (*string == 0) {
821: return 1;
822: } else {
823: return 0;
824: }
825: }
826: if ((*string == 0) && (*pattern != '*')) {
827: return 0;
828: }
829:
830: /* Check for a "*" as the next pattern character. It matches
831: * any substring. We handle this by calling ourselves
832: * recursively for each postfix of string, until either we
833: * match or we reach the end of the string.
834: */
835:
836: if (*pattern == '*') {
837: pattern += 1;
838: if (*pattern == 0) {
839: return 1;
840: }
841: while (1) {
842: if (Tcl_StringMatch(string, pattern)) {
843: return 1;
844: }
845: if (*string == 0) {
846: return 0;
847: }
848: string += 1;
849: }
850: }
851:
852: /* Check for a "?" as the next pattern character. It matches
853: * any single character.
854: */
855:
856: if (*pattern == '?') {
857: goto thisCharOK;
858: }
859:
860: /* Check for a "[" as the next pattern character. It is followed
861: * by a list of characters that are acceptable, or by a range
862: * (two characters separated by "-").
863: */
864:
865: if (*pattern == '[') {
866: pattern += 1;
867: while (1) {
868: if ((*pattern == ']') || (*pattern == 0)) {
869: return 0;
870: }
871: if (*pattern == *string) {
872: break;
873: }
874: if (pattern[1] == '-') {
875: c2 = pattern[2];
876: if (c2 == 0) {
877: return 0;
878: }
879: if ((*pattern <= *string) && (c2 >= *string)) {
880: break;
881: }
882: if ((*pattern >= *string) && (c2 <= *string)) {
883: break;
884: }
885: pattern += 2;
886: }
887: pattern += 1;
888: }
889: while ((*pattern != ']') && (*pattern != 0)) {
890: pattern += 1;
891: }
892: goto thisCharOK;
893: }
894:
895: /* If the next pattern character is '/', just strip off the '/'
896: * so we do exact matching on the character that follows.
897: */
898:
899: if (*pattern == '\\') {
900: pattern += 1;
901: if (*pattern == 0) {
902: return 0;
903: }
904: }
905:
906: /* There's no special character. Just make sure that the next
907: * characters of each string match.
908: */
909:
910: if (*pattern != *string) {
911: return 0;
912: }
913:
914: thisCharOK: pattern += 1;
915: string += 1;
916: }
917: }
918:
919: /*
920: *----------------------------------------------------------------------
921: *
922: * Tcl_SetResult --
923: *
924: * Arrange for "string" to be the Tcl return value.
925: *
926: * Results:
927: * None.
928: *
929: * Side effects:
930: * interp->result is left pointing either to "string" (if "copy" is 0)
931: * or to a copy of string.
932: *
933: *----------------------------------------------------------------------
934: */
935:
936: void
937: Tcl_SetResult(interp, string, freeProc)
938: Tcl_Interp *interp; /* Interpreter with which to associate the
939: * return value. */
940: char *string; /* Value to be returned. If NULL,
941: * the result is set to an empty string. */
942: Tcl_FreeProc *freeProc; /* Gives information about the string:
943: * TCL_STATIC, TCL_VOLATILE, or the address
944: * of a Tcl_FreeProc such as free. */
945: {
946: register Interp *iPtr = (Interp *) interp;
947: int length;
948: Tcl_FreeProc *oldFreeProc = iPtr->freeProc;
949: char *oldResult = iPtr->result;
950:
951: iPtr->freeProc = freeProc;
952: if (string == NULL) {
953: iPtr->resultSpace[0] = 0;
954: iPtr->result = iPtr->resultSpace;
955: iPtr->freeProc = 0;
956: } else if (freeProc == TCL_VOLATILE) {
957: length = strlen(string);
958: if (length > TCL_RESULT_SIZE) {
959: iPtr->result = (char *) ckalloc((unsigned) length+1);
960: iPtr->freeProc = (Tcl_FreeProc *) free;
961: } else {
962: iPtr->result = iPtr->resultSpace;
963: iPtr->freeProc = 0;
964: }
965: strcpy(iPtr->result, string);
966: } else {
967: iPtr->result = string;
968: }
969:
970: /*
971: * If the old result was dynamically-allocated, free it up. Do it
972: * here, rather than at the beginning, in case the new result value
973: * was part of the old result value.
974: */
975:
976: if (oldFreeProc != 0) {
977: (*oldFreeProc)(oldResult);
978: }
979: }
980:
981: /*
982: *----------------------------------------------------------------------
983: *
984: * Tcl_AppendResult --
985: *
986: * Append a variable number of strings onto the result already
987: * present for an interpreter.
988: *
989: * Results:
990: * None.
991: *
992: * Side effects:
993: * The result in the interpreter given by the first argument
994: * is extended by the strings given by the second and following
995: * arguments (up to a terminating NULL argument).
996: *
997: *----------------------------------------------------------------------
998: */
999:
1000: void
1001: Tcl_AppendResult(Tcl_Interp *interp, ...)
1002: {
1003: va_list argList;
1004: register Interp *iPtr;
1005: char *string;
1006: int newSpace;
1007:
1008: /*
1009: * First, scan through all the arguments to see how much space is
1010: * needed.
1011: */
1012:
1013: va_start(argList, interp);
1014: iPtr = (Interp *)interp;
1015: newSpace = 0;
1016: while (1) {
1017: string = va_arg(argList, char *);
1018: if (string == NULL) {
1019: break;
1020: }
1021: newSpace += strlen(string);
1022: }
1023: va_end(argList);
1024:
1025: /*
1026: * If the append buffer isn't already setup and large enough
1027: * to hold the new data, set it up.
1028: */
1029:
1030: if ((iPtr->result != iPtr->appendResult)
1031: || ((newSpace + iPtr->appendUsed) >= iPtr->appendAvl)) {
1032: SetupAppendBuffer(iPtr, newSpace);
1033: }
1034:
1035: /*
1036: * Final step: go through all the argument strings again, copying
1037: * them into the buffer.
1038: */
1039:
1040: va_start(argList, interp);
1041: while (1) {
1042: string = va_arg(argList, char *);
1043: if (string == NULL) {
1044: break;
1045: }
1046: strcpy(iPtr->appendResult + iPtr->appendUsed, string);
1047: iPtr->appendUsed += strlen(string);
1048: }
1049: va_end(argList);
1050: }
1051:
1052: /*
1053: *----------------------------------------------------------------------
1054: *
1055: * Tcl_AppendElement --
1056: *
1057: * Convert a string to a valid Tcl list element and append it
1058: * to the current result (which is ostensibly a list).
1059: *
1060: * Results:
1061: * None.
1062: *
1063: * Side effects:
1064: * The result in the interpreter given by the first argument
1065: * is extended with a list element converted from string. If
1066: * the original result wasn't empty, then a blank is added before
1067: * the converted list element.
1068: *
1069: *----------------------------------------------------------------------
1070: */
1071:
1072: void
1073: Tcl_AppendElement(interp, string, noSep)
1074: Tcl_Interp *interp; /* Interpreter whose result is to be
1075: * extended. */
1076: char *string; /* String to convert to list element and
1077: * add to result. */
1078: int noSep; /* If non-zero, then don't output a
1079: * space character before this element,
1080: * even if the element isn't the first
1081: * thing in the output buffer. */
1082: {
1083: register Interp *iPtr = (Interp *) interp;
1084: int size, flags;
1085: char *dst;
1086:
1087: /*
1088: * See how much space is needed, and grow the append buffer if
1089: * needed to accommodate the list element.
1090: */
1091:
1092: size = Tcl_ScanElement(string, &flags) + 1;
1093: if ((iPtr->result != iPtr->appendResult)
1094: || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) {
1095: SetupAppendBuffer(iPtr, size+iPtr->appendUsed);
1096: }
1097:
1098: /*
1099: * Convert the string into a list element and copy it to the
1100: * buffer that's forming.
1101: */
1102:
1103: dst = iPtr->appendResult + iPtr->appendUsed;
1104: if (!noSep && (iPtr->appendUsed != 0)) {
1105: iPtr->appendUsed++;
1106: *dst = ' ';
1107: dst++;
1108: }
1109: iPtr->appendUsed += Tcl_ConvertElement(string, dst, flags);
1110: }
1111:
1112: /*
1113: *----------------------------------------------------------------------
1114: *
1115: * SetupAppendBuffer --
1116: *
1117: * This procedure makes sure that there is an append buffer
1118: * properly initialized for interp, and that it has at least
1119: * enough room to accommodate newSpace new bytes of information.
1120: *
1121: * Results:
1122: * None.
1123: *
1124: * Side effects:
1125: * None.
1126: *
1127: *----------------------------------------------------------------------
1128: */
1129:
1130: static void
1131: SetupAppendBuffer(iPtr, newSpace)
1132: register Interp *iPtr; /* Interpreter whose result is being set up. */
1133: int newSpace; /* Make sure that at least this many bytes
1134: * of new information may be added. */
1135: {
1136: int totalSpace;
1137:
1138: /*
1139: * Make the append buffer larger, if that's necessary, then
1140: * copy the current result into the append buffer and make the
1141: * append buffer the official Tcl result.
1142: */
1143:
1144: if (iPtr->result != iPtr->appendResult) {
1145: /*
1146: * If an oversized buffer was used recently, then free it up
1147: * so we go back to a smaller buffer. This avoids tying up
1148: * memory forever after a large operation.
1149: */
1150:
1151: if (iPtr->appendAvl > 500) {
1152: ckfree(iPtr->appendResult);
1153: iPtr->appendResult = NULL;
1154: iPtr->appendAvl = 0;
1155: }
1156: iPtr->appendUsed = strlen(iPtr->result);
1157: }
1158: totalSpace = newSpace + iPtr->appendUsed;
1159: if (totalSpace >= iPtr->appendAvl) {
1160: char *new;
1161:
1162: if (totalSpace < 100) {
1163: totalSpace = 200;
1164: } else {
1165: totalSpace *= 2;
1166: }
1167: new = (char *) ckalloc((unsigned) totalSpace);
1168: strcpy(new, iPtr->result);
1169: if (iPtr->appendResult != NULL) {
1170: ckfree(iPtr->appendResult);
1171: }
1172: iPtr->appendResult = new;
1173: iPtr->appendAvl = totalSpace;
1174: } else if (iPtr->result != iPtr->appendResult) {
1175: strcpy(iPtr->appendResult, iPtr->result);
1176: }
1177: Tcl_FreeResult(iPtr);
1178: iPtr->result = iPtr->appendResult;
1179: }
1180:
1181: /*
1182: *----------------------------------------------------------------------
1183: *
1184: * Tcl_ResetResult --
1185: *
1186: * This procedure restores the result area for an interpreter
1187: * to its default initialized state, freeing up any memory that
1188: * may have been allocated for the result and clearing any
1189: * error information for the interpreter.
1190: *
1191: * Results:
1192: * None.
1193: *
1194: * Side effects:
1195: * None.
1196: *
1197: *----------------------------------------------------------------------
1198: */
1199:
1200: void
1201: Tcl_ResetResult(interp)
1202: Tcl_Interp *interp; /* Interpreter for which to clear result. */
1203: {
1204: register Interp *iPtr = (Interp *) interp;
1205:
1206: Tcl_FreeResult(iPtr);
1207: iPtr->result = iPtr->resultSpace;
1208: iPtr->resultSpace[0] = 0;
1209: iPtr->flags &=
1210: ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS | ERROR_CODE_SET);
1211: }
1212:
1213: /*
1214: *----------------------------------------------------------------------
1215: *
1216: * Tcl_SetErrorCode --
1217: *
1218: * This procedure is called to record machine-readable information
1219: * about an error that is about to be returned.
1220: *
1221: * Results:
1222: * None.
1223: *
1224: * Side effects:
1225: * The errorCode global variable is modified to hold all of the
1226: * arguments to this procedure, in a list form with each argument
1227: * becoming one element of the list. A flag is set internally
1228: * to remember that errorCode has been set, so the variable doesn't
1229: * get set automatically when the error is returned.
1230: *
1231: *----------------------------------------------------------------------
1232: */
1233: void
1234: Tcl_SetErrorCode(Tcl_Interp *interp, ...)
1235: {
1236: va_list argList;
1237: char *string;
1238: int flags;
1239: Interp *iPtr;
1240:
1241: /*
1242: * Scan through the arguments one at a time, appending them to
1243: * $errorCode as list elements.
1244: */
1245:
1246: va_start(argList, interp);
1247: iPtr = (Interp *)interp;
1248: flags = TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT;
1249: while (1) {
1250: string = va_arg(argList, char *);
1251: if (string == NULL) {
1252: break;
1253: }
1254: (void) Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode",
1255: (char *) NULL, string, flags);
1256: flags |= TCL_APPEND_VALUE;
1257: }
1258: va_end(argList);
1259: iPtr->flags |= ERROR_CODE_SET;
1260: }
1261:
1262: /*
1263: *----------------------------------------------------------------------
1264: *
1265: * TclGetListIndex --
1266: *
1267: * Parse a list index, which may be either an integer or the
1268: * value "end".
1269: *
1270: * Results:
1271: * The return value is either TCL_OK or TCL_ERROR. If it is
1272: * TCL_OK, then the index corresponding to string is left in
1273: * *indexPtr. If the return value is TCL_ERROR, then string
1274: * was bogus; an error message is returned in interp->result.
1275: * If a negative index is specified, it is rounded up to 0.
1276: * The index value may be larger than the size of the list
1277: * (this happens when "end" is specified).
1278: *
1279: * Side effects:
1280: * None.
1281: *
1282: *----------------------------------------------------------------------
1283: */
1284:
1285: int
1286: TclGetListIndex(interp, string, indexPtr)
1287: Tcl_Interp *interp; /* Interpreter for error reporting. */
1288: char *string; /* String containing list index. */
1289: int *indexPtr; /* Where to store index. */
1290: {
1291: if (isdigit(*string) || (*string == '-')) {
1292: if (Tcl_GetInt(interp, string, indexPtr) != TCL_OK) {
1293: return TCL_ERROR;
1294: }
1295: if (*indexPtr < 0) {
1296: *indexPtr = 0;
1297: }
1298: } else if (strncmp(string, "end", strlen(string)) == 0) {
1299: *indexPtr = 1<<30;
1300: } else {
1301: Tcl_AppendResult(interp, "bad index \"", string,
1302: "\": must be integer or \"end\"", (char *) NULL);
1303: return TCL_ERROR;
1304: }
1305: return TCL_OK;
1306: }
1307:
1308: /*
1309: *----------------------------------------------------------------------
1310: *
1311: * TclCompileRegexp --
1312: *
1313: * Compile a regular expression into a form suitable for fast
1314: * matching. This procedure retains a small cache of pre-compiled
1315: * regular expressions in the interpreter, in order to avoid
1316: * compilation costs as much as possible.
1317: *
1318: * Results:
1319: * The return value is a pointer to the compiled form of string,
1320: * suitable for passing to regexec. If an error occurred while
1321: * compiling the pattern, then NULL is returned and an error
1322: * message is left in interp->result.
1323: *
1324: * Side effects:
1325: * The cache of compiled regexp's in interp will be modified to
1326: * hold information for string, if such information isn't already
1327: * present in the cache.
1328: *
1329: *----------------------------------------------------------------------
1330: */
1331:
1332: regexp *
1333: TclCompileRegexp(interp, string)
1334: Tcl_Interp *interp; /* For use in error reporting. */
1335: char *string; /* String for which to produce
1336: * compiled regular expression. */
1337: {
1338: register Interp *iPtr = (Interp *) interp;
1339: int i, length;
1340: regexp *result;
1341:
1342: length = strlen(string);
1343: for (i = 0; i < NUM_REGEXPS; i++) {
1344: if ((length == iPtr->patLengths[i])
1345: && (strcmp(string, iPtr->patterns[i]) == 0)) {
1346: /*
1347: * Move the matched pattern to the first slot in the
1348: * cache and shift the other patterns down one position.
1349: */
1350:
1351: if (i != 0) {
1352: int j;
1353: char *cachedString;
1354:
1355: cachedString = iPtr->patterns[i];
1356: result = iPtr->regexps[i];
1357: for (j = i-1; j >= 0; j--) {
1358: iPtr->patterns[j+1] = iPtr->patterns[j];
1359: iPtr->patLengths[j+1] = iPtr->patLengths[j];
1360: iPtr->regexps[j+1] = iPtr->regexps[j];
1361: }
1362: iPtr->patterns[0] = cachedString;
1363: iPtr->patLengths[0] = length;
1364: iPtr->regexps[0] = result;
1365: }
1366: return iPtr->regexps[0];
1367: }
1368: }
1369:
1370: /*
1371: * No match in the cache. Compile the string and add it to the
1372: * cache.
1373: */
1374:
1375: tclRegexpError = NULL;
1376: result = regcomp(string);
1377: if (tclRegexpError != NULL) {
1378: Tcl_AppendResult(interp,
1379: "couldn't compile regular expression pattern: ",
1380: tclRegexpError, (char *) NULL);
1381: return NULL;
1382: }
1383: if (iPtr->patterns[NUM_REGEXPS-1] != NULL) {
1384: ckfree(iPtr->patterns[NUM_REGEXPS-1]);
1385: ckfree((char *) iPtr->regexps[NUM_REGEXPS-1]);
1386: }
1387: for (i = NUM_REGEXPS - 2; i >= 0; i--) {
1388: iPtr->patterns[i+1] = iPtr->patterns[i];
1389: iPtr->patLengths[i+1] = iPtr->patLengths[i];
1390: iPtr->regexps[i+1] = iPtr->regexps[i];
1391: }
1392: iPtr->patterns[0] = (char *) ckalloc((unsigned) (length+1));
1393: strcpy(iPtr->patterns[0], string);
1394: iPtr->patLengths[0] = length;
1395: iPtr->regexps[0] = result;
1396: return result;
1397: }
1398:
1399: /*
1400: *----------------------------------------------------------------------
1401: *
1402: * regerror --
1403: *
1404: * This procedure is invoked by the Henry Spencer's regexp code
1405: * when an error occurs. It saves the error message so it can
1406: * be seen by the code that called Spencer's code.
1407: *
1408: * Results:
1409: * None.
1410: *
1411: * Side effects:
1412: * The value of "string" is saved in "tclRegexpError".
1413: *
1414: *----------------------------------------------------------------------
1415: */
1416:
1417: void
1418: regerror(string)
1419: char *string; /* Error message. */
1420: {
1421: tclRegexpError = string;
1422: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.