riscv
/
OpenFPGA
mirror of https://github.com/lnis-uofu/OpenFPGA.git
1
0
Fork 0
Code Issues Projects Releases Wiki Activity
OpenFPGA/libs/EXTERNAL/tcl8.6.12/generic/tclUtil.c

4706 lines
126 KiB
C
Raw Normal View History

adding Tcl interface to vpr
2022-06-07 11:15:20 -05:00
/*
* tclUtil.c --
*
* This file contains utility functions that are used by many Tcl
* commands.
*
* Copyright (c) 1987-1993 The Regents of the University of California.
* Copyright (c) 1994-1998 Sun Microsystems, Inc.
* Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
*
* 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 "tclParse.h"
#include "tclStringTrim.h"
#include <math.h>
/*
* The absolute pathname of the executable in which this Tcl library is
* running.
*/
static ProcessGlobalValue executableName = {
0, 0, NULL, NULL, NULL, NULL, NULL
};
/*
* The following values are used in the flags arguments of Tcl*Scan*Element
* and Tcl*Convert*Element. The values TCL_DONT_USE_BRACES and
* TCL_DONT_QUOTE_HASH are defined in tcl.h, like so:
*
#define TCL_DONT_USE_BRACES 1
#define TCL_DONT_QUOTE_HASH 8
*
* Those are public flag bits which callers of the public routines
* Tcl_Convert*Element() can use to indicate:
*
* TCL_DONT_USE_BRACES - 1 means the caller is insisting that brace
* quoting not be used when converting the list
* element.
* TCL_DONT_QUOTE_HASH - 1 means the caller insists that a leading hash
* character ('#') should *not* be quoted. This
* is appropriate when the caller can guarantee
* the element is not the first element of a
* list, so [eval] cannot mis-parse the element
* as a comment.
*
* The remaining values which can be carried by the flags of these routines
* are for internal use only. Make sure they do not overlap with the public
* values above.
*
* The Tcl*Scan*Element() routines make a determination which of 4 modes of
* conversion is most appropriate for Tcl*Convert*Element() to perform, and
* sets two bits of the flags value to indicate the mode selected.
*
* CONVERT_NONE The element needs no quoting. Its literal string is
* suitable as is.
* CONVERT_BRACE The conversion should be enclosing the literal string
* in braces.
* CONVERT_ESCAPE The conversion should be using backslashes to escape
* any characters in the string that require it.
* CONVERT_MASK A mask value used to extract the conversion mode from
* the flags argument.
* Also indicates a strange conversion mode where all
* special characters are escaped with backslashes
* *except for braces*. This is a strange and unnecessary
* case, but it's part of the historical way in which
* lists have been formatted in Tcl. To experiment with
* removing this case, set the value of COMPAT to 0.
*
* One last flag value is used only by callers of TclScanElement(). The flag
* value produced by a call to Tcl*Scan*Element() will never leave this bit
* set.
*
* CONVERT_ANY The caller of TclScanElement() declares it can make no
* promise about what public flags will be passed to the
* matching call of TclConvertElement(). As such,
* TclScanElement() has to determine the worst case
* destination buffer length over all possibilities, and
* in other cases this means an overestimate of the
* required size.
*
* For more details, see the comments on the Tcl*Scan*Element and
* Tcl*Convert*Element routines.
*/
#define COMPAT 1
#define CONVERT_NONE 0
#define CONVERT_BRACE 2
#define CONVERT_ESCAPE 4
#define CONVERT_MASK (CONVERT_BRACE | CONVERT_ESCAPE)
#define CONVERT_ANY 16
/*
* The following key is used by Tcl_PrintDouble and TclPrecTraceProc to
* access the precision to be used for double formatting.
*/
static Tcl_ThreadDataKey precisionKey;
/*
* Prototypes for functions defined later in this file.
*/
static void ClearHash(Tcl_HashTable *tablePtr);
static void FreeProcessGlobalValue(ClientData clientData);
static void FreeThreadHash(ClientData clientData);
static int GetEndOffsetFromObj(Tcl_Obj *objPtr, int endValue,
int *indexPtr);
static Tcl_HashTable * GetThreadHash(Tcl_ThreadDataKey *keyPtr);
static int SetEndOffsetFromAny(Tcl_Interp *interp,
Tcl_Obj *objPtr);
static void UpdateStringOfEndOffset(Tcl_Obj *objPtr);
static int FindElement(Tcl_Interp *interp, const char *string,
int stringLength, const char *typeStr,
const char *typeCode, const char **elementPtr,
const char **nextPtr, int *sizePtr,
int *literalPtr);
/*
* The following is the Tcl object type definition for an object that
* represents a list index in the form, "end-offset". It is used as a
* performance optimization in TclGetIntForIndex. The internal rep is an
* integer, so no memory management is required for it.
*/
const Tcl_ObjType tclEndOffsetType = {
"end-offset", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
UpdateStringOfEndOffset, /* updateStringProc */
SetEndOffsetFromAny
};
/*
* * STRING REPRESENTATION OF LISTS * * *
*
* The next several routines implement the conversions of strings to and from
* Tcl lists. To understand their operation, the rules of parsing and
* generating the string representation of lists must be known. Here we
* describe them in one place.
*
* A list is made up of zero or more elements. Any string is a list if it is
* made up of alternating substrings of element-separating ASCII whitespace
* and properly formatted elements.
*
* The ASCII characters which can make up the whitespace between list elements
* are:
*
* \u0009 \t TAB
* \u000A \n NEWLINE
* \u000B \v VERTICAL TAB
* \u000C \f FORM FEED
* \u000D \r CARRIAGE RETURN
* \u0020 SPACE
*
* NOTE: differences between this and other places where Tcl defines a role
* for "whitespace".
*
* * Unlike command parsing, here NEWLINE is just another whitespace
* character; its role as a command terminator in a script has no
* importance here.
*
* * Unlike command parsing, the BACKSLASH NEWLINE sequence is not
* considered to be a whitespace character.
*
* * Other Unicode whitespace characters (recognized by [string is space]
* or Tcl_UniCharIsSpace()) do not play any role as element separators
* in Tcl lists.
*
* * The NUL byte ought not appear, as it is not in strings properly
* encoded for Tcl, but if it is present, it is not treated as
* separating whitespace, or a string terminator. It is just another
* character in a list element.
*
* The interpretation of a formatted substring as a list element follows rules
* similar to the parsing of the words of a command in a Tcl script. Backslash
* substitution plays a key role, and is defined exactly as it is in command
* parsing. The same routine, TclParseBackslash() is used in both command
* parsing and list parsing.
*
* NOTE: This means that if and when backslash substitution rules ever change
* for command parsing, the interpretation of strings as lists also changes.
*
* Backslash substitution replaces an "escape sequence" of one or more
* characters starting with
* \u005c \ BACKSLASH
* with a single character. The one character escape sequence case happens only
* when BACKSLASH is the last character in the string. In all other cases, the
* escape sequence is at least two characters long.
*
* The formatted substrings are interpreted as element values according to the
* following cases:
*
* * If the first character of a formatted substring is
* \u007b { OPEN BRACE
* then the end of the substring is the matching
* \u007d } CLOSE BRACE
* character, where matching is determined by counting nesting levels, and
* not including any brace characters that are contained within a backslash
* escape sequence in the nesting count. Having found the matching brace,
* all characters between the braces are the string value of the element.
* If no matching close brace is found before the end of the string, the
* string is not a Tcl list. If the character following the close brace is
* not an element separating whitespace character, or the end of the string,
* then the string is not a Tcl list.
*
* NOTE: this differs from a brace-quoted word in the parsing of a Tcl
* command only in its treatment of the backslash-newline sequence. In a
* list element, the literal characters in the backslash-newline sequence
* become part of the element value. In a script word, conversion to a
* single SPACE character is done.
*
* NOTE: Most list element values can be represented by a formatted
* substring using brace quoting. The exceptions are any element value that
* includes an unbalanced brace not in a backslash escape sequence, and any
* value that ends with a backslash not itself in a backslash escape
* sequence.
*
* * If the first character of a formatted substring is
* \u0022 " QUOTE
* then the end of the substring is the next QUOTE character, not counting
* any QUOTE characters that are contained within a backslash escape
* sequence. If no next QUOTE is found before the end of the string, the
* string is not a Tcl list. If the character following the closing QUOTE is
* not an element separating whitespace character, or the end of the string,
* then the string is not a Tcl list. Having found the limits of the
* substring, the element value is produced by performing backslash
* substitution on the character sequence between the open and close QUOTEs.
*
* NOTE: Any element value can be represented by this style of formatting,
* given suitable choice of backslash escape sequences.
*
* * All other formatted substrings are terminated by the next element
* separating whitespace character in the string. Having found the limits
* of the substring, the element value is produced by performing backslash
* substitution on it.
*
* NOTE: Any element value can be represented by this style of formatting,
* given suitable choice of backslash escape sequences, with one exception.
* The empty string cannot be represented as a list element without the use
* of either braces or quotes to delimit it.
*
* This collection of parsing rules is implemented in the routine
* FindElement().
*
* In order to produce lists that can be parsed by these rules, we need the
* ability to distinguish between characters that are part of a list element
* value from characters providing syntax that define the structure of the
* list. This means that our code that generates lists must at a minimum be
* able to produce escape sequences for the 10 characters identified above
* that have significance to a list parser.
*
* * * CANONICAL LISTS * * * * *
*
* In addition to the basic rules for parsing strings into Tcl lists, there
* are additional properties to be met by the set of list values that are
* generated by Tcl. Such list values are often said to be in "canonical
* form":
*
* * When any canonical list is evaluated as a Tcl script, it is a script of
* either zero commands (an empty list) or exactly one command. The command
* word is exactly the first element of the list, and each argument word is
* exactly one of the following elements of the list. This means that any
* characters that have special meaning during script evaluation need
* special treatment when canonical lists are produced:
*
* * Whitespace between elements may not include NEWLINE.
* * The command terminating character,
* \u003b ; SEMICOLON
* must be BRACEd, QUOTEd, or escaped so that it does not terminate the
* command prematurely.
* * Any of the characters that begin substitutions in scripts,
* \u0024 $ DOLLAR
* \u005b [ OPEN BRACKET
* \u005c \ BACKSLASH
* need to be BRACEd or escaped.
* * In any list where the first character of the first element is
* \u0023 # HASH
* that HASH character must be BRACEd, QUOTEd, or escaped so that it
* does not convert the command into a comment.
* * Any list element that contains the character sequence BACKSLASH
* NEWLINE cannot be formatted with BRACEs. The BACKSLASH character
* must be represented by an escape sequence, and unless QUOTEs are
* used, the NEWLINE must be as well.
*
* * It is also guaranteed that one can use a canonical list as a building
* block of a larger script within command substitution, as in this example:
* set script "puts \[[list $cmd $arg]]"; eval $script
* To support this usage, any appearance of the character
* \u005d ] CLOSE BRACKET
* in a list element must be BRACEd, QUOTEd, or escaped.
*
* * Finally it is guaranteed that enclosing a canonical list in braces
* produces a new value that is also a canonical list. This new list has
* length 1, and its only element is the original canonical list. This same
* guarantee also makes it possible to construct scripts where an argument
* word is given a list value by enclosing the canonical form of that list
* in braces:
* set script "puts {[list $one $two $three]}"; eval $script
* This sort of coding was once fairly common, though it's become more
* idiomatic to see the following instead:
* set script [list puts [list $one $two $three]]; eval $script
* In order to support this guarantee, every canonical list must have
* balance when counting those braces that are not in escape sequences.
*
* Within these constraints, the canonical list generation routines
* TclScanElement() and TclConvertElement() attempt to generate the string for
* any list that is easiest to read. When an element value is itself
* acceptable as the formatted substring, it is usually used (CONVERT_NONE).
* When some quoting or escaping is required, use of BRACEs (CONVERT_BRACE) is
* usually preferred over the use of escape sequences (CONVERT_ESCAPE). There
* are some exceptions to both of these preferences for reasons of code
* simplicity, efficiency, and continuation of historical habits. Canonical
* lists never use the QUOTE formatting to delimit their elements because that
* form of quoting does not nest, which makes construction of nested lists far
* too much trouble. Canonical lists always use only a single SPACE character
* for element-separating whitespace.
*
* * * FUTURE CONSIDERATIONS * * *
*
* When a list element requires quoting or escaping due to a CLOSE BRACKET
* character or an internal QUOTE character, a strange formatting mode is
* recommended. For example, if the value "a{b]c}d" is converted by the usual
* modes:
*
* CONVERT_BRACE: a{b]c}d => {a{b]c}d}
* CONVERT_ESCAPE: a{b]c}d => a\{b\]c\}d
*
* we get perfectly usable formatted list elements. However, this is not what
* Tcl releases have been producing. Instead, we have:
*
* CONVERT_MASK: a{b]c}d => a{b\]c}d
*
* where the CLOSE BRACKET is escaped, but the BRACEs are not. The same effect
* can be seen replacing ] with " in this example. There does not appear to be
* any functional or aesthetic purpose for this strange additional mode. The
* sole purpose I can see for preserving it is to keep generating the same
* formatted lists programmers have become accustomed to, and perhaps written
* tests to expect. That is, compatibility only. The additional code
* complexity required to support this mode is significant. The lines of code
* supporting it are delimited in the routines below with #if COMPAT
* directives. This makes it easy to experiment with eliminating this
* formatting mode simply with "#define COMPAT 0" above. I believe this is
* worth considering.
*
* Another consideration is the treatment of QUOTE characters in list
* elements. TclConvertElement() must have the ability to produce the escape
* sequence \" so that when a list element begins with a QUOTE we do not
* confuse that first character with a QUOTE used as list syntax to define
* list structure. However, that is the only place where QUOTE characters need
* quoting. In this way, handling QUOTE could really be much more like the way
* we handle HASH which also needs quoting and escaping only in particular
* situations. Following up this could increase the set of list elements that
* can use the CONVERT_NONE formatting mode.
*
* More speculative is that the demands of canonical list form require brace
* balance for the list as a whole, while the current implementation achieves
* this by establishing brace balance for every element.
*
* Finally, a reminder that the rules for parsing and formatting lists are
* closely tied together with the rules for parsing and evaluating scripts,
* and will need to evolve in sync.
*/
/*
*----------------------------------------------------------------------
*
* TclMaxListLength --
*
* Given 'bytes' pointing to 'numBytes' bytes, scan through them and
* count the number of whitespace runs that could be list element
* separators. If 'numBytes' is -1, scan to the terminating '\0'. Not a
* full list parser. Typically used to get a quick and dirty overestimate
* of length size in order to allocate space for an actual list parser to
* operate with.
*
* Results:
* Returns the largest number of list elements that could possibly be in
* this string, interpreted as a Tcl list. If 'endPtr' is not NULL,
* writes a pointer to the end of the string scanned there.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclMaxListLength(
const char *bytes,
int numBytes,
const char **endPtr)
{
int count = 0;
if ((numBytes == 0) || ((numBytes == -1) && (*bytes == '\0'))) {
/* Empty string case - quick exit */
goto done;
}
/*
* No list element before leading white space.
*/
count += 1 - TclIsSpaceProcM(*bytes);
/*
* Count white space runs as potential element separators.
*/
while (numBytes) {
if ((numBytes == -1) && (*bytes == '\0')) {
break;
}
if (TclIsSpaceProcM(*bytes)) {
/*
* Space run started; bump count.
*/
count++;
do {
bytes++;
numBytes -= (numBytes != -1);
} while (numBytes && TclIsSpaceProcM(*bytes));
if ((numBytes == 0) || ((numBytes == -1) && (*bytes == '\0'))) {
break;
}
/*
* (*bytes) is non-space; return to counting state.
*/
}
bytes++;
numBytes -= (numBytes != -1);
}
/*
* No list element following trailing white space.
*/
count -= TclIsSpaceProcM(bytes[-1]);
done:
if (endPtr) {
*endPtr = bytes;
}
return count;
}
/*
*----------------------------------------------------------------------
*
* TclFindElement --
*
* Given a pointer into a Tcl list, locate the first (or next) element in
* the list.
*
* Results:
* The return value is normally TCL_OK, which means that the element was
* successfully located. If TCL_ERROR is returned it means that list
* didn't have proper list structure; the interp's result contains a more
* detailed error message.
*
* If TCL_OK is returned, then *elementPtr will be set to point to the
* first element of list, and *nextPtr will be set to point to the
* character just after any white space following the last character
* that's part of the element. If this is the last argument in the list,
* then *nextPtr will point just after the last character in the list
* (i.e., at the character at list+listLength). If sizePtr is non-NULL,
* *sizePtr is filled in with the number of bytes in the element. If the
* element is in braces, then *elementPtr will point to the character
* after the opening brace and *sizePtr will not include either of the
* braces. If there isn't an element in the list, *sizePtr will be zero,
* and both *elementPtr and *nextPtr will point just after the last
* character in the list. If literalPtr is non-NULL, *literalPtr is set
* to a boolean value indicating whether the substring returned as the
* values of **elementPtr and *sizePtr is the literal value of a list
* element. If not, a call to TclCopyAndCollapse() is needed to produce
* the actual value of the list element. Note: this function does NOT
* collapse backslash sequences, but uses *literalPtr to tell callers
* when it is required for them to do so.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclFindElement(
Tcl_Interp *interp, /* Interpreter to use for error reporting. If
* NULL, then no error message is left after
* errors. */
const char *list, /* Points to the first byte of a string
* containing a Tcl list with zero or more
* elements (possibly in braces). */
int listLength, /* Number of bytes in the list's string. */
const char **elementPtr, /* Where to put address of first significant
* character in first element of list. */
const char **nextPtr, /* Fill in with location of character just
* after all white space following end of
* argument (next arg or end of list). */
int *sizePtr, /* If non-zero, fill in with size of
* element. */
int *literalPtr) /* If non-zero, fill in with non-zero/zero to
* indicate that the substring of *sizePtr
* bytes starting at **elementPtr is/is not
* the literal list element and therefore
* does not/does require a call to
* TclCopyAndCollapse() by the caller. */
{
return FindElement(interp, list, listLength, "list", "LIST", elementPtr,
nextPtr, sizePtr, literalPtr);
}
int
TclFindDictElement(
Tcl_Interp *interp, /* Interpreter to use for error reporting. If
* NULL, then no error message is left after
* errors. */
const char *dict, /* Points to the first byte of a string
* containing a Tcl dictionary with zero or
* more keys and values (possibly in
* braces). */
int dictLength, /* Number of bytes in the dict's string. */
const char **elementPtr, /* Where to put address of first significant
* character in the first element (i.e., key
* or value) of dict. */
const char **nextPtr, /* Fill in with location of character just
* after all white space following end of
* element (next arg or end of list). */
int *sizePtr, /* If non-zero, fill in with size of
* element. */
int *literalPtr) /* If non-zero, fill in with non-zero/zero to
* indicate that the substring of *sizePtr
* bytes starting at **elementPtr is/is not
* the literal key or value and therefore
* does not/does require a call to
* TclCopyAndCollapse() by the caller. */
{
return FindElement(interp, dict, dictLength, "dict", "DICTIONARY",
elementPtr, nextPtr, sizePtr, literalPtr);
}
static int
FindElement(
Tcl_Interp *interp, /* Interpreter to use for error reporting. If
* NULL, then no error message is left after
* errors. */
const char *string, /* Points to the first byte of a string
* containing a Tcl list or dictionary with
* zero or more elements (possibly in
* braces). */
int stringLength, /* Number of bytes in the string. */
const char *typeStr, /* The name of the type of thing we are
* parsing, for error messages. */
const char *typeCode, /* The type code for thing we are parsing, for
* error messages. */
const char **elementPtr, /* Where to put address of first significant
* character in first element. */
const char **nextPtr, /* Fill in with location of character just
* after all white space following end of
* argument (next arg or end of list/dict). */
int *sizePtr, /* If non-zero, fill in with size of
* element. */
int *literalPtr) /* If non-zero, fill in with non-zero/zero to
* indicate that the substring of *sizePtr
* bytes starting at **elementPtr is/is not
* the literal list/dict element and therefore
* does not/does require a call to
* TclCopyAndCollapse() by the caller. */
{
const char *p = string;
const char *elemStart; /* Points to first byte of first element. */
const char *limit; /* Points just after list/dict's last byte. */
int openBraces = 0; /* Brace nesting level during parse. */
int inQuotes = 0;
int size = 0;
int numChars;
int literal = 1;
const char *p2;
/*
* Skim off leading white space and check for an opening brace or quote.
* We treat embedded NULLs in the list/dict as bytes belonging to a list
* element (or dictionary key or value).
*/
limit = (string + stringLength);
while ((p < limit) && (TclIsSpaceProcM(*p))) {
p++;
}
if (p == limit) { /* no element found */
elemStart = limit;
goto done;
}
if (*p == '{') {
openBraces = 1;
p++;
} else if (*p == '"') {
inQuotes = 1;
p++;
}
elemStart = p;
/*
* Find element's end (a space, close brace, or the end of the string).
*/
while (p < limit) {
switch (*p) {
/*
* Open brace: don't treat specially unless the element is in
* braces. In this case, keep a nesting count.
*/
case '{':
if (openBraces != 0) {
openBraces++;
}
break;
/*
* Close brace: if element is in braces, keep nesting count and
* quit when the last close brace is seen.
*/
case '}':
if (openBraces > 1) {
openBraces--;
} else if (openBraces == 1) {
size = (p - elemStart);
p++;
if ((p >= limit) || TclIsSpaceProcM(*p)) {
goto done;
}
/*
* Garbage after the closing brace; return an error.
*/
if (interp != NULL) {
p2 = p;
while ((p2 < limit) && (!TclIsSpaceProcM(*p2))
&& (p2 < p+20)) {
p2++;
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s element in braces followed by \"%.*s\" "
"instead of space", typeStr, (int) (p2-p), p));
Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "JUNK",
NULL);
}
return TCL_ERROR;
}
break;
/*
* Backslash: skip over everything up to the end of the backslash
* sequence.
*/
case '\\':
if (openBraces == 0) {
/*
* A backslash sequence not within a brace quoted element
* means the value of the element is different from the
* substring we are parsing. A call to TclCopyAndCollapse() is
* needed to produce the element value. Inform the caller.
*/
literal = 0;
}
TclParseBackslash(p, limit - p, &numChars, NULL);
p += (numChars - 1);
break;
/*
* Double-quote: if element is in quotes then terminate it.
*/
case '"':
if (inQuotes) {
size = (p - elemStart);
p++;
if ((p >= limit) || TclIsSpaceProcM(*p)) {
goto done;
}
/*
* Garbage after the closing quote; return an error.
*/
if (interp != NULL) {
p2 = p;
while ((p2 < limit) && (!TclIsSpaceProcM(*p2))
&& (p2 < p+20)) {
p2++;
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s element in quotes followed by \"%.*s\" "
"instead of space", typeStr, (int) (p2-p), p));
Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "JUNK",
NULL);
}
return TCL_ERROR;
}
break;
default:
if (TclIsSpaceProcM(*p)) {
/*
* Space: ignore if element is in braces or quotes;
* otherwise terminate element.
*/
if ((openBraces == 0) && !inQuotes) {
size = (p - elemStart);
goto done;
}
}
break;
}
p++;
}
/*
* End of list/dict: terminate element.
*/
if (p == limit) {
if (openBraces != 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unmatched open brace in %s", typeStr));
Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "BRACE",
NULL);
}
return TCL_ERROR;
} else if (inQuotes) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unmatched open quote in %s", typeStr));
Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "QUOTE",
NULL);
}
return TCL_ERROR;
}
size = (p - elemStart);
}
done:
while ((p < limit) && (TclIsSpaceProcM(*p))) {
p++;
}
*elementPtr = elemStart;
*nextPtr = p;
if (sizePtr != 0) {
*sizePtr = size;
}
if (literalPtr != 0) {
*literalPtr = literal;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCopyAndCollapse --
*
* Copy a string and substitute all backslash escape sequences
*
* Results:
* Count bytes get copied from src to dst. Along the way, backslash
* sequences are substituted in the copy. After scanning count bytes from
* src, a null character is placed at the end of dst. Returns the number
* of bytes that got written to dst.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclCopyAndCollapse(
int count, /* Number of byte to copy from src. */
const char *src, /* Copy from here... */
char *dst) /* ... to here. */
{
int newCount = 0;
while (count > 0) {
char c = *src;
if (c == '\\') {
int numRead;
int backslashCount = TclParseBackslash(src, count, &numRead, dst);
dst += backslashCount;
newCount += backslashCount;
src += numRead;
count -= numRead;
} else {
*dst = c;
dst++;
newCount++;
src++;
count--;
}
}
*dst = 0;
return newCount;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SplitList --
*
* Splits a list up into its constituent fields.
*
* Results
* The return value is normally TCL_OK, which means that the list was
* successfully split up. If TCL_ERROR is returned, it means that "list"
* didn't have proper list structure; the interp's result will contain a
* more detailed error message.
*
* *argvPtr will be filled in with the address of an array whose elements
* point to the elements of list, in order. *argcPtr will get filled in
* with the number of valid elements in the array. A single block of
* memory is dynamically allocated to hold both the argv array and a copy
* of the list (with backslashes and braces removed in the standard way).
* The caller must eventually free this memory by calling free() on
* *argvPtr. Note: *argvPtr and *argcPtr are only modified if the
* function returns normally.
*
* Side effects:
* Memory is allocated.
*
*----------------------------------------------------------------------
*/
int
Tcl_SplitList(
Tcl_Interp *interp, /* Interpreter to use for error reporting. If
* NULL, no error message is left. */
const char *list, /* Pointer to string with list structure. */
int *argcPtr, /* Pointer to location to fill in with the
* number of elements in the list. */
const char ***argvPtr) /* Pointer to place to store pointer to array
* of pointers to list elements. */
{
const char **argv, *end, *element;
char *p;
int length, size, i, result, elSize;
/*
* Allocate enough space to work in. A (const char *) for each (possible)
* list element plus one more for terminating NULL, plus as many bytes as
* in the original string value, plus one more for a terminating '\0'.
* Space used to hold element separating white space in the original
* string gets re-purposed to hold '\0' characters in the argv array.
*/
size = TclMaxListLength(list, -1, &end) + 1;
length = end - list;
argv = (const char **)ckalloc((size * sizeof(char *)) + length + 1);
for (i = 0, p = ((char *) argv) + size*sizeof(char *);
*list != 0; i++) {
const char *prevList = list;
int literal;
result = TclFindElement(interp, list, length, &element, &list,
&elSize, &literal);
length -= (list - prevList);
if (result != TCL_OK) {
ckfree(argv);
return result;
}
if (*element == 0) {
break;
}
if (i >= size) {
ckfree(argv);
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"internal error in Tcl_SplitList", -1));
Tcl_SetErrorCode(interp, "TCL", "INTERNAL", "Tcl_SplitList",
NULL);
}
return TCL_ERROR;
}
argv[i] = p;
if (literal) {
memcpy(p, element, elSize);
p += elSize;
*p = 0;
p++;
} else {
p += 1 + TclCopyAndCollapse(elSize, element, p);
}
}
argv[i] = NULL;
*argvPtr = argv;
*argcPtr = i;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ScanElement --
*
* This function is a companion function to Tcl_ConvertElement. It scans
* a string to see what needs to be done to it (e.g. add backslashes or
* enclosing braces) to make the string into a valid Tcl list element.
*
* Results:
* The return value is an overestimate of the number of bytes that will
* be needed by Tcl_ConvertElement to produce a valid list element from
* src. The word at *flagPtr is filled in with a value needed by
* Tcl_ConvertElement when doing the actual conversion.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_ScanElement(
const char *src, /* String to convert to list element. */
int *flagPtr) /* Where to store information to guide
* Tcl_ConvertCountedElement. */
{
return Tcl_ScanCountedElement(src, -1, flagPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_ScanCountedElement --
*
* This function is a companion function to Tcl_ConvertCountedElement. It
* scans a string to see what needs to be done to it (e.g. add
* backslashes or enclosing braces) to make the string into a valid Tcl
* list element. If length is -1, then the string is scanned from src up
* to the first null byte.
*
* Results:
* The return value is an overestimate of the number of bytes that will
* be needed by Tcl_ConvertCountedElement to produce a valid list element
* from src. The word at *flagPtr is filled in with a value needed by
* Tcl_ConvertCountedElement when doing the actual conversion.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_ScanCountedElement(
const char *src, /* String to convert to Tcl list element. */
int length, /* Number of bytes in src, or -1. */
int *flagPtr) /* Where to store information to guide
* Tcl_ConvertElement. */
{
char flags = CONVERT_ANY;
int numBytes = TclScanElement(src, length, &flags);
*flagPtr = flags;
return numBytes;
}
/*
*----------------------------------------------------------------------
*
* TclScanElement --
*
* This function is a companion function to TclConvertElement. It scans a
* string to see what needs to be done to it (e.g. add backslashes or
* enclosing braces) to make the string into a valid Tcl list element. If
* length is -1, then the string is scanned from src up to the first null
* byte. A NULL value for src is treated as an empty string. The incoming
* value of *flagPtr is a report from the caller what additional flags it
* will pass to TclConvertElement().
*
* Results:
* The recommended formatting mode for the element is determined and a
* value is written to *flagPtr indicating that recommendation. This
* recommendation is combined with the incoming flag values in *flagPtr
* set by the caller to determine how many bytes will be needed by
* TclConvertElement() in which to write the formatted element following
* the recommendation modified by the flag values. This number of bytes
* is the return value of the routine. In some situations it may be an
* overestimate, but so long as the caller passes the same flags to
* TclConvertElement(), it will be large enough.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclScanElement(
const char *src, /* String to convert to Tcl list element. */
int length, /* Number of bytes in src, or -1. */
char *flagPtr) /* Where to store information to guide
* Tcl_ConvertElement. */
{
const char *p = src;
int nestingLevel = 0; /* Brace nesting count */
int forbidNone = 0; /* Do not permit CONVERT_NONE mode. Something
* needs protection or escape. */
int requireEscape = 0; /* Force use of CONVERT_ESCAPE mode. For some
* reason bare or brace-quoted form fails. */
int extra = 0; /* Count of number of extra bytes needed for
* formatted element, assuming we use escape
* sequences in formatting. */
int bytesNeeded; /* Buffer length computed to complete the
* element formatting in the selected mode. */
#if COMPAT
int preferEscape = 0; /* Use preferences to track whether to use */
int preferBrace = 0; /* CONVERT_MASK mode. */
int braceCount = 0; /* Count of all braces '{' '}' seen. */
#endif /* COMPAT */
if ((p == NULL) || (length == 0) || ((*p == '\0') && (length == -1))) {
/*
* Empty string element must be brace quoted.
*/
*flagPtr = CONVERT_BRACE;
return 2;
}
#if COMPAT
/*
* We have an established history in TclConvertElement() when quoting
* because of a leading hash character to force what would be the
* CONVERT_MASK mode into the CONVERT_BRACE mode. That is, we format
* the element #{a"b} like this:
* {#{a"b}}
* and not like this:
* \#{a\"b}
* This is inconsistent with [list x{a"b}], but we will not change that now.
* Set that preference here so that we compute a tight size requirement.
*/
if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) {
preferBrace = 1;
}
#endif
if ((*p == '{') || (*p == '"')) {
/*
* Must escape or protect so leading character of value is not
* misinterpreted as list element delimiting syntax.
*/
forbidNone = 1;
#if COMPAT
preferBrace = 1;
#endif /* COMPAT */
}
while (length) {
if (CHAR_TYPE(*p) != TYPE_NORMAL) {
switch (*p) {
case '{': /* TYPE_BRACE */
#if COMPAT
braceCount++;
#endif /* COMPAT */
extra++; /* Escape '{' => '\{' */
nestingLevel++;
break;
case '}': /* TYPE_BRACE */
#if COMPAT
braceCount++;
#endif /* COMPAT */
extra++; /* Escape '}' => '\}' */
nestingLevel--;
if (nestingLevel < 0) {
/*
* Unbalanced braces! Cannot format with brace quoting.
*/
requireEscape = 1;
}
break;
case ']': /* TYPE_CLOSE_BRACK */
case '"': /* TYPE_SPACE */
#if COMPAT
forbidNone = 1;
extra++; /* Escapes all just prepend a backslash */
preferEscape = 1;
break;
#else
/* FLOW THROUGH */
#endif /* COMPAT */
case '[': /* TYPE_SUBS */
case '$': /* TYPE_SUBS */
case ';': /* TYPE_COMMAND_END */
forbidNone = 1;
extra++; /* Escape sequences all one byte longer. */
#if COMPAT
preferBrace = 1;
#endif /* COMPAT */
break;
case '\\': /* TYPE_SUBS */
extra++; /* Escape '\' => '\\' */
if ((length == 1) || ((length == -1) && (p[1] == '\0'))) {
/*
* Final backslash. Cannot format with brace quoting.
*/
requireEscape = 1;
break;
}
if (p[1] == '\n') {
extra++; /* Escape newline => '\n', one byte longer */
/*
* Backslash newline sequence. Brace quoting not permitted.
*/
requireEscape = 1;
length -= (length > 0);
p++;
break;
}
if ((p[1] == '{') || (p[1] == '}') || (p[1] == '\\')) {
extra++; /* Escape sequences all one byte longer. */
length -= (length > 0);
p++;
}
forbidNone = 1;
#if COMPAT
preferBrace = 1;
#endif /* COMPAT */
break;
case '\0': /* TYPE_SUBS */
if (length == -1) {
goto endOfString;
}
/* TODO: Panic on improper encoding? */
break;
default:
if (TclIsSpaceProcM(*p)) {
forbidNone = 1;
extra++; /* Escape sequences all one byte longer. */
#if COMPAT
preferBrace = 1;
#endif
}
break;
}
}
length -= (length > 0);
p++;
}
endOfString:
if (nestingLevel != 0) {
/*
* Unbalanced braces! Cannot format with brace quoting.
*/
requireEscape = 1;
}
/*
* We need at least as many bytes as are in the element value...
*/
bytesNeeded = p - src;
if (requireEscape) {
/*
* We must use escape sequences. Add all the extra bytes needed to
* have room to create them.
*/
bytesNeeded += extra;
/*
* Make room to escape leading #, if needed.
*/
if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) {
bytesNeeded++;
}
*flagPtr = CONVERT_ESCAPE;
goto overflowCheck;
}
if (*flagPtr & CONVERT_ANY) {
/*
* The caller has not let us know what flags it will pass to
* TclConvertElement() so compute the max size we might need for any
* possible choice. Normally the formatting using escape sequences is
* the longer one, and a minimum "extra" value of 2 makes sure we
* don't request too small a buffer in those edge cases where that's
* not true.
*/
if (extra < 2) {
extra = 2;
}
*flagPtr &= ~CONVERT_ANY;
*flagPtr |= TCL_DONT_USE_BRACES;
}
if (forbidNone) {
/*
* We must request some form of quoting of escaping...
*/
#if COMPAT
if (preferEscape && !preferBrace) {
/*
* If we are quoting solely due to ] or internal " characters use
* the CONVERT_MASK mode where we escape all special characters
* except for braces. "extra" counted space needed to escape
* braces too, so substract "braceCount" to get our actual needs.
*/
bytesNeeded += (extra - braceCount);
/* Make room to escape leading #, if needed. */
if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) {
bytesNeeded++;
}
/*
* If the caller reports it will direct TclConvertElement() to
* use full escapes on the element, add back the bytes needed to
* escape the braces.
*/
if (*flagPtr & TCL_DONT_USE_BRACES) {
bytesNeeded += braceCount;
}
*flagPtr = CONVERT_MASK;
goto overflowCheck;
}
#endif /* COMPAT */
if (*flagPtr & TCL_DONT_USE_BRACES) {
/*
* If the caller reports it will direct TclConvertElement() to
* use escapes, add the extra bytes needed to have room for them.
*/
bytesNeeded += extra;
/*
* Make room to escape leading #, if needed.
*/
if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) {
bytesNeeded++;
}
} else {
/*
* Add 2 bytes for room for the enclosing braces.
*/
bytesNeeded += 2;
}
*flagPtr = CONVERT_BRACE;
goto overflowCheck;
}
/*
* So far, no need to quote or escape anything.
*/
if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) {
/*
* If we need to quote a leading #, make room to enclose in braces.
*/
bytesNeeded += 2;
}
*flagPtr = CONVERT_NONE;
overflowCheck:
if (bytesNeeded < 0) {
Tcl_Panic("TclScanElement: string length overflow");
}
return bytesNeeded;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ConvertElement --
*
* This is a companion function to Tcl_ScanElement. Given the information
* produced by Tcl_ScanElement, this function converts a string to a list
* element equal to that string.
*
* Results:
* Information is copied to *dst in the form of a list element identical
* to src (i.e. if Tcl_SplitList is applied to dst it will produce a
* string identical to src). The return value is a count of the number of
* characters copied (not including the terminating NULL character).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_ConvertElement(
const char *src, /* Source information for list element. */
char *dst, /* Place to put list-ified element. */
int flags) /* Flags produced by Tcl_ScanElement. */
{
return Tcl_ConvertCountedElement(src, -1, dst, flags);
}
/*
*----------------------------------------------------------------------
*
* Tcl_ConvertCountedElement --
*
* This is a companion function to Tcl_ScanCountedElement. Given the
* information produced by Tcl_ScanCountedElement, this function converts
* a string to a list element equal to that string.
*
* Results:
* Information is copied to *dst in the form of a list element identical
* to src (i.e. if Tcl_SplitList is applied to dst it will produce a
* string identical to src). The return value is a count of the number of
* characters copied (not including the terminating NULL character).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_ConvertCountedElement(
const char *src, /* Source information for list element. */
int length, /* Number of bytes in src, or -1. */
char *dst, /* Place to put list-ified element. */
int flags) /* Flags produced by Tcl_ScanElement. */
{
int numBytes = TclConvertElement(src, length, dst, flags);
dst[numBytes] = '\0';
return numBytes;
}
/*
*----------------------------------------------------------------------
*
* TclConvertElement --
*
* This is a companion function to TclScanElement. Given the information
* produced by TclScanElement, this function converts a string to a list
* element equal to that string.
*
* Results:
* Information is copied to *dst in the form of a list element identical
* to src (i.e. if Tcl_SplitList is applied to dst it will produce a
* string identical to src). The return value is a count of the number of
* characters copied (not including the terminating NULL character).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclConvertElement(
const char *src, /* Source information for list element. */
int length, /* Number of bytes in src, or -1. */
char *dst, /* Place to put list-ified element. */
int flags) /* Flags produced by Tcl_ScanElement. */
{
int conversion = flags & CONVERT_MASK;
char *p = dst;
/*
* Let the caller demand we use escape sequences rather than braces.
*/
if ((flags & TCL_DONT_USE_BRACES) && (conversion & CONVERT_BRACE)) {
conversion = CONVERT_ESCAPE;
}
/*
* No matter what the caller demands, empty string must be braced!
*/
if ((src == NULL) || (length == 0) || (*src == '\0' && length == -1)) {
src = tclEmptyStringRep;
length = 0;
conversion = CONVERT_BRACE;
}
/*
* Escape leading hash as needed and requested.
*/
if ((*src == '#') && !(flags & TCL_DONT_QUOTE_HASH)) {
if (conversion == CONVERT_ESCAPE) {
p[0] = '\\';
p[1] = '#';
p += 2;
src++;
length -= (length > 0);
} else {
conversion = CONVERT_BRACE;
}
}
/*
* No escape or quoting needed. Copy the literal string value.
*/
if (conversion == CONVERT_NONE) {
if (length == -1) {
/* TODO: INT_MAX overflow? */
while (*src) {
*p++ = *src++;
}
return p - dst;
} else {
memcpy(dst, src, length);
return length;
}
}
/*
* Formatted string is original string enclosed in braces.
*/
if (conversion == CONVERT_BRACE) {
*p = '{';
p++;
if (length == -1) {
/* TODO: INT_MAX overflow? */
while (*src) {
*p++ = *src++;
}
} else {
memcpy(p, src, length);
p += length;
}
*p = '}';
p++;
return p - dst;
}
/* conversion == CONVERT_ESCAPE or CONVERT_MASK */
/*
* Formatted string is original string converted to escape sequences.
*/
for ( ; length; src++, length -= (length > 0)) {
switch (*src) {
case ']':
case '[':
case '$':
case ';':
case ' ':
case '\\':
case '"':
*p = '\\';
p++;
break;
case '{':
case '}':
#if COMPAT
if (conversion == CONVERT_ESCAPE)
#endif /* COMPAT */
{
*p = '\\';
p++;
}
break;
case '\f':
*p = '\\';
p++;
*p = 'f';
p++;
continue;
case '\n':
*p = '\\';
p++;
*p = 'n';
p++;
continue;
case '\r':
*p = '\\';
p++;
*p = 'r';
p++;
continue;
case '\t':
*p = '\\';
p++;
*p = 't';
p++;
continue;
case '\v':
*p = '\\';
p++;
*p = 'v';
p++;
continue;
case '\0':
if (length == -1) {
return p - dst;
}
/*
* If we reach this point, there's an embedded NULL in the string
* range being processed, which should not happen when the
* encoding rules for Tcl strings are properly followed. If the
* day ever comes when we stop tolerating such things, this is
* where to put the Tcl_Panic().
*/
break;
}
*p = *src;
p++;
}
return p - dst;
}
/*
*----------------------------------------------------------------------
*
* Tcl_Merge --
*
* Given a collection of strings, merge them together into a single
* string that has proper Tcl list structured (i.e. Tcl_SplitList may be
* used to retrieve strings equal to the original elements, and Tcl_Eval
* will parse the string back into its original elements).
*
* Results:
* The return value is the address of a dynamically-allocated string
* containing the merged list.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
char *
Tcl_Merge(
int argc, /* How many strings to merge. */
const char *const *argv) /* Array of string values. */
{
#define LOCAL_SIZE 64
char localFlags[LOCAL_SIZE], *flagPtr = NULL;
int i, bytesNeeded = 0;
char *result, *dst;
/*
* Handle empty list case first, so logic of the general case can be
* simpler.
*/
if (argc == 0) {
result = (char *)ckalloc(1);
result[0] = '\0';
return result;
}
/*
* Pass 1: estimate space, gather flags.
*/
if (argc <= LOCAL_SIZE) {
flagPtr = localFlags;
} else {
flagPtr = (char *)ckalloc(argc);
}
for (i = 0; i < argc; i++) {
flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 );
bytesNeeded += TclScanElement(argv[i], -1, &flagPtr[i]);
if (bytesNeeded < 0) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
}
if (bytesNeeded > INT_MAX - argc + 1) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
bytesNeeded += argc;
/*
* Pass two: copy into the result area.
*/
result = (char *)ckalloc(bytesNeeded);
dst = result;
for (i = 0; i < argc; i++) {
flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 );
dst += TclConvertElement(argv[i], -1, dst, flagPtr[i]);
*dst = ' ';
dst++;
}
dst[-1] = 0;
if (flagPtr != localFlags) {
ckfree(flagPtr);
}
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_Backslash --
*
* Figure out how to handle a backslash sequence.
*
* Results:
* The return value is the character that should be substituted in place
* of the backslash sequence that starts at src. If readPtr isn't NULL
* then it is filled in with a count of the number of characters in the
* backslash sequence.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
char
Tcl_Backslash(
const char *src, /* Points to the backslash character of a
* backslash sequence. */
int *readPtr) /* Fill in with number of characters read from
* src, unless NULL. */
{
char buf[4] = "";
Tcl_UniChar ch = 0;
Tcl_UtfBackslash(src, readPtr, buf);
TclUtfToUniChar(buf, &ch);
return (char) ch;
}
/*
*----------------------------------------------------------------------
*
* TclTrimRight --
* Takes two counted strings in the Tcl encoding. Conceptually
* finds the sub string (offset) to trim from the right side of the
* first string all characters found in the second string.
*
* Results:
* The number of bytes to be removed from the end of the string.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclTrimRight(
const char *bytes, /* String to be trimmed... */
int numBytes, /* ...and its length in bytes */
/* Calls to TclUtfToUniChar() in this routine
* rely on (bytes[numBytes] == '\0'). */
const char *trim, /* String of trim characters... */
int numTrim) /* ...and its length in bytes */
/* Calls to TclUtfToUniChar() in this routine
* rely on (trim[numTrim] == '\0'). */
{
const char *pp, *p = bytes + numBytes;
int ch1, ch2;
/* Empty strings -> nothing to do */
if ((numBytes == 0) || (numTrim == 0)) {
return 0;
}
/*
* Outer loop: iterate over string to be trimmed.
*/
do {
const char *q = trim;
int pInc = 0, bytesLeft = numTrim;
pp = TclUtfPrev(p, bytes);
#if TCL_UTF_MAX < 4
pp = TclUtfPrev(pp, bytes);
#endif
do {
pp += pInc;
pInc = TclUtfToUCS4(pp, &ch1);
} while (pp + pInc < p);
/*
* Inner loop: scan trim string for match to current character.
*/
do {
pInc = TclUtfToUCS4(q, &ch2);
if (ch1 == ch2) {
break;
}
q += pInc;
bytesLeft -= pInc;
} while (bytesLeft);
if (bytesLeft == 0) {
/*
* No match; trim task done; *p is last non-trimmed char.
*/
break;
}
p = pp;
} while (p > bytes);
return numBytes - (p - bytes);
}
/*
*----------------------------------------------------------------------
*
* TclTrimLeft --
*
* Takes two counted strings in the Tcl encoding. Conceptually
* finds the sub string (offset) to trim from the left side of the
* first string all characters found in the second string.
*
* Results:
* The number of bytes to be removed from the start of the string.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclTrimLeft(
const char *bytes, /* String to be trimmed... */
int numBytes, /* ...and its length in bytes */
/* Calls to TclUtfToUniChar() in this routine
* rely on (bytes[numBytes] == '\0'). */
const char *trim, /* String of trim characters... */
int numTrim) /* ...and its length in bytes */
/* Calls to TclUtfToUniChar() in this routine
* rely on (trim[numTrim] == '\0'). */
{
const char *p = bytes;
int ch1, ch2;
/* Empty strings -> nothing to do */
if ((numBytes == 0) || (numTrim == 0)) {
return 0;
}
/*
* Outer loop: iterate over string to be trimmed.
*/
do {
int pInc = TclUtfToUCS4(p, &ch1);
const char *q = trim;
int bytesLeft = numTrim;
/*
* Inner loop: scan trim string for match to current character.
*/
do {
int qInc = TclUtfToUCS4(q, &ch2);
if (ch1 == ch2) {
break;
}
q += qInc;
bytesLeft -= qInc;
} while (bytesLeft);
if (bytesLeft == 0) {
/*
* No match; trim task done; *p is first non-trimmed char.
*/
break;
}
p += pInc;
numBytes -= pInc;
} while (numBytes > 0);
return p - bytes;
}
/*
*----------------------------------------------------------------------
*
* TclTrim --
* Finds the sub string (offset) to trim from both sides of the
* first string all characters found in the second string.
*
* Results:
* The number of bytes to be removed from the start of the string
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclTrim(
const char *bytes, /* String to be trimmed... */
int numBytes, /* ...and its length in bytes */
/* Calls in this routine
* rely on (bytes[numBytes] == '\0'). */
const char *trim, /* String of trim characters... */
int numTrim, /* ...and its length in bytes */
/* Calls in this routine
* rely on (trim[numTrim] == '\0'). */
int *trimRightPtr) /* Offset from the end of the string. */
{
int trimLeft = 0, trimRight = 0;
/* Empty strings -> nothing to do */
if ((numBytes > 0) && (numTrim > 0)) {
/* When bytes is NUL-terminated, returns 0 <= trimLeft <= numBytes */
trimLeft = TclTrimLeft(bytes, numBytes, trim, numTrim);
numBytes -= trimLeft;
/* If we did not trim the whole string, it starts with a character
* that we will not trim. Skip over it. */
if (numBytes > 0) {
int ch;
const char *first = bytes + trimLeft;
bytes += TclUtfToUCS4(first, &ch);
numBytes -= (bytes - first);
if (numBytes > 0) {
/* When bytes is NUL-terminated, returns
* 0 <= trimRight <= numBytes */
trimRight = TclTrimRight(bytes, numBytes, trim, numTrim);
}
}
}
*trimRightPtr = trimRight;
return trimLeft;
}
/*
*----------------------------------------------------------------------
*
* Tcl_Concat --
*
* Concatenate a set of strings into a single large string.
*
* Results:
* The return value is dynamically-allocated string containing a
* concatenation of all the strings in argv, with spaces between the
* original argv elements.
*
* Side effects:
* Memory is allocated for the result; the caller is responsible for
* freeing the memory.
*
*----------------------------------------------------------------------
*/
/* The whitespace characters trimmed during [concat] operations */
#define CONCAT_WS_SIZE (int) (sizeof(CONCAT_TRIM_SET "") - 1)
char *
Tcl_Concat(
int argc, /* Number of strings to concatenate. */
const char *const *argv) /* Array of strings to concatenate. */
{
int i, needSpace = 0, bytesNeeded = 0;
char *result, *p;
/*
* Dispose of the empty result corner case first to simplify later code.
*/
if (argc == 0) {
result = (char *) ckalloc(1);
result[0] = '\0';
return result;
}
/*
* First allocate the result buffer at the size required.
*/
for (i = 0; i < argc; i++) {
bytesNeeded += strlen(argv[i]);
if (bytesNeeded < 0) {
Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded");
}
}
if (bytesNeeded + argc - 1 < 0) {
/*
* Panic test could be tighter, but not going to bother for this
* legacy routine.
*/
Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded");
}
/*
* All element bytes + (argc - 1) spaces + 1 terminating NULL.
*/
result = (char *)ckalloc(bytesNeeded + argc);
for (p = result, i = 0; i < argc; i++) {
int triml, trimr, elemLength;
const char *element;
element = argv[i];
elemLength = strlen(argv[i]);
/* Trim away the leading/trailing whitespace. */
triml = TclTrim(element, elemLength, CONCAT_TRIM_SET,
CONCAT_WS_SIZE, &trimr);
element += triml;
elemLength -= triml + trimr;
/* Do not permit trimming to expose a final backslash character. */
elemLength += trimr && (element[elemLength - 1] == '\\');
/*
* If we're left with empty element after trimming, do nothing.
*/
if (elemLength == 0) {
continue;
}
/*
* Append to the result with space if needed.
*/
if (needSpace) {
*p++ = ' ';
}
memcpy(p, element, elemLength);
p += elemLength;
needSpace = 1;
}
*p = '\0';
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ConcatObj --
*
* Concatenate the strings from a set of objects into a single string
* object with spaces between the original strings.
*
* Results:
* The return value is a new string object containing a concatenation of
* the strings in objv. Its ref count is zero.
*
* Side effects:
* A new object is created.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_ConcatObj(
int objc, /* Number of objects to concatenate. */
Tcl_Obj *const objv[]) /* Array of objects to concatenate. */
{
int i, elemLength, needSpace = 0, bytesNeeded = 0;
const char *element;
Tcl_Obj *objPtr, *resPtr;
/*
* Check first to see if all the items are of list type or empty. If so,
* we will concat them together as lists, and return a list object. This
* is only valid when the lists are in canonical form.
*/
for (i = 0; i < objc; i++) {
int length;
objPtr = objv[i];
if (TclListObjIsCanonical(objPtr)) {
continue;
}
Tcl_GetStringFromObj(objPtr, &length);
if (length > 0) {
break;
}
}
if (i == objc) {
resPtr = NULL;
for (i = 0; i < objc; i++) {
objPtr = objv[i];
if (objPtr->bytes && objPtr->length == 0) {
continue;
}
if (resPtr) {
Tcl_Obj *elemPtr = NULL;
Tcl_ListObjIndex(NULL, objPtr, 0, &elemPtr);
if (elemPtr == NULL) {
continue;
}
if (Tcl_GetString(elemPtr)[0] == '#' || TCL_OK
!= Tcl_ListObjAppendList(NULL, resPtr, objPtr)) {
/* Abandon ship! */
Tcl_DecrRefCount(resPtr);
goto slow;
}
} else {
resPtr = TclListObjCopy(NULL, objPtr);
}
}
if (!resPtr) {
TclNewObj(resPtr);
}
return resPtr;
}
slow:
/*
* Something cannot be determined to be safe, so build the concatenation
* the slow way, using the string representations.
*
* First try to pre-allocate the size required.
*/
for (i = 0; i < objc; i++) {
element = TclGetStringFromObj(objv[i], &elemLength);
bytesNeeded += elemLength;
if (bytesNeeded < 0) {
break;
}
}
/*
* Does not matter if this fails, will simply try later to build up the
* string with each Append reallocating as needed with the usual string
* append algorithm. When that fails it will report the error.
*/
TclNewObj(resPtr);
(void) Tcl_AttemptSetObjLength(resPtr, bytesNeeded + objc - 1);
Tcl_SetObjLength(resPtr, 0);
for (i = 0; i < objc; i++) {
int triml, trimr;
element = TclGetStringFromObj(objv[i], &elemLength);
/* Trim away the leading/trailing whitespace. */
triml = TclTrim(element, elemLength, CONCAT_TRIM_SET,
CONCAT_WS_SIZE, &trimr);
element += triml;
elemLength -= triml + trimr;
/* Do not permit trimming to expose a final backslash character. */
elemLength += trimr && (element[elemLength - 1] == '\\');
/*
* If we're left with empty element after trimming, do nothing.
*/
if (elemLength == 0) {
continue;
}
/*
* Append to the result with space if needed.
*/
if (needSpace) {
Tcl_AppendToObj(resPtr, " ", 1);
}
Tcl_AppendToObj(resPtr, element, elemLength);
needSpace = 1;
}
return resPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_StringMatch --
*
* See if a particular string matches a particular pattern.
*
* Results:
* The return value is 1 if string matches pattern, and 0 otherwise. The
* matching operation permits the following special characters in the
* pattern: *?\[] (see the manual entry for details on what these mean).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_StringMatch(
const char *str, /* String. */
const char *pattern) /* Pattern, which may contain special
* characters. */
{
return Tcl_StringCaseMatch(str, pattern, 0);
}
/*
*----------------------------------------------------------------------
*
* Tcl_StringCaseMatch --
*
* See if a particular string matches a particular pattern. Allows case
* insensitivity.
*
* Results:
* The return value is 1 if string matches pattern, and 0 otherwise. The
* matching operation permits the following special characters in the
* pattern: *?\[] (see the manual entry for details on what these mean).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_StringCaseMatch(
const char *str, /* String. */
const char *pattern, /* Pattern, which may contain special
* characters. */
int nocase) /* 0 for case sensitive, 1 for insensitive */
{
int p, charLen;
int ch1 = 0, ch2 = 0;
while (1) {
p = *pattern;
/*
* See if we're at the end of both the pattern and the string. If so,
* we succeeded. If we're at the end of the pattern but not at the end
* of the string, we failed.
*/
if (p == '\0') {
return (*str == '\0');
}
if ((*str == '\0') && (p != '*')) {
return 0;
}
/*
* Check for a "*" as the next pattern character. It matches any
* substring. We handle this by calling ourselves recursively for each
* postfix of string, until either we match or we reach the end of the
* string.
*/
if (p == '*') {
/*
* Skip all successive *'s in the pattern
*/
while (*(++pattern) == '*') {}
p = *pattern;
if (p == '\0') {
return 1;
}
/*
* This is a special case optimization for single-byte utf.
*/
if (UCHAR(*pattern) < 0x80) {
ch2 = (int)
(nocase ? tolower(UCHAR(*pattern)) : UCHAR(*pattern));
} else {
TclUtfToUCS4(pattern, &ch2);
if (nocase) {
ch2 = TclUCS4ToLower(ch2);
}
}
while (1) {
/*
* Optimization for matching - cruise through the string
* quickly if the next char in the pattern isn't a special
* character
*/
if ((p != '[') && (p != '?') && (p != '\\')) {
if (nocase) {
while (*str) {
charLen = TclUtfToUCS4(str, &ch1);
if (ch2==ch1 || ch2==TclUCS4ToLower(ch1)) {
break;
}
str += charLen;
}
} else {
/*
* There's no point in trying to make this code
* shorter, as the number of bytes you want to compare
* each time is non-constant.
*/
while (*str) {
charLen = TclUtfToUCS4(str, &ch1);
if (ch2 == ch1) {
break;
}
str += charLen;
}
}
}
if (Tcl_StringCaseMatch(str, pattern, nocase)) {
return 1;
}
if (*str == '\0') {
return 0;
}
str += TclUtfToUCS4(str, &ch1);
}
}
/*
* Check for a "?" as the next pattern character. It matches any
* single character.
*/
if (p == '?') {
pattern++;
str += TclUtfToUCS4(str, &ch1);
continue;
}
/*
* Check for a "[" as the next pattern character. It is followed by a
* list of characters that are acceptable, or by a range (two
* characters separated by "-").
*/
if (p == '[') {
int startChar = 0, endChar = 0;
pattern++;
if (UCHAR(*str) < 0x80) {
ch1 = (int)
(nocase ? tolower(UCHAR(*str)) : UCHAR(*str));
str++;
} else {
str += TclUtfToUCS4(str, &ch1);
if (nocase) {
ch1 = TclUCS4ToLower(ch1);
}
}
while (1) {
if ((*pattern == ']') || (*pattern == '\0')) {
return 0;
}
if (UCHAR(*pattern) < 0x80) {
startChar = (int) (nocase
? tolower(UCHAR(*pattern)) : UCHAR(*pattern));
pattern++;
} else {
pattern += TclUtfToUCS4(pattern, &startChar);
if (nocase) {
startChar = TclUCS4ToLower(startChar);
}
}
if (*pattern == '-') {
pattern++;
if (*pattern == '\0') {
return 0;
}
if (UCHAR(*pattern) < 0x80) {
endChar = (int) (nocase
? tolower(UCHAR(*pattern)) : UCHAR(*pattern));
pattern++;
} else {
pattern += TclUtfToUCS4(pattern, &endChar);
if (nocase) {
endChar = TclUCS4ToLower(endChar);
}
}
if (((startChar <= ch1) && (ch1 <= endChar))
|| ((endChar <= ch1) && (ch1 <= startChar))) {
/*
* Matches ranges of form [a-z] or [z-a].
*/
break;
}
} else if (startChar == ch1) {
break;
}
}
/* If we reach here, we matched. Need to move past closing ] */
while (*pattern != ']') {
if (*pattern == '\0') {
/* We ran out of pattern after matching something in
* (unclosed!) brackets. So long as we ran out of string
* at the same time, we have a match. Otherwise, not. */
return (*str == '\0');
}
pattern++;
}
pattern++;
continue;
}
/*
* If the next pattern character is '\', just strip off the '\' so we
* do exact matching on the character that follows.
*/
if (p == '\\') {
pattern++;
if (*pattern == '\0') {
return 0;
}
}
/*
* There's no special character. Just make sure that the next bytes of
* each string match.
*/
str += TclUtfToUCS4(str, &ch1);
pattern += TclUtfToUCS4(pattern, &ch2);
if (nocase) {
if (TclUCS4ToLower(ch1) != TclUCS4ToLower(ch2)) {
return 0;
}
} else if (ch1 != ch2) {
return 0;
}
}
}
/*
*----------------------------------------------------------------------
*
* TclByteArrayMatch --
*
* See if a particular string matches a particular pattern. Does not
* allow for case insensitivity.
* Parallels tclUtf.c:TclUniCharMatch, adjusted for char* and sans nocase.
*
* Results:
* The return value is 1 if string matches pattern, and 0 otherwise. The
* matching operation permits the following special characters in the
* pattern: *?\[] (see the manual entry for details on what these mean).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclByteArrayMatch(
const unsigned char *string,/* String. */
int strLen, /* Length of String */
const unsigned char *pattern,
/* Pattern, which may contain special
* characters. */
int ptnLen, /* Length of Pattern */
int flags)
{
const unsigned char *stringEnd, *patternEnd;
unsigned char p;
stringEnd = string + strLen;
patternEnd = pattern + ptnLen;
while (1) {
/*
* See if we're at the end of both the pattern and the string. If so,
* we succeeded. If we're at the end of the pattern but not at the end
* of the string, we failed.
*/
if (pattern == patternEnd) {
return (string == stringEnd);
}
p = *pattern;
if ((string == stringEnd) && (p != '*')) {
return 0;
}
/*
* Check for a "*" as the next pattern character. It matches any
* substring. We handle this by skipping all the characters up to the
* next matching one in the pattern, and then calling ourselves
* recursively for each postfix of string, until either we match or we
* reach the end of the string.
*/
if (p == '*') {
/*
* Skip all successive *'s in the pattern.
*/
while ((++pattern < patternEnd) && (*pattern == '*')) {
/* empty body */
}
if (pattern == patternEnd) {
return 1;
}
p = *pattern;
while (1) {
/*
* Optimization for matching - cruise through the string
* quickly if the next char in the pattern isn't a special
* character.
*/
if ((p != '[') && (p != '?') && (p != '\\')) {
while ((string < stringEnd) && (p != *string)) {
string++;
}
}
if (TclByteArrayMatch(string, stringEnd - string,
pattern, patternEnd - pattern, 0)) {
return 1;
}
if (string == stringEnd) {
return 0;
}
string++;
}
}
/*
* Check for a "?" as the next pattern character. It matches any
* single character.
*/
if (p == '?') {
pattern++;
string++;
continue;
}
/*
* Check for a "[" as the next pattern character. It is followed by a
* list of characters that are acceptable, or by a range (two
* characters separated by "-").
*/
if (p == '[') {
unsigned char ch1, startChar, endChar;
pattern++;
ch1 = *string;
string++;
while (1) {
if ((*pattern == ']') || (pattern == patternEnd)) {
return 0;
}
startChar = *pattern;
pattern++;
if (*pattern == '-') {
pattern++;
if (pattern == patternEnd) {
return 0;
}
endChar = *pattern;
pattern++;
if (((startChar <= ch1) && (ch1 <= endChar))
|| ((endChar <= ch1) && (ch1 <= startChar))) {
/*
* Matches ranges of form [a-z] or [z-a].
*/
break;
}
} else if (startChar == ch1) {
break;
}
}
while (*pattern != ']') {
if (pattern == patternEnd) {
pattern--;
break;
}
pattern++;
}
pattern++;
continue;
}
/*
* If the next pattern character is '\', just strip off the '\' so we
* do exact matching on the character that follows.
*/
if (p == '\\') {
if (++pattern == patternEnd) {
return 0;
}
}
/*
* There's no special character. Just make sure that the next bytes of
* each string match.
*/
if (*string != *pattern) {
return 0;
}
string++;
pattern++;
}
}
/*
*----------------------------------------------------------------------
*
* TclStringMatchObj --
*
* See if a particular string matches a particular pattern. Allows case
* insensitivity. This is the generic multi-type handler for the various
* matching algorithms.
*
* Results:
* The return value is 1 if string matches pattern, and 0 otherwise. The
* matching operation permits the following special characters in the
* pattern: *?\[] (see the manual entry for details on what these mean).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclStringMatchObj(
Tcl_Obj *strObj, /* string object. */
Tcl_Obj *ptnObj, /* pattern object. */
int flags) /* Only TCL_MATCH_NOCASE should be passed, or
* 0. */
{
int match, length, plen;
/*
* Promote based on the type of incoming object.
* XXX: Currently doesn't take advantage of exact-ness that
* XXX: TclReToGlob tells us about
trivial = nocase ? 0 : TclMatchIsTrivial(TclGetString(ptnObj));
*/
if ((strObj->typePtr == &tclStringType) || (strObj->typePtr == NULL)) {
Tcl_UniChar *udata, *uptn;
udata = Tcl_GetUnicodeFromObj(strObj, &length);
uptn = Tcl_GetUnicodeFromObj(ptnObj, &plen);
match = TclUniCharMatch(udata, length, uptn, plen, flags);
} else if (TclIsPureByteArray(strObj) && TclIsPureByteArray(ptnObj)
&& !flags) {
unsigned char *data, *ptn;
data = Tcl_GetByteArrayFromObj(strObj, &length);
ptn = Tcl_GetByteArrayFromObj(ptnObj, &plen);
match = TclByteArrayMatch(data, length, ptn, plen, 0);
} else {
match = Tcl_StringCaseMatch(TclGetString(strObj),
TclGetString(ptnObj), flags);
}
return match;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DStringInit --
*
* Initializes a dynamic string, discarding any previous contents of the
* string (Tcl_DStringFree should have been called already if the dynamic
* string was previously in use).
*
* Results:
* None.
*
* Side effects:
* The dynamic string is initialized to be empty.
*
*----------------------------------------------------------------------
*/
void
Tcl_DStringInit(
Tcl_DString *dsPtr) /* Pointer to structure for dynamic string. */
{
dsPtr->string = dsPtr->staticSpace;
dsPtr->length = 0;
dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
dsPtr->staticSpace[0] = '\0';
}
/*
*----------------------------------------------------------------------
*
* Tcl_DStringAppend --
*
* Append more bytes to the current value of a dynamic string.
*
* Results:
* The return value is a pointer to the dynamic string's new value.
*
* Side effects:
* Length bytes from "bytes" (or all of "bytes" if length is less than
* zero) are added to the current value of the string. Memory gets
* reallocated if needed to accomodate the string's new size.
*
*----------------------------------------------------------------------
*/
char *
Tcl_DStringAppend(
Tcl_DString *dsPtr, /* Structure describing dynamic string. */
const char *bytes, /* String to append. If length is -1 then this
* must be null-terminated. */
int length) /* Number of bytes from "bytes" to append. If
* < 0, then append all of bytes, up to null
* at end. */
{
int newSize;
if (length < 0) {
length = strlen(bytes);
}
newSize = length + dsPtr->length;
/*
* Allocate a larger buffer for the string if the current one isn't large
* enough. Allocate extra space in the new buffer so that there will be
* room to grow before we have to allocate again.
*/
if (newSize >= dsPtr->spaceAvl) {
dsPtr->spaceAvl = newSize * 2;
if (dsPtr->string == dsPtr->staticSpace) {
char *newString = (char *)ckalloc(dsPtr->spaceAvl);
memcpy(newString, dsPtr->string, dsPtr->length);
dsPtr->string = newString;
} else {
int offset = -1;
/* See [16896d49fd] */
if (bytes >= dsPtr->string
&& bytes <= dsPtr->string + dsPtr->length) {
offset = bytes - dsPtr->string;
}
dsPtr->string = (char *)ckrealloc(dsPtr->string, dsPtr->spaceAvl);
if (offset >= 0) {
bytes = dsPtr->string + offset;
}
}
}
/*
* Copy the new string into the buffer at the end of the old one.
*/
memcpy(dsPtr->string + dsPtr->length, bytes, length);
dsPtr->length += length;
dsPtr->string[dsPtr->length] = '\0';
return dsPtr->string;
}
/*
*----------------------------------------------------------------------
*
* TclDStringAppendObj, TclDStringAppendDString --
*
* Simple wrappers round Tcl_DStringAppend that make it easier to append
* from particular sources of strings.
*
*----------------------------------------------------------------------
*/
char *
TclDStringAppendObj(
Tcl_DString *dsPtr,
Tcl_Obj *objPtr)
{
int length;
char *bytes = Tcl_GetStringFromObj(objPtr, &length);
return Tcl_DStringAppend(dsPtr, bytes, length);
}
char *
TclDStringAppendDString(
Tcl_DString *dsPtr,
Tcl_DString *toAppendPtr)
{
return Tcl_DStringAppend(dsPtr, Tcl_DStringValue(toAppendPtr),
Tcl_DStringLength(toAppendPtr));
}
/*
*----------------------------------------------------------------------
*
* Tcl_DStringAppendElement --
*
* Append a list element to the current value of a dynamic string.
*
* Results:
* The return value is a pointer to the dynamic string's new value.
*
* Side effects:
* String is reformatted as a list element and added to the current value
* of the string. Memory gets reallocated if needed to accomodate the
* string's new size.
*
*----------------------------------------------------------------------
*/
char *
Tcl_DStringAppendElement(
Tcl_DString *dsPtr, /* Structure describing dynamic string. */
const char *element) /* String to append. Must be
* null-terminated. */
{
char *dst = dsPtr->string + dsPtr->length;
int needSpace = TclNeedSpace(dsPtr->string, dst);
char flags = 0;
int quoteHash = 1, newSize;
if (needSpace) {
/*
* If we need a space to separate the new element from something
* already ending the string, we're not appending the first element
* of any list, so we need not quote any leading hash character.
*/
quoteHash = 0;
} else {
/*
* We don't need a space, maybe because there's some already there.
* Checking whether we might be appending a first element is a bit
* more involved.
*
* Backtrack over all whitespace.
*/
while ((--dst >= dsPtr->string) && TclIsSpaceProcM(*dst)) {
}
/* Call again without whitespace to confound things. */
quoteHash = !TclNeedSpace(dsPtr->string, dst+1);
}
if (!quoteHash) {
flags |= TCL_DONT_QUOTE_HASH;
}
newSize = dsPtr->length + needSpace + TclScanElement(element, -1, &flags);
if (!quoteHash) {
flags |= TCL_DONT_QUOTE_HASH;
}
/*
* Allocate a larger buffer for the string if the current one isn't large
* enough. Allocate extra space in the new buffer so that there will be
* room to grow before we have to allocate again. SPECIAL NOTE: must use
* memcpy, not strcpy, to copy the string to a larger buffer, since there
* may be embedded NULLs in the string in some cases.
*/
if (newSize >= dsPtr->spaceAvl) {
dsPtr->spaceAvl = newSize * 2;
if (dsPtr->string == dsPtr->staticSpace) {
char *newString = (char *)ckalloc(dsPtr->spaceAvl);
memcpy(newString, dsPtr->string, dsPtr->length);
dsPtr->string = newString;
} else {
int offset = -1;
/* See [16896d49fd] */
if (element >= dsPtr->string
&& element <= dsPtr->string + dsPtr->length) {
offset = element - dsPtr->string;
}
dsPtr->string = (char *)ckrealloc(dsPtr->string, dsPtr->spaceAvl);
if (offset >= 0) {
element = dsPtr->string + offset;
}
}
}
dst = dsPtr->string + dsPtr->length;
/*
* Convert the new string to a list element and copy it into the buffer at
* the end, with a space, if needed.
*/
if (needSpace) {
*dst = ' ';
dst++;
dsPtr->length++;
}
dsPtr->length += TclConvertElement(element, -1, dst, flags);
dsPtr->string[dsPtr->length] = '\0';
return dsPtr->string;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DStringSetLength --
*
* Change the length of a dynamic string. This can cause the string to
* either grow or shrink, depending on the value of length.
*
* Results:
* None.
*
* Side effects:
* The length of dsPtr is changed to length and a null byte is stored at
* that position in the string. If length is larger than the space
* allocated for dsPtr, then a panic occurs.
*
*----------------------------------------------------------------------
*/
void
Tcl_DStringSetLength(
Tcl_DString *dsPtr, /* Structure describing dynamic string. */
int length) /* New length for dynamic string. */
{
int newsize;
if (length < 0) {
length = 0;
}
if (length >= dsPtr->spaceAvl) {
/*
* There are two interesting cases here. In the first case, the user
* may be trying to allocate a large buffer of a specific size. It
* would be wasteful to overallocate that buffer, so we just allocate
* enough for the requested size plus the trailing null byte. In the
* second case, we are growing the buffer incrementally, so we need
* behavior similar to Tcl_DStringAppend. The requested length will
* usually be a small delta above the current spaceAvl, so we'll end
* up doubling the old size. This won't grow the buffer quite as
* quickly, but it should be close enough.
*/
newsize = dsPtr->spaceAvl * 2;
if (length < newsize) {
dsPtr->spaceAvl = newsize;
} else {
dsPtr->spaceAvl = length + 1;
}
if (dsPtr->string == dsPtr->staticSpace) {
char *newString = (char *)ckalloc(dsPtr->spaceAvl);
memcpy(newString, dsPtr->string, dsPtr->length);
dsPtr->string = newString;
} else {
dsPtr->string = (char *)ckrealloc(dsPtr->string, dsPtr->spaceAvl);
}
}
dsPtr->length = length;
dsPtr->string[length] = 0;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DStringFree --
*
* Frees up any memory allocated for the dynamic string and reinitializes
* the string to an empty state.
*
* Results:
* None.
*
* Side effects:
* The previous contents of the dynamic string are lost, and the new
* value is an empty string.
*
*----------------------------------------------------------------------
*/
void
Tcl_DStringFree(
Tcl_DString *dsPtr) /* Structure describing dynamic string. */
{
if (dsPtr->string != dsPtr->staticSpace) {
ckfree(dsPtr->string);
}
dsPtr->string = dsPtr->staticSpace;
dsPtr->length = 0;
dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
dsPtr->staticSpace[0] = '\0';
}
/*
*----------------------------------------------------------------------
*
* Tcl_DStringResult --
*
* This function moves the value of a dynamic string into an interpreter
* as its string result. Afterwards, the dynamic string is reset to an
* empty string.
*
* Results:
* None.
*
* Side effects:
* The string is "moved" to interp's result, and any existing string
* result for interp is freed. dsPtr is reinitialized to an empty string.
*
*----------------------------------------------------------------------
*/
void
Tcl_DStringResult(
Tcl_Interp *interp, /* Interpreter whose result is to be reset. */
Tcl_DString *dsPtr) /* Dynamic string that is to become the
* result of interp. */
{
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, TclDStringToObj(dsPtr));
}
/*
*----------------------------------------------------------------------
*
* Tcl_DStringGetResult --
*
* This function moves an interpreter's result into a dynamic string.
*
* Results:
* None.
*
* Side effects:
* The interpreter's string result is cleared, and the previous contents
* of dsPtr are freed.
*
* If the string result is empty, the object result is moved to the
* string result, then the object result is reset.
*
*----------------------------------------------------------------------
*/
void
Tcl_DStringGetResult(
Tcl_Interp *interp, /* Interpreter whose result is to be reset. */
Tcl_DString *dsPtr) /* Dynamic string that is to become the result
* of interp. */
{
Interp *iPtr = (Interp *) interp;
if (dsPtr->string != dsPtr->staticSpace) {
ckfree(dsPtr->string);
}
/*
* Do more efficient transfer when we know the result is a Tcl_Obj. When
* there's no string result, we only have to deal with two cases:
*
* 1. When the string rep is the empty string, when we don't copy but
* instead use the staticSpace in the DString to hold an empty string.
* 2. When the string rep is not there or there's a real string rep, when
* we use Tcl_GetString to fetch (or generate) the string rep - which
* we know to have been allocated with ckalloc() - and use it to
* populate the DString space. Then, we free the internal rep. and set
* the object's string representation back to the canonical empty
* string.
*/
if (!iPtr->result[0] && iPtr->objResultPtr
&& !Tcl_IsShared(iPtr->objResultPtr)) {
if (iPtr->objResultPtr->bytes == tclEmptyStringRep) {
dsPtr->string = dsPtr->staticSpace;
dsPtr->string[0] = 0;
dsPtr->length = 0;
dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
} else {
dsPtr->string = TclGetString(iPtr->objResultPtr);
dsPtr->length = iPtr->objResultPtr->length;
dsPtr->spaceAvl = dsPtr->length + 1;
TclFreeIntRep(iPtr->objResultPtr);
iPtr->objResultPtr->bytes = tclEmptyStringRep;
iPtr->objResultPtr->length = 0;
}
return;
}
/*
* If the string result is empty, move the object result to the string
* result, then reset the object result.
*/
(void) Tcl_GetStringResult(interp);
dsPtr->length = strlen(iPtr->result);
if (iPtr->freeProc != NULL) {
if (iPtr->freeProc == TCL_DYNAMIC) {
dsPtr->string = iPtr->result;
dsPtr->spaceAvl = dsPtr->length+1;
} else {
dsPtr->string = (char *)ckalloc(dsPtr->length+1);
memcpy(dsPtr->string, iPtr->result, dsPtr->length+1);
iPtr->freeProc(iPtr->result);
}
dsPtr->spaceAvl = dsPtr->length+1;
iPtr->freeProc = NULL;
} else {
if (dsPtr->length < TCL_DSTRING_STATIC_SIZE) {
dsPtr->string = dsPtr->staticSpace;
dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
} else {
dsPtr->string = (char *)ckalloc(dsPtr->length+1);
dsPtr->spaceAvl = dsPtr->length + 1;
}
memcpy(dsPtr->string, iPtr->result, dsPtr->length+1);
}
iPtr->result = iPtr->resultSpace;
iPtr->resultSpace[0] = 0;
}
/*
*----------------------------------------------------------------------
*
* TclDStringToObj --
*
* This function moves a dynamic string's contents to a new Tcl_Obj. Be
* aware that this function does *not* check that the encoding of the
* contents of the dynamic string is correct; this is the caller's
* responsibility to enforce.
*
* Results:
* The newly-allocated untyped (i.e., typePtr==NULL) Tcl_Obj with a
* reference count of zero.
*
* Side effects:
* The string is "moved" to the object. dsPtr is reinitialized to an
* empty string; it does not need to be Tcl_DStringFree'd after this if
* not used further.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclDStringToObj(
Tcl_DString *dsPtr)
{
Tcl_Obj *result;
if (dsPtr->string == dsPtr->staticSpace) {
if (dsPtr->length == 0) {
TclNewObj(result);
} else {
/*
* Static buffer, so must copy.
*/
TclNewStringObj(result, dsPtr->string, dsPtr->length);
}
} else {
/*
* Dynamic buffer, so transfer ownership and reset.
*/
TclNewObj(result);
result->bytes = dsPtr->string;
result->length = dsPtr->length;
}
/*
* Re-establish the DString as empty with no buffer allocated.
*/
dsPtr->string = dsPtr->staticSpace;
dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
dsPtr->length = 0;
dsPtr->staticSpace[0] = '\0';
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DStringStartSublist --
*
* This function adds the necessary information to a dynamic string
* (e.g. " {") to start a sublist. Future element appends will be in the
* sublist rather than the main list.
*
* Results:
* None.
*
* Side effects:
* Characters get added to the dynamic string.
*
*----------------------------------------------------------------------
*/
void
Tcl_DStringStartSublist(
Tcl_DString *dsPtr) /* Dynamic string. */
{
if (TclNeedSpace(dsPtr->string, dsPtr->string + dsPtr->length)) {
TclDStringAppendLiteral(dsPtr, " {");
} else {
TclDStringAppendLiteral(dsPtr, "{");
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_DStringEndSublist --
*
* This function adds the necessary characters to a dynamic string to end
* a sublist (e.g. "}"). Future element appends will be in the enclosing
* (sub)list rather than the current sublist.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
Tcl_DStringEndSublist(
Tcl_DString *dsPtr) /* Dynamic string. */
{
TclDStringAppendLiteral(dsPtr, "}");
}
/*
*----------------------------------------------------------------------
*
* Tcl_PrintDouble --
*
* Given a floating-point value, this function converts it to an ASCII
* string using.
*
* Results:
* The ASCII equivalent of "value" is written at "dst". It is written
* using the current precision, and it is guaranteed to contain a decimal
* point or exponent, so that it looks like a floating-point value and
* not an integer.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
Tcl_PrintDouble(
Tcl_Interp *interp, /* Interpreter whose tcl_precision variable
* used to be used to control printing. It's
* ignored now. */
double value, /* Value to print as string. */
char *dst) /* Where to store converted value; must have
* at least TCL_DOUBLE_SPACE characters. */
{
char *p, c;
int exponent;
int signum;
char *digits;
char *end;
int *precisionPtr = (int *)Tcl_GetThreadData(&precisionKey, sizeof(int));
/*
* Handle NaN.
*/
if (TclIsNaN(value)) {
TclFormatNaN(value, dst);
return;
}
/*
* Handle infinities.
*/
if (TclIsInfinite(value)) {
/*
* Remember to copy the terminating NUL too.
*/
if (value < 0) {
memcpy(dst, "-Inf", 5);
} else {
memcpy(dst, "Inf", 4);
}
return;
}
/*
* Ordinary (normal and denormal) values.
*/
if (*precisionPtr == 0) {
digits = TclDoubleDigits(value, -1, TCL_DD_SHORTEST,
&exponent, &signum, &end);
} else {
/*
* There are at least two possible interpretations for tcl_precision.
*
* The first is, "choose the decimal representation having
* $tcl_precision digits of significance that is nearest to the given
* number, breaking ties by rounding to even, and then trimming
* trailing zeros." This gives the greatest possible precision in the
* decimal string, but offers the anomaly that [expr 0.1] will be
* "0.10000000000000001".
*
* The second is "choose the decimal representation having at most
* $tcl_precision digits of significance that is nearest to the given
* number. If no such representation converts exactly to the given
* number, choose the one that is closest, breaking ties by rounding
* to even. If more than one such representation converts exactly to
* the given number, choose the shortest, breaking ties in favour of
* the nearest, breaking remaining ties in favour of the one ending in
* an even digit."
*
* Tcl 8.4 implements the first of these, which gives rise to
* anomalies in formatting:
*
* % expr 0.1
* 0.10000000000000001
* % expr 0.01
* 0.01
* % expr 1e-7
* 9.9999999999999995e-08
*
* For human readability, it appears better to choose the second rule,
* and let [expr 0.1] return 0.1. But for 8.4 compatibility, we prefer
* the first (the recommended zero value for tcl_precision avoids the
* problem entirely).
*
* Uncomment TCL_DD_SHORTEN_FLAG in the next call to prefer the method
* that allows floating point values to be shortened if it can be done
* without loss of precision.
*/
digits = TclDoubleDigits(value, *precisionPtr,
TCL_DD_E_FORMAT /* | TCL_DD_SHORTEN_FLAG */,
&exponent, &signum, &end);
}
if (signum) {
*dst++ = '-';
}
p = digits;
if (exponent < -4 || exponent > 16) {
/*
* E format for numbers < 1e-3 or >= 1e17.
*/
*dst++ = *p++;
c = *p;
if (c != '\0') {
*dst++ = '.';
while (c != '\0') {
*dst++ = c;
c = *++p;
}
}
/*
* Tcl 8.4 appears to format with at least a two-digit exponent;
* preserve that behaviour when tcl_precision != 0
*/
if (*precisionPtr == 0) {
sprintf(dst, "e%+d", exponent);
} else {
sprintf(dst, "e%+03d", exponent);
}
} else {
/*
* F format for others.
*/
if (exponent < 0) {
*dst++ = '0';
}
c = *p;
while (exponent-- >= 0) {
if (c != '\0') {
*dst++ = c;
c = *++p;
} else {
*dst++ = '0';
}
}
*dst++ = '.';
if (c == '\0') {
*dst++ = '0';
} else {
while (++exponent < -1) {
*dst++ = '0';
}
while (c != '\0') {
*dst++ = c;
c = *++p;
}
}
*dst++ = '\0';
}
ckfree(digits);
}
/*
*----------------------------------------------------------------------
*
* TclPrecTraceProc --
*
* This function is invoked whenever the variable "tcl_precision" is
* written.
*
* Results:
* Returns NULL if all went well, or an error message if the new value
* for the variable doesn't make sense.
*
* Side effects:
* If the new value doesn't make sense then this function undoes the
* effect of the variable modification. Otherwise it modifies the format
* string that's used by Tcl_PrintDouble.
*
*----------------------------------------------------------------------
*/
char *
TclPrecTraceProc(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Interpreter containing variable. */
const char *name1, /* Name of variable. */
const char *name2, /* Second part of variable name. */
int flags) /* Information about what happened. */
{
Tcl_Obj *value;
int prec;
int *precisionPtr = (int *)Tcl_GetThreadData(&precisionKey, sizeof(int));
/*
* If the variable is unset, then recreate the trace.
*/
if (flags & TCL_TRACE_UNSETS) {
if ((flags & TCL_TRACE_DESTROYED) && !Tcl_InterpDeleted(interp)) {
Tcl_TraceVar2(interp, name1, name2,
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES
|TCL_TRACE_UNSETS, TclPrecTraceProc, clientData);
}
return NULL;
}
/*
* When the variable is read, reset its value from our shared value. This
* is needed in case the variable was modified in some other interpreter
* so that this interpreter's value is out of date.
*/
if (flags & TCL_TRACE_READS) {
Tcl_SetVar2Ex(interp, name1, name2, Tcl_NewIntObj(*precisionPtr),
flags & TCL_GLOBAL_ONLY);
return NULL;
}
/*
* The variable is being written. Check the new value and disallow it if
* it isn't reasonable or if this is a safe interpreter (we don't want
* safe interpreters messing up the precision of other interpreters).
*/
if (Tcl_IsSafe(interp)) {
return (char *) "can't modify precision from a safe interpreter";
}
value = Tcl_GetVar2Ex(interp, name1, name2, flags & TCL_GLOBAL_ONLY);
if (value == NULL
|| Tcl_GetIntFromObj(NULL, value, &prec) != TCL_OK
|| prec < 0 || prec > TCL_MAX_PREC) {
return (char *) "improper value for precision";
}
*precisionPtr = prec;
return NULL;
}
/*
*----------------------------------------------------------------------
*
* TclNeedSpace --
*
* This function checks to see whether it is appropriate to add a space
* before appending a new list element to an existing string.
*
* Results:
* The return value is 1 if a space is appropriate, 0 otherwise.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclNeedSpace(
const char *start, /* First character in string. */
const char *end) /* End of string (place where space will be
* added, if appropriate). */
{
/*
* A space is needed unless either:
* (a) we're at the start of the string, or
*
* (NOTE: This check is now absorbed into the loop below.)
*
if (end == start) {
return 0;
}
*
*/
/*
* (b) we're at the start of a nested list-element, quoted with an open
* curly brace; we can be nested arbitrarily deep, so long as the
* first curly brace starts an element, so backtrack over open curly
* braces that are trailing characters of the string; and
*
* (NOTE: Every character our parser is looking for is a proper
* single-byte encoding of an ASCII value. It does not accept
* overlong encodings. Given that, there's no benefit using
* Tcl_UtfPrev. If it would find what we seek, so would byte-by-byte
* backward scan. Save routine call overhead and risk of wrong
* results should the behavior of Tcl_UtfPrev change in unexpected ways.
* Reconsider this if we ever start treating non-ASCII Unicode
* characters as meaningful list syntax, expanded Unicode spaces as
* element separators, for example.)
*
end = Tcl_UtfPrev(end, start);
while (*end == '{') {
if (end == start) {
return 0;
}
end = Tcl_UtfPrev(end, start);
}
*
*/
while ((--end >= start) && (*end == '{')) {
}
if (end < start) {
return 0;
}
/*
* (c) the trailing character of the string is already a list-element
* separator, Use the same testing routine as TclFindElement to
* enforce consistency.
*/
if (TclIsSpaceProcM(*end)) {
int result = 0;
/*
* Trailing whitespace might be part of a backslash escape
* sequence. Handle that possibility.
*/
while ((--end >= start) && (*end == '\\')) {
result = !result;
}
return result;
}
return 1;
}
/*
*----------------------------------------------------------------------
*
* TclFormatInt --
*
* This procedure formats an integer into a sequence of decimal digit
* characters in a buffer. If the integer is negative, a minus sign is
* inserted at the start of the buffer. A null character is inserted at
* the end of the formatted characters. It is the caller's responsibility
* to ensure that enough storage is available. This procedure has the
* effect of sprintf(buffer, "%ld", n) but is faster as proven in
* benchmarks. This is key to UpdateStringOfInt, which is a common path
* for a lot of code (e.g. int-indexed arrays).
*
* Results:
* An integer representing the number of characters formatted, not
* including the terminating \0.
*
* Side effects:
* The formatted characters are written into the storage pointer to by
* the "buffer" argument.
*
*----------------------------------------------------------------------
*/
int
TclFormatInt(
char *buffer, /* Points to the storage into which the
* formatted characters are written. */
long n) /* The integer to format. */
{
unsigned long intVal;
int i = 0;
int numFormatted, j;
static const char digits[] = "0123456789";
/*
* Generate the characters of the result backwards in the buffer.
*/
intVal = (n < 0 ? -(unsigned long)n : (unsigned long)n);
do {
buffer[i++] = digits[intVal % 10];
intVal = intVal / 10;
} while (intVal > 0);
if (n < 0) {
buffer[i++] = '-';
}
buffer[i] = '\0';
numFormatted = i--;
/*
* Now reverse the characters.
*/
for (j = 0; j < i; j++, i--) {
char tmp = buffer[i];
buffer[i] = buffer[j];
buffer[j] = tmp;
}
return numFormatted;
}
/*
*----------------------------------------------------------------------
*
* TclGetIntForIndex --
*
* Provides an integer corresponding to the list index held in a Tcl
* object. The string value 'objPtr' is expected have the format
* integer([+-]integer)? or end([+-]integer)?.
*
* Value
* TCL_OK
*
* The index is stored at the address given by by 'indexPtr'. If
* 'objPtr' has the value "end", the value stored is 'endValue'.
*
* TCL_ERROR
*
* The value of 'objPtr' does not have one of the expected formats. If
* 'interp' is non-NULL, an error message is left in the interpreter's
* result object.
*
* Effect
*
* The object referenced by 'objPtr' is converted, as needed, to an
* integer, wide integer, or end-based-index object.
*
*----------------------------------------------------------------------
*/
int
TclGetIntForIndex(
Tcl_Interp *interp, /* Interpreter to use for error reporting. If
* NULL, then no error message is left after
* errors. */
Tcl_Obj *objPtr, /* Points to an object containing either "end"
* or an integer. */
int endValue, /* The value to be stored at "indexPtr" if
* "objPtr" holds "end". */
int *indexPtr) /* Location filled in with an integer
* representing an index. */
{
int length;
char *opPtr;
const char *bytes;
if (TclGetIntFromObj(NULL, objPtr, indexPtr) == TCL_OK) {
return TCL_OK;
}
if (GetEndOffsetFromObj(objPtr, endValue, indexPtr) == TCL_OK) {
return TCL_OK;
}
bytes = TclGetStringFromObj(objPtr, &length);
/*
* Leading whitespace is acceptable in an index.
*/
while (length && TclIsSpaceProcM(*bytes)) {
bytes++;
length--;
}
if (TclParseNumber(NULL, NULL, NULL, bytes, length, (const char **)&opPtr,
TCL_PARSE_INTEGER_ONLY | TCL_PARSE_NO_WHITESPACE) == TCL_OK) {
int code, first, second;
char savedOp = *opPtr;
if ((savedOp != '+') && (savedOp != '-')) {
goto parseError;
}
if (TclIsSpaceProcM(opPtr[1])) {
goto parseError;
}
*opPtr = '\0';
code = Tcl_GetInt(interp, bytes, &first);
*opPtr = savedOp;
if (code == TCL_ERROR) {
goto parseError;
}
if (TCL_ERROR == Tcl_GetInt(interp, opPtr+1, &second)) {
goto parseError;
}
if (savedOp == '+') {
*indexPtr = first + second;
} else {
*indexPtr = first - second;
}
return TCL_OK;
}
/*
* Report a parse error.
*/
parseError:
if (interp != NULL) {
bytes = TclGetString(objPtr);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad index \"%s\": must be integer?[+-]integer? or"
" end?[+-]integer?", bytes));
if (!strncmp(bytes, "end-", 4)) {
bytes += 4;
}
TclCheckBadOctal(interp, bytes);
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL);
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* UpdateStringOfEndOffset --
*
* Update the string rep of a Tcl object holding an "end-offset"
* expression.
*
* Results:
* None.
*
* Side effects:
* Stores a valid string in the object's string rep.
*
* This function does NOT free any earlier string rep. If it is called on an
* object that already has a valid string rep, it will leak memory.
*
*----------------------------------------------------------------------
*/
static void
UpdateStringOfEndOffset(
Tcl_Obj *objPtr)
{
char buffer[TCL_INTEGER_SPACE + 5];
int len = 3;
memcpy(buffer, "end", 4);
if (objPtr->internalRep.longValue != 0) {
buffer[len++] = '-';
len += TclFormatInt(buffer+len, -(objPtr->internalRep.longValue));
}
objPtr->bytes = (char *)ckalloc(len+1);
memcpy(objPtr->bytes, buffer, len+1);
objPtr->length = len;
}
/*
*----------------------------------------------------------------------
*
* GetEndOffsetFromObj --
*
* Look for a string of the form "end[+-]offset" and convert it to an
* internal representation holding the offset.
*
* Results:
* Tcl return code.
*
* Side effects:
* May store a Tcl_ObjType.
*
*----------------------------------------------------------------------
*/
static int
GetEndOffsetFromObj(
Tcl_Obj *objPtr, /* Pointer to the object to parse */
int endValue, /* The value to be stored at "indexPtr" if
* "objPtr" holds "end". */
int *indexPtr) /* Location filled in with an integer
* representing an index. */
{
if (SetEndOffsetFromAny(NULL, objPtr) != TCL_OK) {
return TCL_ERROR;
}
/* TODO: Handle overflow cases sensibly */
*indexPtr = endValue + (int)objPtr->internalRep.longValue;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* SetEndOffsetFromAny --
*
* Look for a string of the form "end[+-]offset" and convert it to an
* internal representation holding the offset.
*
* Results:
* Returns TCL_OK if ok, TCL_ERROR if the string was badly formed.
*
* Side effects:
* If interp is not NULL, stores an error message in the interpreter
* result.
*
*----------------------------------------------------------------------
*/
static int
SetEndOffsetFromAny(
Tcl_Interp *interp, /* Tcl interpreter or NULL */
Tcl_Obj *objPtr) /* Pointer to the object to parse */
{
int offset; /* Offset in the "end-offset" expression */
const char *bytes; /* String rep of the object */
int length; /* Length of the object's string rep */
/*
* If it's already the right type, we're fine.
*/
if (objPtr->typePtr == &tclEndOffsetType) {
return TCL_OK;
}
/*
* Check for a string rep of the right form.
*/
bytes = TclGetStringFromObj(objPtr, &length);
if ((*bytes != 'e') || (strncmp(bytes, "end",
(size_t)((length > 3) ? 3 : length)) != 0)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad index \"%s\": must be end?[+-]integer?", bytes));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL);
}
return TCL_ERROR;
}
/*
* Convert the string rep.
*/
if (length <= 3) {
offset = 0;
} else if ((length > 4) && ((bytes[3] == '-') || (bytes[3] == '+'))) {
/*
* This is our limited string expression evaluator. Pass everything
* after "end-" to Tcl_GetInt, then reverse for offset.
*/
if (TclIsSpaceProcM(bytes[4])) {
goto badIndexFormat;
}
if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) {
return TCL_ERROR;
}
if (bytes[3] == '-') {
/* TODO: Review overflow concerns here! */
offset = -offset;
}
} else {
/*
* Conversion failed. Report the error.
*/
badIndexFormat:
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad index \"%s\": must be end?[+-]integer?", bytes));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL);
}
return TCL_ERROR;
}
/*
* The conversion succeeded. Free the old internal rep and set the new
* one.
*/
TclFreeIntRep(objPtr);
objPtr->internalRep.longValue = offset;
objPtr->typePtr = &tclEndOffsetType;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclIndexEncode --
*
* Parse objPtr to determine if it is an index value. Two cases
* are possible. The value objPtr might be parsed as an absolute
* index value in the C signed int range. Note that this includes
* index values that are integers as presented and it includes index
* arithmetic expressions. The absolute index values that can be
* directly meaningful as an index into either a list or a string are
* those integer values >= TCL_INDEX_START (0)
* and < TCL_INDEX_AFTER (INT_MAX).
* The largest string supported in Tcl 8 has bytelength INT_MAX.
* This means the largest supported character length is also INT_MAX,
* and the index of the last character in a string of length INT_MAX
* is INT_MAX-1.
*
* Any absolute index value parsed outside that range is encoded
* using the before and after values passed in by the
* caller as the encoding to use for indices that are either
* less than or greater than the usable index range. TCL_INDEX_AFTER
* is available as a good choice for most callers to use for
* after. Likewise, the value TCL_INDEX_BEFORE is good for
* most callers to use for before. Other values are possible
* when the caller knows it is helpful in producing its own behavior
* for indices before and after the indexed item.
*
* A token can also be parsed as an end-relative index expression.
* All end-relative expressions that indicate an index larger
* than end (end+2, end--5) point beyond the end of the indexed
* collection, and can be encoded as after. The end-relative
* expressions that indicate an index less than or equal to end
* are encoded relative to the value TCL_INDEX_END (-2). The
* index "end" is encoded as -2, down to the index "end-0x7FFFFFFE"
* which is encoded as INT_MIN. Since the largest index into a
* string possible in Tcl 8 is 0x7FFFFFFE, the interpretation of
* "end-0x7FFFFFFE" for that largest string would be 0. Thus,
* if the tokens "end-0x7FFFFFFF" or "end+-0x80000000" are parsed,
* they can be encoded with the before value.
*
* These details will require re-examination whenever string and
* list length limits are increased, but that will likely also
* mean a revised routine capable of returning Tcl_WideInt values.
*
* Returns:
* TCL_OK if parsing succeeded, and TCL_ERROR if it failed.
*
* Side effects:
* When TCL_OK is returned, the encoded index value is written
* to *indexPtr.
*
*----------------------------------------------------------------------
*/
int
TclIndexEncode(
Tcl_Interp *interp, /* For error reporting, may be NULL */
Tcl_Obj *objPtr, /* Index value to parse */
int before, /* Value to return for index before beginning */
int after, /* Value to return for index after end */
int *indexPtr) /* Where to write the encoded answer, not NULL */
{
int idx;
if (TCL_OK == TclGetIntFromObj(NULL, objPtr, &idx)) {
/* We parsed a value in the range INT_MIN...INT_MAX */
integerEncode:
if (idx < TCL_INDEX_START) {
/* All negative absolute indices are "before the beginning" */
idx = before;
} else if (idx == INT_MAX) {
/* This index value is always "after the end" */
idx = after;
}
/* usual case, the absolute index value encodes itself */
} else if (TCL_OK == GetEndOffsetFromObj(objPtr, 0, &idx)) {
/*
* We parsed an end+offset index value.
* idx holds the offset value in the range INT_MIN...INT_MAX.
*/
if (idx > 0) {
/*
* All end+postive or end-negative expressions
* always indicate "after the end".
*/
idx = after;
} else if (idx < INT_MIN - TCL_INDEX_END) {
/* These indices always indicate "before the beginning */
idx = before;
} else {
/* Encoded end-positive (or end+negative) are offset */
idx += TCL_INDEX_END;
}
/* TODO: Consider flag to suppress repeated end-offset parse. */
} else if (TCL_OK == TclGetIntForIndexM(interp, objPtr, 0, &idx)) {
/*
* Only reach this case when the index value is a
* constant index arithmetic expression, and idx
* holds the result. Treat it the same as if it were
* parsed as an absolute integer value.
*/
goto integerEncode;
} else {
return TCL_ERROR;
}
*indexPtr = idx;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclIndexDecode --
*
* Decodes a value previously encoded by TclIndexEncode. The argument
* endValue indicates what value of "end" should be used in the
* decoding.
*
* Results:
* The decoded index value.
*
*----------------------------------------------------------------------
*/
int
TclIndexDecode(
int encoded, /* Value to decode */
int endValue) /* Meaning of "end" to use, > TCL_INDEX_END */
{
if (encoded <= TCL_INDEX_END) {
return (encoded - TCL_INDEX_END) + endValue;
}
return encoded;
}
/*
*----------------------------------------------------------------------
*
* TclCheckBadOctal --
*
* This function checks for a bad octal value and appends a meaningful
* error to the interp's result.
*
* Results:
* 1 if the argument was a bad octal, else 0.
*
* Side effects:
* The interpreter's result is modified.
*
*----------------------------------------------------------------------
*/
int
TclCheckBadOctal(
Tcl_Interp *interp, /* Interpreter to use for error reporting. If
* NULL, then no error message is left after
* errors. */
const char *value) /* String to check. */
{
const char *p = value;
/*
* A frequent mistake is invalid octal values due to an unwanted leading
* zero. Try to generate a meaningful error message.
*/
while (TclIsSpaceProcM(*p)) {
p++;
}
if (*p == '+' || *p == '-') {
p++;
}
if (*p == '0') {
if ((p[1] == 'o') || p[1] == 'O') {
p += 2;
}
while (isdigit(UCHAR(*p))) { /* INTL: digit. */
p++;
}
while (TclIsSpaceProcM(*p)) {
p++;
}
if (*p == '\0') {
/*
* Reached end of string.
*/
if (interp != NULL) {
/*
* Don't reset the result here because we want this result to
* be added to an existing error message as extra info.
*/
Tcl_AppendToObj(Tcl_GetObjResult(interp),
" (looks like invalid octal number)", -1);
}
return 1;
}
}
return 0;
}
/*
*----------------------------------------------------------------------
*
* ClearHash --
*
* Remove all the entries in the hash table *tablePtr.
*
*----------------------------------------------------------------------
*/
static void
ClearHash(
Tcl_HashTable *tablePtr)
{
Tcl_HashSearch search;
Tcl_HashEntry *hPtr;
for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
Tcl_Obj *objPtr = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
Tcl_DecrRefCount(objPtr);
Tcl_DeleteHashEntry(hPtr);
}
}
/*
*----------------------------------------------------------------------
*
* GetThreadHash --
*
* Get a thread-specific (Tcl_HashTable *) associated with a thread data
* key.
*
* Results:
* The Tcl_HashTable * corresponding to *keyPtr.
*
* Side effects:
* The first call on a keyPtr in each thread creates a new Tcl_HashTable,
* and registers a thread exit handler to dispose of it.
*
*----------------------------------------------------------------------
*/
static Tcl_HashTable *
GetThreadHash(
Tcl_ThreadDataKey *keyPtr)
{
Tcl_HashTable **tablePtrPtr =
(Tcl_HashTable **)Tcl_GetThreadData(keyPtr, sizeof(Tcl_HashTable *));
if (NULL == *tablePtrPtr) {
*tablePtrPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_CreateThreadExitHandler(FreeThreadHash, *tablePtrPtr);
Tcl_InitHashTable(*tablePtrPtr, TCL_ONE_WORD_KEYS);
}
return *tablePtrPtr;
}
/*
*----------------------------------------------------------------------
*
* FreeThreadHash --
*
* Thread exit handler used by GetThreadHash to dispose of a thread hash
* table.
*
* Side effects:
* Frees a Tcl_HashTable.
*
*----------------------------------------------------------------------
*/
static void
FreeThreadHash(
ClientData clientData)
{
Tcl_HashTable *tablePtr = (Tcl_HashTable *)clientData;
ClearHash(tablePtr);
Tcl_DeleteHashTable(tablePtr);
ckfree(tablePtr);
}
/*
*----------------------------------------------------------------------
*
* FreeProcessGlobalValue --
*
* Exit handler used by Tcl(Set|Get)ProcessGlobalValue to cleanup a
* ProcessGlobalValue at exit.
*
*----------------------------------------------------------------------
*/
static void
FreeProcessGlobalValue(
ClientData clientData)
{
ProcessGlobalValue *pgvPtr = (ProcessGlobalValue *)clientData;
pgvPtr->epoch++;
pgvPtr->numBytes = 0;
ckfree(pgvPtr->value);
pgvPtr->value = NULL;
if (pgvPtr->encoding) {
Tcl_FreeEncoding(pgvPtr->encoding);
pgvPtr->encoding = NULL;
}
Tcl_MutexFinalize(&pgvPtr->mutex);
}
/*
*----------------------------------------------------------------------
*
* TclSetProcessGlobalValue --
*
* Utility routine to set a global value shared by all threads in the
* process while keeping a thread-local copy as well.
*
*----------------------------------------------------------------------
*/
void
TclSetProcessGlobalValue(
ProcessGlobalValue *pgvPtr,
Tcl_Obj *newValue,
Tcl_Encoding encoding)
{
const char *bytes;
Tcl_HashTable *cacheMap;
Tcl_HashEntry *hPtr;
int dummy;
Tcl_MutexLock(&pgvPtr->mutex);
/*
* Fill the global string value.
*/
pgvPtr->epoch++;
if (NULL != pgvPtr->value) {
ckfree(pgvPtr->value);
} else {
Tcl_CreateExitHandler(FreeProcessGlobalValue, pgvPtr);
}
bytes = Tcl_GetStringFromObj(newValue, &pgvPtr->numBytes);
pgvPtr->value = (char *)ckalloc(pgvPtr->numBytes + 1);
memcpy(pgvPtr->value, bytes, pgvPtr->numBytes + 1);
if (pgvPtr->encoding) {
Tcl_FreeEncoding(pgvPtr->encoding);
}
pgvPtr->encoding = encoding;
/*
* Fill the local thread copy directly with the Tcl_Obj value to avoid
* loss of the internalrep. Increment newValue refCount early to handle case
* where we set a PGV to itself.
*/
Tcl_IncrRefCount(newValue);
cacheMap = GetThreadHash(&pgvPtr->key);
ClearHash(cacheMap);
hPtr = Tcl_CreateHashEntry(cacheMap, INT2PTR(pgvPtr->epoch), &dummy);
Tcl_SetHashValue(hPtr, newValue);
Tcl_MutexUnlock(&pgvPtr->mutex);
}
/*
*----------------------------------------------------------------------
*
* TclGetProcessGlobalValue --
*
* Retrieve a global value shared among all threads of the process,
* preferring a thread-local copy as long as it remains valid.
*
* Results:
* Returns a (Tcl_Obj *) that holds a copy of the global value.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclGetProcessGlobalValue(
ProcessGlobalValue *pgvPtr)
{
Tcl_Obj *value = NULL;
Tcl_HashTable *cacheMap;
Tcl_HashEntry *hPtr;
int epoch = pgvPtr->epoch;
if (pgvPtr->encoding) {
Tcl_Encoding current = Tcl_GetEncoding(NULL, NULL);
if (pgvPtr->encoding != current) {
/*
* The system encoding has changed since the global string value
* was saved. Convert the global value to be based on the new
* system encoding.
*/
Tcl_DString native, newValue;
Tcl_MutexLock(&pgvPtr->mutex);
epoch = ++pgvPtr->epoch;
Tcl_UtfToExternalDString(pgvPtr->encoding, pgvPtr->value,
pgvPtr->numBytes, &native);
Tcl_ExternalToUtfDString(current, Tcl_DStringValue(&native),
Tcl_DStringLength(&native), &newValue);
Tcl_DStringFree(&native);
ckfree(pgvPtr->value);
pgvPtr->value = (char *)ckalloc(Tcl_DStringLength(&newValue) + 1);
memcpy(pgvPtr->value, Tcl_DStringValue(&newValue),
Tcl_DStringLength(&newValue) + 1);
Tcl_DStringFree(&newValue);
Tcl_FreeEncoding(pgvPtr->encoding);
pgvPtr->encoding = current;
Tcl_MutexUnlock(&pgvPtr->mutex);
} else {
Tcl_FreeEncoding(current);
}
}
cacheMap = GetThreadHash(&pgvPtr->key);
hPtr = Tcl_FindHashEntry(cacheMap, INT2PTR(epoch));
if (NULL == hPtr) {
int dummy;
/*
* No cache for the current epoch - must be a new one.
*
* First, clear the cacheMap, as anything in it must refer to some
* expired epoch.
*/
ClearHash(cacheMap);
/*
* If no thread has set the shared value, call the initializer.
*/
Tcl_MutexLock(&pgvPtr->mutex);
if ((NULL == pgvPtr->value) && (pgvPtr->proc)) {
pgvPtr->epoch++;
pgvPtr->proc(&pgvPtr->value,&pgvPtr->numBytes,&pgvPtr->encoding);
if (pgvPtr->value == NULL) {
Tcl_Panic("PGV Initializer did not initialize");
}
Tcl_CreateExitHandler(FreeProcessGlobalValue, pgvPtr);
}
/*
* Store a copy of the shared value in our epoch-indexed cache.
*/
value = Tcl_NewStringObj(pgvPtr->value, pgvPtr->numBytes);
hPtr = Tcl_CreateHashEntry(cacheMap,
INT2PTR(pgvPtr->epoch), &dummy);
Tcl_MutexUnlock(&pgvPtr->mutex);
Tcl_SetHashValue(hPtr, value);
Tcl_IncrRefCount(value);
}
return (Tcl_Obj *)Tcl_GetHashValue(hPtr);
}
/*
*----------------------------------------------------------------------
*
* TclSetObjNameOfExecutable --
*
* This function stores the absolute pathname of the executable file
* (normally as computed by TclpFindExecutable).
*
* Results:
* None.
*
* Side effects:
* Stores the executable name.
*
*----------------------------------------------------------------------
*/
void
TclSetObjNameOfExecutable(
Tcl_Obj *name,
Tcl_Encoding encoding)
{
TclSetProcessGlobalValue(&executableName, name, encoding);
}
/*
*----------------------------------------------------------------------
*
* TclGetObjNameOfExecutable --
*
* This function retrieves the absolute pathname of the application in
* which the Tcl library is running, usually as previously stored by
* TclpFindExecutable(). This function call is the C API equivalent to
* the "info nameofexecutable" command.
*
* Results:
* A pointer to an "fsPath" Tcl_Obj, or to an empty Tcl_Obj if the
* pathname of the application is unknown.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclGetObjNameOfExecutable(void)
{
return TclGetProcessGlobalValue(&executableName);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetNameOfExecutable --
*
* This function retrieves the absolute pathname of the application in
* which the Tcl library is running, and returns it in string form.
*
* The returned string belongs to Tcl and should be copied if the caller
* plans to keep it, to guard against it becoming invalid.
*
* Results:
* A pointer to the internal string or NULL if the internal full path
* name has not been computed or unknown.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
const char *
Tcl_GetNameOfExecutable(void)
{
int numBytes;
const char *bytes =
Tcl_GetStringFromObj(TclGetObjNameOfExecutable(), &numBytes);
if (numBytes == 0) {
return NULL;
}
return bytes;
}
/*
*----------------------------------------------------------------------
*
* TclpGetTime --
*
* Deprecated synonym for Tcl_GetTime. This function is provided for the
* benefit of extensions written before Tcl_GetTime was exported from the
* library.
*
* Results:
* None.
*
* Side effects:
* Stores current time in the buffer designated by "timePtr"
*
*----------------------------------------------------------------------
*/
void
TclpGetTime(
Tcl_Time *timePtr)
{
Tcl_GetTime(timePtr);
}
/*
*----------------------------------------------------------------------
*
* TclGetPlatform --
*
* This is a kludge that allows the test library to get access the
* internal tclPlatform variable.
*
* Results:
* Returns a pointer to the tclPlatform variable.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
TclPlatformType *
TclGetPlatform(void)
{
return &tclPlatform;
}
/*
*----------------------------------------------------------------------
*
* TclReToGlob --
*
* Attempt to convert a regular expression to an equivalent glob pattern.
*
* Results:
* Returns TCL_OK on success, TCL_ERROR on failure. If interp is not
* NULL, an error message is placed in the result. On success, the
* DString will contain an exact equivalent glob pattern. The caller is
* responsible for calling Tcl_DStringFree on success. If exactPtr is not
* NULL, it will be 1 if an exact match qualifies.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclReToGlob(
Tcl_Interp *interp,
const char *reStr,
int reStrLen,
Tcl_DString *dsPtr,
int *exactPtr,
int *quantifiersFoundPtr)
{
int anchorLeft, anchorRight, lastIsStar, numStars;
char *dsStr, *dsStrStart;
const char *msg, *p, *strEnd, *code;
strEnd = reStr + reStrLen;
Tcl_DStringInit(dsPtr);
if (quantifiersFoundPtr != NULL) {
*quantifiersFoundPtr = 0;
}
/*
* "***=xxx" == "*xxx*", watch for glob-sensitive chars.
*/
if ((reStrLen >= 4) && (memcmp("***=", reStr, 4) == 0)) {
/*
* At most, the glob pattern has length 2*reStrLen + 2 to backslash
* escape every character and have * at each end.
*/
Tcl_DStringSetLength(dsPtr, reStrLen + 2);
dsStr = dsStrStart = Tcl_DStringValue(dsPtr);
*dsStr++ = '*';
for (p = reStr + 4; p < strEnd; p++) {
switch (*p) {
case '\\': case '*': case '[': case ']': case '?':
/* Only add \ where necessary for glob */
*dsStr++ = '\\';
/* fall through */
default:
*dsStr++ = *p;
break;
}
}
*dsStr++ = '*';
Tcl_DStringSetLength(dsPtr, dsStr - dsStrStart);
if (exactPtr) {
*exactPtr = 0;
}
return TCL_OK;
}
/*
* At most, the glob pattern has length reStrLen + 2 to account for
* possible * at each end.
*/
Tcl_DStringSetLength(dsPtr, reStrLen + 2);
dsStr = dsStrStart = Tcl_DStringValue(dsPtr);
/*
* Check for anchored REs (ie ^foo$), so we can use string equal if
* possible. Do not alter the start of str so we can free it correctly.
*
* Keep track of the last char being an unescaped star to prevent multiple
* instances. Simpler than checking that the last star may be escaped.
*/
msg = NULL;
code = NULL;
p = reStr;
anchorRight = 0;
lastIsStar = 0;
numStars = 0;
if (*p == '^') {
anchorLeft = 1;
p++;
} else {
anchorLeft = 0;
*dsStr++ = '*';
lastIsStar = 1;
}
for ( ; p < strEnd; p++) {
switch (*p) {
case '\\':
p++;
switch (*p) {
case 'a':
*dsStr++ = '\a';
break;
case 'b':
*dsStr++ = '\b';
break;
case 'f':
*dsStr++ = '\f';
break;
case 'n':
*dsStr++ = '\n';
break;
case 'r':
*dsStr++ = '\r';
break;
case 't':
*dsStr++ = '\t';
break;
case 'v':
*dsStr++ = '\v';
break;
case 'B': case '\\':
*dsStr++ = '\\';
*dsStr++ = '\\';
anchorLeft = 0; /* prevent exact match */
break;
case '*': case '[': case ']': case '?':
/* Only add \ where necessary for glob */
*dsStr++ = '\\';
anchorLeft = 0; /* prevent exact match */
/* fall through */
case '{': case '}': case '(': case ')': case '+':
case '.': case '|': case '^': case '$':
*dsStr++ = *p;
break;
default:
msg = "invalid escape sequence";
code = "BADESCAPE";
goto invalidGlob;
}
break;
case '.':
if (quantifiersFoundPtr != NULL) {
*quantifiersFoundPtr = 1;
}
anchorLeft = 0; /* prevent exact match */
if (p+1 < strEnd) {
if (p[1] == '*') {
p++;
if (!lastIsStar) {
*dsStr++ = '*';
lastIsStar = 1;
numStars++;
}
continue;
} else if (p[1] == '+') {
p++;
*dsStr++ = '?';
*dsStr++ = '*';
lastIsStar = 1;
numStars++;
continue;
}
}
*dsStr++ = '?';
break;
case '$':
if (p+1 != strEnd) {
msg = "$ not anchor";
code = "NONANCHOR";
goto invalidGlob;
}
anchorRight = 1;
break;
case '*': case '+': case '?': case '|': case '^':
case '{': case '}': case '(': case ')': case '[': case ']':
msg = "unhandled RE special char";
code = "UNHANDLED";
goto invalidGlob;
default:
*dsStr++ = *p;
break;
}
lastIsStar = 0;
}
if (numStars > 1) {
/*
* Heuristic: if >1 non-anchoring *, the risk is large that glob
* matching is slower than the RE engine, so report invalid.
*/
msg = "excessive recursive glob backtrack potential";
code = "OVERCOMPLEX";
goto invalidGlob;
}
if (!anchorRight && !lastIsStar) {
*dsStr++ = '*';
}
Tcl_DStringSetLength(dsPtr, dsStr - dsStrStart);
if (exactPtr) {
*exactPtr = (anchorLeft && anchorRight);
}
return TCL_OK;
invalidGlob:
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1));
Tcl_SetErrorCode(interp, "TCL", "RE2GLOB", code, NULL);
}
Tcl_DStringFree(dsPtr);
return TCL_ERROR;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/