summaryrefslogtreecommitdiffstats
path: root/generic/tclUtil.c
diff options
context:
space:
mode:
authorstanton <stanton>1999-04-16 00:46:29 (GMT)
committerstanton <stanton>1999-04-16 00:46:29 (GMT)
commit97464e6cba8eb0008cf2727c15718671992b913f (patch)
treece9959f2747257d98d52ec8d18bf3b0de99b9535 /generic/tclUtil.c
parenta8c96ddb94d1483a9de5e340b740cb74ef6cafa7 (diff)
downloadtcl-97464e6cba8eb0008cf2727c15718671992b913f.zip
tcl-97464e6cba8eb0008cf2727c15718671992b913f.tar.gz
tcl-97464e6cba8eb0008cf2727c15718671992b913f.tar.bz2
merged tcl 8.1 branch back into the main trunk
Diffstat (limited to 'generic/tclUtil.c')
-rw-r--r--generic/tclUtil.c1395
1 files changed, 321 insertions, 1074 deletions
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index c02c700..54811df 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -5,12 +5,12 @@
* commands.
*
* Copyright (c) 1987-1993 The Regents of the University of California.
- * Copyright (c) 1994-1997 Sun Microsystems, Inc.
+ * Copyright (c) 1994-1998 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclUtil.c,v 1.4 1999/03/10 05:52:50 stanton Exp $
+ * RCS: @(#) $Id: tclUtil.c,v 1.5 1999/04/16 00:46:55 stanton Exp $
*/
#include "tclInt.h"
@@ -22,8 +22,9 @@
* know. The value of the variable is set by the procedure
* Tcl_FindExecutable. The storage space is dynamically allocated.
*/
-
+
char *tclExecutableName = NULL;
+char *tclNativeExecutableName = NULL;
/*
* The following values are used in the flags returned by Tcl_ScanElement
@@ -51,8 +52,6 @@ char *tclExecutableName = NULL;
* floating-point values to strings. This information is linked to all
* of the tcl_precision variables in all interpreters via the procedure
* TclPrecTraceProc.
- *
- * NOTE: these variables are not thread-safe.
*/
static char precisionString[10] = "12";
@@ -61,14 +60,8 @@ static char precisionString[10] = "12";
static char precisionFormat[10] = "%.12g";
/* The format string actually used in calls
* to sprintf. */
+TCL_DECLARE_MUTEX(precisionMutex)
-
-/*
- * Function prototypes for local procedures in this file:
- */
-
-static void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr,
- int newSpace));
/*
*----------------------------------------------------------------------
@@ -82,7 +75,7 @@ static void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr,
* The return value is normally TCL_OK, which means that the
* element was successfully located. If TCL_ERROR is returned
* it means that list didn't have proper list structure;
- * interp->result contains a more detailed error message.
+ * the interp's result contains a more detailed error message.
*
* 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
@@ -110,13 +103,13 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr,
Tcl_Interp *interp; /* Interpreter to use for error reporting.
* If NULL, then no error message is left
* after errors. */
- char *list; /* Points to the first byte of a string
+ CONST char *list; /* Points to the first byte of a string
* containing a Tcl list with zero or more
* elements (possibly in braces). */
int listLength; /* Number of bytes in the list's string. */
- char **elementPtr; /* Where to put address of first significant
+ CONST char **elementPtr; /* Where to put address of first significant
* character in first element of list. */
- char **nextPtr; /* Fill in with location of character just
+ CONST char **nextPtr; /* Fill in with location of character just
* after all white space following end of
* argument (next arg or end of list). */
int *sizePtr; /* If non-zero, fill in with size of
@@ -125,26 +118,23 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr,
* to indicate that arg was/wasn't
* in braces. */
{
- char *p = list;
- char *elemStart; /* Points to first byte of first element. */
- char *limit; /* Points just after list's last byte. */
+ CONST char *p = list;
+ CONST char *elemStart; /* Points to first byte of first element. */
+ CONST char *limit; /* Points just after list's last byte. */
int openBraces = 0; /* Brace nesting level during parse. */
int inQuotes = 0;
- int size = 0; /* Init. avoids compiler warning. */
+ int size = 0; /* lint. */
int numChars;
- char *p2;
+ CONST char *p2;
/*
* Skim off leading white space and check for an opening brace or
* quote. We treat embedded NULLs in the list as bytes belonging to
- * a list element. Note: use of "isascii" below and elsewhere in this
- * procedure is a temporary hack (7/27/90) because Mx uses characters
- * with the high-order bit set for some things. This should probably
- * be changed back eventually, or all of Tcl should call isascii.
+ * a list element.
*/
limit = (list + listLength);
- while ((p < limit) && (isspace(UCHAR(*p)))) {
+ while ((p < limit) && (isspace(UCHAR(*p)))) { /* INTL: ISO space. */
p++;
}
if (p == limit) { /* no element found */
@@ -193,7 +183,8 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr,
} else if (openBraces == 1) {
size = (p - elemStart);
p++;
- if ((p >= limit) || isspace(UCHAR(*p))) {
+ if ((p >= limit)
+ || isspace(UCHAR(*p))) { /* INTL: ISO space. */
goto done;
}
@@ -205,7 +196,8 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr,
char buf[100];
p2 = p;
- while ((p2 < limit) && (!isspace(UCHAR(*p2)))
+ while ((p2 < limit)
+ && (!isspace(UCHAR(*p2))) /* INTL: ISO space. */
&& (p2 < p+20)) {
p2++;
}
@@ -224,7 +216,7 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr,
*/
case '\\': {
- (void) Tcl_Backslash(p, &numChars);
+ Tcl_UtfBackslash(p, &numChars, NULL);
p += (numChars - 1);
break;
}
@@ -254,7 +246,8 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr,
if (inQuotes) {
size = (p - elemStart);
p++;
- if ((p >= limit) || isspace(UCHAR(*p))) {
+ if ((p >= limit)
+ || isspace(UCHAR(*p))) { /* INTL: ISO space */
goto done;
}
@@ -266,7 +259,8 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr,
char buf[100];
p2 = p;
- while ((p2 < limit) && (!isspace(UCHAR(*p2)))
+ while ((p2 < limit)
+ && (!isspace(UCHAR(*p2))) /* INTL: ISO space */
&& (p2 < p+20)) {
p2++;
}
@@ -305,7 +299,7 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr,
}
done:
- while ((p < limit) && (isspace(UCHAR(*p)))) {
+ while ((p < limit) && (isspace(UCHAR(*p)))) { /* INTL: ISO space. */
p++;
}
*elementPtr = elemStart;
@@ -339,20 +333,21 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr,
int
TclCopyAndCollapse(count, src, dst)
int count; /* Number of characters to copy from src. */
- char *src; /* Copy from here... */
+ CONST char *src; /* Copy from here... */
char *dst; /* ... to here. */
{
- char c;
+ register char c;
int numRead;
int newCount = 0;
+ int backslashCount;
for (c = *src; count > 0; src++, c = *src, count--) {
if (c == '\\') {
- *dst = Tcl_Backslash(src, &numRead);
- dst++;
+ backslashCount = Tcl_UtfBackslash(src, &numRead, dst);
+ dst += backslashCount;
+ newCount += backslashCount;
src += numRead-1;
count -= numRead-1;
- newCount++;
} else {
*dst = c;
dst++;
@@ -374,7 +369,7 @@ TclCopyAndCollapse(count, src, dst)
* The return value is normally TCL_OK, which means that
* the list was successfully split up. If TCL_ERROR is
* returned, it means that "list" didn't have proper list
- * structure; interp->result will contain a more detailed
+ * structure; the interp's result will contain a more detailed
* error message.
*
* *argvPtr will be filled in with the address of an array
@@ -397,16 +392,17 @@ int
Tcl_SplitList(interp, list, argcPtr, argvPtr)
Tcl_Interp *interp; /* Interpreter to use for error reporting.
* If NULL, no error message is left. */
- char *list; /* Pointer to string with list structure. */
+ CONST char *list; /* Pointer to string with list structure. */
int *argcPtr; /* Pointer to location to fill in with
* the number of elements in the list. */
char ***argvPtr; /* Pointer to place to store pointer to
* array of pointers to list elements. */
{
char **argv;
+ CONST char *l;
char *p;
int length, size, i, result, elSize, brace;
- char *element;
+ CONST char *element;
/*
* Figure out how much space to allocate. There must be enough
@@ -415,18 +411,18 @@ Tcl_SplitList(interp, list, argcPtr, argvPtr)
* the number of space characters in the list.
*/
- for (size = 1, p = list; *p != 0; p++) {
- if (isspace(UCHAR(*p))) {
+ for (size = 1, l = list; *l != 0; l++) {
+ if (isspace(UCHAR(*l))) { /* INTL: ISO space. */
size++;
}
}
size++; /* Leave space for final NULL pointer. */
argv = (char **) ckalloc((unsigned)
- ((size * sizeof(char *)) + (p - list) + 1));
+ ((size * sizeof(char *)) + (l - list) + 1));
length = strlen(list);
for (i = 0, p = ((char *) argv) + size*sizeof(char *);
*list != 0; i++) {
- char *prevList = list;
+ CONST char *prevList = list;
result = TclFindElement(interp, list, length, &element,
&list, &elSize, &brace);
@@ -489,9 +485,9 @@ Tcl_SplitList(interp, list, argcPtr, argvPtr)
int
Tcl_ScanElement(string, flagPtr)
- CONST char *string; /* String to convert to Tcl list element. */
- int *flagPtr; /* Where to store information to guide
- * Tcl_ConvertCountedElement. */
+ register CONST char *string; /* String to convert to list element. */
+ register int *flagPtr; /* Where to store information to guide
+ * Tcl_ConvertCountedElement. */
{
return Tcl_ScanCountedElement(string, -1, flagPtr);
}
@@ -529,7 +525,7 @@ Tcl_ScanCountedElement(string, length, flagPtr)
* Tcl_ConvertElement. */
{
int flags, nestingLevel;
- CONST char *p, *lastChar;
+ register CONST char *p, *lastChar;
/*
* This procedure and Tcl_ConvertElement together do two things:
@@ -613,7 +609,7 @@ Tcl_ScanCountedElement(string, length, flagPtr)
} else {
int size;
- (void) Tcl_Backslash(p, &size);
+ Tcl_UtfBackslash(p, &size, NULL);
p += size-1;
flags |= USE_BRACES;
}
@@ -657,9 +653,9 @@ Tcl_ScanCountedElement(string, length, flagPtr)
int
Tcl_ConvertElement(src, dst, flags)
- CONST char *src; /* Source information for list element. */
- char *dst; /* Place to put list-ified element. */
- int flags; /* Flags produced by Tcl_ScanElement. */
+ register CONST char *src; /* Source information for list element. */
+ register char *dst; /* Place to put list-ified element. */
+ register int flags; /* Flags produced by Tcl_ScanElement. */
{
return Tcl_ConvertCountedElement(src, -1, dst, flags);
}
@@ -689,13 +685,13 @@ Tcl_ConvertElement(src, dst, flags)
int
Tcl_ConvertCountedElement(src, length, dst, flags)
- CONST char *src; /* Source information for list element. */
+ register CONST char *src; /* Source information for list element. */
int length; /* Number of bytes in src, or -1. */
char *dst; /* Place to put list-ified element. */
int flags; /* Flags produced by Tcl_ScanElement. */
{
- char *p = dst;
- CONST char *lastChar;
+ register char *p = dst;
+ register CONST char *lastChar;
/*
* See the comment block at the beginning of the Tcl_ScanElement
@@ -876,6 +872,40 @@ Tcl_Merge(argc, argv)
/*
*----------------------------------------------------------------------
*
+ * Tcl_Backslash --
+ *
+ * Figure out how to handle a backslash sequence.
+ *
+ * Results:
+ * The return value is the character that should be substituted
+ * in place of the backslash sequence that starts at src. If
+ * readPtr isn't NULL then it is filled in with a count of the
+ * number of characters in the backslash sequence.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char
+Tcl_Backslash(src, readPtr)
+ CONST char *src; /* Points to the backslash character of
+ * a backslash sequence. */
+ int *readPtr; /* Fill in with number of characters read
+ * from src, unless NULL. */
+{
+ char buf[TCL_UTF_MAX];
+ Tcl_UniChar ch;
+
+ Tcl_UtfBackslash(src, readPtr, buf);
+ Tcl_UtfToUniChar(buf, &ch);
+ return (char) ch;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_Concat --
*
* Concatenate a set of strings into a single large string.
@@ -920,13 +950,14 @@ Tcl_Concat(argc, argv)
*/
element = argv[i];
- while (isspace(UCHAR(*element))) {
+ while (isspace(UCHAR(*element))) { /* INTL: ISO space. */
element++;
}
for (length = strlen(element);
- (length > 0) && (isspace(UCHAR(element[length-1])))
+ (length > 0)
+ && (isspace(UCHAR(element[length-1]))) /* INTL: ISO space. */
&& ((length < 2) || (element[length-2] != '\\'));
- length--) {
+ length--) {
/* Null loop body. */
}
if (length == 0) {
@@ -977,7 +1008,7 @@ Tcl_ConcatObj(objc, objv)
allocSize = 0;
for (i = 0; i < objc; i++) {
objPtr = objv[i];
- element = TclGetStringFromObj(objPtr, &length);
+ element = Tcl_GetStringFromObj(objPtr, &length);
if ((element != NULL) && (length > 0)) {
allocSize += (length + 1);
}
@@ -1007,8 +1038,9 @@ Tcl_ConcatObj(objc, objv)
p = concatStr;
for (i = 0; i < objc; i++) {
objPtr = objv[i];
- element = TclGetStringFromObj(objPtr, &elemLength);
- while ((elemLength > 0) && (isspace(UCHAR(*element)))) {
+ element = Tcl_GetStringFromObj(objPtr, &elemLength);
+ while ((elemLength > 0)
+ && (isspace(UCHAR(*element)))) { /* INTL: ISO space. */
element++;
elemLength--;
}
@@ -1020,7 +1052,7 @@ Tcl_ConcatObj(objc, objv)
*/
while ((elemLength > 0)
- && isspace(UCHAR(element[elemLength-1]))
+ && isspace(UCHAR(element[elemLength-1])) /* INTL: ISO space. */
&& ((elemLength < 2) || (element[elemLength-2] != '\\'))) {
elemLength--;
}
@@ -1068,26 +1100,31 @@ Tcl_ConcatObj(objc, objv)
int
Tcl_StringMatch(string, pattern)
- char *string; /* String. */
- char *pattern; /* Pattern, which may contain special
+ CONST char *string; /* String. */
+ CONST char *pattern; /* Pattern, which may contain special
* characters. */
{
- char c2;
-
+ int p, s;
+ CONST char *pstart = pattern;
+
while (1) {
- /* 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
- * but not at the end of the string, we failed.
+ p = *pattern;
+ s = *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 but not at
+ * the end of the string, we failed.
*/
- if (*pattern == 0) {
- if (*string == 0) {
+ if (p == '\0') {
+ if (s == '\0') {
return 1;
} else {
return 0;
}
}
- if ((*string == 0) && (*pattern != '*')) {
+ if ((s == '\0') && (p != '*')) {
return 0;
}
@@ -1097,28 +1134,32 @@ Tcl_StringMatch(string, pattern)
* match or we reach the end of the string.
*/
- if (*pattern == '*') {
- pattern += 1;
- if (*pattern == 0) {
+ if (p == '*') {
+ pattern++;
+ if (*pattern == '\0') {
return 1;
}
while (1) {
if (Tcl_StringMatch(string, pattern)) {
return 1;
}
- if (*string == 0) {
+ if (*string == '\0') {
return 0;
}
- string += 1;
+ string++;
}
}
-
+
/* Check for a "?" as the next pattern character. It matches
* any single character.
*/
- if (*pattern == '?') {
- goto thisCharOK;
+ if (p == '?') {
+ Tcl_UniChar ch;
+
+ pattern++;
+ string += Tcl_UtfToUniChar(string, &ch);
+ continue;
}
/* Check for a "[" as the next pattern character. It is followed
@@ -1126,971 +1167,68 @@ Tcl_StringMatch(string, pattern)
* (two characters separated by "-").
*/
- if (*pattern == '[') {
- pattern += 1;
+ if (p == '[') {
+ Tcl_UniChar ch, startChar, endChar;
+
+ pattern++;
+ string += Tcl_UtfToUniChar(string, &ch);
+
while (1) {
- if ((*pattern == ']') || (*pattern == 0)) {
+ if ((*pattern == ']') || (*pattern == '\0')) {
return 0;
}
- if (*pattern == *string) {
- break;
- }
- if (pattern[1] == '-') {
- c2 = pattern[2];
- if (c2 == 0) {
+ pattern += Tcl_UtfToUniChar(pattern, &startChar);
+ if (*pattern == '-') {
+ pattern++;
+ if (*pattern == '\0') {
return 0;
}
- if ((*pattern <= *string) && (c2 >= *string)) {
- break;
- }
- if ((*pattern >= *string) && (c2 <= *string)) {
+ pattern += Tcl_UtfToUniChar(pattern, &endChar);
+ if (((startChar <= ch) && (ch <= endChar))
+ || ((endChar <= ch) && (ch <= startChar))) {
+ /*
+ * Matches ranges of form [a-z] or [z-a].
+ */
+
break;
}
- pattern += 2;
+ } else if (startChar == ch) {
+ break;
}
- pattern += 1;
}
while (*pattern != ']') {
- if (*pattern == 0) {
- pattern--;
+ if (*pattern == '\0') {
+ pattern = Tcl_UtfPrev(pattern, pstart);
break;
}
- pattern += 1;
+ pattern++;
}
- goto thisCharOK;
+ pattern++;
+ continue;
}
- /* 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.
*/
- if (*pattern == '\\') {
- pattern += 1;
- if (*pattern == 0) {
+ if (p == '\\') {
+ pattern++;
+ p = *pattern;
+ if (p == '\0') {
return 0;
}
}
/* There's no special character. Just make sure that the next
- * characters of each string match.
+ * bytes of each string match.
*/
- if (*pattern != *string) {
+ if (s != p) {
return 0;
}
-
- thisCharOK: pattern += 1;
- string += 1;
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_SetResult --
- *
- * Arrange for "string" to be the Tcl return value.
- *
- * Results:
- * None.
- *
- * Side effects:
- * interp->result is left pointing either to "string" (if "copy" is 0)
- * or to a copy of string. Also, the object result is reset.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_SetResult(interp, string, freeProc)
- Tcl_Interp *interp; /* Interpreter with which to associate the
- * return value. */
- char *string; /* Value to be returned. If NULL, the
- * result is set to an empty string. */
- Tcl_FreeProc *freeProc; /* Gives information about the string:
- * TCL_STATIC, TCL_VOLATILE, or the address
- * of a Tcl_FreeProc such as free. */
-{
- Interp *iPtr = (Interp *) interp;
- int length;
- Tcl_FreeProc *oldFreeProc = iPtr->freeProc;
- char *oldResult = iPtr->result;
-
- if (string == NULL) {
- iPtr->resultSpace[0] = 0;
- iPtr->result = iPtr->resultSpace;
- iPtr->freeProc = 0;
- } else if (freeProc == TCL_VOLATILE) {
- length = strlen(string);
- if (length > TCL_RESULT_SIZE) {
- iPtr->result = (char *) ckalloc((unsigned) length+1);
- iPtr->freeProc = TCL_DYNAMIC;
- } else {
- iPtr->result = iPtr->resultSpace;
- iPtr->freeProc = 0;
- }
- strcpy(iPtr->result, string);
- } else {
- iPtr->result = string;
- iPtr->freeProc = freeProc;
- }
-
- /*
- * If the old result was dynamically-allocated, free it up. Do it
- * here, rather than at the beginning, in case the new result value
- * was part of the old result value.
- */
-
- if (oldFreeProc != 0) {
- if ((oldFreeProc == TCL_DYNAMIC)
- || (oldFreeProc == (Tcl_FreeProc *) free)) {
- ckfree(oldResult);
- } else {
- (*oldFreeProc)(oldResult);
- }
- }
-
- /*
- * Reset the object result since we just set the string result.
- */
-
- TclResetObjResult(iPtr);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_GetStringResult --
- *
- * Returns an interpreter's result value as a string.
- *
- * Results:
- * The interpreter's result as a string.
- *
- * Side effects:
- * If the string result is empty, the object result is moved to the
- * string result, then the object result is reset.
- *
- *----------------------------------------------------------------------
- */
-
-char *
-Tcl_GetStringResult(interp)
- Tcl_Interp *interp; /* Interpreter whose result to return. */
-{
- /*
- * If the string result is empty, move the object result to the
- * string result, then reset the object result.
- * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS.
- */
-
- if (*(interp->result) == 0) {
- Tcl_SetResult(interp,
- TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL),
- TCL_VOLATILE);
- }
- return interp->result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_SetObjResult --
- *
- * Arrange for objPtr to be an interpreter's result value.
- *
- * Results:
- * None.
- *
- * Side effects:
- * interp->objResultPtr is left pointing to the object referenced
- * by objPtr. The object's reference count is incremented since
- * there is now a new reference to it. The reference count for any
- * old objResultPtr value is decremented. Also, the string result
- * is reset.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_SetObjResult(interp, objPtr)
- Tcl_Interp *interp; /* Interpreter with which to associate the
- * return object value. */
- Tcl_Obj *objPtr; /* Tcl object to be returned. If NULL, the
- * obj result is made an empty string
- * object. */
-{
- Interp *iPtr = (Interp *) interp;
- Tcl_Obj *oldObjResult = iPtr->objResultPtr;
-
- iPtr->objResultPtr = objPtr;
- Tcl_IncrRefCount(objPtr); /* since interp result is a reference */
-
- /*
- * We wait until the end to release the old object result, in case
- * we are setting the result to itself.
- */
-
- TclDecrRefCount(oldObjResult);
-
- /*
- * Reset the string result since we just set the result object.
- */
-
- if (iPtr->freeProc != NULL) {
- if ((iPtr->freeProc == TCL_DYNAMIC)
- || (iPtr->freeProc == (Tcl_FreeProc *) free)) {
- ckfree(iPtr->result);
- } else {
- (*iPtr->freeProc)(iPtr->result);
- }
- iPtr->freeProc = 0;
- }
- iPtr->result = iPtr->resultSpace;
- iPtr->resultSpace[0] = 0;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_GetObjResult --
- *
- * 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
- * needs to hold on to a long-term reference to it.
- *
- * Results:
- * The interpreter's result as an object.
- *
- * Side effects:
- * If the interpreter has a non-empty string result, the result object
- * is either empty or stale because some procedure set interp->result
- * directly. If so, the string result is moved to the result object
- * then the string result is reset.
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_Obj *
-Tcl_GetObjResult(interp)
- Tcl_Interp *interp; /* Interpreter whose result to return. */
-{
- Interp *iPtr = (Interp *) interp;
- Tcl_Obj *objResultPtr;
- int length;
-
- /*
- * If the string result is non-empty, move the string result to the
- * object result, then reset the string result.
- */
-
- if (*(iPtr->result) != 0) {
- TclResetObjResult(iPtr);
-
- objResultPtr = iPtr->objResultPtr;
- length = strlen(iPtr->result);
- TclInitStringRep(objResultPtr, iPtr->result, length);
-
- if (iPtr->freeProc != NULL) {
- if ((iPtr->freeProc == TCL_DYNAMIC)
- || (iPtr->freeProc == (Tcl_FreeProc *) free)) {
- ckfree(iPtr->result);
- } else {
- (*iPtr->freeProc)(iPtr->result);
- }
- iPtr->freeProc = 0;
- }
- iPtr->result = iPtr->resultSpace;
- iPtr->resultSpace[0] = 0;
- }
- return iPtr->objResultPtr;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_AppendResultVA --
- *
- * Append a variable number of strings onto the interpreter's string
- * result.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The result of the interpreter given by the first argument is
- * extended by the strings in the va_list (up to a terminating NULL
- * argument).
- *
- * If the string result is empty, the object result is moved to the
- * string result, then the object result is reset.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_AppendResultVA (interp, argList)
- Tcl_Interp *interp; /* Interpreter with which to associate the
- * return value. */
- va_list argList; /* Variable argument list. */
-{
- Interp *iPtr = (Interp *) interp;
- va_list tmpArgList;
- char *string;
- int newSpace;
-
- /*
- * If the string result is empty, move the object result to the
- * string result, then reset the object result.
- * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS.
- */
-
- if (*(iPtr->result) == 0) {
- Tcl_SetResult((Tcl_Interp *) iPtr,
- TclGetStringFromObj(Tcl_GetObjResult((Tcl_Interp *) iPtr),
- (int *) NULL),
- TCL_VOLATILE);
- }
-
- /*
- * Scan through all the arguments to see how much space is needed.
- */
-
- tmpArgList = argList;
- newSpace = 0;
- while (1) {
- string = va_arg(tmpArgList, char *);
- if (string == NULL) {
- break;
- }
- newSpace += strlen(string);
- }
-
- /*
- * If the append buffer isn't already setup and large enough to hold
- * the new data, set it up.
- */
-
- if ((iPtr->result != iPtr->appendResult)
- || (iPtr->appendResult[iPtr->appendUsed] != 0)
- || ((newSpace + iPtr->appendUsed) >= iPtr->appendAvl)) {
- SetupAppendBuffer(iPtr, newSpace);
- }
-
- /*
- * Now go through all the argument strings again, copying them into the
- * buffer.
- */
-
- while (1) {
- string = va_arg(argList, char *);
- if (string == NULL) {
- break;
- }
- strcpy(iPtr->appendResult + iPtr->appendUsed, string);
- iPtr->appendUsed += strlen(string);
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_AppendResult --
- *
- * Append a variable number of strings onto the interpreter's string
- * result.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The result of the interpreter given by the first argument is
- * extended by the strings given by the second and following arguments
- * (up to a terminating NULL argument).
- *
- * If the string result is empty, the object result is moved to the
- * string result, then the object result is reset.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_AppendResult TCL_VARARGS_DEF(Tcl_Interp *,arg1)
-{
- Tcl_Interp *interp;
- va_list argList;
-
- interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
- Tcl_AppendResultVA(interp, argList);
- va_end(argList);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_AppendElement --
- *
- * Convert a string to a valid Tcl list element and append it to the
- * result (which is ostensibly a list).
- *
- * Results:
- * None.
- *
- * Side effects:
- * The result in the interpreter given by the first argument is
- * extended with a list element converted from string. A separator
- * space is added before the converted list element unless the current
- * result is empty, contains the single character "{", or ends in " {".
- *
- * If the string result is empty, the object result is moved to the
- * string result, then the object result is reset.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_AppendElement(interp, string)
- Tcl_Interp *interp; /* Interpreter whose result is to be
- * extended. */
- char *string; /* String to convert to list element and
- * add to result. */
-{
- Interp *iPtr = (Interp *) interp;
- char *dst;
- int size;
- int flags;
-
- /*
- * If the string result is empty, move the object result to the
- * string result, then reset the object result.
- * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS.
- */
-
- if (*(iPtr->result) == 0) {
- Tcl_SetResult(interp,
- TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL),
- TCL_VOLATILE);
- }
-
- /*
- * See how much space is needed, and grow the append buffer if
- * needed to accommodate the list element.
- */
-
- size = Tcl_ScanElement(string, &flags) + 1;
- if ((iPtr->result != iPtr->appendResult)
- || (iPtr->appendResult[iPtr->appendUsed] != 0)
- || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) {
- SetupAppendBuffer(iPtr, size+iPtr->appendUsed);
- }
-
- /*
- * Convert the string into a list element and copy it to the
- * buffer that's forming, with a space separator if needed.
- */
-
- dst = iPtr->appendResult + iPtr->appendUsed;
- if (TclNeedSpace(iPtr->appendResult, dst)) {
- iPtr->appendUsed++;
- *dst = ' ';
- dst++;
- }
- iPtr->appendUsed += Tcl_ConvertElement(string, dst, flags);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * SetupAppendBuffer --
- *
- * This procedure makes sure that there is an append buffer properly
- * initialized, if necessary, from the interpreter's result, and
- * that it has at least enough room to accommodate newSpace new
- * bytes of information.
- *
- * Results:
- * None.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-SetupAppendBuffer(iPtr, newSpace)
- Interp *iPtr; /* Interpreter whose result is being set up. */
- int newSpace; /* Make sure that at least this many bytes
- * of new information may be added. */
-{
- int totalSpace;
-
- /*
- * Make the append buffer larger, if that's necessary, then copy the
- * result into the append buffer and make the append buffer the official
- * Tcl result.
- */
-
- if (iPtr->result != iPtr->appendResult) {
- /*
- * If an oversized buffer was used recently, then free it up
- * so we go back to a smaller buffer. This avoids tying up
- * memory forever after a large operation.
- */
-
- if (iPtr->appendAvl > 500) {
- ckfree(iPtr->appendResult);
- iPtr->appendResult = NULL;
- iPtr->appendAvl = 0;
- }
- iPtr->appendUsed = strlen(iPtr->result);
- } else if (iPtr->result[iPtr->appendUsed] != 0) {
- /*
- * Most likely someone has modified a result created by
- * Tcl_AppendResult et al. so that it has a different size.
- * Just recompute the size.
- */
-
- iPtr->appendUsed = strlen(iPtr->result);
- }
-
- totalSpace = newSpace + iPtr->appendUsed;
- if (totalSpace >= iPtr->appendAvl) {
- char *new;
-
- if (totalSpace < 100) {
- totalSpace = 200;
- } else {
- totalSpace *= 2;
- }
- new = (char *) ckalloc((unsigned) totalSpace);
- strcpy(new, iPtr->result);
- if (iPtr->appendResult != NULL) {
- ckfree(iPtr->appendResult);
- }
- iPtr->appendResult = new;
- iPtr->appendAvl = totalSpace;
- } else if (iPtr->result != iPtr->appendResult) {
- strcpy(iPtr->appendResult, iPtr->result);
- }
-
- Tcl_FreeResult((Tcl_Interp *) iPtr);
- iPtr->result = iPtr->appendResult;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_FreeResult --
- *
- * This procedure frees up the memory associated with an interpreter's
- * string result. It also resets the interpreter's result object.
- * Tcl_FreeResult is most commonly used when a procedure is about to
- * replace one result value with another.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Frees the memory associated with interp's string result and sets
- * interp->freeProc to zero, but does not change interp->result or
- * clear error state. Resets interp's result object to an unshared
- * empty object.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_FreeResult(interp)
- Tcl_Interp *interp; /* Interpreter for which to free result. */
-{
- Interp *iPtr = (Interp *) interp;
-
- if (iPtr->freeProc != NULL) {
- if ((iPtr->freeProc == TCL_DYNAMIC)
- || (iPtr->freeProc == (Tcl_FreeProc *) free)) {
- ckfree(iPtr->result);
- } else {
- (*iPtr->freeProc)(iPtr->result);
- }
- iPtr->freeProc = 0;
- }
-
- TclResetObjResult(iPtr);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_ResetResult --
- *
- * This procedure resets both the interpreter's string and object
- * results.
- *
- * Results:
- * None.
- *
- * Side effects:
- * It resets the result object to an unshared empty object. It
- * then restores the interpreter's string result area to its default
- * initialized state, freeing up any memory that may have been
- * allocated. It also clears any error information for the interpreter.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_ResetResult(interp)
- Tcl_Interp *interp; /* Interpreter for which to clear result. */
-{
- Interp *iPtr = (Interp *) interp;
-
- TclResetObjResult(iPtr);
-
- Tcl_FreeResult(interp);
- iPtr->result = iPtr->resultSpace;
- iPtr->resultSpace[0] = 0;
-
- iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS | ERROR_CODE_SET);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_SetErrorCodeVA --
- *
- * This procedure is called to record machine-readable information
- * about an error that is about to be returned.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The errorCode global variable is modified to hold all of the
- * arguments to this procedure, in a list form with each argument
- * becoming one element of the list. A flag is set internally
- * to remember that errorCode has been set, so the variable doesn't
- * get set automatically when the error is returned.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_SetErrorCodeVA (interp, argList)
- Tcl_Interp *interp; /* Interpreter in which to access the errorCode
- * variable. */
- va_list argList; /* Variable argument list. */
-{
- char *string;
- int flags;
- Interp *iPtr = (Interp *) interp;
-
- /*
- * Scan through the arguments one at a time, appending them to
- * $errorCode as list elements.
- */
-
- flags = TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT;
- while (1) {
- string = va_arg(argList, char *);
- if (string == NULL) {
- break;
- }
- (void) Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode",
- (char *) NULL, string, flags);
- flags |= TCL_APPEND_VALUE;
- }
- iPtr->flags |= ERROR_CODE_SET;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_SetErrorCode --
- *
- * This procedure is called to record machine-readable information
- * about an error that is about to be returned.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The errorCode global variable is modified to hold all of the
- * arguments to this procedure, in a list form with each argument
- * becoming one element of the list. A flag is set internally
- * to remember that errorCode has been set, so the variable doesn't
- * get set automatically when the error is returned.
- *
- *----------------------------------------------------------------------
- */
- /* VARARGS2 */
-void
-Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1)
-{
- Tcl_Interp *interp;
- va_list argList;
-
- /*
- * Scan through the arguments one at a time, appending them to
- * $errorCode as list elements.
- */
-
- interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
- Tcl_SetErrorCodeVA(interp, argList);
- va_end(argList);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_SetObjErrorCode --
- *
- * This procedure is called to record machine-readable information
- * about an error that is about to be returned. The caller should
- * build a list object up and pass it to this routine.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The errorCode global variable is modified to be the new value.
- * A flag is set internally to remember that errorCode has been
- * set, so the variable doesn't get set automatically when the
- * error is returned.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_SetObjErrorCode(interp, errorObjPtr)
- Tcl_Interp *interp;
- Tcl_Obj *errorObjPtr;
-{
- Tcl_Obj *namePtr;
- Interp *iPtr;
-
- namePtr = Tcl_NewStringObj("errorCode", -1);
- iPtr = (Interp *) interp;
- Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL, errorObjPtr,
- TCL_GLOBAL_ONLY);
- iPtr->flags |= ERROR_CODE_SET;
- Tcl_DecrRefCount(namePtr);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_RegExpCompile --
- *
- * Compile a regular expression into a form suitable for fast
- * matching. This procedure retains a small cache of pre-compiled
- * regular expressions in the interpreter, in order to avoid
- * compilation costs as much as possible.
- *
- * Results:
- * The return value is a pointer to the compiled form of string,
- * suitable for passing to Tcl_RegExpExec. This compiled form
- * 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
- * while compiling the pattern, then NULL is returned and an error
- * message is left in interp->result.
- *
- * Side effects:
- * The cache of compiled regexp's in interp will be modified to
- * hold information for string, if such information isn't already
- * present in the cache.
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_RegExp
-Tcl_RegExpCompile(interp, string)
- Tcl_Interp *interp; /* For use in error reporting. */
- char *string; /* String for which to produce
- * compiled regular expression. */
-{
- Interp *iPtr = (Interp *) interp;
- int i, length;
- regexp *result;
-
- length = strlen(string);
- for (i = 0; i < NUM_REGEXPS; i++) {
- if ((length == iPtr->patLengths[i])
- && (strcmp(string, iPtr->patterns[i]) == 0)) {
- /*
- * Move the matched pattern to the first slot in the
- * cache and shift the other patterns down one position.
- */
-
- if (i != 0) {
- int j;
- char *cachedString;
-
- cachedString = iPtr->patterns[i];
- result = iPtr->regexps[i];
- for (j = i-1; j >= 0; j--) {
- iPtr->patterns[j+1] = iPtr->patterns[j];
- iPtr->patLengths[j+1] = iPtr->patLengths[j];
- iPtr->regexps[j+1] = iPtr->regexps[j];
- }
- iPtr->patterns[0] = cachedString;
- iPtr->patLengths[0] = length;
- iPtr->regexps[0] = result;
- }
- return (Tcl_RegExp) iPtr->regexps[0];
- }
- }
-
- /*
- * No match in the cache. Compile the string and add it to the
- * cache.
- */
-
- TclRegError((char *) NULL);
- result = TclRegComp(string);
- if (TclGetRegError() != NULL) {
- Tcl_AppendResult(interp,
- "couldn't compile regular expression pattern: ",
- TclGetRegError(), (char *) NULL);
- return NULL;
- }
- if (iPtr->patterns[NUM_REGEXPS-1] != NULL) {
- ckfree(iPtr->patterns[NUM_REGEXPS-1]);
- ckfree((char *) iPtr->regexps[NUM_REGEXPS-1]);
- }
- for (i = NUM_REGEXPS - 2; i >= 0; i--) {
- iPtr->patterns[i+1] = iPtr->patterns[i];
- iPtr->patLengths[i+1] = iPtr->patLengths[i];
- iPtr->regexps[i+1] = iPtr->regexps[i];
- }
- iPtr->patterns[0] = (char *) ckalloc((unsigned) (length+1));
- strcpy(iPtr->patterns[0], string);
- iPtr->patLengths[0] = length;
- iPtr->regexps[0] = result;
- return (Tcl_RegExp) result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_RegExpExec --
- *
- * Execute the regular expression matcher using a compiled form
- * of a regular expression and save information about any match
- * that is found.
- *
- * Results:
- * If an error occurs during the matching operation then -1
- * is returned and interp->result contains an error message.
- * Otherwise the return value is 1 if a matching range is
- * found and 0 if there is no matching range.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_RegExpExec(interp, re, string, start)
- Tcl_Interp *interp; /* Interpreter to use for error reporting. */
- Tcl_RegExp re; /* Compiled regular expression; must have
- * been returned by previous call to
- * Tcl_RegExpCompile. */
- char *string; /* String against which to match re. */
- char *start; /* If string is part of a larger string,
- * this identifies beginning of larger
- * string, so that "^" won't match. */
-{
- int match;
-
- regexp *regexpPtr = (regexp *) re;
- TclRegError((char *) NULL);
- match = TclRegExec(regexpPtr, string, start);
- if (TclGetRegError() != NULL) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "error while matching regular expression: ",
- TclGetRegError(), (char *) NULL);
- return -1;
- }
- return match;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_RegExpRange --
- *
- * Returns pointers describing the range of a regular expression match,
- * or one of the subranges within the match.
- *
- * Results:
- * The variables at *startPtr and *endPtr are modified to hold the
- * addresses of the endpoints of the range given by index. If the
- * specified range doesn't exist then NULLs are returned.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_RegExpRange(re, index, startPtr, endPtr)
- Tcl_RegExp re; /* Compiled regular expression that has
- * been passed to Tcl_RegExpExec. */
- int index; /* 0 means give the range of the entire
- * match, > 0 means give the range of
- * a matching subrange. Must be no greater
- * than NSUBEXP. */
- char **startPtr; /* Store address of first character in
- * (sub-) range here. */
- char **endPtr; /* Store address of character just after last
- * in (sub-) range here. */
-{
- regexp *regexpPtr = (regexp *) re;
-
- if (index >= NSUBEXP) {
- *startPtr = *endPtr = NULL;
- } else {
- *startPtr = regexpPtr->startp[index];
- *endPtr = regexpPtr->endp[index];
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_RegExpMatch --
- *
- * See if a string matches a regular expression.
- *
- * Results:
- * If an error occurs during the matching operation then -1
- * is returned and interp->result contains an error message.
- * Otherwise the return value is 1 if "string" matches "pattern"
- * and 0 otherwise.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_RegExpMatch(interp, string, pattern)
- Tcl_Interp *interp; /* Used for error reporting. */
- char *string; /* String. */
- char *pattern; /* Regular expression to match against
- * string. */
-{
- Tcl_RegExp re;
-
- re = Tcl_RegExpCompile(interp, pattern);
- if (re == NULL) {
- return -1;
+ pattern++;
+ string++;
}
- return Tcl_RegExpExec(interp, re, string, string);
}
/*
@@ -2118,7 +1256,7 @@ Tcl_DStringInit(dsPtr)
dsPtr->string = dsPtr->staticSpace;
dsPtr->length = 0;
dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
- dsPtr->staticSpace[0] = 0;
+ dsPtr->staticSpace[0] = '\0';
}
/*
@@ -2149,7 +1287,7 @@ Tcl_DStringAppend(dsPtr, string, length)
* up to null at end. */
{
int newSize;
- char *newString, *dst;
+ char *dst;
CONST char *end;
if (length < 0) {
@@ -2164,14 +1302,18 @@ Tcl_DStringAppend(dsPtr, string, length)
*/
if (newSize >= dsPtr->spaceAvl) {
- dsPtr->spaceAvl = newSize*2;
- newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl);
- memcpy((VOID *) newString, (VOID *) dsPtr->string,
- (size_t) dsPtr->length);
- if (dsPtr->string != dsPtr->staticSpace) {
- ckfree(dsPtr->string);
+ dsPtr->spaceAvl = newSize * 2;
+ if (dsPtr->string == dsPtr->staticSpace) {
+ char *newString;
+
+ newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl);
+ memcpy((VOID *) newString, (VOID *) dsPtr->string,
+ (size_t) dsPtr->length);
+ dsPtr->string = newString;
+ } else {
+ dsPtr->string = (char *) ckrealloc((VOID *) dsPtr->string,
+ (size_t) dsPtr->spaceAvl);
}
- dsPtr->string = newString;
}
/*
@@ -2213,7 +1355,7 @@ Tcl_DStringAppendElement(dsPtr, string)
* null-terminated. */
{
int newSize, flags;
- char *dst, *newString;
+ char *dst;
newSize = Tcl_ScanElement(string, &flags) + dsPtr->length + 1;
@@ -2227,14 +1369,18 @@ Tcl_DStringAppendElement(dsPtr, string)
*/
if (newSize >= dsPtr->spaceAvl) {
- dsPtr->spaceAvl = newSize*2;
- newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl);
- memcpy((VOID *) newString, (VOID *) dsPtr->string,
- (size_t) dsPtr->length);
- if (dsPtr->string != dsPtr->staticSpace) {
- ckfree(dsPtr->string);
+ dsPtr->spaceAvl = newSize * 2;
+ if (dsPtr->string == dsPtr->staticSpace) {
+ char *newString;
+
+ newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl);
+ memcpy((VOID *) newString, (VOID *) dsPtr->string,
+ (size_t) dsPtr->length);
+ dsPtr->string = newString;
+ } else {
+ dsPtr->string = (char *) ckrealloc((VOID *) dsPtr->string,
+ (size_t) dsPtr->spaceAvl);
}
- dsPtr->string = newString;
}
/*
@@ -2277,27 +1423,41 @@ Tcl_DStringSetLength(dsPtr, length)
Tcl_DString *dsPtr; /* Structure describing dynamic string. */
int length; /* New length for dynamic string. */
{
+ int newsize;
+
if (length < 0) {
length = 0;
}
if (length >= dsPtr->spaceAvl) {
- char *newString;
-
- dsPtr->spaceAvl = length+1;
- newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl);
-
/*
- * SPECIAL NOTE: must use memcpy, not strcpy, to copy the string
- * to a larger buffer, since there may be embedded NULLs in the
- * string in some cases.
+ * There are two interesting cases here. In the first case, the user
+ * may be trying to allocate a large buffer of a specific size. It
+ * would be wasteful to overallocate that buffer, so we just allocate
+ * enough for the requested size plus the trailing null byte. In the
+ * second case, we are growing the buffer incrementally, so we need
+ * behavior similar to Tcl_DStringAppend. The requested length will
+ * usually be a small delta above the current spaceAvl, so we'll end up
+ * doubling the old size. This won't grow the buffer quite as quickly,
+ * but it should be close enough.
*/
- memcpy((VOID *) newString, (VOID *) dsPtr->string,
- (size_t) dsPtr->length);
- if (dsPtr->string != dsPtr->staticSpace) {
- ckfree(dsPtr->string);
+ newsize = dsPtr->spaceAvl * 2;
+ if (length < newsize) {
+ dsPtr->spaceAvl = newsize;
+ } else {
+ dsPtr->spaceAvl = length + 1;
+ }
+ if (dsPtr->string == dsPtr->staticSpace) {
+ char *newString;
+
+ newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl);
+ memcpy((VOID *) newString, (VOID *) dsPtr->string,
+ (size_t) dsPtr->length);
+ dsPtr->string = newString;
+ } else {
+ dsPtr->string = (char *) ckrealloc((VOID *) dsPtr->string,
+ (size_t) dsPtr->spaceAvl);
}
- dsPtr->string = newString;
}
dsPtr->length = length;
dsPtr->string[length] = 0;
@@ -2318,8 +1478,7 @@ Tcl_DStringSetLength(dsPtr, length)
* The previous contents of the dynamic string are lost, and
* the new value is an empty string.
*
- *----------------------------------------------------------------------
- */
+ *---------------------------------------------------------------------- */
void
Tcl_DStringFree(dsPtr)
@@ -2331,7 +1490,7 @@ Tcl_DStringFree(dsPtr)
dsPtr->string = dsPtr->staticSpace;
dsPtr->length = 0;
dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
- dsPtr->staticSpace[0] = 0;
+ dsPtr->staticSpace[0] = '\0';
}
/*
@@ -2375,7 +1534,7 @@ Tcl_DStringResult(interp, dsPtr)
dsPtr->string = dsPtr->staticSpace;
dsPtr->length = 0;
dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
- dsPtr->staticSpace[0] = 0;
+ dsPtr->staticSpace[0] = '\0';
}
/*
@@ -2413,12 +1572,10 @@ Tcl_DStringGetResult(interp, dsPtr)
/*
* If the string result is empty, move the object result to the
* string result, then reset the object result.
- * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS.
*/
if (*(iPtr->result) == 0) {
- Tcl_SetResult(interp,
- TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL),
+ Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
TCL_VOLATILE);
}
@@ -2535,9 +1692,12 @@ Tcl_PrintDouble(interp, value, dst)
* must have at least TCL_DOUBLE_SPACE
* characters. */
{
- char *p;
+ char *p, c;
+ Tcl_UniChar ch;
+ Tcl_MutexLock(&precisionMutex);
sprintf(dst, precisionFormat, value);
+ Tcl_MutexUnlock(&precisionMutex);
/*
* If the ASCII result looks like an integer, add ".0" so that it
@@ -2545,8 +1705,10 @@ Tcl_PrintDouble(interp, value, dst)
* values from being converted to integers unintentionally.
*/
- for (p = dst; *p != 0; p++) {
- if ((*p == '.') || (isalpha(UCHAR(*p)))) {
+ for (p = dst; *p != 0; ) {
+ p += Tcl_UtfToUniChar(p, &ch);
+ c = UCHAR(ch);
+ if ((c == '.') || isalpha(UCHAR(c))) { /* INTL: ISO only. */
return;
}
}
@@ -2607,9 +1769,12 @@ TclPrecTraceProc(clientData, interp, name1, name2, flags)
* out of date.
*/
+ Tcl_MutexLock(&precisionMutex);
+
if (flags & TCL_TRACE_READS) {
Tcl_SetVar2(interp, name1, name2, precisionString,
flags & TCL_GLOBAL_ONLY);
+ Tcl_MutexUnlock(&precisionMutex);
return (char *) NULL;
}
@@ -2623,6 +1788,7 @@ TclPrecTraceProc(clientData, interp, name1, name2, flags)
if (Tcl_IsSafe(interp)) {
Tcl_SetVar2(interp, name1, name2, precisionString,
flags & TCL_GLOBAL_ONLY);
+ Tcl_MutexUnlock(&precisionMutex);
return "can't modify precision from a safe interpreter";
}
value = Tcl_GetVar2(interp, name1, name2, flags & TCL_GLOBAL_ONLY);
@@ -2634,10 +1800,12 @@ TclPrecTraceProc(clientData, interp, name1, name2, flags)
(end == value) || (*end != 0)) {
Tcl_SetVar2(interp, name1, name2, precisionString,
flags & TCL_GLOBAL_ONLY);
+ Tcl_MutexUnlock(&precisionMutex);
return "improper value for precision";
}
TclFormatInt(precisionString, prec);
sprintf(precisionFormat, "%%.%dg", prec);
+ Tcl_MutexUnlock(&precisionMutex);
return (char *) NULL;
}
@@ -2680,7 +1848,8 @@ TclNeedSpace(start, end)
}
end--;
if (*end != '{') {
- if (isspace(UCHAR(*end)) && ((end == start) || (end[-1] != '\\'))) {
+ if (isspace(UCHAR(*end)) /* INTL: ISO space. */
+ && ((end == start) || (end[-1] != '\\'))) {
return 0;
}
return 1;
@@ -2691,7 +1860,7 @@ TclNeedSpace(start, end)
}
end--;
} while (*end == '{');
- if (isspace(UCHAR(*end))) {
+ if (isspace(UCHAR(*end))) { /* INTL: ISO space. */
return 0;
}
return 1;
@@ -2732,7 +1901,17 @@ TclFormatInt(buffer, n)
char *digits = "0123456789";
/*
- * Check first whether "n" is the maximum negative value. This is
+ * Check first whether "n" is zero.
+ */
+
+ if (n == 0) {
+ buffer[0] = '0';
+ buffer[1] = 0;
+ return 1;
+ }
+
+ /*
+ * Check whether "n" is the maximum negative value. This is
* -2^(m-1) for an m-bit word, and has no positive equivalent;
* negating it produces the same value.
*/
@@ -2794,22 +1973,41 @@ TclFormatInt(buffer, n)
*/
int
-TclLooksLikeInt(p)
- char *p; /* Pointer to string. */
+TclLooksLikeInt(bytes, length)
+ register char *bytes; /* Points to first byte of the string. */
+ int length; /* Number of bytes in the string. If < 0
+ * bytes up to the first null byte are
+ * considered (if they may appear in an
+ * integer). */
{
- while (isspace(UCHAR(*p))) {
+ register char *p, *end;
+
+ if (length < 0) {
+ length = (bytes? strlen(bytes) : 0);
+ }
+ end = (bytes + length);
+
+ p = bytes;
+ while ((p < end) && isspace(UCHAR(*p))) { /* INTL: ISO space. */
p++;
}
+ if (p == end) {
+ return 0;
+ }
+
if ((*p == '+') || (*p == '-')) {
p++;
}
- if (!isdigit(UCHAR(*p))) {
+ if ((p == end) || !isdigit(UCHAR(*p))) { /* INTL: digit */
return 0;
}
p++;
- while (isdigit(UCHAR(*p))) {
+ while ((p < end) && isdigit(UCHAR(*p))) { /* INTL: digit */
p++;
}
+ if (p == end) {
+ return 1;
+ }
if ((*p != '.') && (*p != 'e') && (*p != 'E')) {
return 1;
}
@@ -2843,30 +2041,26 @@ TclLooksLikeInt(p)
int
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
* after errors. */
- Tcl_Obj *objPtr; /* Points to an object containing either
+ Tcl_Obj *objPtr; /* Points to an object containing either
* "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". */
- int *indexPtr; /* Location filled in with an integer
+ int *indexPtr; /* Location filled in with an integer
* representing an index. */
{
Interp *iPtr = (Interp *) interp;
char *bytes;
int index, length, result;
- /*
- * THIS FAILS IF THE INDEX OBJECT'S STRING REP CONTAINS NULLS.
- */
-
if (objPtr->typePtr == &tclIntType) {
*indexPtr = (int)objPtr->internalRep.longValue;
return TCL_OK;
}
- bytes = TclGetStringFromObj(objPtr, &length);
+ bytes = Tcl_GetStringFromObj(objPtr, &length);
if ((*bytes == 'e')
&& (strncmp(bytes, "end", (unsigned) length) == 0)) {
index = endValue;
@@ -2911,3 +2105,56 @@ Tcl_GetNameOfExecutable()
{
return (tclExecutableName);
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetCwd --
+ *
+ * This function replaces the library version of getcwd().
+ *
+ * Results:
+ * The result is a pointer to a string specifying the current
+ * directory, or NULL if the current directory could not be
+ * determined. If NULL is returned, an error message is left in the
+ * interp's result. Storage for the result string is allocated in
+ * bufferPtr; the caller must call Tcl_DStringFree() when the result
+ * is no longer needed.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char *
+Tcl_GetCwd(interp, cwdPtr)
+ Tcl_Interp *interp;
+ Tcl_DString *cwdPtr;
+{
+ return TclpGetCwd(interp, cwdPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_Chdir --
+ *
+ * This function replaces the library version of chdir().
+ *
+ * Results:
+ * See chdir() documentation.
+ *
+ * Side effects:
+ * See chdir() documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_Chdir(dirName)
+ CONST char *dirName;
+{
+ return TclpChdir(dirName);
+}
+