Commit | Line | Data |
b3eb6a9b |
1 | package re; |
2 | |
56953603 |
3 | $VERSION = 0.02; |
4 | |
b3eb6a9b |
5 | =head1 NAME |
6 | |
7 | re - Perl pragma to alter regular expression behaviour |
8 | |
9 | =head1 SYNOPSIS |
10 | |
e4d48cc9 |
11 | use re 'taint'; |
12 | ($x) = ($^X =~ /^(.*)$/s); # $x is tainted here |
b3eb6a9b |
13 | |
2cd61cdb |
14 | $pat = '(?{ $foo = 1 })'; |
e4d48cc9 |
15 | use re 'eval'; |
2cd61cdb |
16 | /foo${pat}bar/; # won't fail (when not under -T switch) |
e4d48cc9 |
17 | |
18 | { |
19 | no re 'taint'; # the default |
20 | ($x) = ($^X =~ /^(.*)$/s); # $x is not tainted here |
21 | |
22 | no re 'eval'; # the default |
2cd61cdb |
23 | /foo${pat}bar/; # disallowed (with or without -T switch) |
e4d48cc9 |
24 | } |
b3eb6a9b |
25 | |
0a92e3a8 |
26 | use re 'debug'; # NOT lexically scoped (as others are) |
27 | /^(.*)$/s; # output debugging info during |
28 | # compile and run time |
2cd61cdb |
29 | |
02ea72ae |
30 | use re 'debugcolor'; # same as 'debug', but with colored output |
31 | ... |
32 | |
3ffabb8c |
33 | (We use $^X in these examples because it's tainted by default.) |
34 | |
b3eb6a9b |
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 |
e4d48cc9 |
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. |
b3eb6a9b |
42 | |
e4d48cc9 |
43 | When C<use re 'eval'> is in effect, a regex is allowed to contain |
2cd61cdb |
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 expresssions. See L<perlre/(?{ code })>. |
49 | |
0a92e3a8 |
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: |
2cd61cdb |
53 | |
54 | /foo${pat}bar/ |
55 | |
0a92e3a8 |
56 | I<is> allowed if $pat is a precompiled regular expression, even |
2cd61cdb |
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 |
02ea72ae |
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. |
2cd61cdb |
68 | See L<perldebug/"Debugging regular expressions"> for additional info. |
69 | |
0a92e3a8 |
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. |
b3eb6a9b |
72 | |
73 | See L<perlmodlib/Pragmatic Modules>. |
74 | |
75 | =cut |
76 | |
77 | my %bitmask = ( |
e4d48cc9 |
78 | taint => 0x00100000, |
79 | eval => 0x00200000, |
b3eb6a9b |
80 | ); |
81 | |
02ea72ae |
82 | sub setcolor { |
83 | eval { # Ignore errors |
84 | require Term::Cap; |
85 | |
86 | my $terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning. |
87 | my $props = $ENV{PERL_RE_TC} || 'md,me,so,se'; # can use us/ue later |
88 | my @props = split /,/, $props; |
89 | |
90 | |
91 | $ENV{TERMCAP_COLORS} = join "\t", map {$terminal->Tputs($_,1)} @props; |
92 | }; |
93 | |
94 | not defined $ENV{TERMCAP_COLORS} or ($ENV{TERMCAP_COLORS} =~ tr/\t/\t/) >= 4 |
95 | or not defined $ENV{PERL_RE_TC} |
96 | or die "Not enough fields in \$ENV{PERL_RE_TC}=`$ENV{PERL_RE_TC}'"; |
97 | } |
98 | |
b3eb6a9b |
99 | sub bits { |
56953603 |
100 | my $on = shift; |
b3eb6a9b |
101 | my $bits = 0; |
102 | unless(@_) { |
103 | require Carp; |
104 | Carp::carp("Useless use of \"re\" pragma"); |
105 | } |
56953603 |
106 | foreach my $s (@_){ |
02ea72ae |
107 | if ($s eq 'debug' or $s eq 'debugcolor') { |
108 | setcolor() if $s eq 'debugcolor'; |
8202fd39 |
109 | require DynaLoader; |
110 | @ISA = ('DynaLoader'); |
111 | bootstrap re; |
56953603 |
112 | install() if $on; |
113 | uninstall() unless $on; |
114 | next; |
115 | } |
116 | $bits |= $bitmask{$s} || 0; |
117 | } |
b3eb6a9b |
118 | $bits; |
119 | } |
120 | |
121 | sub import { |
122 | shift; |
56953603 |
123 | $^H |= bits(1,@_); |
b3eb6a9b |
124 | } |
125 | |
126 | sub unimport { |
127 | shift; |
56953603 |
128 | $^H &= ~ bits(0,@_); |
b3eb6a9b |
129 | } |
130 | |
131 | 1; |