summaryrefslogtreecommitdiffstats
path: root/generic/tclStringObj.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclStringObj.c')
-rw-r--r--generic/tclStringObj.c2269
1 files changed, 1678 insertions, 591 deletions
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 6a9d832..13dda54 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -1,108 +1,111 @@
-/*
+/*
* tclStringObj.c --
*
- * This file contains procedures that implement string operations on Tcl
- * objects. Some string operations work with UTF strings and others
- * require Unicode format. Functions that require knowledge of the width
+ * This file contains functions that implement string operations on Tcl
+ * objects. Some string operations work with UTF strings and others
+ * require Unicode format. Functions that require knowledge of the width
* of each character, such as indexing, operate on Unicode data.
*
- * A Unicode string is an internationalized string. Conceptually, a
- * Unicode string is an array of 16-bit quantities organized as a sequence
- * of properly formed UTF-8 characters. There is a one-to-one map between
- * Unicode and UTF characters. Because Unicode characters have a fixed
- * width, operations such as indexing operate on Unicode data. The String
- * object is optimized for the case where each UTF char in a string is
- * only one byte. In this case, we store the value of numChars, but we
- * don't store the Unicode data (unless Tcl_GetUnicode is explicitly
- * called).
- *
- * The String object type stores one or both formats. The default
- * behavior is to store UTF. Once Unicode is calculated by a function, it
+ * A Unicode string is an internationalized string. Conceptually, a
+ * Unicode string is an array of 16-bit quantities organized as a
+ * sequence of properly formed UTF-8 characters. There is a one-to-one
+ * map between Unicode and UTF characters. Because Unicode characters
+ * have a fixed width, operations such as indexing operate on Unicode
+ * data. The String object is optimized for the case where each UTF char
+ * in a string is only one byte. In this case, we store the value of
+ * numChars, but we don't store the Unicode data (unless Tcl_GetUnicode
+ * is explicitly called).
+ *
+ * The String object type stores one or both formats. The default
+ * behavior is to store UTF. Once Unicode is calculated by a function, it
* is stored in the internal rep for future access (without an additional
* O(n) cost).
*
* To allow many appends to be done to an object without constantly
* reallocating the space for the string or Unicode representation, we
* allocate double the space for the string or Unicode and use the
- * internal representation to keep track of how much space is used
- * vs. allocated.
+ * internal representation to keep track of how much space is used vs.
+ * allocated.
*
* Copyright (c) 1995-1997 Sun Microsystems, Inc.
* Copyright (c) 1999 by Scriptics Corporation.
*
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
+#include "tommath.h"
/*
- * Prototypes for procedures defined later in this file:
+ * Prototypes for functions defined later in this file:
*/
-static void AppendUnicodeToUnicodeRep _ANSI_ARGS_((
- Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode,
- int appendNumChars));
-static void AppendUnicodeToUtfRep _ANSI_ARGS_((
- Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode,
- int numChars));
-static void AppendUtfToUnicodeRep _ANSI_ARGS_((Tcl_Obj *objPtr,
- CONST char *bytes, int numBytes));
-static void AppendUtfToUtfRep _ANSI_ARGS_((Tcl_Obj *objPtr,
- CONST char *bytes, int numBytes));
-static void DupStringInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr,
- Tcl_Obj *copyPtr));
-static void FillUnicodeRep _ANSI_ARGS_((Tcl_Obj *objPtr));
-static void FreeStringInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr));
-static void GrowUnicodeBuffer _ANSI_ARGS_((Tcl_Obj *objPtr,
- int needed));
-static int SetStringFromAny _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj *objPtr));
+static void AppendPrintfToObjVA(Tcl_Obj *objPtr,
+ const char *format, va_list argList);
+static void AppendUnicodeToUnicodeRep(Tcl_Obj *objPtr,
+ const Tcl_UniChar *unicode, int appendNumChars);
+static void AppendUnicodeToUtfRep(Tcl_Obj *objPtr,
+ const Tcl_UniChar *unicode, int numChars);
+static void AppendUtfToUnicodeRep(Tcl_Obj *objPtr,
+ const char *bytes, int numBytes);
+static void AppendUtfToUtfRep(Tcl_Obj *objPtr,
+ const char *bytes, int numBytes);
+static void DupStringInternalRep(Tcl_Obj *objPtr,
+ Tcl_Obj *copyPtr);
+static void FillUnicodeRep(Tcl_Obj *objPtr);
+static void FreeStringInternalRep(Tcl_Obj *objPtr);
+static void GrowUnicodeBuffer(Tcl_Obj *objPtr, int needed);
+static int SetStringFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void SetUnicodeObj(Tcl_Obj *objPtr,
- CONST Tcl_UniChar *unicode, int numChars);
-static int UnicodeLength _ANSI_ARGS_((CONST Tcl_UniChar *unicode));
-static void UpdateStringOfString _ANSI_ARGS_((Tcl_Obj *objPtr));
+ const Tcl_UniChar *unicode, int numChars);
+static int UnicodeLength(const Tcl_UniChar *unicode);
+static void UpdateStringOfString(Tcl_Obj *objPtr);
/*
* The structure below defines the string Tcl object type by means of
- * procedures that can be invoked by generic object code.
+ * functions that can be invoked by generic object code.
*/
Tcl_ObjType tclStringType = {
- "string", /* name */
- FreeStringInternalRep, /* freeIntRepPro */
- DupStringInternalRep, /* dupIntRepProc */
- UpdateStringOfString, /* updateStringProc */
- SetStringFromAny /* setFromAnyProc */
+ "string", /* name */
+ FreeStringInternalRep, /* freeIntRepPro */
+ DupStringInternalRep, /* dupIntRepProc */
+ UpdateStringOfString, /* updateStringProc */
+ SetStringFromAny /* setFromAnyProc */
};
/*
- * The following structure is the internal rep for a String object.
- * It keeps track of how much memory has been used and how much has been
- * allocated for the Unicode and UTF string to enable growing and
- * shrinking of the UTF and Unicode reps of the String object with fewer
- * mallocs. To optimize string length and indexing operations, this
- * structure also stores the number of characters (same of UTF and Unicode!)
- * once that value has been computed.
+ * The following structure is the internal rep for a String object. It keeps
+ * track of how much memory has been used and how much has been allocated for
+ * the Unicode and UTF string to enable growing and shrinking of the UTF and
+ * Unicode reps of the String object with fewer mallocs. To optimize string
+ * length and indexing operations, this structure also stores the number of
+ * characters (same of UTF and Unicode!) once that value has been computed.
+ *
+ * Under normal configurations, what Tcl calls "Unicode" is actually UTF-16
+ * restricted to the Basic Multilingual Plane (i.e. U+00000 to U+0FFFF). This
+ * can be officially modified by altering the definition of Tcl_UniChar in
+ * tcl.h, but do not do that unless you are sure what you're doing!
*/
typedef struct String {
- int numChars; /* The number of chars in the string.
- * -1 means this value has not been
- * calculated. >= 0 means that there is a
- * valid Unicode rep, or that the number
- * of UTF bytes == the number of chars. */
- size_t allocated; /* The amount of space actually allocated
- * for the UTF string (minus 1 byte for
- * the termination char). */
- size_t uallocated; /* The amount of space actually allocated
- * for the Unicode string (minus 2 bytes for
- * the termination char). */
- int hasUnicode; /* Boolean determining whether the string
- * has a Unicode representation. */
- Tcl_UniChar unicode[2]; /* The array of Unicode chars. The actual
- * size of this field depends on the
- * 'uallocated' field above. */
+ int numChars; /* The number of chars in the string. -1 means
+ * this value has not been calculated. >= 0
+ * means that there is a valid Unicode rep, or
+ * that the number of UTF bytes == the number
+ * of chars. */
+ size_t allocated; /* The amount of space actually allocated for
+ * the UTF string (minus 1 byte for the
+ * termination char). */
+ size_t uallocated; /* The amount of space actually allocated for
+ * the Unicode string (minus 2 bytes for the
+ * termination char). */
+ int hasUnicode; /* Boolean determining whether the string has
+ * a Unicode representation. */
+ Tcl_UniChar unicode[2]; /* The array of Unicode chars. The actual size
+ * of this field depends on the 'uallocated'
+ * field above. */
} String;
#define STRING_MAXCHARS \
@@ -125,9 +128,9 @@ typedef struct String {
(String *) attemptckrealloc((char *) ptr, \
(unsigned) STRING_SIZE(STRING_UALLOC(numChars)) )
#define GET_STRING(objPtr) \
- ((String *) (objPtr)->internalRep.otherValuePtr)
+ ((String *) (objPtr)->internalRep.otherValuePtr)
#define SET_STRING(objPtr, stringPtr) \
- (objPtr)->internalRep.otherValuePtr = (VOID *) (stringPtr)
+ ((objPtr)->internalRep.otherValuePtr = (void *) (stringPtr))
/*
* TCL STRING GROWTH ALGORITHM
@@ -138,31 +141,31 @@ typedef struct String {
* Attempt to allocate 2 * (originalLength + appendLength)
* On failure:
* attempt to allocate originalLength + 2*appendLength +
- * TCL_GROWTH_MIN_ALLOC
+ * TCL_GROWTH_MIN_ALLOC
*
* This algorithm allows very good performance, as it rapidly increases the
* memory allocated for a given string, which minimizes the number of
- * reallocations that must be performed. However, using only the doubling
- * algorithm can lead to a significant waste of memory. In particular, it
- * may fail even when there is sufficient memory available to complete the
- * append request (but there is not 2 * totalLength memory available). So when
- * the doubling fails (because there is not enough memory available), the
+ * reallocations that must be performed. However, using only the doubling
+ * algorithm can lead to a significant waste of memory. In particular, it may
+ * fail even when there is sufficient memory available to complete the append
+ * request (but there is not 2*totalLength memory available). So when the
+ * doubling fails (because there is not enough memory available), the
* algorithm requests a smaller amount of memory, which is still enough to
- * cover the request, but which hopefully will be less than the total available
- * memory.
- *
- * The addition of TCL_GROWTH_MIN_ALLOC allows for efficient handling
- * of very small appends. Without this extra slush factor, a sequence
- * of several small appends would cause several memory allocations.
- * As long as TCL_GROWTH_MIN_ALLOC is a reasonable size, we can
- * avoid that behavior.
+ * cover the request, but which hopefully will be less than the total
+ * available memory.
+ *
+ * The addition of TCL_GROWTH_MIN_ALLOC allows for efficient handling of very
+ * small appends. Without this extra slush factor, a sequence of several small
+ * appends would cause several memory allocations. As long as
+ * TCL_GROWTH_MIN_ALLOC is a reasonable size, we can avoid that behavior.
*
* The growth algorithm can be tuned by adjusting the following parameters:
*
* TCL_GROWTH_MIN_ALLOC Additional space, in bytes, to allocate when
- * the double allocation has failed.
- * Default is 1024 (1 kilobyte).
+ * the double allocation has failed. Default is
+ * 1024 (1 kilobyte).
*/
+
#ifndef TCL_GROWTH_MIN_ALLOC
#define TCL_GROWTH_MIN_ALLOC 1024
#endif
@@ -215,60 +218,55 @@ GrowUnicodeBuffer(
*
* Tcl_NewStringObj --
*
- * This procedure is normally called when not debugging: i.e., when
+ * This function is normally called when not debugging: i.e., when
* TCL_MEM_DEBUG is not defined. It creates a new string object and
* initializes it from the byte pointer and length arguments.
*
- * When TCL_MEM_DEBUG is defined, this procedure just returns the
- * result of calling the debugging version Tcl_DbNewStringObj.
+ * When TCL_MEM_DEBUG is defined, this function just returns the result
+ * of calling the debugging version Tcl_DbNewStringObj.
*
* Results:
* A newly created string object is returned that has ref count zero.
*
* Side effects:
- * The new object's internal string representation will be set to a
- * copy of the length bytes starting at "bytes". If "length" is
- * negative, use bytes up to the first NULL byte; i.e., assume "bytes"
- * points to a C-style NULL-terminated string. The object's type is set
- * to NULL. An extra NULL is added to the end of the new object's byte
- * array.
+ * The new object's internal string representation will be set to a copy
+ * of the length bytes starting at "bytes". If "length" is negative, use
+ * bytes up to the first NUL byte; i.e., assume "bytes" points to a
+ * C-style NUL-terminated string. The object's type is set to NULL. An
+ * extra NUL is added to the end of the new object's byte array.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
#undef Tcl_NewStringObj
-
Tcl_Obj *
-Tcl_NewStringObj(bytes, length)
- CONST char *bytes; /* Points to the first of the length bytes
+Tcl_NewStringObj(
+ const char *bytes, /* Points to the first of the length bytes
* used to initialize the new object. */
- int length; /* The number of bytes to copy from "bytes"
- * when initializing the new object. If
- * negative, use bytes up to the first
- * NULL byte. */
+ int length) /* The number of bytes to copy from "bytes"
+ * when initializing the new object. If
+ * negative, use bytes up to the first NUL
+ * byte. */
{
return Tcl_DbNewStringObj(bytes, length, "unknown", 0);
}
-
#else /* if not TCL_MEM_DEBUG */
-
Tcl_Obj *
-Tcl_NewStringObj(bytes, length)
- CONST char *bytes; /* Points to the first of the length bytes
+Tcl_NewStringObj(
+ const char *bytes, /* Points to the first of the length bytes
* used to initialize the new object. */
- int length; /* The number of bytes to copy from "bytes"
- * when initializing the new object. If
- * negative, use bytes up to the first
- * NULL byte. */
+ int length) /* The number of bytes to copy from "bytes"
+ * when initializing the new object. If
+ * negative, use bytes up to the first NUL
+ * byte. */
{
register Tcl_Obj *objPtr;
if (length < 0) {
length = (bytes? strlen(bytes) : 0);
}
- TclNewObj(objPtr);
- TclInitStringRep(objPtr, bytes, length);
+ TclNewStringObj(objPtr, bytes, length);
return objPtr;
}
#endif /* TCL_MEM_DEBUG */
@@ -278,45 +276,43 @@ Tcl_NewStringObj(bytes, length)
*
* Tcl_DbNewStringObj --
*
- * This procedure is normally called when debugging: i.e., when
+ * This function is normally called when debugging: i.e., when
* TCL_MEM_DEBUG is defined. It creates new string objects. It is the
- * same as the Tcl_NewStringObj procedure above except that it calls
+ * same as the Tcl_NewStringObj function above except that it calls
* Tcl_DbCkalloc directly with the file name and line number from its
* caller. This simplifies debugging since then the [memory active]
- * command will report the correct file name and line number when
+ * command will report the correct file name and line number when
* reporting objects that haven't been freed.
*
- * When TCL_MEM_DEBUG is not defined, this procedure just returns the
+ * When TCL_MEM_DEBUG is not defined, this function just returns the
* result of calling Tcl_NewStringObj.
*
* Results:
* A newly created string object is returned that has ref count zero.
*
* Side effects:
- * The new object's internal string representation will be set to a
- * copy of the length bytes starting at "bytes". If "length" is
- * negative, use bytes up to the first NULL byte; i.e., assume "bytes"
- * points to a C-style NULL-terminated string. The object's type is set
- * to NULL. An extra NULL is added to the end of the new object's byte
- * array.
+ * The new object's internal string representation will be set to a copy
+ * of the length bytes starting at "bytes". If "length" is negative, use
+ * bytes up to the first NUL byte; i.e., assume "bytes" points to a
+ * C-style NUL-terminated string. The object's type is set to NULL. An
+ * extra NUL is added to the end of the new object's byte array.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
-
Tcl_Obj *
-Tcl_DbNewStringObj(bytes, length, file, line)
- CONST char *bytes; /* Points to the first of the length bytes
+Tcl_DbNewStringObj(
+ const char *bytes, /* Points to the first of the length bytes
* used to initialize the new object. */
- int length; /* The number of bytes to copy from "bytes"
- * when initializing the new object. If
- * negative, use bytes up to the first
- * NULL byte. */
- CONST char *file; /* The name of the source file calling this
- * procedure; used for debugging. */
- int line; /* Line number in the source file; used
- * for debugging. */
+ int length, /* The number of bytes to copy from "bytes"
+ * when initializing the new object. If
+ * negative, use bytes up to the first NUL
+ * byte. */
+ const char *file, /* The name of the source file calling this
+ * function; used for debugging. */
+ int line) /* Line number in the source file; used for
+ * debugging. */
{
register Tcl_Obj *objPtr;
@@ -327,21 +323,19 @@ Tcl_DbNewStringObj(bytes, length, file, line)
TclInitStringRep(objPtr, bytes, length);
return objPtr;
}
-
#else /* if not TCL_MEM_DEBUG */
-
Tcl_Obj *
-Tcl_DbNewStringObj(bytes, length, file, line)
- CONST char *bytes; /* Points to the first of the length bytes
+Tcl_DbNewStringObj(
+ const char *bytes, /* Points to the first of the length bytes
* used to initialize the new object. */
- register int length; /* The number of bytes to copy from "bytes"
- * when initializing the new object. If
- * negative, use bytes up to the first
- * NULL byte. */
- CONST char *file; /* The name of the source file calling this
- * procedure; used for debugging. */
- int line; /* Line number in the source file; used
- * for debugging. */
+ register int length, /* The number of bytes to copy from "bytes"
+ * when initializing the new object. If
+ * negative, use bytes up to the first NUL
+ * byte. */
+ const char *file, /* The name of the source file calling this
+ * function; used for debugging. */
+ int line) /* Line number in the source file; used for
+ * debugging. */
{
return Tcl_NewStringObj(bytes, length);
}
@@ -352,14 +346,13 @@ Tcl_DbNewStringObj(bytes, length, file, line)
*
* Tcl_NewUnicodeObj --
*
- * This procedure is creates a new String object and initializes
- * it from the given Unicode String. If the Utf String is the same size
- * as the Unicode string, don't duplicate the data.
+ * This function is creates a new String object and initializes it from
+ * the given Unicode String. If the Utf String is the same size as the
+ * Unicode string, don't duplicate the data.
*
* Results:
- * The newly created object is returned. This object will have no
- * initial string representation. The returned object has a ref count
- * of 0.
+ * The newly created object is returned. This object will have no initial
+ * string representation. The returned object has a ref count of 0.
*
* Side effects:
* Memory allocated for new object and copy of Unicode argument.
@@ -368,10 +361,10 @@ Tcl_DbNewStringObj(bytes, length, file, line)
*/
Tcl_Obj *
-Tcl_NewUnicodeObj(unicode, numChars)
- CONST Tcl_UniChar *unicode; /* The unicode string used to initialize
- * the new object. */
- int numChars; /* Number of characters in the unicode
+Tcl_NewUnicodeObj(
+ const Tcl_UniChar *unicode, /* The unicode string used to initialize the
+ * new object. */
+ int numChars) /* Number of characters in the unicode
* string. */
{
Tcl_Obj *objPtr;
@@ -392,60 +385,63 @@ Tcl_NewUnicodeObj(unicode, numChars)
* Pointer to unicode string representing the unicode object.
*
* Side effects:
- * Frees old internal rep. Allocates memory for new "String"
- * internal rep.
+ * Frees old internal rep. Allocates memory for new "String" internal
+ * rep.
*
*----------------------------------------------------------------------
*/
int
-Tcl_GetCharLength(objPtr)
- Tcl_Obj *objPtr; /* The String object to get the num chars of. */
+Tcl_GetCharLength(
+ Tcl_Obj *objPtr) /* The String object to get the num chars
+ * of. */
{
String *stringPtr;
-
+
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
/*
- * If numChars is unknown, then calculate the number of characaters
- * while populating the Unicode string.
+ * If numChars is unknown, then calculate the number of characaters while
+ * populating the Unicode string.
*/
-
+
if (stringPtr->numChars == -1) {
register int i = objPtr->length;
register unsigned char *str = (unsigned char *) objPtr->bytes;
/*
* This is a speed sensitive function, so run specially over the
- * string to count continuous ascii characters before resorting
- * to the Tcl_NumUtfChars call. This is a long form of:
- stringPtr->numChars = Tcl_NumUtfChars(objPtr->bytes, objPtr->length);
- */
+ * string to count continuous ascii characters before resorting to the
+ * Tcl_NumUtfChars call. This is a long form of:
+ stringPtr->numChars = Tcl_NumUtfChars(objPtr->bytes,objPtr->length);
+ *
+ * TODO: Consider macro-izing this.
+ */
- while (i && (*str < 0xC0)) { i--; str++; }
+ while (i && (*str < 0xC0)) {
+ i--;
+ str++;
+ }
stringPtr->numChars = objPtr->length - i;
if (i) {
stringPtr->numChars += Tcl_NumUtfChars(objPtr->bytes
+ (objPtr->length - i), i);
}
- if (stringPtr->numChars == objPtr->length) {
-
+ if (stringPtr->numChars == objPtr->length) {
/*
- * Since we've just calculated the number of chars, and all
- * UTF chars are 1-byte long, we don't need to store the
- * unicode string.
+ * Since we've just calculated the number of chars, and all UTF
+ * chars are 1-byte long, we don't need to store the unicode
+ * string.
*/
stringPtr->hasUnicode = 0;
-
} else {
-
/*
- * Since we've just calucalated the number of chars, and not
- * all UTF chars are 1-byte long, go ahead and populate the
- * unicode string.
+ * Since we've just calucalated the number of chars, and not all
+ * UTF chars are 1-byte long, go ahead and populate the unicode
+ * string.
*/
FillUnicodeRep(objPtr);
@@ -454,7 +450,7 @@ Tcl_GetCharLength(objPtr)
* We need to fetch the pointer again because we have just
* reallocated the structure to make room for the Unicode data.
*/
-
+
stringPtr = GET_STRING(objPtr);
}
}
@@ -466,8 +462,8 @@ Tcl_GetCharLength(objPtr)
*
* Tcl_GetUniChar --
*
- * Get the index'th Unicode character from the String object. The
- * index is assumed to be in the appropriate range.
+ * Get the index'th Unicode character from the String object. The index
+ * is assumed to be in the appropriate range.
*
* Results:
* Returns the index'th Unicode character in the Object.
@@ -479,22 +475,21 @@ Tcl_GetCharLength(objPtr)
*/
Tcl_UniChar
-Tcl_GetUniChar(objPtr, index)
- Tcl_Obj *objPtr; /* The object to get the Unicode charater from. */
- int index; /* Get the index'th Unicode character. */
+Tcl_GetUniChar(
+ Tcl_Obj *objPtr, /* The object to get the Unicode charater
+ * from. */
+ int index) /* Get the index'th Unicode character. */
{
Tcl_UniChar unichar;
String *stringPtr;
-
+
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
if (stringPtr->numChars == -1) {
-
/*
- * We haven't yet calculated the length, so we don't have the
- * Unicode str. We need to know the number of chars before we
- * can do indexing.
+ * We haven't yet calculated the length, so we don't have the Unicode
+ * str. We need to know the number of chars before we can do indexing.
*/
Tcl_GetCharLength(objPtr);
@@ -503,15 +498,14 @@ Tcl_GetUniChar(objPtr, index)
* We need to fetch the pointer again because we may have just
* reallocated the structure.
*/
-
+
stringPtr = GET_STRING(objPtr);
}
if (stringPtr->hasUnicode == 0) {
-
/*
- * All of the characters in the Utf string are 1 byte chars,
- * so we don't store the unicode char. We get the Utf string
- * and convert the index'th byte to a Unicode character.
+ * All of the characters in the Utf string are 1 byte chars, so we
+ * don't store the unicode char. We get the Utf string and convert the
+ * index'th byte to a Unicode character.
*/
unichar = (Tcl_UniChar) objPtr->bytes[index];
@@ -526,10 +520,10 @@ Tcl_GetUniChar(objPtr, index)
*
* Tcl_GetUnicode --
*
- * Get the Unicode form of the String object. If
- * the object is not already a String object, it will be converted
- * to one. If the String object does not have a Unicode rep, then
- * one is create from the UTF string format.
+ * Get the Unicode form of the String object. If the object is not
+ * already a String object, it will be converted to one. If the String
+ * object does not have a Unicode rep, then one is create from the UTF
+ * string format.
*
* Results:
* Returns a pointer to the object's internal Unicode string.
@@ -541,31 +535,31 @@ Tcl_GetUniChar(objPtr, index)
*/
Tcl_UniChar *
-Tcl_GetUnicode(objPtr)
- Tcl_Obj *objPtr; /* The object to find the unicode string for. */
+Tcl_GetUnicode(
+ Tcl_Obj *objPtr) /* The object to find the unicode string
+ * for. */
{
String *stringPtr;
-
+
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
-
- if ((stringPtr->numChars == -1) || (stringPtr->hasUnicode == 0)) {
+ if ((stringPtr->numChars == -1) || (stringPtr->hasUnicode == 0)) {
/*
- * We haven't yet calculated the length, or all of the characters
- * in the Utf string are 1 byte chars (so we didn't store the
- * unicode str). Since this function must return a unicode string,
- * and one has not yet been stored, force the Unicode to be
- * calculated and stored now.
+ * We haven't yet calculated the length, or all of the characters in
+ * the Utf string are 1 byte chars (so we didn't store the unicode
+ * str). Since this function must return a unicode string, and one has
+ * not yet been stored, force the Unicode to be calculated and stored
+ * now.
*/
FillUnicodeRep(objPtr);
/*
- * We need to fetch the pointer again because we have just
- * reallocated the structure to make room for the Unicode data.
+ * We need to fetch the pointer again because we have just reallocated
+ * the structure to make room for the Unicode data.
*/
-
+
stringPtr = GET_STRING(objPtr);
}
return stringPtr->unicode;
@@ -576,10 +570,10 @@ Tcl_GetUnicode(objPtr)
*
* Tcl_GetUnicodeFromObj --
*
- * Get the Unicode form of the String object with length. If
- * the object is not already a String object, it will be converted
- * to one. If the String object does not have a Unicode rep, then
- * one is create from the UTF string format.
+ * Get the Unicode form of the String object with length. If the object
+ * is not already a String object, it will be converted to one. If the
+ * String object does not have a Unicode rep, then one is create from the
+ * UTF string format.
*
* Results:
* Returns a pointer to the object's internal Unicode string.
@@ -591,34 +585,34 @@ Tcl_GetUnicode(objPtr)
*/
Tcl_UniChar *
-Tcl_GetUnicodeFromObj(objPtr, lengthPtr)
- Tcl_Obj *objPtr; /* The object to find the unicode string for. */
- int *lengthPtr; /* If non-NULL, the location where the
- * string rep's unichar length should be
- * stored. If NULL, no length is stored. */
+Tcl_GetUnicodeFromObj(
+ Tcl_Obj *objPtr, /* The object to find the unicode string
+ * for. */
+ int *lengthPtr) /* If non-NULL, the location where the string
+ * rep's unichar length should be stored. If
+ * NULL, no length is stored. */
{
String *stringPtr;
-
+
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
-
- if ((stringPtr->numChars == -1) || (stringPtr->hasUnicode == 0)) {
+ if ((stringPtr->numChars == -1) || (stringPtr->hasUnicode == 0)) {
/*
- * We haven't yet calculated the length, or all of the characters
- * in the Utf string are 1 byte chars (so we didn't store the
- * unicode str). Since this function must return a unicode string,
- * and one has not yet been stored, force the Unicode to be
- * calculated and stored now.
+ * We haven't yet calculated the length, or all of the characters in
+ * the Utf string are 1 byte chars (so we didn't store the unicode
+ * str). Since this function must return a unicode string, and one has
+ * not yet been stored, force the Unicode to be calculated and stored
+ * now.
*/
FillUnicodeRep(objPtr);
/*
- * We need to fetch the pointer again because we have just
- * reallocated the structure to make room for the Unicode data.
+ * We need to fetch the pointer again because we have just reallocated
+ * the structure to make room for the Unicode data.
*/
-
+
stringPtr = GET_STRING(objPtr);
}
@@ -633,10 +627,10 @@ Tcl_GetUnicodeFromObj(objPtr, lengthPtr)
*
* Tcl_GetRange --
*
- * Create a Tcl Object that contains the chars between first and last
- * of the object indicated by "objPtr". If the object is not already
- * a String object, convert it to one. The first and last indices
- * are assumed to be in the appropriate range.
+ * Create a Tcl Object that contains the chars between first and last of
+ * the object indicated by "objPtr". If the object is not already a
+ * String object, convert it to one. The first and last indices are
+ * assumed to be in the appropriate range.
*
* Results:
* Returns a new Tcl Object of the String type.
@@ -648,23 +642,21 @@ Tcl_GetUnicodeFromObj(objPtr, lengthPtr)
*/
Tcl_Obj *
-Tcl_GetRange(objPtr, first, last)
- Tcl_Obj *objPtr; /* The Tcl object to find the range of. */
- int first; /* First index of the range. */
- int last; /* Last index of the range. */
+Tcl_GetRange(
+ Tcl_Obj *objPtr, /* The Tcl object to find the range of. */
+ int first, /* First index of the range. */
+ int last) /* Last index of the range. */
{
Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */
String *stringPtr;
-
+
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
if (stringPtr->numChars == -1) {
-
/*
- * We haven't yet calculated the length, so we don't have the
- * Unicode str. We need to know the number of chars before we
- * can do indexing.
+ * We haven't yet calculated the length, so we don't have the Unicode
+ * str. We need to know the number of chars before we can do indexing.
*/
Tcl_GetCharLength(objPtr);
@@ -673,26 +665,26 @@ Tcl_GetRange(objPtr, first, last)
* We need to fetch the pointer again because we may have just
* reallocated the structure.
*/
-
+
stringPtr = GET_STRING(objPtr);
}
- if (objPtr->bytes && stringPtr->numChars == objPtr->length) {
- char *str = Tcl_GetString(objPtr);
+ if (objPtr->bytes && (stringPtr->numChars == objPtr->length)) {
+ char *str = TclGetString(objPtr);
/*
- * All of the characters in the Utf string are 1 byte chars,
- * so we don't store the unicode char. Create a new string
- * object containing the specified range of chars.
+ * All of the characters in the Utf string are 1 byte chars, so we
+ * don't store the unicode char. Create a new string object containing
+ * the specified range of chars.
*/
-
+
newObjPtr = Tcl_NewStringObj(&str[first], last-first+1);
/*
- * Since we know the new string only has 1-byte chars, we
- * can set it's numChars field.
+ * Since we know the new string only has 1-byte chars, we can set it's
+ * numChars field.
*/
-
+
SetStringFromAny(NULL, newObjPtr);
stringPtr = GET_STRING(newObjPtr);
stringPtr->numChars = last-first+1;
@@ -709,49 +701,44 @@ Tcl_GetRange(objPtr, first, last)
* Tcl_SetStringObj --
*
* Modify an object to hold a string that is a copy of the bytes
- * indicated by the byte pointer and length arguments.
+ * indicated by the byte pointer and length arguments.
*
* Results:
* None.
*
* Side effects:
- * The object's string representation will be set to a copy of
- * the "length" bytes starting at "bytes". If "length" is negative, use
- * bytes up to the first NULL byte; i.e., assume "bytes" points to a
- * C-style NULL-terminated string. The object's old string and internal
+ * The object's string representation will be set to a copy of the
+ * "length" bytes starting at "bytes". If "length" is negative, use bytes
+ * up to the first NUL byte; i.e., assume "bytes" points to a C-style
+ * NUL-terminated string. The object's old string and internal
* representations are freed and the object's type is set NULL.
*
*----------------------------------------------------------------------
*/
void
-Tcl_SetStringObj(objPtr, bytes, length)
- register Tcl_Obj *objPtr; /* Object whose internal rep to init. */
- CONST char *bytes; /* Points to the first of the length bytes
+Tcl_SetStringObj(
+ register Tcl_Obj *objPtr, /* Object whose internal rep to init. */
+ const char *bytes, /* Points to the first of the length bytes
* used to initialize the object. */
- register int length; /* The number of bytes to copy from "bytes"
- * when initializing the object. If
- * negative, use bytes up to the first
- * NULL byte.*/
+ register int length) /* The number of bytes to copy from "bytes"
+ * when initializing the object. If negative,
+ * use bytes up to the first NUL byte.*/
{
- register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
-
if (Tcl_IsShared(objPtr)) {
- panic("Tcl_SetStringObj called with shared object");
+ Tcl_Panic("%s called with shared object", "Tcl_SetStringObj");
}
/*
* Set the type to NULL and free any internal rep for the old type.
*/
- if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
- oldTypePtr->freeIntRepProc(objPtr);
- }
+ TclFreeIntRep(objPtr);
objPtr->typePtr = NULL;
/*
- * Free any old string rep, then set the string rep to a copy of
- * the length bytes starting at "bytes".
+ * Free any old string rep, then set the string rep to a copy of the
+ * length bytes starting at "bytes".
*/
Tcl_InvalidateStringRep(objPtr);
@@ -766,30 +753,29 @@ Tcl_SetStringObj(objPtr, bytes, length)
*
* Tcl_SetObjLength --
*
- * This procedure changes the length of the string representation
- * of an object.
+ * This function changes the length of the string representation of an
+ * object.
*
* Results:
* None.
*
* Side effects:
- * If the size of objPtr's string representation is greater than
- * length, then it is reduced to length and a new terminating null
- * byte is stored in the strength. If the length of the string
- * representation is greater than length, the storage space is
- * reallocated to the given length; a null byte is stored at the
- * end, but other bytes past the end of the original string
- * representation are undefined. The object's internal
+ * If the size of objPtr's string representation is greater than length,
+ * then it is reduced to length and a new terminating null byte is stored
+ * in the strength. If the length of the string representation is greater
+ * than length, the storage space is reallocated to the given length; a
+ * null byte is stored at the end, but other bytes past the end of the
+ * original string representation are undefined. The object's internal
* representation is changed to "expendable string".
*
*----------------------------------------------------------------------
*/
void
-Tcl_SetObjLength(objPtr, length)
- register Tcl_Obj *objPtr; /* Pointer to object. This object must
- * not currently be shared. */
- register int length; /* Number of bytes desired for string
+Tcl_SetObjLength(
+ register Tcl_Obj *objPtr, /* Pointer to object. This object must not
+ * currently be shared. */
+ register int length) /* Number of bytes desired for string
* representation of object, not including
* terminating null byte. */
{
@@ -804,64 +790,83 @@ Tcl_SetObjLength(objPtr, length)
"%d (integer overflow?)", length);
}
if (Tcl_IsShared(objPtr)) {
- panic("Tcl_SetObjLength called with shared object");
+ Tcl_Panic("%s called with shared object", "Tcl_SetObjLength");
}
SetStringFromAny(NULL, objPtr);
-
+
stringPtr = GET_STRING(objPtr);
-
- /* Check that we're not extending a pure unicode string */
-
- if ((size_t)length > stringPtr->allocated &&
- (objPtr->bytes != NULL || stringPtr->hasUnicode == 0)) {
- char *new;
+ /*
+ * Check that we're not extending a pure unicode string.
+ */
+
+ if ((size_t)length > stringPtr->allocated &&
+ (objPtr->bytes != NULL || stringPtr->hasUnicode == 0)) {
/*
- * Not enough space in current string. Reallocate the string
- * space and free the old string.
+ * Not enough space in current string. Reallocate the string space and
+ * free the old string.
*/
- if (objPtr->bytes != tclEmptyStringRep && objPtr->bytes != NULL) {
- new = (char *) ckrealloc((char *)objPtr->bytes,
- (unsigned)(length+1));
+
+ if (objPtr->bytes != tclEmptyStringRep) {
+ objPtr->bytes = ckrealloc((char *) objPtr->bytes,
+ (unsigned) (length + 1));
} else {
- new = (char *) ckalloc((unsigned) (length+1));
+ char *newBytes = ckalloc((unsigned) (length+1));
+
if (objPtr->bytes != NULL && objPtr->length != 0) {
- memcpy((VOID *) new, (VOID *) objPtr->bytes,
- (size_t) objPtr->length);
+ memcpy(newBytes, objPtr->bytes, (size_t) objPtr->length);
Tcl_InvalidateStringRep(objPtr);
}
+ objPtr->bytes = newBytes;
}
- objPtr->bytes = new;
stringPtr->allocated = length;
- /* Invalidate the unicode data. */
+
+ /*
+ * Invalidate the unicode data.
+ */
+
stringPtr->hasUnicode = 0;
}
-
+
if (objPtr->bytes != NULL) {
- objPtr->length = length;
- if (objPtr->bytes != tclEmptyStringRep) {
- /* Ensure the string is NULL-terminated */
- objPtr->bytes[length] = 0;
- }
- /* Invalidate the unicode data. */
- stringPtr->numChars = -1;
- stringPtr->hasUnicode = 0;
+ objPtr->length = length;
+ if (objPtr->bytes != tclEmptyStringRep) {
+ /*
+ * Ensure the string is NUL-terminated.
+ */
+
+ objPtr->bytes[length] = 0;
+ }
+
+ /*
+ * Invalidate the unicode data.
+ */
+
+ stringPtr->numChars = -1;
+ stringPtr->hasUnicode = 0;
} else {
- /* Changing length of pure unicode string */
- size_t uallocated = STRING_UALLOC(length);
+ /*
+ * Changing length of pure unicode string.
+ */
+
+ size_t uallocated = STRING_UALLOC(length);
stringCheckLimits(length);
- if (uallocated > stringPtr->uallocated) {
+ if (uallocated > stringPtr->uallocated) {
stringPtr = stringRealloc(stringPtr, length);
- SET_STRING(objPtr, stringPtr);
- stringPtr->uallocated = uallocated;
- }
- stringPtr->numChars = length;
- stringPtr->hasUnicode = (length > 0);
- /* Ensure the string is NULL-terminated */
- stringPtr->unicode[length] = 0;
- stringPtr->allocated = 0;
- objPtr->length = 0;
+ SET_STRING(objPtr, stringPtr);
+ stringPtr->uallocated = uallocated;
+ }
+ stringPtr->numChars = length;
+ stringPtr->hasUnicode = (length > 0);
+
+ /*
+ * Ensure the string is NUL-terminated.
+ */
+
+ stringPtr->unicode[length] = 0;
+ stringPtr->allocated = 0;
+ objPtr->length = 0;
}
}
@@ -870,30 +875,29 @@ Tcl_SetObjLength(objPtr, length)
*
* Tcl_AttemptSetObjLength --
*
- * This procedure changes the length of the string representation
- * of an object. It uses the attempt* (non-panic'ing) memory allocators.
+ * This function changes the length of the string representation of an
+ * object. It uses the attempt* (non-panic'ing) memory allocators.
*
* Results:
* 1 if the requested memory was allocated, 0 otherwise.
*
* Side effects:
- * If the size of objPtr's string representation is greater than
- * length, then it is reduced to length and a new terminating null
- * byte is stored in the strength. If the length of the string
- * representation is greater than length, the storage space is
- * reallocated to the given length; a null byte is stored at the
- * end, but other bytes past the end of the original string
- * representation are undefined. The object's internal
+ * If the size of objPtr's string representation is greater than length,
+ * then it is reduced to length and a new terminating null byte is stored
+ * in the strength. If the length of the string representation is greater
+ * than length, the storage space is reallocated to the given length; a
+ * null byte is stored at the end, but other bytes past the end of the
+ * original string representation are undefined. The object's internal
* representation is changed to "expendable string".
*
*----------------------------------------------------------------------
*/
int
-Tcl_AttemptSetObjLength(objPtr, length)
- register Tcl_Obj *objPtr; /* Pointer to object. This object must
- * not currently be shared. */
- register int length; /* Number of bytes desired for string
+Tcl_AttemptSetObjLength(
+ register Tcl_Obj *objPtr, /* Pointer to object. This object must not
+ * currently be shared. */
+ register int length) /* Number of bytes desired for string
* representation of object, not including
* terminating null byte. */
{
@@ -907,56 +911,72 @@ Tcl_AttemptSetObjLength(objPtr, length)
return 0;
}
if (Tcl_IsShared(objPtr)) {
- panic("Tcl_AttemptSetObjLength called with shared object");
+ Tcl_Panic("%s called with shared object", "Tcl_AttemptSetObjLength");
}
SetStringFromAny(NULL, objPtr);
-
+
stringPtr = GET_STRING(objPtr);
- /* Check that we're not extending a pure unicode string */
+ /*
+ * Check that we're not extending a pure unicode string.
+ */
- if (length > (int) stringPtr->allocated &&
+ if (length > (int) stringPtr->allocated &&
(objPtr->bytes != NULL || stringPtr->hasUnicode == 0)) {
- char *new;
+ char *newBytes;
/*
- * Not enough space in current string. Reallocate the string
- * space and free the old string.
+ * Not enough space in current string. Reallocate the string space and
+ * free the old string.
*/
- if (objPtr->bytes != tclEmptyStringRep && objPtr->bytes != NULL) {
- new = (char *) attemptckrealloc((char *)objPtr->bytes,
- (unsigned)(length+1));
- if (new == NULL) {
+
+ if (objPtr->bytes != tclEmptyStringRep) {
+ newBytes = attemptckrealloc(objPtr->bytes,
+ (unsigned)(length + 1));
+ if (newBytes == NULL) {
return 0;
}
} else {
- new = (char *) attemptckalloc((unsigned) (length+1));
- if (new == NULL) {
+ newBytes = attemptckalloc((unsigned) (length + 1));
+ if (newBytes == NULL) {
return 0;
}
if (objPtr->bytes != NULL && objPtr->length != 0) {
- memcpy((VOID *) new, (VOID *) objPtr->bytes,
- (size_t) objPtr->length);
- Tcl_InvalidateStringRep(objPtr);
+ memcpy(newBytes, objPtr->bytes, (size_t) objPtr->length);
+ Tcl_InvalidateStringRep(objPtr);
}
}
- objPtr->bytes = new;
+ objPtr->bytes = newBytes;
stringPtr->allocated = length;
- /* Invalidate the unicode data. */
+
+ /*
+ * Invalidate the unicode data.
+ */
+
stringPtr->hasUnicode = 0;
}
-
+
if (objPtr->bytes != NULL) {
objPtr->length = length;
if (objPtr->bytes != tclEmptyStringRep) {
- /* Ensure the string is NULL-terminated */
+ /*
+ * Ensure the string is NULL-terminated.
+ */
+
objPtr->bytes[length] = 0;
}
- /* Invalidate the unicode data. */
+
+ /*
+ * Invalidate the unicode data.
+ */
+
stringPtr->numChars = -1;
stringPtr->hasUnicode = 0;
} else {
- /* Changing length of pure unicode string */
+ /*
+ * Changing length of pure unicode string.
+ */
+
size_t uallocated = STRING_UALLOC(length);
if (length > STRING_MAXCHARS) {
return 0;
@@ -965,14 +985,18 @@ Tcl_AttemptSetObjLength(objPtr, length)
if (uallocated > stringPtr->uallocated) {
stringPtr = stringAttemptRealloc(stringPtr, length);
if (stringPtr == NULL) {
- return 0;
+ return 0;
}
SET_STRING(objPtr, stringPtr);
stringPtr->uallocated = uallocated;
}
stringPtr->numChars = length;
stringPtr->hasUnicode = (length > 0);
- /* Ensure the string is NULL-terminated */
+
+ /*
+ * Ensure the string is NUL-terminated.
+ */
+
stringPtr->unicode[length] = 0;
stringPtr->allocated = 0;
objPtr->length = 0;
@@ -997,21 +1021,17 @@ Tcl_AttemptSetObjLength(objPtr, length)
*/
void
-Tcl_SetUnicodeObj(objPtr, unicode, numChars)
- Tcl_Obj *objPtr; /* The object to set the string of. */
- CONST Tcl_UniChar *unicode; /* The unicode string used to initialize
- * the object. */
- int numChars; /* Number of characters in the unicode
+Tcl_SetUnicodeObj(
+ Tcl_Obj *objPtr, /* The object to set the string of. */
+ const Tcl_UniChar *unicode, /* The unicode string used to initialize the
+ * object. */
+ int numChars) /* Number of characters in the unicode
* string. */
{
- Tcl_ObjType *typePtr = objPtr->typePtr;
-
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetUnicodeObj");
}
- if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
- typePtr->freeIntRepProc(objPtr);
- }
+ TclFreeIntRep(objPtr);
SetUnicodeObj(objPtr, unicode, numChars);
}
@@ -1031,11 +1051,11 @@ UnicodeLength(
}
static void
-SetUnicodeObj(objPtr, unicode, numChars)
- Tcl_Obj *objPtr; /* The object to set the string of. */
- CONST Tcl_UniChar *unicode; /* The unicode string used to initialize
- * the object. */
- int numChars; /* Number of characters in the unicode
+SetUnicodeObj(
+ Tcl_Obj *objPtr, /* The object to set the string of. */
+ const Tcl_UniChar *unicode, /* The unicode string used to initialize the
+ * object. */
+ int numChars) /* Number of characters in the unicode
* string. */
{
String *stringPtr;
@@ -1048,7 +1068,7 @@ SetUnicodeObj(objPtr, unicode, numChars)
/*
* Allocate enough space for the String structure + Unicode string.
*/
-
+
stringCheckLimits(numChars);
uallocated = STRING_UALLOC(numChars);
stringPtr = (String *) ckalloc(STRING_SIZE(uallocated));
@@ -1057,7 +1077,7 @@ SetUnicodeObj(objPtr, unicode, numChars)
stringPtr->uallocated = uallocated;
stringPtr->hasUnicode = (numChars > 0);
stringPtr->allocated = 0;
- memcpy((VOID *) stringPtr->unicode, (VOID *) unicode, uallocated);
+ memcpy(stringPtr->unicode, unicode, uallocated);
stringPtr->unicode[numChars] = 0;
Tcl_InvalidateStringRep(objPtr);
@@ -1068,35 +1088,42 @@ SetUnicodeObj(objPtr, unicode, numChars)
/*
*----------------------------------------------------------------------
*
- * Tcl_AppendToObj --
+ * Tcl_AppendLimitedToObj --
*
- * This procedure appends a sequence of bytes to an object.
+ * This function appends a limited number of bytes from a sequence of
+ * bytes to an object, marking any limitation with an ellipsis.
*
* Results:
* None.
*
* Side effects:
- * The bytes at *bytes are appended to the string representation
- * of objPtr.
+ * The bytes at *bytes are appended to the string representation of
+ * objPtr.
*
*----------------------------------------------------------------------
*/
void
-Tcl_AppendToObj(objPtr, bytes, length)
- register Tcl_Obj *objPtr; /* Points to the object to append to. */
- CONST char *bytes; /* Points to the bytes to append to the
+Tcl_AppendLimitedToObj(
+ register Tcl_Obj *objPtr, /* Points to the object to append to. */
+ const char *bytes, /* Points to the bytes to append to the
* object. */
- register int length; /* The number of bytes to append from
- * "bytes". If < 0, then append all bytes
- * up to NULL byte. */
+ register int length, /* The number of bytes available to be
+ * appended from "bytes". If < 0, then all
+ * bytes up to a NUL byte are available. */
+ register int limit, /* The maximum number of bytes to append to
+ * the object. */
+ const char *ellipsis) /* Ellipsis marker string, appended to the
+ * object to indicate not all available bytes
+ * at "bytes" were appended. */
{
String *stringPtr;
+ int toCopy = 0;
if (Tcl_IsShared(objPtr)) {
- panic("Tcl_AppendToObj called with shared object");
+ Tcl_Panic("%s called with shared object", "Tcl_AppendLimitedToObj");
}
-
+
SetStringFromAny(NULL, objPtr);
if (length < 0) {
@@ -1106,29 +1133,76 @@ Tcl_AppendToObj(objPtr, bytes, length)
return;
}
+ if (length <= limit) {
+ toCopy = length;
+ } else {
+ if (ellipsis == NULL) {
+ ellipsis = "...";
+ }
+ toCopy = Tcl_UtfPrev(bytes+limit+1-strlen(ellipsis), bytes) - bytes;
+ }
+
/*
- * If objPtr has a valid Unicode rep, then append the Unicode
- * conversion of "bytes" to the objPtr's Unicode rep, otherwise
- * append "bytes" to objPtr's string rep.
+ * If objPtr has a valid Unicode rep, then append the Unicode conversion
+ * of "bytes" to the objPtr's Unicode rep, otherwise append "bytes" to
+ * objPtr's string rep.
*/
stringPtr = GET_STRING(objPtr);
if (stringPtr->hasUnicode != 0) {
- AppendUtfToUnicodeRep(objPtr, bytes, length);
+ AppendUtfToUnicodeRep(objPtr, bytes, toCopy);
+ } else {
+ AppendUtfToUtfRep(objPtr, bytes, toCopy);
+ }
- stringPtr = GET_STRING(objPtr);
+ if (length <= limit) {
+ return;
+ }
+
+ stringPtr = GET_STRING(objPtr);
+ if (stringPtr->hasUnicode != 0) {
+ AppendUtfToUnicodeRep(objPtr, ellipsis, -1);
} else {
- AppendUtfToUtfRep(objPtr, bytes, length);
+ AppendUtfToUtfRep(objPtr, ellipsis, -1);
}
}
/*
*----------------------------------------------------------------------
*
+ * Tcl_AppendToObj --
+ *
+ * This function appends a sequence of bytes to an object.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The bytes at *bytes are appended to the string representation of
+ * objPtr.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_AppendToObj(
+ register Tcl_Obj *objPtr, /* Points to the object to append to. */
+ const char *bytes, /* Points to the bytes to append to the
+ * object. */
+ register int length) /* The number of bytes to append from "bytes".
+ * If < 0, then append all bytes up to NUL
+ * byte. */
+{
+ Tcl_AppendLimitedToObj(objPtr, bytes, length, INT_MAX, NULL);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_AppendUnicodeToObj --
*
- * This procedure appends a Unicode string to an object in the
- * most efficient manner possible. Length must be >= 0.
+ * This function appends a Unicode string to an object in the most
+ * efficient manner possible. Length must be >= 0.
*
* Results:
* None.
@@ -1140,16 +1214,16 @@ Tcl_AppendToObj(objPtr, bytes, length)
*/
void
-Tcl_AppendUnicodeToObj(objPtr, unicode, length)
- register Tcl_Obj *objPtr; /* Points to the object to append to. */
- CONST Tcl_UniChar *unicode; /* The unicode string to append to the
- * object. */
- int length; /* Number of chars in "unicode". */
+Tcl_AppendUnicodeToObj(
+ register Tcl_Obj *objPtr, /* Points to the object to append to. */
+ const Tcl_UniChar *unicode, /* The unicode string to append to the
+ * object. */
+ int length) /* Number of chars in "unicode". */
{
String *stringPtr;
if (Tcl_IsShared(objPtr)) {
- panic("Tcl_AppendUnicodeToObj called with shared object");
+ Tcl_Panic("%s called with shared object", "Tcl_AppendUnicodeToObj");
}
if (length == 0) {
@@ -1160,9 +1234,9 @@ Tcl_AppendUnicodeToObj(objPtr, unicode, length)
stringPtr = GET_STRING(objPtr);
/*
- * If objPtr has a valid Unicode rep, then append the "unicode"
- * to the objPtr's Unicode rep, otherwise the UTF conversion of
- * "unicode" to objPtr's string rep.
+ * If objPtr has a valid Unicode rep, then append the "unicode" to the
+ * objPtr's Unicode rep, otherwise the UTF conversion of "unicode" to
+ * objPtr's string rep.
*/
if (stringPtr->hasUnicode != 0) {
@@ -1177,23 +1251,23 @@ Tcl_AppendUnicodeToObj(objPtr, unicode, length)
*
* Tcl_AppendObjToObj --
*
- * This procedure appends the string rep of one object to another.
+ * This function appends the string rep of one object to another.
* "objPtr" cannot be a shared object.
*
* Results:
* None.
*
* Side effects:
- * The string rep of appendObjPtr is appended to the string
+ * The string rep of appendObjPtr is appended to the string
* representation of objPtr.
*
*----------------------------------------------------------------------
*/
void
-Tcl_AppendObjToObj(objPtr, appendObjPtr)
- Tcl_Obj *objPtr; /* Points to the object to append to. */
- Tcl_Obj *appendObjPtr; /* Object to append. */
+Tcl_AppendObjToObj(
+ Tcl_Obj *objPtr, /* Points to the object to append to. */
+ Tcl_Obj *appendObjPtr) /* Object to append. */
{
String *stringPtr;
int length, numChars, allOneByteChars;
@@ -1202,25 +1276,22 @@ Tcl_AppendObjToObj(objPtr, appendObjPtr)
SetStringFromAny(NULL, objPtr);
/*
- * If objPtr has a valid Unicode rep, then get a Unicode string
- * from appendObjPtr and append it.
+ * If objPtr has a valid Unicode rep, then get a Unicode string from
+ * appendObjPtr and append it.
*/
stringPtr = GET_STRING(objPtr);
if (stringPtr->hasUnicode != 0) {
-
/*
* If appendObjPtr is not of the "String" type, don't convert it.
*/
if (appendObjPtr->typePtr == &tclStringType) {
stringPtr = GET_STRING(appendObjPtr);
- if ((stringPtr->numChars == -1)
- || (stringPtr->hasUnicode == 0)) {
-
+ if ((stringPtr->numChars == -1) || (stringPtr->hasUnicode == 0)) {
/*
- * If appendObjPtr is a string obj with no valid Unicode
- * rep, then fill its unicode rep.
+ * If appendObjPtr is a string obj with no valid Unicode rep,
+ * then fill its unicode rep.
*/
FillUnicodeRep(appendObjPtr);
@@ -1229,19 +1300,19 @@ Tcl_AppendObjToObj(objPtr, appendObjPtr)
AppendUnicodeToUnicodeRep(objPtr, stringPtr->unicode,
stringPtr->numChars);
} else {
- bytes = Tcl_GetStringFromObj(appendObjPtr, &length);
+ bytes = TclGetStringFromObj(appendObjPtr, &length);
AppendUtfToUnicodeRep(objPtr, bytes, length);
}
return;
}
/*
- * Append to objPtr's UTF string rep. If we know the number of
- * characters in both objects before appending, then set the combined
- * number of characters in the final (appended-to) object.
+ * Append to objPtr's UTF string rep. If we know the number of characters
+ * in both objects before appending, then set the combined number of
+ * characters in the final (appended-to) object.
*/
- bytes = Tcl_GetStringFromObj(appendObjPtr, &length);
+ bytes = TclGetStringFromObj(appendObjPtr, &length);
allOneByteChars = 0;
numChars = stringPtr->numChars;
@@ -1266,8 +1337,8 @@ Tcl_AppendObjToObj(objPtr, appendObjPtr)
*
* AppendUnicodeToUnicodeRep --
*
- * This procedure appends the contents of "unicode" to the Unicode
- * rep of "objPtr". objPtr must already have a valid Unicode rep.
+ * This function appends the contents of "unicode" to the Unicode rep of
+ * "objPtr". objPtr must already have a valid Unicode rep.
*
* Results:
* None.
@@ -1279,13 +1350,13 @@ Tcl_AppendObjToObj(objPtr, appendObjPtr)
*/
static void
-AppendUnicodeToUnicodeRep(objPtr, unicode, appendNumChars)
- Tcl_Obj *objPtr; /* Points to the object to append to. */
- CONST Tcl_UniChar *unicode; /* String to append. */
- int appendNumChars; /* Number of chars of "unicode" to append. */
+AppendUnicodeToUnicodeRep(
+ Tcl_Obj *objPtr, /* Points to the object to append to. */
+ const Tcl_UniChar *unicode, /* String to append. */
+ int appendNumChars) /* Number of chars of "unicode" to append. */
{
String *stringPtr;
- size_t numChars;
+ int numChars;
if (appendNumChars < 0) {
appendNumChars = UnicodeLength(unicode);
@@ -1298,11 +1369,11 @@ AppendUnicodeToUnicodeRep(objPtr, unicode, appendNumChars)
stringPtr = GET_STRING(objPtr);
/*
- * If not enough space has been allocated for the unicode rep,
- * reallocate the internal rep object with additional space. First
- * try to double the required allocation; if that fails, try a more
- * modest increase. See the "TCL STRING GROWTH ALGORITHM" comment at
- * the top of this file for an explanation of this growth algorithm.
+ * If not enough space has been allocated for the unicode rep, reallocate
+ * the internal rep object with additional space. First try to double the
+ * required allocation; if that fails, try a more modest increase. See the
+ * "TCL STRING GROWTH ALGORITHM" comment at the top of this file for an
+ * explanation of this growth algorithm.
*/
numChars = stringPtr->numChars + appendNumChars;
@@ -1315,11 +1386,11 @@ AppendUnicodeToUnicodeRep(objPtr, unicode, appendNumChars)
* due to the reallocs below.
*/
int offset = -1;
- if (unicode >= stringPtr->unicode && unicode <= stringPtr->unicode
+ if (unicode >= stringPtr->unicode && unicode <= stringPtr->unicode
+ 1 + stringPtr->uallocated / sizeof(Tcl_UniChar)) {
offset = unicode - stringPtr->unicode;
}
-
+
GrowUnicodeBuffer(objPtr, numChars);
stringPtr = GET_STRING(objPtr);
@@ -1334,7 +1405,7 @@ AppendUnicodeToUnicodeRep(objPtr, unicode, appendNumChars)
* trailing null.
*/
- memcpy((VOID*) (stringPtr->unicode + stringPtr->numChars), unicode,
+ memcpy(stringPtr->unicode + stringPtr->numChars, unicode,
appendNumChars * sizeof(Tcl_UniChar));
stringPtr->unicode[numChars] = 0;
stringPtr->numChars = numChars;
@@ -1348,8 +1419,8 @@ AppendUnicodeToUnicodeRep(objPtr, unicode, appendNumChars)
*
* AppendUnicodeToUtfRep --
*
- * This procedure converts the contents of "unicode" to UTF and
- * appends the UTF to the string rep of "objPtr".
+ * This function converts the contents of "unicode" to UTF and appends
+ * the UTF to the string rep of "objPtr".
*
* Results:
* None.
@@ -1361,14 +1432,14 @@ AppendUnicodeToUnicodeRep(objPtr, unicode, appendNumChars)
*/
static void
-AppendUnicodeToUtfRep(objPtr, unicode, numChars)
- Tcl_Obj *objPtr; /* Points to the object to append to. */
- CONST Tcl_UniChar *unicode; /* String to convert to UTF. */
- int numChars; /* Number of chars of "unicode" to convert. */
+AppendUnicodeToUtfRep(
+ Tcl_Obj *objPtr, /* Points to the object to append to. */
+ const Tcl_UniChar *unicode, /* String to convert to UTF. */
+ int numChars) /* Number of chars of "unicode" to convert. */
{
Tcl_DString dsPtr;
- CONST char *bytes;
-
+ const char *bytes;
+
if (numChars < 0) {
numChars = UnicodeLength(unicode);
}
@@ -1387,9 +1458,9 @@ AppendUnicodeToUtfRep(objPtr, unicode, numChars)
*
* AppendUtfToUnicodeRep --
*
- * This procedure converts the contents of "bytes" to Unicode and
- * appends the Unicode to the Unicode rep of "objPtr". objPtr must
- * already have a valid Unicode rep.
+ * This function converts the contents of "bytes" to Unicode and appends
+ * the Unicode to the Unicode rep of "objPtr". objPtr must already have a
+ * valid Unicode rep.
*
* Results:
* None.
@@ -1401,10 +1472,10 @@ AppendUnicodeToUtfRep(objPtr, unicode, numChars)
*/
static void
-AppendUtfToUnicodeRep(objPtr, bytes, numBytes)
- Tcl_Obj *objPtr; /* Points to the object to append to. */
- CONST char *bytes; /* String to convert to Unicode. */
- int numBytes; /* Number of bytes of "bytes" to convert. */
+AppendUtfToUnicodeRep(
+ Tcl_Obj *objPtr, /* Points to the object to append to. */
+ const char *bytes, /* String to convert to Unicode. */
+ int numBytes) /* Number of bytes of "bytes" to convert. */
{
Tcl_DString dsPtr;
int numChars;
@@ -1416,7 +1487,7 @@ AppendUtfToUnicodeRep(objPtr, bytes, numBytes)
if (numBytes == 0) {
return;
}
-
+
Tcl_DStringInit(&dsPtr);
numChars = Tcl_NumUtfChars(bytes, numBytes);
unicode = (Tcl_UniChar *)Tcl_UtfToUniCharDString(bytes, numBytes, &dsPtr);
@@ -1429,8 +1500,8 @@ AppendUtfToUnicodeRep(objPtr, bytes, numBytes)
*
* AppendUtfToUtfRep --
*
- * This procedure appends "numBytes" bytes of "bytes" to the UTF string
- * rep of "objPtr". objPtr must already have a valid String rep.
+ * This function appends "numBytes" bytes of "bytes" to the UTF string
+ * rep of "objPtr". objPtr must already have a valid String rep.
*
* Results:
* None.
@@ -1442,10 +1513,10 @@ AppendUtfToUnicodeRep(objPtr, bytes, numBytes)
*/
static void
-AppendUtfToUtfRep(objPtr, bytes, numBytes)
- Tcl_Obj *objPtr; /* Points to the object to append to. */
- CONST char *bytes; /* String to append. */
- int numBytes; /* Number of bytes of "bytes" to append. */
+AppendUtfToUtfRep(
+ Tcl_Obj *objPtr, /* Points to the object to append to. */
+ const char *bytes, /* String to append. */
+ int numBytes) /* Number of bytes of "bytes" to append. */
{
String *stringPtr;
int newLength, oldLength;
@@ -1470,7 +1541,7 @@ AppendUtfToUtfRep(objPtr, bytes, numBytes)
stringPtr = GET_STRING(objPtr);
if (newLength > (int) stringPtr->allocated) {
- /*
+ /*
* Protect against case where unicode points into the existing
* stringPtr->unicode array. Force it to follow any relocations
* due to the reallocs below.
@@ -1482,10 +1553,10 @@ AppendUtfToUtfRep(objPtr, bytes, numBytes)
}
/*
- * There isn't currently enough space in the string representation
- * so allocate additional space. First, try to double the length
- * required. If that fails, try a more modest allocation. See the
- * "TCL STRING GROWTH ALGORITHM" comment at the top of this file for an
+ * There isn't currently enough space in the string representation so
+ * allocate additional space. First, try to double the length
+ * required. If that fails, try a more modest allocation. See the "TCL
+ * STRING GROWTH ALGORITHM" comment at the top of this file for an
* explanation of this growth algorithm.
*/
@@ -1497,7 +1568,7 @@ AppendUtfToUtfRep(objPtr, bytes, numBytes)
unsigned int limit = INT_MAX - newLength;
unsigned int extra = numBytes + TCL_GROWTH_MIN_ALLOC;
int growth = (int) ((extra > limit) ? limit : extra);
-
+
Tcl_SetObjLength(objPtr, newLength + growth);
}
@@ -1510,12 +1581,11 @@ AppendUtfToUtfRep(objPtr, bytes, numBytes)
/*
* Invalidate the unicode data.
*/
-
+
stringPtr->numChars = -1;
stringPtr->hasUnicode = 0;
-
- memcpy((VOID *) (objPtr->bytes + oldLength), (VOID *) bytes,
- (size_t) numBytes);
+
+ memcpy(objPtr->bytes + oldLength, bytes, (size_t) numBytes);
objPtr->bytes[newLength] = 0;
objPtr->length = newLength;
}
@@ -1525,23 +1595,23 @@ AppendUtfToUtfRep(objPtr, bytes, numBytes)
*
* Tcl_AppendStringsToObjVA --
*
- * This procedure appends one or more null-terminated strings
- * to an object.
+ * This function appends one or more null-terminated strings to an
+ * object.
*
* Results:
* None.
*
* Side effects:
- * The contents of all the string arguments are appended to the
- * string representation of objPtr.
+ * The contents of all the string arguments are appended to the string
+ * representation of objPtr.
*
*----------------------------------------------------------------------
*/
void
-Tcl_AppendStringsToObjVA (objPtr, argList)
- Tcl_Obj *objPtr; /* Points to the object to append to. */
- va_list argList; /* Variable argument list. */
+Tcl_AppendStringsToObjVA(
+ Tcl_Obj *objPtr, /* Points to the object to append to. */
+ va_list argList) /* Variable argument list. */
{
#define STATIC_LIST_SIZE 16
String *stringPtr;
@@ -1553,7 +1623,7 @@ Tcl_AppendStringsToObjVA (objPtr, argList)
int nargs, i;
if (Tcl_IsShared(objPtr)) {
- panic("Tcl_AppendStringsToObj called with shared object");
+ Tcl_Panic("%s called with shared object", "Tcl_AppendStringsToObj");
}
SetStringFromAny(NULL, objPtr);
@@ -1566,10 +1636,10 @@ Tcl_AppendStringsToObjVA (objPtr, argList)
(void) Tcl_GetStringFromObj(objPtr, &oldLength);
/*
- * Figure out how much space is needed for all the strings, and
- * expand the string representation if it isn't big enough. If no
- * bytes would be appended, just return. Note that on some platforms
- * (notably OS/390) the argList is an array so we need to use memcpy.
+ * Figure out how much space is needed for all the strings, and expand the
+ * string representation if it isn't big enough. If no bytes would be
+ * appended, just return. Note that on some platforms (notably OS/390) the
+ * argList is an array so we need to use memcpy.
*/
nargs = 0;
@@ -1579,21 +1649,22 @@ Tcl_AppendStringsToObjVA (objPtr, argList)
if (string == NULL) {
break;
}
- if (nargs >= nargs_space) {
- /*
- * Expand the args buffer
- */
- nargs_space += STATIC_LIST_SIZE;
- if (args == static_list) {
- args = (void *)ckalloc(nargs_space * sizeof(char *));
- for (i = 0; i < nargs; ++i) {
- args[i] = static_list[i];
- }
- } else {
- args = (void *)ckrealloc((void *)args,
+ if (nargs >= nargs_space) {
+ /*
+ * Expand the args buffer.
+ */
+
+ nargs_space += STATIC_LIST_SIZE;
+ if (args == static_list) {
+ args = (void *) ckalloc(nargs_space * sizeof(char *));
+ for (i = 0; i < nargs; ++i) {
+ args[i] = static_list[i];
+ }
+ } else {
+ args = (void *) ckrealloc((void *) args,
nargs_space * sizeof(char *));
- }
- }
+ }
+ }
newLength += strlen(string);
args[nargs++] = string;
}
@@ -1603,17 +1674,16 @@ Tcl_AppendStringsToObjVA (objPtr, argList)
stringPtr = GET_STRING(objPtr);
if (oldLength + newLength > (int) stringPtr->allocated) {
-
/*
- * There isn't currently enough space in the string
- * representation, so allocate additional space. If the current
- * string representation isn't empty (i.e. it looks like we're
- * doing a series of appends) then try to allocate extra space to
- * accomodate future growth: first try to double the required memory;
- * if that fails, try a more modest allocation. See the "TCL STRING
- * GROWTH ALGORITHM" comment at the top of this file for an explanation
- * of this growth algorithm. Otherwise, if the current string
- * representation is empty, exactly enough memory is allocated.
+ * There isn't currently enough space in the string representation, so
+ * allocate additional space. If the current string representation
+ * isn't empty (i.e. it looks like we're doing a series of appends)
+ * then try to allocate extra space to accomodate future growth: first
+ * try to double the required memory; if that fails, try a more modest
+ * allocation. See the "TCL STRING GROWTH ALGORITHM" comment at the
+ * top of this file for an explanation of this growth algorithm.
+ * Otherwise, if the current string representation is empty, exactly
+ * enough memory is allocated.
*/
if (oldLength == 0) {
@@ -1622,20 +1692,20 @@ Tcl_AppendStringsToObjVA (objPtr, argList)
attemptLength = 2 * (oldLength + newLength);
if (Tcl_AttemptSetObjLength(objPtr, attemptLength) == 0) {
attemptLength = oldLength + (2 * newLength) +
- TCL_GROWTH_MIN_ALLOC;
+ TCL_GROWTH_MIN_ALLOC;
Tcl_SetObjLength(objPtr, attemptLength);
}
}
}
/*
- * Make a second pass through the arguments, appending all the
- * strings to the object.
+ * Make a second pass through the arguments, appending all the strings to
+ * the object.
*/
dst = objPtr->bytes + oldLength;
for (i = 0; i < nargs; ++i) {
- string = args[i];
+ string = args[i];
if (string == NULL) {
break;
}
@@ -1647,10 +1717,10 @@ Tcl_AppendStringsToObjVA (objPtr, argList)
}
/*
- * Add a null byte to terminate the string. However, be careful:
- * it's possible that the object is totally empty (if it was empty
- * originally and there was nothing to append). In this case dst is
- * NULL; just leave everything alone.
+ * Add a null byte to terminate the string. However, be careful: it's
+ * possible that the object is totally empty (if it was empty originally
+ * and there was nothing to append). In this case dst is NULL; just leave
+ * everything alone.
*/
if (dst != NULL) {
@@ -1658,14 +1728,13 @@ Tcl_AppendStringsToObjVA (objPtr, argList)
}
objPtr->length = oldLength + newLength;
- done:
+ done:
/*
- * If we had to allocate a buffer from the heap,
- * free it now.
+ * If we had to allocate a buffer from the heap, free it now.
*/
-
+
if (args != static_list) {
- ckfree((void *)args);
+ ckfree((void *) args);
}
#undef STATIC_LIST_SIZE
}
@@ -1675,37 +1744,1051 @@ Tcl_AppendStringsToObjVA (objPtr, argList)
*
* Tcl_AppendStringsToObj --
*
- * This procedure appends one or more null-terminated strings
- * to an object.
+ * This function appends one or more null-terminated strings to an
+ * object.
*
* Results:
* None.
*
* Side effects:
- * The contents of all the string arguments are appended to the
- * string representation of objPtr.
+ * The contents of all the string arguments are appended to the string
+ * representation of objPtr.
*
*----------------------------------------------------------------------
*/
void
-Tcl_AppendStringsToObj TCL_VARARGS_DEF(Tcl_Obj *,arg1)
+Tcl_AppendStringsToObj(
+ Tcl_Obj *objPtr,
+ ...)
{
- register Tcl_Obj *objPtr;
va_list argList;
- objPtr = TCL_VARARGS_START(Tcl_Obj *,arg1,argList);
+ va_start(argList, objPtr);
Tcl_AppendStringsToObjVA(objPtr, argList);
va_end(argList);
}
/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_AppendFormatToObj --
+ *
+ * This function appends a list of Tcl_Obj's to a Tcl_Obj according to
+ * the formatting instructions embedded in the format string. The
+ * formatting instructions are inspired by sprintf(). Returns TCL_OK when
+ * successful. If there's an error in the arguments, TCL_ERROR is
+ * returned, and an error message is written to the interp, if non-NULL.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_AppendFormatToObj(
+ Tcl_Interp *interp,
+ Tcl_Obj *appendObj,
+ const char *format,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ const char *span = format, *msg;
+ int numBytes = 0, objIndex = 0, gotXpg = 0, gotSequential = 0;
+ int originalLength, limit;
+ static const char *mixedXPG =
+ "cannot mix \"%\" and \"%n$\" conversion specifiers";
+ static const char *badIndex[2] = {
+ "not enough arguments for all format specifiers",
+ "\"%n$\" argument index out of range"
+ };
+ static const char *overflow = "max size for a Tcl value exceeded";
+
+ if (Tcl_IsShared(appendObj)) {
+ Tcl_Panic("%s called with shared object", "Tcl_AppendFormatToObj");
+ }
+ TclGetStringFromObj(appendObj, &originalLength);
+ limit = INT_MAX - originalLength;
+
+ /*
+ * Format string is NUL-terminated.
+ */
+
+ while (*format != '\0') {
+ char *end;
+ int gotMinus, gotHash, gotZero, gotSpace, gotPlus, sawFlag;
+ int width, gotPrecision, precision, useShort, useWide, useBig;
+ int newXpg, numChars, allocSegment = 0, segmentLimit, segmentNumBytes;
+ Tcl_Obj *segment;
+ Tcl_UniChar ch;
+ int step = Tcl_UtfToUniChar(format, &ch);
+
+ format += step;
+ if (ch != '%') {
+ numBytes += step;
+ continue;
+ }
+ if (numBytes) {
+ if (numBytes > limit) {
+ msg = overflow;
+ goto errorMsg;
+ }
+ Tcl_AppendToObj(appendObj, span, numBytes);
+ limit -= numBytes;
+ numBytes = 0;
+ }
+
+ /*
+ * Saw a % : process the format specifier.
+ *
+ * Step 0. Handle special case of escaped format marker (i.e., %%).
+ */
+
+ step = Tcl_UtfToUniChar(format, &ch);
+ if (ch == '%') {
+ span = format;
+ numBytes = step;
+ format += step;
+ continue;
+ }
+
+ /*
+ * Step 1. XPG3 position specifier
+ */
+
+ newXpg = 0;
+ if (isdigit(UCHAR(ch))) {
+ int position = strtoul(format, &end, 10);
+ if (*end == '$') {
+ newXpg = 1;
+ objIndex = position - 1;
+ format = end + 1;
+ step = Tcl_UtfToUniChar(format, &ch);
+ }
+ }
+ if (newXpg) {
+ if (gotSequential) {
+ msg = mixedXPG;
+ goto errorMsg;
+ }
+ gotXpg = 1;
+ } else {
+ if (gotXpg) {
+ msg = mixedXPG;
+ goto errorMsg;
+ }
+ gotSequential = 1;
+ }
+ if ((objIndex < 0) || (objIndex >= objc)) {
+ msg = badIndex[gotXpg];
+ goto errorMsg;
+ }
+
+ /*
+ * Step 2. Set of flags.
+ */
+
+ gotMinus = gotHash = gotZero = gotSpace = gotPlus = 0;
+ sawFlag = 1;
+ do {
+ switch (ch) {
+ case '-':
+ gotMinus = 1;
+ break;
+ case '#':
+ gotHash = 1;
+ break;
+ case '0':
+ gotZero = 1;
+ break;
+ case ' ':
+ gotSpace = 1;
+ break;
+ case '+':
+ gotPlus = 1;
+ break;
+ default:
+ sawFlag = 0;
+ }
+ if (sawFlag) {
+ format += step;
+ step = Tcl_UtfToUniChar(format, &ch);
+ }
+ } while (sawFlag);
+
+ /*
+ * Step 3. Minimum field width.
+ */
+
+ width = 0;
+ if (isdigit(UCHAR(ch))) {
+ width = strtoul(format, &end, 10);
+ format = end;
+ step = Tcl_UtfToUniChar(format, &ch);
+ } else if (ch == '*') {
+ if (objIndex >= objc - 1) {
+ msg = badIndex[gotXpg];
+ goto errorMsg;
+ }
+ if (TclGetIntFromObj(interp, objv[objIndex], &width) != TCL_OK) {
+ goto error;
+ }
+ if (width < 0) {
+ width = -width;
+ gotMinus = 1;
+ }
+ objIndex++;
+ format += step;
+ step = Tcl_UtfToUniChar(format, &ch);
+ }
+ if (width > limit) {
+ msg = overflow;
+ goto errorMsg;
+ }
+
+ /*
+ * Step 4. Precision.
+ */
+
+ gotPrecision = precision = 0;
+ if (ch == '.') {
+ gotPrecision = 1;
+ format += step;
+ step = Tcl_UtfToUniChar(format, &ch);
+ }
+ if (isdigit(UCHAR(ch))) {
+ precision = strtoul(format, &end, 10);
+ format = end;
+ step = Tcl_UtfToUniChar(format, &ch);
+ } else if (ch == '*') {
+ if (objIndex >= objc - 1) {
+ msg = badIndex[gotXpg];
+ goto errorMsg;
+ }
+ if (TclGetIntFromObj(interp, objv[objIndex], &precision)
+ != TCL_OK) {
+ goto error;
+ }
+
+ /*
+ * TODO: Check this truncation logic.
+ */
+
+ if (precision < 0) {
+ precision = 0;
+ }
+ objIndex++;
+ format += step;
+ step = Tcl_UtfToUniChar(format, &ch);
+ }
+
+ /*
+ * Step 5. Length modifier.
+ */
+
+ useShort = useWide = useBig = 0;
+ if (ch == 'h') {
+ useShort = 1;
+ format += step;
+ step = Tcl_UtfToUniChar(format, &ch);
+ } else if (ch == 'l') {
+ format += step;
+ step = Tcl_UtfToUniChar(format, &ch);
+ if (ch == 'l') {
+ useBig = 1;
+ format += step;
+ step = Tcl_UtfToUniChar(format, &ch);
+ } else {
+#ifndef TCL_WIDE_INT_IS_LONG
+ useWide = 1;
+#endif
+ }
+ }
+
+ format += step;
+ span = format;
+
+ /*
+ * Step 6. The actual conversion character.
+ */
+
+ segment = objv[objIndex];
+ numChars = -1;
+ if (ch == 'i') {
+ ch = 'd';
+ }
+ switch (ch) {
+ case '\0':
+ msg = "format string ended in middle of field specifier";
+ goto errorMsg;
+ case 's':
+ if (gotPrecision) {
+ numChars = Tcl_GetCharLength(segment);
+ if (precision < numChars) {
+ segment = Tcl_GetRange(segment, 0, precision - 1);
+ numChars = precision;
+ Tcl_IncrRefCount(segment);
+ allocSegment = 1;
+ }
+ }
+ break;
+ case 'c': {
+ char buf[TCL_UTF_MAX];
+ int code, length;
+
+ if (TclGetIntFromObj(interp, segment, &code) != TCL_OK) {
+ goto error;
+ }
+ length = Tcl_UniCharToUtf(code, buf);
+ segment = Tcl_NewStringObj(buf, length);
+ Tcl_IncrRefCount(segment);
+ allocSegment = 1;
+ break;
+ }
+
+ case 'u':
+ if (useBig) {
+ msg = "unsigned bignum format is invalid";
+ goto errorMsg;
+ }
+ case 'd':
+ case 'o':
+ case 'x':
+ case 'X': {
+ short int s = 0; /* Silence compiler warning; only defined and
+ * used when useShort is true. */
+ long l;
+ Tcl_WideInt w;
+ mp_int big;
+ int toAppend, isNegative = 0;
+
+ if (useBig) {
+ if (Tcl_GetBignumFromObj(interp, segment, &big) != TCL_OK) {
+ goto error;
+ }
+ isNegative = (mp_cmp_d(&big, 0) == MP_LT);
+ } else if (useWide) {
+ if (Tcl_GetWideIntFromObj(NULL, segment, &w) != TCL_OK) {
+ Tcl_Obj *objPtr;
+
+ if (Tcl_GetBignumFromObj(interp,segment,&big) != TCL_OK) {
+ goto error;
+ }
+ mp_mod_2d(&big, (int) CHAR_BIT*sizeof(Tcl_WideInt), &big);
+ objPtr = Tcl_NewBignumObj(&big);
+ Tcl_IncrRefCount(objPtr);
+ Tcl_GetWideIntFromObj(NULL, objPtr, &w);
+ Tcl_DecrRefCount(objPtr);
+ }
+ isNegative = (w < (Tcl_WideInt)0);
+ } else if (TclGetLongFromObj(NULL, segment, &l) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(NULL, segment, &w) != TCL_OK) {
+ Tcl_Obj *objPtr;
+
+ if (Tcl_GetBignumFromObj(interp,segment,&big) != TCL_OK) {
+ goto error;
+ }
+ mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big);
+ objPtr = Tcl_NewBignumObj(&big);
+ Tcl_IncrRefCount(objPtr);
+ TclGetLongFromObj(NULL, objPtr, &l);
+ Tcl_DecrRefCount(objPtr);
+ } else {
+ l = Tcl_WideAsLong(w);
+ }
+ if (useShort) {
+ s = (short int) l;
+ isNegative = (s < (short int)0);
+ } else {
+ isNegative = (l < (long)0);
+ }
+ } else if (useShort) {
+ s = (short int) l;
+ isNegative = (s < (short int)0);
+ } else {
+ isNegative = (l < (long)0);
+ }
+
+ segment = Tcl_NewObj();
+ allocSegment = 1;
+ segmentLimit = INT_MAX;
+ Tcl_IncrRefCount(segment);
+
+ if ((isNegative || gotPlus || gotSpace) && (useBig || (ch == 'd'))) {
+ Tcl_AppendToObj(segment, (isNegative ? "-" : gotPlus ? "+" : " "), 1);
+ segmentLimit -= 1;
+ }
+
+ if (gotHash) {
+ switch (ch) {
+ case 'o':
+ Tcl_AppendToObj(segment, "0", 1);
+ segmentLimit -= 1;
+ precision--;
+ break;
+ case 'x':
+ case 'X':
+ Tcl_AppendToObj(segment, "0x", 2);
+ segmentLimit -= 2;
+ break;
+ }
+ }
+
+ switch (ch) {
+ case 'd': {
+ int length;
+ Tcl_Obj *pure;
+ const char *bytes;
+
+ if (useShort) {
+ pure = Tcl_NewIntObj((int)(s));
+ } else if (useWide) {
+ pure = Tcl_NewWideIntObj(w);
+ } else if (useBig) {
+ pure = Tcl_NewBignumObj(&big);
+ } else {
+ pure = Tcl_NewLongObj(l);
+ }
+ Tcl_IncrRefCount(pure);
+ bytes = TclGetStringFromObj(pure, &length);
+
+ /*
+ * Already did the sign above.
+ */
+
+ if (*bytes == '-') {
+ length--;
+ bytes++;
+ }
+ toAppend = length;
+
+ /*
+ * Canonical decimal string reps for integers are composed
+ * entirely of one-byte encoded characters, so "length" is the
+ * number of chars.
+ */
+
+ if (gotPrecision) {
+ if (length < precision) {
+ segmentLimit -= (precision - length);
+ }
+ while (length < precision) {
+ Tcl_AppendToObj(segment, "0", 1);
+ length++;
+ }
+ gotZero = 0;
+ }
+ if (gotZero) {
+ length += Tcl_GetCharLength(segment);
+ if (length < width) {
+ segmentLimit -= (width - length);
+ }
+ while (length < width) {
+ Tcl_AppendToObj(segment, "0", 1);
+ length++;
+ }
+ }
+ if (toAppend > segmentLimit) {
+ msg = overflow;
+ goto errorMsg;
+ }
+ Tcl_AppendToObj(segment, bytes, toAppend);
+ Tcl_DecrRefCount(pure);
+ break;
+ }
+
+ case 'u':
+ case 'o':
+ case 'x':
+ case 'X': {
+ Tcl_WideUInt bits = (Tcl_WideUInt)0;
+ Tcl_WideInt numDigits = (Tcl_WideInt)0;
+ int length, numBits = 4, base = 16;
+ int index = 0, shift = 0;
+ Tcl_Obj *pure;
+ char *bytes;
+
+ if (ch == 'u') {
+ base = 10;
+ }
+ if (ch == 'o') {
+ base = 8;
+ numBits = 3;
+ }
+ if (useShort) {
+ unsigned short int us = (unsigned short int) s;
+
+ bits = (Tcl_WideUInt) us;
+ while (us) {
+ numDigits++;
+ us /= base;
+ }
+ } else if (useWide) {
+ Tcl_WideUInt uw = (Tcl_WideUInt) w;
+
+ bits = uw;
+ while (uw) {
+ numDigits++;
+ uw /= base;
+ }
+ } else if (useBig && big.used) {
+ int leftover = (big.used * DIGIT_BIT) % numBits;
+ mp_digit mask = (~(mp_digit)0) << (DIGIT_BIT-leftover);
+
+ numDigits = 1 +
+ (((Tcl_WideInt)big.used * DIGIT_BIT) / numBits);
+ while ((mask & big.dp[big.used-1]) == 0) {
+ numDigits--;
+ mask >>= numBits;
+ }
+ if (numDigits > INT_MAX) {
+ msg = overflow;
+ goto errorMsg;
+ }
+ } else if (!useBig) {
+ unsigned long int ul = (unsigned long int) l;
+
+ bits = (Tcl_WideUInt) ul;
+ while (ul) {
+ numDigits++;
+ ul /= base;
+ }
+ }
+
+ /*
+ * Need to be sure zero becomes "0", not "".
+ */
+
+ if ((numDigits == 0) && !((ch == 'o') && gotHash)) {
+ numDigits = 1;
+ }
+ pure = Tcl_NewObj();
+ Tcl_SetObjLength(pure, (int)numDigits);
+ bytes = TclGetString(pure);
+ toAppend = length = (int)numDigits;
+ while (numDigits--) {
+ int digitOffset;
+
+ if (useBig && big.used) {
+ if (index < big.used && (size_t) shift <
+ CHAR_BIT*sizeof(Tcl_WideUInt) - DIGIT_BIT) {
+ bits |= (((Tcl_WideUInt)big.dp[index++]) <<shift);
+ shift += DIGIT_BIT;
+ }
+ shift -= numBits;
+ }
+ digitOffset = (int) (bits % base);
+ if (digitOffset > 9) {
+ bytes[numDigits] = 'a' + digitOffset - 10;
+ } else {
+ bytes[numDigits] = '0' + digitOffset;
+ }
+ bits /= base;
+ }
+ if (useBig) {
+ mp_clear(&big);
+ }
+ if (gotPrecision) {
+ if (length < precision) {
+ segmentLimit -= (precision - length);
+ }
+ while (length < precision) {
+ Tcl_AppendToObj(segment, "0", 1);
+ length++;
+ }
+ gotZero = 0;
+ }
+ if (gotZero) {
+ length += Tcl_GetCharLength(segment);
+ if (length < width) {
+ segmentLimit -= (width - length);
+ }
+ while (length < width) {
+ Tcl_AppendToObj(segment, "0", 1);
+ length++;
+ }
+ }
+ if (toAppend > segmentLimit) {
+ msg = overflow;
+ goto errorMsg;
+ }
+ Tcl_AppendObjToObj(segment, pure);
+ Tcl_DecrRefCount(pure);
+ break;
+ }
+
+ }
+ break;
+ }
+
+ case 'e':
+ case 'E':
+ case 'f':
+ case 'g':
+ case 'G': {
+#define MAX_FLOAT_SIZE 320
+ char spec[2*TCL_INTEGER_SPACE + 9], *p = spec;
+ double d;
+ int length = MAX_FLOAT_SIZE;
+ char *bytes;
+
+ if (Tcl_GetDoubleFromObj(interp, segment, &d) != TCL_OK) {
+ /* TODO: Figure out ACCEPT_NAN here */
+ goto error;
+ }
+ *p++ = '%';
+ if (gotMinus) {
+ *p++ = '-';
+ }
+ if (gotHash) {
+ *p++ = '#';
+ }
+ if (gotZero) {
+ *p++ = '0';
+ }
+ if (gotSpace) {
+ *p++ = ' ';
+ }
+ if (gotPlus) {
+ *p++ = '+';
+ }
+ if (width) {
+ p += sprintf(p, "%d", width);
+ if (width > length) {
+ length = width;
+ }
+ }
+ if (gotPrecision) {
+ *p++ = '.';
+ p += sprintf(p, "%d", precision);
+ if (precision > INT_MAX - length) {
+ msg=overflow;
+ goto errorMsg;
+ }
+ length += precision;
+ }
+
+ /*
+ * Don't pass length modifiers!
+ */
+
+ *p++ = (char) ch;
+ *p = '\0';
+
+ segment = Tcl_NewObj();
+ allocSegment = 1;
+ if (!Tcl_AttemptSetObjLength(segment, length)) {
+ msg = overflow;
+ goto errorMsg;
+ }
+ bytes = TclGetString(segment);
+ if (!Tcl_AttemptSetObjLength(segment, sprintf(bytes, spec, d))) {
+ msg = overflow;
+ goto errorMsg;
+ }
+ break;
+ }
+ default:
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp,
+ Tcl_ObjPrintf("bad field specifier \"%c\"", ch));
+ }
+ goto error;
+ }
+
+ switch (ch) {
+ case 'E':
+ case 'G':
+ case 'X': {
+ Tcl_SetObjLength(segment, Tcl_UtfToUpper(TclGetString(segment)));
+ }
+ }
+
+ if (width > 0) {
+ if (numChars < 0) {
+ numChars = Tcl_GetCharLength(segment);
+ }
+ if (!gotMinus) {
+ if (numChars < width) {
+ limit -= (width - numChars);
+ }
+ while (numChars < width) {
+ Tcl_AppendToObj(appendObj, (gotZero ? "0" : " "), 1);
+ numChars++;
+ }
+ }
+ }
+
+ Tcl_GetStringFromObj(segment, &segmentNumBytes);
+ if (segmentNumBytes > limit) {
+ if (allocSegment) {
+ Tcl_DecrRefCount(segment);
+ }
+ msg = overflow;
+ goto errorMsg;
+ }
+ Tcl_AppendObjToObj(appendObj, segment);
+ limit -= segmentNumBytes;
+ if (allocSegment) {
+ Tcl_DecrRefCount(segment);
+ }
+ if (width > 0) {
+ if (numChars < width) {
+ limit -= (width - numChars);
+ }
+ while (numChars < width) {
+ Tcl_AppendToObj(appendObj, (gotZero ? "0" : " "), 1);
+ numChars++;
+ }
+ }
+
+ objIndex += gotSequential;
+ }
+ if (numBytes) {
+ if (numBytes > limit) {
+ msg = overflow;
+ goto errorMsg;
+ }
+ Tcl_AppendToObj(appendObj, span, numBytes);
+ limit -= numBytes;
+ numBytes = 0;
+ }
+
+ return TCL_OK;
+
+ errorMsg:
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1));
+ }
+ error:
+ Tcl_SetObjLength(appendObj, originalLength);
+ return TCL_ERROR;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_Format--
+ *
+ * Results:
+ * A refcount zero Tcl_Obj.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+Tcl_Format(
+ Tcl_Interp *interp,
+ const char *format,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ int result;
+ Tcl_Obj *objPtr = Tcl_NewObj();
+ result = Tcl_AppendFormatToObj(interp, objPtr, format, objc, objv);
+ if (result != TCL_OK) {
+ Tcl_DecrRefCount(objPtr);
+ return NULL;
+ }
+ return objPtr;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * AppendPrintfToObjVA --
+ *
+ * Results:
+ *
+ * Side effects:
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static void
+AppendPrintfToObjVA(
+ Tcl_Obj *objPtr,
+ const char *format,
+ va_list argList)
+{
+ int code, objc;
+ Tcl_Obj **objv, *list = Tcl_NewObj();
+ const char *p;
+ char *end;
+
+ p = format;
+ Tcl_IncrRefCount(list);
+ while (*p != '\0') {
+ int size = 0, seekingConversion = 1, gotPrecision = 0;
+ int lastNum = -1;
+
+ if (*p++ != '%') {
+ continue;
+ }
+ if (*p == '%') {
+ p++;
+ continue;
+ }
+ do {
+ switch (*p) {
+
+ case '\0':
+ seekingConversion = 0;
+ break;
+ case 's': {
+ const char *q, *end, *bytes = va_arg(argList, char *);
+ seekingConversion = 0;
+
+ /*
+ * The buffer to copy characters from starts at bytes and ends
+ * at either the first NUL byte, or after lastNum bytes, when
+ * caller has indicated a limit.
+ */
+
+ end = bytes;
+ while ((!gotPrecision || lastNum--) && (*end != '\0')) {
+ end++;
+ }
+
+ /*
+ * Within that buffer, we trim both ends if needed so that we
+ * copy only whole characters, and avoid copying any partial
+ * multi-byte characters.
+ */
+
+ q = Tcl_UtfPrev(end, bytes);
+ if (!Tcl_UtfCharComplete(q, (int)(end - q))) {
+ end = q;
+ }
+
+ q = bytes + TCL_UTF_MAX;
+ while ((bytes < end) && (bytes < q)
+ && ((*bytes & 0xC0) == 0x80)) {
+ bytes++;
+ }
+
+ Tcl_ListObjAppendElement(NULL, list,
+ Tcl_NewStringObj(bytes , (int)(end - bytes)));
+
+ break;
+ }
+ case 'c':
+ case 'i':
+ case 'u':
+ case 'd':
+ case 'o':
+ case 'x':
+ case 'X':
+ seekingConversion = 0;
+ switch (size) {
+ case -1:
+ case 0:
+ Tcl_ListObjAppendElement(NULL, list, Tcl_NewLongObj(
+ (long int)va_arg(argList, int)));
+ break;
+ case 1:
+ Tcl_ListObjAppendElement(NULL, list, Tcl_NewLongObj(
+ va_arg(argList, long int)));
+ break;
+ }
+ break;
+ case 'e':
+ case 'E':
+ case 'f':
+ case 'g':
+ case 'G':
+ Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj(
+ va_arg(argList, double)));
+ seekingConversion = 0;
+ break;
+ case '*':
+ lastNum = (int)va_arg(argList, int);
+ Tcl_ListObjAppendElement(NULL, list, Tcl_NewIntObj(lastNum));
+ p++;
+ break;
+ case '0': case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9':
+ lastNum = (int) strtoul(p, &end, 10);
+ p = end;
+ break;
+ case '.':
+ gotPrecision = 1;
+ p++;
+ break;
+ /* TODO: support for wide (and bignum?) arguments */
+ case 'l':
+ size = 1;
+ p++;
+ break;
+ case 'h':
+ size = -1;
+ default:
+ p++;
+ }
+ } while (seekingConversion);
+ }
+ TclListObjGetElements(NULL, list, &objc, &objv);
+ code = Tcl_AppendFormatToObj(NULL, objPtr, format, objc, objv);
+ if (code != TCL_OK) {
+ Tcl_AppendPrintfToObj(objPtr,
+ "Unable to format \"%s\" with supplied arguments: %s",
+ format, Tcl_GetString(list));
+ }
+ Tcl_DecrRefCount(list);
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_AppendPrintfToObj --
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+void
+Tcl_AppendPrintfToObj(
+ Tcl_Obj *objPtr,
+ const char *format,
+ ...)
+{
+ va_list argList;
+
+ va_start(argList, format);
+ AppendPrintfToObjVA(objPtr, format, argList);
+ va_end(argList);
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_ObjPrintf --
+ *
+ * Results:
+ * A refcount zero Tcl_Obj.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+Tcl_ObjPrintf(
+ const char *format,
+ ...)
+{
+ va_list argList;
+ Tcl_Obj *objPtr = Tcl_NewObj();
+
+ va_start(argList, format);
+ AppendPrintfToObjVA(objPtr, format, argList);
+ va_end(argList);
+ return objPtr;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclStringObjReverse --
+ *
+ * Implements the [string reverse] operation.
+ *
+ * Results:
+ * An unshared Tcl value which is the [string reverse] of the argument
+ * supplied. When sharing rules permit, the returned value might be
+ * the argument with modifications done in place.
+ *
+ * Side effects:
+ * May allocate a new Tcl_Obj.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclStringObjReverse(
+ Tcl_Obj *objPtr)
+{
+ String *stringPtr;
+ int numChars = Tcl_GetCharLength(objPtr);
+ int i = 0, lastCharIdx = numChars - 1;
+ char *bytes;
+
+ if (numChars <= 1) {
+ return objPtr;
+ }
+
+ stringPtr = GET_STRING(objPtr);
+ if (stringPtr->hasUnicode) {
+ Tcl_UniChar *source = stringPtr->unicode;
+
+ if (Tcl_IsShared(objPtr)) {
+ Tcl_UniChar *dest, ch = 0;
+
+ /*
+ * Create a non-empty, pure unicode value, so we can coax
+ * Tcl_SetObjLength into growing the unicode rep buffer.
+ */
+
+ Tcl_Obj *resultPtr = Tcl_NewUnicodeObj(&ch, 1);
+ Tcl_SetObjLength(resultPtr, numChars);
+ dest = Tcl_GetUnicode(resultPtr);
+
+ while (i < numChars) {
+ dest[i++] = source[lastCharIdx--];
+ }
+ return resultPtr;
+ }
+
+ while (i < lastCharIdx) {
+ Tcl_UniChar tmp = source[lastCharIdx];
+ source[lastCharIdx--] = source[i];
+ source[i++] = tmp;
+ }
+ Tcl_InvalidateStringRep(objPtr);
+ stringPtr->allocated = 0;
+ return objPtr;
+ }
+
+ bytes = TclGetString(objPtr);
+ if (Tcl_IsShared(objPtr)) {
+ char *dest;
+ Tcl_Obj *resultPtr = Tcl_NewObj();
+ Tcl_SetObjLength(resultPtr, numChars);
+ dest = TclGetString(resultPtr);
+ while (i < numChars) {
+ dest[i++] = bytes[lastCharIdx--];
+ }
+ return resultPtr;
+ }
+
+ while (i < lastCharIdx) {
+ char tmp = bytes[lastCharIdx];
+ bytes[lastCharIdx--] = bytes[i];
+ bytes[i++] = tmp;
+ }
+ return objPtr;
+}
+
+/*
*---------------------------------------------------------------------------
*
* FillUnicodeRep --
*
* Populate the Unicode internal rep with the Unicode form of its string
- * rep. The object must alread have a "String" internal rep.
+ * rep. The object must alread have a "String" internal rep.
*
* Results:
* None.
@@ -1717,15 +2800,15 @@ Tcl_AppendStringsToObj TCL_VARARGS_DEF(Tcl_Obj *,arg1)
*/
static void
-FillUnicodeRep(objPtr)
- Tcl_Obj *objPtr; /* The object in which to fill the unicode rep. */
+FillUnicodeRep(
+ Tcl_Obj *objPtr) /* The object in which to fill the unicode
+ * rep. */
{
String *stringPtr;
size_t uallocated;
- char *src, *srcEnd;
+ char *srcEnd, *src = objPtr->bytes;
Tcl_UniChar *dst;
- src = objPtr->bytes;
-
+
stringPtr = GET_STRING(objPtr);
if (stringPtr->numChars == -1) {
stringPtr->numChars = Tcl_NumUtfChars(src, objPtr->length);
@@ -1742,13 +2825,13 @@ FillUnicodeRep(objPtr)
/*
* Convert src to Unicode and store the coverted data in "unicode".
*/
-
+
srcEnd = src + objPtr->length;
for (dst = stringPtr->unicode; src < srcEnd; dst++) {
src += TclUtfToUniChar(src, dst);
}
*dst = 0;
-
+
SET_STRING(objPtr, stringPtr);
}
@@ -1757,8 +2840,8 @@ FillUnicodeRep(objPtr)
*
* DupStringInternalRep --
*
- * Initialize the internal representation of a new Tcl_Obj to a
- * copy of the internal representation of an existing string object.
+ * Initialize the internal representation of a new Tcl_Obj to a copy of
+ * the internal representation of an existing string object.
*
* Results:
* None.
@@ -1771,32 +2854,31 @@ FillUnicodeRep(objPtr)
*/
static void
-DupStringInternalRep(srcPtr, copyPtr)
- register Tcl_Obj *srcPtr; /* Object with internal rep to copy. Must
- * have an internal rep of type "String". */
- register Tcl_Obj *copyPtr; /* Object with internal rep to set. Must
- * not currently have an internal rep.*/
+DupStringInternalRep(
+ register Tcl_Obj *srcPtr, /* Object with internal rep to copy. Must have
+ * an internal rep of type "String". */
+ register Tcl_Obj *copyPtr) /* Object with internal rep to set. Must not
+ * currently have an internal rep.*/
{
String *srcStringPtr = GET_STRING(srcPtr);
String *copyStringPtr = NULL;
/*
- * If the src obj is a string of 1-byte Utf chars, then copy the
- * string rep of the source object and create an "empty" Unicode
- * internal rep for the new object. Otherwise, copy Unicode
- * internal rep, and invalidate the string rep of the new object.
+ * If the src obj is a string of 1-byte Utf chars, then copy the string
+ * rep of the source object and create an "empty" Unicode internal rep for
+ * the new object. Otherwise, copy Unicode internal rep, and invalidate
+ * the string rep of the new object.
*/
-
+
if (srcStringPtr->hasUnicode == 0) {
- copyStringPtr = (String *) ckalloc(sizeof(String));
+ copyStringPtr = (String *) ckalloc(sizeof(String));
copyStringPtr->uallocated = 0;
} else {
copyStringPtr = (String *) ckalloc(
- STRING_SIZE(srcStringPtr->uallocated));
+ STRING_SIZE(srcStringPtr->uallocated));
copyStringPtr->uallocated = srcStringPtr->uallocated;
- memcpy((VOID *) copyStringPtr->unicode,
- (VOID *) srcStringPtr->unicode,
+ memcpy(copyStringPtr->unicode, srcStringPtr->unicode,
(size_t) srcStringPtr->numChars * sizeof(Tcl_UniChar));
copyStringPtr->unicode[srcStringPtr->numChars] = 0;
}
@@ -1805,9 +2887,9 @@ DupStringInternalRep(srcPtr, copyPtr)
copyStringPtr->allocated = srcStringPtr->allocated;
/*
- * Tricky point: the string value was copied by generic object
- * management code, so it doesn't contain any extra bytes that
- * might exist in the source object.
+ * Tricky point: the string value was copied by generic object management
+ * code, so it doesn't contain any extra bytes that might exist in the
+ * source object.
*/
copyStringPtr->allocated = copyPtr->length;
@@ -1827,21 +2909,21 @@ DupStringInternalRep(srcPtr, copyPtr)
* This operation always succeeds and returns TCL_OK.
*
* Side effects:
- * Any old internal reputation for objPtr is freed and the
- * internal representation is set to "String".
+ * Any old internal reputation for objPtr is freed and the internal
+ * representation is set to "String".
*
*----------------------------------------------------------------------
*/
static int
-SetStringFromAny(interp, objPtr)
- Tcl_Interp *interp; /* Used for error reporting if not NULL. */
- register Tcl_Obj *objPtr; /* The object to convert. */
+SetStringFromAny(
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ register Tcl_Obj *objPtr) /* The object to convert. */
{
/*
- * The Unicode object is optimized for the case where each UTF char
- * in a string is only one byte. In this case, we store the value of
- * numChars, but we don't copy the bytes to the unicodeObj->unicode.
+ * The Unicode object is optimized for the case where each UTF char in a
+ * string is only one byte. In this case, we store the value of numChars,
+ * but we don't copy the bytes to the unicodeObj->unicode.
*/
if (objPtr->typePtr != &tclStringType) {
@@ -1851,9 +2933,7 @@ SetStringFromAny(interp, objPtr)
if (objPtr->bytes == NULL) {
objPtr->typePtr->updateStringProc(objPtr);
}
- if ((objPtr->typePtr->freeIntRepProc) != NULL) {
- (*objPtr->typePtr->freeIntRepProc)(objPtr);
- }
+ TclFreeIntRep(objPtr);
}
objPtr->typePtr = &tclStringType;
@@ -1867,10 +2947,10 @@ SetStringFromAny(interp, objPtr)
stringPtr->hasUnicode = 0;
if (objPtr->bytes != NULL) {
- stringPtr->allocated = objPtr->length;
- if (objPtr->bytes != tclEmptyStringRep) {
- objPtr->bytes[objPtr->length] = 0;
- }
+ stringPtr->allocated = objPtr->length;
+ if (objPtr->bytes != tclEmptyStringRep) {
+ objPtr->bytes[objPtr->length] = 0;
+ }
} else {
objPtr->length = 0;
}
@@ -1891,15 +2971,15 @@ SetStringFromAny(interp, objPtr)
* None.
*
* Side effects:
- * The object's string may be set by converting its Unicode
- * represention to UTF format.
+ * The object's string may be set by converting its Unicode represention
+ * to UTF format.
*
*----------------------------------------------------------------------
*/
static void
-UpdateStringOfString(objPtr)
- Tcl_Obj *objPtr; /* Object with string rep to update. */
+UpdateStringOfString(
+ Tcl_Obj *objPtr) /* Object with string rep to update. */
{
int i, size;
Tcl_UniChar *unicode;
@@ -1909,12 +2989,10 @@ UpdateStringOfString(objPtr)
stringPtr = GET_STRING(objPtr);
if ((objPtr->bytes == NULL) || (stringPtr->allocated == 0)) {
-
if (stringPtr->numChars <= 0) {
-
/*
- * If there is no Unicode rep, or the string has 0 chars,
- * then set the string rep to an empty string.
+ * If there is no Unicode rep, or the string has 0 chars, then set
+ * the string rep to an empty string.
*/
objPtr->bytes = tclEmptyStringRep;
@@ -1925,12 +3003,12 @@ UpdateStringOfString(objPtr)
unicode = stringPtr->unicode;
/*
- * Translate the Unicode string to UTF. "size" will hold the
- * amount of space the UTF string needs.
+ * Translate the Unicode string to UTF. "size" will hold the amount of
+ * space the UTF string needs.
*/
if (stringPtr->numChars <= INT_MAX/TCL_UTF_MAX
- && stringPtr->allocated >= (size_t) (stringPtr->numChars * TCL_UTF_MAX)) {
+ && stringPtr->allocated >= stringPtr->numChars * (size_t)TCL_UTF_MAX) {
goto copyBytes;
}
@@ -1961,21 +3039,30 @@ UpdateStringOfString(objPtr)
*
* FreeStringInternalRep --
*
- * Deallocate the storage associated with a String data object's
- * internal representation.
+ * Deallocate the storage associated with a String data object's internal
+ * representation.
*
* Results:
* None.
*
* Side effects:
- * Frees memory.
+ * Frees memory.
*
*----------------------------------------------------------------------
*/
static void
-FreeStringInternalRep(objPtr)
- Tcl_Obj *objPtr; /* Object with internal rep to free. */
+FreeStringInternalRep(
+ Tcl_Obj *objPtr) /* Object with internal rep to free. */
{
ckfree((char *) GET_STRING(objPtr));
+ objPtr->typePtr = NULL;
}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */