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'; |
84bb2957 | 10 | plan( tests => 170 ); |
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'; | |
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 LW |
90 | |
91 | $x = 'foo'; | |
92 | $_ = "x"; | |
93 | s/x/\$x/; | |
e8ebd21b | 94 | ok( $_ eq '$x', ":$_: eq :\$x:" ); |
d9d8d8de LW |
95 | |
96 | $_ = "x"; | |
97 | s/x/$x/; | |
e8ebd21b | 98 | ok( $_ eq 'foo', ":$_: eq :foo:" ); |
d9d8d8de LW |
99 | |
100 | $_ = "x"; | |
101 | s/x/\$x $x/; | |
e8ebd21b | 102 | ok( $_ eq '$x foo', ":$_: eq :\$x foo:" ); |
d9d8d8de LW |
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 LW |
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 LW |
114 | |
115 | $_ = 'ABACADA'; | |
e8ebd21b | 116 | ok( /a/i && s///gi && $_ eq 'BCD' ); |
d9d8d8de LW |
117 | |
118 | $_ = '\\' x 4; | |
e8ebd21b RGS |
119 | ok( length($_) == 4 ); |
120 | $snum = s/\\/\\\\/g; | |
121 | ok( $_ eq '\\' x 8 && $snum == 4 ); | |
d9d8d8de LW |
122 | |
123 | $_ = '\/' x 4; | |
e8ebd21b RGS |
124 | ok( length($_) == 8 ); |
125 | $snum = s/\//\/\//g; | |
126 | ok( $_ eq '\\//' x 4 && $snum == 4 ); | |
127 | ok( length($_) == 12 ); | |
d9d8d8de LW |
128 | |
129 | $_ = 'aaaXXXXbbb'; | |
130 | s/^a//; | |
e8ebd21b | 131 | ok( $_ eq 'aaXXXXbbb' ); |
d9d8d8de LW |
132 | |
133 | $_ = 'aaaXXXXbbb'; | |
134 | s/a//; | |
e8ebd21b | 135 | ok( $_ eq 'aaXXXXbbb' ); |
d9d8d8de LW |
136 | |
137 | $_ = 'aaaXXXXbbb'; | |
138 | s/^a/b/; | |
e8ebd21b | 139 | ok( $_ eq 'baaXXXXbbb' ); |
d9d8d8de LW |
140 | |
141 | $_ = 'aaaXXXXbbb'; | |
142 | s/a/b/; | |
e8ebd21b | 143 | ok( $_ eq 'baaXXXXbbb' ); |
d9d8d8de LW |
144 | |
145 | $_ = 'aaaXXXXbbb'; | |
146 | s/aa//; | |
e8ebd21b | 147 | ok( $_ eq 'aXXXXbbb' ); |
d9d8d8de LW |
148 | |
149 | $_ = 'aaaXXXXbbb'; | |
150 | s/aa/b/; | |
e8ebd21b | 151 | ok( $_ eq 'baXXXXbbb' ); |
d9d8d8de LW |
152 | |
153 | $_ = 'aaaXXXXbbb'; | |
154 | s/b$//; | |
e8ebd21b | 155 | ok( $_ eq 'aaaXXXXbb' ); |
d9d8d8de LW |
156 | |
157 | $_ = 'aaaXXXXbbb'; | |
158 | s/b//; | |
e8ebd21b | 159 | ok( $_ eq 'aaaXXXXbb' ); |
d9d8d8de LW |
160 | |
161 | $_ = 'aaaXXXXbbb'; | |
162 | s/bb//; | |
e8ebd21b | 163 | ok( $_ eq 'aaaXXXXb' ); |
d9d8d8de LW |
164 | |
165 | $_ = 'aaaXXXXbbb'; | |
166 | s/aX/y/; | |
e8ebd21b | 167 | ok( $_ eq 'aayXXXbbb' ); |
d9d8d8de LW |
168 | |
169 | $_ = 'aaaXXXXbbb'; | |
170 | s/Xb/z/; | |
e8ebd21b | 171 | ok( $_ eq 'aaaXXXzbb' ); |
d9d8d8de LW |
172 | |
173 | $_ = 'aaaXXXXbbb'; | |
174 | s/aaX.*Xbb//; | |
e8ebd21b | 175 | ok( $_ eq 'ab' ); |
d9d8d8de LW |
176 | |
177 | $_ = 'aaaXXXXbbb'; | |
178 | s/bb/x/; | |
e8ebd21b | 179 | ok( $_ eq 'aaaXXXXxb' ); |
d9d8d8de LW |
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 LW |
186 | |
187 | $_ = 'aaaXXXXbbb'; | |
188 | $x ne $x || s/a//; | |
e8ebd21b | 189 | ok( $_ eq 'aaXXXXbbb' ); |
d9d8d8de LW |
190 | |
191 | $_ = 'aaaXXXXbbb'; | |
192 | $x ne $x || s/^a/b/; | |
e8ebd21b | 193 | ok( $_ eq 'baaXXXXbbb' ); |
d9d8d8de LW |
194 | |
195 | $_ = 'aaaXXXXbbb'; | |
196 | $x ne $x || s/a/b/; | |
e8ebd21b | 197 | ok( $_ eq 'baaXXXXbbb' ); |
d9d8d8de LW |
198 | |
199 | $_ = 'aaaXXXXbbb'; | |
200 | $x ne $x || s/aa//; | |
e8ebd21b | 201 | ok( $_ eq 'aXXXXbbb' ); |
d9d8d8de LW |
202 | |
203 | $_ = 'aaaXXXXbbb'; | |
204 | $x ne $x || s/aa/b/; | |
e8ebd21b | 205 | ok( $_ eq 'baXXXXbbb' ); |
d9d8d8de LW |
206 | |
207 | $_ = 'aaaXXXXbbb'; | |
208 | $x ne $x || s/b$//; | |
e8ebd21b | 209 | ok( $_ eq 'aaaXXXXbb' ); |
d9d8d8de LW |
210 | |
211 | $_ = 'aaaXXXXbbb'; | |
212 | $x ne $x || s/b//; | |
e8ebd21b | 213 | ok( $_ eq 'aaaXXXXbb' ); |
d9d8d8de LW |
214 | |
215 | $_ = 'aaaXXXXbbb'; | |
216 | $x ne $x || s/bb//; | |
e8ebd21b | 217 | ok( $_ eq 'aaaXXXXb' ); |
d9d8d8de LW |
218 | |
219 | $_ = 'aaaXXXXbbb'; | |
220 | $x ne $x || s/aX/y/; | |
e8ebd21b | 221 | ok( $_ eq 'aayXXXbbb' ); |
d9d8d8de LW |
222 | |
223 | $_ = 'aaaXXXXbbb'; | |
224 | $x ne $x || s/Xb/z/; | |
e8ebd21b | 225 | ok( $_ eq 'aaaXXXzbb' ); |
d9d8d8de LW |
226 | |
227 | $_ = 'aaaXXXXbbb'; | |
228 | $x ne $x || s/aaX.*Xbb//; | |
e8ebd21b | 229 | ok( $_ eq 'ab' ); |
d9d8d8de LW |
230 | |
231 | $_ = 'aaaXXXXbbb'; | |
232 | $x ne $x || s/bb/x/; | |
e8ebd21b | 233 | ok( $_ eq 'aaaXXXXxb' ); |
d9d8d8de LW |
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 LW |
242 | |
243 | $_ = "aaaaa"; | |
e8ebd21b RGS |
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 LW |
251 | |
252 | $_ = "Now is the %#*! time for all good men..."; | |
e8ebd21b RGS |
253 | ok( ($x=(y/a-zA-Z //cd)) == 7 ); |
254 | ok( y/ / /s == 8 ); | |
d9d8d8de | 255 | |
79072805 LW |
256 | $_ = 'abcdefghijklmnopqrstuvwxyz0123456789'; |
257 | tr/a-z/A-Z/; | |
258 | ||
e8ebd21b | 259 | ok( $_ eq 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789' ); |
79072805 LW |
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 JH |
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 RGS |
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 LW |
280 | |
281 | $_ = '+,-'; | |
282 | tr/+\--/a\/c/; | |
e8ebd21b | 283 | ok( $_ eq 'a,/' ); |
79072805 LW |
284 | |
285 | $_ = '+,-'; | |
286 | tr/-+,/ab\-/; | |
e8ebd21b | 287 | ok( $_ eq 'b-a' ); |
843b4603 TB |
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 RGS |
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 TB |
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 IZ |
319 | # Subst and lookbehind |
320 | ||
321 | $_="ccccc"; | |
e8ebd21b RGS |
322 | $snum = s/(?<!x)c/x/g; |
323 | ok( $_ eq "xxxxx" && $snum == 5 ); | |
c277df42 IZ |
324 | |
325 | $_="ccccc"; | |
e8ebd21b RGS |
326 | $snum = s/(?<!x)(c)/x/g; |
327 | ok( $_ eq "xxxxx" && $snum == 5 ); | |
c277df42 IZ |
328 | |
329 | $_="foobbarfoobbar"; | |
e8ebd21b RGS |
330 | $snum = s/(?<!r)foobbar/foobar/g; |
331 | ok( $_ eq "foobarfoobbar" && $snum == 1 ); | |
c277df42 IZ |
332 | |
333 | $_="foobbarfoobbar"; | |
e8ebd21b RGS |
334 | $snum = s/(?<!ar)(foobbar)/foobar/g; |
335 | ok( $_ eq "foobarfoobbar" && $snum == 1 ); | |
c277df42 IZ |
336 | |
337 | $_="foobbarfoobbar"; | |
e8ebd21b RGS |
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 DN |
345 | $snum = eval '$_="exactly"; s sxsys;m 3(yactl)3;$1'; |
346 | is( $snum, 'yactl', 'alpha delimiters are allowed' ); | |
347 | ||
f3ea7b5e | 348 | $_="baacbaa"; |
e8ebd21b RGS |
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 IZ |
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 IZ |
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 RGS |
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 IZ |
393 | |
394 | $t = 'aaaaaaaaa'; | |
395 | ||
396 | $_ = $t; | |
397 | pos = 6; | |
e8ebd21b RGS |
398 | $snum = s/\Ga/xx/g; |
399 | ok( $_ eq 'aaaaaaxxxxxx' && $snum == 3 ); | |
ad94a511 IZ |
400 | |
401 | $_ = $t; | |
402 | pos = 6; | |
e8ebd21b RGS |
403 | $snum = s/\Ga/x/g; |
404 | ok( $_ eq 'aaaaaaxxx' && $snum == 3 ); | |
ad94a511 IZ |
405 | |
406 | $_ = $t; | |
407 | pos = 6; | |
408 | s/\Ga/xx/; | |
e8ebd21b | 409 | ok( $_ eq 'aaaaaaxxaa' ); |
ad94a511 IZ |
410 | |
411 | $_ = $t; | |
412 | pos = 6; | |
413 | s/\Ga/x/; | |
e8ebd21b | 414 | ok( $_ eq 'aaaaaaxaa' ); |
ad94a511 IZ |
415 | |
416 | $_ = $t; | |
e8ebd21b RGS |
417 | $snum = s/\Ga/xx/g; |
418 | ok( $_ eq 'xxxxxxxxxxxxxxxxxx' && $snum == 9 ); | |
ad94a511 IZ |
419 | |
420 | $_ = $t; | |
e8ebd21b RGS |
421 | $snum = s/\Ga/x/g; |
422 | ok( $_ eq 'xxxxxxxxx' && $snum == 9 ); | |
ad94a511 IZ |
423 | |
424 | $_ = $t; | |
425 | s/\Ga/xx/; | |
e8ebd21b | 426 | ok( $_ eq 'xxaaaaaaaa' ); |
ad94a511 IZ |
427 | |
428 | $_ = $t; | |
429 | s/\Ga/x/; | |
e8ebd21b | 430 | ok( $_ eq 'xaaaaaaaa' ); |
ad94a511 | 431 | |
f5c9036e | 432 | $_ = 'aaaa'; |
e8ebd21b RGS |
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 HS |
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 RGS |
448 | $snum = s/\B\w//g; |
449 | ok( $_ eq "C B" && $snum == 12 ); | |
5b71a6a7 A |
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 A |
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 JH |
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 JH |
489 | } |
490 | ||
8514a05a JH |
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 JH |
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 HS |
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 HS |
576 | $_ = 'aaaa'; |
577 | $r = 'x'; | |
578 | $s = s/a(?{})/$r/g; | |
f14c76ed | 579 | is("<$_> <$s>", "<xxxx> <4>", "[perl #7806]"); |
6c8d78fb HS |
580 | |
581 | $_ = 'aaaa'; | |
582 | $s = s/a(?{})//g; | |
f14c76ed | 583 | is("<$_> <$s>", "<> <4>", "[perl #7806]"); |
6c8d78fb | 584 | |
f14c76ed RGS |
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 HS |
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 AE |
601 | |
602 | # [perl #20684] returned a zero count | |
603 | $_ = "1111"; | |
604 | is(s/(??{1})/2/eg, 4, '#20684 s/// with (??{..}) inside'); | |
605 | ||
83b43d92 AE |
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 AE |
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 JH |
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 DM |
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 TS |
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 YO |
648 | $_ = "xy"; |
649 | no warnings 'uninitialized'; | |
650 | /(((((((((x)))))))))(z)/; # clear $10 | |
651 | s/(((((((((x)))))))))(y)/${10}/; | |
652 | is($_,"y","RT#6006: \$_ eq '$_'"); | |
3be69782 RGS |
653 | $_ = "xr"; |
654 | s/(((((((((x)))))))))(r)/fooba${10}/; | |
655 | is($_,"foobar","RT#6006: \$_ eq '$_'"); | |
f0852a51 | 656 | } |
336b1602 YO |
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 NC |
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 MM |
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 FC |
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 KW |
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 | } | |
84bb2957 KW |
716 | |
717 | { # Verify largish octal in replacement pattern | |
718 | ||
719 | my $string = "a"; | |
720 | $string =~ s/a/\400/; | |
721 | is($string, chr 0x100, "Verify that handles s/foo/\\400/"); | |
722 | $string =~ s/./\600/; | |
723 | is($string, chr 0x180, "Verify that handles s/foo/\\600/"); | |
724 | $string =~ s/./\777/; | |
725 | is($string, chr 0x1FF, "Verify that handles s/foo/\\777/"); | |
726 | } |