diff options
| -rw-r--r-- | doc/uplevel.n | 4 | ||||
| -rw-r--r-- | generic/tclBasic.c | 4 | ||||
| -rw-r--r-- | generic/tclObj.c | 2 | ||||
| -rw-r--r-- | generic/tclProc.c | 98 | ||||
| -rw-r--r-- | tests/proc.test | 16 | ||||
| -rw-r--r-- | tests/uplevel.test | 14 | ||||
| -rw-r--r-- | win/tclWinNotify.c | 4 | ||||
| -rw-r--r-- | win/tclWinPipe.c | 14 |
8 files changed, 71 insertions, 85 deletions
diff --git a/doc/uplevel.n b/doc/uplevel.n index 4decc6d..cda1652 100644 --- a/doc/uplevel.n +++ b/doc/uplevel.n @@ -24,9 +24,9 @@ the result of that evaluation. If \fIlevel\fR is an integer then it gives a distance (up the procedure calling stack) to move before executing the command. If \fIlevel\fR consists of \fB#\fR followed by -a number then the number gives an absolute level number. If \fIlevel\fR +a integer then the level gives an absolute level. If \fIlevel\fR is omitted then it defaults to \fB1\fR. \fILevel\fR cannot be -defaulted if the first \fIcommand\fR argument starts with a digit or \fB#\fR. +defaulted if the first \fIcommand\fR argument is an integer or starts with \fB#\fR. .PP For example, suppose that procedure \fBa\fR was invoked from top-level, and that it called \fBb\fR, and that \fBb\fR called \fBc\fR. diff --git a/generic/tclBasic.c b/generic/tclBasic.c index f8ebbe9..7294dd6 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -7787,7 +7787,7 @@ ExprRandFunc( * Make sure 1 <= randSeed <= (2^31) - 2. See below. */ - iPtr->randSeed &= (unsigned long) 0x7fffffff; + iPtr->randSeed &= 0x7fffffff; if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) { iPtr->randSeed ^= 123459876; } @@ -7952,7 +7952,7 @@ ExprSrandFunc( */ iPtr->flags |= RAND_SEED_INITIALIZED; - iPtr->randSeed = w & (unsigned long) 0x7fffffff; + iPtr->randSeed = (long) w & 0x7fffffff; if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) { iPtr->randSeed ^= 123459876; } diff --git a/generic/tclObj.c b/generic/tclObj.c index 83b2915..59f3090 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -3121,7 +3121,7 @@ Tcl_GetWideIntFromObj( * Attempt to return a wide integer from the Tcl object "objPtr". If the * object is not already a int, double or bignum, an attempt will be made * to convert it to one of these. Out-of-range values don't result in an - * error, but only the least significant 64 bits will be returned. + * error, but only the least significant 64 bits will be returned. * * Results: * The return value is a standard Tcl object result. If an error occurs diff --git a/generic/tclProc.c b/generic/tclProc.c index 212b680..a1e51f3 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -505,10 +505,11 @@ TclCreateProc( goto procError; } - nameLength = Tcl_NumUtfChars(Tcl_GetString(fieldValues[0]), fieldValues[0]->length); + argname = Tcl_GetStringFromObj(fieldValues[0], &plen); + nameLength = Tcl_NumUtfChars(argname, plen); if (fieldCount == 2) { - valueLength = Tcl_NumUtfChars(Tcl_GetString(fieldValues[1]), - fieldValues[1]->length); + const char * value = TclGetString(fieldValues[1]); + valueLength = Tcl_NumUtfChars(value, fieldValues[1]->length); } else { valueLength = 0; } @@ -517,7 +518,6 @@ TclCreateProc( * Check that the formal parameter name is a scalar. */ - argname = Tcl_GetStringFromObj(fieldValues[0], &plen); argnamei = argname; argnamelast = argname[plen-1]; while (plen--) { @@ -688,51 +688,15 @@ TclGetFrame( CallFrame **framePtrPtr) /* Store pointer to frame here (or NULL if * global frame indicated). */ { - register Interp *iPtr = (Interp *) interp; - int curLevel, level, result; - CallFrame *framePtr; - - /* - * Parse string to figure out which level number to go to. - */ - - result = 1; - curLevel = iPtr->varFramePtr->level; - if (*name== '#') { - if (Tcl_GetInt(interp, name+1, &level) != TCL_OK || level < 0) { - goto levelError; - } - } else if (isdigit(UCHAR(*name))) { /* INTL: digit */ - if (Tcl_GetInt(interp, name, &level) != TCL_OK) { - goto levelError; - } - level = curLevel - level; - } else { - level = curLevel - 1; - result = 0; - } - - /* - * Figure out which frame to use, and return it to the caller. - */ - - for (framePtr = iPtr->varFramePtr; framePtr != NULL; - framePtr = framePtr->callerVarPtr) { - if (framePtr->level == level) { - break; - } - } - if (framePtr == NULL) { - goto levelError; - } - - *framePtrPtr = framePtr; - return result; - - levelError: - Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL); - return -1; + int result; + Tcl_Obj obj; + + obj.bytes = (char *) name; + obj.length = strlen(name); + obj.typePtr = NULL; + result = TclObjGetFrame(interp, &obj, framePtrPtr); + TclFreeIntRep(&obj); + return result; } /* @@ -770,6 +734,7 @@ TclObjGetFrame( register Interp *iPtr = (Interp *) interp; int curLevel, level, result; const char *name = NULL; + Tcl_WideInt w; /* * Parse object to figure out which level number to go to. @@ -785,25 +750,33 @@ TclObjGetFrame( if (objPtr == NULL) { /* Do nothing */ - } else if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &level) - && (level >= 0)) { - level = curLevel - level; - result = 1; + } else if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &level)) { + Tcl_GetWideIntFromObj(NULL, objPtr, &w); + if (w < 0 || w > INT_MAX || curLevel > w + INT_MAX) { + result = -1; + } else { + level = curLevel - level; + result = 1; + } } else if (objPtr->typePtr == &levelReferenceType) { level = (int) objPtr->internalRep.wideValue; result = 1; } else { name = TclGetString(objPtr); if (name[0] == '#') { - if (TCL_OK == Tcl_GetInt(NULL, name+1, &level) && level >= 0) { - TclFreeIntRep(objPtr); - objPtr->typePtr = &levelReferenceType; - objPtr->internalRep.wideValue = level; - result = 1; + if (TCL_OK == Tcl_GetInt(NULL, name+1, &level)) { + if (level < 0 || (level > 0 && name[1] == '-')) { + result = -1; + } else { + TclFreeIntRep(objPtr); + objPtr->typePtr = &levelReferenceType; + objPtr->internalRep.wideValue = level; + result = 1; + } } else { result = -1; } - } else if (isdigit(UCHAR(name[0]))) { /* INTL: digit */ + } else if (TclGetWideBitsFromObj(interp, objPtr, &w) == TCL_OK) { /* * If this were an integer, we'd have succeeded already. * Docs say we have to treat this as a 'bad level' error. @@ -814,7 +787,6 @@ TclObjGetFrame( if (result == 0) { level = curLevel - 1; - name = "1"; } if (result != -1) { if (level >= 0) { @@ -827,11 +799,11 @@ TclObjGetFrame( } } } - if (name == NULL) { - name = TclGetString(objPtr); - } } + if (name == NULL) { + name = TclGetString(objPtr); + } Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", name, NULL); return -1; diff --git a/tests/proc.test b/tests/proc.test index bae5e15..1893d0f 100644 --- a/tests/proc.test +++ b/tests/proc.test @@ -110,6 +110,14 @@ test proc-1.8 {Tcl_ProcObjCmd, check that formal parameter names are simple name proc p {b:a b::a} { } } -returnCodes error -result {formal parameter "b::a" is not a simple name} +test proc-1.9 {Tcl_ProcObjCmd, arguments via canonical list (string-representation bug [631b4c45df])} -body { + set v 2 + binary scan AB cc a b + proc p [list [list a $a] [list b $b] [list v [expr {$v + 2}]]] {expr {$a + $b + $v}} + p +} -result [expr {65+66+4}] -cleanup { + rename p {} +} test proc-2.1 {TclFindProc, simple proc name and proc not in namespace} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -383,6 +391,14 @@ test proc-7.4 {Proc struct outlives its interp: Bug 3532959} { interp delete slave unset lambda } {} + +test proc-7.5 {[631b4c45df] Crash in argument processing} { + binary scan A c val + proc foo [list [list from $val]] {} + rename foo {} + unset -nocomplain val +} {} + # cleanup catch {rename p ""} diff --git a/tests/uplevel.test b/tests/uplevel.test index 83d6b42..be2268a 100644 --- a/tests/uplevel.test +++ b/tests/uplevel.test @@ -139,25 +139,25 @@ test uplevel-4.16 {level parsing} { } {} test uplevel-4.17 {level parsing} -returnCodes error -body { apply {{} {uplevel -0xffffffff {}}} -} -result {invalid command name "-0xffffffff"} +} -result {bad level "-0xffffffff"} test uplevel-4.18 {level parsing} -returnCodes error -body { apply {{} {uplevel #-0xffffffff {}}} } -result {bad level "#-0xffffffff"} test uplevel-4.19 {level parsing} -returnCodes error -body { apply {{} {uplevel [expr -0xffffffff] {}}} -} -result {invalid command name "-4294967295"} +} -result {bad level "-4294967295"} test uplevel-4.20 {level parsing} -returnCodes error -body { apply {{} {uplevel #[expr -0xffffffff] {}}} } -result {bad level "#-4294967295"} test uplevel-4.21 {level parsing} -body { apply {{} {uplevel -1 {}}} -} -returnCodes error -result {invalid command name "-1"} +} -returnCodes error -result {bad level "-1"} test uplevel-4.22 {level parsing} -body { apply {{} {uplevel #-1 {}}} } -returnCodes error -result {bad level "#-1"} test uplevel-4.23 {level parsing} -body { apply {{} {uplevel [expr -1] {}}} -} -returnCodes error -result {invalid command name "-1"} +} -returnCodes error -result {bad level "-1"} test uplevel-4.24 {level parsing} -body { apply {{} {uplevel #[expr -1] {}}} } -returnCodes error -result {bad level "#-1"} @@ -175,13 +175,13 @@ test uplevel-4.28 {level parsing} -body { } -returnCodes error -result {bad level "#4294967295"} test uplevel-4.29 {level parsing} -body { apply {{} {uplevel 0.2 {}}} -} -returnCodes error -result {bad level "0.2"} +} -returnCodes error -result {invalid command name "0.2"} test uplevel-4.30 {level parsing} -body { apply {{} {uplevel #0.2 {}}} } -returnCodes error -result {bad level "#0.2"} test uplevel-4.31 {level parsing} -body { apply {{} {uplevel [expr 0.2] {}}} -} -returnCodes error -result {bad level "0.2"} +} -returnCodes error -result {invalid command name "0.2"} test uplevel-4.32 {level parsing} -body { apply {{} {uplevel #[expr 0.2] {}}} } -returnCodes error -result {bad level "#0.2"} @@ -193,7 +193,7 @@ test uplevel-4.34 {level parsing} -body { } -returnCodes error -result {bad level "#.2"} test uplevel-4.35 {level parsing} -body { apply {{} {uplevel [expr .2] {}}} -} -returnCodes error -result {bad level "0.2"} +} -returnCodes error -result {invalid command name "0.2"} test uplevel-4.36 {level parsing} -body { apply {{} {uplevel #[expr .2] {}}} } -returnCodes error -result {bad level "#0.2"} diff --git a/win/tclWinNotify.c b/win/tclWinNotify.c index 28c8445..b34fc4f 100644 --- a/win/tclWinNotify.c +++ b/win/tclWinNotify.c @@ -36,7 +36,6 @@ typedef struct { int pending; /* Alert message pending, this field is locked * by the notifierMutex. */ HWND hwnd; /* Messaging window. */ - int timeout; /* Current timeout value. */ int timerActive; /* 1 if interval timer is running. */ } ThreadSpecificData; @@ -309,11 +308,10 @@ Tcl_SetTimer( timeout = 1; } } - tsdPtr->timeout = timeout; if (timeout != 0) { tsdPtr->timerActive = 1; SetTimer(tsdPtr->hwnd, INTERVAL_TIMER, - (unsigned long) tsdPtr->timeout, NULL); + timeout, NULL); } else { tsdPtr->timerActive = 0; KillTimer(tsdPtr->hwnd, INTERVAL_TIMER); diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index cf0b80f..bd95ea4 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -869,7 +869,7 @@ TclpGetPid( Tcl_MutexLock(&pipeMutex); for (infoPtr = procList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { - if (infoPtr->dwProcessId == (DWORD) pid) { + if (infoPtr->dwProcessId == (DWORD) (size_t) pid) { Tcl_MutexUnlock(&pipeMutex); return infoPtr->dwProcessId; } @@ -1163,7 +1163,7 @@ TclpCreateProcess( WaitForInputIdle(procInfo.hProcess, 5000); CloseHandle(procInfo.hThread); - *pidPtr = (Tcl_Pid) procInfo.dwProcessId; + *pidPtr = (Tcl_Pid) (size_t) procInfo.dwProcessId; if (*pidPtr != 0) { TclWinAddProcess(procInfo.hProcess, procInfo.dwProcessId); } @@ -1478,10 +1478,10 @@ QuoteCmdLinePart( QuoteCmdLineBackslash(dsPtr, start, *bspos, NULL); start = *bspos; } - /* - * escape all special chars enclosed in quotes like `"..."`, note that here we + /* + * escape all special chars enclosed in quotes like `"..."`, note that here we * don't must escape `\` (with `\`), because it's outside of the main quotes, - * so `\` remains `\`, but important - not at end of part, because results as + * so `\` remains `\`, but important - not at end of part, because results as * before the quote, so `%\%\` should be escaped as `"%\%"\\`). */ TclDStringAppendLiteral(dsPtr, "\""); /* opening escape quote-char */ @@ -1636,7 +1636,7 @@ BuildCommandLine( special++; } /* rest of argument (and escape backslashes before closing main quote) */ - QuoteCmdLineBackslash(&ds, start, special, + QuoteCmdLineBackslash(&ds, start, special, (quote & CL_QUOTE) ? bspos : NULL); } if (quote & CL_QUOTE) { @@ -2476,7 +2476,7 @@ Tcl_WaitPid( prevPtrPtr = &procList; for (infoPtr = procList; infoPtr != NULL; prevPtrPtr = &infoPtr->nextPtr, infoPtr = infoPtr->nextPtr) { - if (infoPtr->dwProcessId == (DWORD) pid) { + if (infoPtr->dwProcessId == (DWORD) (size_t) pid) { *prevPtrPtr = infoPtr->nextPtr; break; } |