1 /*
2 * tclUtil.c --
3 *
4 * This file contains utility procedures that are used by many Tcl
5 * commands.
6 *
7 * Copyright (c) 1987-1993 The Regents of the University of California.
8 * Copyright (c) 1994-1995 Sun Microsystems, Inc.
9 *
10 * See the file "license.terms" for information on usage and redistribution
11 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
12 *
13 * SCCS: @(#) tclUtil.c 1.114 96/06/06 13:48:58
14 */
15
16 #include "tclInt.h"
17 #include "tclPort.h"
18
19 /*
20 * The following values are used in the flags returned by Tcl_ScanElement
21 * and used by Tcl_ConvertElement. The value TCL_DONT_USE_BRACES is also
22 * defined in tcl.h; make sure its value doesn't overlap with any of the
23 * values below.
24 *
25 * TCL_DONT_USE_BRACES - 1 means the string mustn't be enclosed in
26 * braces (e.g. it contains unmatched braces,
27 * or ends in a backslash character, or user
28 * just doesn't want braces); handle all
29 * special characters by adding backslashes.
30 * USE_BRACES - 1 means the string contains a special
31 * character that can be handled simply by
32 * enclosing the entire argument in braces.
33 * BRACES_UNMATCHED - 1 means that braces aren't properly matched
34 * in the argument.
35 */
36
37 #define USE_BRACES 2
38 #define BRACES_UNMATCHED 4
39
40 /*
41 * Function prototypes for local procedures in this file:
42 */
43
44 static void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr,
45 int newSpace));
46
47 /*
48 *----------------------------------------------------------------------
49 *
50 * TclFindElement --
51 *
52 * Given a pointer into a Tcl list, locate the first (or next)
53 * element in the list.
54 *
55 * Results:
56 * The return value is normally TCL_OK, which means that the
57 * element was successfully located. If TCL_ERROR is returned
58 * it means that list didn't have proper list structure;
59 * interp->result contains a more detailed error message.
60 *
61 * If TCL_OK is returned, then *elementPtr will be set to point
62 * to the first element of list, and *nextPtr will be set to point
63 * to the character just after any white space following the last
64 * character that's part of the element. If this is the last argument
65 * in the list, then *nextPtr will point to the NULL character at the
66 * end of list. If sizePtr is non-NULL, *sizePtr is filled in with
67 * the number of characters in the element. If the element is in
68 * braces, then *elementPtr will point to the character after the
69 * opening brace and *sizePtr will not include either of the braces.
70 * If there isn't an element in the list, *sizePtr will be zero, and
71 * both *elementPtr and *termPtr will refer to the null character at
72 * the end of list. Note: this procedure does NOT collapse backslash
73 * sequences.
74 *
75 * Side effects:
76 * None.
77 *
78 *----------------------------------------------------------------------
79 */
80
81 int
TclFindElement(interp,list,elementPtr,nextPtr,sizePtr,bracePtr)82 TclFindElement(interp, list, elementPtr, nextPtr, sizePtr, bracePtr)
83 Tcl_Interp *interp; /* Interpreter to use for error reporting.
84 * If NULL, then no error message is left
85 * after errors. */
86 register char *list; /* String containing Tcl list with zero
87 * or more elements (possibly in braces). */
88 char **elementPtr; /* Fill in with location of first significant
89 * character in first element of list. */
90 char **nextPtr; /* Fill in with location of character just
91 * after all white space following end of
92 * argument (i.e. next argument or end of
93 * list). */
94 int *sizePtr; /* If non-zero, fill in with size of
95 * element. */
96 int *bracePtr; /* If non-zero fill in with non-zero/zero
97 * to indicate that arg was/wasn't
98 * in braces. */
99 {
100 register char *p;
101 int openBraces = 0;
102 int inQuotes = 0;
103 int size;
104
105 /*
106 * Skim off leading white space and check for an opening brace or
107 * quote. Note: use of "isascii" below and elsewhere in this
108 * procedure is a temporary hack (7/27/90) because Mx uses characters
109 * with the high-order bit set for some things. This should probably
110 * be changed back eventually, or all of Tcl should call isascii.
111 */
112
113 while (isspace(UCHAR(*list))) {
114 list++;
115 }
116 if (*list == '{') {
117 openBraces = 1;
118 list++;
119 } else if (*list == '"') {
120 inQuotes = 1;
121 list++;
122 }
123 if (bracePtr != 0) {
124 *bracePtr = openBraces;
125 }
126 p = list;
127
128 /*
129 * Find the end of the element (either a space or a close brace or
130 * the end of the string).
131 */
132
133 while (1) {
134 switch (*p) {
135
136 /*
137 * Open brace: don't treat specially unless the element is
138 * in braces. In this case, keep a nesting count.
139 */
140
141 case '{':
142 if (openBraces != 0) {
143 openBraces++;
144 }
145 break;
146
147 /*
148 * Close brace: if element is in braces, keep nesting
149 * count and quit when the last close brace is seen.
150 */
151
152 case '}':
153 if (openBraces == 1) {
154 char *p2;
155
156 size = p - list;
157 p++;
158 if (isspace(UCHAR(*p)) || (*p == 0)) {
159 goto done;
160 }
161 for (p2 = p; (*p2 != 0) && (!isspace(UCHAR(*p2)))
162 && (p2 < p+20); p2++) {
163 /* null body */
164 }
165 if (interp != NULL) {
166 Tcl_ResetResult(interp);
167 sprintf(interp->result,
168 "list element in braces followed by \"%.*s\" instead of space",
169 (int) (p2-p), p);
170 }
171 return TCL_ERROR;
172 } else if (openBraces != 0) {
173 openBraces--;
174 }
175 break;
176
177 /*
178 * Backslash: skip over everything up to the end of the
179 * backslash sequence.
180 */
181
182 case '\\': {
183 int size;
184
185 (void) Tcl_Backslash(p, &size);
186 p += size - 1;
187 break;
188 }
189
190 /*
191 * Space: ignore if element is in braces or quotes; otherwise
192 * terminate element.
193 */
194
195 case ' ':
196 case '\f':
197 case '\n':
198 case '\r':
199 case '\t':
200 case '\v':
201 if ((openBraces == 0) && !inQuotes) {
202 size = p - list;
203 goto done;
204 }
205 break;
206
207 /*
208 * Double-quote: if element is in quotes then terminate it.
209 */
210
211 case '"':
212 if (inQuotes) {
213 char *p2;
214
215 size = p-list;
216 p++;
217 if (isspace(UCHAR(*p)) || (*p == 0)) {
218 goto done;
219 }
220 for (p2 = p; (*p2 != 0) && (!isspace(UCHAR(*p2)))
221 && (p2 < p+20); p2++) {
222 /* null body */
223 }
224 if (interp != NULL) {
225 Tcl_ResetResult(interp);
226 sprintf(interp->result,
227 "list element in quotes followed by \"%.*s\" %s", (int) (p2-p), p,
228 "instead of space");
229 }
230 return TCL_ERROR;
231 }
232 break;
233
234 /*
235 * End of list: terminate element.
236 */
237
238 case 0:
239 if (openBraces != 0) {
240 if (interp != NULL) {
241 Tcl_SetResult(interp, "unmatched open brace in list",
242 TCL_STATIC);
243 }
244 return TCL_ERROR;
245 } else if (inQuotes) {
246 if (interp != NULL) {
247 Tcl_SetResult(interp, "unmatched open quote in list",
248 TCL_STATIC);
249 }
250 return TCL_ERROR;
251 }
252 size = p - list;
253 goto done;
254
255 }
256 p++;
257 }
258
259 done:
260 while (isspace(UCHAR(*p))) {
261 p++;
262 }
263 *elementPtr = list;
264 *nextPtr = p;
265 if (sizePtr != 0) {
266 *sizePtr = size;
267 }
268 return TCL_OK;
269 }
270
271 /*
272 *----------------------------------------------------------------------
273 *
274 * TclCopyAndCollapse --
275 *
276 * Copy a string and eliminate any backslashes that aren't in braces.
277 *
278 * Results:
279 * There is no return value. Count chars. get copied from src
280 * to dst. Along the way, if backslash sequences are found outside
281 * braces, the backslashes are eliminated in the copy.
282 * After scanning count chars. from source, a null character is
283 * placed at the end of dst.
284 *
285 * Side effects:
286 * None.
287 *
288 *----------------------------------------------------------------------
289 */
290
291 void
TclCopyAndCollapse(count,src,dst)292 TclCopyAndCollapse(count, src, dst)
293 int count; /* Total number of characters to copy
294 * from src. */
295 register char *src; /* Copy from here... */
296 register char *dst; /* ... to here. */
297 {
298 register char c;
299 int numRead;
300
301 for (c = *src; count > 0; src++, c = *src, count--) {
302 if (c == '\\') {
303 *dst = Tcl_Backslash(src, &numRead);
304 dst++;
305 src += numRead-1;
306 count -= numRead-1;
307 } else {
308 *dst = c;
309 dst++;
310 }
311 }
312 *dst = 0;
313 }
314
315 /*
316 *----------------------------------------------------------------------
317 *
318 * Tcl_SplitList --
319 *
320 * Splits a list up into its constituent fields.
321 *
322 * Results
323 * The return value is normally TCL_OK, which means that
324 * the list was successfully split up. If TCL_ERROR is
325 * returned, it means that "list" didn't have proper list
326 * structure; interp->result will contain a more detailed
327 * error message.
328 *
329 * *argvPtr will be filled in with the address of an array
330 * whose elements point to the elements of list, in order.
331 * *argcPtr will get filled in with the number of valid elements
332 * in the array. A single block of memory is dynamically allocated
333 * to hold both the argv array and a copy of the list (with
334 * backslashes and braces removed in the standard way).
335 * The caller must eventually free this memory by calling free()
336 * on *argvPtr. Note: *argvPtr and *argcPtr are only modified
337 * if the procedure returns normally.
338 *
339 * Side effects:
340 * Memory is allocated.
341 *
342 *----------------------------------------------------------------------
343 */
344
345 int
Tcl_TclSplitList(interp,list,argcPtr,argvPtr)346 Tcl_TclSplitList(interp, list, argcPtr, argvPtr)
347 Tcl_Interp *interp; /* Interpreter to use for error reporting.
348 * If NULL, then no error message is left. */
349 char *list; /* Pointer to string with list structure. */
350 int *argcPtr; /* Pointer to location to fill in with
351 * the number of elements in the list. */
352 char ***argvPtr; /* Pointer to place to store pointer to array
353 * of pointers to list elements. */
354 {
355 char **argv;
356 register char *p;
357 int size, i, result, elSize, brace;
358 char *element;
359
360 /*
361 * Figure out how much space to allocate. There must be enough
362 * space for both the array of pointers and also for a copy of
363 * the list. To estimate the number of pointers needed, count
364 * the number of space characters in the list.
365 */
366
367 for (size = 1, p = list; *p != 0; p++) {
368 if (isspace(UCHAR(*p))) {
369 size++;
370 }
371 }
372 size++; /* Leave space for final NULL pointer. */
373 argv = (char **) ckalloc((unsigned)
374 ((size * sizeof(char *)) + (p - list) + 1));
375 for (i = 0, p = ((char *) argv) + size*sizeof(char *);
376 *list != 0; i++) {
377 result = TclFindElement(interp, list, &element, &list, &elSize, &brace);
378 if (result != TCL_OK) {
379 ckfree((char *) argv);
380 return result;
381 }
382 if (*element == 0) {
383 break;
384 }
385 if (i >= size) {
386 ckfree((char *) argv);
387 if (interp != NULL) {
388 Tcl_SetResult(interp, "internal error in Tcl_SplitList",
389 TCL_STATIC);
390 }
391 return TCL_ERROR;
392 }
393 argv[i] = p;
394 if (brace) {
395 strncpy(p, element, (size_t) elSize);
396 p += elSize;
397 *p = 0;
398 p++;
399 } else {
400 TclCopyAndCollapse(elSize, element, p);
401 p += elSize+1;
402 }
403 }
404
405 argv[i] = NULL;
406 *argvPtr = argv;
407 *argcPtr = i;
408 return TCL_OK;
409 }
410
411 /*
412 *----------------------------------------------------------------------
413 *
414 * Tcl_ScanElement --
415 *
416 * This procedure is a companion procedure to Tcl_ConvertElement.
417 * It scans a string to see what needs to be done to it (e.g.
418 * add backslashes or enclosing braces) to make the string into
419 * a valid Tcl list element.
420 *
421 * Results:
422 * The return value is an overestimate of the number of characters
423 * that will be needed by Tcl_ConvertElement to produce a valid
424 * list element from string. The word at *flagPtr is filled in
425 * with a value needed by Tcl_ConvertElement when doing the actual
426 * conversion.
427 *
428 * Side effects:
429 * None.
430 *
431 *----------------------------------------------------------------------
432 */
433
434 int
Tcl_TclScanElement(string,flagPtr)435 Tcl_TclScanElement(string, flagPtr)
436 char *string; /* String to convert to Tcl list element. */
437 int *flagPtr; /* Where to store information to guide
438 * Tcl_ConvertElement. */
439 {
440 int flags, nestingLevel;
441 register char *p;
442
443 /*
444 * This procedure and Tcl_ConvertElement together do two things:
445 *
446 * 1. They produce a proper list, one that will yield back the
447 * argument strings when evaluated or when disassembled with
448 * Tcl_SplitList. This is the most important thing.
449 *
450 * 2. They try to produce legible output, which means minimizing the
451 * use of backslashes (using braces instead). However, there are
452 * some situations where backslashes must be used (e.g. an element
453 * like "{abc": the leading brace will have to be backslashed. For
454 * each element, one of three things must be done:
455 *
456 * (a) Use the element as-is (it doesn't contain anything special
457 * characters). This is the most desirable option.
458 *
459 * (b) Enclose the element in braces, but leave the contents alone.
460 * This happens if the element contains embedded space, or if it
461 * contains characters with special interpretation ($, [, ;, or \),
462 * or if it starts with a brace or double-quote, or if there are
463 * no characters in the element.
464 *
465 * (c) Don't enclose the element in braces, but add backslashes to
466 * prevent special interpretation of special characters. This is a
467 * last resort used when the argument would normally fall under case
468 * (b) but contains unmatched braces. It also occurs if the last
469 * character of the argument is a backslash or if the element contains
470 * a backslash followed by newline.
471 *
472 * The procedure figures out how many bytes will be needed to store
473 * the result (actually, it overestimates). It also collects information
474 * about the element in the form of a flags word.
475 */
476
477 nestingLevel = 0;
478 flags = 0;
479 if (string == NULL) {
480 string = "";
481 }
482 p = string;
483 if ((*p == '{') || (*p == '"') || (*p == 0)) {
484 flags |= USE_BRACES;
485 }
486 for ( ; *p != 0; p++) {
487 switch (*p) {
488 case '{':
489 nestingLevel++;
490 break;
491 case '}':
492 nestingLevel--;
493 if (nestingLevel < 0) {
494 flags |= TCL_DONT_USE_BRACES|BRACES_UNMATCHED;
495 }
496 break;
497 case '[':
498 case '$':
499 case ';':
500 case ' ':
501 case '\f':
502 case '\n':
503 case '\r':
504 case '\t':
505 case '\v':
506 flags |= USE_BRACES;
507 break;
508 case '\\':
509 if ((p[1] == 0) || (p[1] == '\n')) {
510 flags = TCL_DONT_USE_BRACES;
511 } else {
512 int size;
513
514 (void) Tcl_Backslash(p, &size);
515 p += size-1;
516 flags |= USE_BRACES;
517 }
518 break;
519 }
520 }
521 if (nestingLevel != 0) {
522 flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED;
523 }
524 *flagPtr = flags;
525
526 /*
527 * Allow enough space to backslash every character plus leave
528 * two spaces for braces.
529 */
530
531 return 2*(p-string) + 2;
532 }
533
534 /*
535 *----------------------------------------------------------------------
536 *
537 * Tcl_ConvertElement --
538 *
539 * This is a companion procedure to Tcl_ScanElement. Given the
540 * information produced by Tcl_ScanElement, this procedure converts
541 * a string to a list element equal to that string.
542 *
543 * Results:
544 * Information is copied to *dst in the form of a list element
545 * identical to src (i.e. if Tcl_SplitList is applied to dst it
546 * will produce a string identical to src). The return value is
547 * a count of the number of characters copied (not including the
548 * terminating NULL character).
549 *
550 * Side effects:
551 * None.
552 *
553 *----------------------------------------------------------------------
554 */
555
556 int
Tcl_TclConvertElement(src,dst,flags)557 Tcl_TclConvertElement(src, dst, flags)
558 register char *src; /* Source information for list element. */
559 char *dst; /* Place to put list-ified element. */
560 int flags; /* Flags produced by Tcl_ScanElement. */
561 {
562 register char *p = dst;
563
564 /*
565 * See the comment block at the beginning of the Tcl_ScanElement
566 * code for details of how this works.
567 */
568
569 if ((src == NULL) || (*src == 0)) {
570 p[0] = '{';
571 p[1] = '}';
572 p[2] = 0;
573 return 2;
574 }
575 if ((flags & USE_BRACES) && !(flags & TCL_DONT_USE_BRACES)) {
576 *p = '{';
577 p++;
578 for ( ; *src != 0; src++, p++) {
579 *p = *src;
580 }
581 *p = '}';
582 p++;
583 } else {
584 if (*src == '{') {
585 /*
586 * Can't have a leading brace unless the whole element is
587 * enclosed in braces. Add a backslash before the brace.
588 * Furthermore, this may destroy the balance between open
589 * and close braces, so set BRACES_UNMATCHED.
590 */
591
592 p[0] = '\\';
593 p[1] = '{';
594 p += 2;
595 src++;
596 flags |= BRACES_UNMATCHED;
597 }
598 for (; *src != 0 ; src++) {
599 switch (*src) {
600 case ']':
601 case '[':
602 case '$':
603 case ';':
604 case ' ':
605 case '\\':
606 case '"':
607 *p = '\\';
608 p++;
609 break;
610 case '{':
611 case '}':
612 /*
613 * It may not seem necessary to backslash braces, but
614 * it is. The reason for this is that the resulting
615 * list element may actually be an element of a sub-list
616 * enclosed in braces (e.g. if Tcl_DStringStartSublist
617 * has been invoked), so there may be a brace mismatch
618 * if the braces aren't backslashed.
619 */
620
621 if (flags & BRACES_UNMATCHED) {
622 *p = '\\';
623 p++;
624 }
625 break;
626 case '\f':
627 *p = '\\';
628 p++;
629 *p = 'f';
630 p++;
631 continue;
632 case '\n':
633 *p = '\\';
634 p++;
635 *p = 'n';
636 p++;
637 continue;
638 case '\r':
639 *p = '\\';
640 p++;
641 *p = 'r';
642 p++;
643 continue;
644 case '\t':
645 *p = '\\';
646 p++;
647 *p = 't';
648 p++;
649 continue;
650 case '\v':
651 *p = '\\';
652 p++;
653 *p = 'v';
654 p++;
655 continue;
656 }
657 *p = *src;
658 p++;
659 }
660 }
661 *p = '\0';
662 return p-dst;
663 }
664
665 /*
666 *----------------------------------------------------------------------
667 *
668 * Tcl_Merge --
669 *
670 * Given a collection of strings, merge them together into a
671 * single string that has proper Tcl list structured (i.e.
672 * Tcl_SplitList may be used to retrieve strings equal to the
673 * original elements, and Tcl_Eval will parse the string back
674 * into its original elements).
675 *
676 * Results:
677 * The return value is the address of a dynamically-allocated
678 * string containing the merged list.
679 *
680 * Side effects:
681 * None.
682 *
683 *----------------------------------------------------------------------
684 */
685
686 char *
Tcl_TclMerge(argc,argv)687 Tcl_TclMerge(argc, argv)
688 int argc; /* How many strings to merge. */
689 char **argv; /* Array of string values. */
690 {
691 # define LOCAL_SIZE 20
692 int localFlags[LOCAL_SIZE], *flagPtr;
693 int numChars;
694 char *result;
695 register char *dst;
696 int i;
697
698 /*
699 * Pass 1: estimate space, gather flags.
700 */
701
702 if (argc <= LOCAL_SIZE) {
703 flagPtr = localFlags;
704 } else {
705 flagPtr = (int *) ckalloc((unsigned) argc*sizeof(int));
706 }
707 numChars = 1;
708 for (i = 0; i < argc; i++) {
709 numChars += Tcl_ScanElement(argv[i], &flagPtr[i]) + 1;
710 }
711
712 /*
713 * Pass two: copy into the result area.
714 */
715
716 result = (char *) ckalloc((unsigned) numChars);
717 dst = result;
718 for (i = 0; i < argc; i++) {
719 numChars = Tcl_ConvertElement(argv[i], dst, flagPtr[i]);
720 dst += numChars;
721 *dst = ' ';
722 dst++;
723 }
724 if (dst == result) {
725 *dst = 0;
726 } else {
727 dst[-1] = 0;
728 }
729
730 if (flagPtr != localFlags) {
731 ckfree((char *) flagPtr);
732 }
733 return result;
734 }
735
736 /*
737 *----------------------------------------------------------------------
738 *
739 * Tcl_Concat --
740 *
741 * Concatenate a set of strings into a single large string.
742 *
743 * Results:
744 * The return value is dynamically-allocated string containing
745 * a concatenation of all the strings in argv, with spaces between
746 * the original argv elements.
747 *
748 * Side effects:
749 * Memory is allocated for the result; the caller is responsible
750 * for freeing the memory.
751 *
752 *----------------------------------------------------------------------
753 */
754
755 char *
Tcl_Concat(argc,argv)756 Tcl_Concat(argc, argv)
757 int argc; /* Number of strings to concatenate. */
758 char **argv; /* Array of strings to concatenate. */
759 {
760 int totalSize, i;
761 register char *p;
762 char *result;
763
764 for (totalSize = 1, i = 0; i < argc; i++) {
765 totalSize += strlen(argv[i]) + 1;
766 }
767 result = (char *) ckalloc((unsigned) totalSize);
768 if (argc == 0) {
769 *result = '\0';
770 return result;
771 }
772 for (p = result, i = 0; i < argc; i++) {
773 char *element;
774 int length;
775
776 /*
777 * Clip white space off the front and back of the string
778 * to generate a neater result, and ignore any empty
779 * elements.
780 */
781
782 element = argv[i];
783 while (isspace(UCHAR(*element))) {
784 element++;
785 }
786 for (length = strlen(element);
787 (length > 0) && (isspace(UCHAR(element[length-1])));
788 length--) {
789 /* Null loop body. */
790 }
791 if (length == 0) {
792 continue;
793 }
794 (void) strncpy(p, element, (size_t) length);
795 p += length;
796 *p = ' ';
797 p++;
798 }
799 if (p != result) {
800 p[-1] = 0;
801 } else {
802 *p = 0;
803 }
804 return result;
805 }
806
807 /*
808 *----------------------------------------------------------------------
809 *
810 * Tcl_StringMatch --
811 *
812 * See if a particular string matches a particular pattern.
813 *
814 * Results:
815 * The return value is 1 if string matches pattern, and
816 * 0 otherwise. The matching operation permits the following
817 * special characters in the pattern: *?\[] (see the manual
818 * entry for details on what these mean).
819 *
820 * Side effects:
821 * None.
822 *
823 *----------------------------------------------------------------------
824 */
825
826 int
Tcl_StringMatch(string,pattern)827 Tcl_StringMatch(string, pattern)
828 register char *string; /* String. */
829 register char *pattern; /* Pattern, which may contain
830 * special characters. */
831 {
832 char c2;
833
834 while (1) {
835 /* See if we're at the end of both the pattern and the string.
836 * If so, we succeeded. If we're at the end of the pattern
837 * but not at the end of the string, we failed.
838 */
839
840 if (*pattern == 0) {
841 if (*string == 0) {
842 return 1;
843 } else {
844 return 0;
845 }
846 }
847 if ((*string == 0) && (*pattern != '*')) {
848 return 0;
849 }
850
851 /* Check for a "*" as the next pattern character. It matches
852 * any substring. We handle this by calling ourselves
853 * recursively for each postfix of string, until either we
854 * match or we reach the end of the string.
855 */
856
857 if (*pattern == '*') {
858 pattern += 1;
859 if (*pattern == 0) {
860 return 1;
861 }
862 while (1) {
863 if (Tcl_StringMatch(string, pattern)) {
864 return 1;
865 }
866 if (*string == 0) {
867 return 0;
868 }
869 string += 1;
870 }
871 }
872
873 /* Check for a "?" as the next pattern character. It matches
874 * any single character.
875 */
876
877 if (*pattern == '?') {
878 goto thisCharOK;
879 }
880
881 /* Check for a "[" as the next pattern character. It is followed
882 * by a list of characters that are acceptable, or by a range
883 * (two characters separated by "-").
884 */
885
886 if (*pattern == '[') {
887 pattern += 1;
888 while (1) {
889 if ((*pattern == ']') || (*pattern == 0)) {
890 return 0;
891 }
892 if (*pattern == *string) {
893 break;
894 }
895 if (pattern[1] == '-') {
896 c2 = pattern[2];
897 if (c2 == 0) {
898 return 0;
899 }
900 if ((*pattern <= *string) && (c2 >= *string)) {
901 break;
902 }
903 if ((*pattern >= *string) && (c2 <= *string)) {
904 break;
905 }
906 pattern += 2;
907 }
908 pattern += 1;
909 }
910 while (*pattern != ']') {
911 if (*pattern == 0) {
912 pattern--;
913 break;
914 }
915 pattern += 1;
916 }
917 goto thisCharOK;
918 }
919
920 /* If the next pattern character is '/', just strip off the '/'
921 * so we do exact matching on the character that follows.
922 */
923
924 if (*pattern == '\\') {
925 pattern += 1;
926 if (*pattern == 0) {
927 return 0;
928 }
929 }
930
931 /* There's no special character. Just make sure that the next
932 * characters of each string match.
933 */
934
935 if (*pattern != *string) {
936 return 0;
937 }
938
939 thisCharOK: pattern += 1;
940 string += 1;
941 }
942 }
943
944 /*
945 *----------------------------------------------------------------------
946 *
947 * Tcl_SetResult --
948 *
949 * Arrange for "string" to be the Tcl return value.
950 *
951 * Results:
952 * None.
953 *
954 * Side effects:
955 * interp->result is left pointing either to "string" (if "copy" is 0)
956 * or to a copy of string.
957 *
958 *----------------------------------------------------------------------
959 */
960
961 void
Tcl_SetResult(interp,string,freeProc)962 Tcl_SetResult(interp, string, freeProc)
963 Tcl_Interp *interp; /* Interpreter with which to associate the
964 * return value. */
965 char *string; /* Value to be returned. If NULL,
966 * the result is set to an empty string. */
967 Tcl_FreeProc *freeProc; /* Gives information about the string:
968 * TCL_STATIC, TCL_VOLATILE, or the address
969 * of a Tcl_FreeProc such as free. */
970 {
971 register Interp *iPtr = (Interp *) interp;
972 int length;
973 Tcl_FreeProc *oldFreeProc = iPtr->freeProc;
974 char *oldResult = iPtr->result;
975
976 if (string == NULL) {
977 iPtr->resultSpace[0] = 0;
978 iPtr->result = iPtr->resultSpace;
979 iPtr->freeProc = 0;
980 } else if (freeProc == TCL_VOLATILE) {
981 length = strlen(string);
982 if (length > TCL_RESULT_SIZE) {
983 iPtr->result = (char *) ckalloc((unsigned) length+1);
984 iPtr->freeProc = TCL_DYNAMIC;
985 } else {
986 iPtr->result = iPtr->resultSpace;
987 iPtr->freeProc = 0;
988 }
989 strcpy(iPtr->result, string);
990 } else {
991 iPtr->result = string;
992 iPtr->freeProc = freeProc;
993 }
994
995 /*
996 * If the old result was dynamically-allocated, free it up. Do it
997 * here, rather than at the beginning, in case the new result value
998 * was part of the old result value.
999 */
1000
1001 if (oldFreeProc != 0) {
1002 if ((oldFreeProc == TCL_DYNAMIC)
1003 || (oldFreeProc == (Tcl_FreeProc *) free)) {
1004 ckfree(oldResult);
1005 } else {
1006 (*oldFreeProc)(oldResult);
1007 }
1008 }
1009 }
1010
1011 /*
1012 *----------------------------------------------------------------------
1013 *
1014 * Tcl_AppendResult --
1015 *
1016 * Append a variable number of strings onto the result already
1017 * present for an interpreter.
1018 *
1019 * Results:
1020 * None.
1021 *
1022 * Side effects:
1023 * The result in the interpreter given by the first argument
1024 * is extended by the strings given by the second and following
1025 * arguments (up to a terminating NULL argument).
1026 *
1027 *----------------------------------------------------------------------
1028 */
1029
1030 /* VARARGS2 */
1031 void
TCL_VARARGS_DEF(Tcl_Interp *,arg1)1032 Tcl_AppendResult TCL_VARARGS_DEF(Tcl_Interp *,arg1)
1033 {
1034 va_list argList;
1035 register Interp *iPtr;
1036 char *string;
1037 int newSpace;
1038
1039 /*
1040 * First, scan through all the arguments to see how much space is
1041 * needed.
1042 */
1043
1044 iPtr = (Interp *) TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
1045 newSpace = 0;
1046 while (1) {
1047 string = va_arg(argList, char *);
1048 if (string == NULL) {
1049 break;
1050 }
1051 newSpace += strlen(string);
1052 }
1053 va_end(argList);
1054
1055 /*
1056 * If the append buffer isn't already setup and large enough
1057 * to hold the new data, set it up.
1058 */
1059
1060 if ((iPtr->result != iPtr->appendResult)
1061 || (iPtr->appendResult[iPtr->appendUsed] != 0)
1062 || ((newSpace + iPtr->appendUsed) >= iPtr->appendAvl)) {
1063 SetupAppendBuffer(iPtr, newSpace);
1064 }
1065
1066 /*
1067 * Final step: go through all the argument strings again, copying
1068 * them into the buffer.
1069 */
1070
1071 TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
1072 while (1) {
1073 string = va_arg(argList, char *);
1074 if (string == NULL) {
1075 break;
1076 }
1077 strcpy(iPtr->appendResult + iPtr->appendUsed, string);
1078 iPtr->appendUsed += strlen(string);
1079 }
1080 va_end(argList);
1081 }
1082
1083 /*
1084 *----------------------------------------------------------------------
1085 *
1086 * Tcl_AppendElement --
1087 *
1088 * Convert a string to a valid Tcl list element and append it
1089 * to the current result (which is ostensibly a list).
1090 *
1091 * Results:
1092 * None.
1093 *
1094 * Side effects:
1095 * The result in the interpreter given by the first argument
1096 * is extended with a list element converted from string. A
1097 * separator space is added before the converted list element
1098 * unless the current result is empty, contains the single
1099 * character "{", or ends in " {".
1100 *
1101 *----------------------------------------------------------------------
1102 */
1103
1104 void
Tcl_AppendElement(interp,string)1105 Tcl_AppendElement(interp, string)
1106 Tcl_Interp *interp; /* Interpreter whose result is to be
1107 * extended. */
1108 char *string; /* String to convert to list element and
1109 * add to result. */
1110 {
1111 register Interp *iPtr = (Interp *) interp;
1112 int size, flags;
1113 char *dst;
1114
1115 /*
1116 * See how much space is needed, and grow the append buffer if
1117 * needed to accommodate the list element.
1118 */
1119
1120 size = Tcl_ScanElement(string, &flags) + 1;
1121 if ((iPtr->result != iPtr->appendResult)
1122 || (iPtr->appendResult[iPtr->appendUsed] != 0)
1123 || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) {
1124 SetupAppendBuffer(iPtr, size+iPtr->appendUsed);
1125 }
1126
1127 /*
1128 * Convert the string into a list element and copy it to the
1129 * buffer that's forming, with a space separator if needed.
1130 */
1131
1132 dst = iPtr->appendResult + iPtr->appendUsed;
1133 if (TclNeedSpace(iPtr->appendResult, dst)) {
1134 iPtr->appendUsed++;
1135 *dst = ' ';
1136 dst++;
1137 }
1138 iPtr->appendUsed += Tcl_ConvertElement(string, dst, flags);
1139 }
1140
1141 /*
1142 *----------------------------------------------------------------------
1143 *
1144 * SetupAppendBuffer --
1145 *
1146 * This procedure makes sure that there is an append buffer
1147 * properly initialized for interp, and that it has at least
1148 * enough room to accommodate newSpace new bytes of information.
1149 *
1150 * Results:
1151 * None.
1152 *
1153 * Side effects:
1154 * None.
1155 *
1156 *----------------------------------------------------------------------
1157 */
1158
1159 static void
SetupAppendBuffer(iPtr,newSpace)1160 SetupAppendBuffer(iPtr, newSpace)
1161 register Interp *iPtr; /* Interpreter whose result is being set up. */
1162 int newSpace; /* Make sure that at least this many bytes
1163 * of new information may be added. */
1164 {
1165 int totalSpace;
1166
1167 /*
1168 * Make the append buffer larger, if that's necessary, then
1169 * copy the current result into the append buffer and make the
1170 * append buffer the official Tcl result.
1171 */
1172
1173 if (iPtr->result != iPtr->appendResult) {
1174 /*
1175 * If an oversized buffer was used recently, then free it up
1176 * so we go back to a smaller buffer. This avoids tying up
1177 * memory forever after a large operation.
1178 */
1179
1180 if (iPtr->appendAvl > 500) {
1181 ckfree(iPtr->appendResult);
1182 iPtr->appendResult = NULL;
1183 iPtr->appendAvl = 0;
1184 }
1185 iPtr->appendUsed = strlen(iPtr->result);
1186 } else if (iPtr->result[iPtr->appendUsed] != 0) {
1187 /*
1188 * Most likely someone has modified a result created by
1189 * Tcl_AppendResult et al. so that it has a different size.
1190 * Just recompute the size.
1191 */
1192
1193 iPtr->appendUsed = strlen(iPtr->result);
1194 }
1195 totalSpace = newSpace + iPtr->appendUsed;
1196 if (totalSpace >= iPtr->appendAvl) {
1197 char *new;
1198
1199 if (totalSpace < 100) {
1200 totalSpace = 200;
1201 } else {
1202 totalSpace *= 2;
1203 }
1204 new = (char *) ckalloc((unsigned) totalSpace);
1205 strcpy(new, iPtr->result);
1206 if (iPtr->appendResult != NULL) {
1207 ckfree(iPtr->appendResult);
1208 }
1209 iPtr->appendResult = new;
1210 iPtr->appendAvl = totalSpace;
1211 } else if (iPtr->result != iPtr->appendResult) {
1212 strcpy(iPtr->appendResult, iPtr->result);
1213 }
1214 Tcl_FreeResult(iPtr);
1215 iPtr->result = iPtr->appendResult;
1216 }
1217
1218 /*
1219 *----------------------------------------------------------------------
1220 *
1221 * Tcl_ResetResult --
1222 *
1223 * This procedure restores the result area for an interpreter
1224 * to its default initialized state, freeing up any memory that
1225 * may have been allocated for the result and clearing any
1226 * error information for the interpreter.
1227 *
1228 * Results:
1229 * None.
1230 *
1231 * Side effects:
1232 * None.
1233 *
1234 *----------------------------------------------------------------------
1235 */
1236
1237 void
Tcl_ResetResult(interp)1238 Tcl_ResetResult(interp)
1239 Tcl_Interp *interp; /* Interpreter for which to clear result. */
1240 {
1241 register Interp *iPtr = (Interp *) interp;
1242
1243 Tcl_FreeResult(iPtr);
1244 iPtr->result = iPtr->resultSpace;
1245 iPtr->resultSpace[0] = 0;
1246 iPtr->flags &=
1247 ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS | ERROR_CODE_SET);
1248 }
1249
1250 /*
1251 *----------------------------------------------------------------------
1252 *
1253 * Tcl_SetErrorCode --
1254 *
1255 * This procedure is called to record machine-readable information
1256 * about an error that is about to be returned.
1257 *
1258 * Results:
1259 * None.
1260 *
1261 * Side effects:
1262 * The errorCode global variable is modified to hold all of the
1263 * arguments to this procedure, in a list form with each argument
1264 * becoming one element of the list. A flag is set internally
1265 * to remember that errorCode has been set, so the variable doesn't
1266 * get set automatically when the error is returned.
1267 *
1268 *----------------------------------------------------------------------
1269 */
1270 /* VARARGS2 */
1271 void
TCL_VARARGS_DEF(Tcl_Interp *,arg1)1272 Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1)
1273 {
1274 va_list argList;
1275 char *string;
1276 int flags;
1277 Interp *iPtr;
1278
1279 /*
1280 * Scan through the arguments one at a time, appending them to
1281 * $errorCode as list elements.
1282 */
1283
1284 iPtr = (Interp *) TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
1285 flags = TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT;
1286 while (1) {
1287 string = va_arg(argList, char *);
1288 if (string == NULL) {
1289 break;
1290 }
1291 (void) Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode",
1292 (char *) NULL, string, flags);
1293 flags |= TCL_APPEND_VALUE;
1294 }
1295 va_end(argList);
1296 iPtr->flags |= ERROR_CODE_SET;
1297 }
1298
1299 /*
1300 *----------------------------------------------------------------------
1301 *
1302 * TclGetListIndex --
1303 *
1304 * Parse a list index, which may be either an integer or the
1305 * value "end".
1306 *
1307 * Results:
1308 * The return value is either TCL_OK or TCL_ERROR. If it is
1309 * TCL_OK, then the index corresponding to string is left in
1310 * *indexPtr. If the return value is TCL_ERROR, then string
1311 * was bogus; an error message is returned in interp->result.
1312 * If a negative index is specified, it is rounded up to 0.
1313 * The index value may be larger than the size of the list
1314 * (this happens when "end" is specified).
1315 *
1316 * Side effects:
1317 * None.
1318 *
1319 *----------------------------------------------------------------------
1320 */
1321
1322 int
TclGetListIndex(interp,string,indexPtr)1323 TclGetListIndex(interp, string, indexPtr)
1324 Tcl_Interp *interp; /* Interpreter for error reporting. */
1325 char *string; /* String containing list index. */
1326 int *indexPtr; /* Where to store index. */
1327 {
1328 if (isdigit(UCHAR(*string)) || (*string == '-')) {
1329 if (Tcl_GetInt(interp, string, indexPtr) != TCL_OK) {
1330 return TCL_ERROR;
1331 }
1332 if (*indexPtr < 0) {
1333 *indexPtr = 0;
1334 }
1335 } else if (strncmp(string, "end", strlen(string)) == 0) {
1336 *indexPtr = INT_MAX;
1337 } else {
1338 Tcl_AppendResult(interp, "bad index \"", string,
1339 "\": must be integer or \"end\"", (char *) NULL);
1340 return TCL_ERROR;
1341 }
1342 return TCL_OK;
1343 }
1344
1345 /*
1346 *----------------------------------------------------------------------
1347 *
1348 * Tcl_RegExpCompile --
1349 *
1350 * Compile a regular expression into a form suitable for fast
1351 * matching. This procedure retains a small cache of pre-compiled
1352 * regular expressions in the interpreter, in order to avoid
1353 * compilation costs as much as possible.
1354 *
1355 * Results:
1356 * The return value is a pointer to the compiled form of string,
1357 * suitable for passing to Tcl_RegExpExec. This compiled form
1358 * is only valid up until the next call to this procedure, so
1359 * don't keep these around for a long time! If an error occurred
1360 * while compiling the pattern, then NULL is returned and an error
1361 * message is left in interp->result.
1362 *
1363 * Side effects:
1364 * The cache of compiled regexp's in interp will be modified to
1365 * hold information for string, if such information isn't already
1366 * present in the cache.
1367 *
1368 *----------------------------------------------------------------------
1369 */
1370
1371 Tcl_RegExp
Tcl_RegExpCompile(interp,string)1372 Tcl_RegExpCompile(interp, string)
1373 Tcl_Interp *interp; /* For use in error reporting. */
1374 char *string; /* String for which to produce
1375 * compiled regular expression. */
1376 {
1377 register Interp *iPtr = (Interp *) interp;
1378 int i, length;
1379 regexp *result;
1380
1381 length = strlen(string);
1382 for (i = 0; i < NUM_REGEXPS; i++) {
1383 if ((length == iPtr->patLengths[i])
1384 && (strcmp(string, iPtr->patterns[i]) == 0)) {
1385 /*
1386 * Move the matched pattern to the first slot in the
1387 * cache and shift the other patterns down one position.
1388 */
1389
1390 if (i != 0) {
1391 int j;
1392 char *cachedString;
1393
1394 cachedString = iPtr->patterns[i];
1395 result = iPtr->regexps[i];
1396 for (j = i-1; j >= 0; j--) {
1397 iPtr->patterns[j+1] = iPtr->patterns[j];
1398 iPtr->patLengths[j+1] = iPtr->patLengths[j];
1399 iPtr->regexps[j+1] = iPtr->regexps[j];
1400 }
1401 iPtr->patterns[0] = cachedString;
1402 iPtr->patLengths[0] = length;
1403 iPtr->regexps[0] = result;
1404 }
1405 return (Tcl_RegExp) iPtr->regexps[0];
1406 }
1407 }
1408
1409 /*
1410 * No match in the cache. Compile the string and add it to the
1411 * cache.
1412 */
1413
1414 TclRegError((char *) NULL);
1415 result = TclRegComp(string);
1416 if (TclGetRegError() != NULL) {
1417 Tcl_AppendResult(interp,
1418 "couldn't compile regular expression pattern: ",
1419 TclGetRegError(), (char *) NULL);
1420 return NULL;
1421 }
1422 if (iPtr->patterns[NUM_REGEXPS-1] != NULL) {
1423 ckfree(iPtr->patterns[NUM_REGEXPS-1]);
1424 ckfree((char *) iPtr->regexps[NUM_REGEXPS-1]);
1425 }
1426 for (i = NUM_REGEXPS - 2; i >= 0; i--) {
1427 iPtr->patterns[i+1] = iPtr->patterns[i];
1428 iPtr->patLengths[i+1] = iPtr->patLengths[i];
1429 iPtr->regexps[i+1] = iPtr->regexps[i];
1430 }
1431 iPtr->patterns[0] = (char *) ckalloc((unsigned) (length+1));
1432 strcpy(iPtr->patterns[0], string);
1433 iPtr->patLengths[0] = length;
1434 iPtr->regexps[0] = result;
1435 return (Tcl_RegExp) result;
1436 }
1437
1438 /*
1439 *----------------------------------------------------------------------
1440 *
1441 * Tcl_RegExpExec --
1442 *
1443 * Execute the regular expression matcher using a compiled form
1444 * of a regular expression and save information about any match
1445 * that is found.
1446 *
1447 * Results:
1448 * If an error occurs during the matching operation then -1
1449 * is returned and interp->result contains an error message.
1450 * Otherwise the return value is 1 if a matching range is
1451 * found and 0 if there is no matching range.
1452 *
1453 * Side effects:
1454 * None.
1455 *
1456 *----------------------------------------------------------------------
1457 */
1458
1459 int
Tcl_RegExpExec(interp,re,string,start)1460 Tcl_RegExpExec(interp, re, string, start)
1461 Tcl_Interp *interp; /* Interpreter to use for error reporting. */
1462 Tcl_RegExp re; /* Compiled regular expression; must have
1463 * been returned by previous call to
1464 * Tcl_RegExpCompile. */
1465 char *string; /* String against which to match re. */
1466 char *start; /* If string is part of a larger string,
1467 * this identifies beginning of larger
1468 * string, so that "^" won't match. */
1469 {
1470 int match;
1471
1472 regexp *regexpPtr = (regexp *) re;
1473 TclRegError((char *) NULL);
1474 match = TclRegExec(regexpPtr, string, start);
1475 if (TclGetRegError() != NULL) {
1476 Tcl_ResetResult(interp);
1477 Tcl_AppendResult(interp, "error while matching regular expression: ",
1478 TclGetRegError(), (char *) NULL);
1479 return -1;
1480 }
1481 return match;
1482 }
1483
1484 /*
1485 *----------------------------------------------------------------------
1486 *
1487 * Tcl_RegExpRange --
1488 *
1489 * Returns pointers describing the range of a regular expression match,
1490 * or one of the subranges within the match.
1491 *
1492 * Results:
1493 * The variables at *startPtr and *endPtr are modified to hold the
1494 * addresses of the endpoints of the range given by index. If the
1495 * specified range doesn't exist then NULLs are returned.
1496 *
1497 * Side effects:
1498 * None.
1499 *
1500 *----------------------------------------------------------------------
1501 */
1502
1503 void
Tcl_RegExpRange(re,index,startPtr,endPtr)1504 Tcl_RegExpRange(re, index, startPtr, endPtr)
1505 Tcl_RegExp re; /* Compiled regular expression that has
1506 * been passed to Tcl_RegExpExec. */
1507 int index; /* 0 means give the range of the entire
1508 * match, > 0 means give the range of
1509 * a matching subrange. Must be no greater
1510 * than NSUBEXP. */
1511 char **startPtr; /* Store address of first character in
1512 * (sub-) range here. */
1513 char **endPtr; /* Store address of character just after last
1514 * in (sub-) range here. */
1515 {
1516 regexp *regexpPtr = (regexp *) re;
1517
1518 if (index >= NSUBEXP) {
1519 *startPtr = *endPtr = NULL;
1520 } else {
1521 *startPtr = regexpPtr->startp[index];
1522 *endPtr = regexpPtr->endp[index];
1523 }
1524 }
1525
1526 /*
1527 *----------------------------------------------------------------------
1528 *
1529 * Tcl_RegExpMatch --
1530 *
1531 * See if a string matches a regular expression.
1532 *
1533 * Results:
1534 * If an error occurs during the matching operation then -1
1535 * is returned and interp->result contains an error message.
1536 * Otherwise the return value is 1 if "string" matches "pattern"
1537 * and 0 otherwise.
1538 *
1539 * Side effects:
1540 * None.
1541 *
1542 *----------------------------------------------------------------------
1543 */
1544
1545 int
Tcl_RegExpMatch(interp,string,pattern)1546 Tcl_RegExpMatch(interp, string, pattern)
1547 Tcl_Interp *interp; /* Used for error reporting. */
1548 char *string; /* String. */
1549 char *pattern; /* Regular expression to match against
1550 * string. */
1551 {
1552 Tcl_RegExp re;
1553
1554 re = Tcl_RegExpCompile(interp, pattern);
1555 if (re == NULL) {
1556 return -1;
1557 }
1558 return Tcl_RegExpExec(interp, re, string, string);
1559 }
1560
1561 /*
1562 *----------------------------------------------------------------------
1563 *
1564 * Tcl_DStringInit --
1565 *
1566 * Initializes a dynamic string, discarding any previous contents
1567 * of the string (Tcl_DStringFree should have been called already
1568 * if the dynamic string was previously in use).
1569 *
1570 * Results:
1571 * None.
1572 *
1573 * Side effects:
1574 * The dynamic string is initialized to be empty.
1575 *
1576 *----------------------------------------------------------------------
1577 */
1578
1579 void
Tcl_DStringInit(dsPtr)1580 Tcl_DStringInit(dsPtr)
1581 register Tcl_DString *dsPtr; /* Pointer to structure for
1582 * dynamic string. */
1583 {
1584 dsPtr->string = dsPtr->staticSpace;
1585 dsPtr->length = 0;
1586 dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
1587 dsPtr->staticSpace[0] = 0;
1588 }
1589
1590 /*
1591 *----------------------------------------------------------------------
1592 *
1593 * Tcl_DStringAppend --
1594 *
1595 * Append more characters to the current value of a dynamic string.
1596 *
1597 * Results:
1598 * The return value is a pointer to the dynamic string's new value.
1599 *
1600 * Side effects:
1601 * Length bytes from string (or all of string if length is less
1602 * than zero) are added to the current value of the string. Memory
1603 * gets reallocated if needed to accomodate the string's new size.
1604 *
1605 *----------------------------------------------------------------------
1606 */
1607
1608 char *
Tcl_DStringAppend(dsPtr,string,length)1609 Tcl_DStringAppend(dsPtr, string, length)
1610 register Tcl_DString *dsPtr; /* Structure describing dynamic
1611 * string. */
1612 char *string; /* String to append. If length is
1613 * -1 then this must be
1614 * null-terminated. */
1615 int length; /* Number of characters from string
1616 * to append. If < 0, then append all
1617 * of string, up to null at end. */
1618 {
1619 int newSize;
1620 char *newString, *dst, *end;
1621
1622 if (length < 0) {
1623 length = strlen(string);
1624 }
1625 newSize = length + dsPtr->length;
1626
1627 /*
1628 * Allocate a larger buffer for the string if the current one isn't
1629 * large enough. Allocate extra space in the new buffer so that there
1630 * will be room to grow before we have to allocate again.
1631 */
1632
1633 if (newSize >= dsPtr->spaceAvl) {
1634 dsPtr->spaceAvl = newSize*2;
1635 newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl);
1636 memcpy((VOID *)newString, (VOID *) dsPtr->string,
1637 (size_t) dsPtr->length);
1638 if (dsPtr->string != dsPtr->staticSpace) {
1639 ckfree(dsPtr->string);
1640 }
1641 dsPtr->string = newString;
1642 }
1643
1644 /*
1645 * Copy the new string into the buffer at the end of the old
1646 * one.
1647 */
1648
1649 for (dst = dsPtr->string + dsPtr->length, end = string+length;
1650 string < end; string++, dst++) {
1651 *dst = *string;
1652 }
1653 *dst = 0;
1654 dsPtr->length += length;
1655 return dsPtr->string;
1656 }
1657
1658 /*
1659 *----------------------------------------------------------------------
1660 *
1661 * Tcl_DStringAppendElement --
1662 *
1663 * Append a list element to the current value of a dynamic string.
1664 *
1665 * Results:
1666 * The return value is a pointer to the dynamic string's new value.
1667 *
1668 * Side effects:
1669 * String is reformatted as a list element and added to the current
1670 * value of the string. Memory gets reallocated if needed to
1671 * accomodate the string's new size.
1672 *
1673 *----------------------------------------------------------------------
1674 */
1675
1676 char *
Tcl_DStringAppendElement(dsPtr,string)1677 Tcl_DStringAppendElement(dsPtr, string)
1678 register Tcl_DString *dsPtr; /* Structure describing dynamic
1679 * string. */
1680 char *string; /* String to append. Must be
1681 * null-terminated. */
1682 {
1683 int newSize, flags;
1684 char *dst, *newString;
1685
1686 newSize = Tcl_ScanElement(string, &flags) + dsPtr->length + 1;
1687
1688 /*
1689 * Allocate a larger buffer for the string if the current one isn't
1690 * large enough. Allocate extra space in the new buffer so that there
1691 * will be room to grow before we have to allocate again.
1692 * SPECIAL NOTE: must use memcpy, not strcpy, to copy the string
1693 * to a larger buffer, since there may be embedded NULLs in the
1694 * string in some cases.
1695 */
1696
1697 if (newSize >= dsPtr->spaceAvl) {
1698 dsPtr->spaceAvl = newSize*2;
1699 newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl);
1700 memcpy((VOID *) newString, (VOID *) dsPtr->string,
1701 (size_t) dsPtr->length);
1702 if (dsPtr->string != dsPtr->staticSpace) {
1703 ckfree(dsPtr->string);
1704 }
1705 dsPtr->string = newString;
1706 }
1707
1708 /*
1709 * Convert the new string to a list element and copy it into the
1710 * buffer at the end, with a space, if needed.
1711 */
1712
1713 dst = dsPtr->string + dsPtr->length;
1714 if (TclNeedSpace(dsPtr->string, dst)) {
1715 *dst = ' ';
1716 dst++;
1717 dsPtr->length++;
1718 }
1719 dsPtr->length += Tcl_ConvertElement(string, dst, flags);
1720 return dsPtr->string;
1721 }
1722
1723 /*
1724 *----------------------------------------------------------------------
1725 *
1726 * Tcl_DStringSetLength --
1727 *
1728 * Change the length of a dynamic string. This can cause the
1729 * string to either grow or shrink, depending on the value of
1730 * length.
1731 *
1732 * Results:
1733 * None.
1734 *
1735 * Side effects:
1736 * The length of dsPtr is changed to length and a null byte is
1737 * stored at that position in the string. If length is larger
1738 * than the space allocated for dsPtr, then a panic occurs.
1739 *
1740 *----------------------------------------------------------------------
1741 */
1742
1743 void
Tcl_DStringSetLength(dsPtr,length)1744 Tcl_DStringSetLength(dsPtr, length)
1745 register Tcl_DString *dsPtr; /* Structure describing dynamic
1746 * string. */
1747 int length; /* New length for dynamic string. */
1748 {
1749 if (length < 0) {
1750 length = 0;
1751 }
1752 if (length >= dsPtr->spaceAvl) {
1753 char *newString;
1754
1755 dsPtr->spaceAvl = length+1;
1756 newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl);
1757
1758 /*
1759 * SPECIAL NOTE: must use memcpy, not strcpy, to copy the string
1760 * to a larger buffer, since there may be embedded NULLs in the
1761 * string in some cases.
1762 */
1763
1764 memcpy((VOID *) newString, (VOID *) dsPtr->string,
1765 (size_t) dsPtr->length);
1766 if (dsPtr->string != dsPtr->staticSpace) {
1767 ckfree(dsPtr->string);
1768 }
1769 dsPtr->string = newString;
1770 }
1771 dsPtr->length = length;
1772 dsPtr->string[length] = 0;
1773 }
1774
1775 /*
1776 *----------------------------------------------------------------------
1777 *
1778 * Tcl_DStringFree --
1779 *
1780 * Frees up any memory allocated for the dynamic string and
1781 * reinitializes the string to an empty state.
1782 *
1783 * Results:
1784 * None.
1785 *
1786 * Side effects:
1787 * The previous contents of the dynamic string are lost, and
1788 * the new value is an empty string.
1789 *
1790 *----------------------------------------------------------------------
1791 */
1792
1793 void
Tcl_DStringFree(dsPtr)1794 Tcl_DStringFree(dsPtr)
1795 register Tcl_DString *dsPtr; /* Structure describing dynamic
1796 * string. */
1797 {
1798 if (dsPtr->string != dsPtr->staticSpace) {
1799 ckfree(dsPtr->string);
1800 }
1801 dsPtr->string = dsPtr->staticSpace;
1802 dsPtr->length = 0;
1803 dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
1804 dsPtr->staticSpace[0] = 0;
1805 }
1806
1807 /*
1808 *----------------------------------------------------------------------
1809 *
1810 * Tcl_DStringResult --
1811 *
1812 * This procedure moves the value of a dynamic string into an
1813 * interpreter as its result. The string itself is reinitialized
1814 * to an empty string.
1815 *
1816 * Results:
1817 * None.
1818 *
1819 * Side effects:
1820 * The string is "moved" to interp's result, and any existing
1821 * result for interp is freed up. DsPtr is reinitialized to
1822 * an empty string.
1823 *
1824 *----------------------------------------------------------------------
1825 */
1826
1827 void
Tcl_DStringResult(interp,dsPtr)1828 Tcl_DStringResult(interp, dsPtr)
1829 Tcl_Interp *interp; /* Interpreter whose result is to be
1830 * reset. */
1831 Tcl_DString *dsPtr; /* Dynamic string that is to become
1832 * the result of interp. */
1833 {
1834 Tcl_ResetResult(interp);
1835 if (dsPtr->string != dsPtr->staticSpace) {
1836 interp->result = dsPtr->string;
1837 interp->freeProc = TCL_DYNAMIC;
1838 } else if (dsPtr->length < TCL_RESULT_SIZE) {
1839 interp->result = ((Interp *) interp)->resultSpace;
1840 strcpy(interp->result, dsPtr->string);
1841 } else {
1842 Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE);
1843 }
1844 dsPtr->string = dsPtr->staticSpace;
1845 dsPtr->length = 0;
1846 dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
1847 dsPtr->staticSpace[0] = 0;
1848 }
1849
1850 /*
1851 *----------------------------------------------------------------------
1852 *
1853 * Tcl_DStringGetResult --
1854 *
1855 * This procedure moves the result of an interpreter into a
1856 * dynamic string.
1857 *
1858 * Results:
1859 * None.
1860 *
1861 * Side effects:
1862 * The interpreter's result is cleared, and the previous contents
1863 * of dsPtr are freed.
1864 *
1865 *----------------------------------------------------------------------
1866 */
1867
1868 void
Tcl_DStringGetResult(interp,dsPtr)1869 Tcl_DStringGetResult(interp, dsPtr)
1870 Tcl_Interp *interp; /* Interpreter whose result is to be
1871 * reset. */
1872 Tcl_DString *dsPtr; /* Dynamic string that is to become
1873 * the result of interp. */
1874 {
1875 Interp *iPtr = (Interp *) interp;
1876 if (dsPtr->string != dsPtr->staticSpace) {
1877 ckfree(dsPtr->string);
1878 }
1879 dsPtr->length = strlen(iPtr->result);
1880 if (iPtr->freeProc != NULL) {
1881 if ((iPtr->freeProc == TCL_DYNAMIC)
1882 || (iPtr->freeProc == (Tcl_FreeProc *) free)) {
1883 dsPtr->string = iPtr->result;
1884 dsPtr->spaceAvl = dsPtr->length+1;
1885 } else {
1886 dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length+1));
1887 strcpy(dsPtr->string, iPtr->result);
1888 (*iPtr->freeProc)(iPtr->result);
1889 }
1890 dsPtr->spaceAvl = dsPtr->length+1;
1891 iPtr->freeProc = NULL;
1892 } else {
1893 if (dsPtr->length < TCL_DSTRING_STATIC_SIZE) {
1894 dsPtr->string = dsPtr->staticSpace;
1895 dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
1896 } else {
1897 dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length + 1));
1898 dsPtr->spaceAvl = dsPtr->length + 1;
1899 }
1900 strcpy(dsPtr->string, iPtr->result);
1901 }
1902 iPtr->result = iPtr->resultSpace;
1903 iPtr->resultSpace[0] = 0;
1904 }
1905
1906 /*
1907 *----------------------------------------------------------------------
1908 *
1909 * Tcl_DStringStartSublist --
1910 *
1911 * This procedure adds the necessary information to a dynamic
1912 * string (e.g. " {" to start a sublist. Future element
1913 * appends will be in the sublist rather than the main list.
1914 *
1915 * Results:
1916 * None.
1917 *
1918 * Side effects:
1919 * Characters get added to the dynamic string.
1920 *
1921 *----------------------------------------------------------------------
1922 */
1923
1924 void
Tcl_DStringStartSublist(dsPtr)1925 Tcl_DStringStartSublist(dsPtr)
1926 Tcl_DString *dsPtr; /* Dynamic string. */
1927 {
1928 if (TclNeedSpace(dsPtr->string, dsPtr->string + dsPtr->length)) {
1929 Tcl_DStringAppend(dsPtr, " {", -1);
1930 } else {
1931 Tcl_DStringAppend(dsPtr, "{", -1);
1932 }
1933 }
1934
1935 /*
1936 *----------------------------------------------------------------------
1937 *
1938 * Tcl_DStringEndSublist --
1939 *
1940 * This procedure adds the necessary characters to a dynamic
1941 * string to end a sublist (e.g. "}"). Future element appends
1942 * will be in the enclosing (sub)list rather than the current
1943 * sublist.
1944 *
1945 * Results:
1946 * None.
1947 *
1948 * Side effects:
1949 * None.
1950 *
1951 *----------------------------------------------------------------------
1952 */
1953
1954 void
Tcl_DStringEndSublist(dsPtr)1955 Tcl_DStringEndSublist(dsPtr)
1956 Tcl_DString *dsPtr; /* Dynamic string. */
1957 {
1958 Tcl_DStringAppend(dsPtr, "}", -1);
1959 }
1960
1961 /*
1962 *----------------------------------------------------------------------
1963 *
1964 * Tcl_PrintDouble --
1965 *
1966 * Given a floating-point value, this procedure converts it to
1967 * an ASCII string using.
1968 *
1969 * Results:
1970 * The ASCII equivalent of "value" is written at "dst". It is
1971 * written using the current precision, and it is guaranteed to
1972 * contain a decimal point or exponent, so that it looks like
1973 * a floating-point value and not an integer.
1974 *
1975 * Side effects:
1976 * None.
1977 *
1978 *----------------------------------------------------------------------
1979 */
1980
1981 void
Tcl_PrintDouble(interp,value,dst)1982 Tcl_PrintDouble(interp, value, dst)
1983 Tcl_Interp *interp; /* Interpreter whose tcl_precision
1984 * variable controls printing. */
1985 double value; /* Value to print as string. */
1986 char *dst; /* Where to store converted value;
1987 * must have at least TCL_DOUBLE_SPACE
1988 * characters. */
1989 {
1990 register char *p;
1991 sprintf(dst, ((Interp *) interp)->pdFormat, value);
1992
1993 /*
1994 * If the ASCII result looks like an integer, add ".0" so that it
1995 * doesn't look like an integer anymore. This prevents floating-point
1996 * values from being converted to integers unintentionally.
1997 */
1998
1999 for (p = dst; *p != 0; p++) {
2000 if ((*p == '.') || (isalpha(UCHAR(*p)))) {
2001 return;
2002 }
2003 }
2004 p[0] = '.';
2005 p[1] = '0';
2006 p[2] = 0;
2007 }
2008
2009 /*
2010 *----------------------------------------------------------------------
2011 *
2012 * TclPrecTraceProc --
2013 *
2014 * This procedure is invoked whenever the variable "tcl_precision"
2015 * is written.
2016 *
2017 * Results:
2018 * Returns NULL if all went well, or an error message if the
2019 * new value for the variable doesn't make sense.
2020 *
2021 * Side effects:
2022 * If the new value doesn't make sense then this procedure
2023 * undoes the effect of the variable modification. Otherwise
2024 * it modifies the format string that's used by Tcl_PrintDouble.
2025 *
2026 *----------------------------------------------------------------------
2027 */
2028
2029 /* ARGSUSED */
2030 char *
TclPrecTraceProc(clientData,interp,name1,name2,flags)2031 TclPrecTraceProc(clientData, interp, name1, name2, flags)
2032 ClientData clientData; /* Not used. */
2033 Tcl_Interp *interp; /* Interpreter containing variable. */
2034 char *name1; /* Name of variable. */
2035 char *name2; /* Second part of variable name. */
2036 int flags; /* Information about what happened. */
2037 {
2038 register Interp *iPtr = (Interp *) interp;
2039 char *value, *end;
2040 int prec;
2041
2042 /*
2043 * If the variable is unset, then recreate the trace and restore
2044 * the default value of the format string.
2045 */
2046
2047 if (flags & TCL_TRACE_UNSETS) {
2048 if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) {
2049 Tcl_TraceVar2(interp, name1, name2,
2050 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
2051 TclPrecTraceProc, clientData);
2052 }
2053 strcpy(iPtr->pdFormat, DEFAULT_PD_FORMAT);
2054 iPtr->pdPrec = DEFAULT_PD_PREC;
2055 return (char *) NULL;
2056 }
2057
2058 value = Tcl_GetVar2(interp, name1, name2, flags & TCL_GLOBAL_ONLY);
2059 if (value == NULL) {
2060 value = "";
2061 }
2062 prec = strtoul(value, &end, 10);
2063 if ((prec <= 0) || (prec > TCL_MAX_PREC) || (prec > 100) ||
2064 (end == value) || (*end != 0)) {
2065 char oldValue[10];
2066
2067 sprintf(oldValue, "%d", iPtr->pdPrec);
2068 Tcl_SetVar2(interp, name1, name2, oldValue, flags & TCL_GLOBAL_ONLY);
2069 return "improper value for precision";
2070 }
2071 sprintf(iPtr->pdFormat, "%%.%dg", prec);
2072 iPtr->pdPrec = prec;
2073 return (char *) NULL;
2074 }
2075
2076 /*
2077 *----------------------------------------------------------------------
2078 *
2079 * TclNeedSpace --
2080 *
2081 * This procedure checks to see whether it is appropriate to
2082 * add a space before appending a new list element to an
2083 * existing string.
2084 *
2085 * Results:
2086 * The return value is 1 if a space is appropriate, 0 otherwise.
2087 *
2088 * Side effects:
2089 * None.
2090 *
2091 *----------------------------------------------------------------------
2092 */
2093
2094 int
TclNeedSpace(start,end)2095 TclNeedSpace(start, end)
2096 char *start; /* First character in string. */
2097 char *end; /* End of string (place where space will
2098 * be added, if appropriate). */
2099 {
2100 /*
2101 * A space is needed unless either
2102 * (a) we're at the start of the string, or
2103 * (b) the trailing characters of the string consist of one or more
2104 * open curly braces preceded by a space or extending back to
2105 * the beginning of the string.
2106 * (c) the trailing characters of the string consist of a space
2107 * preceded by a character other than backslash.
2108 */
2109
2110 if (end == start) {
2111 return 0;
2112 }
2113 end--;
2114 if (*end != '{') {
2115 if (isspace(UCHAR(*end)) && ((end == start) || (end[-1] != '\\'))) {
2116 return 0;
2117 }
2118 return 1;
2119 }
2120 do {
2121 if (end == start) {
2122 return 0;
2123 }
2124 end--;
2125 } while (*end == '{');
2126 if (isspace(UCHAR(*end))) {
2127 return 0;
2128 }
2129 return 1;
2130 }
2131