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