[14489] | 1 | package re;
|
---|
| 2 |
|
---|
| 3 | our $VERSION = 0.05;
|
---|
| 4 |
|
---|
| 5 | =head1 NAME
|
---|
| 6 |
|
---|
| 7 | re - Perl pragma to alter regular expression behaviour
|
---|
| 8 |
|
---|
| 9 | =head1 SYNOPSIS
|
---|
| 10 |
|
---|
| 11 | use re 'taint';
|
---|
| 12 | ($x) = ($^X =~ /^(.*)$/s); # $x is tainted here
|
---|
| 13 |
|
---|
| 14 | $pat = '(?{ $foo = 1 })';
|
---|
| 15 | use re 'eval';
|
---|
| 16 | /foo${pat}bar/; # won't fail (when not under -T switch)
|
---|
| 17 |
|
---|
| 18 | {
|
---|
| 19 | no re 'taint'; # the default
|
---|
| 20 | ($x) = ($^X =~ /^(.*)$/s); # $x is not tainted here
|
---|
| 21 |
|
---|
| 22 | no re 'eval'; # the default
|
---|
| 23 | /foo${pat}bar/; # disallowed (with or without -T switch)
|
---|
| 24 | }
|
---|
| 25 |
|
---|
| 26 | use re 'debug'; # NOT lexically scoped (as others are)
|
---|
| 27 | /^(.*)$/s; # output debugging info during
|
---|
| 28 | # compile and run time
|
---|
| 29 |
|
---|
| 30 | use re 'debugcolor'; # same as 'debug', but with colored output
|
---|
| 31 | ...
|
---|
| 32 |
|
---|
| 33 | (We use $^X in these examples because it's tainted by default.)
|
---|
| 34 |
|
---|
| 35 | =head1 DESCRIPTION
|
---|
| 36 |
|
---|
| 37 | When C<use re 'taint'> is in effect, and a tainted string is the target
|
---|
| 38 | of a regex, the regex memories (or values returned by the m// operator
|
---|
| 39 | in list context) are tainted. This feature is useful when regex operations
|
---|
| 40 | on tainted data aren't meant to extract safe substrings, but to perform
|
---|
| 41 | other transformations.
|
---|
| 42 |
|
---|
| 43 | When C<use re 'eval'> is in effect, a regex is allowed to contain
|
---|
| 44 | C<(?{ ... })> zero-width assertions even if regular expression contains
|
---|
| 45 | variable interpolation. That is normally disallowed, since it is a
|
---|
| 46 | potential security risk. Note that this pragma is ignored when the regular
|
---|
| 47 | expression is obtained from tainted data, i.e. evaluation is always
|
---|
| 48 | disallowed with tainted regular expressions. See L<perlre/(?{ code })>.
|
---|
| 49 |
|
---|
| 50 | For the purpose of this pragma, interpolation of precompiled regular
|
---|
| 51 | expressions (i.e., the result of C<qr//>) is I<not> considered variable
|
---|
| 52 | interpolation. Thus:
|
---|
| 53 |
|
---|
| 54 | /foo${pat}bar/
|
---|
| 55 |
|
---|
| 56 | I<is> allowed if $pat is a precompiled regular expression, even
|
---|
| 57 | if $pat contains C<(?{ ... })> assertions.
|
---|
| 58 |
|
---|
| 59 | When C<use re 'debug'> is in effect, perl emits debugging messages when
|
---|
| 60 | compiling and using regular expressions. The output is the same as that
|
---|
| 61 | obtained by running a C<-DDEBUGGING>-enabled perl interpreter with the
|
---|
| 62 | B<-Dr> switch. It may be quite voluminous depending on the complexity
|
---|
| 63 | of the match. Using C<debugcolor> instead of C<debug> enables a
|
---|
| 64 | form of output that can be used to get a colorful display on terminals
|
---|
| 65 | that understand termcap color sequences. Set C<$ENV{PERL_RE_TC}> to a
|
---|
| 66 | comma-separated list of C<termcap> properties to use for highlighting
|
---|
| 67 | strings on/off, pre-point part on/off.
|
---|
| 68 | See L<perldebug/"Debugging regular expressions"> for additional info.
|
---|
| 69 |
|
---|
| 70 | The directive C<use re 'debug'> is I<not lexically scoped>, as the
|
---|
| 71 | other directives are. It has both compile-time and run-time effects.
|
---|
| 72 |
|
---|
| 73 | See L<perlmodlib/Pragmatic Modules>.
|
---|
| 74 |
|
---|
| 75 | =cut
|
---|
| 76 |
|
---|
| 77 | # N.B. File::Basename contains a literal for 'taint' as a fallback. If
|
---|
| 78 | # taint is changed here, File::Basename must be updated as well.
|
---|
| 79 | my %bitmask = (
|
---|
| 80 | taint => 0x00100000, # HINT_RE_TAINT
|
---|
| 81 | eval => 0x00200000, # HINT_RE_EVAL
|
---|
| 82 | );
|
---|
| 83 |
|
---|
| 84 | sub setcolor {
|
---|
| 85 | eval { # Ignore errors
|
---|
| 86 | require Term::Cap;
|
---|
| 87 |
|
---|
| 88 | my $terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning.
|
---|
| 89 | my $props = $ENV{PERL_RE_TC} || 'md,me,so,se,us,ue';
|
---|
| 90 | my @props = split /,/, $props;
|
---|
| 91 | my $colors = join "\t", map {$terminal->Tputs($_,1)} @props;
|
---|
| 92 |
|
---|
| 93 | $colors =~ s/\0//g;
|
---|
| 94 | $ENV{PERL_RE_COLORS} = $colors;
|
---|
| 95 | };
|
---|
| 96 | }
|
---|
| 97 |
|
---|
| 98 | sub bits {
|
---|
| 99 | my $on = shift;
|
---|
| 100 | my $bits = 0;
|
---|
| 101 | unless (@_) {
|
---|
| 102 | require Carp;
|
---|
| 103 | Carp::carp("Useless use of \"re\" pragma");
|
---|
| 104 | }
|
---|
| 105 | foreach my $s (@_){
|
---|
| 106 | if ($s eq 'debug' or $s eq 'debugcolor') {
|
---|
| 107 | setcolor() if $s eq 'debugcolor';
|
---|
| 108 | require XSLoader;
|
---|
| 109 | XSLoader::load('re');
|
---|
| 110 | install() if $on;
|
---|
| 111 | uninstall() unless $on;
|
---|
| 112 | next;
|
---|
| 113 | }
|
---|
| 114 | if (exists $bitmask{$s}) {
|
---|
| 115 | $bits |= $bitmask{$s};
|
---|
| 116 | } else {
|
---|
| 117 | require Carp;
|
---|
| 118 | Carp::carp("Unknown \"re\" subpragma '$s' (known ones are: @{[join(', ', map {qq('$_')} 'debug', 'debugcolor', sort keys %bitmask)]})");
|
---|
| 119 | }
|
---|
| 120 | }
|
---|
| 121 | $bits;
|
---|
| 122 | }
|
---|
| 123 |
|
---|
| 124 | sub import {
|
---|
| 125 | shift;
|
---|
| 126 | $^H |= bits(1, @_);
|
---|
| 127 | }
|
---|
| 128 |
|
---|
| 129 | sub unimport {
|
---|
| 130 | shift;
|
---|
| 131 | $^H &= ~ bits(0, @_);
|
---|
| 132 | }
|
---|
| 133 |
|
---|
| 134 | 1;
|
---|