X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2Fre%2Fre.pm;h=edc6cb8eb77d228807930459c53a3ec2f80e0032;hb=1e2a0f0b335850099f95fa1c4512aa7b8b89dd77;hp=a033d97c944e2ceb8d141b64bf29378c458927c8;hpb=2cd61cdbd64958437da8294b84109bc8b63ab360;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/re/re.pm b/ext/re/re.pm index a033d97..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 @@ -23,9 +23,18 @@ re - Perl pragma to alter regular expression behaviour /foo${pat}bar/; # disallowed (with or without -T switch) } - use re 'debug'; - /^(.*)$/s; # output debugging info - # during compile and run time + use re 'debug'; # NOT lexically scoped (as others are) + /^(.*)$/s; # output debugging info during + # compile and run time + + 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 @@ -37,69 +46,162 @@ 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 preexisting regular -expressions is I considered a variable interpolation, thus +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 preexisting regular expressions, 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 -of the match. +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. See L for additional info. -I is not lexically scoped.> 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. =cut +# 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 { + eval { # Ignore errors + require Term::Cap; + + my $terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning. + my $props = $ENV{PERL_RE_TC} || 'md,me,so,se,us,ue'; + my @props = split /,/, $props; + my $colors = join "\t", map {$terminal->Tputs($_,1)} @props; + + $colors =~ s/\0//g; + $ENV{PERL_RE_COLORS} = $colors; + }; +} + +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') { - eval <<'EOE'; - use DynaLoader; - @ISA = ('DynaLoader'); - bootstrap re; -EOE - 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;