Commit | Line | Data |
---|---|---|
25aae3a7 | 1 | #!./perl -w |
d9d8d8de | 2 | |
a1a0e61e TD |
3 | BEGIN { |
4 | chdir 't' if -d 't'; | |
20822f61 | 5 | @INC = '../lib'; |
a1a0e61e TD |
6 | require Config; import Config; |
7 | } | |
344462d3 | 8 | |
e8ebd21b | 9 | require './test.pl'; |
3e462cdc | 10 | plan( tests => 149 ); |
d9d8d8de LW |
11 | |
12 | $x = 'foo'; | |
13 | $_ = "x"; | |
14 | s/x/\$x/; | |
e8ebd21b | 15 | ok( $_ eq '$x', ":$_: eq :\$x:" ); |
d9d8d8de LW |
16 | |
17 | $_ = "x"; | |
18 | s/x/$x/; | |
e8ebd21b | 19 | ok( $_ eq 'foo', ":$_: eq :foo:" ); |
d9d8d8de LW |
20 | |
21 | $_ = "x"; | |
22 | s/x/\$x $x/; | |
e8ebd21b | 23 | ok( $_ eq '$x foo', ":$_: eq :\$x foo:" ); |
d9d8d8de LW |
24 | |
25 | $b = 'cd'; | |
79072805 | 26 | ($a = 'abcdef') =~ s<(b${b}e)>'\n$1'; |
e8ebd21b | 27 | ok( $1 eq 'bcde' && $a eq 'a\n$1f', ":$1: eq :bcde: ; :$a: eq :a\\n\$1f:" ); |
d9d8d8de LW |
28 | |
29 | $a = 'abacada'; | |
e8ebd21b | 30 | ok( ($a =~ s/a/x/g) == 4 && $a eq 'xbxcxdx' ); |
d9d8d8de | 31 | |
e8ebd21b | 32 | ok( ($a =~ s/a/y/g) == 0 && $a eq 'xbxcxdx' ); |
d9d8d8de | 33 | |
e8ebd21b | 34 | ok( ($a =~ s/b/y/g) == 1 && $a eq 'xyxcxdx' ); |
d9d8d8de LW |
35 | |
36 | $_ = 'ABACADA'; | |
e8ebd21b | 37 | ok( /a/i && s///gi && $_ eq 'BCD' ); |
d9d8d8de LW |
38 | |
39 | $_ = '\\' x 4; | |
e8ebd21b RGS |
40 | ok( length($_) == 4 ); |
41 | $snum = s/\\/\\\\/g; | |
42 | ok( $_ eq '\\' x 8 && $snum == 4 ); | |
d9d8d8de LW |
43 | |
44 | $_ = '\/' x 4; | |
e8ebd21b RGS |
45 | ok( length($_) == 8 ); |
46 | $snum = s/\//\/\//g; | |
47 | ok( $_ eq '\\//' x 4 && $snum == 4 ); | |
48 | ok( length($_) == 12 ); | |
d9d8d8de LW |
49 | |
50 | $_ = 'aaaXXXXbbb'; | |
51 | s/^a//; | |
e8ebd21b | 52 | ok( $_ eq 'aaXXXXbbb' ); |
d9d8d8de LW |
53 | |
54 | $_ = 'aaaXXXXbbb'; | |
55 | s/a//; | |
e8ebd21b | 56 | ok( $_ eq 'aaXXXXbbb' ); |
d9d8d8de LW |
57 | |
58 | $_ = 'aaaXXXXbbb'; | |
59 | s/^a/b/; | |
e8ebd21b | 60 | ok( $_ eq 'baaXXXXbbb' ); |
d9d8d8de LW |
61 | |
62 | $_ = 'aaaXXXXbbb'; | |
63 | s/a/b/; | |
e8ebd21b | 64 | ok( $_ eq 'baaXXXXbbb' ); |
d9d8d8de LW |
65 | |
66 | $_ = 'aaaXXXXbbb'; | |
67 | s/aa//; | |
e8ebd21b | 68 | ok( $_ eq 'aXXXXbbb' ); |
d9d8d8de LW |
69 | |
70 | $_ = 'aaaXXXXbbb'; | |
71 | s/aa/b/; | |
e8ebd21b | 72 | ok( $_ eq 'baXXXXbbb' ); |
d9d8d8de LW |
73 | |
74 | $_ = 'aaaXXXXbbb'; | |
75 | s/b$//; | |
e8ebd21b | 76 | ok( $_ eq 'aaaXXXXbb' ); |
d9d8d8de LW |
77 | |
78 | $_ = 'aaaXXXXbbb'; | |
79 | s/b//; | |
e8ebd21b | 80 | ok( $_ eq 'aaaXXXXbb' ); |
d9d8d8de LW |
81 | |
82 | $_ = 'aaaXXXXbbb'; | |
83 | s/bb//; | |
e8ebd21b | 84 | ok( $_ eq 'aaaXXXXb' ); |
d9d8d8de LW |
85 | |
86 | $_ = 'aaaXXXXbbb'; | |
87 | s/aX/y/; | |
e8ebd21b | 88 | ok( $_ eq 'aayXXXbbb' ); |
d9d8d8de LW |
89 | |
90 | $_ = 'aaaXXXXbbb'; | |
91 | s/Xb/z/; | |
e8ebd21b | 92 | ok( $_ eq 'aaaXXXzbb' ); |
d9d8d8de LW |
93 | |
94 | $_ = 'aaaXXXXbbb'; | |
95 | s/aaX.*Xbb//; | |
e8ebd21b | 96 | ok( $_ eq 'ab' ); |
d9d8d8de LW |
97 | |
98 | $_ = 'aaaXXXXbbb'; | |
99 | s/bb/x/; | |
e8ebd21b | 100 | ok( $_ eq 'aaaXXXXxb' ); |
d9d8d8de LW |
101 | |
102 | # now for some unoptimized versions of the same. | |
103 | ||
104 | $_ = 'aaaXXXXbbb'; | |
105 | $x ne $x || s/^a//; | |
e8ebd21b | 106 | ok( $_ eq 'aaXXXXbbb' ); |
d9d8d8de LW |
107 | |
108 | $_ = 'aaaXXXXbbb'; | |
109 | $x ne $x || s/a//; | |
e8ebd21b | 110 | ok( $_ eq 'aaXXXXbbb' ); |
d9d8d8de LW |
111 | |
112 | $_ = 'aaaXXXXbbb'; | |
113 | $x ne $x || s/^a/b/; | |
e8ebd21b | 114 | ok( $_ eq 'baaXXXXbbb' ); |
d9d8d8de LW |
115 | |
116 | $_ = 'aaaXXXXbbb'; | |
117 | $x ne $x || s/a/b/; | |
e8ebd21b | 118 | ok( $_ eq 'baaXXXXbbb' ); |
d9d8d8de LW |
119 | |
120 | $_ = 'aaaXXXXbbb'; | |
121 | $x ne $x || s/aa//; | |
e8ebd21b | 122 | ok( $_ eq 'aXXXXbbb' ); |
d9d8d8de LW |
123 | |
124 | $_ = 'aaaXXXXbbb'; | |
125 | $x ne $x || s/aa/b/; | |
e8ebd21b | 126 | ok( $_ eq 'baXXXXbbb' ); |
d9d8d8de LW |
127 | |
128 | $_ = 'aaaXXXXbbb'; | |
129 | $x ne $x || s/b$//; | |
e8ebd21b | 130 | ok( $_ eq 'aaaXXXXbb' ); |
d9d8d8de LW |
131 | |
132 | $_ = 'aaaXXXXbbb'; | |
133 | $x ne $x || s/b//; | |
e8ebd21b | 134 | ok( $_ eq 'aaaXXXXbb' ); |
d9d8d8de LW |
135 | |
136 | $_ = 'aaaXXXXbbb'; | |
137 | $x ne $x || s/bb//; | |
e8ebd21b | 138 | ok( $_ eq 'aaaXXXXb' ); |
d9d8d8de LW |
139 | |
140 | $_ = 'aaaXXXXbbb'; | |
141 | $x ne $x || s/aX/y/; | |
e8ebd21b | 142 | ok( $_ eq 'aayXXXbbb' ); |
d9d8d8de LW |
143 | |
144 | $_ = 'aaaXXXXbbb'; | |
145 | $x ne $x || s/Xb/z/; | |
e8ebd21b | 146 | ok( $_ eq 'aaaXXXzbb' ); |
d9d8d8de LW |
147 | |
148 | $_ = 'aaaXXXXbbb'; | |
149 | $x ne $x || s/aaX.*Xbb//; | |
e8ebd21b | 150 | ok( $_ eq 'ab' ); |
d9d8d8de LW |
151 | |
152 | $_ = 'aaaXXXXbbb'; | |
153 | $x ne $x || s/bb/x/; | |
e8ebd21b | 154 | ok( $_ eq 'aaaXXXXxb' ); |
d9d8d8de LW |
155 | |
156 | $_ = 'abc123xyz'; | |
c277df42 | 157 | s/(\d+)/$1*2/e; # yields 'abc246xyz' |
e8ebd21b | 158 | ok( $_ eq 'abc246xyz' ); |
c277df42 | 159 | s/(\d+)/sprintf("%5d",$1)/e; # yields 'abc 246xyz' |
e8ebd21b | 160 | ok( $_ eq 'abc 246xyz' ); |
c277df42 | 161 | s/(\w)/$1 x 2/eg; # yields 'aabbcc 224466xxyyzz' |
e8ebd21b | 162 | ok( $_ eq 'aabbcc 224466xxyyzz' ); |
d9d8d8de LW |
163 | |
164 | $_ = "aaaaa"; | |
e8ebd21b RGS |
165 | ok( y/a/b/ == 5 ); |
166 | ok( y/a/b/ == 0 ); | |
167 | ok( y/b// == 5 ); | |
168 | ok( y/b/c/s == 5 ); | |
169 | ok( y/c// == 1 ); | |
170 | ok( y/c//d == 1 ); | |
171 | ok( $_ eq "" ); | |
d9d8d8de LW |
172 | |
173 | $_ = "Now is the %#*! time for all good men..."; | |
e8ebd21b RGS |
174 | ok( ($x=(y/a-zA-Z //cd)) == 7 ); |
175 | ok( y/ / /s == 8 ); | |
d9d8d8de | 176 | |
79072805 LW |
177 | $_ = 'abcdefghijklmnopqrstuvwxyz0123456789'; |
178 | tr/a-z/A-Z/; | |
179 | ||
e8ebd21b | 180 | ok( $_ eq 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789' ); |
79072805 LW |
181 | |
182 | # same as tr/A-Z/a-z/; | |
e8ebd21b | 183 | if (defined $Config{ebcdic} && $Config{ebcdic} eq 'define') { # EBCDIC. |
6e68dac8 | 184 | no utf8; |
9d116dd7 JH |
185 | y[\301-\351][\201-\251]; |
186 | } else { # Ye Olde ASCII. Or something like it. | |
187 | y[\101-\132][\141-\172]; | |
188 | } | |
79072805 | 189 | |
e8ebd21b | 190 | ok( $_ eq 'abcdefghijklmnopqrstuvwxyz0123456789' ); |
79072805 | 191 | |
e8ebd21b RGS |
192 | SKIP: { |
193 | skip("not ASCII",1) unless (ord("+") == ord(",") - 1 | |
194 | && ord(",") == ord("-") - 1 | |
195 | && ord("a") == ord("b") - 1 | |
196 | && ord("b") == ord("c") - 1); | |
197 | $_ = '+,-'; | |
198 | tr/+--/a-c/; | |
199 | ok( $_ eq 'abc' ); | |
9d116dd7 | 200 | } |
79072805 LW |
201 | |
202 | $_ = '+,-'; | |
203 | tr/+\--/a\/c/; | |
e8ebd21b | 204 | ok( $_ eq 'a,/' ); |
79072805 LW |
205 | |
206 | $_ = '+,-'; | |
207 | tr/-+,/ab\-/; | |
e8ebd21b | 208 | ok( $_ eq 'b-a' ); |
843b4603 TB |
209 | |
210 | ||
211 | # test recursive substitutions | |
212 | # code based on the recursive expansion of makefile variables | |
213 | ||
214 | my %MK = ( | |
215 | AAAAA => '$(B)', B=>'$(C)', C => 'D', # long->short | |
216 | E => '$(F)', F=>'p $(G) q', G => 'HHHHH', # short->long | |
217 | DIR => '$(UNDEFINEDNAME)/xxx', | |
218 | ); | |
219 | sub var { | |
220 | my($var,$level) = @_; | |
221 | return "\$($var)" unless exists $MK{$var}; | |
222 | return exp_vars($MK{$var}, $level+1); # can recurse | |
223 | } | |
224 | sub exp_vars { | |
225 | my($str,$level) = @_; | |
226 | $str =~ s/\$\((\w+)\)/var($1, $level+1)/ge; # can recurse | |
227 | #warn "exp_vars $level = '$str'\n"; | |
228 | $str; | |
229 | } | |
230 | ||
e8ebd21b RGS |
231 | ok( exp_vars('$(AAAAA)',0) eq 'D' ); |
232 | ok( exp_vars('$(E)',0) eq 'p HHHHH q' ); | |
233 | ok( exp_vars('$(DIR)',0) eq '$(UNDEFINEDNAME)/xxx' ); | |
234 | ok( exp_vars('foo $(DIR)/yyy bar',0) eq 'foo $(UNDEFINEDNAME)/xxx/yyy bar' ); | |
3e3baf6d TB |
235 | |
236 | $_ = "abcd"; | |
c277df42 | 237 | s/(..)/$x = $1, m#.#/eg; |
e8ebd21b | 238 | ok( $x eq "cd", 'a match nested in the RHS of a substitution' ); |
fb73857a | 239 | |
c277df42 IZ |
240 | # Subst and lookbehind |
241 | ||
242 | $_="ccccc"; | |
e8ebd21b RGS |
243 | $snum = s/(?<!x)c/x/g; |
244 | ok( $_ eq "xxxxx" && $snum == 5 ); | |
c277df42 IZ |
245 | |
246 | $_="ccccc"; | |
e8ebd21b RGS |
247 | $snum = s/(?<!x)(c)/x/g; |
248 | ok( $_ eq "xxxxx" && $snum == 5 ); | |
c277df42 IZ |
249 | |
250 | $_="foobbarfoobbar"; | |
e8ebd21b RGS |
251 | $snum = s/(?<!r)foobbar/foobar/g; |
252 | ok( $_ eq "foobarfoobbar" && $snum == 1 ); | |
c277df42 IZ |
253 | |
254 | $_="foobbarfoobbar"; | |
e8ebd21b RGS |
255 | $snum = s/(?<!ar)(foobbar)/foobar/g; |
256 | ok( $_ eq "foobarfoobbar" && $snum == 1 ); | |
c277df42 IZ |
257 | |
258 | $_="foobbarfoobbar"; | |
e8ebd21b RGS |
259 | $snum = s/(?<!ar)foobbar/foobar/g; |
260 | ok( $_ eq "foobarfoobbar" && $snum == 1 ); | |
c277df42 | 261 | |
fb73857a | 262 | eval 's{foo} # this is a comment, not a delimiter |
263 | {bar};'; | |
e8ebd21b | 264 | ok( ! @?, 'parsing of split subst with comment' ); |
f3ea7b5e | 265 | |
ed02a3bf DN |
266 | $snum = eval '$_="exactly"; s sxsys;m 3(yactl)3;$1'; |
267 | is( $snum, 'yactl', 'alpha delimiters are allowed' ); | |
268 | ||
f3ea7b5e | 269 | $_="baacbaa"; |
e8ebd21b RGS |
270 | $snum = tr/a/b/s; |
271 | ok( $_ eq "bbcbb" && $snum == 4, | |
272 | 'check if squashing works at the end of string' ); | |
f3ea7b5e | 273 | |
2216f30a | 274 | $_ = "ab"; |
e8ebd21b | 275 | ok( s/a/b/ == 1 ); |
ce862d02 IZ |
276 | |
277 | $_ = <<'EOL'; | |
278 | $url = new URI::URL "http://www/"; die if $url eq "xXx"; | |
279 | EOL | |
280 | $^R = 'junk'; | |
281 | ||
282 | $foo = ' $@%#lowercase $@%# lowercase UPPERCASE$@%#UPPERCASE' . | |
283 | ' $@%#lowercase$@%#lowercase$@%# lowercase lowercase $@%#lowercase' . | |
284 | ' lowercase $@%#MiXeD$@%# '; | |
285 | ||
e8ebd21b | 286 | $snum = |
ce862d02 IZ |
287 | s{ \d+ \b [,.;]? (?{ 'digits' }) |
288 | | | |
289 | [a-z]+ \b [,.;]? (?{ 'lowercase' }) | |
290 | | | |
291 | [A-Z]+ \b [,.;]? (?{ 'UPPERCASE' }) | |
292 | | | |
293 | [A-Z] [a-z]+ \b [,.;]? (?{ 'Capitalized' }) | |
294 | | | |
295 | [A-Za-z]+ \b [,.;]? (?{ 'MiXeD' }) | |
296 | | | |
297 | [A-Za-z0-9]+ \b [,.;]? (?{ 'alphanumeric' }) | |
298 | | | |
299 | \s+ (?{ ' ' }) | |
300 | | | |
301 | [^A-Za-z0-9\s]+ (?{ '$@%#' }) | |
302 | }{$^R}xg; | |
e8ebd21b | 303 | ok( $_ eq $foo ); |
8e5e9ebe RGS |
304 | ok( $snum == 31 ); |
305 | ||
306 | $_ = 'a' x 6; | |
307 | $snum = s/a(?{})//g; | |
308 | ok( $_ eq '' && $snum == 6 ); | |
ce862d02 | 309 | |
2beec16e | 310 | $_ = 'x' x 20; |
e8ebd21b | 311 | $snum = s/(\d*|x)/<$1>/g; |
2beec16e | 312 | $foo = '<>' . ('<x><>' x 20) ; |
e8ebd21b | 313 | ok( $_ eq $foo && $snum == 41 ); |
ad94a511 IZ |
314 | |
315 | $t = 'aaaaaaaaa'; | |
316 | ||
317 | $_ = $t; | |
318 | pos = 6; | |
e8ebd21b RGS |
319 | $snum = s/\Ga/xx/g; |
320 | ok( $_ eq 'aaaaaaxxxxxx' && $snum == 3 ); | |
ad94a511 IZ |
321 | |
322 | $_ = $t; | |
323 | pos = 6; | |
e8ebd21b RGS |
324 | $snum = s/\Ga/x/g; |
325 | ok( $_ eq 'aaaaaaxxx' && $snum == 3 ); | |
ad94a511 IZ |
326 | |
327 | $_ = $t; | |
328 | pos = 6; | |
329 | s/\Ga/xx/; | |
e8ebd21b | 330 | ok( $_ eq 'aaaaaaxxaa' ); |
ad94a511 IZ |
331 | |
332 | $_ = $t; | |
333 | pos = 6; | |
334 | s/\Ga/x/; | |
e8ebd21b | 335 | ok( $_ eq 'aaaaaaxaa' ); |
ad94a511 IZ |
336 | |
337 | $_ = $t; | |
e8ebd21b RGS |
338 | $snum = s/\Ga/xx/g; |
339 | ok( $_ eq 'xxxxxxxxxxxxxxxxxx' && $snum == 9 ); | |
ad94a511 IZ |
340 | |
341 | $_ = $t; | |
e8ebd21b RGS |
342 | $snum = s/\Ga/x/g; |
343 | ok( $_ eq 'xxxxxxxxx' && $snum == 9 ); | |
ad94a511 IZ |
344 | |
345 | $_ = $t; | |
346 | s/\Ga/xx/; | |
e8ebd21b | 347 | ok( $_ eq 'xxaaaaaaaa' ); |
ad94a511 IZ |
348 | |
349 | $_ = $t; | |
350 | s/\Ga/x/; | |
e8ebd21b | 351 | ok( $_ eq 'xaaaaaaaa' ); |
ad94a511 | 352 | |
f5c9036e | 353 | $_ = 'aaaa'; |
e8ebd21b RGS |
354 | $snum = s/\ba/./g; |
355 | ok( $_ eq '.aaa' && $snum == 1 ); | |
ad94a511 | 356 | |
e9fa98b2 | 357 | eval q% s/a/"b"}/e %; |
e8ebd21b | 358 | ok( $@ =~ /Bad evalled substitution/ ); |
e9fa98b2 | 359 | eval q% ($_ = "x") =~ s/(.)/"$1 "/e %; |
e8ebd21b | 360 | ok( $_ eq "x " and !length $@ ); |
43a16006 HS |
361 | $x = $x = 'interp'; |
362 | eval q% ($_ = "x") =~ s/x(($x)*)/"$1"/e %; | |
e8ebd21b | 363 | ok( $_ eq '' and !length $@ ); |
e9fa98b2 | 364 | |
653099ff | 365 | $_ = "C:/"; |
e8ebd21b | 366 | ok( !s/^([a-z]:)/\u$1/ ); |
e9fa98b2 | 367 | |
12d33761 | 368 | $_ = "Charles Bronson"; |
e8ebd21b RGS |
369 | $snum = s/\B\w//g; |
370 | ok( $_ eq "C B" && $snum == 12 ); | |
5b71a6a7 A |
371 | |
372 | { | |
373 | use utf8; | |
374 | my $s = "H\303\266he"; | |
375 | my $l = my $r = $s; | |
376 | $l =~ s/[^\w]//g; | |
377 | $r =~ s/[^\w\.]//g; | |
aefe6dfc | 378 | is($l, $r, "use utf8 \\w"); |
5b71a6a7 | 379 | } |
89afcb60 A |
380 | |
381 | my $pv1 = my $pv2 = "Andreas J. K\303\266nig"; | |
382 | $pv1 =~ s/A/\x{100}/; | |
383 | substr($pv2,0,1) = "\x{100}"; | |
384 | is($pv1, $pv2); | |
aefe6dfc | 385 | |
8e9639e9 JH |
386 | SKIP: { |
387 | skip("EBCDIC", 3) if ord("A") == 193; | |
388 | ||
389 | { | |
390 | # Gregor Chrupala <gregor.chrupala@star-group.net> | |
391 | use utf8; | |
392 | $a = 'España'; | |
393 | $a =~ s/ñ/ñ/; | |
394 | like($a, qr/ñ/, "use utf8 RHS"); | |
395 | } | |
396 | ||
397 | { | |
398 | use utf8; | |
399 | $a = 'España España'; | |
400 | $a =~ s/ñ/ñ/; | |
401 | like($a, qr/ñ/, "use utf8 LHS"); | |
402 | } | |
403 | ||
404 | { | |
405 | use utf8; | |
406 | $a = 'España'; | |
407 | $a =~ s/ñ/ñ/; | |
408 | like($a, qr/ñ/, "use utf8 LHS and RHS"); | |
409 | } | |
aefe6dfc JH |
410 | } |
411 | ||
8514a05a JH |
412 | { |
413 | # SADAHIRO Tomoyuki <bqw10602@nifty.com> | |
414 | ||
415 | $a = "\x{100}\x{101}"; | |
416 | $a =~ s/\x{101}/\xFF/; | |
417 | like($a, qr/\xFF/); | |
4a176938 | 418 | is(length($a), 2, "SADAHIRO utf8 s///"); |
8514a05a JH |
419 | |
420 | $a = "\x{100}\x{101}"; | |
421 | $a =~ s/\x{101}/"\xFF"/e; | |
422 | like($a, qr/\xFF/); | |
423 | is(length($a), 2); | |
424 | ||
425 | $a = "\x{100}\x{101}"; | |
426 | $a =~ s/\x{101}/\xFF\xFF\xFF/; | |
427 | like($a, qr/\xFF\xFF\xFF/); | |
428 | is(length($a), 4); | |
429 | ||
430 | $a = "\x{100}\x{101}"; | |
431 | $a =~ s/\x{101}/"\xFF\xFF\xFF"/e; | |
432 | like($a, qr/\xFF\xFF\xFF/); | |
433 | is(length($a), 4); | |
434 | ||
435 | $a = "\xFF\x{101}"; | |
436 | $a =~ s/\xFF/\x{100}/; | |
437 | like($a, qr/\x{100}/); | |
438 | is(length($a), 2); | |
439 | ||
440 | $a = "\xFF\x{101}"; | |
441 | $a =~ s/\xFF/"\x{100}"/e; | |
442 | like($a, qr/\x{100}/); | |
443 | is(length($a), 2); | |
444 | ||
445 | $a = "\xFF"; | |
446 | $a =~ s/\xFF/\x{100}/; | |
447 | like($a, qr/\x{100}/); | |
448 | is(length($a), 1); | |
449 | ||
450 | $a = "\xFF"; | |
451 | $a =~ s/\xFF/"\x{100}"/e; | |
452 | like($a, qr/\x{100}/); | |
453 | is(length($a), 1); | |
454 | } | |
d6d0e86e HS |
455 | |
456 | { | |
457 | # subst with mixed utf8/non-utf8 type | |
458 | my($ua, $ub, $uc, $ud) = ("\x{101}", "\x{102}", "\x{103}", "\x{104}"); | |
459 | my($na, $nb) = ("\x{ff}", "\x{fe}"); | |
460 | my $a = "$ua--$ub"; | |
461 | my $b; | |
462 | ($b = $a) =~ s/--/$na/; | |
463 | is($b, "$ua$na$ub", "s///: replace non-utf8 into utf8"); | |
464 | ($b = $a) =~ s/--/--$na--/; | |
465 | is($b, "$ua--$na--$ub", "s///: replace long non-utf8 into utf8"); | |
466 | ($b = $a) =~ s/--/$uc/; | |
467 | is($b, "$ua$uc$ub", "s///: replace utf8 into utf8"); | |
468 | ($b = $a) =~ s/--/--$uc--/; | |
469 | is($b, "$ua--$uc--$ub", "s///: replace long utf8 into utf8"); | |
470 | $a = "$na--$nb"; | |
471 | ($b = $a) =~ s/--/$ua/; | |
472 | is($b, "$na$ua$nb", "s///: replace utf8 into non-utf8"); | |
473 | ($b = $a) =~ s/--/--$ua--/; | |
474 | is($b, "$na--$ua--$nb", "s///: replace long utf8 into non-utf8"); | |
475 | ||
476 | # now with utf8 pattern | |
477 | $a = "$ua--$ub"; | |
478 | ($b = $a) =~ s/-($ud)?-/$na/; | |
479 | is($b, "$ua$na$ub", "s///: replace non-utf8 into utf8 (utf8 pattern)"); | |
480 | ($b = $a) =~ s/-($ud)?-/--$na--/; | |
481 | is($b, "$ua--$na--$ub", "s///: replace long non-utf8 into utf8 (utf8 pattern)"); | |
482 | ($b = $a) =~ s/-($ud)?-/$uc/; | |
483 | is($b, "$ua$uc$ub", "s///: replace utf8 into utf8 (utf8 pattern)"); | |
484 | ($b = $a) =~ s/-($ud)?-/--$uc--/; | |
485 | is($b, "$ua--$uc--$ub", "s///: replace long utf8 into utf8 (utf8 pattern)"); | |
486 | $a = "$na--$nb"; | |
487 | ($b = $a) =~ s/-($ud)?-/$ua/; | |
488 | is($b, "$na$ua$nb", "s///: replace utf8 into non-utf8 (utf8 pattern)"); | |
489 | ($b = $a) =~ s/-($ud)?-/--$ua--/; | |
490 | is($b, "$na--$ua--$nb", "s///: replace long utf8 into non-utf8 (utf8 pattern)"); | |
491 | ($b = $a) =~ s/-($ud)?-/$na/; | |
492 | is($b, "$na$na$nb", "s///: replace non-utf8 into non-utf8 (utf8 pattern)"); | |
493 | ($b = $a) =~ s/-($ud)?-/--$na--/; | |
494 | is($b, "$na--$na--$nb", "s///: replace long non-utf8 into non-utf8 (utf8 pattern)"); | |
495 | } | |
496 | ||
6c8d78fb HS |
497 | $_ = 'aaaa'; |
498 | $r = 'x'; | |
499 | $s = s/a(?{})/$r/g; | |
f14c76ed | 500 | is("<$_> <$s>", "<xxxx> <4>", "[perl #7806]"); |
6c8d78fb HS |
501 | |
502 | $_ = 'aaaa'; | |
503 | $s = s/a(?{})//g; | |
f14c76ed | 504 | is("<$_> <$s>", "<> <4>", "[perl #7806]"); |
6c8d78fb | 505 | |
f14c76ed RGS |
506 | # [perl #19048] Coredump in silly replacement |
507 | { | |
508 | local $^W = 0; | |
509 | $_="abcdef\n"; | |
510 | s!.!!eg; | |
511 | is($_, "\n", "[perl #19048]"); | |
512 | } | |
513 | ||
4addbd3b HS |
514 | # [perl #17757] interaction between saw_ampersand and study |
515 | { | |
516 | my $f = eval q{ $& }; | |
517 | $f = "xx"; | |
518 | study $f; | |
519 | $f =~ s/x/y/g; | |
520 | is($f, "yy", "[perl #17757]"); | |
521 | } | |
22e13caa AE |
522 | |
523 | # [perl #20684] returned a zero count | |
524 | $_ = "1111"; | |
525 | is(s/(??{1})/2/eg, 4, '#20684 s/// with (??{..}) inside'); | |
526 | ||
83b43d92 AE |
527 | # [perl #20682] @- not visible in replacement |
528 | $_ = "123"; | |
529 | /(2)/; # seed @- with something else | |
530 | s/(1)(2)(3)/$#- (@-)/; | |
531 | is($_, "3 (0 0 1 2)", '#20682 @- not visible in replacement'); | |
532 | ||
76ec6486 AE |
533 | # [perl #20682] $^N not visible in replacement |
534 | $_ = "abc"; | |
535 | /(a)/; s/(b)|(c)/-$^N/g; | |
536 | is($_,'a-b-c','#20682 $^N not visible in replacement'); | |
7357df17 JH |
537 | |
538 | # [perl #22351] perl bug with 'e' substitution modifier | |
539 | my $name = "chris"; | |
540 | { | |
541 | no warnings 'uninitialized'; | |
542 | $name =~ s/hr//e; | |
543 | } | |
544 | is($name, "cis", q[#22351 bug with 'e' substitution modifier]); | |
01b35787 DM |
545 | |
546 | ||
547 | # [perl #34171] $1 didn't honour 'use bytes' in s//e | |
548 | { | |
549 | my $s="\x{100}"; | |
550 | my $x; | |
551 | { | |
552 | use bytes; | |
553 | $s=~ s/(..)/$x=$1/e | |
554 | } | |
555 | is(length($x), 2, '[perl #34171]'); | |
556 | } | |
557 | ||
558 | ||
1749ea0d TS |
559 | { # [perl #27940] perlbug: [\x00-\x1f] works, [\c@-\c_] does not |
560 | my $c; | |
561 | ||
562 | ($c = "\x20\c@\x30\cA\x40\cZ\x50\c_\x60") =~ s/[\c@-\c_]//g; | |
563 | is($c, "\x20\x30\x40\x50\x60", "s/[\\c\@-\\c_]//g"); | |
564 | ||
565 | ($c = "\x20\x00\x30\x01\x40\x1A\x50\x1F\x60") =~ s/[\x00-\x1f]//g; | |
566 | is($c, "\x20\x30\x40\x50\x60", "s/[\\x00-\\x1f]//g"); | |
567 | } | |
3be69782 | 568 | { |
f0852a51 YO |
569 | $_ = "xy"; |
570 | no warnings 'uninitialized'; | |
571 | /(((((((((x)))))))))(z)/; # clear $10 | |
572 | s/(((((((((x)))))))))(y)/${10}/; | |
573 | is($_,"y","RT#6006: \$_ eq '$_'"); | |
3be69782 RGS |
574 | $_ = "xr"; |
575 | s/(((((((((x)))))))))(r)/fooba${10}/; | |
576 | is($_,"foobar","RT#6006: \$_ eq '$_'"); | |
f0852a51 | 577 | } |
336b1602 YO |
578 | { |
579 | my $want=("\n" x 11).("B\n" x 11)."B"; | |
580 | $_="B"; | |
581 | our $i; | |
582 | for $i(1..11){ | |
583 | s/^.*$/$&/gm; | |
584 | $_="\n$_\n$&"; | |
585 | } | |
586 | is($want,$_,"RT#17542"); | |
587 | } | |
1749ea0d | 588 | |
ce474962 NC |
589 | { |
590 | my @tests = ('ABC', "\xA3\xA4\xA5", "\x{410}\x{411}\x{412}"); | |
591 | foreach (@tests) { | |
592 | my $id = ord $_; | |
593 | s/./pos/ge; | |
594 | is($_, "012", "RT#52104: $id"); | |
595 | } | |
596 | } | |
831a7dd7 MM |
597 | |
598 | fresh_perl_is( '$_=q(foo);s/(.)\G//g;print' => 'foo', '[perl #69056] positive GPOS regex segfault' ); | |
2c296965 | 599 | fresh_perl_is( '$_="abcef"; s/bc|(.)\G(.)/$1 ? "[$1-$2]" : "XX"/ge; print' => 'aXX[c-e][e-f]f', 'positive GPOS regex substitution failure' ); |
831a7dd7 | 600 | |
455d9033 FC |
601 | # [perl #~~~~~] $var =~ s/$qr//e calling get-magic on $_ as well as $var |
602 | { | |
603 | local *_; | |
604 | my $scratch; | |
605 | sub qrBug::TIESCALAR { bless[pop], 'qrBug' } | |
606 | sub qrBug::FETCH { $scratch .= "[fetching $_[0][0]]"; 'prew' } | |
607 | sub qrBug::STORE{} | |
608 | tie my $kror, qrBug => '$kror'; | |
609 | tie $_, qrBug => '$_'; | |
610 | my $qr = qr/(?:)/; | |
611 | $kror =~ s/$qr/""/e; | |
612 | is( | |
613 | $scratch, '[fetching $kror]', | |
614 | 'bug: $var =~ s/$qr//e calling get-magic on $_ as well as $var', | |
615 | ); | |
616 | } | |
3e462cdc KW |
617 | |
618 | { # Bug #41530; replacing non-utf8 with a utf8 causes problems | |
619 | my $string = "a\x{a0}a"; | |
620 | my $sub_string = $string; | |
621 | ok(! utf8::is_utf8($sub_string), "Verify that string isn't initially utf8"); | |
622 | $sub_string =~ s/a/\x{100}/g; | |
623 | ok(utf8::is_utf8($sub_string), | |
624 | 'Verify replace of non-utf8 with utf8 upgrades to utf8'); | |
625 | is($sub_string, "\x{100}\x{A0}\x{100}", | |
626 | 'Verify #41530 fixed: replace of non-utf8 with utf8'); | |
627 | ||
628 | my $non_sub_string = $string; | |
629 | ok(! utf8::is_utf8($non_sub_string), | |
630 | "Verify that string isn't initially utf8"); | |
631 | $non_sub_string =~ s/b/\x{100}/g; | |
632 | ok(! utf8::is_utf8($non_sub_string), | |
633 | "Verify that failed substitute doesn't change string's utf8ness"); | |
634 | is($non_sub_string, $string, | |
635 | "Verify that failed substitute doesn't change string"); | |
636 | } |