Patch by Salvador Fandiño to read the warning mask

returned by caller() and ${^WARNING_BITS} from
$warnings::Bits{all} and not from the hardcoded core
constant. (This mask could have been extended by
warnings::register.) Plus tests.

p4raw-id: //depot/perl@18829

1 files changed, 12 insertions, 2 deletions

diff --git a/pp_ctl.c b/pp_ctl.c
index 68204ce53c..5143391289 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1635,8 +1635,18 @@ PP(pp_caller)
 		(old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
         else if (old_warnings == pWARN_ALL ||
-		  (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
-            mask = newSVpvn(WARN_ALLstring, WARNsize) ;
+		  (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
+	    /* Get the bit mask for $warnings::Bits{all}, because
+	     * it could have been extended by warnings::register */
+	    SV **bits_all;
+	    HV *bits = get_hv("warnings::Bits", FALSE);
+	    if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
+		mask = newSVsv(*bits_all);
+	    }
+	    else {
+		mask = newSVpvn(WARN_ALLstring, WARNsize) ;
+	    }
+	}
         else
             mask = newSVsv(old_warnings);
         PUSHs(sv_2mortal(mask));