This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
bump re.pm version number
[perl5.git] / ext / re / re.pm
1 package re;
2
3 # pragma for controlling the regexp engine
4 use strict;
5 use warnings;
6
7 our $VERSION     = "0.20";
8 our @ISA         = qw(Exporter);
9 our @EXPORT_OK   = ('regmust',
10                     qw(is_regexp regexp_pattern
11                        regname regnames regnames_count));
12 our %EXPORT_OK = map { $_ => 1 } @EXPORT_OK;
13
14 my %bitmask = (
15     taint   => 0x00100000, # HINT_RE_TAINT
16     eval    => 0x00200000, # HINT_RE_EVAL
17 );
18
19 my $flags_hint = 0x02000000; # HINT_RE_FLAGS
20 my $PMMOD_SHIFT = 0;
21 my %reflags = (
22     m => 1 << ($PMMOD_SHIFT + 0),
23     s => 1 << ($PMMOD_SHIFT + 1),
24     i => 1 << ($PMMOD_SHIFT + 2),
25     x => 1 << ($PMMOD_SHIFT + 3),
26     p => 1 << ($PMMOD_SHIFT + 4),
27 # special cases:
28     d => 0,
29     l => 1,
30     u => 2,
31     a => 3,
32     aa => 4,
33 );
34
35 sub setcolor {
36  eval {                         # Ignore errors
37   require Term::Cap;
38
39   my $terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning.
40   my $props = $ENV{PERL_RE_TC} || 'md,me,so,se,us,ue';
41   my @props = split /,/, $props;
42   my $colors = join "\t", map {$terminal->Tputs($_,1)} @props;
43
44   $colors =~ s/\0//g;
45   $ENV{PERL_RE_COLORS} = $colors;
46  };
47  if ($@) {
48     $ENV{PERL_RE_COLORS} ||= qq'\t\t> <\t> <\t\t';
49  }
50
51 }
52
53 my %flags = (
54     COMPILE         => 0x0000FF,
55     PARSE           => 0x000001,
56     OPTIMISE        => 0x000002,
57     TRIEC           => 0x000004,
58     DUMP            => 0x000008,
59     FLAGS           => 0x000010,
60
61     EXECUTE         => 0x00FF00,
62     INTUIT          => 0x000100,
63     MATCH           => 0x000200,
64     TRIEE           => 0x000400,
65
66     EXTRA           => 0xFF0000,
67     TRIEM           => 0x010000,
68     OFFSETS         => 0x020000,
69     OFFSETSDBG      => 0x040000,
70     STATE           => 0x080000,
71     OPTIMISEM       => 0x100000,
72     STACK           => 0x280000,
73     BUFFERS         => 0x400000,
74     GPOS            => 0x800000,
75 );
76 $flags{ALL} = -1 & ~($flags{OFFSETS}|$flags{OFFSETSDBG}|$flags{BUFFERS});
77 $flags{All} = $flags{all} = $flags{DUMP} | $flags{EXECUTE};
78 $flags{Extra} = $flags{EXECUTE} | $flags{COMPILE} | $flags{GPOS};
79 $flags{More} = $flags{MORE} = $flags{All} | $flags{TRIEC} | $flags{TRIEM} | $flags{STATE};
80 $flags{State} = $flags{DUMP} | $flags{EXECUTE} | $flags{STATE};
81 $flags{TRIE} = $flags{DUMP} | $flags{EXECUTE} | $flags{TRIEC};
82
83 if (defined &DynaLoader::boot_DynaLoader) {
84     require XSLoader;
85     XSLoader::load();
86 }
87 # else we're miniperl
88 # We need to work for miniperl, because the XS toolchain uses Text::Wrap, which
89 # uses re 'taint'.
90
91 sub _load_unload {
92     my ($on)= @_;
93     if ($on) {
94         # We call install() every time, as if we didn't, we wouldn't
95         # "see" any changes to the color environment var since
96         # the last time it was called.
97
98         # install() returns an integer, which if casted properly
99         # in C resolves to a structure containing the regexp
100         # hooks. Setting it to a random integer will guarantee
101         # segfaults.
102         $^H{regcomp} = install();
103     } else {
104         delete $^H{regcomp};
105     }
106 }
107
108 sub bits {
109     my $on = shift;
110     my $bits = 0;
111    ARG:
112     foreach my $idx (0..$#_){
113         my $s=$_[$idx];
114         if ($s eq 'Debug' or $s eq 'Debugcolor') {
115             setcolor() if $s =~/color/i;
116             ${^RE_DEBUG_FLAGS} = 0 unless defined ${^RE_DEBUG_FLAGS};
117             for my $idx ($idx+1..$#_) {
118                 if ($flags{$_[$idx]}) {
119                     if ($on) {
120                         ${^RE_DEBUG_FLAGS} |= $flags{$_[$idx]};
121                     } else {
122                         ${^RE_DEBUG_FLAGS} &= ~ $flags{$_[$idx]};
123                     }
124                 } else {
125                     require Carp;
126                     Carp::carp("Unknown \"re\" Debug flag '$_[$idx]', possible flags: ",
127                                join(", ",sort keys %flags ) );
128                 }
129             }
130             _load_unload($on ? 1 : ${^RE_DEBUG_FLAGS});
131             last;
132         } elsif ($s eq 'debug' or $s eq 'debugcolor') {
133             setcolor() if $s =~/color/i;
134             _load_unload($on);
135             last;
136         } elsif (exists $bitmask{$s}) {
137             $bits |= $bitmask{$s};
138         } elsif ($EXPORT_OK{$s}) {
139             require Exporter;
140             re->export_to_level(2, 're', $s);
141         } elsif ($s =~ s/^\///) {
142             my $reflags = $^H{reflags} || 0;
143             my $seen_charset;
144             while ($s =~ m/( . )/gx) {
145                 $_ = $1;
146                 if (/[adul]/) {
147                     # The 'a' may be repeated; hide this from the rest of the
148                     # code by counting and getting rid of all of them, then
149                     # changing to 'aa' if there is a repeat.
150                     if ($_ eq 'a') {
151                         my $sav_pos = pos $s;
152                         my $a_count = $s =~ s/a//g;
153                         pos $s = $sav_pos - 1;  # -1 because got rid of the 'a'
154                         if ($a_count > 2) {
155                             require Carp;
156                             Carp::carp(
157                             qq 'The "a" flag may only appear a maximum of twice'
158                             );
159                         }
160                         elsif ($a_count == 2) {
161                             $_ = 'aa';
162                         }
163                     }
164                     if ($on) {
165                         if ($seen_charset) {
166                             require Carp;
167                             if ($seen_charset ne $_) {
168                                 Carp::carp(
169                                 qq 'The "$seen_charset" and "$_" flags '
170                                 .qq 'are exclusive'
171                                 );
172                             }
173                             else {
174                                 Carp::carp(
175                                 qq 'The "$seen_charset" flag may not appear '
176                                 .qq 'twice'
177                                 );
178                             }
179                         }
180                         $^H{reflags_charset} = $reflags{$_};
181                         $seen_charset = $_;
182                     }
183                     else {
184                         delete $^H{reflags_charset}
185                          if  defined $^H{reflags_charset}
186                           && $^H{reflags_charset} == $reflags{$_};
187                     }
188                 } elsif (exists $reflags{$_}) {
189                     $on
190                       ? $reflags |= $reflags{$_}
191                       : ($reflags &= ~$reflags{$_});
192                 } else {
193                     require Carp;
194                     Carp::carp(
195                      qq'Unknown regular expression flag "$_"'
196                     );
197                     next ARG;
198                 }
199             }
200             ($^H{reflags} = $reflags or defined $^H{reflags_charset})
201              ? $^H |= $flags_hint
202              : ($^H &= ~$flags_hint);
203         } else {
204             require Carp;
205             Carp::carp("Unknown \"re\" subpragma '$s' (known ones are: ",
206                        join(', ', map {qq('$_')} 'debug', 'debugcolor', sort keys %bitmask),
207                        ")");
208         }
209     }
210     $bits;
211 }
212
213 sub import {
214     shift;
215     $^H |= bits(1, @_);
216 }
217
218 sub unimport {
219     shift;
220     $^H &= ~ bits(0, @_);
221 }
222
223 1;
224
225 __END__
226
227 =head1 NAME
228
229 re - Perl pragma to alter regular expression behaviour
230
231 =head1 SYNOPSIS
232
233     use re 'taint';
234     ($x) = ($^X =~ /^(.*)$/s);     # $x is tainted here
235
236     $pat = '(?{ $foo = 1 })';
237     use re 'eval';
238     /foo${pat}bar/;                # won't fail (when not under -T switch)
239
240     {
241         no re 'taint';             # the default
242         ($x) = ($^X =~ /^(.*)$/s); # $x is not tainted here
243
244         no re 'eval';              # the default
245         /foo${pat}bar/;            # disallowed (with or without -T switch)
246     }
247
248     use re '/ix';
249     "FOO" =~ / foo /; # /ix implied
250     no re '/x';
251     "FOO" =~ /foo/; # just /i implied
252
253     use re 'debug';                # output debugging info during
254     /^(.*)$/s;                     #     compile and run time
255
256
257     use re 'debugcolor';           # same as 'debug', but with colored output
258     ...
259
260     use re qw(Debug All);          # Finer tuned debugging options.
261     use re qw(Debug More);
262     no re qw(Debug ALL);           # Turn of all re debugging in this scope
263
264     use re qw(is_regexp regexp_pattern); # import utility functions
265     my ($pat,$mods)=regexp_pattern(qr/foo/i);
266     if (is_regexp($obj)) { 
267         print "Got regexp: ",
268             scalar regexp_pattern($obj); # just as perl would stringify it
269     }                                    # but no hassle with blessed re's.
270
271 (We use $^X in these examples because it's tainted by default.)
272
273 =head1 DESCRIPTION
274
275 =head2 'taint' mode
276
277 When C<use re 'taint'> is in effect, and a tainted string is the target
278 of a regexp, the regexp memories (or values returned by the m// operator
279 in list context) are tainted.  This feature is useful when regexp operations
280 on tainted data aren't meant to extract safe substrings, but to perform
281 other transformations.
282
283 =head2 'eval' mode
284
285 When C<use re 'eval'> is in effect, a regexp is allowed to contain
286 C<(?{ ... })> zero-width assertions and C<(??{ ... })> postponed
287 subexpressions, even if the regular expression contains
288 variable interpolation.  That is normally disallowed, since it is a
289 potential security risk.  Note that this pragma is ignored when the regular
290 expression is obtained from tainted data, i.e.  evaluation is always
291 disallowed with tainted regular expressions.  See L<perlre/(?{ code })> 
292 and L<perlre/(??{ code })>.
293
294 For the purpose of this pragma, interpolation of precompiled regular
295 expressions (i.e., the result of C<qr//>) is I<not> considered variable
296 interpolation.  Thus:
297
298     /foo${pat}bar/
299
300 I<is> allowed if $pat is a precompiled regular expression, even
301 if $pat contains C<(?{ ... })> assertions or C<(??{ ... })> subexpressions.
302
303 =head2 '/flags' mode
304
305 When C<use re '/flags'> is specified, the given flags are automatically
306 added to every regular expression till the end of the lexical scope.
307
308 C<no re '/flags'> will turn off the effect of C<use re '/flags'> for the
309 given flags.
310
311 For example, if you want all your regular expressions to have /msx on by
312 default, simply put
313
314     use re '/msx';
315
316 at the top of your code.
317
318 The character set /adul flags cancel each other out. So, in this example,
319
320     use re "/u";
321     "ss" =~ /\xdf/;
322     use re "/d";
323     "ss" =~ /\xdf/;
324
325 the second C<use re> does an implicit C<no re '/u'>.
326
327 Turning on one of the character set flags with C<use re> takes precedence over the
328 C<locale> pragma and the 'unicode_strings' C<feature>, for regular
329 expressions. Turning off one of these flags when it is active reverts to
330 the behaviour specified by whatever other pragmata are in scope. For
331 example:
332
333     use feature "unicode_strings";
334     no re "/u"; # does nothing
335     use re "/l";
336     no re "/l"; # reverts to unicode_strings behaviour
337
338 =head2 'debug' mode
339
340 When C<use re 'debug'> is in effect, perl emits debugging messages when
341 compiling and using regular expressions.  The output is the same as that
342 obtained by running a C<-DDEBUGGING>-enabled perl interpreter with the
343 B<-Dr> switch. It may be quite voluminous depending on the complexity
344 of the match.  Using C<debugcolor> instead of C<debug> enables a
345 form of output that can be used to get a colorful display on terminals
346 that understand termcap color sequences.  Set C<$ENV{PERL_RE_TC}> to a
347 comma-separated list of C<termcap> properties to use for highlighting
348 strings on/off, pre-point part on/off.
349 See L<perldebug/"Debugging Regular Expressions"> for additional info.
350
351 As of 5.9.5 the directive C<use re 'debug'> and its equivalents are
352 lexically scoped, as the other directives are.  However they have both 
353 compile-time and run-time effects.
354
355 See L<perlmodlib/Pragmatic Modules>.
356
357 =head2 'Debug' mode
358
359 Similarly C<use re 'Debug'> produces debugging output, the difference
360 being that it allows the fine tuning of what debugging output will be
361 emitted. Options are divided into three groups, those related to
362 compilation, those related to execution and those related to special
363 purposes. The options are as follows:
364
365 =over 4
366
367 =item Compile related options
368
369 =over 4
370
371 =item COMPILE
372
373 Turns on all compile related debug options.
374
375 =item PARSE
376
377 Turns on debug output related to the process of parsing the pattern.
378
379 =item OPTIMISE
380
381 Enables output related to the optimisation phase of compilation.
382
383 =item TRIEC
384
385 Detailed info about trie compilation.
386
387 =item DUMP
388
389 Dump the final program out after it is compiled and optimised.
390
391 =back
392
393 =item Execute related options
394
395 =over 4
396
397 =item EXECUTE
398
399 Turns on all execute related debug options.
400
401 =item MATCH
402
403 Turns on debugging of the main matching loop.
404
405 =item TRIEE
406
407 Extra debugging of how tries execute.
408
409 =item INTUIT
410
411 Enable debugging of start point optimisations.
412
413 =back
414
415 =item Extra debugging options
416
417 =over 4
418
419 =item EXTRA
420
421 Turns on all "extra" debugging options.
422
423 =item BUFFERS
424
425 Enable debugging the capture group storage during match. Warning,
426 this can potentially produce extremely large output.
427
428 =item TRIEM
429
430 Enable enhanced TRIE debugging. Enhances both TRIEE
431 and TRIEC.
432
433 =item STATE
434
435 Enable debugging of states in the engine.
436
437 =item STACK
438
439 Enable debugging of the recursion stack in the engine. Enabling
440 or disabling this option automatically does the same for debugging
441 states as well. This output from this can be quite large.
442
443 =item OPTIMISEM
444
445 Enable enhanced optimisation debugging and start point optimisations.
446 Probably not useful except when debugging the regexp engine itself.
447
448 =item OFFSETS
449
450 Dump offset information. This can be used to see how regops correlate
451 to the pattern. Output format is
452
453    NODENUM:POSITION[LENGTH]
454
455 Where 1 is the position of the first char in the string. Note that position
456 can be 0, or larger than the actual length of the pattern, likewise length
457 can be zero.
458
459 =item OFFSETSDBG
460
461 Enable debugging of offsets information. This emits copious
462 amounts of trace information and doesn't mesh well with other
463 debug options.
464
465 Almost definitely only useful to people hacking
466 on the offsets part of the debug engine.
467
468 =back
469
470 =item Other useful flags
471
472 These are useful shortcuts to save on the typing.
473
474 =over 4
475
476 =item ALL
477
478 Enable all options at once except OFFSETS, OFFSETSDBG and BUFFERS
479
480 =item All
481
482 Enable DUMP and all execute options. Equivalent to:
483
484   use re 'debug';
485
486 =item MORE
487
488 =item More
489
490 Enable TRIEM and all execute compile and execute options.
491
492 =back
493
494 =back
495
496 As of 5.9.5 the directive C<use re 'debug'> and its equivalents are
497 lexically scoped, as the other directives are.  However they have both
498 compile-time and run-time effects.
499
500 =head2 Exportable Functions
501
502 As of perl 5.9.5 're' debug contains a number of utility functions that
503 may be optionally exported into the caller's namespace. They are listed
504 below.
505
506 =over 4
507
508 =item is_regexp($ref)
509
510 Returns true if the argument is a compiled regular expression as returned
511 by C<qr//>, false if it is not.
512
513 This function will not be confused by overloading or blessing. In
514 internals terms, this extracts the regexp pointer out of the
515 PERL_MAGIC_qr structure so it cannot be fooled.
516
517 =item regexp_pattern($ref)
518
519 If the argument is a compiled regular expression as returned by C<qr//>,
520 then this function returns the pattern.
521
522 In list context it returns a two element list, the first element
523 containing the pattern and the second containing the modifiers used when
524 the pattern was compiled.
525
526   my ($pat, $mods) = regexp_pattern($ref);
527
528 In scalar context it returns the same as perl would when stringifying a raw
529 C<qr//> with the same pattern inside.  If the argument is not a compiled
530 reference then this routine returns false but defined in scalar context,
531 and the empty list in list context. Thus the following
532
533     if (regexp_pattern($ref) eq '(?^i:foo)')
534
535 will be warning free regardless of what $ref actually is.
536
537 Like C<is_regexp> this function will not be confused by overloading
538 or blessing of the object.
539
540 =item regmust($ref)
541
542 If the argument is a compiled regular expression as returned by C<qr//>,
543 then this function returns what the optimiser considers to be the longest
544 anchored fixed string and longest floating fixed string in the pattern.
545
546 A I<fixed string> is defined as being a substring that must appear for the
547 pattern to match. An I<anchored fixed string> is a fixed string that must
548 appear at a particular offset from the beginning of the match. A I<floating
549 fixed string> is defined as a fixed string that can appear at any point in
550 a range of positions relative to the start of the match. For example,
551
552     my $qr = qr/here .* there/x;
553     my ($anchored, $floating) = regmust($qr);
554     print "anchored:'$anchored'\nfloating:'$floating'\n";
555
556 results in
557
558     anchored:'here'
559     floating:'there'
560
561 Because the C<here> is before the C<.*> in the pattern, its position
562 can be determined exactly. That's not true, however, for the C<there>;
563 it could appear at any point after where the anchored string appeared.
564 Perl uses both for its optimisations, prefering the longer, or, if they are
565 equal, the floating.
566
567 B<NOTE:> This may not necessarily be the definitive longest anchored and
568 floating string. This will be what the optimiser of the Perl that you
569 are using thinks is the longest. If you believe that the result is wrong
570 please report it via the L<perlbug> utility.
571
572 =item regname($name,$all)
573
574 Returns the contents of a named buffer of the last successful match. If
575 $all is true, then returns an array ref containing one entry per buffer,
576 otherwise returns the first defined buffer.
577
578 =item regnames($all)
579
580 Returns a list of all of the named buffers defined in the last successful
581 match. If $all is true, then it returns all names defined, if not it returns
582 only names which were involved in the match.
583
584 =item regnames_count()
585
586 Returns the number of distinct names defined in the pattern used
587 for the last successful match.
588
589 B<Note:> this result is always the actual number of distinct
590 named buffers defined, it may not actually match that which is
591 returned by C<regnames()> and related routines when those routines
592 have not been called with the $all parameter set.
593
594 =back
595
596 =head1 SEE ALSO
597
598 L<perlmodlib/Pragmatic Modules>.
599
600 =cut