t/op/split.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     require './test.pl';
   7 }
   8
   9 use Config;
  10
  11 plan tests => 135;
  12
  13 $FS = ':';
  14
  15 $_ = 'a:b:c';
  16
  17 ($a,$b,$c) = split($FS,$_);
  18
  19 is(join(';',$a,$b,$c), 'a;b;c');
  20
  21 @ary = split(/:b:/);
  22 is(join("$_",@ary), 'aa:b:cc');
  23
  24 $_ = "abc\n";
  25 my @xyz = (@ary = split(//));
  26 is(join(".",@ary), "a.b.c.\n");
  27
  28 $_ = "a:b:c::::";
  29 @ary = split(/:/);
  30 is(join(".",@ary), "a.b.c");
  31
  32 $_ = join(':',split(' ',"    a b\tc \t d "));
  33 is($_, 'a:b:c:d');
  34
  35 $_ = join(':',split(/ */,"foo  bar bie\tdoll"));
  36 is($_ , "f:o:o:b:a:r:b:i:e:\t:d:o:l:l");
  37
  38 $_ = join(':', 'foo', split(/ /,'a b  c'), 'bar');
  39 is($_, "foo:a:b::c:bar");
  40
  41 # Can we say how many fields to split to?
  42 $_ = join(':', split(' ','1 2 3 4 5 6', 3));
  43 is($_, '1:2:3 4 5 6');
  44
  45 # Can we do it as a variable?
  46 $x = 4;
  47 $_ = join(':', split(' ','1 2 3 4 5 6', $x));
  48 is($_, '1:2:3:4 5 6');
  49
  50 # Does the 999 suppress null field chopping?
  51 $_ = join(':', split(/:/,'1:2:3:4:5:6:::', 999));
  52 is($_ , '1:2:3:4:5:6:::');
  53
  54 # Does assignment to a list imply split to one more field than that?
  55 SKIP: {
  56     if ($Config{useithreads}) {
  57         skip("No IV value dump with threads", 1);
  58     }
  59     else {
  60         $foo = runperl( switches => ['-Dt'], stderr => 1, prog => '($a,$b)=split;' );
  61         ok($foo =~ /DEBUGGING/ || $foo =~ /const\n?\Q(IV(3))\E/);
  62     }
  63 }
  64
  65 # Can we say how many fields to split to when assigning to a list?
  66 ($a,$b) = split(' ','1 2 3 4 5 6', 2);
  67 $_ = join(':',$a,$b);
  68 is($_, '1:2 3 4 5 6');
  69
  70 # do subpatterns generate additional fields (without trailing nulls)?
  71 $_ = join '|', split(/,|(-)/, "1-10,20,,,");
  72 is($_, "1|-|10||20");
  73
  74 # do subpatterns generate additional fields (with a limit)?
  75 $_ = join '|', split(/,|(-)/, "1-10,20,,,", 10);
  76 is($_, "1|-|10||20||||||");
  77
  78 # is the 'two undefs' bug fixed?
  79 (undef, $a, undef, $b) = qw(1 2 3 4);
  80 is("$a|$b", "2|4");
  81
  82 # .. even for locals?
  83 {
  84   local(undef, $a, undef, $b) = qw(1 2 3 4);
  85   is("$a|$b", "2|4");
  86 }
  87
  88 # check splitting of null string
  89 $_ = join('|', split(/x/,   '',-1), 'Z');
  90 is($_, "Z");
  91
  92 $_ = join('|', split(/x/,   '', 1), 'Z');
  93 is($_, "Z");
  94
  95 $_ = join('|', split(/(p+)/,'',-1), 'Z');
  96 is($_, "Z");
  97
  98 $_ = join('|', split(/.?/,  '',-1), 'Z');
  99 is($_, "Z");
 100
 101
 102 # Are /^/m patterns scanned?
 103 $_ = join '|', split(/^a/m, "a b a\na d a", 20);
 104 is($_, "| b a\n| d a");
 105
 106 # Are /$/m patterns scanned?
 107 $_ = join '|', split(/a$/m, "a b a\na d a", 20);
 108 is($_, "a b |\na d |");
 109
 110 # Are /^/m patterns scanned?
 111 $_ = join '|', split(/^aa/m, "aa b aa\naa d aa", 20);
 112 is($_, "| b aa\n| d aa");
 113
 114 # Are /$/m patterns scanned?
 115 $_ = join '|', split(/aa$/m, "aa b aa\naa d aa", 20);
 116 is($_, "aa b |\naa d |");
 117
 118 # Greedyness:
 119 $_ = "a : b :c: d";
 120 @ary = split(/\s*:\s*/);
 121 is(($res = join(".",@ary)), "a.b.c.d", $res);
 122
 123 # use of match result as pattern (!)
 124 is('p:q:r:s', join ':', split('abc' =~ /b/, 'p1q1r1s'));
 125
 126 # /^/ treated as /^/m
 127 $_ = join ':', split /^/, "ab\ncd\nef\n";
 128 is($_, "ab\n:cd\n:ef\n");
 129
 130 # see if @a = @b = split(...) optimization works
 131 @list1 = @list2 = split ('p',"a p b c p");
 132 ok(@list1 == @list2 &&
 133    "@list1" eq "@list2" &&
 134    @list1 == 2 &&
 135    "@list1" eq "a   b c ");
 136
 137 # zero-width assertion
 138 $_ = join ':', split /(?=\w)/, "rm b";
 139 is($_, "r:m :b");
 140
 141 # unicode splittage
 142
 143 @ary = map {ord} split //, v1.20.300.4000.50000.4000.300.20.1;
 144 is("@ary", "1 20 300 4000 50000 4000 300 20 1");
 145
 146 @ary = split(/\x{FE}/, "\x{FF}\x{FE}\x{FD}"); # bug id 20010105.016
 147 ok(@ary == 2 &&
 148    $ary[0] eq "\xFF"   && $ary[1] eq "\xFD" &&
 149    $ary[0] eq "\x{FF}" && $ary[1] eq "\x{FD}");
 150
 151 @ary = split(/(\x{FE}\xFE)/, "\xFF\x{FF}\xFE\x{FE}\xFD\x{FD}"); # variant of 31
 152 ok(@ary == 3 &&
 153    $ary[0] eq "\xFF\xFF"     &&
 154    $ary[0] eq "\x{FF}\xFF"   &&
 155    $ary[0] eq "\x{FF}\x{FF}" &&
 156    $ary[1] eq "\xFE\xFE"     &&
 157    $ary[1] eq "\x{FE}\xFE"   &&
 158    $ary[1] eq "\x{FE}\x{FE}" &&
 159    $ary[2] eq "\xFD\xFD"     &&
 160    $ary[2] eq "\x{FD}\xFD"   &&
 161    $ary[2] eq "\x{FD}\x{FD}");
 162
 163 {
 164     my @a = map ord, split(//, join("", map chr, (1234, 123, 2345)));
 165     is("@a", "1234 123 2345");
 166 }
 167
 168 {
 169     my $x = 'A';
 170     my @a = map ord, split(/$x/, join("", map chr, (1234, ord($x), 2345)));
 171     is("@a", "1234 2345");
 172 }
 173
 174 {
 175     # bug id 20000427.003
 176
 177     use warnings;
 178     use strict;
 179
 180     my $sushi = "\x{b36c}\x{5a8c}\x{ff5b}\x{5079}\x{505b}";
 181
 182     my @charlist = split //, $sushi;
 183     my $r = '';
 184     foreach my $ch (@charlist) {
 185         $r = $r . " " . sprintf "U+%04X", ord($ch);
 186     }
 187
 188     is($r, " U+B36C U+5A8C U+FF5B U+5079 U+505B");
 189 }
 190
 191 {
 192     my $s = "\x20\x40\x{80}\x{100}\x{80}\x40\x20";
 193
 194   SKIP: {
 195     if (ord('A') == 193) {
 196         skip("EBCDIC", 1);
 197     } else {
 198         # bug id 20000426.003
 199
 200         my ($a, $b, $c) = split(/\x40/, $s);
 201         ok($a eq "\x20" && $b eq "\x{80}\x{100}\x{80}" && $c eq $a);
 202     }
 203   }
 204
 205     my ($a, $b) = split(/\x{100}/, $s);
 206     ok($a eq "\x20\x40\x{80}" && $b eq "\x{80}\x40\x20");
 207
 208     my ($a, $b) = split(/\x{80}\x{100}\x{80}/, $s);
 209     ok($a eq "\x20\x40" && $b eq "\x40\x20");
 210
 211   SKIP: {
 212     if (ord('A') == 193) {
 213         skip("EBCDIC", 1);
 214     }  else {
 215         my ($a, $b) = split(/\x40\x{80}/, $s);
 216         ok($a eq "\x20" && $b eq "\x{100}\x{80}\x40\x20");
 217     }
 218   }
 219
 220     my ($a, $b, $c) = split(/[\x40\x{80}]+/, $s);
 221     ok($a eq "\x20" && $b eq "\x{100}" && $c eq "\x20");
 222 }
 223
 224 {
 225     # 20001205.014
 226
 227     my $a = "ABC\x{263A}";
 228
 229     my @b = split( //, $a );
 230
 231     is(scalar @b, 4);
 232
 233     ok(length($b[3]) == 1 && $b[3] eq "\x{263A}");
 234
 235     $a =~ s/^A/Z/;
 236     ok(length($a) == 4 && $a eq "ZBC\x{263A}");
 237 }
 238
 239 {
 240     my @a = split(/\xFE/, "\xFF\xFE\xFD");
 241
 242     ok(@a == 2 && $a[0] eq "\xFF" && $a[1] eq "\xFD");
 243 }
 244
 245 {
 246     # check that PMf_WHITE is cleared after \s+ is used
 247     # reported in <20010627113312.RWGY6087.viemta06@localhost>
 248     my $r;
 249     foreach my $pat ( qr/\s+/, qr/ll/ ) {
 250         $r = join ':' => split($pat, "hello cruel world");
 251     }
 252     is($r, "he:o cruel world");
 253 }
 254
 255
 256 {
 257     # split /(A)|B/, "1B2" should return (1, undef, 2)
 258     my @x = split /(A)|B/, "1B2";
 259     ok($x[0] eq '1' and (not defined $x[1]) and $x[2] eq '2');
 260 }
 261
 262 {
 263     # [perl #17064]
 264     my $warn;
 265     local $SIG{__WARN__} = sub { $warn = join '', @_; chomp $warn };
 266     my $char = "\x{10f1ff}";
 267     my @a = split /\r?\n/, "$char\n";
 268     ok(@a == 1 && $a[0] eq $char && !defined($warn));
 269 }
 270
 271 {
 272     # [perl #18195]
 273     for my $u (0, 1) {
 274         for my $a (0, 1) {
 275             $_ = 'readin,database,readout';
 276             utf8::upgrade $_ if $u;
 277             /(.+)/;
 278             my @d = split /[,]/,$1;
 279             is(join (':',@d), 'readin:database:readout', "[perl #18195]");
 280         }
 281     }
 282 }
 283
 284 {
 285     $p="a,b";
 286     utf8::upgrade $p;
 287     eval { @a=split(/[, ]+/,$p) };
 288     is ("$@-@a-", '-a b-', '#20912 - split() to array with /[]+/ and utf8');
 289 }
 290
 291 {
 292     is (\@a, \@{"a"}, '@a must be global for following test');
 293     $p="";
 294     $n = @a = split /,/,$p;
 295     is ($n, 0, '#21765 - pmreplroot hack used to return undef for 0 iters');
 296 }
 297
 298 {
 299     # [perl #28938]
 300     # assigning off the end of the array after a split could leave garbage
 301     # in the inner elements
 302
 303     my $x;
 304     @a = split /,/, ',,,,,';
 305     $a[3]=1;
 306     $x = \$a[2];
 307     is (ref $x, 'SCALAR', '#28938 - garbage after extend');
 308 }
 309 {
 310     # check the special casing of split /\s/ and unicode
 311     use charnames qw(:full);
 312     # below test data is extracted from
 313     # PropList-5.0.0.txt
 314     # Date: 2006-06-07, 23:22:52 GMT [MD]
 315     #
 316     # Unicode Character Database
 317     # Copyright (c) 1991-2006 Unicode, Inc.
 318     # For terms of use, see http://www.unicode.org/terms_of_use.html
 319     # For documentation, see UCD.html
 320     my @spaces=(
 321         ord("\t"),      # Cc       <control-0009>
 322         ord("\n"),      # Cc       <control-000A>
 323         # not PerlSpace # Cc       <control-000B>
 324         ord("\f"),      # Cc       <control-000C>
 325         ord("\r"),      # Cc       <control-000D>
 326         ord(" "),       # Zs       SPACE
 327         ord("\N{NEL}"), # Cc       <control-0085>
 328         ord("\N{NO-BREAK SPACE}"),
 329                         # Zs       NO-BREAK SPACE
 330         0x1680,         # Zs       OGHAM SPACE MARK
 331         0x180E,         # Zs       MONGOLIAN VOWEL SEPARATOR
 332         0x2000..0x200A, # Zs  [11] EN QUAD..HAIR SPACE
 333         0x2028,         # Zl       LINE SEPARATOR
 334         0x2029,         # Zp       PARAGRAPH SEPARATOR
 335         0x202F,         # Zs       NARROW NO-BREAK SPACE
 336         0x205F,         # Zs       MEDIUM MATHEMATICAL SPACE
 337         0x3000          # Zs       IDEOGRAPHIC SPACE
 338     );
 339     #diag "Have @{[0+@spaces]} to test\n";
 340     foreach my $cp (@spaces) {
 341         my $msg = sprintf "Space: U+%04x", $cp;
 342         my $space = chr($cp);
 343         my $str="A:$space:B\x{FFFD}";
 344         chop $str;
 345
 346         my @res=split(/\s+/,$str);
 347         ok(@res == 2 && join('-',@res) eq "A:-:B", "$msg - /\\s+/");
 348
 349         my $s2 = "$space$space:A:$space$space:B\x{FFFD}";
 350         chop $s2;
 351
 352         my @r2 = split(' ',$s2);
 353         ok(@r2 == 2 && join('-', @r2) eq ":A:-:B",  "$msg - ' '");
 354
 355         my @r3 = split(/\s+/, $s2);
 356         ok(@r3 == 3 && join('-', @r3) eq "-:A:-:B", "$msg - /\\s+/ No.2");
 357     }
 358 }
 359
 360 {
 361     my $src = "ABC \0 FOO \0  XYZ";
 362     my @s = split(" \0 ", $src);
 363     my @r = split(/ \0 /, $src);
 364     is(scalar(@s), 3);
 365     is($s[0], "ABC");
 366     is($s[1], "FOO");
 367     is($s[2]," XYZ");
 368     is(join(':',@s), join(':',@r));
 369 }