This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #118175] prevent a similar overflow for CANY
[perl5.git] / t / re / pat_rt_report.t
CommitLineData
e425a60b
YO
1#!./perl
2#
3# This is a home for regular expression tests that don't fit into
4# the format supported by re/regexp.t. If you want to add a test
5# that does fit that format, add it to re/re_tests, not here.
6
7use strict;
8use warnings;
9use 5.010;
453466ce 10use Config;
e425a60b
YO
11
12sub run_tests;
13
14$| = 1;
15
e425a60b
YO
16
17BEGIN {
18 chdir 't' if -d 't';
9d45b377 19 @INC = ('../lib','.');
6f4e0180 20 require './test.pl';
2fcf74c4 21 skip_all_if_miniperl("miniperl can't load Tie::Hash::NamedCapture, need for %+ and %-");
e425a60b 22}
e425a60b 23
e425a60b 24
9597860a 25plan tests => 2532; # Update this when adding/deleting tests.
e425a60b 26
9d45b377 27run_tests() unless caller;
e425a60b
YO
28
29#
30# Tests start here.
31#
32sub run_tests {
33
a86da477
NC
34 like("A \x{263a} B z C", qr/A . B (??{ "z" }) C/,
35 "Match UTF-8 char in presence of (??{ }); Bug 20000731.001");
36
e425a60b 37 {
e425a60b 38 no warnings 'uninitialized';
a86da477 39 ok(undef =~ /^([^\/]*)(.*)$/, "Used to cause a SEGV; Bug 20001021.005");
e425a60b
YO
40 }
41
e425a60b 42 {
51b6c6b3 43 my $message = 'bug id 20001008.001';
e425a60b
YO
44
45 my @x = ("stra\337e 138", "stra\337e 138");
46 for (@x) {
51b6c6b3
NC
47 ok(s/(\d+)\s*([\w\-]+)/$1 . uc $2/e, $message);
48 ok(my ($latin) = /^(.+)(?:\s+\d)/, $message);
49 is($latin, "stra\337e", $message);
50 ok($latin =~ s/stra\337e/straße/, $message);
e425a60b
YO
51 #
52 # Previous code follows, but outcommented - there were no tests.
53 #
54 # $latin =~ s/stra\337e/straße/; # \303\237 after the 2nd a
55 # use utf8; # needed for the raw UTF-8
56 # $latin =~ s!(s)tr(?:aß|s+e)!$1tr.!; # \303\237 after the a
57 }
58 }
59
e425a60b 60 {
e425a60b 61 # Fist half of the bug.
a86da477 62 my $message = 'HEBREW ACCENT QADMA matched by .*; Bug 20001028.003';
e425a60b 63 my $X = chr (1448);
51b6c6b3
NC
64 ok(my ($Y) = $X =~ /(.*)/, $message);
65 is($Y, v1448, $message);
66 is(length $Y, 1, $message);
e425a60b
YO
67
68 # Second half of the bug.
a86da477 69 $message = 'HEBREW ACCENT QADMA in replacement; Bug 20001028.003';
e425a60b
YO
70 $X = '';
71 $X =~ s/^/chr(1488)/e;
51b6c6b3
NC
72 is(length $X, 1, $message);
73 is(ord $X, 1488, $message);
e425a60b
YO
74 }
75
e425a60b 76 {
a86da477 77 my $message = 'Repeated s///; Bug 20001108.001';
e425a60b
YO
78 my $X = "Szab\x{f3},Bal\x{e1}zs";
79 my $Y = $X;
80 $Y =~ s/(B)/$1/ for 0 .. 3;
51b6c6b3
NC
81 is($Y, $X, $message);
82 is($X, "Szab\x{f3},Bal\x{e1}zs", $message);
e425a60b
YO
83 }
84
e425a60b 85 {
a86da477 86 my $message = 's/// on UTF-8 string; Bug 20000517.001';
e425a60b
YO
87 my $x = "\x{100}A";
88 $x =~ s/A/B/;
51b6c6b3
NC
89 is($x, "\x{100}B", $message);
90 is(length $x, 2, $message);
e425a60b
YO
91 }
92
e425a60b 93 {
a86da477 94 my $message = '\C and É; Bug 20001230.002';
51b6c6b3
NC
95 ok("École" =~ /^\C\C(.)/ && $1 eq 'c', $message);
96 like("École", qr/^\C\C(c)/, $message);
e425a60b
YO
97 }
98
e425a60b
YO
99 {
100 # The original bug report had 'no utf8' here but that was irrelevant.
a86da477
NC
101
102 my $message = "Don't dump core; Bug 20010306.008";
e425a60b 103 my $a = "a\x{1234}";
51b6c6b3 104 like($a, qr/\w/, $message); # used to core dump.
e425a60b
YO
105 }
106
e425a60b 107 {
a86da477 108 my $message = '/g in scalar context; Bug 20010410.006';
e425a60b
YO
109 for my $rx ('/(.*?)\{(.*?)\}/csg',
110 '/(.*?)\{(.*?)\}/cg',
111 '/(.*?)\{(.*?)\}/sg',
112 '/(.*?)\{(.*?)\}/g',
113 '/(.+?)\{(.+?)\}/csg',) {
114 my $i = 0;
115 my $input = "a{b}c{d}";
116 eval <<" --";
117 while (eval \$input =~ $rx) {
118 \$i ++;
119 }
120 --
51b6c6b3 121 is($i, 2, $message);
e425a60b
YO
122 }
123 }
124
e425a60b 125 {
e425a60b
YO
126 # Amazingly vertical tabulator is the same in ASCII and EBCDIC.
127 for ("\n", "\t", "\014", "\r") {
5895685f 128 unlike($_, qr/[[:print:]]/, sprintf "\\%03o not in [[:print:]]; Bug 20010619.003", ord $_);
e425a60b
YO
129 }
130 for (" ") {
a86da477 131 like($_, qr/[[:print:]]/, "'$_' in [[:print:]]; Bug 20010619.003");
e425a60b
YO
132 }
133 }
134
e425a60b
YO
135 {
136 # [ID 20010814.004] pos() doesn't work when using =~m// in list context
a86da477 137
e425a60b
YO
138 $_ = "ababacadaea";
139 my $a = join ":", /b./gc;
140 my $b = join ":", /a./gc;
141 my $c = pos;
a86da477 142 is("$a $b $c", 'ba:ba ad:ae 10', "pos() works with () = m//; Bug 20010814.004");
e425a60b
YO
143 }
144
e425a60b
YO
145 {
146 # [ID 20010407.006] matching utf8 return values from
147 # functions does not work
a86da477
NC
148
149 my $message = 'UTF-8 return values from functions; Bug 20010407.006';
e425a60b
YO
150 package ID_20010407_006;
151 sub x {"a\x{1234}"}
152 my $x = x;
153 my $y;
51b6c6b3 154 ::ok($x =~ /(..)/, $message);
e425a60b 155 $y = $1;
51b6c6b3
NC
156 ::ok(length ($y) == 2 && $y eq $x, $message);
157 ::ok(x =~ /(..)/, $message);
e425a60b 158 $y = $1;
51b6c6b3 159 ::ok(length ($y) == 2 && $y eq $x, $message);
e425a60b
YO
160 }
161
e425a60b
YO
162 {
163 # High bit bug -- japhy
164 my $x = "ab\200d";
165 ok $x =~ /.*?\200/, "High bit fine";
166 }
167
e425a60b 168 {
51b6c6b3 169 my $message = 'UTF-8 hash keys and /$/';
e425a60b
YO
170 # http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters
171 # /2002-01/msg01327.html
172
173 my $u = "a\x{100}";
174 my $v = substr ($u, 0, 1);
175 my $w = substr ($u, 1, 1);
176 my %u = ($u => $u, $v => $v, $w => $w);
177 for (keys %u) {
178 my $m1 = /^\w*$/ ? 1 : 0;
179 my $m2 = $u {$_} =~ /^\w*$/ ? 1 : 0;
51b6c6b3 180 is($m1, $m2, $message);
e425a60b
YO
181 }
182 }
183
e425a60b 184 {
a86da477 185 my $message = "s///eg [change 13f46d054db22cf4]; Bug 20020124.005";
e425a60b
YO
186
187 for my $char ("a", "\x{df}", "\x{100}") {
188 my $x = "$char b $char";
189 $x =~ s{($char)}{
190 "c" =~ /c/;
191 "x";
192 }ge;
51b6c6b3 193 is(substr ($x, 0, 1), substr ($x, -1, 1), $message);
e425a60b
YO
194 }
195 }
196
e425a60b 197 {
a86da477 198 my $message = "Correct pmop flags checked when empty pattern; Bug 20020412.005";
e425a60b
YO
199
200 # Requires reuse of last successful pattern.
201 my $num = 123;
202 $num =~ /\d/;
203 for (0 .. 1) {
725a61d7 204 my $match = m?? + 0;
5895685f
NC
205 ok($match != $_, $message)
206 or diag(sprintf "'match one' %s on %s iteration" =>
207 $match ? 'succeeded' : 'failed',
208 $_ ? 'second' : 'first');
e425a60b
YO
209 }
210 $num =~ /(\d)/;
211 my $result = join "" => $num =~ //g;
51b6c6b3 212 is($result, $num, $message);
e425a60b
YO
213 }
214
e425a60b 215 {
a86da477 216 my $message = 'UTF-8 regex matches above 32k; Bug 20020630.002';
e425a60b
YO
217 for (['byte', "\x{ff}"], ['utf8', "\x{1ff}"]) {
218 my ($type, $char) = @$_;
219 for my $len (32000, 32768, 33000) {
220 my $s = $char . "f" x $len;
221 my $r = $s =~ /$char([f]*)/gc;
5895685f
NC
222 ok($r, $message) or diag("<$type x $len>");
223 ok(!$r || pos ($s) == $len + 1, $message)
224 or diag("<$type x $len>; pos = @{[pos $s]}");
e425a60b
YO
225 }
226 }
227 }
228
e425a60b 229 {
e425a60b
YO
230 my $s = "\x{100}" x 5;
231 my $ok = $s =~ /(\x{100}{4})/;
232 my ($ord, $len) = (ord $1, length $1);
1c6f1211 233 ok $ok && $ord == 0x100 && $len == 4, "No panic: end_shift [change 0e933229fa758625]";
e425a60b
YO
234 }
235
e425a60b 236 {
e425a60b
YO
237 our $a = "x\x{100}";
238 chop $a; # Leaves the UTF-8 flag
239 $a .= "y"; # 1 byte before 'y'.
240
a86da477
NC
241 like($a, qr/^\C/, 'match one \C on 1-byte UTF-8; Bug 15763');
242 like($a, qr/^\C{1}/, 'match \C{1}; Bug 15763');
e425a60b 243
a86da477
NC
244 like($a, qr/^\Cy/, 'match \Cy; Bug 15763');
245 like($a, qr/^\C{1}y/, 'match \C{1}y; Bug 15763');
e425a60b 246
a86da477
NC
247 unlike($a, qr/^\C\Cy/, q {don't match two \Cy; Bug 15763});
248 unlike($a, qr/^\C{2}y/, q {don't match \C{2}y; Bug 15763});
e425a60b
YO
249
250 $a = "\x{100}y"; # 2 bytes before "y"
251
a86da477
NC
252 like($a, qr/^\C/, 'match one \C on 2-byte UTF-8; Bug 15763');
253 like($a, qr/^\C{1}/, 'match \C{1}; Bug 15763');
254 like($a, qr/^\C\C/, 'match two \C; Bug 15763');
255 like($a, qr/^\C{2}/, 'match \C{2}; Bug 15763');
e425a60b 256
a86da477
NC
257 like($a, qr/^\C\C\C/, 'match three \C on 2-byte UTF-8 and a byte; Bug 15763');
258 like($a, qr/^\C{3}/, 'match \C{3}; Bug 15763');
e425a60b 259
a86da477
NC
260 like($a, qr/^\C\Cy/, 'match two \C; Bug 15763');
261 like($a, qr/^\C{2}y/, 'match \C{2}; Bug 15763');
e425a60b 262
a86da477
NC
263 unlike($a, qr/^\C\C\Cy/, q {don't match three \Cy; Bug 15763});
264 unlike($a, qr/^\C{2}\Cy/, q {don't match \C{2}\Cy; Bug 15763});
265 unlike($a, qr/^\C{3}y/, q {don't match \C{3}y; Bug 15763});
e425a60b
YO
266
267 $a = "\x{1000}y"; # 3 bytes before "y"
268
a86da477
NC
269 like($a, qr/^\C/, 'match one \C on three-byte UTF-8; Bug 15763');
270 like($a, qr/^\C{1}/, 'match \C{1}; Bug 15763');
271 like($a, qr/^\C\C/, 'match two \C; Bug 15763');
272 like($a, qr/^\C{2}/, 'match \C{2}; Bug 15763');
273 like($a, qr/^\C\C\C/, 'match three \C; Bug 15763');
274 like($a, qr/^\C{3}/, 'match \C{3}; Bug 15763');
e425a60b 275
a86da477
NC
276 like($a, qr/^\C\C\C\C/, 'match four \C on three-byte UTF-8 and a byte; Bug 15763');
277 like($a, qr/^\C{4}/, 'match \C{4}; Bug 15763');
e425a60b 278
a86da477
NC
279 like($a, qr/^\C\C\Cy/, 'match three \Cy; Bug 15763');
280 like($a, qr/^\C{3}y/, 'match \C{3}y; Bug 15763');
e425a60b 281
a86da477
NC
282 unlike($a, qr/^\C\C\C\Cy/, q {don't match four \Cy; Bug 15763});
283 unlike($a, qr/^\C{4}y/, q {don't match \C{4}y; Bug 15763});
e425a60b
YO
284 }
285
286
287 {
a86da477 288 my $message = 'UTF-8 matching; Bug 15397';
51b6c6b3
NC
289 like("\x{100}", qr/\x{100}/, $message);
290 like("\x{100}", qr/(\x{100})/, $message);
291 like("\x{100}", qr/(\x{100}){1}/, $message);
292 like("\x{100}\x{100}", qr/(\x{100}){2}/, $message);
293 like("\x{100}\x{100}", qr/(\x{100})(\x{100})/, $message);
e425a60b
YO
294 }
295
e425a60b 296 {
a86da477 297 my $message = 'Neither ()* nor ()*? sets $1 when matched 0 times; Bug 7471';
e425a60b 298 local $_ = 'CD';
51b6c6b3
NC
299 ok(/(AB)*?CD/ && !defined $1, $message);
300 ok(/(AB)*CD/ && !defined $1, $message);
e425a60b
YO
301 }
302
e425a60b 303 {
a86da477 304 my $message = "Caching shouldn't prevent match; Bug 3547";
e425a60b 305 my $pattern = "^(b+?|a){1,2}c";
51b6c6b3
NC
306 ok("bac" =~ /$pattern/ && $1 eq 'a', $message);
307 ok("bbac" =~ /$pattern/ && $1 eq 'a', $message);
308 ok("bbbac" =~ /$pattern/ && $1 eq 'a', $message);
309 ok("bbbbac" =~ /$pattern/ && $1 eq 'a', $message);
e425a60b
YO
310 }
311
e425a60b 312 {
a86da477
NC
313 ok("\x{100}" =~ /(.)/, '$1 should keep UTF-8 ness; Bug 18232');
314 is($1, "\x{100}", '$1 is UTF-8; Bug 18232');
e425a60b 315 { 'a' =~ /./; }
a86da477
NC
316 is($1, "\x{100}", '$1 is still UTF-8; Bug 18232');
317 isnt($1, "\xC4\x80", '$1 is not non-UTF-8; Bug 18232');
e425a60b
YO
318 }
319
e425a60b 320 {
a86da477 321 my $message = "Optimizer doesn't prematurely reject match; Bug 19767";
e425a60b
YO
322 use utf8;
323
324 my $attr = 'Name-1';
325 my $NormalChar = qr /[\p{IsDigit}\p{IsLower}\p{IsUpper}]/;
326 my $NormalWord = qr /${NormalChar}+?/;
327 my $PredNameHyphen = qr /^${NormalWord}(\-${NormalWord})*?$/;
328
329 $attr =~ /^$/;
51b6c6b3 330 like($attr, $PredNameHyphen, $message); # Original test.
e425a60b
YO
331
332 "a" =~ m/[b]/;
51b6c6b3 333 like("0", qr/\p{N}+\z/, $message); # Variant.
e425a60b
YO
334 }
335
e425a60b 336 {
a86da477 337 my $message = "(??{ }) doesn't return stale values; Bug 20683";
e425a60b
YO
338 our $p = 1;
339 foreach (1, 2, 3, 4) {
340 $p ++ if /(??{ $p })/
341 }
51b6c6b3 342 is($p, 5, $message);
e425a60b
YO
343
344 {
345 package P;
346 $a = 1;
347 sub TIESCALAR {bless []}
348 sub FETCH {$a ++}
349 }
350 tie $p, "P";
351 foreach (1, 2, 3, 4) {
352 /(??{ $p })/
353 }
51b6c6b3 354 is($p, 5, $message);
e425a60b
YO
355 }
356
e425a60b
YO
357 {
358 # Subject: Odd regexp behavior
359 # From: Markus Kuhn <Markus.Kuhn@cl.cam.ac.uk>
360 # Date: Wed, 26 Feb 2003 16:53:12 +0000
361 # Message-Id: <E18o4nw-0008Ly-00@wisbech.cl.cam.ac.uk>
362 # To: perl-unicode@perl.org
363
51b6c6b3 364 my $message = 'Markus Kuhn 2003-02-26';
e425a60b
YO
365
366 my $x = "\x{2019}\nk";
51b6c6b3
NC
367 ok($x =~ s/(\S)\n(\S)/$1 $2/sg, $message);
368 is($x, "\x{2019} k", $message);
e425a60b
YO
369
370 $x = "b\nk";
51b6c6b3
NC
371 ok($x =~ s/(\S)\n(\S)/$1 $2/sg, $message);
372 is($x, "b k", $message);
e425a60b 373
51b6c6b3 374 like("\x{2019}", qr/\S/, $message);
e425a60b
YO
375 }
376
e425a60b 377 {
a86da477 378 my $message = "(??{ .. }) in split doesn't corrupt its stack; Bug 21411";
e425a60b 379 our $i;
51b6c6b3 380 is('-1-3-5-', join('', split /((??{$i++}))/, '-1-3-5-'), $message);
e425a60b
YO
381 no warnings 'syntax';
382 @_ = split /(?{'WOW'})/, 'abc';
383 local $" = "|";
51b6c6b3 384 is("@_", "a|b|c", $message);
e425a60b
YO
385 }
386
f7a1f402 387 is(join('-', split /(?{ split "" })/, "abc"), 'a-b-c', 'nested split');
e425a60b 388
e425a60b 389 {
e425a60b
YO
390 $_ = "code: 'x' { '...' }\n"; study;
391 my @x; push @x, $& while m/'[^\']*'/gx;
392 local $" = ":";
a86da477 393 is("@x", "'x':'...'", "Parse::RecDescent triggered infinite loop; Bug 17757");
e425a60b
YO
394 }
395
e425a60b 396 {
e425a60b 397 sub func ($) {
a86da477
NC
398 ok("a\nb" !~ /^b/, "Propagated modifier; $_[0]; Bug 22354");
399 ok("a\nb" =~ /^b/m, "Propagated modifier; $_[0] - with /m; Bug 22354");
e425a60b
YO
400 }
401 func "standalone";
402 $_ = "x"; s/x/func "in subst"/e;
403 $_ = "x"; s/x/func "in multiline subst"/em;
1d0dc949
FC
404 $_ = "x"; /x(?{func "in regexp"})/;
405 $_ = "x"; /x(?{func "in multiline regexp"})/m;
e425a60b
YO
406 }
407
e425a60b 408 {
e425a60b
YO
409 $_ = "abcdef\n";
410 my @x = m/./g;
a86da477 411 is("abcde", $`, 'Global match sets $`; Bug 19049');
e425a60b
YO
412 }
413
e425a60b 414 {
e425a60b
YO
415 # [perl #23769] Unicode regex broken on simple example
416 # regrepeat() didn't handle UTF-8 EXACT case right.
a86da477 417
e425a60b 418 my $Mess = 'regrepeat() handles UTF-8 EXACT case right';
a86da477 419 my $message = "$Mess; Bug 23769";
e425a60b
YO
420
421 my $s = "\x{a0}\x{a0}\x{a0}\x{100}"; chop $s;
422
51b6c6b3
NC
423 like($s, qr/\x{a0}/, $message);
424 like($s, qr/\x{a0}+/, $message);
425 like($s, qr/\x{a0}\x{a0}/, $message);
e425a60b 426
a86da477 427 $message = "$Mess (easy variant); Bug 23769";
51b6c6b3
NC
428 ok("aaa\x{100}" =~ /(a+)/, $message);
429 is($1, "aaa", $message);
e425a60b 430
a86da477 431 $message = "$Mess (easy invariant); Bug 23769";
51b6c6b3
NC
432 ok("aaa\x{100} " =~ /(a+?)/, $message);
433 is($1, "a", $message);
e425a60b 434
a86da477 435 $message = "$Mess (regrepeat variant); Bug 23769";
51b6c6b3
NC
436 ok("\xa0\xa0\xa0\x{100} " =~ /(\xa0+?)/, $message);
437 is($1, "\xa0", $message);
e425a60b 438
a86da477 439 $message = "$Mess (regrepeat invariant); Bug 23769";
51b6c6b3
NC
440 ok("\xa0\xa0\xa0\x{100}" =~ /(\xa0+)/, $message);
441 is($1, "\xa0\xa0\xa0", $message);
e425a60b 442
a86da477 443 $message = "$Mess (hard variant); Bug 23769";
51b6c6b3
NC
444 ok("\xa0\xa1\xa0\xa1\xa0\xa1\x{100}" =~ /((?:\xa0\xa1)+?)/, $message);
445 is($1, "\xa0\xa1", $message);
e425a60b 446
a86da477 447 $message = "$Mess (hard invariant); Bug 23769";
51b6c6b3
NC
448 ok("ababab\x{100} " =~ /((?:ab)+)/, $message);
449 is($1, 'ababab', $message);
e425a60b 450
51b6c6b3
NC
451 ok("\xa0\xa1\xa0\xa1\xa0\xa1\x{100}" =~ /((?:\xa0\xa1)+)/, $message);
452 is($1, "\xa0\xa1\xa0\xa1\xa0\xa1", $message);
e425a60b 453
51b6c6b3
NC
454 ok("ababab\x{100} " =~ /((?:ab)+?)/, $message);
455 is($1, "ab", $message);
e425a60b 456
a86da477 457 $message = "Don't match first byte of UTF-8 representation; Bug 23769";
51b6c6b3
NC
458 unlike("\xc4\xc4\xc4", qr/(\x{100}+)/, $message);
459 unlike("\xc4\xc4\xc4", qr/(\x{100}+?)/, $message);
460 unlike("\xc4\xc4\xc4", qr/(\x{100}++)/, $message);
e425a60b
YO
461 }
462
e425a60b 463 {
e425a60b 464 # perl panic: pp_match start/end pointers
a86da477
NC
465
466 is(eval {my ($x, $y) = "bca" =~ /^(?=.*(a)).*(bc)/; "$x-$y"}, "a-bc",
467 'Captures can move backwards in string; Bug 25269');
e425a60b
YO
468 }
469
e425a60b 470 {
a86da477
NC
471 # \cA not recognized in character classes
472 like("a\cAb", qr/\cA/, '\cA in pattern; Bug 27940');
473 like("a\cAb", qr/[\cA]/, '\cA in character class; Bug 27940');
474 like("a\cAb", qr/[\cA-\cB]/, '\cA in character class range; Bug 27940');
475 like("abc", qr/[^\cA-\cB]/, '\cA in negated character class range; Bug 27940');
476 like("a\cBb", qr/[\cA-\cC]/, '\cB in character class range; Bug 27940');
477 like("a\cCbc", qr/[^\cA-\cB]/, '\cC in negated character class range; Bug 27940');
478 like("a\cAb", qr/(??{"\cA"})/, '\cA in ??{} pattern; Bug 27940');
479 unlike("ab", qr/a\cIb/x, '\cI in pattern; Bug 27940');
e425a60b
YO
480 }
481
e425a60b 482 {
9d45b377 483 # perl #28532: optional zero-width match at end of string is ignored
a86da477
NC
484
485 ok("abc" =~ /^abc(\z)?/ && defined($1),
486 'Optional zero-width match at end of string; Bug 28532');
487 ok("abc" =~ /^abc(\z)??/ && !defined($1),
488 'Optional zero-width match at end of string; Bug 28532');
e425a60b
YO
489 }
490
e425a60b 491 {
e425a60b
YO
492 my $utf8 = "\xe9\x{100}"; chop $utf8;
493 my $latin1 = "\xe9";
494
a86da477
NC
495 like($utf8, qr/\xe9/i, "utf8/latin; Bug 36207");
496 like($utf8, qr/$latin1/i, "utf8/latin runtime; Bug 36207");
497 like($utf8, qr/(abc|\xe9)/i, "utf8/latin trie; Bug 36207");
498 like($utf8, qr/(abc|$latin1)/i, "utf8/latin trie runtime; Bug 36207");
e425a60b 499
a86da477
NC
500 like("\xe9", qr/$utf8/i, "latin/utf8; Bug 36207");
501 like("\xe9", qr/(abc|$utf8)/i, "latin/utf8 trie; Bug 36207");
502 like($latin1, qr/$utf8/i, "latin/utf8 runtime; Bug 36207");
503 like($latin1, qr/(abc|$utf8)/i, "latin/utf8 trie runtime; Bug 36207");
e425a60b
YO
504 }
505
e425a60b 506 {
e425a60b
YO
507 my $s = "abcd";
508 $s =~ /(..)(..)/g;
509 $s = $1;
510 $s = $2;
a86da477
NC
511 is($2, 'cd',
512 "Assigning to original string does not corrupt match vars; Bug 37038");
e425a60b
YO
513 }
514
e425a60b
YO
515 {
516 {
517 package wooosh;
518 sub gloople {"!"}
519 }
520 my $aeek = bless {} => 'wooosh';
2e321296
NC
521 is(do {$aeek -> gloople () =~ /(.)/g}, 1,
522 "//g match against return value of sub [change e26a497577f3ce7b]");
e425a60b
YO
523
524 sub gloople {"!"}
2e321296
NC
525 is(do{gloople () =~ /(.)/g}, 1,
526 "change e26a497577f3ce7b didn't affect sub calls for some reason");
e425a60b
YO
527 }
528
e425a60b 529 {
bf8fb5eb
FC
530 # [perl #78680]
531 # See changes 26925-26928, which reverted change 26410
e425a60b
YO
532 {
533 package lv;
534 our $var = "abc";
535 sub variable : lvalue {$var}
536 }
537 my $o = bless [] => 'lv';
538 my $f = "";
539 my $r = eval {
540 for (1 .. 2) {
541 $f .= $1 if $o -> variable =~ /(.)/g;
542 }
543 1;
544 };
545 if ($r) {
de26e0cc 546 is($f, "ab", "pos() retained between calls");
e425a60b
YO
547 }
548 else {
e425a60b
YO
549 ok 0, "Code failed: $@";
550 }
551
552 our $var = "abc";
553 sub variable : lvalue {$var}
554 my $g = "";
555 my $s = eval {
556 for (1 .. 2) {
557 $g .= $1 if variable =~ /(.)/g;
558 }
559 1;
560 };
561 if ($s) {
de26e0cc 562 is($g, "ab", "pos() retained between calls");
e425a60b
YO
563 }
564 else {
e425a60b
YO
565 ok 0, "Code failed: $@";
566 }
567 }
568
e425a60b
YO
569 SKIP:
570 {
ef237063 571 skip "In EBCDIC" if $::IS_EBCDIC;
e425a60b
YO
572 no warnings 'utf8';
573 $_ = pack 'U0C2', 0xa2, 0xf8; # Ill-formed UTF-8
574 my $ret = 0;
2e321296
NC
575 is(do {!($ret = s/[\0]+//g)}, 1,
576 "Ill-formed UTF-8 doesn't match NUL in class; Bug 37836");
e425a60b
YO
577 }
578
e425a60b
YO
579 {
580 # chr(65535) should be allowed in regexes
a86da477 581
e425a60b
YO
582 no warnings 'utf8'; # To allow non-characters
583 my ($c, $r, $s);
584
585 $c = chr 0xffff;
586 $c =~ s/$c//g;
a86da477 587 is($c, "", "U+FFFF, parsed as atom; Bug 38293");
e425a60b
YO
588
589 $c = chr 0xffff;
590 $r = "\\$c";
591 $c =~ s/$r//g;
a86da477 592 is($c, "", "U+FFFF backslashed, parsed as atom; Bug 38293");
e425a60b
YO
593
594 $c = chr 0xffff;
595 $c =~ s/[$c]//g;
a86da477 596 is($c, "", "U+FFFF, parsed in class; Bug 38293");
e425a60b
YO
597
598 $c = chr 0xffff;
599 $r = "[\\$c]";
600 $c =~ s/$r//g;
a86da477 601 is($c, "", "U+FFFF backslashed, parsed in class; Bug 38293");
e425a60b
YO
602
603 $s = "A\x{ffff}B";
604 $s =~ s/\x{ffff}//i;
a86da477 605 is($s, "AB", "U+FFFF, EXACTF; Bug 38293");
e425a60b
YO
606
607 $s = "\x{ffff}A";
608 $s =~ s/\bA//;
a86da477 609 is($s, "\x{ffff}", "U+FFFF, BOUND; Bug 38293");
e425a60b
YO
610
611 $s = "\x{ffff}!";
612 $s =~ s/\B!//;
a86da477 613 is($s, "\x{ffff}", "U+FFFF, NBOUND; Bug 38293");
e425a60b
YO
614 }
615
e425a60b 616 {
e425a60b
YO
617
618 # The printing characters
619 my @chars = ("A" .. "Z");
620 my $delim = ",";
621 my $size = 32771 - 4;
622 my $str = '';
623
624 # Create some random junk. Inefficient, but it works.
625 for (my $i = 0; $i < $size; $ i++) {
626 $str .= $chars [rand @chars];
627 }
628
629 $str .= ($delim x 4);
630 my $res;
631 my $matched;
a86da477
NC
632 ok($str =~ s/^(.*?)${delim}{4}//s, "Pattern matches; Bug 39583");
633 is($str, "", "Empty string; Bug 39583");
634 ok(defined $1 && length ($1) == $size, '$1 is correct size; Bug 39583');
e425a60b
YO
635 }
636
e425a60b 637 {
a86da477
NC
638 like("\0-A", qr/\c@-A/, '@- should not be interpolated in a pattern; Bug 27940');
639 like("\0\0A", qr/\c@+A/, '@+ should not be interpolated in a pattern; Bug 27940');
640 like("X\@-A", qr/X@-A/, '@- should not be interpolated in a pattern; Bug 27940');
641 like("X\@\@A", qr/X@+A/, '@+ should not be interpolated in a pattern; Bug 27940');
e425a60b 642
a86da477
NC
643 like("X\0A", qr/X\c@?A/, '\c@?; Bug 27940');
644 like("X\0A", qr/X\c@*A/, '\c@*; Bug 27940');
645 like("X\0A", qr/X\c@(A)/, '\c@(; Bug 27940');
646 like("X\0A", qr/X(\c@)A/, '\c@); Bug 27940');
647 like("X\0A", qr/X\c@|ZA/, '\c@|; Bug 27940');
648
649 like("X\@A", qr/X@?A/, '@?; Bug 27940');
650 like("X\@A", qr/X@*A/, '@*; Bug 27940');
651 like("X\@A", qr/X@(A)/, '@(; Bug 27940');
652 like("X\@A", qr/X(@)A/, '@); Bug 27940');
653 like("X\@A", qr/X@|ZA/, '@|; Bug 27940');
e425a60b
YO
654
655 local $" = ','; # non-whitespace and non-RE-specific
a86da477
NC
656 like('abc', qr/(.)(.)(.)/, 'The last successful match is bogus; Bug 27940');
657 like("A@+B", qr/A@{+}B/, 'Interpolation of @+ in /@{+}/; Bug 27940');
658 like("A@-B", qr/A@{-}B/, 'Interpolation of @- in /@{-}/; Bug 27940');
659 like("A@+B", qr/A@{+}B/x, 'Interpolation of @+ in /@{+}/x; Bug 27940');
660 like("A@-B", qr/A@{-}B/x, 'Interpolation of @- in /@{-}/x; Bug 27940');
e425a60b
YO
661 }
662
e425a60b 663 {
e425a60b
YO
664 my $s = 'foo bar baz';
665 my (@k, @v, @fetch, $res);
666 my $count = 0;
667 my @names = qw ($+{A} $+{B} $+{C});
668 if ($s =~ /(?<A>foo)\s+(?<B>bar)?\s+(?<C>baz)/) {
669 while (my ($k, $v) = each (%+)) {
670 $count++;
671 }
672 @k = sort keys (%+);
673 @v = sort values (%+);
674 $res = 1;
675 push @fetch,
676 ["$+{A}", "$1"],
677 ["$+{B}", "$2"],
678 ["$+{C}", "$3"],
679 ;
680 }
681 foreach (0 .. 2) {
682 if ($fetch [$_]) {
a86da477 683 is($fetch[$_][0], $fetch[$_][1], "$names[$_]; Bug 50496");
e425a60b
YO
684 } else {
685 ok 0, $names[$_];
686 }
687 }
a86da477
NC
688 is($res, 1, "'$s' =~ /(?<A>foo)\\s+(?<B>bar)?\\s+(?<C>baz)/; Bug 50496");
689 is($count, 3, "Got 3 keys in %+ via each; Bug 50496");
690 is(0 + @k, 3, "Got 3 keys in %+ via keys; Bug 50496");
691 is("@k", "A B C", "Got expected keys; Bug 50496");
692 is("@v", "bar baz foo", "Got expected values; Bug 50496");
e425a60b
YO
693 eval '
694 no warnings "uninitialized";
695 print for $+ {this_key_doesnt_exist};
696 ';
a86da477 697 is($@, '', 'lvalue $+ {...} should not throw an exception; Bug 50496');
e425a60b
YO
698 }
699
e425a60b
YO
700 {
701 #
702 # Almost the same as the block above, except that the capture is nested.
703 #
a86da477 704
e425a60b
YO
705 my $s = 'foo bar baz';
706 my (@k, @v, @fetch, $res);
707 my $count = 0;
708 my @names = qw ($+{A} $+{B} $+{C} $+{D});
709 if ($s =~ /(?<D>(?<A>foo)\s+(?<B>bar)?\s+(?<C>baz))/) {
710 while (my ($k,$v) = each(%+)) {
711 $count++;
712 }
713 @k = sort keys (%+);
714 @v = sort values (%+);
715 $res = 1;
716 push @fetch,
717 ["$+{A}", "$2"],
718 ["$+{B}", "$3"],
719 ["$+{C}", "$4"],
720 ["$+{D}", "$1"],
721 ;
722 }
723 foreach (0 .. 3) {
724 if ($fetch [$_]) {
a86da477 725 is($fetch[$_][0], $fetch[$_][1], "$names[$_]; Bug 50496");
e425a60b
YO
726 } else {
727 ok 0, $names [$_];
728 }
729 }
a86da477
NC
730 is($res, 1, "'$s' =~ /(?<D>(?<A>foo)\\s+(?<B>bar)?\\s+(?<C>baz))/; Bug 50496");
731 is($count, 4, "Got 4 keys in %+ via each; Bug 50496");
732 is(@k, 4, "Got 4 keys in %+ via keys; Bug 50496");
733 is("@k", "A B C D", "Got expected keys; Bug 50496");
734 is("@v", "bar baz foo foo bar baz", "Got expected values; Bug 50496");
e425a60b
YO
735 eval '
736 no warnings "uninitialized";
737 print for $+ {this_key_doesnt_exist};
738 ';
a86da477 739 is($@, '', 'lvalue $+ {...} should not throw an exception; Bug 50496');
e425a60b
YO
740 }
741
e425a60b 742 {
e425a60b
YO
743 my $str = 'abc';
744 my $count = 0;
745 my $mval = 0;
746 my $pval = 0;
747 while ($str =~ /b/g) {$mval = $#-; $pval = $#+; $count ++}
a86da477
NC
748 is($mval, 0, '@- should be empty; Bug 36046');
749 is($pval, 0, '@+ should be empty; Bug 36046');
750 is($count, 1, 'Should have matched once only; Bug 36046');
e425a60b
YO
751 }
752
e425a60b 753 {
a86da477 754 my $message = '/m in precompiled regexp; Bug 40684';
e425a60b
YO
755 my $s = "abc\ndef";
756 my $rex = qr'^abc$'m;
51b6c6b3
NC
757 ok($s =~ m/$rex/, $message);
758 ok($s =~ m/^abc$/m, $message);
e425a60b
YO
759 }
760
e425a60b 761 {
a86da477 762 my $message = '(?: ... )? should not lose $^R; Bug 36909';
e425a60b
YO
763 $^R = 'Nothing';
764 {
765 local $^R = "Bad";
51b6c6b3 766 ok('x foofoo y' =~ m {
e425a60b
YO
767 (foo) # $^R correctly set
768 (?{ "last regexp code result" })
51b6c6b3
NC
769 }x, $message);
770 is($^R, 'last regexp code result', $message);
e425a60b 771 }
51b6c6b3 772 is($^R, 'Nothing', $message);
e425a60b
YO
773
774 {
775 local $^R = "Bad";
776
51b6c6b3 777 ok('x foofoo y' =~ m {
e425a60b
YO
778 (?:foo|bar)+ # $^R correctly set
779 (?{ "last regexp code result" })
51b6c6b3
NC
780 }x, $message);
781 is($^R, 'last regexp code result', $message);
e425a60b 782 }
51b6c6b3 783 is($^R, 'Nothing', $message);
e425a60b
YO
784
785 {
786 local $^R = "Bad";
51b6c6b3 787 ok('x foofoo y' =~ m {
e425a60b
YO
788 (foo|bar)\1+ # $^R undefined
789 (?{ "last regexp code result" })
51b6c6b3
NC
790 }x, $message);
791 is($^R, 'last regexp code result', $message);
e425a60b 792 }
51b6c6b3 793 is($^R, 'Nothing', $message);
e425a60b
YO
794
795 {
796 local $^R = "Bad";
51b6c6b3 797 ok('x foofoo y' =~ m {
e425a60b
YO
798 (foo|bar)\1 # This time without the +
799 (?{"last regexp code result"})
51b6c6b3
NC
800 }x, $message);
801 is($^R, 'last regexp code result', $message);
e425a60b 802 }
51b6c6b3 803 is($^R, 'Nothing', $message);
e425a60b
YO
804 }
805
e425a60b 806 {
a86da477 807 my $message = 'Match is linear, not quadratic; Bug 22395';
e425a60b
YO
808 our $count;
809 for my $l (10, 100, 1000) {
810 $count = 0;
811 ('a' x $l) =~ /(.*)(?{$count++})[bc]/;
04934b6d 812 local $::TODO = "Should be L+1 not L*(L+3)/2 (L=$l)";
51b6c6b3 813 is($count, $l + 1, $message);
e425a60b
YO
814 }
815 }
816
e425a60b 817 {
a86da477 818 my $message = '@-/@+ should not have undefined values; Bug 22614';
e425a60b
YO
819 local $_ = 'ab';
820 our @len = ();
821 /(.){1,}(?{push @len,0+@-})(.){1,}(?{})^/;
51b6c6b3 822 is("@len", "2 2 2", $message);
e425a60b
YO
823 }
824
e425a60b 825 {
a86da477 826 my $message = '$& set on s///; Bug 18209';
e425a60b
YO
827 my $text = ' word1 word2 word3 word4 word5 word6 ';
828
829 my @words = ('word1', 'word3', 'word5');
830 my $count;
831 foreach my $word (@words) {
93f09d7b 832 $text =~ s/$word\s//gi; # Leave a space to separate words
e425a60b
YO
833 # in the resultant str.
834 # The following block is not working.
835 if ($&) {
836 $count ++;
837 }
838 # End bad block
839 }
51b6c6b3
NC
840 is($count, 3, $message);
841 is($text, ' word2 word4 word6 ', $message);
e425a60b
YO
842 }
843
e425a60b
YO
844 {
845 # RT#6893
a86da477 846
e425a60b
YO
847 local $_ = qq (A\nB\nC\n);
848 my @res;
849 while (m#(\G|\n)([^\n]*)\n#gsx) {
850 push @res, "$2";
851 last if @res > 3;
852 }
de26e0cc 853 is("@res", "A B C", "/g pattern shouldn't infinite loop; Bug 6893");
e425a60b
YO
854 }
855
e425a60b 856 {
51b6c6b3 857 # No optimizer bug
e425a60b
YO
858 my @tails = ('', '(?(1))', '(|)', '()?');
859 my @quants = ('*','+');
860 my $doit = sub {
861 my $pats = shift;
862 for (@_) {
863 for my $pat (@$pats) {
864 for my $quant (@quants) {
865 for my $tail (@tails) {
866 my $re = "($pat$quant\$)$tail";
a86da477
NC
867 ok(/$re/ && $1 eq $_, "'$_' =~ /$re/; Bug 41010");
868 ok(/$re/m && $1 eq $_, "'$_' =~ /$re/m; Bug 41010");
e425a60b
YO
869 }
870 }
871 }
872 }
873 };
874
875 my @dpats = ('\d',
876 '[1234567890]',
877 '(1|[23]|4|[56]|[78]|[90])',
878 '(?:1|[23]|4|[56]|[78]|[90])',
879 '(1|2|3|4|5|6|7|8|9|0)',
880 '(?:1|2|3|4|5|6|7|8|9|0)');
881 my @spats = ('[ ]', ' ', '( |\t)', '(?: |\t)', '[ \t]', '\s');
882 my @sstrs = (' ');
883 my @dstrs = ('12345');
884 $doit -> (\@spats, @sstrs);
885 $doit -> (\@dpats, @dstrs);
886 }
887
e425a60b 888 {
e425a60b
YO
889 # [perl #45605] Regexp failure with utf8-flagged and byte-flagged string
890
891 my $utf_8 = "\xd6schel";
892 utf8::upgrade ($utf_8);
893 $utf_8 =~ m {(\xd6|&Ouml;)schel};
a86da477 894 is($1, "\xd6", "Upgrade error; Bug 45605");
e425a60b
YO
895 }
896
897 {
e425a60b
YO
898 # Regardless of utf8ness any character matches itself when
899 # doing a case insensitive match. See also [perl #36207]
a86da477 900
e425a60b
YO
901 for my $o (0 .. 255) {
902 my @ch = (chr ($o), chr ($o));
903 utf8::upgrade ($ch [1]);
904 for my $u_str (0, 1) {
905 for my $u_pat (0, 1) {
a86da477
NC
906 like($ch[$u_str], qr/\Q$ch[$u_pat]\E/i,
907 "\$c =~ /\$c/i : chr ($o) : u_str = $u_str u_pat = $u_pat; Bug 36207");
908 like($ch[$u_str], qr/\Q$ch[$u_pat]\E|xyz/i,
909 "\$c=~/\$c|xyz/i : chr($o) : u_str = $u_str u_pat = $u_pat; Bug 36207");
e425a60b
YO
910 }
911 }
912 }
913 }
914
e425a60b 915 {
a86da477 916 my $message = '$REGMARK in replacement; Bug 49190';
e425a60b 917 our $REGMARK;
dcd695b6 918 no warnings 'experimental::lexical_topic';
e425a60b 919 my $_ = "A";
51b6c6b3
NC
920 ok(s/(*:B)A/$REGMARK/, $message);
921 is($_, "B", $message);
e425a60b 922 $_ = "CCCCBAA";
51b6c6b3
NC
923 ok(s/(*:X)A+|(*:Y)B+|(*:Z)C+/$REGMARK/g, $message);
924 is($_, "ZYX", $message);
1754320d
FC
925 # Use a longer name to force reallocation of $REGMARK.
926 $_ = "CCCCBAA";
927 ok(s/(*:X)A+|(*:YYYYYYYYYYYYYYYY)B+|(*:Z)C+/$REGMARK/g, $message);
928 is($_, "ZYYYYYYYYYYYYYYYYX", $message);
e425a60b
YO
929 }
930
e425a60b 931 {
a86da477 932 my $message = 'Substitution evaluation in list context; Bug 52658';
e425a60b
YO
933 my $reg = '../xxx/';
934 my @te = ($reg =~ m{^(/?(?:\.\./)*)},
935 $reg =~ s/(x)/'b'/eg > 1 ? '##' : '++');
51b6c6b3
NC
936 is($reg, '../bbb/', $message);
937 is($te [0], '../', $message);
e425a60b
YO
938 }
939
e425a60b 940 {
e425a60b 941 my $a = "xyzt" x 8192;
a86da477
NC
942 like($a, qr/\A(?>[a-z])*\z/,
943 '(?>) does not cause wrongness on long string; Bug 60034');
e425a60b
YO
944 my $b = $a . chr 256;
945 chop $b;
4b0d13b9 946 is($a, $b, 'Bug 60034');
a86da477
NC
947 like($b, qr/\A(?>[a-z])*\z/,
948 '(?>) does not cause wrongness on long string with UTF-8; Bug 60034');
e425a60b
YO
949 }
950
e425a60b
YO
951 #
952 # Keep the following tests last -- they may crash perl
953 #
954 print "# Tests that follow may crash perl\n";
955 {
a86da477 956
51b6c6b3 957 my $message = 'Pattern in a loop, failure should not ' .
a86da477 958 'affect previous success; Bug 19049/38869';
e425a60b
YO
959 my @list = (
960 'ab cdef', # Matches regex
961 ('e' x 40000 ) .'ab c' # Matches not, but 'ab c' matches part of it
962 );
963 my $y;
964 my $x;
965 foreach (@list) {
966 m/ab(.+)cd/i; # The ignore-case seems to be important
967 $y = $1; # Use $1, which might not be from the last match!
968 $x = substr ($list [0], $- [0], $+ [0] - $- [0]);
969 }
51b6c6b3
NC
970 is($y, ' ', $message);
971 is($x, 'ab cd', $message);
e425a60b
YO
972 }
973
e425a60b 974 {
a86da477 975 ok (("a" x (2 ** 15 - 10)) =~ /^()(a|bb)*$/, "Recursive stack cracker; Bug 24274");
e425a60b 976 ok ((q(a)x 100) =~ /^(??{'(.)'x 100})/,
a86da477 977 "Regexp /^(??{'(.)'x 100})/ crashes older perls; Bug 24274");
e425a60b
YO
978 }
979
e425a60b 980 {
e425a60b 981 # [perl #45337] utf8 + "[a]a{2}" + /$.../ = panic: sv_len_utf8 cache
a86da477 982
e425a60b 983 local ${^UTF8CACHE} = -1;
a86da477 984 my $message = "Shouldn't panic; Bug 45337";
e425a60b
YO
985 my $s = "[a]a{2}";
986 utf8::upgrade $s;
51b6c6b3 987 like("aaa", qr/$s/, $message);
e425a60b
YO
988 }
989 {
a86da477 990 my $message = "Check if tree logic breaks \$^R; Bug 57042";
e425a60b
YO
991 my $cond_re = qr/\s*
992 \s* (?:
993 \( \s* A (?{1})
994 | \( \s* B (?{2})
995 )
996 /x;
997 my @res;
998 for my $line ("(A)","(B)") {
999 if ($line =~ m/$cond_re/) {
1000 push @res, $^R ? "#$^R" : "UNDEF";
1001 }
1002 }
51b6c6b3 1003 is("@res","#1 #2", $message);
e425a60b
YO
1004 }
1005 {
1006 no warnings 'closure';
1007 my $re = qr/A(??{"1"})/;
1008 ok "A1B" =~ m/^((??{ $re }))((??{"B"}))$/;
1009 ok $1 eq "A1";
1010 ok $2 eq "B";
1011 }
1012
e425a60b
YO
1013 # This only works under -DEBUGGING because it relies on an assert().
1014 {
51b6c6b3 1015 # Check capture offset re-entrancy of utf8 code.
e425a60b
YO
1016
1017 sub fswash { $_[0] =~ s/([>X])//g; }
1018
1019 my $k1 = "." x 4 . ">>";
1020 fswash($k1);
1021
1022 my $k2 = "\x{f1}\x{2022}";
1023 $k2 =~ s/([\360-\362])/>/g;
1024 fswash($k2);
1025
a86da477 1026 is($k2, "\x{2022}", "utf8::SWASHNEW doesn't cause capture leaks; Bug 60508");
e425a60b
YO
1027 }
1028
e425a60b 1029 {
a86da477 1030 # minimal CURLYM limited to 32767 matches
e425a60b
YO
1031 my @pat = (
1032 qr{a(x|y)*b}, # CURLYM
1033 qr{a(x|y)*?b}, # .. with minmod
1034 qr{a([wx]|[yz])*b}, # .. and without tries
1035 qr{a([wx]|[yz])*?b},
1036 );
1037 my $len = 32768;
1038 my $s = join '', 'a', 'x' x $len, 'b';
1039 for my $pat (@pat) {
a86da477 1040 like($s, $pat, "$pat; Bug 65372");
e425a60b
YO
1041 }
1042 }
b4da7bae
BR
1043
1044 {
04934b6d 1045 local $::TODO = "[perl #38133]";
b4da7bae
BR
1046
1047 "A" =~ /(((?:A))?)+/;
1048 my $first = $2;
1049
1050 "A" =~ /(((A))?)+/;
1051 my $second = $2;
1052
de26e0cc 1053 is($first, $second);
b4da7bae 1054 }
aca53033
FC
1055
1056 {
51b6c6b3 1057 my $message
a86da477 1058 = 'utf8 =~ /trie/ where trie matches a continuation octet; Bug 70998';
aca53033
FC
1059
1060 # Catch warnings:
1061 my $w;
1062 local $SIG{__WARN__} = sub { $w .= shift };
1063
1064 # This bug can be reduced to
1065 qq{\x{30ab}} =~ /\xab|\xa9/;
1066 # but it's nice to have a more 'real-world' test. The original test
1067 # case from the RT ticket follows:
1068
1069 my %conv = (
1070 "\xab" => "&lt;",
1071 "\xa9" => "(c)",
1072 );
1073 my $conv_rx = '(' . join('|', map { quotemeta } keys %conv) . ')';
1074 $conv_rx = qr{$conv_rx};
1075
1076 my $x
1077 = qq{\x{3042}\x{304b}\x{3055}\x{305f}\x{306a}\x{306f}\x{307e}}
1078 . qq{\x{3084}\x{3089}\x{308f}\x{3093}\x{3042}\x{304b}\x{3055}}
1079 . qq{\x{305f}\x{306a}\x{306f}\x{307e}\x{3084}\x{3089}\x{308f}}
1080 . qq{\x{3093}\x{30a2}\x{30ab}\x{30b5}\x{30bf}\x{30ca}\x{30cf}}
1081 . qq{\x{30de}\x{30e4}\x{30e9}\x{30ef}\x{30f3}\x{30a2}\x{30ab}}
1082 . qq{\x{30b5}\x{30bf}\x{30ca}\x{30cf}\x{30de}\x{30e4}\x{30e9}}
1083 . qq{\x{30ef}\x{30f3}\x{30a2}\x{30ab}\x{30b5}\x{30bf}\x{30ca}}
1084 . qq{\x{30cf}\x{30de}\x{30e4}\x{30e9}\x{30ef}\x{30f3}};
1085
1086 $x =~ s{$conv_rx}{$conv{$1}}eg;
1087
51b6c6b3 1088 is($w, undef, $message);
aca53033
FC
1089 }
1090
e7f38d0f 1091 {
a86da477 1092 # minimal CURLYM limited to 32767 matches
51b6c6b3
NC
1093
1094 is(join("-", " abc def " =~ /(?=(\S+))/g), "abc-bc-c-def-ef-f",
a86da477 1095 'stclass optimisation does not break + inside (?=); Bug 68564');
e7f38d0f
YO
1096 }
1097
5c0a530f
NC
1098 {
1099 use charnames ":full";
1100 # Delayed interpolation of \N'
1101 my $r1 = qr/\N{THAI CHARACTER SARA I}/;
1102 my $s1 = "\x{E34}\x{E34}\x{E34}\x{E34}";
1103
1104 # Bug #56444
1105 ok $s1 =~ /$r1+/, 'my $r1 = qr/\N{THAI CHARACTER SARA I}/; my $s1 = "\x{E34}\x{E34}\x{E34}\x{E34}; $s1 =~ /$r1+/';
1106
1107 # Bug #62056
1108 ok "${s1}A" =~ m/$s1\N{LATIN CAPITAL LETTER A}/, '"${s1}A" =~ m/$s1\N{LATIN CAPITAL LETTER A}/';
1109
1110 ok "abbbbc" =~ m/\N{1}/ && $& eq "a", '"abbbbc" =~ m/\N{1}/ && $& eq "a"';
1111 ok "abbbbc" =~ m/\N{3,4}/ && $& eq "abbb", '"abbbbc" =~ m/\N{3,4}/ && $& eq "abbb"';
1112 }
1113
1114 {
1115 use charnames ":full";
1116 my $message = '[perl #74982] Period coming after \N{}';
1117 ok("\x{ff08}." =~ m/\N{FULLWIDTH LEFT PARENTHESIS}./ && $& eq "\x{ff08}.", $message);
1118 ok("\x{ff08}." =~ m/[\N{FULLWIDTH LEFT PARENTHESIS}]./ && $& eq "\x{ff08}.", $message);
1119 }
1120
453466ce
NC
1121SKIP: {
1122 ######## "Segfault using HTML::Entities", Richard Jolly <richardjolly@mac.com>, <A3C7D27E-C9F4-11D8-B294-003065AE00B6@mac.com> in perl-unicode@perl.org
1123
1124 skip('Perl configured without Encode module', 1)
1125 unless $Config{extensions} =~ / Encode /;
1126
1127 # Test case cut down by jhi
1128 fresh_perl_like(<<'EOP', qr!Malformed UTF-8 character \(unexpected end of string\) in substitution \(s///\) at!, 'Segfault using HTML::Entities');
1129use Encode;
1130my $t = ord('A') == 193 ? "\xEA" : "\xE9";
1131Encode::_utf8_on($t);
1132$t =~ s/([^a])//ge;
1133EOP
1134 }
1135
e6351b37
YO
1136 {
1137 # pattern must be compiled late or we can break the test file
1138 my $message = '[perl #115050] repeated nothings in a trie can cause panic';
1139 my $pattern;
1140 $pattern = '[xyz]|||';
1141 ok("blah blah" =~ /$pattern/, $message);
1142 ok("blah blah" =~ /(?:$pattern)h/, $message);
1143 $pattern = '|||[xyz]';
1144 ok("blah blah" =~ /$pattern/, $message);
1145 ok("blah blah" =~ /(?:$pattern)h/, $message);
1146 }
00f6437b
FC
1147
1148 {
1149 # [perl #4289] First mention $& after a match
1150 fresh_perl_is(
1151 '$_ = "abc"; /b/g; $_ = "hello"; print eval q|$&|, "\n"',
1152 "b\n", {}, '$& first mentioned after match');
1153 fresh_perl_is(
1154 '$_ = "abc"; /b/g; $_ = "hello"; print eval q|$`|, "\n"',
1155 "a\n", {}, '$` first mentioned after match');
1156 fresh_perl_is(
1157 '$_ = "abc"; /b/g; $_ = "hello"; print eval q|$\'|,"\n"',
1158 "c\n", {}, '$\' first mentioned after match');
1159 }
0430522f
TC
1160
1161 {
1162 # [perl #118175] threaded perl-5.18.0 fails pat_rt_report_thr.t
1163 # this tests some related failures
1164 #
1165 # The tests in the block *only* fail when run on 32-bit systems
1166 # with a malloc that allocates above the 2GB line. On the system
1167 # in the report above that only happened in a thread.
1168 my $s = "\x{1ff}" . "f" x 32;
1169 ok($s =~ /\x{1ff}[[:alpha:]]+/gca, "POSIXA pointer wrap");
9597860a
TC
1170
1171 # this one segfaulted under the conditions above
1172 # of course, CANY is evil, maybe it should crash
1173 ok($s =~ /.\C+/, "CANY pointer wrap");
0430522f 1174 }
e425a60b
YO
1175} # End of sub run_tests
1176
11771;