/*
|
/*
|
* tclUtil.c --
|
* tclUtil.c --
|
*
|
*
|
* This file contains utility procedures that are used by many Tcl
|
* This file contains utility procedures that are used by many Tcl
|
* commands.
|
* commands.
|
*
|
*
|
* Copyright (c) 1987-1993 The Regents of the University of California.
|
* Copyright (c) 1987-1993 The Regents of the University of California.
|
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
|
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
|
*
|
*
|
* See the file "license.terms" for information on usage and redistribution
|
* See the file "license.terms" for information on usage and redistribution
|
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
*
|
*
|
* RCS: @(#) $Id: tclUtil.c,v 1.1.1.1 2002-01-16 10:25:29 markom Exp $
|
* RCS: @(#) $Id: tclUtil.c,v 1.1.1.1 2002-01-16 10:25:29 markom Exp $
|
*/
|
*/
|
|
|
#include "tclInt.h"
|
#include "tclInt.h"
|
#include "tclPort.h"
|
#include "tclPort.h"
|
|
|
/*
|
/*
|
* The following variable holds the full path name of the binary
|
* The following variable holds the full path name of the binary
|
* from which this application was executed, or NULL if it isn't
|
* from which this application was executed, or NULL if it isn't
|
* know. The value of the variable is set by the procedure
|
* know. The value of the variable is set by the procedure
|
* Tcl_FindExecutable. The storage space is dynamically allocated.
|
* Tcl_FindExecutable. The storage space is dynamically allocated.
|
*/
|
*/
|
|
|
char *tclExecutableName = NULL;
|
char *tclExecutableName = NULL;
|
|
|
/*
|
/*
|
* The following values are used in the flags returned by Tcl_ScanElement
|
* The following values are used in the flags returned by Tcl_ScanElement
|
* and used by Tcl_ConvertElement. The value TCL_DONT_USE_BRACES is also
|
* and used by Tcl_ConvertElement. The value TCL_DONT_USE_BRACES is also
|
* defined in tcl.h; make sure its value doesn't overlap with any of the
|
* defined in tcl.h; make sure its value doesn't overlap with any of the
|
* values below.
|
* values below.
|
*
|
*
|
* TCL_DONT_USE_BRACES - 1 means the string mustn't be enclosed in
|
* TCL_DONT_USE_BRACES - 1 means the string mustn't be enclosed in
|
* braces (e.g. it contains unmatched braces,
|
* braces (e.g. it contains unmatched braces,
|
* or ends in a backslash character, or user
|
* or ends in a backslash character, or user
|
* just doesn't want braces); handle all
|
* just doesn't want braces); handle all
|
* special characters by adding backslashes.
|
* special characters by adding backslashes.
|
* USE_BRACES - 1 means the string contains a special
|
* USE_BRACES - 1 means the string contains a special
|
* character that can be handled simply by
|
* character that can be handled simply by
|
* enclosing the entire argument in braces.
|
* enclosing the entire argument in braces.
|
* BRACES_UNMATCHED - 1 means that braces aren't properly matched
|
* BRACES_UNMATCHED - 1 means that braces aren't properly matched
|
* in the argument.
|
* in the argument.
|
*/
|
*/
|
|
|
#define USE_BRACES 2
|
#define USE_BRACES 2
|
#define BRACES_UNMATCHED 4
|
#define BRACES_UNMATCHED 4
|
|
|
/*
|
/*
|
* The following values determine the precision used when converting
|
* The following values determine the precision used when converting
|
* floating-point values to strings. This information is linked to all
|
* floating-point values to strings. This information is linked to all
|
* of the tcl_precision variables in all interpreters via the procedure
|
* of the tcl_precision variables in all interpreters via the procedure
|
* TclPrecTraceProc.
|
* TclPrecTraceProc.
|
*
|
*
|
* NOTE: these variables are not thread-safe.
|
* NOTE: these variables are not thread-safe.
|
*/
|
*/
|
|
|
static char precisionString[10] = "12";
|
static char precisionString[10] = "12";
|
/* The string value of all the tcl_precision
|
/* The string value of all the tcl_precision
|
* variables. */
|
* variables. */
|
static char precisionFormat[10] = "%.12g";
|
static char precisionFormat[10] = "%.12g";
|
/* The format string actually used in calls
|
/* The format string actually used in calls
|
* to sprintf. */
|
* to sprintf. */
|
|
|
|
|
/*
|
/*
|
* Function prototypes for local procedures in this file:
|
* Function prototypes for local procedures in this file:
|
*/
|
*/
|
|
|
static void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr,
|
static void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr,
|
int newSpace));
|
int newSpace));
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* TclFindElement --
|
* TclFindElement --
|
*
|
*
|
* Given a pointer into a Tcl list, locate the first (or next)
|
* Given a pointer into a Tcl list, locate the first (or next)
|
* element in the list.
|
* element in the list.
|
*
|
*
|
* Results:
|
* Results:
|
* The return value is normally TCL_OK, which means that the
|
* The return value is normally TCL_OK, which means that the
|
* element was successfully located. If TCL_ERROR is returned
|
* element was successfully located. If TCL_ERROR is returned
|
* it means that list didn't have proper list structure;
|
* it means that list didn't have proper list structure;
|
* interp->result contains a more detailed error message.
|
* interp->result contains a more detailed error message.
|
*
|
*
|
* If TCL_OK is returned, then *elementPtr will be set to point to the
|
* If TCL_OK is returned, then *elementPtr will be set to point to the
|
* first element of list, and *nextPtr will be set to point to the
|
* first element of list, and *nextPtr will be set to point to the
|
* character just after any white space following the last character
|
* character just after any white space following the last character
|
* that's part of the element. If this is the last argument in the
|
* that's part of the element. If this is the last argument in the
|
* list, then *nextPtr will point just after the last character in the
|
* list, then *nextPtr will point just after the last character in the
|
* list (i.e., at the character at list+listLength). If sizePtr is
|
* list (i.e., at the character at list+listLength). If sizePtr is
|
* non-NULL, *sizePtr is filled in with the number of characters in the
|
* non-NULL, *sizePtr is filled in with the number of characters in the
|
* element. If the element is in braces, then *elementPtr will point
|
* element. If the element is in braces, then *elementPtr will point
|
* to the character after the opening brace and *sizePtr will not
|
* to the character after the opening brace and *sizePtr will not
|
* include either of the braces. If there isn't an element in the list,
|
* include either of the braces. If there isn't an element in the list,
|
* *sizePtr will be zero, and both *elementPtr and *termPtr will point
|
* *sizePtr will be zero, and both *elementPtr and *termPtr will point
|
* just after the last character in the list. Note: this procedure does
|
* just after the last character in the list. Note: this procedure does
|
* NOT collapse backslash sequences.
|
* NOT collapse backslash sequences.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr,
|
TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr,
|
bracePtr)
|
bracePtr)
|
Tcl_Interp *interp; /* Interpreter to use for error reporting.
|
Tcl_Interp *interp; /* Interpreter to use for error reporting.
|
* If NULL, then no error message is left
|
* If NULL, then no error message is left
|
* after errors. */
|
* after errors. */
|
char *list; /* Points to the first byte of a string
|
char *list; /* Points to the first byte of a string
|
* containing a Tcl list with zero or more
|
* containing a Tcl list with zero or more
|
* elements (possibly in braces). */
|
* elements (possibly in braces). */
|
int listLength; /* Number of bytes in the list's string. */
|
int listLength; /* Number of bytes in the list's string. */
|
char **elementPtr; /* Where to put address of first significant
|
char **elementPtr; /* Where to put address of first significant
|
* character in first element of list. */
|
* character in first element of list. */
|
char **nextPtr; /* Fill in with location of character just
|
char **nextPtr; /* Fill in with location of character just
|
* after all white space following end of
|
* after all white space following end of
|
* argument (next arg or end of list). */
|
* argument (next arg or end of list). */
|
int *sizePtr; /* If non-zero, fill in with size of
|
int *sizePtr; /* If non-zero, fill in with size of
|
* element. */
|
* element. */
|
int *bracePtr; /* If non-zero, fill in with non-zero/zero
|
int *bracePtr; /* If non-zero, fill in with non-zero/zero
|
* to indicate that arg was/wasn't
|
* to indicate that arg was/wasn't
|
* in braces. */
|
* in braces. */
|
{
|
{
|
char *p = list;
|
char *p = list;
|
char *elemStart; /* Points to first byte of first element. */
|
char *elemStart; /* Points to first byte of first element. */
|
char *limit; /* Points just after list's last byte. */
|
char *limit; /* Points just after list's last byte. */
|
int openBraces = 0; /* Brace nesting level during parse. */
|
int openBraces = 0; /* Brace nesting level during parse. */
|
int inQuotes = 0;
|
int inQuotes = 0;
|
int size = 0; /* Init. avoids compiler warning. */
|
int size = 0; /* Init. avoids compiler warning. */
|
int numChars;
|
int numChars;
|
char *p2;
|
char *p2;
|
|
|
/*
|
/*
|
* Skim off leading white space and check for an opening brace or
|
* Skim off leading white space and check for an opening brace or
|
* quote. We treat embedded NULLs in the list as bytes belonging to
|
* quote. We treat embedded NULLs in the list as bytes belonging to
|
* a list element. Note: use of "isascii" below and elsewhere in this
|
* a list element. Note: use of "isascii" below and elsewhere in this
|
* procedure is a temporary hack (7/27/90) because Mx uses characters
|
* procedure is a temporary hack (7/27/90) because Mx uses characters
|
* with the high-order bit set for some things. This should probably
|
* with the high-order bit set for some things. This should probably
|
* be changed back eventually, or all of Tcl should call isascii.
|
* be changed back eventually, or all of Tcl should call isascii.
|
*/
|
*/
|
|
|
limit = (list + listLength);
|
limit = (list + listLength);
|
while ((p < limit) && (isspace(UCHAR(*p)))) {
|
while ((p < limit) && (isspace(UCHAR(*p)))) {
|
p++;
|
p++;
|
}
|
}
|
if (p == limit) { /* no element found */
|
if (p == limit) { /* no element found */
|
elemStart = limit;
|
elemStart = limit;
|
goto done;
|
goto done;
|
}
|
}
|
|
|
if (*p == '{') {
|
if (*p == '{') {
|
openBraces = 1;
|
openBraces = 1;
|
p++;
|
p++;
|
} else if (*p == '"') {
|
} else if (*p == '"') {
|
inQuotes = 1;
|
inQuotes = 1;
|
p++;
|
p++;
|
}
|
}
|
elemStart = p;
|
elemStart = p;
|
if (bracePtr != 0) {
|
if (bracePtr != 0) {
|
*bracePtr = openBraces;
|
*bracePtr = openBraces;
|
}
|
}
|
|
|
/*
|
/*
|
* Find element's end (a space, close brace, or the end of the string).
|
* Find element's end (a space, close brace, or the end of the string).
|
*/
|
*/
|
|
|
while (p < limit) {
|
while (p < limit) {
|
switch (*p) {
|
switch (*p) {
|
|
|
/*
|
/*
|
* Open brace: don't treat specially unless the element is in
|
* Open brace: don't treat specially unless the element is in
|
* braces. In this case, keep a nesting count.
|
* braces. In this case, keep a nesting count.
|
*/
|
*/
|
|
|
case '{':
|
case '{':
|
if (openBraces != 0) {
|
if (openBraces != 0) {
|
openBraces++;
|
openBraces++;
|
}
|
}
|
break;
|
break;
|
|
|
/*
|
/*
|
* Close brace: if element is in braces, keep nesting count and
|
* Close brace: if element is in braces, keep nesting count and
|
* quit when the last close brace is seen.
|
* quit when the last close brace is seen.
|
*/
|
*/
|
|
|
case '}':
|
case '}':
|
if (openBraces > 1) {
|
if (openBraces > 1) {
|
openBraces--;
|
openBraces--;
|
} else if (openBraces == 1) {
|
} else if (openBraces == 1) {
|
size = (p - elemStart);
|
size = (p - elemStart);
|
p++;
|
p++;
|
if ((p >= limit) || isspace(UCHAR(*p))) {
|
if ((p >= limit) || isspace(UCHAR(*p))) {
|
goto done;
|
goto done;
|
}
|
}
|
|
|
/*
|
/*
|
* Garbage after the closing brace; return an error.
|
* Garbage after the closing brace; return an error.
|
*/
|
*/
|
|
|
if (interp != NULL) {
|
if (interp != NULL) {
|
char buf[100];
|
char buf[100];
|
|
|
p2 = p;
|
p2 = p;
|
while ((p2 < limit) && (!isspace(UCHAR(*p2)))
|
while ((p2 < limit) && (!isspace(UCHAR(*p2)))
|
&& (p2 < p+20)) {
|
&& (p2 < p+20)) {
|
p2++;
|
p2++;
|
}
|
}
|
sprintf(buf,
|
sprintf(buf,
|
"list element in braces followed by \"%.*s\" instead of space",
|
"list element in braces followed by \"%.*s\" instead of space",
|
(int) (p2-p), p);
|
(int) (p2-p), p);
|
Tcl_SetResult(interp, buf, TCL_VOLATILE);
|
Tcl_SetResult(interp, buf, TCL_VOLATILE);
|
}
|
}
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
break;
|
break;
|
|
|
/*
|
/*
|
* Backslash: skip over everything up to the end of the
|
* Backslash: skip over everything up to the end of the
|
* backslash sequence.
|
* backslash sequence.
|
*/
|
*/
|
|
|
case '\\': {
|
case '\\': {
|
(void) Tcl_Backslash(p, &numChars);
|
(void) Tcl_Backslash(p, &numChars);
|
p += (numChars - 1);
|
p += (numChars - 1);
|
break;
|
break;
|
}
|
}
|
|
|
/*
|
/*
|
* Space: ignore if element is in braces or quotes; otherwise
|
* Space: ignore if element is in braces or quotes; otherwise
|
* terminate element.
|
* terminate element.
|
*/
|
*/
|
|
|
case ' ':
|
case ' ':
|
case '\f':
|
case '\f':
|
case '\n':
|
case '\n':
|
case '\r':
|
case '\r':
|
case '\t':
|
case '\t':
|
case '\v':
|
case '\v':
|
if ((openBraces == 0) && !inQuotes) {
|
if ((openBraces == 0) && !inQuotes) {
|
size = (p - elemStart);
|
size = (p - elemStart);
|
goto done;
|
goto done;
|
}
|
}
|
break;
|
break;
|
|
|
/*
|
/*
|
* Double-quote: if element is in quotes then terminate it.
|
* Double-quote: if element is in quotes then terminate it.
|
*/
|
*/
|
|
|
case '"':
|
case '"':
|
if (inQuotes) {
|
if (inQuotes) {
|
size = (p - elemStart);
|
size = (p - elemStart);
|
p++;
|
p++;
|
if ((p >= limit) || isspace(UCHAR(*p))) {
|
if ((p >= limit) || isspace(UCHAR(*p))) {
|
goto done;
|
goto done;
|
}
|
}
|
|
|
/*
|
/*
|
* Garbage after the closing quote; return an error.
|
* Garbage after the closing quote; return an error.
|
*/
|
*/
|
|
|
if (interp != NULL) {
|
if (interp != NULL) {
|
char buf[100];
|
char buf[100];
|
|
|
p2 = p;
|
p2 = p;
|
while ((p2 < limit) && (!isspace(UCHAR(*p2)))
|
while ((p2 < limit) && (!isspace(UCHAR(*p2)))
|
&& (p2 < p+20)) {
|
&& (p2 < p+20)) {
|
p2++;
|
p2++;
|
}
|
}
|
sprintf(buf,
|
sprintf(buf,
|
"list element in quotes followed by \"%.*s\" %s",
|
"list element in quotes followed by \"%.*s\" %s",
|
(int) (p2-p), p, "instead of space");
|
(int) (p2-p), p, "instead of space");
|
Tcl_SetResult(interp, buf, TCL_VOLATILE);
|
Tcl_SetResult(interp, buf, TCL_VOLATILE);
|
}
|
}
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
break;
|
break;
|
}
|
}
|
p++;
|
p++;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* End of list: terminate element.
|
* End of list: terminate element.
|
*/
|
*/
|
|
|
if (p == limit) {
|
if (p == limit) {
|
if (openBraces != 0) {
|
if (openBraces != 0) {
|
if (interp != NULL) {
|
if (interp != NULL) {
|
Tcl_SetResult(interp, "unmatched open brace in list",
|
Tcl_SetResult(interp, "unmatched open brace in list",
|
TCL_STATIC);
|
TCL_STATIC);
|
}
|
}
|
return TCL_ERROR;
|
return TCL_ERROR;
|
} else if (inQuotes) {
|
} else if (inQuotes) {
|
if (interp != NULL) {
|
if (interp != NULL) {
|
Tcl_SetResult(interp, "unmatched open quote in list",
|
Tcl_SetResult(interp, "unmatched open quote in list",
|
TCL_STATIC);
|
TCL_STATIC);
|
}
|
}
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
size = (p - elemStart);
|
size = (p - elemStart);
|
}
|
}
|
|
|
done:
|
done:
|
while ((p < limit) && (isspace(UCHAR(*p)))) {
|
while ((p < limit) && (isspace(UCHAR(*p)))) {
|
p++;
|
p++;
|
}
|
}
|
*elementPtr = elemStart;
|
*elementPtr = elemStart;
|
*nextPtr = p;
|
*nextPtr = p;
|
if (sizePtr != 0) {
|
if (sizePtr != 0) {
|
*sizePtr = size;
|
*sizePtr = size;
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* TclCopyAndCollapse --
|
* TclCopyAndCollapse --
|
*
|
*
|
* Copy a string and eliminate any backslashes that aren't in braces.
|
* Copy a string and eliminate any backslashes that aren't in braces.
|
*
|
*
|
* Results:
|
* Results:
|
* There is no return value. Count characters get copied from src to
|
* There is no return value. Count characters get copied from src to
|
* dst. Along the way, if backslash sequences are found outside braces,
|
* dst. Along the way, if backslash sequences are found outside braces,
|
* the backslashes are eliminated in the copy. After scanning count
|
* the backslashes are eliminated in the copy. After scanning count
|
* chars from source, a null character is placed at the end of dst.
|
* chars from source, a null character is placed at the end of dst.
|
* Returns the number of characters that got copied.
|
* Returns the number of characters that got copied.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
TclCopyAndCollapse(count, src, dst)
|
TclCopyAndCollapse(count, src, dst)
|
int count; /* Number of characters to copy from src. */
|
int count; /* Number of characters to copy from src. */
|
char *src; /* Copy from here... */
|
char *src; /* Copy from here... */
|
char *dst; /* ... to here. */
|
char *dst; /* ... to here. */
|
{
|
{
|
char c;
|
char c;
|
int numRead;
|
int numRead;
|
int newCount = 0;
|
int newCount = 0;
|
|
|
for (c = *src; count > 0; src++, c = *src, count--) {
|
for (c = *src; count > 0; src++, c = *src, count--) {
|
if (c == '\\') {
|
if (c == '\\') {
|
*dst = Tcl_Backslash(src, &numRead);
|
*dst = Tcl_Backslash(src, &numRead);
|
dst++;
|
dst++;
|
src += numRead-1;
|
src += numRead-1;
|
count -= numRead-1;
|
count -= numRead-1;
|
newCount++;
|
newCount++;
|
} else {
|
} else {
|
*dst = c;
|
*dst = c;
|
dst++;
|
dst++;
|
newCount++;
|
newCount++;
|
}
|
}
|
}
|
}
|
*dst = 0;
|
*dst = 0;
|
return newCount;
|
return newCount;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_SplitList --
|
* Tcl_SplitList --
|
*
|
*
|
* Splits a list up into its constituent fields.
|
* Splits a list up into its constituent fields.
|
*
|
*
|
* Results
|
* Results
|
* The return value is normally TCL_OK, which means that
|
* The return value is normally TCL_OK, which means that
|
* the list was successfully split up. If TCL_ERROR is
|
* the list was successfully split up. If TCL_ERROR is
|
* returned, it means that "list" didn't have proper list
|
* returned, it means that "list" didn't have proper list
|
* structure; interp->result will contain a more detailed
|
* structure; interp->result will contain a more detailed
|
* error message.
|
* error message.
|
*
|
*
|
* *argvPtr will be filled in with the address of an array
|
* *argvPtr will be filled in with the address of an array
|
* whose elements point to the elements of list, in order.
|
* whose elements point to the elements of list, in order.
|
* *argcPtr will get filled in with the number of valid elements
|
* *argcPtr will get filled in with the number of valid elements
|
* in the array. A single block of memory is dynamically allocated
|
* in the array. A single block of memory is dynamically allocated
|
* to hold both the argv array and a copy of the list (with
|
* to hold both the argv array and a copy of the list (with
|
* backslashes and braces removed in the standard way).
|
* backslashes and braces removed in the standard way).
|
* The caller must eventually free this memory by calling free()
|
* The caller must eventually free this memory by calling free()
|
* on *argvPtr. Note: *argvPtr and *argcPtr are only modified
|
* on *argvPtr. Note: *argvPtr and *argcPtr are only modified
|
* if the procedure returns normally.
|
* if the procedure returns normally.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Memory is allocated.
|
* Memory is allocated.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_SplitList(interp, list, argcPtr, argvPtr)
|
Tcl_SplitList(interp, list, argcPtr, argvPtr)
|
Tcl_Interp *interp; /* Interpreter to use for error reporting.
|
Tcl_Interp *interp; /* Interpreter to use for error reporting.
|
* If NULL, no error message is left. */
|
* If NULL, no error message is left. */
|
char *list; /* Pointer to string with list structure. */
|
char *list; /* Pointer to string with list structure. */
|
int *argcPtr; /* Pointer to location to fill in with
|
int *argcPtr; /* Pointer to location to fill in with
|
* the number of elements in the list. */
|
* the number of elements in the list. */
|
char ***argvPtr; /* Pointer to place to store pointer to
|
char ***argvPtr; /* Pointer to place to store pointer to
|
* array of pointers to list elements. */
|
* array of pointers to list elements. */
|
{
|
{
|
char **argv;
|
char **argv;
|
char *p;
|
char *p;
|
int length, size, i, result, elSize, brace;
|
int length, size, i, result, elSize, brace;
|
char *element;
|
char *element;
|
|
|
/*
|
/*
|
* Figure out how much space to allocate. There must be enough
|
* Figure out how much space to allocate. There must be enough
|
* space for both the array of pointers and also for a copy of
|
* space for both the array of pointers and also for a copy of
|
* the list. To estimate the number of pointers needed, count
|
* the list. To estimate the number of pointers needed, count
|
* the number of space characters in the list.
|
* the number of space characters in the list.
|
*/
|
*/
|
|
|
for (size = 1, p = list; *p != 0; p++) {
|
for (size = 1, p = list; *p != 0; p++) {
|
if (isspace(UCHAR(*p))) {
|
if (isspace(UCHAR(*p))) {
|
size++;
|
size++;
|
}
|
}
|
}
|
}
|
size++; /* Leave space for final NULL pointer. */
|
size++; /* Leave space for final NULL pointer. */
|
argv = (char **) ckalloc((unsigned)
|
argv = (char **) ckalloc((unsigned)
|
((size * sizeof(char *)) + (p - list) + 1));
|
((size * sizeof(char *)) + (p - list) + 1));
|
length = strlen(list);
|
length = strlen(list);
|
for (i = 0, p = ((char *) argv) + size*sizeof(char *);
|
for (i = 0, p = ((char *) argv) + size*sizeof(char *);
|
*list != 0; i++) {
|
*list != 0; i++) {
|
char *prevList = list;
|
char *prevList = list;
|
|
|
result = TclFindElement(interp, list, length, &element,
|
result = TclFindElement(interp, list, length, &element,
|
&list, &elSize, &brace);
|
&list, &elSize, &brace);
|
length -= (list - prevList);
|
length -= (list - prevList);
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
ckfree((char *) argv);
|
ckfree((char *) argv);
|
return result;
|
return result;
|
}
|
}
|
if (*element == 0) {
|
if (*element == 0) {
|
break;
|
break;
|
}
|
}
|
if (i >= size) {
|
if (i >= size) {
|
ckfree((char *) argv);
|
ckfree((char *) argv);
|
if (interp != NULL) {
|
if (interp != NULL) {
|
Tcl_SetResult(interp, "internal error in Tcl_SplitList",
|
Tcl_SetResult(interp, "internal error in Tcl_SplitList",
|
TCL_STATIC);
|
TCL_STATIC);
|
}
|
}
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
argv[i] = p;
|
argv[i] = p;
|
if (brace) {
|
if (brace) {
|
memcpy((VOID *) p, (VOID *) element, (size_t) elSize);
|
memcpy((VOID *) p, (VOID *) element, (size_t) elSize);
|
p += elSize;
|
p += elSize;
|
*p = 0;
|
*p = 0;
|
p++;
|
p++;
|
} else {
|
} else {
|
TclCopyAndCollapse(elSize, element, p);
|
TclCopyAndCollapse(elSize, element, p);
|
p += elSize+1;
|
p += elSize+1;
|
}
|
}
|
}
|
}
|
|
|
argv[i] = NULL;
|
argv[i] = NULL;
|
*argvPtr = argv;
|
*argvPtr = argv;
|
*argcPtr = i;
|
*argcPtr = i;
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_ScanElement --
|
* Tcl_ScanElement --
|
*
|
*
|
* This procedure is a companion procedure to Tcl_ConvertElement.
|
* This procedure is a companion procedure to Tcl_ConvertElement.
|
* It scans a string to see what needs to be done to it (e.g. add
|
* It scans a string to see what needs to be done to it (e.g. add
|
* backslashes or enclosing braces) to make the string into a
|
* backslashes or enclosing braces) to make the string into a
|
* valid Tcl list element.
|
* valid Tcl list element.
|
*
|
*
|
* Results:
|
* Results:
|
* The return value is an overestimate of the number of characters
|
* The return value is an overestimate of the number of characters
|
* that will be needed by Tcl_ConvertElement to produce a valid
|
* that will be needed by Tcl_ConvertElement to produce a valid
|
* list element from string. The word at *flagPtr is filled in
|
* list element from string. The word at *flagPtr is filled in
|
* with a value needed by Tcl_ConvertElement when doing the actual
|
* with a value needed by Tcl_ConvertElement when doing the actual
|
* conversion.
|
* conversion.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_ScanElement(string, flagPtr)
|
Tcl_ScanElement(string, flagPtr)
|
CONST char *string; /* String to convert to Tcl list element. */
|
CONST char *string; /* String to convert to Tcl list element. */
|
int *flagPtr; /* Where to store information to guide
|
int *flagPtr; /* Where to store information to guide
|
* Tcl_ConvertCountedElement. */
|
* Tcl_ConvertCountedElement. */
|
{
|
{
|
return Tcl_ScanCountedElement(string, -1, flagPtr);
|
return Tcl_ScanCountedElement(string, -1, flagPtr);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_ScanCountedElement --
|
* Tcl_ScanCountedElement --
|
*
|
*
|
* This procedure is a companion procedure to
|
* This procedure is a companion procedure to
|
* Tcl_ConvertCountedElement. It scans a string to see what
|
* Tcl_ConvertCountedElement. It scans a string to see what
|
* needs to be done to it (e.g. add backslashes or enclosing
|
* needs to be done to it (e.g. add backslashes or enclosing
|
* braces) to make the string into a valid Tcl list element.
|
* braces) to make the string into a valid Tcl list element.
|
* If length is -1, then the string is scanned up to the first
|
* If length is -1, then the string is scanned up to the first
|
* null byte.
|
* null byte.
|
*
|
*
|
* Results:
|
* Results:
|
* The return value is an overestimate of the number of characters
|
* The return value is an overestimate of the number of characters
|
* that will be needed by Tcl_ConvertCountedElement to produce a
|
* that will be needed by Tcl_ConvertCountedElement to produce a
|
* valid list element from string. The word at *flagPtr is
|
* valid list element from string. The word at *flagPtr is
|
* filled in with a value needed by Tcl_ConvertCountedElement
|
* filled in with a value needed by Tcl_ConvertCountedElement
|
* when doing the actual conversion.
|
* when doing the actual conversion.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_ScanCountedElement(string, length, flagPtr)
|
Tcl_ScanCountedElement(string, length, flagPtr)
|
CONST char *string; /* String to convert to Tcl list element. */
|
CONST char *string; /* String to convert to Tcl list element. */
|
int length; /* Number of bytes in string, or -1. */
|
int length; /* Number of bytes in string, or -1. */
|
int *flagPtr; /* Where to store information to guide
|
int *flagPtr; /* Where to store information to guide
|
* Tcl_ConvertElement. */
|
* Tcl_ConvertElement. */
|
{
|
{
|
int flags, nestingLevel;
|
int flags, nestingLevel;
|
CONST char *p, *lastChar;
|
CONST char *p, *lastChar;
|
|
|
/*
|
/*
|
* This procedure and Tcl_ConvertElement together do two things:
|
* This procedure and Tcl_ConvertElement together do two things:
|
*
|
*
|
* 1. They produce a proper list, one that will yield back the
|
* 1. They produce a proper list, one that will yield back the
|
* argument strings when evaluated or when disassembled with
|
* argument strings when evaluated or when disassembled with
|
* Tcl_SplitList. This is the most important thing.
|
* Tcl_SplitList. This is the most important thing.
|
*
|
*
|
* 2. They try to produce legible output, which means minimizing the
|
* 2. They try to produce legible output, which means minimizing the
|
* use of backslashes (using braces instead). However, there are
|
* use of backslashes (using braces instead). However, there are
|
* some situations where backslashes must be used (e.g. an element
|
* some situations where backslashes must be used (e.g. an element
|
* like "{abc": the leading brace will have to be backslashed.
|
* like "{abc": the leading brace will have to be backslashed.
|
* For each element, one of three things must be done:
|
* For each element, one of three things must be done:
|
*
|
*
|
* (a) Use the element as-is (it doesn't contain any special
|
* (a) Use the element as-is (it doesn't contain any special
|
* characters). This is the most desirable option.
|
* characters). This is the most desirable option.
|
*
|
*
|
* (b) Enclose the element in braces, but leave the contents alone.
|
* (b) Enclose the element in braces, but leave the contents alone.
|
* This happens if the element contains embedded space, or if it
|
* This happens if the element contains embedded space, or if it
|
* contains characters with special interpretation ($, [, ;, or \),
|
* contains characters with special interpretation ($, [, ;, or \),
|
* or if it starts with a brace or double-quote, or if there are
|
* or if it starts with a brace or double-quote, or if there are
|
* no characters in the element.
|
* no characters in the element.
|
*
|
*
|
* (c) Don't enclose the element in braces, but add backslashes to
|
* (c) Don't enclose the element in braces, but add backslashes to
|
* prevent special interpretation of special characters. This is a
|
* prevent special interpretation of special characters. This is a
|
* last resort used when the argument would normally fall under case
|
* last resort used when the argument would normally fall under case
|
* (b) but contains unmatched braces. It also occurs if the last
|
* (b) but contains unmatched braces. It also occurs if the last
|
* character of the argument is a backslash or if the element contains
|
* character of the argument is a backslash or if the element contains
|
* a backslash followed by newline.
|
* a backslash followed by newline.
|
*
|
*
|
* The procedure figures out how many bytes will be needed to store
|
* The procedure figures out how many bytes will be needed to store
|
* the result (actually, it overestimates). It also collects information
|
* the result (actually, it overestimates). It also collects information
|
* about the element in the form of a flags word.
|
* about the element in the form of a flags word.
|
*
|
*
|
* Note: list elements produced by this procedure and
|
* Note: list elements produced by this procedure and
|
* Tcl_ConvertCountedElement must have the property that they can be
|
* Tcl_ConvertCountedElement must have the property that they can be
|
* enclosing in curly braces to make sub-lists. This means, for
|
* enclosing in curly braces to make sub-lists. This means, for
|
* example, that we must not leave unmatched curly braces in the
|
* example, that we must not leave unmatched curly braces in the
|
* resulting list element. This property is necessary in order for
|
* resulting list element. This property is necessary in order for
|
* procedures like Tcl_DStringStartSublist to work.
|
* procedures like Tcl_DStringStartSublist to work.
|
*/
|
*/
|
|
|
nestingLevel = 0;
|
nestingLevel = 0;
|
flags = 0;
|
flags = 0;
|
if (string == NULL) {
|
if (string == NULL) {
|
string = "";
|
string = "";
|
}
|
}
|
if (length == -1) {
|
if (length == -1) {
|
length = strlen(string);
|
length = strlen(string);
|
}
|
}
|
lastChar = string + length;
|
lastChar = string + length;
|
p = string;
|
p = string;
|
if ((p == lastChar) || (*p == '{') || (*p == '"')) {
|
if ((p == lastChar) || (*p == '{') || (*p == '"')) {
|
flags |= USE_BRACES;
|
flags |= USE_BRACES;
|
}
|
}
|
for ( ; p != lastChar; p++) {
|
for ( ; p != lastChar; p++) {
|
switch (*p) {
|
switch (*p) {
|
case '{':
|
case '{':
|
nestingLevel++;
|
nestingLevel++;
|
break;
|
break;
|
case '}':
|
case '}':
|
nestingLevel--;
|
nestingLevel--;
|
if (nestingLevel < 0) {
|
if (nestingLevel < 0) {
|
flags |= TCL_DONT_USE_BRACES|BRACES_UNMATCHED;
|
flags |= TCL_DONT_USE_BRACES|BRACES_UNMATCHED;
|
}
|
}
|
break;
|
break;
|
case '[':
|
case '[':
|
case '$':
|
case '$':
|
case ';':
|
case ';':
|
case ' ':
|
case ' ':
|
case '\f':
|
case '\f':
|
case '\n':
|
case '\n':
|
case '\r':
|
case '\r':
|
case '\t':
|
case '\t':
|
case '\v':
|
case '\v':
|
flags |= USE_BRACES;
|
flags |= USE_BRACES;
|
break;
|
break;
|
case '\\':
|
case '\\':
|
if ((p+1 == lastChar) || (p[1] == '\n')) {
|
if ((p+1 == lastChar) || (p[1] == '\n')) {
|
flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED;
|
flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED;
|
} else {
|
} else {
|
int size;
|
int size;
|
|
|
(void) Tcl_Backslash(p, &size);
|
(void) Tcl_Backslash(p, &size);
|
p += size-1;
|
p += size-1;
|
flags |= USE_BRACES;
|
flags |= USE_BRACES;
|
}
|
}
|
break;
|
break;
|
}
|
}
|
}
|
}
|
if (nestingLevel != 0) {
|
if (nestingLevel != 0) {
|
flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED;
|
flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED;
|
}
|
}
|
*flagPtr = flags;
|
*flagPtr = flags;
|
|
|
/*
|
/*
|
* Allow enough space to backslash every character plus leave
|
* Allow enough space to backslash every character plus leave
|
* two spaces for braces.
|
* two spaces for braces.
|
*/
|
*/
|
|
|
return 2*(p-string) + 2;
|
return 2*(p-string) + 2;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_ConvertElement --
|
* Tcl_ConvertElement --
|
*
|
*
|
* This is a companion procedure to Tcl_ScanElement. Given
|
* This is a companion procedure to Tcl_ScanElement. Given
|
* the information produced by Tcl_ScanElement, this procedure
|
* the information produced by Tcl_ScanElement, this procedure
|
* converts a string to a list element equal to that string.
|
* converts a string to a list element equal to that string.
|
*
|
*
|
* Results:
|
* Results:
|
* Information is copied to *dst in the form of a list element
|
* Information is copied to *dst in the form of a list element
|
* identical to src (i.e. if Tcl_SplitList is applied to dst it
|
* identical to src (i.e. if Tcl_SplitList is applied to dst it
|
* will produce a string identical to src). The return value is
|
* will produce a string identical to src). The return value is
|
* a count of the number of characters copied (not including the
|
* a count of the number of characters copied (not including the
|
* terminating NULL character).
|
* terminating NULL character).
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_ConvertElement(src, dst, flags)
|
Tcl_ConvertElement(src, dst, flags)
|
CONST char *src; /* Source information for list element. */
|
CONST char *src; /* Source information for list element. */
|
char *dst; /* Place to put list-ified element. */
|
char *dst; /* Place to put list-ified element. */
|
int flags; /* Flags produced by Tcl_ScanElement. */
|
int flags; /* Flags produced by Tcl_ScanElement. */
|
{
|
{
|
return Tcl_ConvertCountedElement(src, -1, dst, flags);
|
return Tcl_ConvertCountedElement(src, -1, dst, flags);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_ConvertCountedElement --
|
* Tcl_ConvertCountedElement --
|
*
|
*
|
* This is a companion procedure to Tcl_ScanCountedElement. Given
|
* This is a companion procedure to Tcl_ScanCountedElement. Given
|
* the information produced by Tcl_ScanCountedElement, this
|
* the information produced by Tcl_ScanCountedElement, this
|
* procedure converts a string to a list element equal to that
|
* procedure converts a string to a list element equal to that
|
* string.
|
* string.
|
*
|
*
|
* Results:
|
* Results:
|
* Information is copied to *dst in the form of a list element
|
* Information is copied to *dst in the form of a list element
|
* identical to src (i.e. if Tcl_SplitList is applied to dst it
|
* identical to src (i.e. if Tcl_SplitList is applied to dst it
|
* will produce a string identical to src). The return value is
|
* will produce a string identical to src). The return value is
|
* a count of the number of characters copied (not including the
|
* a count of the number of characters copied (not including the
|
* terminating NULL character).
|
* terminating NULL character).
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_ConvertCountedElement(src, length, dst, flags)
|
Tcl_ConvertCountedElement(src, length, dst, flags)
|
CONST char *src; /* Source information for list element. */
|
CONST char *src; /* Source information for list element. */
|
int length; /* Number of bytes in src, or -1. */
|
int length; /* Number of bytes in src, or -1. */
|
char *dst; /* Place to put list-ified element. */
|
char *dst; /* Place to put list-ified element. */
|
int flags; /* Flags produced by Tcl_ScanElement. */
|
int flags; /* Flags produced by Tcl_ScanElement. */
|
{
|
{
|
char *p = dst;
|
char *p = dst;
|
CONST char *lastChar;
|
CONST char *lastChar;
|
|
|
/*
|
/*
|
* See the comment block at the beginning of the Tcl_ScanElement
|
* See the comment block at the beginning of the Tcl_ScanElement
|
* code for details of how this works.
|
* code for details of how this works.
|
*/
|
*/
|
|
|
if (src && length == -1) {
|
if (src && length == -1) {
|
length = strlen(src);
|
length = strlen(src);
|
}
|
}
|
if ((src == NULL) || (length == 0)) {
|
if ((src == NULL) || (length == 0)) {
|
p[0] = '{';
|
p[0] = '{';
|
p[1] = '}';
|
p[1] = '}';
|
p[2] = 0;
|
p[2] = 0;
|
return 2;
|
return 2;
|
}
|
}
|
lastChar = src + length;
|
lastChar = src + length;
|
if ((flags & USE_BRACES) && !(flags & TCL_DONT_USE_BRACES)) {
|
if ((flags & USE_BRACES) && !(flags & TCL_DONT_USE_BRACES)) {
|
*p = '{';
|
*p = '{';
|
p++;
|
p++;
|
for ( ; src != lastChar; src++, p++) {
|
for ( ; src != lastChar; src++, p++) {
|
*p = *src;
|
*p = *src;
|
}
|
}
|
*p = '}';
|
*p = '}';
|
p++;
|
p++;
|
} else {
|
} else {
|
if (*src == '{') {
|
if (*src == '{') {
|
/*
|
/*
|
* Can't have a leading brace unless the whole element is
|
* Can't have a leading brace unless the whole element is
|
* enclosed in braces. Add a backslash before the brace.
|
* enclosed in braces. Add a backslash before the brace.
|
* Furthermore, this may destroy the balance between open
|
* Furthermore, this may destroy the balance between open
|
* and close braces, so set BRACES_UNMATCHED.
|
* and close braces, so set BRACES_UNMATCHED.
|
*/
|
*/
|
|
|
p[0] = '\\';
|
p[0] = '\\';
|
p[1] = '{';
|
p[1] = '{';
|
p += 2;
|
p += 2;
|
src++;
|
src++;
|
flags |= BRACES_UNMATCHED;
|
flags |= BRACES_UNMATCHED;
|
}
|
}
|
for (; src != lastChar; src++) {
|
for (; src != lastChar; src++) {
|
switch (*src) {
|
switch (*src) {
|
case ']':
|
case ']':
|
case '[':
|
case '[':
|
case '$':
|
case '$':
|
case ';':
|
case ';':
|
case ' ':
|
case ' ':
|
case '\\':
|
case '\\':
|
case '"':
|
case '"':
|
*p = '\\';
|
*p = '\\';
|
p++;
|
p++;
|
break;
|
break;
|
case '{':
|
case '{':
|
case '}':
|
case '}':
|
/*
|
/*
|
* It may not seem necessary to backslash braces, but
|
* It may not seem necessary to backslash braces, but
|
* it is. The reason for this is that the resulting
|
* it is. The reason for this is that the resulting
|
* list element may actually be an element of a sub-list
|
* list element may actually be an element of a sub-list
|
* enclosed in braces (e.g. if Tcl_DStringStartSublist
|
* enclosed in braces (e.g. if Tcl_DStringStartSublist
|
* has been invoked), so there may be a brace mismatch
|
* has been invoked), so there may be a brace mismatch
|
* if the braces aren't backslashed.
|
* if the braces aren't backslashed.
|
*/
|
*/
|
|
|
if (flags & BRACES_UNMATCHED) {
|
if (flags & BRACES_UNMATCHED) {
|
*p = '\\';
|
*p = '\\';
|
p++;
|
p++;
|
}
|
}
|
break;
|
break;
|
case '\f':
|
case '\f':
|
*p = '\\';
|
*p = '\\';
|
p++;
|
p++;
|
*p = 'f';
|
*p = 'f';
|
p++;
|
p++;
|
continue;
|
continue;
|
case '\n':
|
case '\n':
|
*p = '\\';
|
*p = '\\';
|
p++;
|
p++;
|
*p = 'n';
|
*p = 'n';
|
p++;
|
p++;
|
continue;
|
continue;
|
case '\r':
|
case '\r':
|
*p = '\\';
|
*p = '\\';
|
p++;
|
p++;
|
*p = 'r';
|
*p = 'r';
|
p++;
|
p++;
|
continue;
|
continue;
|
case '\t':
|
case '\t':
|
*p = '\\';
|
*p = '\\';
|
p++;
|
p++;
|
*p = 't';
|
*p = 't';
|
p++;
|
p++;
|
continue;
|
continue;
|
case '\v':
|
case '\v':
|
*p = '\\';
|
*p = '\\';
|
p++;
|
p++;
|
*p = 'v';
|
*p = 'v';
|
p++;
|
p++;
|
continue;
|
continue;
|
}
|
}
|
*p = *src;
|
*p = *src;
|
p++;
|
p++;
|
}
|
}
|
}
|
}
|
*p = '\0';
|
*p = '\0';
|
return p-dst;
|
return p-dst;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_Merge --
|
* Tcl_Merge --
|
*
|
*
|
* Given a collection of strings, merge them together into a
|
* Given a collection of strings, merge them together into a
|
* single string that has proper Tcl list structured (i.e.
|
* single string that has proper Tcl list structured (i.e.
|
* Tcl_SplitList may be used to retrieve strings equal to the
|
* Tcl_SplitList may be used to retrieve strings equal to the
|
* original elements, and Tcl_Eval will parse the string back
|
* original elements, and Tcl_Eval will parse the string back
|
* into its original elements).
|
* into its original elements).
|
*
|
*
|
* Results:
|
* Results:
|
* The return value is the address of a dynamically-allocated
|
* The return value is the address of a dynamically-allocated
|
* string containing the merged list.
|
* string containing the merged list.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
char *
|
char *
|
Tcl_Merge(argc, argv)
|
Tcl_Merge(argc, argv)
|
int argc; /* How many strings to merge. */
|
int argc; /* How many strings to merge. */
|
char **argv; /* Array of string values. */
|
char **argv; /* Array of string values. */
|
{
|
{
|
# define LOCAL_SIZE 20
|
# define LOCAL_SIZE 20
|
int localFlags[LOCAL_SIZE], *flagPtr;
|
int localFlags[LOCAL_SIZE], *flagPtr;
|
int numChars;
|
int numChars;
|
char *result;
|
char *result;
|
char *dst;
|
char *dst;
|
int i;
|
int i;
|
|
|
/*
|
/*
|
* Pass 1: estimate space, gather flags.
|
* Pass 1: estimate space, gather flags.
|
*/
|
*/
|
|
|
if (argc <= LOCAL_SIZE) {
|
if (argc <= LOCAL_SIZE) {
|
flagPtr = localFlags;
|
flagPtr = localFlags;
|
} else {
|
} else {
|
flagPtr = (int *) ckalloc((unsigned) argc*sizeof(int));
|
flagPtr = (int *) ckalloc((unsigned) argc*sizeof(int));
|
}
|
}
|
numChars = 1;
|
numChars = 1;
|
for (i = 0; i < argc; i++) {
|
for (i = 0; i < argc; i++) {
|
numChars += Tcl_ScanElement(argv[i], &flagPtr[i]) + 1;
|
numChars += Tcl_ScanElement(argv[i], &flagPtr[i]) + 1;
|
}
|
}
|
|
|
/*
|
/*
|
* Pass two: copy into the result area.
|
* Pass two: copy into the result area.
|
*/
|
*/
|
|
|
result = (char *) ckalloc((unsigned) numChars);
|
result = (char *) ckalloc((unsigned) numChars);
|
dst = result;
|
dst = result;
|
for (i = 0; i < argc; i++) {
|
for (i = 0; i < argc; i++) {
|
numChars = Tcl_ConvertElement(argv[i], dst, flagPtr[i]);
|
numChars = Tcl_ConvertElement(argv[i], dst, flagPtr[i]);
|
dst += numChars;
|
dst += numChars;
|
*dst = ' ';
|
*dst = ' ';
|
dst++;
|
dst++;
|
}
|
}
|
if (dst == result) {
|
if (dst == result) {
|
*dst = 0;
|
*dst = 0;
|
} else {
|
} else {
|
dst[-1] = 0;
|
dst[-1] = 0;
|
}
|
}
|
|
|
if (flagPtr != localFlags) {
|
if (flagPtr != localFlags) {
|
ckfree((char *) flagPtr);
|
ckfree((char *) flagPtr);
|
}
|
}
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_Concat --
|
* Tcl_Concat --
|
*
|
*
|
* Concatenate a set of strings into a single large string.
|
* Concatenate a set of strings into a single large string.
|
*
|
*
|
* Results:
|
* Results:
|
* The return value is dynamically-allocated string containing
|
* The return value is dynamically-allocated string containing
|
* a concatenation of all the strings in argv, with spaces between
|
* a concatenation of all the strings in argv, with spaces between
|
* the original argv elements.
|
* the original argv elements.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Memory is allocated for the result; the caller is responsible
|
* Memory is allocated for the result; the caller is responsible
|
* for freeing the memory.
|
* for freeing the memory.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
char *
|
char *
|
Tcl_Concat(argc, argv)
|
Tcl_Concat(argc, argv)
|
int argc; /* Number of strings to concatenate. */
|
int argc; /* Number of strings to concatenate. */
|
char **argv; /* Array of strings to concatenate. */
|
char **argv; /* Array of strings to concatenate. */
|
{
|
{
|
int totalSize, i;
|
int totalSize, i;
|
char *p;
|
char *p;
|
char *result;
|
char *result;
|
|
|
for (totalSize = 1, i = 0; i < argc; i++) {
|
for (totalSize = 1, i = 0; i < argc; i++) {
|
totalSize += strlen(argv[i]) + 1;
|
totalSize += strlen(argv[i]) + 1;
|
}
|
}
|
result = (char *) ckalloc((unsigned) totalSize);
|
result = (char *) ckalloc((unsigned) totalSize);
|
if (argc == 0) {
|
if (argc == 0) {
|
*result = '\0';
|
*result = '\0';
|
return result;
|
return result;
|
}
|
}
|
for (p = result, i = 0; i < argc; i++) {
|
for (p = result, i = 0; i < argc; i++) {
|
char *element;
|
char *element;
|
int length;
|
int length;
|
|
|
/*
|
/*
|
* Clip white space off the front and back of the string
|
* Clip white space off the front and back of the string
|
* to generate a neater result, and ignore any empty
|
* to generate a neater result, and ignore any empty
|
* elements.
|
* elements.
|
*/
|
*/
|
|
|
element = argv[i];
|
element = argv[i];
|
while (isspace(UCHAR(*element))) {
|
while (isspace(UCHAR(*element))) {
|
element++;
|
element++;
|
}
|
}
|
for (length = strlen(element);
|
for (length = strlen(element);
|
(length > 0) && (isspace(UCHAR(element[length-1])))
|
(length > 0) && (isspace(UCHAR(element[length-1])))
|
&& ((length < 2) || (element[length-2] != '\\'));
|
&& ((length < 2) || (element[length-2] != '\\'));
|
length--) {
|
length--) {
|
/* Null loop body. */
|
/* Null loop body. */
|
}
|
}
|
if (length == 0) {
|
if (length == 0) {
|
continue;
|
continue;
|
}
|
}
|
memcpy((VOID *) p, (VOID *) element, (size_t) length);
|
memcpy((VOID *) p, (VOID *) element, (size_t) length);
|
p += length;
|
p += length;
|
*p = ' ';
|
*p = ' ';
|
p++;
|
p++;
|
}
|
}
|
if (p != result) {
|
if (p != result) {
|
p[-1] = 0;
|
p[-1] = 0;
|
} else {
|
} else {
|
*p = 0;
|
*p = 0;
|
}
|
}
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_ConcatObj --
|
* Tcl_ConcatObj --
|
*
|
*
|
* Concatenate the strings from a set of objects into a single string
|
* Concatenate the strings from a set of objects into a single string
|
* object with spaces between the original strings.
|
* object with spaces between the original strings.
|
*
|
*
|
* Results:
|
* Results:
|
* The return value is a new string object containing a concatenation
|
* The return value is a new string object containing a concatenation
|
* of the strings in objv. Its ref count is zero.
|
* of the strings in objv. Its ref count is zero.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* A new object is created.
|
* A new object is created.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
Tcl_Obj *
|
Tcl_Obj *
|
Tcl_ConcatObj(objc, objv)
|
Tcl_ConcatObj(objc, objv)
|
int objc; /* Number of objects to concatenate. */
|
int objc; /* Number of objects to concatenate. */
|
Tcl_Obj *CONST objv[]; /* Array of objects to concatenate. */
|
Tcl_Obj *CONST objv[]; /* Array of objects to concatenate. */
|
{
|
{
|
int allocSize, finalSize, length, elemLength, i;
|
int allocSize, finalSize, length, elemLength, i;
|
char *p;
|
char *p;
|
char *element;
|
char *element;
|
char *concatStr;
|
char *concatStr;
|
Tcl_Obj *objPtr;
|
Tcl_Obj *objPtr;
|
|
|
allocSize = 0;
|
allocSize = 0;
|
for (i = 0; i < objc; i++) {
|
for (i = 0; i < objc; i++) {
|
objPtr = objv[i];
|
objPtr = objv[i];
|
element = TclGetStringFromObj(objPtr, &length);
|
element = TclGetStringFromObj(objPtr, &length);
|
if ((element != NULL) && (length > 0)) {
|
if ((element != NULL) && (length > 0)) {
|
allocSize += (length + 1);
|
allocSize += (length + 1);
|
}
|
}
|
}
|
}
|
if (allocSize == 0) {
|
if (allocSize == 0) {
|
allocSize = 1; /* enough for the NULL byte at end */
|
allocSize = 1; /* enough for the NULL byte at end */
|
}
|
}
|
|
|
/*
|
/*
|
* Allocate storage for the concatenated result. Note that allocSize
|
* Allocate storage for the concatenated result. Note that allocSize
|
* is one more than the total number of characters, and so includes
|
* is one more than the total number of characters, and so includes
|
* room for the terminating NULL byte.
|
* room for the terminating NULL byte.
|
*/
|
*/
|
|
|
concatStr = (char *) ckalloc((unsigned) allocSize);
|
concatStr = (char *) ckalloc((unsigned) allocSize);
|
|
|
/*
|
/*
|
* Now concatenate the elements. Clip white space off the front and back
|
* Now concatenate the elements. Clip white space off the front and back
|
* to generate a neater result, and ignore any empty elements. Also put
|
* to generate a neater result, and ignore any empty elements. Also put
|
* a null byte at the end.
|
* a null byte at the end.
|
*/
|
*/
|
|
|
finalSize = 0;
|
finalSize = 0;
|
if (objc == 0) {
|
if (objc == 0) {
|
*concatStr = '\0';
|
*concatStr = '\0';
|
} else {
|
} else {
|
p = concatStr;
|
p = concatStr;
|
for (i = 0; i < objc; i++) {
|
for (i = 0; i < objc; i++) {
|
objPtr = objv[i];
|
objPtr = objv[i];
|
element = TclGetStringFromObj(objPtr, &elemLength);
|
element = TclGetStringFromObj(objPtr, &elemLength);
|
while ((elemLength > 0) && (isspace(UCHAR(*element)))) {
|
while ((elemLength > 0) && (isspace(UCHAR(*element)))) {
|
element++;
|
element++;
|
elemLength--;
|
elemLength--;
|
}
|
}
|
|
|
/*
|
/*
|
* Trim trailing white space. But, be careful not to trim
|
* Trim trailing white space. But, be careful not to trim
|
* a space character if it is preceded by a backslash: in
|
* a space character if it is preceded by a backslash: in
|
* this case it could be significant.
|
* this case it could be significant.
|
*/
|
*/
|
|
|
while ((elemLength > 0)
|
while ((elemLength > 0)
|
&& isspace(UCHAR(element[elemLength-1]))
|
&& isspace(UCHAR(element[elemLength-1]))
|
&& ((elemLength < 2) || (element[elemLength-2] != '\\'))) {
|
&& ((elemLength < 2) || (element[elemLength-2] != '\\'))) {
|
elemLength--;
|
elemLength--;
|
}
|
}
|
if (elemLength == 0) {
|
if (elemLength == 0) {
|
continue; /* nothing left of this element */
|
continue; /* nothing left of this element */
|
}
|
}
|
memcpy((VOID *) p, (VOID *) element, (size_t) elemLength);
|
memcpy((VOID *) p, (VOID *) element, (size_t) elemLength);
|
p += elemLength;
|
p += elemLength;
|
*p = ' ';
|
*p = ' ';
|
p++;
|
p++;
|
finalSize += (elemLength + 1);
|
finalSize += (elemLength + 1);
|
}
|
}
|
if (p != concatStr) {
|
if (p != concatStr) {
|
p[-1] = 0;
|
p[-1] = 0;
|
finalSize -= 1; /* we overwrote the final ' ' */
|
finalSize -= 1; /* we overwrote the final ' ' */
|
} else {
|
} else {
|
*p = 0;
|
*p = 0;
|
}
|
}
|
}
|
}
|
|
|
TclNewObj(objPtr);
|
TclNewObj(objPtr);
|
objPtr->bytes = concatStr;
|
objPtr->bytes = concatStr;
|
objPtr->length = finalSize;
|
objPtr->length = finalSize;
|
return objPtr;
|
return objPtr;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_StringMatch --
|
* Tcl_StringMatch --
|
*
|
*
|
* See if a particular string matches a particular pattern.
|
* See if a particular string matches a particular pattern.
|
*
|
*
|
* Results:
|
* Results:
|
* The return value is 1 if string matches pattern, and
|
* The return value is 1 if string matches pattern, and
|
* 0 otherwise. The matching operation permits the following
|
* 0 otherwise. The matching operation permits the following
|
* special characters in the pattern: *?\[] (see the manual
|
* special characters in the pattern: *?\[] (see the manual
|
* entry for details on what these mean).
|
* entry for details on what these mean).
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_StringMatch(string, pattern)
|
Tcl_StringMatch(string, pattern)
|
char *string; /* String. */
|
char *string; /* String. */
|
char *pattern; /* Pattern, which may contain special
|
char *pattern; /* Pattern, which may contain special
|
* characters. */
|
* characters. */
|
{
|
{
|
char c2;
|
char c2;
|
|
|
while (1) {
|
while (1) {
|
/* See if we're at the end of both the pattern and the string.
|
/* See if we're at the end of both the pattern and the string.
|
* If so, we succeeded. If we're at the end of the pattern
|
* If so, we succeeded. If we're at the end of the pattern
|
* but not at the end of the string, we failed.
|
* but not at the end of the string, we failed.
|
*/
|
*/
|
|
|
if (*pattern == 0) {
|
if (*pattern == 0) {
|
if (*string == 0) {
|
if (*string == 0) {
|
return 1;
|
return 1;
|
} else {
|
} else {
|
return 0;
|
return 0;
|
}
|
}
|
}
|
}
|
if ((*string == 0) && (*pattern != '*')) {
|
if ((*string == 0) && (*pattern != '*')) {
|
return 0;
|
return 0;
|
}
|
}
|
|
|
/* Check for a "*" as the next pattern character. It matches
|
/* Check for a "*" as the next pattern character. It matches
|
* any substring. We handle this by calling ourselves
|
* any substring. We handle this by calling ourselves
|
* recursively for each postfix of string, until either we
|
* recursively for each postfix of string, until either we
|
* match or we reach the end of the string.
|
* match or we reach the end of the string.
|
*/
|
*/
|
|
|
if (*pattern == '*') {
|
if (*pattern == '*') {
|
pattern += 1;
|
pattern += 1;
|
if (*pattern == 0) {
|
if (*pattern == 0) {
|
return 1;
|
return 1;
|
}
|
}
|
while (1) {
|
while (1) {
|
if (Tcl_StringMatch(string, pattern)) {
|
if (Tcl_StringMatch(string, pattern)) {
|
return 1;
|
return 1;
|
}
|
}
|
if (*string == 0) {
|
if (*string == 0) {
|
return 0;
|
return 0;
|
}
|
}
|
string += 1;
|
string += 1;
|
}
|
}
|
}
|
}
|
|
|
/* Check for a "?" as the next pattern character. It matches
|
/* Check for a "?" as the next pattern character. It matches
|
* any single character.
|
* any single character.
|
*/
|
*/
|
|
|
if (*pattern == '?') {
|
if (*pattern == '?') {
|
goto thisCharOK;
|
goto thisCharOK;
|
}
|
}
|
|
|
/* Check for a "[" as the next pattern character. It is followed
|
/* Check for a "[" as the next pattern character. It is followed
|
* by a list of characters that are acceptable, or by a range
|
* by a list of characters that are acceptable, or by a range
|
* (two characters separated by "-").
|
* (two characters separated by "-").
|
*/
|
*/
|
|
|
if (*pattern == '[') {
|
if (*pattern == '[') {
|
pattern += 1;
|
pattern += 1;
|
while (1) {
|
while (1) {
|
if ((*pattern == ']') || (*pattern == 0)) {
|
if ((*pattern == ']') || (*pattern == 0)) {
|
return 0;
|
return 0;
|
}
|
}
|
if (*pattern == *string) {
|
if (*pattern == *string) {
|
break;
|
break;
|
}
|
}
|
if (pattern[1] == '-') {
|
if (pattern[1] == '-') {
|
c2 = pattern[2];
|
c2 = pattern[2];
|
if (c2 == 0) {
|
if (c2 == 0) {
|
return 0;
|
return 0;
|
}
|
}
|
if ((*pattern <= *string) && (c2 >= *string)) {
|
if ((*pattern <= *string) && (c2 >= *string)) {
|
break;
|
break;
|
}
|
}
|
if ((*pattern >= *string) && (c2 <= *string)) {
|
if ((*pattern >= *string) && (c2 <= *string)) {
|
break;
|
break;
|
}
|
}
|
pattern += 2;
|
pattern += 2;
|
}
|
}
|
pattern += 1;
|
pattern += 1;
|
}
|
}
|
while (*pattern != ']') {
|
while (*pattern != ']') {
|
if (*pattern == 0) {
|
if (*pattern == 0) {
|
pattern--;
|
pattern--;
|
break;
|
break;
|
}
|
}
|
pattern += 1;
|
pattern += 1;
|
}
|
}
|
goto thisCharOK;
|
goto thisCharOK;
|
}
|
}
|
|
|
/* If the next pattern character is '/', just strip off the '/'
|
/* If the next pattern character is '/', just strip off the '/'
|
* so we do exact matching on the character that follows.
|
* so we do exact matching on the character that follows.
|
*/
|
*/
|
|
|
if (*pattern == '\\') {
|
if (*pattern == '\\') {
|
pattern += 1;
|
pattern += 1;
|
if (*pattern == 0) {
|
if (*pattern == 0) {
|
return 0;
|
return 0;
|
}
|
}
|
}
|
}
|
|
|
/* There's no special character. Just make sure that the next
|
/* There's no special character. Just make sure that the next
|
* characters of each string match.
|
* characters of each string match.
|
*/
|
*/
|
|
|
if (*pattern != *string) {
|
if (*pattern != *string) {
|
return 0;
|
return 0;
|
}
|
}
|
|
|
thisCharOK: pattern += 1;
|
thisCharOK: pattern += 1;
|
string += 1;
|
string += 1;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_SetResult --
|
* Tcl_SetResult --
|
*
|
*
|
* Arrange for "string" to be the Tcl return value.
|
* Arrange for "string" to be the Tcl return value.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* interp->result is left pointing either to "string" (if "copy" is 0)
|
* interp->result is left pointing either to "string" (if "copy" is 0)
|
* or to a copy of string. Also, the object result is reset.
|
* or to a copy of string. Also, the object result is reset.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
void
|
void
|
Tcl_SetResult(interp, string, freeProc)
|
Tcl_SetResult(interp, string, freeProc)
|
Tcl_Interp *interp; /* Interpreter with which to associate the
|
Tcl_Interp *interp; /* Interpreter with which to associate the
|
* return value. */
|
* return value. */
|
char *string; /* Value to be returned. If NULL, the
|
char *string; /* Value to be returned. If NULL, the
|
* result is set to an empty string. */
|
* result is set to an empty string. */
|
Tcl_FreeProc *freeProc; /* Gives information about the string:
|
Tcl_FreeProc *freeProc; /* Gives information about the string:
|
* TCL_STATIC, TCL_VOLATILE, or the address
|
* TCL_STATIC, TCL_VOLATILE, or the address
|
* of a Tcl_FreeProc such as free. */
|
* of a Tcl_FreeProc such as free. */
|
{
|
{
|
Interp *iPtr = (Interp *) interp;
|
Interp *iPtr = (Interp *) interp;
|
int length;
|
int length;
|
Tcl_FreeProc *oldFreeProc = iPtr->freeProc;
|
Tcl_FreeProc *oldFreeProc = iPtr->freeProc;
|
char *oldResult = iPtr->result;
|
char *oldResult = iPtr->result;
|
|
|
if (string == NULL) {
|
if (string == NULL) {
|
iPtr->resultSpace[0] = 0;
|
iPtr->resultSpace[0] = 0;
|
iPtr->result = iPtr->resultSpace;
|
iPtr->result = iPtr->resultSpace;
|
iPtr->freeProc = 0;
|
iPtr->freeProc = 0;
|
} else if (freeProc == TCL_VOLATILE) {
|
} else if (freeProc == TCL_VOLATILE) {
|
length = strlen(string);
|
length = strlen(string);
|
if (length > TCL_RESULT_SIZE) {
|
if (length > TCL_RESULT_SIZE) {
|
iPtr->result = (char *) ckalloc((unsigned) length+1);
|
iPtr->result = (char *) ckalloc((unsigned) length+1);
|
iPtr->freeProc = TCL_DYNAMIC;
|
iPtr->freeProc = TCL_DYNAMIC;
|
} else {
|
} else {
|
iPtr->result = iPtr->resultSpace;
|
iPtr->result = iPtr->resultSpace;
|
iPtr->freeProc = 0;
|
iPtr->freeProc = 0;
|
}
|
}
|
strcpy(iPtr->result, string);
|
strcpy(iPtr->result, string);
|
} else {
|
} else {
|
iPtr->result = string;
|
iPtr->result = string;
|
iPtr->freeProc = freeProc;
|
iPtr->freeProc = freeProc;
|
}
|
}
|
|
|
/*
|
/*
|
* If the old result was dynamically-allocated, free it up. Do it
|
* If the old result was dynamically-allocated, free it up. Do it
|
* here, rather than at the beginning, in case the new result value
|
* here, rather than at the beginning, in case the new result value
|
* was part of the old result value.
|
* was part of the old result value.
|
*/
|
*/
|
|
|
if (oldFreeProc != 0) {
|
if (oldFreeProc != 0) {
|
if ((oldFreeProc == TCL_DYNAMIC)
|
if ((oldFreeProc == TCL_DYNAMIC)
|
|| (oldFreeProc == (Tcl_FreeProc *) free)) {
|
|| (oldFreeProc == (Tcl_FreeProc *) free)) {
|
ckfree(oldResult);
|
ckfree(oldResult);
|
} else {
|
} else {
|
(*oldFreeProc)(oldResult);
|
(*oldFreeProc)(oldResult);
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* Reset the object result since we just set the string result.
|
* Reset the object result since we just set the string result.
|
*/
|
*/
|
|
|
TclResetObjResult(iPtr);
|
TclResetObjResult(iPtr);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_GetStringResult --
|
* Tcl_GetStringResult --
|
*
|
*
|
* Returns an interpreter's result value as a string.
|
* Returns an interpreter's result value as a string.
|
*
|
*
|
* Results:
|
* Results:
|
* The interpreter's result as a string.
|
* The interpreter's result as a string.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* If the string result is empty, the object result is moved to the
|
* If the string result is empty, the object result is moved to the
|
* string result, then the object result is reset.
|
* string result, then the object result is reset.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
char *
|
char *
|
Tcl_GetStringResult(interp)
|
Tcl_GetStringResult(interp)
|
Tcl_Interp *interp; /* Interpreter whose result to return. */
|
Tcl_Interp *interp; /* Interpreter whose result to return. */
|
{
|
{
|
/*
|
/*
|
* If the string result is empty, move the object result to the
|
* If the string result is empty, move the object result to the
|
* string result, then reset the object result.
|
* string result, then reset the object result.
|
* FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS.
|
* FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS.
|
*/
|
*/
|
|
|
if (*(interp->result) == 0) {
|
if (*(interp->result) == 0) {
|
Tcl_SetResult(interp,
|
Tcl_SetResult(interp,
|
TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL),
|
TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL),
|
TCL_VOLATILE);
|
TCL_VOLATILE);
|
}
|
}
|
return interp->result;
|
return interp->result;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_SetObjResult --
|
* Tcl_SetObjResult --
|
*
|
*
|
* Arrange for objPtr to be an interpreter's result value.
|
* Arrange for objPtr to be an interpreter's result value.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* interp->objResultPtr is left pointing to the object referenced
|
* interp->objResultPtr is left pointing to the object referenced
|
* by objPtr. The object's reference count is incremented since
|
* by objPtr. The object's reference count is incremented since
|
* there is now a new reference to it. The reference count for any
|
* there is now a new reference to it. The reference count for any
|
* old objResultPtr value is decremented. Also, the string result
|
* old objResultPtr value is decremented. Also, the string result
|
* is reset.
|
* is reset.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
void
|
void
|
Tcl_SetObjResult(interp, objPtr)
|
Tcl_SetObjResult(interp, objPtr)
|
Tcl_Interp *interp; /* Interpreter with which to associate the
|
Tcl_Interp *interp; /* Interpreter with which to associate the
|
* return object value. */
|
* return object value. */
|
Tcl_Obj *objPtr; /* Tcl object to be returned. If NULL, the
|
Tcl_Obj *objPtr; /* Tcl object to be returned. If NULL, the
|
* obj result is made an empty string
|
* obj result is made an empty string
|
* object. */
|
* object. */
|
{
|
{
|
Interp *iPtr = (Interp *) interp;
|
Interp *iPtr = (Interp *) interp;
|
Tcl_Obj *oldObjResult = iPtr->objResultPtr;
|
Tcl_Obj *oldObjResult = iPtr->objResultPtr;
|
|
|
iPtr->objResultPtr = objPtr;
|
iPtr->objResultPtr = objPtr;
|
Tcl_IncrRefCount(objPtr); /* since interp result is a reference */
|
Tcl_IncrRefCount(objPtr); /* since interp result is a reference */
|
|
|
/*
|
/*
|
* We wait until the end to release the old object result, in case
|
* We wait until the end to release the old object result, in case
|
* we are setting the result to itself.
|
* we are setting the result to itself.
|
*/
|
*/
|
|
|
TclDecrRefCount(oldObjResult);
|
TclDecrRefCount(oldObjResult);
|
|
|
/*
|
/*
|
* Reset the string result since we just set the result object.
|
* Reset the string result since we just set the result object.
|
*/
|
*/
|
|
|
if (iPtr->freeProc != NULL) {
|
if (iPtr->freeProc != NULL) {
|
if ((iPtr->freeProc == TCL_DYNAMIC)
|
if ((iPtr->freeProc == TCL_DYNAMIC)
|
|| (iPtr->freeProc == (Tcl_FreeProc *) free)) {
|
|| (iPtr->freeProc == (Tcl_FreeProc *) free)) {
|
ckfree(iPtr->result);
|
ckfree(iPtr->result);
|
} else {
|
} else {
|
(*iPtr->freeProc)(iPtr->result);
|
(*iPtr->freeProc)(iPtr->result);
|
}
|
}
|
iPtr->freeProc = 0;
|
iPtr->freeProc = 0;
|
}
|
}
|
iPtr->result = iPtr->resultSpace;
|
iPtr->result = iPtr->resultSpace;
|
iPtr->resultSpace[0] = 0;
|
iPtr->resultSpace[0] = 0;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_GetObjResult --
|
* Tcl_GetObjResult --
|
*
|
*
|
* Returns an interpreter's result value as a Tcl object. The object's
|
* Returns an interpreter's result value as a Tcl object. The object's
|
* reference count is not modified; the caller must do that if it
|
* reference count is not modified; the caller must do that if it
|
* needs to hold on to a long-term reference to it.
|
* needs to hold on to a long-term reference to it.
|
*
|
*
|
* Results:
|
* Results:
|
* The interpreter's result as an object.
|
* The interpreter's result as an object.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* If the interpreter has a non-empty string result, the result object
|
* If the interpreter has a non-empty string result, the result object
|
* is either empty or stale because some procedure set interp->result
|
* is either empty or stale because some procedure set interp->result
|
* directly. If so, the string result is moved to the result object
|
* directly. If so, the string result is moved to the result object
|
* then the string result is reset.
|
* then the string result is reset.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
Tcl_Obj *
|
Tcl_Obj *
|
Tcl_GetObjResult(interp)
|
Tcl_GetObjResult(interp)
|
Tcl_Interp *interp; /* Interpreter whose result to return. */
|
Tcl_Interp *interp; /* Interpreter whose result to return. */
|
{
|
{
|
Interp *iPtr = (Interp *) interp;
|
Interp *iPtr = (Interp *) interp;
|
Tcl_Obj *objResultPtr;
|
Tcl_Obj *objResultPtr;
|
int length;
|
int length;
|
|
|
/*
|
/*
|
* If the string result is non-empty, move the string result to the
|
* If the string result is non-empty, move the string result to the
|
* object result, then reset the string result.
|
* object result, then reset the string result.
|
*/
|
*/
|
|
|
if (*(iPtr->result) != 0) {
|
if (*(iPtr->result) != 0) {
|
TclResetObjResult(iPtr);
|
TclResetObjResult(iPtr);
|
|
|
objResultPtr = iPtr->objResultPtr;
|
objResultPtr = iPtr->objResultPtr;
|
length = strlen(iPtr->result);
|
length = strlen(iPtr->result);
|
TclInitStringRep(objResultPtr, iPtr->result, length);
|
TclInitStringRep(objResultPtr, iPtr->result, length);
|
|
|
if (iPtr->freeProc != NULL) {
|
if (iPtr->freeProc != NULL) {
|
if ((iPtr->freeProc == TCL_DYNAMIC)
|
if ((iPtr->freeProc == TCL_DYNAMIC)
|
|| (iPtr->freeProc == (Tcl_FreeProc *) free)) {
|
|| (iPtr->freeProc == (Tcl_FreeProc *) free)) {
|
ckfree(iPtr->result);
|
ckfree(iPtr->result);
|
} else {
|
} else {
|
(*iPtr->freeProc)(iPtr->result);
|
(*iPtr->freeProc)(iPtr->result);
|
}
|
}
|
iPtr->freeProc = 0;
|
iPtr->freeProc = 0;
|
}
|
}
|
iPtr->result = iPtr->resultSpace;
|
iPtr->result = iPtr->resultSpace;
|
iPtr->resultSpace[0] = 0;
|
iPtr->resultSpace[0] = 0;
|
}
|
}
|
return iPtr->objResultPtr;
|
return iPtr->objResultPtr;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_AppendResult --
|
* Tcl_AppendResult --
|
*
|
*
|
* Append a variable number of strings onto the interpreter's string
|
* Append a variable number of strings onto the interpreter's string
|
* result.
|
* result.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* The result of the interpreter given by the first argument is
|
* The result of the interpreter given by the first argument is
|
* extended by the strings given by the second and following arguments
|
* extended by the strings given by the second and following arguments
|
* (up to a terminating NULL argument).
|
* (up to a terminating NULL argument).
|
*
|
*
|
* If the string result is empty, the object result is moved to the
|
* If the string result is empty, the object result is moved to the
|
* string result, then the object result is reset.
|
* string result, then the object result is reset.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
void
|
void
|
Tcl_AppendResult TCL_VARARGS_DEF(Tcl_Interp *,arg1)
|
Tcl_AppendResult TCL_VARARGS_DEF(Tcl_Interp *,arg1)
|
{
|
{
|
va_list argList;
|
va_list argList;
|
Interp *iPtr;
|
Interp *iPtr;
|
char *string;
|
char *string;
|
int newSpace;
|
int newSpace;
|
|
|
/*
|
/*
|
* If the string result is empty, move the object result to the
|
* If the string result is empty, move the object result to the
|
* string result, then reset the object result.
|
* string result, then reset the object result.
|
* FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS.
|
* FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS.
|
*/
|
*/
|
|
|
iPtr = (Interp *) TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
|
iPtr = (Interp *) TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
|
if (*(iPtr->result) == 0) {
|
if (*(iPtr->result) == 0) {
|
Tcl_SetResult((Tcl_Interp *) iPtr,
|
Tcl_SetResult((Tcl_Interp *) iPtr,
|
TclGetStringFromObj(Tcl_GetObjResult((Tcl_Interp *) iPtr),
|
TclGetStringFromObj(Tcl_GetObjResult((Tcl_Interp *) iPtr),
|
(int *) NULL),
|
(int *) NULL),
|
TCL_VOLATILE);
|
TCL_VOLATILE);
|
}
|
}
|
|
|
/*
|
/*
|
* Scan through all the arguments to see how much space is needed.
|
* Scan through all the arguments to see how much space is needed.
|
*/
|
*/
|
|
|
newSpace = 0;
|
newSpace = 0;
|
while (1) {
|
while (1) {
|
string = va_arg(argList, char *);
|
string = va_arg(argList, char *);
|
if (string == NULL) {
|
if (string == NULL) {
|
break;
|
break;
|
}
|
}
|
newSpace += strlen(string);
|
newSpace += strlen(string);
|
}
|
}
|
va_end(argList);
|
va_end(argList);
|
|
|
/*
|
/*
|
* If the append buffer isn't already setup and large enough to hold
|
* If the append buffer isn't already setup and large enough to hold
|
* the new data, set it up.
|
* the new data, set it up.
|
*/
|
*/
|
|
|
if ((iPtr->result != iPtr->appendResult)
|
if ((iPtr->result != iPtr->appendResult)
|
|| (iPtr->appendResult[iPtr->appendUsed] != 0)
|
|| (iPtr->appendResult[iPtr->appendUsed] != 0)
|
|| ((newSpace + iPtr->appendUsed) >= iPtr->appendAvl)) {
|
|| ((newSpace + iPtr->appendUsed) >= iPtr->appendAvl)) {
|
SetupAppendBuffer(iPtr, newSpace);
|
SetupAppendBuffer(iPtr, newSpace);
|
}
|
}
|
|
|
/*
|
/*
|
* Now go through all the argument strings again, copying them into the
|
* Now go through all the argument strings again, copying them into the
|
* buffer.
|
* buffer.
|
*/
|
*/
|
|
|
TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
|
TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
|
while (1) {
|
while (1) {
|
string = va_arg(argList, char *);
|
string = va_arg(argList, char *);
|
if (string == NULL) {
|
if (string == NULL) {
|
break;
|
break;
|
}
|
}
|
strcpy(iPtr->appendResult + iPtr->appendUsed, string);
|
strcpy(iPtr->appendResult + iPtr->appendUsed, string);
|
iPtr->appendUsed += strlen(string);
|
iPtr->appendUsed += strlen(string);
|
}
|
}
|
va_end(argList);
|
va_end(argList);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_AppendElement --
|
* Tcl_AppendElement --
|
*
|
*
|
* Convert a string to a valid Tcl list element and append it to the
|
* Convert a string to a valid Tcl list element and append it to the
|
* result (which is ostensibly a list).
|
* result (which is ostensibly a list).
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* The result in the interpreter given by the first argument is
|
* The result in the interpreter given by the first argument is
|
* extended with a list element converted from string. A separator
|
* extended with a list element converted from string. A separator
|
* space is added before the converted list element unless the current
|
* space is added before the converted list element unless the current
|
* result is empty, contains the single character "{", or ends in " {".
|
* result is empty, contains the single character "{", or ends in " {".
|
*
|
*
|
* If the string result is empty, the object result is moved to the
|
* If the string result is empty, the object result is moved to the
|
* string result, then the object result is reset.
|
* string result, then the object result is reset.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
void
|
void
|
Tcl_AppendElement(interp, string)
|
Tcl_AppendElement(interp, string)
|
Tcl_Interp *interp; /* Interpreter whose result is to be
|
Tcl_Interp *interp; /* Interpreter whose result is to be
|
* extended. */
|
* extended. */
|
char *string; /* String to convert to list element and
|
char *string; /* String to convert to list element and
|
* add to result. */
|
* add to result. */
|
{
|
{
|
Interp *iPtr = (Interp *) interp;
|
Interp *iPtr = (Interp *) interp;
|
char *dst;
|
char *dst;
|
int size;
|
int size;
|
int flags;
|
int flags;
|
|
|
/*
|
/*
|
* If the string result is empty, move the object result to the
|
* If the string result is empty, move the object result to the
|
* string result, then reset the object result.
|
* string result, then reset the object result.
|
* FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS.
|
* FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS.
|
*/
|
*/
|
|
|
if (*(iPtr->result) == 0) {
|
if (*(iPtr->result) == 0) {
|
Tcl_SetResult(interp,
|
Tcl_SetResult(interp,
|
TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL),
|
TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL),
|
TCL_VOLATILE);
|
TCL_VOLATILE);
|
}
|
}
|
|
|
/*
|
/*
|
* See how much space is needed, and grow the append buffer if
|
* See how much space is needed, and grow the append buffer if
|
* needed to accommodate the list element.
|
* needed to accommodate the list element.
|
*/
|
*/
|
|
|
size = Tcl_ScanElement(string, &flags) + 1;
|
size = Tcl_ScanElement(string, &flags) + 1;
|
if ((iPtr->result != iPtr->appendResult)
|
if ((iPtr->result != iPtr->appendResult)
|
|| (iPtr->appendResult[iPtr->appendUsed] != 0)
|
|| (iPtr->appendResult[iPtr->appendUsed] != 0)
|
|| ((size + iPtr->appendUsed) >= iPtr->appendAvl)) {
|
|| ((size + iPtr->appendUsed) >= iPtr->appendAvl)) {
|
SetupAppendBuffer(iPtr, size+iPtr->appendUsed);
|
SetupAppendBuffer(iPtr, size+iPtr->appendUsed);
|
}
|
}
|
|
|
/*
|
/*
|
* Convert the string into a list element and copy it to the
|
* Convert the string into a list element and copy it to the
|
* buffer that's forming, with a space separator if needed.
|
* buffer that's forming, with a space separator if needed.
|
*/
|
*/
|
|
|
dst = iPtr->appendResult + iPtr->appendUsed;
|
dst = iPtr->appendResult + iPtr->appendUsed;
|
if (TclNeedSpace(iPtr->appendResult, dst)) {
|
if (TclNeedSpace(iPtr->appendResult, dst)) {
|
iPtr->appendUsed++;
|
iPtr->appendUsed++;
|
*dst = ' ';
|
*dst = ' ';
|
dst++;
|
dst++;
|
}
|
}
|
iPtr->appendUsed += Tcl_ConvertElement(string, dst, flags);
|
iPtr->appendUsed += Tcl_ConvertElement(string, dst, flags);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* SetupAppendBuffer --
|
* SetupAppendBuffer --
|
*
|
*
|
* This procedure makes sure that there is an append buffer properly
|
* This procedure makes sure that there is an append buffer properly
|
* initialized, if necessary, from the interpreter's result, and
|
* initialized, if necessary, from the interpreter's result, and
|
* that it has at least enough room to accommodate newSpace new
|
* that it has at least enough room to accommodate newSpace new
|
* bytes of information.
|
* bytes of information.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static void
|
static void
|
SetupAppendBuffer(iPtr, newSpace)
|
SetupAppendBuffer(iPtr, newSpace)
|
Interp *iPtr; /* Interpreter whose result is being set up. */
|
Interp *iPtr; /* Interpreter whose result is being set up. */
|
int newSpace; /* Make sure that at least this many bytes
|
int newSpace; /* Make sure that at least this many bytes
|
* of new information may be added. */
|
* of new information may be added. */
|
{
|
{
|
int totalSpace;
|
int totalSpace;
|
|
|
/*
|
/*
|
* Make the append buffer larger, if that's necessary, then copy the
|
* Make the append buffer larger, if that's necessary, then copy the
|
* result into the append buffer and make the append buffer the official
|
* result into the append buffer and make the append buffer the official
|
* Tcl result.
|
* Tcl result.
|
*/
|
*/
|
|
|
if (iPtr->result != iPtr->appendResult) {
|
if (iPtr->result != iPtr->appendResult) {
|
/*
|
/*
|
* If an oversized buffer was used recently, then free it up
|
* If an oversized buffer was used recently, then free it up
|
* so we go back to a smaller buffer. This avoids tying up
|
* so we go back to a smaller buffer. This avoids tying up
|
* memory forever after a large operation.
|
* memory forever after a large operation.
|
*/
|
*/
|
|
|
if (iPtr->appendAvl > 500) {
|
if (iPtr->appendAvl > 500) {
|
ckfree(iPtr->appendResult);
|
ckfree(iPtr->appendResult);
|
iPtr->appendResult = NULL;
|
iPtr->appendResult = NULL;
|
iPtr->appendAvl = 0;
|
iPtr->appendAvl = 0;
|
}
|
}
|
iPtr->appendUsed = strlen(iPtr->result);
|
iPtr->appendUsed = strlen(iPtr->result);
|
} else if (iPtr->result[iPtr->appendUsed] != 0) {
|
} else if (iPtr->result[iPtr->appendUsed] != 0) {
|
/*
|
/*
|
* Most likely someone has modified a result created by
|
* Most likely someone has modified a result created by
|
* Tcl_AppendResult et al. so that it has a different size.
|
* Tcl_AppendResult et al. so that it has a different size.
|
* Just recompute the size.
|
* Just recompute the size.
|
*/
|
*/
|
|
|
iPtr->appendUsed = strlen(iPtr->result);
|
iPtr->appendUsed = strlen(iPtr->result);
|
}
|
}
|
|
|
totalSpace = newSpace + iPtr->appendUsed;
|
totalSpace = newSpace + iPtr->appendUsed;
|
if (totalSpace >= iPtr->appendAvl) {
|
if (totalSpace >= iPtr->appendAvl) {
|
char *new;
|
char *new;
|
|
|
if (totalSpace < 100) {
|
if (totalSpace < 100) {
|
totalSpace = 200;
|
totalSpace = 200;
|
} else {
|
} else {
|
totalSpace *= 2;
|
totalSpace *= 2;
|
}
|
}
|
new = (char *) ckalloc((unsigned) totalSpace);
|
new = (char *) ckalloc((unsigned) totalSpace);
|
strcpy(new, iPtr->result);
|
strcpy(new, iPtr->result);
|
if (iPtr->appendResult != NULL) {
|
if (iPtr->appendResult != NULL) {
|
ckfree(iPtr->appendResult);
|
ckfree(iPtr->appendResult);
|
}
|
}
|
iPtr->appendResult = new;
|
iPtr->appendResult = new;
|
iPtr->appendAvl = totalSpace;
|
iPtr->appendAvl = totalSpace;
|
} else if (iPtr->result != iPtr->appendResult) {
|
} else if (iPtr->result != iPtr->appendResult) {
|
strcpy(iPtr->appendResult, iPtr->result);
|
strcpy(iPtr->appendResult, iPtr->result);
|
}
|
}
|
|
|
Tcl_FreeResult((Tcl_Interp *) iPtr);
|
Tcl_FreeResult((Tcl_Interp *) iPtr);
|
iPtr->result = iPtr->appendResult;
|
iPtr->result = iPtr->appendResult;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_FreeResult --
|
* Tcl_FreeResult --
|
*
|
*
|
* This procedure frees up the memory associated with an interpreter's
|
* This procedure frees up the memory associated with an interpreter's
|
* string result. It also resets the interpreter's result object.
|
* string result. It also resets the interpreter's result object.
|
* Tcl_FreeResult is most commonly used when a procedure is about to
|
* Tcl_FreeResult is most commonly used when a procedure is about to
|
* replace one result value with another.
|
* replace one result value with another.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Frees the memory associated with interp's string result and sets
|
* Frees the memory associated with interp's string result and sets
|
* interp->freeProc to zero, but does not change interp->result or
|
* interp->freeProc to zero, but does not change interp->result or
|
* clear error state. Resets interp's result object to an unshared
|
* clear error state. Resets interp's result object to an unshared
|
* empty object.
|
* empty object.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
void
|
void
|
Tcl_FreeResult(interp)
|
Tcl_FreeResult(interp)
|
Tcl_Interp *interp; /* Interpreter for which to free result. */
|
Tcl_Interp *interp; /* Interpreter for which to free result. */
|
{
|
{
|
Interp *iPtr = (Interp *) interp;
|
Interp *iPtr = (Interp *) interp;
|
|
|
if (iPtr->freeProc != NULL) {
|
if (iPtr->freeProc != NULL) {
|
if ((iPtr->freeProc == TCL_DYNAMIC)
|
if ((iPtr->freeProc == TCL_DYNAMIC)
|
|| (iPtr->freeProc == (Tcl_FreeProc *) free)) {
|
|| (iPtr->freeProc == (Tcl_FreeProc *) free)) {
|
ckfree(iPtr->result);
|
ckfree(iPtr->result);
|
} else {
|
} else {
|
(*iPtr->freeProc)(iPtr->result);
|
(*iPtr->freeProc)(iPtr->result);
|
}
|
}
|
iPtr->freeProc = 0;
|
iPtr->freeProc = 0;
|
}
|
}
|
|
|
TclResetObjResult(iPtr);
|
TclResetObjResult(iPtr);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_ResetResult --
|
* Tcl_ResetResult --
|
*
|
*
|
* This procedure resets both the interpreter's string and object
|
* This procedure resets both the interpreter's string and object
|
* results.
|
* results.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* It resets the result object to an unshared empty object. It
|
* It resets the result object to an unshared empty object. It
|
* then restores the interpreter's string result area to its default
|
* then restores the interpreter's string result area to its default
|
* initialized state, freeing up any memory that may have been
|
* initialized state, freeing up any memory that may have been
|
* allocated. It also clears any error information for the interpreter.
|
* allocated. It also clears any error information for the interpreter.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
void
|
void
|
Tcl_ResetResult(interp)
|
Tcl_ResetResult(interp)
|
Tcl_Interp *interp; /* Interpreter for which to clear result. */
|
Tcl_Interp *interp; /* Interpreter for which to clear result. */
|
{
|
{
|
Interp *iPtr = (Interp *) interp;
|
Interp *iPtr = (Interp *) interp;
|
|
|
TclResetObjResult(iPtr);
|
TclResetObjResult(iPtr);
|
|
|
Tcl_FreeResult(interp);
|
Tcl_FreeResult(interp);
|
iPtr->result = iPtr->resultSpace;
|
iPtr->result = iPtr->resultSpace;
|
iPtr->resultSpace[0] = 0;
|
iPtr->resultSpace[0] = 0;
|
|
|
iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS | ERROR_CODE_SET);
|
iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS | ERROR_CODE_SET);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_SetErrorCode --
|
* Tcl_SetErrorCode --
|
*
|
*
|
* This procedure is called to record machine-readable information
|
* This procedure is called to record machine-readable information
|
* about an error that is about to be returned.
|
* about an error that is about to be returned.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* The errorCode global variable is modified to hold all of the
|
* The errorCode global variable is modified to hold all of the
|
* arguments to this procedure, in a list form with each argument
|
* arguments to this procedure, in a list form with each argument
|
* becoming one element of the list. A flag is set internally
|
* becoming one element of the list. A flag is set internally
|
* to remember that errorCode has been set, so the variable doesn't
|
* to remember that errorCode has been set, so the variable doesn't
|
* get set automatically when the error is returned.
|
* get set automatically when the error is returned.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
/* VARARGS2 */
|
/* VARARGS2 */
|
void
|
void
|
Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1)
|
Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1)
|
{
|
{
|
va_list argList;
|
va_list argList;
|
char *string;
|
char *string;
|
int flags;
|
int flags;
|
Interp *iPtr;
|
Interp *iPtr;
|
|
|
/*
|
/*
|
* Scan through the arguments one at a time, appending them to
|
* Scan through the arguments one at a time, appending them to
|
* $errorCode as list elements.
|
* $errorCode as list elements.
|
*/
|
*/
|
|
|
iPtr = (Interp *) TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
|
iPtr = (Interp *) TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
|
flags = TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT;
|
flags = TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT;
|
while (1) {
|
while (1) {
|
string = va_arg(argList, char *);
|
string = va_arg(argList, char *);
|
if (string == NULL) {
|
if (string == NULL) {
|
break;
|
break;
|
}
|
}
|
(void) Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode",
|
(void) Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode",
|
(char *) NULL, string, flags);
|
(char *) NULL, string, flags);
|
flags |= TCL_APPEND_VALUE;
|
flags |= TCL_APPEND_VALUE;
|
}
|
}
|
va_end(argList);
|
va_end(argList);
|
iPtr->flags |= ERROR_CODE_SET;
|
iPtr->flags |= ERROR_CODE_SET;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_SetObjErrorCode --
|
* Tcl_SetObjErrorCode --
|
*
|
*
|
* This procedure is called to record machine-readable information
|
* This procedure is called to record machine-readable information
|
* about an error that is about to be returned. The caller should
|
* about an error that is about to be returned. The caller should
|
* build a list object up and pass it to this routine.
|
* build a list object up and pass it to this routine.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* The errorCode global variable is modified to be the new value.
|
* The errorCode global variable is modified to be the new value.
|
* A flag is set internally to remember that errorCode has been
|
* A flag is set internally to remember that errorCode has been
|
* set, so the variable doesn't get set automatically when the
|
* set, so the variable doesn't get set automatically when the
|
* error is returned.
|
* error is returned.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
void
|
void
|
Tcl_SetObjErrorCode(interp, errorObjPtr)
|
Tcl_SetObjErrorCode(interp, errorObjPtr)
|
Tcl_Interp *interp;
|
Tcl_Interp *interp;
|
Tcl_Obj *errorObjPtr;
|
Tcl_Obj *errorObjPtr;
|
{
|
{
|
Tcl_Obj *namePtr;
|
Tcl_Obj *namePtr;
|
Interp *iPtr;
|
Interp *iPtr;
|
|
|
namePtr = Tcl_NewStringObj("errorCode", -1);
|
namePtr = Tcl_NewStringObj("errorCode", -1);
|
iPtr = (Interp *) interp;
|
iPtr = (Interp *) interp;
|
Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL, errorObjPtr,
|
Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL, errorObjPtr,
|
TCL_GLOBAL_ONLY);
|
TCL_GLOBAL_ONLY);
|
iPtr->flags |= ERROR_CODE_SET;
|
iPtr->flags |= ERROR_CODE_SET;
|
Tcl_DecrRefCount(namePtr);
|
Tcl_DecrRefCount(namePtr);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_RegExpCompile --
|
* Tcl_RegExpCompile --
|
*
|
*
|
* Compile a regular expression into a form suitable for fast
|
* Compile a regular expression into a form suitable for fast
|
* matching. This procedure retains a small cache of pre-compiled
|
* matching. This procedure retains a small cache of pre-compiled
|
* regular expressions in the interpreter, in order to avoid
|
* regular expressions in the interpreter, in order to avoid
|
* compilation costs as much as possible.
|
* compilation costs as much as possible.
|
*
|
*
|
* Results:
|
* Results:
|
* The return value is a pointer to the compiled form of string,
|
* The return value is a pointer to the compiled form of string,
|
* suitable for passing to Tcl_RegExpExec. This compiled form
|
* suitable for passing to Tcl_RegExpExec. This compiled form
|
* is only valid up until the next call to this procedure, so
|
* is only valid up until the next call to this procedure, so
|
* don't keep these around for a long time! If an error occurred
|
* don't keep these around for a long time! If an error occurred
|
* while compiling the pattern, then NULL is returned and an error
|
* while compiling the pattern, then NULL is returned and an error
|
* message is left in interp->result.
|
* message is left in interp->result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* The cache of compiled regexp's in interp will be modified to
|
* The cache of compiled regexp's in interp will be modified to
|
* hold information for string, if such information isn't already
|
* hold information for string, if such information isn't already
|
* present in the cache.
|
* present in the cache.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
Tcl_RegExp
|
Tcl_RegExp
|
Tcl_RegExpCompile(interp, string)
|
Tcl_RegExpCompile(interp, string)
|
Tcl_Interp *interp; /* For use in error reporting. */
|
Tcl_Interp *interp; /* For use in error reporting. */
|
char *string; /* String for which to produce
|
char *string; /* String for which to produce
|
* compiled regular expression. */
|
* compiled regular expression. */
|
{
|
{
|
Interp *iPtr = (Interp *) interp;
|
Interp *iPtr = (Interp *) interp;
|
int i, length;
|
int i, length;
|
regexp *result;
|
regexp *result;
|
|
|
length = strlen(string);
|
length = strlen(string);
|
for (i = 0; i < NUM_REGEXPS; i++) {
|
for (i = 0; i < NUM_REGEXPS; i++) {
|
if ((length == iPtr->patLengths[i])
|
if ((length == iPtr->patLengths[i])
|
&& (strcmp(string, iPtr->patterns[i]) == 0)) {
|
&& (strcmp(string, iPtr->patterns[i]) == 0)) {
|
/*
|
/*
|
* Move the matched pattern to the first slot in the
|
* Move the matched pattern to the first slot in the
|
* cache and shift the other patterns down one position.
|
* cache and shift the other patterns down one position.
|
*/
|
*/
|
|
|
if (i != 0) {
|
if (i != 0) {
|
int j;
|
int j;
|
char *cachedString;
|
char *cachedString;
|
|
|
cachedString = iPtr->patterns[i];
|
cachedString = iPtr->patterns[i];
|
result = iPtr->regexps[i];
|
result = iPtr->regexps[i];
|
for (j = i-1; j >= 0; j--) {
|
for (j = i-1; j >= 0; j--) {
|
iPtr->patterns[j+1] = iPtr->patterns[j];
|
iPtr->patterns[j+1] = iPtr->patterns[j];
|
iPtr->patLengths[j+1] = iPtr->patLengths[j];
|
iPtr->patLengths[j+1] = iPtr->patLengths[j];
|
iPtr->regexps[j+1] = iPtr->regexps[j];
|
iPtr->regexps[j+1] = iPtr->regexps[j];
|
}
|
}
|
iPtr->patterns[0] = cachedString;
|
iPtr->patterns[0] = cachedString;
|
iPtr->patLengths[0] = length;
|
iPtr->patLengths[0] = length;
|
iPtr->regexps[0] = result;
|
iPtr->regexps[0] = result;
|
}
|
}
|
return (Tcl_RegExp) iPtr->regexps[0];
|
return (Tcl_RegExp) iPtr->regexps[0];
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* No match in the cache. Compile the string and add it to the
|
* No match in the cache. Compile the string and add it to the
|
* cache.
|
* cache.
|
*/
|
*/
|
|
|
TclRegError((char *) NULL);
|
TclRegError((char *) NULL);
|
result = TclRegComp(string);
|
result = TclRegComp(string);
|
if (TclGetRegError() != NULL) {
|
if (TclGetRegError() != NULL) {
|
Tcl_AppendResult(interp,
|
Tcl_AppendResult(interp,
|
"couldn't compile regular expression pattern: ",
|
"couldn't compile regular expression pattern: ",
|
TclGetRegError(), (char *) NULL);
|
TclGetRegError(), (char *) NULL);
|
return NULL;
|
return NULL;
|
}
|
}
|
if (iPtr->patterns[NUM_REGEXPS-1] != NULL) {
|
if (iPtr->patterns[NUM_REGEXPS-1] != NULL) {
|
ckfree(iPtr->patterns[NUM_REGEXPS-1]);
|
ckfree(iPtr->patterns[NUM_REGEXPS-1]);
|
ckfree((char *) iPtr->regexps[NUM_REGEXPS-1]);
|
ckfree((char *) iPtr->regexps[NUM_REGEXPS-1]);
|
}
|
}
|
for (i = NUM_REGEXPS - 2; i >= 0; i--) {
|
for (i = NUM_REGEXPS - 2; i >= 0; i--) {
|
iPtr->patterns[i+1] = iPtr->patterns[i];
|
iPtr->patterns[i+1] = iPtr->patterns[i];
|
iPtr->patLengths[i+1] = iPtr->patLengths[i];
|
iPtr->patLengths[i+1] = iPtr->patLengths[i];
|
iPtr->regexps[i+1] = iPtr->regexps[i];
|
iPtr->regexps[i+1] = iPtr->regexps[i];
|
}
|
}
|
iPtr->patterns[0] = (char *) ckalloc((unsigned) (length+1));
|
iPtr->patterns[0] = (char *) ckalloc((unsigned) (length+1));
|
strcpy(iPtr->patterns[0], string);
|
strcpy(iPtr->patterns[0], string);
|
iPtr->patLengths[0] = length;
|
iPtr->patLengths[0] = length;
|
iPtr->regexps[0] = result;
|
iPtr->regexps[0] = result;
|
return (Tcl_RegExp) result;
|
return (Tcl_RegExp) result;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_RegExpExec --
|
* Tcl_RegExpExec --
|
*
|
*
|
* Execute the regular expression matcher using a compiled form
|
* Execute the regular expression matcher using a compiled form
|
* of a regular expression and save information about any match
|
* of a regular expression and save information about any match
|
* that is found.
|
* that is found.
|
*
|
*
|
* Results:
|
* Results:
|
* If an error occurs during the matching operation then -1
|
* If an error occurs during the matching operation then -1
|
* is returned and interp->result contains an error message.
|
* is returned and interp->result contains an error message.
|
* Otherwise the return value is 1 if a matching range is
|
* Otherwise the return value is 1 if a matching range is
|
* found and 0 if there is no matching range.
|
* found and 0 if there is no matching range.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_RegExpExec(interp, re, string, start)
|
Tcl_RegExpExec(interp, re, string, start)
|
Tcl_Interp *interp; /* Interpreter to use for error reporting. */
|
Tcl_Interp *interp; /* Interpreter to use for error reporting. */
|
Tcl_RegExp re; /* Compiled regular expression; must have
|
Tcl_RegExp re; /* Compiled regular expression; must have
|
* been returned by previous call to
|
* been returned by previous call to
|
* Tcl_RegExpCompile. */
|
* Tcl_RegExpCompile. */
|
char *string; /* String against which to match re. */
|
char *string; /* String against which to match re. */
|
char *start; /* If string is part of a larger string,
|
char *start; /* If string is part of a larger string,
|
* this identifies beginning of larger
|
* this identifies beginning of larger
|
* string, so that "^" won't match. */
|
* string, so that "^" won't match. */
|
{
|
{
|
int match;
|
int match;
|
|
|
regexp *regexpPtr = (regexp *) re;
|
regexp *regexpPtr = (regexp *) re;
|
TclRegError((char *) NULL);
|
TclRegError((char *) NULL);
|
match = TclRegExec(regexpPtr, string, start);
|
match = TclRegExec(regexpPtr, string, start);
|
if (TclGetRegError() != NULL) {
|
if (TclGetRegError() != NULL) {
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
Tcl_AppendResult(interp, "error while matching regular expression: ",
|
Tcl_AppendResult(interp, "error while matching regular expression: ",
|
TclGetRegError(), (char *) NULL);
|
TclGetRegError(), (char *) NULL);
|
return -1;
|
return -1;
|
}
|
}
|
return match;
|
return match;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_RegExpRange --
|
* Tcl_RegExpRange --
|
*
|
*
|
* Returns pointers describing the range of a regular expression match,
|
* Returns pointers describing the range of a regular expression match,
|
* or one of the subranges within the match.
|
* or one of the subranges within the match.
|
*
|
*
|
* Results:
|
* Results:
|
* The variables at *startPtr and *endPtr are modified to hold the
|
* The variables at *startPtr and *endPtr are modified to hold the
|
* addresses of the endpoints of the range given by index. If the
|
* addresses of the endpoints of the range given by index. If the
|
* specified range doesn't exist then NULLs are returned.
|
* specified range doesn't exist then NULLs are returned.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
void
|
void
|
Tcl_RegExpRange(re, index, startPtr, endPtr)
|
Tcl_RegExpRange(re, index, startPtr, endPtr)
|
Tcl_RegExp re; /* Compiled regular expression that has
|
Tcl_RegExp re; /* Compiled regular expression that has
|
* been passed to Tcl_RegExpExec. */
|
* been passed to Tcl_RegExpExec. */
|
int index; /* 0 means give the range of the entire
|
int index; /* 0 means give the range of the entire
|
* match, > 0 means give the range of
|
* match, > 0 means give the range of
|
* a matching subrange. Must be no greater
|
* a matching subrange. Must be no greater
|
* than NSUBEXP. */
|
* than NSUBEXP. */
|
char **startPtr; /* Store address of first character in
|
char **startPtr; /* Store address of first character in
|
* (sub-) range here. */
|
* (sub-) range here. */
|
char **endPtr; /* Store address of character just after last
|
char **endPtr; /* Store address of character just after last
|
* in (sub-) range here. */
|
* in (sub-) range here. */
|
{
|
{
|
regexp *regexpPtr = (regexp *) re;
|
regexp *regexpPtr = (regexp *) re;
|
|
|
if (index >= NSUBEXP) {
|
if (index >= NSUBEXP) {
|
*startPtr = *endPtr = NULL;
|
*startPtr = *endPtr = NULL;
|
} else {
|
} else {
|
*startPtr = regexpPtr->startp[index];
|
*startPtr = regexpPtr->startp[index];
|
*endPtr = regexpPtr->endp[index];
|
*endPtr = regexpPtr->endp[index];
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_RegExpMatch --
|
* Tcl_RegExpMatch --
|
*
|
*
|
* See if a string matches a regular expression.
|
* See if a string matches a regular expression.
|
*
|
*
|
* Results:
|
* Results:
|
* If an error occurs during the matching operation then -1
|
* If an error occurs during the matching operation then -1
|
* is returned and interp->result contains an error message.
|
* is returned and interp->result contains an error message.
|
* Otherwise the return value is 1 if "string" matches "pattern"
|
* Otherwise the return value is 1 if "string" matches "pattern"
|
* and 0 otherwise.
|
* and 0 otherwise.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_RegExpMatch(interp, string, pattern)
|
Tcl_RegExpMatch(interp, string, pattern)
|
Tcl_Interp *interp; /* Used for error reporting. */
|
Tcl_Interp *interp; /* Used for error reporting. */
|
char *string; /* String. */
|
char *string; /* String. */
|
char *pattern; /* Regular expression to match against
|
char *pattern; /* Regular expression to match against
|
* string. */
|
* string. */
|
{
|
{
|
Tcl_RegExp re;
|
Tcl_RegExp re;
|
|
|
re = Tcl_RegExpCompile(interp, pattern);
|
re = Tcl_RegExpCompile(interp, pattern);
|
if (re == NULL) {
|
if (re == NULL) {
|
return -1;
|
return -1;
|
}
|
}
|
return Tcl_RegExpExec(interp, re, string, string);
|
return Tcl_RegExpExec(interp, re, string, string);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_DStringInit --
|
* Tcl_DStringInit --
|
*
|
*
|
* Initializes a dynamic string, discarding any previous contents
|
* Initializes a dynamic string, discarding any previous contents
|
* of the string (Tcl_DStringFree should have been called already
|
* of the string (Tcl_DStringFree should have been called already
|
* if the dynamic string was previously in use).
|
* if the dynamic string was previously in use).
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* The dynamic string is initialized to be empty.
|
* The dynamic string is initialized to be empty.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
void
|
void
|
Tcl_DStringInit(dsPtr)
|
Tcl_DStringInit(dsPtr)
|
Tcl_DString *dsPtr; /* Pointer to structure for dynamic string. */
|
Tcl_DString *dsPtr; /* Pointer to structure for dynamic string. */
|
{
|
{
|
dsPtr->string = dsPtr->staticSpace;
|
dsPtr->string = dsPtr->staticSpace;
|
dsPtr->length = 0;
|
dsPtr->length = 0;
|
dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
|
dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
|
dsPtr->staticSpace[0] = 0;
|
dsPtr->staticSpace[0] = 0;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_DStringAppend --
|
* Tcl_DStringAppend --
|
*
|
*
|
* Append more characters to the current value of a dynamic string.
|
* Append more characters to the current value of a dynamic string.
|
*
|
*
|
* Results:
|
* Results:
|
* The return value is a pointer to the dynamic string's new value.
|
* The return value is a pointer to the dynamic string's new value.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Length bytes from string (or all of string if length is less
|
* Length bytes from string (or all of string if length is less
|
* than zero) are added to the current value of the string. Memory
|
* than zero) are added to the current value of the string. Memory
|
* gets reallocated if needed to accomodate the string's new size.
|
* gets reallocated if needed to accomodate the string's new size.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
char *
|
char *
|
Tcl_DStringAppend(dsPtr, string, length)
|
Tcl_DStringAppend(dsPtr, string, length)
|
Tcl_DString *dsPtr; /* Structure describing dynamic string. */
|
Tcl_DString *dsPtr; /* Structure describing dynamic string. */
|
CONST char *string; /* String to append. If length is -1 then
|
CONST char *string; /* String to append. If length is -1 then
|
* this must be null-terminated. */
|
* this must be null-terminated. */
|
int length; /* Number of characters from string to
|
int length; /* Number of characters from string to
|
* append. If < 0, then append all of string,
|
* append. If < 0, then append all of string,
|
* up to null at end. */
|
* up to null at end. */
|
{
|
{
|
int newSize;
|
int newSize;
|
char *newString, *dst;
|
char *newString, *dst;
|
CONST char *end;
|
CONST char *end;
|
|
|
if (length < 0) {
|
if (length < 0) {
|
length = strlen(string);
|
length = strlen(string);
|
}
|
}
|
newSize = length + dsPtr->length;
|
newSize = length + dsPtr->length;
|
|
|
/*
|
/*
|
* Allocate a larger buffer for the string if the current one isn't
|
* Allocate a larger buffer for the string if the current one isn't
|
* large enough. Allocate extra space in the new buffer so that there
|
* large enough. Allocate extra space in the new buffer so that there
|
* will be room to grow before we have to allocate again.
|
* will be room to grow before we have to allocate again.
|
*/
|
*/
|
|
|
if (newSize >= dsPtr->spaceAvl) {
|
if (newSize >= dsPtr->spaceAvl) {
|
dsPtr->spaceAvl = newSize*2;
|
dsPtr->spaceAvl = newSize*2;
|
newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl);
|
newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl);
|
memcpy((VOID *) newString, (VOID *) dsPtr->string,
|
memcpy((VOID *) newString, (VOID *) dsPtr->string,
|
(size_t) dsPtr->length);
|
(size_t) dsPtr->length);
|
if (dsPtr->string != dsPtr->staticSpace) {
|
if (dsPtr->string != dsPtr->staticSpace) {
|
ckfree(dsPtr->string);
|
ckfree(dsPtr->string);
|
}
|
}
|
dsPtr->string = newString;
|
dsPtr->string = newString;
|
}
|
}
|
|
|
/*
|
/*
|
* Copy the new string into the buffer at the end of the old
|
* Copy the new string into the buffer at the end of the old
|
* one.
|
* one.
|
*/
|
*/
|
|
|
for (dst = dsPtr->string + dsPtr->length, end = string+length;
|
for (dst = dsPtr->string + dsPtr->length, end = string+length;
|
string < end; string++, dst++) {
|
string < end; string++, dst++) {
|
*dst = *string;
|
*dst = *string;
|
}
|
}
|
*dst = '\0';
|
*dst = '\0';
|
dsPtr->length += length;
|
dsPtr->length += length;
|
return dsPtr->string;
|
return dsPtr->string;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_DStringAppendElement --
|
* Tcl_DStringAppendElement --
|
*
|
*
|
* Append a list element to the current value of a dynamic string.
|
* Append a list element to the current value of a dynamic string.
|
*
|
*
|
* Results:
|
* Results:
|
* The return value is a pointer to the dynamic string's new value.
|
* The return value is a pointer to the dynamic string's new value.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* String is reformatted as a list element and added to the current
|
* String is reformatted as a list element and added to the current
|
* value of the string. Memory gets reallocated if needed to
|
* value of the string. Memory gets reallocated if needed to
|
* accomodate the string's new size.
|
* accomodate the string's new size.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
char *
|
char *
|
Tcl_DStringAppendElement(dsPtr, string)
|
Tcl_DStringAppendElement(dsPtr, string)
|
Tcl_DString *dsPtr; /* Structure describing dynamic string. */
|
Tcl_DString *dsPtr; /* Structure describing dynamic string. */
|
CONST char *string; /* String to append. Must be
|
CONST char *string; /* String to append. Must be
|
* null-terminated. */
|
* null-terminated. */
|
{
|
{
|
int newSize, flags;
|
int newSize, flags;
|
char *dst, *newString;
|
char *dst, *newString;
|
|
|
newSize = Tcl_ScanElement(string, &flags) + dsPtr->length + 1;
|
newSize = Tcl_ScanElement(string, &flags) + dsPtr->length + 1;
|
|
|
/*
|
/*
|
* Allocate a larger buffer for the string if the current one isn't
|
* Allocate a larger buffer for the string if the current one isn't
|
* large enough. Allocate extra space in the new buffer so that there
|
* large enough. Allocate extra space in the new buffer so that there
|
* will be room to grow before we have to allocate again.
|
* will be room to grow before we have to allocate again.
|
* SPECIAL NOTE: must use memcpy, not strcpy, to copy the string
|
* SPECIAL NOTE: must use memcpy, not strcpy, to copy the string
|
* to a larger buffer, since there may be embedded NULLs in the
|
* to a larger buffer, since there may be embedded NULLs in the
|
* string in some cases.
|
* string in some cases.
|
*/
|
*/
|
|
|
if (newSize >= dsPtr->spaceAvl) {
|
if (newSize >= dsPtr->spaceAvl) {
|
dsPtr->spaceAvl = newSize*2;
|
dsPtr->spaceAvl = newSize*2;
|
newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl);
|
newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl);
|
memcpy((VOID *) newString, (VOID *) dsPtr->string,
|
memcpy((VOID *) newString, (VOID *) dsPtr->string,
|
(size_t) dsPtr->length);
|
(size_t) dsPtr->length);
|
if (dsPtr->string != dsPtr->staticSpace) {
|
if (dsPtr->string != dsPtr->staticSpace) {
|
ckfree(dsPtr->string);
|
ckfree(dsPtr->string);
|
}
|
}
|
dsPtr->string = newString;
|
dsPtr->string = newString;
|
}
|
}
|
|
|
/*
|
/*
|
* Convert the new string to a list element and copy it into the
|
* Convert the new string to a list element and copy it into the
|
* buffer at the end, with a space, if needed.
|
* buffer at the end, with a space, if needed.
|
*/
|
*/
|
|
|
dst = dsPtr->string + dsPtr->length;
|
dst = dsPtr->string + dsPtr->length;
|
if (TclNeedSpace(dsPtr->string, dst)) {
|
if (TclNeedSpace(dsPtr->string, dst)) {
|
*dst = ' ';
|
*dst = ' ';
|
dst++;
|
dst++;
|
dsPtr->length++;
|
dsPtr->length++;
|
}
|
}
|
dsPtr->length += Tcl_ConvertElement(string, dst, flags);
|
dsPtr->length += Tcl_ConvertElement(string, dst, flags);
|
return dsPtr->string;
|
return dsPtr->string;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_DStringSetLength --
|
* Tcl_DStringSetLength --
|
*
|
*
|
* Change the length of a dynamic string. This can cause the
|
* Change the length of a dynamic string. This can cause the
|
* string to either grow or shrink, depending on the value of
|
* string to either grow or shrink, depending on the value of
|
* length.
|
* length.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* The length of dsPtr is changed to length and a null byte is
|
* The length of dsPtr is changed to length and a null byte is
|
* stored at that position in the string. If length is larger
|
* stored at that position in the string. If length is larger
|
* than the space allocated for dsPtr, then a panic occurs.
|
* than the space allocated for dsPtr, then a panic occurs.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
void
|
void
|
Tcl_DStringSetLength(dsPtr, length)
|
Tcl_DStringSetLength(dsPtr, length)
|
Tcl_DString *dsPtr; /* Structure describing dynamic string. */
|
Tcl_DString *dsPtr; /* Structure describing dynamic string. */
|
int length; /* New length for dynamic string. */
|
int length; /* New length for dynamic string. */
|
{
|
{
|
if (length < 0) {
|
if (length < 0) {
|
length = 0;
|
length = 0;
|
}
|
}
|
if (length >= dsPtr->spaceAvl) {
|
if (length >= dsPtr->spaceAvl) {
|
char *newString;
|
char *newString;
|
|
|
dsPtr->spaceAvl = length+1;
|
dsPtr->spaceAvl = length+1;
|
newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl);
|
newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl);
|
|
|
/*
|
/*
|
* SPECIAL NOTE: must use memcpy, not strcpy, to copy the string
|
* SPECIAL NOTE: must use memcpy, not strcpy, to copy the string
|
* to a larger buffer, since there may be embedded NULLs in the
|
* to a larger buffer, since there may be embedded NULLs in the
|
* string in some cases.
|
* string in some cases.
|
*/
|
*/
|
|
|
memcpy((VOID *) newString, (VOID *) dsPtr->string,
|
memcpy((VOID *) newString, (VOID *) dsPtr->string,
|
(size_t) dsPtr->length);
|
(size_t) dsPtr->length);
|
if (dsPtr->string != dsPtr->staticSpace) {
|
if (dsPtr->string != dsPtr->staticSpace) {
|
ckfree(dsPtr->string);
|
ckfree(dsPtr->string);
|
}
|
}
|
dsPtr->string = newString;
|
dsPtr->string = newString;
|
}
|
}
|
dsPtr->length = length;
|
dsPtr->length = length;
|
dsPtr->string[length] = 0;
|
dsPtr->string[length] = 0;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_DStringFree --
|
* Tcl_DStringFree --
|
*
|
*
|
* Frees up any memory allocated for the dynamic string and
|
* Frees up any memory allocated for the dynamic string and
|
* reinitializes the string to an empty state.
|
* reinitializes the string to an empty state.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* The previous contents of the dynamic string are lost, and
|
* The previous contents of the dynamic string are lost, and
|
* the new value is an empty string.
|
* the new value is an empty string.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
void
|
void
|
Tcl_DStringFree(dsPtr)
|
Tcl_DStringFree(dsPtr)
|
Tcl_DString *dsPtr; /* Structure describing dynamic string. */
|
Tcl_DString *dsPtr; /* Structure describing dynamic string. */
|
{
|
{
|
if (dsPtr->string != dsPtr->staticSpace) {
|
if (dsPtr->string != dsPtr->staticSpace) {
|
ckfree(dsPtr->string);
|
ckfree(dsPtr->string);
|
}
|
}
|
dsPtr->string = dsPtr->staticSpace;
|
dsPtr->string = dsPtr->staticSpace;
|
dsPtr->length = 0;
|
dsPtr->length = 0;
|
dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
|
dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
|
dsPtr->staticSpace[0] = 0;
|
dsPtr->staticSpace[0] = 0;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_DStringResult --
|
* Tcl_DStringResult --
|
*
|
*
|
* This procedure moves the value of a dynamic string into an
|
* This procedure moves the value of a dynamic string into an
|
* interpreter as its string result. Afterwards, the dynamic string
|
* interpreter as its string result. Afterwards, the dynamic string
|
* is reset to an empty string.
|
* is reset to an empty string.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* The string is "moved" to interp's result, and any existing
|
* The string is "moved" to interp's result, and any existing
|
* string result for interp is freed. dsPtr is reinitialized to
|
* string result for interp is freed. dsPtr is reinitialized to
|
* an empty string.
|
* an empty string.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
void
|
void
|
Tcl_DStringResult(interp, dsPtr)
|
Tcl_DStringResult(interp, dsPtr)
|
Tcl_Interp *interp; /* Interpreter whose result is to be reset. */
|
Tcl_Interp *interp; /* Interpreter whose result is to be reset. */
|
Tcl_DString *dsPtr; /* Dynamic string that is to become the
|
Tcl_DString *dsPtr; /* Dynamic string that is to become the
|
* result of interp. */
|
* result of interp. */
|
{
|
{
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
|
|
if (dsPtr->string != dsPtr->staticSpace) {
|
if (dsPtr->string != dsPtr->staticSpace) {
|
interp->result = dsPtr->string;
|
interp->result = dsPtr->string;
|
interp->freeProc = TCL_DYNAMIC;
|
interp->freeProc = TCL_DYNAMIC;
|
} else if (dsPtr->length < TCL_RESULT_SIZE) {
|
} else if (dsPtr->length < TCL_RESULT_SIZE) {
|
interp->result = ((Interp *) interp)->resultSpace;
|
interp->result = ((Interp *) interp)->resultSpace;
|
strcpy(interp->result, dsPtr->string);
|
strcpy(interp->result, dsPtr->string);
|
} else {
|
} else {
|
Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE);
|
Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE);
|
}
|
}
|
|
|
dsPtr->string = dsPtr->staticSpace;
|
dsPtr->string = dsPtr->staticSpace;
|
dsPtr->length = 0;
|
dsPtr->length = 0;
|
dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
|
dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
|
dsPtr->staticSpace[0] = 0;
|
dsPtr->staticSpace[0] = 0;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_DStringGetResult --
|
* Tcl_DStringGetResult --
|
*
|
*
|
* This procedure moves an interpreter's result into a dynamic string.
|
* This procedure moves an interpreter's result into a dynamic string.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* The interpreter's string result is cleared, and the previous
|
* The interpreter's string result is cleared, and the previous
|
* contents of dsPtr are freed.
|
* contents of dsPtr are freed.
|
*
|
*
|
* If the string result is empty, the object result is moved to the
|
* If the string result is empty, the object result is moved to the
|
* string result, then the object result is reset.
|
* string result, then the object result is reset.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
void
|
void
|
Tcl_DStringGetResult(interp, dsPtr)
|
Tcl_DStringGetResult(interp, dsPtr)
|
Tcl_Interp *interp; /* Interpreter whose result is to be reset. */
|
Tcl_Interp *interp; /* Interpreter whose result is to be reset. */
|
Tcl_DString *dsPtr; /* Dynamic string that is to become the
|
Tcl_DString *dsPtr; /* Dynamic string that is to become the
|
* result of interp. */
|
* result of interp. */
|
{
|
{
|
Interp *iPtr = (Interp *) interp;
|
Interp *iPtr = (Interp *) interp;
|
|
|
if (dsPtr->string != dsPtr->staticSpace) {
|
if (dsPtr->string != dsPtr->staticSpace) {
|
ckfree(dsPtr->string);
|
ckfree(dsPtr->string);
|
}
|
}
|
|
|
/*
|
/*
|
* If the string result is empty, move the object result to the
|
* If the string result is empty, move the object result to the
|
* string result, then reset the object result.
|
* string result, then reset the object result.
|
* FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS.
|
* FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS.
|
*/
|
*/
|
|
|
if (*(iPtr->result) == 0) {
|
if (*(iPtr->result) == 0) {
|
Tcl_SetResult(interp,
|
Tcl_SetResult(interp,
|
TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL),
|
TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL),
|
TCL_VOLATILE);
|
TCL_VOLATILE);
|
}
|
}
|
|
|
dsPtr->length = strlen(iPtr->result);
|
dsPtr->length = strlen(iPtr->result);
|
if (iPtr->freeProc != NULL) {
|
if (iPtr->freeProc != NULL) {
|
if ((iPtr->freeProc == TCL_DYNAMIC)
|
if ((iPtr->freeProc == TCL_DYNAMIC)
|
|| (iPtr->freeProc == (Tcl_FreeProc *) free)) {
|
|| (iPtr->freeProc == (Tcl_FreeProc *) free)) {
|
dsPtr->string = iPtr->result;
|
dsPtr->string = iPtr->result;
|
dsPtr->spaceAvl = dsPtr->length+1;
|
dsPtr->spaceAvl = dsPtr->length+1;
|
} else {
|
} else {
|
dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length+1));
|
dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length+1));
|
strcpy(dsPtr->string, iPtr->result);
|
strcpy(dsPtr->string, iPtr->result);
|
(*iPtr->freeProc)(iPtr->result);
|
(*iPtr->freeProc)(iPtr->result);
|
}
|
}
|
dsPtr->spaceAvl = dsPtr->length+1;
|
dsPtr->spaceAvl = dsPtr->length+1;
|
iPtr->freeProc = NULL;
|
iPtr->freeProc = NULL;
|
} else {
|
} else {
|
if (dsPtr->length < TCL_DSTRING_STATIC_SIZE) {
|
if (dsPtr->length < TCL_DSTRING_STATIC_SIZE) {
|
dsPtr->string = dsPtr->staticSpace;
|
dsPtr->string = dsPtr->staticSpace;
|
dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
|
dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
|
} else {
|
} else {
|
dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length + 1));
|
dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length + 1));
|
dsPtr->spaceAvl = dsPtr->length + 1;
|
dsPtr->spaceAvl = dsPtr->length + 1;
|
}
|
}
|
strcpy(dsPtr->string, iPtr->result);
|
strcpy(dsPtr->string, iPtr->result);
|
}
|
}
|
|
|
iPtr->result = iPtr->resultSpace;
|
iPtr->result = iPtr->resultSpace;
|
iPtr->resultSpace[0] = 0;
|
iPtr->resultSpace[0] = 0;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_DStringStartSublist --
|
* Tcl_DStringStartSublist --
|
*
|
*
|
* This procedure adds the necessary information to a dynamic
|
* This procedure adds the necessary information to a dynamic
|
* string (e.g. " {" to start a sublist. Future element
|
* string (e.g. " {" to start a sublist. Future element
|
* appends will be in the sublist rather than the main list.
|
* appends will be in the sublist rather than the main list.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Characters get added to the dynamic string.
|
* Characters get added to the dynamic string.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
void
|
void
|
Tcl_DStringStartSublist(dsPtr)
|
Tcl_DStringStartSublist(dsPtr)
|
Tcl_DString *dsPtr; /* Dynamic string. */
|
Tcl_DString *dsPtr; /* Dynamic string. */
|
{
|
{
|
if (TclNeedSpace(dsPtr->string, dsPtr->string + dsPtr->length)) {
|
if (TclNeedSpace(dsPtr->string, dsPtr->string + dsPtr->length)) {
|
Tcl_DStringAppend(dsPtr, " {", -1);
|
Tcl_DStringAppend(dsPtr, " {", -1);
|
} else {
|
} else {
|
Tcl_DStringAppend(dsPtr, "{", -1);
|
Tcl_DStringAppend(dsPtr, "{", -1);
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_DStringEndSublist --
|
* Tcl_DStringEndSublist --
|
*
|
*
|
* This procedure adds the necessary characters to a dynamic
|
* This procedure adds the necessary characters to a dynamic
|
* string to end a sublist (e.g. "}"). Future element appends
|
* string to end a sublist (e.g. "}"). Future element appends
|
* will be in the enclosing (sub)list rather than the current
|
* will be in the enclosing (sub)list rather than the current
|
* sublist.
|
* sublist.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
void
|
void
|
Tcl_DStringEndSublist(dsPtr)
|
Tcl_DStringEndSublist(dsPtr)
|
Tcl_DString *dsPtr; /* Dynamic string. */
|
Tcl_DString *dsPtr; /* Dynamic string. */
|
{
|
{
|
Tcl_DStringAppend(dsPtr, "}", -1);
|
Tcl_DStringAppend(dsPtr, "}", -1);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_PrintDouble --
|
* Tcl_PrintDouble --
|
*
|
*
|
* Given a floating-point value, this procedure converts it to
|
* Given a floating-point value, this procedure converts it to
|
* an ASCII string using.
|
* an ASCII string using.
|
*
|
*
|
* Results:
|
* Results:
|
* The ASCII equivalent of "value" is written at "dst". It is
|
* The ASCII equivalent of "value" is written at "dst". It is
|
* written using the current precision, and it is guaranteed to
|
* written using the current precision, and it is guaranteed to
|
* contain a decimal point or exponent, so that it looks like
|
* contain a decimal point or exponent, so that it looks like
|
* a floating-point value and not an integer.
|
* a floating-point value and not an integer.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
void
|
void
|
Tcl_PrintDouble(interp, value, dst)
|
Tcl_PrintDouble(interp, value, dst)
|
Tcl_Interp *interp; /* Interpreter whose tcl_precision
|
Tcl_Interp *interp; /* Interpreter whose tcl_precision
|
* variable used to be used to control
|
* variable used to be used to control
|
* printing. It's ignored now. */
|
* printing. It's ignored now. */
|
double value; /* Value to print as string. */
|
double value; /* Value to print as string. */
|
char *dst; /* Where to store converted value;
|
char *dst; /* Where to store converted value;
|
* must have at least TCL_DOUBLE_SPACE
|
* must have at least TCL_DOUBLE_SPACE
|
* characters. */
|
* characters. */
|
{
|
{
|
char *p;
|
char *p;
|
|
|
sprintf(dst, precisionFormat, value);
|
sprintf(dst, precisionFormat, value);
|
|
|
/*
|
/*
|
* If the ASCII result looks like an integer, add ".0" so that it
|
* If the ASCII result looks like an integer, add ".0" so that it
|
* doesn't look like an integer anymore. This prevents floating-point
|
* doesn't look like an integer anymore. This prevents floating-point
|
* values from being converted to integers unintentionally.
|
* values from being converted to integers unintentionally.
|
*/
|
*/
|
|
|
for (p = dst; *p != 0; p++) {
|
for (p = dst; *p != 0; p++) {
|
if ((*p == '.') || (isalpha(UCHAR(*p)))) {
|
if ((*p == '.') || (isalpha(UCHAR(*p)))) {
|
return;
|
return;
|
}
|
}
|
}
|
}
|
p[0] = '.';
|
p[0] = '.';
|
p[1] = '0';
|
p[1] = '0';
|
p[2] = 0;
|
p[2] = 0;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* TclPrecTraceProc --
|
* TclPrecTraceProc --
|
*
|
*
|
* This procedure is invoked whenever the variable "tcl_precision"
|
* This procedure is invoked whenever the variable "tcl_precision"
|
* is written.
|
* is written.
|
*
|
*
|
* Results:
|
* Results:
|
* Returns NULL if all went well, or an error message if the
|
* Returns NULL if all went well, or an error message if the
|
* new value for the variable doesn't make sense.
|
* new value for the variable doesn't make sense.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* If the new value doesn't make sense then this procedure
|
* If the new value doesn't make sense then this procedure
|
* undoes the effect of the variable modification. Otherwise
|
* undoes the effect of the variable modification. Otherwise
|
* it modifies the format string that's used by Tcl_PrintDouble.
|
* it modifies the format string that's used by Tcl_PrintDouble.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
/* ARGSUSED */
|
/* ARGSUSED */
|
char *
|
char *
|
TclPrecTraceProc(clientData, interp, name1, name2, flags)
|
TclPrecTraceProc(clientData, interp, name1, name2, flags)
|
ClientData clientData; /* Not used. */
|
ClientData clientData; /* Not used. */
|
Tcl_Interp *interp; /* Interpreter containing variable. */
|
Tcl_Interp *interp; /* Interpreter containing variable. */
|
char *name1; /* Name of variable. */
|
char *name1; /* Name of variable. */
|
char *name2; /* Second part of variable name. */
|
char *name2; /* Second part of variable name. */
|
int flags; /* Information about what happened. */
|
int flags; /* Information about what happened. */
|
{
|
{
|
char *value, *end;
|
char *value, *end;
|
int prec;
|
int prec;
|
|
|
/*
|
/*
|
* If the variable is unset, then recreate the trace.
|
* If the variable is unset, then recreate the trace.
|
*/
|
*/
|
|
|
if (flags & TCL_TRACE_UNSETS) {
|
if (flags & TCL_TRACE_UNSETS) {
|
if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) {
|
if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) {
|
Tcl_TraceVar2(interp, name1, name2,
|
Tcl_TraceVar2(interp, name1, name2,
|
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES
|
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES
|
|TCL_TRACE_UNSETS, TclPrecTraceProc, clientData);
|
|TCL_TRACE_UNSETS, TclPrecTraceProc, clientData);
|
}
|
}
|
return (char *) NULL;
|
return (char *) NULL;
|
}
|
}
|
|
|
/*
|
/*
|
* When the variable is read, reset its value from our shared
|
* When the variable is read, reset its value from our shared
|
* value. This is needed in case the variable was modified in
|
* value. This is needed in case the variable was modified in
|
* some other interpreter so that this interpreter's value is
|
* some other interpreter so that this interpreter's value is
|
* out of date.
|
* out of date.
|
*/
|
*/
|
|
|
if (flags & TCL_TRACE_READS) {
|
if (flags & TCL_TRACE_READS) {
|
Tcl_SetVar2(interp, name1, name2, precisionString,
|
Tcl_SetVar2(interp, name1, name2, precisionString,
|
flags & TCL_GLOBAL_ONLY);
|
flags & TCL_GLOBAL_ONLY);
|
return (char *) NULL;
|
return (char *) NULL;
|
}
|
}
|
|
|
/*
|
/*
|
* The variable is being written. Check the new value and disallow
|
* The variable is being written. Check the new value and disallow
|
* it if it isn't reasonable or if this is a safe interpreter (we
|
* it if it isn't reasonable or if this is a safe interpreter (we
|
* don't want safe interpreters messing up the precision of other
|
* don't want safe interpreters messing up the precision of other
|
* interpreters).
|
* interpreters).
|
*/
|
*/
|
|
|
if (Tcl_IsSafe(interp)) {
|
if (Tcl_IsSafe(interp)) {
|
Tcl_SetVar2(interp, name1, name2, precisionString,
|
Tcl_SetVar2(interp, name1, name2, precisionString,
|
flags & TCL_GLOBAL_ONLY);
|
flags & TCL_GLOBAL_ONLY);
|
return "can't modify precision from a safe interpreter";
|
return "can't modify precision from a safe interpreter";
|
}
|
}
|
value = Tcl_GetVar2(interp, name1, name2, flags & TCL_GLOBAL_ONLY);
|
value = Tcl_GetVar2(interp, name1, name2, flags & TCL_GLOBAL_ONLY);
|
if (value == NULL) {
|
if (value == NULL) {
|
value = "";
|
value = "";
|
}
|
}
|
prec = strtoul(value, &end, 10);
|
prec = strtoul(value, &end, 10);
|
if ((prec <= 0) || (prec > TCL_MAX_PREC) || (prec > 100) ||
|
if ((prec <= 0) || (prec > TCL_MAX_PREC) || (prec > 100) ||
|
(end == value) || (*end != 0)) {
|
(end == value) || (*end != 0)) {
|
Tcl_SetVar2(interp, name1, name2, precisionString,
|
Tcl_SetVar2(interp, name1, name2, precisionString,
|
flags & TCL_GLOBAL_ONLY);
|
flags & TCL_GLOBAL_ONLY);
|
return "improper value for precision";
|
return "improper value for precision";
|
}
|
}
|
TclFormatInt(precisionString, prec);
|
TclFormatInt(precisionString, prec);
|
sprintf(precisionFormat, "%%.%dg", prec);
|
sprintf(precisionFormat, "%%.%dg", prec);
|
return (char *) NULL;
|
return (char *) NULL;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* TclNeedSpace --
|
* TclNeedSpace --
|
*
|
*
|
* This procedure checks to see whether it is appropriate to
|
* This procedure checks to see whether it is appropriate to
|
* add a space before appending a new list element to an
|
* add a space before appending a new list element to an
|
* existing string.
|
* existing string.
|
*
|
*
|
* Results:
|
* Results:
|
* The return value is 1 if a space is appropriate, 0 otherwise.
|
* The return value is 1 if a space is appropriate, 0 otherwise.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
TclNeedSpace(start, end)
|
TclNeedSpace(start, end)
|
char *start; /* First character in string. */
|
char *start; /* First character in string. */
|
char *end; /* End of string (place where space will
|
char *end; /* End of string (place where space will
|
* be added, if appropriate). */
|
* be added, if appropriate). */
|
{
|
{
|
/*
|
/*
|
* A space is needed unless either
|
* A space is needed unless either
|
* (a) we're at the start of the string, or
|
* (a) we're at the start of the string, or
|
* (b) the trailing characters of the string consist of one or more
|
* (b) the trailing characters of the string consist of one or more
|
* open curly braces preceded by a space or extending back to
|
* open curly braces preceded by a space or extending back to
|
* the beginning of the string.
|
* the beginning of the string.
|
* (c) the trailing characters of the string consist of a space
|
* (c) the trailing characters of the string consist of a space
|
* preceded by a character other than backslash.
|
* preceded by a character other than backslash.
|
*/
|
*/
|
|
|
if (end == start) {
|
if (end == start) {
|
return 0;
|
return 0;
|
}
|
}
|
end--;
|
end--;
|
if (*end != '{') {
|
if (*end != '{') {
|
if (isspace(UCHAR(*end)) && ((end == start) || (end[-1] != '\\'))) {
|
if (isspace(UCHAR(*end)) && ((end == start) || (end[-1] != '\\'))) {
|
return 0;
|
return 0;
|
}
|
}
|
return 1;
|
return 1;
|
}
|
}
|
do {
|
do {
|
if (end == start) {
|
if (end == start) {
|
return 0;
|
return 0;
|
}
|
}
|
end--;
|
end--;
|
} while (*end == '{');
|
} while (*end == '{');
|
if (isspace(UCHAR(*end))) {
|
if (isspace(UCHAR(*end))) {
|
return 0;
|
return 0;
|
}
|
}
|
return 1;
|
return 1;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* TclFormatInt --
|
* TclFormatInt --
|
*
|
*
|
* This procedure formats an integer into a sequence of decimal digit
|
* This procedure formats an integer into a sequence of decimal digit
|
* characters in a buffer. If the integer is negative, a minus sign is
|
* characters in a buffer. If the integer is negative, a minus sign is
|
* inserted at the start of the buffer. A null character is inserted at
|
* inserted at the start of the buffer. A null character is inserted at
|
* the end of the formatted characters. It is the caller's
|
* the end of the formatted characters. It is the caller's
|
* responsibility to ensure that enough storage is available. This
|
* responsibility to ensure that enough storage is available. This
|
* procedure has the effect of sprintf(buffer, "%d", n) but is faster.
|
* procedure has the effect of sprintf(buffer, "%d", n) but is faster.
|
*
|
*
|
* Results:
|
* Results:
|
* An integer representing the number of characters formatted, not
|
* An integer representing the number of characters formatted, not
|
* including the terminating \0.
|
* including the terminating \0.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* The formatted characters are written into the storage pointer to
|
* The formatted characters are written into the storage pointer to
|
* by the "buffer" argument.
|
* by the "buffer" argument.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
TclFormatInt(buffer, n)
|
TclFormatInt(buffer, n)
|
char *buffer; /* Points to the storage into which the
|
char *buffer; /* Points to the storage into which the
|
* formatted characters are written. */
|
* formatted characters are written. */
|
long n; /* The integer to format. */
|
long n; /* The integer to format. */
|
{
|
{
|
long intVal;
|
long intVal;
|
int i;
|
int i;
|
int numFormatted, j;
|
int numFormatted, j;
|
char *digits = "0123456789";
|
char *digits = "0123456789";
|
|
|
/*
|
/*
|
* Check first whether "n" is the maximum negative value. This is
|
* Check first whether "n" is the maximum negative value. This is
|
* -2^(m-1) for an m-bit word, and has no positive equivalent;
|
* -2^(m-1) for an m-bit word, and has no positive equivalent;
|
* negating it produces the same value.
|
* negating it produces the same value.
|
*/
|
*/
|
|
|
if (n == -n) {
|
if (n == -n) {
|
sprintf(buffer, "%ld", n);
|
sprintf(buffer, "%ld", n);
|
return strlen(buffer);
|
return strlen(buffer);
|
}
|
}
|
|
|
/*
|
/*
|
* Generate the characters of the result backwards in the buffer.
|
* Generate the characters of the result backwards in the buffer.
|
*/
|
*/
|
|
|
intVal = (n < 0? -n : n);
|
intVal = (n < 0? -n : n);
|
i = 0;
|
i = 0;
|
buffer[0] = '\0';
|
buffer[0] = '\0';
|
do {
|
do {
|
i++;
|
i++;
|
buffer[i] = digits[intVal % 10];
|
buffer[i] = digits[intVal % 10];
|
intVal = intVal/10;
|
intVal = intVal/10;
|
} while (intVal > 0);
|
} while (intVal > 0);
|
if (n < 0) {
|
if (n < 0) {
|
i++;
|
i++;
|
buffer[i] = '-';
|
buffer[i] = '-';
|
}
|
}
|
numFormatted = i;
|
numFormatted = i;
|
|
|
/*
|
/*
|
* Now reverse the characters.
|
* Now reverse the characters.
|
*/
|
*/
|
|
|
for (j = 0; j < i; j++, i--) {
|
for (j = 0; j < i; j++, i--) {
|
char tmp = buffer[i];
|
char tmp = buffer[i];
|
buffer[i] = buffer[j];
|
buffer[i] = buffer[j];
|
buffer[j] = tmp;
|
buffer[j] = tmp;
|
}
|
}
|
return numFormatted;
|
return numFormatted;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* TclLooksLikeInt --
|
* TclLooksLikeInt --
|
*
|
*
|
* This procedure decides whether the leading characters of a
|
* This procedure decides whether the leading characters of a
|
* string look like an integer or something else (such as a
|
* string look like an integer or something else (such as a
|
* floating-point number or string).
|
* floating-point number or string).
|
*
|
*
|
* Results:
|
* Results:
|
* The return value is 1 if the leading characters of p look
|
* The return value is 1 if the leading characters of p look
|
* like a valid Tcl integer. If they look like a floating-point
|
* like a valid Tcl integer. If they look like a floating-point
|
* number (e.g. "e01" or "2.4"), or if they don't look like a
|
* number (e.g. "e01" or "2.4"), or if they don't look like a
|
* number at all, then 0 is returned.
|
* number at all, then 0 is returned.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
TclLooksLikeInt(p)
|
TclLooksLikeInt(p)
|
char *p; /* Pointer to string. */
|
char *p; /* Pointer to string. */
|
{
|
{
|
while (isspace(UCHAR(*p))) {
|
while (isspace(UCHAR(*p))) {
|
p++;
|
p++;
|
}
|
}
|
if ((*p == '+') || (*p == '-')) {
|
if ((*p == '+') || (*p == '-')) {
|
p++;
|
p++;
|
}
|
}
|
if (!isdigit(UCHAR(*p))) {
|
if (!isdigit(UCHAR(*p))) {
|
return 0;
|
return 0;
|
}
|
}
|
p++;
|
p++;
|
while (isdigit(UCHAR(*p))) {
|
while (isdigit(UCHAR(*p))) {
|
p++;
|
p++;
|
}
|
}
|
if ((*p != '.') && (*p != 'e') && (*p != 'E')) {
|
if ((*p != '.') && (*p != 'e') && (*p != 'E')) {
|
return 1;
|
return 1;
|
}
|
}
|
return 0;
|
return 0;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* TclGetIntForIndex --
|
* TclGetIntForIndex --
|
*
|
*
|
* This procedure returns an integer corresponding to the list index
|
* This procedure returns an integer corresponding to the list index
|
* held in a Tcl object. The Tcl object's value is expected to be
|
* held in a Tcl object. The Tcl object's value is expected to be
|
* either an integer or the string "end".
|
* either an integer or the string "end".
|
*
|
*
|
* Results:
|
* Results:
|
* The return value is normally TCL_OK, which means that the index was
|
* The return value is normally TCL_OK, which means that the index was
|
* successfully stored into the location referenced by "indexPtr". If
|
* successfully stored into the location referenced by "indexPtr". If
|
* the Tcl object referenced by "objPtr" has the value "end", the
|
* the Tcl object referenced by "objPtr" has the value "end", the
|
* value stored is "endValue". If "objPtr"s values is not "end" and
|
* value stored is "endValue". If "objPtr"s values is not "end" and
|
* can not be converted to an integer, TCL_ERROR is returned and, if
|
* can not be converted to an integer, TCL_ERROR is returned and, if
|
* "interp" is non-NULL, an error message is left in the interpreter's
|
* "interp" is non-NULL, an error message is left in the interpreter's
|
* result object.
|
* result object.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* The object referenced by "objPtr" might be converted to an
|
* The object referenced by "objPtr" might be converted to an
|
* integer object.
|
* integer object.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
TclGetIntForIndex(interp, objPtr, endValue, indexPtr)
|
TclGetIntForIndex(interp, objPtr, endValue, indexPtr)
|
Tcl_Interp *interp; /* Interpreter to use for error reporting.
|
Tcl_Interp *interp; /* Interpreter to use for error reporting.
|
* If NULL, then no error message is left
|
* If NULL, then no error message is left
|
* after errors. */
|
* after errors. */
|
Tcl_Obj *objPtr; /* Points to an object containing either
|
Tcl_Obj *objPtr; /* Points to an object containing either
|
* "end" or an integer. */
|
* "end" or an integer. */
|
int endValue; /* The value to be stored at "indexPtr" if
|
int endValue; /* The value to be stored at "indexPtr" if
|
* "objPtr" holds "end". */
|
* "objPtr" holds "end". */
|
int *indexPtr; /* Location filled in with an integer
|
int *indexPtr; /* Location filled in with an integer
|
* representing an index. */
|
* representing an index. */
|
{
|
{
|
Interp *iPtr = (Interp *) interp;
|
Interp *iPtr = (Interp *) interp;
|
char *bytes;
|
char *bytes;
|
int index, length, result;
|
int index, length, result;
|
|
|
/*
|
/*
|
* THIS FAILS IF THE INDEX OBJECT'S STRING REP CONTAINS NULLS.
|
* THIS FAILS IF THE INDEX OBJECT'S STRING REP CONTAINS NULLS.
|
*/
|
*/
|
|
|
if (objPtr->typePtr == &tclIntType) {
|
if (objPtr->typePtr == &tclIntType) {
|
*indexPtr = (int)objPtr->internalRep.longValue;
|
*indexPtr = (int)objPtr->internalRep.longValue;
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
bytes = TclGetStringFromObj(objPtr, &length);
|
bytes = TclGetStringFromObj(objPtr, &length);
|
if ((*bytes == 'e')
|
if ((*bytes == 'e')
|
&& (strncmp(bytes, "end", (unsigned) length) == 0)) {
|
&& (strncmp(bytes, "end", (unsigned) length) == 0)) {
|
index = endValue;
|
index = endValue;
|
} else {
|
} else {
|
result = Tcl_GetIntFromObj((Tcl_Interp *) NULL, objPtr, &index);
|
result = Tcl_GetIntFromObj((Tcl_Interp *) NULL, objPtr, &index);
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
if (iPtr != NULL) {
|
if (iPtr != NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"bad index \"", bytes,
|
"bad index \"", bytes,
|
"\": must be integer or \"end\"", (char *) NULL);
|
"\": must be integer or \"end\"", (char *) NULL);
|
}
|
}
|
return result;
|
return result;
|
}
|
}
|
}
|
}
|
*indexPtr = index;
|
*indexPtr = index;
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_GetNameOfExecutable --
|
* Tcl_GetNameOfExecutable --
|
*
|
*
|
* This procedure simply returns a pointer to the internal full
|
* This procedure simply returns a pointer to the internal full
|
* path name of the executable file as computed by
|
* path name of the executable file as computed by
|
* Tcl_FindExecutable. This procedure call is the C API
|
* Tcl_FindExecutable. This procedure call is the C API
|
* equivalent to the "info nameofexecutable" command.
|
* equivalent to the "info nameofexecutable" command.
|
*
|
*
|
* Results:
|
* Results:
|
* A pointer to the internal string or NULL if the internal full
|
* A pointer to the internal string or NULL if the internal full
|
* path name has not been computed or unknown.
|
* path name has not been computed or unknown.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* The object referenced by "objPtr" might be converted to an
|
* The object referenced by "objPtr" might be converted to an
|
* integer object.
|
* integer object.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
CONST char *
|
CONST char *
|
Tcl_GetNameOfExecutable()
|
Tcl_GetNameOfExecutable()
|
{
|
{
|
return (tclExecutableName);
|
return (tclExecutableName);
|
}
|
}
|
|
|
