X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2Fre%2Fre.pm;h=edc6cb8eb77d228807930459c53a3ec2f80e0032;hb=1e2a0f0b335850099f95fa1c4512aa7b8b89dd77;hp=3f142d9de4852cd0a7329b93002d802de5351368;hpb=9426adcd48655815b65cea5a9f1eebbe7e23a9df;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/re/re.pm b/ext/re/re.pm index 3f142d9..edc6cb8 100644 --- a/ext/re/re.pm +++ b/ext/re/re.pm @@ -1,6 +1,6 @@ package re; -$VERSION = 0.02; +our $VERSION = 0.05; =head1 NAME @@ -30,6 +30,10 @@ re - Perl pragma to alter regular expression behaviour use re 'debugcolor'; # same as 'debug', but with colored output ... + use re qw(Debug All); # Finer tuned debugging options. + use re qw(Debug More); # Similarly not lexically scoped. + no re qw(Debug ALL); # Turn of all re dugging and unload the module. + (We use $^X in these examples because it's tainted by default.) =head1 DESCRIPTION @@ -42,21 +46,21 @@ other transformations. When C is in effect, a regex is allowed to contain C<(?{ ... })> zero-width assertions even if regular expression contains -variable interpolation. That is normally disallowed, since it is a +variable interpolation. That is normally disallowed, since it is a potential security risk. Note that this pragma is ignored when the regular expression is obtained from tainted data, i.e. evaluation is always disallowed with tainted regular expresssions. See L. -For the purpose of this pragma, interpolation of precompiled regular +For the purpose of this pragma, interpolation of precompiled regular expressions (i.e., the result of C) is I considered variable interpolation. Thus: /foo${pat}bar/ -I allowed if $pat is a precompiled regular expression, even +I allowed if $pat is a precompiled regular expression, even if $pat contains C<(?{ ... })> assertions. -When C is in effect, perl emits debugging messages when +When C is in effect, perl emits debugging messages when compiling and using regular expressions. The output is the same as that obtained by running a C<-DDEBUGGING>-enabled perl interpreter with the B<-Dr> switch. It may be quite voluminous depending on the complexity @@ -64,11 +68,32 @@ of the match. Using C instead of C enables a form of output that can be used to get a colorful display on terminals that understand termcap color sequences. Set C<$ENV{PERL_RE_TC}> to a comma-separated list of C properties to use for highlighting -strings on/off, pre-point part on/off. +strings on/off, pre-point part on/off. See L for additional info. -The directive C is I, as the -other directives are. It has both compile-time and run-time effects. +Similarly C produces debugging output, the difference +being that it allows the fine tuning of what debugging output will be +emitted. Following the 'Debug' keyword one of several options may be +provided: COMPILE, EXECUTE, TRIE_COMPILE, TRIE_EXECUTE, TRIE_MORE, +OPTIMISE, OFFSETS and ALL. Additionally the special keywords 'All' and +'More' may be provided. 'All' represents everything but OPTIMISE and +OFFSETS and TRIE_MORE, and 'More' is similar but include TRIE_MORE. +Saying C<< no re Debug => 'EXECUTE' >> will disable executing debug +statements and saying C<< use re Debug => 'EXECUTE' >> will turn it on. Note +that these flags can be set directly via ${^RE_DEBUG_FLAGS} by using the +following flag values: + + RE_DEBUG_COMPILE 1 + RE_DEBUG_EXECUTE 2 + RE_DEBUG_TRIE_COMPILE 4 + RE_DEBUG_TRIE_EXECUTE 8 + RE_DEBUG_TRIE_MORE 16 + RE_DEBUG_OPTIMISE 32 + RE_DEBUG_OFFSETS 64 + +The directive C and its equivalents are I lexically +scoped, as the other directives are. They have both compile-time and run-time +effects. See L. @@ -77,8 +102,8 @@ See L. # N.B. File::Basename contains a literal for 'taint' as a fallback. If # taint is changed here, File::Basename must be updated as well. my %bitmask = ( -taint => 0x00100000, -eval => 0x00200000, +taint => 0x00100000, # HINT_RE_TAINT +eval => 0x00200000, # HINT_RE_EVAL ); sub setcolor { @@ -95,35 +120,88 @@ sub setcolor { }; } +my %flags = ( + COMPILE => 1, + EXECUTE => 2, + TRIE_COMPILE => 4, + TRIE_EXECUTE => 8, + TRIE_MORE => 16, + OPTIMISE => 32, + OPTIMIZE => 32, # alias + OFFSETS => 64, + ALL => 127, + All => 15, + More => 31, +); + +my $installed = 0; + sub bits { my $on = shift; my $bits = 0; - unless(@_) { + unless (@_) { require Carp; Carp::carp("Useless use of \"re\" pragma"); } - foreach my $s (@_){ - if ($s eq 'debug' or $s eq 'debugcolor') { - setcolor() if $s eq 'debugcolor'; - require XSLoader; - XSLoader::load('re'); - install() if $on; - uninstall() unless $on; - next; - } - $bits |= $bitmask{$s} || 0; + foreach my $idx (0..$#_){ + my $s=$_[$idx]; + if ($s eq 'Debug' or $s eq 'Debugcolor') { + setcolor() if $s eq 'Debugcolor'; + ${^RE_DEBUG_FLAGS} = 0 unless defined ${^RE_DEBUG_FLAGS}; + require XSLoader; + XSLoader::load('re'); + for my $idx ($idx+1..$#_) { + if ($flags{$_[$idx]}) { + if ($on) { + ${^RE_DEBUG_FLAGS} |= $flags{$_[$idx]}; + } else { + ${^RE_DEBUG_FLAGS} &= ~ $flags{$_[$idx]}; + } + } else { + require Carp; + Carp::carp("Unknown \"re\" Debug flag '$_[$idx]', possible flags: ", + join(", ",sort { $flags{$a} <=> $flags{$b} } keys %flags ) ); + } + } + if ($on) { + install() unless $installed; + $installed = 1; + } elsif (!${^RE_DEBUG_FLAGS}) { + uninstall() if $installed; + $installed = 0; + } + last; + } elsif ($s eq 'debug' or $s eq 'debugcolor') { + setcolor() if $s eq 'debugcolor'; + require XSLoader; + XSLoader::load('re'); + if ($on) { + install() unless $installed; + $installed=1; + } else { + uninstall() if $installed; + $installed=0; + } + } elsif (exists $bitmask{$s}) { + $bits |= $bitmask{$s}; + } else { + require Carp; + Carp::carp("Unknown \"re\" subpragma '$s' (known ones are: ", + join(', ', map {qq('$_')} 'debug', 'debugcolor', sort keys %bitmask), + ")"); + } } $bits; } sub import { shift; - $^H |= bits(1,@_); + $^H |= bits(1, @_); } sub unimport { shift; - $^H &= ~ bits(0,@_); + $^H &= ~ bits(0, @_); } 1;