diff options
| -rw-r--r-- | ChangeLog | 67 | ||||
| -rw-r--r-- | doc/re_syntax.n | 8 | ||||
| -rw-r--r-- | generic/tclCmdAH.c | 11 | ||||
| -rw-r--r-- | generic/tclCmdIL.c | 66 | ||||
| -rw-r--r-- | generic/tclIO.c | 4 | ||||
| -rw-r--r-- | generic/tclIORTrans.c | 120 | ||||
| -rw-r--r-- | generic/tclIndexObj.c | 47 | ||||
| -rw-r--r-- | generic/tclOO.h | 14 | ||||
| -rw-r--r-- | generic/tclOODecls.h | 24 | ||||
| -rw-r--r-- | generic/tclOOIntDecls.h | 16 | ||||
| -rw-r--r-- | generic/tclTest.c | 46 | ||||
| -rw-r--r-- | generic/tclThreadTest.c | 12 | ||||
| -rw-r--r-- | tests/indexObj.test | 38 | ||||
| -rw-r--r-- | tests/safe.test | 16 | ||||
| -rw-r--r-- | tests/thread.test | 41 | ||||
| -rw-r--r-- | tools/tcltk-man2html-utils.tcl | 33 | ||||
| -rwxr-xr-x | tools/tcltk-man2html.tcl | 30 | ||||
| -rw-r--r-- | unix/Makefile.in | 2 |
18 files changed, 382 insertions, 213 deletions
@@ -1,3 +1,62 @@ +2011-09-28 Jan Nijtmans <nijtmans@users.sf.net> + + * generic/tclOO.h: [RFE 3010352]: make all TclOO API functions + * generic/tclOODecls.h: MODULE_SCOPE + * generic/tclOOIntDecls.h: + +2011-09-27 Donal K. Fellows <dkf@users.sf.net> + + * generic/tclIndexObj.c (Tcl_ParseArgsObjv): [Bug 3413857]: Corrected + the memory management for the code parsing arguments when returning + "large" numbers of arguments. Also unbroke the TCL_ARGV_AUTO_REST + macro in passing. + +2011-09-26 Donal K. Fellows <dkf@users.sf.net> + + * generic/tclCmdAH.c (TclMakeFileCommandSafe): [Bug 3211758]: Also + make the main [file] command hidden by default in safe interpreters, + because that's what existing code expects. This will reduce the amount + which the code breaks, but not necessarily eliminate it... + +2011-09-23 Don Porter <dgp@users.sourceforge.net> + + * generic/tclIORTrans.c: More revisions to get finalization of + ReflectedTransforms correct, including adopting a "dead" field as + was done in tclIORChan.c. + + * tests/thread.test: Stop using the deprecated thread management + commands of the tcltest package. The test suite ought to provide + these tools for itself. They do not belong in a testing harness. + +2011-09-22 Don Porter <dgp@users.sourceforge.net> + + * generic/tclCmdIL.c: Revise [info frame] so that it stops creating + cycles in the iPtr->cmdFramePtr stack. + +2011-09-22 Donal K. Fellows <dkf@users.sf.net> + + * doc/re_syntax.n: [Bug 2903743]: Add more magic so that we can do at + least something sane on Solaris. + * tools/tcltk-man2html-utils.tcl (process-text): Teach the HTML + generator how to handle this magic. + +2011-09-21 Don Porter <dgp@users.sourceforge.net> + + * generic/tclThreadTest.c: Revise the thread exit handling of the + [testthread] command so that it properly maintains the per-process + data structures even when the thread exits for reasons other than + the [testthread exit] command. + +2011-09-21 Alexandre Ferrieux <ferrieux@users.sourceforge.net> + + * unix/tclIO.c: [Bug 3412487]: Now short reads are allowed in + synchronous fcopy, avoid mistaking them as nonblocking ones. + +2011-09-21 Andreas Kupries <andreask@activestate.com> + + * generic/tclIORTrans.c (ForwardOpToOwnerThread): Fixed the missing + initialization of the 'dsti' field. Reported by Don Porter, on chat. + 2011-09-20 Don Porter <dgp@users.sourceforge.net> * generic/tclIORChan.c: Re-using the "interp" field to signal a dead @@ -12,17 +71,17 @@ 2011-09-19 Don Porter <dgp@users.sourceforge.net> * tests/ioTrans.test: Conversion from [testthread] to Thread package - stops most memory leaks. + stops most memory leaks. * tests/thread.test: Plug most memory leaks in thread.test. - Constrain the rest to be skipped during `make valgrind`. Tests using + Constrain the rest to be skipped during `make valgrind'. Tests using the [testthread cancel] testing command are leaky. Corrections wait for either addition of [thread::cancel] to the Thread package, or improvements to the [testthread] testing command to make leak-free versions of these tests possible. * generic/tclIORChan.c: Plug all memory leaks in ioCmd.test exposed - * tests/ioCmd.test: by `make valgrind`. + * tests/ioCmd.test: by `make valgrind'. * unix/Makefile.in: 2011-09-16 Jan Nijtmans <nijtmans@users.sf.net> @@ -2202,7 +2261,7 @@ [BRANCH: dogeen-assembler-branch] - * generic/tclAssembly.c (new file): + * generic/tclAssembly.c (new file): * generic/tclAssembly.h: * generic/tclBasic.c (builtInCmds, Tcl_CreateInterp): * generic/tclInt.h: diff --git a/doc/re_syntax.n b/doc/re_syntax.n index a53f58b..dacc41f 100644 --- a/doc/re_syntax.n +++ b/doc/re_syntax.n @@ -6,6 +6,8 @@ '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros +.ie '\w'o''\w'\C'^o''' .ds qo \C'^o' +.el .ds qo u .TH re_syntax n "8.1" Tcl "Tcl Built-In Commands" .BS .SH NAME @@ -290,12 +292,12 @@ treatment is as if the enclosing delimiters were .QW \fB[.\fR \& and .QW \fB.]\fR .) -For example, if \fBo\fR and \fB\N'244'\fR are the members of an +For example, if \fBo\fR and \fB\*(qo\fR are the members of an equivalence class, then .QW \fB[[=o=]]\fR , -.QW \fB[[=\N'244'=]]\fR , +.QW \fB[[=\*(qo=]]\fR , and -.QW \fB[o\N'244']\fR \& +.QW \fB[o\*(qo]\fR \& are all synonymous. An equivalence class may not be an endpoint of a range. .RS .PP diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index fc9d39d..d036bd6 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -1063,6 +1063,17 @@ TclMakeFileCommandSafe( } Tcl_DStringFree(&oldBuf); Tcl_DStringFree(&newBuf); + + /* + * Ugh. The [file] command is now actually safe, but it is assumed by + * scripts that it is not, which messes up security policies. [Bug + * 3211758] + */ + + if (Tcl_HideCommand(interp, "file", "file") != TCL_OK) { + Tcl_Panic("problem making 'file' safe: %s", + Tcl_GetString(Tcl_GetObjResult(interp))); + } return TCL_OK; } diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 95532d3..b312026 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -1140,32 +1140,40 @@ InfoFrameCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Interp *iPtr = (Interp *) interp; - int level, topLevel; - CmdFrame *framePtr; + int level, topLevel, code = TCL_OK; + CmdFrame *runPtr, *framePtr; + CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; + + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?number?"); + return TCL_ERROR; + } topLevel = ((iPtr->cmdFramePtr == NULL) ? 0 : iPtr->cmdFramePtr->level); - - if (iPtr->execEnvPtr->corPtr) { + if (corPtr) { /* * A coroutine: must fix the level computations AND the cmdFrame chain, * which is interrupted at the base. */ + CmdFrame *lastPtr = NULL; - CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; - CmdFrame *runPtr = iPtr->cmdFramePtr; - CmdFrame *lastPtr = NULL; + runPtr = iPtr->cmdFramePtr; + /* TODO - deal with overflow */ topLevel += corPtr->caller.cmdFramePtr->level; - while (runPtr && (runPtr != corPtr->caller.cmdFramePtr)) { - lastPtr = runPtr; - runPtr = runPtr->nextPtr; - } - if (lastPtr && !runPtr) { - lastPtr->nextPtr = corPtr->caller.cmdFramePtr; - } + while (runPtr) { + runPtr->level += corPtr->caller.cmdFramePtr->level; + lastPtr = runPtr; + runPtr = runPtr->nextPtr; + } + if (lastPtr) { + lastPtr->nextPtr = corPtr->caller.cmdFramePtr; + } else { + iPtr->cmdFramePtr = corPtr->caller.cmdFramePtr; + } } if (objc == 1) { @@ -1174,10 +1182,7 @@ InfoFrameCmd( */ Tcl_SetObjResult(interp, Tcl_NewIntObj(topLevel)); - return TCL_OK; - } else if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "?number?"); - return TCL_ERROR; + goto done; } /* @@ -1185,7 +1190,8 @@ InfoFrameCmd( */ if (TclGetIntFromObj(interp, objv[1], &level) != TCL_OK) { - return TCL_ERROR; + code = TCL_ERROR; + goto done; } if ((level > topLevel) || (level <= - topLevel)) { @@ -1194,7 +1200,8 @@ InfoFrameCmd( NULL); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_FRAME", TclGetString(objv[1]), NULL); - return TCL_ERROR; + code = TCL_ERROR; + goto done; } /* @@ -1214,7 +1221,24 @@ InfoFrameCmd( } Tcl_SetObjResult(interp, TclInfoFrame(interp, framePtr)); - return TCL_OK; + + done: + if (corPtr) { + + if (iPtr->cmdFramePtr == corPtr->caller.cmdFramePtr) { + iPtr->cmdFramePtr = NULL; + } else { + runPtr = iPtr->cmdFramePtr; + while (runPtr->nextPtr != corPtr->caller.cmdFramePtr) { + runPtr->level -= corPtr->caller.cmdFramePtr->level; + runPtr = runPtr->nextPtr; + } + runPtr->level = 1; + runPtr->nextPtr = NULL; + } + + } + return code; } /* diff --git a/generic/tclIO.c b/generic/tclIO.c index ae1b89a..082cf70 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -9215,8 +9215,8 @@ CopyData( if ((size == 0) && Tcl_Eof(inChan) && !(cmdPtr && (mask == 0))) { break; } - if (((!Tcl_Eof(inChan)) || (cmdPtr && (mask == 0))) && - !(mask & TCL_READABLE)) { + if (cmdPtr && (!Tcl_Eof(inChan) || (mask == 0)) && + !(mask & TCL_READABLE)) { if (mask & TCL_WRITABLE) { Tcl_DeleteChannelHandler(outChan, CopyEventProc, csPtr); } diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index ef37d5c..b095dcf 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -161,6 +161,8 @@ typedef struct { int mode; /* Mask of R/W mode */ int nonblocking; /* Flag: Channel is blocking or not. */ int readIsDrained; /* Flag: Read buffers are flushed. */ + int dead; /* Boolean signal that some operations + * should no longer be attempted. */ ResultBuffer result; } ReflectedTransform; @@ -1008,27 +1010,27 @@ ReflectClose( * the per-interp DeleteReflectedTransformMap exit-handler. */ - if (rtPtr->interp) { + if (!rtPtr->dead) { rtmPtr = GetReflectedTransformMap(rtPtr->interp); hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle)); if (hPtr) { Tcl_DeleteHashEntry(hPtr); } - } - /* - * In a threaded interpreter we manage a per-thread map as well, to allow - * us to survive if the script level pulls the rug out under a channel by - * deleting the owning thread. - */ + /* + * In a threaded interpreter we manage a per-thread map as well, + * to allow us to survive if the script level pulls the rug out + * under a channel by deleting the owning thread. + */ #ifdef TCL_THREADS - rtmPtr = GetThreadReflectedTransformMap(); - hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle)); - if (hPtr) { - Tcl_DeleteHashEntry(hPtr); - } + rtmPtr = GetThreadReflectedTransformMap(); + hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle)); + if (hPtr) { + Tcl_DeleteHashEntry(hPtr); + } #endif + } Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); return errorCodeSet ? errorCode : ((result == TCL_OK) ? EOK : EINVAL); @@ -1771,6 +1773,7 @@ NewReflectedTransform( rtPtr->readIsDrained = 0; rtPtr->nonblocking = (((Channel *) parentChan)->state->flags & CHANNEL_NONBLOCKING); + rtPtr->dead = 0; /* * Query parent for current blocking mode. @@ -1950,7 +1953,7 @@ InvokeTclMethod( int result; /* Result code of method invokation */ Tcl_Obj *resObj = NULL; /* Result of method invokation. */ - if (!rtPtr->interp) { + if (rtPtr->dead) { /* * The transform is marked as dead. Bail out immediately, with an * appropriate error. @@ -2163,7 +2166,8 @@ DeleteReflectedTransformMap( hPtr != NULL; hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch)) { rtPtr = Tcl_GetHashValue(hPtr); - rtPtr->interp = NULL; + + rtPtr->dead = 1; Tcl_DeleteHashEntry(hPtr); } Tcl_DeleteHashTable(&rtmPtr->map); @@ -2175,6 +2179,32 @@ DeleteReflectedTransformMap( */ /* + * Get the map of all channels handled by the current thread. This is a + * ReflectedTransformMap, but on a per-thread basis, not per-interp. Go + * through the channels and remove all which were handled by this + * interpreter. They have already been marked as dead. + */ + + rtmPtr = GetThreadReflectedTransformMap(); + for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + rtPtr = Tcl_GetHashValue(hPtr); + + if (rtPtr->interp != interp) { + /* + * Ignore entries for other interpreters. + */ + + continue; + } + + rtPtr->dead = 1; + FreeReflectedTransformArgs(rtPtr); + Tcl_DeleteHashEntry(hPtr); + } + + /* * Go through the list of pending results and cancel all whose events were * destined for this interpreter. While this is in progress we block any * other access to the list of pending results. @@ -2210,29 +2240,6 @@ DeleteReflectedTransformMap( } Tcl_MutexUnlock(&rtForwardMutex); - /* - * Get the map of all channels handled by the current thread. This is a - * ReflectedTransformMap, but on a per-thread basis, not per-interp. Go - * through the channels and remove all which were handled by this - * interpreter. They have already been marked as dead. - */ - - rtmPtr = GetThreadReflectedTransformMap(); - for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch); - hPtr != NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { - rtPtr = Tcl_GetHashValue(hPtr); - - if (rtPtr->interp != interp) { - /* - * Ignore entries for other interpreters. - */ - - continue; - } - - Tcl_DeleteHashEntry(hPtr); - } #endif } @@ -2303,6 +2310,24 @@ DeleteThreadReflectedTransformMap( */ /* + * Get the map of all channels handled by the current thread. This is a + * ReflectedTransformMap, but on a per-thread basis, not per-interp. Go + * through the channels, remove all, mark them as dead. + */ + + rtmPtr = GetThreadReflectedTransformMap(); + for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch); + hPtr != NULL; + hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch)) { + ReflectedTransform *rtPtr = Tcl_GetHashValue(hPtr); + + rtPtr->dead = 1; + FreeReflectedTransformArgs(rtPtr); + Tcl_DeleteHashEntry(hPtr); + } + ckfree(rtmPtr); + + /* * Go through the list of pending results and cancel all whose events were * destined for this thread. While this is in progress we block any * other access to the list of pending results. @@ -2340,24 +2365,6 @@ DeleteThreadReflectedTransformMap( Tcl_ConditionNotify(&resultPtr->done); } Tcl_MutexUnlock(&rtForwardMutex); - - /* - * Get the map of all channels handled by the current thread. This is a - * ReflectedTransformMap, but on a per-thread basis, not per-interp. Go - * through the channels, remove all, mark them as dead. - */ - - rtmPtr = GetThreadReflectedTransformMap(); - for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch); - hPtr != NULL; - hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch)) { - ReflectedTransform *rtPtr = Tcl_GetHashValue(hPtr); - - rtPtr->interp = NULL; - FreeReflectedTransformArgs(rtPtr); - Tcl_DeleteHashEntry(hPtr); - } - ckfree(rtmPtr); } static void @@ -2377,7 +2384,7 @@ ForwardOpToOwnerThread( Tcl_MutexLock(&rtForwardMutex); - if (rtPtr->interp == NULL) { + if (rtPtr->dead) { /* * The channel is marked as dead. Bail out immediately, with an * appropriate error. Do not forget to unlock the mutex on this path. @@ -2403,6 +2410,7 @@ ForwardOpToOwnerThread( resultPtr->src = Tcl_GetCurrentThread(); resultPtr->dst = dst; + resultPtr->dsti = rtPtr->interp; resultPtr->done = NULL; resultPtr->result = -1; resultPtr->evPtr = evPtr; diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 6f378a4..8651542 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -1113,13 +1113,15 @@ Tcl_ParseArgsObjv( if (remObjv != NULL) { /* - * Then we should copy the name of the command (0th argument). + * Then we should copy the name of the command (0th argument). The + * upper bound on the number of elements is known, and (undocumented, + * but historically true) there should be a NULL argument after the + * last result. [Bug 3413857] */ nrem = 1; - leftovers = ckalloc((nrem + 1) * sizeof(Tcl_Obj *)); - leftovers[nrem-1] = objv[0]; - leftovers[nrem] = NULL; + leftovers = ckalloc((1 + *objcPtr) * sizeof(Tcl_Obj *)); + leftovers[0] = objv[0]; } else { nrem = 0; leftovers = NULL; @@ -1182,14 +1184,7 @@ Tcl_ParseArgsObjv( } dstIndex++; /* This argument is now handled */ - nrem++; - - /* - * Allocate nrem (+1 extra for NULL terminator) pointers. - */ - - leftovers = ckrealloc(leftovers, (nrem+1) * sizeof(Tcl_Obj *)); - leftovers[nrem-1] = curArg; + leftovers[nrem++] = curArg; continue; } @@ -1227,7 +1222,14 @@ Tcl_ParseArgsObjv( objc--; break; case TCL_ARGV_REST: - *((int *) infoPtr->dstPtr) = dstIndex; + /* + * Only store the point where we got to if it's not to be written + * to NULL, so that TCL_ARGV_AUTO_REST works. + */ + + if (infoPtr->dstPtr != NULL) { + *((int *) infoPtr->dstPtr) = dstIndex; + } goto argsDone; case TCL_ARGV_FLOAT: if (objc == 0) { @@ -1282,7 +1284,9 @@ Tcl_ParseArgsObjv( /* * If we broke out of the loop because of an OPT_REST argument, copy the - * remaining arguments down. + * remaining arguments down. Note that there is always at least one + * argument left over - the command name - so we always have a result if + * our caller is willing to receive it. [Bug 3413857] */ argsDone: @@ -1295,19 +1299,12 @@ Tcl_ParseArgsObjv( } if (objc > 0) { - leftovers = ckrealloc(leftovers, (nrem+objc+1) * sizeof(Tcl_Obj *)); - while (objc) { - leftovers[nrem] = objv[srcIndex]; - nrem++; - srcIndex++; - objc--; - } - } else if (leftovers != NULL) { - ckfree(leftovers); + memcpy(leftovers+nrem, objv+srcIndex, objc*sizeof(Tcl_Obj *)); + nrem += objc; } leftovers[nrem] = NULL; - *objcPtr = nrem; - *remObjv = leftovers; + *objcPtr = nrem++; + *remObjv = ckrealloc(leftovers, nrem * sizeof(Tcl_Obj *)); return TCL_OK; /* diff --git a/generic/tclOO.h b/generic/tclOO.h index c791930..fef2bd0 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -14,6 +14,20 @@ #define TCLOO_H_INCLUDED #include "tcl.h" +#ifndef TCLOOAPI +# if defined(BUILD_tcl) || defined(BUILD_TclOO) +# define TCLOOAPI MODULE_SCOPE +# else +# define TCLOOAPI extern +# undef USE_TCLOO_STUBS +# define USE_TCLOO_STUBS 1 +# endif +#endif + +extern const char *TclOOInitializeStubs( + Tcl_Interp *, const char *version); +#define Tcl_OOInitStubs(interp) TclOOInitializeStubs((interp), TCLOO_VERSION) + /* * Be careful when it comes to versioning; need to make sure that the * standalone TclOO version matches. Also make sure that this matches the diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index 5e48b0b..6316303 100644 --- a/generic/tclOODecls.h +++ b/generic/tclOODecls.h @@ -5,30 +5,6 @@ #ifndef _TCLOODECLS #define _TCLOODECLS -#ifndef TCLOOAPI -# ifdef BUILD_tcl -# define TCLOOAPI MODULE_SCOPE -# else -# define TCLOOAPI extern -# undef USE_TCLOO_STUBS -# define USE_TCLOO_STUBS 1 -# endif -#endif - -/* - * WARNING: This file is automatically generated by the tools/genStubs.tcl - * script. Any modifications to the function declarations below should be made - * in the generic/tclOO.decls script. - */ - -#if defined(USE_TCL_STUBS) -extern const char *TclOOInitializeStubs(Tcl_Interp *, const char *version); -#define Tcl_OOInitStubs(interp) TclOOInitializeStubs((interp),TCLOO_VERSION) -#else -#define Tcl_OOInitStubs(interp) \ - Tcl_PkgRequire((interp),"TclOO",TCLOO_VERSION,0) -#endif - /* !BEGIN!: Do not edit below this line. */ /* diff --git a/generic/tclOOIntDecls.h b/generic/tclOOIntDecls.h index 49a43aa..c751838 100644 --- a/generic/tclOOIntDecls.h +++ b/generic/tclOOIntDecls.h @@ -5,22 +5,6 @@ #ifndef _TCLOOINTDECLS #define _TCLOOINTDECLS -#ifndef TCLOOAPI -# ifdef BUILD_tcl -# define TCLOOAPI MODULE_SCOPE -# else -# define TCLOOAPI extern -# undef USE_TCLOO_STUBS -# define USE_TCLOO_STUBS 1 -# endif -#endif - -/* - * WARNING: This file is automatically generated by the tools/genStubs.tcl - * script. Any modifications to the function declarations below should be made - * in the generic/tclOO.decls script. - */ - /* !BEGIN!: Do not edit below this line. */ /* diff --git a/generic/tclTest.c b/generic/tclTest.c index 96dcb36..30c95c8 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -311,6 +311,8 @@ static int TestpanicCmd(ClientData dummy, static int TestfinexitObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +static int TestparseargsCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); static int TestparserObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -624,6 +626,7 @@ Tcltest_Init( NULL); Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testfinexit", TestfinexitObjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testparseargs", TestparseargsCmd,NULL,NULL); Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testparsevar", TestparsevarObjCmd, @@ -7082,6 +7085,49 @@ TestconcatobjCmd( } /* + *---------------------------------------------------------------------- + * + * TestparseargsCmd -- + * + * This procedure implements the "testparseargs" command. It is used to + * test that Tcl_ParseArgsObjv does indeed return the right number of + * arguments. In other words, that [Bug 3413857] was fixed properly. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestparseargsCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Arguments. */ +{ + int count = objc, foo = 0; + Tcl_Obj **remObjv, *result[3]; + Tcl_ArgvInfo argTable[] = { + {TCL_ARGV_CONSTANT, "-bool", INT2PTR(1), &foo, "booltest", NULL}, + TCL_ARGV_AUTO_REST, TCL_ARGV_AUTO_HELP, TCL_ARGV_TABLE_END + }; + + if (Tcl_ParseArgsObjv(interp, argTable, &count, objv, &remObjv)!=TCL_OK) { + return TCL_ERROR; + } + result[0] = Tcl_NewIntObj(foo); + result[1] = Tcl_NewIntObj(count); + result[2] = Tcl_NewListObj(count, remObjv); + Tcl_SetObjResult(interp, Tcl_NewListObj(3, result)); + ckfree(remObjv); + return TCL_OK; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index 71d5a66..3345081 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -46,7 +46,7 @@ static Tcl_ThreadDataKey dataKey; * protected by threadMutex. */ -static ThreadSpecificData *threadList; +static ThreadSpecificData *threadList = NULL; /* * The following bit-values are legal for the "flags" field of the @@ -623,9 +623,9 @@ NewTestThread( * Clean up. */ - ListRemove(tsdPtr); - Tcl_Release(tsdPtr->interp); Tcl_DeleteInterp(tsdPtr->interp); + Tcl_Release(tsdPtr->interp); + ListRemove(tsdPtr); Tcl_ExitThread(result); TCL_THREAD_CREATE_RETURN; @@ -744,6 +744,7 @@ ListRemove( tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr; } tsdPtr->nextPtr = tsdPtr->prevPtr = 0; + tsdPtr->interp = NULL; Tcl_MutexUnlock(&threadMutex); } @@ -1148,6 +1149,11 @@ ThreadExitProc( char *threadEvalScript = clientData; ThreadEventResult *resultPtr, *nextPtr; Tcl_ThreadId self = Tcl_GetCurrentThread(); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + if (tsdPtr->interp != NULL) { + ListRemove(tsdPtr); + } Tcl_MutexLock(&threadMutex); diff --git a/tests/indexObj.test b/tests/indexObj.test index 098aec0..479cc3b 100644 --- a/tests/indexObj.test +++ b/tests/indexObj.test @@ -1,20 +1,21 @@ # This file is a Tcl script to test out the the procedures in file -# tkIndexObj.c, which implement indexed table lookups. The tests here -# are organized in the standard fashion for Tcl tests. +# tkIndexObj.c, which implement indexed table lookups. The tests here are +# organized in the standard fashion for Tcl tests. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest + package require tcltest 2 namespace import -force ::tcltest::* } testConstraint testindexobj [llength [info commands testindexobj]] - +testConstraint testparseargs [llength [info commands testparseargs]] + test indexObj-1.1 {exact match} testindexobj { testindexobj 1 1 xyz abc def xyz alm } {2} @@ -128,6 +129,31 @@ test indexObj-6.4 {Tcl_GetIndexFromObjStruct} testindexobj { testgetindexfromobjstruct $x 1 } "wrong # args: should be \"testgetindexfromobjstruct c 1\"" +test indexObj-7.1 {Tcl_ParseArgsObjv} testparseargs { + testparseargs +} {0 1 testparseargs} +test indexObj-7.2 {Tcl_ParseArgsObjv} testparseargs { + testparseargs -bool +} {1 1 testparseargs} +test indexObj-7.3 {Tcl_ParseArgsObjv} testparseargs { + testparseargs -bool bar +} {1 2 {testparseargs bar}} +test indexObj-7.4 {Tcl_ParseArgsObjv} testparseargs { + testparseargs bar +} {0 2 {testparseargs bar}} +test indexObj-7.5 {Tcl_ParseArgsObjv} -constraints testparseargs -body { + testparseargs -help +} -returnCodes error -result {Command-specific options: + -bool: booltest + --: Marks the end of the options + -help: Print summary of command-line options and abort} +test indexObj-7.6 {Tcl_ParseArgsObjv} testparseargs { + testparseargs -- -bool -help +} {0 3 {testparseargs -bool -help}} +test indexObj-7.7 {Tcl_ParseArgsObjv memory management} testparseargs { + testparseargs 1 2 3 4 5 6 7 8 9 0 -bool 1 2 3 4 5 6 7 8 9 0 +} {1 21 {testparseargs 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0}} + # cleanup ::tcltest::cleanupTests return diff --git a/tests/safe.test b/tests/safe.test index 0f82a6a..4190976 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -541,6 +541,22 @@ test safe-12.7 {glob is restricted} -setup { } -cleanup { safe::interpDelete $i } -match glob -result * + +test safe-13.1 {safe file ensemble does not surprise code} -setup { + set i [interp create -safe] +} -body { + set result [expr {"file" in [interp hidden $i]}] + lappend result [interp eval $i {tcl::file::split a/b/c}] + lappend result [catch {interp eval $i {tcl::file::isdirectory .}}] + lappend result [interp invokehidden $i file split a/b/c] + lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg + lappend result [catch {interp invokehidden $i file isdirectory .}] + interp expose $i file + lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg + lappend result [catch {interp eval $i {file isdirectory .}} msg] $msg +} -cleanup { + interp delete $i +} -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {invalid command name "::tcl::file::isdirectory"}} set ::auto_path $saveAutoPath # cleanup diff --git a/tests/thread.test b/tests/thread.test index e818388..74f7043 100644 --- a/tests/thread.test +++ b/tests/thread.test @@ -23,23 +23,41 @@ testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}] testConstraint notValgrind [expr {![testConstraint valgrind]}] -if {[testConstraint testthread]} { - testthread errorproc ThreadError +proc ThreadError {id info} { + global threadId threadError + set threadId $id + set threadError $info } + if {[testConstraint thread]} { thread::errorproc ThreadError } - proc ThreadError {id info} { - global threadId threadError - set threadId $id - set threadError $info - } +if {[testConstraint testthread]} { + testthread errorproc ThreadError + + set mainThread [testthread id] proc ThreadNullError {id info} { # ignore } + proc threadReap {} { + testthread errorproc ThreadNullError + while {[llength [testthread names]] > 1} { + foreach tid [testthread names] { + if {$tid != [testthread id]} { + catch { + testthread send -async $tid {testthread exit} + } + } + } + after 1 + } + testthread errorproc ThreadError + return [llength [testthread names]] + } +} test thread-1.1 {Tcl_ThreadObjCmd: no args} {testthread} { list [catch {testthread} msg] $msg @@ -70,7 +88,6 @@ test thread-1.5 {Tcl_ThreadObjCmd: thread create one shot} {thread} { set l } {1} test thread-1.6 {Tcl_ThreadObjCmd: thread exit} {thread} { - threadReap thread::create {{*}{}} update after 10 @@ -81,14 +98,14 @@ test thread-1.7 {Tcl_ThreadObjCmd: thread id args} {testthread} { list $x $msg } {1 {wrong # args: should be "testthread id"}} test thread-1.8 {Tcl_ThreadObjCmd: thread id} {testthread} { - string compare [testthread id] $::tcltest::mainThread + string compare [testthread id] $mainThread } {0} test thread-1.9 {Tcl_ThreadObjCmd: thread names args} {testthread} { set x [catch {testthread names x} msg] list $x $msg } {1 {wrong # args: should be "testthread names"}} test thread-1.10 {Tcl_ThreadObjCmd: thread id} {testthread} { - string compare [testthread names] $::tcltest::mainThread + string compare [testthread names] $mainThread } {0} test thread-1.11 {Tcl_ThreadObjCmd: send args} {testthread} { set x [catch {testthread send} msg] @@ -105,7 +122,7 @@ test thread-1.13 {Tcl_ThreadObjCmd: send args} {thread} { set five } 5 test thread-1.14 {Tcl_ThreadObjCmd: send bad id} {testthread} { - set tid [expr $::tcltest::mainThread + 10] + set tid [expr $mainThread + 10] set x [catch {testthread send $tid {set x 5}} msg] list $x $msg } {1 {invalid thread id}} @@ -249,7 +266,7 @@ test thread-7.2 {cancel: nonint} {testthread} { list $x $msg } {1 {expected integer but got "abc"}} test thread-7.3 {cancel: bad id} {testthread} { - set tid [expr $::tcltest::mainThread + 10] + set tid [expr $mainThread + 10] set x [catch {testthread cancel $tid} msg] list $x $msg } {1 {invalid thread id}} diff --git a/tools/tcltk-man2html-utils.tcl b/tools/tcltk-man2html-utils.tcl index 938a1af..ef1f62a 100644 --- a/tools/tcltk-man2html-utils.tcl +++ b/tools/tcltk-man2html-utils.tcl @@ -110,6 +110,7 @@ proc htmlize-text {text {charmap {}}} { # contains some extras for use in nroff->html processing # build on the list passed in, if any lappend charmap \ + "–" "–" \ {&} {&} \ {\\} "\" \ {\e} "\" \ @@ -143,8 +144,8 @@ proc process-text {text} { {\fP} {\fR} \ {\.} . \ {\(bu} "•" \ + {\*(qo} "ô" \ ] - lappend charmap {\o'o^'} {ô} ; # o-circumflex in re_syntax.n lappend charmap {\-\|\-} -- ; # two hyphens lappend charmap {\-} - ; # a hyphen @@ -1063,25 +1064,17 @@ proc output-directive {line} { output-IP-list .IP .IP $rest return } - .PP { + .PP - .sp { man-puts <P> } .RS { output-RS-list return } - .RE { - manerror "unexpected .RE" - return - } .br { man-puts <BR> return } - .DE { - manerror "unexpected .DE" - return - } .DS { if {[next-op-is .ta rest]} { # skip the leading .ta directive if it is there @@ -1109,16 +1102,6 @@ proc output-directive {line} { } return } - .CE { - manerror "unexpected .CE" - return - } - .sp { - man-puts <P> - } - .ta { - manerror "ignoring $line" - } .nf { if {[match-text @more .fi]} { foreach more [split $more \n] { @@ -1174,13 +1157,11 @@ proc output-directive {line} { manerror "ignoring $line" } } - .fi { - manerror "ignoring $line" + .RE - .DE - .CE { + manerror "unexpected $code" + return } - .na - - .ad - - .UL - - .ne { + .ta - .fi - .na - .ad - .UL - .ie - .el - .ne { manerror "ignoring $line" } default { diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl index b347abf..e4845a6 100755 --- a/tools/tcltk-man2html.tcl +++ b/tools/tcltk-man2html.tcl @@ -360,7 +360,7 @@ proc make-man-pages {html args} { continue } switch -exact -- $code { - .if - .nr - .ti - .in - + .if - .nr - .ti - .in - .ie - .el - .ad - .na - .so - .ne - .AS - .VE - .VS - . { # ignore continue @@ -379,21 +379,22 @@ proc make-man-pages {html args} { lappend manual(text) "$code [unquote $rest]" } .QW { - set rest [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest] - addbuffer $LQ [unquote [lindex $rest 0]] $RQ \ - [unquote [lindex $rest 1]] + lassign [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest] \ + inQuote afterwards + addbuffer $LQ [unquote $inQuote] $RQ [unquote $afterwards] } .PQ { - set rest [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest] - addbuffer ( $LQ [unquote [lindex $rest 0]] $RQ \ - [unquote [lindex $rest 1]] ) \ - [unquote [lindex $rest 2]] + lassign [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest] \ + inQuote punctuation afterwards + addbuffer ( $LQ [unquote $inQuote] $RQ \ + [unquote $punctuation] ) \ + [unquote $afterwards] } .QR { - set rest [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest] - addbuffer $LQ [unquote [lindex $rest 0]] - \ - [unquote [lindex $rest 1]] $RQ \ - [unquote [lindex $rest 2]] + lassign [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest] \ + rangeFrom rangeTo afterwards + addbuffer $LQ [unquote $rangeFrom] "–" \ + [unquote $rangeTo] $RQ [unquote $afterwards] } .MT { addbuffer $LQ$RQ @@ -404,7 +405,7 @@ proc make-man-pages {html args} { } .BS - .BE - .br - .fi - .sp - .nf { flushbuffer - if {"$rest" ne {}} { + if {$rest ne ""} { if {!$verbose} { puts stderr "" } @@ -435,8 +436,9 @@ proc make-man-pages {html args} { } .OP { flushbuffer + lassign $rest cmdName dbName dbClass lappend manual(text) [concat .OP [process-text \ - "\\fB[lindex $rest 0]\\fR \\fB[lindex $rest 1]\\fR \\fB[lindex $rest 2]\\fR"]] + "\\fB$cmdName\\fR \\fB$dbName\\fR \\fB$dbClass\\fR"]] } .PP - .LP { flushbuffer diff --git a/unix/Makefile.in b/unix/Makefile.in index 5014ccb..a2ade1d 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -468,7 +468,7 @@ OO_SRCS = \ STUB_SRCS = \ $(GENERIC_DIR)/tclStubLib.c \ $(GENERIC_DIR)/tclTomMathStubLib.c \ - $(GENERIC_DIR)/tclOOStubLib.o + $(GENERIC_DIR)/tclOOStubLib.c TOMMATH_SRCS = \ $(TOMMATH_DIR)/bncore.c \ |