1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 require './test.pl'; 6 set_up_inc('../lib'); 7 require './charset_tools.pl'; 8} 9 10plan tests => 219; 11 12$FS = ':'; 13 14$_ = 'a:b:c'; 15 16($a,$b,$c) = split($FS,$_); 17 18is(join(';',$a,$b,$c), 'a;b;c', 'Split a simple string into scalars.'); 19 20@ary = split(/:b:/); 21$cnt = split(/:b:/); 22is(join("$_",@ary), 'aa:b:cc'); 23is($cnt, scalar(@ary)); 24 25$_ = "abc\n"; 26my @xyz = (@ary = split(//)); 27$cnt = split(//); 28is(join(".",@ary), "a.b.c.\n"); 29is($cnt, scalar(@ary)); 30 31$_ = "a:b:c::::"; 32@ary = split(/:/); 33$cnt = split(/:/); 34is(join(".",@ary), "a.b.c"); 35is($cnt, scalar(@ary)); 36 37$_ = join(':',split(' '," a b\tc \t d ")); 38is($_, 'a:b:c:d'); 39@ary = split(' '," a b\tc \t d "); 40$cnt = split(' '," a b\tc \t d "); 41is($cnt, scalar(@ary)); 42 43$_ = join(':',split(/ */,"foo bar bie\tdoll")); 44is($_ , "f:o:o:b:a:r:b:i:e:\t:d:o:l:l"); 45@ary = split(/ */,"foo bar bie\tdoll"); 46$cnt = split(/ */,"foo bar bie\tdoll"); 47is($cnt, scalar(@ary)); 48 49$_ = join(':', 'foo', split(/ /,'a b c'), 'bar'); 50is($_, "foo:a:b::c:bar"); 51@ary = split(/ /,'a b c'); 52$cnt = split(/ /,'a b c'); 53is($cnt, scalar(@ary)); 54 55# Can we say how many fields to split to? 56$_ = join(':', split(' ','1 2 3 4 5 6', 3)); 57is($_, '1:2:3 4 5 6', "Split into a specified number of fields, defined by a literal"); 58@ary = split(' ','1 2 3 4 5 6', 3); 59$cnt = split(' ','1 2 3 4 5 6', 3); 60is($cnt, scalar(@ary), "Check element count from previous test"); 61 62# Can we do it as a variable? 63$x = 4; 64$_ = join(':', split(' ','1 2 3 4 5 6', $x)); 65is($_, '1:2:3:4 5 6', "Split into a specified number of fields, defined by a scalar variable"); 66@ary = split(' ','1 2 3 4 5 6', $x); 67$cnt = split(' ','1 2 3 4 5 6', $x); 68is($cnt, scalar(@ary), "Check element count from previous test"); 69 70# Can we do it with the empty pattern? 71$_ = join(':', split(//, '123', -1)); 72is($_, '1:2:3:', "Split with empty pattern and LIMIT == -1"); 73$_ = join(':', split(//, '123', 0)); 74is($_, '1:2:3', "Split with empty pattern and LIMIT == 0"); 75$_ = join(':', split(//, '123', 2)); 76is($_, '1:23', "Split into specified number of fields with empty pattern"); 77$_ = join(':', split(//, '123', 6)); 78is($_, '1:2:3:', "Split with empty pattern and LIMIT > length"); 79for (-1..5) { 80 @ary = split(//, '123', $_); 81 $cnt = split(//, '123', $_); 82 is($cnt, scalar(@ary), "Check empty pattern element count with LIMIT == $_"); 83} 84 85# Does the 999 suppress null field chopping? 86$_ = join(':', split(/:/,'1:2:3:4:5:6:::', 999)); 87is($_ , '1:2:3:4:5:6:::'); 88@ary = split(/:/,'1:2:3:4:5:6:::', 999); 89$cnt = split(/:/,'1:2:3:4:5:6:::', 999); 90is($cnt, scalar(@ary)); 91 92# Splitting without pattern 93$_ = "1 2 3 4"; 94$_ = join(':', split); 95is($_ , '1:2:3:4', "Split and join without specifying a split pattern"); 96 97# Does assignment to a list imply split to one more field than that? 98$foo = runperl( switches => ['-Dt'], stderr => 1, prog => '($a,$b)=split;' ); 99ok($foo =~ /DEBUGGING/ || $foo =~ /const\n?\Q(IV(3))\E/); 100 101# Can we say how many fields to split to when assigning to a list? 102($a,$b) = split(' ','1 2 3 4 5 6', 2); 103$_ = join(':',$a,$b); 104is($_, '1:2 3 4 5 6', "Storing split output into list of scalars"); 105 106# do subpatterns generate additional fields (without trailing nulls)? 107$_ = join '|', split(/,|(-)/, "1-10,20,,,"); 108is($_, "1|-|10||20"); 109@ary = split(/,|(-)/, "1-10,20,,,"); 110$cnt = split(/,|(-)/, "1-10,20,,,"); 111is($cnt, scalar(@ary)); 112 113# do subpatterns generate additional fields (with a limit)? 114$_ = join '|', split(/,|(-)/, "1-10,20,,,", 10); 115is($_, "1|-|10||20||||||"); 116@ary = split(/,|(-)/, "1-10,20,,,", 10); 117$cnt = split(/,|(-)/, "1-10,20,,,", 10); 118is($cnt, scalar(@ary)); 119 120# is the 'two undefs' bug fixed? 121(undef, $a, undef, $b) = qw(1 2 3 4); 122is("$a|$b", "2|4"); 123 124# .. even for locals? 125{ 126 local(undef, $a, undef, $b) = qw(1 2 3 4); 127 is("$a|$b", "2|4"); 128} 129 130# check splitting of null string 131$_ = join('|', split(/x/, '',-1), 'Z'); 132is($_, "Z"); 133@ary = split(/x/, '',-1); 134$cnt = split(/x/, '',-1); 135is($cnt, scalar(@ary)); 136 137$_ = join('|', split(/x/, '', 1), 'Z'); 138is($_, "Z"); 139@ary = split(/x/, '', 1); 140$cnt = split(/x/, '', 1); 141is($cnt, scalar(@ary)); 142 143$_ = join('|', split(/(p+)/,'',-1), 'Z'); 144is($_, "Z"); 145@ary = split(/(p+)/,'',-1); 146$cnt = split(/(p+)/,'',-1); 147is($cnt, scalar(@ary)); 148 149$_ = join('|', split(/.?/, '',-1), 'Z'); 150is($_, "Z"); 151@ary = split(/.?/, '',-1); 152$cnt = split(/.?/, '',-1); 153is($cnt, scalar(@ary)); 154 155 156# Are /^/m patterns scanned? 157$_ = join '|', split(/^a/m, "a b a\na d a", 20); 158is($_, "| b a\n| d a"); 159@ary = split(/^a/m, "a b a\na d a", 20); 160$cnt = split(/^a/m, "a b a\na d a", 20); 161is($cnt, scalar(@ary)); 162 163# Are /$/m patterns scanned? 164$_ = join '|', split(/a$/m, "a b a\na d a", 20); 165is($_, "a b |\na d |"); 166@ary = split(/a$/m, "a b a\na d a", 20); 167$cnt = split(/a$/m, "a b a\na d a", 20); 168is($cnt, scalar(@ary)); 169 170# Are /^/m patterns scanned? 171$_ = join '|', split(/^aa/m, "aa b aa\naa d aa", 20); 172is($_, "| b aa\n| d aa"); 173@ary = split(/^aa/m, "aa b aa\naa d aa", 20); 174$cnt = split(/^aa/m, "aa b aa\naa d aa", 20); 175is($cnt, scalar(@ary)); 176 177# Are /$/m patterns scanned? 178$_ = join '|', split(/aa$/m, "aa b aa\naa d aa", 20); 179is($_, "aa b |\naa d |"); 180@ary = split(/aa$/m, "aa b aa\naa d aa", 20); 181$cnt = split(/aa$/m, "aa b aa\naa d aa", 20); 182is($cnt, scalar(@ary)); 183 184# Greedyness: 185$_ = "a : b :c: d"; 186@ary = split(/\s*:\s*/); 187$cnt = split(/\s*:\s*/); 188is(($res = join(".",@ary)), "a.b.c.d", $res); 189is($cnt, scalar(@ary)); 190 191# use of match result as pattern (!) 192is('p:q:r:s', join ':', split('abc' =~ /b/, 'p1q1r1s')); 193@ary = split('abc' =~ /b/, 'p1q1r1s'); 194$cnt = split('abc' =~ /b/, 'p1q1r1s'); 195is($cnt, scalar(@ary)); 196 197# /^/ treated as /^/m 198$_ = join ':', split /^/, "ab\ncd\nef\n"; 199is($_, "ab\n:cd\n:ef\n","check that split /^/ is treated as split /^/m"); 200 201$_ = join ':', split /\A/, "ab\ncd\nef\n"; 202is($_, "ab\ncd\nef\n","check that split /\A/ is NOT treated as split /^/m"); 203 204# see if @a = @b = split(...) optimization works 205@list1 = @list2 = split ('p',"a p b c p"); 206ok(@list1 == @list2 && 207 "@list1" eq "@list2" && 208 @list1 == 2 && 209 "@list1" eq "a b c "); 210 211# zero-width assertion 212$_ = join ':', split /(?=\w)/, "rm b"; 213is($_, "r:m :b"); 214@ary = split /(?=\w)/, "rm b"; 215$cnt = split /(?=\w)/, "rm b"; 216is($cnt, scalar(@ary)); 217 218# unicode splittage 219 220@ary = map {ord} split //, v1.20.300.4000.50000.4000.300.20.1; 221$cnt = split //, v1.20.300.4000.50000.4000.300.20.1; 222is("@ary", "1 20 300 4000 50000 4000 300 20 1"); 223is($cnt, scalar(@ary)); 224 225@ary = split(/\x{FE}/, "\x{FF}\x{FE}\x{FD}"); # bug id 20010105.016 (#5088) 226$cnt = split(/\x{FE}/, "\x{FF}\x{FE}\x{FD}"); # bug id 20010105.016 (#5088) 227ok(@ary == 2 && 228 $ary[0] eq "\xFF" && $ary[1] eq "\xFD" && 229 $ary[0] eq "\x{FF}" && $ary[1] eq "\x{FD}"); 230is($cnt, scalar(@ary)); 231 232@ary = split(/(\x{FE}\xFE)/, "\xFF\x{FF}\xFE\x{FE}\xFD\x{FD}"); # variant of 31 233$cnt = split(/(\x{FE}\xFE)/, "\xFF\x{FF}\xFE\x{FE}\xFD\x{FD}"); # variant of 31 234ok(@ary == 3 && 235 $ary[0] eq "\xFF\xFF" && 236 $ary[0] eq "\x{FF}\xFF" && 237 $ary[0] eq "\x{FF}\x{FF}" && 238 $ary[1] eq "\xFE\xFE" && 239 $ary[1] eq "\x{FE}\xFE" && 240 $ary[1] eq "\x{FE}\x{FE}" && 241 $ary[2] eq "\xFD\xFD" && 242 $ary[2] eq "\x{FD}\xFD" && 243 $ary[2] eq "\x{FD}\x{FD}"); 244is($cnt, scalar(@ary)); 245 246{ 247 my @a = map ord, split(//, join("", map chr, (1234, 123, 2345))); 248 my $c = split(//, join("", map chr, (1234, 123, 2345))); 249 is("@a", "1234 123 2345"); 250 is($c, scalar(@a)); 251} 252 253{ 254 my $x = 'A'; 255 my @a = map ord, split(/$x/, join("", map chr, (1234, ord($x), 2345))); 256 my $c = split(/$x/, join("", map chr, (1234, ord($x), 2345))); 257 is("@a", "1234 2345"); 258 is($c, scalar(@a)); 259} 260 261{ 262 # bug id 20000427.003 (#3173) 263 264 use warnings; 265 use strict; 266 267 my $sushi = "\x{b36c}\x{5a8c}\x{ff5b}\x{5079}\x{505b}"; 268 269 my @charlist = split //, $sushi; 270 my $charnum = split //, $sushi; 271 is($charnum, scalar(@charlist)); 272 my $r = ''; 273 foreach my $ch (@charlist) { 274 $r = $r . " " . sprintf "U+%04X", ord($ch); 275 } 276 277 is($r, " U+B36C U+5A8C U+FF5B U+5079 U+505B"); 278} 279 280{ 281 my $s = "\x20\x40\x{80}\x{100}\x{80}\x40\x20"; 282 283 { 284 # bug id 20000426.003 (#3166) 285 286 my ($a, $b, $c) = split(/\x40/, $s); 287 ok($a eq "\x20" && $b eq "\x{80}\x{100}\x{80}" && $c eq $a); 288 } 289 290 my ($a, $b) = split(/\x{100}/, $s); 291 ok($a eq "\x20\x40\x{80}" && $b eq "\x{80}\x40\x20"); 292 293 my ($a, $b) = split(/\x{80}\x{100}\x{80}/, $s); 294 ok($a eq "\x20\x40" && $b eq "\x40\x20"); 295 296 { 297 my ($a, $b) = split(/\x40\x{80}/, $s); 298 ok($a eq "\x20" && $b eq "\x{100}\x{80}\x40\x20"); 299 } 300 301 my ($a, $b, $c) = split(/[\x40\x{80}]+/, $s); 302 ok($a eq "\x20" && $b eq "\x{100}" && $c eq "\x20"); 303} 304 305{ 306 # 20001205.014 (#4844) 307 308 my $a = "ABC\x{263A}"; 309 310 my @b = split( //, $a ); 311 my $c = split( //, $a ); 312 is($c, scalar(@b)); 313 314 is(scalar @b, 4); 315 316 ok(length($b[3]) == 1 && $b[3] eq "\x{263A}"); 317 318 $a =~ s/^A/Z/; 319 ok(length($a) == 4 && $a eq "ZBC\x{263A}"); 320} 321 322{ 323 my @a = split(/\xFE/, "\xFF\xFE\xFD"); 324 my $b = split(/\xFE/, "\xFF\xFE\xFD"); 325 326 ok(@a == 2 && $a[0] eq "\xFF" && $a[1] eq "\xFD"); 327 is($b, scalar(@a)); 328} 329 330{ 331 # check that PMf_WHITE is cleared after \s+ is used 332 # reported in <20010627113312.RWGY6087.viemta06@localhost> 333 my $r; 334 foreach my $pat ( qr/\s+/, qr/ll/ ) { 335 $r = join ':' => split($pat, "hello cruel world"); 336 } 337 is($r, "he:o cruel world"); 338} 339 340 341{ 342 # split /(A)|B/, "1B2" should return (1, undef, 2) 343 my @x = split /(A)|B/, "1B2"; 344 my $y = split /(A)|B/, "1B2"; 345 is($y, scalar(@x)); 346 ok($x[0] eq '1' and (not defined $x[1]) and $x[2] eq '2'); 347} 348 349{ 350 # [perl #17064] 351 my $warn; 352 local $SIG{__WARN__} = sub { $warn = join '', @_; chomp $warn }; 353 my $char = "\x{10f1ff}"; 354 my @a = split /\r?\n/, "$char\n"; 355 my $b = split /\r?\n/, "$char\n"; 356 is($b, scalar(@a)); 357 ok(@a == 1 && $a[0] eq $char && !defined($warn)); 358} 359 360{ 361 # [perl #18195] 362 for my $u (0, 1) { 363 for my $a (0, 1) { 364 $_ = 'readin,database,readout'; 365 utf8::upgrade $_ if $u; 366 /(.+)/; 367 my @d = split /[,]/,$1; 368 my $e = split /[,]/,$1; 369 is($e, scalar(@d)); 370 is(join (':',@d), 'readin:database:readout', "[perl #18195]"); 371 } 372 } 373} 374 375{ 376 $p="a,b"; 377 utf8::upgrade $p; 378 eval { @a=split(/[, ]+/,$p) }; 379 eval { $b=split(/[, ]+/,$p) }; 380 is($b, scalar(@a)); 381 is ("$@-@a-", '-a b-', '#20912 - split() to array with /[]+/ and utf8'); 382} 383 384{ 385 # LATIN SMALL LETTER A WITH DIAERESIS, CYRILLIC SMALL LETTER I 386 for my $pattern ("\N{U+E4}", "\x{0437}") { 387 utf8::upgrade $pattern; 388 my @res; 389 for my $str ("a${pattern}b", "axb", "a${pattern}b") { 390 @split = split /$pattern/, $str; 391 push @res, scalar(@split); 392 } 393 is($res[0], 2); 394 is($res[1], 1); 395 is($res[2], 2, '#123469 - split with utf8 pattern after handling non-utf8 EXPR'); 396 } 397} 398 399{ 400 is (\@a, \@{"a"}, '@a must be global for following test'); 401 $p=""; 402 $n = @a = split /,/,$p; 403 is ($n, 0, '#21765 - pmreplroot hack used to return undef for 0 iters'); 404} 405 406{ 407 # [perl #28938] 408 # assigning off the end of the array after a split could leave garbage 409 # in the inner elements 410 411 my $x; 412 @a = split /,/, ',,,,,'; 413 $a[3]=1; 414 $x = \$a[2]; 415 is (ref $x, 'SCALAR', '#28938 - garbage after extend'); 416} 417 418{ 419 my $src = "ABC \0 FOO \0 XYZ"; 420 my @s = split(" \0 ", $src); 421 my @r = split(/ \0 /, $src); 422 my $cs = split(" \0 ", $src); 423 my $cr = split(/ \0 /, $src); 424 is(scalar(@s), 3); 425 is($cs, 3); 426 is($cr, 3); 427 is($s[0], "ABC"); 428 is($s[1], "FOO"); 429 is($s[2]," XYZ"); 430 is(join(':',@s), join(':',@r)); 431} 432 433{ 434 use constant BANG => {}; 435 () = split m/,/, "", BANG; 436 ok(1); 437} 438 439{ 440 # Bug #69875 441 # 'Hybrid' scalar-and-array context 442 scalar(our @PATH = split /::/, "Font::GlyphNames"); 443 # 'my' doesn't trigger the bug 444 is "@PATH", "Font GlyphNames", "hybrid scalar-and-array context"; 445} 446 447{ 448 my @results; 449 my $expr= "foo bar"; 450 my $cond; 451 452 @results= split(0||" ", $expr); 453 is @results, 2, 'split(0||" ") is treated like split(" ")'; #' 454 455 $cond= 0; 456 @results= split $cond ? " " : qr/ /, $expr; 457 is @results, 3, 'split($cond ? " " : qr/ /, $expr) works as expected (like qr/ /)'; 458 $cond= 1; 459 @results= split $cond ? " " : qr/ /, $expr; 460 is @results, 2, 'split($cond ? " " : qr/ /, $expr) works as expected (like " ")'; 461 462 $expr = ' a b c '; 463 @results = split /\s/, $expr; 464 is @results, 4, 465 "split on regex of single space metacharacter: captured 4 elements"; 466 is $results[0], '', 467 "split on regex of single space metacharacter: first element is empty string"; 468 469 @results = split / /, $expr; 470 is @results, 4, 471 "split on regex of single whitespace: captured 4 elements"; 472 is $results[0], '', 473 "split on regex of single whitespace: first element is empty string"; 474 475 @results = split " ", $expr; 476 is @results, 3, 477 "split on string of single whitespace: captured 3 elements"; 478 is $results[0], 'a', 479 "split on string of single whitespace: first element is non-empty"; 480 481 $expr = " a \tb c "; 482 @results = split " ", $expr; 483 is @results, 3, 484 "split on string of single whitespace: captured 3 elements"; 485 is $results[0], 'a', 486 "split on string of single whitespace: first element is non-empty; multiple contiguous space characters"; 487 488 my @seq; 489 for my $cond (0,1,0,1,0) { 490 $expr = " foo "; 491 @results = split $cond ? qr/ / : " ", $expr; 492 push @seq, scalar(@results) . ":" . $results[-1]; 493 } 494 is join(" ", @seq), "1:foo 3:foo 1:foo 3:foo 1:foo", 495 qq{split(\$cond ? qr/ / : " ", "$exp") behaves as expected over repeated similar patterns}; 496} 497 498SKIP: { 499 # RT #130907: unicode_strings feature doesn't work with split ' ' 500 501 my ($sp) = grep /\s/u, map chr, reverse 128 .. 255 # prefer \xA0 over \x85 502 or skip 'no unicode whitespace found in high-8-bit range', 9; 503 504 for (["$sp$sp. /", "leading unicode whitespace"], 505 [".$sp$sp/", "unicode whitespace separator"], 506 [". /$sp$sp", "trailing unicode whitespace"]) { 507 my ($str, $desc) = @$_; 508 use feature "unicode_strings"; 509 my @got = split " ", $str; 510 is @got, 2, "whitespace split: $desc: field count"; 511 is $got[0], '.', "whitespace split: $desc: field 0"; 512 is $got[1], '/', "whitespace split: $desc: field 1"; 513 } 514} 515 516{ 517 # 'RT #116086: split "\x20" does not work as documented'; 518 my @results; 519 my $expr; 520 $expr = ' a b c '; 521 @results = split uni_to_native("\x20"), $expr; 522 is @results, 3, 523 "RT #116086: split on string of single hex-20: captured 3 elements"; 524 is $results[0], 'a', 525 "RT #116086: split on string of single hex-20: first element is non-empty"; 526 527 $expr = " a \tb c "; 528 @results = split uni_to_native("\x20"), $expr; 529 is @results, 3, 530 "RT #116086: split on string of single hex-20: captured 3 elements"; 531 is $results[0], 'a', 532 "RT #116086: split on string of single hex-20: first element is non-empty; multiple contiguous space characters"; 533} 534 535# Nasty interaction between split and use constant 536use constant nought => 0; 537($a,$b,$c) = split //, $foo, nought; 538is nought, 0, 'split does not mangle 0 constants'; 539 540*aaa = *bbb; 541$aaa[1] = "foobarbaz"; 542$aaa[1] .= ""; 543@aaa = split //, $bbb[1]; 544is "@aaa", "f o o b a r b a z", 545 'split-to-array does not free its own argument'; 546 547() = @a = split //, "abc"; 548is "@a", "a b c", '() = split-to-array'; 549 550(@a = split //, "abc") = 1..10; 551is "@a", '1 2 3', 'assignment to split-to-array (pmtarget/package array)'; 552{ 553 my @a; 554 (@a = split //, "abc") = 1..10; 555 is "@a", '1 2 3', 'assignment to split-to-array (targ/lexical)'; 556} 557(@{\@a} = split //, "abc") = 1..10; 558is "@a", '1 2 3', 'assignment to split-to-array (stacked)'; 559 560# check that re-evals work 561 562{ 563 my $c = 0; 564 @a = split /-(?{ $c++ })/, "a-b-c"; 565 is "@a", "a b c", "compile-time re-eval"; 566 is $c, 2, "compile-time re-eval count"; 567 568 my $sep = '-'; 569 $c = 0; 570 @a = split /$sep(?{ $c++ })/, "a-b-c"; 571 is "@a", "a b c", "run-time re-eval"; 572 is $c, 2, "run-time re-eval count"; 573} 574 575# check that my/local @array = split works 576 577{ 578 my $s = "a:b:c"; 579 580 local @a = qw(x y z); 581 { 582 local @a = split /:/, $s; 583 is "@a", "a b c", "local split inside"; 584 } 585 is "@a", "x y z", "local split outside"; 586 587 my @b = qw(x y z); 588 { 589 my @b = split /:/, $s; 590 is "@b", "a b c", "my split inside"; 591 } 592 is "@b", "x y z", "my split outside"; 593} 594 595# check that the (@a = split) optimisation works in scalar/list context 596 597{ 598 my $s = "a:b:c:d:e"; 599 my @outer; 600 my $outer; 601 my @lex; 602 local our @pkg; 603 604 $outer = (@lex = split /:/, $s); 605 is "@lex", "a b c d e", "array split: scalar cx lex: inner"; 606 is $outer, 5, "array split: scalar cx lex: outer"; 607 608 @outer = (@lex = split /:/, $s); 609 is "@lex", "a b c d e", "array split: list cx lex: inner"; 610 is "@outer", "a b c d e", "array split: list cx lex: outer"; 611 612 $outer = (@pkg = split /:/, $s); 613 is "@pkg", "a b c d e", "array split: scalar cx pkg inner"; 614 is $outer, 5, "array split: scalar cx pkg outer"; 615 616 @outer = (@pkg = split /:/, $s); 617 is "@pkg", "a b c d e", "array split: list cx pkg inner"; 618 is "@outer", "a b c d e", "array split: list cx pkg outer"; 619 620 $outer = (my @a1 = split /:/, $s); 621 is "@a1", "a b c d e", "array split: scalar cx my lex: inner"; 622 is $outer, 5, "array split: scalar cx my lex: outer"; 623 624 @outer = (my @a2 = split /:/, $s); 625 is "@a2", "a b c d e", "array split: list cx my lex: inner"; 626 is "@outer", "a b c d e", "array split: list cx my lex: outer"; 627 628 $outer = (local @pkg = split /:/, $s); 629 is "@pkg", "a b c d e", "array split: scalar cx local pkg inner"; 630 is $outer, 5, "array split: scalar cx local pkg outer"; 631 632 @outer = (local @pkg = split /:/, $s); 633 is "@pkg", "a b c d e", "array split: list cx local pkg inner"; 634 is "@outer", "a b c d e", "array split: list cx local pkg outer"; 635 636 $outer = (@{\@lex} = split /:/, $s); 637 is "@lex", "a b c d e", "array split: scalar cx lexref inner"; 638 is $outer, 5, "array split: scalar cx lexref outer"; 639 640 @outer = (@{\@pkg} = split /:/, $s); 641 is "@pkg", "a b c d e", "array split: list cx pkgref inner"; 642 is "@outer", "a b c d e", "array split: list cx pkgref outer"; 643 644 645} 646 647# splitting directly to an array wasn't filling unused AvARRAY slots with 648# NULL 649 650{ 651 my @a; 652 @a = split(/-/,"-"); 653 $a[1] = 'b'; 654 ok eval { $a[0] = 'a'; 1; }, "array split filling AvARRAY: assign 0"; 655 is "@a", "a b", "array split filling AvARRAY: result"; 656} 657 658# splitting an empty utf8 string gave an assert failure 659{ 660 my $s = "\x{100}"; 661 chop $s; 662 my @a = split ' ', $s; 663 is (+@a, 0, "empty utf8 string"); 664} 665 666# correct stack adjustments (gh#18232) 667{ 668 sub foo { return @_ } 669 my @a = foo(1, scalar split " ", "a b"); 670 is(join('', @a), "12", "Scalar split to a sub parameter"); 671} 672 673{ 674 sub foo { return @_ } 675 my @a = foo(1, scalar(@x = split " ", "a b")); 676 is(join('', @a), "12", "Split to @x then use scalar result as a sub parameter"); 677} 678 679fresh_perl_is(<<'CODE', '', {}, "scalar split stack overflow"); 680map{int"";split//.0>60for"0000000000000000"}split// for"00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000" 681CODE 682 683# RT #132334: /o modifier no longer has side effects on split 684{ 685 my @records = ( 686 { separator => '0', effective => '', text => 'ab' }, 687 { separator => ';', effective => ';', text => 'a;b' }, 688 ); 689 690 for (@records) { 691 my ($separator, $effective, $text) = @$_{qw(separator effective text)}; 692 $separator =~ s/0//o; 693 is($separator,$effective,"Going to split '$text' with '$separator'"); 694 my @result = split($separator,$text); 695 ok(eq_array(\@result,['a','b']), "Resulting in ('a','b')"); 696 } 697} 698 699# check that the (@ary = split) optimisation survives @ary being modified 700 701fresh_perl_is('my @ary; @ary = split(/\w(?{ @ary[1000] = 1 })/, "abc");', 702 '',{},'(@ary = split ...) survives @ary being Renew()ed'); 703fresh_perl_is('my @ary; @ary = split(/\w(?{ undef @ary })/, "abc");', 704 '',{},'(@ary = split ...) survives an (undef @ary)'); 705 706# check the (@ary = split) optimisation survives stack-not-refcounted bugs 707fresh_perl_is('our @ary; @ary = split(/\w(?{ *ary = 0 })/, "abc");', 708 '',{},'(@ary = split ...) survives @ary destruction via typeglob'); 709fresh_perl_is('my $ary = []; @$ary = split(/\w(?{ $ary = [] })/, "abc");', 710 '',{},'(@ary = split ...) survives @ary destruction via reassignment'); 711 712# gh18515: check that we spot and flag specific regexps for special treatment 713SKIP: { 714 skip_if_miniperl("special-case patterns: need dynamic loading", 4); 715 for ([ q{" "}, 'WHITE' ], 716 [ q{/\\s+/}, 'WHITE' ], 717 [ q{/^/}, 'START_ONLY' ], 718 [ q{//}, 'NULL' ], 719 ) { 720 my($pattern, $flag) = @$_; 721 my $prog = "split $pattern"; 722 my $expect = qr{^r->extflags:.*\b$flag\b}m; 723 fresh_perl_like($prog, $expect, { 724 switches => [ '-Mre=Debug,COMPILE', '-c' ], 725 }, "special-case pattern for $prog"); 726 } 727} 728 729# gh18032: check that `split " "` does not get converted to `split ""` 730SKIP: { 731 my @skipwhite= ('split " "', 'split "\x20"', 'split "\N{SPACE}"', 732 'split "$e$sp$e"', 'split'); 733 my @noskipwhite= ( 734 'split / /', 'split m/ /', 'split qr/ /', 735 'split /$e$sp$e/', 'split m/$e$sp$e/', 'split qr/$e$sp$e/' 736 ); 737 skip_if_miniperl("special-case patterns: need dynamic loading", 738 2*(@skipwhite+@noskipwhite)); 739 740 my $modifiers = "x"; # the original bug report used /aansx 741 742 for my $prog ( @skipwhite ) { 743 fresh_perl_like("use re qw(/$modifiers); \$sp=qq( ); \$e=qq(); $prog;", 744 qr{^r->extflags:.*\bSKIPWHITE\b\s\bWHITE\b}m, 745 {switches => [ '-Mre=Debug,COMPILE' ]}, 746 "$prog sets SKIPWHITE|WHITE under `use re qw(/$modifiers)`"); 747 748 fresh_perl_like("use re qw(/$modifiers); \$sp=qq( ); \$e=qq();" 749 ."\$_=qq( 1 1 ); \@c=$prog; print 0+\@c, qq(<\@c>)", 750 qr{^2<1 1>}m, 751 {}, 752 "$prog matches as expected `use re qw(/$modifiers)`"); 753 } 754 for my $prog ( @noskipwhite) { 755 fresh_perl_like("use re qw(/$modifiers); \$sp=qq( ); \$e=qq(); $prog;", 756 qr{^r->extflags:.*\bNULL\b}m, 757 {switches => [ '-Mre=Debug,COMPILE' ]}, 758 "$prog does not set SKIPWHITE|WHITE under `use re qw(/$modifiers)`"); 759 fresh_perl_like("use re qw(/$modifiers); \$sp=qq( ); \$e=qq();" 760 ."\$_=qq( 1 1 ); \@c=$prog; print 0+\@c, qq(<\@c>)", 761 qr{^6< 1 1 >}m, 762 {}, 763 "$prog matches expected under `use re qw(/$modifiers)`"); 764 } 765} 766