1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = '../lib'; 6 require './test.pl'; 7} 8 9plan tests => 55; 10 11$FS = ':'; 12 13$_ = 'a:b:c'; 14 15($a,$b,$c) = split($FS,$_); 16 17is(join(';',$a,$b,$c), 'a;b;c'); 18 19@ary = split(/:b:/); 20is(join("$_",@ary), 'aa:b:cc'); 21 22$_ = "abc\n"; 23my @xyz = (@ary = split(//)); 24is(join(".",@ary), "a.b.c.\n"); 25 26$_ = "a:b:c::::"; 27@ary = split(/:/); 28is(join(".",@ary), "a.b.c"); 29 30$_ = join(':',split(' '," a b\tc \t d ")); 31is($_, 'a:b:c:d'); 32 33$_ = join(':',split(/ */,"foo bar bie\tdoll")); 34is($_ , "f:o:o:b:a:r:b:i:e:\t:d:o:l:l"); 35 36$_ = join(':', 'foo', split(/ /,'a b c'), 'bar'); 37is($_, "foo:a:b::c:bar"); 38 39# Can we say how many fields to split to? 40$_ = join(':', split(' ','1 2 3 4 5 6', 3)); 41is($_, '1:2:3 4 5 6'); 42 43# Can we do it as a variable? 44$x = 4; 45$_ = join(':', split(' ','1 2 3 4 5 6', $x)); 46is($_, '1:2:3:4 5 6'); 47 48# Does the 999 suppress null field chopping? 49$_ = join(':', split(/:/,'1:2:3:4:5:6:::', 999)); 50is($_ , '1:2:3:4:5:6:::'); 51 52# Does assignment to a list imply split to one more field than that? 53if ($^O eq 'MSWin32') { $foo = `.\\perl -Dt -e "(\$a,\$b) = split;" 2>&1` } 54elsif ($^O eq 'NetWare') { $foo = `perl -Dt -e "(\$a,\$b) = split;" 2>&1` } 55elsif ($^O eq 'VMS') { $foo = `./perl "-Dt" -e "(\$a,\$b) = split;" 2>&1` } 56elsif ($^O eq 'MacOS'){ $foo = `$^X "-Dt" -e "(\$a,\$b) = split;"` } 57else { $foo = `./perl -Dt -e '(\$a,\$b) = split;' 2>&1` } 58ok($foo =~ /DEBUGGING/ || $foo =~ /\Qconst(IV(3))\E/); 59 60# Can we say how many fields to split to when assigning to a list? 61($a,$b) = split(' ','1 2 3 4 5 6', 2); 62$_ = join(':',$a,$b); 63is($_, '1:2 3 4 5 6'); 64 65# do subpatterns generate additional fields (without trailing nulls)? 66$_ = join '|', split(/,|(-)/, "1-10,20,,,"); 67is($_, "1|-|10||20"); 68 69# do subpatterns generate additional fields (with a limit)? 70$_ = join '|', split(/,|(-)/, "1-10,20,,,", 10); 71is($_, "1|-|10||20||||||"); 72 73# is the 'two undefs' bug fixed? 74(undef, $a, undef, $b) = qw(1 2 3 4); 75is("$a|$b", "2|4"); 76 77# .. even for locals? 78{ 79 local(undef, $a, undef, $b) = qw(1 2 3 4); 80 is("$a|$b", "2|4"); 81} 82 83# check splitting of null string 84$_ = join('|', split(/x/, '',-1), 'Z'); 85is($_, "Z"); 86 87$_ = join('|', split(/x/, '', 1), 'Z'); 88is($_, "Z"); 89 90$_ = join('|', split(/(p+)/,'',-1), 'Z'); 91is($_, "Z"); 92 93$_ = join('|', split(/.?/, '',-1), 'Z'); 94is($_, "Z"); 95 96 97# Are /^/m patterns scanned? 98$_ = join '|', split(/^a/m, "a b a\na d a", 20); 99is($_, "| b a\n| d a"); 100 101# Are /$/m patterns scanned? 102$_ = join '|', split(/a$/m, "a b a\na d a", 20); 103is($_, "a b |\na d |"); 104 105# Are /^/m patterns scanned? 106$_ = join '|', split(/^aa/m, "aa b aa\naa d aa", 20); 107is($_, "| b aa\n| d aa"); 108 109# Are /$/m patterns scanned? 110$_ = join '|', split(/aa$/m, "aa b aa\naa d aa", 20); 111is($_, "aa b |\naa d |"); 112 113# Greedyness: 114$_ = "a : b :c: d"; 115@ary = split(/\s*:\s*/); 116is(($res = join(".",@ary)), "a.b.c.d", $res); 117 118# use of match result as pattern (!) 119is('p:q:r:s', join ':', split('abc' =~ /b/, 'p1q1r1s')); 120 121# /^/ treated as /^/m 122$_ = join ':', split /^/, "ab\ncd\nef\n"; 123is($_, "ab\n:cd\n:ef\n"); 124 125# see if @a = @b = split(...) optimization works 126@list1 = @list2 = split ('p',"a p b c p"); 127ok(@list1 == @list2 && 128 "@list1" eq "@list2" && 129 @list1 == 2 && 130 "@list1" eq "a b c "); 131 132# zero-width assertion 133$_ = join ':', split /(?=\w)/, "rm b"; 134is($_, "r:m :b"); 135 136# unicode splittage 137 138@ary = map {ord} split //, v1.20.300.4000.50000.4000.300.20.1; 139is("@ary", "1 20 300 4000 50000 4000 300 20 1"); 140 141@ary = split(/\x{FE}/, "\x{FF}\x{FE}\x{FD}"); # bug id 20010105.016 142ok(@ary == 2 && 143 $ary[0] eq "\xFF" && $ary[1] eq "\xFD" && 144 $ary[0] eq "\x{FF}" && $ary[1] eq "\x{FD}"); 145 146@ary = split(/(\x{FE}\xFE)/, "\xFF\x{FF}\xFE\x{FE}\xFD\x{FD}"); # variant of 31 147ok(@ary == 3 && 148 $ary[0] eq "\xFF\xFF" && 149 $ary[0] eq "\x{FF}\xFF" && 150 $ary[0] eq "\x{FF}\x{FF}" && 151 $ary[1] eq "\xFE\xFE" && 152 $ary[1] eq "\x{FE}\xFE" && 153 $ary[1] eq "\x{FE}\x{FE}" && 154 $ary[2] eq "\xFD\xFD" && 155 $ary[2] eq "\x{FD}\xFD" && 156 $ary[2] eq "\x{FD}\x{FD}"); 157 158{ 159 my @a = map ord, split(//, join("", map chr, (1234, 123, 2345))); 160 is("@a", "1234 123 2345"); 161} 162 163{ 164 my $x = 'A'; 165 my @a = map ord, split(/$x/, join("", map chr, (1234, ord($x), 2345))); 166 is("@a", "1234 2345"); 167} 168 169{ 170 # bug id 20000427.003 171 172 use warnings; 173 use strict; 174 175 my $sushi = "\x{b36c}\x{5a8c}\x{ff5b}\x{5079}\x{505b}"; 176 177 my @charlist = split //, $sushi; 178 my $r = ''; 179 foreach my $ch (@charlist) { 180 $r = $r . " " . sprintf "U+%04X", ord($ch); 181 } 182 183 is($r, " U+B36C U+5A8C U+FF5B U+5079 U+505B"); 184} 185 186{ 187 my $s = "\x20\x40\x{80}\x{100}\x{80}\x40\x20"; 188 189 SKIP: { 190 if (ord('A') == 193) { 191 skip("EBCDIC", 1); 192 } else { 193 # bug id 20000426.003 194 195 my ($a, $b, $c) = split(/\x40/, $s); 196 ok($a eq "\x20" && $b eq "\x{80}\x{100}\x{80}" && $c eq $a); 197 } 198 } 199 200 my ($a, $b) = split(/\x{100}/, $s); 201 ok($a eq "\x20\x40\x{80}" && $b eq "\x{80}\x40\x20"); 202 203 my ($a, $b) = split(/\x{80}\x{100}\x{80}/, $s); 204 ok($a eq "\x20\x40" && $b eq "\x40\x20"); 205 206 SKIP: { 207 if (ord('A') == 193) { 208 skip("EBCDIC", 1); 209 } else { 210 my ($a, $b) = split(/\x40\x{80}/, $s); 211 ok($a eq "\x20" && $b eq "\x{100}\x{80}\x40\x20"); 212 } 213 } 214 215 my ($a, $b, $c) = split(/[\x40\x{80}]+/, $s); 216 ok($a eq "\x20" && $b eq "\x{100}" && $c eq "\x20"); 217} 218 219{ 220 # 20001205.014 221 222 my $a = "ABC\x{263A}"; 223 224 my @b = split( //, $a ); 225 226 is(scalar @b, 4); 227 228 ok(length($b[3]) == 1 && $b[3] eq "\x{263A}"); 229 230 $a =~ s/^A/Z/; 231 ok(length($a) == 4 && $a eq "ZBC\x{263A}"); 232} 233 234{ 235 my @a = split(/\xFE/, "\xFF\xFE\xFD"); 236 237 ok(@a == 2 && $a[0] eq "\xFF" && $a[1] eq "\xFD"); 238} 239 240{ 241 # check that PMf_WHITE is cleared after \s+ is used 242 # reported in <20010627113312.RWGY6087.viemta06@localhost> 243 my $r; 244 foreach my $pat ( qr/\s+/, qr/ll/ ) { 245 $r = join ':' => split($pat, "hello cruel world"); 246 } 247 is($r, "he:o cruel world"); 248} 249 250 251{ 252 # split /(A)|B/, "1B2" should return (1, undef, 2) 253 my @x = split /(A)|B/, "1B2"; 254 ok($x[0] eq '1' and (not defined $x[1]) and $x[2] eq '2'); 255} 256 257{ 258 # [perl #17064] 259 my $warn; 260 local $SIG{__WARN__} = sub { $warn = join '', @_; chomp $warn }; 261 my $char = "\x{10f1ff}"; 262 my @a = split /\r?\n/, "$char\n"; 263 ok(@a == 1 && $a[0] eq $char && !defined($warn)); 264} 265 266{ 267 # [perl #18195] 268 for my $u (0, 1) { 269 for my $a (0, 1) { 270 $_ = 'readin,database,readout'; 271 utf8::upgrade $_ if $u; 272 /(.+)/; 273 my @d = split /[,]/,$1; 274 is(join (':',@d), 'readin:database:readout', "[perl #18195]"); 275 } 276 } 277} 278 279{ 280 $p="a,b"; 281 utf8::upgrade $p; 282 eval { @a=split(/[, ]+/,$p) }; 283 is ("$@-@a-", '-a b-', '#20912 - split() to array with /[]+/ and utf8'); 284} 285 286{ 287 is (\@a, \@{"a"}, '@a must be global for following test'); 288 $p=""; 289 $n = @a = split /,/,$p; 290 is ($n, 0, '#21765 - pmreplroot hack used to return undef for 0 iters'); 291} 292 293{ 294 # [perl #28938] 295 # assigning off the end of the array after a split could leave garbage 296 # in the inner elements 297 298 my $x; 299 @a = split /,/, ',,,,,'; 300 $a[3]=1; 301 $x = \$a[2]; 302 is (ref $x, 'SCALAR', '#28938 - garbage after extend'); 303} 304 305