ext/re/re.pm

   1 package re;
   2
   3 # pragma for controlling the regex engine
   4 use strict;
   5 use warnings;
   6
   7 our $VERSION     = "0.09";
   8 our @ISA         = qw(Exporter);
   9 my @XS_FUNCTIONS = qw(regmust);
  10 my %XS_FUNCTIONS = map { $_ => 1 } @XS_FUNCTIONS;
  11 our @EXPORT_OK   = (@XS_FUNCTIONS,
  12                     qw(is_regexp regexp_pattern
  13                        regname regnames regnames_count));
  14 our %EXPORT_OK = map { $_ => 1 } @EXPORT_OK;
  15
  16 # *** WARNING *** WARNING *** WARNING *** WARNING *** WARNING ***
  17 #
  18 # If you modify these values see comment below!
  19
  20 my %bitmask = (
  21     taint   => 0x00100000, # HINT_RE_TAINT
  22     eval    => 0x00200000, # HINT_RE_EVAL
  23 );
  24
  25 # - File::Basename contains a literal for 'taint' as a fallback.  If
  26 # taint is changed here, File::Basename must be updated as well.
  27 #
  28 # - ExtUtils::ParseXS uses a hardcoded
  29 # BEGIN { $^H |= 0x00200000 }
  30 # in it to allow re.xs to be built. So if 'eval' is changed here then
  31 # ExtUtils::ParseXS must be changed as well.
  32 #
  33 # *** WARNING *** WARNING *** WARNING *** WARNING *** WARNING ***
  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 );
  75 $flags{ALL} = -1 & ~($flags{OFFSETS}|$flags{OFFSETSDBG}|$flags{BUFFERS});
  76 $flags{All} = $flags{all} = $flags{DUMP} | $flags{EXECUTE};
  77 $flags{Extra} = $flags{EXECUTE} | $flags{COMPILE};
  78 $flags{More} = $flags{MORE} = $flags{All} | $flags{TRIEC} | $flags{TRIEM} | $flags{STATE};
  79 $flags{State} = $flags{DUMP} | $flags{EXECUTE} | $flags{STATE};
  80 $flags{TRIE} = $flags{DUMP} | $flags{EXECUTE} | $flags{TRIEC};
  81
  82 my $installed;
  83 my $installed_error;
  84
  85 sub _do_install {
  86     if ( ! defined($installed) ) {
  87         require XSLoader;
  88         $installed = eval { XSLoader::load('re', $VERSION) } || 0;
  89         $installed_error = $@;
  90     }
  91 }
  92
  93 sub _load_unload {
  94     my ($on)= @_;
  95     if ($on) {
  96         _do_install();
  97         if ( ! $installed ) {
  98             die "'re' not installed!? ($installed_error)";
  99         } else {
 100             # We call install() every time, as if we didn't, we wouldn't
 101             # "see" any changes to the color environment var since
 102             # the last time it was called.
 103
 104             # install() returns an integer, which if casted properly
 105             # in C resolves to a structure containing the regex
 106             # hooks. Setting it to a random integer will guarantee
 107             # segfaults.
 108             $^H{regcomp} = install();
 109         }
 110     } else {
 111         delete $^H{regcomp};
 112     }
 113 }
 114
 115 sub bits {
 116     my $on = shift;
 117     my $bits = 0;
 118     unless (@_) {
 119         require Carp;
 120         Carp::carp("Useless use of \"re\" pragma");
 121     }
 122     foreach my $idx (0..$#_){
 123         my $s=$_[$idx];
 124         if ($s eq 'Debug' or $s eq 'Debugcolor') {
 125             setcolor() if $s =~/color/i;
 126             ${^RE_DEBUG_FLAGS} = 0 unless defined ${^RE_DEBUG_FLAGS};
 127             for my $idx ($idx+1..$#_) {
 128                 if ($flags{$_[$idx]}) {
 129                     if ($on) {
 130                         ${^RE_DEBUG_FLAGS} |= $flags{$_[$idx]};
 131                     } else {
 132                         ${^RE_DEBUG_FLAGS} &= ~ $flags{$_[$idx]};
 133                     }
 134                 } else {
 135                     require Carp;
 136                     Carp::carp("Unknown \"re\" Debug flag '$_[$idx]', possible flags: ",
 137                                join(", ",sort keys %flags ) );
 138                 }
 139             }
 140             _load_unload($on ? 1 : ${^RE_DEBUG_FLAGS});
 141             last;
 142         } elsif ($s eq 'debug' or $s eq 'debugcolor') {
 143             setcolor() if $s =~/color/i;
 144             _load_unload($on);
 145             last;
 146         } elsif (exists $bitmask{$s}) {
 147             $bits |= $bitmask{$s};
 148         } elsif ($XS_FUNCTIONS{$s}) {
 149             _do_install();
 150             if (! $installed) {
 151                 require Carp;
 152                 Carp::croak("\"re\" function '$s' not available");
 153             }
 154             require Exporter;
 155             re->export_to_level(2, 're', $s);
 156         } elsif ($EXPORT_OK{$s}) {
 157             require Exporter;
 158             re->export_to_level(2, 're', $s);
 159         } else {
 160             require Carp;
 161             Carp::carp("Unknown \"re\" subpragma '$s' (known ones are: ",
 162                        join(', ', map {qq('$_')} 'debug', 'debugcolor', sort keys %bitmask),
 163                        ")");
 164         }
 165     }
 166     $bits;
 167 }
 168
 169 sub import {
 170     shift;
 171     $^H |= bits(1, @_);
 172 }
 173
 174 sub unimport {
 175     shift;
 176     $^H &= ~ bits(0, @_);
 177 }
 178
 179 1;
 180
 181 __END__
 182
 183 =head1 NAME
 184
 185 re - Perl pragma to alter regular expression behaviour
 186
 187 =head1 SYNOPSIS
 188
 189     use re 'taint';
 190     ($x) = ($^X =~ /^(.*)$/s);     # $x is tainted here
 191
 192     $pat = '(?{ $foo = 1 })';
 193     use re 'eval';
 194     /foo${pat}bar/;                # won't fail (when not under -T switch)
 195
 196     {
 197         no re 'taint';             # the default
 198         ($x) = ($^X =~ /^(.*)$/s); # $x is not tainted here
 199
 200         no re 'eval';              # the default
 201         /foo${pat}bar/;            # disallowed (with or without -T switch)
 202     }
 203
 204     use re 'debug';                # output debugging info during
 205     /^(.*)$/s;                     #     compile and run time
 206
 207
 208     use re 'debugcolor';           # same as 'debug', but with colored output
 209     ...
 210
 211     use re qw(Debug All);          # Finer tuned debugging options.
 212     use re qw(Debug More);
 213     no re qw(Debug ALL);           # Turn of all re debugging in this scope
 214
 215     use re qw(is_regexp regexp_pattern); # import utility functions
 216     my ($pat,$mods)=regexp_pattern(qr/foo/i);
 217     if (is_regexp($obj)) {
 218         print "Got regexp: ",
 219             scalar regexp_pattern($obj); # just as perl would stringify it
 220     }                                    # but no hassle with blessed re's.
 221
 222 (We use $^X in these examples because it's tainted by default.)
 223
 224 =head1 DESCRIPTION
 225
 226 =head2 'taint' mode
 227
 228 When C<use re 'taint'> is in effect, and a tainted string is the target
 229 of a regex, the regex memories (or values returned by the m// operator
 230 in list context) are tainted.  This feature is useful when regex operations
 231 on tainted data aren't meant to extract safe substrings, but to perform
 232 other transformations.
 233
 234 =head2 'eval' mode
 235
 236 When C<use re 'eval'> is in effect, a regex is allowed to contain
 237 C<(?{ ... })> zero-width assertions even if regular expression contains
 238 variable interpolation.  That is normally disallowed, since it is a
 239 potential security risk.  Note that this pragma is ignored when the regular
 240 expression is obtained from tainted data, i.e.  evaluation is always
 241 disallowed with tainted regular expressions.  See L<perlre/(?{ code })>.
 242
 243 For the purpose of this pragma, interpolation of precompiled regular
 244 expressions (i.e., the result of C<qr//>) is I<not> considered variable
 245 interpolation.  Thus:
 246
 247     /foo${pat}bar/
 248
 249 I<is> allowed if $pat is a precompiled regular expression, even
 250 if $pat contains C<(?{ ... })> assertions.
 251
 252 =head2 'debug' mode
 253
 254 When C<use re 'debug'> is in effect, perl emits debugging messages when
 255 compiling and using regular expressions.  The output is the same as that
 256 obtained by running a C<-DDEBUGGING>-enabled perl interpreter with the
 257 B<-Dr> switch. It may be quite voluminous depending on the complexity
 258 of the match.  Using C<debugcolor> instead of C<debug> enables a
 259 form of output that can be used to get a colorful display on terminals
 260 that understand termcap color sequences.  Set C<$ENV{PERL_RE_TC}> to a
 261 comma-separated list of C<termcap> properties to use for highlighting
 262 strings on/off, pre-point part on/off.
 263 See L<perldebug/"Debugging regular expressions"> for additional info.
 264
 265 As of 5.9.5 the directive C<use re 'debug'> and its equivalents are
 266 lexically scoped, as the other directives are.  However they have both
 267 compile-time and run-time effects.
 268
 269 See L<perlmodlib/Pragmatic Modules>.
 270
 271 =head2 'Debug' mode
 272
 273 Similarly C<use re 'Debug'> produces debugging output, the difference
 274 being that it allows the fine tuning of what debugging output will be
 275 emitted. Options are divided into three groups, those related to
 276 compilation, those related to execution and those related to special
 277 purposes. The options are as follows:
 278
 279 =over 4
 280
 281 =item Compile related options
 282
 283 =over 4
 284
 285 =item COMPILE
 286
 287 Turns on all compile related debug options.
 288
 289 =item PARSE
 290
 291 Turns on debug output related to the process of parsing the pattern.
 292
 293 =item OPTIMISE
 294
 295 Enables output related to the optimisation phase of compilation.
 296
 297 =item TRIEC
 298
 299 Detailed info about trie compilation.
 300
 301 =item DUMP
 302
 303 Dump the final program out after it is compiled and optimised.
 304
 305 =back
 306
 307 =item Execute related options
 308
 309 =over 4
 310
 311 =item EXECUTE
 312
 313 Turns on all execute related debug options.
 314
 315 =item MATCH
 316
 317 Turns on debugging of the main matching loop.
 318
 319 =item TRIEE
 320
 321 Extra debugging of how tries execute.
 322
 323 =item INTUIT
 324
 325 Enable debugging of start point optimisations.
 326
 327 =back
 328
 329 =item Extra debugging options
 330
 331 =over 4
 332
 333 =item EXTRA
 334
 335 Turns on all "extra" debugging options.
 336
 337 =item BUFFERS
 338
 339 Enable debugging the capture buffer storage during match. Warning,
 340 this can potentially produce extremely large output.
 341
 342 =item TRIEM
 343
 344 Enable enhanced TRIE debugging. Enhances both TRIEE
 345 and TRIEC.
 346
 347 =item STATE
 348
 349 Enable debugging of states in the engine.
 350
 351 =item STACK
 352
 353 Enable debugging of the recursion stack in the engine. Enabling
 354 or disabling this option automatically does the same for debugging
 355 states as well. This output from this can be quite large.
 356
 357 =item OPTIMISEM
 358
 359 Enable enhanced optimisation debugging and start point optimisations.
 360 Probably not useful except when debugging the regex engine itself.
 361
 362 =item OFFSETS
 363
 364 Dump offset information. This can be used to see how regops correlate
 365 to the pattern. Output format is
 366
 367    NODENUM:POSITION[LENGTH]
 368
 369 Where 1 is the position of the first char in the string. Note that position
 370 can be 0, or larger than the actual length of the pattern, likewise length
 371 can be zero.
 372
 373 =item OFFSETSDBG
 374
 375 Enable debugging of offsets information. This emits copious
 376 amounts of trace information and doesn't mesh well with other
 377 debug options.
 378
 379 Almost definitely only useful to people hacking
 380 on the offsets part of the debug engine.
 381
 382 =back
 383
 384 =item Other useful flags
 385
 386 These are useful shortcuts to save on the typing.
 387
 388 =over 4
 389
 390 =item ALL
 391
 392 Enable all options at once except OFFSETS, OFFSETSDBG and BUFFERS
 393
 394 =item All
 395
 396 Enable DUMP and all execute options. Equivalent to:
 397
 398   use re 'debug';
 399
 400 =item MORE
 401
 402 =item More
 403
 404 Enable TRIEM and all execute compile and execute options.
 405
 406 =back
 407
 408 =back
 409
 410 As of 5.9.5 the directive C<use re 'debug'> and its equivalents are
 411 lexically scoped, as the other directives are.  However they have both
 412 compile-time and run-time effects.
 413
 414 =head2 Exportable Functions
 415
 416 As of perl 5.9.5 're' debug contains a number of utility functions that
 417 may be optionally exported into the caller's namespace. They are listed
 418 below.
 419
 420 =over 4
 421
 422 =item is_regexp($ref)
 423
 424 Returns true if the argument is a compiled regular expression as returned
 425 by C<qr//>, false if it is not.
 426
 427 This function will not be confused by overloading or blessing. In
 428 internals terms, this extracts the regexp pointer out of the
 429 PERL_MAGIC_qr structure so it it cannot be fooled.
 430
 431 =item regexp_pattern($ref)
 432
 433 If the argument is a compiled regular expression as returned by C<qr//>,
 434 then this function returns the pattern.
 435
 436 In list context it returns a two element list, the first element
 437 containing the pattern and the second containing the modifiers used when
 438 the pattern was compiled.
 439
 440   my ($pat, $mods) = regexp_pattern($ref);
 441
 442 In scalar context it returns the same as perl would when strigifying a raw
 443 C<qr//> with the same pattern inside.  If the argument is not a compiled
 444 reference then this routine returns false but defined in scalar context,
 445 and the empty list in list context. Thus the following
 446
 447     if (regexp_pattern($ref) eq '(?i-xsm:foo)')
 448
 449 will be warning free regardless of what $ref actually is.
 450
 451 Like C<is_regexp> this function will not be confused by overloading
 452 or blessing of the object.
 453
 454 =item regmust($ref)
 455
 456 If the argument is a compiled regular expression as returned by C<qr//>,
 457 then this function returns what the optimiser consiers to be the longest
 458 anchored fixed string and longest floating fixed string in the pattern.
 459
 460 A I<fixed string> is defined as being a substring that must appear for the
 461 pattern to match. An I<anchored fixed string> is a fixed string that must
 462 appear at a particular offset from the beginning of the match. A I<floating
 463 fixed string> is defined as a fixed string that can appear at any point in
 464 a range of positions relative to the start of the match. For example,
 465
 466     my $qr = qr/here .* there/x;
 467     my ($anchored, $floating) = regmust($qr);
 468     print "anchored:'$anchored'\nfloating:'$floating'\n";
 469
 470 results in
 471
 472     anchored:'here'
 473     floating:'there'
 474
 475 Because the C<here> is before the C<.*> in the pattern, its position
 476 can be determined exactly. That's not true, however, for the C<there>;
 477 it could appear at any point after where the anchored string appeared.
 478 Perl uses both for its optimisations, prefering the longer, or, if they are
 479 equal, the floating.
 480
 481 B<NOTE:> This may not necessarily be the definitive longest anchored and
 482 floating string. This will be what the optimiser of the Perl that you
 483 are using thinks is the longest. If you believe that the result is wrong
 484 please report it via the L<perlbug> utility.
 485
 486 =item regname($name,$all)
 487
 488 Returns the contents of a named buffer of the last successful match. If
 489 $all is true, then returns an array ref containing one entry per buffer,
 490 otherwise returns the first defined buffer.
 491
 492 =item regnames($all)
 493
 494 Returns a list of all of the named buffers defined in the last successful
 495 match. If $all is true, then it returns all names defined, if not it returns
 496 only names which were involved in the match.
 497
 498 =item regnames_count()
 499
 500 Returns the number of distinct names defined in the pattern used
 501 for the last successful match.
 502
 503 B<Note:> this result is always the actual number of distinct
 504 named buffers defined, it may not actually match that which is
 505 returned by C<regnames()> and related routines when those routines
 506 have not been called with the $all parameter set.
 507
 508 =back
 509
 510 =head1 SEE ALSO
 511
 512 L<perlmodlib/Pragmatic Modules>.
 513
 514 =cut