summaryrefslogtreecommitdiffstats
path: root/gnu/usr.bin/perl/t/re/regexp.t
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/usr.bin/perl/t/re/regexp.t')
-rwxr-xr-xgnu/usr.bin/perl/t/re/regexp.t106
1 files changed, 84 insertions, 22 deletions
diff --git a/gnu/usr.bin/perl/t/re/regexp.t b/gnu/usr.bin/perl/t/re/regexp.t
index 8e98e55d8d9..037d7b7a488 100755
--- a/gnu/usr.bin/perl/t/re/regexp.t
+++ b/gnu/usr.bin/perl/t/re/regexp.t
@@ -5,8 +5,9 @@
# There are five columns, separated by tabs.
# An optional sixth column is used to give a reason, only when skipping tests
#
-# Column 1 contains the pattern, optionally enclosed in C<''>.
-# Modifiers can be put after the closing C<'>.
+# Column 1 contains the pattern, optionally enclosed in C<''> C<::> or
+# C<//>. Modifiers can be put after the closing delimiter. C<''> will
+# automatically be added to any other patterns.
#
# Column 2 contains the string to be matched.
#
@@ -70,6 +71,13 @@ BEGIN {
print("1..0 # Skip Unicode tables not built yet\n"), exit
unless eval 'require "unicore/Heavy.pl"';
}
+
+ # Some of the tests need a locale; which one doesn't much matter, except
+ # that it be valid. Make sure of that
+ eval { require POSIX;
+ POSIX->import(qw(LC_ALL setlocale));
+ POSIX::setlocale(&LC_ALL, "C");
+ };
}
sub _comment {
@@ -97,10 +105,11 @@ sub convert_from_ascii {
use strict;
use warnings FATAL=>"all";
-use vars qw($bang $ffff $nulnul); # used by the tests
-use vars qw($qr $skip_amp $qr_embed $qr_embed_thr $regex_sets); # set by our callers
-
+our ($bang, $ffff, $nulnul); # used by the tests
+our ($qr, $skip_amp, $qr_embed, $qr_embed_thr, $regex_sets, $alpha_assertions, $no_null); # set by our callers
+my $expanded_text = "expanded name from original test number";
+my $expanded_text_re = qr/$expanded_text/;
if (!defined $file) {
open TESTS, 're/re_tests' or die "Can't open re/re_tests: $!";
@@ -116,7 +125,6 @@ $nulnul = "\0" x 2;
my $OP = $qr ? 'qr' : 'm';
$| = 1;
-printf "1..%d\n# $iters iterations\n", scalar @tests;
my $test;
TEST:
@@ -132,6 +140,7 @@ foreach (@tests) {
chomp;
s/\\n/\n/g unless $regex_sets;
my ($pat, $subject, $result, $repl, $expect, $reason, $comment) = split(/\t/,$_,7);
+ $comment = "" unless defined $comment;
if (!defined $subject) {
die "Bad test definition on line $test: $_\n";
}
@@ -144,6 +153,11 @@ foreach (@tests) {
$pat =~ s/\\n/\n/g unless $regex_sets;
$pat = convert_from_ascii($pat) if ord("A") != 65;
+ my $no_null_pat;
+ if ($no_null && $pat =~ /^'(.*)'\z/) {
+ $no_null_pat = XS::APItest::string_without_null($1);
+ }
+
$subject = convert_from_ascii($subject) if ord("A") != 65;
$subject = eval qq("$subject"); die $@ if $@;
@@ -176,7 +190,42 @@ foreach (@tests) {
$comment=~s/^\s*(?:#\s*)?//;
$testname .= " - $comment" if $comment;
}
- if (! $skip && $regex_sets) {
+ if (! $skip && $alpha_assertions) {
+ my $assertions_re = qr/ (?: \Q(?\E (?: > | <? [=>] ) ) /x;
+ if ($pat !~ $assertions_re && $comment !~ $expanded_text_re) {
+ $skip++;
+ $reason = "Pattern doesn't contain assertions";
+ }
+ elsif ($comment !~ $expanded_text_re) {
+ my $expanded_pat = $pat;
+
+ $pat =~ s/\( \? > /(*atomic:/xg;
+
+ if ($pat =~ s/\( \? = /(*pla:/xg) {
+ $expanded_pat =~ s//(*positive_lookahead:/g;
+ }
+ if ($pat =~ s/\( \? ! /(*nla:/xg) {
+ $expanded_pat =~ s//(*negative_lookahead:/g;
+ }
+ if ($pat =~ s/\( \? <= /(*plb:/xg) {
+ $expanded_pat =~ s//(*positive_lookbehind:/g;
+ }
+ if ($pat =~ s/\( \? <! /(*nlb:/xg) {
+ $expanded_pat =~ s//(*negative_lookbehind:/g;
+ }
+ if ($expanded_pat ne $pat) {
+ $comment .= " $expanded_text $test";
+ push @tests, join "\t", $expanded_pat,
+ $subject // "",
+ $result // "",
+ $repl // "",
+ $expect // "",
+ $reason // "",
+ $comment;
+ }
+ }
+ }
+ elsif (! $skip && $regex_sets) {
# If testing regex sets, change the [bracketed] classes into
# (?[bracketed]). But note that '\[' and '\c[' don't introduce such a
@@ -240,7 +289,8 @@ foreach (@tests) {
}
}
$j--;
- $modified .= substr($pat, $i + 1, $j - $i) . " ";
+ $modified .= substr($pat, $i + 1, $j - $i);
+ $modified .= " " if $in_brackets;
$i = $j;
}
elsif (ord($curchar) >= ord('0')
@@ -283,12 +333,8 @@ foreach (@tests) {
# A regular character.
if ($curchar ne '[') {
- if (! $in_brackets) {
- $modified .= $curchar;
- }
- else {
- $modified .= " $curchar ";
- }
+ $modified .= " " if $in_brackets;
+ $modified .= $curchar;
next;
}
@@ -358,25 +404,28 @@ foreach (@tests) {
}
}
- for my $study ('', 'study $subject', 'utf8::upgrade($subject)',
- 'utf8::upgrade($subject); study $subject') {
+ for my $study ('', 'study $subject;', 'utf8::upgrade($subject);',
+ 'utf8::upgrade($subject); study $subject;') {
# Need to make a copy, else the utf8::upgrade of an already studied
# scalar confuses things.
my $subject = $subject;
+ $subject = XS::APItest::string_without_null($subject) if $no_null;
my $c = $iters;
my ($code, $match, $got);
if ($repl eq 'pos') {
+ my $patcode = defined $no_null_pat ? '/$no_null_pat/g'
+ : "m${pat}g";
$code= <<EOFCODE;
- $study;
+ $study
pos(\$subject)=0;
- \$match = ( \$subject =~ m${pat}g );
+ \$match = ( \$subject =~ $patcode );
\$got = pos(\$subject);
EOFCODE
}
elsif ($qr_embed) {
$code= <<EOFCODE;
my \$RE = qr$pat;
- $study;
+ $study
\$match = (\$subject =~ /(?:)\$RE(?:)/) while \$c--;
\$got = "$repl";
EOFCODE
@@ -386,19 +435,29 @@ EOFCODE
# Can't run the match in a subthread, but can do this and
# clone the pattern the other way.
my \$RE = threads->new(sub {qr$pat})->join();
- $study;
+ $study
\$match = (\$subject =~ /(?:)\$RE(?:)/) while \$c--;
\$got = "$repl";
EOFCODE
}
+ elsif ($no_null) {
+ my $patcode = defined $no_null_pat ? '/$no_null_pat/'
+ : $pat;
+ $code= <<EOFCODE;
+ $study
+ \$match = (\$subject =~ $OP$pat) while \$c--;
+ \$got = "$repl";
+EOFCODE
+ }
else {
$code= <<EOFCODE;
- $study;
+ $study
\$match = (\$subject =~ $OP$pat) while \$c--;
\$got = "$repl";
EOFCODE
}
$code = "no warnings 'experimental::regex_sets';$code" if $regex_sets;
+ $code = "no warnings 'experimental::alpha_assertions';$code" if $alpha_assertions;
#$code.=qq[\n\$expect="$expect";\n];
#use Devel::Peek;
#die Dump($code) if $pat=~/\\h/ and $subject=~/\x{A0}/;
@@ -442,7 +501,8 @@ EOFCODE
else { # better diagnostics
my $s = Data::Dumper->new([$subject],['subject'])->Useqq(1)->Dump;
my $g = Data::Dumper->new([$got],['got'])->Useqq(1)->Dump;
- print "not ok $testname$todo ($study) $input => '$got', match=$match\n", _comment("$s\n$g\n$code\n");
+ my $e = Data::Dumper->new([$expect],['expected'])->Useqq(1)->Dump;
+ print "not ok $testname$todo ($study) $input => '$got', match=$match\n", _comment("$s\n$code\n$g\n$e\n");
}
next TEST;
}
@@ -451,4 +511,6 @@ EOFCODE
print "ok $testname$todo\n";
}
+printf "1..%d\n# $iters iterations\n", scalar @tests;
+
1;
Copyright © 1996 – 2023 Jason A. Donenfeld. All Rights Reverse Engineered.