1 |
/* $Header$ */ |
2 |
/* |
3 |
* tclUtil.c -- |
4 |
* |
5 |
* This file contains utility procedures that are used by many Tcl |
6 |
* commands. |
7 |
* |
8 |
* Copyright (c) 1987-1993 The Regents of the University of California. |
9 |
* Copyright (c) 1994-1998 Sun Microsystems, Inc. |
10 |
* |
11 |
* See the file "license.terms" for information on usage and redistribution |
12 |
* of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
13 |
* |
14 |
* RCS: @(#) $Id: tclutil.c,v 1.1.1.1 2001/06/13 04:47:21 dtashley Exp $ |
15 |
*/ |
16 |
|
17 |
#include "tclInt.h" |
18 |
#include "tclPort.h" |
19 |
|
20 |
/* |
21 |
* The following variable holds the full path name of the binary |
22 |
* from which this application was executed, or NULL if it isn't |
23 |
* know. The value of the variable is set by the procedure |
24 |
* Tcl_FindExecutable. The storage space is dynamically allocated. |
25 |
*/ |
26 |
|
27 |
char *tclExecutableName = NULL; |
28 |
char *tclNativeExecutableName = NULL; |
29 |
|
30 |
/* |
31 |
* The following values are used in the flags returned by Tcl_ScanElement |
32 |
* and used by Tcl_ConvertElement. The value TCL_DONT_USE_BRACES is also |
33 |
* defined in tcl.h; make sure its value doesn't overlap with any of the |
34 |
* values below. |
35 |
* |
36 |
* TCL_DONT_USE_BRACES - 1 means the string mustn't be enclosed in |
37 |
* braces (e.g. it contains unmatched braces, |
38 |
* or ends in a backslash character, or user |
39 |
* just doesn't want braces); handle all |
40 |
* special characters by adding backslashes. |
41 |
* USE_BRACES - 1 means the string contains a special |
42 |
* character that can be handled simply by |
43 |
* enclosing the entire argument in braces. |
44 |
* BRACES_UNMATCHED - 1 means that braces aren't properly matched |
45 |
* in the argument. |
46 |
*/ |
47 |
|
48 |
#define USE_BRACES 2 |
49 |
#define BRACES_UNMATCHED 4 |
50 |
|
51 |
/* |
52 |
* The following values determine the precision used when converting |
53 |
* floating-point values to strings. This information is linked to all |
54 |
* of the tcl_precision variables in all interpreters via the procedure |
55 |
* TclPrecTraceProc. |
56 |
*/ |
57 |
|
58 |
static char precisionString[10] = "12"; |
59 |
/* The string value of all the tcl_precision |
60 |
* variables. */ |
61 |
static char precisionFormat[10] = "%.12g"; |
62 |
/* The format string actually used in calls |
63 |
* to sprintf. */ |
64 |
TCL_DECLARE_MUTEX(precisionMutex) |
65 |
|
66 |
|
67 |
/* |
68 |
*---------------------------------------------------------------------- |
69 |
* |
70 |
* TclFindElement -- |
71 |
* |
72 |
* Given a pointer into a Tcl list, locate the first (or next) |
73 |
* element in the list. |
74 |
* |
75 |
* Results: |
76 |
* The return value is normally TCL_OK, which means that the |
77 |
* element was successfully located. If TCL_ERROR is returned |
78 |
* it means that list didn't have proper list structure; |
79 |
* the interp's result contains a more detailed error message. |
80 |
* |
81 |
* If TCL_OK is returned, then *elementPtr will be set to point to the |
82 |
* first element of list, and *nextPtr will be set to point to the |
83 |
* character just after any white space following the last character |
84 |
* that's part of the element. If this is the last argument in the |
85 |
* list, then *nextPtr will point just after the last character in the |
86 |
* list (i.e., at the character at list+listLength). If sizePtr is |
87 |
* non-NULL, *sizePtr is filled in with the number of characters in the |
88 |
* element. If the element is in braces, then *elementPtr will point |
89 |
* to the character after the opening brace and *sizePtr will not |
90 |
* include either of the braces. If there isn't an element in the list, |
91 |
* *sizePtr will be zero, and both *elementPtr and *termPtr will point |
92 |
* just after the last character in the list. Note: this procedure does |
93 |
* NOT collapse backslash sequences. |
94 |
* |
95 |
* Side effects: |
96 |
* None. |
97 |
* |
98 |
*---------------------------------------------------------------------- |
99 |
*/ |
100 |
|
101 |
int |
102 |
TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr, |
103 |
bracePtr) |
104 |
Tcl_Interp *interp; /* Interpreter to use for error reporting. |
105 |
* If NULL, then no error message is left |
106 |
* after errors. */ |
107 |
CONST char *list; /* Points to the first byte of a string |
108 |
* containing a Tcl list with zero or more |
109 |
* elements (possibly in braces). */ |
110 |
int listLength; /* Number of bytes in the list's string. */ |
111 |
CONST char **elementPtr; /* Where to put address of first significant |
112 |
* character in first element of list. */ |
113 |
CONST char **nextPtr; /* Fill in with location of character just |
114 |
* after all white space following end of |
115 |
* argument (next arg or end of list). */ |
116 |
int *sizePtr; /* If non-zero, fill in with size of |
117 |
* element. */ |
118 |
int *bracePtr; /* If non-zero, fill in with non-zero/zero |
119 |
* to indicate that arg was/wasn't |
120 |
* in braces. */ |
121 |
{ |
122 |
CONST char *p = list; |
123 |
CONST char *elemStart; /* Points to first byte of first element. */ |
124 |
CONST char *limit; /* Points just after list's last byte. */ |
125 |
int openBraces = 0; /* Brace nesting level during parse. */ |
126 |
int inQuotes = 0; |
127 |
int size = 0; /* lint. */ |
128 |
int numChars; |
129 |
CONST char *p2; |
130 |
|
131 |
/* |
132 |
* Skim off leading white space and check for an opening brace or |
133 |
* quote. We treat embedded NULLs in the list as bytes belonging to |
134 |
* a list element. |
135 |
*/ |
136 |
|
137 |
limit = (list + listLength); |
138 |
while ((p < limit) && (isspace(UCHAR(*p)))) { /* INTL: ISO space. */ |
139 |
p++; |
140 |
} |
141 |
if (p == limit) { /* no element found */ |
142 |
elemStart = limit; |
143 |
goto done; |
144 |
} |
145 |
|
146 |
if (*p == '{') { |
147 |
openBraces = 1; |
148 |
p++; |
149 |
} else if (*p == '"') { |
150 |
inQuotes = 1; |
151 |
p++; |
152 |
} |
153 |
elemStart = p; |
154 |
if (bracePtr != 0) { |
155 |
*bracePtr = openBraces; |
156 |
} |
157 |
|
158 |
/* |
159 |
* Find element's end (a space, close brace, or the end of the string). |
160 |
*/ |
161 |
|
162 |
while (p < limit) { |
163 |
switch (*p) { |
164 |
|
165 |
/* |
166 |
* Open brace: don't treat specially unless the element is in |
167 |
* braces. In this case, keep a nesting count. |
168 |
*/ |
169 |
|
170 |
case '{': |
171 |
if (openBraces != 0) { |
172 |
openBraces++; |
173 |
} |
174 |
break; |
175 |
|
176 |
/* |
177 |
* Close brace: if element is in braces, keep nesting count and |
178 |
* quit when the last close brace is seen. |
179 |
*/ |
180 |
|
181 |
case '}': |
182 |
if (openBraces > 1) { |
183 |
openBraces--; |
184 |
} else if (openBraces == 1) { |
185 |
size = (p - elemStart); |
186 |
p++; |
187 |
if ((p >= limit) |
188 |
|| isspace(UCHAR(*p))) { /* INTL: ISO space. */ |
189 |
goto done; |
190 |
} |
191 |
|
192 |
/* |
193 |
* Garbage after the closing brace; return an error. |
194 |
*/ |
195 |
|
196 |
if (interp != NULL) { |
197 |
char buf[100]; |
198 |
|
199 |
p2 = p; |
200 |
while ((p2 < limit) |
201 |
&& (!isspace(UCHAR(*p2))) /* INTL: ISO space. */ |
202 |
&& (p2 < p+20)) { |
203 |
p2++; |
204 |
} |
205 |
sprintf(buf, |
206 |
"list element in braces followed by \"%.*s\" instead of space", |
207 |
(int) (p2-p), p); |
208 |
Tcl_SetResult(interp, buf, TCL_VOLATILE); |
209 |
} |
210 |
return TCL_ERROR; |
211 |
} |
212 |
break; |
213 |
|
214 |
/* |
215 |
* Backslash: skip over everything up to the end of the |
216 |
* backslash sequence. |
217 |
*/ |
218 |
|
219 |
case '\\': { |
220 |
Tcl_UtfBackslash(p, &numChars, NULL); |
221 |
p += (numChars - 1); |
222 |
break; |
223 |
} |
224 |
|
225 |
/* |
226 |
* Space: ignore if element is in braces or quotes; otherwise |
227 |
* terminate element. |
228 |
*/ |
229 |
|
230 |
case ' ': |
231 |
case '\f': |
232 |
case '\n': |
233 |
case '\r': |
234 |
case '\t': |
235 |
case '\v': |
236 |
if ((openBraces == 0) && !inQuotes) { |
237 |
size = (p - elemStart); |
238 |
goto done; |
239 |
} |
240 |
break; |
241 |
|
242 |
/* |
243 |
* Double-quote: if element is in quotes then terminate it. |
244 |
*/ |
245 |
|
246 |
case '"': |
247 |
if (inQuotes) { |
248 |
size = (p - elemStart); |
249 |
p++; |
250 |
if ((p >= limit) |
251 |
|| isspace(UCHAR(*p))) { /* INTL: ISO space */ |
252 |
goto done; |
253 |
} |
254 |
|
255 |
/* |
256 |
* Garbage after the closing quote; return an error. |
257 |
*/ |
258 |
|
259 |
if (interp != NULL) { |
260 |
char buf[100]; |
261 |
|
262 |
p2 = p; |
263 |
while ((p2 < limit) |
264 |
&& (!isspace(UCHAR(*p2))) /* INTL: ISO space */ |
265 |
&& (p2 < p+20)) { |
266 |
p2++; |
267 |
} |
268 |
sprintf(buf, |
269 |
"list element in quotes followed by \"%.*s\" %s", |
270 |
(int) (p2-p), p, "instead of space"); |
271 |
Tcl_SetResult(interp, buf, TCL_VOLATILE); |
272 |
} |
273 |
return TCL_ERROR; |
274 |
} |
275 |
break; |
276 |
} |
277 |
p++; |
278 |
} |
279 |
|
280 |
|
281 |
/* |
282 |
* End of list: terminate element. |
283 |
*/ |
284 |
|
285 |
if (p == limit) { |
286 |
if (openBraces != 0) { |
287 |
if (interp != NULL) { |
288 |
Tcl_SetResult(interp, "unmatched open brace in list", |
289 |
TCL_STATIC); |
290 |
} |
291 |
return TCL_ERROR; |
292 |
} else if (inQuotes) { |
293 |
if (interp != NULL) { |
294 |
Tcl_SetResult(interp, "unmatched open quote in list", |
295 |
TCL_STATIC); |
296 |
} |
297 |
return TCL_ERROR; |
298 |
} |
299 |
size = (p - elemStart); |
300 |
} |
301 |
|
302 |
done: |
303 |
while ((p < limit) && (isspace(UCHAR(*p)))) { /* INTL: ISO space. */ |
304 |
p++; |
305 |
} |
306 |
*elementPtr = elemStart; |
307 |
*nextPtr = p; |
308 |
if (sizePtr != 0) { |
309 |
*sizePtr = size; |
310 |
} |
311 |
return TCL_OK; |
312 |
} |
313 |
|
314 |
/* |
315 |
*---------------------------------------------------------------------- |
316 |
* |
317 |
* TclCopyAndCollapse -- |
318 |
* |
319 |
* Copy a string and eliminate any backslashes that aren't in braces. |
320 |
* |
321 |
* Results: |
322 |
* There is no return value. Count characters get copied from src to |
323 |
* dst. Along the way, if backslash sequences are found outside braces, |
324 |
* the backslashes are eliminated in the copy. After scanning count |
325 |
* chars from source, a null character is placed at the end of dst. |
326 |
* Returns the number of characters that got copied. |
327 |
* |
328 |
* Side effects: |
329 |
* None. |
330 |
* |
331 |
*---------------------------------------------------------------------- |
332 |
*/ |
333 |
|
334 |
int |
335 |
TclCopyAndCollapse(count, src, dst) |
336 |
int count; /* Number of characters to copy from src. */ |
337 |
CONST char *src; /* Copy from here... */ |
338 |
char *dst; /* ... to here. */ |
339 |
{ |
340 |
register char c; |
341 |
int numRead; |
342 |
int newCount = 0; |
343 |
int backslashCount; |
344 |
|
345 |
for (c = *src; count > 0; src++, c = *src, count--) { |
346 |
if (c == '\\') { |
347 |
backslashCount = Tcl_UtfBackslash(src, &numRead, dst); |
348 |
dst += backslashCount; |
349 |
newCount += backslashCount; |
350 |
src += numRead-1; |
351 |
count -= numRead-1; |
352 |
} else { |
353 |
*dst = c; |
354 |
dst++; |
355 |
newCount++; |
356 |
} |
357 |
} |
358 |
*dst = 0; |
359 |
return newCount; |
360 |
} |
361 |
|
362 |
/* |
363 |
*---------------------------------------------------------------------- |
364 |
* |
365 |
* Tcl_SplitList -- |
366 |
* |
367 |
* Splits a list up into its constituent fields. |
368 |
* |
369 |
* Results |
370 |
* The return value is normally TCL_OK, which means that |
371 |
* the list was successfully split up. If TCL_ERROR is |
372 |
* returned, it means that "list" didn't have proper list |
373 |
* structure; the interp's result will contain a more detailed |
374 |
* error message. |
375 |
* |
376 |
* *argvPtr will be filled in with the address of an array |
377 |
* whose elements point to the elements of list, in order. |
378 |
* *argcPtr will get filled in with the number of valid elements |
379 |
* in the array. A single block of memory is dynamically allocated |
380 |
* to hold both the argv array and a copy of the list (with |
381 |
* backslashes and braces removed in the standard way). |
382 |
* The caller must eventually free this memory by calling free() |
383 |
* on *argvPtr. Note: *argvPtr and *argcPtr are only modified |
384 |
* if the procedure returns normally. |
385 |
* |
386 |
* Side effects: |
387 |
* Memory is allocated. |
388 |
* |
389 |
*---------------------------------------------------------------------- |
390 |
*/ |
391 |
|
392 |
int |
393 |
Tcl_SplitList(interp, list, argcPtr, argvPtr) |
394 |
Tcl_Interp *interp; /* Interpreter to use for error reporting. |
395 |
* If NULL, no error message is left. */ |
396 |
CONST char *list; /* Pointer to string with list structure. */ |
397 |
int *argcPtr; /* Pointer to location to fill in with |
398 |
* the number of elements in the list. */ |
399 |
char ***argvPtr; /* Pointer to place to store pointer to |
400 |
* array of pointers to list elements. */ |
401 |
{ |
402 |
char **argv; |
403 |
CONST char *l; |
404 |
char *p; |
405 |
int length, size, i, result, elSize, brace; |
406 |
CONST char *element; |
407 |
|
408 |
/* |
409 |
* Figure out how much space to allocate. There must be enough |
410 |
* space for both the array of pointers and also for a copy of |
411 |
* the list. To estimate the number of pointers needed, count |
412 |
* the number of space characters in the list. |
413 |
*/ |
414 |
|
415 |
for (size = 1, l = list; *l != 0; l++) { |
416 |
if (isspace(UCHAR(*l))) { /* INTL: ISO space. */ |
417 |
size++; |
418 |
} |
419 |
} |
420 |
size++; /* Leave space for final NULL pointer. */ |
421 |
argv = (char **) ckalloc((unsigned) |
422 |
((size * sizeof(char *)) + (l - list) + 1)); |
423 |
length = strlen(list); |
424 |
for (i = 0, p = ((char *) argv) + size*sizeof(char *); |
425 |
*list != 0; i++) { |
426 |
CONST char *prevList = list; |
427 |
|
428 |
result = TclFindElement(interp, list, length, &element, |
429 |
&list, &elSize, &brace); |
430 |
length -= (list - prevList); |
431 |
if (result != TCL_OK) { |
432 |
ckfree((char *) argv); |
433 |
return result; |
434 |
} |
435 |
if (*element == 0) { |
436 |
break; |
437 |
} |
438 |
if (i >= size) { |
439 |
ckfree((char *) argv); |
440 |
if (interp != NULL) { |
441 |
Tcl_SetResult(interp, "internal error in Tcl_SplitList", |
442 |
TCL_STATIC); |
443 |
} |
444 |
return TCL_ERROR; |
445 |
} |
446 |
argv[i] = p; |
447 |
if (brace) { |
448 |
memcpy((VOID *) p, (VOID *) element, (size_t) elSize); |
449 |
p += elSize; |
450 |
*p = 0; |
451 |
p++; |
452 |
} else { |
453 |
TclCopyAndCollapse(elSize, element, p); |
454 |
p += elSize+1; |
455 |
} |
456 |
} |
457 |
|
458 |
argv[i] = NULL; |
459 |
*argvPtr = argv; |
460 |
*argcPtr = i; |
461 |
return TCL_OK; |
462 |
} |
463 |
|
464 |
/* |
465 |
*---------------------------------------------------------------------- |
466 |
* |
467 |
* Tcl_ScanElement -- |
468 |
* |
469 |
* This procedure is a companion procedure to Tcl_ConvertElement. |
470 |
* It scans a string to see what needs to be done to it (e.g. add |
471 |
* backslashes or enclosing braces) to make the string into a |
472 |
* valid Tcl list element. |
473 |
* |
474 |
* Results: |
475 |
* The return value is an overestimate of the number of characters |
476 |
* that will be needed by Tcl_ConvertElement to produce a valid |
477 |
* list element from string. The word at *flagPtr is filled in |
478 |
* with a value needed by Tcl_ConvertElement when doing the actual |
479 |
* conversion. |
480 |
* |
481 |
* Side effects: |
482 |
* None. |
483 |
* |
484 |
*---------------------------------------------------------------------- |
485 |
*/ |
486 |
|
487 |
int |
488 |
Tcl_ScanElement(string, flagPtr) |
489 |
register CONST char *string; /* String to convert to list element. */ |
490 |
register int *flagPtr; /* Where to store information to guide |
491 |
* Tcl_ConvertCountedElement. */ |
492 |
{ |
493 |
return Tcl_ScanCountedElement(string, -1, flagPtr); |
494 |
} |
495 |
|
496 |
/* |
497 |
*---------------------------------------------------------------------- |
498 |
* |
499 |
* Tcl_ScanCountedElement -- |
500 |
* |
501 |
* This procedure is a companion procedure to |
502 |
* Tcl_ConvertCountedElement. It scans a string to see what |
503 |
* needs to be done to it (e.g. add backslashes or enclosing |
504 |
* braces) to make the string into a valid Tcl list element. |
505 |
* If length is -1, then the string is scanned up to the first |
506 |
* null byte. |
507 |
* |
508 |
* Results: |
509 |
* The return value is an overestimate of the number of characters |
510 |
* that will be needed by Tcl_ConvertCountedElement to produce a |
511 |
* valid list element from string. The word at *flagPtr is |
512 |
* filled in with a value needed by Tcl_ConvertCountedElement |
513 |
* when doing the actual conversion. |
514 |
* |
515 |
* Side effects: |
516 |
* None. |
517 |
* |
518 |
*---------------------------------------------------------------------- |
519 |
*/ |
520 |
|
521 |
int |
522 |
Tcl_ScanCountedElement(string, length, flagPtr) |
523 |
CONST char *string; /* String to convert to Tcl list element. */ |
524 |
int length; /* Number of bytes in string, or -1. */ |
525 |
int *flagPtr; /* Where to store information to guide |
526 |
* Tcl_ConvertElement. */ |
527 |
{ |
528 |
int flags, nestingLevel; |
529 |
register CONST char *p, *lastChar; |
530 |
|
531 |
/* |
532 |
* This procedure and Tcl_ConvertElement together do two things: |
533 |
* |
534 |
* 1. They produce a proper list, one that will yield back the |
535 |
* argument strings when evaluated or when disassembled with |
536 |
* Tcl_SplitList. This is the most important thing. |
537 |
* |
538 |
* 2. They try to produce legible output, which means minimizing the |
539 |
* use of backslashes (using braces instead). However, there are |
540 |
* some situations where backslashes must be used (e.g. an element |
541 |
* like "{abc": the leading brace will have to be backslashed. |
542 |
* For each element, one of three things must be done: |
543 |
* |
544 |
* (a) Use the element as-is (it doesn't contain any special |
545 |
* characters). This is the most desirable option. |
546 |
* |
547 |
* (b) Enclose the element in braces, but leave the contents alone. |
548 |
* This happens if the element contains embedded space, or if it |
549 |
* contains characters with special interpretation ($, [, ;, or \), |
550 |
* or if it starts with a brace or double-quote, or if there are |
551 |
* no characters in the element. |
552 |
* |
553 |
* (c) Don't enclose the element in braces, but add backslashes to |
554 |
* prevent special interpretation of special characters. This is a |
555 |
* last resort used when the argument would normally fall under case |
556 |
* (b) but contains unmatched braces. It also occurs if the last |
557 |
* character of the argument is a backslash or if the element contains |
558 |
* a backslash followed by newline. |
559 |
* |
560 |
* The procedure figures out how many bytes will be needed to store |
561 |
* the result (actually, it overestimates). It also collects information |
562 |
* about the element in the form of a flags word. |
563 |
* |
564 |
* Note: list elements produced by this procedure and |
565 |
* Tcl_ConvertCountedElement must have the property that they can be |
566 |
* enclosing in curly braces to make sub-lists. This means, for |
567 |
* example, that we must not leave unmatched curly braces in the |
568 |
* resulting list element. This property is necessary in order for |
569 |
* procedures like Tcl_DStringStartSublist to work. |
570 |
*/ |
571 |
|
572 |
nestingLevel = 0; |
573 |
flags = 0; |
574 |
if (string == NULL) { |
575 |
string = ""; |
576 |
} |
577 |
if (length == -1) { |
578 |
length = strlen(string); |
579 |
} |
580 |
lastChar = string + length; |
581 |
p = string; |
582 |
if ((p == lastChar) || (*p == '{') || (*p == '"')) { |
583 |
flags |= USE_BRACES; |
584 |
} |
585 |
for ( ; p < lastChar; p++) { |
586 |
switch (*p) { |
587 |
case '{': |
588 |
nestingLevel++; |
589 |
break; |
590 |
case '}': |
591 |
nestingLevel--; |
592 |
if (nestingLevel < 0) { |
593 |
flags |= TCL_DONT_USE_BRACES|BRACES_UNMATCHED; |
594 |
} |
595 |
break; |
596 |
case '[': |
597 |
case '$': |
598 |
case ';': |
599 |
case ' ': |
600 |
case '\f': |
601 |
case '\n': |
602 |
case '\r': |
603 |
case '\t': |
604 |
case '\v': |
605 |
flags |= USE_BRACES; |
606 |
break; |
607 |
case '\\': |
608 |
if ((p+1 == lastChar) || (p[1] == '\n')) { |
609 |
flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED; |
610 |
} else { |
611 |
int size; |
612 |
|
613 |
Tcl_UtfBackslash(p, &size, NULL); |
614 |
p += size-1; |
615 |
flags |= USE_BRACES; |
616 |
} |
617 |
break; |
618 |
} |
619 |
} |
620 |
if (nestingLevel != 0) { |
621 |
flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED; |
622 |
} |
623 |
*flagPtr = flags; |
624 |
|
625 |
/* |
626 |
* Allow enough space to backslash every character plus leave |
627 |
* two spaces for braces. |
628 |
*/ |
629 |
|
630 |
return 2*(p-string) + 2; |
631 |
} |
632 |
|
633 |
/* |
634 |
*---------------------------------------------------------------------- |
635 |
* |
636 |
* Tcl_ConvertElement -- |
637 |
* |
638 |
* This is a companion procedure to Tcl_ScanElement. Given |
639 |
* the information produced by Tcl_ScanElement, this procedure |
640 |
* converts a string to a list element equal to that string. |
641 |
* |
642 |
* Results: |
643 |
* Information is copied to *dst in the form of a list element |
644 |
* identical to src (i.e. if Tcl_SplitList is applied to dst it |
645 |
* will produce a string identical to src). The return value is |
646 |
* a count of the number of characters copied (not including the |
647 |
* terminating NULL character). |
648 |
* |
649 |
* Side effects: |
650 |
* None. |
651 |
* |
652 |
*---------------------------------------------------------------------- |
653 |
*/ |
654 |
|
655 |
int |
656 |
Tcl_ConvertElement(src, dst, flags) |
657 |
register CONST char *src; /* Source information for list element. */ |
658 |
register char *dst; /* Place to put list-ified element. */ |
659 |
register int flags; /* Flags produced by Tcl_ScanElement. */ |
660 |
{ |
661 |
return Tcl_ConvertCountedElement(src, -1, dst, flags); |
662 |
} |
663 |
|
664 |
/* |
665 |
*---------------------------------------------------------------------- |
666 |
* |
667 |
* Tcl_ConvertCountedElement -- |
668 |
* |
669 |
* This is a companion procedure to Tcl_ScanCountedElement. Given |
670 |
* the information produced by Tcl_ScanCountedElement, this |
671 |
* procedure converts a string to a list element equal to that |
672 |
* string. |
673 |
* |
674 |
* Results: |
675 |
* Information is copied to *dst in the form of a list element |
676 |
* identical to src (i.e. if Tcl_SplitList is applied to dst it |
677 |
* will produce a string identical to src). The return value is |
678 |
* a count of the number of characters copied (not including the |
679 |
* terminating NULL character). |
680 |
* |
681 |
* Side effects: |
682 |
* None. |
683 |
* |
684 |
*---------------------------------------------------------------------- |
685 |
*/ |
686 |
|
687 |
int |
688 |
Tcl_ConvertCountedElement(src, length, dst, flags) |
689 |
register CONST char *src; /* Source information for list element. */ |
690 |
int length; /* Number of bytes in src, or -1. */ |
691 |
char *dst; /* Place to put list-ified element. */ |
692 |
int flags; /* Flags produced by Tcl_ScanElement. */ |
693 |
{ |
694 |
register char *p = dst; |
695 |
register CONST char *lastChar; |
696 |
|
697 |
/* |
698 |
* See the comment block at the beginning of the Tcl_ScanElement |
699 |
* code for details of how this works. |
700 |
*/ |
701 |
|
702 |
if (src && length == -1) { |
703 |
length = strlen(src); |
704 |
} |
705 |
if ((src == NULL) || (length == 0)) { |
706 |
p[0] = '{'; |
707 |
p[1] = '}'; |
708 |
p[2] = 0; |
709 |
return 2; |
710 |
} |
711 |
lastChar = src + length; |
712 |
if ((flags & USE_BRACES) && !(flags & TCL_DONT_USE_BRACES)) { |
713 |
*p = '{'; |
714 |
p++; |
715 |
for ( ; src != lastChar; src++, p++) { |
716 |
*p = *src; |
717 |
} |
718 |
*p = '}'; |
719 |
p++; |
720 |
} else { |
721 |
if (*src == '{') { |
722 |
/* |
723 |
* Can't have a leading brace unless the whole element is |
724 |
* enclosed in braces. Add a backslash before the brace. |
725 |
* Furthermore, this may destroy the balance between open |
726 |
* and close braces, so set BRACES_UNMATCHED. |
727 |
*/ |
728 |
|
729 |
p[0] = '\\'; |
730 |
p[1] = '{'; |
731 |
p += 2; |
732 |
src++; |
733 |
flags |= BRACES_UNMATCHED; |
734 |
} |
735 |
for (; src != lastChar; src++) { |
736 |
switch (*src) { |
737 |
case ']': |
738 |
case '[': |
739 |
case '$': |
740 |
case ';': |
741 |
case ' ': |
742 |
case '\\': |
743 |
case '"': |
744 |
*p = '\\'; |
745 |
p++; |
746 |
break; |
747 |
case '{': |
748 |
case '}': |
749 |
/* |
750 |
* It may not seem necessary to backslash braces, but |
751 |
* it is. The reason for this is that the resulting |
752 |
* list element may actually be an element of a sub-list |
753 |
* enclosed in braces (e.g. if Tcl_DStringStartSublist |
754 |
* has been invoked), so there may be a brace mismatch |
755 |
* if the braces aren't backslashed. |
756 |
*/ |
757 |
|
758 |
if (flags & BRACES_UNMATCHED) { |
759 |
*p = '\\'; |
760 |
p++; |
761 |
} |
762 |
break; |
763 |
case '\f': |
764 |
*p = '\\'; |
765 |
p++; |
766 |
*p = 'f'; |
767 |
p++; |
768 |
continue; |
769 |
case '\n': |
770 |
*p = '\\'; |
771 |
p++; |
772 |
*p = 'n'; |
773 |
p++; |
774 |
continue; |
775 |
case '\r': |
776 |
*p = '\\'; |
777 |
p++; |
778 |
*p = 'r'; |
779 |
p++; |
780 |
continue; |
781 |
case '\t': |
782 |
*p = '\\'; |
783 |
p++; |
784 |
*p = 't'; |
785 |
p++; |
786 |
continue; |
787 |
case '\v': |
788 |
*p = '\\'; |
789 |
p++; |
790 |
*p = 'v'; |
791 |
p++; |
792 |
continue; |
793 |
} |
794 |
*p = *src; |
795 |
p++; |
796 |
} |
797 |
} |
798 |
*p = '\0'; |
799 |
return p-dst; |
800 |
} |
801 |
|
802 |
/* |
803 |
*---------------------------------------------------------------------- |
804 |
* |
805 |
* Tcl_Merge -- |
806 |
* |
807 |
* Given a collection of strings, merge them together into a |
808 |
* single string that has proper Tcl list structured (i.e. |
809 |
* Tcl_SplitList may be used to retrieve strings equal to the |
810 |
* original elements, and Tcl_Eval will parse the string back |
811 |
* into its original elements). |
812 |
* |
813 |
* Results: |
814 |
* The return value is the address of a dynamically-allocated |
815 |
* string containing the merged list. |
816 |
* |
817 |
* Side effects: |
818 |
* None. |
819 |
* |
820 |
*---------------------------------------------------------------------- |
821 |
*/ |
822 |
|
823 |
char * |
824 |
Tcl_Merge(argc, argv) |
825 |
int argc; /* How many strings to merge. */ |
826 |
char **argv; /* Array of string values. */ |
827 |
{ |
828 |
# define LOCAL_SIZE 20 |
829 |
int localFlags[LOCAL_SIZE], *flagPtr; |
830 |
int numChars; |
831 |
char *result; |
832 |
char *dst; |
833 |
int i; |
834 |
|
835 |
/* |
836 |
* Pass 1: estimate space, gather flags. |
837 |
*/ |
838 |
|
839 |
if (argc <= LOCAL_SIZE) { |
840 |
flagPtr = localFlags; |
841 |
} else { |
842 |
flagPtr = (int *) ckalloc((unsigned) argc*sizeof(int)); |
843 |
} |
844 |
numChars = 1; |
845 |
for (i = 0; i < argc; i++) { |
846 |
numChars += Tcl_ScanElement(argv[i], &flagPtr[i]) + 1; |
847 |
} |
848 |
|
849 |
/* |
850 |
* Pass two: copy into the result area. |
851 |
*/ |
852 |
|
853 |
result = (char *) ckalloc((unsigned) numChars); |
854 |
dst = result; |
855 |
for (i = 0; i < argc; i++) { |
856 |
numChars = Tcl_ConvertElement(argv[i], dst, flagPtr[i]); |
857 |
dst += numChars; |
858 |
*dst = ' '; |
859 |
dst++; |
860 |
} |
861 |
if (dst == result) { |
862 |
*dst = 0; |
863 |
} else { |
864 |
dst[-1] = 0; |
865 |
} |
866 |
|
867 |
if (flagPtr != localFlags) { |
868 |
ckfree((char *) flagPtr); |
869 |
} |
870 |
return result; |
871 |
} |
872 |
|
873 |
/* |
874 |
*---------------------------------------------------------------------- |
875 |
* |
876 |
* Tcl_Backslash -- |
877 |
* |
878 |
* Figure out how to handle a backslash sequence. |
879 |
* |
880 |
* Results: |
881 |
* The return value is the character that should be substituted |
882 |
* in place of the backslash sequence that starts at src. If |
883 |
* readPtr isn't NULL then it is filled in with a count of the |
884 |
* number of characters in the backslash sequence. |
885 |
* |
886 |
* Side effects: |
887 |
* None. |
888 |
* |
889 |
*---------------------------------------------------------------------- |
890 |
*/ |
891 |
|
892 |
char |
893 |
Tcl_Backslash(src, readPtr) |
894 |
CONST char *src; /* Points to the backslash character of |
895 |
* a backslash sequence. */ |
896 |
int *readPtr; /* Fill in with number of characters read |
897 |
* from src, unless NULL. */ |
898 |
{ |
899 |
char buf[TCL_UTF_MAX]; |
900 |
Tcl_UniChar ch; |
901 |
|
902 |
Tcl_UtfBackslash(src, readPtr, buf); |
903 |
Tcl_UtfToUniChar(buf, &ch); |
904 |
return (char) ch; |
905 |
} |
906 |
|
907 |
/* |
908 |
*---------------------------------------------------------------------- |
909 |
* |
910 |
* Tcl_Concat -- |
911 |
* |
912 |
* Concatenate a set of strings into a single large string. |
913 |
* |
914 |
* Results: |
915 |
* The return value is dynamically-allocated string containing |
916 |
* a concatenation of all the strings in argv, with spaces between |
917 |
* the original argv elements. |
918 |
* |
919 |
* Side effects: |
920 |
* Memory is allocated for the result; the caller is responsible |
921 |
* for freeing the memory. |
922 |
* |
923 |
*---------------------------------------------------------------------- |
924 |
*/ |
925 |
|
926 |
char * |
927 |
Tcl_Concat(argc, argv) |
928 |
int argc; /* Number of strings to concatenate. */ |
929 |
char **argv; /* Array of strings to concatenate. */ |
930 |
{ |
931 |
int totalSize, i; |
932 |
char *p; |
933 |
char *result; |
934 |
|
935 |
for (totalSize = 1, i = 0; i < argc; i++) { |
936 |
totalSize += strlen(argv[i]) + 1; |
937 |
} |
938 |
result = (char *) ckalloc((unsigned) totalSize); |
939 |
if (argc == 0) { |
940 |
*result = '\0'; |
941 |
return result; |
942 |
} |
943 |
for (p = result, i = 0; i < argc; i++) { |
944 |
char *element; |
945 |
int length; |
946 |
|
947 |
/* |
948 |
* Clip white space off the front and back of the string |
949 |
* to generate a neater result, and ignore any empty |
950 |
* elements. |
951 |
*/ |
952 |
|
953 |
element = argv[i]; |
954 |
while (isspace(UCHAR(*element))) { /* INTL: ISO space. */ |
955 |
element++; |
956 |
} |
957 |
for (length = strlen(element); |
958 |
(length > 0) |
959 |
&& (isspace(UCHAR(element[length-1]))) /* INTL: ISO space. */ |
960 |
&& ((length < 2) || (element[length-2] != '\\')); |
961 |
length--) { |
962 |
/* Null loop body. */ |
963 |
} |
964 |
if (length == 0) { |
965 |
continue; |
966 |
} |
967 |
memcpy((VOID *) p, (VOID *) element, (size_t) length); |
968 |
p += length; |
969 |
*p = ' '; |
970 |
p++; |
971 |
} |
972 |
if (p != result) { |
973 |
p[-1] = 0; |
974 |
} else { |
975 |
*p = 0; |
976 |
} |
977 |
return result; |
978 |
} |
979 |
|
980 |
/* |
981 |
*---------------------------------------------------------------------- |
982 |
* |
983 |
* Tcl_ConcatObj -- |
984 |
* |
985 |
* Concatenate the strings from a set of objects into a single string |
986 |
* object with spaces between the original strings. |
987 |
* |
988 |
* Results: |
989 |
* The return value is a new string object containing a concatenation |
990 |
* of the strings in objv. Its ref count is zero. |
991 |
* |
992 |
* Side effects: |
993 |
* A new object is created. |
994 |
* |
995 |
*---------------------------------------------------------------------- |
996 |
*/ |
997 |
|
998 |
Tcl_Obj * |
999 |
Tcl_ConcatObj(objc, objv) |
1000 |
int objc; /* Number of objects to concatenate. */ |
1001 |
Tcl_Obj *CONST objv[]; /* Array of objects to concatenate. */ |
1002 |
{ |
1003 |
int allocSize, finalSize, length, elemLength, i; |
1004 |
char *p; |
1005 |
char *element; |
1006 |
char *concatStr; |
1007 |
Tcl_Obj *objPtr; |
1008 |
|
1009 |
/* |
1010 |
* Check first to see if all the items are of list type. If so, |
1011 |
* we will concat them together as lists, and return a list object. |
1012 |
* This is only valid when the lists have no current string |
1013 |
* representation, since we don't know what the original type was. |
1014 |
* An original string rep may have lost some whitespace info when |
1015 |
* converted which could be important. |
1016 |
*/ |
1017 |
for (i = 0; i < objc; i++) { |
1018 |
objPtr = objv[i]; |
1019 |
if ((objPtr->typePtr != &tclListType) || (objPtr->bytes != NULL)) { |
1020 |
break; |
1021 |
} |
1022 |
} |
1023 |
if (i == objc) { |
1024 |
Tcl_Obj **listv; |
1025 |
int listc; |
1026 |
|
1027 |
objPtr = Tcl_NewListObj(0, NULL); |
1028 |
for (i = 0; i < objc; i++) { |
1029 |
/* |
1030 |
* Tcl_ListObjAppendList could be used here, but this saves |
1031 |
* us a bit of type checking (since we've already done it) |
1032 |
* Use of INT_MAX tells us to always put the new stuff on |
1033 |
* the end. It will be set right in Tcl_ListObjReplace. |
1034 |
*/ |
1035 |
Tcl_ListObjGetElements(NULL, objv[i], &listc, &listv); |
1036 |
Tcl_ListObjReplace(NULL, objPtr, INT_MAX, 0, listc, listv); |
1037 |
} |
1038 |
return objPtr; |
1039 |
} |
1040 |
|
1041 |
allocSize = 0; |
1042 |
for (i = 0; i < objc; i++) { |
1043 |
objPtr = objv[i]; |
1044 |
element = Tcl_GetStringFromObj(objPtr, &length); |
1045 |
if ((element != NULL) && (length > 0)) { |
1046 |
allocSize += (length + 1); |
1047 |
} |
1048 |
} |
1049 |
if (allocSize == 0) { |
1050 |
allocSize = 1; /* enough for the NULL byte at end */ |
1051 |
} |
1052 |
|
1053 |
/* |
1054 |
* Allocate storage for the concatenated result. Note that allocSize |
1055 |
* is one more than the total number of characters, and so includes |
1056 |
* room for the terminating NULL byte. |
1057 |
*/ |
1058 |
|
1059 |
concatStr = (char *) ckalloc((unsigned) allocSize); |
1060 |
|
1061 |
/* |
1062 |
* Now concatenate the elements. Clip white space off the front and back |
1063 |
* to generate a neater result, and ignore any empty elements. Also put |
1064 |
* a null byte at the end. |
1065 |
*/ |
1066 |
|
1067 |
finalSize = 0; |
1068 |
if (objc == 0) { |
1069 |
*concatStr = '\0'; |
1070 |
} else { |
1071 |
p = concatStr; |
1072 |
for (i = 0; i < objc; i++) { |
1073 |
objPtr = objv[i]; |
1074 |
element = Tcl_GetStringFromObj(objPtr, &elemLength); |
1075 |
while ((elemLength > 0) |
1076 |
&& (isspace(UCHAR(*element)))) { /* INTL: ISO space. */ |
1077 |
element++; |
1078 |
elemLength--; |
1079 |
} |
1080 |
|
1081 |
/* |
1082 |
* Trim trailing white space. But, be careful not to trim |
1083 |
* a space character if it is preceded by a backslash: in |
1084 |
* this case it could be significant. |
1085 |
*/ |
1086 |
|
1087 |
while ((elemLength > 0) |
1088 |
&& isspace(UCHAR(element[elemLength-1])) /* INTL: ISO space. */ |
1089 |
&& ((elemLength < 2) || (element[elemLength-2] != '\\'))) { |
1090 |
elemLength--; |
1091 |
} |
1092 |
if (elemLength == 0) { |
1093 |
continue; /* nothing left of this element */ |
1094 |
} |
1095 |
memcpy((VOID *) p, (VOID *) element, (size_t) elemLength); |
1096 |
p += elemLength; |
1097 |
*p = ' '; |
1098 |
p++; |
1099 |
finalSize += (elemLength + 1); |
1100 |
} |
1101 |
if (p != concatStr) { |
1102 |
p[-1] = 0; |
1103 |
finalSize -= 1; /* we overwrote the final ' ' */ |
1104 |
} else { |
1105 |
*p = 0; |
1106 |
} |
1107 |
} |
1108 |
|
1109 |
TclNewObj(objPtr); |
1110 |
objPtr->bytes = concatStr; |
1111 |
objPtr->length = finalSize; |
1112 |
return objPtr; |
1113 |
} |
1114 |
|
1115 |
/* |
1116 |
*---------------------------------------------------------------------- |
1117 |
* |
1118 |
* Tcl_StringMatch -- |
1119 |
* |
1120 |
* See if a particular string matches a particular pattern. |
1121 |
* |
1122 |
* Results: |
1123 |
* The return value is 1 if string matches pattern, and |
1124 |
* 0 otherwise. The matching operation permits the following |
1125 |
* special characters in the pattern: *?\[] (see the manual |
1126 |
* entry for details on what these mean). |
1127 |
* |
1128 |
* Side effects: |
1129 |
* None. |
1130 |
* |
1131 |
*---------------------------------------------------------------------- |
1132 |
*/ |
1133 |
|
1134 |
int |
1135 |
Tcl_StringMatch(string, pattern) |
1136 |
CONST char *string; /* String. */ |
1137 |
CONST char *pattern; /* Pattern, which may contain special |
1138 |
* characters. */ |
1139 |
{ |
1140 |
int p, s; |
1141 |
CONST char *pstart = pattern; |
1142 |
|
1143 |
while (1) { |
1144 |
p = *pattern; |
1145 |
s = *string; |
1146 |
|
1147 |
/* |
1148 |
* See if we're at the end of both the pattern and the string. If |
1149 |
* so, we succeeded. If we're at the end of the pattern but not at |
1150 |
* the end of the string, we failed. |
1151 |
*/ |
1152 |
|
1153 |
if (p == '\0') { |
1154 |
if (s == '\0') { |
1155 |
return 1; |
1156 |
} else { |
1157 |
return 0; |
1158 |
} |
1159 |
} |
1160 |
if ((s == '\0') && (p != '*')) { |
1161 |
return 0; |
1162 |
} |
1163 |
|
1164 |
/* Check for a "*" as the next pattern character. It matches |
1165 |
* any substring. We handle this by calling ourselves |
1166 |
* recursively for each postfix of string, until either we |
1167 |
* match or we reach the end of the string. |
1168 |
*/ |
1169 |
|
1170 |
if (p == '*') { |
1171 |
pattern++; |
1172 |
if (*pattern == '\0') { |
1173 |
return 1; |
1174 |
} |
1175 |
while (1) { |
1176 |
if (Tcl_StringMatch(string, pattern)) { |
1177 |
return 1; |
1178 |
} |
1179 |
if (*string == '\0') { |
1180 |
return 0; |
1181 |
} |
1182 |
string++; |
1183 |
} |
1184 |
} |
1185 |
|
1186 |
/* Check for a "?" as the next pattern character. It matches |
1187 |
* any single character. |
1188 |
*/ |
1189 |
|
1190 |
if (p == '?') { |
1191 |
Tcl_UniChar ch; |
1192 |
|
1193 |
pattern++; |
1194 |
string += Tcl_UtfToUniChar(string, &ch); |
1195 |
continue; |
1196 |
} |
1197 |
|
1198 |
/* Check for a "[" as the next pattern character. It is followed |
1199 |
* by a list of characters that are acceptable, or by a range |
1200 |
* (two characters separated by "-"). |
1201 |
*/ |
1202 |
|
1203 |
if (p == '[') { |
1204 |
Tcl_UniChar ch, startChar, endChar; |
1205 |
|
1206 |
pattern++; |
1207 |
string += Tcl_UtfToUniChar(string, &ch); |
1208 |
|
1209 |
while (1) { |
1210 |
if ((*pattern == ']') || (*pattern == '\0')) { |
1211 |
return 0; |
1212 |
} |
1213 |
pattern += Tcl_UtfToUniChar(pattern, &startChar); |
1214 |
if (*pattern == '-') { |
1215 |
pattern++; |
1216 |
if (*pattern == '\0') { |
1217 |
return 0; |
1218 |
} |
1219 |
pattern += Tcl_UtfToUniChar(pattern, &endChar); |
1220 |
if (((startChar <= ch) && (ch <= endChar)) |
1221 |
|| ((endChar <= ch) && (ch <= startChar))) { |
1222 |
/* |
1223 |
* Matches ranges of form [a-z] or [z-a]. |
1224 |
*/ |
1225 |
|
1226 |
break; |
1227 |
} |
1228 |
} else if (startChar == ch) { |
1229 |
break; |
1230 |
} |
1231 |
} |
1232 |
while (*pattern != ']') { |
1233 |
if (*pattern == '\0') { |
1234 |
pattern = Tcl_UtfPrev(pattern, pstart); |
1235 |
break; |
1236 |
} |
1237 |
pattern++; |
1238 |
} |
1239 |
pattern++; |
1240 |
continue; |
1241 |
} |
1242 |
|
1243 |
/* If the next pattern character is '\', just strip off the '\' |
1244 |
* so we do exact matching on the character that follows. |
1245 |
*/ |
1246 |
|
1247 |
if (p == '\\') { |
1248 |
pattern++; |
1249 |
p = *pattern; |
1250 |
if (p == '\0') { |
1251 |
return 0; |
1252 |
} |
1253 |
} |
1254 |
|
1255 |
/* There's no special character. Just make sure that the next |
1256 |
* bytes of each string match. |
1257 |
*/ |
1258 |
|
1259 |
if (s != p) { |
1260 |
return 0; |
1261 |
} |
1262 |
pattern++; |
1263 |
string++; |
1264 |
} |
1265 |
} |
1266 |
|
1267 |
/* |
1268 |
*---------------------------------------------------------------------- |
1269 |
* |
1270 |
* Tcl_StringCaseMatch -- |
1271 |
* |
1272 |
* See if a particular string matches a particular pattern. |
1273 |
* Allows case insensitivity. |
1274 |
* |
1275 |
* Results: |
1276 |
* The return value is 1 if string matches pattern, and |
1277 |
* 0 otherwise. The matching operation permits the following |
1278 |
* special characters in the pattern: *?\[] (see the manual |
1279 |
* entry for details on what these mean). |
1280 |
* |
1281 |
* Side effects: |
1282 |
* None. |
1283 |
* |
1284 |
*---------------------------------------------------------------------- |
1285 |
*/ |
1286 |
|
1287 |
int |
1288 |
Tcl_StringCaseMatch(string, pattern, nocase) |
1289 |
CONST char *string; /* String. */ |
1290 |
CONST char *pattern; /* Pattern, which may contain special |
1291 |
* characters. */ |
1292 |
int nocase; /* 0 for case sensitive, 1 for insensitive */ |
1293 |
{ |
1294 |
int p, s; |
1295 |
CONST char *pstart = pattern; |
1296 |
Tcl_UniChar ch1, ch2; |
1297 |
|
1298 |
while (1) { |
1299 |
p = *pattern; |
1300 |
s = *string; |
1301 |
|
1302 |
/* |
1303 |
* See if we're at the end of both the pattern and the string. If |
1304 |
* so, we succeeded. If we're at the end of the pattern but not at |
1305 |
* the end of the string, we failed. |
1306 |
*/ |
1307 |
|
1308 |
if (p == '\0') { |
1309 |
return (s == '\0'); |
1310 |
} |
1311 |
if ((s == '\0') && (p != '*')) { |
1312 |
return 0; |
1313 |
} |
1314 |
|
1315 |
/* Check for a "*" as the next pattern character. It matches |
1316 |
* any substring. We handle this by calling ourselves |
1317 |
* recursively for each postfix of string, until either we |
1318 |
* match or we reach the end of the string. |
1319 |
*/ |
1320 |
|
1321 |
if (p == '*') { |
1322 |
pattern++; |
1323 |
if (*pattern == '\0') { |
1324 |
return 1; |
1325 |
} |
1326 |
while (1) { |
1327 |
if (Tcl_StringCaseMatch(string, pattern, nocase)) { |
1328 |
return 1; |
1329 |
} |
1330 |
if (*string == '\0') { |
1331 |
return 0; |
1332 |
} |
1333 |
string++; |
1334 |
} |
1335 |
} |
1336 |
|
1337 |
/* Check for a "?" as the next pattern character. It matches |
1338 |
* any single character. |
1339 |
*/ |
1340 |
|
1341 |
if (p == '?') { |
1342 |
pattern++; |
1343 |
string += Tcl_UtfToUniChar(string, &ch1); |
1344 |
continue; |
1345 |
} |
1346 |
|
1347 |
/* Check for a "[" as the next pattern character. It is followed |
1348 |
* by a list of characters that are acceptable, or by a range |
1349 |
* (two characters separated by "-"). |
1350 |
*/ |
1351 |
|
1352 |
if (p == '[') { |
1353 |
Tcl_UniChar startChar, endChar; |
1354 |
|
1355 |
pattern++; |
1356 |
string += Tcl_UtfToUniChar(string, &ch1); |
1357 |
if (nocase) { |
1358 |
ch1 = Tcl_UniCharToLower(ch1); |
1359 |
} |
1360 |
while (1) { |
1361 |
if ((*pattern == ']') || (*pattern == '\0')) { |
1362 |
return 0; |
1363 |
} |
1364 |
pattern += Tcl_UtfToUniChar(pattern, &startChar); |
1365 |
if (nocase) { |
1366 |
startChar = Tcl_UniCharToLower(startChar); |
1367 |
} |
1368 |
if (*pattern == '-') { |
1369 |
pattern++; |
1370 |
if (*pattern == '\0') { |
1371 |
return 0; |
1372 |
} |
1373 |
pattern += Tcl_UtfToUniChar(pattern, &endChar); |
1374 |
if (nocase) { |
1375 |
endChar = Tcl_UniCharToLower(endChar); |
1376 |
} |
1377 |
if (((startChar <= ch1) && (ch1 <= endChar)) |
1378 |
|| ((endChar <= ch1) && (ch1 <= startChar))) { |
1379 |
/* |
1380 |
* Matches ranges of form [a-z] or [z-a]. |
1381 |
*/ |
1382 |
|
1383 |
break; |
1384 |
} |
1385 |
} else if (startChar == ch1) { |
1386 |
break; |
1387 |
} |
1388 |
} |
1389 |
while (*pattern != ']') { |
1390 |
if (*pattern == '\0') { |
1391 |
pattern = Tcl_UtfPrev(pattern, pstart); |
1392 |
break; |
1393 |
} |
1394 |
pattern++; |
1395 |
} |
1396 |
pattern++; |
1397 |
continue; |
1398 |
} |
1399 |
|
1400 |
/* If the next pattern character is '\', just strip off the '\' |
1401 |
* so we do exact matching on the character that follows. |
1402 |
*/ |
1403 |
|
1404 |
if (p == '\\') { |
1405 |
pattern++; |
1406 |
p = *pattern; |
1407 |
if (p == '\0') { |
1408 |
return 0; |
1409 |
} |
1410 |
} |
1411 |
|
1412 |
/* There's no special character. Just make sure that the next |
1413 |
* bytes of each string match. |
1414 |
*/ |
1415 |
|
1416 |
string += Tcl_UtfToUniChar(string, &ch1); |
1417 |
pattern += Tcl_UtfToUniChar(pattern, &ch2); |
1418 |
if (nocase) { |
1419 |
if (Tcl_UniCharToLower(ch1) != Tcl_UniCharToLower(ch2)) { |
1420 |
return 0; |
1421 |
} |
1422 |
} else if (ch1 != ch2) { |
1423 |
return 0; |
1424 |
} |
1425 |
} |
1426 |
} |
1427 |
|
1428 |
/* |
1429 |
*---------------------------------------------------------------------- |
1430 |
* |
1431 |
* Tcl_DStringInit -- |
1432 |
* |
1433 |
* Initializes a dynamic string, discarding any previous contents |
1434 |
* of the string (Tcl_DStringFree should have been called already |
1435 |
* if the dynamic string was previously in use). |
1436 |
* |
1437 |
* Results: |
1438 |
* None. |
1439 |
* |
1440 |
* Side effects: |
1441 |
* The dynamic string is initialized to be empty. |
1442 |
* |
1443 |
*---------------------------------------------------------------------- |
1444 |
*/ |
1445 |
|
1446 |
void |
1447 |
Tcl_DStringInit(dsPtr) |
1448 |
Tcl_DString *dsPtr; /* Pointer to structure for dynamic string. */ |
1449 |
{ |
1450 |
dsPtr->string = dsPtr->staticSpace; |
1451 |
dsPtr->length = 0; |
1452 |
dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; |
1453 |
dsPtr->staticSpace[0] = '\0'; |
1454 |
} |
1455 |
|
1456 |
/* |
1457 |
*---------------------------------------------------------------------- |
1458 |
* |
1459 |
* Tcl_DStringAppend -- |
1460 |
* |
1461 |
* Append more characters to the current value of a dynamic string. |
1462 |
* |
1463 |
* Results: |
1464 |
* The return value is a pointer to the dynamic string's new value. |
1465 |
* |
1466 |
* Side effects: |
1467 |
* Length bytes from string (or all of string if length is less |
1468 |
* than zero) are added to the current value of the string. Memory |
1469 |
* gets reallocated if needed to accomodate the string's new size. |
1470 |
* |
1471 |
*---------------------------------------------------------------------- |
1472 |
*/ |
1473 |
|
1474 |
char * |
1475 |
Tcl_DStringAppend(dsPtr, string, length) |
1476 |
Tcl_DString *dsPtr; /* Structure describing dynamic string. */ |
1477 |
CONST char *string; /* String to append. If length is -1 then |
1478 |
* this must be null-terminated. */ |
1479 |
int length; /* Number of characters from string to |
1480 |
* append. If < 0, then append all of string, |
1481 |
* up to null at end. */ |
1482 |
{ |
1483 |
int newSize; |
1484 |
char *dst; |
1485 |
CONST char *end; |
1486 |
|
1487 |
if (length < 0) { |
1488 |
length = strlen(string); |
1489 |
} |
1490 |
newSize = length + dsPtr->length; |
1491 |
|
1492 |
/* |
1493 |
* Allocate a larger buffer for the string if the current one isn't |
1494 |
* large enough. Allocate extra space in the new buffer so that there |
1495 |
* will be room to grow before we have to allocate again. |
1496 |
*/ |
1497 |
|
1498 |
if (newSize >= dsPtr->spaceAvl) { |
1499 |
dsPtr->spaceAvl = newSize * 2; |
1500 |
if (dsPtr->string == dsPtr->staticSpace) { |
1501 |
char *newString; |
1502 |
|
1503 |
newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); |
1504 |
memcpy((VOID *) newString, (VOID *) dsPtr->string, |
1505 |
(size_t) dsPtr->length); |
1506 |
dsPtr->string = newString; |
1507 |
} else { |
1508 |
dsPtr->string = (char *) ckrealloc((VOID *) dsPtr->string, |
1509 |
(size_t) dsPtr->spaceAvl); |
1510 |
} |
1511 |
} |
1512 |
|
1513 |
/* |
1514 |
* Copy the new string into the buffer at the end of the old |
1515 |
* one. |
1516 |
*/ |
1517 |
|
1518 |
for (dst = dsPtr->string + dsPtr->length, end = string+length; |
1519 |
string < end; string++, dst++) { |
1520 |
*dst = *string; |
1521 |
} |
1522 |
*dst = '\0'; |
1523 |
dsPtr->length += length; |
1524 |
return dsPtr->string; |
1525 |
} |
1526 |
|
1527 |
/* |
1528 |
*---------------------------------------------------------------------- |
1529 |
* |
1530 |
* Tcl_DStringAppendElement -- |
1531 |
* |
1532 |
* Append a list element to the current value of a dynamic string. |
1533 |
* |
1534 |
* Results: |
1535 |
* The return value is a pointer to the dynamic string's new value. |
1536 |
* |
1537 |
* Side effects: |
1538 |
* String is reformatted as a list element and added to the current |
1539 |
* value of the string. Memory gets reallocated if needed to |
1540 |
* accomodate the string's new size. |
1541 |
* |
1542 |
*---------------------------------------------------------------------- |
1543 |
*/ |
1544 |
|
1545 |
char * |
1546 |
Tcl_DStringAppendElement(dsPtr, string) |
1547 |
Tcl_DString *dsPtr; /* Structure describing dynamic string. */ |
1548 |
CONST char *string; /* String to append. Must be |
1549 |
* null-terminated. */ |
1550 |
{ |
1551 |
int newSize, flags; |
1552 |
char *dst; |
1553 |
|
1554 |
newSize = Tcl_ScanElement(string, &flags) + dsPtr->length + 1; |
1555 |
|
1556 |
/* |
1557 |
* Allocate a larger buffer for the string if the current one isn't |
1558 |
* large enough. Allocate extra space in the new buffer so that there |
1559 |
* will be room to grow before we have to allocate again. |
1560 |
* SPECIAL NOTE: must use memcpy, not strcpy, to copy the string |
1561 |
* to a larger buffer, since there may be embedded NULLs in the |
1562 |
* string in some cases. |
1563 |
*/ |
1564 |
|
1565 |
if (newSize >= dsPtr->spaceAvl) { |
1566 |
dsPtr->spaceAvl = newSize * 2; |
1567 |
if (dsPtr->string == dsPtr->staticSpace) { |
1568 |
char *newString; |
1569 |
|
1570 |
newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); |
1571 |
memcpy((VOID *) newString, (VOID *) dsPtr->string, |
1572 |
(size_t) dsPtr->length); |
1573 |
dsPtr->string = newString; |
1574 |
} else { |
1575 |
dsPtr->string = (char *) ckrealloc((VOID *) dsPtr->string, |
1576 |
(size_t) dsPtr->spaceAvl); |
1577 |
} |
1578 |
} |
1579 |
|
1580 |
/* |
1581 |
* Convert the new string to a list element and copy it into the |
1582 |
* buffer at the end, with a space, if needed. |
1583 |
*/ |
1584 |
|
1585 |
dst = dsPtr->string + dsPtr->length; |
1586 |
if (TclNeedSpace(dsPtr->string, dst)) { |
1587 |
*dst = ' '; |
1588 |
dst++; |
1589 |
dsPtr->length++; |
1590 |
} |
1591 |
dsPtr->length += Tcl_ConvertElement(string, dst, flags); |
1592 |
return dsPtr->string; |
1593 |
} |
1594 |
|
1595 |
/* |
1596 |
*---------------------------------------------------------------------- |
1597 |
* |
1598 |
* Tcl_DStringSetLength -- |
1599 |
* |
1600 |
* Change the length of a dynamic string. This can cause the |
1601 |
* string to either grow or shrink, depending on the value of |
1602 |
* length. |
1603 |
* |
1604 |
* Results: |
1605 |
* None. |
1606 |
* |
1607 |
* Side effects: |
1608 |
* The length of dsPtr is changed to length and a null byte is |
1609 |
* stored at that position in the string. If length is larger |
1610 |
* than the space allocated for dsPtr, then a panic occurs. |
1611 |
* |
1612 |
*---------------------------------------------------------------------- |
1613 |
*/ |
1614 |
|
1615 |
void |
1616 |
Tcl_DStringSetLength(dsPtr, length) |
1617 |
Tcl_DString *dsPtr; /* Structure describing dynamic string. */ |
1618 |
int length; /* New length for dynamic string. */ |
1619 |
{ |
1620 |
int newsize; |
1621 |
|
1622 |
if (length < 0) { |
1623 |
length = 0; |
1624 |
} |
1625 |
if (length >= dsPtr->spaceAvl) { |
1626 |
/* |
1627 |
* There are two interesting cases here. In the first case, the user |
1628 |
* may be trying to allocate a large buffer of a specific size. It |
1629 |
* would be wasteful to overallocate that buffer, so we just allocate |
1630 |
* enough for the requested size plus the trailing null byte. In the |
1631 |
* second case, we are growing the buffer incrementally, so we need |
1632 |
* behavior similar to Tcl_DStringAppend. The requested length will |
1633 |
* usually be a small delta above the current spaceAvl, so we'll end up |
1634 |
* doubling the old size. This won't grow the buffer quite as quickly, |
1635 |
* but it should be close enough. |
1636 |
*/ |
1637 |
|
1638 |
newsize = dsPtr->spaceAvl * 2; |
1639 |
if (length < newsize) { |
1640 |
dsPtr->spaceAvl = newsize; |
1641 |
} else { |
1642 |
dsPtr->spaceAvl = length + 1; |
1643 |
} |
1644 |
if (dsPtr->string == dsPtr->staticSpace) { |
1645 |
char *newString; |
1646 |
|
1647 |
newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); |
1648 |
memcpy((VOID *) newString, (VOID *) dsPtr->string, |
1649 |
(size_t) dsPtr->length); |
1650 |
dsPtr->string = newString; |
1651 |
} else { |
1652 |
dsPtr->string = (char *) ckrealloc((VOID *) dsPtr->string, |
1653 |
(size_t) dsPtr->spaceAvl); |
1654 |
} |
1655 |
} |
1656 |
dsPtr->length = length; |
1657 |
dsPtr->string[length] = 0; |
1658 |
} |
1659 |
|
1660 |
/* |
1661 |
*---------------------------------------------------------------------- |
1662 |
* |
1663 |
* Tcl_DStringFree -- |
1664 |
* |
1665 |
* Frees up any memory allocated for the dynamic string and |
1666 |
* reinitializes the string to an empty state. |
1667 |
* |
1668 |
* Results: |
1669 |
* None. |
1670 |
* |
1671 |
* Side effects: |
1672 |
* The previous contents of the dynamic string are lost, and |
1673 |
* the new value is an empty string. |
1674 |
* |
1675 |
*---------------------------------------------------------------------- */ |
1676 |
|
1677 |
void |
1678 |
Tcl_DStringFree(dsPtr) |
1679 |
Tcl_DString *dsPtr; /* Structure describing dynamic string. */ |
1680 |
{ |
1681 |
if (dsPtr->string != dsPtr->staticSpace) { |
1682 |
ckfree(dsPtr->string); |
1683 |
} |
1684 |
dsPtr->string = dsPtr->staticSpace; |
1685 |
dsPtr->length = 0; |
1686 |
dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; |
1687 |
dsPtr->staticSpace[0] = '\0'; |
1688 |
} |
1689 |
|
1690 |
/* |
1691 |
*---------------------------------------------------------------------- |
1692 |
* |
1693 |
* Tcl_DStringResult -- |
1694 |
* |
1695 |
* This procedure moves the value of a dynamic string into an |
1696 |
* interpreter as its string result. Afterwards, the dynamic string |
1697 |
* is reset to an empty string. |
1698 |
* |
1699 |
* Results: |
1700 |
* None. |
1701 |
* |
1702 |
* Side effects: |
1703 |
* The string is "moved" to interp's result, and any existing |
1704 |
* string result for interp is freed. dsPtr is reinitialized to |
1705 |
* an empty string. |
1706 |
* |
1707 |
*---------------------------------------------------------------------- |
1708 |
*/ |
1709 |
|
1710 |
void |
1711 |
Tcl_DStringResult(interp, dsPtr) |
1712 |
Tcl_Interp *interp; /* Interpreter whose result is to be reset. */ |
1713 |
Tcl_DString *dsPtr; /* Dynamic string that is to become the |
1714 |
* result of interp. */ |
1715 |
{ |
1716 |
Tcl_ResetResult(interp); |
1717 |
|
1718 |
if (dsPtr->string != dsPtr->staticSpace) { |
1719 |
interp->result = dsPtr->string; |
1720 |
interp->freeProc = TCL_DYNAMIC; |
1721 |
} else if (dsPtr->length < TCL_RESULT_SIZE) { |
1722 |
interp->result = ((Interp *) interp)->resultSpace; |
1723 |
strcpy(interp->result, dsPtr->string); |
1724 |
} else { |
1725 |
Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE); |
1726 |
} |
1727 |
|
1728 |
dsPtr->string = dsPtr->staticSpace; |
1729 |
dsPtr->length = 0; |
1730 |
dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; |
1731 |
dsPtr->staticSpace[0] = '\0'; |
1732 |
} |
1733 |
|
1734 |
/* |
1735 |
*---------------------------------------------------------------------- |
1736 |
* |
1737 |
* Tcl_DStringGetResult -- |
1738 |
* |
1739 |
* This procedure moves an interpreter's result into a dynamic string. |
1740 |
* |
1741 |
* Results: |
1742 |
* None. |
1743 |
* |
1744 |
* Side effects: |
1745 |
* The interpreter's string result is cleared, and the previous |
1746 |
* contents of dsPtr are freed. |
1747 |
* |
1748 |
* If the string result is empty, the object result is moved to the |
1749 |
* string result, then the object result is reset. |
1750 |
* |
1751 |
*---------------------------------------------------------------------- |
1752 |
*/ |
1753 |
|
1754 |
void |
1755 |
Tcl_DStringGetResult(interp, dsPtr) |
1756 |
Tcl_Interp *interp; /* Interpreter whose result is to be reset. */ |
1757 |
Tcl_DString *dsPtr; /* Dynamic string that is to become the |
1758 |
* result of interp. */ |
1759 |
{ |
1760 |
Interp *iPtr = (Interp *) interp; |
1761 |
|
1762 |
if (dsPtr->string != dsPtr->staticSpace) { |
1763 |
ckfree(dsPtr->string); |
1764 |
} |
1765 |
|
1766 |
/* |
1767 |
* If the string result is empty, move the object result to the |
1768 |
* string result, then reset the object result. |
1769 |
*/ |
1770 |
|
1771 |
if (*(iPtr->result) == 0) { |
1772 |
Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), |
1773 |
TCL_VOLATILE); |
1774 |
} |
1775 |
|
1776 |
dsPtr->length = strlen(iPtr->result); |
1777 |
if (iPtr->freeProc != NULL) { |
1778 |
if ((iPtr->freeProc == TCL_DYNAMIC) |
1779 |
|| (iPtr->freeProc == (Tcl_FreeProc *) free)) { |
1780 |
dsPtr->string = iPtr->result; |
1781 |
dsPtr->spaceAvl = dsPtr->length+1; |
1782 |
} else { |
1783 |
dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length+1)); |
1784 |
strcpy(dsPtr->string, iPtr->result); |
1785 |
(*iPtr->freeProc)(iPtr->result); |
1786 |
} |
1787 |
dsPtr->spaceAvl = dsPtr->length+1; |
1788 |
iPtr->freeProc = NULL; |
1789 |
} else { |
1790 |
if (dsPtr->length < TCL_DSTRING_STATIC_SIZE) { |
1791 |
dsPtr->string = dsPtr->staticSpace; |
1792 |
dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; |
1793 |
} else { |
1794 |
dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length + 1)); |
1795 |
dsPtr->spaceAvl = dsPtr->length + 1; |
1796 |
} |
1797 |
strcpy(dsPtr->string, iPtr->result); |
1798 |
} |
1799 |
|
1800 |
iPtr->result = iPtr->resultSpace; |
1801 |
iPtr->resultSpace[0] = 0; |
1802 |
} |
1803 |
|
1804 |
/* |
1805 |
*---------------------------------------------------------------------- |
1806 |
* |
1807 |
* Tcl_DStringStartSublist -- |
1808 |
* |
1809 |
* This procedure adds the necessary information to a dynamic |
1810 |
* string (e.g. " {" to start a sublist. Future element |
1811 |
* appends will be in the sublist rather than the main list. |
1812 |
* |
1813 |
* Results: |
1814 |
* None. |
1815 |
* |
1816 |
* Side effects: |
1817 |
* Characters get added to the dynamic string. |
1818 |
* |
1819 |
*---------------------------------------------------------------------- |
1820 |
*/ |
1821 |
|
1822 |
void |
1823 |
Tcl_DStringStartSublist(dsPtr) |
1824 |
Tcl_DString *dsPtr; /* Dynamic string. */ |
1825 |
{ |
1826 |
if (TclNeedSpace(dsPtr->string, dsPtr->string + dsPtr->length)) { |
1827 |
Tcl_DStringAppend(dsPtr, " {", -1); |
1828 |
} else { |
1829 |
Tcl_DStringAppend(dsPtr, "{", -1); |
1830 |
} |
1831 |
} |
1832 |
|
1833 |
/* |
1834 |
*---------------------------------------------------------------------- |
1835 |
* |
1836 |
* Tcl_DStringEndSublist -- |
1837 |
* |
1838 |
* This procedure adds the necessary characters to a dynamic |
1839 |
* string to end a sublist (e.g. "}"). Future element appends |
1840 |
* will be in the enclosing (sub)list rather than the current |
1841 |
* sublist. |
1842 |
* |
1843 |
* Results: |
1844 |
* None. |
1845 |
* |
1846 |
* Side effects: |
1847 |
* None. |
1848 |
* |
1849 |
*---------------------------------------------------------------------- |
1850 |
*/ |
1851 |
|
1852 |
void |
1853 |
Tcl_DStringEndSublist(dsPtr) |
1854 |
Tcl_DString *dsPtr; /* Dynamic string. */ |
1855 |
{ |
1856 |
Tcl_DStringAppend(dsPtr, "}", -1); |
1857 |
} |
1858 |
|
1859 |
/* |
1860 |
*---------------------------------------------------------------------- |
1861 |
* |
1862 |
* Tcl_PrintDouble -- |
1863 |
* |
1864 |
* Given a floating-point value, this procedure converts it to |
1865 |
* an ASCII string using. |
1866 |
* |
1867 |
* Results: |
1868 |
* The ASCII equivalent of "value" is written at "dst". It is |
1869 |
* written using the current precision, and it is guaranteed to |
1870 |
* contain a decimal point or exponent, so that it looks like |
1871 |
* a floating-point value and not an integer. |
1872 |
* |
1873 |
* Side effects: |
1874 |
* None. |
1875 |
* |
1876 |
*---------------------------------------------------------------------- |
1877 |
*/ |
1878 |
|
1879 |
void |
1880 |
Tcl_PrintDouble(interp, value, dst) |
1881 |
Tcl_Interp *interp; /* Interpreter whose tcl_precision |
1882 |
* variable used to be used to control |
1883 |
* printing. It's ignored now. */ |
1884 |
double value; /* Value to print as string. */ |
1885 |
char *dst; /* Where to store converted value; |
1886 |
* must have at least TCL_DOUBLE_SPACE |
1887 |
* characters. */ |
1888 |
{ |
1889 |
char *p, c; |
1890 |
Tcl_UniChar ch; |
1891 |
|
1892 |
Tcl_MutexLock(&precisionMutex); |
1893 |
sprintf(dst, precisionFormat, value); |
1894 |
Tcl_MutexUnlock(&precisionMutex); |
1895 |
|
1896 |
/* |
1897 |
* If the ASCII result looks like an integer, add ".0" so that it |
1898 |
* doesn't look like an integer anymore. This prevents floating-point |
1899 |
* values from being converted to integers unintentionally. |
1900 |
*/ |
1901 |
|
1902 |
for (p = dst; *p != 0; ) { |
1903 |
p += Tcl_UtfToUniChar(p, &ch); |
1904 |
c = UCHAR(ch); |
1905 |
if ((c == '.') || isalpha(UCHAR(c))) { /* INTL: ISO only. */ |
1906 |
return; |
1907 |
} |
1908 |
} |
1909 |
p[0] = '.'; |
1910 |
p[1] = '0'; |
1911 |
p[2] = 0; |
1912 |
} |
1913 |
|
1914 |
/* |
1915 |
*---------------------------------------------------------------------- |
1916 |
* |
1917 |
* TclPrecTraceProc -- |
1918 |
* |
1919 |
* This procedure is invoked whenever the variable "tcl_precision" |
1920 |
* is written. |
1921 |
* |
1922 |
* Results: |
1923 |
* Returns NULL if all went well, or an error message if the |
1924 |
* new value for the variable doesn't make sense. |
1925 |
* |
1926 |
* Side effects: |
1927 |
* If the new value doesn't make sense then this procedure |
1928 |
* undoes the effect of the variable modification. Otherwise |
1929 |
* it modifies the format string that's used by Tcl_PrintDouble. |
1930 |
* |
1931 |
*---------------------------------------------------------------------- |
1932 |
*/ |
1933 |
|
1934 |
/* ARGSUSED */ |
1935 |
char * |
1936 |
TclPrecTraceProc(clientData, interp, name1, name2, flags) |
1937 |
ClientData clientData; /* Not used. */ |
1938 |
Tcl_Interp *interp; /* Interpreter containing variable. */ |
1939 |
char *name1; /* Name of variable. */ |
1940 |
char *name2; /* Second part of variable name. */ |
1941 |
int flags; /* Information about what happened. */ |
1942 |
{ |
1943 |
char *value, *end; |
1944 |
int prec; |
1945 |
|
1946 |
/* |
1947 |
* If the variable is unset, then recreate the trace. |
1948 |
*/ |
1949 |
|
1950 |
if (flags & TCL_TRACE_UNSETS) { |
1951 |
if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) { |
1952 |
Tcl_TraceVar2(interp, name1, name2, |
1953 |
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES |
1954 |
|TCL_TRACE_UNSETS, TclPrecTraceProc, clientData); |
1955 |
} |
1956 |
return (char *) NULL; |
1957 |
} |
1958 |
|
1959 |
/* |
1960 |
* When the variable is read, reset its value from our shared |
1961 |
* value. This is needed in case the variable was modified in |
1962 |
* some other interpreter so that this interpreter's value is |
1963 |
* out of date. |
1964 |
*/ |
1965 |
|
1966 |
Tcl_MutexLock(&precisionMutex); |
1967 |
|
1968 |
if (flags & TCL_TRACE_READS) { |
1969 |
Tcl_SetVar2(interp, name1, name2, precisionString, |
1970 |
flags & TCL_GLOBAL_ONLY); |
1971 |
Tcl_MutexUnlock(&precisionMutex); |
1972 |
return (char *) NULL; |
1973 |
} |
1974 |
|
1975 |
/* |
1976 |
* The variable is being written. Check the new value and disallow |
1977 |
* it if it isn't reasonable or if this is a safe interpreter (we |
1978 |
* don't want safe interpreters messing up the precision of other |
1979 |
* interpreters). |
1980 |
*/ |
1981 |
|
1982 |
if (Tcl_IsSafe(interp)) { |
1983 |
Tcl_SetVar2(interp, name1, name2, precisionString, |
1984 |
flags & TCL_GLOBAL_ONLY); |
1985 |
Tcl_MutexUnlock(&precisionMutex); |
1986 |
return "can't modify precision from a safe interpreter"; |
1987 |
} |
1988 |
value = Tcl_GetVar2(interp, name1, name2, flags & TCL_GLOBAL_ONLY); |
1989 |
if (value == NULL) { |
1990 |
value = ""; |
1991 |
} |
1992 |
prec = strtoul(value, &end, 10); |
1993 |
if ((prec <= 0) || (prec > TCL_MAX_PREC) || (prec > 100) || |
1994 |
(end == value) || (*end != 0)) { |
1995 |
Tcl_SetVar2(interp, name1, name2, precisionString, |
1996 |
flags & TCL_GLOBAL_ONLY); |
1997 |
Tcl_MutexUnlock(&precisionMutex); |
1998 |
return "improper value for precision"; |
1999 |
} |
2000 |
TclFormatInt(precisionString, prec); |
2001 |
sprintf(precisionFormat, "%%.%dg", prec); |
2002 |
Tcl_MutexUnlock(&precisionMutex); |
2003 |
return (char *) NULL; |
2004 |
} |
2005 |
|
2006 |
/* |
2007 |
*---------------------------------------------------------------------- |
2008 |
* |
2009 |
* TclNeedSpace -- |
2010 |
* |
2011 |
* This procedure checks to see whether it is appropriate to |
2012 |
* add a space before appending a new list element to an |
2013 |
* existing string. |
2014 |
* |
2015 |
* Results: |
2016 |
* The return value is 1 if a space is appropriate, 0 otherwise. |
2017 |
* |
2018 |
* Side effects: |
2019 |
* None. |
2020 |
* |
2021 |
*---------------------------------------------------------------------- |
2022 |
*/ |
2023 |
|
2024 |
int |
2025 |
TclNeedSpace(start, end) |
2026 |
char *start; /* First character in string. */ |
2027 |
char *end; /* End of string (place where space will |
2028 |
* be added, if appropriate). */ |
2029 |
{ |
2030 |
/* |
2031 |
* A space is needed unless either |
2032 |
* (a) we're at the start of the string, or |
2033 |
* (b) the trailing characters of the string consist of one or more |
2034 |
* open curly braces preceded by a space or extending back to |
2035 |
* the beginning of the string. |
2036 |
* (c) the trailing characters of the string consist of a space |
2037 |
* preceded by a character other than backslash. |
2038 |
*/ |
2039 |
|
2040 |
if (end == start) { |
2041 |
return 0; |
2042 |
} |
2043 |
end--; |
2044 |
if (*end != '{') { |
2045 |
if (isspace(UCHAR(*end)) /* INTL: ISO space. */ |
2046 |
&& ((end == start) || (end[-1] != '\\'))) { |
2047 |
return 0; |
2048 |
} |
2049 |
return 1; |
2050 |
} |
2051 |
do { |
2052 |
if (end == start) { |
2053 |
return 0; |
2054 |
} |
2055 |
end--; |
2056 |
} while (*end == '{'); |
2057 |
if (isspace(UCHAR(*end))) { /* INTL: ISO space. */ |
2058 |
return 0; |
2059 |
} |
2060 |
return 1; |
2061 |
} |
2062 |
|
2063 |
/* |
2064 |
*---------------------------------------------------------------------- |
2065 |
* |
2066 |
* TclFormatInt -- |
2067 |
* |
2068 |
* This procedure formats an integer into a sequence of decimal digit |
2069 |
* characters in a buffer. If the integer is negative, a minus sign is |
2070 |
* inserted at the start of the buffer. A null character is inserted at |
2071 |
* the end of the formatted characters. It is the caller's |
2072 |
* responsibility to ensure that enough storage is available. This |
2073 |
* procedure has the effect of sprintf(buffer, "%d", n) but is faster. |
2074 |
* |
2075 |
* Results: |
2076 |
* An integer representing the number of characters formatted, not |
2077 |
* including the terminating \0. |
2078 |
* |
2079 |
* Side effects: |
2080 |
* The formatted characters are written into the storage pointer to |
2081 |
* by the "buffer" argument. |
2082 |
* |
2083 |
*---------------------------------------------------------------------- |
2084 |
*/ |
2085 |
|
2086 |
int |
2087 |
TclFormatInt(buffer, n) |
2088 |
char *buffer; /* Points to the storage into which the |
2089 |
* formatted characters are written. */ |
2090 |
long n; /* The integer to format. */ |
2091 |
{ |
2092 |
long intVal; |
2093 |
int i; |
2094 |
int numFormatted, j; |
2095 |
char *digits = "0123456789"; |
2096 |
|
2097 |
/* |
2098 |
* Check first whether "n" is zero. |
2099 |
*/ |
2100 |
|
2101 |
if (n == 0) { |
2102 |
buffer[0] = '0'; |
2103 |
buffer[1] = 0; |
2104 |
return 1; |
2105 |
} |
2106 |
|
2107 |
/* |
2108 |
* Check whether "n" is the maximum negative value. This is |
2109 |
* -2^(m-1) for an m-bit word, and has no positive equivalent; |
2110 |
* negating it produces the same value. |
2111 |
*/ |
2112 |
|
2113 |
if (n == -n) { |
2114 |
sprintf(buffer, "%ld", n); |
2115 |
return strlen(buffer); |
2116 |
} |
2117 |
|
2118 |
/* |
2119 |
* Generate the characters of the result backwards in the buffer. |
2120 |
*/ |
2121 |
|
2122 |
intVal = (n < 0? -n : n); |
2123 |
i = 0; |
2124 |
buffer[0] = '\0'; |
2125 |
do { |
2126 |
i++; |
2127 |
buffer[i] = digits[intVal % 10]; |
2128 |
intVal = intVal/10; |
2129 |
} while (intVal > 0); |
2130 |
if (n < 0) { |
2131 |
i++; |
2132 |
buffer[i] = '-'; |
2133 |
} |
2134 |
numFormatted = i; |
2135 |
|
2136 |
/* |
2137 |
* Now reverse the characters. |
2138 |
*/ |
2139 |
|
2140 |
for (j = 0; j < i; j++, i--) { |
2141 |
char tmp = buffer[i]; |
2142 |
buffer[i] = buffer[j]; |
2143 |
buffer[j] = tmp; |
2144 |
} |
2145 |
return numFormatted; |
2146 |
} |
2147 |
|
2148 |
/* |
2149 |
*---------------------------------------------------------------------- |
2150 |
* |
2151 |
* TclLooksLikeInt -- |
2152 |
* |
2153 |
* This procedure decides whether the leading characters of a |
2154 |
* string look like an integer or something else (such as a |
2155 |
* floating-point number or string). |
2156 |
* |
2157 |
* Results: |
2158 |
* The return value is 1 if the leading characters of p look |
2159 |
* like a valid Tcl integer. If they look like a floating-point |
2160 |
* number (e.g. "e01" or "2.4"), or if they don't look like a |
2161 |
* number at all, then 0 is returned. |
2162 |
* |
2163 |
* Side effects: |
2164 |
* None. |
2165 |
* |
2166 |
*---------------------------------------------------------------------- |
2167 |
*/ |
2168 |
|
2169 |
int |
2170 |
TclLooksLikeInt(bytes, length) |
2171 |
register char *bytes; /* Points to first byte of the string. */ |
2172 |
int length; /* Number of bytes in the string. If < 0 |
2173 |
* bytes up to the first null byte are |
2174 |
* considered (if they may appear in an |
2175 |
* integer). */ |
2176 |
{ |
2177 |
register char *p, *end; |
2178 |
|
2179 |
if (length < 0) { |
2180 |
length = (bytes? strlen(bytes) : 0); |
2181 |
} |
2182 |
end = (bytes + length); |
2183 |
|
2184 |
p = bytes; |
2185 |
while ((p < end) && isspace(UCHAR(*p))) { /* INTL: ISO space. */ |
2186 |
p++; |
2187 |
} |
2188 |
if (p == end) { |
2189 |
return 0; |
2190 |
} |
2191 |
|
2192 |
if ((*p == '+') || (*p == '-')) { |
2193 |
p++; |
2194 |
} |
2195 |
if ((p == end) || !isdigit(UCHAR(*p))) { /* INTL: digit */ |
2196 |
return 0; |
2197 |
} |
2198 |
p++; |
2199 |
while ((p < end) && isdigit(UCHAR(*p))) { /* INTL: digit */ |
2200 |
p++; |
2201 |
} |
2202 |
if (p == end) { |
2203 |
return 1; |
2204 |
} |
2205 |
if ((*p != '.') && (*p != 'e') && (*p != 'E')) { |
2206 |
return 1; |
2207 |
} |
2208 |
return 0; |
2209 |
} |
2210 |
|
2211 |
/* |
2212 |
*---------------------------------------------------------------------- |
2213 |
* |
2214 |
* TclGetIntForIndex -- |
2215 |
* |
2216 |
* This procedure returns an integer corresponding to the list index |
2217 |
* held in a Tcl object. The Tcl object's value is expected to be |
2218 |
* either an integer or a string of the form "end([+-]integer)?". |
2219 |
* |
2220 |
* Results: |
2221 |
* The return value is normally TCL_OK, which means that the index was |
2222 |
* successfully stored into the location referenced by "indexPtr". If |
2223 |
* the Tcl object referenced by "objPtr" has the value "end", the |
2224 |
* value stored is "endValue". If "objPtr"s values is not of the form |
2225 |
* "end([+-]integer)?" and |
2226 |
* can not be converted to an integer, TCL_ERROR is returned and, if |
2227 |
* "interp" is non-NULL, an error message is left in the interpreter's |
2228 |
* result object. |
2229 |
* |
2230 |
* Side effects: |
2231 |
* The object referenced by "objPtr" might be converted to an |
2232 |
* integer object. |
2233 |
* |
2234 |
*---------------------------------------------------------------------- |
2235 |
*/ |
2236 |
|
2237 |
int |
2238 |
TclGetIntForIndex(interp, objPtr, endValue, indexPtr) |
2239 |
Tcl_Interp *interp; /* Interpreter to use for error reporting. |
2240 |
* If NULL, then no error message is left |
2241 |
* after errors. */ |
2242 |
Tcl_Obj *objPtr; /* Points to an object containing either |
2243 |
* "end" or an integer. */ |
2244 |
int endValue; /* The value to be stored at "indexPtr" if |
2245 |
* "objPtr" holds "end". */ |
2246 |
int *indexPtr; /* Location filled in with an integer |
2247 |
* representing an index. */ |
2248 |
{ |
2249 |
char *bytes; |
2250 |
int length, offset; |
2251 |
|
2252 |
if (objPtr->typePtr == &tclIntType) { |
2253 |
*indexPtr = (int)objPtr->internalRep.longValue; |
2254 |
return TCL_OK; |
2255 |
} |
2256 |
|
2257 |
bytes = Tcl_GetStringFromObj(objPtr, &length); |
2258 |
|
2259 |
if ((*bytes != 'e') || (strncmp(bytes, "end", |
2260 |
(size_t)((length > 3) ? 3 : length)) != 0)) { |
2261 |
if (Tcl_GetIntFromObj(NULL, objPtr, &offset) != TCL_OK) { |
2262 |
goto intforindex_error; |
2263 |
} |
2264 |
*indexPtr = offset; |
2265 |
return TCL_OK; |
2266 |
} |
2267 |
|
2268 |
if (length <= 3) { |
2269 |
*indexPtr = endValue; |
2270 |
} else if (bytes[3] == '-') { |
2271 |
/* |
2272 |
* This is our limited string expression evaluator |
2273 |
*/ |
2274 |
if (Tcl_GetInt(interp, bytes+3, &offset) != TCL_OK) { |
2275 |
return TCL_ERROR; |
2276 |
} |
2277 |
*indexPtr = endValue + offset; |
2278 |
} else { |
2279 |
intforindex_error: |
2280 |
if ((Interp *)interp != NULL) { |
2281 |
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), |
2282 |
"bad index \"", bytes, |
2283 |
"\": must be integer or end?-integer?", (char *) NULL); |
2284 |
TclCheckBadOctal(interp, bytes); |
2285 |
} |
2286 |
return TCL_ERROR; |
2287 |
} |
2288 |
return TCL_OK; |
2289 |
} |
2290 |
|
2291 |
/* |
2292 |
*---------------------------------------------------------------------- |
2293 |
* |
2294 |
* TclCheckBadOctal -- |
2295 |
* |
2296 |
* This procedure checks for a bad octal value and appends a |
2297 |
* meaningful error to the interp's result. |
2298 |
* |
2299 |
* Results: |
2300 |
* 1 if the argument was a bad octal, else 0. |
2301 |
* |
2302 |
* Side effects: |
2303 |
* The interpreter's result is modified. |
2304 |
* |
2305 |
*---------------------------------------------------------------------- |
2306 |
*/ |
2307 |
|
2308 |
int |
2309 |
TclCheckBadOctal(interp, value) |
2310 |
Tcl_Interp *interp; /* Interpreter to use for error reporting. |
2311 |
* If NULL, then no error message is left |
2312 |
* after errors. */ |
2313 |
char *value; /* String to check. */ |
2314 |
{ |
2315 |
register char *p = value; |
2316 |
|
2317 |
/* |
2318 |
* A frequent mistake is invalid octal values due to an unwanted |
2319 |
* leading zero. Try to generate a meaningful error message. |
2320 |
*/ |
2321 |
|
2322 |
while (isspace(UCHAR(*p))) { /* INTL: ISO space. */ |
2323 |
p++; |
2324 |
} |
2325 |
if (*p == '+' || *p == '-') { |
2326 |
p++; |
2327 |
} |
2328 |
if (*p == '0') { |
2329 |
while (isdigit(UCHAR(*p))) { /* INTL: digit. */ |
2330 |
p++; |
2331 |
} |
2332 |
while (isspace(UCHAR(*p))) { /* INTL: ISO space. */ |
2333 |
p++; |
2334 |
} |
2335 |
if (*p == '\0') { |
2336 |
/* Reached end of string */ |
2337 |
if (interp != NULL) { |
2338 |
Tcl_AppendResult(interp, " (looks like invalid octal number)", |
2339 |
(char *) NULL); |
2340 |
} |
2341 |
return 1; |
2342 |
} |
2343 |
} |
2344 |
return 0; |
2345 |
} |
2346 |
|
2347 |
/* |
2348 |
*---------------------------------------------------------------------- |
2349 |
* |
2350 |
* Tcl_GetNameOfExecutable -- |
2351 |
* |
2352 |
* This procedure simply returns a pointer to the internal full |
2353 |
* path name of the executable file as computed by |
2354 |
* Tcl_FindExecutable. This procedure call is the C API |
2355 |
* equivalent to the "info nameofexecutable" command. |
2356 |
* |
2357 |
* Results: |
2358 |
* A pointer to the internal string or NULL if the internal full |
2359 |
* path name has not been computed or unknown. |
2360 |
* |
2361 |
* Side effects: |
2362 |
* The object referenced by "objPtr" might be converted to an |
2363 |
* integer object. |
2364 |
* |
2365 |
*---------------------------------------------------------------------- |
2366 |
*/ |
2367 |
|
2368 |
CONST char * |
2369 |
Tcl_GetNameOfExecutable() |
2370 |
{ |
2371 |
return (tclExecutableName); |
2372 |
} |
2373 |
|
2374 |
/* |
2375 |
*---------------------------------------------------------------------- |
2376 |
* |
2377 |
* Tcl_GetCwd -- |
2378 |
* |
2379 |
* This function replaces the library version of getcwd(). |
2380 |
* |
2381 |
* Results: |
2382 |
* The result is a pointer to a string specifying the current |
2383 |
* directory, or NULL if the current directory could not be |
2384 |
* determined. If NULL is returned, an error message is left in the |
2385 |
* interp's result. Storage for the result string is allocated in |
2386 |
* bufferPtr; the caller must call Tcl_DStringFree() when the result |
2387 |
* is no longer needed. |
2388 |
* |
2389 |
* Side effects: |
2390 |
* None. |
2391 |
* |
2392 |
*---------------------------------------------------------------------- |
2393 |
*/ |
2394 |
|
2395 |
char * |
2396 |
Tcl_GetCwd(interp, cwdPtr) |
2397 |
Tcl_Interp *interp; |
2398 |
Tcl_DString *cwdPtr; |
2399 |
{ |
2400 |
return TclpGetCwd(interp, cwdPtr); |
2401 |
} |
2402 |
|
2403 |
/* |
2404 |
*---------------------------------------------------------------------- |
2405 |
* |
2406 |
* Tcl_Chdir -- |
2407 |
* |
2408 |
* This function replaces the library version of chdir(). |
2409 |
* |
2410 |
* Results: |
2411 |
* See chdir() documentation. |
2412 |
* |
2413 |
* Side effects: |
2414 |
* See chdir() documentation. |
2415 |
* |
2416 |
*---------------------------------------------------------------------- |
2417 |
*/ |
2418 |
|
2419 |
int |
2420 |
Tcl_Chdir(dirName) |
2421 |
CONST char *dirName; |
2422 |
{ |
2423 |
return TclpChdir(dirName); |
2424 |
} |
2425 |
|
2426 |
/* |
2427 |
*---------------------------------------------------------------------- |
2428 |
* |
2429 |
* Tcl_Access -- |
2430 |
* |
2431 |
* This function replaces the library version of access(). |
2432 |
* |
2433 |
* Results: |
2434 |
* See access() documentation. |
2435 |
* |
2436 |
* Side effects: |
2437 |
* See access() documentation. |
2438 |
* |
2439 |
*---------------------------------------------------------------------- |
2440 |
*/ |
2441 |
|
2442 |
int |
2443 |
Tcl_Access(path, mode) |
2444 |
CONST char *path; /* Path of file to access (UTF-8). */ |
2445 |
int mode; /* Permission setting. */ |
2446 |
{ |
2447 |
return TclAccess(path, mode); |
2448 |
} |
2449 |
|
2450 |
/* |
2451 |
*---------------------------------------------------------------------- |
2452 |
* |
2453 |
* Tcl_Stat -- |
2454 |
* |
2455 |
* This function replaces the library version of stat(). |
2456 |
* |
2457 |
* Results: |
2458 |
* See stat() documentation. |
2459 |
* |
2460 |
* Side effects: |
2461 |
* See stat() documentation. |
2462 |
* |
2463 |
*---------------------------------------------------------------------- |
2464 |
*/ |
2465 |
|
2466 |
int |
2467 |
Tcl_Stat(path, bufPtr) |
2468 |
CONST char *path; /* Path of file to stat (in UTF-8). */ |
2469 |
struct stat *bufPtr; /* Filled with results of stat call. */ |
2470 |
{ |
2471 |
return TclStat(path, bufPtr); |
2472 |
} |
2473 |
|
2474 |
/* End of tclutil.c */ |