home *** CD-ROM | disk | FTP | other *** search
/ PC World 2005 June / PCWorld_2005-06_cd.bin / software / vyzkuste / firewally / firewally.exe / framework-2.3.exe / re.pm < prev    next >
Text File  |  2003-11-07  |  4KB  |  135 lines
  1. package re;
  2.  
  3. our $VERSION = 0.04;
  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 expresssions.  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;
  135.