diff options
author | William Joye <wjoye@cfa.harvard.edu> | 2016-12-21 22:13:18 (GMT) |
---|---|---|
committer | William Joye <wjoye@cfa.harvard.edu> | 2016-12-21 22:13:18 (GMT) |
commit | 07e464099b99459d0a37757771791598ef3395d9 (patch) | |
tree | 4ba7d8aad13735e52f59bdce7ca5ba3151ebd7e3 /tcl8.6/generic/tclStringObj.c | |
parent | deb3650e37f26f651f280e480c4df3d7dde87bae (diff) | |
download | blt-07e464099b99459d0a37757771791598ef3395d9.zip blt-07e464099b99459d0a37757771791598ef3395d9.tar.gz blt-07e464099b99459d0a37757771791598ef3395d9.tar.bz2 |
new subtree for tcl/tk
Diffstat (limited to 'tcl8.6/generic/tclStringObj.c')
-rw-r--r-- | tcl8.6/generic/tclStringObj.c | 3128 |
1 files changed, 0 insertions, 3128 deletions
diff --git a/tcl8.6/generic/tclStringObj.c b/tcl8.6/generic/tclStringObj.c deleted file mode 100644 index 11a57e9..0000000 --- a/tcl8.6/generic/tclStringObj.c +++ /dev/null @@ -1,3128 +0,0 @@ -/* - * tclStringObj.c -- - * - * 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 - * 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. - * - * 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. - */ - -#include "tclInt.h" -#include "tommath.h" -#include "tclStringRep.h" - -/* - * Set COMPAT to 1 to restore the shimmering patterns to those of Tcl 8.5. - * This is an escape hatch in case the changes have some unexpected unwelcome - * impact on performance. If things go well, this mechanism can go away when - * post-8.6 development begins. - */ - -#define COMPAT 0 - -/* - * Prototypes for functions defined later in this file: - */ - -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 int ExtendStringRepWithUnicode(Tcl_Obj *objPtr, - const Tcl_UniChar *unicode, int numChars); -static void ExtendUnicodeRepWithString(Tcl_Obj *objPtr, - const char *bytes, int numBytes, - int numAppendChars); -static void FillUnicodeRep(Tcl_Obj *objPtr); -static void FreeStringInternalRep(Tcl_Obj *objPtr); -static void GrowStringBuffer(Tcl_Obj *objPtr, int needed, int flag); -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(const Tcl_UniChar *unicode); -static void UpdateStringOfString(Tcl_Obj *objPtr); - -/* - * The structure below defines the string Tcl object type by means of - * functions that can be invoked by generic object code. - */ - -const Tcl_ObjType tclStringType = { - "string", /* name */ - FreeStringInternalRep, /* freeIntRepPro */ - DupStringInternalRep, /* dupIntRepProc */ - UpdateStringOfString, /* updateStringProc */ - SetStringFromAny /* setFromAnyProc */ -}; - -/* - * TCL STRING GROWTH ALGORITHM - * - * When growing strings (during an append, for example), the following growth - * algorithm is used: - * - * Attempt to allocate 2 * (originalLength + appendLength) - * On failure: - * attempt to allocate originalLength + 2*appendLength + TCL_MIN_GROWTH - * - * 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 - * 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_MIN_GROWTH 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_MIN_GROWTH is a reasonable size, we can avoid that behavior. - * - * The growth algorithm can be tuned by adjusting the following parameters: - * - * TCL_MIN_GROWTH Additional space, in bytes, to allocate when - * the double allocation has failed. Default is - * 1024 (1 kilobyte). See tclInt.h. - */ - -#ifndef TCL_MIN_UNICHAR_GROWTH -#define TCL_MIN_UNICHAR_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_UniChar) -#endif - -static void -GrowStringBuffer( - Tcl_Obj *objPtr, - int needed, - int flag) -{ - /* - * Pre-conditions: - * objPtr->typePtr == &tclStringType - * needed > stringPtr->allocated - * flag || objPtr->bytes != NULL - */ - - String *stringPtr = GET_STRING(objPtr); - char *ptr = NULL; - int attempt; - - if (objPtr->bytes == tclEmptyStringRep) { - objPtr->bytes = NULL; - } - if (flag == 0 || stringPtr->allocated > 0) { - attempt = 2 * needed; - if (attempt >= 0) { - ptr = attemptckrealloc(objPtr->bytes, attempt + 1); - } - if (ptr == NULL) { - /* - * Take care computing the amount of modest growth to avoid - * overflow into invalid argument values for attempt. - */ - - unsigned int limit = INT_MAX - needed; - unsigned int extra = needed - objPtr->length + TCL_MIN_GROWTH; - int growth = (int) ((extra > limit) ? limit : extra); - - attempt = needed + growth; - ptr = attemptckrealloc(objPtr->bytes, attempt + 1); - } - } - if (ptr == NULL) { - /* - * First allocation - just big enough; or last chance fallback. - */ - - attempt = needed; - ptr = ckrealloc(objPtr->bytes, attempt + 1); - } - objPtr->bytes = ptr; - stringPtr->allocated = attempt; -} - -static void -GrowUnicodeBuffer( - Tcl_Obj *objPtr, - int needed) -{ - /* - * Pre-conditions: - * objPtr->typePtr == &tclStringType - * needed > stringPtr->maxChars - * needed < STRING_MAXCHARS - */ - - String *ptr = NULL, *stringPtr = GET_STRING(objPtr); - int attempt; - - if (stringPtr->maxChars > 0) { - /* - * Subsequent appends - apply the growth algorithm. - */ - - attempt = 2 * needed; - if (attempt >= 0 && attempt <= STRING_MAXCHARS) { - ptr = stringAttemptRealloc(stringPtr, attempt); - } - if (ptr == NULL) { - /* - * Take care computing the amount of modest growth to avoid - * overflow into invalid argument values for attempt. - */ - - unsigned int limit = STRING_MAXCHARS - needed; - unsigned int extra = needed - stringPtr->numChars - + TCL_MIN_UNICHAR_GROWTH; - int growth = (int) ((extra > limit) ? limit : extra); - - attempt = needed + growth; - ptr = stringAttemptRealloc(stringPtr, attempt); - } - } - if (ptr == NULL) { - /* - * First allocation - just big enough; or last chance fallback. - */ - - attempt = needed; - ptr = stringRealloc(stringPtr, attempt); - } - stringPtr = ptr; - stringPtr->maxChars = attempt; - SET_STRING(objPtr, stringPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_NewStringObj -- - * - * 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 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 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( - 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 NUL - * byte. */ -{ - return Tcl_DbNewStringObj(bytes, length, "unknown", 0); -} -#else /* if not TCL_MEM_DEBUG */ -Tcl_Obj * -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 NUL - * byte. */ -{ - Tcl_Obj *objPtr; - - if (length < 0) { - length = (bytes? strlen(bytes) : 0); - } - TclNewStringObj(objPtr, bytes, length); - return objPtr; -} -#endif /* TCL_MEM_DEBUG */ - -/* - *---------------------------------------------------------------------- - * - * Tcl_DbNewStringObj -- - * - * 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 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 - * reporting objects that haven't been freed. - * - * 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 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( - 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 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. */ -{ - Tcl_Obj *objPtr; - - if (length < 0) { - length = (bytes? strlen(bytes) : 0); - } - TclDbNewObj(objPtr, file, line); - TclInitStringRep(objPtr, bytes, length); - return objPtr; -} -#else /* if not TCL_MEM_DEBUG */ -Tcl_Obj * -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 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); -} -#endif /* TCL_MEM_DEBUG */ - -/* - *--------------------------------------------------------------------------- - * - * Tcl_NewUnicodeObj -- - * - * 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. - * - * Side effects: - * Memory allocated for new object and copy of Unicode argument. - * - *--------------------------------------------------------------------------- - */ - -Tcl_Obj * -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; - - TclNewObj(objPtr); - SetUnicodeObj(objPtr, unicode, numChars); - return objPtr; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetCharLength -- - * - * Get the length of the Unicode string from the Tcl object. - * - * Results: - * Pointer to unicode string representing the unicode object. - * - * Side effects: - * Frees old internal rep. Allocates memory for new "String" internal - * rep. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_GetCharLength( - Tcl_Obj *objPtr) /* The String object to get the num chars - * of. */ -{ - String *stringPtr; - int numChars; - - /* - * Optimize the case where we're really dealing with a bytearray object - * without string representation; we don't need to convert to a string to - * perform the get-length operation. - */ - - if (TclIsPureByteArray(objPtr)) { - int length; - - (void) Tcl_GetByteArrayFromObj(objPtr, &length); - return length; - } - - /* - * OK, need to work with the object as a string. - */ - - SetStringFromAny(NULL, objPtr); - stringPtr = GET_STRING(objPtr); - numChars = stringPtr->numChars; - - /* - * If numChars is unknown, compute it. - */ - - if (numChars == -1) { - TclNumUtfChars(numChars, objPtr->bytes, objPtr->length); - stringPtr->numChars = numChars; - -#if COMPAT - if (numChars < objPtr->length) { - /* - * Since we've just computed the number of chars, and not all UTF - * chars are 1-byte long, go ahead and populate the unicode - * string. - */ - - FillUnicodeRep(objPtr); - } -#endif - } - return numChars; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetUniChar -- - * - * 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. - * - * Side effects: - * Fills unichar with the index'th Unicode character. - * - *---------------------------------------------------------------------- - */ - -Tcl_UniChar -Tcl_GetUniChar( - Tcl_Obj *objPtr, /* The object to get the Unicode charater - * from. */ - int index) /* Get the index'th Unicode character. */ -{ - String *stringPtr; - - /* - * Optimize the case where we're really dealing with a bytearray object - * without string representation; we don't need to convert to a string to - * perform the indexing operation. - */ - - if (TclIsPureByteArray(objPtr)) { - unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, NULL); - - return (Tcl_UniChar) bytes[index]; - } - - /* - * OK, need to work with the object as a string. - */ - - SetStringFromAny(NULL, objPtr); - stringPtr = GET_STRING(objPtr); - - if (stringPtr->hasUnicode == 0) { - /* - * If numChars is unknown, compute it. - */ - - if (stringPtr->numChars == -1) { - TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length); - } - if (stringPtr->numChars == objPtr->length) { - return (Tcl_UniChar) objPtr->bytes[index]; - } - FillUnicodeRep(objPtr); - stringPtr = GET_STRING(objPtr); - } - return stringPtr->unicode[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. - * - * Results: - * Returns a pointer to the object's internal Unicode string. - * - * Side effects: - * Converts the object to have the String internal rep. - * - *---------------------------------------------------------------------- - */ - -Tcl_UniChar * -Tcl_GetUnicode( - Tcl_Obj *objPtr) /* The object to find the unicode string - * for. */ -{ - return Tcl_GetUnicodeFromObj(objPtr, NULL); -} - -/* - *---------------------------------------------------------------------- - * - * 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. - * - * Results: - * Returns a pointer to the object's internal Unicode string. - * - * Side effects: - * Converts the object to have the String internal rep. - * - *---------------------------------------------------------------------- - */ - -Tcl_UniChar * -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->hasUnicode == 0) { - FillUnicodeRep(objPtr); - stringPtr = GET_STRING(objPtr); - } - - if (lengthPtr != NULL) { - *lengthPtr = stringPtr->numChars; - } - return stringPtr->unicode; -} - -/* - *---------------------------------------------------------------------- - * - * 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. - * - * Results: - * Returns a new Tcl Object of the String type. - * - * Side effects: - * Changes the internal rep of "objPtr" to the String type. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -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; - - /* - * Optimize the case where we're really dealing with a bytearray object - * without string representation; we don't need to convert to a string to - * perform the substring operation. - */ - - if (TclIsPureByteArray(objPtr)) { - unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, NULL); - - return Tcl_NewByteArrayObj(bytes+first, last-first+1); - } - - /* - * OK, need to work with the object as a string. - */ - - SetStringFromAny(NULL, objPtr); - stringPtr = GET_STRING(objPtr); - - if (stringPtr->hasUnicode == 0) { - /* - * If numChars is unknown, compute it. - */ - - if (stringPtr->numChars == -1) { - TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length); - } - if (stringPtr->numChars == objPtr->length) { - newObjPtr = Tcl_NewStringObj(objPtr->bytes + first, last-first+1); - - /* - * Since we know the char length of the result, store it. - */ - - SetStringFromAny(NULL, newObjPtr); - stringPtr = GET_STRING(newObjPtr); - stringPtr->numChars = newObjPtr->length; - return newObjPtr; - } - FillUnicodeRep(objPtr); - stringPtr = GET_STRING(objPtr); - } - - return Tcl_NewUnicodeObj(stringPtr->unicode + first, last-first+1); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetStringObj -- - * - * Modify an object to hold a string that is a copy of the bytes - * 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 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( - 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. */ - int length) /* The number of bytes to copy from "bytes" - * when initializing the object. If negative, - * use bytes up to the first NUL byte.*/ -{ - if (Tcl_IsShared(objPtr)) { - Tcl_Panic("%s called with shared object", "Tcl_SetStringObj"); - } - - /* - * Set the type to NULL and free any internal rep for the old type. - */ - - TclFreeIntRep(objPtr); - - /* - * Free any old string rep, then set the string rep to a copy of the - * length bytes starting at "bytes". - */ - - TclInvalidateStringRep(objPtr); - if (length < 0) { - length = (bytes? strlen(bytes) : 0); - } - TclInitStringRep(objPtr, bytes, length); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetObjLength -- - * - * 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 - * representation is changed to "expendable string". - * - *---------------------------------------------------------------------- - */ - -void -Tcl_SetObjLength( - Tcl_Obj *objPtr, /* Pointer to object. This object must not - * currently be shared. */ - int length) /* Number of bytes desired for string - * representation of object, not including - * terminating null byte. */ -{ - String *stringPtr; - - if (length < 0) { - /* - * Setting to a negative length is nonsense. This is probably the - * result of overflowing the signed integer range. - */ - - Tcl_Panic("Tcl_SetObjLength: negative length requested: " - "%d (integer overflow?)", length); - } - if (Tcl_IsShared(objPtr)) { - Tcl_Panic("%s called with shared object", "Tcl_SetObjLength"); - } - - if (objPtr->bytes && objPtr->length == length) { - return; - } - - SetStringFromAny(NULL, objPtr); - stringPtr = GET_STRING(objPtr); - - if (objPtr->bytes != NULL) { - /* - * Change length of an existing string rep. - */ - if (length > stringPtr->allocated) { - /* - * Need to enlarge the buffer. - */ - if (objPtr->bytes == tclEmptyStringRep) { - objPtr->bytes = ckalloc(length + 1); - } else { - objPtr->bytes = ckrealloc(objPtr->bytes, length + 1); - } - stringPtr->allocated = length; - } - - objPtr->length = length; - objPtr->bytes[length] = 0; - - /* - * Invalidate the unicode data. - */ - - stringPtr->numChars = -1; - stringPtr->hasUnicode = 0; - } else { - /* - * Changing length of pure unicode string. - */ - - stringCheckLimits(length); - if (length > stringPtr->maxChars) { - stringPtr = stringRealloc(stringPtr, length); - SET_STRING(objPtr, stringPtr); - stringPtr->maxChars = length; - } - - /* - * Mark the new end of the unicode string - */ - - stringPtr->numChars = length; - stringPtr->unicode[length] = 0; - stringPtr->hasUnicode = 1; - - /* - * Can only get here when objPtr->bytes == NULL. No need to invalidate - * the string rep. - */ - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_AttemptSetObjLength -- - * - * 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 - * representation is changed to "expendable string". - * - *---------------------------------------------------------------------- - */ - -int -Tcl_AttemptSetObjLength( - Tcl_Obj *objPtr, /* Pointer to object. This object must not - * currently be shared. */ - int length) /* Number of bytes desired for string - * representation of object, not including - * terminating null byte. */ -{ - String *stringPtr; - - if (length < 0) { - /* - * Setting to a negative length is nonsense. This is probably the - * result of overflowing the signed integer range. - */ - - return 0; - } - if (Tcl_IsShared(objPtr)) { - Tcl_Panic("%s called with shared object", "Tcl_AttemptSetObjLength"); - } - if (objPtr->bytes && objPtr->length == length) { - return 1; - } - - SetStringFromAny(NULL, objPtr); - stringPtr = GET_STRING(objPtr); - - if (objPtr->bytes != NULL) { - /* - * Change length of an existing string rep. - */ - if (length > stringPtr->allocated) { - /* - * Need to enlarge the buffer. - */ - - char *newBytes; - - if (objPtr->bytes == tclEmptyStringRep) { - newBytes = attemptckalloc(length + 1); - } else { - newBytes = attemptckrealloc(objPtr->bytes, length + 1); - } - if (newBytes == NULL) { - return 0; - } - objPtr->bytes = newBytes; - stringPtr->allocated = length; - } - - objPtr->length = length; - objPtr->bytes[length] = 0; - - /* - * Invalidate the unicode data. - */ - - stringPtr->numChars = -1; - stringPtr->hasUnicode = 0; - } else { - /* - * Changing length of pure unicode string. - */ - - if (length > STRING_MAXCHARS) { - return 0; - } - if (length > stringPtr->maxChars) { - stringPtr = stringAttemptRealloc(stringPtr, length); - if (stringPtr == NULL) { - return 0; - } - SET_STRING(objPtr, stringPtr); - stringPtr->maxChars = length; - } - - /* - * Mark the new end of the unicode string. - */ - - stringPtr->unicode[length] = 0; - stringPtr->numChars = length; - stringPtr->hasUnicode = 1; - - /* - * Can only get here when objPtr->bytes == NULL. No need to invalidate - * the string rep. - */ - } - return 1; -} - -/* - *--------------------------------------------------------------------------- - * - * Tcl_SetUnicodeObj -- - * - * Modify an object to hold the Unicode string indicated by "unicode". - * - * Results: - * None. - * - * Side effects: - * Memory allocated for new "String" internal rep. - * - *--------------------------------------------------------------------------- - */ - -void -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. */ -{ - if (Tcl_IsShared(objPtr)) { - Tcl_Panic("%s called with shared object", "Tcl_SetUnicodeObj"); - } - TclFreeIntRep(objPtr); - SetUnicodeObj(objPtr, unicode, numChars); -} - -static int -UnicodeLength( - const Tcl_UniChar *unicode) -{ - int numChars = 0; - - if (unicode) { - while (numChars >= 0 && unicode[numChars] != 0) { - numChars++; - } - } - stringCheckLimits(numChars); - return numChars; -} - -static void -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; - - if (numChars < 0) { - numChars = UnicodeLength(unicode); - } - - /* - * Allocate enough space for the String structure + Unicode string. - */ - - stringCheckLimits(numChars); - stringPtr = stringAlloc(numChars); - SET_STRING(objPtr, stringPtr); - objPtr->typePtr = &tclStringType; - - stringPtr->maxChars = numChars; - memcpy(stringPtr->unicode, unicode, numChars * sizeof(Tcl_UniChar)); - stringPtr->unicode[numChars] = 0; - stringPtr->numChars = numChars; - stringPtr->hasUnicode = 1; - - TclInvalidateStringRep(objPtr); - stringPtr->allocated = 0; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_AppendLimitedToObj -- - * - * 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. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_AppendLimitedToObj( - Tcl_Obj *objPtr, /* Points to the object to append to. */ - const char *bytes, /* Points to the bytes to append to the - * object. */ - int length, /* The number of bytes available to be - * appended from "bytes". If < 0, then all - * bytes up to a NUL byte are available. */ - 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)) { - Tcl_Panic("%s called with shared object", "Tcl_AppendLimitedToObj"); - } - - if (length < 0) { - length = (bytes ? strlen(bytes) : 0); - } - if (length == 0) { - return; - } - - if (length <= limit) { - toCopy = length; - } else { - if (ellipsis == NULL) { - ellipsis = "..."; - } - toCopy = (bytes == NULL) ? limit - : 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. - */ - - SetStringFromAny(NULL, objPtr); - stringPtr = GET_STRING(objPtr); - - if (stringPtr->hasUnicode && stringPtr->numChars > 0) { - AppendUtfToUnicodeRep(objPtr, bytes, toCopy); - } else { - AppendUtfToUtfRep(objPtr, bytes, toCopy); - } - - if (length <= limit) { - return; - } - - stringPtr = GET_STRING(objPtr); - if (stringPtr->hasUnicode && stringPtr->numChars > 0) { - AppendUtfToUnicodeRep(objPtr, ellipsis, strlen(ellipsis)); - } else { - AppendUtfToUtfRep(objPtr, ellipsis, strlen(ellipsis)); - } -} - -/* - *---------------------------------------------------------------------- - * - * 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( - Tcl_Obj *objPtr, /* Points to the object to append to. */ - const char *bytes, /* Points to the bytes to append to the - * object. */ - 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 function appends a Unicode string to an object in the most - * efficient manner possible. Length must be >= 0. - * - * Results: - * None. - * - * Side effects: - * Invalidates the string rep and creates a new Unicode string. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_AppendUnicodeToObj( - 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)) { - Tcl_Panic("%s called with shared object", "Tcl_AppendUnicodeToObj"); - } - - if (length == 0) { - return; - } - - SetStringFromAny(NULL, objPtr); - 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 (stringPtr->hasUnicode -#if COMPAT - && stringPtr->numChars > 0 -#endif - ) { - AppendUnicodeToUnicodeRep(objPtr, unicode, length); - } else { - AppendUnicodeToUtfRep(objPtr, unicode, length); - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_AppendObjToObj -- - * - * 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 - * representation of objPtr. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_AppendObjToObj( - Tcl_Obj *objPtr, /* Points to the object to append to. */ - Tcl_Obj *appendObjPtr) /* Object to append. */ -{ - String *stringPtr; - int length, numChars, appendNumChars = -1; - const char *bytes; - - /* - * Special case: second object is standard-empty is fast case. We know - * that appending nothing to anything leaves that starting anything... - */ - - if (appendObjPtr->bytes == tclEmptyStringRep) { - return; - } - - /* - * Handle append of one bytearray object to another as a special case. - * Note that we only do this when the objects don't have string reps; if - * it did, then appending the byte arrays together could well lose - * information; this is a special-case optimization only. - */ - - if ((TclIsPureByteArray(objPtr) || objPtr->bytes == tclEmptyStringRep) - && TclIsPureByteArray(appendObjPtr)) { - - /* - * You might expect the code here to be - * - * bytes = Tcl_GetByteArrayFromObj(appendObjPtr, &length); - * TclAppendBytesToByteArray(objPtr, bytes, length); - * - * and essentially all of the time that would be fine. However, - * it would run into trouble in the case where objPtr and - * appendObjPtr point to the same thing. That may never be a - * good idea. It seems to violate Copy On Write, and we don't - * have any tests for the situation, since making any Tcl commands - * that call Tcl_AppendObjToObj() do that appears impossible - * (They honor Copy On Write!). For the sake of extensions that - * go off into that realm, though, here's a more complex approach - * that can handle all the cases. - */ - - /* Get lengths */ - int lengthSrc; - - (void) Tcl_GetByteArrayFromObj(objPtr, &length); - (void) Tcl_GetByteArrayFromObj(appendObjPtr, &lengthSrc); - - /* Grow buffer enough for the append */ - TclAppendBytesToByteArray(objPtr, NULL, lengthSrc); - - /* Reset objPtr back to the original value */ - Tcl_SetByteArrayLength(objPtr, length); - - /* - * Now do the append knowing that buffer growth cannot cause - * any trouble. - */ - - TclAppendBytesToByteArray(objPtr, - Tcl_GetByteArrayFromObj(appendObjPtr, NULL), lengthSrc); - return; - } - - /* - * Must append as strings. - */ - - SetStringFromAny(NULL, objPtr); - stringPtr = GET_STRING(objPtr); - - /* - * If objPtr has a valid Unicode rep, then get a Unicode string from - * appendObjPtr and append it. - */ - - if (stringPtr->hasUnicode -#if COMPAT - && stringPtr->numChars > 0 -#endif - ) { - /* - * If appendObjPtr is not of the "String" type, don't convert it. - */ - - if (appendObjPtr->typePtr == &tclStringType) { - Tcl_UniChar *unicode = - Tcl_GetUnicodeFromObj(appendObjPtr, &numChars); - - AppendUnicodeToUnicodeRep(objPtr, unicode, numChars); - } else { - 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. - */ - - bytes = TclGetStringFromObj(appendObjPtr, &length); - - numChars = stringPtr->numChars; - if ((numChars >= 0) && (appendObjPtr->typePtr == &tclStringType)) { - String *appendStringPtr = GET_STRING(appendObjPtr); - appendNumChars = appendStringPtr->numChars; - } - - AppendUtfToUtfRep(objPtr, bytes, length); - - if (numChars >= 0 && appendNumChars >= 0 -#if COMPAT - && appendNumChars == length -#endif - ) { - stringPtr->numChars = numChars + appendNumChars; - } -} - -/* - *---------------------------------------------------------------------- - * - * AppendUnicodeToUnicodeRep -- - * - * This function appends the contents of "unicode" to the Unicode rep of - * "objPtr". objPtr must already have a valid Unicode rep. - * - * Results: - * None. - * - * Side effects: - * objPtr's internal rep is reallocated. - * - *---------------------------------------------------------------------- - */ - -static void -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; - int numChars; - - if (appendNumChars < 0) { - appendNumChars = UnicodeLength(unicode); - } - if (appendNumChars == 0) { - return; - } - - SetStringFromAny(NULL, objPtr); - 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. - */ - - numChars = stringPtr->numChars + appendNumChars; - stringCheckLimits(numChars); - - if (numChars > stringPtr->maxChars) { - int offset = -1; - - /* - * Protect against case where unicode points into the existing - * stringPtr->unicode array. Force it to follow any relocations due to - * the reallocs below. - */ - - if (unicode && unicode >= stringPtr->unicode - && unicode <= stringPtr->unicode + stringPtr->maxChars) { - offset = unicode - stringPtr->unicode; - } - - GrowUnicodeBuffer(objPtr, numChars); - stringPtr = GET_STRING(objPtr); - - /* - * Relocate unicode if needed; see above. - */ - - if (offset >= 0) { - unicode = stringPtr->unicode + offset; - } - } - - /* - * Copy the new string onto the end of the old string, then add the - * trailing null. - */ - - if (unicode) { - memmove(stringPtr->unicode + stringPtr->numChars, unicode, - appendNumChars * sizeof(Tcl_UniChar)); - } - stringPtr->unicode[numChars] = 0; - stringPtr->numChars = numChars; - stringPtr->allocated = 0; - - TclInvalidateStringRep(objPtr); -} - -/* - *---------------------------------------------------------------------- - * - * AppendUnicodeToUtfRep -- - * - * This function converts the contents of "unicode" to UTF and appends - * the UTF to the string rep of "objPtr". - * - * Results: - * None. - * - * Side effects: - * objPtr's internal rep is reallocated. - * - *---------------------------------------------------------------------- - */ - -static void -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. */ -{ - String *stringPtr = GET_STRING(objPtr); - - numChars = ExtendStringRepWithUnicode(objPtr, unicode, numChars); - - if (stringPtr->numChars != -1) { - stringPtr->numChars += numChars; - } - -#if COMPAT - /* - * Invalidate the unicode rep. - */ - - stringPtr->hasUnicode = 0; -#endif -} - -/* - *---------------------------------------------------------------------- - * - * AppendUtfToUnicodeRep -- - * - * 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. numBytes must be non-negative. - * - * Results: - * None. - * - * Side effects: - * objPtr's internal rep is reallocated. - * - *---------------------------------------------------------------------- - */ - -static void -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. */ -{ - String *stringPtr; - - if (numBytes == 0) { - return; - } - - ExtendUnicodeRepWithString(objPtr, bytes, numBytes, -1); - TclInvalidateStringRep(objPtr); - stringPtr = GET_STRING(objPtr); - stringPtr->allocated = 0; -} - -/* - *---------------------------------------------------------------------- - * - * AppendUtfToUtfRep -- - * - * This function appends "numBytes" bytes of "bytes" to the UTF string - * rep of "objPtr". objPtr must already have a valid String rep. - * numBytes must be non-negative. - * - * Results: - * None. - * - * Side effects: - * objPtr's internal rep is reallocated. - * - *---------------------------------------------------------------------- - */ - -static void -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; - - if (numBytes == 0) { - return; - } - - /* - * Copy the new string onto the end of the old string, then add the - * trailing null. - */ - - if (objPtr->bytes == NULL) { - objPtr->length = 0; - } - oldLength = objPtr->length; - newLength = numBytes + oldLength; - if (newLength < 0) { - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); - } - - stringPtr = GET_STRING(objPtr); - if (newLength > stringPtr->allocated) { - int offset = -1; - - /* - * Protect against case where unicode points into the existing - * stringPtr->unicode array. Force it to follow any relocations due to - * the reallocs below. - */ - - if (bytes && bytes >= objPtr->bytes - && bytes <= objPtr->bytes + objPtr->length) { - offset = bytes - objPtr->bytes; - } - - /* - * TODO: consider passing flag=1: no overalloc on first append. This - * would make test stringObj-8.1 fail. - */ - - GrowStringBuffer(objPtr, newLength, 0); - - /* - * Relocate bytes if needed; see above. - */ - - if (offset >= 0) { - bytes = objPtr->bytes + offset; - } - } - - /* - * Invalidate the unicode data. - */ - - stringPtr->numChars = -1; - stringPtr->hasUnicode = 0; - - if (bytes) { - memmove(objPtr->bytes + oldLength, bytes, numBytes); - } - objPtr->bytes[newLength] = 0; - objPtr->length = newLength; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_AppendStringsToObjVA -- - * - * 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. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_AppendStringsToObjVA( - Tcl_Obj *objPtr, /* Points to the object to append to. */ - va_list argList) /* Variable argument list. */ -{ - if (Tcl_IsShared(objPtr)) { - Tcl_Panic("%s called with shared object", "Tcl_AppendStringsToObj"); - } - - while (1) { - const char *bytes = va_arg(argList, char *); - - if (bytes == NULL) { - break; - } - Tcl_AppendToObj(objPtr, bytes, -1); - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_AppendStringsToObj -- - * - * 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. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_AppendStringsToObj( - Tcl_Obj *objPtr, - ...) -{ - va_list 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, *errCode; - 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 *const 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; - errCode = "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; - errCode = "MIXEDSPECTYPES"; - goto errorMsg; - } - gotXpg = 1; - } else { - if (gotXpg) { - msg = mixedXPG; - errCode = "MIXEDSPECTYPES"; - goto errorMsg; - } - gotSequential = 1; - } - if ((objIndex < 0) || (objIndex >= objc)) { - msg = badIndex[gotXpg]; - errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH"; - 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]; - errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH"; - 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; - errCode = "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]; - errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH"; - 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); -#ifndef TCL_WIDE_INT_IS_LONG - } else { - 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"; - errCode = "INCOMPLETE"; - 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"; - errCode = "BADUNSIGNED"; - goto errorMsg; - } - case 'd': - case 'o': - case 'x': - case 'X': - case 'b': { - short 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) l; - isNegative = (s < (short) 0); - } else { - isNegative = (l < (long) 0); - } - } else if (useShort) { - s = (short) l; - isNegative = (s < (short) 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; - case 'b': - Tcl_AppendToObj(segment, "0b", 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; - errCode = "OVERFLOW"; - goto errorMsg; - } - Tcl_AppendToObj(segment, bytes, toAppend); - Tcl_DecrRefCount(pure); - break; - } - - case 'u': - case 'o': - case 'x': - case 'X': - case 'b': { - Tcl_WideUInt bits = (Tcl_WideUInt) 0; - Tcl_WideInt numDigits = (Tcl_WideInt) 0; - int length, numBits = 4, base = 16, index = 0, shift = 0; - Tcl_Obj *pure; - char *bytes; - - if (ch == 'u') { - base = 10; - } else if (ch == 'o') { - base = 8; - numBits = 3; - } else if (ch == 'b') { - base = 2; - numBits = 1; - } - if (useShort) { - unsigned short us = (unsigned short) 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; - errCode = "OVERFLOW"; - goto errorMsg; - } - } else if (!useBig) { - unsigned long ul = (unsigned long) 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; - errCode = "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; - errCode = "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; - errCode = "OVERFLOW"; - goto errorMsg; - } - bytes = TclGetString(segment); - if (!Tcl_AttemptSetObjLength(segment, sprintf(bytes, spec, d))) { - msg = overflow; - errCode = "OVERFLOW"; - goto errorMsg; - } - break; - } - default: - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_ObjPrintf("bad field specifier \"%c\"", ch)); - Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADTYPE", NULL); - } - goto error; - } - - switch (ch) { - case 'E': - case 'G': - case 'X': { - Tcl_SetObjLength(segment, Tcl_UtfToUpper(TclGetString(segment))); - } - } - - if (width>0 && numChars<0) { - numChars = Tcl_GetCharLength(segment); - } - if (!gotMinus && width>0) { - 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; - errCode = "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; - errCode = "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)); - Tcl_SetErrorCode(interp, "TCL", "FORMAT", errCode, NULL); - } - 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; - - 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) va_arg(argList, int))); - break; - case 1: - Tcl_ListObjAppendElement(NULL, list, Tcl_NewLongObj( - va_arg(argList, long))); - 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': { - char *end; - - 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; -} - -/* - *--------------------------------------------------------------------------- - * - * TclGetStringStorage -- - * - * Returns the string storage space of a Tcl_Obj. - * - * Results: - * The pointer value objPtr->bytes is returned and the number of bytes - * allocated there is written to *sizePtr (if known). - * - * Side effects: - * May set objPtr->bytes. - * - *--------------------------------------------------------------------------- - */ - -char * -TclGetStringStorage( - Tcl_Obj *objPtr, - unsigned int *sizePtr) -{ - String *stringPtr; - - if (objPtr->typePtr != &tclStringType || objPtr->bytes == NULL) { - return TclGetStringFromObj(objPtr, (int *)sizePtr); - } - - stringPtr = GET_STRING(objPtr); - *sizePtr = stringPtr->allocated; - return objPtr->bytes; -} -/* - *--------------------------------------------------------------------------- - * - * 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. - * - *--------------------------------------------------------------------------- - */ - -static void -ReverseBytes( - unsigned char *to, /* Copy bytes into here... */ - unsigned char *from, /* ...from here... */ - int count) /* Until this many are copied, */ - /* reversing as you go. */ -{ - unsigned char *src = from + count; - if (to == from) { - /* Reversing in place */ - while (--src > to) { - unsigned char c = *src; - *src = *to; - *to++ = c; - } - } else { - while (--src >= from) { - *to++ = *src; - } - } -} - -Tcl_Obj * -TclStringObjReverse( - Tcl_Obj *objPtr) -{ - String *stringPtr; - Tcl_UniChar ch; - - if (TclIsPureByteArray(objPtr)) { - int numBytes; - unsigned char *from = Tcl_GetByteArrayFromObj(objPtr, &numBytes); - - if (Tcl_IsShared(objPtr)) { - objPtr = Tcl_NewByteArrayObj(NULL, numBytes); - } - ReverseBytes(Tcl_GetByteArrayFromObj(objPtr, NULL), from, numBytes); - return objPtr; - } - - SetStringFromAny(NULL, objPtr); - stringPtr = GET_STRING(objPtr); - - if (stringPtr->hasUnicode) { - Tcl_UniChar *from = Tcl_GetUnicode(objPtr); - Tcl_UniChar *src = from + stringPtr->numChars; - - if (Tcl_IsShared(objPtr)) { - Tcl_UniChar *to; - - /* - * Create a non-empty, pure unicode value, so we can coax - * Tcl_SetObjLength into growing the unicode rep buffer. - */ - - ch = 0; - objPtr = Tcl_NewUnicodeObj(&ch, 1); - Tcl_SetObjLength(objPtr, stringPtr->numChars); - to = Tcl_GetUnicode(objPtr); - while (--src >= from) { - *to++ = *src; - } - } else { - /* Reversing in place */ - while (--src > from) { - ch = *src; - *src = *from; - *from++ = ch; - } - } - } - - if (objPtr->bytes) { - int numChars = stringPtr->numChars; - int numBytes = objPtr->length; - char *to, *from = objPtr->bytes; - - if (Tcl_IsShared(objPtr)) { - objPtr = Tcl_NewObj(); - Tcl_SetObjLength(objPtr, numBytes); - } - to = objPtr->bytes; - - if (numChars < numBytes) { - /* - * Either numChars == -1 and we don't know how many chars are - * represented by objPtr->bytes and we need Pass 1 just in case, - * or numChars >= 0 and we know we have fewer chars than bytes, - * so we know there's a multibyte character needing Pass 1. - * - * Pass 1. Reverse the bytes of each multi-byte character. - */ - int charCount = 0; - int bytesLeft = numBytes; - - while (bytesLeft) { - /* - * NOTE: We know that the from buffer is NUL-terminated. - * It's part of the contract for objPtr->bytes values. - * Thus, we can skip calling Tcl_UtfCharComplete() here. - */ - int bytesInChar = Tcl_UtfToUniChar(from, &ch); - - ReverseBytes((unsigned char *)to, (unsigned char *)from, - bytesInChar); - to += bytesInChar; - from += bytesInChar; - bytesLeft -= bytesInChar; - charCount++; - } - - from = to = objPtr->bytes; - stringPtr->numChars = charCount; - } - /* Pass 2. Reverse all the bytes. */ - ReverseBytes((unsigned char *)to, (unsigned char *)from, numBytes); - } - - 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. - * - * Results: - * None. - * - * Side effects: - * Reallocates the String internal rep. - * - *--------------------------------------------------------------------------- - */ - -static void -FillUnicodeRep( - Tcl_Obj *objPtr) /* The object in which to fill the unicode - * rep. */ -{ - String *stringPtr = GET_STRING(objPtr); - - ExtendUnicodeRepWithString(objPtr, objPtr->bytes, objPtr->length, - stringPtr->numChars); -} - -static void -ExtendUnicodeRepWithString( - Tcl_Obj *objPtr, - const char *bytes, - int numBytes, - int numAppendChars) -{ - String *stringPtr = GET_STRING(objPtr); - int needed, numOrigChars = 0; - Tcl_UniChar *dst; - - if (stringPtr->hasUnicode) { - numOrigChars = stringPtr->numChars; - } - if (numAppendChars == -1) { - TclNumUtfChars(numAppendChars, bytes, numBytes); - } - needed = numOrigChars + numAppendChars; - stringCheckLimits(needed); - - if (needed > stringPtr->maxChars) { - GrowUnicodeBuffer(objPtr, needed); - stringPtr = GET_STRING(objPtr); - } - - stringPtr->hasUnicode = 1; - if (bytes) { - stringPtr->numChars = needed; - } else { - numAppendChars = 0; - } - for (dst=stringPtr->unicode + numOrigChars; numAppendChars-- > 0; dst++) { - bytes += TclUtfToUniChar(bytes, dst); - } - *dst = 0; -} - -/* - *---------------------------------------------------------------------- - * - * DupStringInternalRep -- - * - * Initialize the internal representation of a new Tcl_Obj to a copy of - * the internal representation of an existing string object. - * - * Results: - * None. - * - * Side effects: - * copyPtr's internal rep is set to a copy of srcPtr's internal - * representation. - * - *---------------------------------------------------------------------- - */ - -static void -DupStringInternalRep( - Tcl_Obj *srcPtr, /* Object with internal rep to copy. Must have - * an internal rep of type "String". */ - 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 COMPAT==0 - if (srcStringPtr->numChars == -1) { - /* - * The String struct in the source value holds zero useful data. Don't - * bother copying it. Don't even bother allocating space in which to - * copy it. Just let the copy be untyped. - */ - - return; - } - - if (srcStringPtr->hasUnicode) { - int copyMaxChars; - - if (srcStringPtr->maxChars / 2 >= srcStringPtr->numChars) { - copyMaxChars = 2 * srcStringPtr->numChars; - } else { - copyMaxChars = srcStringPtr->maxChars; - } - copyStringPtr = stringAttemptAlloc(copyMaxChars); - if (copyStringPtr == NULL) { - copyMaxChars = srcStringPtr->numChars; - copyStringPtr = stringAlloc(copyMaxChars); - } - copyStringPtr->maxChars = copyMaxChars; - memcpy(copyStringPtr->unicode, srcStringPtr->unicode, - srcStringPtr->numChars * sizeof(Tcl_UniChar)); - copyStringPtr->unicode[srcStringPtr->numChars] = 0; - } else { - copyStringPtr = stringAlloc(0); - copyStringPtr->maxChars = 0; - copyStringPtr->unicode[0] = 0; - } - copyStringPtr->hasUnicode = srcStringPtr->hasUnicode; - copyStringPtr->numChars = srcStringPtr->numChars; - - /* - * 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->bytes ? copyPtr->length : 0; -#else /* COMPAT!=0 */ - /* - * 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 && srcStringPtr->numChars > 0) { - /* - * Copy the full allocation for the Unicode buffer. - */ - - copyStringPtr = stringAlloc(srcStringPtr->maxChars); - copyStringPtr->maxChars = srcStringPtr->maxChars; - memcpy(copyStringPtr->unicode, srcStringPtr->unicode, - srcStringPtr->numChars * sizeof(Tcl_UniChar)); - copyStringPtr->unicode[srcStringPtr->numChars] = 0; - copyStringPtr->allocated = 0; - } else { - copyStringPtr = stringAlloc(0); - copyStringPtr->unicode[0] = 0; - copyStringPtr->maxChars = 0; - - /* - * 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; - } - copyStringPtr->numChars = srcStringPtr->numChars; - copyStringPtr->hasUnicode = srcStringPtr->hasUnicode; -#endif /* COMPAT==0 */ - - SET_STRING(copyPtr, copyStringPtr); - copyPtr->typePtr = &tclStringType; -} - -/* - *---------------------------------------------------------------------- - * - * SetStringFromAny -- - * - * Create an internal representation of type "String" for an object. - * - * Results: - * 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". - * - *---------------------------------------------------------------------- - */ - -static int -SetStringFromAny( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr) /* The object to convert. */ -{ - if (objPtr->typePtr != &tclStringType) { - String *stringPtr = stringAlloc(0); - - /* - * Convert whatever we have into an untyped value. Just A String. - */ - - (void) TclGetString(objPtr); - TclFreeIntRep(objPtr); - - /* - * Create a basic String intrep that just points to the UTF-8 string - * already in place at objPtr->bytes. - */ - - stringPtr->numChars = -1; - stringPtr->allocated = objPtr->length; - stringPtr->maxChars = 0; - stringPtr->hasUnicode = 0; - SET_STRING(objPtr, stringPtr); - objPtr->typePtr = &tclStringType; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * UpdateStringOfString -- - * - * Update the string representation for an object whose internal - * representation is "String". - * - * Results: - * None. - * - * Side effects: - * The object's string may be set by converting its Unicode represention - * to UTF format. - * - *---------------------------------------------------------------------- - */ - -static void -UpdateStringOfString( - Tcl_Obj *objPtr) /* Object with string rep to update. */ -{ - String *stringPtr = GET_STRING(objPtr); - - if (stringPtr->numChars == 0) { - TclInitStringRep(objPtr, tclEmptyStringRep, 0); - } else { - (void) ExtendStringRepWithUnicode(objPtr, stringPtr->unicode, - stringPtr->numChars); - } -} - -static int -ExtendStringRepWithUnicode( - Tcl_Obj *objPtr, - const Tcl_UniChar *unicode, - int numChars) -{ - /* - * Pre-condition: this is the "string" Tcl_ObjType. - */ - - int i, origLength, size = 0; - char *dst, buf[TCL_UTF_MAX]; - String *stringPtr = GET_STRING(objPtr); - - if (numChars < 0) { - numChars = UnicodeLength(unicode); - } - - if (numChars == 0) { - return 0; - } - - if (objPtr->bytes == NULL) { - objPtr->length = 0; - } - size = origLength = objPtr->length; - - /* - * Quick cheap check in case we have more than enough room. - */ - - if (numChars <= (INT_MAX - size)/TCL_UTF_MAX - && stringPtr->allocated >= size + numChars * TCL_UTF_MAX) { - goto copyBytes; - } - - for (i = 0; i < numChars && size >= 0; i++) { - size += Tcl_UniCharToUtf((int) unicode[i], buf); - } - if (size < 0) { - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); - } - - /* - * Grow space if needed. - */ - - if (size > stringPtr->allocated) { - GrowStringBuffer(objPtr, size, 1); - } - - copyBytes: - dst = objPtr->bytes + origLength; - for (i = 0; i < numChars; i++) { - dst += Tcl_UniCharToUtf((int) unicode[i], dst); - } - *dst = '\0'; - objPtr->length = dst - objPtr->bytes; - return numChars; -} - -/* - *---------------------------------------------------------------------- - * - * FreeStringInternalRep -- - * - * Deallocate the storage associated with a String data object's internal - * representation. - * - * Results: - * None. - * - * Side effects: - * Frees memory. - * - *---------------------------------------------------------------------- - */ - -static void -FreeStringInternalRep( - Tcl_Obj *objPtr) /* Object with internal rep to free. */ -{ - ckfree(GET_STRING(objPtr)); - objPtr->typePtr = NULL; -} - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ |