This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
bring G_KEEPERR back to the realm of sanity
authorZefram <zefram@fysh.org>
Fri, 23 Apr 2010 01:22:54 +0000 (02:22 +0100)
committerZefram <zefram@fysh.org>
Fri, 23 Apr 2010 01:22:54 +0000 (02:22 +0100)
Makes the G_KEEPERR logic more consistent, and in particular make it
sensibly handle non-string exceptions.  An exception in a destructor
is now always emitted as a warning, and never copied or merged into
$@ of the surrounding context.  No more clobbering exceptions being
handled elsewhere, and no more double reporting.  This fixes the rest of
[perl #74538].

MANIFEST
cop.h
ext/XS-APItest/t/call.t
pod/perlcall.pod
pp_ctl.c
t/lib/warnings/pp_ctl
t/op/die_keeperr.t [new file with mode: 0644]

index 62e5587..4b1781b 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -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
diff --git a/cop.h b/cop.h
index 6c51d73..73c7681 100644 (file)
--- a/cop.h
+++ b/cop.h
@@ -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
index e7c1545..373a1af 100644 (file)
@@ -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)");
index 359e097..f34a53d 100644 (file)
@@ -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.
index f401fc7..1be7b68 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -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);
index afaf0a7..9b3f298 100644 (file)
@@ -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 (file)
index 0000000..9b41cb5
--- /dev/null
@@ -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;