1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = '../lib'; 6 require './test.pl'; 7} 8 9plan tests => 119; 10 11$FS = ':'; 12 13$_ = 'a:b:c'; 14 15($a,$b,$c) = split($FS,$_); 16 17is(join(';',$a,$b,$c), 'a;b;c', 'Split a simple string into scalars.'); 18 19@ary = split(/:b:/); 20$cnt = split(/:b:/); 21is(join("$_",@ary), 'aa:b:cc'); 22is($cnt, scalar(@ary)); 23 24$_ = "abc\n"; 25my @xyz = (@ary = split(//)); 26$cnt = split(//); 27is(join(".",@ary), "a.b.c.\n"); 28is($cnt, scalar(@ary)); 29 30$_ = "a:b:c::::"; 31@ary = split(/:/); 32$cnt = split(/:/); 33is(join(".",@ary), "a.b.c"); 34is($cnt, scalar(@ary)); 35 36$_ = join(':',split(' '," a b\tc \t d ")); 37is($_, 'a:b:c:d'); 38@ary = split(' '," a b\tc \t d "); 39$cnt = split(' '," a b\tc \t d "); 40is($cnt, scalar(@ary)); 41 42$_ = join(':',split(/ */,"foo bar bie\tdoll")); 43is($_ , "f:o:o:b:a:r:b:i:e:\t:d:o:l:l"); 44@ary = split(/ */,"foo bar bie\tdoll"); 45$cnt = split(/ */,"foo bar bie\tdoll"); 46is($cnt, scalar(@ary)); 47 48$_ = join(':', 'foo', split(/ /,'a b c'), 'bar'); 49is($_, "foo:a:b::c:bar"); 50@ary = split(/ /,'a b c'); 51$cnt = split(/ /,'a b c'); 52is($cnt, scalar(@ary)); 53 54# Can we say how many fields to split to? 55$_ = join(':', split(' ','1 2 3 4 5 6', 3)); 56is($_, '1:2:3 4 5 6', "Split into a specified number of fields, defined by a literal"); 57@ary = split(' ','1 2 3 4 5 6', 3); 58$cnt = split(' ','1 2 3 4 5 6', 3); 59is($cnt, scalar(@ary), "Check element count from previous test"); 60 61# Can we do it as a variable? 62$x = 4; 63$_ = join(':', split(' ','1 2 3 4 5 6', $x)); 64is($_, '1:2:3:4 5 6', "Split into a specified number of fields, defined by a scalar variable"); 65@ary = split(' ','1 2 3 4 5 6', $x); 66$cnt = split(' ','1 2 3 4 5 6', $x); 67is($cnt, scalar(@ary), "Check element count from previous test"); 68 69# Does the 999 suppress null field chopping? 70$_ = join(':', split(/:/,'1:2:3:4:5:6:::', 999)); 71is($_ , '1:2:3:4:5:6:::'); 72@ary = split(/:/,'1:2:3:4:5:6:::', 999); 73$cnt = split(/:/,'1:2:3:4:5:6:::', 999); 74is($cnt, scalar(@ary)); 75 76# Splitting without pattern 77$_ = "1 2 3 4"; 78$_ = join(':', split); 79is($_ , '1:2:3:4', "Split and join without specifying a split pattern"); 80 81# Does assignment to a list imply split to one more field than that? 82$foo = runperl( switches => ['-Dt'], stderr => 1, prog => '($a,$b)=split;' ); 83ok($foo =~ /DEBUGGING/ || $foo =~ /const\n?\Q(IV(3))\E/); 84 85# Can we say how many fields to split to when assigning to a list? 86($a,$b) = split(' ','1 2 3 4 5 6', 2); 87$_ = join(':',$a,$b); 88is($_, '1:2 3 4 5 6', "Storing split output into list of scalars"); 89 90# do subpatterns generate additional fields (without trailing nulls)? 91$_ = join '|', split(/,|(-)/, "1-10,20,,,"); 92is($_, "1|-|10||20"); 93@ary = split(/,|(-)/, "1-10,20,,,"); 94$cnt = split(/,|(-)/, "1-10,20,,,"); 95is($cnt, scalar(@ary)); 96 97# do subpatterns generate additional fields (with a limit)? 98$_ = join '|', split(/,|(-)/, "1-10,20,,,", 10); 99is($_, "1|-|10||20||||||"); 100@ary = split(/,|(-)/, "1-10,20,,,", 10); 101$cnt = split(/,|(-)/, "1-10,20,,,", 10); 102is($cnt, scalar(@ary)); 103 104# is the 'two undefs' bug fixed? 105(undef, $a, undef, $b) = qw(1 2 3 4); 106is("$a|$b", "2|4"); 107 108# .. even for locals? 109{ 110 local(undef, $a, undef, $b) = qw(1 2 3 4); 111 is("$a|$b", "2|4"); 112} 113 114# check splitting of null string 115$_ = join('|', split(/x/, '',-1), 'Z'); 116is($_, "Z"); 117@ary = split(/x/, '',-1); 118$cnt = split(/x/, '',-1); 119is($cnt, scalar(@ary)); 120 121$_ = join('|', split(/x/, '', 1), 'Z'); 122is($_, "Z"); 123@ary = split(/x/, '', 1); 124$cnt = split(/x/, '', 1); 125is($cnt, scalar(@ary)); 126 127$_ = join('|', split(/(p+)/,'',-1), 'Z'); 128is($_, "Z"); 129@ary = split(/(p+)/,'',-1); 130$cnt = split(/(p+)/,'',-1); 131is($cnt, scalar(@ary)); 132 133$_ = join('|', split(/.?/, '',-1), 'Z'); 134is($_, "Z"); 135@ary = split(/.?/, '',-1); 136$cnt = split(/.?/, '',-1); 137is($cnt, scalar(@ary)); 138 139 140# Are /^/m patterns scanned? 141$_ = join '|', split(/^a/m, "a b a\na d a", 20); 142is($_, "| b a\n| d a"); 143@ary = split(/^a/m, "a b a\na d a", 20); 144$cnt = split(/^a/m, "a b a\na d a", 20); 145is($cnt, scalar(@ary)); 146 147# Are /$/m patterns scanned? 148$_ = join '|', split(/a$/m, "a b a\na d a", 20); 149is($_, "a b |\na d |"); 150@ary = split(/a$/m, "a b a\na d a", 20); 151$cnt = split(/a$/m, "a b a\na d a", 20); 152is($cnt, scalar(@ary)); 153 154# Are /^/m patterns scanned? 155$_ = join '|', split(/^aa/m, "aa b aa\naa d aa", 20); 156is($_, "| b aa\n| d aa"); 157@ary = split(/^aa/m, "aa b aa\naa d aa", 20); 158$cnt = split(/^aa/m, "aa b aa\naa d aa", 20); 159is($cnt, scalar(@ary)); 160 161# Are /$/m patterns scanned? 162$_ = join '|', split(/aa$/m, "aa b aa\naa d aa", 20); 163is($_, "aa b |\naa d |"); 164@ary = split(/aa$/m, "aa b aa\naa d aa", 20); 165$cnt = split(/aa$/m, "aa b aa\naa d aa", 20); 166is($cnt, scalar(@ary)); 167 168# Greedyness: 169$_ = "a : b :c: d"; 170@ary = split(/\s*:\s*/); 171$cnt = split(/\s*:\s*/); 172is(($res = join(".",@ary)), "a.b.c.d", $res); 173is($cnt, scalar(@ary)); 174 175# use of match result as pattern (!) 176is('p:q:r:s', join ':', split('abc' =~ /b/, 'p1q1r1s')); 177@ary = split('abc' =~ /b/, 'p1q1r1s'); 178$cnt = split('abc' =~ /b/, 'p1q1r1s'); 179is($cnt, scalar(@ary)); 180 181# /^/ treated as /^/m 182$_ = join ':', split /^/, "ab\ncd\nef\n"; 183is($_, "ab\n:cd\n:ef\n"); 184 185# see if @a = @b = split(...) optimization works 186@list1 = @list2 = split ('p',"a p b c p"); 187ok(@list1 == @list2 && 188 "@list1" eq "@list2" && 189 @list1 == 2 && 190 "@list1" eq "a b c "); 191 192# zero-width assertion 193$_ = join ':', split /(?=\w)/, "rm b"; 194is($_, "r:m :b"); 195@ary = split /(?=\w)/, "rm b"; 196$cnt = split /(?=\w)/, "rm b"; 197is($cnt, scalar(@ary)); 198 199# unicode splittage 200 201@ary = map {ord} split //, v1.20.300.4000.50000.4000.300.20.1; 202$cnt = split //, v1.20.300.4000.50000.4000.300.20.1; 203is("@ary", "1 20 300 4000 50000 4000 300 20 1"); 204is($cnt, scalar(@ary)); 205 206@ary = split(/\x{FE}/, "\x{FF}\x{FE}\x{FD}"); # bug id 20010105.016 207$cnt = split(/\x{FE}/, "\x{FF}\x{FE}\x{FD}"); # bug id 20010105.016 208ok(@ary == 2 && 209 $ary[0] eq "\xFF" && $ary[1] eq "\xFD" && 210 $ary[0] eq "\x{FF}" && $ary[1] eq "\x{FD}"); 211is($cnt, scalar(@ary)); 212 213@ary = split(/(\x{FE}\xFE)/, "\xFF\x{FF}\xFE\x{FE}\xFD\x{FD}"); # variant of 31 214$cnt = split(/(\x{FE}\xFE)/, "\xFF\x{FF}\xFE\x{FE}\xFD\x{FD}"); # variant of 31 215ok(@ary == 3 && 216 $ary[0] eq "\xFF\xFF" && 217 $ary[0] eq "\x{FF}\xFF" && 218 $ary[0] eq "\x{FF}\x{FF}" && 219 $ary[1] eq "\xFE\xFE" && 220 $ary[1] eq "\x{FE}\xFE" && 221 $ary[1] eq "\x{FE}\x{FE}" && 222 $ary[2] eq "\xFD\xFD" && 223 $ary[2] eq "\x{FD}\xFD" && 224 $ary[2] eq "\x{FD}\x{FD}"); 225is($cnt, scalar(@ary)); 226 227{ 228 my @a = map ord, split(//, join("", map chr, (1234, 123, 2345))); 229 my $c = split(//, join("", map chr, (1234, 123, 2345))); 230 is("@a", "1234 123 2345"); 231 is($c, scalar(@a)); 232} 233 234{ 235 my $x = 'A'; 236 my @a = map ord, split(/$x/, join("", map chr, (1234, ord($x), 2345))); 237 my $c = split(/$x/, join("", map chr, (1234, ord($x), 2345))); 238 is("@a", "1234 2345"); 239 is($c, scalar(@a)); 240} 241 242{ 243 # bug id 20000427.003 244 245 use warnings; 246 use strict; 247 248 my $sushi = "\x{b36c}\x{5a8c}\x{ff5b}\x{5079}\x{505b}"; 249 250 my @charlist = split //, $sushi; 251 my $charnum = split //, $sushi; 252 is($charnum, scalar(@charlist)); 253 my $r = ''; 254 foreach my $ch (@charlist) { 255 $r = $r . " " . sprintf "U+%04X", ord($ch); 256 } 257 258 is($r, " U+B36C U+5A8C U+FF5B U+5079 U+505B"); 259} 260 261{ 262 my $s = "\x20\x40\x{80}\x{100}\x{80}\x40\x20"; 263 264 SKIP: { 265 if (ord('A') == 193) { 266 skip("EBCDIC", 1); 267 } else { 268 # bug id 20000426.003 269 270 my ($a, $b, $c) = split(/\x40/, $s); 271 ok($a eq "\x20" && $b eq "\x{80}\x{100}\x{80}" && $c eq $a); 272 } 273 } 274 275 my ($a, $b) = split(/\x{100}/, $s); 276 ok($a eq "\x20\x40\x{80}" && $b eq "\x{80}\x40\x20"); 277 278 my ($a, $b) = split(/\x{80}\x{100}\x{80}/, $s); 279 ok($a eq "\x20\x40" && $b eq "\x40\x20"); 280 281 SKIP: { 282 if (ord('A') == 193) { 283 skip("EBCDIC", 1); 284 } else { 285 my ($a, $b) = split(/\x40\x{80}/, $s); 286 ok($a eq "\x20" && $b eq "\x{100}\x{80}\x40\x20"); 287 } 288 } 289 290 my ($a, $b, $c) = split(/[\x40\x{80}]+/, $s); 291 ok($a eq "\x20" && $b eq "\x{100}" && $c eq "\x20"); 292} 293 294{ 295 # 20001205.014 296 297 my $a = "ABC\x{263A}"; 298 299 my @b = split( //, $a ); 300 my $c = split( //, $a ); 301 is($c, scalar(@b)); 302 303 is(scalar @b, 4); 304 305 ok(length($b[3]) == 1 && $b[3] eq "\x{263A}"); 306 307 $a =~ s/^A/Z/; 308 ok(length($a) == 4 && $a eq "ZBC\x{263A}"); 309} 310 311{ 312 my @a = split(/\xFE/, "\xFF\xFE\xFD"); 313 my $b = split(/\xFE/, "\xFF\xFE\xFD"); 314 315 ok(@a == 2 && $a[0] eq "\xFF" && $a[1] eq "\xFD"); 316 is($b, scalar(@a)); 317} 318 319{ 320 # check that PMf_WHITE is cleared after \s+ is used 321 # reported in <20010627113312.RWGY6087.viemta06@localhost> 322 my $r; 323 foreach my $pat ( qr/\s+/, qr/ll/ ) { 324 $r = join ':' => split($pat, "hello cruel world"); 325 } 326 is($r, "he:o cruel world"); 327} 328 329 330{ 331 # split /(A)|B/, "1B2" should return (1, undef, 2) 332 my @x = split /(A)|B/, "1B2"; 333 my $y = split /(A)|B/, "1B2"; 334 is($y, scalar(@x)); 335 ok($x[0] eq '1' and (not defined $x[1]) and $x[2] eq '2'); 336} 337 338{ 339 # [perl #17064] 340 my $warn; 341 local $SIG{__WARN__} = sub { $warn = join '', @_; chomp $warn }; 342 my $char = "\x{10f1ff}"; 343 my @a = split /\r?\n/, "$char\n"; 344 my $b = split /\r?\n/, "$char\n"; 345 is($b, scalar(@a)); 346 ok(@a == 1 && $a[0] eq $char && !defined($warn)); 347} 348 349{ 350 # [perl #18195] 351 for my $u (0, 1) { 352 for my $a (0, 1) { 353 $_ = 'readin,database,readout'; 354 utf8::upgrade $_ if $u; 355 /(.+)/; 356 my @d = split /[,]/,$1; 357 my $e = split /[,]/,$1; 358 is($e, scalar(@d)); 359 is(join (':',@d), 'readin:database:readout', "[perl #18195]"); 360 } 361 } 362} 363 364{ 365 $p="a,b"; 366 utf8::upgrade $p; 367 eval { @a=split(/[, ]+/,$p) }; 368 eval { $b=split(/[, ]+/,$p) }; 369 is($b, scalar(@a)); 370 is ("$@-@a-", '-a b-', '#20912 - split() to array with /[]+/ and utf8'); 371} 372 373{ 374 is (\@a, \@{"a"}, '@a must be global for following test'); 375 $p=""; 376 $n = @a = split /,/,$p; 377 is ($n, 0, '#21765 - pmreplroot hack used to return undef for 0 iters'); 378} 379 380{ 381 # [perl #28938] 382 # assigning off the end of the array after a split could leave garbage 383 # in the inner elements 384 385 my $x; 386 @a = split /,/, ',,,,,'; 387 $a[3]=1; 388 $x = \$a[2]; 389 is (ref $x, 'SCALAR', '#28938 - garbage after extend'); 390} 391 392{ 393 my $src = "ABC \0 FOO \0 XYZ"; 394 my @s = split(" \0 ", $src); 395 my @r = split(/ \0 /, $src); 396 my $cs = split(" \0 ", $src); 397 my $cr = split(/ \0 /, $src); 398 is(scalar(@s), 3); 399 is($cs, 3); 400 is($cr, 3); 401 is($s[0], "ABC"); 402 is($s[1], "FOO"); 403 is($s[2]," XYZ"); 404 is(join(':',@s), join(':',@r)); 405} 406 407{ 408 use constant BANG => {}; 409 () = split m/,/, "", BANG; 410 ok(1); 411} 412 413{ 414 # Bug #69875 415 # 'Hybrid' scalar-and-array context 416 scalar(our @PATH = split /::/, "Font::GlyphNames"); 417 # 'my' doesn't trigger the bug 418 is "@PATH", "Font GlyphNames", "hybrid scalar-and-array context"; 419} 420 421{ 422 my @results; 423 my $expr= "foo bar"; 424 my $cond; 425 426 @results= split(0||" ", $expr); 427 is @results, 2, 'split(0||" ") is treated like split(" ")'; #' 428 429 $cond= 0; 430 @results= split $cond ? " " : qr/ /, $expr; 431 is @results, 3, 'split($cond ? " " : qr/ /, $expr) works as expected (like qr/ /)'; 432 $cond= 1; 433 @results= split $cond ? " " : qr/ /, $expr; 434 is @results, 2, 'split($cond ? " " : qr/ /, $expr) works as expected (like " ")'; 435 436 $expr = ' a b c '; 437 @results = split /\s/, $expr; 438 is @results, 4, 439 "split on regex of single space metacharacter: captured 4 elements"; 440 is $results[0], '', 441 "split on regex of single space metacharacter: first element is empty string"; 442 443 @results = split / /, $expr; 444 is @results, 4, 445 "split on regex of single whitespace: captured 4 elements"; 446 is $results[0], '', 447 "split on regex of single whitespace: first element is empty string"; 448 449 @results = split " ", $expr; 450 is @results, 3, 451 "split on string of single whitespace: captured 3 elements"; 452 is $results[0], 'a', 453 "split on string of single whitespace: first element is non-empty"; 454 455 $expr = " a \tb c "; 456 @results = split " ", $expr; 457 is @results, 3, 458 "split on string of single whitespace: captured 3 elements"; 459 is $results[0], 'a', 460 "split on string of single whitespace: first element is non-empty; multiple contiguous space characters"; 461 462 my @seq; 463 for my $cond (0,1,0,1,0) { 464 $expr = " foo "; 465 @results = split $cond ? qr/ / : " ", $expr; 466 push @seq, scalar(@results) . ":" . $results[-1]; 467 } 468 is join(" ", @seq), "1:foo 3:foo 1:foo 3:foo 1:foo", 469 qq{split(\$cond ? qr/ / : " ", "$exp") behaves as expected over repeated similar patterns}; 470} 471 472{ 473 # 'RT #116086: split "\x20" does not work as documented'; 474 my @results; 475 my $expr; 476 $expr = ' a b c '; 477 @results = split "\x20", $expr; 478 is @results, 3, 479 "RT #116086: split on string of single hex-20: captured 3 elements"; 480 is $results[0], 'a', 481 "RT #116086: split on string of single hex-20: first element is non-empty"; 482 483 $expr = " a \tb c "; 484 @results = split "\x20", $expr; 485 is @results, 3, 486 "RT #116086: split on string of single hex-20: captured 3 elements"; 487 is $results[0], 'a', 488 "RT #116086: split on string of single hex-20: first element is non-empty; multiple contiguous space characters"; 489} 490 491# Nasty interaction between split and use constant 492use constant nought => 0; 493($a,$b,$c) = split //, $foo, nought; 494is nought, 0, 'split does not mangle 0 constants'; 495