In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/3ab1d9735c654257fb7abf549e007d510bbb718f?hp=a57d3d4daf4971adfdd5495458434fbba9257efe>
- Log ----------------------------------------------------------------- commit 3ab1d9735c654257fb7abf549e007d510bbb718f Author: Karl Williamson <[email protected]> Date: Wed Feb 4 10:31:15 2015 -0700 Make 'no re' work A plain 'no re'; without subpragmas prior to this commit only turned off a few things. Now it turns off all the enabled things. For example, previously, you couldn't turn off debugging, once enabled, inside the same block. M ext/re/re.pm M ext/re/t/lexical_debug.pl M ext/re/t/lexical_debug.t M ext/re/t/reflags.t M ext/re/t/strict.t commit 5e3921fba1b330ae984b7e20387e886de1057c05 Author: Karl Williamson <[email protected]> Date: Wed Feb 4 11:39:32 2015 -0700 ext/re/t/re.t: Use variable instead of constants There are multiple occurrences of these constants in the file. It's better to use a variable than to repeat them. M ext/re/t/re.t commit 0e1658289f9097483ef0df19536b15fbc6a92511 Author: Karl Williamson <[email protected]> Date: Wed Feb 4 11:46:08 2015 -0700 re.pm: Bump version to 0.31 M ext/re/re.pm ----------------------------------------------------------------------- Summary of changes: ext/re/re.pm | 22 ++++++++++++++++++++-- ext/re/t/lexical_debug.pl | 9 ++++++++- ext/re/t/lexical_debug.t | 6 ++++-- ext/re/t/re.t | 15 +++++++++------ ext/re/t/reflags.t | 14 +++++++++++++- ext/re/t/strict.t | 9 ++++++++- 6 files changed, 62 insertions(+), 13 deletions(-) diff --git a/ext/re/re.pm b/ext/re/re.pm index 5ddaa21..fa1c6e6 100644 --- a/ext/re/re.pm +++ b/ext/re/re.pm @@ -4,7 +4,7 @@ package re; use strict; use warnings; -our $VERSION = "0.30"; +our $VERSION = "0.31"; our @ISA = qw(Exporter); our @EXPORT_OK = ('regmust', qw(is_regexp regexp_pattern @@ -111,7 +111,17 @@ sub _load_unload { sub bits { my $on = shift; my $bits = 0; + my $turning_all_off = ! @_ && ! $on; my %seen; # Has flag already been seen? + if ($turning_all_off) { + + # Pretend were called with certain parameters, which are best dealt + # with XXX + push @_, keys %bitmask; # taint and eval + push @_, 'strict'; + } + + # Process each subpragma parameter ARG: foreach my $idx (0..$#_){ my $s=$_[$idx]; @@ -156,7 +166,7 @@ sub bits { } } else { - $^H{reflags} &= ~$reflags{$s}; + $^H{reflags} &= ~$reflags{$s} if $^H{reflags}; # Turn off warnings if we turned them on. warnings->unimport('regexp') if $^H{re_strict}; @@ -249,6 +259,14 @@ sub bits { warnings::warn("regexp", $message); } } + + if ($turning_all_off) { + _load_unload(0); + $^H{reflags} = 0; + $^H{reflags_charset} = 0; + $^H &= ~$flags_hint; + } + $bits; } diff --git a/ext/re/t/lexical_debug.pl b/ext/re/t/lexical_debug.pl index 3ec7455..0e74bf0 100644 --- a/ext/re/t/lexical_debug.pl +++ b/ext/re/t/lexical_debug.pl @@ -1,6 +1,6 @@ use re 'debug'; -$_ = 'foo bar baz bop fip fop'; +$_ = 'foo bar baz bop boq bor fip fop'; /foo/ and $count++; @@ -14,6 +14,13 @@ $_ = 'foo bar baz bop fip fop'; /bop/ and $count++; } +{ + use re 'debug'; + /boq/ and $count++; + no re; + /bor/ and $count++; +} + /fip/ and $count++; no re 'debug'; diff --git a/ext/re/t/lexical_debug.t b/ext/re/t/lexical_debug.t index d4b7e62..b2570f0 100644 --- a/ext/re/t/lexical_debug.t +++ b/ext/re/t/lexical_debug.t @@ -15,7 +15,7 @@ use strict; BEGIN { require "../../t/test.pl"; } my $out = runperl(progfile => "t/lexical_debug.pl", stderr => 1 ); -print "1..10\n"; +print "1..12\n"; # Each pattern will produce an EXACT node with a specific string in # it, so we will look for that. We can't just look for the string @@ -25,11 +25,13 @@ ok( $out =~ /EXACT <foo>/, "Expect 'foo'" ); ok( $out !~ /EXACT <bar>/, "No 'bar'" ); ok( $out =~ /EXACT <baz>/, "Expect 'baz'" ); ok( $out !~ /EXACT <bop>/, "No 'bop'" ); +ok( $out =~ /EXACT <boq>/, "Expect 'boq'" ); +ok( $out !~ /EXACT <bor>/, "No 'bor'" ); ok( $out =~ /EXACT <fip>/, "Expect 'fip'" ); ok( $out !~ /EXACT <fop>/, "No 'baz'" ); ok( $out =~ /<liz>/, "Got 'liz'" ); # in a TRIE so no EXACT ok( $out =~ /<zoo>/, "Got 'zoo'" ); # in a TRIE so no EXACT ok( $out =~ /<zap>/, "Got 'zap'" ); # in a TRIE so no EXACT -ok( $out =~ /Count=7\n/, "Count is 7") +ok( $out =~ /Count=9\n/, "Count is 9") or diag($out); diff --git a/ext/re/t/re.t b/ext/re/t/re.t index 13498bb..353ff81 100644 --- a/ext/re/t/re.t +++ b/ext/re/t/re.t @@ -10,6 +10,9 @@ BEGIN { use strict; +my $re_taint_bit = 0x00100000; +my $re_eval_bit = 0x00200000; + use Test::More tests => 15; require_ok( 're' ); @@ -42,20 +45,20 @@ isnt( $ENV{PERL_RE_COLORS}, '', re::bits(0, 'nosuchsubpragma'); like( $warn, qr/Unknown "re" subpragma/, '... should warn about unknown subpragma' ); -ok( re::bits(0, 'taint') & 0x00100000, '... should set taint bits' ); -ok( re::bits(0, 'eval') & 0x00200000, '... should set eval bits' ); +ok( re::bits(0, 'taint') & $re_taint_bit, '... should set taint bits' ); +ok( re::bits(0, 'eval') & $re_eval_bit, '... should set eval bits' ); local $^H; # import re->import('taint', 'eval'); -ok( $^H & 0x00100000, 'import should set taint bits in $^H when requested' ); -ok( $^H & 0x00200000, 'import should set eval bits in $^H when requested' ); +ok( $^H & $re_taint_bit, 'import should set taint bits in $^H when requested' ); +ok( $^H & $re_eval_bit, 'import should set eval bits in $^H when requested' ); re->unimport('taint'); -ok( !( $^H & 0x00100000 ), 'unimport should clear bits in $^H when requested' ); +ok( !( $^H & $re_taint_bit ), 'unimport should clear bits in $^H when requested' ); re->unimport('eval'); -ok( !( $^H & 0x00200000 ), '... and again' ); +ok( !( $^H & $re_eval_bit ), '... and again' ); my $reg=qr/(foo|bar|baz|blah)/; close STDERR; eval"use re Debug=>'ALL'"; diff --git a/ext/re/t/reflags.t b/ext/re/t/reflags.t index e90a712..03c35a0 100644 --- a/ext/re/t/reflags.t +++ b/ext/re/t/reflags.t @@ -10,7 +10,7 @@ BEGIN { use strict; -use Test::More tests => 63; +use Test::More tests => 67; my @flags = qw( a d l u ); @@ -53,6 +53,18 @@ no re '/sm'; ok 'f r e l p' =~ /f r e l p/, "use re '/x' turns off when it drops out of scope"; +{ + use re '/i'; + ok "Foo" =~ /foo/, 'use re "/i"'; + no re; + ok "Foo" !~ /foo/, "bare 'no re' reverts to no /i"; + use re '/u'; + my $nbsp = chr utf8::unicode_to_native(0xa0); + ok $nbsp =~ /\s/, 'nbsp matches \\s under /u'; + no re; + ok $nbsp !~ /\s/, "bare 'no re' reverts to /d"; +} + SKIP: { if ( !$Config::Config{d_setlocale} diff --git a/ext/re/t/strict.t b/ext/re/t/strict.t index dd9c811..6cafabb 100644 --- a/ext/re/t/strict.t +++ b/ext/re/t/strict.t @@ -12,7 +12,7 @@ BEGIN { use strict; -use Test::More tests => 9; +use Test::More tests => 10; BEGIN { require_ok( 're' ); } { @@ -29,6 +29,13 @@ BEGIN { require_ok( 're' ); } qr/\b*/; BEGIN { is(scalar @w, 1, 'use re "strict" turns on warnings'); } + + BEGIN { undef @w; } + + no re 'strict'; + qr/\b*/; + + BEGIN { is(scalar @w, 0, 'no re "strict" restores warnings state'); } } BEGIN {undef @w; } -- Perl5 Master Repository
