parallel/testsuite/input-files/perllib/re.pm

183 lines
5.1 KiB
Perl
Raw Normal View History

package re;
# pragma for controlling the regex engine
use strict;
use warnings;
our $VERSION = "0.09";
our @ISA = qw(Exporter);
my @XS_FUNCTIONS = qw(regmust);
my %XS_FUNCTIONS = map { $_ => 1 } @XS_FUNCTIONS;
our @EXPORT_OK = (@XS_FUNCTIONS,
qw(is_regexp regexp_pattern
regname regnames regnames_count));
our %EXPORT_OK = map { $_ => 1 } @EXPORT_OK;
# *** WARNING *** WARNING *** WARNING *** WARNING *** WARNING ***
#
# If you modify these values see comment below!
my %bitmask = (
taint => 0x00100000, # HINT_RE_TAINT
eval => 0x00200000, # HINT_RE_EVAL
);
# - File::Basename contains a literal for 'taint' as a fallback. If
# taint is changed here, File::Basename must be updated as well.
#
# - ExtUtils::ParseXS uses a hardcoded
# BEGIN { $^H |= 0x00200000 }
# in it to allow re.xs to be built. So if 'eval' is changed here then
# ExtUtils::ParseXS must be changed as well.
#
# *** WARNING *** WARNING *** WARNING *** WARNING *** WARNING ***
sub setcolor {
eval { # Ignore errors
require Term::Cap;
my $terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning.
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;
$colors =~ s/\0//g;
$ENV{PERL_RE_COLORS} = $colors;
};
if ($@) {
$ENV{PERL_RE_COLORS} ||= qq'\t\t> <\t> <\t\t';
}
}
my %flags = (
COMPILE => 0x0000FF,
PARSE => 0x000001,
OPTIMISE => 0x000002,
TRIEC => 0x000004,
DUMP => 0x000008,
FLAGS => 0x000010,
EXECUTE => 0x00FF00,
INTUIT => 0x000100,
MATCH => 0x000200,
TRIEE => 0x000400,
EXTRA => 0xFF0000,
TRIEM => 0x010000,
OFFSETS => 0x020000,
OFFSETSDBG => 0x040000,
STATE => 0x080000,
OPTIMISEM => 0x100000,
STACK => 0x280000,
BUFFERS => 0x400000,
);
$flags{ALL} = -1 & ~($flags{OFFSETS}|$flags{OFFSETSDBG}|$flags{BUFFERS});
$flags{All} = $flags{all} = $flags{DUMP} | $flags{EXECUTE};
$flags{Extra} = $flags{EXECUTE} | $flags{COMPILE};
$flags{More} = $flags{MORE} = $flags{All} | $flags{TRIEC} | $flags{TRIEM} | $flags{STATE};
$flags{State} = $flags{DUMP} | $flags{EXECUTE} | $flags{STATE};
$flags{TRIE} = $flags{DUMP} | $flags{EXECUTE} | $flags{TRIEC};
my $installed;
my $installed_error;
sub _do_install {
if ( ! defined($installed) ) {
require XSLoader;
$installed = eval { XSLoader::load('re', $VERSION) } || 0;
$installed_error = $@;
}
}
sub _load_unload {
my ($on)= @_;
if ($on) {
_do_install();
if ( ! $installed ) {
die "'re' not installed!? ($installed_error)";
} else {
# We call install() every time, as if we didn't, we wouldn't
# "see" any changes to the color environment var since
# the last time it was called.
# install() returns an integer, which if casted properly
# in C resolves to a structure containing the regex
# hooks. Setting it to a random integer will guarantee
# segfaults.
$^H{regcomp} = install();
}
} else {
delete $^H{regcomp};
}
}
sub bits {
my $on = shift;
my $bits = 0;
unless (@_) {
require Carp;
Carp::carp("Useless use of \"re\" pragma");
}
foreach my $idx (0..$#_){
my $s=$_[$idx];
if ($s eq 'Debug' or $s eq 'Debugcolor') {
setcolor() if $s =~/color/i;
${^RE_DEBUG_FLAGS} = 0 unless defined ${^RE_DEBUG_FLAGS};
for my $idx ($idx+1..$#_) {
if ($flags{$_[$idx]}) {
if ($on) {
${^RE_DEBUG_FLAGS} |= $flags{$_[$idx]};
} else {
${^RE_DEBUG_FLAGS} &= ~ $flags{$_[$idx]};
}
} else {
require Carp;
Carp::carp("Unknown \"re\" Debug flag '$_[$idx]', possible flags: ",
join(", ",sort keys %flags ) );
}
}
_load_unload($on ? 1 : ${^RE_DEBUG_FLAGS});
last;
} elsif ($s eq 'debug' or $s eq 'debugcolor') {
setcolor() if $s =~/color/i;
_load_unload($on);
last;
} elsif (exists $bitmask{$s}) {
$bits |= $bitmask{$s};
} elsif ($XS_FUNCTIONS{$s}) {
_do_install();
if (! $installed) {
require Carp;
Carp::croak("\"re\" function '$s' not available");
}
require Exporter;
re->export_to_level(2, 're', $s);
} elsif ($EXPORT_OK{$s}) {
require Exporter;
re->export_to_level(2, 're', $s);
} else {
require Carp;
Carp::carp("Unknown \"re\" subpragma '$s' (known ones are: ",
join(', ', map {qq('$_')} 'debug', 'debugcolor', sort keys %bitmask),
")");
}
}
$bits;
}
sub import {
shift;
$^H |= bits(1, @_);
}
sub unimport {
shift;
$^H &= ~ bits(0, @_);
}
1;
__END__