xref: /openbsd/gnu/usr.bin/perl/t/re/regexp.t (revision cca36db2) 
1#!./perl
2
3# The tests are in a separate file 't/re/re_tests'.
4# Each line in that file is a separate test.
5# There are five columns, separated by tabs.
6#
7# Column 1 contains the pattern, optionally enclosed in C<''>.
8# Modifiers can be put after the closing C<'>.
9#
10# Column 2 contains the string to be matched.
11#
12# Column 3 contains the expected result:
13# 	y	expect a match
14# 	n	expect no match
15# 	c	expect an error
16#	T	the test is a TODO (can be combined with y/n/c)
17#	B	test exposes a known bug in Perl, should be skipped
18#	b	test exposes a known bug in Perl, should be skipped if noamp
19#	t	test exposes a bug with threading, TODO if qr_embed_thr
20#
21# Columns 4 and 5 are used only if column 3 contains C<y> or C<c>.
22#
23# Column 4 contains a string, usually C<$&>.
24#
25# Column 5 contains the expected result of double-quote
26# interpolating that string after the match, or start of error message.
27#
28# Column 6, if present, contains a reason why the test is skipped.
29# This is printed with "skipped", for harness to pick up.
30#
31# \n in the tests are interpolated, as are variables of the form ${\w+}.
32#
33# Blanks lines are treated as PASSING tests to keep the line numbers
34# linked to the test number.
35#
36# If you want to add a regular expression test that can't be expressed
37# in this format, don't add it here: put it in re/pat.t instead.
38#
39# Note that the inputs get passed on as "m're'", so the re bypasses the lexer.
40# This means this file cannot be used for testing anything that the lexer
41# handles; in 5.12 this means just \N{NAME} and \N{U+...}.
42#
43# Note that columns 2,3 and 5 are all enclosed in double quotes and then
44# evalled; so something like a\"\x{100}$1 has length 3+length($1).
45
46my $file;
47BEGIN {
48    $iters = shift || 1;	# Poor man performance suite, 10000 is OK.
49
50    # Do this open before any chdir
51    $file = shift;
52    if (defined $file) {
53	open TESTS, $file or die "Can't open $file";
54    }
55
56    chdir 't' if -d 't';
57    @INC = '../lib';
58
59    if ($qr_embed_thr) {
60	require Config;
61	if (!$Config::Config{useithreads}) {
62	    print "1..0 # Skip: no ithreads\n";
63		exit 0;
64	}
65	if ($ENV{PERL_CORE_MINITEST}) {
66	    print "1..0 # Skip: no dynamic loading on miniperl, no threads\n";
67		exit 0;
68	}
69	require threads;
70    }
71}
72
73use strict;
74use warnings FATAL=>"all";
75use vars qw($iters $numtests $bang $ffff $nulnul $OP);
76use vars qw($qr $skip_amp $qr_embed $qr_embed_thr); # set by our callers
77
78
79if (!defined $file) {
80    open(TESTS,'re/re_tests') || open(TESTS,'t/re/re_tests')
81	|| open(TESTS,':re:re_tests') || die "Can't open re_tests";
82}
83
84my @tests = <TESTS>;
85
86close TESTS;
87
88$bang = sprintf "\\%03o", ord "!"; # \41 would not be portable.
89$ffff  = chr(0xff) x 2;
90$nulnul = "\0" x 2;
91$OP = $qr ? 'qr' : 'm';
92
93$| = 1;
94printf "1..%d\n# $iters iterations\n", scalar @tests;
95
96my $test;
97TEST:
98foreach (@tests) {
99    $test++;
100    if (!/\S/ || /^\s*#/ || /^__END__$/) {
101        print "ok $test # (Blank line or comment)\n";
102        if (/#/) { print $_ };
103        next;
104    }
105    chomp;
106    s/\\n/\n/g;
107    my ($pat, $subject, $result, $repl, $expect, $reason) = split(/\t/,$_,6);
108    $reason = '' unless defined $reason;
109    my $input = join(':',$pat,$subject,$result,$repl,$expect);
110    # the double '' below keeps simple syntax highlighters from going crazy
111    $pat = "'$pat'" unless $pat =~ /^[:''\/]/;
112    $pat =~ s/(\$\{\w+\})/$1/eeg;
113    $pat =~ s/\\n/\n/g;
114    $subject = eval qq("$subject"); die $@ if $@;
115    $expect  = eval qq("$expect"); die $@ if $@;
116    $expect = $repl = '-' if $skip_amp and $input =~ /\$[&\`\']/;
117    my $todo_qr = $qr_embed_thr && ($result =~ s/t//);
118    my $skip = ($skip_amp ? ($result =~ s/B//i) : ($result =~ s/B//));
119    $reason = 'skipping $&' if $reason eq  '' && $skip_amp;
120    $result =~ s/B//i unless $skip;
121    my $todo= $result =~ s/T// ? " # TODO" : "";
122
123
124    for my $study ('', 'study $subject', 'utf8::upgrade($subject)',
125		   'utf8::upgrade($subject); study $subject') {
126	# Need to make a copy, else the utf8::upgrade of an alreay studied
127	# scalar confuses things.
128	my $subject = $subject;
129	my $c = $iters;
130	my ($code, $match, $got);
131        if ($repl eq 'pos') {
132            $code= <<EOFCODE;
133                $study;
134                pos(\$subject)=0;
135                \$match = ( \$subject =~ m${pat}g );
136                \$got = pos(\$subject);
137EOFCODE
138        }
139        elsif ($qr_embed) {
140            $code= <<EOFCODE;
141                my \$RE = qr$pat;
142                $study;
143                \$match = (\$subject =~ /(?:)\$RE(?:)/) while \$c--;
144                \$got = "$repl";
145EOFCODE
146        }
147        elsif ($qr_embed_thr) {
148            $code= <<EOFCODE;
149		# Can't run the match in a subthread, but can do this and
150	 	# clone the pattern the other way.
151                my \$RE = threads->new(sub {qr$pat})->join();
152                $study;
153                \$match = (\$subject =~ /(?:)\$RE(?:)/) while \$c--;
154                \$got = "$repl";
155EOFCODE
156        }
157        else {
158            $code= <<EOFCODE;
159                $study;
160                \$match = (\$subject =~ $OP$pat) while \$c--;
161                \$got = "$repl";
162EOFCODE
163        }
164        #$code.=qq[\n\$expect="$expect";\n];
165        #use Devel::Peek;
166        #die Dump($code) if $pat=~/\\h/ and $subject=~/\x{A0}/;
167	{
168	    # Probably we should annotate specific tests with which warnings
169	    # categories they're known to trigger, and hence should be
170	    # disabled just for that test
171	    no warnings qw(uninitialized regexp);
172	    eval $code;
173	}
174	chomp( my $err = $@ );
175	if ($result eq 'c') {
176	    if ($err !~ m!^\Q$expect!) { print "not ok $test$todo (compile) $input => `$err'\n"; next TEST }
177	    last;  # no need to study a syntax error
178	}
179	elsif ( $skip ) {
180	    print "ok $test # skipped", length($reason) ? " $reason" : '', "\n";
181	    next TEST;
182	}
183	elsif ( $todo_qr ) {
184	    print "not ok $test # TODO", length($reason) ? " - $reason" : '', "\n";
185	    next TEST;
186	}
187	elsif ($@) {
188	    print "not ok $test$todo $input => error `$err'\n$code\n$@\n"; next TEST;
189	}
190	elsif ($result =~ /^n/) {
191	    if ($match) { print "not ok $test$todo ($study) $input => false positive\n"; next TEST }
192	}
193	else {
194	    if (!$match || $got ne $expect) {
195	        eval { require Data::Dumper };
196		if ($@) {
197		    print "not ok $test$todo ($study) $input => `$got', match=$match\n$code\n";
198		}
199		else { # better diagnostics
200		    my $s = Data::Dumper->new([$subject],['subject'])->Useqq(1)->Dump;
201		    my $g = Data::Dumper->new([$got],['got'])->Useqq(1)->Dump;
202		    print "not ok $test$todo ($study) $input => `$got', match=$match\n$s\n$g\n$code\n";
203		}
204		next TEST;
205	    }
206	}
207    }
208    print "ok $test$todo\n";
209}
210
2111;
212