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