propagate failures in DESTROY() as (optional) warnings

p4raw-id: //depot/perl@2245

diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 4e09da0..29ed897 100644 (file)
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -143,6 +143,18 @@ Perl yourself.
 instead of Perl.  Check the #! line, or manually feed your script
 into Perl yourself.
 
+=item         (in cleanup) %s
+
+(W) This prefix usually indicates that a DESTROY() method raised
+the indicated exception.  Since destructors are usually called by
+the system at arbitrary points during execution, and often a vast
+number of times, the warning is issued only once for any number
+of failures that would otherwise result in the same message being
+repeated.
+
+Failure of user callbacks dispatched using the C<G_KEEPERR> flag
+could also result in this warning.  See L<perlcall/G_KEEPERR>.
+
 =item         (Missing semicolon on previous line?)
 
 (S) This is an educated guess made in conjunction with the message "%s

diff --git a/pp_ctl.c b/pp_ctl.c
index 0f02c66..e4b8a73 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1253,6 +1253,8 @@ die_where(char *message)
                        SvGROW(err, SvCUR(err)+sizeof(prefix)+klen);
                        sv_catpvn(err, prefix, sizeof(prefix)-1);
                        sv_catpvn(err, message, klen);
+                       if (ckWARN(WARN_UNSAFE))
+                           warner(WARN_UNSAFE, SvPVX(err));
                    }
                    sv_inc(*svp);
                }

diff --git a/t/pragma/warn/pp_ctl b/t/pragma/warn/pp_ctl
index 4f17f1f..70c67fa 100644 (file)
--- a/t/pragma/warn/pp_ctl
+++ b/t/pragma/warn/pp_ctl
@@ -53,6 +53,10 @@
         
        goto &fred()
 
+      (in cleanup) foo bar
+       package Foo;
+       DESTROY { die "foo bar" }
+       { bless [], 'Foo' for 1..10 }
 
 __END__
 # pp_ctl.c
@@ -143,3 +147,11 @@ sub fred
 goto &fred()
 EXPECT
 Deep recursion on subroutine "main::fred" at - line 6.
+########
+# pp_ctl.c
+use warning 'unsafe' ;
+package Foo;
+DESTROY { die "@{$_[0]} foo bar" }
+{ bless ['A'], 'Foo' for 1..10 }
+EXPECT
+       (in cleanup) A foo bar at - line 4.