diff options
| -rw-r--r-- | ChangeLog | 6 | ||||
| -rw-r--r-- | generic/tclCmdMZ.c | 26 | ||||
| -rw-r--r-- | tests/error.test | 16 |
3 files changed, 28 insertions, 20 deletions
@@ -1,7 +1,9 @@ 2009-09-28 Don Porter <dgp@users.sourceforge.net> - * tests/error.test (error-15.9.*): More coverage tests for [try]. - Test error-15.9.3.0.0 covers [Bug 2855247]. + * generic/tclCmdMZ.c: Replaced TclProcessReturn() calls with + * tests/error.test: Tcl_SetReturnOptions() calls as a simple fix + for [Bug 2855247]. Thanks to Anton Kovalenko for the report and fix. + Additional fixes for other failures demonstrated by new tests. 2009-09-27 Don Porter <dgp@users.sourceforge.net> diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 8824c48..9aed082 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -15,7 +15,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdMZ.c,v 1.194 2009/09/24 17:19:18 dgp Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.195 2009/09/28 18:02:20 dgp Exp $ */ #include "tclInt.h" @@ -4348,12 +4348,8 @@ TryPostBody( "\n (\"%s\" body line %d)", TclGetString(cmdObj), Tcl_GetErrorLine(interp))); } - if (handlersObj != NULL || finallyObj != NULL) { - options = Tcl_GetReturnOptions(interp, result); - Tcl_IncrRefCount(options); - } else { - options = NULL; - } + options = Tcl_GetReturnOptions(interp, result); + Tcl_IncrRefCount(options); Tcl_ResetResult(interp); /* @@ -4496,14 +4492,10 @@ TryPostBody( * any temporary storage. */ - if (options != NULL) { - result = TclProcessReturn(interp, result, 0, options); - Tcl_DecrRefCount(options); - } - if (resultObj != NULL) { - Tcl_SetObjResult(interp, resultObj); - Tcl_DecrRefCount(resultObj); - } + result = Tcl_SetReturnOptions(interp, options); + Tcl_DecrRefCount(options); + Tcl_SetObjResult(interp, resultObj); + Tcl_DecrRefCount(resultObj); return result; } @@ -4565,7 +4557,7 @@ TryPostHandler( * any temporary storage. */ - result = TclProcessReturn(interp, result, 0, options); + result = Tcl_SetReturnOptions(interp, options); Tcl_DecrRefCount(options); Tcl_SetObjResult(interp, resultObj); Tcl_DecrRefCount(resultObj); @@ -4623,7 +4615,7 @@ TryPostFinal( * any temporary storage. */ - result = TclProcessReturn(interp, result, 0, options); + result = Tcl_SetReturnOptions(interp, options); Tcl_DecrRefCount(options); if (resultObj != NULL) { Tcl_SetObjResult(interp, resultObj); diff --git a/tests/error.test b/tests/error.test index 3106ca9..e18afad 100644 --- a/tests/error.test +++ b/tests/error.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: error.test,v 1.21 2009/09/28 16:34:40 dgp Exp $ +# RCS: @(#) $Id: error.test,v 1.22 2009/09/28 18:02:20 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -495,6 +495,7 @@ foreach level {0 1 2 3} { foreach code {0 1 2 3 4 5} { # Following cases have different -errorinfo; avoid false alarms + # TODO: examine whether these difference are as they ought to be. if {$level == 0 && $code == 1} continue foreach extras {{} {-bar soom}} { @@ -503,6 +504,8 @@ test error-15.8.$level.$code.[llength $extras] {[try] coverage} { set script {return -level $level -code $code {*}$extras foo} catch $script m1 o1 catch {try $script} m2 o2 + set o1 [lsort -stride 2 $o1] + set o2 [lsort -stride 2 $o2] expr {$o1 eq $o2 ? "ok" : "$o1\n\tis not equal to\n$o2"} } ok @@ -510,6 +513,17 @@ test error-15.9.$level.$code.[llength $extras] {[try] coverage} { set script {return -level $level -code $code {*}$extras foo} catch $script m1 o1 catch {try $script finally {}} m2 o2 + set o1 [lsort -stride 2 $o1] + set o2 [lsort -stride 2 $o2] + expr {$o1 eq $o2 ? "ok" : "$o1\n\tis not equal to\n$o2"} +} ok + +test error-15.10.$level.$code.[llength $extras] {[try] coverage} { + set script {return -level $level -code $code {*}$extras foo} + catch $script m1 o1 + catch {try $script on $code {x y} {return -options $y $x}} m2 o2 + set o1 [lsort -stride 2 $o1] + set o2 [lsort -stride 2 $o2] expr {$o1 eq $o2 ? "ok" : "$o1\n\tis not equal to\n$o2"} } ok |