da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chinpackage re;
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chinour $VERSION = 0.04;
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin=head1 NAME
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chinre - Perl pragma to alter regular expression behaviour
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin=head1 SYNOPSIS
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin use re 'taint';
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin ($x) = ($^X =~ /^(.*)$/s); # $x is tainted here
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin $pat = '(?{ $foo = 1 })';
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin use re 'eval';
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin /foo${pat}bar/; # won't fail (when not under -T switch)
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin {
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin no re 'taint'; # the default
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin ($x) = ($^X =~ /^(.*)$/s); # $x is not tainted here
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin no re 'eval'; # the default
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin /foo${pat}bar/; # disallowed (with or without -T switch)
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin }
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin use re 'debug'; # NOT lexically scoped (as others are)
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin /^(.*)$/s; # output debugging info during
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin # compile and run time
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin use re 'debugcolor'; # same as 'debug', but with colored output
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin ...
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin(We use $^X in these examples because it's tainted by default.)
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin=head1 DESCRIPTION
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chinWhen C<use re 'taint'> is in effect, and a tainted string is the target
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chinof a regex, the regex memories (or values returned by the m// operator
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chinin list context) are tainted. This feature is useful when regex operations
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chinon tainted data aren't meant to extract safe substrings, but to perform
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chinother transformations.
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chinWhen C<use re 'eval'> is in effect, a regex is allowed to contain
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chinC<(?{ ... })> zero-width assertions even if regular expression contains
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chinvariable interpolation. That is normally disallowed, since it is a
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chinpotential security risk. Note that this pragma is ignored when the regular
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chinexpression is obtained from tainted data, i.e. evaluation is always
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chindisallowed with tainted regular expresssions. See L<perlre/(?{ code })>.
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chinFor the purpose of this pragma, interpolation of precompiled regular
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chinexpressions (i.e., the result of C<qr//>) is I<not> considered variable
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chininterpolation. Thus:
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin /foo${pat}bar/
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chinI<is> allowed if $pat is a precompiled regular expression, even
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chinif $pat contains C<(?{ ... })> assertions.
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chinWhen C<use re 'debug'> is in effect, perl emits debugging messages when
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chincompiling and using regular expressions. The output is the same as that
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chinobtained by running a C<-DDEBUGGING>-enabled perl interpreter with the
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chinB<-Dr> switch. It may be quite voluminous depending on the complexity
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chinof the match. Using C<debugcolor> instead of C<debug> enables a
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chinform of output that can be used to get a colorful display on terminals
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chinthat understand termcap color sequences. Set C<$ENV{PERL_RE_TC}> to a
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chincomma-separated list of C<termcap> properties to use for highlighting
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chinstrings on/off, pre-point part on/off.
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chinSee L<perldebug/"Debugging regular expressions"> for additional info.
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chinThe directive C<use re 'debug'> is I<not lexically scoped>, as the
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chinother directives are. It has both compile-time and run-time effects.
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chinSee L<perlmodlib/Pragmatic Modules>.
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin=cut
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin# N.B. File::Basename contains a literal for 'taint' as a fallback. If
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin# taint is changed here, File::Basename must be updated as well.
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chinmy %bitmask = (
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chintaint => 0x00100000, # HINT_RE_TAINT
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chineval => 0x00200000, # HINT_RE_EVAL
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin);
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chinsub setcolor {
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin eval { # Ignore errors
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin require Term::Cap;
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin my $terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning.
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin my $props = $ENV{PERL_RE_TC} || 'md,me,so,se,us,ue';
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin my @props = split /,/, $props;
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin my $colors = join "\t", map {$terminal->Tputs($_,1)} @props;
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin $colors =~ s/\0//g;
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin $ENV{PERL_RE_COLORS} = $colors;
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin };
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin}
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chinsub bits {
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin my $on = shift;
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin my $bits = 0;
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin unless (@_) {
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin require Carp;
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin Carp::carp("Useless use of \"re\" pragma");
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin }
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin foreach my $s (@_){
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin if ($s eq 'debug' or $s eq 'debugcolor') {
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin setcolor() if $s eq 'debugcolor';
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin require XSLoader;
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin XSLoader::load('re');
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin install() if $on;
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin uninstall() unless $on;
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin next;
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin }
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin if (exists $bitmask{$s}) {
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin $bits |= $bitmask{$s};
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin } else {
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin require Carp;
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin Carp::carp("Unknown \"re\" subpragma '$s' (known ones are: @{[join(', ', map {qq('$_')} 'debug', 'debugcolor', sort keys %bitmask)]})");
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin }
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin }
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin $bits;
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin}
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chinsub import {
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin shift;
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin $^H |= bits(1, @_);
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin}
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chinsub unimport {
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin shift;
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin $^H &= ~ bits(0, @_);
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin}
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin1;
da2e3ebdc1edfbc5028edf1354e7dd2fa69a7968chin