t/op/split.t

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