From cc63d97f54b28d904f4c315b8aeff5359ffe2fc0 Mon Sep 17 00:00:00 2001 From: andreask Date: Thu, 22 May 2014 17:17:12 +0000 Subject: Workarounds and fixes for wrapped executables on various platforms regarding the handling of wrapped dynamic libraries. The basic flow of operation is to copy such libraries into a temp file, hand them to the OS loader for processing, and then to delete them immediately, to prevent them from being accessible to other executables. On platforms where that is not possible the library is left in place and things are arranged to delete it on regular process exit. An example of the latter are older revisions of HPUX which report that the file is busy when trying to delete it. Younger revisions of HPUX have changed to allow the deletion, but are also buggy, the OS loader mangles its data structures so that a second library loaded in this manner fails. More recently it was found that Linux which is usually ok with deleting the file and gets everything right shows the same trouble as modern HPUX when the "docker" containerization system is involved, or more specifically the AUFS in use there. Deleting the loaded library file mangles data structures and breaks loading of the following libraries. For a demonstration which does not involve Tcl at all see the ticket https://github.com/dotcloud/docker/issues/1911 in the docker tracker. This of course breaks the use of wrapped executables within docker containers. This commit introduces the function TclSkipUnlink() which centralizes the handling of such exceptions to unlinking the library after unload, and provides code handling the known cases. IOW HPUX is generally forced to not unlink, and ditto when we detect that the copied library file resides within an AUFS. The latter must however be explicitly activated by setting the define -DTCL_TEMPLOAD_NO_UNLINK during build. We still need proper configure tests to set it on the relevant platforms (i.e. Linux). The AUFS detection and handling can be overridden by the environment variable TCL_TEMPLOAD_NO_UNLINK which can force the behaviour either way (skip or not). In case the user knows best, or wishes to test if the problem with AUFS has been fixed. --- generic/tclIOUtil.c | 87 ++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 86 insertions(+), 1 deletion(-) diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 295e313..3d33992 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -24,6 +24,12 @@ #endif #include "tclFileSystem.h" +#ifdef TCL_TEMPLOAD_NO_UNLINK +#ifndef NO_FSTATFS +#include +#endif +#endif + /* * struct FilesystemRecord -- * @@ -3149,6 +3155,83 @@ Tcl_FSLoadFile( typedef int (Tcl_FSLoadFileProc2) (Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr, int flags); +/* + * Workaround for issue with modern HPUX which do allow the unlink (no ETXTBSY + * error) yet somehow trash some internal data structures which prevents the + * second and further shared libraries from getting properly loaded. Only the + * first is ok. We try to get around the issue by not unlinking, + * i.e. emulating the behaviour of the older HPUX which denied removal. + * + * Doing the unlink is also an issue within docker containers, whose AUFS + * bungles this as well, see + * https://github.com/dotcloud/docker/issues/1911 + * + * For these situations the change below makes the execution of the unlink + * semi-controllable at runtime. + * + * An AUFS filesystem (if it can be detected) will force avoidance of + * unlink. The env variable TCL_TEMPLOAD_NO_UNLINK allows detection of a + * users general request (unlink and not. + * + * By default the unlink is done (if not in AUFS). However if the variable is + * present and set to true (any integer > 0) then the unlink is skipped. + */ + +int +TclSkipUnlink (Tcl_Obj* shlibFile) +{ + /* Order of testing: + * 1. On hpux we generally want to skip unlink in general + * + * Outside of hpux then: + * 2. For a general user request (TCL_TEMPLOAD_NO_UNLINK present, non-empty, => int) + * 3. For general AUFS environment (statfs, if available). + * + * Ad 2: This variable can disable/override the AUFS detection, i.e. for + * testing if a newer AUFS does not have the bug any more. + * + * Ad 3: This is conditionally compiled in. Condition currently must be set manually. + * This part needs proper tests in the configure(.in). + */ + +#ifdef hpux + return 1; +#else + int skip = 0; + char* skipstr; + + skipstr = getenv ("TCL_TEMPLOAD_NO_UNLINK"); + if (skipstr && (skipstr[0] != '\0')) { + return atoi(skipstr); + } + +#ifdef TCL_TEMPLOAD_NO_UNLINK +#ifndef NO_FSTATFS + { + struct statfs fs; + /* Have fstatfs. May not have the AUFS super magic ... Indeed our build + * box is too old to have it directly in the headers. Define taken from + * http://mooon.googlecode.com/svn/trunk/linux_include/linux/aufs_type.h + * http://aufs.sourceforge.net/ + * Better reference will be gladly taken. + */ +#ifndef AUFS_SUPER_MAGIC +#define AUFS_SUPER_MAGIC ('a' << 24 | 'u' << 16 | 'f' << 8 | 's') +#endif /* AUFS_SUPER_MAGIC */ + if ((statfs(Tcl_GetString (shlibFile), &fs) == 0) && + (fs.f_type == AUFS_SUPER_MAGIC)) { + return 1; + } + } +#endif /* ... NO_FSTATFS */ +#endif /* ... TCL_TEMPLOAD_NO_UNLINK */ + + /* Fallback: !hpux, no EV override, no AUFS (detection, nor detected): + * Don't skip */ + return 0; +#endif /* hpux */ +} + int TclLoadFile( Tcl_Interp *interp, /* Used for error reporting. */ @@ -3353,7 +3436,9 @@ TclLoadFile( * avoids any worries about leaving the copy laying around on exit. */ - if (Tcl_FSDeleteFile(copyToPtr) == TCL_OK) { + if ( + !TclSkipUnlink (copyToPtr) && + (Tcl_FSDeleteFile(copyToPtr) == TCL_OK)) { Tcl_DecrRefCount(copyToPtr); /* -- cgit v0.12 From ceae73bd2872786586283029576d72532b89b659 Mon Sep 17 00:00:00 2001 From: andreask Date: Fri, 23 May 2014 17:17:35 +0000 Subject: Followup on [72c54e1659]. Removed unused variable. --- generic/tclIOUtil.c | 1 - 1 file changed, 1 deletion(-) diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 3d33992..82ffd88 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -3197,7 +3197,6 @@ TclSkipUnlink (Tcl_Obj* shlibFile) #ifdef hpux return 1; #else - int skip = 0; char* skipstr; skipstr = getenv ("TCL_TEMPLOAD_NO_UNLINK"); -- cgit v0.12 From 5f8f27387d73b4da427fb6e29ddd143686a0bddc Mon Sep 17 00:00:00 2001 From: dgp Date: Sat, 24 May 2014 19:56:37 +0000 Subject: Comment out lines of test io-53.4 that appear to do nothing of any value. --- tests/io.test | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/tests/io.test b/tests/io.test index a2e2397..c7da8e6 100644 --- a/tests/io.test +++ b/tests/io.test @@ -7120,17 +7120,17 @@ test io-53.4 {CopyData: background write overflow} {stdio unix openpipe fileeven for {set x 0} {$x < 12} {incr x} { append big $big } - file delete $path(test1) +# file delete $path(test1) file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 { puts ready fcopy stdin stdout -command { set x } vwait x - set f [open $path(test1) w] - fconfigure $f -translation lf - puts $f "done" - close $f +# set f [open $path(test1) w] +# fconfigure $f -translation lf +# puts $f "done" +# close $f } close $f1 set f1 [open "|[list [interpreter] $path(pipe)]" r+] -- cgit v0.12 From 88ab76b3b8d6f0bce701aa143b37d6167c885c9e Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 27 May 2014 13:28:41 +0000 Subject: Move code that can only matter in the first loop iteration out of the loop. --- generic/tclIO.c | 19 ++++++------------- 1 file changed, 6 insertions(+), 13 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 9e1a723..4e325ba 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -2510,12 +2510,6 @@ FlushChannel( return -1; } - /* - * Loop over the queued buffers and attempt to flush as much as possible - * of the queued output to the channel. - */ - - while (1) { /* * If the queue is empty and there is a ready current buffer, OR if * the current buffer is full, then move the current buffer to the @@ -2536,7 +2530,6 @@ FlushChannel( statePtr->outQueueTail = statePtr->curOutPtr; statePtr->curOutPtr = NULL; } - bufPtr = statePtr->outQueueHead; /* * If we are not being called from an async flush and an async flush @@ -2547,13 +2540,13 @@ FlushChannel( return 0; } - /* - * If the output queue is still empty, break out of the while loop. - */ + /* + * Loop over the queued buffers and attempt to flush as much as possible + * of the queued output to the channel. + */ - if (bufPtr == NULL) { - break; /* Out of the "while (1)". */ - } + while (statePtr->outQueueHead) { + bufPtr = statePtr->outQueueHead; /* * Produce the output on the channel. -- cgit v0.12 From a60da763ba80a364d4f77d4c04b40dbf02f557e7 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 28 May 2014 16:54:02 +0000 Subject: Increase size of test io-29.34 so that it more portably tests the case where the OS networking machinery gets backed up and blocks. Added several TODO comments on potential simplifications. --- generic/tclIO.c | 9 +++++++++ tests/io.test | 4 ++-- 2 files changed, 11 insertions(+), 2 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 4e325ba..9e0d7f1 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -2555,6 +2555,7 @@ FlushChannel( PreserveChannelBuffer(bufPtr); toWrite = BytesLeft(bufPtr); if (toWrite == 0) { + /* TODO: This cannot happen. */ written = 0; } else { written = (chanPtr->typePtr->outputProc)(chanPtr->instanceData, @@ -2667,6 +2668,8 @@ FlushChannel( ReleaseChannelBuffer(bufPtr); continue; } else { + /* TODO: Consider detecting and reacting to short writes + * on blocking channels. Ought not happen. See iocmd-24.2. */ wroteSome = 1; } @@ -2700,6 +2703,12 @@ FlushChannel( ResetFlag(statePtr, BG_FLUSH_SCHEDULED); (chanPtr->typePtr->watchProc)(chanPtr->instanceData, statePtr->interestMask); + } else { + /* TODO: If code reaches this point, it means a writable + * event is being handled on the channel, but the channel + * could not in fact be written to. This ought not happen, + * but Unix pipes appear to act this way (see io-53.4). + * Also can imagine broken reflected channels. */ } } diff --git a/tests/io.test b/tests/io.test index c7da8e6..f1248b9 100644 --- a/tests/io.test +++ b/tests/io.test @@ -2786,7 +2786,7 @@ test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMa variable x running set l abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz proc writelots {s l} { - for {set i 0} {$i < 2000} {incr i} { + for {set i 0} {$i < 9000} {incr i} { puts $s $l } } @@ -2817,7 +2817,7 @@ test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMa close $ss vwait [namespace which -variable x] set c -} 2000 +} 9000 test io-29.35 {Tcl_Close vs fileevent vs multiple interpreters} {socket tempNotMac fileevent} { # On Mac, this test screws up sockets such that subsequent tests using port 2828 # either cause errors or panic(). -- cgit v0.12 From c08a9df4d6f77032655cfedda1c62c5c3d171758 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 28 May 2014 17:14:11 +0000 Subject: Expand the IsBufferFull() macro to check non-NULL bufPtr.. --- generic/tclIO.c | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 9e0d7f1..17efa1e 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -12,6 +12,7 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ +#undef NDEBUG #include "tclInt.h" #include "tclIO.h" #include @@ -284,7 +285,7 @@ static int WillRead(Channel *chanPtr); #define IsBufferEmpty(bufPtr) ((bufPtr)->nextAdded == (bufPtr)->nextRemoved) -#define IsBufferFull(bufPtr) ((bufPtr)->nextAdded >= (bufPtr)->bufLength) +#define IsBufferFull(bufPtr) ((bufPtr) && (bufPtr)->nextAdded >= (bufPtr)->bufLength) #define IsBufferOverflowing(bufPtr) ((bufPtr)->nextAdded > (bufPtr)->bufLength) @@ -2516,8 +2517,7 @@ FlushChannel( * queue. */ - if (((statePtr->curOutPtr != NULL) && - IsBufferFull(statePtr->curOutPtr)) + if (IsBufferFull(statePtr->curOutPtr) || (GotFlag(statePtr, BUFFER_READY) && (statePtr->outQueueHead == NULL))) { ResetFlag(statePtr, BUFFER_READY); @@ -2531,6 +2531,8 @@ FlushChannel( statePtr->curOutPtr = NULL; } + assert(!IsBufferFull(statePtr->curOutPtr)); + /* * If we are not being called from an async flush and an async flush * is active, we just return without producing any output. @@ -6122,9 +6124,8 @@ GetInput( */ bufPtr = statePtr->inQueueTail; - if ((bufPtr != NULL) && !IsBufferFull(bufPtr)) { - toRead = SpaceLeft(bufPtr); - } else { + + if ((bufPtr == NULL) || IsBufferFull(bufPtr)) { bufPtr = statePtr->saveInBufPtr; statePtr->saveInBufPtr = NULL; @@ -6154,6 +6155,8 @@ GetInput( statePtr->inQueueTail->nextPtr = bufPtr; } statePtr->inQueueTail = bufPtr; + } else { + toRead = SpaceLeft(bufPtr); } PreserveChannelBuffer(bufPtr); @@ -8827,7 +8830,7 @@ DoRead( /* If there is no full buffer, attempt to create and/or fill one. */ - while (bufPtr == NULL || !IsBufferFull(bufPtr)) { + while (!IsBufferFull(bufPtr)) { int code; moreData: -- cgit v0.12 From 0fe50b37a2a0e487e648136d0f3e77cd4428f1e0 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 28 May 2014 18:24:56 +0000 Subject: Further simplifications to FlushChannel(). This makes clear the BUFFER_READY flag serves no necessary purpose, so it is removed. --- generic/tclIO.c | 114 +++++++++++++++++++------------------------------------- generic/tclIO.h | 5 --- 2 files changed, 38 insertions(+), 81 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 17efa1e..911fa97 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -1149,15 +1149,6 @@ Tcl_UnregisterChannel( */ if (statePtr->refCount <= 0) { - /* - * Ensure that if there is another buffer, it gets flushed whether or - * not we are doing a background flush. - */ - - if ((statePtr->curOutPtr != NULL) && - IsBufferReady(statePtr->curOutPtr)) { - SetFlag(statePtr, BUFFER_READY); - } Tcl_Preserve((ClientData)statePtr); if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED)) { /* @@ -2491,8 +2482,6 @@ FlushChannel( ChannelState *statePtr = chanPtr->state; /* State of the channel stack. */ ChannelBuffer *bufPtr; /* Iterates over buffered output queue. */ - int toWrite; /* Amount of output data in current buffer - * available to be written. */ int written; /* Amount of output data actually written in * current round. */ int errorCode = 0; /* Stores POSIX error codes from channel @@ -2511,36 +2500,42 @@ FlushChannel( return -1; } - /* - * If the queue is empty and there is a ready current buffer, OR if - * the current buffer is full, then move the current buffer to the - * queue. - */ + /* + * Should we shift the current output buffer over to the output queue? + * First check that there are bytes in it. If so then... + * If the output queue is empty, then yes, trusting the caller called + * us only when written bytes ought to be flushed. + * If the current output buffer is full, then yes, so we can meet + * the post-condition that on a successful return to caller we've + * left space in the current output buffer for more writing (the flush + * call was to make new room). + * Otherwise, no. Keep the current output buffer where it is so more + * can be written to it, possibly filling it, to promote more efficient + * buffer usage. + */ - if (IsBufferFull(statePtr->curOutPtr) - || (GotFlag(statePtr, BUFFER_READY) && - (statePtr->outQueueHead == NULL))) { - ResetFlag(statePtr, BUFFER_READY); - statePtr->curOutPtr->nextPtr = NULL; - if (statePtr->outQueueHead == NULL) { - statePtr->outQueueHead = statePtr->curOutPtr; - } else { - statePtr->outQueueTail->nextPtr = statePtr->curOutPtr; - } - statePtr->outQueueTail = statePtr->curOutPtr; - statePtr->curOutPtr = NULL; + bufPtr = statePtr->curOutPtr; + if (bufPtr && BytesLeft(bufPtr) && /* Keep empties off queue */ + (statePtr->outQueueHead == NULL || IsBufferFull(bufPtr))) { + if (statePtr->outQueueHead == NULL) { + statePtr->outQueueHead = bufPtr; + } else { + statePtr->outQueueTail->nextPtr = bufPtr; } + statePtr->outQueueTail = bufPtr; + statePtr->curOutPtr = NULL; + } assert(!IsBufferFull(statePtr->curOutPtr)); - /* - * If we are not being called from an async flush and an async flush - * is active, we just return without producing any output. - */ + /* + * If we are not being called from an async flush and an async flush + * is active, we just return without producing any output. + */ - if (!calledFromAsyncFlush && GotFlag(statePtr, BG_FLUSH_SCHEDULED)) { - return 0; - } + if (!calledFromAsyncFlush && GotFlag(statePtr, BG_FLUSH_SCHEDULED)) { + return 0; + } /* * Loop over the queued buffers and attempt to flush as much as possible @@ -2555,14 +2550,8 @@ FlushChannel( */ PreserveChannelBuffer(bufPtr); - toWrite = BytesLeft(bufPtr); - if (toWrite == 0) { - /* TODO: This cannot happen. */ - written = 0; - } else { - written = (chanPtr->typePtr->outputProc)(chanPtr->instanceData, - RemovePoint(bufPtr), toWrite, &errorCode); - } + written = (chanPtr->typePtr->outputProc)(chanPtr->instanceData, + RemovePoint(bufPtr), BytesLeft(bufPtr), &errorCode); /* * If the write failed completely attempt to start the asynchronous @@ -2668,7 +2657,7 @@ FlushChannel( DiscardOutputQueued(statePtr); ReleaseChannelBuffer(bufPtr); - continue; + break; } else { /* TODO: Consider detecting and reacting to short writes * on blocking channels. Ought not happen. See iocmd-24.2. */ @@ -2689,7 +2678,7 @@ FlushChannel( RecycleBuffer(statePtr, bufPtr, 0); } ReleaseChannelBuffer(bufPtr); - } /* Closes "while (1)". */ + } /* Closes "while". */ /* * If we wrote some data while flushing in the background, we are done. @@ -3256,14 +3245,6 @@ Tcl_Close( ResetFlag(statePtr, CHANNEL_INCLOSE); /* - * Ensure that the last output buffer will be flushed. - */ - - if ((statePtr->curOutPtr != NULL) && IsBufferReady(statePtr->curOutPtr)) { - SetFlag(statePtr, BUFFER_READY); - } - - /* * If this channel supports it, close the read side, since we don't need * it anymore and this will help avoid deadlocks on some channel types. */ @@ -3673,10 +3654,10 @@ static int WillRead(Channel *chanPtr) } if ((chanPtr->typePtr->seekProc != NULL) && (Tcl_OutputBuffered((Tcl_Channel) chanPtr) > 0)) { - if ((chanPtr->state->curOutPtr != NULL) - && IsBufferReady(chanPtr->state->curOutPtr)) { - SetFlag(chanPtr->state, BUFFER_READY); - } + + /* TODO: Consider when channel is nonblocking and this + * FlushChannel() call may not finish the task of shoving + * bytes out. Then what? */ if (FlushChannel(NULL, chanPtr, 0) != 0) { return -1; } @@ -3858,7 +3839,6 @@ Write( } if ((flushed < total) && (GotFlag(statePtr, CHANNEL_UNBUFFERED) || (needNlFlush && GotFlag(statePtr, CHANNEL_LINEBUFFERED)))) { - SetFlag(statePtr, BUFFER_READY); if (FlushChannel(NULL, chanPtr, 0) != 0) { return -1; } @@ -5977,14 +5957,6 @@ Tcl_Flush( return -1; } - /* - * Force current output buffer to be output also. - */ - - if ((statePtr->curOutPtr != NULL) && IsBufferReady(statePtr->curOutPtr)) { - SetFlag(statePtr, BUFFER_READY); - } - result = FlushChannel(NULL, chanPtr, 0); if (result != 0) { return TCL_ERROR; @@ -6298,15 +6270,6 @@ Tcl_Seek( } /* - * If there is data buffered in statePtr->curOutPtr then mark the channel - * as ready to flush before invoking FlushChannel. - */ - - if ((statePtr->curOutPtr != NULL) && IsBufferReady(statePtr->curOutPtr)) { - SetFlag(statePtr, BUFFER_READY); - } - - /* * If the flush fails we cannot recover the original position. In that * case the seek is not attempted because we do not know where the access * position is - instead we return the error. FlushChannel has already @@ -10385,7 +10348,6 @@ DumpFlags( ChanFlag('n', CHANNEL_NONBLOCKING); ChanFlag('l', CHANNEL_LINEBUFFERED); ChanFlag('u', CHANNEL_UNBUFFERED); - ChanFlag('R', BUFFER_READY); ChanFlag('F', BG_FLUSH_SCHEDULED); ChanFlag('c', CHANNEL_CLOSED); ChanFlag('E', CHANNEL_EOF); diff --git a/generic/tclIO.h b/generic/tclIO.h index b8fb5be..59182ec 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -227,11 +227,6 @@ typedef struct ChannelState { * flushed after every newline. */ #define CHANNEL_UNBUFFERED (1<<5) /* Output to the channel must always * be flushed immediately. */ -#define BUFFER_READY (1<<6) /* Current output buffer (the - * curOutPtr field in the channel - * structure) should be output as soon - * as possible even though it may not - * be full. */ #define BG_FLUSH_SCHEDULED (1<<7) /* A background flush of the queued * output buffers has been * scheduled. */ -- cgit v0.12 From 4b98569f897cfeb52b74ea8c8957cc84244d4944 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 28 May 2014 18:49:02 +0000 Subject: Update comment to explain assumptions. --- generic/tclIO.c | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 911fa97..ccd5708 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -3655,9 +3655,16 @@ static int WillRead(Channel *chanPtr) if ((chanPtr->typePtr->seekProc != NULL) && (Tcl_OutputBuffered((Tcl_Channel) chanPtr) > 0)) { - /* TODO: Consider when channel is nonblocking and this - * FlushChannel() call may not finish the task of shoving - * bytes out. Then what? */ + /* + * CAVEAT - The assumption here is that FlushChannel() will + * push out the bytes of any writes that are in progress. + * Since this is a seekable channel, we assume it is not one + * that can block and force bg flushing. Channels we know that + * can do that -- sockets, pipes -- are not seekable. If the + * assumption is wrong, more drastic measures may be required here + * like temporarily setting the channel into blocking mode. + */ + if (FlushChannel(NULL, chanPtr, 0) != 0) { return -1; } -- cgit v0.12 From 78bb5378e9246dab5774d2d17c3397f36f0658cf Mon Sep 17 00:00:00 2001 From: oehhar Date: Thu, 29 May 2014 14:56:10 +0000 Subject: Try not to loose FD_CONNECT by switching monitoring off. --- win/tclWinSock.c | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/win/tclWinSock.c b/win/tclWinSock.c index e18a3dd..ae9ba17 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -1239,13 +1239,17 @@ WaitForSocketEvent( /* * Reset WSAAsyncSelect so we have a fresh set of events pending. + * Don't do that if we are waiting for a connect as this may ignore + * a failed connect. */ - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) UNSELECT, - (LPARAM) infoPtr); - - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, - (LPARAM) infoPtr); + if ( 0 == (events & FD_CONNECT) ) { + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) UNSELECT, + (LPARAM) infoPtr); + + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, + (LPARAM) infoPtr); + } while (1) { if (infoPtr->lastError) { -- cgit v0.12 From 1f197f004a8ea114fe3cd6d3c8ec925200584e1c Mon Sep 17 00:00:00 2001 From: dgp Date: Sat, 31 May 2014 02:30:53 +0000 Subject: Correct the interest masks in the Tcl_CreateFileHandler() calls in PipeWatchProc(). When we are interested in both readable and writable events of a command pipeline channel, we only want the readable from the read end of the pipe, and the writable from the write end of the pipe. --- generic/tclIO.c | 17 ++++++++++++----- tests/io.test | 6 ------ unix/tclUnixPipe.c | 4 ++-- 3 files changed, 14 insertions(+), 13 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 0716074..1c4a5b3 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -2694,11 +2694,18 @@ FlushChannel( (chanPtr->typePtr->watchProc)(chanPtr->instanceData, statePtr->interestMask); } else { - /* TODO: If code reaches this point, it means a writable - * event is being handled on the channel, but the channel - * could not in fact be written to. This ought not happen, - * but Unix pipes appear to act this way (see io-53.4). - * Also can imagine broken reflected channels. */ + + /* + * When we are calledFromAsyncFlush, that means a writable + * state on the channel triggered the call, so we should be + * able to write something. Either we did write something + * and wroteSome should be set, or there was nothing left to + * write in this call, and we've completed the BG flush. + * These are the two cases above. If we get here, that means + * there is some kind failure in the writable event machinery. + */ + + assert(!calledFromAsyncFlush); } } diff --git a/tests/io.test b/tests/io.test index f1248b9..2296986 100644 --- a/tests/io.test +++ b/tests/io.test @@ -7120,17 +7120,12 @@ test io-53.4 {CopyData: background write overflow} {stdio unix openpipe fileeven for {set x 0} {$x < 12} {incr x} { append big $big } -# file delete $path(test1) file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 { puts ready fcopy stdin stdout -command { set x } vwait x -# set f [open $path(test1) w] -# fconfigure $f -translation lf -# puts $f "done" -# close $f } close $f1 set f1 [open "|[list [interpreter] $path(pipe)]" r+] @@ -7138,7 +7133,6 @@ test io-53.4 {CopyData: background write overflow} {stdio unix openpipe fileeven fconfigure $f1 -blocking 0 puts $f1 $big flush $f1 - after 500 set result "" fileevent $f1 read [namespace code { append result [read $f1 1024] diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index d0a5e53..57be08f 100644 --- a/unix/tclUnixPipe.c +++ b/unix/tclUnixPipe.c @@ -1125,7 +1125,7 @@ PipeWatchProc( if (psPtr->inFile) { newmask = mask & (TCL_READABLE | TCL_EXCEPTION); if (newmask) { - Tcl_CreateFileHandler(GetFd(psPtr->inFile), mask, + Tcl_CreateFileHandler(GetFd(psPtr->inFile), newmask, (Tcl_FileProc *) Tcl_NotifyChannel, (ClientData) psPtr->channel); } else { @@ -1135,7 +1135,7 @@ PipeWatchProc( if (psPtr->outFile) { newmask = mask & (TCL_WRITABLE | TCL_EXCEPTION); if (newmask) { - Tcl_CreateFileHandler(GetFd(psPtr->outFile), mask, + Tcl_CreateFileHandler(GetFd(psPtr->outFile), newmask, (Tcl_FileProc *) Tcl_NotifyChannel, (ClientData) psPtr->channel); } else { -- cgit v0.12 From 744e7bfe511513ce1937354615cf3a83da7c388f Mon Sep 17 00:00:00 2001 From: max Date: Mon, 2 Jun 2014 10:57:38 +0000 Subject: Improve robustness of the socket tests against systems that support IPv6, but don't resolve localhost to ::1 (and vice versa for IPv4 and 127.0.0.1). --- tests/socket.test | 135 ++++++++++++++++++++++++++++++------------------------ 1 file changed, 75 insertions(+), 60 deletions(-) diff --git a/tests/socket.test b/tests/socket.test index 5c5b7c3..88d8767 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -99,7 +99,7 @@ set lat2 [expr {($t2-$t1)*3}] # Use the maximum of the two latency calculations, but at least 100ms set latency [expr {$lat1 > $lat2 ? $lat1 : $lat2}] -set latency [expr {$latency > 100 ? $latency : 100}] +set latency [expr {$latency > 100 ? $latency : 1000}] unset t1 t2 s1 s2 lat1 lat2 server # If remoteServerIP or remoteServerPort are not set, check in the environment @@ -137,7 +137,6 @@ foreach {af localhost} { testConstraint supported_$af [expr {![catch {socket -server foo -myaddr $localhost 0} sock]}] catch {close $sock} } -testConstraint supported_any [expr {[testConstraint supported_inet] || [testConstraint supported_inet6]}] set sock [socket -server foo -myaddr localhost 0] set sockname [fconfigure $sock -sockname] @@ -151,6 +150,9 @@ foreach {af localhost} { inet 127.0.0.1 inet6 ::1 } { + if {![testConstraint supported_$af]} { + continue + } set ::tcl::unsupported::socketAF $af # # Check if we're supposed to do tests against the remote server @@ -1728,7 +1730,7 @@ catch {close $remoteProcChan} } unset ::tcl::unsupported::socketAF test socket-14.0.0 {[socket -async] when server only listens on IPv4} \ - -constraints [list socket supported_any localhost_v4] \ + -constraints {socket supported_inet localhost_v4} \ -setup { proc accept {s a p} { global x @@ -1750,7 +1752,7 @@ test socket-14.0.0 {[socket -async] when server only listens on IPv4} \ unset x } -result ok test socket-14.0.1 {[socket -async] when server only listens on IPv6} \ - -constraints [list socket supported_any localhost_v6] \ + -constraints {socket supported_inet6 localhost_v6} \ -setup { proc accept {s a p} { global x @@ -1772,7 +1774,7 @@ test socket-14.0.1 {[socket -async] when server only listens on IPv6} \ unset x } -result ok test socket-14.1 {[socket -async] fileevent while still connecting} \ - -constraints [list socket supported_any] \ + -constraints {socket} \ -setup { proc accept {s a p} { global x @@ -1801,7 +1803,7 @@ test socket-14.1 {[socket -async] fileevent while still connecting} \ unset x } -result {{} ok} test socket-14.2 {[socket -async] fileevent connection refused} \ - -constraints [list socket supported_any] \ + -constraints {socket} \ -body { set client [socket -async localhost [randport]] fileevent $client writable {set x ok} @@ -1815,7 +1817,7 @@ test socket-14.2 {[socket -async] fileevent connection refused} \ unset x after client } -result {ok {connection refused}} test socket-14.3 {[socket -async] when server only listens on IPv6} \ - -constraints [list socket supported_any localhost_v6] \ + -constraints {socket supported_inet6 localhost_v6} \ -setup { proc accept {s a p} { global x @@ -1837,7 +1839,7 @@ test socket-14.3 {[socket -async] when server only listens on IPv6} \ unset x } -result ok test socket-14.4 {[socket -async] and both, readdable and writable fileevents} \ - -constraints [list socket supported_any] \ + -constraints {socket} \ -setup { proc accept {s a p} { puts $s bye @@ -1864,8 +1866,9 @@ test socket-14.4 {[socket -async] and both, readdable and writable fileevents} \ close $server unset x } -result {{} bye} +# FIXME: we should also have an IPv6 counterpart of this test socket-14.5 {[socket -async] which fails before any connect() can be made} \ - -constraints [list socket supported_any] \ + -constraints {socket supported_inet} \ -body { # address from rfc5737 socket -async -myaddr 192.0.2.42 127.0.0.1 [randport] @@ -1873,7 +1876,7 @@ test socket-14.5 {[socket -async] which fails before any connect() can be made} -returnCodes 1 \ -result {couldn't open socket: cannot assign requested address} test socket-14.6.0 {[socket -async] with no event loop and server listening on IPv4} \ - -constraints [list socket supported_inet supported_inet6] \ + -constraints {socket supported_inet localhost_v4} \ -setup { proc accept {s a p} { global x @@ -1904,7 +1907,7 @@ test socket-14.6.0 {[socket -async] with no event loop and server listening on I } \ -result {ok bye} test socket-14.6.1 {[socket -async] with no event loop and server listening on IPv6} \ - -constraints [list socket supported_inet supported_inet6] \ + -constraints {socket supported_inet6 localhost_v6} \ -setup { proc accept {s a p} { global x @@ -1935,9 +1938,10 @@ test socket-14.6.1 {[socket -async] with no event loop and server listening on I } \ -result {ok bye} test socket-14.7.0 {pending [socket -async] and blocking [gets], server is IPv4} \ - -constraints {socket supported_inet supported_inet6} \ + -constraints {socket supported_inet localhost_v4} \ -setup { makeFile { + fileevent stdin readable exit set server [socket -server accept -myaddr 127.0.0.1 0] proc accept {s h p} {puts $s ok; close $s; set ::x 1} puts [lindex [fconfigure $server -sockname] 2] @@ -1950,15 +1954,14 @@ test socket-14.7.0 {pending [socket -async] and blocking [gets], server is IPv4} set sock [socket -async localhost $port] list [fconfigure $sock -error] [gets $sock] [fconfigure $sock -error] } -cleanup { - # make sure the server exits - catch {socket 127.0.0.1 $port} - close $sock close $fd + close $sock } -result {{} ok {}} test socket-14.7.1 {pending [socket -async] and blocking [gets], server is IPv6} \ - -constraints {socket supported_inet supported_inet6} \ + -constraints {socket supported_inet6 localhost_v6} \ -setup { makeFile { + fileevent stdin readable exit set server [socket -server accept -myaddr ::1 0] proc accept {s h p} {puts $s ok; close $s; set ::x 1} puts [lindex [fconfigure $server -sockname] 2] @@ -1971,13 +1974,11 @@ test socket-14.7.1 {pending [socket -async] and blocking [gets], server is IPv6} set sock [socket -async localhost $port] list [fconfigure $sock -error] [gets $sock] [fconfigure $sock -error] } -cleanup { - # make sure the server exits - catch {socket ::1 $port} - close $sock close $fd + close $sock } -result {{} ok {}} test socket-14.7.2 {pending [socket -async] and blocking [gets], no listener} \ - -constraints {socket supported_inet supported_inet6} \ + -constraints {socket} \ -body { set sock [socket -async localhost [randport]] catch {gets $sock} x @@ -1986,9 +1987,10 @@ test socket-14.7.2 {pending [socket -async] and blocking [gets], no listener} \ close $sock } -match glob -result {{error reading "sock*": socket is not connected} {connection refused} {}} test socket-14.8.0 {pending [socket -async] and nonblocking [gets], server is IPv4} \ - -constraints {socket supported_inet supported_inet6} \ + -constraints {socket supported_inet localhost_v4} \ -setup { makeFile { + fileevent stdin readable exit set server [socket -server accept -myaddr 127.0.0.1 0] proc accept {s h p} {puts $s ok; close $s; set ::x 1} puts [lindex [fconfigure $server -sockname] 2] @@ -2006,15 +2008,14 @@ test socket-14.8.0 {pending [socket -async] and nonblocking [gets], server is IP } set x } -cleanup { - # make sure the server exits - catch {socket 127.0.0.1 $port} - close $sock close $fd + close $sock } -result {ok} test socket-14.8.1 {pending [socket -async] and nonblocking [gets], server is IPv6} \ - -constraints {socket supported_inet supported_inet6} \ + -constraints {socket supported_inet6 localhost_v6} \ -setup { makeFile { + fileevent stdin readable exit set server [socket -server accept -myaddr ::1 0] proc accept {s h p} {puts $s ok; close $s; set ::x 1} puts [lindex [fconfigure $server -sockname] 2] @@ -2032,13 +2033,11 @@ test socket-14.8.1 {pending [socket -async] and nonblocking [gets], server is IP } set x } -cleanup { - # make sure the server exits - catch {socket ::1 $port} - close $sock close $fd + close $sock } -result {ok} test socket-14.8.2 {pending [socket -async] and nonblocking [gets], no listener} \ - -constraints {socket supported_inet supported_inet6} \ + -constraints {socket} \ -body { set sock [socket -async localhost [randport]] fconfigure $sock -blocking 0 @@ -2051,9 +2050,10 @@ test socket-14.8.2 {pending [socket -async] and nonblocking [gets], no listener} close $sock } -match glob -result {{error reading "sock*": socket is not connected} {connection refused} {}} test socket-14.9.0 {pending [socket -async] and blocking [puts], server is IPv4} \ - -constraints {socket supported_inet supported_inet6} \ + -constraints {socket supported_inet localhost_v4} \ -setup { makeFile { + fileevent stdin readable exit set server [socket -server accept -myaddr 127.0.0.1 0] proc accept {s h p} {set ::x $s} puts [lindex [fconfigure $server -sockname] 2] @@ -2069,15 +2069,14 @@ test socket-14.9.0 {pending [socket -async] and blocking [puts], server is IPv4} flush $sock list [fconfigure $sock -error] [gets $fd] } -cleanup { - # make sure the server exits - catch {socket 127.0.0.1 $port} - close $sock close $fd + close $sock } -result {{} ok} test socket-14.9.1 {pending [socket -async] and blocking [puts], server is IPv6} \ - -constraints {socket supported_inet supported_inet6} \ + -constraints {socket supported_inet6 localhost_v6} \ -setup { makeFile { + fileevent stdin readable exit set server [socket -server accept -myaddr ::1 0] proc accept {s h p} {set ::x $s} puts [lindex [fconfigure $server -sockname] 2] @@ -2093,15 +2092,14 @@ test socket-14.9.1 {pending [socket -async] and blocking [puts], server is IPv6} flush $sock list [fconfigure $sock -error] [gets $fd] } -cleanup { - # make sure the server exits - catch {socket ::1 $port} - close $sock close $fd + close $sock } -result {{} ok} test socket-14.10.0 {pending [socket -async] and nonblocking [puts], server is IPv4} \ - -constraints {socket supported_inet supported_inet6} \ + -constraints {socket supported_inet localhost_v4} \ -setup { makeFile { + fileevent stdin readable exit set server [socket -server accept -myaddr 127.0.0.1 0] proc accept {s h p} {set ::x $s} puts [lindex [fconfigure $server -sockname] 2] @@ -2120,15 +2118,14 @@ test socket-14.10.0 {pending [socket -async] and nonblocking [puts], server is I vwait x list [fconfigure $sock -error] [gets $fd] } -cleanup { - # make sure the server exits - catch {socket 127.0.0.1 $port} - close $sock close $fd + close $sock } -result {{} ok} test socket-14.10.1 {pending [socket -async] and nonblocking [puts], server is IPv6} \ - -constraints {socket supported_inet supported_inet6} \ + -constraints {socket supported_inet6 localhost_v6} \ -setup { makeFile { + fileevent stdin readable exit set server [socket -server accept -myaddr ::1 0] proc accept {s h p} {set ::x $s} puts [lindex [fconfigure $server -sockname] 2] @@ -2147,13 +2144,11 @@ test socket-14.10.1 {pending [socket -async] and nonblocking [puts], server is I vwait x list [fconfigure $sock -error] [gets $fd] } -cleanup { - # make sure the server exits - catch {socket ::1 $port} - close $sock close $fd + close $sock } -result {{} ok} test socket-14.11.0 {pending [socket -async] and nonblocking [puts], no listener, no flush} \ - -constraints {socket supported_inet supported_inet6} \ + -constraints {socket} \ -body { set sock [socket -async localhost [randport]] fconfigure $sock -blocking 0 @@ -2166,7 +2161,7 @@ test socket-14.11.0 {pending [socket -async] and nonblocking [puts], no listener unset x } -result {socket is not connected} -returnCodes 1 test socket-14.11.1 {pending [socket -async] and nonblocking [puts], no listener, flush} \ - -constraints {socket supported_inet supported_inet6} \ + -constraints {socket knownBug} \ -body { set sock [socket -async localhost [randport]] fconfigure $sock -blocking 0 @@ -2177,10 +2172,10 @@ test socket-14.11.1 {pending [socket -async] and nonblocking [puts], no listener close $sock } -cleanup { catch {close $sock} - unset x + catch {unset x} } -result {socket is not connected} -returnCodes 1 test socket-14.12 {[socket -async] background progress triggered by [fconfigure -error]} \ - -constraints {socket supported_inet supported_inet6} \ + -constraints {socket} \ -body { set s [socket -async localhost [randport]] for {set i 0} {$i < 50} {incr i} { @@ -2194,7 +2189,9 @@ test socket-14.12 {[socket -async] background progress triggered by [fconfigure unset x s } -result {connection refused} -test socket-14.13 {testing writable event when quick failure} -constraints {socket win supported_inet} -body { +test socket-14.13 {testing writable event when quick failure} \ + -constraints {socket win supported_inet} \ + -body { # Test for bug 336441ed59 where a quick background fail was ignored # Test only for windows as socket -async 255.255.255.255 fails @@ -2211,7 +2208,8 @@ test socket-14.13 {testing writable event when quick failure} -constraints {sock after cancel $a1 } -result writable -test socket-14.14 {testing fileevent readable on failed async socket connect} -constraints [list socket] -body { +test socket-14.14 {testing fileevent readable on failed async socket connect} \ + -constraints {socket} -body { # Test for bug 581937ab1e set a1 [after 5000 {set x timeout}] @@ -2235,18 +2233,35 @@ test socket-14.15 {blocking read on async socket should not trigger event handle } -result ok set num 0 -foreach servip {127.0.0.1 ::1 localhost} { - foreach cliip {127.0.0.1 ::1 localhost} { - if {$servip eq $cliip || "localhost" in [list $servip $cliip]} { - set result {-result "sock*" -match glob} - } else { - set result { - -result {couldn't open socket: connection refused} - -returnCodes 1 + +set x {localhost {socket} 127.0.0.1 {supported_inet} ::1 {supported_inet6}} +set resultok {-result "sock*" -match glob} +set resulterr { + -result {couldn't open socket: connection refused} + -returnCodes 1 +} +foreach {servip sc} $x { + foreach {cliip cc} $x { + set constraints socket + lappend constraints $sc $cc + set result $resulterr + switch -- [lsort -unique [list $servip $cliip]] { + localhost - 127.0.0.1 - ::1 { + set result $resultok + } + {127.0.0.1 localhost} { + if {[testConstraint localhost_v4]} { + set result $resultok + } + } + {::1 localhost} { + if {[testConstraint localhost_v6]} { + set result $resultok + } } } test socket-15.1.$num "Connect to $servip from $cliip" \ - -constraints {socket supported_inet supported_inet6} -setup { + -constraints $constraints -setup { set server [socket -server accept -myaddr $servip 0] proc accept {s h p} { close $s } set port [lindex [fconfigure $server -sockname] 2] -- cgit v0.12 From 004361c91defcf9afeb7de00e9d4fcb6a043ae24 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 2 Jun 2014 20:03:14 +0000 Subject: These edits make the tests socket-14.11.[01] stop hanging, but also introduce a whole raft of test failures. WIP. --- generic/tclIO.c | 18 ++++++++++++------ tests/socket.test | 2 +- unix/tclUnixSock.c | 8 +++----- 3 files changed, 16 insertions(+), 12 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 7d94037..5552329 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -3288,10 +3288,15 @@ Tcl_Close( stickyError = 0; if ((statePtr->encoding != NULL) - && !(statePtr->outputEncodingFlags & TCL_ENCODING_START) - && (CheckChannelErrors(statePtr, TCL_WRITABLE) == 0)) { - statePtr->outputEncodingFlags |= TCL_ENCODING_END; - if (WriteChars(chanPtr, "", 0) < 0) { + && !(statePtr->outputEncodingFlags & TCL_ENCODING_START)) { + + int code = CheckChannelErrors(statePtr, TCL_WRITABLE); + + if (code == 0) { + statePtr->outputEncodingFlags |= TCL_ENCODING_END; + code = WriteChars(chanPtr, "", 0); + } + if (code < 0) { stickyError = Tcl_GetErrno(); } @@ -8034,8 +8039,9 @@ Tcl_NotifyChannel( */ if (GotFlag(statePtr, BG_FLUSH_SCHEDULED) && (mask & TCL_WRITABLE)) { - FlushChannel(NULL, chanPtr, 1); - mask &= ~TCL_WRITABLE; + if (0 == FlushChannel(NULL, chanPtr, 1)) { + mask &= ~TCL_WRITABLE; + } } /* diff --git a/tests/socket.test b/tests/socket.test index 88d8767..0c9320a 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -2161,7 +2161,7 @@ test socket-14.11.0 {pending [socket -async] and nonblocking [puts], no listener unset x } -result {socket is not connected} -returnCodes 1 test socket-14.11.1 {pending [socket -async] and nonblocking [puts], no listener, flush} \ - -constraints {socket knownBug} \ + -constraints {socket} \ -body { set sock [socket -async localhost [randport]] fconfigure $sock -blocking 0 diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 08a14d3..47d0681 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -1160,11 +1160,9 @@ out: * the event mechanism one roundtrip through select(). */ - /* Note: disabling this for now as it causes spurious event triggering - * under Linux (see test socket-14.15). */ -#if 0 - Tcl_NotifyChannel(statePtr->channel, TCL_WRITABLE); -#endif + if (statePtr->cachedBlocking == TCL_MODE_NONBLOCKING) { + Tcl_NotifyChannel(statePtr->channel, TCL_WRITABLE); + } } if (error != 0) { /* -- cgit v0.12 From 6c7e545b80e6ce72b0bf64749efedcd61153043a Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 3 Jun 2014 02:26:07 +0000 Subject: These edits make all tests outside of socket-14.* pass on OSX Mavericks. Several socket-14.* tests failing there, and those that pass are very slow about it. Firewall or poor networking configuration may be playing a role. --- generic/tclIO.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 5552329..998fe5e 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -3287,7 +3287,7 @@ Tcl_Close( stickyError = 0; - if ((statePtr->encoding != NULL) + if (GotFlag(statePtr, TCL_WRITABLE) && (statePtr->encoding != NULL) && !(statePtr->outputEncodingFlags & TCL_ENCODING_START)) { int code = CheckChannelErrors(statePtr, TCL_WRITABLE); @@ -3295,6 +3295,8 @@ Tcl_Close( if (code == 0) { statePtr->outputEncodingFlags |= TCL_ENCODING_END; code = WriteChars(chanPtr, "", 0); + statePtr->outputEncodingFlags &= ~TCL_ENCODING_END; + statePtr->outputEncodingFlags |= TCL_ENCODING_START; } if (code < 0) { stickyError = Tcl_GetErrno(); -- cgit v0.12 From 10caa9b482786c7c4010b25d33f05249709aa37c Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 3 Jun 2014 07:26:11 +0000 Subject: [1b0266d8bb] Working towards ensuring that all dict operations are sufficiently strict. --- generic/tclDictObj.c | 46 +++++++++++++++++++++------------------------- tests/dict.test | 42 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 63 insertions(+), 25 deletions(-) diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index e31d708..71d5f5d 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -1026,11 +1026,11 @@ Tcl_DictObjRemove( } } - if (dictPtr->bytes != NULL) { - TclInvalidateStringRep(dictPtr); - } dict = dictPtr->internalRep.twoPtrValue.ptr1; if (DeleteChainEntry(dict, keyPtr)) { + if (dictPtr->bytes != NULL) { + TclInvalidateStringRep(dictPtr); + } dict->epoch++; } return TCL_OK; @@ -1629,8 +1629,7 @@ DictReplaceCmd( Tcl_Obj *const *objv) { Tcl_Obj *dictPtr; - int i, result; - int allocatedDict = 0; + int i; if ((objc < 2) || (objc & 1)) { Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key value ...?"); @@ -1638,18 +1637,17 @@ DictReplaceCmd( } dictPtr = objv[1]; - if (Tcl_IsShared(dictPtr)) { - dictPtr = Tcl_DuplicateObj(dictPtr); - allocatedDict = 1; + if (dictPtr->typePtr != &tclDictType) { + int result = SetDictFromAny(interp, dictPtr); + if (result != TCL_OK) { + return result; + } } for (i=2 ; itypePtr != &tclDictType) { + int result = SetDictFromAny(interp, dictPtr); + if (result != TCL_OK) { + return result; + } } for (i=2 ; i Date: Wed, 4 Jun 2014 03:25:44 +0000 Subject: Valgrind doesn't like use of uninitialized variables. --- unix/tclUnixSock.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 47d0681..a9323c4 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -1024,7 +1024,7 @@ TcpConnect( { socklen_t optlen; int async_callback = statePtr->flags & TCP_ASYNC_PENDING; - int ret = -1, error; + int ret = -1, error = errno; int async = statePtr->flags & TCP_ASYNC_CONNECT; if (async_callback) { -- cgit v0.12 From 6a91e192f8c18d0a05947f6a8129357fe145d945 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 4 Jun 2014 08:15:26 +0000 Subject: more tests, cleaning up the code a bit --- generic/tclDictObj.c | 29 +++++++++++++---------------- tests/dict.test | 29 +++++++++++++++++++++++++++++ 2 files changed, 42 insertions(+), 16 deletions(-) diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 71d5f5d..f3c582c 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -600,7 +600,7 @@ SetDictFromAny( Tcl_Obj *objPtr) { Tcl_HashEntry *hPtr; - int isNew, result; + int isNew; Dict *dict = ckalloc(sizeof(Dict)); InitChainTable(dict); @@ -651,10 +651,9 @@ SetDictFromAny( const char *elemStart; int elemSize, literal; - result = TclFindElement(interp, nextElem, (limit - nextElem), - &elemStart, &nextElem, &elemSize, &literal); - if (result != TCL_OK) { - goto errorExit; + if (TclFindElement(interp, nextElem, (limit - nextElem), + &elemStart, &nextElem, &elemSize, &literal) != TCL_OK) { + goto errorInFindElement; } if (elemStart == limit) { break; @@ -673,11 +672,10 @@ SetDictFromAny( keyPtr->bytes); } - result = TclFindElement(interp, nextElem, (limit - nextElem), - &elemStart, &nextElem, &elemSize, &literal); - if (result != TCL_OK) { + if (TclFindElement(interp, nextElem, (limit - nextElem), + &elemStart, &nextElem, &elemSize, &literal) != TCL_OK) { TclDecrRefCount(keyPtr); - goto errorExit; + goto errorInFindElement; } if (literal) { @@ -722,16 +720,15 @@ SetDictFromAny( Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing value to go with key", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL); - } - result = TCL_ERROR; - - errorExit: - if (interp != NULL) { - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL); + } else { + errorInFindElement: + if (interp != NULL) { + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL); + } } DeleteChainTable(dict); ckfree(dict); - return result; + return TCL_ERROR; } /* diff --git a/tests/dict.test b/tests/dict.test index 1ccad7c..ae6f42a 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -176,9 +176,38 @@ test dict-4.12 {dict replace command: canonicality forced by update} { test dict-4.13 {dict replace command: type check is mandatory} -body { dict replace { a b c d e } } -returnCodes error -result {missing value to go with key} +test dict-4.13a {dict replace command: type check is mandatory} { + catch {dict replace { a b c d e }} -> opt + dict get $opt -errorcode +} {TCL VALUE DICTIONARY} test dict-4.14 {dict replace command: type check is mandatory} -body { dict replace { a b {}c d } } -returnCodes error -result {list element in braces followed by "c" instead of space} +test dict-4.14a {dict replace command: type check is mandatory} { + catch {dict replace { a b {}c d }} -> opt + dict get $opt -errorcode +} {TCL VALUE DICTIONARY} +test dict-4.15 {dict replace command: type check is mandatory} -body { + dict replace { a b ""c d } +} -returnCodes error -result {list element in quotes followed by "c" instead of space} +test dict-4.15a {dict replace command: type check is mandatory} { + catch {dict replace { a b ""c d }} -> opt + dict get $opt -errorcode +} {TCL VALUE DICTIONARY} +test dict-4.16 {dict replace command: type check is mandatory} -body { + dict replace " a b \"c d " +} -returnCodes error -result {unmatched open quote in list} +test dict-4.16a {dict replace command: type check is mandatory} { + catch {dict replace " a b \"c d "} -> opt + dict get $opt -errorcode +} {TCL VALUE DICTIONARY} +test dict-4.17 {dict replace command: type check is mandatory} -body { + dict replace " a b \{c d " +} -returnCodes error -result {unmatched open brace in list} +test dict-4.17a {dict replace command: type check is mandatory} { + catch {dict replace " a b \{c d "} -> opt + dict get $opt -errorcode +} {TCL VALUE DICTIONARY} test dict-5.1 {dict remove command} {dict remove {a b c d} a} {c d} test dict-5.2 {dict remove command} {dict remove {a b c d} c} {a b} -- cgit v0.12 From 3189f48d19ee5fe595f856ca7d755f61414cfbef Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 4 Jun 2014 16:36:25 +0000 Subject: Revise DiscardOutput() to account for revisions to the loop in FlushChannel() which is its only caller. We need to discard the curOutPtr buffer as well, and not count on another pass through the loop to attempt to flush it (and raise the same failure again?). --- generic/tclIO.c | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/generic/tclIO.c b/generic/tclIO.c index ed94bfe..b7135e9 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -2415,6 +2415,11 @@ DiscardOutputQueued( } statePtr->outQueueHead = NULL; statePtr->outQueueTail = NULL; + bufPtr = statePtr->curOutPtr; + if (bufPtr && BytesLeft(bufPtr)) { + statePtr->curOutPtr = NULL; + RecycleBuffer(statePtr, bufPtr, 0); + } } /* -- cgit v0.12 From 45fd54872fa0bcff3d89f8077d9a7ca220bba89f Mon Sep 17 00:00:00 2001 From: andy Date: Wed, 4 Jun 2014 21:45:29 +0000 Subject: Add missing calls to Tcl_DecrRefCount() in string object man page examples. --- doc/StringObj.3 | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/doc/StringObj.3 b/doc/StringObj.3 index d81f23d..cf8f6d3 100644 --- a/doc/StringObj.3 +++ b/doc/StringObj.3 @@ -293,6 +293,7 @@ of \fBTcl_Format\fR with functionality equivalent to: Tcl_Obj *newPtr = \fBTcl_Format\fR(interp, format, objc, objv); if (newPtr == NULL) return TCL_ERROR; \fBTcl_AppendObjToObj\fR(objPtr, newPtr); +\fBTcl_DecrRefCount\fR(newPtr); return TCL_OK; .CE .PP @@ -337,7 +338,9 @@ Compile-time protection may be provided by some compilers. of \fBTcl_ObjPrintf\fR with functionality equivalent to .PP .CS -\fBTcl_AppendObjToObj\fR(objPtr, \fBTcl_ObjPrintf\fR(format, ...)); +Tcl_Obj *newPtr = \fBTcl_ObjPrintf\fR(format, ...); +\fBTcl_AppendObjToObj\fR(objPtr, newPtr); +\fBTcl_DecrRefCount\fR(newPtr); .CE .PP but with greater convenience and efficiency when the appending -- cgit v0.12 From ba7b49d9c4a0bf981789fd0a2b29ea5244b4680b Mon Sep 17 00:00:00 2001 From: andreask Date: Thu, 5 Jun 2014 00:22:59 +0000 Subject: Fixed a tricky interaction of IO system and encodings which could result in a panic. The relevant function is ReadChars() (short RC in the following). When the encoding and translation transforms deliver more characters than were requested the iterative algorithm used by RC reduces the value of "dstLimit" (= the number of bytes allowed to be copied into the destination buffer) to force the next round to deliver less characters, hopefully the number requested. The existing code used the byte located just after the last wanted character to determine the new limit. The resulting value could _undershoot_ the best possible limit because Tcl_ExternalToUtf would effectively reduce this limit further, by TCL_UTF_MAX+1, to have enough space for a single multi-byte character in the buffer, and a closing '\0' as well. One effect of this were additional calls to ReadChars() to retrieve the characters missed by a call with an undershot limit. In the limit (sic) however this was also able to cause a full-blown "Buffer Underflow" panic if the original request was for less than TCL_UTF_MAX characters (*), and we are using a single-byte encoding like iso-8859-1. Because then the undershot dstLimit would prevent the next round from copying anything, and causing it to try and consolidate the current buffer with the next buffer, thinking that it had to merge a multi-byte character split across buffer boundaries. (Ad *) For example because the previous call had undershot already and left only such a small amount of characters behind! The basic fix to the problem is to add TCL_UTF_MAX back to the limit, like is done in all the (three) other places in RC setting a new one. Note however that this naive fix may generate a new limit which is the same as the old, or possibly larger. If that happens we act very conservatively and reduce the limit by only one byte instead. While I believe that this last conservative approach will never reduce the limit to TCL_UTF_MAX or less before reaching a state where it returnds the exact amount of requested characters I still added a check against this situation anyway, causing a new panic if triggered. --- generic/tclIO.c | 23 +++++++++++++++++++++-- 1 file changed, 21 insertions(+), 2 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index b7135e9..e414668 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -5596,9 +5596,27 @@ ReadChars( /* * We read more chars than allowed. Reset limits to * prevent that and try again. + * + * Note how we are adding back TCL_UTF_MAX to ensure that the + * Tcl_External2Utf invoked by the next round will have enough + * space in the destination for at least one multi-byte + * character. Without that nothing will be copied and the system + * will try to consolidate the entire current and next buffer, + * likely triggering the "Buffer Underflow" panic. */ - dstLimit = Tcl_UtfAtIndex(dst, charsToRead + 1) - dst; + int newLimit = Tcl_UtfAtIndex(dst, charsToRead + 1) - dst + TCL_UTF_MAX; + + if (newLimit >= dstLimit) { + dstLimit --; + } else { + dstLimit = newLimit; + } + + if (dstLimit <= TCL_UTF_MAX) { + Tcl_Panic ("Not enough space left for a single multi-byte character."); + } + statePtr->flags = savedFlags; statePtr->inputEncodingFlags = savedIEFlags; statePtr->inputEncodingState = savedState; @@ -5661,7 +5679,8 @@ ReadChars( */ if (nextPtr->nextRemoved - srcLen < 0) { - Tcl_Panic("Buffer Underflow, BUFFER_PADDING not enough"); + Tcl_Panic("Buffer Underflow, BUFFER_PADDING not enough (%d < %d)", + nextPtr->nextRemoved, srcLen); } nextPtr->nextRemoved -= srcLen; -- cgit v0.12 From 3eb959fc935f4f1a92c7527be675245c0def5dfd Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 5 Jun 2014 15:17:29 +0000 Subject: When too many chars are read by ReadChars() and we trim the limits to get it right on the next pass, don't forget the TCL_UTF_MAX padding demanded by Tcl_ExternalToUtf(). (Thanks for finding that, aku!) Fix the factorPtr management. It was just totaly wrong. The factor should be a ratio of the record of bytes read to the record of chars read. With those fixes, new test io-12.6 covers the "too many chars" code. --- generic/tclIO.c | 15 +++++++++++---- tests/io.test | 33 +++++++++++++++++++++++++++++++++ 2 files changed, 44 insertions(+), 4 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index b7135e9..308e7a9 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -5595,10 +5595,13 @@ ReadChars( /* * We read more chars than allowed. Reset limits to - * prevent that and try again. + * prevent that and try again. Don't forget the extra + * padding of TCL_UTF_MAX - 1 bytes demanded by the + * Tcl_ExternalToUtf() call! */ - dstLimit = Tcl_UtfAtIndex(dst, charsToRead + 1) - dst; + dstLimit = Tcl_UtfAtIndex(dst, charsToRead + 1) + + TCL_UTF_MAX - 1 - dst; statePtr->flags = savedFlags; statePtr->inputEncodingFlags = savedIEFlags; statePtr->inputEncodingState = savedState; @@ -5676,8 +5679,12 @@ ReadChars( consume: bufPtr->nextRemoved += srcRead; - if (dstWrote > srcRead + 1) { - *factorPtr = dstWrote * UTF_EXPANSION_FACTOR / srcRead; + /* + * If this read contained multibyte characters, revise factorPtr + * so the next read will allocate bigger buffers. + */ + if (numChars && numChars < srcRead) { + *factorPtr = srcRead * UTF_EXPANSION_FACTOR / numChars; } Tcl_SetObjLength(objPtr, numBytes + dstWrote); return numChars; diff --git a/tests/io.test b/tests/io.test index f1248b9..a1625ba 100644 --- a/tests/io.test +++ b/tests/io.test @@ -1445,6 +1445,39 @@ test io-12.5 {ReadChars: fileevents on partial characters} {stdio openpipe filee lappend x [catch {close $f} msg] $msg set x } "{} timeout {} timeout \u7266 {} eof 0 {}" +test io-12.6 {ReadChars: too many chars read} { + proc driver {cmd args} { + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) [encoding convertto utf-8 \ + [string repeat \uBEEF 20][string repeat . 20]] + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } + } + set c [chan create read [namespace which driver]] + chan configure $c -encoding utf-8 + while {![eof $c]} { + read $c 15 + } + close $c +} {} test io-13.1 {TranslateInputEOL: cr mode} {} { set f [open $path(test1) w] -- cgit v0.12 From bb4c894bca0bed064a485d8896bc22bb352d3d66 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 5 Jun 2014 19:06:08 +0000 Subject: Test socket-2.12 covers the DiscardOutput() update. --- tests/socket.test | 40 +++++++++++++++++++++++++++++++++++++++- 1 file changed, 39 insertions(+), 1 deletion(-) diff --git a/tests/socket.test b/tests/socket.test index 1b7c5fa..2953c39 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -577,7 +577,45 @@ test socket-2.11 {detecting new data} {socket} { close $sock set result } {a:one b: c:two} - +test socket-2.12 {} {socket stdio} { + file delete $path(script) + set f [open $path(script) w] + puts $f { + set server [socket -server accept_client 0] + puts [lindex [chan configure $server -sockname] 2] + proc accept_client { client host port } { + chan configure $client -blocking 0 -buffering line + write_line $client + } + proc write_line client { + if { [catch { chan puts $client [string repeat . 720000]}] } { + puts [catch {chan close $client}] + } else { + puts signal1 + after 0 write_line $client + } + } + chan event stdin readable {set forever now} + vwait forever + exit + } + close $f + set f [open "|[list [interpreter] $path(script)]" r+] + gets $f port + set sock [socket 127.0.0.1 $port] + chan event $sock readable [list read_lines $sock $f] + proc read_lines { sock pipe } { + gets $pipe + chan close $sock + chan event $pipe readable [list readpipe $pipe] + } + proc readpipe {pipe} { + while {![string is integer [set ::done [gets $pipe]]]} {} + } + vwait ::done + close $f + set ::done +} 0 test socket-3.1 {socket conflict} {socket stdio} { file delete $path(script) -- cgit v0.12 From 6a99b9a54626111350b21ac428bb850942170ba4 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 7 Jun 2014 14:18:40 +0000 Subject: Improved the error messages. We do not want parsing an invalid dictionary to give errors about lists! As compensation, we get greater precision in the errorcode. --- generic/tclDictObj.c | 14 +++---- generic/tclInt.h | 4 ++ generic/tclUtil.c | 105 +++++++++++++++++++++++++++++++++++++++++---------- tests/dict.test | 20 +++++----- 4 files changed, 104 insertions(+), 39 deletions(-) diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index f3c582c..77f66fb 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -651,9 +651,9 @@ SetDictFromAny( const char *elemStart; int elemSize, literal; - if (TclFindElement(interp, nextElem, (limit - nextElem), + if (TclFindDictElement(interp, nextElem, (limit - nextElem), &elemStart, &nextElem, &elemSize, &literal) != TCL_OK) { - goto errorInFindElement; + goto errorInFindDictElement; } if (elemStart == limit) { break; @@ -672,10 +672,10 @@ SetDictFromAny( keyPtr->bytes); } - if (TclFindElement(interp, nextElem, (limit - nextElem), + if (TclFindDictElement(interp, nextElem, (limit - nextElem), &elemStart, &nextElem, &elemSize, &literal) != TCL_OK) { TclDecrRefCount(keyPtr); - goto errorInFindElement; + goto errorInFindDictElement; } if (literal) { @@ -720,12 +720,8 @@ SetDictFromAny( Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing value to go with key", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL); - } else { - errorInFindElement: - if (interp != NULL) { - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL); - } } + errorInFindDictElement: DeleteChainTable(dict); ckfree(dict); return TCL_ERROR; diff --git a/generic/tclInt.h b/generic/tclInt.h index b1a368e..9a2e8dd 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2881,6 +2881,10 @@ MODULE_SCOPE void TclContinuationsCopy(Tcl_Obj *objPtr, MODULE_SCOPE int TclConvertElement(const char *src, int length, char *dst, int flags); MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr); +MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp, + const char *dict, int dictLength, + const char **elementPtr, const char **nextPtr, + int *sizePtr, int *literalPtr); /* TIP #280 - Modified token based evulation, with line information. */ MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script, int numBytes, int flags, int line, diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 2d00adf..ae3adae 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -111,7 +111,11 @@ static Tcl_HashTable * GetThreadHash(Tcl_ThreadDataKey *keyPtr); static int SetEndOffsetFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfEndOffset(Tcl_Obj *objPtr); - +static int FindElement(Tcl_Interp *interp, const char *string, + int stringLength, const char *typeStr, + const char *typeCode, const char **elementPtr, + const char **nextPtr, int *sizePtr, + int *literalPtr); /* * The following is the Tcl object type definition for an object that * represents a list index in the form, "end-offset". It is used as a @@ -237,7 +241,7 @@ const Tcl_ObjType tclEndOffsetType = { * of either braces or quotes to delimit it. * * This collection of parsing rules is implemented in the routine - * TclFindElement(). + * FindElement(). * * In order to produce lists that can be parsed by these rules, we need the * ability to distinguish between characters that are part of a list element @@ -505,9 +509,70 @@ TclFindElement( * does not/does require a call to * TclCopyAndCollapse() by the caller. */ { - const char *p = list; + return FindElement(interp, list, listLength, "list", "LIST", elementPtr, + nextPtr, sizePtr, literalPtr); +} + +int +TclFindDictElement( + Tcl_Interp *interp, /* Interpreter to use for error reporting. If + * NULL, then no error message is left after + * errors. */ + const char *dict, /* Points to the first byte of a string + * containing a Tcl dictionary with zero or + * more keys and values (possibly in + * braces). */ + int dictLength, /* Number of bytes in the dict's string. */ + const char **elementPtr, /* Where to put address of first significant + * character in the first element (i.e., key + * or value) of dict. */ + const char **nextPtr, /* Fill in with location of character just + * after all white space following end of + * element (next arg or end of list). */ + int *sizePtr, /* If non-zero, fill in with size of + * element. */ + int *literalPtr) /* If non-zero, fill in with non-zero/zero to + * indicate that the substring of *sizePtr + * bytes starting at **elementPtr is/is not + * the literal key or value and therefore + * does not/does require a call to + * TclCopyAndCollapse() by the caller. */ +{ + return FindElement(interp, dict, dictLength, "dict", "DICTIONARY", + elementPtr, nextPtr, sizePtr, literalPtr); +} + +static int +FindElement( + Tcl_Interp *interp, /* Interpreter to use for error reporting. If + * NULL, then no error message is left after + * errors. */ + const char *string, /* Points to the first byte of a string + * containing a Tcl list or dictionary with + * zero or more elements (possibly in + * braces). */ + int stringLength, /* Number of bytes in the string. */ + const char *typeStr, /* The name of the type of thing we are + * parsing, for error messages. */ + const char *typeCode, /* The type code for thing we are parsing, for + * error messages. */ + const char **elementPtr, /* Where to put address of first significant + * character in first element. */ + const char **nextPtr, /* Fill in with location of character just + * after all white space following end of + * argument (next arg or end of list/dict). */ + int *sizePtr, /* If non-zero, fill in with size of + * element. */ + int *literalPtr) /* If non-zero, fill in with non-zero/zero to + * indicate that the substring of *sizePtr + * bytes starting at **elementPtr is/is not + * the literal list/dict element and therefore + * does not/does require a call to + * TclCopyAndCollapse() by the caller. */ +{ + const char *p = string; const char *elemStart; /* Points to first byte of first element. */ - const char *limit; /* Points just after list's last byte. */ + const char *limit; /* Points just after list/dict's last byte. */ int openBraces = 0; /* Brace nesting level during parse. */ int inQuotes = 0; int size = 0; /* lint. */ @@ -517,11 +582,11 @@ TclFindElement( /* * Skim off leading white space and check for an opening brace or quote. - * We treat embedded NULLs in the list as bytes belonging to a list - * element. + * We treat embedded NULLs in the list/dict as bytes belonging to a list + * element (or dictionary key or value). */ - limit = (list + listLength); + limit = (string + stringLength); while ((p < limit) && (TclIsSpaceProc(*p))) { p++; } @@ -582,9 +647,9 @@ TclFindElement( p2++; } Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "list element in braces followed by \"%.*s\" " - "instead of space", (int) (p2-p), p)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "JUNK", + "%s element in braces followed by \"%.*s\" " + "instead of space", typeStr, (int) (p2-p), p)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "JUNK", NULL); } return TCL_ERROR; @@ -651,9 +716,9 @@ TclFindElement( p2++; } Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "list element in quotes followed by \"%.*s\" " - "instead of space", (int) (p2-p), p)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "JUNK", + "%s element in quotes followed by \"%.*s\" " + "instead of space", typeStr, (int) (p2-p), p)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "JUNK", NULL); } return TCL_ERROR; @@ -664,23 +729,23 @@ TclFindElement( } /* - * End of list: terminate element. + * End of list/dict: terminate element. */ if (p == limit) { if (openBraces != 0) { if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "unmatched open brace in list", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "BRACE", + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unmatched open brace in %s", typeStr)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "BRACE", NULL); } return TCL_ERROR; } else if (inQuotes) { if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "unmatched open quote in list", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "QUOTE", + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unmatched open quote in %s", typeStr)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "QUOTE", NULL); } return TCL_ERROR; diff --git a/tests/dict.test b/tests/dict.test index ae6f42a..1439af9 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -182,32 +182,32 @@ test dict-4.13a {dict replace command: type check is mandatory} { } {TCL VALUE DICTIONARY} test dict-4.14 {dict replace command: type check is mandatory} -body { dict replace { a b {}c d } -} -returnCodes error -result {list element in braces followed by "c" instead of space} +} -returnCodes error -result {dict element in braces followed by "c" instead of space} test dict-4.14a {dict replace command: type check is mandatory} { catch {dict replace { a b {}c d }} -> opt dict get $opt -errorcode -} {TCL VALUE DICTIONARY} +} {TCL VALUE DICTIONARY JUNK} test dict-4.15 {dict replace command: type check is mandatory} -body { dict replace { a b ""c d } -} -returnCodes error -result {list element in quotes followed by "c" instead of space} +} -returnCodes error -result {dict element in quotes followed by "c" instead of space} test dict-4.15a {dict replace command: type check is mandatory} { catch {dict replace { a b ""c d }} -> opt dict get $opt -errorcode -} {TCL VALUE DICTIONARY} +} {TCL VALUE DICTIONARY JUNK} test dict-4.16 {dict replace command: type check is mandatory} -body { dict replace " a b \"c d " -} -returnCodes error -result {unmatched open quote in list} +} -returnCodes error -result {unmatched open quote in dict} test dict-4.16a {dict replace command: type check is mandatory} { catch {dict replace " a b \"c d "} -> opt dict get $opt -errorcode -} {TCL VALUE DICTIONARY} +} {TCL VALUE DICTIONARY QUOTE} test dict-4.17 {dict replace command: type check is mandatory} -body { dict replace " a b \{c d " -} -returnCodes error -result {unmatched open brace in list} +} -returnCodes error -result {unmatched open brace in dict} test dict-4.17a {dict replace command: type check is mandatory} { catch {dict replace " a b \{c d "} -> opt dict get $opt -errorcode -} {TCL VALUE DICTIONARY} +} {TCL VALUE DICTIONARY BRACE} test dict-5.1 {dict remove command} {dict remove {a b c d} a} {c d} test dict-5.2 {dict remove command} {dict remove {a b c d} c} {a b} @@ -234,7 +234,7 @@ test dict-5.11 {dict remove command: type check is mandatory} -body { } -returnCodes error -result {missing value to go with key} test dict-5.12 {dict remove command: type check is mandatory} -body { dict remove { a b {}c d } -} -returnCodes error -result {list element in braces followed by "c" instead of space} +} -returnCodes error -result {dict element in braces followed by "c" instead of space} test dict-6.1 {dict keys command} {dict keys {a b}} a test dict-6.2 {dict keys command} {dict keys {c d}} c @@ -1296,7 +1296,7 @@ test dict-20.24 {dict merge command: type check is mandatory} -body { } -returnCodes error -result {missing value to go with key} test dict-20.25 {dict merge command: type check is mandatory} -body { dict merge { a b {}c d } -} -returnCodes error -result {list element in braces followed by "c" instead of space} +} -returnCodes error -result {dict element in braces followed by "c" instead of space} test dict-21.1 {dict update command} -returnCodes 1 -body { dict update -- cgit v0.12 From 2621d5a21a7d9f2313adcc8d3ea4595ee65c1c20 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 13 Jun 2014 21:15:13 +0000 Subject: Draft test for [1758a0b603]. --- tests/socket.test | 41 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 41 insertions(+) diff --git a/tests/socket.test b/tests/socket.test index 2953c39..b390627 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -616,6 +616,47 @@ test socket-2.12 {} {socket stdio} { close $f set ::done } 0 +test socket-2.13 {Bug 1758a0b603} {socket stdio} { + file delete $path(script) + set f [open $path(script) w] + puts $f { + set server [socket -server accept 0] + puts [lindex [chan configure $server -sockname] 2] + proc accept { client host port } { + chan configure $client -blocking 0 -buffering line -buffersize 1 + puts $client [string repeat . 720000] + puts ready + chan event $client writable [list setup $client] + } + proc setup client { + chan event $client writable {set forever write} + after 5 {set forever timeout} + } + vwait forever + puts $forever + } + close $f + set pipe [open |[list [interpreter] $path(script)] r] + gets $pipe port + set sock [socket localhost $port] + chan configure $sock -blocking 0 -buffering line + chan event $sock readable [list read_lines $sock $pipe ] + proc read_lines { sock pipe } { + gets $pipe + gets $sock line + after idle [list stop $sock $pipe] + chan event $sock readable {} + } + proc stop {sock pipe} { + variable done + close $sock + set done [gets $pipe] + } + variable done + vwait [namespace which -variable done] + close $pipe + set done +} write test socket-3.1 {socket conflict} {socket stdio} { file delete $path(script) -- cgit v0.12 From 08d90963621681f9cbaed569b85284792c3faa51 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 15 Jun 2014 07:52:57 +0000 Subject: Make [dict replace] and [dict remove] guarantee result canonicality. --- generic/tclDictObj.c | 149 ++++++++++++++++++++++----------------------------- tests/dict.test | 30 +++++++---- 2 files changed, 84 insertions(+), 95 deletions(-) diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 77f66fb..a057b8a 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -770,10 +770,9 @@ TclTraceDictPath( Dict *dict, *newDict; int i; - if (dictPtr->typePtr != &tclDictType) { - if (SetDictFromAny(interp, dictPtr) != TCL_OK) { - return NULL; - } + if (dictPtr->typePtr != &tclDictType + && SetDictFromAny(interp, dictPtr) != TCL_OK) { + return NULL; } dict = dictPtr->internalRep.twoPtrValue.ptr1; if (flags & DICT_PATH_UPDATE) { @@ -811,10 +810,9 @@ TclTraceDictPath( Tcl_SetHashValue(hPtr, tmpObj); } else { tmpObj = Tcl_GetHashValue(hPtr); - if (tmpObj->typePtr != &tclDictType) { - if (SetDictFromAny(interp, tmpObj) != TCL_OK) { - return NULL; - } + if (tmpObj->typePtr != &tclDictType + && SetDictFromAny(interp, tmpObj) != TCL_OK) { + return NULL; } } @@ -909,12 +907,9 @@ Tcl_DictObjPut( Tcl_Panic("%s called with shared object", "Tcl_DictObjPut"); } - if (dictPtr->typePtr != &tclDictType) { - int result = SetDictFromAny(interp, dictPtr); - - if (result != TCL_OK) { - return result; - } + if (dictPtr->typePtr != &tclDictType + && SetDictFromAny(interp, dictPtr) != TCL_OK) { + return TCL_ERROR; } if (dictPtr->bytes != NULL) { @@ -963,12 +958,10 @@ Tcl_DictObjGet( Dict *dict; Tcl_HashEntry *hPtr; - if (dictPtr->typePtr != &tclDictType) { - int result = SetDictFromAny(interp, dictPtr); - if (result != TCL_OK) { - *valuePtrPtr = NULL; - return result; - } + if (dictPtr->typePtr != &tclDictType + && SetDictFromAny(interp, dictPtr) != TCL_OK) { + *valuePtrPtr = NULL; + return TCL_ERROR; } dict = dictPtr->internalRep.twoPtrValue.ptr1; @@ -1012,11 +1005,9 @@ Tcl_DictObjRemove( Tcl_Panic("%s called with shared object", "Tcl_DictObjRemove"); } - if (dictPtr->typePtr != &tclDictType) { - int result = SetDictFromAny(interp, dictPtr); - if (result != TCL_OK) { - return result; - } + if (dictPtr->typePtr != &tclDictType + && SetDictFromAny(interp, dictPtr) != TCL_OK) { + return TCL_ERROR; } dict = dictPtr->internalRep.twoPtrValue.ptr1; @@ -1055,11 +1046,9 @@ Tcl_DictObjSize( { Dict *dict; - if (dictPtr->typePtr != &tclDictType) { - int result = SetDictFromAny(interp, dictPtr); - if (result != TCL_OK) { - return result; - } + if (dictPtr->typePtr != &tclDictType + && SetDictFromAny(interp, dictPtr) != TCL_OK) { + return TCL_ERROR; } dict = dictPtr->internalRep.twoPtrValue.ptr1; @@ -1109,12 +1098,9 @@ Tcl_DictObjFirst( Dict *dict; ChainEntry *cPtr; - if (dictPtr->typePtr != &tclDictType) { - int result = SetDictFromAny(interp, dictPtr); - - if (result != TCL_OK) { - return result; - } + if (dictPtr->typePtr != &tclDictType + && SetDictFromAny(interp, dictPtr) != TCL_OK) { + return TCL_ERROR; } dict = dictPtr->internalRep.twoPtrValue.ptr1; @@ -1497,7 +1483,7 @@ DictCreateCmd( /* * The next command is assumed to never fail... */ - Tcl_DictObjPut(interp, dictObj, objv[i], objv[i+1]); + Tcl_DictObjPut(NULL, dictObj, objv[i], objv[i+1]); } Tcl_SetObjResult(interp, dictObj); return TCL_OK; @@ -1630,17 +1616,18 @@ DictReplaceCmd( } dictPtr = objv[1]; - if (dictPtr->typePtr != &tclDictType) { - int result = SetDictFromAny(interp, dictPtr); - if (result != TCL_OK) { - return result; - } + if (dictPtr->typePtr != &tclDictType + && SetDictFromAny(interp, dictPtr) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_IsShared(dictPtr)) { + dictPtr = Tcl_DuplicateObj(dictPtr); + } + if (dictPtr->bytes != NULL) { + TclInvalidateStringRep(dictPtr); } for (i=2 ; itypePtr != &tclDictType) { - int result = SetDictFromAny(interp, dictPtr); - if (result != TCL_OK) { - return result; - } + if (dictPtr->typePtr != &tclDictType + && SetDictFromAny(interp, dictPtr) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_IsShared(dictPtr)) { + dictPtr = Tcl_DuplicateObj(dictPtr); + } + if (dictPtr->bytes != NULL) { + TclInvalidateStringRep(dictPtr); } for (i=2 ; itypePtr != &tclDictType) { - if (SetDictFromAny(interp, targetObj) != TCL_OK) { - return TCL_ERROR; - } + if (targetObj->typePtr != &tclDictType + && SetDictFromAny(interp, targetObj) != TCL_OK) { + return TCL_ERROR; } if (objc == 2) { @@ -1824,12 +1811,9 @@ DictKeysCmd( * need. [Bug 1705778, leak K04] */ - if (objv[1]->typePtr != &tclDictType) { - int result = SetDictFromAny(interp, objv[1]); - - if (result != TCL_OK) { - return result; - } + if (objv[1]->typePtr != &tclDictType + && SetDictFromAny(interp, objv[1]) != TCL_OK) { + return TCL_ERROR; } if (objc == 3) { @@ -2045,11 +2029,9 @@ DictInfoCmd( } dictPtr = objv[1]; - if (dictPtr->typePtr != &tclDictType) { - int result = SetDictFromAny(interp, dictPtr); - if (result != TCL_OK) { - return result; - } + if (dictPtr->typePtr != &tclDictType + && SetDictFromAny(interp, dictPtr) != TCL_OK) { + return TCL_ERROR; } dict = dictPtr->internalRep.twoPtrValue.ptr1; @@ -2141,10 +2123,10 @@ DictIncrCmd( */ mp_clear(&increment); - Tcl_DictObjPut(interp, dictPtr, objv[2], objv[3]); + Tcl_DictObjPut(NULL, dictPtr, objv[2], objv[3]); } } else { - Tcl_DictObjPut(interp, dictPtr, objv[2], Tcl_NewIntObj(1)); + Tcl_DictObjPut(NULL, dictPtr, objv[2], Tcl_NewIntObj(1)); } } else { /* @@ -2153,7 +2135,7 @@ DictIncrCmd( if (Tcl_IsShared(valuePtr)) { valuePtr = Tcl_DuplicateObj(valuePtr); - Tcl_DictObjPut(interp, dictPtr, objv[2], valuePtr); + Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr); } if (objc == 4) { code = TclIncrObj(interp, valuePtr, objv[3]); @@ -2253,7 +2235,7 @@ DictLappendCmd( } if (allocatedValue) { - Tcl_DictObjPut(interp, dictPtr, objv[2], valuePtr); + Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr); } else if (dictPtr->bytes != NULL) { TclInvalidateStringRep(dictPtr); } @@ -2328,7 +2310,7 @@ DictAppendCmd( Tcl_AppendObjToObj(valuePtr, objv[i]); } - Tcl_DictObjPut(interp, dictPtr, objv[2], valuePtr); + Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr); resultPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr, TCL_LEAVE_ERR_MSG); @@ -2938,12 +2920,12 @@ DictFilterCmd( Tcl_DictObjDone(&search); Tcl_DictObjGet(interp, objv[1], objv[3], &valueObj); if (valueObj != NULL) { - Tcl_DictObjPut(interp, resultObj, objv[3], valueObj); + Tcl_DictObjPut(NULL, resultObj, objv[3], valueObj); } } else { while (!done) { if (Tcl_StringMatch(TclGetString(keyObj), pattern)) { - Tcl_DictObjPut(interp, resultObj, keyObj, valueObj); + Tcl_DictObjPut(NULL, resultObj, keyObj, valueObj); } Tcl_DictObjNext(&search, &keyObj, &valueObj, &done); } @@ -2961,7 +2943,7 @@ DictFilterCmd( for (i=3 ; i opt dict get $opt -errorcode } {TCL VALUE DICTIONARY BRACE} +test dict-4.18 {dict replace command: canonicality forcing doesn't leak} { + set example { a b c d } + list $example [dict replace $example] +} {{ a b c d } {a b c d}} test dict-5.1 {dict remove command} {dict remove {a b c d} a} {c d} test dict-5.2 {dict remove command} {dict remove {a b c d} c} {a b} @@ -220,12 +224,12 @@ test dict-5.6 {dict remove command} {dict remove {a b} c} {a b} test dict-5.7 {dict remove command} -returnCodes error -body { dict remove } -result {wrong # args: should be "dict remove dictionary ?key ...?"} -test dict-5.8 {dict remove command: canonicality not forced} { - dict remove { a b c d } -} { a b c d } -test dict-5.9 {dict remove command: canonicality not forced} { - dict remove { a b c d } e -} { a b c d } +test dict-5.8 {dict remove command: canonicality is forced} { + dict remove { a b c d } +} {a b c d} +test dict-5.9 {dict remove command: canonicality is forced} { + dict remove {a b c d a e} +} {a e c d} test dict-5.10 {dict remove command: canonicality forced by update} { dict remove { a b c d } c } {a b} @@ -235,6 +239,10 @@ test dict-5.11 {dict remove command: type check is mandatory} -body { test dict-5.12 {dict remove command: type check is mandatory} -body { dict remove { a b {}c d } } -returnCodes error -result {dict element in braces followed by "c" instead of space} +test dict-5.13 {dict remove command: canonicality forcing doesn't leak} { + set example { a b c d } + list $example [dict remove $example] +} {{ a b c d } {a b c d}} test dict-6.1 {dict keys command} {dict keys {a b}} a test dict-6.2 {dict keys command} {dict keys {c d}} c -- cgit v0.12 From 17751a998c8d965247ded100b90e4a2e51e0925d Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 15 Jun 2014 16:11:56 +0000 Subject: Some more cleaning up --- generic/tclDictObj.c | 80 +++++++++++++++++++++++++++++----------------------- 1 file changed, 44 insertions(+), 36 deletions(-) diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index a057b8a..9e606f7 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -155,6 +155,13 @@ typedef struct Dict { } Dict; /* + * Accessor macro for converting between a Tcl_Obj* and a Dict. Note that this + * must be assignable as well as readable. + */ + +#define DICT(dictObj) (*((Dict **)&(dictObj)->internalRep.twoPtrValue.ptr1)) + +/* * The structure below defines the dictionary object type by means of * functions that can be invoked by generic object code. */ @@ -312,6 +319,7 @@ DeleteChainEntry( return 0; } else { Tcl_Obj *valuePtr = Tcl_GetHashValue(&cPtr->entry); + TclDecrRefCount(valuePtr); } @@ -361,7 +369,7 @@ DupDictInternalRep( Tcl_Obj *srcPtr, Tcl_Obj *copyPtr) { - Dict *oldDict = srcPtr->internalRep.twoPtrValue.ptr1; + Dict *oldDict = DICT(srcPtr); Dict *newDict = ckalloc(sizeof(Dict)); ChainEntry *cPtr; @@ -396,7 +404,7 @@ DupDictInternalRep( * Store in the object. */ - copyPtr->internalRep.twoPtrValue.ptr1 = newDict; + DICT(copyPtr) = newDict; copyPtr->typePtr = &tclDictType; } @@ -422,7 +430,7 @@ static void FreeDictInternalRep( Tcl_Obj *dictPtr) { - Dict *dict = dictPtr->internalRep.twoPtrValue.ptr1; + Dict *dict = DICT(dictPtr); dict->refcount--; if (dict->refcount <= 0) { @@ -487,7 +495,7 @@ UpdateStringOfDict( { #define LOCAL_SIZE 20 int localFlags[LOCAL_SIZE], *flagPtr = NULL; - Dict *dict = dictPtr->internalRep.twoPtrValue.ptr1; + Dict *dict = DICT(dictPtr); ChainEntry *cPtr; Tcl_Obj *keyPtr, *valuePtr; int i, length, bytesNeeded = 0; @@ -711,7 +719,7 @@ SetDictFromAny( dict->epoch = 0; dict->chain = NULL; dict->refcount = 1; - objPtr->internalRep.twoPtrValue.ptr1 = dict; + DICT(objPtr) = dict; objPtr->typePtr = &tclDictType; return TCL_OK; @@ -774,7 +782,7 @@ TclTraceDictPath( && SetDictFromAny(interp, dictPtr) != TCL_OK) { return NULL; } - dict = dictPtr->internalRep.twoPtrValue.ptr1; + dict = DICT(dictPtr); if (flags & DICT_PATH_UPDATE) { dict->chain = NULL; } @@ -816,7 +824,7 @@ TclTraceDictPath( } } - newDict = tmpObj->internalRep.twoPtrValue.ptr1; + newDict = DICT(tmpObj); if (flags & DICT_PATH_UPDATE) { if (Tcl_IsShared(tmpObj)) { TclDecrRefCount(tmpObj); @@ -824,7 +832,7 @@ TclTraceDictPath( Tcl_IncrRefCount(tmpObj); Tcl_SetHashValue(hPtr, tmpObj); dict->epoch++; - newDict = tmpObj->internalRep.twoPtrValue.ptr1; + newDict = DICT(tmpObj); } newDict->chain = dictPtr; @@ -859,7 +867,7 @@ static void InvalidateDictChain( Tcl_Obj *dictObj) { - Dict *dict = dictObj->internalRep.twoPtrValue.ptr1; + Dict *dict = DICT(dictObj); do { TclInvalidateStringRep(dictObj); @@ -869,7 +877,7 @@ InvalidateDictChain( break; } dict->chain = NULL; - dict = dictObj->internalRep.twoPtrValue.ptr1; + dict = DICT(dictObj); } while (dict != NULL); } @@ -915,7 +923,7 @@ Tcl_DictObjPut( if (dictPtr->bytes != NULL) { TclInvalidateStringRep(dictPtr); } - dict = dictPtr->internalRep.twoPtrValue.ptr1; + dict = DICT(dictPtr); hPtr = CreateChainEntry(dict, keyPtr, &isNew); Tcl_IncrRefCount(valuePtr); if (!isNew) { @@ -964,7 +972,7 @@ Tcl_DictObjGet( return TCL_ERROR; } - dict = dictPtr->internalRep.twoPtrValue.ptr1; + dict = DICT(dictPtr); hPtr = Tcl_FindHashEntry(&dict->table, keyPtr); if (hPtr == NULL) { *valuePtrPtr = NULL; @@ -1010,7 +1018,7 @@ Tcl_DictObjRemove( return TCL_ERROR; } - dict = dictPtr->internalRep.twoPtrValue.ptr1; + dict = DICT(dictPtr); if (DeleteChainEntry(dict, keyPtr)) { if (dictPtr->bytes != NULL) { TclInvalidateStringRep(dictPtr); @@ -1051,7 +1059,7 @@ Tcl_DictObjSize( return TCL_ERROR; } - dict = dictPtr->internalRep.twoPtrValue.ptr1; + dict = DICT(dictPtr); *sizePtr = dict->table.numEntries; return TCL_OK; } @@ -1103,7 +1111,7 @@ Tcl_DictObjFirst( return TCL_ERROR; } - dict = dictPtr->internalRep.twoPtrValue.ptr1; + dict = DICT(dictPtr); cPtr = dict->entryChainHead; if (cPtr == NULL) { searchPtr->epoch = -1; @@ -1278,11 +1286,12 @@ Tcl_DictObjPutKeyList( return TCL_ERROR; } - dict = dictPtr->internalRep.twoPtrValue.ptr1; + dict = DICT(dictPtr); hPtr = CreateChainEntry(dict, keyv[keyc-1], &isNew); Tcl_IncrRefCount(valuePtr); if (!isNew) { Tcl_Obj *oldValuePtr = Tcl_GetHashValue(hPtr); + TclDecrRefCount(oldValuePtr); } Tcl_SetHashValue(hPtr, valuePtr); @@ -1334,7 +1343,7 @@ Tcl_DictObjRemoveKeyList( return TCL_ERROR; } - dict = dictPtr->internalRep.twoPtrValue.ptr1; + dict = DICT(dictPtr); DeleteChainEntry(dict, keyv[keyc-1]); InvalidateDictChain(dictPtr); return TCL_OK; @@ -1380,7 +1389,7 @@ Tcl_NewDictObj(void) dict->epoch = 0; dict->chain = NULL; dict->refcount = 1; - dictPtr->internalRep.twoPtrValue.ptr1 = dict; + DICT(dictPtr) = dict; dictPtr->typePtr = &tclDictType; return dictPtr; #endif @@ -1429,7 +1438,7 @@ Tcl_DbNewDictObj( dict->epoch = 0; dict->chain = NULL; dict->refcount = 1; - dictPtr->internalRep.twoPtrValue.ptr1 = dict; + DICT(dictPtr) = dict; dictPtr->typePtr = &tclDictType; return dictPtr; #else /* !TCL_MEM_DEBUG */ @@ -2033,7 +2042,7 @@ DictInfoCmd( && SetDictFromAny(interp, dictPtr) != TCL_OK) { return TCL_ERROR; } - dict = dictPtr->internalRep.twoPtrValue.ptr1; + dict = DICT(dictPtr); statsStr = Tcl_HashStats(&dict->table); Tcl_SetObjResult(interp, Tcl_NewStringObj(statsStr, -1)); @@ -2144,7 +2153,7 @@ DictIncrCmd( Tcl_IncrRefCount(incrPtr); code = TclIncrObj(interp, valuePtr, incrPtr); - Tcl_DecrRefCount(incrPtr); + TclDecrRefCount(incrPtr); } } if (code == TCL_OK) { @@ -2157,7 +2166,7 @@ DictIncrCmd( Tcl_SetObjResult(interp, valuePtr); } } else if (dictPtr->refCount == 0) { - Tcl_DecrRefCount(dictPtr); + TclDecrRefCount(dictPtr); } return code; } @@ -2300,10 +2309,8 @@ DictAppendCmd( if (valuePtr == NULL) { TclNewObj(valuePtr); - } else { - if (Tcl_IsShared(valuePtr)) { - valuePtr = Tcl_DuplicateObj(valuePtr); - } + } else if (Tcl_IsShared(valuePtr)) { + valuePtr = Tcl_DuplicateObj(valuePtr); } for (i=3 ; i Date: Sun, 15 Jun 2014 16:50:32 +0000 Subject: [cb042d294e] Improve consistency of [dict] wrong-args error messages. --- doc/dict.n | 10 +++++----- generic/tclDictObj.c | 20 ++++++++++---------- tests/dict.test | 52 ++++++++++++++++++++++++++-------------------------- 3 files changed, 41 insertions(+), 41 deletions(-) diff --git a/doc/dict.n b/doc/dict.n index 3bb5465..fecad85 100644 --- a/doc/dict.n +++ b/doc/dict.n @@ -54,10 +54,10 @@ The key rule only matches those key/value pairs whose keys match any of the given patterns (in the style of \fBstring match\fR.) .VE 8.6 .TP -\fBdict filter \fIdictionaryValue \fBscript {\fIkeyVar valueVar\fB} \fIscript\fR +\fBdict filter \fIdictionaryValue \fBscript {\fIkeyVariable valueVariable\fB} \fIscript\fR . The script rule tests for matching by assigning the key to the -\fIkeyVar\fR and the value to the \fIvalueVar\fR, and then evaluating +\fIkeyVariable\fR and the value to the \fIvalueVariable\fR, and then evaluating the given script which should return a boolean value (with the key/value pair only being included in the result of the \fBdict filter\fR when a true value is returned.) Note that the first @@ -75,7 +75,7 @@ of the given patterns (in the style of \fBstring match\fR.) .VE 8.6 .RE .TP -\fBdict for {\fIkeyVar valueVar\fB} \fIdictionaryValue body\fR +\fBdict for {\fIkeyVariable valueVariable\fB} \fIdictionaryValue body\fR . This command takes three arguments, the first a two-element list of variable names (for the key and value respectively of each mapping in @@ -150,7 +150,7 @@ there to be no items to append to the list. It is an error for the value that the key maps to to not be representable as a list. The updated dictionary value is returned. .TP -\fBdict map \fR{\fIkeyVar valueVar\fR} \fIdictionaryValue body\fR +\fBdict map \fR{\fIkeyVariable valueVariable\fR} \fIdictionaryValue body\fR . This command applies a transformation to each element of a dictionary, returning a new dictionary. It takes three arguments: the first is a @@ -160,7 +160,7 @@ and the third a script to be evaluated for each mapping with the key and value variables set appropriately (in the manner of \fBlmap\fR). In an iteration where the evaluated script completes normally (\fBTCL_OK\fR, as opposed to an \fBerror\fR, etc.) the result of the script is put into an accumulator -dictionary using the key that is the current contents of the \fIkeyVar\fR +dictionary using the key that is the current contents of the \fIkeyVariable\fR variable at that point. The result of the \fBdict map\fR command is the accumulator dictionary after all keys have been iterated over. .RS diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 9e606f7..3c0ddd8 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -2079,7 +2079,7 @@ DictIncrCmd( Tcl_Obj *dictPtr, *valuePtr = NULL; if (objc < 3 || objc > 4) { - Tcl_WrongNumArgs(interp, 1, objv, "varName key ?increment?"); + Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?increment?"); return TCL_ERROR; } @@ -2200,7 +2200,7 @@ DictLappendCmd( int i, allocatedDict = 0, allocatedValue = 0; if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "varName key ?value ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?value ...?"); return TCL_ERROR; } @@ -2287,7 +2287,7 @@ DictAppendCmd( int i, allocatedDict = 0; if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "varName key ?value ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?value ...?"); return TCL_ERROR; } @@ -2361,7 +2361,7 @@ DictForNRCmd( if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, - "{keyVar valueVar} dictionary script"); + "{keyVarName valueVarName} dictionary script"); return TCL_ERROR; } @@ -2555,7 +2555,7 @@ DictMapNRCmd( if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, - "{keyVar valueVar} dictionary script"); + "{keyVarName valueVarName} dictionary script"); return TCL_ERROR; } @@ -2764,7 +2764,7 @@ DictSetCmd( int result, allocatedDict = 0; if (objc < 4) { - Tcl_WrongNumArgs(interp, 1, objv, "varName key ?key ...? value"); + Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?key ...? value"); return TCL_ERROR; } @@ -2824,7 +2824,7 @@ DictUnsetCmd( int result, allocatedDict = 0; if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "varName key ?key ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?key ...?"); return TCL_ERROR; } @@ -2992,7 +2992,7 @@ DictFilterCmd( case FILTER_SCRIPT: if (objc != 5) { Tcl_WrongNumArgs(interp, 1, objv, - "dictionary script {keyVar valueVar} filterScript"); + "dictionary script {keyVarName valueVarName} filterScript"); return TCL_ERROR; } @@ -3169,7 +3169,7 @@ DictUpdateCmd( if (objc < 5 || !(objc & 1)) { Tcl_WrongNumArgs(interp, 1, objv, - "varName key varName ?key varName ...? script"); + "dictVarName key varName ?key varName ...? script"); return TCL_ERROR; } @@ -3325,7 +3325,7 @@ DictWithCmd( Tcl_Obj *dictPtr, *keysPtr, *pathPtr; if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "dictVar ?key ...? script"); + Tcl_WrongNumArgs(interp, 1, objv, "dictVarName ?key ...? script"); return TCL_ERROR; } diff --git a/tests/dict.test b/tests/dict.test index 642abd8..d5406d0 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -409,13 +409,13 @@ test dict-11.13 {dict incr command} -returnCodes error -body { dict incr dictv a a a } -cleanup { unset dictv -} -result {wrong # args: should be "dict incr varName key ?increment?"} +} -result {wrong # args: should be "dict incr dictVarName key ?increment?"} test dict-11.14 {dict incr command} -returnCodes error -body { set dictv a dict incr dictv } -cleanup { unset dictv -} -result {wrong # args: should be "dict incr varName key ?increment?"} +} -result {wrong # args: should be "dict incr dictVarName key ?increment?"} test dict-11.15 {dict incr command: write failure} -setup { unset -nocomplain dictVar } -body { @@ -486,10 +486,10 @@ test dict-12.6 {dict lappend command} -returnCodes error -body { } -result {missing value to go with key} test dict-12.7 {dict lappend command} -returnCodes error -body { dict lappend -} -result {wrong # args: should be "dict lappend varName key ?value ...?"} +} -result {wrong # args: should be "dict lappend dictVarName key ?value ...?"} test dict-12.8 {dict lappend command} -returnCodes error -body { dict lappend dictv -} -result {wrong # args: should be "dict lappend varName key ?value ...?"} +} -result {wrong # args: should be "dict lappend dictVarName key ?value ...?"} test dict-12.9 {dict lappend command} -returnCodes error -body { set dictv [dict create a "\{"] dict lappend dictv a a @@ -553,10 +553,10 @@ test dict-13.6 {dict append command} -returnCodes error -body { } -result {missing value to go with key} test dict-13.7 {dict append command} -returnCodes error -body { dict append -} -result {wrong # args: should be "dict append varName key ?value ...?"} +} -result {wrong # args: should be "dict append dictVarName key ?value ...?"} test dict-13.8 {dict append command} -returnCodes error -body { dict append dictv -} -result {wrong # args: should be "dict append varName key ?value ...?"} +} -result {wrong # args: should be "dict append dictVarName key ?value ...?"} test dict-13.9 {dict append command: write failure} -setup { unset -nocomplain dictVar } -body { @@ -574,16 +574,16 @@ test dict-13.11 {compiled dict append: invalidate string rep - Bug 3079830} { test dict-14.1 {dict for command: syntax} -returnCodes error -body { dict for -} -result {wrong # args: should be "dict for {keyVar valueVar} dictionary script"} +} -result {wrong # args: should be "dict for {keyVarName valueVarName} dictionary script"} test dict-14.2 {dict for command: syntax} -returnCodes error -body { dict for x -} -result {wrong # args: should be "dict for {keyVar valueVar} dictionary script"} +} -result {wrong # args: should be "dict for {keyVarName valueVarName} dictionary script"} test dict-14.3 {dict for command: syntax} -returnCodes error -body { dict for x x -} -result {wrong # args: should be "dict for {keyVar valueVar} dictionary script"} +} -result {wrong # args: should be "dict for {keyVarName valueVarName} dictionary script"} test dict-14.4 {dict for command: syntax} -returnCodes error -body { dict for x x x x -} -result {wrong # args: should be "dict for {keyVar valueVar} dictionary script"} +} -result {wrong # args: should be "dict for {keyVarName valueVarName} dictionary script"} test dict-14.5 {dict for command: syntax} -returnCodes error -body { dict for x x x } -result {must have exactly two variable names} @@ -813,13 +813,13 @@ test dict-15.9 {dict set command: write failure} -setup { } -result {can't set "dictVar": variable is array} test dict-15.10 {dict set command: syntax} -returnCodes error -body { dict set -} -result {wrong # args: should be "dict set varName key ?key ...? value"} +} -result {wrong # args: should be "dict set dictVarName key ?key ...? value"} test dict-15.11 {dict set command: syntax} -returnCodes error -body { dict set a -} -result {wrong # args: should be "dict set varName key ?key ...? value"} +} -result {wrong # args: should be "dict set dictVarName key ?key ...? value"} test dict-15.12 {dict set command: syntax} -returnCodes error -body { dict set a a -} -result {wrong # args: should be "dict set varName key ?key ...? value"} +} -result {wrong # args: should be "dict set dictVarName key ?key ...? value"} test dict-15.13 {dict set command} -returnCodes error -body { set dictVar a dict set dictVar b c @@ -872,7 +872,7 @@ test dict-16.7 {dict unset command} -setup { } -result {0 {} 1} test dict-16.8 {dict unset command} -returnCodes error -body { dict unset dictVar -} -result {wrong # args: should be "dict unset varName key ?key ...?"} +} -result {wrong # args: should be "dict unset dictVarName key ?key ...?"} test dict-16.9 {dict unset command: write failure} -setup { unset -nocomplain dictVar } -body { @@ -923,7 +923,7 @@ test dict-16.16 {dict unset command} -body { } -result {0 {} 1} test dict-16.17 {dict unset command} -returnCodes error -body { apply {{} {dict unset dictVar}} -} -result {wrong # args: should be "dict unset varName key ?key ...?"} +} -result {wrong # args: should be "dict unset dictVarName key ?key ...?"} test dict-16.18 {dict unset command: write failure} -body { apply {{} { set dictVar(block) {} @@ -1052,7 +1052,7 @@ test dict-17.17 {dict filter command: script} -body { } -result b test dict-17.18 {dict filter command: script} -returnCodes error -body { dict filter {a b} script {k k} -} -result {wrong # args: should be "dict filter dictionary script {keyVar valueVar} filterScript"} +} -result {wrong # args: should be "dict filter dictionary script {keyVarName valueVarName} filterScript"} test dict-17.19 {dict filter command: script} -returnCodes error -body { dict filter {a b} script k {continue} } -result {must have exactly two variable names} @@ -1308,16 +1308,16 @@ test dict-20.25 {dict merge command: type check is mandatory} -body { test dict-21.1 {dict update command} -returnCodes 1 -body { dict update -} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"} +} -result {wrong # args: should be "dict update dictVarName key varName ?key varName ...? script"} test dict-21.2 {dict update command} -returnCodes 1 -body { dict update v -} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"} +} -result {wrong # args: should be "dict update dictVarName key varName ?key varName ...? script"} test dict-21.3 {dict update command} -returnCodes 1 -body { dict update v k -} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"} +} -result {wrong # args: should be "dict update dictVarName key varName ?key varName ...? script"} test dict-21.4 {dict update command} -returnCodes 1 -body { dict update v k v -} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"} +} -result {wrong # args: should be "dict update dictVarName key varName ?key varName ...? script"} test dict-21.5 {dict update command} -body { set a {b c} set result {} @@ -1455,10 +1455,10 @@ test dict-21.17 {dict update command: no recursive structures [Bug 1786481]} { test dict-22.1 {dict with command} -body { dict with -} -returnCodes 1 -result {wrong # args: should be "dict with dictVar ?key ...? script"} +} -returnCodes 1 -result {wrong # args: should be "dict with dictVarName ?key ...? script"} test dict-22.2 {dict with command} -body { dict with v -} -returnCodes 1 -result {wrong # args: should be "dict with dictVar ?key ...? script"} +} -returnCodes 1 -result {wrong # args: should be "dict with dictVarName ?key ...? script"} test dict-22.3 {dict with command} -body { unset -nocomplain v dict with v {error "in body"} @@ -1718,16 +1718,16 @@ rename linenumber {} test dict-24.1 {dict map command: syntax} -returnCodes error -body { dict map -} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"} +} -result {wrong # args: should be "dict map {keyVarName valueVarName} dictionary script"} test dict-24.2 {dict map command: syntax} -returnCodes error -body { dict map x -} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"} +} -result {wrong # args: should be "dict map {keyVarName valueVarName} dictionary script"} test dict-24.3 {dict map command: syntax} -returnCodes error -body { dict map x x -} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"} +} -result {wrong # args: should be "dict map {keyVarName valueVarName} dictionary script"} test dict-24.4 {dict map command: syntax} -returnCodes error -body { dict map x x x x -} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"} +} -result {wrong # args: should be "dict map {keyVarName valueVarName} dictionary script"} test dict-24.5 {dict map command: syntax} -returnCodes error -body { dict map x x x } -result {must have exactly two variable names} -- cgit v0.12 From ab6933ef6bad77e36a80b261ffd48e2cc8d7575f Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 16 Jun 2014 09:24:39 +0000 Subject: [311e61d12a] Generate error code in *all* places where commands are looked up. --- library/init.tcl | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/library/init.tcl b/library/init.tcl index f63eedf..bb17319 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -398,7 +398,8 @@ proc unknown args { return -code error "ambiguous command name \"$name\": [lsort $cmds]" } } - return -code error "invalid command name \"$name\"" + return -code error -errorcode [list TCL LOOKUP COMMAND $name] \ + "invalid command name \"$name\"" } # auto_load -- -- cgit v0.12