Commit | Line | Data |
---|---|---|
920dae64 AT |
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; |