Devel::PPPort: Fix D_PPP_FIX_UTF8_ERRSV macro
[perl.git] / t / op / chop.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     require './test.pl';
6     set_up_inc('../lib');
7     require './charset_tools.pl';
8 }
9
10 my $tests_count = 148;
11 plan tests => $tests_count;
12
13 $_ = 'abc';
14 $c = foo();
15 is ($c . $_, 'cab', 'optimized');
16
17 $_ = 'abc';
18 $c = chop($_);
19 is ($c . $_ , 'cab', 'unoptimized');
20
21 sub foo {
22     chop;
23 }
24
25 @foo = ("hi \n","there\n","!\n");
26 @bar = @foo;
27 chop(@bar);
28 is (join('',@bar), 'hi there!', 'chop list of strings');
29
30 $foo = "\n";
31 chop($foo,@foo);
32 is (join('',$foo,@foo), 'hi there!', 'chop on list reduces one-character element to an empty string');
33
34 $_ = "foo\n\n";
35 $got = chomp();
36 is($got, 1, 'check return value when chomp string ending with two newlines; $/ is set to default of one newline');
37 is ($_, "foo\n", 'chomp string ending with two newlines while $/ is set to one newline' );
38
39 $_ = "foo\n";
40 $got = chomp();
41 is($got, 1, 'check return value chomp string ending with one newline while $/ is set to a newline');
42 is ($_, "foo", 'test typical use of chomp; chomp a string ending in a single newline while $/ is set to default of one newline');
43
44 $_ = "foo";
45 $got = chomp();
46 is($got, 0, 'check return value when chomp a string that does not end with current value of $/, 0 should be returned');
47 is ($_, "foo", 'chomp a string that does not end with the current value of $/');
48
49 $_ = "foo";
50 $/ = "oo";
51 $got = chomp();
52 is ($got, "2", 'check return value when chomp string with $/ consisting of more than one character, and with the ending of the string matching $/');
53 is ($_, "f", 'chomp a string when $/ consists of two characters that are at the end of the string, check that chomped string contains remnant of original string');
54
55 $_ = "bar";
56 $/ = "oo";
57 $got = chomp();
58 is($got, "0", 'check return value when call chomp with $/ consisting of more than one character, and with the ending of the string NOT matching $/');
59 is ($_, "bar", 'chomp a string when $/ consists of two characters that are NOT at the end of the string');
60
61 $_ = "f\n\n\n\n\n";
62 $/ = "";
63 $got = chomp();
64 is ($got, 5, 'check return value when chomp in paragraph mode on string ending with 5 newlines');
65 is ($_, "f", 'chomp in paragraph mode on string ending with 5 newlines');
66
67 $_ = "f\n\n";
68 $/ = "";
69 $got = chomp();
70 is ($got, 2, 'check return value when chomp in paragraph mode on string ending with 2 newlines');
71 is ($_, "f", 'chomp in paragraph mode on string ending with 2 newlines');
72
73 $_ = "f\n";
74 $/ = "";
75 $got = chomp();
76 is ($got, 1, 'check return value when chomp in paragraph mode on string ending with 1 newline');
77 is ($_, "f", 'chomp in paragraph mode on string ending with 1 newlines');
78
79 $_ = "f";
80 $/ = "";
81 $got = chomp();
82 is ($got, 0, 'check return value when chomp in paragraph mode on string ending with no newlines');
83 is ($_, "f", 'chomp in paragraph mode on string lacking trailing newlines');
84
85 $_ = "xx";
86 $/ = "xx";
87 $got = chomp();
88 is ($got, 2, 'check return value when chomp string that consists solely of current value of $/');
89 is ($_, "", 'chomp on string that consists solely of current value of $/; check that empty string remains');
90
91 $_ = "axx";
92 $/ = "xx";
93 $got = chomp();
94 is ($got, 2, 'check return value when chomp string that ends with current value of $/. $/ contains two characters');
95 is ($_, "a", 'check that when chomp string that ends with currnt value of $/, the part of original string that wasn\'t in $/ remains');
96
97 $_ = "axx";
98 $/ = "yy";
99 $got = chomp();
100 is ($got, 0, 'check return value when chomp string that does not end with $/');
101 is ($_, "axx", 'chomp a string that does not end with $/, the entire string should remain intact');
102
103 # This case once mistakenly behaved like paragraph mode.
104 $_ = "ab\n";
105 $/ = \3;
106 $got = chomp();
107 is ($got, 0, 'check return value when call chomp with $_ = "ab\\n", $/ = \3' );
108 is ($_, "ab\n", 'chomp with $_ = "ab\\n", $/ = \3' );
109
110 # Go Unicode.
111
112 $_ = "abc\x{1234}";
113 chop;
114 is ($_, "abc", 'Go Unicode');
115
116 $_ = "abc\x{1234}d";
117 chop;
118 is ($_, "abc\x{1234}");
119
120 $_ = "\x{1234}\x{2345}";
121 chop;
122 is ($_, "\x{1234}");
123
124 my @stuff = qw(this that);
125 is (chop(@stuff[0,1]), 't');
126
127 # bug id 20010305.012 (#5972)
128 @stuff = qw(ab cd ef);
129 is (chop(@stuff = @stuff), 'f');
130
131 @stuff = qw(ab cd ef);
132 is (chop(@stuff[0, 2]), 'f');
133
134 my %stuff = (1..4);
135 is (chop(@stuff{1, 3}), '4');
136
137 # chomp should not stringify references unless it decides to modify them
138 $_ = [];
139 $/ = "\n";
140 $got = chomp();
141 ok ($got == 0) or print "# got $got\n";
142 is (ref($_), "ARRAY", "chomp ref (modify)");
143
144 $/ = ")";  # the last char of something like "ARRAY(0x80ff6e4)"
145 $got = chomp();
146 ok ($got == 1) or print "# got $got\n";
147 ok (!ref($_), "chomp ref (no modify)");
148
149 $/ = "\n";
150
151 %chomp = ("One" => "One", "Two\n" => "Two", "" => "");
152 %chop = ("One" => "On", "Two\n" => "Two", "" => "");
153
154 foreach (keys %chomp) {
155   my $key = $_;
156   eval {chomp $_};
157   if ($@) {
158     my $err = $@;
159     $err =~ s/\n$//s;
160     fail ("\$\@ = \"$err\"");
161   } else {
162     is ($_, $chomp{$key}, "chomp hash key");
163   }
164 }
165
166 foreach (keys %chop) {
167   my $key = $_;
168   eval {chop $_};
169   if ($@) {
170     my $err = $@;
171     $err =~ s/\n$//s;
172     fail ("\$\@ = \"$err\"");
173   } else {
174     is ($_, $chop{$key}, "chop hash key");
175   }
176 }
177
178 # chop and chomp can't be lvalues
179 eval 'chop($x) = 1;';
180 ok($@ =~ /Can\'t modify.*chop.*in.*assignment/);
181 eval 'chomp($x) = 1;';
182 ok($@ =~ /Can\'t modify.*chom?p.*in.*assignment/);
183 eval 'chop($x, $y) = (1, 2);';
184 ok($@ =~ /Can\'t modify.*chop.*in.*assignment/);
185 eval 'chomp($x, $y) = (1, 2);';
186 ok($@ =~ /Can\'t modify.*chom?p.*in.*assignment/);
187
188 my @chars = ("N",
189              uni_to_native("\xd3"),
190              substr (uni_to_native("\xd4") . "\x{100}", 0, 1),
191              chr 1296);
192 foreach my $start (@chars) {
193   foreach my $end (@chars) {
194     local $/ = $end;
195     my $message = "start=" . ord ($start) . " end=" . ord $end;
196     my $string = $start . $end;
197     is (chomp ($string), 1, "$message [returns 1]");
198     is ($string, $start, $message);
199
200     my $end_utf8 = $end;
201     utf8::encode ($end_utf8);
202     next if $end_utf8 eq $end;
203
204     # $end ne $end_utf8, so these should not chomp.
205     $string = $start . $end_utf8;
206     my $chomped = $string;
207     is (chomp ($chomped), 0, "$message (end as bytes) [returns 0]");
208     is ($chomped, $string, "$message (end as bytes)");
209
210     $/ = $end_utf8;
211     $string = $start . $end;
212     $chomped = $string;
213     is (chomp ($chomped), 0, "$message (\$/ as bytes) [returns 0]");
214     is ($chomped, $string, "$message (\$/ as bytes)");
215   }
216 }
217
218 {
219     # returns length in characters, but not in bytes.
220     $/ = "\x{100}";
221     $a = "A$/";
222     $b = chomp $a;
223     is ($b, 1);
224
225     $/ = "\x{100}\x{101}";
226     $a = "A$/";
227     $b = chomp $a;
228     is ($b, 2);
229 }
230
231 {
232     # [perl #36569] chop fails on decoded string with trailing nul
233     my $asc = "perl\0";
234     my $utf = "perl".pack('U',0); # marked as utf8
235     is(chop($asc), "\0", "chopping ascii NUL");
236     is(chop($utf), "\0", "chopping utf8 NUL");
237     is($asc, "perl", "chopped ascii NUL");
238     is($utf, "perl", "chopped utf8 NUL");
239 }
240
241 {
242     # Change 26011: Re: A surprising segfault
243     # to make sure only that these obfuscated sentences will not crash.
244
245     map chop(+()), ('')x68;
246     ok(1, "extend sp in pp_chop");
247
248     map chomp(+()), ('')x68;
249     ok(1, "extend sp in pp_chomp");
250 }
251
252 SKIP: {
253     # [perl #73246] chop doesn't support utf8
254     # the problem was UTF8_IS_START() didn't handle perl's extended UTF8
255     # The first code point that failed was 0x80000000, which is now illegal on
256     # 32-bit machines.
257
258     use Config;
259     ($Config{ivsize} > 4)
260         or skip("this build can't handle very large characters", 4);
261
262     # Use chr instead of \x{} so doesn't try to compile these on 32-bit
263     # machines, which would crash
264     my $utf = chr(0x80000001) . chr(0x80000000);
265     my $result = chop($utf);
266     is($utf, chr(0x80000001), "chopping high 'unicode'- remnant");
267     is($result, chr(0x80000000), "chopping high 'unicode' - result");
268
269     no warnings;
270     $utf = chr(0x7fffffffffffffff) . chr(0x7ffffffffffffffe);
271     $result = chop($utf);
272     is($utf, chr(0x7fffffffffffffff), "chop even higher 'unicode'- remnant");
273     is($result, chr(0x7ffffffffffffffe), "chop even higher 'unicode' - result");
274 }
275
276 $/ = "\n";
277 {
278     my $expected = 99999;
279     my $input = "UserID\talpha $expected\n";
280     my $uid = '';
281     chomp(my @line = split (/ |\t/,$input));
282     $uid = $line[-1];
283     is($uid, $expected,
284         "RT #123057: chomp works as expected on split");
285 }
286
287 {
288     my $a = local $/ = 7;
289     $a = chomp $a;
290     is $a, 1, 'lexical $a = chomp $a when $a eq $/ eq 7';
291     $a = $/ = 0;
292     $a = chomp $a;
293     is $a, 1, 'lexical $a = chomp $a when $a eq $/ eq 0';
294     my @a = "7";
295     for my $b($a[0]) {
296         $/ = 7;
297         $b = chomp @a;
298         is $b, 1,
299           'lexical $b = chomp @a when $b eq $/ eq 7 and \$a[0] == \$b';
300         $b = $/ = 0;
301         $b = chomp @a;
302         is $b, 1,
303           'lexical $b = chomp @a when $b eq $/ eq 0 and \$a[0] == \$b';
304     }
305 }