1 |
/* $Header$ */
|
2 |
/*
|
3 |
* tclResult.c --
|
4 |
*
|
5 |
* This file contains code to manage the interpreter result.
|
6 |
*
|
7 |
* Copyright (c) 1997 by Sun Microsystems, Inc.
|
8 |
*
|
9 |
* See the file "license.terms" for information on usage and redistribution
|
10 |
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
11 |
*
|
12 |
* RCS: @(#) $Id: tclresult.c,v 1.1.1.1 2001/06/13 04:45:53 dtashley Exp $
|
13 |
*/
|
14 |
|
15 |
#include "tclInt.h"
|
16 |
|
17 |
/*
|
18 |
* Function prototypes for local procedures in this file:
|
19 |
*/
|
20 |
|
21 |
static void ResetObjResult _ANSI_ARGS_((Interp *iPtr));
|
22 |
static void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr,
|
23 |
int newSpace));
|
24 |
|
25 |
|
26 |
/*
|
27 |
*----------------------------------------------------------------------
|
28 |
*
|
29 |
* Tcl_SaveResult --
|
30 |
*
|
31 |
* Takes a snapshot of the current result state of the interpreter.
|
32 |
* The snapshot can be restored at any point by
|
33 |
* Tcl_RestoreResult. Note that this routine does not
|
34 |
* preserve the errorCode, errorInfo, or flags fields so it
|
35 |
* should not be used if an error is in progress.
|
36 |
*
|
37 |
* Once a snapshot is saved, it must be restored by calling
|
38 |
* Tcl_RestoreResult, or discarded by calling
|
39 |
* Tcl_DiscardResult.
|
40 |
*
|
41 |
* Results:
|
42 |
* None.
|
43 |
*
|
44 |
* Side effects:
|
45 |
* Resets the interpreter result.
|
46 |
*
|
47 |
*----------------------------------------------------------------------
|
48 |
*/
|
49 |
|
50 |
void
|
51 |
Tcl_SaveResult(interp, statePtr)
|
52 |
Tcl_Interp *interp; /* Interpreter to save. */
|
53 |
Tcl_SavedResult *statePtr; /* Pointer to state structure. */
|
54 |
{
|
55 |
Interp *iPtr = (Interp *) interp;
|
56 |
|
57 |
/*
|
58 |
* Move the result object into the save state. Note that we don't need
|
59 |
* to change its refcount because we're moving it, not adding a new
|
60 |
* reference. Put an empty object into the interpreter.
|
61 |
*/
|
62 |
|
63 |
statePtr->objResultPtr = iPtr->objResultPtr;
|
64 |
iPtr->objResultPtr = Tcl_NewObj();
|
65 |
Tcl_IncrRefCount(iPtr->objResultPtr);
|
66 |
|
67 |
/*
|
68 |
* Save the string result.
|
69 |
*/
|
70 |
|
71 |
statePtr->freeProc = iPtr->freeProc;
|
72 |
if (iPtr->result == iPtr->resultSpace) {
|
73 |
/*
|
74 |
* Copy the static string data out of the interp buffer.
|
75 |
*/
|
76 |
|
77 |
statePtr->result = statePtr->resultSpace;
|
78 |
strcpy(statePtr->result, iPtr->result);
|
79 |
statePtr->appendResult = NULL;
|
80 |
} else if (iPtr->result == iPtr->appendResult) {
|
81 |
/*
|
82 |
* Move the append buffer out of the interp.
|
83 |
*/
|
84 |
|
85 |
statePtr->appendResult = iPtr->appendResult;
|
86 |
statePtr->appendAvl = iPtr->appendAvl;
|
87 |
statePtr->appendUsed = iPtr->appendUsed;
|
88 |
statePtr->result = statePtr->appendResult;
|
89 |
iPtr->appendResult = NULL;
|
90 |
iPtr->appendAvl = 0;
|
91 |
iPtr->appendUsed = 0;
|
92 |
} else {
|
93 |
/*
|
94 |
* Move the dynamic or static string out of the interpreter.
|
95 |
*/
|
96 |
|
97 |
statePtr->result = iPtr->result;
|
98 |
statePtr->appendResult = NULL;
|
99 |
}
|
100 |
|
101 |
iPtr->result = iPtr->resultSpace;
|
102 |
iPtr->resultSpace[0] = 0;
|
103 |
iPtr->freeProc = 0;
|
104 |
}
|
105 |
|
106 |
/*
|
107 |
*----------------------------------------------------------------------
|
108 |
*
|
109 |
* Tcl_RestoreResult --
|
110 |
*
|
111 |
* Restores the state of the interpreter to a snapshot taken
|
112 |
* by Tcl_SaveResult. After this call, the token for
|
113 |
* the interpreter state is no longer valid.
|
114 |
*
|
115 |
* Results:
|
116 |
* None.
|
117 |
*
|
118 |
* Side effects:
|
119 |
* Restores the interpreter result.
|
120 |
*
|
121 |
*----------------------------------------------------------------------
|
122 |
*/
|
123 |
|
124 |
void
|
125 |
Tcl_RestoreResult(interp, statePtr)
|
126 |
Tcl_Interp* interp; /* Interpreter being restored. */
|
127 |
Tcl_SavedResult *statePtr; /* State returned by Tcl_SaveResult. */
|
128 |
{
|
129 |
Interp *iPtr = (Interp *) interp;
|
130 |
|
131 |
Tcl_ResetResult(interp);
|
132 |
|
133 |
/*
|
134 |
* Restore the string result.
|
135 |
*/
|
136 |
|
137 |
iPtr->freeProc = statePtr->freeProc;
|
138 |
if (statePtr->result == statePtr->resultSpace) {
|
139 |
/*
|
140 |
* Copy the static string data into the interp buffer.
|
141 |
*/
|
142 |
|
143 |
iPtr->result = iPtr->resultSpace;
|
144 |
strcpy(iPtr->result, statePtr->result);
|
145 |
} else if (statePtr->result == statePtr->appendResult) {
|
146 |
/*
|
147 |
* Move the append buffer back into the interp.
|
148 |
*/
|
149 |
|
150 |
if (iPtr->appendResult != NULL) {
|
151 |
ckfree((char *)iPtr->appendResult);
|
152 |
}
|
153 |
|
154 |
iPtr->appendResult = statePtr->appendResult;
|
155 |
iPtr->appendAvl = statePtr->appendAvl;
|
156 |
iPtr->appendUsed = statePtr->appendUsed;
|
157 |
iPtr->result = iPtr->appendResult;
|
158 |
} else {
|
159 |
/*
|
160 |
* Move the dynamic or static string back into the interpreter.
|
161 |
*/
|
162 |
|
163 |
iPtr->result = statePtr->result;
|
164 |
}
|
165 |
|
166 |
/*
|
167 |
* Restore the object result.
|
168 |
*/
|
169 |
|
170 |
Tcl_DecrRefCount(iPtr->objResultPtr);
|
171 |
iPtr->objResultPtr = statePtr->objResultPtr;
|
172 |
}
|
173 |
|
174 |
/*
|
175 |
*----------------------------------------------------------------------
|
176 |
*
|
177 |
* Tcl_DiscardResult --
|
178 |
*
|
179 |
* Frees the memory associated with an interpreter snapshot
|
180 |
* taken by Tcl_SaveResult. If the snapshot is not
|
181 |
* restored, this procedure must be called to discard it,
|
182 |
* or the memory will be lost.
|
183 |
*
|
184 |
* Results:
|
185 |
* None.
|
186 |
*
|
187 |
* Side effects:
|
188 |
* None.
|
189 |
*
|
190 |
*----------------------------------------------------------------------
|
191 |
*/
|
192 |
|
193 |
void
|
194 |
Tcl_DiscardResult(statePtr)
|
195 |
Tcl_SavedResult *statePtr; /* State returned by Tcl_SaveResult. */
|
196 |
{
|
197 |
TclDecrRefCount(statePtr->objResultPtr);
|
198 |
|
199 |
if (statePtr->result == statePtr->appendResult) {
|
200 |
ckfree(statePtr->appendResult);
|
201 |
} else if (statePtr->freeProc) {
|
202 |
if ((statePtr->freeProc == TCL_DYNAMIC)
|
203 |
|| (statePtr->freeProc == (Tcl_FreeProc *) free)) {
|
204 |
ckfree(statePtr->result);
|
205 |
} else {
|
206 |
(*statePtr->freeProc)(statePtr->result);
|
207 |
}
|
208 |
}
|
209 |
}
|
210 |
|
211 |
/*
|
212 |
*----------------------------------------------------------------------
|
213 |
*
|
214 |
* Tcl_SetResult --
|
215 |
*
|
216 |
* Arrange for "string" to be the Tcl return value.
|
217 |
*
|
218 |
* Results:
|
219 |
* None.
|
220 |
*
|
221 |
* Side effects:
|
222 |
* interp->result is left pointing either to "string" (if "copy" is 0)
|
223 |
* or to a copy of string. Also, the object result is reset.
|
224 |
*
|
225 |
*----------------------------------------------------------------------
|
226 |
*/
|
227 |
|
228 |
void
|
229 |
Tcl_SetResult(interp, string, freeProc)
|
230 |
Tcl_Interp *interp; /* Interpreter with which to associate the
|
231 |
* return value. */
|
232 |
register char *string; /* Value to be returned. If NULL, the
|
233 |
* result is set to an empty string. */
|
234 |
Tcl_FreeProc *freeProc; /* Gives information about the string:
|
235 |
* TCL_STATIC, TCL_VOLATILE, or the address
|
236 |
* of a Tcl_FreeProc such as free. */
|
237 |
{
|
238 |
Interp *iPtr = (Interp *) interp;
|
239 |
int length;
|
240 |
register Tcl_FreeProc *oldFreeProc = iPtr->freeProc;
|
241 |
char *oldResult = iPtr->result;
|
242 |
|
243 |
if (string == NULL) {
|
244 |
iPtr->resultSpace[0] = 0;
|
245 |
iPtr->result = iPtr->resultSpace;
|
246 |
iPtr->freeProc = 0;
|
247 |
} else if (freeProc == TCL_VOLATILE) {
|
248 |
length = strlen(string);
|
249 |
if (length > TCL_RESULT_SIZE) {
|
250 |
iPtr->result = (char *) ckalloc((unsigned) length+1);
|
251 |
iPtr->freeProc = TCL_DYNAMIC;
|
252 |
} else {
|
253 |
iPtr->result = iPtr->resultSpace;
|
254 |
iPtr->freeProc = 0;
|
255 |
}
|
256 |
strcpy(iPtr->result, string);
|
257 |
} else {
|
258 |
iPtr->result = string;
|
259 |
iPtr->freeProc = freeProc;
|
260 |
}
|
261 |
|
262 |
/*
|
263 |
* If the old result was dynamically-allocated, free it up. Do it
|
264 |
* here, rather than at the beginning, in case the new result value
|
265 |
* was part of the old result value.
|
266 |
*/
|
267 |
|
268 |
if (oldFreeProc != 0) {
|
269 |
if ((oldFreeProc == TCL_DYNAMIC)
|
270 |
|| (oldFreeProc == (Tcl_FreeProc *) free)) {
|
271 |
ckfree(oldResult);
|
272 |
} else {
|
273 |
(*oldFreeProc)(oldResult);
|
274 |
}
|
275 |
}
|
276 |
|
277 |
/*
|
278 |
* Reset the object result since we just set the string result.
|
279 |
*/
|
280 |
|
281 |
ResetObjResult(iPtr);
|
282 |
}
|
283 |
|
284 |
/*
|
285 |
*----------------------------------------------------------------------
|
286 |
*
|
287 |
* Tcl_GetStringResult --
|
288 |
*
|
289 |
* Returns an interpreter's result value as a string.
|
290 |
*
|
291 |
* Results:
|
292 |
* The interpreter's result as a string.
|
293 |
*
|
294 |
* Side effects:
|
295 |
* If the string result is empty, the object result is moved to the
|
296 |
* string result, then the object result is reset.
|
297 |
*
|
298 |
*----------------------------------------------------------------------
|
299 |
*/
|
300 |
|
301 |
char *
|
302 |
Tcl_GetStringResult(interp)
|
303 |
register Tcl_Interp *interp; /* Interpreter whose result to return. */
|
304 |
{
|
305 |
/*
|
306 |
* If the string result is empty, move the object result to the
|
307 |
* string result, then reset the object result.
|
308 |
*/
|
309 |
|
310 |
if (*(interp->result) == 0) {
|
311 |
Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
|
312 |
TCL_VOLATILE);
|
313 |
}
|
314 |
return interp->result;
|
315 |
}
|
316 |
|
317 |
/*
|
318 |
*----------------------------------------------------------------------
|
319 |
*
|
320 |
* Tcl_SetObjResult --
|
321 |
*
|
322 |
* Arrange for objPtr to be an interpreter's result value.
|
323 |
*
|
324 |
* Results:
|
325 |
* None.
|
326 |
*
|
327 |
* Side effects:
|
328 |
* interp->objResultPtr is left pointing to the object referenced
|
329 |
* by objPtr. The object's reference count is incremented since
|
330 |
* there is now a new reference to it. The reference count for any
|
331 |
* old objResultPtr value is decremented. Also, the string result
|
332 |
* is reset.
|
333 |
*
|
334 |
*----------------------------------------------------------------------
|
335 |
*/
|
336 |
|
337 |
void
|
338 |
Tcl_SetObjResult(interp, objPtr)
|
339 |
Tcl_Interp *interp; /* Interpreter with which to associate the
|
340 |
* return object value. */
|
341 |
register Tcl_Obj *objPtr; /* Tcl object to be returned. If NULL, the
|
342 |
* obj result is made an empty string
|
343 |
* object. */
|
344 |
{
|
345 |
register Interp *iPtr = (Interp *) interp;
|
346 |
register Tcl_Obj *oldObjResult = iPtr->objResultPtr;
|
347 |
|
348 |
iPtr->objResultPtr = objPtr;
|
349 |
Tcl_IncrRefCount(objPtr); /* since interp result is a reference */
|
350 |
|
351 |
/*
|
352 |
* We wait until the end to release the old object result, in case
|
353 |
* we are setting the result to itself.
|
354 |
*/
|
355 |
|
356 |
TclDecrRefCount(oldObjResult);
|
357 |
|
358 |
/*
|
359 |
* Reset the string result since we just set the result object.
|
360 |
*/
|
361 |
|
362 |
if (iPtr->freeProc != NULL) {
|
363 |
if ((iPtr->freeProc == TCL_DYNAMIC)
|
364 |
|| (iPtr->freeProc == (Tcl_FreeProc *) free)) {
|
365 |
ckfree(iPtr->result);
|
366 |
} else {
|
367 |
(*iPtr->freeProc)(iPtr->result);
|
368 |
}
|
369 |
iPtr->freeProc = 0;
|
370 |
}
|
371 |
iPtr->result = iPtr->resultSpace;
|
372 |
iPtr->resultSpace[0] = 0;
|
373 |
}
|
374 |
|
375 |
/*
|
376 |
*----------------------------------------------------------------------
|
377 |
*
|
378 |
* Tcl_GetObjResult --
|
379 |
*
|
380 |
* Returns an interpreter's result value as a Tcl object. The object's
|
381 |
* reference count is not modified; the caller must do that if it
|
382 |
* needs to hold on to a long-term reference to it.
|
383 |
*
|
384 |
* Results:
|
385 |
* The interpreter's result as an object.
|
386 |
*
|
387 |
* Side effects:
|
388 |
* If the interpreter has a non-empty string result, the result object
|
389 |
* is either empty or stale because some procedure set interp->result
|
390 |
* directly. If so, the string result is moved to the result object
|
391 |
* then the string result is reset.
|
392 |
*
|
393 |
*----------------------------------------------------------------------
|
394 |
*/
|
395 |
|
396 |
Tcl_Obj *
|
397 |
Tcl_GetObjResult(interp)
|
398 |
Tcl_Interp *interp; /* Interpreter whose result to return. */
|
399 |
{
|
400 |
register Interp *iPtr = (Interp *) interp;
|
401 |
Tcl_Obj *objResultPtr;
|
402 |
int length;
|
403 |
|
404 |
/*
|
405 |
* If the string result is non-empty, move the string result to the
|
406 |
* object result, then reset the string result.
|
407 |
*/
|
408 |
|
409 |
if (*(iPtr->result) != 0) {
|
410 |
ResetObjResult(iPtr);
|
411 |
|
412 |
objResultPtr = iPtr->objResultPtr;
|
413 |
length = strlen(iPtr->result);
|
414 |
TclInitStringRep(objResultPtr, iPtr->result, length);
|
415 |
|
416 |
if (iPtr->freeProc != NULL) {
|
417 |
if ((iPtr->freeProc == TCL_DYNAMIC)
|
418 |
|| (iPtr->freeProc == (Tcl_FreeProc *) free)) {
|
419 |
ckfree(iPtr->result);
|
420 |
} else {
|
421 |
(*iPtr->freeProc)(iPtr->result);
|
422 |
}
|
423 |
iPtr->freeProc = 0;
|
424 |
}
|
425 |
iPtr->result = iPtr->resultSpace;
|
426 |
iPtr->resultSpace[0] = 0;
|
427 |
}
|
428 |
return iPtr->objResultPtr;
|
429 |
}
|
430 |
|
431 |
/*
|
432 |
*----------------------------------------------------------------------
|
433 |
*
|
434 |
* Tcl_AppendResultVA --
|
435 |
*
|
436 |
* Append a variable number of strings onto the interpreter's string
|
437 |
* result.
|
438 |
*
|
439 |
* Results:
|
440 |
* None.
|
441 |
*
|
442 |
* Side effects:
|
443 |
* The result of the interpreter given by the first argument is
|
444 |
* extended by the strings in the va_list (up to a terminating NULL
|
445 |
* argument).
|
446 |
*
|
447 |
* If the string result is empty, the object result is moved to the
|
448 |
* string result, then the object result is reset.
|
449 |
*
|
450 |
*----------------------------------------------------------------------
|
451 |
*/
|
452 |
|
453 |
void
|
454 |
Tcl_AppendResultVA (interp, argList)
|
455 |
Tcl_Interp *interp; /* Interpreter with which to associate the
|
456 |
* return value. */
|
457 |
va_list argList; /* Variable argument list. */
|
458 |
{
|
459 |
#define STATIC_LIST_SIZE 16
|
460 |
Interp *iPtr = (Interp *) interp;
|
461 |
char *string, *static_list[STATIC_LIST_SIZE];
|
462 |
char **args = static_list;
|
463 |
int nargs_space = STATIC_LIST_SIZE;
|
464 |
int nargs, newSpace, i;
|
465 |
|
466 |
/*
|
467 |
* If the string result is empty, move the object result to the
|
468 |
* string result, then reset the object result.
|
469 |
*/
|
470 |
|
471 |
if (*(iPtr->result) == 0) {
|
472 |
Tcl_SetResult((Tcl_Interp *) iPtr,
|
473 |
TclGetString(Tcl_GetObjResult((Tcl_Interp *) iPtr)),
|
474 |
TCL_VOLATILE);
|
475 |
}
|
476 |
|
477 |
/*
|
478 |
* Scan through all the arguments to see how much space is needed
|
479 |
* and save pointers to the arguments in the args array,
|
480 |
* reallocating as necessary.
|
481 |
*/
|
482 |
|
483 |
nargs = 0;
|
484 |
newSpace = 0;
|
485 |
while (1) {
|
486 |
string = va_arg(argList, char *);
|
487 |
if (string == NULL) {
|
488 |
break;
|
489 |
}
|
490 |
if (nargs >= nargs_space) {
|
491 |
/*
|
492 |
* Expand the args buffer
|
493 |
*/
|
494 |
nargs_space += STATIC_LIST_SIZE;
|
495 |
if (args == static_list) {
|
496 |
args = (void *)ckalloc(nargs_space * sizeof(char *));
|
497 |
for (i = 0; i < nargs; ++i) {
|
498 |
args[i] = static_list[i];
|
499 |
}
|
500 |
} else {
|
501 |
args = (void *)ckrealloc((void *)args,
|
502 |
nargs_space * sizeof(char *));
|
503 |
}
|
504 |
}
|
505 |
newSpace += strlen(string);
|
506 |
args[nargs++] = string;
|
507 |
}
|
508 |
|
509 |
/*
|
510 |
* If the append buffer isn't already setup and large enough to hold
|
511 |
* the new data, set it up.
|
512 |
*/
|
513 |
|
514 |
if ((iPtr->result != iPtr->appendResult)
|
515 |
|| (iPtr->appendResult[iPtr->appendUsed] != 0)
|
516 |
|| ((newSpace + iPtr->appendUsed) >= iPtr->appendAvl)) {
|
517 |
SetupAppendBuffer(iPtr, newSpace);
|
518 |
}
|
519 |
|
520 |
/*
|
521 |
* Now go through all the argument strings again, copying them into the
|
522 |
* buffer.
|
523 |
*/
|
524 |
|
525 |
for (i = 0; i < nargs; ++i) {
|
526 |
string = args[i];
|
527 |
strcpy(iPtr->appendResult + iPtr->appendUsed, string);
|
528 |
iPtr->appendUsed += strlen(string);
|
529 |
}
|
530 |
|
531 |
/*
|
532 |
* If we had to allocate a buffer from the heap,
|
533 |
* free it now.
|
534 |
*/
|
535 |
|
536 |
if (args != static_list) {
|
537 |
ckfree((void *)args);
|
538 |
}
|
539 |
#undef STATIC_LIST_SIZE
|
540 |
}
|
541 |
|
542 |
/*
|
543 |
*----------------------------------------------------------------------
|
544 |
*
|
545 |
* Tcl_AppendResult --
|
546 |
*
|
547 |
* Append a variable number of strings onto the interpreter's string
|
548 |
* result.
|
549 |
*
|
550 |
* Results:
|
551 |
* None.
|
552 |
*
|
553 |
* Side effects:
|
554 |
* The result of the interpreter given by the first argument is
|
555 |
* extended by the strings given by the second and following arguments
|
556 |
* (up to a terminating NULL argument).
|
557 |
*
|
558 |
* If the string result is empty, the object result is moved to the
|
559 |
* string result, then the object result is reset.
|
560 |
*
|
561 |
*----------------------------------------------------------------------
|
562 |
*/
|
563 |
|
564 |
void
|
565 |
Tcl_AppendResult TCL_VARARGS_DEF(Tcl_Interp *,arg1)
|
566 |
{
|
567 |
Tcl_Interp *interp;
|
568 |
va_list argList;
|
569 |
|
570 |
interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
|
571 |
Tcl_AppendResultVA(interp, argList);
|
572 |
va_end(argList);
|
573 |
}
|
574 |
|
575 |
/*
|
576 |
*----------------------------------------------------------------------
|
577 |
*
|
578 |
* Tcl_AppendElement --
|
579 |
*
|
580 |
* Convert a string to a valid Tcl list element and append it to the
|
581 |
* result (which is ostensibly a list).
|
582 |
*
|
583 |
* Results:
|
584 |
* None.
|
585 |
*
|
586 |
* Side effects:
|
587 |
* The result in the interpreter given by the first argument is
|
588 |
* extended with a list element converted from string. A separator
|
589 |
* space is added before the converted list element unless the current
|
590 |
* result is empty, contains the single character "{", or ends in " {".
|
591 |
*
|
592 |
* If the string result is empty, the object result is moved to the
|
593 |
* string result, then the object result is reset.
|
594 |
*
|
595 |
*----------------------------------------------------------------------
|
596 |
*/
|
597 |
|
598 |
void
|
599 |
Tcl_AppendElement(interp, string)
|
600 |
Tcl_Interp *interp; /* Interpreter whose result is to be
|
601 |
* extended. */
|
602 |
CONST char *string; /* String to convert to list element and
|
603 |
* add to result. */
|
604 |
{
|
605 |
Interp *iPtr = (Interp *) interp;
|
606 |
char *dst;
|
607 |
int size;
|
608 |
int flags;
|
609 |
|
610 |
/*
|
611 |
* If the string result is empty, move the object result to the
|
612 |
* string result, then reset the object result.
|
613 |
*/
|
614 |
|
615 |
if (*(iPtr->result) == 0) {
|
616 |
Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
|
617 |
TCL_VOLATILE);
|
618 |
}
|
619 |
|
620 |
/*
|
621 |
* See how much space is needed, and grow the append buffer if
|
622 |
* needed to accommodate the list element.
|
623 |
*/
|
624 |
|
625 |
size = Tcl_ScanElement(string, &flags) + 1;
|
626 |
if ((iPtr->result != iPtr->appendResult)
|
627 |
|| (iPtr->appendResult[iPtr->appendUsed] != 0)
|
628 |
|| ((size + iPtr->appendUsed) >= iPtr->appendAvl)) {
|
629 |
SetupAppendBuffer(iPtr, size+iPtr->appendUsed);
|
630 |
}
|
631 |
|
632 |
/*
|
633 |
* Convert the string into a list element and copy it to the
|
634 |
* buffer that's forming, with a space separator if needed.
|
635 |
*/
|
636 |
|
637 |
dst = iPtr->appendResult + iPtr->appendUsed;
|
638 |
if (TclNeedSpace(iPtr->appendResult, dst)) {
|
639 |
iPtr->appendUsed++;
|
640 |
*dst = ' ';
|
641 |
dst++;
|
642 |
}
|
643 |
iPtr->appendUsed += Tcl_ConvertElement(string, dst, flags);
|
644 |
}
|
645 |
|
646 |
/*
|
647 |
*----------------------------------------------------------------------
|
648 |
*
|
649 |
* SetupAppendBuffer --
|
650 |
*
|
651 |
* This procedure makes sure that there is an append buffer properly
|
652 |
* initialized, if necessary, from the interpreter's result, and
|
653 |
* that it has at least enough room to accommodate newSpace new
|
654 |
* bytes of information.
|
655 |
*
|
656 |
* Results:
|
657 |
* None.
|
658 |
*
|
659 |
* Side effects:
|
660 |
* None.
|
661 |
*
|
662 |
*----------------------------------------------------------------------
|
663 |
*/
|
664 |
|
665 |
static void
|
666 |
SetupAppendBuffer(iPtr, newSpace)
|
667 |
Interp *iPtr; /* Interpreter whose result is being set up. */
|
668 |
int newSpace; /* Make sure that at least this many bytes
|
669 |
* of new information may be added. */
|
670 |
{
|
671 |
int totalSpace;
|
672 |
|
673 |
/*
|
674 |
* Make the append buffer larger, if that's necessary, then copy the
|
675 |
* result into the append buffer and make the append buffer the official
|
676 |
* Tcl result.
|
677 |
*/
|
678 |
|
679 |
if (iPtr->result != iPtr->appendResult) {
|
680 |
/*
|
681 |
* If an oversized buffer was used recently, then free it up
|
682 |
* so we go back to a smaller buffer. This avoids tying up
|
683 |
* memory forever after a large operation.
|
684 |
*/
|
685 |
|
686 |
if (iPtr->appendAvl > 500) {
|
687 |
ckfree(iPtr->appendResult);
|
688 |
iPtr->appendResult = NULL;
|
689 |
iPtr->appendAvl = 0;
|
690 |
}
|
691 |
iPtr->appendUsed = strlen(iPtr->result);
|
692 |
} else if (iPtr->result[iPtr->appendUsed] != 0) {
|
693 |
/*
|
694 |
* Most likely someone has modified a result created by
|
695 |
* Tcl_AppendResult et al. so that it has a different size.
|
696 |
* Just recompute the size.
|
697 |
*/
|
698 |
|
699 |
iPtr->appendUsed = strlen(iPtr->result);
|
700 |
}
|
701 |
|
702 |
totalSpace = newSpace + iPtr->appendUsed;
|
703 |
if (totalSpace >= iPtr->appendAvl) {
|
704 |
char *new;
|
705 |
|
706 |
if (totalSpace < 100) {
|
707 |
totalSpace = 200;
|
708 |
} else {
|
709 |
totalSpace *= 2;
|
710 |
}
|
711 |
new = (char *) ckalloc((unsigned) totalSpace);
|
712 |
strcpy(new, iPtr->result);
|
713 |
if (iPtr->appendResult != NULL) {
|
714 |
ckfree(iPtr->appendResult);
|
715 |
}
|
716 |
iPtr->appendResult = new;
|
717 |
iPtr->appendAvl = totalSpace;
|
718 |
} else if (iPtr->result != iPtr->appendResult) {
|
719 |
strcpy(iPtr->appendResult, iPtr->result);
|
720 |
}
|
721 |
|
722 |
Tcl_FreeResult((Tcl_Interp *) iPtr);
|
723 |
iPtr->result = iPtr->appendResult;
|
724 |
}
|
725 |
|
726 |
/*
|
727 |
*----------------------------------------------------------------------
|
728 |
*
|
729 |
* Tcl_FreeResult --
|
730 |
*
|
731 |
* This procedure frees up the memory associated with an interpreter's
|
732 |
* string result. It also resets the interpreter's result object.
|
733 |
* Tcl_FreeResult is most commonly used when a procedure is about to
|
734 |
* replace one result value with another.
|
735 |
*
|
736 |
* Results:
|
737 |
* None.
|
738 |
*
|
739 |
* Side effects:
|
740 |
* Frees the memory associated with interp's string result and sets
|
741 |
* interp->freeProc to zero, but does not change interp->result or
|
742 |
* clear error state. Resets interp's result object to an unshared
|
743 |
* empty object.
|
744 |
*
|
745 |
*----------------------------------------------------------------------
|
746 |
*/
|
747 |
|
748 |
void
|
749 |
Tcl_FreeResult(interp)
|
750 |
register Tcl_Interp *interp; /* Interpreter for which to free result. */
|
751 |
{
|
752 |
register Interp *iPtr = (Interp *) interp;
|
753 |
|
754 |
if (iPtr->freeProc != NULL) {
|
755 |
if ((iPtr->freeProc == TCL_DYNAMIC)
|
756 |
|| (iPtr->freeProc == (Tcl_FreeProc *) free)) {
|
757 |
ckfree(iPtr->result);
|
758 |
} else {
|
759 |
(*iPtr->freeProc)(iPtr->result);
|
760 |
}
|
761 |
iPtr->freeProc = 0;
|
762 |
}
|
763 |
|
764 |
ResetObjResult(iPtr);
|
765 |
}
|
766 |
|
767 |
/*
|
768 |
*----------------------------------------------------------------------
|
769 |
*
|
770 |
* Tcl_ResetResult --
|
771 |
*
|
772 |
* This procedure resets both the interpreter's string and object
|
773 |
* results.
|
774 |
*
|
775 |
* Results:
|
776 |
* None.
|
777 |
*
|
778 |
* Side effects:
|
779 |
* It resets the result object to an unshared empty object. It
|
780 |
* then restores the interpreter's string result area to its default
|
781 |
* initialized state, freeing up any memory that may have been
|
782 |
* allocated. It also clears any error information for the interpreter.
|
783 |
*
|
784 |
*----------------------------------------------------------------------
|
785 |
*/
|
786 |
|
787 |
void
|
788 |
Tcl_ResetResult(interp)
|
789 |
register Tcl_Interp *interp; /* Interpreter for which to clear result. */
|
790 |
{
|
791 |
register Interp *iPtr = (Interp *) interp;
|
792 |
|
793 |
ResetObjResult(iPtr);
|
794 |
if (iPtr->freeProc != NULL) {
|
795 |
if ((iPtr->freeProc == TCL_DYNAMIC)
|
796 |
|| (iPtr->freeProc == (Tcl_FreeProc *) free)) {
|
797 |
ckfree(iPtr->result);
|
798 |
} else {
|
799 |
(*iPtr->freeProc)(iPtr->result);
|
800 |
}
|
801 |
iPtr->freeProc = 0;
|
802 |
}
|
803 |
iPtr->result = iPtr->resultSpace;
|
804 |
iPtr->resultSpace[0] = 0;
|
805 |
iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS | ERROR_CODE_SET);
|
806 |
}
|
807 |
|
808 |
/*
|
809 |
*----------------------------------------------------------------------
|
810 |
*
|
811 |
* ResetObjResult --
|
812 |
*
|
813 |
* Procedure used to reset an interpreter's Tcl result object.
|
814 |
*
|
815 |
* Results:
|
816 |
* None.
|
817 |
*
|
818 |
* Side effects:
|
819 |
* Resets the interpreter's result object to an unshared empty string
|
820 |
* object with ref count one. It does not clear any error information
|
821 |
* in the interpreter.
|
822 |
*
|
823 |
*----------------------------------------------------------------------
|
824 |
*/
|
825 |
|
826 |
static void
|
827 |
ResetObjResult(iPtr)
|
828 |
register Interp *iPtr; /* Points to the interpreter whose result
|
829 |
* object should be reset. */
|
830 |
{
|
831 |
register Tcl_Obj *objResultPtr = iPtr->objResultPtr;
|
832 |
|
833 |
if (Tcl_IsShared(objResultPtr)) {
|
834 |
TclDecrRefCount(objResultPtr);
|
835 |
TclNewObj(objResultPtr);
|
836 |
Tcl_IncrRefCount(objResultPtr);
|
837 |
iPtr->objResultPtr = objResultPtr;
|
838 |
} else {
|
839 |
if ((objResultPtr->bytes != NULL)
|
840 |
&& (objResultPtr->bytes != tclEmptyStringRep)) {
|
841 |
ckfree((char *) objResultPtr->bytes);
|
842 |
}
|
843 |
objResultPtr->bytes = tclEmptyStringRep;
|
844 |
objResultPtr->length = 0;
|
845 |
if ((objResultPtr->typePtr != NULL)
|
846 |
&& (objResultPtr->typePtr->freeIntRepProc != NULL)) {
|
847 |
objResultPtr->typePtr->freeIntRepProc(objResultPtr);
|
848 |
}
|
849 |
objResultPtr->typePtr = (Tcl_ObjType *) NULL;
|
850 |
}
|
851 |
}
|
852 |
|
853 |
/*
|
854 |
*----------------------------------------------------------------------
|
855 |
*
|
856 |
* Tcl_SetErrorCodeVA --
|
857 |
*
|
858 |
* This procedure is called to record machine-readable information
|
859 |
* about an error that is about to be returned.
|
860 |
*
|
861 |
* Results:
|
862 |
* None.
|
863 |
*
|
864 |
* Side effects:
|
865 |
* The errorCode global variable is modified to hold all of the
|
866 |
* arguments to this procedure, in a list form with each argument
|
867 |
* becoming one element of the list. A flag is set internally
|
868 |
* to remember that errorCode has been set, so the variable doesn't
|
869 |
* get set automatically when the error is returned.
|
870 |
*
|
871 |
*----------------------------------------------------------------------
|
872 |
*/
|
873 |
|
874 |
void
|
875 |
Tcl_SetErrorCodeVA (interp, argList)
|
876 |
Tcl_Interp *interp; /* Interpreter in which to access the errorCode
|
877 |
* variable. */
|
878 |
va_list argList; /* Variable argument list. */
|
879 |
{
|
880 |
char *string;
|
881 |
int flags;
|
882 |
Interp *iPtr = (Interp *) interp;
|
883 |
|
884 |
/*
|
885 |
* Scan through the arguments one at a time, appending them to
|
886 |
* $errorCode as list elements.
|
887 |
*/
|
888 |
|
889 |
flags = TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT;
|
890 |
while (1) {
|
891 |
string = va_arg(argList, char *);
|
892 |
if (string == NULL) {
|
893 |
break;
|
894 |
}
|
895 |
(void) Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode",
|
896 |
(char *) NULL, string, flags);
|
897 |
flags |= TCL_APPEND_VALUE;
|
898 |
}
|
899 |
iPtr->flags |= ERROR_CODE_SET;
|
900 |
}
|
901 |
|
902 |
/*
|
903 |
*----------------------------------------------------------------------
|
904 |
*
|
905 |
* Tcl_SetErrorCode --
|
906 |
*
|
907 |
* This procedure is called to record machine-readable information
|
908 |
* about an error that is about to be returned.
|
909 |
*
|
910 |
* Results:
|
911 |
* None.
|
912 |
*
|
913 |
* Side effects:
|
914 |
* The errorCode global variable is modified to hold all of the
|
915 |
* arguments to this procedure, in a list form with each argument
|
916 |
* becoming one element of the list. A flag is set internally
|
917 |
* to remember that errorCode has been set, so the variable doesn't
|
918 |
* get set automatically when the error is returned.
|
919 |
*
|
920 |
*----------------------------------------------------------------------
|
921 |
*/
|
922 |
/* VARARGS2 */
|
923 |
void
|
924 |
Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1)
|
925 |
{
|
926 |
Tcl_Interp *interp;
|
927 |
va_list argList;
|
928 |
|
929 |
/*
|
930 |
* Scan through the arguments one at a time, appending them to
|
931 |
* $errorCode as list elements.
|
932 |
*/
|
933 |
|
934 |
interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
|
935 |
Tcl_SetErrorCodeVA(interp, argList);
|
936 |
va_end(argList);
|
937 |
}
|
938 |
|
939 |
/*
|
940 |
*----------------------------------------------------------------------
|
941 |
*
|
942 |
* Tcl_SetObjErrorCode --
|
943 |
*
|
944 |
* This procedure is called to record machine-readable information
|
945 |
* about an error that is about to be returned. The caller should
|
946 |
* build a list object up and pass it to this routine.
|
947 |
*
|
948 |
* Results:
|
949 |
* None.
|
950 |
*
|
951 |
* Side effects:
|
952 |
* The errorCode global variable is modified to be the new value.
|
953 |
* A flag is set internally to remember that errorCode has been
|
954 |
* set, so the variable doesn't get set automatically when the
|
955 |
* error is returned.
|
956 |
*
|
957 |
*----------------------------------------------------------------------
|
958 |
*/
|
959 |
|
960 |
void
|
961 |
Tcl_SetObjErrorCode(interp, errorObjPtr)
|
962 |
Tcl_Interp *interp;
|
963 |
Tcl_Obj *errorObjPtr;
|
964 |
{
|
965 |
Interp *iPtr;
|
966 |
|
967 |
iPtr = (Interp *) interp;
|
968 |
Tcl_SetVar2Ex(interp, "errorCode", NULL, errorObjPtr, TCL_GLOBAL_ONLY);
|
969 |
iPtr->flags |= ERROR_CODE_SET;
|
970 |
}
|
971 |
|
972 |
/*
|
973 |
*-------------------------------------------------------------------------
|
974 |
*
|
975 |
* TclTransferResult --
|
976 |
*
|
977 |
* Copy the result (and error information) from one interp to
|
978 |
* another. Used when one interp has caused another interp to
|
979 |
* evaluate a script and then wants to transfer the results back
|
980 |
* to itself.
|
981 |
*
|
982 |
* This routine copies the string reps of the result and error
|
983 |
* information. It does not simply increment the refcounts of the
|
984 |
* result and error information objects themselves.
|
985 |
* It is not legal to exchange objects between interps, because an
|
986 |
* object may be kept alive by one interp, but have an internal rep
|
987 |
* that is only valid while some other interp is alive.
|
988 |
*
|
989 |
* Results:
|
990 |
* The target interp's result is set to a copy of the source interp's
|
991 |
* result. The source's error information "$errorInfo" may be
|
992 |
* appended to the target's error information and the source's error
|
993 |
* code "$errorCode" may be stored in the target's error code.
|
994 |
*
|
995 |
* Side effects:
|
996 |
* None.
|
997 |
*
|
998 |
*-------------------------------------------------------------------------
|
999 |
*/
|
1000 |
|
1001 |
void
|
1002 |
TclTransferResult(sourceInterp, result, targetInterp)
|
1003 |
Tcl_Interp *sourceInterp; /* Interp whose result and error information
|
1004 |
* should be moved to the target interp.
|
1005 |
* After moving result, this interp's result
|
1006 |
* is reset. */
|
1007 |
int result; /* TCL_OK if just the result should be copied,
|
1008 |
* TCL_ERROR if both the result and error
|
1009 |
* information should be copied. */
|
1010 |
Tcl_Interp *targetInterp; /* Interp where result and error information
|
1011 |
* should be stored. If source and target
|
1012 |
* are the same, nothing is done. */
|
1013 |
{
|
1014 |
Interp *iPtr;
|
1015 |
Tcl_Obj *objPtr;
|
1016 |
|
1017 |
if (sourceInterp == targetInterp) {
|
1018 |
return;
|
1019 |
}
|
1020 |
|
1021 |
if (result == TCL_ERROR) {
|
1022 |
/*
|
1023 |
* An error occurred, so transfer error information from the source
|
1024 |
* interpreter to the target interpreter. Setting the flags tells
|
1025 |
* the target interp that it has inherited a partial traceback
|
1026 |
* chain, not just a simple error message.
|
1027 |
*/
|
1028 |
|
1029 |
iPtr = (Interp *) sourceInterp;
|
1030 |
if ((iPtr->flags & ERR_ALREADY_LOGGED) == 0) {
|
1031 |
Tcl_AddErrorInfo(sourceInterp, "");
|
1032 |
}
|
1033 |
iPtr->flags &= ~(ERR_ALREADY_LOGGED);
|
1034 |
|
1035 |
Tcl_ResetResult(targetInterp);
|
1036 |
|
1037 |
objPtr = Tcl_GetVar2Ex(sourceInterp, "errorInfo", NULL,
|
1038 |
TCL_GLOBAL_ONLY);
|
1039 |
Tcl_SetVar2Ex(targetInterp, "errorInfo", NULL, objPtr,
|
1040 |
TCL_GLOBAL_ONLY);
|
1041 |
|
1042 |
objPtr = Tcl_GetVar2Ex(sourceInterp, "errorCode", NULL,
|
1043 |
TCL_GLOBAL_ONLY);
|
1044 |
Tcl_SetVar2Ex(targetInterp, "errorCode", NULL, objPtr,
|
1045 |
TCL_GLOBAL_ONLY);
|
1046 |
|
1047 |
((Interp *) targetInterp)->flags |= (ERR_IN_PROGRESS | ERROR_CODE_SET);
|
1048 |
}
|
1049 |
|
1050 |
((Interp *) targetInterp)->returnCode = ((Interp *) sourceInterp)->returnCode;
|
1051 |
Tcl_SetObjResult(targetInterp, Tcl_GetObjResult(sourceInterp));
|
1052 |
Tcl_ResetResult(sourceInterp);
|
1053 |
}
|
1054 |
|
1055 |
/* End of tclresult.c */
|