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