[perl5.git] / t / op / split.t

#!./perl

BEGIN {
    chdir 't' if -d 't';
    @INC = '../lib';
    require './test.pl';
}

plan tests => 250;

$FS = ':';

$_ = 'a:b:c';

($a,$b,$c) = split($FS,$_);

is(join(';',$a,$b,$c), 'a;b;c');

@ary = split(/:b:/);
$cnt = split(/:b:/);
is(join("$_",@ary), 'aa:b:cc');
is($cnt, scalar(@ary));

$_ = "abc\n";
my @xyz = (@ary = split(//));
$cnt = split(//);
is(join(".",@ary), "a.b.c.\n");
is($cnt, scalar(@ary));

$_ = "a:b:c::::";
@ary = split(/:/);
$cnt = split(/:/);
is(join(".",@ary), "a.b.c");
is($cnt, scalar(@ary));

$_ = join(':',split(' ',"    a b\tc \t d "));
is($_, 'a:b:c:d');
@ary = split(' ',"    a b\tc \t d ");
$cnt = split(' ',"    a b\tc \t d ");
is($cnt, scalar(@ary));

$_ = join(':',split(/ */,"foo  bar bie\tdoll"));
is($_ , "f:o:o:b:a:r:b:i:e:\t:d:o:l:l");
@ary = split(/ */,"foo  bar bie\tdoll");
$cnt = split(/ */,"foo  bar bie\tdoll");
is($cnt, scalar(@ary));

$_ = join(':', 'foo', split(/ /,'a b  c'), 'bar');
is($_, "foo:a:b::c:bar");
@ary = split(/ /,'a b  c');
$cnt = split(/ /,'a b  c');
is($cnt, scalar(@ary));

# Can we say how many fields to split to?
$_ = join(':', split(' ','1 2 3 4 5 6', 3));
is($_, '1:2:3 4 5 6');
@ary = split(' ','1 2 3 4 5 6', 3);
$cnt = split(' ','1 2 3 4 5 6', 3);
is($cnt, scalar(@ary));

# Can we do it as a variable?
$x = 4;
$_ = join(':', split(' ','1 2 3 4 5 6', $x));
is($_, '1:2:3:4 5 6');
@ary = split(' ','1 2 3 4 5 6', $x);
$cnt = split(' ','1 2 3 4 5 6', $x);
is($cnt, scalar(@ary));

# Does the 999 suppress null field chopping?
$_ = join(':', split(/:/,'1:2:3:4:5:6:::', 999));
is($_ , '1:2:3:4:5:6:::');
@ary = split(/:/,'1:2:3:4:5:6:::', 999);
$cnt = split(/:/,'1:2:3:4:5:6:::', 999);
is($cnt, scalar(@ary));

# Does assignment to a list imply split to one more field than that?
$foo = runperl( switches => ['-Dt'], stderr => 1, prog => '($a,$b)=split;' );
ok($foo =~ /DEBUGGING/ || $foo =~ /const\n?\Q(IV(3))\E/);

# Can we say how many fields to split to when assigning to a list?
($a,$b) = split(' ','1 2 3 4 5 6', 2);
$_ = join(':',$a,$b);
is($_, '1:2 3 4 5 6');

# do subpatterns generate additional fields (without trailing nulls)?
$_ = join '|', split(/,|(-)/, "1-10,20,,,");
is($_, "1|-|10||20");
@ary = split(/,|(-)/, "1-10,20,,,");
$cnt = split(/,|(-)/, "1-10,20,,,");
is($cnt, scalar(@ary));

# do subpatterns generate additional fields (with a limit)?
$_ = join '|', split(/,|(-)/, "1-10,20,,,", 10);
is($_, "1|-|10||20||||||");
@ary = split(/,|(-)/, "1-10,20,,,", 10);
$cnt = split(/,|(-)/, "1-10,20,,,", 10);
is($cnt, scalar(@ary));

# is the 'two undefs' bug fixed?
(undef, $a, undef, $b) = qw(1 2 3 4);
is("$a|$b", "2|4");

# .. even for locals?
{
  local(undef, $a, undef, $b) = qw(1 2 3 4);
  is("$a|$b", "2|4");
}

# check splitting of null string
$_ = join('|', split(/x/,   '',-1), 'Z');
is($_, "Z");
@ary = split(/x/,   '',-1);
$cnt = split(/x/,   '',-1);
is($cnt, scalar(@ary));

$_ = join('|', split(/x/,   '', 1), 'Z');
is($_, "Z");
@ary = split(/x/,   '', 1);
$cnt = split(/x/,   '', 1);
is($cnt, scalar(@ary));

$_ = join('|', split(/(p+)/,'',-1), 'Z');
is($_, "Z");
@ary = split(/(p+)/,'',-1);
$cnt = split(/(p+)/,'',-1);
is($cnt, scalar(@ary));

$_ = join('|', split(/.?/,  '',-1), 'Z');
is($_, "Z");
@ary = split(/.?/,  '',-1);
$cnt = split(/.?/,  '',-1);
is($cnt, scalar(@ary));


# Are /^/m patterns scanned?
$_ = join '|', split(/^a/m, "a b a\na d a", 20);
is($_, "| b a\n| d a");
@ary = split(/^a/m, "a b a\na d a", 20);
$cnt = split(/^a/m, "a b a\na d a", 20);
is($cnt, scalar(@ary));

# Are /$/m patterns scanned?
$_ = join '|', split(/a$/m, "a b a\na d a", 20);
is($_, "a b |\na d |");
@ary = split(/a$/m, "a b a\na d a", 20);
$cnt = split(/a$/m, "a b a\na d a", 20);
is($cnt, scalar(@ary));

# Are /^/m patterns scanned?
$_ = join '|', split(/^aa/m, "aa b aa\naa d aa", 20);
is($_, "| b aa\n| d aa");
@ary = split(/^aa/m, "aa b aa\naa d aa", 20);
$cnt = split(/^aa/m, "aa b aa\naa d aa", 20);
is($cnt, scalar(@ary));

# Are /$/m patterns scanned?
$_ = join '|', split(/aa$/m, "aa b aa\naa d aa", 20);
is($_, "aa b |\naa d |");
@ary = split(/aa$/m, "aa b aa\naa d aa", 20);
$cnt = split(/aa$/m, "aa b aa\naa d aa", 20);
is($cnt, scalar(@ary));

# Greedyness:
$_ = "a : b :c: d";
@ary = split(/\s*:\s*/);
$cnt = split(/\s*:\s*/);
is(($res = join(".",@ary)), "a.b.c.d", $res);
is($cnt, scalar(@ary));

# use of match result as pattern (!)
is('p:q:r:s', join ':', split('abc' =~ /b/, 'p1q1r1s'));
@ary = split('abc' =~ /b/, 'p1q1r1s');
$cnt = split('abc' =~ /b/, 'p1q1r1s');
is($cnt, scalar(@ary));

# /^/ treated as /^/m
$_ = join ':', split /^/, "ab\ncd\nef\n";
is($_, "ab\n:cd\n:ef\n");

# see if @a = @b = split(...) optimization works
@list1 = @list2 = split ('p',"a p b c p");
ok(@list1 == @list2 &&
   "@list1" eq "@list2" &&
   @list1 == 2 &&
   "@list1" eq "a   b c ");

# zero-width assertion
$_ = join ':', split /(?=\w)/, "rm b";
is($_, "r:m :b");
@ary = split /(?=\w)/, "rm b";
$cnt = split /(?=\w)/, "rm b";
is($cnt, scalar(@ary));

# unicode splittage

@ary = map {ord} split //, v1.20.300.4000.50000.4000.300.20.1;
$cnt =           split //, v1.20.300.4000.50000.4000.300.20.1;
is("@ary", "1 20 300 4000 50000 4000 300 20 1");
is($cnt, scalar(@ary));

@ary = split(/\x{FE}/, "\x{FF}\x{FE}\x{FD}"); # bug id 20010105.016
$cnt = split(/\x{FE}/, "\x{FF}\x{FE}\x{FD}"); # bug id 20010105.016
ok(@ary == 2 &&
   $ary[0] eq "\xFF"   && $ary[1] eq "\xFD" &&
   $ary[0] eq "\x{FF}" && $ary[1] eq "\x{FD}");
is($cnt, scalar(@ary));

@ary = split(/(\x{FE}\xFE)/, "\xFF\x{FF}\xFE\x{FE}\xFD\x{FD}"); # variant of 31
$cnt = split(/(\x{FE}\xFE)/, "\xFF\x{FF}\xFE\x{FE}\xFD\x{FD}"); # variant of 31
ok(@ary == 3 &&
   $ary[0] eq "\xFF\xFF"     &&
   $ary[0] eq "\x{FF}\xFF"   &&
   $ary[0] eq "\x{FF}\x{FF}" &&
   $ary[1] eq "\xFE\xFE"     &&
   $ary[1] eq "\x{FE}\xFE"   &&
   $ary[1] eq "\x{FE}\x{FE}" &&
   $ary[2] eq "\xFD\xFD"     &&
   $ary[2] eq "\x{FD}\xFD"   &&
   $ary[2] eq "\x{FD}\x{FD}");
is($cnt, scalar(@ary));

{
    my @a = map ord, split(//, join("", map chr, (1234, 123, 2345)));
    my $c =          split(//, join("", map chr, (1234, 123, 2345)));
    is("@a", "1234 123 2345");
    is($c, scalar(@a));
}

{
    my $x = 'A';
    my @a = map ord, split(/$x/, join("", map chr, (1234, ord($x), 2345)));
    my $c =          split(/$x/, join("", map chr, (1234, ord($x), 2345)));
    is("@a", "1234 2345");
    is($c, scalar(@a));
}

{
    # bug id 20000427.003 

    use warnings;
    use strict;

    my $sushi = "\x{b36c}\x{5a8c}\x{ff5b}\x{5079}\x{505b}";

    my @charlist = split //, $sushi;
    my $charnum  = split //, $sushi;
    is($charnum, scalar(@charlist));
    my $r = '';
    foreach my $ch (@charlist) {
	$r = $r . " " . sprintf "U+%04X", ord($ch);
    }

    is($r, " U+B36C U+5A8C U+FF5B U+5079 U+505B");
}

{
    my $s = "\x20\x40\x{80}\x{100}\x{80}\x40\x20";

  SKIP: {
    if (ord('A') == 193) {
	skip("EBCDIC", 1);
    } else {
	# bug id 20000426.003

	my ($a, $b, $c) = split(/\x40/, $s);
	ok($a eq "\x20" && $b eq "\x{80}\x{100}\x{80}" && $c eq $a);
    }
  }

    my ($a, $b) = split(/\x{100}/, $s);
    ok($a eq "\x20\x40\x{80}" && $b eq "\x{80}\x40\x20");

    my ($a, $b) = split(/\x{80}\x{100}\x{80}/, $s);
    ok($a eq "\x20\x40" && $b eq "\x40\x20");

  SKIP: {
    if (ord('A') == 193) {
	skip("EBCDIC", 1);
    }  else {
	my ($a, $b) = split(/\x40\x{80}/, $s);
	ok($a eq "\x20" && $b eq "\x{100}\x{80}\x40\x20");
    }
  }

    my ($a, $b, $c) = split(/[\x40\x{80}]+/, $s);
    ok($a eq "\x20" && $b eq "\x{100}" && $c eq "\x20");
}

{
    # 20001205.014

    my $a = "ABC\x{263A}";

    my @b = split( //, $a );
    my $c = split( //, $a );
    is($c, scalar(@b));

    is(scalar @b, 4);

    ok(length($b[3]) == 1 && $b[3] eq "\x{263A}");

    $a =~ s/^A/Z/;
    ok(length($a) == 4 && $a eq "ZBC\x{263A}");
}

{
    my @a = split(/\xFE/, "\xFF\xFE\xFD");
    my $b = split(/\xFE/, "\xFF\xFE\xFD");

    ok(@a == 2 && $a[0] eq "\xFF" && $a[1] eq "\xFD");
    is($b, scalar(@a));
}

{
    # check that PMf_WHITE is cleared after \s+ is used
    # reported in <20010627113312.RWGY6087.viemta06@localhost>
    my $r;
    foreach my $pat ( qr/\s+/, qr/ll/ ) {
	$r = join ':' => split($pat, "hello cruel world");
    }
    is($r, "he:o cruel world");
}


{
    # split /(A)|B/, "1B2" should return (1, undef, 2)
    my @x = split /(A)|B/, "1B2";
    my $y = split /(A)|B/, "1B2";
    is($y, scalar(@x));
    ok($x[0] eq '1' and (not defined $x[1]) and $x[2] eq '2');
}

{
    # [perl #17064]
    my $warn;
    local $SIG{__WARN__} = sub { $warn = join '', @_; chomp $warn };
    my $char = "\x{10f1ff}";
    my @a = split /\r?\n/, "$char\n";
    my $b = split /\r?\n/, "$char\n";
    is($b, scalar(@a));
    ok(@a == 1 && $a[0] eq $char && !defined($warn));
}

{
    # [perl #18195]
    for my $u (0, 1) {
	for my $a (0, 1) {
	    $_ = 'readin,database,readout';
	    utf8::upgrade $_ if $u;
	    /(.+)/;
	    my @d = split /[,]/,$1;
	    my $e = split /[,]/,$1;
	    is($e, scalar(@d));
	    is(join (':',@d), 'readin:database:readout', "[perl #18195]");
	}
    }
}

{
    $p="a,b";
    utf8::upgrade $p;
    eval { @a=split(/[, ]+/,$p) };
    eval { $b=split(/[, ]+/,$p) };
    is($b, scalar(@a));
    is ("$@-@a-", '-a b-', '#20912 - split() to array with /[]+/ and utf8');
}

{
    is (\@a, \@{"a"}, '@a must be global for following test');
    $p="";
    $n = @a = split /,/,$p;
    is ($n, 0, '#21765 - pmreplroot hack used to return undef for 0 iters');
}

{
    # [perl #28938]
    # assigning off the end of the array after a split could leave garbage
    # in the inner elements

    my $x;
    @a = split /,/, ',,,,,';
    $a[3]=1;
    $x = \$a[2];
    is (ref $x, 'SCALAR', '#28938 - garbage after extend');
}
{
    # check the special casing of split /\s/ and unicode
    use charnames qw(:full);
    # below test data is extracted from
    # PropList-5.0.0.txt
    # Date: 2006-06-07, 23:22:52 GMT [MD]
    #
    # Unicode Character Database
    # Copyright (c) 1991-2006 Unicode, Inc.
    # For terms of use, see http://www.unicode.org/terms_of_use.html
    # For documentation, see UCD.html
    my @spaces=(
	ord("\t"),      # Cc       <control-0009>
	ord("\n"),      # Cc       <control-000A>
	# not PerlSpace # Cc       <control-000B>
	ord("\f"),      # Cc       <control-000C>
	ord("\r"),      # Cc       <control-000D>
	ord(" "),       # Zs       SPACE
	ord("\N{NEL}"), # Cc       <control-0085>
	ord("\N{NO-BREAK SPACE}"),
			# Zs       NO-BREAK SPACE
        0x1680,         # Zs       OGHAM SPACE MARK
        0x180E,         # Zs       MONGOLIAN VOWEL SEPARATOR
        0x2000..0x200A, # Zs  [11] EN QUAD..HAIR SPACE
        0x2028,         # Zl       LINE SEPARATOR
        0x2029,         # Zp       PARAGRAPH SEPARATOR
        0x202F,         # Zs       NARROW NO-BREAK SPACE
        0x205F,         # Zs       MEDIUM MATHEMATICAL SPACE
        0x3000          # Zs       IDEOGRAPHIC SPACE
    );
    #diag "Have @{[0+@spaces]} to test\n";
    foreach my $cp (@spaces) {
	my $msg = sprintf "Space: U+%04x", $cp;
        my $space = chr($cp);
        my $str="A:$space:B\x{FFFD}";
        chop $str;

        my @res=split(/\s+/,$str);
        my $cnt=split(/\s+/,$str);
        ok(@res == 2 && join('-',@res) eq "A:-:B", "$msg - /\\s+/");
	is($cnt, scalar(@res), "$msg - /\\s+/ (count)");

        my $s2 = "$space$space:A:$space$space:B\x{FFFD}";
        chop $s2;

        my @r2 = split(' ',$s2);
	my $c2 = split(' ',$s2);
        ok(@r2 == 2 && join('-', @r2) eq ":A:-:B",  "$msg - ' '");
	is($c2, scalar(@r2), "$msg - ' ' (count)");

        my @r3 = split(/\s+/, $s2);
        my $c3 = split(/\s+/, $s2);
        ok(@r3 == 3 && join('-', @r3) eq "-:A:-:B", "$msg - /\\s+/ No.2");
	is($c3, scalar(@r3), "$msg - /\\s+/ No.2 (count)");
    }
}

{
    my $src = "ABC \0 FOO \0  XYZ";
    my @s = split(" \0 ", $src);
    my @r = split(/ \0 /, $src);
    my $cs = split(" \0 ", $src);
    my $cr = split(/ \0 /, $src);
    is(scalar(@s), 3);
    is($cs, 3);
    is($cr, 3);
    is($s[0], "ABC");
    is($s[1], "FOO");
    is($s[2]," XYZ");
    is(join(':',@s), join(':',@r));
}

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