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.19";
   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