]> git.zerfleddert.de Git - micropolis/blame - src/tcl/tclutil.c
fix colors on BGR displays
[micropolis] / src / tcl / tclutil.c
CommitLineData
6a5fa4e0
MG
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
18static 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
52char *tclRegexpError = NULL;
53
54/*
55 * Function prototypes for local procedures in this file:
56 */
57
58static void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr,
59 int newSpace));
60\f
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
95int
96TclFindElement(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\f
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
295void
296TclCopyAndCollapse(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\f
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
351int
352Tcl_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\f
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
437int
438Tcl_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\f
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
555int
556Tcl_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\f
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
665char *
666Tcl_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\f
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
734char *
735Tcl_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\f
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
805int
806Tcl_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\f
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
936void
937Tcl_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\f
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
1000void
1001Tcl_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\f
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
1072void
1073Tcl_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\f
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
1130static void
1131SetupAppendBuffer(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\f
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
1200void
1201Tcl_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\f
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 */
1233void
1234Tcl_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\f
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
1285int
1286TclGetListIndex(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\f
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
1332regexp *
1333TclCompileRegexp(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\f
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
1417void
1418regerror(string)
1419 char *string; /* Error message. */
1420{
1421 tclRegexpError = string;
1422}
Impressum, Datenschutz