summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2007-11-12 19:18:11 (GMT)
committerdgp <dgp@users.sourceforge.net>2007-11-12 19:18:11 (GMT)
commit19ff89ec05fbfdb2e383a89c9f522e5474f484fd (patch)
tree7795d4849bbe3267bf65b73119c570602cce9a73
parent0a7049c4674056ec95788074fd9275355f9e1b7f (diff)
downloadtcl-19ff89ec05fbfdb2e383a89c9f522e5474f484fd.zip
tcl-19ff89ec05fbfdb2e383a89c9f522e5474f484fd.tar.gz
tcl-19ff89ec05fbfdb2e383a89c9f522e5474f484fd.tar.bz2
merge updates from HEAD
-rw-r--r--ChangeLog196
-rw-r--r--generic/tclAsync.c9
-rw-r--r--generic/tclBasic.c90
-rw-r--r--generic/tclBinary.c37
-rw-r--r--generic/tclClock.c36
-rw-r--r--generic/tclCmdAH.c12
-rw-r--r--generic/tclCmdIL.c72
-rw-r--r--generic/tclCmdMZ.c87
-rw-r--r--generic/tclCompCmds.c140
-rw-r--r--generic/tclCompExpr.c11
-rw-r--r--generic/tclCompile.c7
-rw-r--r--generic/tclCompile.h8
-rw-r--r--generic/tclConfig.c70
-rw-r--r--generic/tclDictObj.c22
-rw-r--r--generic/tclEncoding.c223
-rw-r--r--generic/tclExecute.c124
-rw-r--r--generic/tclGet.c6
-rw-r--r--generic/tclIO.c289
-rw-r--r--generic/tclIOCmd.c84
-rw-r--r--generic/tclIOGT.c4
-rw-r--r--generic/tclIOUtil.c4
-rw-r--r--generic/tclIndexObj.c6
-rw-r--r--generic/tclInt.decls13
-rw-r--r--generic/tclInt.h142
-rw-r--r--generic/tclIntDecls.h26
-rw-r--r--generic/tclInterp.c66
-rw-r--r--generic/tclListObj.c49
-rw-r--r--generic/tclLiteral.c10
-rw-r--r--generic/tclNamesp.c34
-rw-r--r--generic/tclObj.c14
-rw-r--r--generic/tclParse.c6
-rw-r--r--generic/tclProc.c17
-rw-r--r--generic/tclRegexp.c65
-rw-r--r--generic/tclRegexp.h3
-rw-r--r--generic/tclResult.c74
-rw-r--r--generic/tclScan.c8
-rw-r--r--generic/tclStringObj.c34
-rw-r--r--generic/tclStubInit.c4
-rw-r--r--generic/tclStubLib.c3
-rw-r--r--generic/tclUtil.c377
-rw-r--r--generic/tclVar.c14
-rw-r--r--tests/regexpComp.test76
-rw-r--r--tools/Makefile.in4
-rwxr-xr-xunix/configure72
-rw-r--r--unix/configure.in31
-rw-r--r--unix/tclConfig.h.in6
-rw-r--r--unix/tclUnixChan.c30
-rw-r--r--unix/tclUnixInit.c162
-rw-r--r--unix/tclUnixTime.c10
-rw-r--r--win/tclWin32Dll.c172
50 files changed, 2260 insertions, 799 deletions
diff --git a/ChangeLog b/ChangeLog
index deb652b..37aacc8 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,10 +1,180 @@
+2007-11-12 Miguel Sofer <msofer@users.sf.net>
+
+ * generic/tclBasic.c: New macro TclResetResult, new iPtr flag
+ * generic/tclExecute.c: bit INTERP_RESULT_UNCLEAN: shortcut for
+ * generic/tclInt.h: Tcl_ResetResult for the "normal" case:
+ * generic/tclProc.c: TCL_OK, no return options, no errorCode
+ * generic/tclResult.c: nor errorInfo, return at normal level.
+ * generic/tclStubLib.c: [Patch 1830184]
+ * generic/tclUtil.c:
+
+
+2007-11-11 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * generic/tclCompCmds.c, generic/tclCompile.c, generic/tclCompile.h:
+ * generic/tclExecute.c, generic/tclInt.decls, generic/tclIntDecls.h:
+ * generic/tclRegexp.c, generic/tclRegexp.h: Add INST_REGEXP and fully
+ * generic/tclStubInit.c, generic/tclUtil.c: compiled [regexp] for the
+ * tests/regexpComp.test: [Bug 1830166] simple cases. Also
+ added TclReToGlob function to convert RE to glob patterns and use
+ these in the possible cases.
+
+2007-11-11 Miguel Sofer <msofer@users.sf.net>
+
+ * generic/tclResult.c (ResetObjResult): clarify the logic.
+
+ * generic/tclBasic.c: Increased usage of macros to detect
+ * generic/tclBinary.c: and take advantage of objTypes. Added
+ * generic/tclClock.c: macros TclGet(Int|Long)FromObj,
+ * generic/tclCmdAH.c: TclGetIntForIndexM and TclListObjLength,
+ * generic/tclCmdIL.c: modified TclListObjGetElements.
+ * generic/tclCmdMZ.c:
+ * generic/tclCompCmds.c: The TclGetInt* macros are only a shortcut
+ * generic/tclCompExpr.c: on platforms where 'long' is 'int'; it may
+ * generic/tclCompile.c: be worthwhile to extend their functionality
+ * generic/tclDictObj.c: also to other cases.
+ * generic/tclExecute.c:
+ * generic/tclGet.c: As this patch touches many files it has
+ * generic/tclIO.c: been recorded as [Patch 1830038] in order to
+ * generic/tclIOCmd.c: facilitate reviewing.
+ * generic/tclIOGT.c:
+ * generic/tclIndexObj.c:
+ * generic/tclInt.h:
+ * generic/tclInterp.c:
+ * generic/tclListObj.c:
+ * generic/tclLiteral.c:
+ * generic/tclNamesp.c:
+ * generic/tclObj.c:
+ * generic/tclParse.c:
+ * generic/tclProc.c:
+ * generic/tclRegexp.c:
+ * generic/tclResult.c:
+ * generic/tclScan.c:
+ * generic/tclStringObj.c:
+ * generic/tclUtil.c:
+ * generic/tclVar.c:
+
+2007-11-11 Daniel Steffen <das@users.sourceforge.net>
+
+ * unix/tclUnixTime.c (TclpWideClicksToNanoseconds): Fix issues with
+ * generic/tclInt.h: int64_t overflow.
+
+ * generic/tclBasic.c: Fix stack check failure case if stack grows up
+ * unix/tclUnixInit.c: Simplify non-crosscompiled case.
+
+ * unix/configure: autoconf-2.59
+ * unix/tclConfig.h.in: autoheader-2.59
+
+2007-11-10 Miguel Sofer <msofer@users.sf.net>
+
+ * generic/tclExecute.c: Fast path for INST_LIST_INDEX when the index
+ is not a list.
+
+ * generic/tclBasic.c:
+ * unix/configure.in:
+ * unix/tclUnixInit.c: Detect stack grwoth direction at compile time,
+ only fall to runtime detection when crosscompiling.
+
+ * unix/configure: autoconf 2.61
+
+ * generic/tclBasic.c:
+ * generic/tclInt.h:
+ * tests/interp.test:
+ * unix/tclUnixInit.c:
+ * win/tclWin32Dll.c: Restore simpler behaviour for stack checking, not
+ adaptive to stack size changes after a thread is launched. Consensus
+ is that "nobody does that", and so it is not worth the cost. Improved
+ failure comments (mistachkin).
+
+2007-11-10 Kevin Kenny <kennykb@acm.org>
+
+ * win/tclWin32Dll.c: Rewrote the Windows stack checking algorithm to
+ use information from VirtualQuery to determine the bound of the stack.
+ This change fixes a bug where the guard page of the stack was never
+ restored after an overflow. It also eliminates a nasty piece of
+ assembly code for structured exception handling on mingw. It
+ introduces an assumption that the stack is a single memory arena
+ returned from VirtualAlloc, but the code in MSVCRT makes the same
+ assumption, so it should be fairly safe.
+
+2007-11-10 Miguel Sofer <msofer@users.sf.net>
+
+ * generic/tclBasic.c:
+ * generic/tclInt.h:
+ * unix/tclUnixInit.c:
+ * unix/tclUnixPort.h:
+ * win/tclWin32Dll.c: Modify the stack checking algorithm to recheck in
+ case of failure. The working assumptions are now that (a) a thread's
+ stack is never moved, and (b) a thread's stack can grow but not
+ shrink. Port to windows - could be more efficient, but is already
+ cheaper than it was.
+
+2007-11-09 Miguel Sofer <msofer@users.sf.net>
+
+ * generic/tclResult.c (ResetObjResult): new shortcut.
+
+ * generic/tclAsync.c:
+ * generic/tclBasic.c:
+ * generic/tclExecute.c:
+ * generic/tclInt.h:
+ * generic/tclUnixInit.c:
+ * generic/tclUnixPort.h: New fields in interp (ekeko!) to cache TSD
+ data that is accessed at each command invocation, access macros to
+ replace Tcl_AsyncReady and TclpCheckStackSpace by much faster
+ variants. [Patch 1829248]
+
+2007-11-09 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * generic/tclInt.decls, generic/tclIntDecls.h: Use unsigned char for
+ * generic/tclExecute.c, generic/tclUtil.c: TclByteArrayMatch and
+ don't allow a nocase option. [Bug 1828296]
+ For INST_STR_MATCH, ignore pattern type for TclByteArrayMatch case.
+
+ * generic/tclBinary.c (Tcl_GetByteArrayFromObj): check type before
+ func jump (perf).
+
+2007-11-07 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * generic/tclStubInit.c: Added TclByteArrayMatch
+ * generic/tclInt.decls: for efficient glob
+ * generic/tclIntDecls.h: matching of ByteArray
+ * generic/tclUtil.c (TclByteArrayMatch): Tcl_Objs, used in
+ * generic/tclExecute.c (TclExecuteByteCode): INST_STR_MATCH. [Bug
+ 1827996]
+
+ * generic/tclIO.c (TclGetsObjBinary): Add an efficient binary path for
+ [gets].
+ (DoWriteChars): Special case for 1-byte channel write.
+
+2007-11-06 Miguel Sofer <msofer@users.sf.net>
+
+ * generic/tclEncoding.c: Version of the embedded iso8859-1 encoding
+ handler that is faster (functions to do the encoding know exactly what
+ they're doing instead of pulling it from a table, though the table
+ itself has to be retained for use by shift encodings that depend on
+ iso8859-1). [Patch 1826906], committing for dkf.
+
+2007-11-05 Andreas Kupries <andreask@activestate.com>
+
+ * generic/tclConfig.c (Tcl_RegisterConfig): Modified to not extend the
+ config database if the encoding provided by the user is not found
+ (venc == NULL). Scripts expecting the data will error out, however we
+ neither crash nor provide bogus information. See [Bug 983509] for more
+ discussion.
+
+ * unix/tclUnixChan.c (TtyGetOptionProc): Accepted [Patch 1823576]
+ provided by Stuart Cassof <stwo@users.sourceforge.net>. The patch adds
+ the necessary utf/external conversions to the handling of the
+ arguments of option -xchar which will allow the use of \0 and similar
+ characters.
+
2007-11-03 Miguel Sofer <msofer@users.sf.net>
* generic/tclTest.c (TestSetCmd2):
- * generic/tclVar.c (TclObjLookupVarEx):
- * tests/set.test (set-5.1): fix error branch when array name looks
- like array element (code not normally exercised).
-
+ * generic/tclVar.c (TclObjLookupVarEx):
+ * tests/set.test (set-5.1): Fix error branch when array name looks
+ like array element (code not normally exercised).
+
2007-11-01 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* tools/tcltk-man2html.tcl (output-directive): Convert .DS/.DE pairs
@@ -15,8 +185,8 @@
* doc/refchan.n: Adjust internal name to be consistent with the file
name for reduced user confusion. After comment by Dan Steffen.
- * generic/tclCmdMZ.c (Tcl_StringObjCmd, UniCharIsAscii): Remember,
- the NUL character is in ASCII too. [Bug 1808258]
+ * generic/tclCmdMZ.c (Tcl_StringObjCmd, UniCharIsAscii): Remember, the
+ NUL character is in ASCII too. [Bug 1808258]
* doc/file.n: Clarified use of [file normalize]. [Bug 1185154]
@@ -47,7 +217,7 @@
2007-10-28 Miguel Sofer <msofer@users.sf.net>
* generic/tclUtil.c (Tcl_ConcatObj): optimise for some of the
- concatenees being empty objs [Bug 1447328]
+ concatenees being empty objs. [Bug 1447328]
2007-10-28 Donal K. Fellows <dkf@users.sf.net>
@@ -60,13 +230,13 @@
2007-10-27 Donal K. Fellows <dkf@users.sf.net>
* generic/regc_lex.c (lexescape): Close off one of the problems
- mentioned in [Bug 1810264]
+ mentioned in [Bug 1810264].
2007-10-27 Miguel Sofer <msofer@users.sf.net>
- * generic/tclNamesp.c (Tcl_FindCommand): insure that FQ command
- names are searched from the global namespace, ie, bypassing
- resolvers of the current namespace [Bug 1114355].
+ * generic/tclNamesp.c (Tcl_FindCommand): insure that FQ command names
+ are searched from the global namespace, ie, bypassing resolvers of the
+ current namespace. [Bug 1114355]
* doc/apply.n: fixed example [Bug 1811791]
* doc/namespace.n: improved example [Bug 1788984]
@@ -79,7 +249,7 @@
commit of 2007-10-11 (both I and gcc missed one dep).
* generic/tclVar.c: try to preserve Tcl_Objs when doing variable
- lookups by name, partially addressing [Bug 1793601]
+ lookups by name, partially addressing [Bug 1793601].
2007-10-27 Donal K. Fellows <dkf@users.sf.net>
@@ -192,7 +362,7 @@
itself no longer parses integers in that way.
* generic/tclCompExpr.c: Corrections to code that produces
- * generic/tclUtil.c: extended "bad octal" error messages.
+ * generic/tclUtil.c: extended "bad octal" error messages.
* tests/cmdAH.test: Test revisions so that tests pass whether or
* tests/cmdIL.test: not Tcl parses leading zero strings as octal.
diff --git a/generic/tclAsync.c b/generic/tclAsync.c
index f53e9fa..7d27ffa 100644
--- a/generic/tclAsync.c
+++ b/generic/tclAsync.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclAsync.c,v 1.10 2006/07/11 14:29:14 vasiljevic Exp $
+ * RCS: @(#) $Id: tclAsync.c,v 1.10.6.1 2007/11/12 19:18:13 dgp Exp $
*/
#include "tclInt.h"
@@ -324,6 +324,13 @@ Tcl_AsyncReady(void)
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
return tsdPtr->asyncReady;
}
+
+int *
+TclGetAsyncReadyPtr(void)
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ return &(tsdPtr->asyncReady);
+}
/*
* Local Variables:
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 6d77af1..bd4a102 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -14,7 +14,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclBasic.c,v 1.244.2.13 2007/10/02 20:11:49 dgp Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.244.2.14 2007/11/12 19:18:13 dgp Exp $
*/
#include "tclInt.h"
@@ -333,6 +333,34 @@ static const OpCmdInfo mathOpCmds[] = {
{ NULL, NULL, NULL,
{0}, NULL }
};
+
+#ifdef TCL_NO_STACK_CHECK
+/* stack check disabled: make them noops */
+#define CheckCStack(interp, localIntPtr) 1
+#define GetCStackParams(iPtr)
+#else /* TCL_NO_STACK_CHECK */
+#ifdef TCL_CROSS_COMPILE
+static int stackGrowsDown = 1;
+#define GetCStackParams(iPtr) \
+ stackGrowsDown = TclpGetCStackParams(&((iPtr)->stackBound))
+#define CheckCStack(iPtr, localIntPtr) \
+ (stackGrowsDown \
+ ? ((localIntPtr) > (iPtr)->stackBound) \
+ : ((localIntPtr) < (iPtr)->stackBound) \
+ )
+#else /* TCL_CROSS_COMPILE */
+#define GetCStackParams(iPtr) \
+ TclpGetCStackParams(&((iPtr)->stackBound))
+#ifdef TCL_STACK_GROWS_UP
+#define CheckCStack(iPtr, localIntPtr) \
+ (!(iPtr)->stackBound || (localIntPtr) < (iPtr)->stackBound)
+#else /* TCL_STACK_GROWS_UP */
+#define CheckCStack(iPtr, localIntPtr) \
+ ((localIntPtr) > (iPtr)->stackBound)
+#endif /* TCL_STACK_GROWS_UP */
+#endif /* TCL_CROSS_COMPILE */
+#endif /* TCL_NO_STACK_CHECK */
+
/*
*----------------------------------------------------------------------
@@ -572,6 +600,20 @@ Tcl_CreateInterp(void)
TclInitLimitSupport(interp);
/*
+ * Initialise the thread-specific data ekeko.
+ */
+
+#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
+ iPtr->allocCache = TclpGetAllocCache();
+#else
+ iPtr->allocCache = NULL;
+#endif
+ iPtr->pendingObjDataPtr = NULL;
+ iPtr->asyncReadyPtr = TclGetAsyncReadyPtr();
+
+ GetCStackParams(iPtr);
+
+ /*
* Create the core commands. Do it here, rather than calling
* Tcl_CreateCommand, because it's faster (there's no need to check for a
* pre-existing command by the same name). If a command has a Tcl_CmdProc
@@ -3376,6 +3418,7 @@ int
TclInterpReady(
Tcl_Interp *interp)
{
+ int localInt; /* used for checking the stack */
register Interp *iPtr = (Interp *) interp;
/*
@@ -3383,7 +3426,7 @@ TclInterpReady(
* any previous error information.
*/
- Tcl_ResetResult(interp);
+ TclResetResult(iPtr);
/*
* If the interpreter has been deleted, return an error.
@@ -3403,14 +3446,19 @@ TclInterpReady(
* probably because of an infinite loop somewhere.
*/
- if (((iPtr->numLevels) > iPtr->maxNestingDepth)
- || (TclpCheckStackSpace() == 0)) {
+ if (((iPtr->numLevels) <= iPtr->maxNestingDepth)
+ && CheckCStack(iPtr, &localInt)) {
+ return TCL_OK;
+ }
+
+ if (!CheckCStack(iPtr, &localInt)) {
+ Tcl_AppendResult(interp,
+ "out of stack space (infinite loop?)", NULL);
+ } else {
Tcl_AppendResult(interp,
"too many nested evaluations (infinite loop?)", NULL);
- return TCL_ERROR;
}
-
- return TCL_OK;
+ return TCL_ERROR;
}
/*
@@ -3471,7 +3519,7 @@ TclEvalObjvInternal(
Namespace *savedNsPtr = NULL;
Namespace *lookupNsPtr = iPtr->lookupNsPtr;
Tcl_Obj *commandPtr = NULL;
-
+
if (TclInterpReady(interp) == TCL_ERROR) {
return TCL_ERROR;
}
@@ -3546,7 +3594,7 @@ TclEvalObjvInternal(
*/
commandPtr = GetCommandSource(iPtr, command, length, objc, objv);
- command = Tcl_GetStringFromObj(commandPtr, &length);
+ command = TclGetStringFromObj(commandPtr, &length);
/*
* Execute any command or execution traces. Note that we bump up the
@@ -3615,7 +3663,8 @@ TclEvalObjvInternal(
TCL_DTRACE_CMD_RETURN(TclGetString(objv[0]), code);
}
}
- if (Tcl_AsyncReady()) {
+
+ if (TclAsyncReady(iPtr)) {
code = Tcl_AsyncInvoke(interp, code);
}
if (code == TCL_OK && TclLimitReady(iPtr->limit)) {
@@ -4168,7 +4217,7 @@ TclEvalEx(
if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
int numElements;
- code = Tcl_ListObjLength(interp, objv[objectsUsed],
+ code = TclListObjLength(interp, objv[objectsUsed],
&numElements);
if (code == TCL_ERROR) {
/*
@@ -4599,7 +4648,7 @@ TclEvalObjEx(
line = 1;
for (i=0; i < eoFramePtr->nline; i++) {
eoFramePtr->line[i] = line;
- w = Tcl_GetString(elements[i]);
+ w = TclGetString(elements[i]);
TclAdvanceLines(&line, w, w + strlen(w));
}
@@ -4956,7 +5005,7 @@ Tcl_ExprLongObj(
case TCL_NUMBER_LONG:
case TCL_NUMBER_WIDE:
case TCL_NUMBER_BIG:
- result = Tcl_GetLongFromObj(interp, resultPtr, ptr);
+ result = TclGetLongFromObj(interp, resultPtr, ptr);
break;
case TCL_NUMBER_NAN:
@@ -5125,7 +5174,7 @@ TclObjInvoke(
return TCL_ERROR;
}
- cmdName = Tcl_GetString(objv[0]);
+ cmdName = TclGetString(objv[0]);
hTblPtr = iPtr->hiddenCmdTablePtr;
if (hTblPtr != NULL) {
hPtr = Tcl_FindHashEntry(hTblPtr, cmdName);
@@ -5245,7 +5294,7 @@ Tcl_AppendObjToErrorInfo(
Tcl_Obj *objPtr) /* Message to record. */
{
int length;
- const char *message = Tcl_GetStringFromObj(objPtr, &length);
+ const char *message = TclGetStringFromObj(objPtr, &length);
Tcl_AddObjErrorInfo(interp, message, length);
Tcl_DecrRefCount(objPtr);
@@ -5349,6 +5398,7 @@ Tcl_AddObjErrorInfo(
}
Tcl_AppendToObj(iPtr->errorInfo, message, length);
}
+ ((Interp *) interp)->flags |= INTERP_RESULT_UNCLEAN;
}
/*
@@ -6103,7 +6153,7 @@ ExprIntFunc(
return TCL_ERROR;
}
objPtr = Tcl_GetObjResult(interp);
- if (Tcl_GetLongFromObj(NULL, objPtr, &iResult) != TCL_OK) {
+ if (TclGetLongFromObj(NULL, objPtr, &iResult) != TCL_OK) {
/*
* Truncate the bignum; keep only bits in long range.
*/
@@ -6114,7 +6164,7 @@ ExprIntFunc(
mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big);
objPtr = Tcl_NewBignumObj(&big);
Tcl_IncrRefCount(objPtr);
- Tcl_GetLongFromObj(NULL, objPtr, &iResult);
+ TclGetLongFromObj(NULL, objPtr, &iResult);
Tcl_DecrRefCount(objPtr);
}
Tcl_SetObjResult(interp, Tcl_NewLongObj(iResult));
@@ -6341,7 +6391,7 @@ ExprSrandFunc(
return TCL_ERROR;
}
- if (Tcl_GetLongFromObj(NULL, objv[1], &i) != TCL_OK) {
+ if (TclGetLongFromObj(NULL, objv[1], &i) != TCL_OK) {
Tcl_Obj *objPtr;
mp_int big;
@@ -6353,7 +6403,7 @@ ExprSrandFunc(
mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big);
objPtr = Tcl_NewBignumObj(&big);
Tcl_IncrRefCount(objPtr);
- Tcl_GetLongFromObj(NULL, objPtr, &i);
+ TclGetLongFromObj(NULL, objPtr, &i);
Tcl_DecrRefCount(objPtr);
}
@@ -6501,7 +6551,7 @@ TclDTraceInfo(
for (i = 0; i < 2; i++) {
Tcl_DictObjGet(NULL, info, *k++, &val);
if (val) {
- Tcl_GetIntFromObj(NULL, val, &(argsi[i]));
+ TclGetIntFromObj(NULL, val, &(argsi[i]));
} else {
argsi[i] = 0;
}
diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index 12c5b8b..77c9c7e 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclBinary.c,v 1.35.2.1 2007/09/07 01:23:37 dgp Exp $
+ * RCS: @(#) $Id: tclBinary.c,v 1.35.2.2 2007/11/12 19:18:14 dgp Exp $
*/
#include "tclInt.h"
@@ -310,7 +310,9 @@ Tcl_GetByteArrayFromObj(
{
ByteArray *baPtr;
- SetByteArrayFromAny(NULL, objPtr);
+ if (objPtr->typePtr != &tclByteArrayType) {
+ SetByteArrayFromAny(NULL, objPtr);
+ }
baPtr = GET_BYTEARRAY(objPtr);
if (lengthPtr != NULL) {
@@ -395,7 +397,7 @@ SetByteArrayFromAny(
Tcl_UniChar ch;
if (objPtr->typePtr != &tclByteArrayType) {
- src = Tcl_GetStringFromObj(objPtr, &length);
+ src = TclGetStringFromObj(objPtr, &length);
srcEnd = src + length;
byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
@@ -607,7 +609,7 @@ Tcl_BinaryObjCmd(
* places the formatted data into the buffer.
*/
- format = Tcl_GetString(objv[2]);
+ format = TclGetString(objv[2]);
arg = 3;
offset = 0;
length = 0;
@@ -693,10 +695,13 @@ Tcl_BinaryObjCmd(
int listc;
Tcl_Obj **listv;
- if (Tcl_ListObjGetElements(interp, objv[arg++], &listc,
+ /* The macro evals its args more than once: avoid arg++ */
+ if (TclListObjGetElements(interp, objv[arg], &listc,
&listv) != TCL_OK) {
return TCL_ERROR;
}
+ arg++;
+
if (count == BINARY_ALL) {
count = listc;
} else if (count > listc) {
@@ -772,7 +777,7 @@ Tcl_BinaryObjCmd(
*/
arg = 3;
- format = Tcl_GetString(objv[2]);
+ format = TclGetString(objv[2]);
cursor = buffer;
maxPos = cursor;
while (*format != 0) {
@@ -810,7 +815,8 @@ Tcl_BinaryObjCmd(
case 'B': {
unsigned char *last;
- str = Tcl_GetStringFromObj(objv[arg++], &length);
+ str = TclGetStringFromObj(objv[arg], &length);
+ arg++;
if (count == BINARY_ALL) {
count = length;
} else if (count == BINARY_NOCOUNT) {
@@ -871,7 +877,8 @@ Tcl_BinaryObjCmd(
unsigned char *last;
int c;
- str = Tcl_GetStringFromObj(objv[arg++], &length);
+ str = TclGetStringFromObj(objv[arg], &length);
+ arg++;
if (count == BINARY_ALL) {
count = length;
} else if (count == BINARY_NOCOUNT) {
@@ -971,7 +978,7 @@ Tcl_BinaryObjCmd(
listc = 1;
count = 1;
} else {
- Tcl_ListObjGetElements(interp, objv[arg], &listc, &listv);
+ TclListObjGetElements(interp, objv[arg], &listc, &listv);
if (count == BINARY_ALL) {
count = listc;
}
@@ -1033,7 +1040,7 @@ Tcl_BinaryObjCmd(
numberCachePtr = &numberCacheHash;
Tcl_InitHashTable(numberCachePtr, TCL_ONE_WORD_KEYS);
buffer = Tcl_GetByteArrayFromObj(objv[2], &length);
- format = Tcl_GetString(objv[3]);
+ format = TclGetString(objv[3]);
cursor = buffer;
arg = 4;
offset = 0;
@@ -1124,7 +1131,7 @@ Tcl_BinaryObjCmd(
src = buffer + offset;
valuePtr = Tcl_NewObj();
Tcl_SetObjLength(valuePtr, count);
- dest = Tcl_GetString(valuePtr);
+ dest = TclGetString(valuePtr);
if (cmd == 'b') {
for (i = 0; i < count; i++) {
@@ -1180,7 +1187,7 @@ Tcl_BinaryObjCmd(
src = buffer + offset;
valuePtr = Tcl_NewObj();
Tcl_SetObjLength(valuePtr, count);
- dest = Tcl_GetString(valuePtr);
+ dest = TclGetString(valuePtr);
if (cmd == 'h') {
for (i = 0; i < count; i++) {
@@ -1724,7 +1731,7 @@ FormatNumber(
case 'i':
case 'I':
case 'n':
- if (Tcl_GetLongFromObj(interp, src, &value) != TCL_OK) {
+ if (TclGetLongFromObj(interp, src, &value) != TCL_OK) {
return TCL_ERROR;
}
if (NeedReversing(type)) {
@@ -1746,7 +1753,7 @@ FormatNumber(
case 's':
case 'S':
case 't':
- if (Tcl_GetLongFromObj(interp, src, &value) != TCL_OK) {
+ if (TclGetLongFromObj(interp, src, &value) != TCL_OK) {
return TCL_ERROR;
}
if (NeedReversing(type)) {
@@ -1762,7 +1769,7 @@ FormatNumber(
* 8-bit integer values.
*/
case 'c':
- if (Tcl_GetLongFromObj(interp, src, &value) != TCL_OK) {
+ if (TclGetLongFromObj(interp, src, &value) != TCL_OK) {
return TCL_ERROR;
}
*(*cursorPtr)++ = (unsigned char) value;
diff --git a/generic/tclClock.c b/generic/tclClock.c
index ff3e7bb..5a9b011 100644
--- a/generic/tclClock.c
+++ b/generic/tclClock.c
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclClock.c,v 1.61 2007/04/20 05:51:09 kennykb Exp $
+ * RCS: @(#) $Id: tclClock.c,v 1.61.2.1 2007/11/12 19:18:14 dgp Exp $
*/
#include "tclInt.h"
@@ -323,7 +323,7 @@ ClockConvertlocaltoutcObjCmd(
&secondsObj) != TCL_OK)
|| (Tcl_GetWideIntFromObj(interp, secondsObj,
&(fields.localSeconds)) != TCL_OK)
- || (Tcl_GetIntFromObj(interp, objv[3], &changeover) != TCL_OK)
+ || (TclGetIntFromObj(interp, objv[3], &changeover) != TCL_OK)
|| ConvertLocalToUTC(interp, &fields, objv[2], changeover)) {
return TCL_ERROR;
}
@@ -401,7 +401,7 @@ ClockGetdatefieldsObjCmd(
return TCL_ERROR;
}
if (Tcl_GetWideIntFromObj(interp, objv[1], &(fields.seconds)) != TCL_OK
- || Tcl_GetIntFromObj(interp, objv[3], &changeover) != TCL_OK) {
+ || TclGetIntFromObj(interp, objv[3], &changeover) != TCL_OK) {
return TCL_ERROR;
}
@@ -514,15 +514,15 @@ ClockGetjuliandayfromerayearmonthdayObjCmd (
&era) != TCL_OK
|| Tcl_DictObjGet(interp, dict, literals[LIT_YEAR],
&fieldPtr) != TCL_OK
- || Tcl_GetIntFromObj(interp, fieldPtr, &(fields.year)) != TCL_OK
+ || TclGetIntFromObj(interp, fieldPtr, &(fields.year)) != TCL_OK
|| Tcl_DictObjGet(interp, dict, literals[LIT_MONTH],
&fieldPtr) != TCL_OK
- || Tcl_GetIntFromObj(interp, fieldPtr, &(fields.month)) != TCL_OK
+ || TclGetIntFromObj(interp, fieldPtr, &(fields.month)) != TCL_OK
|| Tcl_DictObjGet(interp, dict, literals[LIT_DAYOFMONTH],
&fieldPtr) != TCL_OK
- || Tcl_GetIntFromObj(interp, fieldPtr,
+ || TclGetIntFromObj(interp, fieldPtr,
&(fields.dayOfMonth)) != TCL_OK
- || Tcl_GetIntFromObj(interp, objv[2], &changeover) != TCL_OK) {
+ || TclGetIntFromObj(interp, objv[2], &changeover) != TCL_OK) {
return TCL_ERROR;
}
fields.era = era;
@@ -605,17 +605,17 @@ ClockGetjuliandayfromerayearweekdayObjCmd (
&era) != TCL_OK
|| Tcl_DictObjGet(interp, dict, literals[LIT_ISO8601YEAR],
&fieldPtr) != TCL_OK
- || Tcl_GetIntFromObj(interp, fieldPtr,
+ || TclGetIntFromObj(interp, fieldPtr,
&(fields.iso8601Year)) != TCL_OK
|| Tcl_DictObjGet(interp, dict, literals[LIT_ISO8601WEEK],
&fieldPtr) != TCL_OK
- || Tcl_GetIntFromObj(interp, fieldPtr,
+ || TclGetIntFromObj(interp, fieldPtr,
&(fields.iso8601Week)) != TCL_OK
|| Tcl_DictObjGet(interp, dict, literals[LIT_DAYOFWEEK],
&fieldPtr) != TCL_OK
- || Tcl_GetIntFromObj(interp, fieldPtr,
+ || TclGetIntFromObj(interp, fieldPtr,
&(fields.dayOfWeek)) != TCL_OK
- || Tcl_GetIntFromObj(interp, objv[2], &changeover) != TCL_OK) {
+ || TclGetIntFromObj(interp, objv[2], &changeover) != TCL_OK) {
return TCL_ERROR;
}
fields.era = era;
@@ -678,7 +678,7 @@ ConvertLocalToUTC(
* Unpack the tz data.
*/
- if (Tcl_ListObjGetElements(interp, tzdata, &rowc, &rowv) != TCL_OK) {
+ if (TclListObjGetElements(interp, tzdata, &rowc, &rowv) != TCL_OK) {
return TCL_ERROR;
}
@@ -743,9 +743,9 @@ ConvertLocalToUTCUsingTable(
while (!found) {
row = LookupLastTransition(interp, fields->seconds, rowc, rowv);
if ((row == NULL)
- || Tcl_ListObjGetElements(interp, row, &cellc,
+ || TclListObjGetElements(interp, row, &cellc,
&cellv) != TCL_OK
- || Tcl_GetIntFromObj(interp, cellv[1],
+ || TclGetIntFromObj(interp, cellv[1],
&(fields->tzOffset)) != TCL_OK) {
return TCL_ERROR;
}
@@ -882,7 +882,7 @@ ConvertUTCToLocal(
* Unpack the tz data.
*/
- if (Tcl_ListObjGetElements(interp, tzdata, &rowc, &rowv) != TCL_OK) {
+ if (TclListObjGetElements(interp, tzdata, &rowc, &rowv) != TCL_OK) {
return TCL_ERROR;
}
@@ -934,8 +934,8 @@ ConvertUTCToLocalUsingTable(
row = LookupLastTransition(interp, fields->seconds, rowc, rowv);
if (row == NULL ||
- Tcl_ListObjGetElements(interp, row, &cellc, &cellv) != TCL_OK ||
- Tcl_GetIntFromObj(interp,cellv[1],&(fields->tzOffset)) != TCL_OK) {
+ TclListObjGetElements(interp, row, &cellc, &cellv) != TCL_OK ||
+ TclGetIntFromObj(interp,cellv[1],&(fields->tzOffset)) != TCL_OK) {
return TCL_ERROR;
}
@@ -1577,7 +1577,7 @@ ClockGetenvObjCmd(
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
- varName = Tcl_GetStringFromObj(objv[1], NULL);
+ varName = TclGetString(objv[1]);
varValue = getenv(varName);
if (varValue == NULL) {
varValue = "";
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 92f0179..c83d594 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCmdAH.c,v 1.88.2.1 2007/06/21 16:04:55 dgp Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.88.2.2 2007/11/12 19:18:14 dgp Exp $
*/
#include "tclInt.h"
@@ -125,7 +125,7 @@ Tcl_CaseObjCmd(
if (caseObjc == 1) {
Tcl_Obj **newObjv;
- Tcl_ListObjGetElements(interp, caseObjv[0], &caseObjc, &newObjv);
+ TclListObjGetElements(interp, caseObjv[0], &caseObjc, &newObjv);
caseObjv = newObjv;
}
@@ -494,7 +494,7 @@ Tcl_EncodingObjCmd(
* Store the result as binary data.
*/
- stringPtr = Tcl_GetStringFromObj(data, &length);
+ stringPtr = TclGetStringFromObj(data, &length);
Tcl_UtfToExternalDString(encoding, stringPtr, length, &ds);
Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(
(unsigned char *) Tcl_DStringValue(&ds),
@@ -869,7 +869,7 @@ Tcl_FileObjCmd(
long newTime;
- if (Tcl_GetLongFromObj(interp, objv[3], &newTime) != TCL_OK) {
+ if (TclGetLongFromObj(interp, objv[3], &newTime) != TCL_OK) {
return TCL_ERROR;
}
@@ -1752,7 +1752,7 @@ Tcl_ForeachObjCmd(
result = TCL_ERROR;
goto done;
}
- Tcl_ListObjGetElements(NULL, vCopyList[i], &varcList[i], &varvList[i]);
+ TclListObjGetElements(NULL, vCopyList[i], &varcList[i], &varvList[i]);
if (varcList[i] < 1) {
Tcl_AppendResult(interp, "foreach varlist is empty", NULL);
result = TCL_ERROR;
@@ -1764,7 +1764,7 @@ Tcl_ForeachObjCmd(
result = TCL_ERROR;
goto done;
}
- Tcl_ListObjGetElements(NULL, aCopyList[i], &argcList[i], &argvList[i]);
+ TclListObjGetElements(NULL, aCopyList[i], &argcList[i], &argvList[i]);
j = argcList[i] / varcList[i];
if ((argcList[i] % varcList[i]) != 0) {
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index c7455a9..d558cd1 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -16,7 +16,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCmdIL.c,v 1.115.2.7 2007/09/14 16:28:33 dgp Exp $
+ * RCS: @(#) $Id: tclCmdIL.c,v 1.115.2.8 2007/11/12 19:18:14 dgp Exp $
*/
#include "tclInt.h"
@@ -540,7 +540,7 @@ InfoBodyCmd(
* run before. [Bug #545644]
*/
- (void) Tcl_GetString(bodyPtr);
+ (void) TclGetString(bodyPtr);
}
resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length);
@@ -1082,7 +1082,7 @@ InfoFrameCmd(
* We've got "info frame level" and must parse the level first.
*/
- if (Tcl_GetIntFromObj(interp, objv[1], &level) != TCL_OK) {
+ if (TclGetIntFromObj(interp, objv[1], &level) != TCL_OK) {
return TCL_ERROR;
}
if (level <= 0) {
@@ -1456,7 +1456,7 @@ InfoLevelCmd(
int level;
CallFrame *framePtr, *rootFramePtr = iPtr->rootFramePtr;
- if (Tcl_GetIntFromObj(interp, objv[1], &level) != TCL_OK) {
+ if (TclGetIntFromObj(interp, objv[1], &level) != TCL_OK) {
return TCL_ERROR;
}
if (level <= 0) {
@@ -2015,7 +2015,7 @@ Tcl_JoinObjCmd(
* pointer to its array of element pointers.
*/
- if (Tcl_ListObjGetElements(interp, objv[1], &listLen,
+ if (TclListObjGetElements(interp, objv[1], &listLen,
&elemPtrs) != TCL_OK) {
return TCL_ERROR;
}
@@ -2074,7 +2074,7 @@ Tcl_LassignObjCmd(
return TCL_ERROR;
}
- Tcl_ListObjGetElements(NULL, listCopyPtr, &listObjc, &listObjv);
+ TclListObjGetElements(NULL, listCopyPtr, &listObjc, &listObjv);
objc -= 2;
objv += 2;
@@ -2198,7 +2198,7 @@ Tcl_LinsertObjCmd(
return TCL_ERROR;
}
- result = Tcl_ListObjLength(interp, objv[1], &len);
+ result = TclListObjLength(interp, objv[1], &len);
if (result != TCL_OK) {
return result;
}
@@ -2209,7 +2209,7 @@ Tcl_LinsertObjCmd(
* appended to the list.
*/
- result = TclGetIntForIndex(interp, objv[2], /*end*/ len, &index);
+ result = TclGetIntForIndexM(interp, objv[2], /*end*/ len, &index);
if (result != TCL_OK) {
return result;
}
@@ -2313,7 +2313,7 @@ Tcl_LlengthObjCmd(
return TCL_ERROR;
}
- result = Tcl_ListObjLength(interp, objv[1], &listLen);
+ result = TclListObjLength(interp, objv[1], &listLen);
if (result != TCL_OK) {
return result;
}
@@ -2369,9 +2369,9 @@ Tcl_LrangeObjCmd(
if (listPtr == NULL) {
return TCL_ERROR;
}
- Tcl_ListObjGetElements(NULL, listPtr, &listLen, &elemPtrs);
+ TclListObjGetElements(NULL, listPtr, &listLen, &elemPtrs);
- result = TclGetIntForIndex(interp, objv[2], /*endValue*/ listLen - 1,
+ result = TclGetIntForIndexM(interp, objv[2], /*endValue*/ listLen - 1,
&first);
if (result == TCL_OK) {
int last;
@@ -2380,7 +2380,7 @@ Tcl_LrangeObjCmd(
first = 0;
}
- result = TclGetIntForIndex(interp, objv[3], /*endValue*/ listLen - 1,
+ result = TclGetIntForIndexM(interp, objv[3], /*endValue*/ listLen - 1,
&last);
if (result == TCL_OK) {
if (last >= listLen) {
@@ -2438,7 +2438,7 @@ Tcl_LrepeatObjCmd(
Tcl_WrongNumArgs(interp, 1, objv, "positiveCount value ?value ...?");
return TCL_ERROR;
}
- result = Tcl_GetIntFromObj(interp, objv[1], &elementCount);
+ result = TclGetIntFromObj(interp, objv[1], &elementCount);
if (result == TCL_ERROR) {
return TCL_ERROR;
}
@@ -2527,7 +2527,7 @@ Tcl_LreplaceObjCmd(
return TCL_ERROR;
}
- result = Tcl_ListObjLength(interp, objv[1], &listLen);
+ result = TclListObjLength(interp, objv[1], &listLen);
if (result != TCL_OK) {
return result;
}
@@ -2538,12 +2538,12 @@ Tcl_LreplaceObjCmd(
* included for deletion.
*/
- result = TclGetIntForIndex(interp, objv[2], /*end*/ listLen-1, &first);
+ result = TclGetIntForIndexM(interp, objv[2], /*end*/ listLen-1, &first);
if (result != TCL_OK) {
return result;
}
- result = TclGetIntForIndex(interp, objv[3], /*end*/ listLen-1, &last);
+ result = TclGetIntForIndexM(interp, objv[3], /*end*/ listLen-1, &last);
if (result != TCL_OK) {
return result;
}
@@ -2632,7 +2632,7 @@ Tcl_LreverseObjCmd(
Tcl_WrongNumArgs(interp, 1, objv, "list");
return TCL_ERROR;
}
- if (Tcl_ListObjGetElements(interp, objv[1], &elemc, &elemv) != TCL_OK) {
+ if (TclListObjGetElements(interp, objv[1], &elemc, &elemv) != TCL_OK) {
return TCL_ERROR;
}
@@ -2871,7 +2871,7 @@ Tcl_LsearchObjCmd(
*/
i++;
- if (Tcl_ListObjGetElements(interp, objv[i],
+ if (TclListObjGetElements(interp, objv[i],
&sortInfo.indexc, &indices) != TCL_OK) {
if (startPtr != NULL) {
Tcl_DecrRefCount(startPtr);
@@ -2897,7 +2897,7 @@ Tcl_LsearchObjCmd(
*/
for (j=0 ; j<sortInfo.indexc ; j++) {
- if (TclGetIntForIndex(interp, indices[j], SORTIDX_END,
+ if (TclGetIntForIndexM(interp, indices[j], SORTIDX_END,
&sortInfo.indexv[j]) != TCL_OK) {
if (sortInfo.indexc > 1) {
ckfree((char *) sortInfo.indexv);
@@ -2963,7 +2963,7 @@ Tcl_LsearchObjCmd(
* pointer to its array of element pointers.
*/
- result = Tcl_ListObjGetElements(interp, objv[objc - 2], &listc, &listv);
+ result = TclListObjGetElements(interp, objv[objc - 2], &listc, &listv);
if (result != TCL_OK) {
if (startPtr != NULL) {
Tcl_DecrRefCount(startPtr);
@@ -2979,7 +2979,7 @@ Tcl_LsearchObjCmd(
*/
if (startPtr) {
- result = TclGetIntForIndex(interp, startPtr, listc-1, &offset);
+ result = TclGetIntForIndexM(interp, startPtr, listc-1, &offset);
Tcl_DecrRefCount(startPtr);
if (result != TCL_OK) {
if (sortInfo.indexc > 1) {
@@ -3015,10 +3015,10 @@ Tcl_LsearchObjCmd(
switch ((enum datatypes) dataType) {
case ASCII:
case DICTIONARY:
- patternBytes = Tcl_GetStringFromObj(patObj, &length);
+ patternBytes = TclGetStringFromObj(patObj, &length);
break;
case INTEGER:
- result = Tcl_GetIntFromObj(interp, patObj, &patInt);
+ result = TclGetIntFromObj(interp, patObj, &patInt);
if (result != TCL_OK) {
if (sortInfo.indexc > 1) {
ckfree((char *) sortInfo.indexv);
@@ -3037,7 +3037,7 @@ Tcl_LsearchObjCmd(
break;
}
} else {
- patternBytes = Tcl_GetStringFromObj(patObj, &length);
+ patternBytes = TclGetStringFromObj(patObj, &length);
}
/*
@@ -3077,7 +3077,7 @@ Tcl_LsearchObjCmd(
match = DictionaryCompare(patternBytes, bytes);
break;
case INTEGER:
- result = Tcl_GetIntFromObj(interp, itemPtr, &objInt);
+ result = TclGetIntFromObj(interp, itemPtr, &objInt);
if (result != TCL_OK) {
if (sortInfo.indexc > 1) {
ckfree((char *) sortInfo.indexv);
@@ -3169,7 +3169,7 @@ Tcl_LsearchObjCmd(
case EXACT:
switch ((enum datatypes) dataType) {
case ASCII:
- bytes = Tcl_GetStringFromObj(itemPtr, &elemLen);
+ bytes = TclGetStringFromObj(itemPtr, &elemLen);
if (length == elemLen) {
/*
* This split allows for more optimal compilation of
@@ -3191,7 +3191,7 @@ Tcl_LsearchObjCmd(
break;
case INTEGER:
- result = Tcl_GetIntFromObj(interp, itemPtr, &objInt);
+ result = TclGetIntFromObj(interp, itemPtr, &objInt);
if (result != TCL_OK) {
if (listPtr != NULL) {
Tcl_DecrRefCount(listPtr);
@@ -3511,7 +3511,7 @@ Tcl_LsortObjCmd(
* Take copy to prevent shimmering problems.
*/
- if (Tcl_ListObjGetElements(interp, objv[i+1], &sortInfo.indexc,
+ if (TclListObjGetElements(interp, objv[i+1], &sortInfo.indexc,
&indices) != TCL_OK) {
return TCL_ERROR;
}
@@ -3534,7 +3534,7 @@ Tcl_LsortObjCmd(
*/
for (j=0 ; j<sortInfo.indexc ; j++) {
- if (TclGetIntForIndex(interp, indices[j], SORTIDX_END,
+ if (TclGetIntForIndexM(interp, indices[j], SORTIDX_END,
&sortInfo.indexv[j]) != TCL_OK) {
if (sortInfo.indexc > 1) {
ckfree((char *) sortInfo.indexv);
@@ -3607,7 +3607,7 @@ Tcl_LsortObjCmd(
sortInfo.compareCmdPtr = newCommandPtr;
}
- sortInfo.resultCode = Tcl_ListObjGetElements(interp, listObj,
+ sortInfo.resultCode = TclListObjGetElements(interp, listObj,
&length, &listObjPtrs);
if (sortInfo.resultCode != TCL_OK || length <= 0) {
goto done;
@@ -3847,8 +3847,8 @@ SortCompare(
} else if (infoPtr->sortMode == SORTMODE_INTEGER) {
long a, b;
- if ((Tcl_GetLongFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK)
- || (Tcl_GetLongFromObj(infoPtr->interp, objPtr2, &b)
+ if ((TclGetLongFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK)
+ || (TclGetLongFromObj(infoPtr->interp, objPtr2, &b)
!= TCL_OK)) {
infoPtr->resultCode = TCL_ERROR;
return order;
@@ -3883,10 +3883,10 @@ SortCompare(
* Replace them and evaluate the result.
*/
- Tcl_ListObjLength(infoPtr->interp, infoPtr->compareCmdPtr, &objc);
+ TclListObjLength(infoPtr->interp, infoPtr->compareCmdPtr, &objc);
Tcl_ListObjReplace(infoPtr->interp, infoPtr->compareCmdPtr, objc - 2,
2, 2, paramObjv);
- Tcl_ListObjGetElements(infoPtr->interp, infoPtr->compareCmdPtr,
+ TclListObjGetElements(infoPtr->interp, infoPtr->compareCmdPtr,
&objc, &objv);
infoPtr->resultCode = Tcl_EvalObjv(infoPtr->interp, objc, objv, 0);
@@ -3901,7 +3901,7 @@ SortCompare(
* Parse the result of the command.
*/
- if (Tcl_GetIntFromObj(infoPtr->interp,
+ if (TclGetIntFromObj(infoPtr->interp,
Tcl_GetObjResult(infoPtr->interp), &order) != TCL_OK) {
Tcl_ResetResult(infoPtr->interp);
Tcl_AppendResult(infoPtr->interp,
@@ -4096,7 +4096,7 @@ SelectObjFromSublist(
int listLen, index;
Tcl_Obj *currentObj;
- if (Tcl_ListObjLength(infoPtr->interp, objPtr, &listLen) != TCL_OK) {
+ if (TclListObjLength(infoPtr->interp, objPtr, &listLen) != TCL_OK) {
infoPtr->resultCode = TCL_ERROR;
return NULL;
}
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 8816110..d2bc8e0 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -15,7 +15,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCmdMZ.c,v 1.150.2.6 2007/11/01 16:25:56 dgp Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.150.2.7 2007/11/12 19:18:15 dgp Exp $
*/
#include "tclInt.h"
@@ -156,7 +156,7 @@ Tcl_RegexpObjCmd(
if (++i >= objc) {
goto endOfForLoop;
}
- if (TclGetIntForIndex(interp, objv[i], 0, &temp) != TCL_OK) {
+ if (TclGetIntForIndexM(interp, objv[i], 0, &temp) != TCL_OK) {
goto optionError;
}
if (startIndex) {
@@ -218,7 +218,7 @@ Tcl_RegexpObjCmd(
stringLength = Tcl_GetCharLength(objPtr);
if (startIndex) {
- TclGetIntForIndex(NULL, startIndex, stringLength, &offset);
+ TclGetIntForIndexM(NULL, startIndex, stringLength, &offset);
Tcl_DecrRefCount(startIndex);
if (offset < 0) {
offset = 0;
@@ -496,7 +496,7 @@ Tcl_RegsubObjCmd(
if (++idx >= objc) {
goto endOfForLoop;
}
- if (TclGetIntForIndex(interp, objv[idx], 0, &temp) != TCL_OK) {
+ if (TclGetIntForIndexM(interp, objv[idx], 0, &temp) != TCL_OK) {
goto optionError;
}
if (startIndex) {
@@ -529,7 +529,7 @@ Tcl_RegsubObjCmd(
if (startIndex) {
int stringLength = Tcl_GetCharLength(objv[1]);
- TclGetIntForIndex(NULL, startIndex, stringLength, &offset);
+ TclGetIntForIndexM(NULL, startIndex, stringLength, &offset);
Tcl_DecrRefCount(startIndex);
if (offset < 0) {
offset = 0;
@@ -989,13 +989,13 @@ Tcl_SplitObjCmd(
splitChars = " \n\t\r";
splitCharLen = 4;
} else if (objc == 3) {
- splitChars = Tcl_GetStringFromObj(objv[2], &splitCharLen);
+ splitChars = TclGetStringFromObj(objv[2], &splitCharLen);
} else {
Tcl_WrongNumArgs(interp, 1, objv, "string ?splitChars?");
return TCL_ERROR;
}
- stringPtr = Tcl_GetStringFromObj(objv[1], &stringLen);
+ stringPtr = TclGetStringFromObj(objv[1], &stringLen);
end = stringPtr + stringLen;
listPtr = Tcl_NewObj();
@@ -1172,7 +1172,7 @@ Tcl_StringObjCmd(
}
for (i = 2; i < objc-2; i++) {
- string2 = Tcl_GetStringFromObj(objv[i], &length2);
+ string2 = TclGetStringFromObj(objv[i], &length2);
if ((length2 > 1)
&& strncmp(string2, "-nocase", (size_t)length2) == 0) {
nocase = 1;
@@ -1181,7 +1181,8 @@ Tcl_StringObjCmd(
if (i+1 >= objc-2) {
goto str_cmp_args;
}
- if (Tcl_GetIntFromObj(interp, objv[++i],
+ ++i;
+ if (TclGetIntFromObj(interp, objv[i],
&reqlength) != TCL_OK) {
return TCL_ERROR;
}
@@ -1241,8 +1242,8 @@ Tcl_StringObjCmd(
* we are case-sensitive and no specific length was requested.
*/
- string1 = (char *) Tcl_GetStringFromObj(objv[0], &length1);
- string2 = (char *) Tcl_GetStringFromObj(objv[1], &length2);
+ string1 = (char *) TclGetStringFromObj(objv[0], &length1);
+ string2 = (char *) TclGetStringFromObj(objv[1], &length2);
if ((reqlength < 0) && !nocase) {
strCmpFn = (strCmpFn_t) TclpUtfNcmp2;
} else {
@@ -1310,7 +1311,7 @@ Tcl_StringObjCmd(
* that point in the string before we think about a match.
*/
- if (TclGetIntForIndex(interp, objv[4], length2 - 1,
+ if (TclGetIntForIndexM(interp, objv[4], length2 - 1,
&start) != TCL_OK) {
return TCL_ERROR;
}
@@ -1372,7 +1373,7 @@ Tcl_StringObjCmd(
if (objv[2]->typePtr == &tclByteArrayType) {
string1 = (char *) Tcl_GetByteArrayFromObj(objv[2], &length1);
- if (TclGetIntForIndex(interp, objv[3], length1 - 1,
+ if (TclGetIntForIndexM(interp, objv[3], length1 - 1,
&index) != TCL_OK) {
return TCL_ERROR;
}
@@ -1387,7 +1388,7 @@ Tcl_StringObjCmd(
length1 = Tcl_GetCharLength(objv[2]);
- if (TclGetIntForIndex(interp, objv[3], length1 - 1,
+ if (TclGetIntForIndexM(interp, objv[3], length1 - 1,
&index) != TCL_OK) {
return TCL_ERROR;
}
@@ -1442,7 +1443,7 @@ Tcl_StringObjCmd(
}
if (objc != 4) {
for (i = 3; i < objc-1; i++) {
- string2 = Tcl_GetStringFromObj(objv[i], &length2);
+ string2 = TclGetStringFromObj(objv[i], &length2);
if ((length2 > 1) &&
strncmp(string2, "-strict", (size_t) length2) == 0) {
strict = 1;
@@ -1470,7 +1471,7 @@ Tcl_StringObjCmd(
*/
objPtr = objv[objc-1];
- string1 = Tcl_GetStringFromObj(objPtr, &length1);
+ string1 = TclGetStringFromObj(objPtr, &length1);
if (length1 == 0 && index != STR_IS_LIST) {
if (strict) {
result = 0;
@@ -1541,7 +1542,7 @@ Tcl_StringObjCmd(
case STR_IS_INT:
case STR_IS_WIDE:
if ((((enum isOptions) index) == STR_IS_INT)
- && (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &i))) {
+ && (TCL_OK == TclGetIntFromObj(NULL, objPtr, &i))) {
break;
}
if ((((enum isOptions) index) == STR_IS_WIDE)
@@ -1591,7 +1592,7 @@ Tcl_StringObjCmd(
* well-formed lists.
*/
- if (TCL_OK == Tcl_ListObjLength(NULL, objPtr, &length2)) {
+ if (TCL_OK == TclListObjLength(NULL, objPtr, &length2)) {
break;
}
@@ -1719,7 +1720,7 @@ Tcl_StringObjCmd(
* string range to that char index in the string
*/
- if (TclGetIntForIndex(interp, objv[4], length2 - 1,
+ if (TclGetIntForIndexM(interp, objv[4], length2 - 1,
&start) != TCL_OK) {
return TCL_ERROR;
}
@@ -1760,7 +1761,7 @@ Tcl_StringObjCmd(
}
if ((enum options) index == STR_BYTELENGTH) {
- (void) Tcl_GetStringFromObj(objv[2], &length1);
+ (void) TclGetStringFromObj(objv[2], &length1);
} else {
/*
* If we have a ByteArray object, avoid recomputing the string
@@ -1788,7 +1789,7 @@ Tcl_StringObjCmd(
}
if (objc == 5) {
- string2 = Tcl_GetStringFromObj(objv[2], &length2);
+ string2 = TclGetStringFromObj(objv[2], &length2);
if ((length2 > 1) &&
strncmp(string2, "-nocase", (size_t) length2) == 0) {
nocase = 1;
@@ -1842,7 +1843,7 @@ Tcl_StringObjCmd(
}
Tcl_DictObjDone(&search);
} else {
- if (Tcl_ListObjGetElements(interp, objv[objc-2],
+ if (TclListObjGetElements(interp, objv[objc-2],
&mapElemc, &mapElemv) != TCL_OK) {
return TCL_ERROR;
}
@@ -2037,7 +2038,7 @@ Tcl_StringObjCmd(
}
if (objc == 5) {
- string2 = Tcl_GetStringFromObj(objv[2], &length2);
+ string2 = TclGetStringFromObj(objv[2], &length2);
if ((length2 > 1) &&
strncmp(string2, "-nocase", (size_t) length2) == 0) {
nocase = 1;
@@ -2079,8 +2080,8 @@ Tcl_StringObjCmd(
length1 = Tcl_GetCharLength(objv[2]) - 1;
}
- if (TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK ||
- TclGetIntForIndex(interp, objv[4], length1, &last) != TCL_OK) {
+ if (TclGetIntForIndexM(interp, objv[3], length1, &first) != TCL_OK ||
+ TclGetIntForIndexM(interp, objv[4], length1, &last) != TCL_OK) {
return TCL_ERROR;
}
@@ -2110,14 +2111,14 @@ Tcl_StringObjCmd(
return TCL_ERROR;
}
- if (Tcl_GetIntFromObj(interp, objv[3], &count) != TCL_OK) {
+ if (TclGetIntFromObj(interp, objv[3], &count) != TCL_OK) {
return TCL_ERROR;
}
if (count == 1) {
Tcl_SetObjResult(interp, objv[2]);
} else if (count > 1) {
- string1 = Tcl_GetStringFromObj(objv[2], &length1);
+ string1 = TclGetStringFromObj(objv[2], &length1);
if (length1 > 0) {
/*
* Only build up a string that has data. Instead of building
@@ -2173,8 +2174,8 @@ Tcl_StringObjCmd(
ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1);
length1--;
- if (TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK ||
- TclGetIntForIndex(interp, objv[4], length1, &last) != TCL_OK){
+ if (TclGetIntForIndexM(interp, objv[3], length1, &first) != TCL_OK ||
+ TclGetIntForIndexM(interp, objv[4], length1, &last) != TCL_OK){
return TCL_ERROR;
}
@@ -2215,7 +2216,7 @@ Tcl_StringObjCmd(
return TCL_ERROR;
}
- string1 = Tcl_GetStringFromObj(objv[2], &length1);
+ string1 = TclGetStringFromObj(objv[2], &length1);
if (objc == 3) {
Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1);
@@ -2234,7 +2235,7 @@ Tcl_StringObjCmd(
Tcl_Obj *resultPtr;
length1 = Tcl_NumUtfChars(string1, length1) - 1;
- if (TclGetIntForIndex(interp,objv[3],length1, &first) != TCL_OK) {
+ if (TclGetIntForIndexM(interp,objv[3],length1, &first) != TCL_OK) {
return TCL_ERROR;
}
if (first < 0) {
@@ -2242,7 +2243,7 @@ Tcl_StringObjCmd(
}
last = first;
- if ((objc == 5) && (TclGetIntForIndex(interp, objv[4], length1,
+ if ((objc == 5) && (TclGetIntForIndexM(interp, objv[4], length1,
&last) != TCL_OK)) {
return TCL_ERROR;
}
@@ -2258,7 +2259,7 @@ Tcl_StringObjCmd(
start = Tcl_UtfAtIndex(string1, first);
end = Tcl_UtfAtIndex(start, last - first + 1);
resultPtr = Tcl_NewStringObj(string1, end - string1);
- string2 = Tcl_GetString(resultPtr) + (start - string1);
+ string2 = TclGetString(resultPtr) + (start - string1);
if ((enum options) index == STR_TOLOWER) {
length2 = Tcl_UtfToLower(string2);
@@ -2293,7 +2294,7 @@ Tcl_StringObjCmd(
dotrim:
if (objc == 4) {
- string2 = Tcl_GetStringFromObj(objv[3], &length2);
+ string2 = TclGetStringFromObj(objv[3], &length2);
} else if (objc == 3) {
string2 = " \t\n\r";
length2 = strlen(string2);
@@ -2301,7 +2302,7 @@ Tcl_StringObjCmd(
Tcl_WrongNumArgs(interp, 2, objv, "string ?chars?");
return TCL_ERROR;
}
- string1 = Tcl_GetStringFromObj(objv[2], &length1);
+ string1 = TclGetStringFromObj(objv[2], &length1);
checkEnd = string2 + length2;
if (left) {
@@ -2371,9 +2372,9 @@ Tcl_StringObjCmd(
return TCL_ERROR;
}
- string1 = Tcl_GetStringFromObj(objv[2], &length1);
+ string1 = TclGetStringFromObj(objv[2], &length1);
numChars = Tcl_NumUtfChars(string1, length1);
- if (TclGetIntForIndex(interp, objv[3], numChars-1, &index) != TCL_OK){
+ if (TclGetIntForIndexM(interp, objv[3], numChars-1, &index) != TCL_OK){
return TCL_ERROR;
}
if (index < 0) {
@@ -2408,9 +2409,9 @@ Tcl_StringObjCmd(
return TCL_ERROR;
}
- string1 = Tcl_GetStringFromObj(objv[2], &length1);
+ string1 = TclGetStringFromObj(objv[2], &length1);
numChars = Tcl_NumUtfChars(string1, length1);
- if (TclGetIntForIndex(interp, objv[3], numChars-1, &index) != TCL_OK){
+ if (TclGetIntForIndexM(interp, objv[3], numChars-1, &index) != TCL_OK){
return TCL_ERROR;
}
if (index >= numChars) {
@@ -2672,7 +2673,7 @@ Tcl_SwitchObjCmd(
Tcl_Obj **listv;
blist = objv[0];
- if (Tcl_ListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK){
+ if (TclListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK){
return TCL_ERROR;
}
@@ -2738,7 +2739,7 @@ Tcl_SwitchObjCmd(
* See if the pattern matches the string.
*/
- pattern = Tcl_GetStringFromObj(objv[i], &patternLength);
+ pattern = TclGetStringFromObj(objv[i], &patternLength);
if ((i == objc - 2) && (*pattern == 'd')
&& (strcmp(pattern, "default") == 0)) {
@@ -2921,7 +2922,7 @@ Tcl_SwitchObjCmd(
ctxPtr->line = (int *) ckalloc(objc * sizeof(int));
ctxPtr->nline = objc;
- TclListLines(Tcl_GetString(blist), bline, objc, ctxPtr->line);
+ TclListLines(TclGetString(blist), bline, objc, ctxPtr->line);
} else {
/*
* This is either a dynamic code word, when all elements are
@@ -3026,7 +3027,7 @@ Tcl_TimeObjCmd(
if (objc == 2) {
count = 1;
} else if (objc == 3) {
- result = Tcl_GetIntFromObj(interp, objv[2], &count);
+ result = TclGetIntFromObj(interp, objv[2], &count);
if (result != TCL_OK) {
return result;
}
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 6468ea9..5d64717 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompCmds.c,v 1.109.2.9 2007/10/19 14:30:01 dgp Exp $
+ * RCS: @(#) $Id: tclCompCmds.c,v 1.109.2.10 2007/11/12 19:18:15 dgp Exp $
*/
#include "tclInt.h"
@@ -694,7 +694,7 @@ TclCompileDictCmd(
intObj = Tcl_NewStringObj(word, numBytes);
Tcl_IncrRefCount(intObj);
- code = Tcl_GetIntFromObj(NULL, intObj, &incrAmount);
+ code = TclGetIntFromObj(NULL, intObj, &incrAmount);
TclDecrRefCount(intObj);
if (code != TCL_OK) {
return TCL_ERROR;
@@ -2200,7 +2200,7 @@ TclCompileIncrCmd(
int code;
Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes);
Tcl_IncrRefCount(intObj);
- code = Tcl_GetIntFromObj(NULL, intObj, &immValue);
+ code = TclGetIntFromObj(NULL, intObj, &immValue);
TclDecrRefCount(intObj);
if ((code == TCL_OK) && (-127 <= immValue) && (immValue <= 127)) {
haveImmValue = 1;
@@ -2531,7 +2531,7 @@ TclCompileLindexCmd(
int idx, result;
tmpObj = Tcl_NewStringObj(idxTokenPtr[1].start, idxTokenPtr[1].size);
- result = Tcl_GetIntFromObj(NULL, tmpObj, &idx);
+ result = TclGetIntFromObj(NULL, tmpObj, &idx);
TclDecrRefCount(tmpObj);
if (result == TCL_OK && idx >= 0) {
@@ -2883,7 +2883,7 @@ TclCompileRegexpCmd(
{
Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the
* parse of the RE or string. */
- int i, len, nocase, anchorLeft, anchorRight, start;
+ int i, len, nocase, exact, sawLast, simple;
char *str;
DefineLineInformation; /* TIP #280 */
@@ -2898,7 +2898,9 @@ TclCompileRegexpCmd(
return TCL_ERROR;
}
+ simple = 0;
nocase = 0;
+ sawLast = 0;
varTokenPtr = parsePtr->tokenPtr;
/*
@@ -2919,6 +2921,7 @@ TclCompileRegexpCmd(
str = (char *) varTokenPtr[1].start;
len = varTokenPtr[1].size;
if ((len == 2) && (str[0] == '-') && (str[1] == '-')) {
+ sawLast++;
i++;
break;
} else if ((len > 1) && (strncmp(str,"-nocase",(unsigned)len) == 0)) {
@@ -2946,102 +2949,41 @@ TclCompileRegexpCmd(
*/
varTokenPtr = TokenAfter(varTokenPtr);
- str = (char *) varTokenPtr[1].start;
- len = varTokenPtr[1].size;
- if ((varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) || (*str == '-')) {
- return TCL_ERROR;
- }
- if (len == 0) {
- /*
- * The semantics of regexp are always match on re == "".
- */
+ if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ Tcl_DString ds;
- PushLiteral(envPtr, "1", 1);
- return TCL_OK;
- }
-
- /*
- * Make a copy of the string that is null-terminated for checks which
- * require such.
- */
-
- str = (char *) TclStackAlloc(interp, (unsigned) len + 1);
- strncpy(str, varTokenPtr[1].start, (size_t) len);
- str[len] = '\0';
- start = 0;
-
- /*
- * 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.
- */
-
- if (str[0] == '^') {
- start++;
- anchorLeft = 1;
- } else {
- anchorLeft = 0;
- }
- if ((str[len-1] == '$') && ((len == 1) || (str[len-2] != '\\'))) {
- anchorRight = 1;
- str[--len] = '\0';
- } else {
- anchorRight = 0;
- }
-
- /*
- * On the first (pattern) arg, check to see if any RE special characters
- * are in the word. If not, this is the same as 'string equal'.
- */
-
- if ((len > 1+start) && (str[start] == '.') && (str[start+1] == '*')) {
- start += 2;
- anchorLeft = 0;
- }
- if ((len > 2+start) && (str[len-3] != '\\')
- && (str[len-2] == '.') && (str[len-1] == '*')) {
- len -= 2;
- str[len] = '\0';
- anchorRight = 0;
- }
+ simple = 1;
+ str = (char *) varTokenPtr[1].start;
+ len = varTokenPtr[1].size;
+ if ((*str == '-') && !sawLast) {
+ return TCL_ERROR;
+ }
- /*
- * Don't do anything with REs with other special chars. Also check if this
- * is a bad RE (do this at the end because it can be expensive). If so,
- * let it complain at runtime.
- */
+ if (len == 0) {
+ /*
+ * The semantics of regexp are always match on re == "".
+ */
- if ((strpbrk(str + start, "*+?{}()[].\\|^$") != NULL)
- || (Tcl_RegExpCompile(NULL, str) == NULL)) {
- TclStackFree(interp, str);
- return TCL_ERROR;
- }
+ PushLiteral(envPtr, "1", 1);
+ return TCL_OK;
+ }
- if (anchorLeft && anchorRight) {
- PushLiteral(envPtr, str+start, len-start);
- } else {
/*
- * This needs to find the substring anywhere in the string, so use
- * [string match] and *foo*, with appropriate anchoring.
+ * Attempt to convert pattern to glob. If successful, push the
+ * converted pattern.
*/
- char *newStr = TclStackAlloc(interp, (unsigned) len + 3);
-
- len -= start;
- if (anchorLeft) {
- strncpy(newStr, str + start, (size_t) len);
- } else {
- newStr[0] = '*';
- strncpy(newStr + 1, str + start, (size_t) len++);
- }
- if (!anchorRight) {
- newStr[len++] = '*';
+ if (TclReToGlob(NULL, varTokenPtr[1].start, len, &ds, &exact)
+ != TCL_OK) {
+ return TCL_ERROR;
}
- newStr[len] = '\0';
- PushLiteral(envPtr, newStr, len);
- TclStackFree(interp, newStr);
+
+ PushLiteral(envPtr, Tcl_DStringValue(&ds), Tcl_DStringLength(&ds));
+ Tcl_DStringFree(&ds);
+ } else {
+ CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-2);
}
- TclStackFree(interp, str);
/*
* Push the string arg.
@@ -3050,10 +2992,14 @@ TclCompileRegexpCmd(
varTokenPtr = TokenAfter(varTokenPtr);
CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-1);
- if (anchorLeft && anchorRight && !nocase) {
- TclEmitOpcode(INST_STR_EQ, envPtr);
+ if (simple) {
+ if (exact && !nocase) {
+ TclEmitOpcode(INST_STR_EQ, envPtr);
+ } else {
+ TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr);
+ }
} else {
- TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr);
+ TclEmitInstInt1(INST_REGEXP, nocase, envPtr);
}
return TCL_OK;
@@ -3243,7 +3189,7 @@ TclCompileSyntaxError(
{
Tcl_Obj *msg = Tcl_GetObjResult(interp);
int numBytes;
- const char *bytes = Tcl_GetStringFromObj(msg, &numBytes);
+ const char *bytes = TclGetStringFromObj(msg, &numBytes);
TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, numBytes), envPtr);
CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0,
@@ -3505,7 +3451,7 @@ TclCompileStringCmd(
Tcl_Obj *copy = Tcl_NewStringObj(str, length);
Tcl_IncrRefCount(copy);
- exactMatch = TclMatchIsTrivial(Tcl_GetString(copy));
+ exactMatch = TclMatchIsTrivial(TclGetString(copy));
TclDecrRefCount(copy);
}
PushLiteral(envPtr, str, length);
@@ -5346,7 +5292,7 @@ IndexTailVarIfKnown(
}
}
- tailName = Tcl_GetStringFromObj(tailPtr, &len);
+ tailName = TclGetStringFromObj(tailPtr, &len);
if (len) {
if (*(tailName+len-1) == ')') {
diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c
index 7ca8327..4500b29 100644
--- a/generic/tclCompExpr.c
+++ b/generic/tclCompExpr.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompExpr.c,v 1.53.2.11 2007/10/17 14:38:34 dgp Exp $
+ * RCS: @(#) $Id: tclCompExpr.c,v 1.53.2.12 2007/11/12 19:18:15 dgp Exp $
*/
#include "tclInt.h"
@@ -2057,8 +2057,8 @@ TclCompileExpr(
TclAdvanceLines(&envPtr->line, script,
script + TclParseAllWhiteSpace(script, numBytes));
- Tcl_ListObjGetElements(NULL, litList, &objc, (Tcl_Obj ***)&litObjv);
- Tcl_ListObjGetElements(NULL, funcList, &objc, &funcObjv);
+ TclListObjGetElements(NULL, litList, &objc, (Tcl_Obj ***)&litObjv);
+ TclListObjGetElements(NULL, funcList, &objc, &funcObjv);
CompileExprTree(interp, opTree, 0, &litObjv, funcObjv,
parsePtr->tokenPtr, envPtr, 1 /* optimize */);
} else {
@@ -2206,7 +2206,8 @@ CompileExprTree(
Tcl_DStringInit(&cmdName);
Tcl_DStringAppend(&cmdName, "tcl::mathfunc::", -1);
- p = Tcl_GetStringFromObj(*funcObjv++, &length);
+ p = TclGetStringFromObj(*funcObjv, &length);
+ funcObjv++;
Tcl_DStringAppend(&cmdName, p, length);
TclEmitPush(TclRegisterNewNSLiteral(envPtr,
Tcl_DStringValue(&cmdName),
@@ -2345,7 +2346,7 @@ CompileExprTree(
Tcl_Obj *const *litObjv = *litObjvPtr;
Tcl_Obj *literal = *litObjv;
int length;
- const char *bytes = Tcl_GetStringFromObj(literal, &length);
+ const char *bytes = TclGetStringFromObj(literal, &length);
TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, length), envPtr);
(*litObjvPtr)++;
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 0e41432..25b9d1e 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompile.c,v 1.117.2.12 2007/10/24 12:52:51 dgp Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.117.2.13 2007/11/12 19:18:16 dgp Exp $
*/
#include "tclInt.h"
@@ -385,6 +385,9 @@ InstructionDesc tclInstructionTable[] = {
/* Compiled bytecodes to signal syntax error. */
{"reverse", 5, 0, 1, {OPERAND_UINT4}},
/* Reverse the order of the arg elements at the top of stack */
+
+ {"regexp", 2, -1, 1, {OPERAND_INT1}},
+ /* Regexp: push (regexp stknext stktop) opnd == nocase */
{0}
};
@@ -484,7 +487,7 @@ TclSetByteCodeFromAny(
}
#endif
- stringPtr = Tcl_GetStringFromObj(objPtr, &length);
+ stringPtr = TclGetStringFromObj(objPtr, &length);
/*
* TIP #280: Pick up the CmdFrame in which the BC compiler was invoked and
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index f5f1a1e..e8d5cbc 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompile.h,v 1.70.2.10 2007/11/01 16:25:57 dgp Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.70.2.11 2007/11/12 19:18:16 dgp Exp $
*/
#ifndef _TCLCOMPILATION
@@ -636,8 +636,12 @@ typedef struct ByteCode {
#define INST_REVERSE 126
+/* regexp instruction */
+
+#define INST_REGEXP 127
+
/* The last opcode */
-#define LAST_INST_OPCODE 126
+#define LAST_INST_OPCODE 127
/*
* Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclConfig.c b/generic/tclConfig.c
index 1199e81..c3871ec 100644
--- a/generic/tclConfig.c
+++ b/generic/tclConfig.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclConfig.c,v 1.14 2007/04/10 14:47:10 dkf Exp $
+ * RCS: @(#) $Id: tclConfig.c,v 1.14.2.1 2007/11/12 19:18:16 dgp Exp $
*/
#include "tclInt.h"
@@ -71,12 +71,11 @@ Tcl_RegisterConfig(
Tcl_Config *cfg;
Tcl_Encoding venc = Tcl_GetEncoding(NULL, valEncoding);
- pDB = GetConfigDict(interp);
pkg = Tcl_NewStringObj(pkgName, -1);
/*
* Phase I: Adding the provided information to the internal database of
- * package meta data.
+ * package meta data. Only if we have an ok encoding.
*
* Phase II: Create a command for querying this database, specific to the
* package registerting its configuration. This is the approved interface
@@ -90,46 +89,55 @@ Tcl_RegisterConfig(
Tcl_IncrRefCount(pkg);
/*
- * Retrieve package specific configuration...
+ * For venc == NULL aka bogus encoding we skip the step setting up the
+ * dictionaries visible at Tcl level. I.e. they are not filled
*/
- if (Tcl_DictObjGet(interp, pDB, pkg, &pkgDict) != TCL_OK
- || (pkgDict == NULL)) {
- pkgDict = Tcl_NewDictObj();
- } else if (Tcl_IsShared(pkgDict)) {
- pkgDict = Tcl_DuplicateObj(pkgDict);
- }
+ if (venc != NULL) {
+ /*
+ * Retrieve package specific configuration...
+ */
- /*
- * Extend the package configuration...
- */
+ pDB = GetConfigDict(interp);
- for (cfg=configuration ; cfg->key!=NULL && cfg->key[0]!='\0' ; cfg++) {
- Tcl_DString conv;
- CONST char *convValue =
- Tcl_ExternalToUtfDString(venc, cfg->value, -1, &conv);
+ if (Tcl_DictObjGet(interp, pDB, pkg, &pkgDict) != TCL_OK
+ || (pkgDict == NULL)) {
+ pkgDict = Tcl_NewDictObj();
+ } else if (Tcl_IsShared(pkgDict)) {
+ pkgDict = Tcl_DuplicateObj(pkgDict);
+ }
/*
- * We know that the keys are in ASCII/UTF-8, so for them is no
- * conversion required.
+ * Extend the package configuration...
*/
- Tcl_DictObjPut(interp, pkgDict, Tcl_NewStringObj(cfg->key, -1),
- Tcl_NewStringObj(convValue, -1));
- Tcl_DStringFree(&conv);
- }
+ for (cfg=configuration ; cfg->key!=NULL && cfg->key[0]!='\0' ; cfg++) {
+ Tcl_DString conv;
+ CONST char *convValue =
+ Tcl_ExternalToUtfDString(venc, cfg->value, -1, &conv);
- /*
- * We're now done with the encoding, so drop it.
- */
+ /*
+ * We know that the keys are in ASCII/UTF-8, so for them is no
+ * conversion required.
+ */
- Tcl_FreeEncoding(venc);
+ Tcl_DictObjPut(interp, pkgDict, Tcl_NewStringObj(cfg->key, -1),
+ Tcl_NewStringObj(convValue, -1));
+ Tcl_DStringFree(&conv);
+ }
- /*
- * Write the changes back into the overall database.
- */
+ /*
+ * We're now done with the encoding, so drop it.
+ */
+
+ Tcl_FreeEncoding(venc);
+
+ /*
+ * Write the changes back into the overall database.
+ */
- Tcl_DictObjPut(interp, pDB, pkg, pkgDict);
+ Tcl_DictObjPut(interp, pDB, pkg, pkgDict);
+ }
/*
* Now create the interface command for retrieval of the package
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index ce25fa9..cf37b21 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclDictObj.c,v 1.49.2.1 2007/09/09 04:14:28 dgp Exp $
+ * RCS: @(#) $Id: tclDictObj.c,v 1.49.2.2 2007/11/12 19:18:16 dgp Exp $
*/
#include "tclInt.h"
@@ -302,12 +302,12 @@ UpdateStringOfDict(
*/
keyPtr = (Tcl_Obj *) Tcl_GetHashKey(&dict->table, hPtr);
- elem = Tcl_GetStringFromObj(keyPtr, &length);
+ elem = TclGetStringFromObj(keyPtr, &length);
dictPtr->length += Tcl_ScanCountedElement(elem, length,
&flagPtr[i]) + 1;
valuePtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr);
- elem = Tcl_GetStringFromObj(valuePtr, &length);
+ elem = TclGetStringFromObj(valuePtr, &length);
dictPtr->length += Tcl_ScanCountedElement(elem, length,
&flagPtr[i+1]) + 1;
}
@@ -321,13 +321,13 @@ UpdateStringOfDict(
for (i=0,hPtr=Tcl_FirstHashEntry(&dict->table,&search) ; i<numElems ;
i+=2,hPtr=Tcl_NextHashEntry(&search)) {
keyPtr = (Tcl_Obj *) Tcl_GetHashKey(&dict->table, hPtr);
- elem = Tcl_GetStringFromObj(keyPtr, &length);
+ elem = TclGetStringFromObj(keyPtr, &length);
dst += Tcl_ConvertCountedElement(elem, length, dst,
flagPtr[i] | (i==0 ? 0 : TCL_DONT_QUOTE_HASH) );
*(dst++) = ' ';
valuePtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr);
- elem = Tcl_GetStringFromObj(valuePtr, &length);
+ elem = TclGetStringFromObj(valuePtr, &length);
dst += Tcl_ConvertCountedElement(elem, length, dst,
flagPtr[i+1] | TCL_DONT_QUOTE_HASH);
*(dst++) = ' ';
@@ -388,7 +388,7 @@ SetDictFromAny(
int objc, i;
Tcl_Obj **objv;
- if (Tcl_ListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) {
+ if (TclListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) {
return TCL_ERROR;
}
if (objc & 1) {
@@ -405,7 +405,7 @@ SetDictFromAny(
*/
if (Tcl_IsShared(objPtr)) {
- (void) Tcl_GetString(objPtr);
+ (void) TclGetString(objPtr);
}
/*
@@ -438,7 +438,7 @@ SetDictFromAny(
* Get the string representation. Make it up-to-date if necessary.
*/
- string = Tcl_GetStringFromObj(objPtr, &length);
+ string = TclGetStringFromObj(objPtr, &length);
limit = (string + length);
/*
@@ -2187,7 +2187,7 @@ DictForCmd(
return TCL_ERROR;
}
- if (Tcl_ListObjGetElements(interp, objv[2], &varc, &varv) != TCL_OK) {
+ if (TclListObjGetElements(interp, objv[2], &varc, &varv) != TCL_OK) {
return TCL_ERROR;
}
if (varc != 2) {
@@ -2512,7 +2512,7 @@ DictFilterCmd(
* copying from the "dict for" implementation has occurred!
*/
- if (Tcl_ListObjGetElements(interp, objv[4], &varc, &varv) != TCL_OK) {
+ if (TclListObjGetElements(interp, objv[4], &varc, &varv) != TCL_OK) {
return TCL_ERROR;
}
if (varc != 2) {
@@ -2918,7 +2918,7 @@ DictWithCmd(
* Now process our updates on the leaf dictionary.
*/
- Tcl_ListObjGetElements(NULL, keysPtr, &keyc, &keyv);
+ TclListObjGetElements(NULL, keysPtr, &keyc, &keyv);
for (i=0 ; i<keyc ; i++) {
valPtr = Tcl_ObjGetVar2(interp, keyv[i], NULL, 0);
if (valPtr == NULL) {
diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index d9f901b..619c2b4 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclEncoding.c,v 1.55.2.1 2007/11/01 16:25:57 dgp Exp $
+ * RCS: @(#) $Id: tclEncoding.c,v 1.55.2.2 2007/11/12 19:18:16 dgp Exp $
*/
#include "tclInt.h"
@@ -260,14 +260,24 @@ static int UtfExtToUtfIntProc(ClientData clientData,
Tcl_EncodingState *statePtr, char *dst, int dstLen,
int *srcReadPtr, int *dstWrotePtr,
int *dstCharsPtr);
+static int Iso88591FromUtfProc(ClientData clientData,
+ CONST char *src, int srcLen, int flags,
+ Tcl_EncodingState *statePtr, char *dst, int dstLen,
+ int *srcReadPtr, int *dstWrotePtr,
+ int *dstCharsPtr);
+static int Iso88591ToUtfProc(ClientData clientData,
+ CONST char *src, int srcLen, int flags,
+ Tcl_EncodingState *statePtr, char *dst,
+ int dstLen, int *srcReadPtr, int *dstWrotePtr,
+ int *dstCharsPtr);
/*
- * A Tcl_ObjType for holding a cached Tcl_Encoding as the intrep. This should
- * help the lifetime of encodings be more useful. See concerns raised in [Bug
- * 1077262].
+ * A Tcl_ObjType for holding a cached Tcl_Encoding in the otherValuePtr field
+ * of the intrep. This should help the lifetime of encodings be more useful.
+ * See concerns raised in [Bug 1077262].
*/
-static Tcl_ObjType EncodingType = {
+static Tcl_ObjType encodingType = {
"encoding", FreeEncodingIntRep, DupEncodingIntRep, NULL, NULL
};
@@ -297,7 +307,7 @@ Tcl_GetEncodingFromObj(
Tcl_Encoding *encodingPtr)
{
CONST char *name = Tcl_GetString(objPtr);
- if (objPtr->typePtr != &EncodingType) {
+ if (objPtr->typePtr != &encodingType) {
Tcl_Encoding encoding = Tcl_GetEncoding(interp, name);
if (encoding == NULL) {
@@ -305,7 +315,7 @@ Tcl_GetEncodingFromObj(
}
TclFreeIntRep(objPtr);
objPtr->internalRep.otherValuePtr = (VOID *) encoding;
- objPtr->typePtr = &EncodingType;
+ objPtr->typePtr = &encodingType;
}
*encodingPtr = Tcl_GetEncoding(NULL, name);
return TCL_OK;
@@ -611,8 +621,8 @@ TclInitEncodingSubsystem(void)
}
type.encodingName = "iso8859-1";
- type.toUtfProc = TableToUtfProc;
- type.fromUtfProc = TableFromUtfProc;
+ type.toUtfProc = Iso88591ToUtfProc;
+ type.fromUtfProc = Iso88591FromUtfProc;
type.freeProc = TableFreeProc;
type.nullSize = 1;
type.clientData = dataPtr;
@@ -1536,6 +1546,7 @@ OpenEncodingFileChannel(
if ((NULL == chan) && (interp != NULL)) {
Tcl_AppendResult(interp, "unknown encoding \"", name, "\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, NULL);
}
Tcl_DecrRefCount(fileNameObj);
Tcl_DecrRefCount(nameObj);
@@ -2132,9 +2143,9 @@ UtfIntToUtfExtProc(
*
* UtfExtToUtfIntProc --
*
- * Convert from UTF-8 to UTF-8 while converting null-bytes from
- * the official representation (0x00) to Tcl's internal
- * representation (0xc0, 0x80). See UtfToUtfProc for details.
+ * Convert from UTF-8 to UTF-8 while converting null-bytes from the
+ * official representation (0x00) to Tcl's internal representation (0xc0,
+ * 0x80). See UtfToUtfProc for details.
*
* Results:
* Returns TCL_OK if conversion was successful.
@@ -2703,6 +2714,190 @@ TableFromUtfProc(
}
/*
+ *-------------------------------------------------------------------------
+ *
+ * Iso88591ToUtfProc --
+ *
+ * Convert from the "iso8859-1" encoding into UTF-8.
+ *
+ * Results:
+ * Returns TCL_OK if conversion was successful.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+Iso88591ToUtfProc(
+ ClientData clientData, /* Ignored. */
+ CONST char *src, /* Source string in specified encoding. */
+ int srcLen, /* Source string length in bytes. */
+ int flags, /* Conversion control flags. */
+ Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
+ * information used during a piecewise
+ * conversion. Contents of statePtr are
+ * initialized and/or reset by conversion
+ * routine under control of flags argument. */
+ char *dst, /* Output buffer in which converted string is
+ * stored. */
+ int dstLen, /* The maximum length of output buffer in
+ * bytes. */
+ int *srcReadPtr, /* Filled with the number of bytes from the
+ * source string that were converted. This may
+ * be less than the original source length if
+ * there was a problem converting some source
+ * characters. */
+ int *dstWrotePtr, /* Filled with the number of bytes that were
+ * stored in the output buffer as a result of
+ * the conversion. */
+ int *dstCharsPtr) /* Filled with the number of characters that
+ * correspond to the bytes stored in the
+ * output buffer. */
+{
+ CONST char *srcStart, *srcEnd;
+ char *dstEnd, *dstStart;
+ int result, numChars;
+
+ srcStart = src;
+ srcEnd = src + srcLen;
+
+ dstStart = dst;
+ dstEnd = dst + dstLen - TCL_UTF_MAX;
+
+ result = TCL_OK;
+ for (numChars = 0; src < srcEnd; numChars++) {
+ Tcl_UniChar ch;
+
+ if (dst > dstEnd) {
+ result = TCL_CONVERT_NOSPACE;
+ break;
+ }
+ ch = (Tcl_UniChar) *((unsigned char *) src);
+ /*
+ * Special case for 1-byte utf chars for speed.
+ */
+ if (ch && ch < 0x80) {
+ *dst++ = (char) ch;
+ } else {
+ dst += Tcl_UniCharToUtf(ch, dst);
+ }
+ src++;
+ }
+
+ *srcReadPtr = src - srcStart;
+ *dstWrotePtr = dst - dstStart;
+ *dstCharsPtr = numChars;
+ return result;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * Iso88591FromUtfProc --
+ *
+ * Convert from UTF-8 into the encoding "iso8859-1".
+ *
+ * Results:
+ * Returns TCL_OK if conversion was successful.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+Iso88591FromUtfProc(
+ ClientData clientData, /* Ignored. */
+ CONST char *src, /* Source string in UTF-8. */
+ int srcLen, /* Source string length in bytes. */
+ int flags, /* Conversion control flags. */
+ Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
+ * information used during a piecewise
+ * conversion. Contents of statePtr are
+ * initialized and/or reset by conversion
+ * routine under control of flags argument. */
+ char *dst, /* Output buffer in which converted string is
+ * stored. */
+ int dstLen, /* The maximum length of output buffer in
+ * bytes. */
+ int *srcReadPtr, /* Filled with the number of bytes from the
+ * source string that were converted. This may
+ * be less than the original source length if
+ * there was a problem converting some source
+ * characters. */
+ int *dstWrotePtr, /* Filled with the number of bytes that were
+ * stored in the output buffer as a result of
+ * the conversion. */
+ int *dstCharsPtr) /* Filled with the number of characters that
+ * correspond to the bytes stored in the
+ * output buffer. */
+{
+ CONST char *srcStart, *srcEnd, *srcClose;
+ char *dstStart, *dstEnd;
+ int result, numChars;
+
+ result = TCL_OK;
+
+ srcStart = src;
+ srcEnd = src + srcLen;
+ srcClose = srcEnd;
+ if ((flags & TCL_ENCODING_END) == 0) {
+ srcClose -= TCL_UTF_MAX;
+ }
+
+ dstStart = dst;
+ dstEnd = dst + dstLen - 1;
+
+ for (numChars = 0; src < srcEnd; numChars++) {
+ Tcl_UniChar ch;
+ int len;
+
+ if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) {
+ /*
+ * If there is more string to follow, this will ensure that the
+ * last UTF-8 character in the source buffer hasn't been cut off.
+ */
+
+ result = TCL_CONVERT_MULTIBYTE;
+ break;
+ }
+ len = TclUtfToUniChar(src, &ch);
+
+ /*
+ * Check for illegal characters.
+ */
+
+ if (ch > 0xff) {
+ if (flags & TCL_ENCODING_STOPONERROR) {
+ result = TCL_CONVERT_UNKNOWN;
+ break;
+ }
+
+ /*
+ * Plunge on, using '?' as a fallback character.
+ */
+
+ ch = (Tcl_UniChar) '?';
+ }
+
+ if (dst > dstEnd) {
+ result = TCL_CONVERT_NOSPACE;
+ break;
+ }
+ *(dst++) = (char) ch;
+ src += len;
+ }
+
+ *srcReadPtr = src - srcStart;
+ *dstWrotePtr = dst - dstStart;
+ *dstCharsPtr = numChars;
+ return result;
+}
+
+/*
*---------------------------------------------------------------------------
*
* TableFreeProc --
@@ -3235,7 +3430,8 @@ GetTableEncoding(
if (encodingPtr == NULL) {
encodingPtr = (Encoding *) Tcl_GetEncoding(NULL, subTablePtr->name);
if ((encodingPtr == NULL)
- || (encodingPtr->toUtfProc != TableToUtfProc)) {
+ || (encodingPtr->toUtfProc != TableToUtfProc
+ && encodingPtr->toUtfProc != Iso88591ToUtfProc)) {
Tcl_Panic("EscapeToUtfProc: invalid sub table");
}
subTablePtr->encodingPtr = encodingPtr;
@@ -3350,3 +3546,4 @@ InitializeEncodingSearchPath(
* fill-column: 78
* End:
*/
+
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 60c166f..3efd610 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclExecute.c,v 1.285.2.21 2007/10/24 12:52:52 dgp Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.285.2.22 2007/11/12 19:18:16 dgp Exp $
*/
#include "tclInt.h"
@@ -1180,7 +1180,7 @@ Tcl_ExprObj(
/* TIP #280: No invoker (yet) - Expression compilation. */
int length;
- const char *string = Tcl_GetStringFromObj(objPtr, &length);
+ const char *string = TclGetStringFromObj(objPtr, &length);
TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0);
TclCompileExpr(interp, string, length, &compEnv);
@@ -1218,7 +1218,7 @@ Tcl_ExprObj(
saveObjPtr = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(saveObjPtr);
- Tcl_ResetResult(interp);
+ TclResetResult(interp);
/*
* Increment the code's ref count while it is being executed. If
@@ -1416,11 +1416,11 @@ TclIncrObj(
if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) {
/* Produce error message (reparse?!) */
- return Tcl_GetIntFromObj(interp, valuePtr, &type1);
+ return TclGetIntFromObj(interp, valuePtr, &type1);
}
if (GetNumberFromObj(NULL, incrPtr, &ptr2, &type2) != TCL_OK) {
/* Produce error message (reparse?!) */
- Tcl_GetIntFromObj(interp, incrPtr, &type1);
+ TclGetIntFromObj(interp, incrPtr, &type1);
Tcl_AddErrorInfo(interp, "\n (reading increment)");
return TCL_ERROR;
}
@@ -1461,14 +1461,14 @@ TclIncrObj(
* Produce error message (reparse?!)
*/
- return Tcl_GetIntFromObj(interp, valuePtr, &type1);
+ return TclGetIntFromObj(interp, valuePtr, &type1);
}
if ((type2 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_NAN)) {
/*
* Produce error message (reparse?!)
*/
- Tcl_GetIntFromObj(interp, incrPtr, &type1);
+ TclGetIntFromObj(interp, incrPtr, &type1);
Tcl_AddErrorInfo(interp, "\n (reading increment)");
return TCL_ERROR;
}
@@ -1734,7 +1734,7 @@ TclExecuteByteCode(
* ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-<1).
*/
- if (Tcl_AsyncReady()) {
+ if (TclAsyncReady(iPtr)) {
int localResult;
DECACHE_STACK_INFO();
@@ -1965,7 +1965,7 @@ TclExecuteByteCode(
*/
for (currPtr=&OBJ_AT_DEPTH(opnd-2); currPtr<=&OBJ_AT_TOS; currPtr++) {
- bytes = Tcl_GetStringFromObj(*currPtr, &length);
+ bytes = TclGetStringFromObj(*currPtr, &length);
if (bytes != NULL) {
appendLen += length;
}
@@ -1994,7 +1994,7 @@ TclExecuteByteCode(
*/
objResultPtr = OBJ_AT_DEPTH(opnd-1);
- bytes = Tcl_GetStringFromObj(objResultPtr, &length);
+ bytes = TclGetStringFromObj(objResultPtr, &length);
#if !TCL_COMPILE_DEBUG
if (!Tcl_IsShared(objResultPtr)) {
Tcl_SetObjLength(objResultPtr, (length + appendLen));
@@ -2016,7 +2016,7 @@ TclExecuteByteCode(
*/
for (; currPtr <= &OBJ_AT_TOS; currPtr++) {
- bytes = Tcl_GetStringFromObj(*currPtr, &length);
+ bytes = TclGetStringFromObj(*currPtr, &length);
if (bytes != NULL) {
memcpy(p, bytes, (size_t) length);
p += length;
@@ -2063,7 +2063,7 @@ TclExecuteByteCode(
*/
valuePtr = OBJ_AT_TOS;
- if (Tcl_ListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK){
+ if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK){
TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)),
Tcl_GetObjResult(interp));
result = TCL_ERROR;
@@ -3317,7 +3317,7 @@ TclExecuteByteCode(
opnd = TclGetInt4AtPtr(pc+1);
jtPtr = (JumptableInfo *) codePtr->auxDataArrayPtr[opnd].clientData;
TRACE(("%d => %.20s ", opnd, O2S(OBJ_AT_TOS)));
- hPtr = Tcl_FindHashEntry(&jtPtr->hashTable, Tcl_GetString(OBJ_AT_TOS));
+ hPtr = Tcl_FindHashEntry(&jtPtr->hashTable, TclGetString(OBJ_AT_TOS));
if (hPtr != NULL) {
int jumpOffset = PTR2INT(Tcl_GetHashValue(hPtr));
@@ -3397,7 +3397,7 @@ TclExecuteByteCode(
valuePtr = OBJ_AT_TOS;
- result = Tcl_ListObjLength(interp, valuePtr, &length);
+ result = TclListObjLength(interp, valuePtr, &length);
if (result == TCL_OK) {
TclNewIntObj(objResultPtr, length);
TRACE(("%.20s => %d\n", O2S(valuePtr), length));
@@ -3412,6 +3412,10 @@ TclExecuteByteCode(
case INST_LIST_INDEX: {
/*** lindex with objc == 3 ***/
+ /* Variables also for INST_LIST_INDEX_IMM */
+
+ int listc, idx, opnd, pcAdjustment;
+ Tcl_Obj **listv;
Tcl_Obj *valuePtr, *value2Ptr;
/*
@@ -3425,6 +3429,15 @@ TclExecuteByteCode(
* Extract the desired list element.
*/
+ result = TclListObjGetElements(interp, valuePtr, &listc, &listv);
+ if ((result == TCL_OK) && (value2Ptr->typePtr != &tclListType)
+ && (TclGetIntForIndexM(NULL , value2Ptr, listc-1, &idx) == TCL_OK)) {
+ Tcl_DecrRefCount(value2Ptr);
+ tosPtr--;
+ pcAdjustment = 1;
+ goto lindexFastPath;
+ }
+
objResultPtr = TclLindexList(interp, valuePtr, value2Ptr);
if (objResultPtr) {
/*
@@ -3440,14 +3453,11 @@ TclExecuteByteCode(
result = TCL_ERROR;
goto checkForCatch;
}
- }
- case INST_LIST_INDEX_IMM: {
+ case INST_LIST_INDEX_IMM:
/*** lindex with objc==3 and index in bytecode stream ***/
- int listc, idx, opnd;
- Tcl_Obj **listv;
- Tcl_Obj *valuePtr;
+ pcAdjustment = 5;
/*
* Pop the list and get the index.
@@ -3461,7 +3471,8 @@ TclExecuteByteCode(
* in the process.
*/
- result = Tcl_ListObjGetElements(interp, valuePtr, &listc, &listv);
+ result = TclListObjGetElements(interp, valuePtr, &listc, &listv);
+
if (result == TCL_OK) {
/*
* Select the list item based on the index. Negative operand means
@@ -3473,6 +3484,8 @@ TclExecuteByteCode(
} else {
idx = opnd;
}
+
+ lindexFastPath:
if (idx >= 0 && idx < listc) {
objResultPtr = listv[idx];
} else {
@@ -3481,7 +3494,7 @@ TclExecuteByteCode(
TRACE_WITH_OBJ(("\"%.30s\" %d => ", O2S(valuePtr), opnd),
objResultPtr);
- NEXT_INST_F(5, 1, 1);
+ NEXT_INST_F(pcAdjustment, 1, 1);
} else {
TRACE_WITH_OBJ(("\"%.30s\" %d => ERROR: ", O2S(valuePtr), opnd),
Tcl_GetObjResult(interp));
@@ -3645,8 +3658,7 @@ TclExecuteByteCode(
* Get the contents of the list, making sure that it really is a list
* in the process.
*/
-
- result = Tcl_ListObjGetElements(interp, valuePtr, &listc, &listv);
+ result = TclListObjGetElements(interp, valuePtr, &listc, &listv);
/*
* Skip a lot of work if we're about to throw the result away (common
@@ -3723,8 +3735,8 @@ TclExecuteByteCode(
valuePtr = OBJ_UNDER_TOS;
/* TODO: Consider more efficient tests than strcmp() */
- s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
- result = Tcl_ListObjLength(interp, value2Ptr, &llen);
+ s1 = TclGetStringFromObj(valuePtr, &s1len);
+ result = TclListObjLength(interp, value2Ptr, &llen);
if (result != TCL_OK) {
TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ERROR: ", O2S(valuePtr),
O2S(value2Ptr)), Tcl_GetObjResult(interp));
@@ -3740,7 +3752,7 @@ TclExecuteByteCode(
do {
Tcl_ListObjIndex(NULL, value2Ptr, i, &o);
if (o != NULL) {
- s2 = Tcl_GetStringFromObj(o, &s2len);
+ s2 = TclGetStringFromObj(o, &s2len);
} else {
s2 = "";
}
@@ -3809,8 +3821,8 @@ TclExecuteByteCode(
char *s1, *s2;
int s1len, s2len;
- s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
- s2 = Tcl_GetStringFromObj(value2Ptr, &s2len);
+ s1 = TclGetStringFromObj(valuePtr, &s1len);
+ s2 = TclGetStringFromObj(value2Ptr, &s2len);
if (s1len == s2len) {
/*
* We only need to check (in)equality when we have equal
@@ -3907,8 +3919,8 @@ TclExecuteByteCode(
* \xC0\x80 null encoding for utf-8.
*/
- s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
- s2 = Tcl_GetStringFromObj(value2Ptr, &s2len);
+ s1 = TclGetStringFromObj(valuePtr, &s1len);
+ s2 = TclGetStringFromObj(value2Ptr, &s2len);
iResult = TclpUtfNcmp2(s1, s2,
(size_t) ((s1len < s2len) ? s1len : s2len));
}
@@ -4005,7 +4017,7 @@ TclExecuteByteCode(
length = Tcl_GetCharLength(valuePtr);
}
- result = TclGetIntForIndex(interp, value2Ptr, length - 1, &index);
+ result = TclGetIntForIndexM(interp, value2Ptr, length - 1, &index);
if (result != TCL_OK) {
goto checkForCatch;
}
@@ -4063,6 +4075,13 @@ TclExecuteByteCode(
ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2);
match = TclUniCharMatch(ustring1, length1, ustring2, length2,
nocase);
+ } else if ((valuePtr->typePtr == &tclByteArrayType) && !nocase) {
+ unsigned char *string1, *string2;
+ int length1, length2;
+
+ string1 = Tcl_GetByteArrayFromObj(valuePtr, &length1);
+ string2 = Tcl_GetByteArrayFromObj(value2Ptr, &length2);
+ match = TclByteArrayMatch(string1, length1, string2, length2);
} else {
match = Tcl_StringCaseMatch(TclGetString(valuePtr),
TclGetString(value2Ptr), nocase);
@@ -4079,6 +4098,39 @@ TclExecuteByteCode(
NEXT_INST_F(2, 2, 1);
}
+ case INST_REGEXP: {
+ int nocase, match;
+ Tcl_Obj *valuePtr, *value2Ptr;
+ Tcl_RegExp regExpr;
+
+ nocase = TclGetInt1AtPtr(pc+1);
+ valuePtr = OBJ_AT_TOS; /* String */
+ value2Ptr = OBJ_UNDER_TOS; /* Pattern */
+
+ regExpr = Tcl_GetRegExpFromObj(interp, value2Ptr,
+ TCL_REG_ADVANCED | (nocase ? TCL_REG_NOCASE : 0));
+ if (regExpr == NULL) {
+ match = -1;
+ } else {
+ match = Tcl_RegExpExecObj(interp, regExpr, valuePtr, 0, 0, 0);
+ }
+
+ /*
+ * Adjustment is 2 due to the nocase byte
+ */
+
+ if (match < 0) {
+ objResultPtr = Tcl_GetObjResult(interp);
+ TRACE_WITH_OBJ(("%.20s %.20s => ERROR: ", O2S(valuePtr), O2S(value2Ptr)), objResultPtr);
+ result = TCL_ERROR;
+ goto checkForCatch;
+ } else {
+ TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match));
+ objResultPtr = constants[match];
+ NEXT_INST_F(2, 2, 1);
+ }
+ }
+
case INST_EQ:
case INST_NEQ:
case INST_LT:
@@ -6178,7 +6230,7 @@ TclExecuteByteCode(
listVarPtr = &(compiledLocals[listTmpIndex]);
listPtr = listVarPtr->value.objPtr;
- result = Tcl_ListObjLength(interp, listPtr, &listLen);
+ result = TclListObjLength(interp, listPtr, &listLen);
if (result == TCL_OK) {
if (listLen > (iterNum * numVars)) {
continueLoop = 1;
@@ -6208,7 +6260,7 @@ TclExecuteByteCode(
listVarPtr = &(compiledLocals[listTmpIndex]);
listPtr = TclListObjCopy(NULL, listVarPtr->value.objPtr);
- Tcl_ListObjGetElements(NULL, listPtr, &listLen, &elements);
+ TclListObjGetElements(interp, listPtr, &listLen, &elements);
valIndex = (iterNum * numVars);
for (j = 0; j < numVars; j++) {
@@ -6284,7 +6336,7 @@ TclExecuteByteCode(
case INST_END_CATCH:
catchTop--;
- Tcl_ResetResult(interp);
+ TclResetResult(interp);
result = TCL_OK;
TRACE(("=> catchTop=%d\n", (catchTop - initCatchTop - 1)));
NEXT_INST_F(1, 0, 0);
@@ -6702,7 +6754,7 @@ TclExecuteByteCode(
goto dictUpdateStartFailed;
}
}
- if (Tcl_ListObjGetElements(interp, OBJ_AT_TOS, &length,
+ if (TclListObjGetElements(interp, OBJ_AT_TOS, &length,
&keyPtrPtr) != TCL_OK) {
goto dictUpdateStartFailed;
}
@@ -6757,7 +6809,7 @@ TclExecuteByteCode(
NEXT_INST_F(9, 1, 0);
}
if (Tcl_DictObjSize(interp, dictPtr, &length) != TCL_OK
- || Tcl_ListObjGetElements(interp, OBJ_AT_TOS, &length,
+ || TclListObjGetElements(interp, OBJ_AT_TOS, &length,
&keyPtrPtr) != TCL_OK) {
result = TCL_ERROR;
goto checkForCatch;
diff --git a/generic/tclGet.c b/generic/tclGet.c
index 058323d..f0be043 100644
--- a/generic/tclGet.c
+++ b/generic/tclGet.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclGet.c,v 1.17 2005/11/07 15:13:36 dkf Exp $
+ * RCS: @(#) $Id: tclGet.c,v 1.17.8.1 2007/11/12 19:18:16 dgp Exp $
*/
#include "tclInt.h"
@@ -50,7 +50,7 @@ Tcl_GetInt(
obj.length = strlen(src);
obj.typePtr = NULL;
- code = Tcl_GetIntFromObj(interp, &obj, intPtr);
+ code = TclGetIntFromObj(interp, &obj, intPtr);
if (obj.refCount > 1) {
Tcl_Panic("invalid sharing of Tcl_Obj on C stack");
}
@@ -94,7 +94,7 @@ TclGetLong(
obj.length = strlen(src);
obj.typePtr = NULL;
- code = Tcl_GetLongFromObj(interp, &obj, longPtr);
+ code = TclGetLongFromObj(interp, &obj, longPtr);
if (obj.refCount > 1) {
Tcl_Panic("invalid sharing of Tcl_Obj on C stack");
}
diff --git a/generic/tclIO.c b/generic/tclIO.c
index c9822e9..c47eaea 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclIO.c,v 1.121.2.3 2007/09/17 15:03:44 dgp Exp $
+ * RCS: @(#) $Id: tclIO.c,v 1.121.2.4 2007/11/12 19:18:17 dgp Exp $
*/
#include "tclInt.h"
@@ -87,6 +87,7 @@ static int FilterInputBytes(Channel *chanPtr,
GetsState *statePtr);
static int FlushChannel(Tcl_Interp *interp, Channel *chanPtr,
int calledFromAsyncFlush);
+static int TclGetsObjBinary(Tcl_Channel chan, Tcl_Obj *objPtr);
static void FreeBinaryEncoding(ClientData clientData);
static Tcl_HashTable * GetChannelTable(Tcl_Interp *interp);
static int GetInput(Channel *chanPtr);
@@ -3231,15 +3232,20 @@ DoWriteChars(
/*
* Inefficient way to convert UTF-8 to byte-array, but the code
* parallels the way it is done for objects.
+ * Special case for 1-byte (used by eg [puts] for the \n) could
+ * be extended to more efficient translation of the src string.
*/
- Tcl_Obj *objPtr;
- int result;
+ int result;
- objPtr = Tcl_NewStringObj(src, len);
- src = (char *) Tcl_GetByteArrayFromObj(objPtr, &len);
- result = WriteBytes(chanPtr, src, len);
- TclDecrRefCount(objPtr);
+ if ((len == 1) && (UCHAR(*src) < 0xC0)) {
+ result = WriteBytes(chanPtr, src, len);
+ } else {
+ Tcl_Obj *objPtr = Tcl_NewStringObj(src, len);
+ src = (char *) Tcl_GetByteArrayFromObj(objPtr, &len);
+ result = WriteBytes(chanPtr, src, len);
+ TclDecrRefCount(objPtr);
+ }
return result;
}
return WriteChars(chanPtr, src, len);
@@ -3294,7 +3300,7 @@ Tcl_WriteObj(
src = (char *) Tcl_GetByteArrayFromObj(objPtr, &srcLen);
return WriteBytes(chanPtr, src, srcLen);
} else {
- src = Tcl_GetStringFromObj(objPtr, &srcLen);
+ src = TclGetStringFromObj(objPtr, &srcLen);
return WriteChars(chanPtr, src, srcLen);
}
}
@@ -3809,7 +3815,7 @@ Tcl_Gets(
TclNewObj(objPtr);
charsStored = Tcl_GetsObj(chan, objPtr);
if (charsStored > 0) {
- string = Tcl_GetStringFromObj(objPtr, &length);
+ string = TclGetStringFromObj(objPtr, &length);
Tcl_DStringAppend(lineRead, string, length);
}
TclDecrRefCount(objPtr);
@@ -3866,6 +3872,18 @@ Tcl_GetsObj(
goto done;
}
+ /*
+ * A binary version of Tcl_GetsObj. This could also handle encodings
+ * that are ascii-7 pure (iso8859, utf-8, ...) with a final encoding
+ * conversion done on objPtr.
+ */
+
+ if ((statePtr->encoding == NULL)
+ && ((statePtr->inputTranslation == TCL_TRANSLATE_LF)
+ || (statePtr->inputTranslation == TCL_TRANSLATE_CR))) {
+ return TclGetsObjBinary(chan, objPtr);
+ }
+
bufPtr = statePtr->inQueueHead;
encoding = statePtr->encoding;
@@ -3874,7 +3892,7 @@ Tcl_GetsObj(
* newline in the available input.
*/
- Tcl_GetStringFromObj(objPtr, &oldLength);
+ TclGetStringFromObj(objPtr, &oldLength);
oldFlags = statePtr->inputEncodingFlags;
oldState = statePtr->inputEncodingState;
oldRemoved = BUFFER_PADDING;
@@ -4171,6 +4189,244 @@ Tcl_GetsObj(
/*
*---------------------------------------------------------------------------
*
+ * TclGetsObjBinary --
+ *
+ * A variation of Tcl_GetsObj that works directly on the buffers until
+ * end-of-line or end-of-file has been seen. Bytes read from the input
+ * channel return as a ByteArray obj.
+ *
+ * Results:
+ * Number of characters accumulated in the object or -1 if error,
+ * blocked, or EOF. If -1, use Tcl_GetErrno() to retrieve the POSIX error
+ * code for the error or condition that occurred.
+ *
+ * Side effects:
+ * Consumes input from the channel.
+ *
+ * On reading EOF, leave channel pointing at EOF char. On reading EOL,
+ * leave channel pointing after EOL, but don't return EOL in dst buffer.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static int
+TclGetsObjBinary(
+ Tcl_Channel chan, /* Channel from which to read. */
+ Tcl_Obj *objPtr) /* The line read will be appended to this
+ * object as UTF-8 characters. */
+{
+ Channel *chanPtr = (Channel *) chan;
+ ChannelState *statePtr = chanPtr->state;
+ /* State info for channel */
+ ChannelBuffer *bufPtr;
+ int inEofChar, skip, copiedTotal, oldLength, oldFlags, oldRemoved;
+ int rawLen, byteLen, eolChar;
+ unsigned char *dst, *dstEnd, *eol, *eof, *byteArray;
+
+ bufPtr = statePtr->inQueueHead;
+
+ /*
+ * Preserved so we can restore the channel's state in case we don't find a
+ * newline in the available input.
+ */
+
+ byteArray = Tcl_GetByteArrayFromObj(objPtr, &byteLen);
+ oldFlags = statePtr->inputEncodingFlags;
+ oldRemoved = BUFFER_PADDING;
+ oldLength = byteLen;
+ if (bufPtr != NULL) {
+ oldRemoved = bufPtr->nextRemoved;
+ }
+
+ rawLen = 0;
+ skip = 0;
+ eof = NULL;
+ inEofChar = statePtr->inEofChar;
+ /* Only handle TCL_TRANSLATE_LF and TCL_TRANSLATE_CR */
+ eolChar = (statePtr->inputTranslation == TCL_TRANSLATE_LF) ? '\n' : '\r';
+
+ while (1) {
+ /*
+ * Subtract the number of bytes that were removed from channel
+ * buffer during last call.
+ */
+
+ if (bufPtr != NULL) {
+ bufPtr->nextRemoved += rawLen;
+ if (!IsBufferReady(bufPtr)) {
+ bufPtr = bufPtr->nextPtr;
+ }
+ }
+
+ if ((bufPtr == NULL) || (bufPtr->nextAdded == BUFFER_PADDING)) {
+ /*
+ * All channel buffers were exhausted and the caller still
+ * hasn't seen EOL. Need to read more bytes from the channel
+ * device. Side effect is to allocate another channel buffer.
+ */
+
+ if (statePtr->flags & CHANNEL_BLOCKED) {
+ if (statePtr->flags & CHANNEL_NONBLOCKING) {
+ goto restore;
+ }
+ statePtr->flags &= ~CHANNEL_BLOCKED;
+ }
+ if (GetInput(chanPtr) != 0) {
+ goto restore;
+ }
+ bufPtr = statePtr->inQueueTail;
+ }
+
+ dst = (unsigned char*) RemovePoint(bufPtr);
+ dstEnd = dst + BytesLeft(bufPtr);
+
+ /*
+ * Remember if EOF char is seen, then look for EOL anyhow, because the
+ * EOL might be before the EOF char.
+ * XXX - in the binary case, consider coincident search for eol/eof.
+ */
+
+ if (inEofChar != '\0') {
+ for (eol = dst; eol < dstEnd; eol++) {
+ if (*eol == inEofChar) {
+ dstEnd = eol;
+ eof = eol;
+ break;
+ }
+ }
+ }
+
+ /*
+ * On EOL, leave current file position pointing after the EOL, but
+ * don't store the EOL in the output string.
+ */
+
+ for (eol = dst; eol < dstEnd; eol++) {
+ if (*eol == eolChar) {
+ skip = 1;
+ goto gotEOL;
+ }
+ }
+ if (eof != NULL) {
+ /*
+ * EOF character was seen. On EOF, leave current file position
+ * pointing at the EOF character, but don't store the EOF
+ * character in the output string.
+ */
+
+ statePtr->flags |= CHANNEL_EOF | CHANNEL_STICKY_EOF;
+ statePtr->inputEncodingFlags |= TCL_ENCODING_END;
+ }
+ if (statePtr->flags & CHANNEL_EOF) {
+ skip = 0;
+ eol = dstEnd;
+ if ((dst == dstEnd) && (byteLen == oldLength)) {
+ /*
+ * If we didn't append any bytes before encountering EOF,
+ * caller needs to see -1.
+ */
+
+ byteArray = Tcl_SetByteArrayLength(objPtr, oldLength);
+ CommonGetsCleanup(chanPtr);
+ copiedTotal = -1;
+ goto done;
+ }
+ goto gotEOL;
+ }
+
+ /*
+ * Copy bytes from the channel buffer to the ByteArray.
+ * This may realloc space, so keep track of result.
+ */
+
+ rawLen = dstEnd - dst;
+ byteArray = Tcl_SetByteArrayLength(objPtr, byteLen + rawLen);
+ memcpy(byteArray + byteLen, dst, (size_t) rawLen);
+ byteLen += rawLen;
+ }
+
+ /*
+ * Found EOL or EOF, but the output buffer may now contain too many bytes.
+ * We need to know how many bytes correspond to the number we want, so we
+ * can remove the correct number of bytes from the channel buffer.
+ */
+
+ gotEOL:
+ if (bufPtr == NULL) {
+ Tcl_Panic("TclGetsObjBinary: gotEOL reached with bufPtr==NULL");
+ }
+
+ rawLen = eol - dst;
+ byteArray = Tcl_SetByteArrayLength(objPtr, byteLen + rawLen);
+ memcpy(byteArray + byteLen, dst, (size_t) rawLen);
+ byteLen += rawLen;
+ bufPtr->nextRemoved += rawLen + skip;
+
+ /*
+ * Convert the buffer if there was an encoding.
+ * XXX - unimplemented.
+ */
+
+ if (statePtr->encoding != NULL) {
+ }
+
+ /*
+ * Recycle all the emptied buffers.
+ */
+
+ CommonGetsCleanup(chanPtr);
+ statePtr->flags &= ~CHANNEL_BLOCKED;
+ copiedTotal = byteLen;
+ goto done;
+
+ /*
+ * Couldn't get a complete line. This only happens if we get a error
+ * reading from the channel or we are non-blocking and there wasn't an EOL
+ * or EOF in the data available.
+ */
+
+ restore:
+ bufPtr = statePtr->inQueueHead;
+ if (bufPtr == NULL) {
+ Tcl_Panic("TclGetsObjBinary: restore reached with bufPtr==NULL");
+ }
+ bufPtr->nextRemoved = oldRemoved;
+
+ for (bufPtr = bufPtr->nextPtr; bufPtr != NULL; bufPtr = bufPtr->nextPtr) {
+ bufPtr->nextRemoved = BUFFER_PADDING;
+ }
+ CommonGetsCleanup(chanPtr);
+
+ statePtr->inputEncodingFlags = oldFlags;
+ byteArray = Tcl_SetByteArrayLength(objPtr, oldLength);
+
+ /*
+ * We didn't get a complete line so we need to indicate to UpdateInterest
+ * that the gets blocked. It will wait for more data instead of firing a
+ * timer, avoiding a busy wait. This is where we are assuming that the
+ * next operation is a gets. No more file events will be delivered on this
+ * channel until new data arrives or some operation is performed on the
+ * channel (e.g. gets, read, fconfigure) that changes the blocking state.
+ * Note that this means a file event will not be delivered even though a
+ * read would be able to consume the buffered data.
+ */
+
+ statePtr->flags |= CHANNEL_NEED_MORE_DATA;
+ copiedTotal = -1;
+
+ /*
+ * Update the notifier state so we don't block while there is still data
+ * in the buffers.
+ */
+
+ done:
+ UpdateInterest(chanPtr);
+ return copiedTotal;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
* FreeBinaryEncoding --
* Frees any "iso8859-1" Tcl_Encoding created by [gets] on a binary
* channel in a thread as part of that thread's finalization.
@@ -4224,7 +4480,7 @@ FilterInputBytes(
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
ChannelBuffer *bufPtr;
- char *raw, *rawStart, *rawEnd, *dst;
+ char *raw, *rawStart, *dst;
int offset, toRead, dstNeeded, spaceLeft, result, rawLen, length;
Tcl_Obj *objPtr;
#define ENCODING_LINESIZE 20 /* Lower bound on how many bytes to convert at
@@ -4283,7 +4539,6 @@ FilterInputBytes(
rawStart = RemovePoint(bufPtr);
raw = rawStart;
- rawEnd = InsertPoint(bufPtr);
rawLen = BytesLeft(bufPtr);
dst = *gsPtr->dstPtr;
@@ -4839,14 +5094,14 @@ DoReadChars(
* been pure Unicode).
*/
- Tcl_GetString(objPtr);
+ TclGetString(objPtr);
}
offset = 0;
} else {
if (encoding == NULL) {
Tcl_GetByteArrayFromObj(objPtr, &offset);
} else {
- Tcl_GetStringFromObj(objPtr, &offset);
+ TclGetStringFromObj(objPtr, &offset);
}
}
@@ -8291,7 +8546,7 @@ CopyData(
buffer = csPtr->buffer;
sizeb = size;
} else {
- buffer = Tcl_GetStringFromObj(bufObj, &sizeb);
+ buffer = TclGetStringFromObj(bufObj, &sizeb);
}
if (outBinary || sameEncoding) {
@@ -10020,7 +10275,7 @@ FixLevelCode(
* !"error", !integer, integer != 1 (numeric code for error)
*/
- res = Tcl_GetIntFromObj(NULL, lv[i+1], &val);
+ res = TclGetIntFromObj(NULL, lv[i+1], &val);
if (((res == TCL_OK) && (val != 1)) || ((res != TCL_OK) &&
(0 != strcmp(TclGetString(lv[i+1]), "error")))) {
newcode = 1;
@@ -10030,7 +10285,7 @@ FixLevelCode(
* !integer, integer != 0
*/
- res = Tcl_GetIntFromObj(NULL, lv [i+1], &val);
+ res = TclGetIntFromObj(NULL, lv [i+1], &val);
if ((res != TCL_OK) || (val != 0)) {
newlevel = 0;
}
diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c
index 02fe534..7e5d184 100644
--- a/generic/tclIOCmd.c
+++ b/generic/tclIOCmd.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclIOCmd.c,v 1.40.2.4 2007/10/16 03:50:31 dgp Exp $
+ * RCS: @(#) $Id: tclIOCmd.c,v 1.40.2.5 2007/11/12 19:18:17 dgp Exp $
*/
#include "tclInt.h"
@@ -77,19 +77,19 @@ Tcl_PutsObjCmd(
break;
case 3: /* [puts -nonewline $x] or [puts $chan $x] */
- if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) {
+ if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) {
newline = 0;
channelId = "stdout";
} else {
newline = 1;
- channelId = Tcl_GetString(objv[1]);
+ channelId = TclGetString(objv[1]);
}
string = objv[2];
break;
case 4: /* [puts -nonewline $chan $x] or [puts $chan $x nonewline] */
- if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) {
- channelId = Tcl_GetString(objv[2]);
+ if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) {
+ channelId = TclGetString(objv[2]);
string = objv[3];
} else {
/*
@@ -101,14 +101,14 @@ Tcl_PutsObjCmd(
char *arg;
int length;
- arg = Tcl_GetStringFromObj(objv[3], &length);
+ arg = TclGetStringFromObj(objv[3], &length);
if ((length != 9)
|| (strncmp(arg, "nonewline", (size_t) length) != 0)) {
Tcl_AppendResult(interp, "bad argument \"", arg,
"\": should be \"nonewline\"", NULL);
return TCL_ERROR;
}
- channelId = Tcl_GetString(objv[1]);
+ channelId = TclGetString(objv[1]);
string = objv[2];
}
newline = 0;
@@ -190,7 +190,7 @@ Tcl_FlushObjCmd(
Tcl_WrongNumArgs(interp, 1, objv, "channelId");
return TCL_ERROR;
}
- channelId = Tcl_GetString(objv[1]);
+ channelId = TclGetString(objv[1]);
chan = Tcl_GetChannel(interp, channelId, &mode);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
@@ -253,7 +253,7 @@ Tcl_GetsObjCmd(
Tcl_WrongNumArgs(interp, 1, objv, "channelId ?varName?");
return TCL_ERROR;
}
- name = Tcl_GetString(objv[1]);
+ name = TclGetString(objv[1]);
chan = Tcl_GetChannel(interp, name, &mode);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
@@ -352,7 +352,7 @@ Tcl_ReadObjCmd(
i = 1;
newline = 0;
- if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) {
+ if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) {
newline = 1;
i++;
}
@@ -361,7 +361,7 @@ Tcl_ReadObjCmd(
goto argerror;
}
- name = Tcl_GetString(objv[i]);
+ name = TclGetString(objv[i]);
chan = Tcl_GetChannel(interp, name, &mode);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
@@ -382,9 +382,9 @@ Tcl_ReadObjCmd(
if (i < objc) {
char *arg;
- arg = Tcl_GetString(objv[i]);
+ arg = TclGetString(objv[i]);
if (isdigit(UCHAR(arg[0]))) { /* INTL: digit */
- if (Tcl_GetIntFromObj(interp, objv[i], &toRead) != TCL_OK) {
+ if (TclGetIntFromObj(interp, objv[i], &toRead) != TCL_OK) {
return TCL_ERROR;
}
} else if (strcmp(arg, "nonewline") == 0) {
@@ -424,7 +424,7 @@ Tcl_ReadObjCmd(
char *result;
int length;
- result = Tcl_GetStringFromObj(resultPtr, &length);
+ result = TclGetStringFromObj(resultPtr, &length);
if (result[length - 1] == '\n') {
Tcl_SetObjLength(resultPtr, length - 1);
}
@@ -475,7 +475,7 @@ Tcl_SeekObjCmd(
Tcl_WrongNumArgs(interp, 1, objv, "channelId offset ?origin?");
return TCL_ERROR;
}
- chanName = Tcl_GetString(objv[1]);
+ chanName = TclGetString(objv[1]);
chan = Tcl_GetChannel(interp, chanName, NULL);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
@@ -548,7 +548,7 @@ Tcl_TellObjCmd(
* channel table of this interpreter.
*/
- chanName = Tcl_GetString(objv[1]);
+ chanName = TclGetString(objv[1]);
chan = Tcl_GetChannel(interp, chanName, NULL);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
@@ -603,7 +603,7 @@ Tcl_CloseObjCmd(
return TCL_ERROR;
}
- arg = Tcl_GetString(objv[1]);
+ arg = TclGetString(objv[1]);
chan = Tcl_GetChannel(interp, arg, NULL);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
@@ -630,7 +630,7 @@ Tcl_CloseObjCmd(
resultPtr = Tcl_DuplicateObj(resultPtr);
Tcl_SetObjResult(interp, resultPtr);
}
- string = Tcl_GetStringFromObj(resultPtr, &len);
+ string = TclGetStringFromObj(resultPtr, &len);
if ((len > 0) && (string[len - 1] == '\n')) {
Tcl_SetObjLength(resultPtr, len - 1);
}
@@ -675,7 +675,7 @@ Tcl_FconfigureObjCmd(
return TCL_ERROR;
}
- chanName = Tcl_GetString(objv[1]);
+ chanName = TclGetString(objv[1]);
chan = Tcl_GetChannel(interp, chanName, NULL);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
@@ -697,7 +697,7 @@ Tcl_FconfigureObjCmd(
* Tcl_GetChannelOption. */
Tcl_DStringInit(&ds);
- optionName = Tcl_GetString(objv[2]);
+ optionName = TclGetString(objv[2]);
if (Tcl_GetChannelOption(interp, chan, optionName, &ds) != TCL_OK) {
Tcl_DStringFree(&ds);
return TCL_ERROR;
@@ -707,8 +707,8 @@ Tcl_FconfigureObjCmd(
}
for (i = 3; i < objc; i += 2) {
- optionName = Tcl_GetString(objv[i-1]);
- valueName = Tcl_GetString(objv[i]);
+ optionName = TclGetString(objv[i-1]);
+ valueName = TclGetString(objv[i]);
if (Tcl_SetChannelOption(interp, chan, optionName, valueName)
!= TCL_OK) {
return TCL_ERROR;
@@ -753,7 +753,7 @@ Tcl_EofObjCmd(
return TCL_ERROR;
}
- arg = Tcl_GetString(objv[1]);
+ arg = TclGetString(objv[1]);
chan = Tcl_GetChannel(interp, arg, &dummy);
if (chan == NULL) {
return TCL_ERROR;
@@ -814,7 +814,7 @@ Tcl_ExecObjCmd(
keepNewline = 0;
ignoreStderr = 0;
for (skip = 1; skip < objc; skip++) {
- string = Tcl_GetString(objv[skip]);
+ string = TclGetString(objv[skip]);
if (string[0] != '-') {
break;
}
@@ -841,7 +841,7 @@ Tcl_ExecObjCmd(
*/
background = 0;
- string = Tcl_GetString(objv[objc - 1]);
+ string = TclGetString(objv[objc - 1]);
if ((string[0] == '&') && (string[1] == '\0')) {
objc--;
background = 1;
@@ -862,7 +862,7 @@ Tcl_ExecObjCmd(
*/
for (i = 0; i < argc; i++) {
- argv[i] = Tcl_GetString(objv[i + skip]);
+ argv[i] = TclGetString(objv[i + skip]);
}
argv[argc] = NULL;
chan = Tcl_OpenCommandChannel(interp, argc, argv, (background ? 0 :
@@ -926,7 +926,7 @@ Tcl_ExecObjCmd(
*/
if (keepNewline == 0) {
- string = Tcl_GetStringFromObj(resultPtr, &length);
+ string = TclGetStringFromObj(resultPtr, &length);
if ((length > 0) && (string[length - 1] == '\n')) {
Tcl_SetObjLength(resultPtr, length - 1);
}
@@ -971,7 +971,7 @@ Tcl_FblockedObjCmd(
return TCL_ERROR;
}
- arg = Tcl_GetString(objv[1]);
+ arg = TclGetString(objv[1]);
chan = Tcl_GetChannel(interp, arg, &mode);
if (chan == NULL) {
return TCL_ERROR;
@@ -1023,7 +1023,7 @@ Tcl_OpenObjCmd(
if (objc == 2) {
modeString = "r";
} else {
- modeString = Tcl_GetString(objv[2]);
+ modeString = TclGetString(objv[2]);
if (objc == 4) {
char *permString = TclGetString(objv[3]);
int code = TCL_ERROR;
@@ -1038,19 +1038,19 @@ Tcl_OpenObjCmd(
TclNewLiteralStringObj(permObj, "0o");
Tcl_AppendToObj(permObj, permString+scanned+1, -1);
- code = Tcl_GetIntFromObj(NULL, permObj, &prot);
+ code = TclGetIntFromObj(NULL, permObj, &prot);
Tcl_DecrRefCount(permObj);
}
if ((code == TCL_ERROR)
- && Tcl_GetIntFromObj(interp, objv[3], &prot) != TCL_OK) {
+ && TclGetIntFromObj(interp, objv[3], &prot) != TCL_OK) {
return TCL_ERROR;
}
}
}
pipeline = 0;
- what = Tcl_GetString(objv[1]);
+ what = TclGetString(objv[1]);
if (what[0] == '|') {
pipeline = 1;
}
@@ -1410,7 +1410,7 @@ Tcl_SocketObjCmd(
}
for (a = 1; a < objc; a++) {
- arg = Tcl_GetString(objv[a]);
+ arg = TclGetString(objv[a]);
if (arg[0] != '-') {
break;
}
@@ -1434,7 +1434,7 @@ Tcl_SocketObjCmd(
"no argument given for -myaddr option", NULL);
return TCL_ERROR;
}
- myaddr = Tcl_GetString(objv[a]);
+ myaddr = TclGetString(objv[a]);
break;
case SKT_MYPORT: {
char *myPortName;
@@ -1445,7 +1445,7 @@ Tcl_SocketObjCmd(
"no argument given for -myport option", NULL);
return TCL_ERROR;
}
- myPortName = Tcl_GetString(objv[a]);
+ myPortName = TclGetString(objv[a]);
if (TclSockGetPort(interp, myPortName, "tcp", &myport) != TCL_OK) {
return TCL_ERROR;
}
@@ -1464,7 +1464,7 @@ Tcl_SocketObjCmd(
"no argument given for -server option", NULL);
return TCL_ERROR;
}
- script = Tcl_GetString(objv[a]);
+ script = TclGetString(objv[a]);
break;
default:
Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions");
@@ -1478,7 +1478,7 @@ Tcl_SocketObjCmd(
return TCL_ERROR;
}
} else if (a < objc) {
- host = Tcl_GetString(objv[a]);
+ host = TclGetString(objv[a]);
a++;
} else {
Interp *iPtr;
@@ -1495,7 +1495,7 @@ Tcl_SocketObjCmd(
}
if (a == objc-1) {
- if (TclSockGetPort(interp, Tcl_GetString(objv[a]), "tcp",
+ if (TclSockGetPort(interp, TclGetString(objv[a]), "tcp",
&port) != TCL_OK) {
return TCL_ERROR;
}
@@ -1591,7 +1591,7 @@ Tcl_FcopyObjCmd(
* writable, as appropriate.
*/
- arg = Tcl_GetString(objv[1]);
+ arg = TclGetString(objv[1]);
inChan = Tcl_GetChannel(interp, arg, &mode);
if (inChan == (Tcl_Channel) NULL) {
return TCL_ERROR;
@@ -1601,7 +1601,7 @@ Tcl_FcopyObjCmd(
"\" wasn't opened for reading", NULL);
return TCL_ERROR;
}
- arg = Tcl_GetString(objv[2]);
+ arg = TclGetString(objv[2]);
outChan = Tcl_GetChannel(interp, arg, &mode);
if (outChan == (Tcl_Channel) NULL) {
return TCL_ERROR;
@@ -1621,7 +1621,7 @@ Tcl_FcopyObjCmd(
}
switch (index) {
case FcopySize:
- if (Tcl_GetIntFromObj(interp, objv[i+1], &toRead) != TCL_OK) {
+ if (TclGetIntFromObj(interp, objv[i+1], &toRead) != TCL_OK) {
return TCL_ERROR;
}
break;
@@ -1678,7 +1678,7 @@ TclChanPendingObjCmd(
return TCL_ERROR;
}
- arg = Tcl_GetString(objv[2]);
+ arg = TclGetString(objv[2]);
chan = Tcl_GetChannel(interp, arg, &mode);
if (chan == NULL) {
return TCL_ERROR;
diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c
index 2460e4a..99a058c 100644
--- a/generic/tclIOGT.c
+++ b/generic/tclIOGT.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * CVS: $Id: tclIOGT.c,v 1.17 2007/04/17 14:49:53 dkf Exp $
+ * CVS: $Id: tclIOGT.c,v 1.17.2.1 2007/11/12 19:18:17 dgp Exp $
*/
#include "tclInt.h"
@@ -451,7 +451,7 @@ ExecuteCallback(
*/
resObj = Tcl_GetObjResult(dataPtr->interp);
- Tcl_GetIntFromObj(dataPtr->interp, resObj, &dataPtr->maxRead);
+ TclGetIntFromObj(dataPtr->interp, resObj, &dataPtr->maxRead);
break;
}
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index eac627a..e32578d 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -17,7 +17,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclIOUtil.c,v 1.145.2.1 2007/09/04 17:43:50 dgp Exp $
+ * RCS: @(#) $Id: tclIOUtil.c,v 1.145.2.2 2007/11/12 19:18:17 dgp Exp $
*/
#include "tclInt.h"
@@ -3813,7 +3813,7 @@ Tcl_FSSplitPath(
*/
if (lenPtr != NULL) {
- Tcl_ListObjLength(NULL, result, lenPtr);
+ TclListObjLength(NULL, result, lenPtr);
}
return result;
}
diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c
index f5b4001..a264c36 100644
--- a/generic/tclIndexObj.c
+++ b/generic/tclIndexObj.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclIndexObj.c,v 1.32.2.2 2007/06/21 16:04:56 dgp Exp $
+ * RCS: @(#) $Id: tclIndexObj.c,v 1.32.2.3 2007/11/12 19:18:18 dgp Exp $
*/
#include "tclInt.h"
@@ -533,7 +533,7 @@ Tcl_WrongNumArgs(
elementStr = ecrPtr->fullSubcmdName;
elemLen = strlen(elementStr);
} else {
- elementStr = Tcl_GetStringFromObj(origObjv[i], &elemLen);
+ elementStr = TclGetStringFromObj(origObjv[i], &elemLen);
}
len = Tcl_ScanCountedElement(elementStr, elemLen, &flags);
@@ -588,7 +588,7 @@ Tcl_WrongNumArgs(
* Quote the argument if it contains spaces (Bug 942757).
*/
- elementStr = Tcl_GetStringFromObj(objv[i], &elemLen);
+ elementStr = TclGetStringFromObj(objv[i], &elemLen);
len = Tcl_ScanCountedElement(elementStr, elemLen, &flags);
if (MAY_QUOTE_WORD && len != elemLen) {
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index 0db281b..2f24ca0 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -12,7 +12,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: tclInt.decls,v 1.108.2.4 2007/09/06 18:20:31 dgp Exp $
+# RCS: @(#) $Id: tclInt.decls,v 1.108.2.5 2007/11/12 19:18:18 dgp Exp $
library tcl
@@ -942,6 +942,17 @@ declare 236 generic {
void TclBackgroundException(Tcl_Interp *interp, int code)
}
+# Added for 8.5b3 to improve binary glob match case
+declare 237 generic {
+ int TclByteArrayMatch(const unsigned char *string, int strLen,
+ const unsigned char *pattern, int ptnLen)
+}
+
+# Added for 8.5b3 to generalize check for RE to glob pattern conversion
+declare 238 generic {
+ int TclReToGlob(Tcl_Interp *interp, const char *reStr, int reStrLen,
+ Tcl_DString *dsPtr, int *exactPtr)
+}
##############################################################################
diff --git a/generic/tclInt.h b/generic/tclInt.h
index a00c8c2..bf304c8 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.310.2.12 2007/11/01 16:25:57 dgp Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.310.2.13 2007/11/12 19:18:18 dgp Exp $
*/
#ifndef _TCLINT
@@ -1837,17 +1837,51 @@ typedef struct Interp {
Tcl_HashTable varSearches; /* Hashtable holding the start of a variable's
* active searches list; varPtr is the key */
/*
+ * The thread-specific data ekeko: cache pointers or values that
+ * (a) do not change during the thread's lifetime
+ * (b) require access to TSD to determine at runtime
+ * (c) are accessed very often (eg, at each command call)
+ *
+ * Note that these are the same for all interps in the same thread. They
+ * just have to be initialised for the thread's master interp, slaves
+ * inherit the value.
+ *
+ * They are used by the macros defined below.
+ */
+
+ void *allocCache;
+ void *pendingObjDataPtr; /* Pointer to the Cache and PendingObjData
+ * structs for this interp's thread; see
+ * tclObj.c and tclThreadAlloc.c */
+ int *asyncReadyPtr; /* Pointer to the asyncReady indicator for
+ * this interp's thread; see tclAsync.c */
+ int *stackBound; /* Pointer to the limit stack address
+ * allowable for invoking a new command
+ * without "risking" a C-stack overflow;
+ * see TclpCheckStackSpace in the
+ * platform's directory. */
+
+
+#ifdef TCL_COMPILE_STATS
+ /*
* Statistical information about the bytecode compiler and interpreter's
* operation.
*/
-#ifdef TCL_COMPILE_STATS
ByteCodeStats stats; /* Holds compilation and execution statistics
* for this interpreter. */
#endif /* TCL_COMPILE_STATS */
} Interp;
/*
+ * Macros that use the TSD-ekeko
+ */
+
+#define TclAsyncReady(iPtr) \
+ *((iPtr)->asyncReadyPtr)
+
+
+/*
* General list of interpreters. Doubly linked for easier removal of items
* deep in the list.
*/
@@ -1939,6 +1973,39 @@ typedef struct InterpList {
#define INTERP_TRACE_IN_PROGRESS 0x200
#define INTERP_ALTERNATE_WRONG_ARGS 0x400
#define ERR_LEGACY_COPY 0x800
+#define INTERP_RESULT_UNCLEAN 0x1000
+
+/*
+ * The following macro resets the interp's obj result and returns 1 if a call
+ * to the full Tcl_ResetResult is needed. TclResetResult macro uses it.
+ */
+
+#define ResetObjResultM(iPtr) \
+ { \
+ register Tcl_Obj *objResultPtr = (iPtr)->objResultPtr; \
+ \
+ if (Tcl_IsShared(objResultPtr)) {\
+ TclDecrRefCount(objResultPtr);\
+ TclNewObj(objResultPtr);\
+ Tcl_IncrRefCount(objResultPtr);\
+ (iPtr)->objResultPtr = objResultPtr; \
+ } else if (objResultPtr->bytes != tclEmptyStringRep) { \
+ if (objResultPtr->bytes != NULL) {\
+ ckfree((char *) objResultPtr->bytes); \
+ }\
+ objResultPtr->bytes = tclEmptyStringRep;\
+ objResultPtr->length = 0;\
+ TclFreeIntRep(objResultPtr);\
+ objResultPtr->typePtr = NULL;\
+ }\
+ }
+
+#define TclResetResult(iPtr) \
+ {\
+ ResetObjResultM((Interp *)(iPtr)); \
+ if (((Interp *)(iPtr))->flags & INTERP_RESULT_UNCLEAN) \
+ TclCleanResult((Interp *)(iPtr)); \
+ }\
/*
* Maximum number of levels of nesting permitted in Tcl commands (used to
@@ -2065,17 +2132,56 @@ typedef struct List {
} List;
/*
- * Macro used to get the elements of a list object - do NOT forget to verify
- * that it is of list type before using!
+ * Macro used to get the elements of a list object.
*/
-#define TclListObjGetElements(listPtr, objc, objv) \
- { \
- List *listRepPtr = \
- (List *) (listPtr)->internalRep.twoPtrValue.ptr1;\
- (objc) = listRepPtr->elemCount;\
- (objv) = &listRepPtr->elements;\
- }
+#define ListRepPtr(listPtr) \
+ ((List *) (listPtr)->internalRep.twoPtrValue.ptr1)
+
+#define ListObjGetElements(listPtr, objc, objv) \
+ ((objv) = &(ListRepPtr(listPtr)->elements), \
+ (objc) = ListRepPtr(listPtr)->elemCount)
+
+#define ListObjLength(listPtr, len) \
+ ((len) = ListRepPtr(listPtr)->elemCount)
+
+#define TclListObjGetElements(interp, listPtr, objcPtr, objvPtr) \
+ (((listPtr)->typePtr == &tclListType) \
+ ? ((ListObjGetElements((listPtr), *(objcPtr), *(objvPtr))), TCL_OK)\
+ : Tcl_ListObjGetElements((interp), (listPtr), (objcPtr), (objvPtr)))
+
+#define TclListObjLength(interp, listPtr, lenPtr) \
+ (((listPtr)->typePtr == &tclListType) \
+ ? ((ListObjLength((listPtr), *(lenPtr))), TCL_OK)\
+ : Tcl_ListObjLength((interp), (listPtr), (lenPtr)))
+
+/*
+ * Macros providing a faster path to integers: Tcl_GetLongFromObj everywhere,
+ * Tcl_GetIntFromObj and TclGetIntForIndex on platforms where longs are ints.
+ *
+ * WARNING: these macros eval their args more than once.
+ */
+
+#define TclGetLongFromObj(interp, objPtr, longPtr) \
+ (((objPtr)->typePtr == &tclIntType) \
+ ? ((*(longPtr) = (long) (objPtr)->internalRep.otherValuePtr), TCL_OK) \
+ : Tcl_GetLongFromObj((interp), (objPtr), (longPtr)))
+
+#if (LONG_MAX == INT_MAX)
+#define TclGetIntFromObj(interp, objPtr, intPtr) \
+ (((objPtr)->typePtr == &tclIntType) \
+ ? ((*(intPtr) = (long) (objPtr)->internalRep.otherValuePtr), TCL_OK) \
+ : Tcl_GetIntFromObj((interp), (objPtr), (intPtr)))
+#define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \
+ (((objPtr)->typePtr == &tclIntType) \
+ ? ((*(idxPtr) = (long) (objPtr)->internalRep.otherValuePtr), TCL_OK) \
+ : TclGetIntForIndex((interp), (objPtr), (endValue), (idxPtr)))
+#else
+#define TclGetIntFromObj(interp, objPtr, intPtr) \
+ Tcl_GetIntFromObj((interp), (objPtr), (intPtr))
+#define TclGetIntForIndexM(interp, objPtr, ignore, idxPtr) \
+ TclGetIntForIndex(interp, objPtr, ignore, idxPtr)
+#endif
/*
* Flag values for TclTraceDictPath().
@@ -2343,6 +2449,7 @@ MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp,
Tcl_Channel chan);
MODULE_SCOPE void TclCleanupLiteralTable(Tcl_Interp *interp,
LiteralTable *tablePtr);
+MODULE_SCOPE void TclCleanResult(Interp *iPtr);
MODULE_SCOPE int TclDoubleDigits(char *buf, double value, int *signum);
MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr);
/* TIP #280 - Modified token based evulation, with line information */
@@ -2381,6 +2488,7 @@ MODULE_SCOPE double TclFloor(mp_int *a);
MODULE_SCOPE void TclFormatNaN(double value, char *buffer);
MODULE_SCOPE int TclFSFileAttrIndex(Tcl_Obj *pathPtr,
CONST char *attributeName, int *indexPtr);
+MODULE_SCOPE int * TclGetAsyncReadyPtr(void);
MODULE_SCOPE Tcl_Obj * TclGetBgErrorHandler(Tcl_Interp *interp);
MODULE_SCOPE int TclGetNumberFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, ClientData *clientDataPtr,
@@ -2466,8 +2574,10 @@ MODULE_SCOPE void TclParseInit(Tcl_Interp *interp, CONST char *string,
MODULE_SCOPE int TclParseAllWhiteSpace(CONST char *src, int numBytes);
MODULE_SCOPE int TclProcessReturn(Tcl_Interp *interp,
int code, int level, Tcl_Obj *returnOpts);
+#ifndef TCL_NO_STACK_CHECK
+MODULE_SCOPE int TclpGetCStackParams(int **stackBoundPtr);
+#endif
MODULE_SCOPE int TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf);
-MODULE_SCOPE int TclpCheckStackSpace(void);
MODULE_SCOPE Tcl_Obj * TclpTempFileName(void);
MODULE_SCOPE Tcl_Obj * TclNewFSPathObj(Tcl_Obj *dirPtr, CONST char *addStrRep,
int len);
@@ -2565,7 +2675,7 @@ MODULE_SCOPE void TclpFinalizeThreadDataThread(void);
MODULE_SCOPE void TclFinalizeThreadStorage(void);
#ifdef TCL_WIDE_CLICKS
MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void);
-MODULE_SCOPE Tcl_WideInt TclpWideClicksToNanoseconds(Tcl_WideInt clicks);
+MODULE_SCOPE double TclpWideClicksToNanoseconds(Tcl_WideInt clicks);
#endif
MODULE_SCOPE Tcl_Obj * TclDisassembleByteCodeObj(Tcl_Obj *objPtr);
@@ -3256,6 +3366,12 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr);
#define TclGetString(objPtr) \
((objPtr)->bytes? (objPtr)->bytes : Tcl_GetString((objPtr)))
+
+#define TclGetStringFromObj(objPtr, lenPtr) \
+ ((objPtr)->bytes \
+ ? (*(lenPtr) = (objPtr)->length, (objPtr)->bytes) \
+ : Tcl_GetStringFromObj((objPtr), (lenPtr)))
+
/*
*----------------------------------------------------------------
* Macro used by the Tcl core to clean out an object's internal
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index 5f931d0..afa3807 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclIntDecls.h,v 1.99.2.4 2007/09/06 18:20:31 dgp Exp $
+ * RCS: @(#) $Id: tclIntDecls.h,v 1.99.2.5 2007/11/12 19:18:19 dgp Exp $
*/
#ifndef _TCLINTDECLS
@@ -1057,6 +1057,20 @@ EXTERN void TclInitVarHashTable (TclVarHashTable * tablePtr,
EXTERN void TclBackgroundException (Tcl_Interp * interp,
int code);
#endif
+#ifndef TclByteArrayMatch_TCL_DECLARED
+#define TclByteArrayMatch_TCL_DECLARED
+/* 237 */
+EXTERN int TclByteArrayMatch (const unsigned char * string,
+ int strLen, const unsigned char * pattern,
+ int ptnLen);
+#endif
+#ifndef TclReToGlob_TCL_DECLARED
+#define TclReToGlob_TCL_DECLARED
+/* 238 */
+EXTERN int TclReToGlob (Tcl_Interp * interp, const char * reStr,
+ int reStrLen, Tcl_DString * dsPtr,
+ int * exactPtr);
+#endif
typedef struct TclIntStubs {
int magic;
@@ -1314,6 +1328,8 @@ typedef struct TclIntStubs {
Var * (*tclVarHashCreateVar) (TclVarHashTable * tablePtr, const char * key, int * newPtr); /* 234 */
void (*tclInitVarHashTable) (TclVarHashTable * tablePtr, Namespace * nsPtr); /* 235 */
void (*tclBackgroundException) (Tcl_Interp * interp, int code); /* 236 */
+ int (*tclByteArrayMatch) (const unsigned char * string, int strLen, const unsigned char * pattern, int ptnLen); /* 237 */
+ int (*tclReToGlob) (Tcl_Interp * interp, const char * reStr, int reStrLen, Tcl_DString * dsPtr, int * exactPtr); /* 238 */
} TclIntStubs;
#ifdef __cplusplus
@@ -2047,6 +2063,14 @@ extern TclIntStubs *tclIntStubsPtr;
#define TclBackgroundException \
(tclIntStubsPtr->tclBackgroundException) /* 236 */
#endif
+#ifndef TclByteArrayMatch
+#define TclByteArrayMatch \
+ (tclIntStubsPtr->tclByteArrayMatch) /* 237 */
+#endif
+#ifndef TclReToGlob
+#define TclReToGlob \
+ (tclIntStubsPtr->tclReToGlob) /* 238 */
+#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 9e0c55f..4251088 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInterp.c,v 1.74.2.4 2007/09/07 01:23:37 dgp Exp $
+ * RCS: @(#) $Id: tclInterp.c,v 1.74.2.5 2007/11/12 19:18:19 dgp Exp $
*/
#include "tclInt.h"
@@ -597,7 +597,7 @@ Tcl_InterpObjCmd(
if (objc == 4) {
return AliasDescribe(interp, slaveInterp, objv[3]);
}
- if ((objc == 5) && (Tcl_GetString(objv[4])[0] == '\0')) {
+ if ((objc == 5) && (TclGetString(objv[4])[0] == '\0')) {
return AliasDelete(interp, slaveInterp, objv[3]);
}
if (objc > 5) {
@@ -605,7 +605,7 @@ Tcl_InterpObjCmd(
if (masterInterp == (Tcl_Interp *) NULL) {
return TCL_ERROR;
}
- if (Tcl_GetString(objv[5])[0] == '\0') {
+ if (TclGetString(objv[5])[0] == '\0') {
if (objc == 6) {
return AliasDelete(interp, slaveInterp, objv[3]);
}
@@ -813,7 +813,7 @@ Tcl_InterpObjCmd(
namespaceName = NULL;
for (i = 3; i < objc; i++) {
- if (Tcl_GetString(objv[i])[0] != '-') {
+ if (TclGetString(objv[i])[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions, "option",
@@ -826,7 +826,7 @@ Tcl_InterpObjCmd(
if (++i == objc) { /* There must be more arguments. */
break;
} else {
- namespaceName = Tcl_GetString(objv[i]);
+ namespaceName = TclGetString(objv[i]);
}
} else {
i++;
@@ -936,7 +936,7 @@ Tcl_InterpObjCmd(
if (masterInterp == NULL) {
return TCL_ERROR;
}
- chan = Tcl_GetChannel(masterInterp, Tcl_GetString(objv[3]), NULL);
+ chan = Tcl_GetChannel(masterInterp, TclGetString(objv[3]), NULL);
if (chan == NULL) {
TclTransferResult(masterInterp, TCL_OK, interp);
return TCL_ERROR;
@@ -965,7 +965,7 @@ Tcl_InterpObjCmd(
return TCL_ERROR;
}
- aliasName = Tcl_GetString(objv[3]);
+ aliasName = TclGetString(objv[3]);
iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
@@ -997,7 +997,7 @@ Tcl_InterpObjCmd(
if (masterInterp == NULL) {
return TCL_ERROR;
}
- chan = Tcl_GetChannel(masterInterp, Tcl_GetString(objv[3]), NULL);
+ chan = Tcl_GetChannel(masterInterp, TclGetString(objv[3]), NULL);
if (chan == NULL) {
TclTransferResult(masterInterp, TCL_OK, interp);
return TCL_ERROR;
@@ -1200,7 +1200,7 @@ Tcl_GetAlias(
*targetInterpPtr = aliasPtr->targetInterp;
}
if (targetNamePtr != NULL) {
- *targetNamePtr = Tcl_GetString(objv[0]);
+ *targetNamePtr = TclGetString(objv[0]);
}
if (argcPtr != NULL) {
*argcPtr = objc - 1;
@@ -1209,7 +1209,7 @@ Tcl_GetAlias(
*argvPtr = (CONST char **)
ckalloc((unsigned) sizeof(CONST char *) * (objc - 1));
for (i = 1; i < objc; i++) {
- *argvPtr[i - 1] = Tcl_GetString(objv[i]);
+ *argvPtr[i - 1] = TclGetString(objv[i]);
}
}
return TCL_OK;
@@ -1262,7 +1262,7 @@ Tcl_GetAliasObj(
*targetInterpPtr = aliasPtr->targetInterp;
}
if (targetNamePtr != (CONST char **) NULL) {
- *targetNamePtr = Tcl_GetString(objv[0]);
+ *targetNamePtr = TclGetString(objv[0]);
}
if (objcPtr != (int *) NULL) {
*objcPtr = objc - 1;
@@ -1345,7 +1345,7 @@ TclPreventAliasLoop(
}
cmdNamePtr = nextAliasPtr->objPtr;
aliasCmd = Tcl_FindCommand(nextAliasPtr->targetInterp,
- Tcl_GetString(cmdNamePtr),
+ TclGetString(cmdNamePtr),
Tcl_GetGlobalNamespace(nextAliasPtr->targetInterp),
/*flags*/ 0);
if (aliasCmd == (Tcl_Command) NULL) {
@@ -1431,7 +1431,7 @@ AliasCreate(
Tcl_Preserve(masterInterp);
aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp,
- Tcl_GetString(namePtr), AliasObjCmd, (ClientData) aliasPtr,
+ TclGetString(namePtr), AliasObjCmd, (ClientData) aliasPtr,
AliasObjCmdDeleteProc);
if (TclPreventAliasLoop(interp, slaveInterp,
@@ -1477,7 +1477,7 @@ AliasCreate(
Tcl_Obj *newToken;
char *string;
- string = Tcl_GetString(aliasPtr->token);
+ string = TclGetString(aliasPtr->token);
hPtr = Tcl_CreateHashEntry(&slavePtr->aliasTable, string, &isNew);
if (isNew != 0) {
break;
@@ -1567,7 +1567,7 @@ AliasDelete(
*/
slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
- hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, Tcl_GetString(namePtr));
+ hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, TclGetString(namePtr));
if (hPtr == NULL) {
Tcl_AppendResult(interp, "alias \"", Tcl_GetString(namePtr),
"\" not found", NULL);
@@ -2015,7 +2015,7 @@ GetInterp(
Tcl_Interp *searchInterp; /* Interim storage for interp. to find. */
InterpInfo *masterInfoPtr;
- if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) {
+ if (TclListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) {
return NULL;
}
@@ -2023,7 +2023,7 @@ GetInterp(
for (i = 0; i < objc; i++) {
masterInfoPtr = (InterpInfo *) ((Interp *) searchInterp)->interpInfo;
hPtr = Tcl_FindHashEntry(&masterInfoPtr->master.slaveTable,
- Tcl_GetString(objv[i]));
+ TclGetString(objv[i]));
if (hPtr == NULL) {
searchInterp = NULL;
break;
@@ -2069,7 +2069,7 @@ SlaveBgerror(
if (objc) {
int length;
- if (TCL_ERROR == Tcl_ListObjLength(NULL, objv[0], &length)
+ if (TCL_ERROR == TclListObjLength(NULL, objv[0], &length)
|| (length < 1)) {
Tcl_AppendResult(interp, "cmdPrefix must be list of length >= 1",
(char *) NULL);
@@ -2119,7 +2119,7 @@ SlaveCreate(
}
if (objc < 2) {
masterInterp = interp;
- path = Tcl_GetString(pathPtr);
+ path = TclGetString(pathPtr);
} else {
Tcl_Obj *objPtr;
@@ -2129,7 +2129,7 @@ SlaveCreate(
if (masterInterp == NULL) {
return NULL;
}
- path = Tcl_GetString(objv[objc - 1]);
+ path = TclGetString(objv[objc - 1]);
}
if (safe == 0) {
safe = Tcl_IsSafe(masterInterp);
@@ -2271,7 +2271,7 @@ SlaveObjCmd(
if (objc == 3) {
return AliasDescribe(interp, slaveInterp, objv[2]);
}
- if (Tcl_GetString(objv[3])[0] == '\0') {
+ if (TclGetString(objv[3])[0] == '\0') {
if (objc == 4) {
return AliasDelete(interp, slaveInterp, objv[2]);
}
@@ -2338,7 +2338,7 @@ SlaveObjCmd(
namespaceName = NULL;
for (i = 2; i < objc; i++) {
- if (Tcl_GetString(objv[i])[0] != '-') {
+ if (TclGetString(objv[i])[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions, "option",
@@ -2351,7 +2351,7 @@ SlaveObjCmd(
if (++i == objc) { /* There must be more arguments. */
break;
} else {
- namespaceName = Tcl_GetString(objv[i]);
+ namespaceName = TclGetString(objv[i]);
}
} else {
i++;
@@ -2534,8 +2534,8 @@ SlaveExpose(
return TCL_ERROR;
}
- name = Tcl_GetString(objv[(objc == 1) ? 0 : 1]);
- if (Tcl_ExposeCommand(slaveInterp, Tcl_GetString(objv[0]),
+ name = TclGetString(objv[(objc == 1) ? 0 : 1]);
+ if (Tcl_ExposeCommand(slaveInterp, TclGetString(objv[0]),
name) != TCL_OK) {
TclTransferResult(slaveInterp, TCL_ERROR, interp);
return TCL_ERROR;
@@ -2577,7 +2577,7 @@ SlaveRecursionLimit(
(char *) NULL);
return TCL_ERROR;
}
- if (Tcl_GetIntFromObj(interp, objv[0], &limit) == TCL_ERROR) {
+ if (TclGetIntFromObj(interp, objv[0], &limit) == TCL_ERROR) {
return TCL_ERROR;
}
if (limit <= 0) {
@@ -2634,8 +2634,8 @@ SlaveHide(
return TCL_ERROR;
}
- name = Tcl_GetString(objv[(objc == 1) ? 0 : 1]);
- if (Tcl_HideCommand(slaveInterp, Tcl_GetString(objv[0]), name) != TCL_OK) {
+ name = TclGetString(objv[(objc == 1) ? 0 : 1]);
+ if (Tcl_HideCommand(slaveInterp, TclGetString(objv[0]), name) != TCL_OK) {
TclTransferResult(slaveInterp, TCL_ERROR, interp);
return TCL_ERROR;
}
@@ -4110,7 +4110,7 @@ SlaveCommandLimitCmd(
break;
case OPT_GRAN:
granObj = objv[i+1];
- if (Tcl_GetIntFromObj(interp, objv[i+1], &gran) != TCL_OK) {
+ if (TclGetIntFromObj(interp, objv[i+1], &gran) != TCL_OK) {
return TCL_ERROR;
}
if (gran < 1) {
@@ -4125,7 +4125,7 @@ SlaveCommandLimitCmd(
if (limitLen == 0) {
break;
}
- if (Tcl_GetIntFromObj(interp, objv[i+1], &limit) != TCL_OK) {
+ if (TclGetIntFromObj(interp, objv[i+1], &limit) != TCL_OK) {
return TCL_ERROR;
}
if (limit < 0) {
@@ -4302,7 +4302,7 @@ SlaveTimeLimitCmd(
break;
case OPT_GRAN:
granObj = objv[i+1];
- if (Tcl_GetIntFromObj(interp, objv[i+1], &gran) != TCL_OK) {
+ if (TclGetIntFromObj(interp, objv[i+1], &gran) != TCL_OK) {
return TCL_ERROR;
}
if (gran < 1) {
@@ -4317,7 +4317,7 @@ SlaveTimeLimitCmd(
if (milliLen == 0) {
break;
}
- if (Tcl_GetIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) {
+ if (TclGetIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) {
return TCL_ERROR;
}
if (tmp < 0) {
@@ -4333,7 +4333,7 @@ SlaveTimeLimitCmd(
if (secLen == 0) {
break;
}
- if (Tcl_GetIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) {
+ if (TclGetIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) {
return TCL_ERROR;
}
if (tmp < 0) {
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index 4931ace..529dacf 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclListObj.c,v 1.46.2.1 2007/09/04 17:43:53 dgp Exp $
+ * RCS: @(#) $Id: tclListObj.c,v 1.46.2.2 2007/11/12 19:18:19 dgp Exp $
*/
#include "tclInt.h"
@@ -428,7 +428,7 @@ Tcl_ListObjGetElements(
if (listPtr->typePtr != &tclListType) {
int result, length;
- (void) Tcl_GetStringFromObj(listPtr, &length);
+ (void) TclGetStringFromObj(listPtr, &length);
if (!length) {
*objcPtr = 0;
*objvPtr = NULL;
@@ -485,12 +485,12 @@ Tcl_ListObjAppendList(
Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendList");
}
- result = Tcl_ListObjLength(interp, listPtr, &listLen);
+ result = TclListObjLength(interp, listPtr, &listLen);
if (result != TCL_OK) {
return result;
}
- result = Tcl_ListObjGetElements(interp, elemListPtr, &objc, &objv);
+ result = TclListObjGetElements(interp, elemListPtr, &objc, &objv);
if (result != TCL_OK) {
return result;
}
@@ -546,7 +546,7 @@ Tcl_ListObjAppendElement(
if (listPtr->typePtr != &tclListType) {
int result, length;
- (void) Tcl_GetStringFromObj(listPtr, &length);
+ (void) TclGetStringFromObj(listPtr, &length);
if (!length) {
Tcl_SetListObj(listPtr, 1, &objPtr);
return TCL_OK;
@@ -657,7 +657,7 @@ Tcl_ListObjIndex(
if (listPtr->typePtr != &tclListType) {
int result, length;
- (void) Tcl_GetStringFromObj(listPtr, &length);
+ (void) TclGetStringFromObj(listPtr, &length);
if (!length) {
*objPtrPtr = NULL;
return TCL_OK;
@@ -712,7 +712,7 @@ Tcl_ListObjLength(
if (listPtr->typePtr != &tclListType) {
int result, length;
- (void) Tcl_GetStringFromObj(listPtr, &length);
+ (void) TclGetStringFromObj(listPtr, &length);
if (!length) {
*intPtr = 0;
return TCL_OK;
@@ -787,7 +787,7 @@ Tcl_ListObjReplace(
if (listPtr->typePtr != &tclListType) {
int length;
- (void) Tcl_GetStringFromObj(listPtr, &length);
+ (void) TclGetStringFromObj(listPtr, &length);
if (!length) {
if (objc) {
Tcl_SetListObj(listPtr, objc, NULL);
@@ -1006,7 +1006,7 @@ TclLindexList(
*/
if (argPtr->typePtr != &tclListType
- && TclGetIntForIndex(NULL , argPtr, 0, &index) == TCL_OK) {
+ && TclGetIntForIndexM(NULL , argPtr, 0, &index) == TCL_OK) {
/*
* argPtr designates a single index.
*/
@@ -1036,7 +1036,7 @@ TclLindexList(
return TclLindexFlat(interp, listPtr, 1, &argPtr);
}
- Tcl_ListObjGetElements(NULL, indexListCopy, &indexCount, &indices);
+ TclListObjGetElements(NULL, indexListCopy, &indexCount, &indices);
listPtr = TclLindexFlat(interp, listPtr, indexCount, indices);
Tcl_DecrRefCount(indexListCopy);
return listPtr;
@@ -1101,9 +1101,9 @@ TclLindexFlat(
break;
}
- Tcl_ListObjGetElements(NULL, sublistCopy, &listLen, &elemPtrs);
+ TclListObjGetElements(NULL, sublistCopy, &listLen, &elemPtrs);
- if (TclGetIntForIndex(interp, indexArray[i], /*endValue*/ listLen-1,
+ if (TclGetIntForIndexM(interp, indexArray[i], /*endValue*/ listLen-1,
&index) == TCL_OK) {
if (index<0 || index>=listLen) {
/*
@@ -1112,7 +1112,7 @@ TclLindexFlat(
*/
while (++i < indexCount) {
- if (TclGetIntForIndex(interp, indexArray[i], -1, &index)
+ if (TclGetIntForIndexM(interp, indexArray[i], -1, &index)
!= TCL_OK) {
Tcl_DecrRefCount(sublistCopy);
return NULL;
@@ -1180,7 +1180,7 @@ TclLsetList(
*/
if (indexArgPtr->typePtr != &tclListType
- && TclGetIntForIndex(NULL, indexArgPtr, 0, &index) == TCL_OK) {
+ && TclGetIntForIndexM(NULL, indexArgPtr, 0, &index) == TCL_OK) {
/*
* indexArgPtr designates a single index.
*/
@@ -1198,7 +1198,7 @@ TclLsetList(
return TclLsetFlat(interp, listPtr, 1, &indexArgPtr, valuePtr);
}
- Tcl_ListObjGetElements(NULL, indexArgPtr, &indexCount, &indices);
+ TclListObjGetElements(NULL, indexArgPtr, &indexCount, &indices);
/*
* Let TclLsetFlat handle the actual lset'ting.
@@ -1307,17 +1307,24 @@ TclLsetFlat(
/* Check for the possible error conditions... */
result = TCL_ERROR;
- if (Tcl_ListObjGetElements(interp, subListPtr, &elemCount, &elemPtrs)
+ if (TclListObjGetElements(interp, subListPtr, &elemCount, &elemPtrs)
!= TCL_OK) {
/* ...the sublist we're indexing into isn't a list at all. */
break;
}
- if (TclGetIntForIndex(interp, *indexArray++, elemCount - 1, &index)
+ /*
+ * WARNING: the macro TclGetIntForIndexM is not safe for
+ * post-increments, avoid '*indexArray++' here.
+ */
+
+ if (TclGetIntForIndexM(interp, *indexArray, elemCount - 1, &index)
!= TCL_OK) {
/* ...the index we're trying to use isn't an index at all. */
+ indexArray++;
break;
}
+ indexArray++;
if (index < 0 || index >= elemCount) {
/* ...the index points outside the sublist. */
@@ -1472,7 +1479,7 @@ TclListObjSetElement(
if (listPtr->typePtr != &tclListType) {
int length, result;
- (void) Tcl_GetStringFromObj(listPtr, &length);
+ (void) TclGetStringFromObj(listPtr, &length);
if (!length) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("list index out of range", -1));
@@ -1654,7 +1661,7 @@ SetListFromAny(
* Get the string representation. Make it up-to-date if necessary.
*/
- string = Tcl_GetStringFromObj(objPtr, &length);
+ string = TclGetStringFromObj(objPtr, &length);
/*
* Parse the string into separate string objects, and create a List
@@ -1794,7 +1801,7 @@ UpdateStringOfList(
listPtr->length = 1;
elemPtrs = &listRepPtr->elements;
for (i = 0; i < numElems; i++) {
- elem = Tcl_GetStringFromObj(elemPtrs[i], &length);
+ elem = TclGetStringFromObj(elemPtrs[i], &length);
listPtr->length += Tcl_ScanCountedElement(elem, length, flagPtr+i)+1;
/*
@@ -1813,7 +1820,7 @@ UpdateStringOfList(
listPtr->bytes = ckalloc((unsigned) listPtr->length);
dst = listPtr->bytes;
for (i = 0; i < numElems; i++) {
- elem = Tcl_GetStringFromObj(elemPtrs[i], &length);
+ elem = TclGetStringFromObj(elemPtrs[i], &length);
dst += Tcl_ConvertCountedElement(elem, length, dst,
flagPtr[i] | (i==0 ? 0 : TCL_DONT_QUOTE_HASH));
*dst = ' ';
diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c
index 9821ce2..ce77393 100644
--- a/generic/tclLiteral.c
+++ b/generic/tclLiteral.c
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclLiteral.c,v 1.30.2.1 2007/09/04 17:43:53 dgp Exp $
+ * RCS: @(#) $Id: tclLiteral.c,v 1.30.2.2 2007/11/12 19:18:19 dgp Exp $
*/
#include "tclInt.h"
@@ -510,7 +510,7 @@ TclLookupLiteralEntry(
char *bytes;
int length, globalHash;
- bytes = Tcl_GetStringFromObj(objPtr, &length);
+ bytes = TclGetStringFromObj(objPtr, &length);
globalHash = (HashString(bytes, length) & globalTablePtr->mask);
for (entryPtr=globalTablePtr->buckets[globalHash] ; entryPtr!=NULL;
entryPtr=entryPtr->nextPtr) {
@@ -570,7 +570,7 @@ TclHideLiteral(
TclReleaseLiteral(interp, lPtr->objPtr);
lPtr->objPtr = newObjPtr;
- bytes = Tcl_GetStringFromObj(newObjPtr, &length);
+ bytes = TclGetStringFromObj(newObjPtr, &length);
localHash = (HashString(bytes, length) & localTablePtr->mask);
nextPtrPtr = &localTablePtr->buckets[localHash];
@@ -820,7 +820,7 @@ TclReleaseLiteral(
char *bytes;
int length, index;
- bytes = Tcl_GetStringFromObj(objPtr, &length);
+ bytes = TclGetStringFromObj(objPtr, &length);
index = (HashString(bytes, length) & globalTablePtr->mask);
/*
@@ -968,7 +968,7 @@ RebuildLiteralTable(
for (oldChainPtr=oldBuckets ; oldSize>0 ; oldSize--,oldChainPtr++) {
for (entryPtr=*oldChainPtr ; entryPtr!=NULL ; entryPtr=*oldChainPtr) {
- bytes = Tcl_GetStringFromObj(entryPtr->objPtr, &length);
+ bytes = TclGetStringFromObj(entryPtr->objPtr, &length);
index = (HashString(bytes, length) & tablePtr->mask);
*oldChainPtr = entryPtr->nextPtr;
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index eed9d9c..1863faf 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -23,7 +23,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclNamesp.c,v 1.134.2.9 2007/11/01 16:25:57 dgp Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.134.2.10 2007/11/12 19:18:20 dgp Exp $
*/
#include "tclInt.h"
@@ -2664,7 +2664,7 @@ TclGetNamespaceFromObj(
Tcl_Namespace **nsPtrPtr) /* Result namespace pointer goes here. */
{
if (GetNamespaceFromObj(interp, objPtr, nsPtrPtr) == TCL_ERROR) {
- const char *name = Tcl_GetString(objPtr);
+ const char *name = TclGetString(objPtr);
if ((name[0] == ':') && (name[1] == ':')) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"namespace \"%s\" not found", name));
@@ -3003,7 +3003,7 @@ NamespaceCodeCmd(
* If "arg" is already a scoped value, then return it directly.
*/
- arg = Tcl_GetStringFromObj(objv[2], &length);
+ arg = TclGetStringFromObj(objv[2], &length);
while (*arg == ':') {
arg++;
length--;
@@ -3921,7 +3921,7 @@ NamespacePathCmd(
* There is a path given, so parse it into an array of namespace pointers.
*/
- if (Tcl_ListObjGetElements(interp, objv[2], &nsObjc, &nsObjv) != TCL_OK) {
+ if (TclListObjGetElements(interp, objv[2], &nsObjc, &nsObjv) != TCL_OK) {
goto badNamespace;
}
if (nsObjc != 0) {
@@ -4300,7 +4300,7 @@ Tcl_SetNamespaceUnknownHandler(
if (handlerPtr == NULL) {
currNsPtr->unknownHandlerPtr = NULL;
- } else if (Tcl_ListObjLength(interp, handlerPtr, &lstlen) != TCL_OK) {
+ } else if (TclListObjLength(interp, handlerPtr, &lstlen) != TCL_OK) {
/*
* Not a list.
*/
@@ -4812,7 +4812,7 @@ NamespaceEnsembleCmd(
name = TclGetString(objv[1]);
continue;
case CRT_SUBCMDS:
- if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) {
+ if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
@@ -4842,7 +4842,7 @@ NamespaceEnsembleCmd(
Tcl_Obj **listv;
char *cmd;
- if (Tcl_ListObjGetElements(interp, listObj, &len,
+ if (TclListObjGetElements(interp, listObj, &len,
&listv) != TCL_OK) {
Tcl_DictObjDone(&search);
if (patchedDict) {
@@ -4903,7 +4903,7 @@ NamespaceEnsembleCmd(
}
continue;
case CRT_UNKNOWN:
- if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) {
+ if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
@@ -5085,7 +5085,7 @@ NamespaceEnsembleCmd(
}
switch ((enum EnsConfigOpts) index) {
case CONF_SUBCMDS:
- if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) {
+ if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
@@ -5115,7 +5115,7 @@ NamespaceEnsembleCmd(
Tcl_Obj **listv;
char *cmd;
- if (Tcl_ListObjGetElements(interp, listObj, &len,
+ if (TclListObjGetElements(interp, listObj, &len,
&listv) != TCL_OK) {
Tcl_DictObjDone(&search);
if (patchedDict) {
@@ -5183,7 +5183,7 @@ NamespaceEnsembleCmd(
}
continue;
case CONF_UNKNOWN:
- if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) {
+ if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
@@ -5325,7 +5325,7 @@ Tcl_SetEnsembleSubcommandList(
}
if (subcmdList != NULL) {
int length;
- if (Tcl_ListObjLength(interp, subcmdList, &length) != TCL_OK) {
+ if (TclListObjLength(interp, subcmdList, &length) != TCL_OK) {
return TCL_ERROR;
}
if (length < 1) {
@@ -5456,7 +5456,7 @@ Tcl_SetEnsembleUnknownHandler(
if (unknownList != NULL) {
int length;
- if (Tcl_ListObjLength(interp, unknownList, &length) != TCL_OK) {
+ if (TclListObjLength(interp, unknownList, &length) != TCL_OK) {
return TCL_ERROR;
}
if (length < 1) {
@@ -5919,7 +5919,7 @@ NsEnsembleImplementationCmd(
(iPtr->ensembleRewrite.sourceObjs == NULL);
copyObj = TclListObjCopy(NULL, prefixObj);
- Tcl_ListObjGetElements(NULL, copyObj, &prefixObjc,
+ TclListObjGetElements(NULL, copyObj, &prefixObjc,
&prefixObjv);
if (isRootEnsemble) {
iPtr->ensembleRewrite.sourceObjs = objv;
@@ -6075,7 +6075,7 @@ NsEnsembleImplementationCmd(
for (i=1 ; i<objc ; i++) {
Tcl_ListObjAppendElement(NULL, unknownCmd, objv[i]);
}
- Tcl_ListObjGetElements(NULL, unknownCmd, &paramc, &paramv);
+ TclListObjGetElements(NULL, unknownCmd, &paramc, &paramv);
Tcl_Preserve(ensemblePtr);
Tcl_IncrRefCount(unknownCmd);
result = Tcl_EvalObjv(interp, paramc, paramv, 0);
@@ -6099,7 +6099,7 @@ NsEnsembleImplementationCmd(
* as our replacement.
*/
- if (Tcl_ListObjLength(interp, prefixObj, &prefixObjc) != TCL_OK) {
+ if (TclListObjLength(interp, prefixObj, &prefixObjc) != TCL_OK) {
Tcl_DecrRefCount(prefixObj);
Tcl_AddErrorInfo(interp, "\n while parsing result of "
"ensemble unknown subcommand handler");
@@ -6399,7 +6399,7 @@ BuildEnsembleConfig(
Tcl_Obj **subcmdv, *target, *cmdObj, *cmdPrefixObj;
int subcmdc;
- Tcl_ListObjGetElements(NULL, ensemblePtr->subcmdList, &subcmdc,
+ TclListObjGetElements(NULL, ensemblePtr->subcmdList, &subcmdc,
&subcmdv);
for (i=0 ; i<subcmdc ; i++) {
char *name = TclGetString(subcmdv[i]);
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 44cccf0..6e78350 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclObj.c,v 1.122.2.6 2007/10/11 16:01:53 dgp Exp $
+ * RCS: @(#) $Id: tclObj.c,v 1.122.2.7 2007/11/12 19:18:20 dgp Exp $
*/
#include "tclInt.h"
@@ -493,7 +493,7 @@ Tcl_AppendAllObjTypes(
* Get the test for a valid list out of the way first.
*/
- if (Tcl_ListObjLength(interp, objPtr, &numElems) != TCL_OK) {
+ if (TclListObjLength(interp, objPtr, &numElems) != TCL_OK) {
return TCL_ERROR;
}
@@ -1422,7 +1422,7 @@ ParseBoolean(
register Tcl_Obj *objPtr) /* The object to parse/convert. */
{
int i, length, newBool;
- char lowerCase[6], *str = Tcl_GetStringFromObj(objPtr, &length);
+ char lowerCase[6], *str = TclGetStringFromObj(objPtr, &length);
if ((length == 0) || (length > 5)) {
/* longest valid boolean string rep. is "false" */
@@ -1901,9 +1901,12 @@ Tcl_GetIntFromObj(
register Tcl_Obj *objPtr, /* The object from which to get a int. */
register int *intPtr) /* Place to store resulting int. */
{
+#if (LONG_MAX == INT_MAX)
+ return TclGetLongFromObj(interp, objPtr, (long *) intPtr);
+#else
long l;
- if (Tcl_GetLongFromObj(interp, objPtr, &l) != TCL_OK) {
+ if (TclGetLongFromObj(interp, objPtr, &l) != TCL_OK) {
return TCL_ERROR;
}
if ((ULONG_MAX > UINT_MAX) && ((l > UINT_MAX) || (l < -(long)UINT_MAX))) {
@@ -1917,6 +1920,7 @@ Tcl_GetIntFromObj(
}
*intPtr = (int) l;
return TCL_OK;
+#endif
}
/*
@@ -1941,7 +1945,7 @@ SetIntFromAny(
Tcl_Obj *objPtr) /* Pointer to the object to convert */
{
long l;
- return Tcl_GetLongFromObj(interp, objPtr, &l);
+ return TclGetLongFromObj(interp, objPtr, &l);
}
/*
diff --git a/generic/tclParse.c b/generic/tclParse.c
index 2c3f52e..4eade27 100644
--- a/generic/tclParse.c
+++ b/generic/tclParse.c
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclParse.c,v 1.52.2.5 2007/10/15 18:38:07 dgp Exp $
+ * RCS: @(#) $Id: tclParse.c,v 1.52.2.6 2007/11/12 19:18:20 dgp Exp $
*/
#include "tclInt.h"
@@ -1921,7 +1921,7 @@ Tcl_SubstObj(
Tcl_Token *endTokenPtr;
Tcl_Obj *result;
Tcl_Obj *errMsg = NULL;
- CONST char *p = Tcl_GetStringFromObj(objPtr, &length);
+ CONST char *p = TclGetStringFromObj(objPtr, &length);
Tcl_Parse *parsePtr = (Tcl_Parse *) TclStackAlloc(interp, sizeof(Tcl_Parse));
TclParseInit(interp, p, length, parsePtr);
@@ -2435,7 +2435,7 @@ TclObjCommandComplete(
CONST char *script;
int length;
- script = Tcl_GetStringFromObj(objPtr, &length);
+ script = TclGetStringFromObj(objPtr, &length);
return CommandComplete(script, length);
}
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 44813f1..6aeaa91 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclProc.c,v 1.115.2.13 2007/10/02 20:11:57 dgp Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.115.2.14 2007/11/12 19:18:20 dgp Exp $
*/
#include "tclInt.h"
@@ -411,7 +411,7 @@ TclCreateProc(
*/
if (Tcl_IsShared(bodyPtr)) {
- bytes = Tcl_GetStringFromObj(bodyPtr, &length);
+ bytes = TclGetStringFromObj(bodyPtr, &length);
bodyPtr = Tcl_NewStringObj(bytes, length);
}
@@ -442,7 +442,7 @@ TclCreateProc(
* THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULS.
*/
- args = Tcl_GetStringFromObj(argsPtr, &length);
+ args = TclGetStringFromObj(argsPtr, &length);
result = Tcl_SplitList(interp, args, &numArgs, &argArray);
if (result != TCL_OK) {
goto procError;
@@ -555,7 +555,7 @@ TclCreateProc(
if (localPtr->defValuePtr != NULL) {
int tmpLength;
- char *tmpPtr = Tcl_GetStringFromObj(localPtr->defValuePtr,
+ char *tmpPtr = TclGetStringFromObj(localPtr->defValuePtr,
&tmpLength);
if ((valueLength != tmpLength) ||
@@ -781,7 +781,7 @@ TclObjGetFrame(
|| objPtr->typePtr == &tclWideIntType
#endif
) {
- if (Tcl_GetIntFromObj(NULL, objPtr, &level) != TCL_OK || level < 0) {
+ if (TclGetIntFromObj(NULL, objPtr, &level) != TCL_OK || level < 0) {
goto levelError;
}
level = curLevel - level;
@@ -2218,6 +2218,7 @@ TclUpdateReturnInfo(
iPtr->flags |= ERR_LEGACY_COPY;
}
}
+ iPtr->flags |= INTERP_RESULT_UNCLEAN;
return code;
}
@@ -2408,7 +2409,7 @@ SetLambdaFromAny(
* length is not 2, then it cannot be converted to lambdaType.
*/
- result = Tcl_ListObjGetElements(interp, objPtr, &objc, &objv);
+ result = TclListObjGetElements(interp, objPtr, &objc, &objv);
if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) {
TclNewLiteralStringObj(errPtr, "can't interpret \"");
Tcl_AppendObjToObj(errPtr, objPtr);
@@ -2539,7 +2540,7 @@ SetLambdaFromAny(
if (objc == 2) {
TclNewLiteralStringObj(nsObjPtr, "::");
} else {
- char *nsName = Tcl_GetString(objv[2]);
+ char *nsName = TclGetString(objv[2]);
if ((*nsName != ':') || (*(nsName+1) != ':')) {
TclNewLiteralStringObj(nsObjPtr, "::");
@@ -2624,7 +2625,7 @@ Tcl_ApplyObjCmd(
int numElem;
if ((lambdaPtr->typePtr == &tclCmdNameType) ||
- (Tcl_ListObjGetElements(interp, lambdaPtr, &numElem,
+ (TclListObjGetElements(interp, lambdaPtr, &numElem,
&elemPtr) == TCL_OK && numElem == 1)) {
return Tcl_EvalObjv(interp, objc-1, objv+1, 0);
}
diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c
index a5a8095..ec7da0b 100644
--- a/generic/tclRegexp.c
+++ b/generic/tclRegexp.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclRegexp.c,v 1.24 2007/03/07 09:35:42 dkf Exp $
+ * RCS: @(#) $Id: tclRegexp.c,v 1.24.2.1 2007/11/12 19:18:20 dgp Exp $
*/
#include "tclInt.h"
@@ -251,7 +251,7 @@ Tcl_RegExpRange(
*startPtr = *endPtr = NULL;
} else {
if (regexpPtr->objPtr) {
- string = Tcl_GetString(regexpPtr->objPtr);
+ string = TclGetString(regexpPtr->objPtr);
} else {
string = regexpPtr->string;
}
@@ -437,6 +437,45 @@ Tcl_RegExpExecObj(
TclRegexp *regexpPtr = (TclRegexp *) re;
Tcl_UniChar *udata;
int length;
+ int reflags = regexpPtr->flags;
+#define TCL_REG_GLOBOK_FLAGS (TCL_REG_ADVANCED | TCL_REG_NOSUB | TCL_REG_NOCASE)
+
+ /*
+ * Take advantage of the equivalent glob pattern, if one exists.
+ * This is possible based only on the right mix of incoming flags (0)
+ * and regexp compile flags.
+ */
+ if ((offset == 0) && (nmatches == 0) && (flags == 0)
+ && !(reflags & ~TCL_REG_GLOBOK_FLAGS)
+ && (regexpPtr->globObjPtr != NULL)) {
+ int match, nocase = (reflags & TCL_REG_NOCASE);
+
+ /*
+ * Promote based on the type of incoming object.
+ * XXX: Currently doesn't take advantage of exact-ness that
+ * XXX: TclReToGlob tells us about
+ */
+
+ if (textObj->typePtr == &tclStringType) {
+ Tcl_UniChar *uptn;
+ int plen;
+
+ udata = Tcl_GetUnicodeFromObj(textObj, &length);
+ uptn = Tcl_GetUnicodeFromObj(regexpPtr->globObjPtr, &plen);
+ match = TclUniCharMatch(udata, length, uptn, plen, nocase);
+ } else if ((textObj->typePtr == &tclByteArrayType) && !nocase) {
+ unsigned char *data, *ptn;
+ int plen;
+
+ data = Tcl_GetByteArrayFromObj(textObj, &length);
+ ptn = Tcl_GetByteArrayFromObj(regexpPtr->globObjPtr, &plen);
+ match = TclByteArrayMatch(data, length, ptn, plen);
+ } else {
+ match = Tcl_StringCaseMatch(TclGetString(textObj),
+ TclGetString(regexpPtr->globObjPtr), nocase);
+ }
+ return match;
+ }
/*
* Save the target object so we can extract strings from it later.
@@ -562,7 +601,7 @@ Tcl_GetRegExpFromObj(
regexpPtr = (TclRegexp *) objPtr->internalRep.otherValuePtr;
if ((objPtr->typePtr != &tclRegexpType) || (regexpPtr->flags != flags)) {
- pattern = Tcl_GetStringFromObj(objPtr, &length);
+ pattern = TclGetStringFromObj(objPtr, &length);
regexpPtr = CompileRegexp(interp, pattern, length, flags);
if (regexpPtr == NULL) {
@@ -830,7 +869,7 @@ CompileRegexp(
{
TclRegexp *regexpPtr;
const Tcl_UniChar *uniString;
- int numChars, status, i;
+ int numChars, status, i, exact;
Tcl_DString stringBuf;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -919,6 +958,21 @@ CompileRegexp(
}
/*
+ * Convert RE to a glob pattern equivalent, if any, and cache it. If this
+ * is not possible, then globObjPtr will be NULL. This is used by
+ * Tcl_RegExpExecObj to optionally do a fast match (avoids RE engine).
+ */
+
+ if (TclReToGlob(NULL, string, length, &stringBuf, &exact) == TCL_OK) {
+ regexpPtr->globObjPtr = Tcl_NewStringObj(Tcl_DStringValue(&stringBuf),
+ Tcl_DStringLength(&stringBuf));
+ Tcl_IncrRefCount(regexpPtr->globObjPtr);
+ Tcl_DStringFree(&stringBuf);
+ } else {
+ regexpPtr->globObjPtr = NULL;
+ }
+
+ /*
* Allocate enough space for all of the subexpressions, plus one extra for
* the entire pattern.
*/
@@ -978,6 +1032,9 @@ FreeRegexp(
TclRegexp *regexpPtr) /* Compiled regular expression to free. */
{
TclReFree(&regexpPtr->re);
+ if (regexpPtr->globObjPtr) {
+ TclDecrRefCount(regexpPtr->globObjPtr);
+ }
if (regexpPtr->matches) {
ckfree((char *) regexpPtr->matches);
}
diff --git a/generic/tclRegexp.h b/generic/tclRegexp.h
index 1515225..004e00c 100644
--- a/generic/tclRegexp.h
+++ b/generic/tclRegexp.h
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclRegexp.h,v 1.13 2005/10/12 23:55:25 dkf Exp $
+ * RCS: @(#) $Id: tclRegexp.h,v 1.13.8.1 2007/11/12 19:18:20 dgp Exp $
*/
#ifndef _TCLREGEXP
@@ -32,6 +32,7 @@ typedef struct TclRegexp {
* subexpressions. */
CONST char *string; /* Last string passed to Tcl_RegExpExec. */
Tcl_Obj *objPtr; /* Last object passed to Tcl_RegExpExecObj. */
+ Tcl_Obj *globObjPtr; /* Glob pattern rep of RE or NULL if none. */
regmatch_t *matches; /* Array of indices into the Tcl_UniChar
* representation of the last string matched
* with this regexp to indicate the location
diff --git a/generic/tclResult.c b/generic/tclResult.c
index 22e0bd0..11ed3bd 100644
--- a/generic/tclResult.c
+++ b/generic/tclResult.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclResult.c,v 1.36.2.3 2007/10/19 14:30:01 dgp Exp $
+ * RCS: @(#) $Id: tclResult.c,v 1.36.2.4 2007/11/12 19:18:20 dgp Exp $
*/
#include "tclInt.h"
@@ -336,6 +336,7 @@ Tcl_RestoreResult(
Tcl_DecrRefCount(iPtr->objResultPtr);
iPtr->objResultPtr = statePtr->objResultPtr;
+ iPtr->flags |= INTERP_RESULT_UNCLEAN;
}
/*
@@ -443,6 +444,7 @@ Tcl_SetResult(
*/
ResetObjResult(iPtr);
+ iPtr->flags |= INTERP_RESULT_UNCLEAN;
}
/*
@@ -475,6 +477,7 @@ Tcl_GetStringResult(
Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
TCL_VOLATILE);
}
+ ((Interp *)interp)->flags |= INTERP_RESULT_UNCLEAN;
return interp->result;
}
@@ -584,6 +587,7 @@ Tcl_GetObjResult(
}
iPtr->result = iPtr->resultSpace;
iPtr->resultSpace[0] = 0;
+ iPtr->flags &= ~INTERP_RESULT_UNCLEAN;
}
return iPtr->objResultPtr;
}
@@ -826,6 +830,7 @@ SetupAppendBuffer(
Tcl_FreeResult((Tcl_Interp *) iPtr);
iPtr->result = iPtr->appendResult;
+ iPtr->flags |= INTERP_RESULT_UNCLEAN;
}
/*
@@ -866,6 +871,7 @@ Tcl_FreeResult(
}
ResetObjResult(iPtr);
+ iPtr->flags &= ~INTERP_RESULT_UNCLEAN;
}
/*
@@ -891,9 +897,17 @@ void
Tcl_ResetResult(
register Tcl_Interp *interp)/* Interpreter for which to clear result. */
{
- register Interp *iPtr = (Interp *) interp;
+ /*
+ * This function is defined in a macro in tclInt.h
+ */
- ResetObjResult(iPtr);
+ TclResetResult((Interp *) interp);
+}
+
+void
+TclCleanResult(
+ Interp *iPtr)
+{
if (iPtr->freeProc != NULL) {
if (iPtr->freeProc == TCL_DYNAMIC) {
ckfree(iPtr->result);
@@ -907,8 +921,8 @@ Tcl_ResetResult(
if (iPtr->errorCode) {
/* Legacy support */
if (iPtr->flags & ERR_LEGACY_COPY) {
- Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL,
- iPtr->errorCode, TCL_GLOBAL_ONLY);
+ Tcl_ObjSetVar2((Tcl_Interp *)iPtr, iPtr->ecVar,
+ NULL, iPtr->errorCode, TCL_GLOBAL_ONLY);
}
Tcl_DecrRefCount(iPtr->errorCode);
iPtr->errorCode = NULL;
@@ -916,8 +930,8 @@ Tcl_ResetResult(
if (iPtr->errorInfo) {
/* Legacy support */
if (iPtr->flags & ERR_LEGACY_COPY) {
- Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL,
- iPtr->errorInfo, TCL_GLOBAL_ONLY);
+ Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->eiVar,
+ NULL, iPtr->errorInfo, TCL_GLOBAL_ONLY);
}
Tcl_DecrRefCount(iPtr->errorInfo);
iPtr->errorInfo = NULL;
@@ -928,7 +942,7 @@ Tcl_ResetResult(
Tcl_DecrRefCount(iPtr->returnOpts);
iPtr->returnOpts = NULL;
}
- iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_LEGACY_COPY);
+ iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_LEGACY_COPY | INTERP_RESULT_UNCLEAN);
}
/*
@@ -954,23 +968,11 @@ ResetObjResult(
register Interp *iPtr) /* Points to the interpreter whose result
* object should be reset. */
{
- register Tcl_Obj *objResultPtr = iPtr->objResultPtr;
-
- if (Tcl_IsShared(objResultPtr)) {
- TclDecrRefCount(objResultPtr);
- TclNewObj(objResultPtr);
- Tcl_IncrRefCount(objResultPtr);
- iPtr->objResultPtr = objResultPtr;
- } else {
- if ((objResultPtr->bytes != NULL)
- && (objResultPtr->bytes != tclEmptyStringRep)) {
- ckfree((char *) objResultPtr->bytes);
- }
- objResultPtr->bytes = tclEmptyStringRep;
- objResultPtr->length = 0;
- TclFreeIntRep(objResultPtr);
- objResultPtr->typePtr = NULL;
- }
+ /*
+ * This function is defined in a macro in tclInt.h
+ */
+
+ ResetObjResultM(iPtr);
}
/*
@@ -1079,6 +1081,7 @@ Tcl_SetObjErrorCode(
}
iPtr->errorCode = errorObjPtr;
Tcl_IncrRefCount(iPtr->errorCode);
+ iPtr->flags |= INTERP_RESULT_UNCLEAN;
}
/*
@@ -1206,6 +1209,7 @@ TclProcessReturn(
}
iPtr->returnOpts = returnOpts;
Tcl_IncrRefCount(iPtr->returnOpts);
+ iPtr->flags |= INTERP_RESULT_UNCLEAN;
}
if (code == TCL_ERROR) {
@@ -1217,7 +1221,7 @@ TclProcessReturn(
if (valuePtr != NULL) {
int infoLen;
- (void) Tcl_GetStringFromObj(valuePtr, &infoLen);
+ (void) TclGetStringFromObj(valuePtr, &infoLen);
if (infoLen) {
iPtr->errorInfo = valuePtr;
Tcl_IncrRefCount(iPtr->errorInfo);
@@ -1233,16 +1237,18 @@ TclProcessReturn(
Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORLINE], &valuePtr);
if (valuePtr != NULL) {
- Tcl_GetIntFromObj(NULL, valuePtr, &iPtr->errorLine);
+ TclGetIntFromObj(NULL, valuePtr, &iPtr->errorLine);
}
+ iPtr->flags |= INTERP_RESULT_UNCLEAN;
}
if (level != 0) {
iPtr->returnLevel = level;
iPtr->returnCode = code;
+ iPtr->flags |= INTERP_RESULT_UNCLEAN;
return TCL_RETURN;
}
if (code == TCL_ERROR) {
- iPtr->flags |= ERR_LEGACY_COPY;
+ iPtr->flags |= (ERR_LEGACY_COPY | INTERP_RESULT_UNCLEAN);
}
return code;
}
@@ -1286,10 +1292,10 @@ TclMergeReturnOptions(
for (; objc > 1; objv += 2, objc -= 2) {
int optLen;
- CONST char *opt = Tcl_GetStringFromObj(objv[0], &optLen);
+ CONST char *opt = TclGetStringFromObj(objv[0], &optLen);
int compareLen;
CONST char *compare =
- Tcl_GetStringFromObj(keys[KEY_OPTIONS], &compareLen);
+ TclGetStringFromObj(keys[KEY_OPTIONS], &compareLen);
if ((optLen == compareLen) && (strcmp(opt, compare) == 0)) {
Tcl_DictSearch search;
@@ -1334,7 +1340,7 @@ TclMergeReturnOptions(
Tcl_DictObjGet(NULL, returnOpts, keys[KEY_CODE], &valuePtr);
if ((valuePtr != NULL)
- && (TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &code))) {
+ && (TCL_ERROR == TclGetIntFromObj(NULL, valuePtr, &code))) {
static CONST char *returnCodes[] = {
"ok", "error", "return", "break", "continue", NULL
};
@@ -1363,7 +1369,7 @@ TclMergeReturnOptions(
Tcl_DictObjGet(NULL, returnOpts, keys[KEY_LEVEL], &valuePtr);
if (valuePtr != NULL) {
- if ((TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &level))
+ if ((TCL_ERROR == TclGetIntFromObj(NULL, valuePtr, &level))
|| (level < 0)) {
/*
* Value is not a legal level.
@@ -1403,6 +1409,7 @@ TclMergeReturnOptions(
} else {
*optionsPtrPtr = returnOpts;
}
+ ((Interp *)interp)->flags |= INTERP_RESULT_UNCLEAN;
return TCL_OK;
error:
@@ -1495,7 +1502,7 @@ Tcl_SetReturnOptions(
int objc, level, code;
Tcl_Obj **objv, *mergedOpts;
- if (TCL_ERROR == Tcl_ListObjGetElements(interp, options, &objc, &objv)
+ if (TCL_ERROR == TclListObjGetElements(interp, options, &objc, &objv)
|| (objc % 2)) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "expected dict but got \"",
@@ -1509,6 +1516,7 @@ Tcl_SetReturnOptions(
}
Tcl_DecrRefCount(options);
+ ((Interp *)interp)->flags |= INTERP_RESULT_UNCLEAN;
return code;
}
diff --git a/generic/tclScan.c b/generic/tclScan.c
index 1a05b8c..b5f962d 100644
--- a/generic/tclScan.c
+++ b/generic/tclScan.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclScan.c,v 1.24.6.1 2007/06/25 18:53:31 dgp Exp $
+ * RCS: @(#) $Id: tclScan.c,v 1.24.6.2 2007/11/12 19:18:20 dgp Exp $
*/
#include "tclInt.h"
@@ -899,7 +899,7 @@ Tcl_ScanObjCmd(
if (flags & SCAN_LONGER) {
if (Tcl_GetWideIntFromObj(NULL, objPtr, &wideValue) != TCL_OK) {
wideValue = ~(Tcl_WideUInt)0 >> 1; /* WIDE_MAX */
- if (Tcl_GetString(objPtr)[0] == '-') {
+ if (TclGetString(objPtr)[0] == '-') {
wideValue++; /* WIDE_MAX + 1 = WIDE_MIN */
}
}
@@ -911,8 +911,8 @@ Tcl_ScanObjCmd(
Tcl_SetWideIntObj(objPtr, wideValue);
}
} else if (!(flags & SCAN_BIG)) {
- if (Tcl_GetLongFromObj(NULL, objPtr, &value) != TCL_OK) {
- if (Tcl_GetString(objPtr)[0] == '-') {
+ if (TclGetLongFromObj(NULL, objPtr, &value) != TCL_OK) {
+ if (TclGetString(objPtr)[0] == '-') {
value = LONG_MIN;
} else {
value = LONG_MAX;
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 2ab51fb..eb83c22 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -33,7 +33,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclStringObj.c,v 1.65 2007/03/28 19:03:42 dgp Exp $ */
+ * RCS: @(#) $Id: tclStringObj.c,v 1.65.2.1 2007/11/12 19:18:20 dgp Exp $ */
#include "tclInt.h"
#include "tommath.h"
@@ -637,7 +637,7 @@ Tcl_GetRange(
}
if (objPtr->bytes && (stringPtr->numChars == objPtr->length)) {
- char *str = Tcl_GetString(objPtr);
+ char *str = TclGetString(objPtr);
/*
* All of the characters in the Utf string are 1 byte chars, so we
@@ -1231,7 +1231,7 @@ Tcl_AppendObjToObj(
AppendUnicodeToUnicodeRep(objPtr, stringPtr->unicode,
stringPtr->numChars);
} else {
- bytes = Tcl_GetStringFromObj(appendObjPtr, &length);
+ bytes = TclGetStringFromObj(appendObjPtr, &length);
AppendUtfToUnicodeRep(objPtr, bytes, length);
}
return;
@@ -1243,7 +1243,7 @@ Tcl_AppendObjToObj(
* characters in the final (appended-to) object.
*/
- bytes = Tcl_GetStringFromObj(appendObjPtr, &length);
+ bytes = TclGetStringFromObj(appendObjPtr, &length);
allOneByteChars = 0;
numChars = stringPtr->numChars;
@@ -1715,7 +1715,7 @@ Tcl_AppendFormatToObj(
if (Tcl_IsShared(appendObj)) {
Tcl_Panic("%s called with shared object", "Tcl_AppendFormatToObj");
}
- Tcl_GetStringFromObj(appendObj, &originalLength);
+ TclGetStringFromObj(appendObj, &originalLength);
/*
* Format string is NUL-terminated.
@@ -1832,7 +1832,7 @@ Tcl_AppendFormatToObj(
msg = badIndex[gotXpg];
goto errorMsg;
}
- if (Tcl_GetIntFromObj(interp, objv[objIndex], &width) != TCL_OK) {
+ if (TclGetIntFromObj(interp, objv[objIndex], &width) != TCL_OK) {
goto error;
}
if (width < 0) {
@@ -1863,7 +1863,7 @@ Tcl_AppendFormatToObj(
msg = badIndex[gotXpg];
goto errorMsg;
}
- if (Tcl_GetIntFromObj(interp, objv[objIndex], &precision)
+ if (TclGetIntFromObj(interp, objv[objIndex], &precision)
!= TCL_OK) {
goto error;
}
@@ -1930,7 +1930,7 @@ Tcl_AppendFormatToObj(
case 'c': {
char buf[TCL_UTF_MAX];
int code, length;
- if (Tcl_GetIntFromObj(interp, segment, &code) != TCL_OK) {
+ if (TclGetIntFromObj(interp, segment, &code) != TCL_OK) {
goto error;
}
length = Tcl_UniCharToUtf(code, buf);
@@ -1975,7 +1975,7 @@ Tcl_AppendFormatToObj(
Tcl_DecrRefCount(objPtr);
}
isNegative = (w < (Tcl_WideInt)0);
- } else if (Tcl_GetLongFromObj(NULL, segment, &l) != TCL_OK) {
+ } else if (TclGetLongFromObj(NULL, segment, &l) != TCL_OK) {
if (Tcl_GetWideIntFromObj(NULL, segment, &w) != TCL_OK) {
Tcl_Obj *objPtr;
@@ -1985,7 +1985,7 @@ Tcl_AppendFormatToObj(
mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big);
objPtr = Tcl_NewBignumObj(&big);
Tcl_IncrRefCount(objPtr);
- Tcl_GetLongFromObj(NULL, objPtr, &l);
+ TclGetLongFromObj(NULL, objPtr, &l);
Tcl_DecrRefCount(objPtr);
} else {
l = Tcl_WideAsLong(w);
@@ -2040,7 +2040,7 @@ Tcl_AppendFormatToObj(
pure = Tcl_NewLongObj(l);
}
Tcl_IncrRefCount(pure);
- bytes = Tcl_GetStringFromObj(pure, &length);
+ bytes = TclGetStringFromObj(pure, &length);
/*
* Already did the sign above.
@@ -2137,7 +2137,7 @@ Tcl_AppendFormatToObj(
}
pure = Tcl_NewObj();
Tcl_SetObjLength(pure, numDigits);
- bytes = Tcl_GetString(pure);
+ bytes = TclGetString(pure);
length = numDigits;
while (numDigits--) {
int digitOffset;
@@ -2230,7 +2230,7 @@ Tcl_AppendFormatToObj(
segment = Tcl_NewObj();
allocSegment = 1;
Tcl_SetObjLength(segment, length);
- bytes = Tcl_GetString(segment);
+ bytes = TclGetString(segment);
Tcl_SetObjLength(segment, sprintf(bytes, spec, d));
break;
}
@@ -2248,7 +2248,7 @@ Tcl_AppendFormatToObj(
case 'E':
case 'G':
case 'X': {
- Tcl_SetObjLength(segment, Tcl_UtfToUpper(Tcl_GetString(segment)));
+ Tcl_SetObjLength(segment, Tcl_UtfToUpper(TclGetString(segment)));
}
}
@@ -2451,7 +2451,7 @@ AppendPrintfToObjVA(
}
} while (seekingConversion);
}
- Tcl_ListObjGetElements(NULL, list, &objc, &objv);
+ TclListObjGetElements(NULL, list, &objc, &objv);
code = Tcl_AppendFormatToObj(NULL, objPtr, format, objc, objv);
if (code != TCL_OK) {
Tcl_AppendPrintfToObj(objPtr,
@@ -2578,12 +2578,12 @@ TclStringObjReverse(
return objPtr;
}
- bytes = Tcl_GetString(objPtr);
+ bytes = TclGetString(objPtr);
if (Tcl_IsShared(objPtr)) {
char *dest;
Tcl_Obj *resultPtr = Tcl_NewObj();
Tcl_SetObjLength(resultPtr, numChars);
- dest = Tcl_GetString(resultPtr);
+ dest = TclGetString(resultPtr);
while (i < numChars) {
dest[i++] = bytes[lastCharIdx--];
}
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 8f75aa7..b149cd0 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclStubInit.c,v 1.140.2.3 2007/09/06 18:20:31 dgp Exp $
+ * RCS: @(#) $Id: tclStubInit.c,v 1.140.2.4 2007/11/12 19:18:20 dgp Exp $
*/
#include "tclInt.h"
@@ -326,6 +326,8 @@ TclIntStubs tclIntStubs = {
TclVarHashCreateVar, /* 234 */
TclInitVarHashTable, /* 235 */
TclBackgroundException, /* 236 */
+ TclByteArrayMatch, /* 237 */
+ TclReToGlob, /* 238 */
};
TclIntPlatStubs tclIntPlatStubs = {
diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c
index 9f5d325..aa1d185 100644
--- a/generic/tclStubLib.c
+++ b/generic/tclStubLib.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclStubLib.c,v 1.15.2.2 2007/09/19 17:28:37 dgp Exp $
+ * RCS: @(#) $Id: tclStubLib.c,v 1.15.2.3 2007/11/12 19:18:20 dgp Exp $
*/
/*
@@ -50,6 +50,7 @@ HasStubSupport(
interp->result =
"This interpreter does not support stubs-enabled extensions.";
interp->freeProc = TCL_STATIC;
+ ((Interp *)interp)->flags |= INTERP_RESULT_UNCLEAN;
return NULL;
}
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index d0b903b..24c9694 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclUtil.c,v 1.82.2.2 2007/11/01 16:25:57 dgp Exp $
+ * RCS: @(#) $Id: tclUtil.c,v 1.82.2.3 2007/11/12 19:18:20 dgp Exp $
*/
#include "tclInt.h"
@@ -1161,7 +1161,7 @@ Tcl_ConcatObj(
objPtr = objv[i];
if (objPtr->typePtr != &tclListType) {
- Tcl_GetString(objPtr);
+ TclGetString(objPtr);
if (objPtr->length) {
break;
} else {
@@ -1192,7 +1192,7 @@ Tcl_ConcatObj(
if (objPtr->bytes && !objPtr->length) {
continue;
}
- Tcl_ListObjGetElements(NULL, objPtr, &listc, &listv);
+ TclListObjGetElements(NULL, objPtr, &listc, &listv);
if (listc) {
if (resPtr) {
Tcl_ListObjReplace(NULL, resPtr, INT_MAX, 0, listc, listv);
@@ -1219,7 +1219,7 @@ Tcl_ConcatObj(
allocSize = 0;
for (i = 0; i < objc; i++) {
objPtr = objv[i];
- element = Tcl_GetStringFromObj(objPtr, &length);
+ element = TclGetStringFromObj(objPtr, &length);
if ((element != NULL) && (length > 0)) {
allocSize += (length + 1);
}
@@ -1249,7 +1249,7 @@ Tcl_ConcatObj(
p = concatStr;
for (i = 0; i < objc; i++) {
objPtr = objv[i];
- element = Tcl_GetStringFromObj(objPtr, &elemLength);
+ element = TclGetStringFromObj(objPtr, &elemLength);
while ((elemLength > 0) && (UCHAR(*element) < 127)
&& isspace(UCHAR(*element))) { /* INTL: ISO C space. */
element++;
@@ -1553,6 +1553,180 @@ Tcl_StringCaseMatch(
/*
*----------------------------------------------------------------------
*
+ * 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 */
+{
+ 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) == '*') {
+ /* 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)) {
+ 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++;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_DStringInit --
*
* Initializes a dynamic string, discarding any previous contents of the
@@ -1850,6 +2024,7 @@ Tcl_DStringResult(
} else {
Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE);
}
+ ((Interp *) interp)->flags |= INTERP_RESULT_UNCLEAN;
dsPtr->string = dsPtr->staticSpace;
dsPtr->length = 0;
@@ -2330,7 +2505,7 @@ TclGetIntForIndex(
int *indexPtr) /* Location filled in with an integer
* representing an index. */
{
- if (Tcl_GetIntFromObj(NULL, objPtr, indexPtr) == TCL_OK) {
+ if (TclGetIntFromObj(NULL, objPtr, indexPtr) == TCL_OK) {
return TCL_OK;
}
@@ -2344,7 +2519,7 @@ TclGetIntForIndex(
} else {
int length;
- char *opPtr, *bytes = Tcl_GetStringFromObj(objPtr, &length);
+ char *opPtr, *bytes = TclGetStringFromObj(objPtr, &length);
/* Leading whitespace is acceptable in an index */
while (length && isspace(UCHAR(*bytes))) { /* INTL: ISO space. */
@@ -2486,7 +2661,7 @@ SetEndOffsetFromAny(
* Check for a string rep of the right form.
*/
- bytes = Tcl_GetStringFromObj(objPtr, &length);
+ bytes = TclGetStringFromObj(objPtr, &length);
if ((*bytes != 'e') || (strncmp(bytes, "end",
(size_t)((length > 3) ? 3 : length)) != 0)) {
if (interp != NULL) {
@@ -2754,7 +2929,7 @@ TclSetProcessGlobalValue(
} else {
Tcl_CreateExitHandler(FreeProcessGlobalValue, (ClientData) pgvPtr);
}
- bytes = Tcl_GetStringFromObj(newValue, &pgvPtr->numBytes);
+ bytes = TclGetStringFromObj(newValue, &pgvPtr->numBytes);
pgvPtr->value = ckalloc((unsigned int) pgvPtr->numBytes + 1);
strcpy(pgvPtr->value, bytes);
if (pgvPtr->encoding) {
@@ -3009,6 +3184,190 @@ TclGetPlatform(void)
}
/*
+ *----------------------------------------------------------------------
+ *
+ * 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.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclReToGlob(Tcl_Interp *interp,
+ const char *reStr,
+ int reStrLen,
+ Tcl_DString *dsPtr,
+ int *exactPtr)
+{
+ int anchorLeft, anchorRight;
+ char *dsStr, *dsStrStart, *msg;
+ const char *p, *strEnd;
+
+ strEnd = reStr + reStrLen;
+ Tcl_DStringInit(dsPtr);
+
+ /*
+ * "***=xxx" == "*xxx*"
+ */
+
+ if ((reStrLen >= 4) && (memcmp("***=", reStr, 4) == 0)) {
+ *exactPtr = 1;
+ Tcl_DStringAppend(dsPtr, reStr + 4, reStrLen - 4);
+ return TCL_OK;
+ }
+
+ /*
+ * Write to the ds directly without the function overhead.
+ * An equivalent glob pattern can be no more than reStrLen+2 in size.
+ */
+
+ Tcl_DStringSetLength(dsPtr, reStrLen + 2);
+ 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.
+ */
+
+ msg = NULL;
+ p = reStr;
+ anchorRight = 0;
+ dsStr = dsStrStart;
+ if (*p == '^') {
+ anchorLeft = 1;
+ p++;
+ } else {
+ anchorLeft = 0;
+ *dsStr++ = '*';
+ }
+
+ 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':
+ *dsStr++ = '\\';
+ *dsStr++ = '\\';
+ anchorLeft = 0; /* prevent exact match */
+ break;
+ case '\\': case '*': case '+': case '?':
+ case '{': case '}': case '(': case ')': case '[': case ']':
+ case '.': case '|': case '^': case '$':
+ *dsStr++ = '\\';
+ *dsStr++ = *p;
+ anchorLeft = 0; /* prevent exact match */
+ break;
+ default:
+ msg = "invalid escape sequence";
+ goto invalidGlob;
+ }
+ break;
+ case '.':
+ anchorLeft = 0; /* prevent exact match */
+ if (p+1 < strEnd) {
+ if (p[1] == '*') {
+ p++;
+ if ((dsStr == dsStrStart) || (dsStr[-1] != '*')) {
+ *dsStr++ = '*';
+ }
+ continue;
+ } else if (p[1] == '+') {
+ p++;
+ *dsStr++ = '?';
+ *dsStr++ = '*';
+ continue;
+ }
+ }
+ *dsStr++ = '?';
+ break;
+ case '$':
+ if (p+1 != strEnd) {
+ msg = "$ not anchor";
+ goto invalidGlob;
+ }
+ anchorRight = 1;
+ break;
+ case '*': case '+': case '?': case '|': case '^':
+ case '{': case '}': case '(': case ')': case '[': case ']':
+ msg = "unhandled RE special char";
+ goto invalidGlob;
+ break;
+ default:
+ *dsStr++ = *p;
+ break;
+ }
+ }
+ if (!anchorRight && ((dsStr == dsStrStart) || (dsStr[-1] != '*'))) {
+ *dsStr++ = '*';
+ }
+ Tcl_DStringSetLength(dsPtr, dsStr - dsStrStart);
+
+#ifdef TCL_MEM_DEBUG
+ /*
+ * Check if this is a bad RE (do this at the end because it can be
+ * expensive).
+ * XXX: Is it possible that we can have a bad RE make it through the
+ * XXX: above checks?
+ */
+
+ if (Tcl_RegExpCompile(NULL, reStr) == NULL) {
+ msg = "couldn't compile RE";
+ goto invalidGlob;
+ }
+#endif
+
+ *exactPtr = (anchorLeft && anchorRight);
+
+#if 0
+ fprintf(stderr, "INPUT RE '%.*s' OUTPUT GLOB '%s' anchor %d:%d \n",
+ reStrLen, reStr,
+ Tcl_DStringValue(dsPtr), anchorLeft, anchorRight);
+ fflush(stderr);
+#endif
+ return TCL_OK;
+
+ invalidGlob:
+#if 0
+ fprintf(stderr, "INPUT RE '%.*s' NO OUTPUT GLOB %s (%c)\n",
+ reStrLen, reStr, msg, *p);
+ fflush(stderr);
+#endif
+ Tcl_DStringFree(dsPtr);
+ return TCL_ERROR;
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclVar.c b/generic/tclVar.c
index e5077cb..63b393d 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -16,7 +16,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclVar.c,v 1.135.2.9 2007/11/05 14:20:57 dgp Exp $
+ * RCS: @(#) $Id: tclVar.c,v 1.135.2.10 2007/11/12 19:18:21 dgp Exp $
*/
#include "tclInt.h"
@@ -614,7 +614,7 @@ TclObjLookupVarEx(
}
parsed = 1;
}
- part1 = Tcl_GetStringFromObj(part1Ptr, &len1);
+ part1 = TclGetStringFromObj(part1Ptr, &len1);
if (!parsed && (*(part1 + len1 - 1) == ')')) {
/*
@@ -2572,7 +2572,7 @@ Tcl_LappendObjCmd(
return TCL_ERROR;
}
} else {
- result = Tcl_ListObjLength(interp, newValuePtr, &numElems);
+ result = TclListObjLength(interp, newValuePtr, &numElems);
if (result != TCL_OK) {
return result;
}
@@ -2630,7 +2630,7 @@ Tcl_LappendObjCmd(
createdNewObj = 1;
}
- result = Tcl_ListObjLength(interp, varValuePtr, &numElems);
+ result = TclListObjLength(interp, varValuePtr, &numElems);
if (result == TCL_OK) {
result = Tcl_ListObjReplace(interp, varValuePtr, numElems, 0,
(objc-2), (objv+2));
@@ -2971,7 +2971,7 @@ Tcl_ArrayObjCmd(
*/
TclNewObj(tmpResPtr);
- result = Tcl_ListObjGetElements(interp, nameLstPtr, &count, &namePtrPtr);
+ result = TclListObjGetElements(interp, nameLstPtr, &count, &namePtrPtr);
if (result != TCL_OK) {
goto errorInArrayGet;
}
@@ -3307,7 +3307,7 @@ TclArraySet(
int elemLen;
Tcl_Obj **elemPtrs, *copyListObj;
- result = Tcl_ListObjGetElements(interp, arrayElemObj,
+ result = TclListObjGetElements(interp, arrayElemObj,
&elemLen, &elemPtrs);
if (result != TCL_OK) {
return result;
@@ -4793,7 +4793,7 @@ UpdateParsedVarName(
Tcl_Panic("scalar parsedVarName without a string rep");
}
- part1 = Tcl_GetStringFromObj(arrayPtr, &len1);
+ part1 = TclGetStringFromObj(arrayPtr, &len1);
len2 = strlen(part2);
totalLen = len1 + len2 + 2;
diff --git a/tests/regexpComp.test b/tests/regexpComp.test
index a84099e..8460006 100644
--- a/tests/regexpComp.test
+++ b/tests/regexpComp.test
@@ -822,6 +822,82 @@ foreach {str exp result} {
[subst {evalInProc {set a "$str"; regexp {$exp} \$a}}] $result
}
+set i 0
+foreach {str exp result} {
+ foo ^foo 1
+ foobar ^foobar$ 1
+ foobar bar$ 1
+ foobar ^$ 0
+ "" ^$ 1
+ anything $ 1
+ anything ^.*$ 1
+ anything ^.*a$ 0
+ anything ^.*a.*$ 1
+ anything ^.*.*$ 1
+ anything ^.*..*$ 1
+ anything ^.*b$ 0
+ anything ^a.*$ 1
+} {
+ test regexpComp-23.[incr i] {regexp command compiling tests INST_REGEXP} \
+ [subst {evalInProc {set a "$str"; set re "$exp"; regexp \$re \$a}}] $result
+}
+
+test regexpComp-24.1 {regexp command compiling tests} {
+ evalInProc {
+ set re foo
+ regexp -nocase $re bar
+ }
+} 0
+test regexpComp-24.2 {regexp command compiling tests} {
+ evalInProc {
+ set re {^foo$}
+ regexp $re dogfood
+ }
+} 0
+test regexpComp-24.3 {regexp command compiling tests} {
+ evalInProc {
+ set a foo
+ set re {^foo$}
+ regexp $re $a
+ }
+} 1
+test regexpComp-24.4 {regexp command compiling tests} {
+ evalInProc {
+ set re foo
+ regexp $re dogfood
+ }
+} 1
+test regexpComp-24.5 {regexp command compiling tests} {
+ evalInProc {
+ set re FOO
+ regexp -nocase $re dogfod
+ }
+} 0
+test regexpComp-24.6 {regexp command compiling tests} {
+ evalInProc {
+ set re foo
+ regexp -n $re dogfoOd
+ }
+} 1
+test regexpComp-24.7 {regexp command compiling tests} {
+ evalInProc {
+ set re FoO
+ regexp -no -- $re dogfood
+ }
+} 1
+test regexpComp-24.8 {regexp command compiling tests} {
+ evalInProc {
+ set re foo
+ regexp -- $re dogfod
+ }
+} 0
+test regexpComp-24.9 {regexp command compiling tests} {
+ evalInProc {
+ set re "("
+ list [catch {regexp -- $re dogfod} msg] $msg
+ }
+} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
+
# cleanup
::tcltest::cleanupTests
return
diff --git a/tools/Makefile.in b/tools/Makefile.in
index ecd115a..77a1916 100644
--- a/tools/Makefile.in
+++ b/tools/Makefile.in
@@ -6,7 +6,7 @@
#
# HTML: 1. Build the html target on Unix
-# RCS: @(#) $Id: Makefile.in,v 1.9 2000/04/20 01:30:20 hobbs Exp $
+# RCS: @(#) $Id: Makefile.in,v 1.9.38.1 2007/11/12 19:18:21 dgp Exp $
TCL = tcl@TCL_VERSION@
TK = tk@TCL_VERSION@
@@ -66,4 +66,4 @@ clean:
-rm -f man2tcl *.o *.cnt *.rtf
helpfile:
- hcw /c /e tcl.hpj
+ hcw /c /e tcl.hpj \ No newline at end of file
diff --git a/unix/configure b/unix/configure
index ca4a5f7..1e01fb3 100755
--- a/unix/configure
+++ b/unix/configure
@@ -17897,6 +17897,78 @@ echo "$as_me:$LINENO: result: $tcl_ok" >&5
echo "${ECHO_T}$tcl_ok" >&6
#--------------------------------------------------------------------
+# Does the C stack grow upwards or downwards? Or cross-compiling?
+#--------------------------------------------------------------------
+
+echo "$as_me:$LINENO: checking does the C stack grow upwards in memory?" >&5
+echo $ECHO_N "checking does the C stack grow upwards in memory?... $ECHO_C" >&6
+if test "${tcl_cv_stack_grows_up+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+
+ if test "$cross_compiling" = yes; then
+ tcl_cv_stack_grows_up=unknown
+else
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+
+ int StackGrowsUp(int *parent)
+ {
+ int here;
+ return (&here < parent);
+ }
+
+ int main (int argc, char *argv[])
+ {
+ int foo;
+ return StackGrowsUp(&foo);
+ }
+
+_ACEOF
+rm -f conftest$ac_exeext
+if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
+ (eval $ac_link) 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && { ac_try='./conftest$ac_exeext'
+ { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+ (eval $ac_try) 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); }; }; then
+ tcl_cv_stack_grows_up=yes
+else
+ echo "$as_me: program exited with status $ac_status" >&5
+echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+( exit $ac_status )
+tcl_cv_stack_grows_up=no
+fi
+rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
+fi
+fi
+echo "$as_me:$LINENO: result: $tcl_cv_stack_grows_up" >&5
+echo "${ECHO_T}$tcl_cv_stack_grows_up" >&6
+if test $tcl_cv_stack_grows_up = unknown; then
+
+cat >>confdefs.h <<\_ACEOF
+#define TCL_CROSS_COMPILE 1
+_ACEOF
+
+elif test $tcl_cv_stack_grows_up = yes; then
+
+cat >>confdefs.h <<\_ACEOF
+#define TCL_STACK_GROWS_UP 1
+_ACEOF
+
+fi
+
+#--------------------------------------------------------------------
# The statements below define a collection of symbols related to
# building libtcl as a shared library instead of a static library.
#--------------------------------------------------------------------
diff --git a/unix/configure.in b/unix/configure.in
index 913f4ef..272e466 100644
--- a/unix/configure.in
+++ b/unix/configure.in
@@ -3,7 +3,7 @@ dnl This file is an input file used by the GNU "autoconf" program to
dnl generate the file "configure", which is run during Tcl installation
dnl to configure the system for the local environment.
#
-# RCS: @(#) $Id: configure.in,v 1.157.2.8 2007/10/27 04:11:51 dgp Exp $
+# RCS: @(#) $Id: configure.in,v 1.157.2.9 2007/11/12 19:18:23 dgp Exp $
AC_INIT([tcl],[8.5])
AC_PREREQ(2.59)
@@ -658,6 +658,35 @@ fi
AC_MSG_RESULT([$tcl_ok])
#--------------------------------------------------------------------
+# Does the C stack grow upwards or downwards? Or cross-compiling?
+#--------------------------------------------------------------------
+
+AC_CACHE_CHECK([does the C stack grow upwards in memory?], tcl_cv_stack_grows_up, [
+ AC_TRY_RUN([
+ int StackGrowsUp(int *parent)
+ {
+ int here;
+ return (&here < parent);
+ }
+
+ int main (int argc, char *argv[])
+ {
+ int foo;
+ return StackGrowsUp(&foo);
+ }
+ ],
+ tcl_cv_stack_grows_up=yes,
+ tcl_cv_stack_grows_up=no,
+ tcl_cv_stack_grows_up=unknown)])
+if test $tcl_cv_stack_grows_up = unknown; then
+ AC_DEFINE(TCL_CROSS_COMPILE, 1,
+ [Are we cross-compiling?])
+elif test $tcl_cv_stack_grows_up = yes; then
+ AC_DEFINE(TCL_STACK_GROWS_UP, 1,
+ [The C stack grows upwards in memory])
+fi
+
+#--------------------------------------------------------------------
# The statements below define a collection of symbols related to
# building libtcl as a shared library instead of a static library.
#--------------------------------------------------------------------
diff --git a/unix/tclConfig.h.in b/unix/tclConfig.h.in
index 75400b8..0dc1839 100644
--- a/unix/tclConfig.h.in
+++ b/unix/tclConfig.h.in
@@ -361,6 +361,9 @@
/* Are bytecode statistics enabled? */
#undef TCL_COMPILE_STATS
+/* Are we cross-compiling? */
+#undef TCL_CROSS_COMPILE
+
/* Are we to override what our default encoding is? */
#undef TCL_DEFAULT_ENCODING
@@ -376,6 +379,9 @@
/* What is the default extension for shared libraries? */
#undef TCL_SHLIB_EXT
+/* The C stack grows upwards in memory */
+#undef TCL_STACK_GROWS_UP
+
/* Are we building with threads enabled? */
#undef TCL_THREADS
diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c
index bb4c0b1..368dd20 100644
--- a/unix/tclUnixChan.c
+++ b/unix/tclUnixChan.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclUnixChan.c,v 1.77.2.3 2007/09/17 15:03:47 dgp Exp $
+ * RCS: @(#) $Id: tclUnixChan.c,v 1.77.2.4 2007/11/12 19:18:24 dgp Exp $
*/
#include "tclInt.h" /* Internal definitions for Tcl. */
@@ -967,8 +967,16 @@ TtySetOptionProc(
return TCL_ERROR;
}
if (argc == 2) {
- iostate.c_cc[VSTART] = argv[0][0];
- iostate.c_cc[VSTOP] = argv[1][0];
+ Tcl_DString ds;
+ Tcl_DStringInit(&ds);
+
+ Tcl_UtfToExternalDString(NULL, argv[0], -1, &ds);
+ iostate.c_cc[VSTART] = *(const cc_t *) Tcl_DStringValue(&ds);
+ Tcl_DStringSetLength(&ds, 0);
+
+ Tcl_UtfToExternalDString(NULL, argv[1], -1, &ds);
+ iostate.c_cc[VSTOP] = *(const cc_t *) Tcl_DStringValue(&ds);
+ Tcl_DStringFree(&ds);
} else {
if (interp) {
Tcl_AppendResult(interp, "bad value for -xchar: "
@@ -1142,13 +1150,19 @@ TtyGetOptionProc(
}
if (len==0 || (len>1 && strncmp(optionName, "-xchar", len)==0)) {
IOSTATE iostate;
-
+ Tcl_DString ds;
valid = 1;
+
GETIOSTATE(fsPtr->fd, &iostate);
- sprintf(buf, "%c", iostate.c_cc[VSTART]);
- Tcl_DStringAppendElement(dsPtr, buf);
- sprintf(buf, "%c", iostate.c_cc[VSTOP]);
- Tcl_DStringAppendElement(dsPtr, buf);
+ Tcl_DStringInit(&ds);
+
+ Tcl_ExternalToUtfDString(NULL, (const char *) &iostate.c_cc[VSTART], 1, &ds);
+ Tcl_DStringAppendElement(dsPtr, (const char *) Tcl_DStringValue(&ds));
+ Tcl_DStringSetLength(&ds, 0);
+
+ Tcl_ExternalToUtfDString(NULL, (const char *) &iostate.c_cc[VSTOP], 1, &ds);
+ Tcl_DStringAppendElement(dsPtr, (const char *) Tcl_DStringValue(&ds));
+ Tcl_DStringFree(&ds);
}
if (len == 0) {
Tcl_DStringEndSublist(dsPtr);
diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c
index c611067..1e6d8f8 100644
--- a/unix/tclUnixInit.c
+++ b/unix/tclUnixInit.c
@@ -7,7 +7,7 @@
* Copyright (c) 1999 by Scriptics Corporation.
* All rights reserved.
*
- * RCS: @(#) $Id: tclUnixInit.c,v 1.70.2.1 2007/09/04 17:44:22 dgp Exp $
+ * RCS: @(#) $Id: tclUnixInit.c,v 1.70.2.2 2007/11/12 19:18:24 dgp Exp $
*/
#include "tclInt.h"
@@ -78,11 +78,17 @@
typedef struct ThreadSpecificData {
int *outerVarPtr; /* The "outermost" stack frame pointer for
* this thread. */
- int initialised; /* Have we found what the stack size was? */
- int stackDetermineResult; /* What happened when we did that? */
- size_t stackSize; /* The size of the current stack. */
+ int *stackBound; /* The current stack boundary */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
+#ifdef TCL_CROSS_COMPILE
+static int stackGrowsDown = -1;
+static int StackGrowsDown(int *parent);
+#elif defined(TCL_STACK_GROWS_UP)
+#define stackGrowsDown 0
+#else
+#define stackGrowsDown 1
+#endif
#endif /* TCL_NO_STACK_CHECK */
#ifdef TCL_DEBUG_STACK_CHECK
@@ -343,6 +349,7 @@ static int MacOSXGetLibraryPath(Tcl_Interp *interp,
MODULE_SCOPE long tclMacOSXDarwinRelease;
long tclMacOSXDarwinRelease = 0;
#endif
+
/*
*---------------------------------------------------------------------------
@@ -1003,111 +1010,111 @@ TclpFindVariable(
return result;
}
+#ifndef TCL_NO_STACK_CHECK
/*
*----------------------------------------------------------------------
*
- * TclpCheckStackSpace --
+ * TclpGetCStackParams --
*
- * Detect if we are about to blow the stack. Called before an evaluation
- * can happen when nesting depth is checked.
+ * Determine the stack params for the current thread: in which
+ * direction does the stack grow, and what is the stack lower (resp.
+ * upper) bound for safe invocation of a new command? This is used to
+ * cache the values needed for an efficient computation of
+ * TclpCheckStackSpace() when the interp is known.
*
* Results:
- * 1 if there is enough stack space to continue; 0 if not.
- *
- * Side effects:
- * None.
+ * Returns 1 if the stack grows down, in which case a stack lower bound
+ * is stored at stackBoundPtr. If the stack grows up, 0 is returned and
+ * an upper bound is stored at stackBoundPtr. If a bound cannot be
+ * determined NULL is stored at stackBoundPtr.
*
*----------------------------------------------------------------------
*/
int
-TclpCheckStackSpace(void)
+TclpGetCStackParams(
+ int **stackBoundPtr)
{
-#ifdef TCL_NO_STACK_CHECK
-
- /*
- * This function was normally unimplemented on Unix platforms and this
- * implements old behavior, i.e. no stack checking performed.
- */
-
- return 1;
-
-#else
-
+ int result = TCL_OK;
+ size_t stackSize = 0; /* The size of the current stack. */
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/* Most variables are actually in a
* thread-specific data block to minimise the
* impact on the stack. */
- register size_t stackUsed;
- int localVar; /* Reference to somewhere on the local stack.
- * This is declared last so it's as "deep" as
- * possible. */
-
- if (tsdPtr == NULL) {
+#ifdef TCL_CROSS_COMPILE
+ if (stackGrowsDown == -1) {
/*
- * This should probably be a panic(); if we're out of stack, we might
- * have virtually no room to manoeuver at all.
+ * Not initialised!
*/
- Tcl_Panic("failed to get thread specific stack check data");
+ stackGrowsDown = StackGrowsDown(&result);
}
-
+#endif
+
/*
- * The first time through, we record the "outermost" stack frame.
+ * The first time through in a thread: record the "outermost" stack
+ * frame and inquire with the OS about the stack size.
*/
if (tsdPtr->outerVarPtr == NULL) {
- tsdPtr->outerVarPtr = &localVar;
+ tsdPtr->outerVarPtr = &result;
+ result = GetStackSize(&stackSize);
+ if (result != TCL_OK) {
+ /* Can't check, assume it always succeeds */
+#ifdef TCL_CROSS_COMPILE
+ stackGrowsDown = 1;
+#endif
+ tsdPtr->stackBound = NULL;
+ goto done;
+ }
}
- if (tsdPtr->initialised == 0) {
+ if (stackSize || (tsdPtr->stackBound &&
+ ((stackGrowsDown && (&result < tsdPtr->stackBound)) ||
+ (!stackGrowsDown && (&result > tsdPtr->stackBound))))) {
/*
- * We appear to have not computed the stack size before. Attempt to
- * retrieve it from either the current thread or, failing that, the
- * process accounting limit. Note that we assume that stack sizes do
- * not change throughout the lifespan of the thread/process; this is
- * almost always true.
+ * Either the thread's first pass or stack failure: set the params
*/
- tsdPtr->stackDetermineResult = GetStackSize(&tsdPtr->stackSize);
- tsdPtr->initialised = 1;
- }
-
- switch (tsdPtr->stackDetermineResult) {
- case TCL_BREAK:
- STACK_DEBUG(("skipping stack check with failure\n"));
- return 0;
- case TCL_CONTINUE:
- STACK_DEBUG(("skipping stack check with success\n"));
- return 1;
- }
-
- /*
- * Sanity check to see if somehow the stack started going the
- * other way.
- */
+ if (!stackSize) {
+ /*
+ * Stack failure: if we didn't already blow up, we are within the
+ * safety area. Recheck with the OS in case the stack was grown.
+ */
+ result = GetStackSize(&stackSize);
+ if (result != TCL_OK) {
+ /* Can't check, assume it always succeeds */
+#ifdef TCL_CROSS_COMPILE
+ stackGrowsDown = 1;
+#endif
+ tsdPtr->stackBound = NULL;
+ goto done;
+ }
+ }
- if (&localVar > tsdPtr->outerVarPtr) {
- stackUsed = (char *)&localVar - (char *)tsdPtr->outerVarPtr;
- } else {
- stackUsed = (char *)tsdPtr->outerVarPtr - (char *)&localVar;
+ if (stackGrowsDown) {
+ tsdPtr->stackBound = (int *) ((char *)tsdPtr->outerVarPtr -
+ stackSize);
+ } else {
+ tsdPtr->stackBound = (int *) ((char *)tsdPtr->outerVarPtr +
+ stackSize);
+ }
}
- /*
- * Now we perform the actual check. Are we about to blow our stack frame?
- */
+ done:
+ *stackBoundPtr = tsdPtr->stackBound;
+ return stackGrowsDown;
+}
- if (stackUsed < tsdPtr->stackSize) {
- STACK_DEBUG(("stack OK\tin:%p\tout:%p\tuse:%04X\tmax:%04X\n",
- &localVar, tsdPtr->outerVarPtr, stackUsed, tsdPtr->stackSize));
- return 1;
- } else {
- STACK_DEBUG(("stack OVERFLOW\tin:%p\tout:%p\tuse:%04X\tmax:%04X\n",
- &localVar, tsdPtr->outerVarPtr, stackUsed, tsdPtr->stackSize));
- return 0;
- }
-#endif /* TCL_NO_STACK_CHECK */
+#ifdef TCL_CROSS_COMPILE
+int
+StackGrowsDown(
+ int *parent)
+{
+ int here;
+ return (&here < parent);
}
+#endif
/*
*----------------------------------------------------------------------
@@ -1132,7 +1139,6 @@ TclpCheckStackSpace(void)
*----------------------------------------------------------------------
*/
-#ifndef TCL_NO_STACK_CHECK
static int
GetStackSize(
size_t *stackSizePtr)
@@ -1146,6 +1152,7 @@ GetStackSize(
/*
* Some kind of confirmed error?!
*/
+ STACK_DEBUG(("skipping stack checks with failure\n"));
return TCL_BREAK;
}
if (rawStackSize > 0) {
@@ -1163,12 +1170,14 @@ GetStackSize(
/*
* getrlimit() failed, just fail the whole thing.
*/
+ STACK_DEBUG(("skipping stack checks with failure: getrlimit failed\n"));
return TCL_BREAK;
}
if (rLimit.rlim_cur == RLIM_INFINITY) {
/*
* Limit is "infinite"; there is no stack limit.
*/
+ STACK_DEBUG(("skipping stack checks with success: infinite limit\n"));
return TCL_CONTINUE;
}
rawStackSize = rLimit.rlim_cur;
@@ -1183,6 +1192,7 @@ GetStackSize(
finalSanityCheck:
#endif
if (rawStackSize <= 0) {
+ STACK_DEBUG(("skipping stack checks with success\n"));
return TCL_CONTINUE;
}
diff --git a/unix/tclUnixTime.c b/unix/tclUnixTime.c
index c99af02..69367b5 100644
--- a/unix/tclUnixTime.c
+++ b/unix/tclUnixTime.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclUnixTime.c,v 1.30.2.1 2007/09/04 17:44:23 dgp Exp $
+ * RCS: @(#) $Id: tclUnixTime.c,v 1.30.2.2 2007/11/12 19:18:24 dgp Exp $
*/
#include "tclInt.h"
@@ -192,11 +192,11 @@ TclpGetWideClicks(void)
*-----------------------------------------------------------------------------
*/
-Tcl_WideInt
+double
TclpWideClicksToNanoseconds(
Tcl_WideInt clicks)
{
- Tcl_WideInt nsec;
+ double nsec;
if (tclGetTimeProcPtr != NativeGetTime) {
nsec = clicks * 1000;
@@ -210,9 +210,9 @@ TclpWideClicksToNanoseconds(
maxClicksForUInt64 = UINT64_MAX / tb.numer;
}
if ((uint64_t) clicks < maxClicksForUInt64) {
- nsec = (Tcl_WideInt) ((uint64_t) clicks * tb.numer / tb.denom);
+ nsec = ((uint64_t) clicks) * tb.numer / tb.denom;
} else {
- nsec = (Tcl_WideInt) ((long double) clicks * tb.numer / tb.denom);
+ nsec = ((long double) (uint64_t) clicks) * tb.numer / tb.denom;
}
#else
#error Wide high-resolution clicks not implemented on this platform
diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c
index c196705..76aab7c 100644
--- a/win/tclWin32Dll.c
+++ b/win/tclWin32Dll.c
@@ -10,11 +10,21 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclWin32Dll.c,v 1.48 2005/11/04 00:06:50 dkf Exp $
+ * RCS: @(#) $Id: tclWin32Dll.c,v 1.48.8.1 2007/11/12 19:18:24 dgp Exp $
*/
#include "tclWinInt.h"
+#ifndef TCL_NO_STACK_CHECK
+/*
+ * The following functions implement stack depth checking
+ */
+typedef struct ThreadSpecificData {
+ int *stackBound; /* The current stack boundary */
+} ThreadSpecificData;
+static Tcl_ThreadDataKey dataKey;
+#endif /* TCL_NO_STACK_CHECK */
+
/*
* The following data structures are used when loading the thunking library
* for execing child processes under Win32s.
@@ -514,127 +524,79 @@ TclWinNoBackslash(
/*
*----------------------------------------------------------------------
*
- * TclpCheckStackSpace --
+ * TclpGetStackParams --
*
- * Detect if we are about to blow the stack. Called before an evaluation
- * can happen when nesting depth is checked.
+ * Determine the stack params for the current thread: in which
+ * direction does the stack grow, and what is the stack lower (resp.
+ * upper) bound for safe invocation of a new command? This is used to
+ * cache the values needed for an efficient computation of
+ * TclpCheckStackSpace() when the interp is known.
*
* Results:
- * 1 if there is enough stack space to continue; 0 if not.
- *
- * Side effects:
- * None.
+ * Returns 1 if the stack grows down, in which case a stack lower bound
+ * is stored at stackBoundPtr. If the stack grows up, 0 is returned and
+ * an upper bound is stored at stackBoundPtr. If a bound cannot be
+ * determined NULL is stored at stackBoundPtr.
*
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_STACK_CHECK
int
-TclpCheckStackSpace(void)
+TclpGetCStackParams(
+ int **stackBoundPtr)
{
-
-#ifdef HAVE_NO_SEH
- EXCEPTION_REGISTRATION registration;
-#endif
- int retval = 0;
-
- /*
- * We can recurse only if there is at least TCL_WIN_STACK_THRESHOLD bytes
- * of stack space left. alloca() is cheap on windows; basically it just
- * subtracts from the stack pointer causing the OS to throw an exception
- * if the stack pointer is set below the bottom of the stack.
- */
-
-#ifdef HAVE_NO_SEH
- __asm__ __volatile__ (
-
- /*
- * Construct an EXCEPTION_REGISTRATION to protect the call to __alloca
- */
-
- "leal %[registration], %%edx" "\n\t"
- "movl %%fs:0, %%eax" "\n\t"
- "movl %%eax, 0x0(%%edx)" "\n\t" /* link */
- "leal 1f, %%eax" "\n\t"
- "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */
- "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */
- "movl %%esp, 0xc(%%edx)" "\n\t" /* esp */
- "movl %[error], 0x10(%%edx)" "\n\t" /* status */
-
- /*
- * Link the EXCEPTION_REGISTRATION on the chain
- */
-
- "movl %%edx, %%fs:0" "\n\t"
-
- /*
- * Attempt a call to __alloca, to determine whether there's sufficient
- * memory to be had.
- */
-
- "movl %[size], %%eax" "\n\t"
- "pushl %%eax" "\n\t"
- "call __alloca" "\n\t"
-
- /*
- * Come here on a normal exit. Recover the EXCEPTION_REGISTRATION and
- * store a TCL_OK status
- */
-
- "movl %%fs:0, %%edx" "\n\t"
- "movl %[ok], %%eax" "\n\t"
- "movl %%eax, 0x10(%%edx)" "\n\t"
- "jmp 2f" "\n"
-
- /*
- * Come here on an exception. Get the EXCEPTION_REGISTRATION that we
- * previously put on the chain.
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ SYSTEM_INFO si; /* The system information, used to
+ * determine the page size */
+ MEMORY_BASIC_INFORMATION mbi;
+ /* The information about the memory
+ * area in which the stack resides */
+
+ if (!tsdPtr->stackBound
+ || ((DWORD_PTR)&tsdPtr < (DWORD_PTR)tsdPtr->stackBound)) {
+
+ /*
+ * Either we haven't determined the stack bound in this thread,
+ * or else we've overflowed the bound that we previously
+ * determined. We need to find a new stack bound from
+ * Windows.
*/
- "1:" "\t"
- "movl %%fs:0, %%edx" "\n\t"
- "movl 0x8(%%edx), %%edx" "\n\t"
+ GetSystemInfo(&si);
+ if (VirtualQuery((LPCVOID) &tsdPtr, &mbi, sizeof(mbi)) == 0) {
- /*
- * Come here however we exited. Restore context from the
- * EXCEPTION_REGISTRATION in case the stack is unbalanced.
- */
+ /* For some reason, the system didn't let us query the
+ * stack size. Nevertheless, we got here and haven't
+ * blown up yet. Don't update the calculated stack bound.
+ * If there is no calculated stack bound yet, set it to
+ * the base of the current page of stack. */
- "2:" "\t"
- "movl 0xc(%%edx), %%esp" "\n\t"
- "movl 0x8(%%edx), %%ebp" "\n\t"
- "movl 0x0(%%edx), %%eax" "\n\t"
- "movl %%eax, %%fs:0" "\n\t"
+ if (!tsdPtr->stackBound) {
+ tsdPtr->stackBound =
+ (int*) ((DWORD_PTR)(&tsdPtr)
+ & ~ (DWORD_PTR)(si.dwPageSize - 1));
+ }
- :
- /* No outputs */
- :
- [registration] "m" (registration),
- [ok] "i" (TCL_OK),
- [error] "i" (TCL_ERROR),
- [size] "i" (TCL_WIN_STACK_THRESHOLD)
- :
- "%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "memory"
- );
- retval = (registration.status == TCL_OK);
+ } else {
-#else /* !HAVE_NO_SEH */
- __try {
-#ifdef HAVE_ALLOCA_GCC_INLINE
- __asm__ __volatile__ (
- "movl %0, %%eax" "\n\t"
- "call __alloca" "\n\t"
- :
- : "i"(TCL_WIN_STACK_THRESHOLD)
- : "%eax");
-#else
- alloca(TCL_WIN_STACK_THRESHOLD);
-#endif /* HAVE_ALLOCA_GCC_INLINE */
- retval = 1;
- } __except (EXCEPTION_EXECUTE_HANDLER) {}
-#endif /* HAVE_NO_SEH */
+ /* The allocation base of the stack segment has to be advanced
+ * by one page (to allow for the guard page maintained in the
+ * C runtime) and then by TCL_WIN_STACK_THRESHOLD (to allow
+ * for the amount of stack that Tcl needs).
+ */
- return retval;
+ tsdPtr->stackBound =
+ (int*) ((DWORD_PTR)(mbi.AllocationBase)
+ + (DWORD_PTR)(si.dwPageSize)
+ + TCL_WIN_STACK_THRESHOLD);
+ }
+ }
+ *stackBoundPtr = tsdPtr->stackBound;
+ return 1;
}
+#endif
+
/*
*---------------------------------------------------------------------------