In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/69a8a234c3a2ac32565c2a341127dbd2cbf56025?hp=d2faed7ebc061063b8653f41b973fecae2dbad90>
- Log ----------------------------------------------------------------- commit 69a8a234c3a2ac32565c2a341127dbd2cbf56025 Author: Father Chrysostomos <[email protected]> Date: Thu Jan 26 22:29:42 2012 -0800 Make blead upstream for warnings.pm This isnât even a dual-life module. Why it has its own entry I donât know; but in any case it has to have blead for upstream, otherwise cmp_version.t skips it. M Porting/Maintainers.pl commit 41ac5f6f523429f1cf16ffb5b09af82c921712c2 Author: Father Chrysostomos <[email protected]> Date: Thu Jan 26 20:45:28 2012 -0800 Increase $warnings::VERSION to 1.13 M lib/warnings.pm M regen/warnings.pl commit 7e4f04509c6d4e8d2ed0e31eaf59004e5c930b39 Author: Father Chrysostomos <[email protected]> Date: Thu Jan 26 20:43:17 2012 -0800 Allow ${^WARNING_BITS} to turn off lexical warnings Various magical modules copy hints from one scope to another. But copying ${^WARNING_BITS} doesnât always copy the same hints. If lexi- cal warnings are not on at all, ${^WARNING_BITS} returns a different value depending on the current value of $^W. Setting ${^WARNING_BITS} to its own value when $^W is true will stop $^W from being able to control the warnings in the current compilation scope. Setting ${^WARNING_BITS} to its own value when $^W is false causes even default warnings to be suppressed. This commit makes undef a special value that represents the default state, in which $^W controls warnings. M lib/warnings.pm M mg.c M regen/warnings.pl M t/comp/hints.t commit cc88c9aaa7ecb8334614c515caf0da2d5538403b Author: Father Chrysostomos <[email protected]> Date: Thu Jan 26 16:31:53 2012 -0800 pat.t: Test that . overloading gets passed qr ref This is something that my sample patch in ticked #108780 (for fixing /foo$qr/ under âno overloadingâ) would have broken had it been applied. M t/re/pat.t ----------------------------------------------------------------------- Summary of changes: Porting/Maintainers.pl | 2 +- lib/warnings.pm | 6 +++--- mg.c | 12 ++++-------- regen/warnings.pl | 6 +++--- t/comp/hints.t | 22 ++++++++++++++++++++-- t/re/pat.t | 19 ++++++++++++++++++- 6 files changed, 49 insertions(+), 18 deletions(-) diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index b110866..716e098 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -2002,7 +2002,7 @@ use File::Glob qw(:case); lib/warnings t/lib/warnings ], - 'UPSTREAM' => undef, + 'UPSTREAM' => 'blead', }, 'win32' => { diff --git a/lib/warnings.pm b/lib/warnings.pm index 90a9d0a..5aef8ea 100644 --- a/lib/warnings.pm +++ b/lib/warnings.pm @@ -5,7 +5,7 @@ package warnings; -our $VERSION = '1.12'; +our $VERSION = '1.13'; # Verify that we're called correctly so that warnings will work. # see also strict.pm. @@ -386,7 +386,7 @@ sub import { shift; - my $mask = ${^WARNING_BITS} ; + my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $NONE) ; if (vec($mask, $Offsets{'all'}, 1)) { $mask |= $Bits{'all'} ; @@ -402,7 +402,7 @@ sub unimport shift; my $catmask ; - my $mask = ${^WARNING_BITS} ; + my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $NONE) ; if (vec($mask, $Offsets{'all'}, 1)) { $mask |= $Bits{'all'} ; diff --git a/mg.c b/mg.c index b72c74a..14e9705 100644 --- a/mg.c +++ b/mg.c @@ -943,11 +943,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) sv_setpvn(sv, WARN_NONEstring, WARNsize) ; } else if (PL_compiling.cop_warnings == pWARN_STD) { - sv_setpvn( - sv, - (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring, - WARNsize - ); + sv_setsv(sv, &PL_sv_undef); + break; } else if (PL_compiling.cop_warnings == pWARN_ALL) { /* Get the bit mask for $warnings::Bits{all}, because @@ -2665,9 +2662,8 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) { if ( ! (PL_dowarn & G_WARN_ALL_MASK)) { - if (!SvPOK(sv) && PL_localizing) { - sv_setpvn(sv, WARN_NONEstring, WARNsize); - PL_compiling.cop_warnings = pWARN_NONE; + if (!SvPOK(sv)) { + PL_compiling.cop_warnings = pWARN_STD; break; } { diff --git a/regen/warnings.pl b/regen/warnings.pl index 3d65d87..b3e1c04 100644 --- a/regen/warnings.pl +++ b/regen/warnings.pl @@ -427,7 +427,7 @@ read_only_bottom_close_and_rename($pm); __END__ package warnings; -our $VERSION = '1.12'; +our $VERSION = '1.13'; # Verify that we're called correctly so that warnings will work. # see also strict.pm. @@ -635,7 +635,7 @@ sub import { shift; - my $mask = ${^WARNING_BITS} ; + my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $NONE) ; if (vec($mask, $Offsets{'all'}, 1)) { $mask |= $Bits{'all'} ; @@ -651,7 +651,7 @@ sub unimport shift; my $catmask ; - my $mask = ${^WARNING_BITS} ; + my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $NONE) ; if (vec($mask, $Offsets{'all'}, 1)) { $mask |= $Bits{'all'} ; diff --git a/t/comp/hints.t b/t/comp/hints.t index 835e1e2..8401ec9 100644 --- a/t/comp/hints.t +++ b/t/comp/hints.t @@ -6,7 +6,7 @@ BEGIN { @INC = qw(. ../lib); } -BEGIN { print "1..28\n"; } +BEGIN { print "1..29\n"; } BEGIN { print "not " if exists $^H{foo}; print "ok 1 - \$^H{foo} doesn't exist initially\n"; @@ -198,6 +198,24 @@ print "ok 26 - no crash when cloning a tied hint hash\n"; print "# got: $w" if $w; } +# Setting ${^WARNING_HINTS} to its own value should not change things. +{ + my $w; + local $SIG{__WARN__} = sub { $w++ }; + BEGIN { + # should have no effect: + my $x = ${^WARNING_BITS}; + ${^WARNING_BITS} = $x; + } + { + local $^W = 1; + () = 1 + undef; + } + print "# ", $w//'no', " warnings\nnot " unless $w == 1; + print "ok 28 - ", + "setting \${^WARNING_BITS} to its own value has no effect\n"; +} + # Add new tests above this require, in case it fails. require './test.pl'; @@ -208,7 +226,7 @@ my $result = runperl( stderr => 1 ); print "not " if length $result; -print "ok 28 - double-freeing hints hash\n"; +print "ok 29 - double-freeing hints hash\n"; print "# got: $result\n" if length $result; __END__ diff --git a/t/re/pat.t b/t/re/pat.t index 7b03e41..6c4cd1a 100644 --- a/t/re/pat.t +++ b/t/re/pat.t @@ -21,7 +21,7 @@ BEGIN { require './test.pl'; } -plan tests => 465; # Update this when adding/deleting tests. +plan tests => 466; # Update this when adding/deleting tests. run_tests() unless caller; @@ -1222,6 +1222,23 @@ EOP eval ' sub { my @a =~ // } '; } + { # Concat overloading and qr// thingies + my @refs; + my $qr = qr//; + package Cat { + use overload + '""' => sub { ${$_[0]} }, + '.' => sub { + push @refs, ref $_[1] if ref $_[1]; + bless $_[2] ? \"$_[1]${$_[0]}" : \"${$_[0]}$_[1]" + } + } + my $s = "foo"; + my $o = bless \$s, Cat::; + /$o$qr/; + is "@refs", "Regexp", '/$o$qr/ passes qr ref to cat overload meth'; + } + } # End of sub run_tests 1; -- Perl5 Master Repository
