| 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; |