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