make ext/re play nice with DEBUGGING override

[p5sagit/p5-mst-13.2.git] / ext / re / re.pm

diff --git a/ext/re/re.pm b/ext/re/re.pm
index 7cea77d..32cee21 100644 (file)
--- a/ext/re/re.pm
+++ b/ext/re/re.pm
@@ -42,21 +42,21 @@ other transformations.
 
 When C<use re 'eval'> is in effect, a regex is allowed to contain
 C<(?{ ... })> zero-width assertions even if regular expression contains
-variable interpolation.  That is normally disallowed, since it is a 
+variable interpolation.  That is normally disallowed, since it is a
 potential security risk.  Note that this pragma is ignored when the regular
 expression is obtained from tainted data, i.e.  evaluation is always
 disallowed with tainted regular expresssions.  See L<perlre/(?{ code })>.
 
-For the purpose of this pragma, interpolation of precompiled regular 
+For the purpose of this pragma, interpolation of precompiled regular
 expressions (i.e., the result of C<qr//>) is I<not> considered variable
 interpolation.  Thus:
 
     /foo${pat}bar/
 
-I<is> allowed if $pat is a precompiled regular expression, even 
+I<is> allowed if $pat is a precompiled regular expression, even
 if $pat contains C<(?{ ... })> assertions.
 
-When C<use re 'debug'> is in effect, perl emits debugging messages when 
+When C<use re 'debug'> is in effect, perl emits debugging messages when
 compiling and using regular expressions.  The output is the same as that
 obtained by running a C<-DDEBUGGING>-enabled perl interpreter with the
 B<-Dr> switch. It may be quite voluminous depending on the complexity
@@ -64,7 +64,7 @@ of the match.  Using C<debugcolor> instead of C<debug> enables a
 form of output that can be used to get a colorful display on terminals
 that understand termcap color sequences.  Set C<$ENV{PERL_RE_TC}> to a
 comma-separated list of C<termcap> properties to use for highlighting
-strings on/off, pre-point part on/off.  
+strings on/off, pre-point part on/off.
 See L<perldebug/"Debugging regular expressions"> for additional info.
 
 The directive C<use re 'debug'> is I<not lexically scoped>, as the
@@ -74,9 +74,11 @@ See L<perlmodlib/Pragmatic Modules>.
 
 =cut
 
+# N.B. File::Basename contains a literal for 'taint' as a fallback.  If
+# taint is changed here, File::Basename must be updated as well.
 my %bitmask = (
-taint  => 0x00100000,
-eval   => 0x00200000,
+taint          => 0x00100000,
+eval           => 0x00200000,
 );
 
 sub setcolor {
@@ -84,48 +86,49 @@ sub setcolor {
   require Term::Cap;
 
   my $terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning.
-  my $props = $ENV{PERL_RE_TC} || 'md,me,so,se'; # can use us/ue later
+  my $props = $ENV{PERL_RE_TC} || 'md,me,so,se,us,ue';
   my @props = split /,/, $props;
+  my $colors = join "\t", map {$terminal->Tputs($_,1)} @props;
 
-
-  $ENV{TERMCAP_COLORS} = join "\t", map {$terminal->Tputs($_,1)} @props;
+  $colors =~ s/\0//g;
+  $ENV{PERL_RE_COLORS} = $colors;
  };
-
- not defined $ENV{TERMCAP_COLORS} or ($ENV{TERMCAP_COLORS} =~ tr/\t/\t/) >= 4
-    or not defined $ENV{PERL_RE_TC}
-    or die "Not enough fields in \$ENV{PERL_RE_TC}=`$ENV{PERL_RE_TC}'";
 }
 
 sub bits {
     my $on = shift;
     my $bits = 0;
-    unless(@_) {
+    unless (@_) {
        require Carp;
        Carp::carp("Useless use of \"re\" pragma");
     }
     foreach my $s (@_){
       if ($s eq 'debug' or $s eq 'debugcolor') {
          setcolor() if $s eq 'debugcolor';
-         require DynaLoader;
-         @ISA = ('DynaLoader');
-         bootstrap re;
+         require XSLoader;
+         XSLoader::load('re');
          install() if $on;
          uninstall() unless $on;
          next;
       }
-      $bits |= $bitmask{$s} || 0;
+      if (exists $bitmask{$s}) {
+         $bits |= $bitmask{$s};
+      } else {
+         require Carp;
+         Carp::carp("Unknown \"re\" subpragma '$s' (known ones are: @{[join(', ', map {qq('$_')} sort keys %bitmask)]})");
+      }
     }
     $bits;
 }
 
 sub import {
     shift;
-    $^H |= bits(1,@_);
+    $^H |= bits(1, @_);
 }
 
 sub unimport {
     shift;
-    $^H &= ~ bits(0,@_);
+    $^H &= ~ bits(0, @_);
 }
 
 1;