Commit | Line | Data |
---|---|---|
55b67815 | 1 | #!./perl |
84902520 TB |
2 | |
3 | #P = start of string Q = start of substr R = end of substr S = end of string | |
a687059c | 4 | |
e476b1b5 | 5 | BEGIN { |
3aa33fe5 | 6 | chdir 't' if -d 't'; |
afe0c9a9 | 7 | require './test.pl'; |
43ece5b1 | 8 | set_up_inc('../lib'); |
e476b1b5 GS |
9 | } |
10 | use warnings ; | |
84902520 | 11 | |
e476b1b5 | 12 | $a = 'abcdefxyz'; |
84902520 TB |
13 | $SIG{__WARN__} = sub { |
14 | if ($_[0] =~ /^substr outside of string/) { | |
15 | $w++; | |
16 | } elsif ($_[0] =~ /^Attempt to use reference as lvalue in substr/) { | |
17 | $w += 2; | |
5d82c453 GA |
18 | } elsif ($_[0] =~ /^Use of uninitialized value/) { |
19 | $w += 3; | |
84902520 | 20 | } else { |
5d82c453 | 21 | warn $_[0]; |
84902520 TB |
22 | } |
23 | }; | |
a687059c | 24 | |
569ddb4a | 25 | plan(388); |
e476b1b5 | 26 | |
e3faa678 NC |
27 | run_tests() unless caller; |
28 | ||
29 | my $krunch = "a"; | |
30 | ||
31 | sub run_tests { | |
32 | ||
e198f039 | 33 | $FATAL_MSG = qr/^substr outside of string/; |
84902520 | 34 | |
e198f039 NC |
35 | is(substr($a,0,3), 'abc'); # P=Q R S |
36 | is(substr($a,3,3), 'def'); # P Q R S | |
37 | is(substr($a,6,999), 'xyz'); # P Q S R | |
e476b1b5 | 38 | $b = substr($a,999,999) ; # warn # P R Q S |
e198f039 | 39 | is ($w--, 1); |
e476b1b5 | 40 | eval{substr($a,999,999) = "" ; };# P R Q S |
e198f039 NC |
41 | like ($@, $FATAL_MSG); |
42 | is(substr($a,0,-6), 'abc'); # P=Q R S | |
43 | is(substr($a,-3,1), 'x'); # P Q R S | |
f378d2d3 FC |
44 | sub{$b = shift}->(substr($a,999,999)); |
45 | is ($w--, 1, 'boundless lvalue substr only warns on fetch'); | |
a687059c | 46 | |
a687059c | 47 | substr($a,3,3) = 'XYZ'; |
e198f039 | 48 | is($a, 'abcXYZxyz' ); |
a687059c | 49 | substr($a,0,2) = ''; |
e198f039 | 50 | is($a, 'cXYZxyz' ); |
a687059c | 51 | substr($a,0,0) = 'ab'; |
e198f039 | 52 | is($a, 'abcXYZxyz' ); |
a687059c | 53 | substr($a,0,0) = '12345678'; |
e198f039 | 54 | is($a, '12345678abcXYZxyz' ); |
a687059c | 55 | substr($a,-3,3) = 'def'; |
e198f039 | 56 | is($a, '12345678abcXYZdef'); |
a687059c | 57 | substr($a,-3,3) = '<'; |
e198f039 | 58 | is($a, '12345678abcXYZ<' ); |
a687059c | 59 | substr($a,-1,1) = '12345678'; |
e198f039 | 60 | is($a, '12345678abcXYZ12345678' ); |
a687059c | 61 | |
d9d8d8de LW |
62 | $a = 'abcdefxyz'; |
63 | ||
e198f039 NC |
64 | is(substr($a,6), 'xyz' ); # P Q R=S |
65 | is(substr($a,-3), 'xyz' ); # P Q R=S | |
e476b1b5 | 66 | $b = substr($a,999,999) ; # warning # P R=S Q |
e198f039 | 67 | is($w--, 1); |
e476b1b5 | 68 | eval{substr($a,999,999) = "" ; } ; # P R=S Q |
e198f039 NC |
69 | like($@, $FATAL_MSG); |
70 | is(substr($a,0), 'abcdefxyz'); # P=Q R=S | |
71 | is(substr($a,9), ''); # P Q=R=S | |
72 | is(substr($a,-11), 'abcdefxyz'); # Q P R=S | |
73 | is(substr($a,-9), 'abcdefxyz'); # P=Q R=S | |
84902520 TB |
74 | |
75 | $a = '54321'; | |
76 | ||
e476b1b5 | 77 | $b = substr($a,-7, 1) ; # warn # Q R P S |
e198f039 | 78 | is($w--, 1); |
e476b1b5 | 79 | eval{substr($a,-7, 1) = "" ; }; # Q R P S |
e198f039 | 80 | like($@, $FATAL_MSG); |
e476b1b5 | 81 | $b = substr($a,-7,-6) ; # warn # Q R P S |
e198f039 | 82 | is($w--, 1); |
e476b1b5 | 83 | eval{substr($a,-7,-6) = "" ; }; # Q R P S |
e198f039 NC |
84 | like($@, $FATAL_MSG); |
85 | is(substr($a,-5,-7), ''); # R P=Q S | |
86 | is(substr($a, 2,-7), ''); # R P Q S | |
87 | is(substr($a,-3,-7), ''); # R P Q S | |
88 | is(substr($a, 2,-5), ''); # P=R Q S | |
89 | is(substr($a,-3,-5), ''); # P=R Q S | |
90 | is(substr($a, 2,-4), ''); # P R Q S | |
91 | is(substr($a,-3,-4), ''); # P R Q S | |
92 | is(substr($a, 5,-6), ''); # R P Q=S | |
93 | is(substr($a, 5,-5), ''); # P=R Q S | |
94 | is(substr($a, 5,-3), ''); # P R Q=S | |
e476b1b5 | 95 | $b = substr($a, 7,-7) ; # warn # R P S Q |
e198f039 | 96 | is($w--, 1); |
e476b1b5 | 97 | eval{substr($a, 7,-7) = "" ; }; # R P S Q |
e198f039 | 98 | like($@, $FATAL_MSG); |
e476b1b5 | 99 | $b = substr($a, 7,-5) ; # warn # P=R S Q |
e198f039 | 100 | is($w--, 1); |
e476b1b5 | 101 | eval{substr($a, 7,-5) = "" ; }; # P=R S Q |
e198f039 | 102 | like($@, $FATAL_MSG); |
e476b1b5 | 103 | $b = substr($a, 7,-3) ; # warn # P Q S Q |
e198f039 | 104 | is($w--, 1); |
e476b1b5 | 105 | eval{substr($a, 7,-3) = "" ; }; # P Q S Q |
e198f039 | 106 | like($@, $FATAL_MSG); |
e476b1b5 | 107 | $b = substr($a, 7, 0) ; # warn # P S Q=R |
e198f039 | 108 | is($w--, 1); |
e476b1b5 | 109 | eval{substr($a, 7, 0) = "" ; }; # P S Q=R |
e198f039 NC |
110 | like($@, $FATAL_MSG); |
111 | ||
112 | is(substr($a,-7,2), ''); # Q P=R S | |
113 | is(substr($a,-7,4), '54'); # Q P R S | |
114 | is(substr($a,-7,7), '54321');# Q P R=S | |
115 | is(substr($a,-7,9), '54321');# Q P S R | |
116 | is(substr($a,-5,0), ''); # P=Q=R S | |
117 | is(substr($a,-5,3), '543');# P=Q R S | |
118 | is(substr($a,-5,5), '54321');# P=Q R=S | |
119 | is(substr($a,-5,7), '54321');# P=Q S R | |
120 | is(substr($a,-3,0), ''); # P Q=R S | |
121 | is(substr($a,-3,3), '321');# P Q R=S | |
122 | is(substr($a,-2,3), '21'); # P Q S R | |
123 | is(substr($a,0,-5), ''); # P=Q=R S | |
124 | is(substr($a,2,-3), ''); # P Q=R S | |
125 | is(substr($a,0,0), ''); # P=Q=R S | |
126 | is(substr($a,0,5), '54321');# P=Q R=S | |
127 | is(substr($a,0,7), '54321');# P=Q S R | |
128 | is(substr($a,2,0), ''); # P Q=R S | |
129 | is(substr($a,2,3), '321'); # P Q R=S | |
130 | is(substr($a,5,0), ''); # P Q=R=S | |
131 | is(substr($a,5,2), ''); # P Q=S R | |
132 | is(substr($a,-7,-5), ''); # Q P=R S | |
133 | is(substr($a,-7,-2), '543');# Q P R S | |
134 | is(substr($a,-5,-5), ''); # P=Q=R S | |
135 | is(substr($a,-5,-2), '543');# P=Q R S | |
136 | is(substr($a,-3,-3), ''); # P Q=R S | |
137 | is(substr($a,-3,-1), '32');# P Q R S | |
84902520 TB |
138 | |
139 | $a = ''; | |
140 | ||
e198f039 NC |
141 | is(substr($a,-2,2), ''); # Q P=R=S |
142 | is(substr($a,0,0), ''); # P=Q=R=S | |
143 | is(substr($a,0,1), ''); # P=Q=S R | |
144 | is(substr($a,-2,3), ''); # Q P=S R | |
145 | is(substr($a,-2), ''); # Q P=R=S | |
146 | is(substr($a,0), ''); # P=Q=R=S | |
e476b1b5 GS |
147 | |
148 | ||
e198f039 | 149 | is(substr($a,0,-1), ''); # R P=Q=S |
e476b1b5 | 150 | $b = substr($a,-2, 0) ; # warn # Q=R P=S |
e198f039 | 151 | is($w--, 1); |
e476b1b5 | 152 | eval{substr($a,-2, 0) = "" ; }; # Q=R P=S |
e198f039 | 153 | like($@, $FATAL_MSG); |
84902520 | 154 | |
e476b1b5 | 155 | $b = substr($a,-2, 1) ; # warn # Q R P=S |
e198f039 | 156 | is($w--, 1); |
e476b1b5 | 157 | eval{substr($a,-2, 1) = "" ; }; # Q R P=S |
e198f039 | 158 | like($@, $FATAL_MSG); |
84902520 | 159 | |
e476b1b5 | 160 | $b = substr($a,-2,-1) ; # warn # Q R P=S |
e198f039 | 161 | is($w--, 1); |
e476b1b5 | 162 | eval{substr($a,-2,-1) = "" ; }; # Q R P=S |
e198f039 | 163 | like($@, $FATAL_MSG); |
84902520 | 164 | |
e476b1b5 | 165 | $b = substr($a,-2,-2) ; # warn # Q=R P=S |
e198f039 | 166 | is($w--, 1); |
e476b1b5 | 167 | eval{substr($a,-2,-2) = "" ; }; # Q=R P=S |
e198f039 | 168 | like($@, $FATAL_MSG); |
e476b1b5 GS |
169 | |
170 | $b = substr($a, 1,-2) ; # warn # R P=S Q | |
e198f039 | 171 | is($w--, 1); |
e476b1b5 | 172 | eval{substr($a, 1,-2) = "" ; }; # R P=S Q |
e198f039 | 173 | like($@, $FATAL_MSG); |
e476b1b5 GS |
174 | |
175 | $b = substr($a, 1, 1) ; # warn # P=S Q R | |
e198f039 | 176 | is($w--, 1); |
e476b1b5 | 177 | eval{substr($a, 1, 1) = "" ; }; # P=S Q R |
e198f039 | 178 | like($@, $FATAL_MSG); |
e476b1b5 GS |
179 | |
180 | $b = substr($a, 1, 0) ;# warn # P=S Q=R | |
e198f039 | 181 | is($w--, 1); |
e476b1b5 | 182 | eval{substr($a, 1, 0) = "" ; }; # P=S Q=R |
e198f039 | 183 | like($@, $FATAL_MSG); |
e476b1b5 GS |
184 | |
185 | $b = substr($a,1) ; # warning # P=R=S Q | |
e198f039 | 186 | is($w--, 1); |
e476b1b5 | 187 | eval{substr($a,1) = "" ; }; # P=R=S Q |
e198f039 | 188 | like($@, $FATAL_MSG); |
84902520 | 189 | |
777f7c56 EB |
190 | $b = substr($a,-7,-6) ; # warn # Q R P S |
191 | is($w--, 1); | |
192 | eval{substr($a,-7,-6) = "" ; }; # Q R P S | |
193 | like($@, $FATAL_MSG); | |
194 | ||
84902520 TB |
195 | my $a = 'zxcvbnm'; |
196 | substr($a,2,0) = ''; | |
e198f039 | 197 | is($a, 'zxcvbnm'); |
84902520 | 198 | substr($a,7,0) = ''; |
e198f039 | 199 | is($a, 'zxcvbnm'); |
84902520 | 200 | substr($a,5,0) = ''; |
e198f039 | 201 | is($a, 'zxcvbnm'); |
84902520 | 202 | substr($a,0,2) = 'pq'; |
e198f039 | 203 | is($a, 'pqcvbnm'); |
84902520 | 204 | substr($a,2,0) = 'r'; |
e198f039 | 205 | is($a, 'pqrcvbnm'); |
84902520 | 206 | substr($a,8,0) = 'asd'; |
e198f039 | 207 | is($a, 'pqrcvbnmasd'); |
84902520 | 208 | substr($a,0,2) = 'iop'; |
e198f039 | 209 | is($a, 'ioprcvbnmasd'); |
84902520 | 210 | substr($a,0,5) = 'fgh'; |
e198f039 | 211 | is($a, 'fghvbnmasd'); |
84902520 | 212 | substr($a,3,5) = 'jkl'; |
e198f039 | 213 | is($a, 'fghjklsd'); |
84902520 | 214 | substr($a,3,2) = '1234'; |
e198f039 | 215 | is($a, 'fgh1234lsd'); |
84902520 | 216 | |
08cb0b0d | 217 | |
218 | # with lexicals (and in re-entered scopes) | |
219 | for (0,1) { | |
220 | my $txt; | |
221 | unless ($_) { | |
222 | $txt = "Foo"; | |
223 | substr($txt, -1) = "X"; | |
e198f039 | 224 | is($txt, "FoX"); |
08cb0b0d | 225 | } |
226 | else { | |
227 | substr($txt, 0, 1) = "X"; | |
e198f039 | 228 | is($txt, "X"); |
08cb0b0d | 229 | } |
230 | } | |
231 | ||
e476b1b5 | 232 | $w = 0 ; |
84902520 | 233 | # coercion of references |
08cb0b0d | 234 | { |
235 | my $s = []; | |
236 | substr($s, 0, 1) = 'Foo'; | |
e198f039 NC |
237 | is (substr($s,0,7), "FooRRAY"); |
238 | is ($w,2); | |
239 | $w = 0; | |
08cb0b0d | 240 | } |
84902520 TB |
241 | |
242 | # check no spurious warnings | |
e198f039 | 243 | is($w, 0); |
7b8d334a | 244 | |
5d82c453 | 245 | # check new 4 arg replacement syntax |
7b8d334a | 246 | $a = "abcxyz"; |
5d82c453 | 247 | $w = 0; |
e198f039 NC |
248 | is(substr($a, 0, 3, ""), "abc"); |
249 | is($a, "xyz"); | |
250 | is(substr($a, 0, 0, "abc"), ""); | |
251 | is($a, "abcxyz"); | |
252 | is(substr($a, 3, -1, ""), "xy"); | |
253 | is($a, "abcz"); | |
e476b1b5 | 254 | |
e198f039 NC |
255 | is(substr($a, 3, undef, "xy"), ""); |
256 | is($a, "abcxyz"); | |
257 | is($w, 3); | |
e476b1b5 | 258 | |
5d82c453 GA |
259 | $w = 0; |
260 | ||
e198f039 NC |
261 | is(substr($a, 3, 9999999, ""), "xyz"); |
262 | is($a, "abc"); | |
e476b1b5 | 263 | eval{substr($a, -99, 0, "") }; |
e198f039 | 264 | like($@, $FATAL_MSG); |
e476b1b5 | 265 | eval{substr($a, 99, 3, "") }; |
e198f039 | 266 | like($@, $FATAL_MSG); |
5d82c453 GA |
267 | |
268 | substr($a, 0, length($a), "foo"); | |
e198f039 NC |
269 | is ($a, "foo"); |
270 | is ($w, 0); | |
5d82c453 GA |
271 | |
272 | # using 4 arg substr as lvalue is a compile time error | |
273 | eval 'substr($a,0,0,"") = "abc"'; | |
e198f039 NC |
274 | like ($@, qr/Can't modify substr/); |
275 | is ($a, "foo"); | |
c8faf1c5 GS |
276 | |
277 | $a = "abcdefgh"; | |
e198f039 NC |
278 | is(sub { shift }->(substr($a, 0, 4, "xxxx")), 'abcd'); |
279 | is($a, 'xxxxefgh'); | |
7f66633b | 280 | |
e84ff256 GS |
281 | { |
282 | my $y = 10; | |
283 | $y = "2" . $y; | |
e198f039 | 284 | is ($y, 210); |
e84ff256 GS |
285 | } |
286 | ||
7f66633b GS |
287 | # utf8 sanity |
288 | { | |
289 | my $x = substr("a\x{263a}b",0); | |
e198f039 | 290 | is(length($x), 3); |
7f66633b | 291 | $x = substr($x,1,1); |
e198f039 | 292 | is($x, "\x{263a}"); |
dfcb284a | 293 | $x = $x x 2; |
e198f039 | 294 | is(length($x), 2); |
7f66633b | 295 | substr($x,0,1) = "abcd"; |
e198f039 NC |
296 | is($x, "abcd\x{263a}"); |
297 | is(length($x), 5); | |
e84ff256 | 298 | $x = reverse $x; |
e198f039 NC |
299 | is(length($x), 5); |
300 | is($x, "\x{263a}dcba"); | |
e84ff256 GS |
301 | |
302 | my $z = 10; | |
303 | $z = "21\x{263a}" . $z; | |
e198f039 NC |
304 | is(length($z), 5); |
305 | is($z, "21\x{263a}10"); | |
7f66633b | 306 | } |
35fba0d9 RG |
307 | |
308 | # replacement should work on magical values | |
309 | require Tie::Scalar; | |
310 | my %data; | |
311 | tie $data{'a'}, 'Tie::StdScalar'; # makes $data{'a'} magical | |
312 | $data{a} = "firstlast"; | |
e198f039 NC |
313 | is(substr($data{'a'}, 0, 5, ""), "first"); |
314 | is($data{'a'}, "last"); | |
075a4a2b JH |
315 | |
316 | # more utf8 | |
317 | ||
318 | # The following two originally from Ignasi Roca. | |
319 | ||
320 | $x = "\xF1\xF2\xF3"; | |
321 | substr($x, 0, 1) = "\x{100}"; # Ignasi had \x{FF} | |
e198f039 NC |
322 | is(length($x), 3); |
323 | is($x, "\x{100}\xF2\xF3"); | |
324 | is(substr($x, 0, 1), "\x{100}"); | |
325 | is(substr($x, 1, 1), "\x{F2}"); | |
326 | is(substr($x, 2, 1), "\x{F3}"); | |
075a4a2b JH |
327 | |
328 | $x = "\xF1\xF2\xF3"; | |
329 | substr($x, 0, 1) = "\x{100}\x{FF}"; # Ignasi had \x{FF} | |
e198f039 NC |
330 | is(length($x), 4); |
331 | is($x, "\x{100}\x{FF}\xF2\xF3"); | |
332 | is(substr($x, 0, 1), "\x{100}"); | |
333 | is(substr($x, 1, 1), "\x{FF}"); | |
334 | is(substr($x, 2, 1), "\x{F2}"); | |
335 | is(substr($x, 3, 1), "\x{F3}"); | |
075a4a2b JH |
336 | |
337 | # more utf8 lval exercise | |
338 | ||
339 | $x = "\xF1\xF2\xF3"; | |
340 | substr($x, 0, 2) = "\x{100}\xFF"; | |
e198f039 NC |
341 | is(length($x), 3); |
342 | is($x, "\x{100}\xFF\xF3"); | |
343 | is(substr($x, 0, 1), "\x{100}"); | |
344 | is(substr($x, 1, 1), "\x{FF}"); | |
345 | is(substr($x, 2, 1), "\x{F3}"); | |
075a4a2b JH |
346 | |
347 | $x = "\xF1\xF2\xF3"; | |
348 | substr($x, 1, 1) = "\x{100}\xFF"; | |
e198f039 NC |
349 | is(length($x), 4); |
350 | is($x, "\xF1\x{100}\xFF\xF3"); | |
351 | is(substr($x, 0, 1), "\x{F1}"); | |
352 | is(substr($x, 1, 1), "\x{100}"); | |
353 | is(substr($x, 2, 1), "\x{FF}"); | |
354 | is(substr($x, 3, 1), "\x{F3}"); | |
075a4a2b JH |
355 | |
356 | $x = "\xF1\xF2\xF3"; | |
357 | substr($x, 2, 1) = "\x{100}\xFF"; | |
e198f039 NC |
358 | is(length($x), 4); |
359 | is($x, "\xF1\xF2\x{100}\xFF"); | |
360 | is(substr($x, 0, 1), "\x{F1}"); | |
361 | is(substr($x, 1, 1), "\x{F2}"); | |
362 | is(substr($x, 2, 1), "\x{100}"); | |
363 | is(substr($x, 3, 1), "\x{FF}"); | |
075a4a2b JH |
364 | |
365 | $x = "\xF1\xF2\xF3"; | |
366 | substr($x, 3, 1) = "\x{100}\xFF"; | |
e198f039 NC |
367 | is(length($x), 5); |
368 | is($x, "\xF1\xF2\xF3\x{100}\xFF"); | |
369 | is(substr($x, 0, 1), "\x{F1}"); | |
370 | is(substr($x, 1, 1), "\x{F2}"); | |
371 | is(substr($x, 2, 1), "\x{F3}"); | |
372 | is(substr($x, 3, 1), "\x{100}"); | |
373 | is(substr($x, 4, 1), "\x{FF}"); | |
075a4a2b JH |
374 | |
375 | $x = "\xF1\xF2\xF3"; | |
376 | substr($x, -1, 1) = "\x{100}\xFF"; | |
e198f039 NC |
377 | is(length($x), 4); |
378 | is($x, "\xF1\xF2\x{100}\xFF"); | |
379 | is(substr($x, 0, 1), "\x{F1}"); | |
380 | is(substr($x, 1, 1), "\x{F2}"); | |
381 | is(substr($x, 2, 1), "\x{100}"); | |
382 | is(substr($x, 3, 1), "\x{FF}"); | |
075a4a2b JH |
383 | |
384 | $x = "\xF1\xF2\xF3"; | |
385 | substr($x, -1, 0) = "\x{100}\xFF"; | |
e198f039 NC |
386 | is(length($x), 5); |
387 | is($x, "\xF1\xF2\x{100}\xFF\xF3"); | |
388 | is(substr($x, 0, 1), "\x{F1}"); | |
389 | is(substr($x, 1, 1), "\x{F2}"); | |
390 | is(substr($x, 2, 1), "\x{100}"); | |
391 | is(substr($x, 3, 1), "\x{FF}"); | |
392 | is(substr($x, 4, 1), "\x{F3}"); | |
075a4a2b JH |
393 | |
394 | $x = "\xF1\xF2\xF3"; | |
395 | substr($x, 0, -1) = "\x{100}\xFF"; | |
e198f039 NC |
396 | is(length($x), 3); |
397 | is($x, "\x{100}\xFF\xF3"); | |
398 | is(substr($x, 0, 1), "\x{100}"); | |
399 | is(substr($x, 1, 1), "\x{FF}"); | |
400 | is(substr($x, 2, 1), "\x{F3}"); | |
075a4a2b JH |
401 | |
402 | $x = "\xF1\xF2\xF3"; | |
403 | substr($x, 0, -2) = "\x{100}\xFF"; | |
e198f039 NC |
404 | is(length($x), 4); |
405 | is($x, "\x{100}\xFF\xF2\xF3"); | |
406 | is(substr($x, 0, 1), "\x{100}"); | |
407 | is(substr($x, 1, 1), "\x{FF}"); | |
408 | is(substr($x, 2, 1), "\x{F2}"); | |
409 | is(substr($x, 3, 1), "\x{F3}"); | |
075a4a2b JH |
410 | |
411 | $x = "\xF1\xF2\xF3"; | |
412 | substr($x, 0, -3) = "\x{100}\xFF"; | |
e198f039 NC |
413 | is(length($x), 5); |
414 | is($x, "\x{100}\xFF\xF1\xF2\xF3"); | |
415 | is(substr($x, 0, 1), "\x{100}"); | |
416 | is(substr($x, 1, 1), "\x{FF}"); | |
417 | is(substr($x, 2, 1), "\x{F1}"); | |
418 | is(substr($x, 3, 1), "\x{F2}"); | |
419 | is(substr($x, 4, 1), "\x{F3}"); | |
075a4a2b JH |
420 | |
421 | $x = "\xF1\xF2\xF3"; | |
422 | substr($x, 1, -1) = "\x{100}\xFF"; | |
e198f039 NC |
423 | is(length($x), 4); |
424 | is($x, "\xF1\x{100}\xFF\xF3"); | |
425 | is(substr($x, 0, 1), "\x{F1}"); | |
426 | is(substr($x, 1, 1), "\x{100}"); | |
427 | is(substr($x, 2, 1), "\x{FF}"); | |
428 | is(substr($x, 3, 1), "\x{F3}"); | |
075a4a2b JH |
429 | |
430 | $x = "\xF1\xF2\xF3"; | |
431 | substr($x, -1, -1) = "\x{100}\xFF"; | |
e198f039 NC |
432 | is(length($x), 5); |
433 | is($x, "\xF1\xF2\x{100}\xFF\xF3"); | |
434 | is(substr($x, 0, 1), "\x{F1}"); | |
435 | is(substr($x, 1, 1), "\x{F2}"); | |
436 | is(substr($x, 2, 1), "\x{100}"); | |
437 | is(substr($x, 3, 1), "\x{FF}"); | |
438 | is(substr($x, 4, 1), "\x{F3}"); | |
075a4a2b | 439 | |
9aa983d2 JH |
440 | # And tests for already-UTF8 one |
441 | ||
442 | $x = "\x{101}\x{F2}\x{F3}"; | |
443 | substr($x, 0, 1) = "\x{100}"; | |
e198f039 NC |
444 | is(length($x), 3); |
445 | is($x, "\x{100}\xF2\xF3"); | |
446 | is(substr($x, 0, 1), "\x{100}"); | |
447 | is(substr($x, 1, 1), "\x{F2}"); | |
448 | is(substr($x, 2, 1), "\x{F3}"); | |
9aa983d2 JH |
449 | |
450 | $x = "\x{101}\x{F2}\x{F3}"; | |
451 | substr($x, 0, 1) = "\x{100}\x{FF}"; | |
e198f039 NC |
452 | is(length($x), 4); |
453 | is($x, "\x{100}\x{FF}\xF2\xF3"); | |
454 | is(substr($x, 0, 1), "\x{100}"); | |
455 | is(substr($x, 1, 1), "\x{FF}"); | |
456 | is(substr($x, 2, 1), "\x{F2}"); | |
457 | is(substr($x, 3, 1), "\x{F3}"); | |
9aa983d2 JH |
458 | |
459 | $x = "\x{101}\x{F2}\x{F3}"; | |
460 | substr($x, 0, 2) = "\x{100}\xFF"; | |
e198f039 NC |
461 | is(length($x), 3); |
462 | is($x, "\x{100}\xFF\xF3"); | |
463 | is(substr($x, 0, 1), "\x{100}"); | |
464 | is(substr($x, 1, 1), "\x{FF}"); | |
465 | is(substr($x, 2, 1), "\x{F3}"); | |
9aa983d2 JH |
466 | |
467 | $x = "\x{101}\x{F2}\x{F3}"; | |
468 | substr($x, 1, 1) = "\x{100}\xFF"; | |
e198f039 NC |
469 | is(length($x), 4); |
470 | is($x, "\x{101}\x{100}\xFF\xF3"); | |
471 | is(substr($x, 0, 1), "\x{101}"); | |
472 | is(substr($x, 1, 1), "\x{100}"); | |
473 | is(substr($x, 2, 1), "\x{FF}"); | |
474 | is(substr($x, 3, 1), "\x{F3}"); | |
9aa983d2 JH |
475 | |
476 | $x = "\x{101}\x{F2}\x{F3}"; | |
477 | substr($x, 2, 1) = "\x{100}\xFF"; | |
e198f039 NC |
478 | is(length($x), 4); |
479 | is($x, "\x{101}\xF2\x{100}\xFF"); | |
480 | is(substr($x, 0, 1), "\x{101}"); | |
481 | is(substr($x, 1, 1), "\x{F2}"); | |
482 | is(substr($x, 2, 1), "\x{100}"); | |
483 | is(substr($x, 3, 1), "\x{FF}"); | |
9aa983d2 JH |
484 | |
485 | $x = "\x{101}\x{F2}\x{F3}"; | |
486 | substr($x, 3, 1) = "\x{100}\xFF"; | |
e198f039 NC |
487 | is(length($x), 5); |
488 | is($x, "\x{101}\x{F2}\x{F3}\x{100}\xFF"); | |
489 | is(substr($x, 0, 1), "\x{101}"); | |
490 | is(substr($x, 1, 1), "\x{F2}"); | |
491 | is(substr($x, 2, 1), "\x{F3}"); | |
492 | is(substr($x, 3, 1), "\x{100}"); | |
493 | is(substr($x, 4, 1), "\x{FF}"); | |
9aa983d2 JH |
494 | |
495 | $x = "\x{101}\x{F2}\x{F3}"; | |
496 | substr($x, -1, 1) = "\x{100}\xFF"; | |
e198f039 NC |
497 | is(length($x), 4); |
498 | is($x, "\x{101}\xF2\x{100}\xFF"); | |
499 | is(substr($x, 0, 1), "\x{101}"); | |
500 | is(substr($x, 1, 1), "\x{F2}"); | |
501 | is(substr($x, 2, 1), "\x{100}"); | |
502 | is(substr($x, 3, 1), "\x{FF}"); | |
9aa983d2 JH |
503 | |
504 | $x = "\x{101}\x{F2}\x{F3}"; | |
505 | substr($x, -1, 0) = "\x{100}\xFF"; | |
e198f039 NC |
506 | is(length($x), 5); |
507 | is($x, "\x{101}\xF2\x{100}\xFF\xF3"); | |
508 | is(substr($x, 0, 1), "\x{101}"); | |
509 | is(substr($x, 1, 1), "\x{F2}"); | |
510 | is(substr($x, 2, 1), "\x{100}"); | |
511 | is(substr($x, 3, 1), "\x{FF}"); | |
512 | is(substr($x, 4, 1), "\x{F3}"); | |
9aa983d2 JH |
513 | |
514 | $x = "\x{101}\x{F2}\x{F3}"; | |
515 | substr($x, 0, -1) = "\x{100}\xFF"; | |
e198f039 NC |
516 | is(length($x), 3); |
517 | is($x, "\x{100}\xFF\xF3"); | |
518 | is(substr($x, 0, 1), "\x{100}"); | |
519 | is(substr($x, 1, 1), "\x{FF}"); | |
520 | is(substr($x, 2, 1), "\x{F3}"); | |
9aa983d2 JH |
521 | |
522 | $x = "\x{101}\x{F2}\x{F3}"; | |
523 | substr($x, 0, -2) = "\x{100}\xFF"; | |
e198f039 NC |
524 | is(length($x), 4); |
525 | is($x, "\x{100}\xFF\xF2\xF3"); | |
526 | is(substr($x, 0, 1), "\x{100}"); | |
527 | is(substr($x, 1, 1), "\x{FF}"); | |
528 | is(substr($x, 2, 1), "\x{F2}"); | |
529 | is(substr($x, 3, 1), "\x{F3}"); | |
9aa983d2 JH |
530 | |
531 | $x = "\x{101}\x{F2}\x{F3}"; | |
532 | substr($x, 0, -3) = "\x{100}\xFF"; | |
e198f039 NC |
533 | is(length($x), 5); |
534 | is($x, "\x{100}\xFF\x{101}\x{F2}\x{F3}"); | |
535 | is(substr($x, 0, 1), "\x{100}"); | |
536 | is(substr($x, 1, 1), "\x{FF}"); | |
537 | is(substr($x, 2, 1), "\x{101}"); | |
538 | is(substr($x, 3, 1), "\x{F2}"); | |
539 | is(substr($x, 4, 1), "\x{F3}"); | |
9aa983d2 JH |
540 | |
541 | $x = "\x{101}\x{F2}\x{F3}"; | |
542 | substr($x, 1, -1) = "\x{100}\xFF"; | |
e198f039 NC |
543 | is(length($x), 4); |
544 | is($x, "\x{101}\x{100}\xFF\xF3"); | |
545 | is(substr($x, 0, 1), "\x{101}"); | |
546 | is(substr($x, 1, 1), "\x{100}"); | |
547 | is(substr($x, 2, 1), "\x{FF}"); | |
548 | is(substr($x, 3, 1), "\x{F3}"); | |
9aa983d2 JH |
549 | |
550 | $x = "\x{101}\x{F2}\x{F3}"; | |
551 | substr($x, -1, -1) = "\x{100}\xFF"; | |
e198f039 NC |
552 | is(length($x), 5); |
553 | is($x, "\x{101}\xF2\x{100}\xFF\xF3"); | |
554 | is(substr($x, 0, 1), "\x{101}"); | |
555 | is(substr($x, 1, 1), "\x{F2}"); | |
556 | is(substr($x, 2, 1), "\x{100}"); | |
557 | is(substr($x, 3, 1), "\x{FF}"); | |
558 | is(substr($x, 4, 1), "\x{F3}"); | |
f7928d6c JH |
559 | |
560 | substr($x = "ab", 0, 0, "\x{100}\x{200}"); | |
e198f039 | 561 | is($x, "\x{100}\x{200}ab"); |
f7928d6c JH |
562 | |
563 | substr($x = "\x{100}\x{200}", 0, 0, "ab"); | |
e198f039 | 564 | is($x, "ab\x{100}\x{200}"); |
f7928d6c JH |
565 | |
566 | substr($x = "ab", 1, 0, "\x{100}\x{200}"); | |
e198f039 | 567 | is($x, "a\x{100}\x{200}b"); |
f7928d6c JH |
568 | |
569 | substr($x = "\x{100}\x{200}", 1, 0, "ab"); | |
e198f039 | 570 | is($x, "\x{100}ab\x{200}"); |
f7928d6c JH |
571 | |
572 | substr($x = "ab", 2, 0, "\x{100}\x{200}"); | |
e198f039 | 573 | is($x, "ab\x{100}\x{200}"); |
f7928d6c JH |
574 | |
575 | substr($x = "\x{100}\x{200}", 2, 0, "ab"); | |
e198f039 | 576 | is($x, "\x{100}\x{200}ab"); |
f7928d6c | 577 | |
9402d6ed | 578 | substr($x = "\xFFb", 0, 0, "\x{100}\x{200}"); |
e198f039 | 579 | is($x, "\x{100}\x{200}\xFFb"); |
9402d6ed JH |
580 | |
581 | substr($x = "\x{100}\x{200}", 0, 0, "\xFFb"); | |
e198f039 | 582 | is($x, "\xFFb\x{100}\x{200}"); |
9402d6ed JH |
583 | |
584 | substr($x = "\xFFb", 1, 0, "\x{100}\x{200}"); | |
e198f039 | 585 | is($x, "\xFF\x{100}\x{200}b"); |
9402d6ed JH |
586 | |
587 | substr($x = "\x{100}\x{200}", 1, 0, "\xFFb"); | |
e198f039 | 588 | is($x, "\x{100}\xFFb\x{200}"); |
9402d6ed JH |
589 | |
590 | substr($x = "\xFFb", 2, 0, "\x{100}\x{200}"); | |
e198f039 | 591 | is($x, "\xFFb\x{100}\x{200}"); |
9402d6ed JH |
592 | |
593 | substr($x = "\x{100}\x{200}", 2, 0, "\xFFb"); | |
e198f039 | 594 | is($x, "\x{100}\x{200}\xFFb"); |
9402d6ed | 595 | |
24aef97f HS |
596 | # [perl #20933] |
597 | { | |
598 | my $s = "ab"; | |
599 | my @r; | |
600 | $r[$_] = \ substr $s, $_, 1 for (0, 1); | |
e198f039 | 601 | is(join("", map { $$_ } @r), "ab"); |
24aef97f | 602 | } |
6214ab63 AE |
603 | |
604 | # [perl #23207] | |
605 | { | |
606 | sub ss { | |
607 | substr($_[0],0,1) ^= substr($_[0],1,1) ^= | |
608 | substr($_[0],0,1) ^= substr($_[0],1,1); | |
609 | } | |
610 | my $x = my $y = 'AB'; ss $x; ss $y; | |
e198f039 | 611 | is($x, $y); |
6214ab63 | 612 | } |
8f78557a AE |
613 | |
614 | # [perl #24605] | |
615 | { | |
616 | my $x = "0123456789\x{500}"; | |
617 | my $y = substr $x, 4; | |
e198f039 | 618 | is(substr($x, 7, 1), "7"); |
8f78557a | 619 | } |
c2552146 DM |
620 | |
621 | # multiple assignments to lvalue [perl #24346] | |
622 | { | |
623 | my $x = "abcdef"; | |
624 | for (substr($x,1,3)) { | |
e198f039 | 625 | is($_, 'bcd'); |
c2552146 | 626 | $_ = 'XX'; |
e198f039 NC |
627 | is($_, 'XX'); |
628 | is($x, 'aXXef'); | |
c2552146 | 629 | $_ = "\xFF"; |
e198f039 NC |
630 | is($_, "\xFF"); |
631 | is($x, "a\xFFef"); | |
c2552146 | 632 | $_ = "\xF1\xF2\xF3\xF4\xF5\xF6"; |
e198f039 NC |
633 | is($_, "\xF1\xF2\xF3\xF4\xF5\xF6"); |
634 | is($x, "a\xF1\xF2\xF3\xF4\xF5\xF6ef"); | |
c2552146 | 635 | $_ = 'YYYY'; |
e198f039 NC |
636 | is($_, 'YYYY'); |
637 | is($x, 'aYYYYef'); | |
c2552146 | 638 | } |
83f78d1a FC |
639 | $x = "abcdef"; |
640 | for (substr($x,1)) { | |
641 | is($_, 'bcdef'); | |
642 | $_ = 'XX'; | |
643 | is($_, 'XX'); | |
644 | is($x, 'aXX'); | |
645 | $x .= "frompswiggle"; | |
646 | is $_, "XXfrompswiggle"; | |
647 | } | |
648 | $x = "abcdef"; | |
649 | for (substr($x,1,-1)) { | |
650 | is($_, 'bcde'); | |
651 | $_ = 'XX'; | |
652 | is($_, 'XX'); | |
653 | is($x, 'aXXf'); | |
654 | $x .= "frompswiggle"; | |
655 | is $_, "XXffrompswiggl"; | |
656 | } | |
657 | $x = "abcdef"; | |
658 | for (substr($x,-5,3)) { | |
659 | is($_, 'bcd'); | |
660 | $_ = 'XX'; # now $_ is substr($x, -4, 2) | |
661 | is($_, 'XX'); | |
662 | is($x, 'aXXef'); | |
663 | $x .= "frompswiggle"; | |
664 | is $_, "gg"; | |
665 | } | |
666 | $x = "abcdef"; | |
667 | for (substr($x,-5)) { | |
668 | is($_, 'bcdef'); | |
669 | $_ = 'XX'; # now substr($x, -2) | |
670 | is($_, 'XX'); | |
671 | is($x, 'aXX'); | |
672 | $x .= "frompswiggle"; | |
673 | is $_, "le"; | |
674 | } | |
675 | $x = "abcdef"; | |
676 | for (substr($x,-5,-1)) { | |
677 | is($_, 'bcde'); | |
678 | $_ = 'XX'; # now substr($x, -3, -1) | |
679 | is($_, 'XX'); | |
680 | is($x, 'aXXf'); | |
681 | $x .= "frompswiggle"; | |
682 | is $_, "gl"; | |
683 | } | |
c2552146 | 684 | } |
781e7547 | 685 | |
569ddb4a FC |
686 | # Also part of perl #24346; scalar(substr...) should not affect lvalueness |
687 | { | |
688 | my $str = "abcdef"; | |
689 | sub { $_[0] = 'dea' }->( scalar substr $str, 3, 2 ); | |
690 | is $str, 'abcdeaf', 'scalar does not affect lvalueness of substr'; | |
691 | } | |
692 | ||
781e7547 DM |
693 | # [perl #24200] string corruption with lvalue sub |
694 | ||
695 | { | |
e3faa678 | 696 | sub bar: lvalue { substr $krunch, 0 } |
781e7547 | 697 | bar = "XXX"; |
e198f039 | 698 | is(bar, 'XXX'); |
e3faa678 | 699 | $krunch = '123456789'; |
e198f039 | 700 | is(bar, '123456789'); |
781e7547 | 701 | } |
a67d7df9 TS |
702 | |
703 | # [perl #29149] | |
704 | { | |
705 | my $text = "0123456789\xED "; | |
706 | utf8::upgrade($text); | |
707 | my $pos = 5; | |
708 | pos($text) = $pos; | |
709 | my $a = substr($text, $pos, $pos); | |
e198f039 | 710 | is(substr($text,$pos,1), $pos); |
a67d7df9 TS |
711 | |
712 | } | |
080534f4 RGS |
713 | |
714 | # [perl #23765] | |
715 | { | |
716 | my $a = pack("C", 0xbf); | |
717 | substr($a, -1) &= chr(0xfeff); | |
e198f039 | 718 | is($a, "\xbf"); |
080534f4 | 719 | } |
ec062429 DM |
720 | |
721 | # [perl #34976] incorrect caching of utf8 substr length | |
722 | { | |
723 | my $a = "abcd\x{100}"; | |
e198f039 NC |
724 | is(substr($a,1,2), 'bc'); |
725 | is(substr($a,1,1), 'b'); | |
ec062429 | 726 | } |
e3faa678 | 727 | |
777f7c56 EB |
728 | # [perl #62646] offsets exceeding 32 bits on 64-bit system |
729 | SKIP: { | |
730 | skip("32-bit system", 24) unless ~0 > 0xffffffff; | |
731 | my $a = "abc"; | |
732 | my $s; | |
733 | my $r; | |
734 | ||
735 | utf8::downgrade($a); | |
736 | for (1..2) { | |
737 | $w = 0; | |
738 | $r = substr($a, 0xffffffff, 1); | |
739 | is($r, undef); | |
740 | is($w, 1); | |
741 | ||
742 | $w = 0; | |
743 | $r = substr($a, 0xffffffff+1, 1); | |
744 | is($r, undef); | |
745 | is($w, 1); | |
746 | ||
747 | $w = 0; | |
748 | ok( !eval { $r = substr($s=$a, 0xffffffff, 1, "_"); 1 } ); | |
749 | is($r, undef); | |
750 | is($s, $a); | |
751 | is($w, 0); | |
752 | ||
753 | $w = 0; | |
754 | ok( !eval { $r = substr($s=$a, 0xffffffff+1, 1, "_"); 1 } ); | |
755 | is($r, undef); | |
756 | is($s, $a); | |
757 | is($w, 0); | |
758 | ||
759 | utf8::upgrade($a); | |
760 | } | |
761 | } | |
762 | ||
e27c778f FC |
763 | # [perl #77692] UTF8 cache not being reset when TARG is reused |
764 | ok eval { | |
765 | local ${^UTF8CACHE} = -1; | |
766 | for my $i (0..1) | |
767 | { | |
768 | my $dummy = length(substr("\x{100}",0,$i)); | |
769 | } | |
770 | 1 | |
771 | }, 'UTF8 cache is reset when TARG is reused [perl #77692]'; | |
23037b03 FC |
772 | |
773 | { | |
bf32a30c BF |
774 | use utf8; |
775 | use open qw( :utf8 :std ); | |
776 | no warnings 'once'; | |
777 | ||
778 | my $t = ""; | |
779 | substr $t, 0, 0, *ワルド; | |
780 | is($t, "*main::ワルド", "substr works on UTF-8 globs"); | |
781 | ||
782 | $t = "The World!"; | |
783 | substr $t, 0, 9, *ザ::ワルド; | |
784 | is($t, "*ザ::ワルド!", "substr works on a UTF-8 glob + stash"); | |
785 | } | |
a74fb2cd FC |
786 | |
787 | { | |
788 | my $x = *foo; | |
789 | my $y = \substr *foo, 0, 0; | |
790 | is ref \$x, 'GLOB', '\substr does not coerce its glob arg just yet'; | |
791 | $x = \"foo"; | |
792 | $y = \substr *foo, 0, 0; | |
793 | is ref \$x, 'REF', '\substr does not coerce its ref arg just yet'; | |
794 | } | |
2956677f | 795 | |
cc02ebe5 FC |
796 | # Test that UTF8-ness of magic var changing does not confuse substr lvalue |
797 | # assignment. | |
798 | # We use overloading for our magic var, but a typeglob would work, too. | |
799 | package o { | |
6582db62 | 800 | use overload '""' => sub { ++our $count; $_[0][0] } |
cc02ebe5 FC |
801 | } |
802 | my $refee = bless ["\x{100}a"], o::; | |
803 | my $substr = \substr $refee, -2; # UTF8 flag still off for $$substr. | |
804 | $$substr = "b"; # UTF8 flag turns on when setsubstr | |
805 | is $refee, "b", # magic stringifies $$substr. | |
806 | 'substr lvalue assignment when stringification turns on UTF8ness'; | |
6582db62 FC |
807 | |
808 | # Test that changing UTF8-ness does not confuse 4-arg substr. | |
809 | $refee = bless [], "\x{100}a"; | |
810 | # stringify without returning on UTF8 flag on $refee: | |
811 | my $string = $refee; $string = "$string"; | |
812 | substr $refee, 0, 0, "\xff"; | |
813 | is $refee, "\xff$string", | |
814 | '4-arg substr with target UTF8ness turning on when stringified'; | |
815 | $refee = bless [], "\x{100}"; | |
816 | () = "$refee"; # UTF8 flag now on | |
817 | bless $refee, "\xff"; | |
818 | $string = $refee; $string = "$string"; | |
819 | substr $refee, 0, 0, "\xff"; | |
820 | is $refee, "\xff$string", | |
821 | '4-arg substr with target UTF8ness turning off when stringified'; | |
822 | ||
823 | # Overload count | |
824 | $refee = bless ["foo"], o::; | |
825 | $o::count = 0; | |
826 | substr $refee, 0, 0, ""; | |
827 | is $o::count, 1, '4-arg substr calls overloading once on the target'; | |
0d788f38 FC |
828 | $refee = bless ["\x{100}"], o::; |
829 | () = "$refee"; # turn UTF8 flag on | |
830 | $o::count = 0; | |
831 | () = substr $refee, 0; | |
832 | is $o::count, 1, 'rvalue substr calls overloading once on utf8 target'; | |
7a385470 FC |
833 | $o::count = 0; |
834 | $refee = ""; | |
835 | ${\substr $refee, 0} = bless ["\x{100}"], o::; | |
836 | is $o::count, 1, 'assigning utf8 overload to substr lvalue calls ovld 1ce'; | |
307e609a FC |
837 | |
838 | # [perl #7678] core dump with substr reference and localisation | |
839 | {$b="abcde"; local $k; *k=\substr($b, 2, 1);} | |
5888debf FC |
840 | |
841 | } # sub run_tests - put tests above this line that can run in threads | |
0815177a FC |
842 | |
843 | ||
844 | my $destroyed; | |
845 | { package Class; DESTROY { ++$destroyed; } } | |
846 | ||
847 | $destroyed = 0; | |
848 | { | |
849 | my $x = ''; | |
850 | substr($x,0,1) = ""; | |
851 | $x = bless({}, 'Class'); | |
852 | } | |
853 | is($destroyed, 1, 'Timely scalar destruction with lvalue substr'); | |
854 | ||
855 | { | |
856 | my $result_3363; | |
857 | sub a_3363 { | |
858 | my ($word, $replace) = @_; | |
859 | my $ref = \substr($word, 0, 1); | |
860 | $$ref = $replace; | |
861 | if ($replace eq "b") { | |
862 | $result_3363 = $word; | |
863 | } else { | |
864 | a_3363($word, "b"); | |
865 | } | |
866 | } | |
867 | a_3363($_, "v") for "test"; | |
868 | ||
869 | is($result_3363, "best", "ref-to-substr retains lvalue-ness under recursion [perl #3363]"); | |
870 | } |