source: trunk/third/perl/t/op/split.t @ 20075

Revision 20075, 6.8 KB checked in by zacheiss, 21 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r20074, which included commits to RCS files with non-trunk default branches.
  • Property svn:executable set to *
Line 
1#!./perl
2
3BEGIN {
4    chdir 't' if -d 't';
5    @INC = '../lib';
6    require './test.pl';
7}
8
9plan tests => 54;
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 -D1024 -e "(\$a,\$b) = split;" 2>&1` }
54elsif ($^O eq 'NetWare') { $foo = `perl -D1024 -e "(\$a,\$b) = split;" 2>&1` }
55elsif ($^O eq 'VMS')  { $foo = `./perl "-D1024" -e "(\$a,\$b) = split;" 2>&1` }
56elsif ($^O eq 'MacOS'){ $foo = `$^X "-D1024" -e "(\$a,\$b) = split;"` }
57else                  { $foo = `./perl -D1024 -e '(\$a,\$b) = split;' 2>&1` }
58ok($foo =~ /DEBUGGING/ || $foo =~ /SV = (VOID|IV\(3\))/);
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}
Note: See TracBrowser for help on using the repository browser.