diff options
| author | Miguel Sofer <miguel.sofer@gmail.com> | 2008-10-08 15:10:30 (GMT) |
|---|---|---|
| committer | Miguel Sofer <miguel.sofer@gmail.com> | 2008-10-08 15:10:30 (GMT) |
| commit | 3dac24314a5483f488d9d5255b7fb6bbeba91b3b (patch) | |
| tree | 24e837db74d4613110a015e7dc96020d98a846ac | |
| parent | 7d5aead5703d324d80a98cf890f90b9a452cb9a2 (diff) | |
| download | tcl-3dac24314a5483f488d9d5255b7fb6bbeba91b3b.zip tcl-3dac24314a5483f488d9d5255b7fb6bbeba91b3b.tar.gz tcl-3dac24314a5483f488d9d5255b7fb6bbeba91b3b.tar.bz2 | |
* generic/tclBasic (TclInfoCoroutineCmd):
* tests/unsupported.test: arrange for [info coroutine] to return
{} when a coroutine is running but the resume command has been
deleted [Bug 2153080]
| -rw-r--r-- | ChangeLog | 7 | ||||
| -rw-r--r-- | generic/tclBasic.c | 13 | ||||
| -rw-r--r-- | tests/unsupported.test | 12 |
3 files changed, 26 insertions, 6 deletions
@@ -1,3 +1,10 @@ +2008-10-08 Miguel Sofer <msofer@users.sf.net> + + * generic/tclBasic (TclInfoCoroutineCmd): + * tests/unsupported.test: arrange for [info coroutine] to return + {} when a coroutine is running but the resume command has been + deleted [Bug 2153080] + 2008-10-08 Don Porter <dgp@users.sourceforge.net> * generic/tclTrace.c: Corrected handling of errors returned by diff --git a/generic/tclBasic.c b/generic/tclBasic.c index afddfb6..b2c9e7c 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -16,7 +16,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.371 2008/10/07 17:57:42 msofer Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.372 2008/10/08 15:10:30 msofer Exp $ */ #include "tclInt.h" @@ -8498,10 +8498,13 @@ TclInfoCoroutineCmd( if (corPtr) { Tcl_Command cmd = (Tcl_Command) corPtr->cmdPtr; Tcl_Obj *namePtr; - - TclNewObj(namePtr); - Tcl_GetCommandFullName(interp, cmd, namePtr); - Tcl_SetObjResult(interp, namePtr); + int deleted = (((Command *)cmd)->flags & CMD_IS_DELETED); + + if (!deleted) { + TclNewObj(namePtr); + Tcl_GetCommandFullName(interp, cmd, namePtr); + Tcl_SetObjResult(interp, namePtr); + } } return TCL_OK; } diff --git a/tests/unsupported.test b/tests/unsupported.test index c41d4bc..7085be6 100644 --- a/tests/unsupported.test +++ b/tests/unsupported.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: unsupported.test,v 1.12 2008/10/07 17:57:43 msofer Exp $ +# RCS: @(#) $Id: unsupported.test,v 1.13 2008/10/08 15:10:30 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -739,6 +739,16 @@ test unsupported-C.3.4 {info coroutine} -setup { rename b {} } -result ::foo +test unsupported-C.3.5 {info coroutine} -setup { + proc a {} {info coroutine} + proc b {} {rename [info coroutine] {}; a} +} -body { + coroutine foo b +} -cleanup { + rename a {} + rename b {} +} -result {} + test unsupported-C.4.1 {bug #2093188} -setup { proc foo {} { |