summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authorjan.nijtmans <nijtmans@users.sourceforge.net>2017-01-04 14:05:20 (GMT)
committerjan.nijtmans <nijtmans@users.sourceforge.net>2017-01-04 14:05:20 (GMT)
commit1297b4be9b37d8c39cb9bd2f8451c1b69bc6fa13 (patch)
tree690246b6abf3458ded10e0293e2c086f894d77ef /generic
parent328461c6cf73105f97aee07048a22741b4d2cc2b (diff)
parent6c67fa6248b76a800bbd47bdc27bfec84e1f0de4 (diff)
downloadtcl-1297b4be9b37d8c39cb9bd2f8451c1b69bc6fa13.zip
tcl-1297b4be9b37d8c39cb9bd2f8451c1b69bc6fa13.tar.gz
tcl-1297b4be9b37d8c39cb9bd2f8451c1b69bc6fa13.tar.bz2
Merge trunk. First steps in eliminating "source -nopkg". Some test-cases still fail.
Diffstat (limited to 'generic')
-rw-r--r--generic/tcl.decls11
-rw-r--r--generic/tcl.h11
-rw-r--r--generic/tclAlloc.c44
-rw-r--r--generic/tclAssembly.c40
-rw-r--r--generic/tclBinary.c14
-rw-r--r--generic/tclClock.c5
-rw-r--r--generic/tclCmdMZ.c2
-rw-r--r--generic/tclCompile.c9
-rw-r--r--generic/tclDecls.h9
-rw-r--r--generic/tclEncoding.c8
-rw-r--r--generic/tclEnsemble.c10
-rw-r--r--generic/tclExecute.c31
-rw-r--r--generic/tclIO.c4
-rw-r--r--generic/tclIOCmd.c79
-rw-r--r--generic/tclIOSock.c28
-rw-r--r--generic/tclInt.h11
-rw-r--r--generic/tclInterp.c1
-rw-r--r--generic/tclLink.c235
-rw-r--r--generic/tclObj.c4
-rw-r--r--generic/tclStringObj.c19
-rw-r--r--generic/tclStubInit.c1
-rw-r--r--generic/tclStubLib.c14
-rw-r--r--generic/tclTest.c50
-rw-r--r--generic/tclZlib.c2
24 files changed, 471 insertions, 171 deletions
diff --git a/generic/tcl.decls b/generic/tcl.decls
index 574b49b..ba047a0 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -2326,6 +2326,17 @@ declare 630 {
# ----- BASELINE -- FOR -- 8.6.0 ----- #
+# TIP #456
+declare 631 {
+ Tcl_Channel Tcl_OpenTcpServerEx(Tcl_Interp *interp, const char *service,
+ const char *host, unsigned int flags, Tcl_TcpAcceptProc *acceptProc,
+ ClientData callbackData)
+}
+
+# ----- BASELINE -- FOR -- 8.7.0 ----- #
+
+
+
##############################################################################
# Define the platform specific public Tcl interface. These functions are only
diff --git a/generic/tcl.h b/generic/tcl.h
index a8c68a6..c0cee27 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -2372,6 +2372,13 @@ typedef int (Tcl_ArgvGenFuncProc)(ClientData clientData, Tcl_Interp *interp,
/*
*----------------------------------------------------------------------------
+ * Definitions needed for the Tcl_OpenTcpServerEx function. [TIP #456]
+ */
+#define TCL_TCPSERVER_REUSEADDR (1<<0)
+#define TCL_TCPSERVER_REUSEPORT (1<<1)
+
+/*
+ *----------------------------------------------------------------------------
* Single public declaration for NRE.
*/
@@ -2410,10 +2417,6 @@ const char * TclTomMathInitializeStubs(Tcl_Interp *interp,
#endif
/*
- * TODO - tommath stubs export goes here!
- */
-
-/*
* Public functions that are not accessible via the stubs table.
* Tcl_GetMemoryInfo is needed for AOLserver. [Bug 1868171]
*/
diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c
index cda1f38..64df1a2 100644
--- a/generic/tclAlloc.c
+++ b/generic/tclAlloc.c
@@ -32,7 +32,7 @@
*/
#if defined(_MSC_VER) || defined(__MSVCRT__) || defined(__BORLANDC__)
-typedef unsigned long caddr_t;
+typedef size_t caddr_t;
#endif
/*
@@ -56,7 +56,7 @@ union overhead {
unsigned char magic1; /* other magic number */
#ifndef NDEBUG
unsigned short rmagic; /* range magic number */
- unsigned long size; /* actual block size */
+ size_t size; /* actual block size */
unsigned short unused2; /* padding to 8-byte align */
#endif
} ovu;
@@ -133,7 +133,7 @@ static int allocInit = 0;
* a given block size.
*/
-static unsigned int numMallocs[NBUCKETS+1];
+static size_t numMallocs[NBUCKETS+1];
#endif
#if !defined(NDEBUG)
@@ -148,7 +148,7 @@ static unsigned int numMallocs[NBUCKETS+1];
* Prototypes for functions used only in this file.
*/
-static void MoreCore(int bucket);
+static void MoreCore(size_t bucket);
/*
*-------------------------------------------------------------------------
@@ -254,7 +254,7 @@ TclpAlloc(
unsigned int numBytes) /* Number of bytes to allocate. */
{
register union overhead *overPtr;
- register long bucket;
+ register size_t bucket;
register unsigned amount;
struct block *bigBlockPtr = NULL;
@@ -385,12 +385,12 @@ TclpAlloc(
static void
MoreCore(
- int bucket) /* What bucket to allocat to. */
+ size_t bucket) /* What bucket to allocate to. */
{
register union overhead *overPtr;
- register long size; /* size of desired block */
- long amount; /* amount to allocate */
- int numBlocks; /* how many blocks we get */
+ register size_t size; /* size of desired block */
+ size_t amount; /* amount to allocate */
+ size_t numBlocks; /* how many blocks we get */
struct block *blockPtr;
/*
@@ -398,14 +398,14 @@ MoreCore(
* VAX, I think) or for a negative arg.
*/
- size = 1 << (bucket + 3);
+ size = ((size_t)1) << (bucket + 3);
ASSERT(size > 0);
amount = MAXMALLOC;
numBlocks = amount / size;
ASSERT(numBlocks*size == amount);
- blockPtr = (struct block *) TclpSysAlloc((unsigned)
+ blockPtr = (struct block *) TclpSysAlloc(
(sizeof(struct block) + amount), 1);
/* no more room! */
if (blockPtr == NULL) {
@@ -448,7 +448,7 @@ void
TclpFree(
char *oldPtr) /* Pointer to memory to free. */
{
- register long size;
+ register size_t size;
register union overhead *overPtr;
struct block *bigBlockPtr;
@@ -518,7 +518,7 @@ TclpRealloc(
union overhead *overPtr;
struct block *bigBlockPtr;
int expensive;
- unsigned long maxSize;
+ size_t maxSize;
if (oldPtr == NULL) {
return TclpAlloc(numBytes);
@@ -645,30 +645,30 @@ void
mstats(
char *s) /* Where to write info. */
{
- register int i, j;
+ register unsigned int i, j;
register union overhead *overPtr;
- int totalFree = 0, totalUsed = 0;
+ size_t totalFree = 0, totalUsed = 0;
Tcl_MutexLock(allocMutexPtr);
fprintf(stderr, "Memory allocation statistics %s\nTclpFree:\t", s);
for (i = 0; i < NBUCKETS; i++) {
for (j=0, overPtr=nextf[i]; overPtr; overPtr=overPtr->next, j++) {
- fprintf(stderr, " %d", j);
+ fprintf(stderr, " %u", j);
}
- totalFree += j * (1 << (i + 3));
+ totalFree += ((size_t)j) * (1 << (i + 3));
}
fprintf(stderr, "\nused:\t");
for (i = 0; i < NBUCKETS; i++) {
- fprintf(stderr, " %d", numMallocs[i]);
+ fprintf(stderr, " %" TCL_LL_MODIFIER "d", (Tcl_WideInt)numMallocs[i]);
totalUsed += numMallocs[i] * (1 << (i + 3));
}
- fprintf(stderr, "\n\tTotal small in use: %d, total free: %d\n",
- totalUsed, totalFree);
- fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %d\n",
- MAXMALLOC, numMallocs[NBUCKETS]);
+ fprintf(stderr, "\n\tTotal small in use: %" TCL_LL_MODIFIER "d, total free: %" TCL_LL_MODIFIER "d\n",
+ (Tcl_WideInt)totalUsed, (Tcl_WideInt)totalFree);
+ fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %" TCL_LL_MODIFIER "d\n",
+ MAXMALLOC, (Tcl_WideInt)numMallocs[NBUCKETS]);
Tcl_MutexUnlock(allocMutexPtr);
}
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 06f277f..2212d1c 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -1543,7 +1543,7 @@ AssembleOneLine(
* Add the (label_name, address) pair to the hash table.
*/
- if (DefineLabel(assemEnvPtr, Tcl_GetString(operand1Obj)) != TCL_OK) {
+ if (DefineLabel(assemEnvPtr, TclGetString(operand1Obj)) != TCL_OK) {
goto cleanup;
}
break;
@@ -1722,7 +1722,7 @@ AssembleOneLine(
default:
Tcl_Panic("Instruction \"%s\" could not be found, can't happen\n",
- Tcl_GetString(instNameObj));
+ TclGetString(instNameObj));
}
status = TCL_OK;
@@ -1985,15 +1985,15 @@ CreateMirrorJumpTable(
DEBUG_PRINT("jump table {\n");
for (i = 0; i < objc; i+=2) {
- DEBUG_PRINT(" %s -> %s\n", Tcl_GetString(objv[i]),
- Tcl_GetString(objv[i+1]));
- hashEntry = Tcl_CreateHashEntry(jtHashPtr, Tcl_GetString(objv[i]),
+ DEBUG_PRINT(" %s -> %s\n", TclGetString(objv[i]),
+ TclGetString(objv[i+1]));
+ hashEntry = Tcl_CreateHashEntry(jtHashPtr, TclGetString(objv[i]),
&isNew);
if (!isNew) {
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"duplicate entry in jump table for \"%s\"",
- Tcl_GetString(objv[i])));
+ TclGetString(objv[i])));
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPJUMPTABLEENTRY");
DeleteMirrorJumpTable(jtPtr);
return TCL_ERROR;
@@ -2801,7 +2801,7 @@ CalculateJumpRelocations(
if (bbPtr->jumpTarget != NULL) {
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(bbPtr->jumpTarget));
+ TclGetString(bbPtr->jumpTarget));
if (entry == NULL) {
ReportUndefinedLabel(assemEnvPtr, bbPtr,
bbPtr->jumpTarget);
@@ -2882,10 +2882,10 @@ CheckJumpTableLabels(
symEntryPtr = Tcl_NextHashEntry(&search)) {
symbolObj = Tcl_GetHashValue(symEntryPtr);
valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(symbolObj));
+ TclGetString(symbolObj));
DEBUG_PRINT(" %s -> %s (%d)\n",
(char*) Tcl_GetHashKey(symHash, symEntryPtr),
- Tcl_GetString(symbolObj), (valEntryPtr != NULL));
+ TclGetString(symbolObj), (valEntryPtr != NULL));
if (valEntryPtr == NULL) {
ReportUndefinedLabel(assemEnvPtr, bbPtr, symbolObj);
return TCL_ERROR;
@@ -2923,9 +2923,9 @@ ReportUndefinedLabel(
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "undefined label \"%s\"", Tcl_GetString(jumpTarget)));
+ "undefined label \"%s\"", TclGetString(jumpTarget)));
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOLABEL",
- Tcl_GetString(jumpTarget), NULL);
+ TclGetString(jumpTarget), NULL);
Tcl_SetErrorLine(interp, bbPtr->jumpLine);
}
}
@@ -3008,7 +3008,7 @@ FillInJumpOffsets(
bbPtr = bbPtr->successor1) {
if (bbPtr->jumpTarget != NULL) {
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(bbPtr->jumpTarget));
+ TclGetString(bbPtr->jumpTarget));
jumpTarget = Tcl_GetHashValue(entry);
fromOffset = bbPtr->jumpOffset;
targetOffset = jumpTarget->startOffset;
@@ -3080,17 +3080,17 @@ ResolveJumpTableTargets(
symEntryPtr != NULL;
symEntryPtr = Tcl_NextHashEntry(&search)) {
symbolObj = Tcl_GetHashValue(symEntryPtr);
- DEBUG_PRINT(" symbol %s\n", Tcl_GetString(symbolObj));
+ DEBUG_PRINT(" symbol %s\n", TclGetString(symbolObj));
valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(symbolObj));
+ TclGetString(symbolObj));
jumpTargetBBPtr = Tcl_GetHashValue(valEntryPtr);
realJumpEntryPtr = Tcl_CreateHashEntry(realJumpHashPtr,
Tcl_GetHashKey(symHash, symEntryPtr), &junk);
DEBUG_PRINT(" %s -> %s -> bb %p (pc %d) hash entry %p\n",
(char*) Tcl_GetHashKey(symHash, symEntryPtr),
- Tcl_GetString(symbolObj), jumpTargetBBPtr,
+ TclGetString(symbolObj), jumpTargetBBPtr,
jumpTargetBBPtr->startOffset, realJumpEntryPtr);
Tcl_SetHashValue(realJumpEntryPtr,
@@ -3462,7 +3462,7 @@ StackCheckBasicBlock(
if (result == TCL_OK && blockPtr->jumpTarget != NULL) {
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(blockPtr->jumpTarget));
+ TclGetString(blockPtr->jumpTarget));
jumpTarget = Tcl_GetHashValue(entry);
result = StackCheckBasicBlock(assemEnvPtr, jumpTarget, blockPtr,
stackDepth);
@@ -3479,7 +3479,7 @@ StackCheckBasicBlock(
jtEntry = Tcl_NextHashEntry(&jtSearch)) {
targetLabel = Tcl_GetHashValue(jtEntry);
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(targetLabel));
+ TclGetString(targetLabel));
jumpTarget = Tcl_GetHashValue(entry);
result = StackCheckBasicBlock(assemEnvPtr, jumpTarget,
blockPtr, stackDepth);
@@ -3784,7 +3784,7 @@ ProcessCatchesInBasicBlock(
}
if (result == TCL_OK && bbPtr->jumpTarget != NULL) {
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(bbPtr->jumpTarget));
+ TclGetString(bbPtr->jumpTarget));
jumpTarget = Tcl_GetHashValue(entry);
result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget,
jumpEnclosing, jumpState, catchDepth);
@@ -3800,7 +3800,7 @@ ProcessCatchesInBasicBlock(
jtEntry = Tcl_NextHashEntry(&jtSearch)) {
targetLabel = Tcl_GetHashValue(jtEntry);
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(targetLabel));
+ TclGetString(targetLabel));
jumpTarget = Tcl_GetHashValue(entry);
result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget,
jumpEnclosing, jumpState, catchDepth);
@@ -4104,7 +4104,7 @@ StackFreshCatches(
range->codeOffset = bbPtr->startOffset;
entryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(catch->jumpTarget));
+ TclGetString(catch->jumpTarget));
if (entryPtr == NULL) {
Tcl_Panic("undefined label in tclAssembly.c:"
"BuildExceptionRanges, can't happen");
diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index 4d063b2..a3e5071 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.c
@@ -172,7 +172,7 @@ static const EnsembleImplMap decodeMap[] = {
* where the codepoint of each character is the value of corresponding byte.
* This approach creates a one-to-one map between all bytearray values
* and a subset of Tcl string values.
- *
+ *
* When converting a Tcl string value to the bytearray internal rep, the
* question arises what to do with strings outside that subset? That is,
* those Tcl strings containing at least one codepoint greater than 255?
@@ -180,7 +180,7 @@ static const EnsembleImplMap decodeMap[] = {
* does not represent any valid bytearray value. Full Stop. The
* setFromAnyProc signature has a completion code return value for just
* this reason, to reject invalid inputs.
- *
+ *
* Unfortunately this was not the path taken by the authors of the
* original tclByteArrayType. They chose to accept all Tcl string values
* as acceptable string encodings of the bytearray values that result
@@ -204,7 +204,7 @@ static const EnsembleImplMap decodeMap[] = {
* unsigned char *Tcl_GetByteArrayFromObj(objPtr, lenPtr)
*
* has a guarantee to always return a non-NULL value, but that value
- * points to a byte sequence that cannot be used by the caller to
+ * points to a byte sequence that cannot be used by the caller to
* process the Tcl value absent some sideband testing that objPtr
* is "pure". Tcl offers no public interface to perform this test,
* so callers either break encapsulation or are unavoidably buggy. Tcl
@@ -218,7 +218,7 @@ static const EnsembleImplMap decodeMap[] = {
* Bytearrays should simply be usable as bytearrays without a kabuki
* dance of testing.
*
- * The Tcl_ObjType "properByteArrayType" is (nearly) a correct
+ * The Tcl_ObjType "properByteArrayType" is (nearly) a correct
* implementation of bytearrays. Any Tcl value with the type
* properByteArrayType can have its bytearray value fetched and
* used with confidence that acting on that value is equivalent to
@@ -531,7 +531,8 @@ SetByteArrayFromAny(
Tcl_Interp *interp, /* Not used. */
Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */
{
- int length, improper = 0;
+ size_t length;
+ int improper = 0;
const char *src, *srcEnd;
unsigned char *dst;
ByteArray *byteArrayPtr;
@@ -544,7 +545,8 @@ SetByteArrayFromAny(
return TCL_OK;
}
- src = TclGetStringFromObj(objPtr, &length);
+ src = TclGetString(objPtr);
+ length = objPtr->length;
srcEnd = src + length;
byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length));
diff --git a/generic/tclClock.c b/generic/tclClock.c
index c3b29e9..27009fd 100644
--- a/generic/tclClock.c
+++ b/generic/tclClock.c
@@ -92,7 +92,7 @@ static const char *const literals[] = {
*/
typedef struct ClockClientData {
- int refCount; /* Number of live references. */
+ size_t refCount; /* Number of live references. */
Tcl_Obj **literals; /* Pool of object literals. */
} ClockClientData;
@@ -2060,8 +2060,7 @@ ClockDeleteCmdProc(
ClockClientData *data = clientData;
int i;
- data->refCount--;
- if (data->refCount == 0) {
+ if (data->refCount-- <= 1) {
for (i = 0; i < LIT__END; ++i) {
Tcl_DecrRefCount(data->literals[i]);
}
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index c06b197..fbc9d8f 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -4179,7 +4179,7 @@ TclNRTryObjCmd(
}
info[0] = objv[i]; /* type */
- TclNewIntObj(info[1], code); /* returnCode */
+ TclNewLongObj(info[1], code); /* returnCode */
if (info[2] == NULL) { /* errorCodePrefix */
TclNewObj(info[2]);
}
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index c0724ee..7e6a5af 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -765,7 +765,8 @@ TclSetByteCodeFromAny(
Interp *iPtr = (Interp *) interp;
CompileEnv compEnv; /* Compilation environment structure allocated
* in frame. */
- int length, result = TCL_OK;
+ size_t length;
+ int result = TCL_OK;
const char *stringPtr;
Proc *procPtr = iPtr->compiledProcPtr;
ContLineLoc *clLocPtr;
@@ -780,7 +781,8 @@ TclSetByteCodeFromAny(
}
#endif
- stringPtr = TclGetStringFromObj(objPtr, &length);
+ stringPtr = TclGetString(objPtr);
+ length = objPtr->length;
/*
* TIP #280: Pick up the CmdFrame in which the BC compiler was invoked and
@@ -2976,7 +2978,8 @@ TclFindCompiledLocal(
varNamePtr = &cachePtr->varName0;
for (i=0; i < cachePtr->numVars; varNamePtr++, i++) {
if (*varNamePtr) {
- localName = TclGetStringFromObj(*varNamePtr, &len);
+ localName = TclGetString(*varNamePtr);
+ len = (*varNamePtr)->length;
if ((len == nameBytes) && !strncmp(name, localName, len)) {
return i;
}
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index b022d3c..49ac440 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -1816,6 +1816,12 @@ EXTERN int Tcl_FSUnloadFile(Tcl_Interp *interp,
EXTERN void Tcl_ZlibStreamSetCompressionDictionary(
Tcl_ZlibStream zhandle,
Tcl_Obj *compressionDictionaryObj);
+/* 631 */
+EXTERN Tcl_Channel Tcl_OpenTcpServerEx(Tcl_Interp *interp,
+ const char *service, const char *host,
+ unsigned int flags,
+ Tcl_TcpAcceptProc *acceptProc,
+ ClientData callbackData);
typedef struct {
const struct TclPlatStubs *tclPlatStubs;
@@ -2482,6 +2488,7 @@ typedef struct TclStubs {
void * (*tcl_FindSymbol) (Tcl_Interp *interp, Tcl_LoadHandle handle, const char *symbol); /* 628 */
int (*tcl_FSUnloadFile) (Tcl_Interp *interp, Tcl_LoadHandle handlePtr); /* 629 */
void (*tcl_ZlibStreamSetCompressionDictionary) (Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); /* 630 */
+ Tcl_Channel (*tcl_OpenTcpServerEx) (Tcl_Interp *interp, const char *service, const char *host, unsigned int flags, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData); /* 631 */
} TclStubs;
extern const TclStubs *tclStubsPtr;
@@ -3774,6 +3781,8 @@ extern const TclStubs *tclStubsPtr;
(tclStubsPtr->tcl_FSUnloadFile) /* 629 */
#define Tcl_ZlibStreamSetCompressionDictionary \
(tclStubsPtr->tcl_ZlibStreamSetCompressionDictionary) /* 630 */
+#define Tcl_OpenTcpServerEx \
+ (tclStubsPtr->tcl_OpenTcpServerEx) /* 631 */
#endif /* defined(USE_TCL_STUBS) */
diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index 8a4dc3b..91c2278 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -46,7 +46,7 @@ typedef struct Encoding {
* nullSize is 2, this is a function that
* returns the number of bytes in a 0x0000
* terminated string. */
- int refCount; /* Number of uses of this structure. */
+ size_t refCount; /* Number of uses of this structure. */
Tcl_HashEntry *hPtr; /* Hash table entry that owns this encoding. */
} Encoding;
@@ -844,11 +844,7 @@ FreeEncoding(
if (encodingPtr == NULL) {
return;
}
- if (encodingPtr->refCount<=0) {
- Tcl_Panic("FreeEncoding: refcount problem !!!");
- }
- encodingPtr->refCount--;
- if (encodingPtr->refCount == 0) {
+ if (encodingPtr->refCount-- <= 1) {
if (encodingPtr->freeProc != NULL) {
encodingPtr->freeProc(encodingPtr->clientData);
}
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index c6407a4..6ada155 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -3306,7 +3306,7 @@ CompileToInvokedCommand(
Tcl_Token *tokPtr;
Tcl_Obj *objPtr, **words;
char *bytes;
- int length, i, numWords, cmdLit, extraLiteralFlags = LITERAL_CMD_NAME;
+ int i, numWords, cmdLit, extraLiteralFlags = LITERAL_CMD_NAME;
DefineLineInformation;
/*
@@ -3319,8 +3319,8 @@ CompileToInvokedCommand(
for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords;
i++, tokPtr = TokenAfter(tokPtr)) {
if (i > 0 && i < numWords+1) {
- bytes = TclGetStringFromObj(words[i-1], &length);
- PushLiteral(envPtr, bytes, length);
+ bytes = TclGetString(words[i-1]);
+ PushLiteral(envPtr, bytes, words[i-1]->length);
continue;
}
@@ -3348,11 +3348,11 @@ CompileToInvokedCommand(
objPtr = Tcl_NewObj();
Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
- bytes = Tcl_GetStringFromObj(objPtr, &length);
+ bytes = TclGetString(objPtr);
if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) {
extraLiteralFlags |= LITERAL_UNSHARED;
}
- cmdLit = TclRegisterLiteral(envPtr, bytes, length, extraLiteralFlags);
+ cmdLit = TclRegisterLiteral(envPtr, bytes, objPtr->length, extraLiteralFlags);
TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLit), cmdPtr);
TclEmitPush(cmdLit, envPtr);
TclDecrRefCount(objPtr);
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 074b1d5..9103da0 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -325,7 +325,7 @@ VarHashCreateVar(
NEXT_INST_F(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \
default: \
if ((condition) < 0) { \
- TclNewIntObj(objResultPtr, -1); \
+ TclNewLongObj(objResultPtr, -1); \
} else { \
objResultPtr = TCONST((condition) > 0); \
} \
@@ -346,7 +346,7 @@ VarHashCreateVar(
NEXT_INST_V(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \
default: \
if ((condition) < 0) { \
- TclNewIntObj(objResultPtr, -1); \
+ TclNewLongObj(objResultPtr, -1); \
} else { \
objResultPtr = TCONST((condition) > 0); \
} \
@@ -357,7 +357,7 @@ VarHashCreateVar(
#define JUMP_PEEPHOLE_F(condition, pcAdjustment, cleanup) \
do{ \
if ((condition) < 0) { \
- TclNewIntObj(objResultPtr, -1); \
+ TclNewLongObj(objResultPtr, -1); \
} else { \
objResultPtr = TCONST((condition) > 0); \
} \
@@ -366,7 +366,7 @@ VarHashCreateVar(
#define JUMP_PEEPHOLE_V(condition, pcAdjustment, cleanup) \
do{ \
if ((condition) < 0) { \
- TclNewIntObj(objResultPtr, -1); \
+ TclNewLongObj(objResultPtr, -1); \
} else { \
objResultPtr = TCONST((condition) > 0); \
} \
@@ -1541,11 +1541,10 @@ CompileExprObj(
* TIP #280: No invoker (yet) - Expression compilation.
*/
- int length;
- const char *string = TclGetStringFromObj(objPtr, &length);
+ const char *string = TclGetString(objPtr);
- TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0);
- TclCompileExpr(interp, string, length, &compEnv, 0);
+ TclInitCompileEnv(interp, &compEnv, string, objPtr->length, NULL, 0);
+ TclCompileExpr(interp, string, objPtr->length, &compEnv, 0);
/*
* Successful compilation. If the expression yielded no instructions,
@@ -4529,7 +4528,7 @@ TEBCresume(
NEXT_INST_F(1, 0, 1);
}
case INST_INFO_LEVEL_NUM:
- TclNewIntObj(objResultPtr, iPtr->varFramePtr->level);
+ TclNewLongObj(objResultPtr, iPtr->varFramePtr->level);
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(1, 0, 1);
case INST_INFO_LEVEL_ARGS: {
@@ -4898,7 +4897,7 @@ TEBCresume(
TRACE_ERROR(interp);
goto gotError;
}
- TclNewIntObj(objResultPtr, length);
+ TclNewLongObj(objResultPtr, length);
TRACE_APPEND(("%d\n", length));
NEXT_INST_F(1, 1, 1);
@@ -5369,7 +5368,7 @@ TEBCresume(
case INST_STR_LEN:
valuePtr = OBJ_AT_TOS;
length = Tcl_GetCharLength(valuePtr);
- TclNewIntObj(objResultPtr, length);
+ TclNewLongObj(objResultPtr, length);
TRACE(("\"%.20s\" => %d\n", O2S(valuePtr), length));
NEXT_INST_F(1, 1, 1);
@@ -5724,7 +5723,7 @@ TEBCresume(
TRACE(("%.20s %.20s => %d\n",
O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match));
- TclNewIntObj(objResultPtr, match);
+ TclNewLongObj(objResultPtr, match);
NEXT_INST_F(1, 2, 1);
case INST_STR_FIND_LAST:
@@ -5732,7 +5731,7 @@ TEBCresume(
TRACE(("%.20s %.20s => %d\n",
O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match));
- TclNewIntObj(objResultPtr, match);
+ TclNewLongObj(objResultPtr, match);
NEXT_INST_F(1, 2, 1);
case INST_STR_CLASS:
@@ -5936,7 +5935,7 @@ TEBCresume(
type1 = TCL_NUMBER_WIDE;
}
}
- TclNewIntObj(objResultPtr, type1);
+ TclNewLongObj(objResultPtr, type1);
TRACE(("\"%.20s\" => %d\n", O2S(OBJ_AT_TOS), type1));
NEXT_INST_F(1, 1, 1);
@@ -6143,7 +6142,7 @@ TEBCresume(
if (l1 > 0L) {
objResultPtr = TCONST(0);
} else {
- TclNewIntObj(objResultPtr, -1);
+ TclNewLongObj(objResultPtr, -1);
}
TRACE(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
@@ -7043,7 +7042,7 @@ TEBCresume(
NEXT_INST_F(1, 0, -1);
case INST_PUSH_RETURN_CODE:
- TclNewIntObj(objResultPtr, result);
+ TclNewLongObj(objResultPtr, result);
TRACE(("=> %u\n", result));
NEXT_INST_F(1, 0, 1);
diff --git a/generic/tclIO.c b/generic/tclIO.c
index ffd2430..5c39e19 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -323,7 +323,7 @@ typedef struct ResolvedChanName {
Tcl_Interp *interp; /* The interp in which the lookup was done. */
int epoch; /* The epoch of the channel when the lookup
* was done. Use to verify validity. */
- int refCount; /* Share this struct among many Tcl_Obj. */
+ size_t refCount; /* Share this struct among many Tcl_Obj. */
} ResolvedChanName;
static void DupChannelIntRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
@@ -11194,7 +11194,7 @@ FreeChannelIntRep(
ResolvedChanName *resPtr = objPtr->internalRep.twoPtrValue.ptr1;
objPtr->typePtr = NULL;
- if (--resPtr->refCount) {
+ if (resPtr->refCount-- > 1) {
return;
}
Tcl_Release(resPtr->statePtr);
diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c
index de65da5..1bd3fe7 100644
--- a/generic/tclIOCmd.c
+++ b/generic/tclIOCmd.c
@@ -1485,13 +1485,17 @@ Tcl_SocketObjCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *const socketOptions[] = {
- "-async", "-myaddr", "-myport", "-server", NULL
+ "-async", "-myaddr", "-myport", "-reuseaddr", "-reuseport", "-server",
+ NULL
};
enum socketOptions {
- SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER
+ SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_REUSEADDR, SKT_REUSEPORT,
+ SKT_SERVER
};
- int optionIndex, a, server = 0, port, myport = 0, async = 0;
- const char *host, *myaddr = NULL;
+ int optionIndex, a, server = 0, myport = 0, async = 0, reusep = -1,
+ reusea = -1;
+ unsigned int flags = 0;
+ const char *host, *port, *myaddr = NULL;
Tcl_Obj *script = NULL;
Tcl_Channel chan;
@@ -1557,6 +1561,28 @@ Tcl_SocketObjCmd(
}
script = objv[a];
break;
+ case SKT_REUSEADDR:
+ a++;
+ if (a >= objc) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "no argument given for -reuseaddr option", -1));
+ return TCL_ERROR;
+ }
+ if (Tcl_GetBooleanFromObj(interp, objv[a], &reusea) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ break;
+ case SKT_REUSEPORT:
+ a++;
+ if (a >= objc) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "no argument given for -reuseport option", -1));
+ return TCL_ERROR;
+ }
+ if (Tcl_GetBooleanFromObj(interp, objv[a], &reusep) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ break;
default:
Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions");
}
@@ -1580,19 +1606,37 @@ Tcl_SocketObjCmd(
"?-myaddr addr? ?-myport myport? ?-async? host port");
iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS;
Tcl_WrongNumArgs(interp, 1, objv,
- "-server command ?-myaddr addr? port");
+ "-server command ?-reuseaddr boolean? ?-reuseport boolean? "
+ "?-myaddr addr? port");
return TCL_ERROR;
}
- if (a == objc-1) {
- if (TclSockGetPort(interp, TclGetString(objv[a]), "tcp",
- &port) != TCL_OK) {
- return TCL_ERROR;
- }
- } else {
+ if (!server && (reusea != -1 || reusep != -1)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "options -reuseaddr and -reuseport are only valid for servers",
+ -1));
+ return TCL_ERROR;
+ }
+
+ // Set the options to their default value if the user didn't override their
+ // value.
+ if (reusep == -1) reusep = 0;
+ if (reusea == -1) reusea = 1;
+
+ // Build the bitset with the flags values.
+ if (reusea)
+ flags |= TCL_TCPSERVER_REUSEADDR;
+ if (reusep)
+ flags |= TCL_TCPSERVER_REUSEPORT;
+
+ // All the arguments should have been parsed by now, 'a' points to the last
+ // one, the port number.
+ if (a != objc-1) {
goto wrongNumArgs;
}
+ port = TclGetString(objv[a]);
+
if (server) {
AcceptCallback *acceptCallbackPtr =
ckalloc(sizeof(AcceptCallback));
@@ -1600,8 +1644,9 @@ Tcl_SocketObjCmd(
Tcl_IncrRefCount(script);
acceptCallbackPtr->script = script;
acceptCallbackPtr->interp = interp;
- chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc,
- acceptCallbackPtr);
+
+ chan = Tcl_OpenTcpServerEx(interp, port, host, flags, AcceptCallbackProc,
+ acceptCallbackPtr);
if (chan == NULL) {
Tcl_DecrRefCount(script);
ckfree(acceptCallbackPtr);
@@ -1625,7 +1670,13 @@ Tcl_SocketObjCmd(
Tcl_CreateCloseHandler(chan, TcpServerCloseProc, acceptCallbackPtr);
} else {
- chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async);
+ int portNum;
+
+ if (TclSockGetPort(interp, port, "tcp", &portNum) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ chan = Tcl_OpenTcpClient(interp, portNum, host, myaddr, myport, async);
if (chan == NULL) {
return TCL_ERROR;
}
diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c
index 7ed751c..8ad268a 100644
--- a/generic/tclIOSock.c
+++ b/generic/tclIOSock.c
@@ -285,6 +285,34 @@ TclCreateSocketAddress(
}
/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_OpenTcpServer --
+ *
+ * Opens a TCP server socket and creates a channel around it.
+ *
+ * Results:
+ * The channel or NULL if failed. If an error occurred, an error message
+ * is left in the interp's result if interp is not NULL.
+ *
+ * Side effects:
+ * Opens a server socket and creates a new channel.
+ *
+ *----------------------------------------------------------------------
+ */
+Tcl_Channel Tcl_OpenTcpServer(Tcl_Interp *interp, int port,
+ const char *host, Tcl_TcpAcceptProc *acceptProc,
+ ClientData callbackData)
+{
+ char portbuf[TCL_INTEGER_SPACE];
+
+ TclFormatInt(portbuf, port);
+
+ return Tcl_OpenTcpServerEx(interp, portbuf, host, TCL_TCPSERVER_REUSEADDR,
+ acceptProc, callbackData);
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 37908bc..dd0c11a 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -4567,13 +4567,12 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
* types, avoiding the corresponding function calls in time critical parts of
* the core. The ANSI C "prototypes" for these macros are:
*
- * MODULE_SCOPE void TclNewIntObj(Tcl_Obj *objPtr, int i);
* MODULE_SCOPE void TclNewLongObj(Tcl_Obj *objPtr, long l);
* MODULE_SCOPE void TclNewBooleanObj(Tcl_Obj *objPtr, int b);
* MODULE_SCOPE void TclNewWideObj(Tcl_Obj *objPtr, Tcl_WideInt w);
* MODULE_SCOPE void TclNewDoubleObj(Tcl_Obj *objPtr, double d);
- * MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, char *s, int len);
- * MODULE_SCOPE void TclNewLiteralStringObj(Tcl_Obj*objPtr, char*sLiteral);
+ * MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, const char *s, int len);
+ * MODULE_SCOPE void TclNewLiteralStringObj(Tcl_Obj*objPtr, const char *sLiteral);
*
*----------------------------------------------------------------
*/
@@ -4590,9 +4589,6 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
TCL_DTRACE_OBJ_CREATE(objPtr); \
} while (0)
-#define TclNewIntObj(objPtr, l) \
- TclNewLongObj(objPtr, l)
-
/*
* NOTE: There is to be no such thing as a "pure" boolean.
* See comment above TclSetBooleanObj macro above.
@@ -4622,9 +4618,6 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
} while (0)
#else /* TCL_MEM_DEBUG */
-#define TclNewIntObj(objPtr, i) \
- (objPtr) = Tcl_NewIntObj(i)
-
#define TclNewLongObj(objPtr, l) \
(objPtr) = Tcl_NewLongObj(l)
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 7874de9..af9f1bf 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -421,6 +421,7 @@ Tcl_Init(
" {file join $grandParentDir lib tcl[info tclversion]} \\\n"
" {file join $parentDir library} \\\n"
" {file join $grandParentDir library} \\\n"
+" {file join $grandParentDir tcl[info tclversion] library} \\\n"
" {file join $grandParentDir tcl[info patchlevel] library} \\\n"
" {\n"
"file join [file dirname $grandParentDir] tcl[info patchlevel] library}\n"
diff --git a/generic/tclLink.c b/generic/tclLink.c
index e6dc657..d6d709f 100644
--- a/generic/tclLink.c
+++ b/generic/tclLink.c
@@ -67,6 +67,10 @@ typedef struct Link {
static char * LinkTraceProc(ClientData clientData,Tcl_Interp *interp,
const char *name1, const char *name2, int flags);
static Tcl_Obj * ObjValue(Link *linkPtr);
+static int GetInvalidIntFromObj(Tcl_Obj *objPtr,
+ int *intPtr);
+static int GetInvalidDoubleFromObj(Tcl_Obj *objPtr,
+ double *doublePtr);
/*
* Convenience macro for accessing the value of the C variable pointed to by a
@@ -380,9 +384,12 @@ LinkTraceProc(
case TCL_LINK_INT:
if (Tcl_GetIntFromObj(NULL, valueObj, &linkPtr->lastValue.i)
!= TCL_OK) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ if (GetInvalidIntFromObj(valueObj, &linkPtr->lastValue.i)
+ != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
- return (char *) "variable must have integer value";
+ return (char *) "variable must have integer value";
+ }
}
LinkedVar(int) = linkPtr->lastValue.i;
break;
@@ -390,9 +397,13 @@ LinkTraceProc(
case TCL_LINK_WIDE_INT:
if (Tcl_GetWideIntFromObj(NULL, valueObj, &linkPtr->lastValue.w)
!= TCL_OK) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ if (GetInvalidIntFromObj(valueObj, &valueInt)
+ != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
- return (char *) "variable must have integer value";
+ return (char *) "variable must have integer value";
+ }
+ linkPtr->lastValue.w = (Tcl_WideInt) valueInt;
}
LinkedVar(Tcl_WideInt) = linkPtr->lastValue.w;
break;
@@ -403,9 +414,12 @@ LinkTraceProc(
#ifdef ACCEPT_NAN
if (valueObj->typePtr != &tclDoubleType) {
#endif
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
- ObjValue(linkPtr), TCL_GLOBAL_ONLY);
- return (char *) "variable must have real value";
+ if (GetInvalidDoubleFromObj(valueObj, &linkPtr->lastValue.d)
+ != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *) "variable must have real value";
+ }
#ifdef ACCEPT_NAN
}
linkPtr->lastValue.d = valueObj->internalRep.doubleValue;
@@ -425,79 +439,106 @@ LinkTraceProc(
break;
case TCL_LINK_CHAR:
- if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK
+ if (Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
|| valueInt < SCHAR_MIN || valueInt > SCHAR_MAX) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have char value";
+ if (GetInvalidIntFromObj(valueObj, &valueInt)
+ != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *) "variable must have char value";
+ }
}
linkPtr->lastValue.c = (char)valueInt;
LinkedVar(char) = linkPtr->lastValue.c;
break;
case TCL_LINK_UCHAR:
- if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK
+ if (Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
|| valueInt < 0 || valueInt > UCHAR_MAX) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have unsigned char value";
+ if (GetInvalidIntFromObj(valueObj, &valueInt)
+ != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *) "variable must have unsigned char value";
+ }
}
linkPtr->lastValue.uc = (unsigned char) valueInt;
LinkedVar(unsigned char) = linkPtr->lastValue.uc;
break;
case TCL_LINK_SHORT:
- if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK
+ if (Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
|| valueInt < SHRT_MIN || valueInt > SHRT_MAX) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have short value";
+ if (GetInvalidIntFromObj(valueObj, &valueInt)
+ != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *) "variable must have short value";
+ }
}
linkPtr->lastValue.s = (short)valueInt;
LinkedVar(short) = linkPtr->lastValue.s;
break;
case TCL_LINK_USHORT:
- if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK
+ if (Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
|| valueInt < 0 || valueInt > USHRT_MAX) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have unsigned short value";
+ if (GetInvalidIntFromObj(valueObj, &valueInt)
+ != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *) "variable must have unsigned short value";
+ }
}
linkPtr->lastValue.us = (unsigned short)valueInt;
LinkedVar(unsigned short) = linkPtr->lastValue.us;
break;
case TCL_LINK_UINT:
- if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK
+ if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
|| valueWide < 0 || valueWide > UINT_MAX) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have unsigned int value";
+ if (GetInvalidIntFromObj(valueObj, &valueInt)
+ != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *) "variable must have unsigned int value";
+ }
+ linkPtr->lastValue.ui = (unsigned int)valueInt;
+ } else {
+ linkPtr->lastValue.ui = (unsigned int)valueWide;
}
- linkPtr->lastValue.ui = (unsigned int)valueWide;
LinkedVar(unsigned int) = linkPtr->lastValue.ui;
break;
case TCL_LINK_LONG:
- if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK
+ if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
|| valueWide < LONG_MIN || valueWide > LONG_MAX) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have long value";
+ if (GetInvalidIntFromObj(valueObj, &valueInt)
+ != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *) "variable must have long value";
+ }
+ linkPtr->lastValue.l = (long)valueInt;
+ } else {
+ linkPtr->lastValue.l = (long)valueWide;
}
- linkPtr->lastValue.l = (long)valueWide;
LinkedVar(long) = linkPtr->lastValue.l;
break;
case TCL_LINK_ULONG:
- if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK
+ if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
|| valueWide < 0 || (Tcl_WideUInt) valueWide > ULONG_MAX) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have unsigned long value";
+ if (GetInvalidIntFromObj(valueObj, &valueInt)
+ != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *) "variable must have unsigned long value";
+ }
+ linkPtr->lastValue.ul = (unsigned long)valueInt;
+ } else {
+ linkPtr->lastValue.ul = (unsigned long)valueWide;
}
- linkPtr->lastValue.ul = (unsigned long)valueWide;
LinkedVar(unsigned long) = linkPtr->lastValue.ul;
break;
@@ -505,21 +546,29 @@ LinkTraceProc(
/*
* FIXME: represent as a bignum.
*/
- if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have unsigned wide int value";
+ if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK) {
+ if (GetInvalidIntFromObj(valueObj, &valueInt)
+ != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *) "variable must have unsigned wide int value";
+ }
+ linkPtr->lastValue.uw = (Tcl_WideUInt)valueInt;
+ } else {
+ linkPtr->lastValue.uw = (Tcl_WideUInt)valueWide;
}
- linkPtr->lastValue.uw = (Tcl_WideUInt)valueWide;
LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw;
break;
case TCL_LINK_FLOAT:
- if (Tcl_GetDoubleFromObj(interp, valueObj, &valueDouble) != TCL_OK
+ if (Tcl_GetDoubleFromObj(NULL, valueObj, &valueDouble) != TCL_OK
|| valueDouble < -FLT_MAX || valueDouble > FLT_MAX) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have float value";
+ if (GetInvalidDoubleFromObj(valueObj, &valueDouble)
+ != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *) "variable must have float value";
+ }
}
linkPtr->lastValue.f = (float)valueDouble;
LinkedVar(float) = linkPtr->lastValue.f;
@@ -577,7 +626,7 @@ ObjValue(
return Tcl_NewDoubleObj(linkPtr->lastValue.d);
case TCL_LINK_BOOLEAN:
linkPtr->lastValue.i = LinkedVar(int);
- return Tcl_NewBooleanObj(linkPtr->lastValue.i != 0);
+ return Tcl_NewBooleanObj(linkPtr->lastValue.i);
case TCL_LINK_CHAR:
linkPtr->lastValue.c = LinkedVar(char);
return Tcl_NewIntObj(linkPtr->lastValue.c);
@@ -626,6 +675,96 @@ ObjValue(
return resultObj;
}
}
+
+static int SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
+
+static Tcl_ObjType invalidRealType = {
+ "invalidReal", /* name */
+ NULL, /* freeIntRepProc */
+ NULL, /* dupIntRepProc */
+ NULL, /* updateStringProc */
+ SetInvalidRealFromAny /* setFromAnyProc */
+};
+
+static int
+SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr) {
+ int length;
+ const char *str;
+ const char *endPtr;
+
+ str = TclGetStringFromObj(objPtr, &length);
+ if ((length == 1) && (str[0] == '.')){
+ objPtr->typePtr = &invalidRealType;
+ objPtr->internalRep.doubleValue = 0.0;
+ return TCL_OK;
+ }
+ if (TclParseNumber(NULL, objPtr, NULL, str, length, &endPtr,
+ TCL_PARSE_DECIMAL_ONLY) == TCL_OK) {
+ /* If number is followed by [eE][+-]?, then it is an invalid
+ * double, but it could be the start of a valid double. */
+ if (*endPtr == 'e' || *endPtr == 'E') {
+ ++endPtr;
+ if (*endPtr == '+' || *endPtr == '-') ++endPtr;
+ if (*endPtr == 0) {
+ double doubleValue = 0.0;
+ Tcl_GetDoubleFromObj(NULL, objPtr, &doubleValue);
+ if (objPtr->typePtr->freeIntRepProc) objPtr->typePtr->freeIntRepProc(objPtr);
+ objPtr->typePtr = &invalidRealType;
+ objPtr->internalRep.doubleValue = doubleValue;
+ return TCL_OK;
+ }
+ }
+ }
+ return TCL_ERROR;
+}
+
+
+/*
+ * This function checks for integer representations, which are valid
+ * when linking with C variables, but which are invalid in other
+ * contexts in Tcl. Handled are "+", "-", "0x", "0b" and "0o" (upper-
+ * and lowercase). See bug [39f6304c2e].
+ */
+int
+GetInvalidIntFromObj(Tcl_Obj *objPtr,
+ int *intPtr)
+{
+ int length;
+ const char *str = TclGetStringFromObj(objPtr, &length);
+
+ if ((length == 1) && strchr("+-", str[0])) {
+ *intPtr = (str[0] == '+');
+ return TCL_OK;
+ } else if ((length == 2) && (str[0] == '0') && strchr("xXbBoO", str[1])) {
+ *intPtr = 0;
+ return TCL_OK;
+ }
+ return TCL_ERROR;
+}
+
+/*
+ * This function checks for double representations, which are valid
+ * when linking with C variables, but which are invalid in other
+ * contexts in Tcl. Handled are ".", "+", "-", "0x", "0b" and "0o"
+ * (upper- and lowercase) and sequences like "1e-". See bug [39f6304c2e].
+ */
+int
+GetInvalidDoubleFromObj(Tcl_Obj *objPtr,
+ double *doublePtr)
+{
+ int intValue, result;
+
+ if ((objPtr->typePtr == &invalidRealType) ||
+ (SetInvalidRealFromAny(NULL, objPtr) == TCL_OK)) {
+ *doublePtr = objPtr->internalRep.doubleValue;
+ return TCL_OK;
+ }
+ result = GetInvalidIntFromObj(objPtr, &intValue);
+ if (result == TCL_OK) {
+ *doublePtr = (double) intValue;
+ }
+ return result;
+}
/*
* Local Variables:
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 416e5ed..df900ce 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -1810,7 +1810,7 @@ Tcl_DbNewBooleanObj(
TclDbNewObj(objPtr, file, line);
objPtr->bytes = NULL;
- objPtr->internalRep.longValue = (boolValue? 1 : 0);
+ objPtr->internalRep.longValue = (boolValue != 0);
objPtr->typePtr = &tclIntType;
return objPtr;
}
@@ -2425,7 +2425,7 @@ Tcl_NewIntObj(
{
register Tcl_Obj *objPtr;
- TclNewIntObj(objPtr, intValue);
+ TclNewLongObj(objPtr, intValue);
return objPtr;
}
#endif /* if TCL_MEM_DEBUG */
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 9471381..db233b3 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -1865,6 +1865,14 @@ Tcl_AppendFormatToObj(
useWide = 1;
#endif
}
+ } else if ((ch == 'I') && (format[1] == '6') && (format[2] == '4')) {
+ format += (step + 2);
+ step = Tcl_UtfToUniChar(format, &ch);
+ useBig = 1;
+ } else if (ch == 'L') {
+ format += step;
+ step = Tcl_UtfToUniChar(format, &ch);
+ useBig = 1;
}
format += step;
@@ -2509,6 +2517,17 @@ AppendPrintfToObjVA(
++size;
p++;
break;
+ case 'L':
+ size = 2;
+ p++;
+ break;
+ case 'I':
+ if (p[1]=='6' && p[2]=='4') {
+ p += 2;
+ size = 2;
+ }
+ p++;
+ break;
case 'h':
size = -1;
default:
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 2f1bb8b..23da6dc 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -1416,6 +1416,7 @@ const TclStubs tclStubs = {
Tcl_FindSymbol, /* 628 */
Tcl_FSUnloadFile, /* 629 */
Tcl_ZlibStreamSetCompressionDictionary, /* 630 */
+ Tcl_OpenTcpServerEx, /* 631 */
};
/* !END!: Do not edit above this line. */
diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c
index afabdca..dd951bf 100644
--- a/generic/tclStubLib.c
+++ b/generic/tclStubLib.c
@@ -101,12 +101,16 @@ Tcl_InitStubs(
}
}
}
- tclStubsPtr = (TclStubs *)pkgData;
+ if (((exact&0xff00) < 0x900)) {
+ /* We are running Tcl 8.x */
+ stubsPtr = (TclStubs *)pkgData;
+ }
+ tclStubsPtr = stubsPtr;
- if (tclStubsPtr->hooks) {
- tclPlatStubsPtr = tclStubsPtr->hooks->tclPlatStubs;
- tclIntStubsPtr = tclStubsPtr->hooks->tclIntStubs;
- tclIntPlatStubsPtr = tclStubsPtr->hooks->tclIntPlatStubs;
+ if (stubsPtr->hooks) {
+ tclPlatStubsPtr = stubsPtr->hooks->tclPlatStubs;
+ tclIntStubsPtr = stubsPtr->hooks->tclIntStubs;
+ tclIntPlatStubsPtr = stubsPtr->hooks->tclIntPlatStubs;
} else {
tclPlatStubsPtr = NULL;
tclIntStubsPtr = NULL;
diff --git a/generic/tclTest.c b/generic/tclTest.c
index e30c4d0..b92c72e 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -318,6 +318,9 @@ static int TestparsevarnameObjCmd(ClientData dummy,
static int TestpreferstableObjCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+static int TestprintObjCmd(ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
static int TestregexpObjCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
@@ -541,10 +544,10 @@ Tcltest_Init(
"-appinitprocclosestderr", "-appinitprocsetrcfile", NULL
};
- if (Tcl_InitStubs(interp, "8.5", 0) == NULL) {
+ if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
- if (Tcl_TomMath_InitStubs(interp, "8.5") == NULL) {
+ if (Tcl_TomMath_InitStubs(interp, "8.5-") == NULL) {
return TCL_ERROR;
}
if (Tcl_OOInitStubs(interp) == NULL) {
@@ -649,6 +652,8 @@ Tcltest_Init(
NULL, NULL);
Tcl_CreateObjCommand(interp, "testpreferstable", TestpreferstableObjCmd,
NULL, NULL);
+ Tcl_CreateObjCommand(interp, "testprint", TestprintObjCmd,
+ NULL, NULL);
Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd,
@@ -781,7 +786,7 @@ int
Tcltest_SafeInit(
Tcl_Interp *interp) /* Interpreter for application. */
{
- if (Tcl_InitStubs(interp, "8.5", 0) == NULL) {
+ if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
return Procbodytest_SafeInit(interp);
@@ -3820,6 +3825,43 @@ TestpreferstableObjCmd(
/*
*----------------------------------------------------------------------
*
+ * TestprintObjCmd --
+ *
+ * This procedure implements the "testprint" command. It is
+ * used for being able to test the Tcl_ObjPrintf() function.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestprintObjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* The argument objects. */
+{
+ Tcl_WideInt argv1 = 0;
+
+ if (objc < 2 || objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "format wideint");
+ }
+
+ if (objc > 1) {
+ Tcl_GetWideIntFromObj(interp, objv[2], &argv1);
+ }
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(Tcl_GetString(objv[1]), argv1));
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TestregexpObjCmd --
*
* This procedure implements the "testregexp" command. It is used to give
@@ -4597,7 +4639,7 @@ TestpanicCmd(
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
- const char *argString;
+ char *argString;
/*
* Put the arguments into a var args structure
diff --git a/generic/tclZlib.c b/generic/tclZlib.c
index 7f7aff6..c231f44 100644
--- a/generic/tclZlib.c
+++ b/generic/tclZlib.c
@@ -373,7 +373,7 @@ ConvertErrorToList(
default:
TclNewLiteralStringObj(objv[2], "UNKNOWN");
- TclNewIntObj(objv[3], code);
+ TclNewLongObj(objv[3], code);
return Tcl_NewListObj(4, objv);
}
}