diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | cop.h | 2 | ||||
| -rw-r--r-- | ext/XS-APItest/t/call.t | 53 | ||||
| -rw-r--r-- | pod/perlcall.pod | 48 | ||||
| -rw-r--r-- | pp_ctl.c | 25 | ||||
| -rw-r--r-- | t/lib/warnings/pp_ctl | 18 | ||||
| -rw-r--r-- | t/op/die_keeperr.t | 45 |
7 files changed, 139 insertions, 53 deletions
@@ -4388,6 +4388,7 @@ t/op/defins.t See if auto-insert of defined() works t/op/delete.t See if delete works t/op/die_except.t See if die/eval avoids $@ clobberage t/op/die_exit.t See if die and exit status interaction works +t/op/die_keeperr.t See if G_KEEPERR works for destructors t/op/die.t See if die works t/op/dor.t See if defined-or (//) works t/op/do.t See if subroutines work @@ -778,7 +778,7 @@ L<perlcall>. hash actions codes defined in hv.h */ #define G_EVAL 8 /* Assume eval {} around subroutine call. */ #define G_NOARGS 16 /* Don't construct a @_ array. */ -#define G_KEEPERR 32 /* Append errors to $@, don't overwrite it */ +#define G_KEEPERR 32 /* Warn for errors, don't overwrite $@ */ #define G_NODEBUG 64 /* Disable debugging at toplevel. */ #define G_METHOD 128 /* Calling method. */ #define G_FAKINGEVAL 256 /* Faking an eval context for call_sv or diff --git a/ext/XS-APItest/t/call.t b/ext/XS-APItest/t/call.t index e7c1545b5e..373a1af907 100644 --- a/ext/XS-APItest/t/call.t +++ b/ext/XS-APItest/t/call.t @@ -18,11 +18,11 @@ use warnings; use strict; # Test::More doesn't have fresh_perl_is() yet -# use Test::More tests => 240; +# use Test::More tests => 342; BEGIN { require '../../t/test.pl'; - plan(240); + plan(342); use_ok('XS::APItest') }; @@ -36,7 +36,6 @@ sub f { } sub d { - no warnings 'misc'; # keep G_KEEPERR from emitting this as a warning die "its_dead_jim\n"; } @@ -52,7 +51,6 @@ sub Foo::meth { } sub Foo::d { - no warnings 'misc'; # keep G_KEEPERR from emitting this as a warning die "its_dead_jim\n"; } @@ -92,31 +90,42 @@ for my $test ( ? [0] : [ undef, 1 ]; for my $keep (0, G_KEEPERR) { my $desc = $description . ($keep ? ' G_KEEPERR' : ''); - my $exp_err = $keep ? "before\n\t(in cleanup) its_dead_jim\n" + my $exp_warn = $keep ? "\t(in cleanup) its_dead_jim\n" : ""; + my $exp_err = $keep ? "before\n" : "its_dead_jim\n"; + my $warn; + local $SIG{__WARN__} = sub { $warn .= $_[0] }; $@ = "before\n"; + $warn = ""; ok(eq_array( [ call_sv('d', $flags|G_EVAL|$keep, @$args) ], $returnval), "$desc G_EVAL call_sv('d')"); is($@, $exp_err, "$desc G_EVAL call_sv('d') - \$@"); + is($warn, $exp_warn, "$desc G_EVAL call_sv('d') - warning"); $@ = "before\n"; + $warn = ""; ok(eq_array( [ call_pv('d', $flags|G_EVAL|$keep, @$args) ], $returnval), "$desc G_EVAL call_pv('d')"); is($@, $exp_err, "$desc G_EVAL call_pv('d') - \$@"); + is($warn, $exp_warn, "$desc G_EVAL call_pv('d') - warning"); $@ = "before\n"; + $warn = ""; ok(eq_array( [ eval_sv('d()', $flags|$keep) ], $returnval), "$desc eval_sv('d()')"); is($@, $exp_err, "$desc eval_sv('d()') - \$@"); + is($warn, $exp_warn, "$desc G_EVAL eval_sv('d') - warning"); $@ = "before\n"; + $warn = ""; ok(eq_array( [ call_method('d', $flags|G_EVAL|$keep, $obj, @$args) ], $returnval), "$desc G_EVAL call_method('d')"); is($@, $exp_err, "$desc G_EVAL call_method('d') - \$@"); + is($warn, $exp_warn, "$desc G_EVAL call_method('d') - warning"); } ok(eq_array( [ sub { call_sv('f', $flags|G_NOARGS, "bad") }->(@$args) ], @@ -147,6 +156,40 @@ for my $test ( }; +foreach my $inx ("", "aabbcc\n", [qw(aa bb cc)]) { + foreach my $outx ("", "xxyyzz\n", [qw(xx yy zz)]) { + my $warn; + local $SIG{__WARN__} = sub { $warn .= $_[0] }; + $@ = $outx; + $warn = ""; + call_sv(sub { die $inx if $inx }, G_VOID|G_EVAL); + ok ref($@) eq ref($inx) && $@ eq $inx; + $warn =~ s/ at [^\n]*\n\z//; + is $warn, ""; + $@ = $outx; + $warn = ""; + call_sv(sub { die $inx if $inx }, G_VOID|G_EVAL|G_KEEPERR); + ok ref($@) eq ref($outx) && $@ eq $outx; + $warn =~ s/ at [^\n]*\n\z//; + is $warn, $inx ? "\t(in cleanup) $inx" : ""; + } +} + +{ + no warnings "misc"; + my $warn = ""; + local $SIG{__WARN__} = sub { $warn .= $_[0] }; + call_sv(sub { die "aa\n" }, G_VOID|G_EVAL|G_KEEPERR); + is $warn, ""; +} + +{ + my $warn = ""; + local $SIG{__WARN__} = sub { $warn .= $_[0] }; + call_sv(sub { no warnings "misc"; die "aa\n" }, G_VOID|G_EVAL|G_KEEPERR); + is $warn, "\t(in cleanup) aa\n"; +} + is(eval_pv('f()', 0), 'y', "eval_pv('f()', 0)"); is(eval_pv('f(qw(a b c))', 0), 'y', "eval_pv('f(qw(a b c))', 0)"); is(eval_pv('d()', 0), undef, "eval_pv('d()', 0)"); diff --git a/pod/perlcall.pod b/pod/perlcall.pod index 359e097a18..f34a53dbfb 100644 --- a/pod/perlcall.pod +++ b/pod/perlcall.pod @@ -321,33 +321,30 @@ See I<Using G_EVAL> for details on using G_EVAL. =head2 G_KEEPERR -You may have noticed that using the G_EVAL flag described above will -B<always> clear the C<$@> variable and set it to a string describing -the error iff there was an error in the called code. This unqualified -resetting of C<$@> can be problematic in the reliable identification of -errors using the C<eval {}> mechanism, because the possibility exists -that perl will call other code (end of block processing code, for -example) between the time the error causes C<$@> to be set within -C<eval {}>, and the subsequent statement which checks for the value of -C<$@> gets executed in the user's script. - -This scenario will mostly be applicable to code that is meant to be -called from within destructors, asynchronous callbacks, signal -handlers, C<__DIE__> or C<__WARN__> hooks, and C<tie> functions. In -such situations, you will not want to clear C<$@> at all, but simply to -append any new errors to any existing value of C<$@>. +Using the G_EVAL flag described above will always set C<$@>: clearing +it if there was no error, and setting it to describe the error if there +was an error in the called code. This is what you want if your intention +is to handle possible errors, but sometimes you just want to trap errors +and stop them interfering with the rest of the program. + +This scenario will mostly be applicable to code that is meant to be called +from within destructors, asynchronous callbacks, and signal handlers. +In such situations, where the code being called has little relation to the +surrounding dynamic context, the main program needs to be insulated from +errors in the called code, even if they can't be handled intelligently. +It may also be useful to do this with code for C<__DIE__> or C<__WARN__> +hooks, and C<tie> functions. The G_KEEPERR flag is meant to be used in conjunction with G_EVAL in I<call_*> functions that are used to implement such code. This flag has no effect when G_EVAL is not used. -When G_KEEPERR is used, any errors in the called code will be prefixed -with the string "\t(in cleanup)", and appended to the current value -of C<$@>. an error will not be appended if that same error string is -already at the end of C<$@>. - -In addition, a warning is generated using the appended string. This can be -disabled using C<no warnings 'misc'>. +When G_KEEPERR is used, any error in the called code will terminate the +call as usual, and the error will not propagate beyond the call (as usual +for G_EVAL), but it will not go into C<$@>. Instead the error will be +converted into a warning, prefixed with the string "\t(in cleanup)". +This can be disabled using C<no warnings 'misc'>. If there is no error, +C<$@> will not be cleared. The G_KEEPERR flag was introduced in Perl version 5.002. @@ -986,12 +983,15 @@ version of the call_Subtract example above inside a destructor: sub foo { die "foo dies"; } package main; - eval { Foo->new->foo }; + { + my $foo = Foo->new; + eval { $foo->foo }; + } print "Saw: $@" if $@; # should be, but isn't This example will fail to recognize that an error occurred inside the C<eval {}>. Here's why: the call_Subtract code got executed while perl -was cleaning up temporaries when exiting the eval block, and because +was cleaning up temporaries when exiting the outer braced block, and because call_Subtract is implemented with I<call_pv> using the G_EVAL flag, it promptly reset C<$@>. This results in the failure of the outermost test for C<$@>, and thereby the failure of the error trap. @@ -1633,29 +1633,8 @@ Perl_die_unwind(pTHX_ SV *msv) *msg ? msg : "Unknown error\n"); } if (in_eval & EVAL_KEEPERR) { - static const char prefix[] = "\t(in cleanup) "; - SV * const err = ERRSV; - const char *e = NULL; - if (!SvPOK(err)) - sv_setpvs(err,""); - else if (SvCUR(err) >= sizeof(prefix)+SvCUR(exceptsv)-1) { - STRLEN len; - STRLEN msglen; - const char* message = SvPV_const(exceptsv, msglen); - e = SvPV_const(err, len); - e += len - msglen; - if (*e != *message || strNE(e,message)) - e = NULL; - } - if (!e) { - STRLEN start; - SvGROW(err, SvCUR(err)+sizeof(prefix)+SvCUR(exceptsv)); - sv_catpvn(err, prefix, sizeof(prefix)-1); - sv_catsv(err, exceptsv); - start = SvCUR(err)-SvCUR(exceptsv)-sizeof(prefix)+1; - Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "%s", - SvPVX_const(err)+start); - } + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s", + SvPV_nolen_const(exceptsv)); } else { sv_setsv(ERRSV, exceptsv); diff --git a/t/lib/warnings/pp_ctl b/t/lib/warnings/pp_ctl index afaf0a78db..9b3f2982e4 100644 --- a/t/lib/warnings/pp_ctl +++ b/t/lib/warnings/pp_ctl @@ -205,6 +205,24 @@ DESTROY { die "@{$_[0]} foo bar" } { bless ['B'], 'Foo' for 1..10 } EXPECT (in cleanup) A foo bar at - line 4. + (in cleanup) A foo bar at - line 4. + (in cleanup) A foo bar at - line 4. + (in cleanup) A foo bar at - line 4. + (in cleanup) A foo bar at - line 4. + (in cleanup) A foo bar at - line 4. + (in cleanup) A foo bar at - line 4. + (in cleanup) A foo bar at - line 4. + (in cleanup) A foo bar at - line 4. + (in cleanup) A foo bar at - line 4. + (in cleanup) B foo bar at - line 4. + (in cleanup) B foo bar at - line 4. + (in cleanup) B foo bar at - line 4. + (in cleanup) B foo bar at - line 4. + (in cleanup) B foo bar at - line 4. + (in cleanup) B foo bar at - line 4. + (in cleanup) B foo bar at - line 4. + (in cleanup) B foo bar at - line 4. + (in cleanup) B foo bar at - line 4. (in cleanup) B foo bar at - line 4. ######## # pp_ctl.c diff --git a/t/op/die_keeperr.t b/t/op/die_keeperr.t new file mode 100644 index 0000000000..9b41cb5935 --- /dev/null +++ b/t/op/die_keeperr.t @@ -0,0 +1,45 @@ +#!perl -w + +BEGIN { + chdir 't' if -d 't'; + require 'test.pl'; + plan(20); +} + +sub End::DESTROY { $_[0]->() } + +sub end(&) { + my($c) = @_; + return bless(sub { $c->() }, "End"); +} + +foreach my $inx ("", "aabbcc\n", [qw(aa bb cc)]) { + foreach my $outx ("", "xxyyzz\n", [qw(xx yy zz)]) { + my $warn = ""; + local $SIG{__WARN__} = sub { $warn .= $_[0] }; + { + $@ = $outx; + my $e = end { die $inx if $inx }; + } + ok ref($@) eq ref($outx) && $@ eq $outx; + $warn =~ s/ at [^\n]*\n\z//; + is $warn, $inx ? "\t(in cleanup) $inx" : ""; + } +} + +{ + no warnings "misc"; + my $warn = ""; + local $SIG{__WARN__} = sub { $warn .= $_[0] }; + { my $e = end { die "aa\n"; }; } + is $warn, ""; +} + +{ + my $warn = ""; + local $SIG{__WARN__} = sub { $warn .= $_[0] }; + { my $e = end { no warnings "misc"; die "aa\n"; }; } + is $warn, "\t(in cleanup) aa\n"; +} + +1; |