Change 18829 by [EMAIL PROTECTED] on 2003/03/04 22:23:41
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.
Affected files ...
... //depot/perl/mg.c#260 edit
... //depot/perl/pp_ctl.c#348 edit
... //depot/perl/t/op/caller.t#3 edit
Differences ...
==== //depot/perl/mg.c#260 (text) ====
Index: perl/mg.c
--- perl/mg.c#259~18803~ Sun Mar 2 08:12:34 2003
+++ perl/mg.c Tue Mar 4 14:23:41 2003
@@ -676,7 +676,16 @@
sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
}
else if (PL_compiling.cop_warnings == pWARN_ALL) {
- sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
+ /* 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))) {
+ sv_setsv(sv, *bits_all);
+ }
+ else {
+ sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
+ }
}
else {
sv_setsv(sv, PL_compiling.cop_warnings);
==== //depot/perl/pp_ctl.c#348 (text) ====
Index: perl/pp_ctl.c
--- perl/pp_ctl.c#347~18801~ Sun Mar 2 07:24:22 2003
+++ perl/pp_ctl.c Tue Mar 4 14:23:41 2003
@@ -1635,8 +1635,18 @@
(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));
==== //depot/perl/t/op/caller.t#3 (text) ====
Index: perl/t/op/caller.t
--- perl/t/op/caller.t#2~16662~ Fri May 17 13:07:21 2002
+++ perl/t/op/caller.t Tue Mar 4 14:23:41 2003
@@ -5,10 +5,9 @@
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
+ plan( tests => 27 );
}
-plan( tests => 20 );
-
my @c;
print "# Tests with caller(0)\n";
@@ -63,3 +62,26 @@
$fooref2 -> ();
is( $c[3], "(unknown)", "unknown subroutine name" );
ok( $c[4], "hasargs true with unknown sub" );
+
+# See if caller() returns the correct warning mask
+
+sub testwarn {
+ my $w = shift;
+ is( (caller(0))[9], $w, "warnings");
+}
+
+# NB : extend the warning mask values below when new warnings are added
+{
+ no warnings;
+ BEGIN { is( ${^WARNING_BITS}, "\0" x 12, 'warning bits' ) }
+ testwarn("\0" x 12);
+ use warnings;
+ BEGIN { is( ${^WARNING_BITS}, "U" x 12, 'warning bits' ) }
+ BEGIN { testwarn("U" x 12); }
+ # run-time :
+ # the warning mask has been extended by warnings::register
+ testwarn("UUUUUUUUUUUU\001");
+ use warnings::register;
+ BEGIN { is( ${^WARNING_BITS}, "UUUUUUUUUUUU\001", 'warning bits' ) }
+ testwarn("UUUUUUUUUUUU\001");
+}
End of Patch.
