From 15df1bf8a56a5077d263e50e009536d98d13ad19 Mon Sep 17 00:00:00 2001
From: Miguel Sofer <miguel.sofer@gmail.com>
Date: Tue, 26 Aug 2008 22:36:52 +0000
Subject: 	* generic/tclBasic.c (InfoCoroutine): 	*
 tests/unsupported.test: new command that returns the 	FQN of the currently
 executing coroutine. Lives as infoCoroutine 	under unsupported, but is
 designed to become a subcommand of [info]

---
 ChangeLog              |  7 +++++++
 generic/tclBasic.c     | 33 ++++++++++++++++++++++++++++++++-
 tests/unsupported.test | 24 +++++++++++++++++++++++-
 3 files changed, 62 insertions(+), 2 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 8d7119e..2ea86ac 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2008-08-26  Miguel Sofer  <msofer@users.sf.net>
+
+	* generic/tclBasic.c (InfoCoroutine): 
+	* tests/unsupported.test: new command that returns the
+	FQN of the currently executing coroutine. Lives as infoCoroutine
+	under unsupported, but is designed to become a subcommand of [info]
+
 2008-08-23  Miguel Sofer  <msofer@users.sf.net>
 
 	* generic/tclBasic.c (NRInterpCoroutine): store the caller's
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index a710857..68700c8 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.364 2008/08/25 13:22:04 msofer Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.365 2008/08/26 22:37:02 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -140,6 +140,9 @@ static Tcl_NRPostProc   NRRunObjProc;
 static Tcl_NRPostProc	AtProcExitCleanup;
 static Tcl_NRPostProc   NRAtProcExitEval;
 
+static int		InfoCoroutineCmd(ClientData dummy, Tcl_Interp *interp, 
+			    int objc, Tcl_Obj *const objv[]);
+
 /*
  * The following structure define the commands in the Tcl core.
  */
@@ -792,6 +795,8 @@ Tcl_CreateInterp(void)
 	    /*objProc*/ NULL, TclNRCoroutineObjCmd, NULL, NULL);
     Tcl_NRCreateCommand(interp, "::tcl::unsupported::yield",
 	    /*objProc*/ NULL, TclNRYieldObjCmd, NULL, NULL);
+    Tcl_NRCreateCommand(interp, "::tcl::unsupported::infoCoroutine",
+	    /*objProc*/ NULL, InfoCoroutineCmd, NULL, NULL);
 
 #ifdef USE_DTRACE
     /*
@@ -8459,6 +8464,32 @@ TclNRCoroutineObjCmd(
     return TclNRRunCallbacks(interp,
 	    TclNREvalObjEx(interp, cmdObjPtr, 0, NULL, 0), rootPtr, 0);
 }
+
+/*
+ * This belongs in the [info] ensemble later on
+ */
+
+static int
+InfoCoroutineCmd(
+    ClientData dummy,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    CoroutineData *corPtr = ((Interp *)interp)->execEnvPtr->corPtr;
+
+    if (corPtr) {
+	Tcl_Command cmd = (Tcl_Command) corPtr->cmdPtr;
+	Tcl_Obj *namePtr;
+
+	TclNewObj(namePtr);
+	Tcl_GetCommandFullName(interp, cmd, namePtr);
+	Tcl_SetObjResult(interp, namePtr);
+    }
+    return TCL_OK;
+}
+
+
 
 /*
  * Local Variables:
diff --git a/tests/unsupported.test b/tests/unsupported.test
index 94242fa..0267c58 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.6 2008/08/22 18:27:27 dgp Exp $
+# RCS: @(#) $Id: unsupported.test,v 1.7 2008/08/26 22:37:05 msofer Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -746,6 +746,28 @@ test unsupported-C.3.2 {info frame computation} -constraints {coroutine} \
     rename b {}
 } -result 1
 
+test unsupported-C.3.3 {info coroutine} -constraints {coroutine} \
+-setup {
+    proc a {} {infoCoroutine}
+    proc b {} a
+} -body {
+    b
+} -cleanup {
+    rename a {}
+    rename b {}
+} -result {}
+
+test unsupported-C.3.4 {info coroutine} -constraints {coroutine} \
+-setup {
+    proc a {} {infoCoroutine}
+    proc b {} a
+} -body {
+    coroutine foo b
+} -cleanup {
+    rename a {}
+    rename b {}
+} -result ::foo
+
 
 # cleanup
 ::tcltest::cleanupTests
-- 
cgit v0.12