This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #127635] s///r with -DPERL_NO_COW attempts to modify source SV
[perl5.git] / t / re / subst.t
CommitLineData
25aae3a7 1#!./perl -w
d9d8d8de 2
a1a0e61e
TD
3BEGIN {
4 chdir 't' if -d 't';
86e69b18 5 require './test.pl';
43ece5b1 6 set_up_inc('../lib');
9555cc07 7 require Config; import Config;
d13a5d3b
TC
8 require constant;
9 constant->import(constcow => *Config::{NAME});
c8519dc7 10 require './charset_tools.pl';
1ec7020c 11 require './loc_tools.pl';
a1a0e61e 12}
344462d3 13
d13a5d3b 14plan( tests => 270 );
4f4d7508 15
4f4d7508
DC
16$_ = 'david';
17$a = s/david/rules/r;
18ok( $_ eq 'david' && $a eq 'rules', 'non-destructive substitute' );
19
20$a = "david" =~ s/david/rules/r;
21ok( $a eq 'rules', 's///r with constant' );
22
d13a5d3b
TC
23#[perl #127635] failed with -DPERL_NO_COW perl build (George smoker uses flag)
24#Modification of a read-only value attempted at ../t/re/subst.t line 23.
25$a = constcow =~ s/Config/David/r;
26ok( $a eq 'David::', 's///r with COW constant' );
27
4f4d7508
DC
28$a = "david" =~ s/david/"is"."great"/er;
29ok( $a eq 'isgreat', 's///er' );
30
31$a = "daviddavid" =~ s/david/cool/gr;
32ok( $a eq 'coolcool', 's///gr' );
33
34$a = 'david';
35$b = $a =~ s/david/sucks/r =~ s/sucks/rules/r;
36ok( $a eq 'david' && $b eq 'rules', 'chained s///r' );
37
38$a = 'david';
39$b = $a =~ s/xxx/sucks/r;
40ok( $a eq 'david' && $b eq 'david', 'non matching s///r' );
41
42$a = 'david';
43for (0..2) {
44 ok( 'david' =~ s/$a/rules/ro eq 'rules', 's///ro '.$_ );
45}
46
47$a = 'david';
48eval '$b = $a !~ s/david/is great/r';
49like( $@, qr{Using !~ with s///r doesn't make sense}, 's///r !~ operator gives error' );
50
51{
52 no warnings 'uninitialized';
53 $a = undef;
54 $b = $a =~ s/left/right/r;
55 ok ( !defined $a && !defined $b, 's///r with undef input' );
56
57 use warnings;
4d18b353
NC
58 warning_like(sub { $b = $a =~ s/left/right/r },
59 qr/^Use of uninitialized value/,
60 's///r Uninitialized warning');
4f4d7508
DC
61
62 $a = 'david';
4d18b353
NC
63 warning_like(sub {eval 's/david/sucks/r; 1'},
64 qr/^Useless use of non-destructive substitution/,
65 's///r void context warning');
4f4d7508
DC
66}
67
68$a = '';
69$b = $a =~ s/david/rules/r;
70ok( $a eq '' && $b eq '', 's///r on empty string' );
71
72$_ = 'david';
73@b = s/david/rules/r;
74ok( $_ eq 'david' && $b[0] eq 'rules', 's///r in list context' );
75
76# Magic value and s///r
77require Tie::Scalar;
78tie $m, 'Tie::StdScalar'; # makes $a magical
79$m = "david";
80$b = $m =~ s/david/rules/r;
81ok( $m eq 'david' && $b eq 'rules', 's///r with magic input' );
82
83$m = $b =~ s/rules/david/r;
84ok( defined tied($m), 's///r magic isn\'t lost' );
85
86$b = $m =~ s/xxx/yyy/r;
87ok( ! defined tied($b), 's///r magic isn\'t contagious' );
d9d8d8de 88
4eedab49
FC
89my $ref = \("aaa" =~ s/aaa/bbb/r);
90is (Internals::SvREFCNT($$ref), 1, 's///r does not leak');
91$ref = \("aaa" =~ s/aaa/bbb/rg);
92is (Internals::SvREFCNT($$ref), 1, 's///rg does not leak');
93
d9d8d8de
LW
94$x = 'foo';
95$_ = "x";
96s/x/\$x/;
e8ebd21b 97ok( $_ eq '$x', ":$_: eq :\$x:" );
d9d8d8de
LW
98
99$_ = "x";
100s/x/$x/;
e8ebd21b 101ok( $_ eq 'foo', ":$_: eq :foo:" );
d9d8d8de
LW
102
103$_ = "x";
104s/x/\$x $x/;
e8ebd21b 105ok( $_ eq '$x foo', ":$_: eq :\$x foo:" );
d9d8d8de
LW
106
107$b = 'cd';
79072805 108($a = 'abcdef') =~ s<(b${b}e)>'\n$1';
e8ebd21b 109ok( $1 eq 'bcde' && $a eq 'a\n$1f', ":$1: eq :bcde: ; :$a: eq :a\\n\$1f:" );
d9d8d8de
LW
110
111$a = 'abacada';
e8ebd21b 112ok( ($a =~ s/a/x/g) == 4 && $a eq 'xbxcxdx' );
d9d8d8de 113
e8ebd21b 114ok( ($a =~ s/a/y/g) == 0 && $a eq 'xbxcxdx' );
d9d8d8de 115
e8ebd21b 116ok( ($a =~ s/b/y/g) == 1 && $a eq 'xyxcxdx' );
d9d8d8de
LW
117
118$_ = 'ABACADA';
e8ebd21b 119ok( /a/i && s///gi && $_ eq 'BCD' );
d9d8d8de
LW
120
121$_ = '\\' x 4;
e8ebd21b
RGS
122ok( length($_) == 4 );
123$snum = s/\\/\\\\/g;
124ok( $_ eq '\\' x 8 && $snum == 4 );
d9d8d8de
LW
125
126$_ = '\/' x 4;
e8ebd21b
RGS
127ok( length($_) == 8 );
128$snum = s/\//\/\//g;
129ok( $_ eq '\\//' x 4 && $snum == 4 );
130ok( length($_) == 12 );
d9d8d8de
LW
131
132$_ = 'aaaXXXXbbb';
133s/^a//;
e8ebd21b 134ok( $_ eq 'aaXXXXbbb' );
d9d8d8de
LW
135
136$_ = 'aaaXXXXbbb';
137s/a//;
e8ebd21b 138ok( $_ eq 'aaXXXXbbb' );
d9d8d8de
LW
139
140$_ = 'aaaXXXXbbb';
141s/^a/b/;
e8ebd21b 142ok( $_ eq 'baaXXXXbbb' );
d9d8d8de
LW
143
144$_ = 'aaaXXXXbbb';
145s/a/b/;
e8ebd21b 146ok( $_ eq 'baaXXXXbbb' );
d9d8d8de
LW
147
148$_ = 'aaaXXXXbbb';
149s/aa//;
e8ebd21b 150ok( $_ eq 'aXXXXbbb' );
d9d8d8de
LW
151
152$_ = 'aaaXXXXbbb';
153s/aa/b/;
e8ebd21b 154ok( $_ eq 'baXXXXbbb' );
d9d8d8de
LW
155
156$_ = 'aaaXXXXbbb';
157s/b$//;
e8ebd21b 158ok( $_ eq 'aaaXXXXbb' );
d9d8d8de
LW
159
160$_ = 'aaaXXXXbbb';
161s/b//;
e8ebd21b 162ok( $_ eq 'aaaXXXXbb' );
d9d8d8de
LW
163
164$_ = 'aaaXXXXbbb';
165s/bb//;
e8ebd21b 166ok( $_ eq 'aaaXXXXb' );
d9d8d8de
LW
167
168$_ = 'aaaXXXXbbb';
169s/aX/y/;
e8ebd21b 170ok( $_ eq 'aayXXXbbb' );
d9d8d8de
LW
171
172$_ = 'aaaXXXXbbb';
173s/Xb/z/;
e8ebd21b 174ok( $_ eq 'aaaXXXzbb' );
d9d8d8de
LW
175
176$_ = 'aaaXXXXbbb';
177s/aaX.*Xbb//;
e8ebd21b 178ok( $_ eq 'ab' );
d9d8d8de
LW
179
180$_ = 'aaaXXXXbbb';
181s/bb/x/;
e8ebd21b 182ok( $_ eq 'aaaXXXXxb' );
d9d8d8de
LW
183
184# now for some unoptimized versions of the same.
185
186$_ = 'aaaXXXXbbb';
187$x ne $x || s/^a//;
e8ebd21b 188ok( $_ eq 'aaXXXXbbb' );
d9d8d8de
LW
189
190$_ = 'aaaXXXXbbb';
191$x ne $x || s/a//;
e8ebd21b 192ok( $_ eq 'aaXXXXbbb' );
d9d8d8de
LW
193
194$_ = 'aaaXXXXbbb';
195$x ne $x || s/^a/b/;
e8ebd21b 196ok( $_ eq 'baaXXXXbbb' );
d9d8d8de
LW
197
198$_ = 'aaaXXXXbbb';
199$x ne $x || s/a/b/;
e8ebd21b 200ok( $_ eq 'baaXXXXbbb' );
d9d8d8de
LW
201
202$_ = 'aaaXXXXbbb';
203$x ne $x || s/aa//;
e8ebd21b 204ok( $_ eq 'aXXXXbbb' );
d9d8d8de
LW
205
206$_ = 'aaaXXXXbbb';
207$x ne $x || s/aa/b/;
e8ebd21b 208ok( $_ eq 'baXXXXbbb' );
d9d8d8de
LW
209
210$_ = 'aaaXXXXbbb';
211$x ne $x || s/b$//;
e8ebd21b 212ok( $_ eq 'aaaXXXXbb' );
d9d8d8de
LW
213
214$_ = 'aaaXXXXbbb';
215$x ne $x || s/b//;
e8ebd21b 216ok( $_ eq 'aaaXXXXbb' );
d9d8d8de
LW
217
218$_ = 'aaaXXXXbbb';
219$x ne $x || s/bb//;
e8ebd21b 220ok( $_ eq 'aaaXXXXb' );
d9d8d8de
LW
221
222$_ = 'aaaXXXXbbb';
223$x ne $x || s/aX/y/;
e8ebd21b 224ok( $_ eq 'aayXXXbbb' );
d9d8d8de
LW
225
226$_ = 'aaaXXXXbbb';
227$x ne $x || s/Xb/z/;
e8ebd21b 228ok( $_ eq 'aaaXXXzbb' );
d9d8d8de
LW
229
230$_ = 'aaaXXXXbbb';
231$x ne $x || s/aaX.*Xbb//;
e8ebd21b 232ok( $_ eq 'ab' );
d9d8d8de
LW
233
234$_ = 'aaaXXXXbbb';
235$x ne $x || s/bb/x/;
e8ebd21b 236ok( $_ eq 'aaaXXXXxb' );
d9d8d8de
LW
237
238$_ = 'abc123xyz';
c277df42 239s/(\d+)/$1*2/e; # yields 'abc246xyz'
e8ebd21b 240ok( $_ eq 'abc246xyz' );
c277df42 241s/(\d+)/sprintf("%5d",$1)/e; # yields 'abc 246xyz'
e8ebd21b 242ok( $_ eq 'abc 246xyz' );
c277df42 243s/(\w)/$1 x 2/eg; # yields 'aabbcc 224466xxyyzz'
e8ebd21b 244ok( $_ eq 'aabbcc 224466xxyyzz' );
d9d8d8de
LW
245
246$_ = "aaaaa";
e8ebd21b
RGS
247ok( y/a/b/ == 5 );
248ok( y/a/b/ == 0 );
249ok( y/b// == 5 );
250ok( y/b/c/s == 5 );
251ok( y/c// == 1 );
252ok( y/c//d == 1 );
253ok( $_ eq "" );
d9d8d8de
LW
254
255$_ = "Now is the %#*! time for all good men...";
e8ebd21b
RGS
256ok( ($x=(y/a-zA-Z //cd)) == 7 );
257ok( y/ / /s == 8 );
d9d8d8de 258
79072805
LW
259$_ = 'abcdefghijklmnopqrstuvwxyz0123456789';
260tr/a-z/A-Z/;
261
e8ebd21b 262ok( $_ eq 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789' );
79072805
LW
263
264# same as tr/A-Z/a-z/;
e8ebd21b 265if (defined $Config{ebcdic} && $Config{ebcdic} eq 'define') { # EBCDIC.
6e68dac8 266 no utf8;
9d116dd7
JH
267 y[\301-\351][\201-\251];
268} else { # Ye Olde ASCII. Or something like it.
269 y[\101-\132][\141-\172];
270}
79072805 271
e8ebd21b 272ok( $_ eq 'abcdefghijklmnopqrstuvwxyz0123456789' );
79072805 273
e8ebd21b 274SKIP: {
80b35dfd
KW
275 skip("ASCII-centric test",1) unless (ord("+") == ord(",") - 1
276 && ord(",") == ord("-") - 1
277 && ord("a") == ord("b") - 1
278 && ord("b") == ord("c") - 1);
e8ebd21b
RGS
279 $_ = '+,-';
280 tr/+--/a-c/;
281 ok( $_ eq 'abc' );
9d116dd7 282}
79072805
LW
283
284$_ = '+,-';
285tr/+\--/a\/c/;
e8ebd21b 286ok( $_ eq 'a,/' );
79072805
LW
287
288$_ = '+,-';
289tr/-+,/ab\-/;
e8ebd21b 290ok( $_ eq 'b-a' );
843b4603
TB
291
292
293# test recursive substitutions
294# code based on the recursive expansion of makefile variables
295
296my %MK = (
297 AAAAA => '$(B)', B=>'$(C)', C => 'D', # long->short
298 E => '$(F)', F=>'p $(G) q', G => 'HHHHH', # short->long
299 DIR => '$(UNDEFINEDNAME)/xxx',
300);
301sub var {
302 my($var,$level) = @_;
303 return "\$($var)" unless exists $MK{$var};
304 return exp_vars($MK{$var}, $level+1); # can recurse
305}
306sub exp_vars {
307 my($str,$level) = @_;
308 $str =~ s/\$\((\w+)\)/var($1, $level+1)/ge; # can recurse
309 #warn "exp_vars $level = '$str'\n";
310 $str;
311}
312
e8ebd21b
RGS
313ok( exp_vars('$(AAAAA)',0) eq 'D' );
314ok( exp_vars('$(E)',0) eq 'p HHHHH q' );
315ok( exp_vars('$(DIR)',0) eq '$(UNDEFINEDNAME)/xxx' );
316ok( exp_vars('foo $(DIR)/yyy bar',0) eq 'foo $(UNDEFINEDNAME)/xxx/yyy bar' );
3e3baf6d
TB
317
318$_ = "abcd";
c277df42 319s/(..)/$x = $1, m#.#/eg;
e8ebd21b 320ok( $x eq "cd", 'a match nested in the RHS of a substitution' );
fb73857a 321
c277df42
IZ
322# Subst and lookbehind
323
324$_="ccccc";
e8ebd21b
RGS
325$snum = s/(?<!x)c/x/g;
326ok( $_ eq "xxxxx" && $snum == 5 );
c277df42
IZ
327
328$_="ccccc";
e8ebd21b
RGS
329$snum = s/(?<!x)(c)/x/g;
330ok( $_ eq "xxxxx" && $snum == 5 );
c277df42
IZ
331
332$_="foobbarfoobbar";
e8ebd21b
RGS
333$snum = s/(?<!r)foobbar/foobar/g;
334ok( $_ eq "foobarfoobbar" && $snum == 1 );
c277df42
IZ
335
336$_="foobbarfoobbar";
e8ebd21b
RGS
337$snum = s/(?<!ar)(foobbar)/foobar/g;
338ok( $_ eq "foobarfoobbar" && $snum == 1 );
c277df42
IZ
339
340$_="foobbarfoobbar";
e8ebd21b
RGS
341$snum = s/(?<!ar)foobbar/foobar/g;
342ok( $_ eq "foobarfoobbar" && $snum == 1 );
c277df42 343
fb73857a
PP
344eval 's{foo} # this is a comment, not a delimiter
345 {bar};';
e8ebd21b 346ok( ! @?, 'parsing of split subst with comment' );
f3ea7b5e 347
ed02a3bf
DN
348$snum = eval '$_="exactly"; s sxsys;m 3(yactl)3;$1';
349is( $snum, 'yactl', 'alpha delimiters are allowed' );
350
f3ea7b5e 351$_="baacbaa";
e8ebd21b
RGS
352$snum = tr/a/b/s;
353ok( $_ eq "bbcbb" && $snum == 4,
354 'check if squashing works at the end of string' );
f3ea7b5e 355
2216f30a 356$_ = "ab";
e8ebd21b 357ok( s/a/b/ == 1 );
ce862d02
IZ
358
359$_ = <<'EOL';
360 $url = new URI::URL "http://www/"; die if $url eq "xXx";
361EOL
362$^R = 'junk';
363
364$foo = ' $@%#lowercase $@%# lowercase UPPERCASE$@%#UPPERCASE' .
365 ' $@%#lowercase$@%#lowercase$@%# lowercase lowercase $@%#lowercase' .
366 ' lowercase $@%#MiXeD$@%# ';
367
e8ebd21b 368$snum =
ce862d02
IZ
369s{ \d+ \b [,.;]? (?{ 'digits' })
370 |
371 [a-z]+ \b [,.;]? (?{ 'lowercase' })
372 |
373 [A-Z]+ \b [,.;]? (?{ 'UPPERCASE' })
374 |
375 [A-Z] [a-z]+ \b [,.;]? (?{ 'Capitalized' })
376 |
377 [A-Za-z]+ \b [,.;]? (?{ 'MiXeD' })
378 |
379 [A-Za-z0-9]+ \b [,.;]? (?{ 'alphanumeric' })
380 |
381 \s+ (?{ ' ' })
382 |
383 [^A-Za-z0-9\s]+ (?{ '$@%#' })
384}{$^R}xg;
e8ebd21b 385ok( $_ eq $foo );
8e5e9ebe
RGS
386ok( $snum == 31 );
387
388$_ = 'a' x 6;
389$snum = s/a(?{})//g;
390ok( $_ eq '' && $snum == 6 );
ce862d02 391
2beec16e 392$_ = 'x' x 20;
e8ebd21b 393$snum = s/(\d*|x)/<$1>/g;
2beec16e 394$foo = '<>' . ('<x><>' x 20) ;
e8ebd21b 395ok( $_ eq $foo && $snum == 41 );
ad94a511
IZ
396
397$t = 'aaaaaaaaa';
398
399$_ = $t;
400pos = 6;
e8ebd21b
RGS
401$snum = s/\Ga/xx/g;
402ok( $_ eq 'aaaaaaxxxxxx' && $snum == 3 );
ad94a511
IZ
403
404$_ = $t;
405pos = 6;
e8ebd21b
RGS
406$snum = s/\Ga/x/g;
407ok( $_ eq 'aaaaaaxxx' && $snum == 3 );
ad94a511
IZ
408
409$_ = $t;
410pos = 6;
411s/\Ga/xx/;
e8ebd21b 412ok( $_ eq 'aaaaaaxxaa' );
ad94a511
IZ
413
414$_ = $t;
415pos = 6;
416s/\Ga/x/;
e8ebd21b 417ok( $_ eq 'aaaaaaxaa' );
ad94a511
IZ
418
419$_ = $t;
e8ebd21b
RGS
420$snum = s/\Ga/xx/g;
421ok( $_ eq 'xxxxxxxxxxxxxxxxxx' && $snum == 9 );
ad94a511
IZ
422
423$_ = $t;
e8ebd21b
RGS
424$snum = s/\Ga/x/g;
425ok( $_ eq 'xxxxxxxxx' && $snum == 9 );
ad94a511
IZ
426
427$_ = $t;
428s/\Ga/xx/;
e8ebd21b 429ok( $_ eq 'xxaaaaaaaa' );
ad94a511
IZ
430
431$_ = $t;
432s/\Ga/x/;
e8ebd21b 433ok( $_ eq 'xaaaaaaaa' );
ad94a511 434
f5c9036e 435$_ = 'aaaa';
e8ebd21b
RGS
436$snum = s/\ba/./g;
437ok( $_ eq '.aaa' && $snum == 1 );
ad94a511 438
e9fa98b2 439eval q% s/a/"b"}/e %;
e8ebd21b 440ok( $@ =~ /Bad evalled substitution/ );
e9fa98b2 441eval q% ($_ = "x") =~ s/(.)/"$1 "/e %;
e8ebd21b 442ok( $_ eq "x " and !length $@ );
43a16006
HS
443$x = $x = 'interp';
444eval q% ($_ = "x") =~ s/x(($x)*)/"$1"/e %;
e8ebd21b 445ok( $_ eq '' and !length $@ );
e9fa98b2 446
653099ff 447$_ = "C:/";
e8ebd21b 448ok( !s/^([a-z]:)/\u$1/ );
e9fa98b2 449
12d33761 450$_ = "Charles Bronson";
e8ebd21b
RGS
451$snum = s/\B\w//g;
452ok( $_ eq "C B" && $snum == 12 );
5b71a6a7
A
453
454{
455 use utf8;
456 my $s = "H\303\266he";
457 my $l = my $r = $s;
458 $l =~ s/[^\w]//g;
459 $r =~ s/[^\w\.]//g;
aefe6dfc 460 is($l, $r, "use utf8 \\w");
5b71a6a7 461}
89afcb60
A
462
463my $pv1 = my $pv2 = "Andreas J. K\303\266nig";
464$pv1 =~ s/A/\x{100}/;
465substr($pv2,0,1) = "\x{100}";
466is($pv1, $pv2);
aefe6dfc 467
26810345 468{
8e9639e9
JH
469 {
470 # Gregor Chrupala <gregor.chrupala@star-group.net>
471 use utf8;
472 $a = 'Espa&ntilde;a';
473 $a =~ s/&ntilde;/ñ/;
474 like($a, qr/ñ/, "use utf8 RHS");
475 }
476
477 {
478 use utf8;
479 $a = 'España España';
480 $a =~ s/ñ/&ntilde;/;
481 like($a, qr/ñ/, "use utf8 LHS");
482 }
483
484 {
485 use utf8;
486 $a = 'España';
487 $a =~ s/ñ/ñ/;
488 like($a, qr/ñ/, "use utf8 LHS and RHS");
489 }
aefe6dfc
JH
490}
491
8514a05a
JH
492{
493 # SADAHIRO Tomoyuki <bqw10602@nifty.com>
494
495 $a = "\x{100}\x{101}";
496 $a =~ s/\x{101}/\xFF/;
497 like($a, qr/\xFF/);
4a176938 498 is(length($a), 2, "SADAHIRO utf8 s///");
8514a05a
JH
499
500 $a = "\x{100}\x{101}";
501 $a =~ s/\x{101}/"\xFF"/e;
502 like($a, qr/\xFF/);
503 is(length($a), 2);
504
505 $a = "\x{100}\x{101}";
506 $a =~ s/\x{101}/\xFF\xFF\xFF/;
507 like($a, qr/\xFF\xFF\xFF/);
508 is(length($a), 4);
509
510 $a = "\x{100}\x{101}";
511 $a =~ s/\x{101}/"\xFF\xFF\xFF"/e;
512 like($a, qr/\xFF\xFF\xFF/);
513 is(length($a), 4);
514
515 $a = "\xFF\x{101}";
516 $a =~ s/\xFF/\x{100}/;
517 like($a, qr/\x{100}/);
518 is(length($a), 2);
519
520 $a = "\xFF\x{101}";
521 $a =~ s/\xFF/"\x{100}"/e;
522 like($a, qr/\x{100}/);
523 is(length($a), 2);
524
525 $a = "\xFF";
526 $a =~ s/\xFF/\x{100}/;
527 like($a, qr/\x{100}/);
528 is(length($a), 1);
529
530 $a = "\xFF";
531 $a =~ s/\xFF/"\x{100}"/e;
532 like($a, qr/\x{100}/);
533 is(length($a), 1);
534}
d6d0e86e
HS
535
536{
537 # subst with mixed utf8/non-utf8 type
538 my($ua, $ub, $uc, $ud) = ("\x{101}", "\x{102}", "\x{103}", "\x{104}");
539 my($na, $nb) = ("\x{ff}", "\x{fe}");
540 my $a = "$ua--$ub";
541 my $b;
542 ($b = $a) =~ s/--/$na/;
543 is($b, "$ua$na$ub", "s///: replace non-utf8 into utf8");
544 ($b = $a) =~ s/--/--$na--/;
545 is($b, "$ua--$na--$ub", "s///: replace long non-utf8 into utf8");
546 ($b = $a) =~ s/--/$uc/;
547 is($b, "$ua$uc$ub", "s///: replace utf8 into utf8");
548 ($b = $a) =~ s/--/--$uc--/;
549 is($b, "$ua--$uc--$ub", "s///: replace long utf8 into utf8");
550 $a = "$na--$nb";
551 ($b = $a) =~ s/--/$ua/;
552 is($b, "$na$ua$nb", "s///: replace utf8 into non-utf8");
553 ($b = $a) =~ s/--/--$ua--/;
554 is($b, "$na--$ua--$nb", "s///: replace long utf8 into non-utf8");
555
556 # now with utf8 pattern
557 $a = "$ua--$ub";
558 ($b = $a) =~ s/-($ud)?-/$na/;
559 is($b, "$ua$na$ub", "s///: replace non-utf8 into utf8 (utf8 pattern)");
560 ($b = $a) =~ s/-($ud)?-/--$na--/;
561 is($b, "$ua--$na--$ub", "s///: replace long non-utf8 into utf8 (utf8 pattern)");
562 ($b = $a) =~ s/-($ud)?-/$uc/;
563 is($b, "$ua$uc$ub", "s///: replace utf8 into utf8 (utf8 pattern)");
564 ($b = $a) =~ s/-($ud)?-/--$uc--/;
565 is($b, "$ua--$uc--$ub", "s///: replace long utf8 into utf8 (utf8 pattern)");
566 $a = "$na--$nb";
567 ($b = $a) =~ s/-($ud)?-/$ua/;
568 is($b, "$na$ua$nb", "s///: replace utf8 into non-utf8 (utf8 pattern)");
569 ($b = $a) =~ s/-($ud)?-/--$ua--/;
570 is($b, "$na--$ua--$nb", "s///: replace long utf8 into non-utf8 (utf8 pattern)");
571 ($b = $a) =~ s/-($ud)?-/$na/;
572 is($b, "$na$na$nb", "s///: replace non-utf8 into non-utf8 (utf8 pattern)");
573 ($b = $a) =~ s/-($ud)?-/--$na--/;
574 is($b, "$na--$na--$nb", "s///: replace long non-utf8 into non-utf8 (utf8 pattern)");
575}
576
6c8d78fb
HS
577$_ = 'aaaa';
578$r = 'x';
579$s = s/a(?{})/$r/g;
f14c76ed 580is("<$_> <$s>", "<xxxx> <4>", "[perl #7806]");
6c8d78fb
HS
581
582$_ = 'aaaa';
583$s = s/a(?{})//g;
f14c76ed 584is("<$_> <$s>", "<> <4>", "[perl #7806]");
6c8d78fb 585
f14c76ed
RGS
586# [perl #19048] Coredump in silly replacement
587{
588 local $^W = 0;
589 $_="abcdef\n";
590 s!.!!eg;
591 is($_, "\n", "[perl #19048]");
592}
593
4addbd3b
HS
594# [perl #17757] interaction between saw_ampersand and study
595{
596 my $f = eval q{ $& };
597 $f = "xx";
598 study $f;
599 $f =~ s/x/y/g;
600 is($f, "yy", "[perl #17757]");
601}
22e13caa
AE
602
603# [perl #20684] returned a zero count
604$_ = "1111";
605is(s/(??{1})/2/eg, 4, '#20684 s/// with (??{..}) inside');
606
83b43d92
AE
607# [perl #20682] @- not visible in replacement
608$_ = "123";
609/(2)/; # seed @- with something else
610s/(1)(2)(3)/$#- (@-)/;
611is($_, "3 (0 0 1 2)", '#20682 @- not visible in replacement');
612
76ec6486
AE
613# [perl #20682] $^N not visible in replacement
614$_ = "abc";
615/(a)/; s/(b)|(c)/-$^N/g;
616is($_,'a-b-c','#20682 $^N not visible in replacement');
7357df17
JH
617
618# [perl #22351] perl bug with 'e' substitution modifier
619my $name = "chris";
620{
621 no warnings 'uninitialized';
622 $name =~ s/hr//e;
623}
624is($name, "cis", q[#22351 bug with 'e' substitution modifier]);
01b35787
DM
625
626
627# [perl #34171] $1 didn't honour 'use bytes' in s//e
628{
629 my $s="\x{100}";
630 my $x;
631 {
632 use bytes;
633 $s=~ s/(..)/$x=$1/e
634 }
635 is(length($x), 2, '[perl #34171]');
636}
637
638
1749ea0d
ST
639{ # [perl #27940] perlbug: [\x00-\x1f] works, [\c@-\c_] does not
640 my $c;
641
642 ($c = "\x20\c@\x30\cA\x40\cZ\x50\c_\x60") =~ s/[\c@-\c_]//g;
643 is($c, "\x20\x30\x40\x50\x60", "s/[\\c\@-\\c_]//g");
644
645 ($c = "\x20\x00\x30\x01\x40\x1A\x50\x1F\x60") =~ s/[\x00-\x1f]//g;
646 is($c, "\x20\x30\x40\x50\x60", "s/[\\x00-\\x1f]//g");
647}
3be69782 648{
f0852a51
YO
649 $_ = "xy";
650 no warnings 'uninitialized';
651 /(((((((((x)))))))))(z)/; # clear $10
652 s/(((((((((x)))))))))(y)/${10}/;
653 is($_,"y","RT#6006: \$_ eq '$_'");
3be69782
RGS
654 $_ = "xr";
655 s/(((((((((x)))))))))(r)/fooba${10}/;
656 is($_,"foobar","RT#6006: \$_ eq '$_'");
f0852a51 657}
336b1602
YO
658{
659 my $want=("\n" x 11).("B\n" x 11)."B";
660 $_="B";
661 our $i;
662 for $i(1..11){
663 s/^.*$/$&/gm;
664 $_="\n$_\n$&";
665 }
666 is($want,$_,"RT#17542");
667}
1749ea0d 668
ce474962
NC
669{
670 my @tests = ('ABC', "\xA3\xA4\xA5", "\x{410}\x{411}\x{412}");
671 foreach (@tests) {
672 my $id = ord $_;
673 s/./pos/ge;
674 is($_, "012", "RT#52104: $id");
675 }
676}
831a7dd7 677
20e5bab4 678fresh_perl_is( '$_=q(foo);s/(.)\G//g;print' => 'foo', {},
8fe3c67a 679 '[perl #69056] positive GPOS regex segfault' );
20e5bab4 680fresh_perl_is( '$_="abcdef"; s/bc|(.)\G(.)/$1 ? "[$1-$2]" : "XX"/ge; print' => 'aXXdef', {},
8fe3c67a 681 'positive GPOS regex substitution failure (#69056, #114884)' );
20e5bab4 682fresh_perl_is( '$_="abcdefg123456"; s/(?<=...\G)?(\d)/($1)/; print' => 'abcdefg(1)23456', {},
8fe3c67a 683 'positive GPOS lookbehind regex substitution failure #114884' );
831a7dd7 684
d5e7783a
DM
685# s/..\G//g should stop after the first iteration, rather than working its
686# way backwards, or looping infinitely, or SEGVing (for example)
687{
688 my ($s, $count);
689
690 # use a function to disable constant folding
691 my $f = sub { substr("789", 0, $_[0]) };
692
693 $s = '123456';
694 pos($s) = 4;
695 $count = $s =~ s/\d\d\G/7/g;
696 is($count, 1, "..\\G count (short)");
697 is($s, "12756", "..\\G s (short)");
698
699 $s = '123456';
700 pos($s) = 4;
701 $count = $s =~ s/\d\d\G/78/g;
702 is($count, 1, "..\\G count (equal)");
703 is($s, "127856", "..\\G s (equal)");
704
705 $s = '123456';
706 pos($s) = 4;
707 $count = $s =~ s/\d\d\G/789/g;
708 is($count, 1, "..\\G count (long)");
709 is($s, "1278956", "..\\G s (long)");
710
711
712 $s = '123456';
713 pos($s) = 4;
714 $count = $s =~ s/\d\d\G/$f->(1)/eg;
715 is($count, 1, "..\\G count (short code)");
716 is($s, "12756", "..\\G s (short code)");
717
718 $s = '123456';
719 pos($s) = 4;
720 $count = $s =~ s/\d\d\G/$f->(2)/eg;
721 is($count, 1, "..\\G count (equal code)");
722 is($s, "127856", "..\\G s (equal code)");
723
724 $s = '123456';
725 pos($s) = 4;
726 $count = $s =~ s/\d\d\G/$f->(3)/eg;
727 is($count, 1, "..\\G count (long code)");
728 is($s, "1278956", "..\\G s (long code)");
729
730 $s = '123456';
731 pos($s) = 4;
732 $count = $s =~ s/\d\d(?=\d\G)/7/g;
733 is($count, 1, "..\\G count (lookahead short)");
734 is($s, "17456", "..\\G s (lookahead short)");
735
736 $s = '123456';
737 pos($s) = 4;
738 $count = $s =~ s/\d\d(?=\d\G)/78/g;
739 is($count, 1, "..\\G count (lookahead equal)");
740 is($s, "178456", "..\\G s (lookahead equal)");
741
742 $s = '123456';
743 pos($s) = 4;
744 $count = $s =~ s/\d\d(?=\d\G)/789/g;
745 is($count, 1, "..\\G count (lookahead long)");
746 is($s, "1789456", "..\\G s (lookahead long)");
747
748
749 $s = '123456';
750 pos($s) = 4;
751 $count = $s =~ s/\d\d(?=\d\G)/$f->(1)/eg;
752 is($count, 1, "..\\G count (lookahead short code)");
753 is($s, "17456", "..\\G s (lookahead short code)");
754
755 $s = '123456';
756 pos($s) = 4;
757 $count = $s =~ s/\d\d(?=\d\G)/$f->(2)/eg;
758 is($count, 1, "..\\G count (lookahead equal code)");
759 is($s, "178456", "..\\G s (lookahead equal code)");
760
761 $s = '123456';
762 pos($s) = 4;
763 $count = $s =~ s/\d\d(?=\d\G)/$f->(3)/eg;
764 is($count, 1, "..\\G count (lookahead long code)");
765 is($s, "1789456", "..\\G s (lookahead long code)");
766}
767
768
92c404cd 769# [perl #71470] $var =~ s/$qr//e calling get-magic on $_ as well as $var
455d9033
FC
770{
771 local *_;
772 my $scratch;
773 sub qrBug::TIESCALAR { bless[pop], 'qrBug' }
774 sub qrBug::FETCH { $scratch .= "[fetching $_[0][0]]"; 'prew' }
775 sub qrBug::STORE{}
776 tie my $kror, qrBug => '$kror';
777 tie $_, qrBug => '$_';
778 my $qr = qr/(?:)/;
779 $kror =~ s/$qr/""/e;
780 is(
781 $scratch, '[fetching $kror]',
782 'bug: $var =~ s/$qr//e calling get-magic on $_ as well as $var',
783 );
784}
3e462cdc
KW
785
786{ # Bug #41530; replacing non-utf8 with a utf8 causes problems
787 my $string = "a\x{a0}a";
788 my $sub_string = $string;
789 ok(! utf8::is_utf8($sub_string), "Verify that string isn't initially utf8");
790 $sub_string =~ s/a/\x{100}/g;
791 ok(utf8::is_utf8($sub_string),
792 'Verify replace of non-utf8 with utf8 upgrades to utf8');
793 is($sub_string, "\x{100}\x{A0}\x{100}",
794 'Verify #41530 fixed: replace of non-utf8 with utf8');
795
796 my $non_sub_string = $string;
797 ok(! utf8::is_utf8($non_sub_string),
798 "Verify that string isn't initially utf8");
799 $non_sub_string =~ s/b/\x{100}/g;
800 ok(! utf8::is_utf8($non_sub_string),
801 "Verify that failed substitute doesn't change string's utf8ness");
802 is($non_sub_string, $string,
803 "Verify that failed substitute doesn't change string");
804}
84bb2957
KW
805
806{ # Verify largish octal in replacement pattern
807
808 my $string = "a";
809 $string =~ s/a/\400/;
810 is($string, chr 0x100, "Verify that handles s/foo/\\400/");
811 $string =~ s/./\600/;
812 is($string, chr 0x180, "Verify that handles s/foo/\\600/");
813 $string =~ s/./\777/;
814 is($string, chr 0x1FF, "Verify that handles s/foo/\\777/");
815}
af9838cc
FC
816
817# Scoping of s//the RHS/ when there is no /e
818# Tests based on [perl #19078]
819{
820 local *_;
821 my $output = ''; my %a;
822 no warnings 'uninitialized';
823
824 $_="CCCGGG";
825 s!.!<@a{$output .= ("$&"),/[$&]/g}>!g;
826 $output .= $_;
827 is(
828 $output, "CCCGGG< >< >< >< >< >< >",
829 's/// sets PL_curpm for each iteration even when the RHS has set it'
830 );
831
832 s/C/$a{m\G\}/;
833 is(
834 "$&", G =>
835 'Match vars reflect the last match after s/pat/$a{m|pat|}/ without /e'
836 );
837}
c95ca9b8
DM
838
839{
840 # a tied scalar that returned a plain string, got messed up
841 # when substituted with a UTF8 replacement string, due to
842 # magic getting called multiple times, and pointers now pointing
843 # to stale/freed strings
5c1648b0
FC
844 # The original fix for this caused infinite loops for non- or cow-
845 # strings, so we test those, too.
c95ca9b8
DM
846 package FOO;
847 my $fc;
848 sub TIESCALAR { bless [ "abcdefgh" ] }
849 sub FETCH { $fc++; $_[0][0] }
850 sub STORE { $_[0][0] = $_[1] }
851
852 my $s;
853 tie $s, 'FOO';
854 $s =~ s/..../\x{101}/;
855 ::is($fc, 1, "tied UTF8 stuff FETCH count");
856 ::is("$s", "\x{101}efgh", "tied UTF8 stuff");
5c1648b0
FC
857
858 ::watchdog(300);
859 $fc = 0;
860 $s = *foo;
861 $s =~ s/..../\x{101}/;
862 ::is($fc, 1, '$tied_glob =~ s/non-utf8/utf8/ fetch count');
863 ::is("$s", "\x{101}::foo", '$tied_glob =~ s/non-utf8/utf8/ result');
864 $fc = 0;
865 $s = *foo;
866 $s =~ s/(....)/\x{101}/g;
867 ::is($fc, 1, '$tied_glob =~ s/(non-utf8)/utf8/g fetch count');
868 ::is("$s", "\x{101}\x{101}o",
869 '$tied_glob =~ s/(non-utf8)/utf8/g result');
870 $fc = 0;
871 $s = "\xff\xff\xff\xff\xff";
872 $s =~ s/..../\x{101}/;
873 ::is($fc, 1, '$tied_latin1 =~ s/non-utf8/utf8/ fetch count');
874 ::is("$s", "\x{101}\xff", '$tied_latin1 =~ s/non-utf8/utf8/ result');
875 $fc = 0;
876 { package package_name; tied($s)->[0] = __PACKAGE__ };
877 $s =~ s/..../\x{101}/;
878 ::is($fc, 1, '$tied_cow =~ s/non-utf8/utf8/ fetch count');
879 ::is("$s", "\x{101}age_name", '$tied_cow =~ s/non-utf8/utf8/ result');
880 $fc = 0;
881 $s = \1;
882 $s =~ s/..../\x{101}/;
883 ::is($fc, 1, '$tied_ref =~ s/non-utf8/utf8/ fetch count');
884 ::like("$s", qr/^\x{101}AR\(0x.*\)\z/,
885 '$tied_ref =~ s/non-utf8/utf8/ result');
c95ca9b8 886}
0c1438a1
NC
887
888# RT #97954
889{
890 my $count;
891
892 sub bam::DESTROY {
893 --$count;
894 }
895
896 my $z_zapp = bless [], 'bam';
897 ++$count;
898
899 is($count, 1, '1 object');
900 is($z_zapp =~ s/.*/R/r, 'R', 'substitution happens');
901 is(ref $z_zapp, 'bam', 'still 1 object');
902 is($count, 1, 'still 1 object');
903 undef $z_zapp;
904 is($count, 0, 'now 0 objects');
905
906 $z_zapp = bless [], 'bam';
907 ++$count;
908
909 is($count, 1, '1 object');
910 like($z_zapp =~ s/./R/rg, qr/\AR{8,}\z/, 'substitution happens');
911 is(ref $z_zapp, 'bam', 'still 1 object');
912 is($count, 1, 'still 1 object');
913 undef $z_zapp;
914 is($count, 0, 'now 0 objects');
915}
916
917is(*bam =~ s/\*//r, 'main::bam', 'Can s///r a tyepglob');
918is(*bam =~ s/\*//rg, 'main::bam', 'Can s///rg a tyepglob');
6fc20922
FC
919
920{
921 sub cowBug::TIESCALAR { bless[], 'cowBug' }
922 sub cowBug::FETCH { __PACKAGE__ }
923 sub cowBug::STORE{}
924 tie my $kror, cowBug =>;
925 $kror =~ s/(?:)/""/e;
926}
610272b5
DM
927pass("s/// on tied var returning a cow");
928
929# a test for 6502e08109cd003b2cdf39bc94ef35e52203240b
930# previously this would segfault
931
932{
933 my $s = "abc";
934 eval { $s =~ s/(.)/die/e; };
935 like($@, qr/Died at/, "s//die/e");
936}
86e69b18
FC
937
938
1754320d 939# Test problems with constant replacement optimisation
86e69b18
FC
940# [perl #26986] logop in repl resulting in incorrect optimisation
941"g" =~ /(.)/;
942@l{'a'..'z'} = 'A'..':';
943$_ = "hello";
944{ s/(.)/$l{my $a||$1}/g }
945is $_, "HELLO",
946 'logop in s/// repl does not result in "constant" repl optimisation';
1754320d
FC
947# Aliases to match vars
948"g" =~ /(.)/;
949$_ = "hello";
950{
951 local *a = *1;
952 s/(.)\1/$a/g;
953}
954is $_, 'helo', 's/pat/$alias_to_match_var/';
bb933b9b
FC
955"g" =~ /(.)/;
956$_ = "hello";
957{
958 local *a = *1;
959 s/e(.)\1/a$a/g;
960}
6daa8d50 961is $_, 'halo', 's/pat/foo$alias_to_match_var/';
b97b7b69
FC
962# Last-used pattern containing re-evals that modify "constant" rhs
963{
964 local *a;
965 $x = "hello";
966 $x =~ /(?{*a = \"a"})./;
967 undef *a;
968 $x =~ s//$a/g;
969 is $x, 'aaaaa',
970 'last-used pattern disables constant repl optimisation';
971}
1754320d 972
64534138
FC
973
974$_ = "\xc4\x80";
975$a = "";
976utf8::upgrade $a;
977$_ =~ s/$/$a/;
978is $_, "\xc4\x80", "empty utf8 repl does not result in mangled utf8";
e1b14503
FC
979
980$@ = "\x{30cb}eval 18";
981$@ =~ s/eval \d+/eval 11/;
982is $@, "\x{30cb}eval 11",
983 'loading utf8 tables does not interfere with matches against $@';
9e0ea7f3
FC
984
985$reftobe = 3;
986$reftobe =~ s/3/$reftobe=\ 3;4/e;
987is $reftobe, '4', 'clobbering target with ref in s//.../e';
988$locker{key} = 3;
989SKIP:{
990 skip "no Hash::Util under miniperl", 2 if is_miniperl;
991 require Hash::Util;
992 eval {
993 $locker{key} =~ s/3/
994 $locker{key} = 3;
995 &Hash::Util::lock_hash(\%locker);4
996 /e;
997 };
998 is $locker{key}, '3', 'locking target in $hash{key} =~ s//.../e';
999 like $@, qr/^Modification of a read-only value/, 'err msg';
1000}
1001delete $::{does_not_exist}; # just in case
1002eval { no warnings; $::{does_not_exist}=~s/(?:)/*{"does_not_exist"}; 4/e };
1003like $@, qr/^Modification of a read-only value/,
1004 'vivifying stash elem in $that::{elem} =~ s//.../e';
958851d8
FC
1005
1006# COWs should not be exempt from read-only checks. s/// croaks on read-
1007# only values even when the pattern does not match, but it was not doing so
1008# for COWs.
1009eval { for (__PACKAGE__) { s/b/c/; } };
1010like $@, qr/^Modification of a read-only value/,
1011 'read-only COW =~ s/does not match// should croak';
c8519dc7
KW
1012
1013SKIP: {
1014 my $a_acute = chr utf8::unicode_to_native(0xE1); # LATIN SMALL LETTER A WITH ACUTE
1015 my $egrave = chr utf8::unicode_to_native(0xE8); # LATIN SMALL LETTER E WITH GRAVE
1016 my $u_umlaut = chr utf8::unicode_to_native(0xFC); # LATIN SMALL LETTER U WITH DIAERESIS
1017 my $division = chr utf8::unicode_to_native(0xF7); # DIVISION SIGN
1018
1019 is("ab.c" =~ s/\b/!/agr, "!ab!.!c!", '\\b matches ASCII before string, mid, and end, /a');
1020 is("$a_acute$egrave.$u_umlaut" =~ s/\b/!/agr, "$a_acute$egrave.$u_umlaut", '\\b matches Latin1 before string, mid, and end, /a');
1021 is("\x{100}\x{101}.\x{102}" =~ s/\b/!/agr, "\x{100}\x{101}.\x{102}", '\\b matches above-Latin1 before string, mid, and end, /a');
1022
1023 is("..." =~ s/\B/!/agr, "!.!.!.!", '\\B matches ASCII before string, mid, and end, /a');
1024 is("$division$division$division" =~ s/\B/!/agr, "!$division!$division!$division!", '\\B matches Latin1 before string, mid, and end, /a');
1025 is("\x{2028}\x{2028}\x{2028}" =~ s/\B/!/agr, "!\x{2028}!\x{2028}!\x{2028}!", '\\B matches above-Latin1 before string, mid, and end, /a');
1026
1027 is("ab.c" =~ s/\b/!/dgr, "!ab!.!c!", '\\b matches ASCII before string, mid, and end, /d');
1028 { is("$a_acute$egrave.$u_umlaut" =~ s/\b/!/dgr, "$a_acute$egrave.$u_umlaut", '\\b matches Latin1 before string, mid, and end, /d'); }
1029 is("\x{100}\x{101}.\x{102}" =~ s/\b/!/dgr, "!\x{100}\x{101}!.!\x{102}!", '\\b matches above-Latin1 before string, mid, and end, /d');
1030
1031 is("..." =~ s/\B/!/dgr, "!.!.!.!", '\\B matches ASCII before string, mid, and end, /d');
1032 is("$division$division$division" =~ s/\B/!/dgr, "!$division!$division!$division!", '\\B matches Latin1 before string, mid, and end, /d');
1033 is("\x{2028}\x{2028}\x{2028}" =~ s/\B/!/dgr, "!\x{2028}!\x{2028}!\x{2028}!", '\\B matches above-Latin1 before string, mid, and end, /d');
1034
1035 is("ab.c" =~ s/\b/!/ugr, "!ab!.!c!", '\\b matches ASCII before string, mid, and end, /u');
1036 is("$a_acute$egrave.$u_umlaut" =~ s/\b/!/ugr, "!$a_acute$egrave!.!$u_umlaut!", '\\b matches Latin1 before string, mid, and end, /u');
1037 is("\x{100}\x{101}.\x{102}" =~ s/\b/!/ugr, "!\x{100}\x{101}!.!\x{102}!", '\\b matches above-Latin1 before string, mid, and end, /u');
1038
1039 is("..." =~ s/\B/!/ugr, "!.!.!.!", '\\B matches ASCII before string, mid, and end, /u');
1040 is("$division$division$division" =~ s/\B/!/ugr, "!$division!$division!$division!", '\\B matches Latin1 before string, mid, and end, /u');
1041 is("\x{2028}\x{2028}\x{2028}" =~ s/\B/!/ugr, "!\x{2028}!\x{2028}!\x{2028}!", '\\B matches above-Latin1 before string, mid, and end, /u');
1042
da271c54
KW
1043 fresh_perl_like( '$_=""; /\b{gcb}/; s///g', qr/^$/, {},
1044 '[perl #126319: Segmentation fault in Perl_sv_catpvn_flags with \b{gcb}'
1045 );
1046 fresh_perl_like( '$_=""; /\B{gcb}/; s///g', qr/^$/, {},
1047 '[perl #126319: Segmentation fault in Perl_sv_catpvn_flags with \b{gcb}'
1048 );
1049 fresh_perl_like( '$_=""; /\b{wb}/; s///g', qr/^$/, {},
1050 '[perl #126319: Segmentation fault in Perl_sv_catpvn_flags with \b{wb}'
1051 );
1052 fresh_perl_like( '$_=""; /\B{wb}/; s///g', qr/^$/, {},
1053 '[perl #126319: Segmentation fault in Perl_sv_catpvn_flags with \b{wb}'
1054 );
1055 fresh_perl_like( '$_=""; /\b{sb}/; s///g', qr/^$/, {},
1056 '[perl #126319: Segmentation fault in Perl_sv_catpvn_flags with \b{sb}'
1057 );
1058 fresh_perl_like( '$_=""; /\B{sb}/; s///g', qr/^$/, {},
1059 '[perl #126319: Segmentation fault in Perl_sv_catpvn_flags with \b{sb}'
1060 );
da271c54 1061
0b75bbb6 1062SKIP: {
1ec7020c 1063 if (! locales_enabled('LC_ALL')) {
fcfe87f6
BF
1064 skip "Can't test locale (maybe you are missing POSIX)", 6;
1065 }
c8519dc7 1066
0b75bbb6 1067 setlocale(&POSIX::LC_ALL, "C");
c8519dc7
KW
1068 use locale;
1069 is("a.b" =~ s/\b/!/gr, "!a!.!b!", '\\b matches ASCII before string, mid, and end, /l');
1070 is("$a_acute.$egrave" =~ s/\b/!/gr, "$a_acute.$egrave", '\\b matches Latin1 before string, mid, and end, /l');
1071 is("\x{100}\x{101}.\x{102}" =~ s/\b/!/gr, "!\x{100}\x{101}!.!\x{102}!", '\\b matches above-Latin1 before string, mid, and end, /l');
1072
1073 is("..." =~ s/\B/!/gr, "!.!.!.!", '\\B matches ASCII before string, mid, and end, /l');
1074 is("$division$division$division" =~ s/\B/!/gr, "!$division!$division!$division!", '\\B matches Latin1 before string, mid, and end, /l');
1075 is("\x{2028}\x{2028}\x{2028}" =~ s/\B/!/gr, "!\x{2028}!\x{2028}!\x{2028}!", '\\B matches above-Latin1 before string, mid, and end, /l');
1076}
0b75bbb6
JH
1077
1078}
a911bb25
DM
1079
1080{
1081 # RT #123954 if the string getting matched against got converted during
1082 # s///e so that it was no longer SvPOK, an assertion would fail when
1083 # setting pos.
1084 my $s1 = 0;
1085 $s1 =~ s/.?/$s1++/ge;
1086 is($s1, "01","RT #123954 s1");
1087}
cf69025f
TC
1088{
1089 # RT #126602 double free if the value being modified is freed in the replacement
1090 fresh_perl_is('s//*_=0;s|0||;00.y0/e; print qq(ok\n)', "ok\n", { stderr => 1 },
1091 "[perl #126602] s//*_=0;s|0||/e crashes");
1092}
4cf1a867
DM
1093
1094{
1095 #RT 126260 gofs is in chars, not bytes
1096
1097 # in something like /..\G/, the engine should start matching two
1098 # chars before pos(). At one point it was matching two bytes before.
1099
1100 my $s = "\x{121}\x{122}\x{123}";
1101 pos($s) = 2;
1102 $s =~ s/..\G//g;
1103 is($s, "\x{123}", "#RT 126260 gofs");
1104}