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