Tcl Source Code

Artifact c0c45d86806058553b52db576c53e68189df31b7:

Attachment "1901113.patch" to ticket [1901113fff] added by dgp 2008-03-11 00:49:54.

---

Index: generic/tclEvent.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclEvent.c,v
retrieving revision 1.79
diff -u -r1.79 tclEvent.c
--- generic/tclEvent.c	29 Feb 2008 20:00:00 -0000	1.79
+++ generic/tclEvent.c	10 Mar 2008 17:47:15 -0000
@@ -317,30 +317,57 @@
 	return TCL_ERROR;
     }
 
-    /* Construct the bgerror command */
-    TclNewLiteralStringObj(tempObjv[0], "bgerror");
-    Tcl_IncrRefCount(tempObjv[0]);
-
     /*
-     * Determine error message argument.  Check the return options in case
-     * a non-error exception brought us here.
+     * Check for a valid return options dictionary.
      */
 
     TclNewLiteralStringObj(keyPtr, "-level");
     Tcl_IncrRefCount(keyPtr);
     Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
     Tcl_DecrRefCount(keyPtr);
-    Tcl_GetIntFromObj(NULL, valuePtr, &level);
+    if (valuePtr == NULL) {
+	Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		"missing return option \"-level\"", -1));
+	return TCL_ERROR;
+    }
+    if (Tcl_GetIntFromObj(interp, valuePtr, &level) == TCL_ERROR) {
+	return TCL_ERROR;
+    }
+    TclNewLiteralStringObj(keyPtr, "-code");
+    Tcl_IncrRefCount(keyPtr);
+    Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
+    Tcl_DecrRefCount(keyPtr);
+    if (valuePtr == NULL) {
+	Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		"missing return option \"-code\"", -1));
+	return TCL_ERROR;
+    }
+    if (Tcl_GetIntFromObj(interp, valuePtr, &code) == TCL_ERROR) {
+	return TCL_ERROR;
+    }
+
     if (level != 0) {
 	/* We're handling a TCL_RETURN exception */
 	code = TCL_RETURN;
-    } else {
-	TclNewLiteralStringObj(keyPtr, "-code");
-	Tcl_IncrRefCount(keyPtr);
-	Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
-	Tcl_DecrRefCount(keyPtr);
-	Tcl_GetIntFromObj(NULL, valuePtr, &code);
     }
+    if (code == TCL_OK) {
+	/*
+	 * Somehow we got to exception handling with no exception.
+	 * (Pass TCL_OK to TclBackgroundException()?)
+	 * Just return without doing anything.
+	 */
+	return TCL_OK;
+    }
+
+    /* Construct the bgerror command */
+    TclNewLiteralStringObj(tempObjv[0], "bgerror");
+    Tcl_IncrRefCount(tempObjv[0]);
+
+    /*
+     * Determine error message argument.  Check the return options in case
+     * a non-error exception brought us here.
+     */
+
     switch (code) {
     case TCL_ERROR:
 	tempObjv[1] = objv[1];
Index: tests/event.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/event.test,v
retrieving revision 1.26
diff -u -r1.26 event.test
--- tests/event.test	13 Dec 2007 15:26:06 -0000	1.26
+++ tests/event.test	10 Mar 2008 17:47:15 -0000
@@ -205,6 +205,69 @@
     rename demo {}
     rename trial {}
 } -result {}
+test event-5.3 {Default [interp bgerror] handler} -body {
+    ::tcl::Bgerror
+} -returnCodes error -match glob -result {*msg options*}
+test event-5.4 {Default [interp bgerror] handler} -body {
+    ::tcl::Bgerror {}
+} -returnCodes error -match glob -result {*msg options*}
+test event-5.5 {Default [interp bgerror] handler} -body {
+    ::tcl::Bgerror {} {} {}
+} -returnCodes error -match glob -result {*msg options*}
+test event-5.6 {Default [interp bgerror] handler} -body {
+    ::tcl::Bgerror {} {}
+} -returnCodes error -match glob -result {*-level*}
+test event-5.7 {Default [interp bgerror] handler} -body {
+    ::tcl::Bgerror {} {-level foo}
+} -returnCodes error -match glob -result {*expected integer*}
+test event-5.8 {Default [interp bgerror] handler} -body {
+    ::tcl::Bgerror {} {-level 0}
+} -returnCodes error -match glob -result {*-code*}
+test event-5.9 {Default [interp bgerror] handler} -body {
+    ::tcl::Bgerror {} {-level 0 -code ok}
+} -returnCodes error -match glob -result {*expected integer*}
+test event-5.10 {Default [interp bgerror] handler} {
+    proc bgerror {m} {append ::res $m}
+    set ::res {}
+    ::tcl::Bgerror {} {-level 0 -code 0}
+    rename bgerror {}
+    set ::res
+} {}
+test event-5.11 {Default [interp bgerror] handler} {
+    proc bgerror {m} {append ::res $m}
+    set ::res {}
+    ::tcl::Bgerror msg {-level 0 -code 1}
+    rename bgerror {}
+    set ::res
+} {msg}
+test event-5.12 {Default [interp bgerror] handler} {
+    proc bgerror {m} {append ::res $m}
+    set ::res {}
+    ::tcl::Bgerror msg {-level 0 -code 2}
+    rename bgerror {}
+    set ::res
+} {command returned bad code: 2}
+test event-5.13 {Default [interp bgerror] handler} {
+    proc bgerror {m} {append ::res $m}
+    set ::res {}
+    ::tcl::Bgerror msg {-level 0 -code 3}
+    rename bgerror {}
+    set ::res
+} {invoked "break" outside of a loop}
+test event-5.14 {Default [interp bgerror] handler} {
+    proc bgerror {m} {append ::res $m}
+    set ::res {}
+    ::tcl::Bgerror msg {-level 0 -code 4}
+    rename bgerror {}
+    set ::res
+} {invoked "continue" outside of a loop}
+test event-5.15 {Default [interp bgerror] handler} {
+    proc bgerror {m} {append ::res $m}
+    set ::res {}
+    ::tcl::Bgerror msg {-level 0 -code 5}
+    rename bgerror {}
+    set ::res
+} {command returned bad code: 5}
 
 test event-6.1 {BgErrorDeleteProc procedure} {
     catch {interp delete foo}