This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Avoid overflow warning in chop.t.
[perl5.git] / t / op / chop.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     @INC = '../lib';
6     require './test.pl';
7 }
8
9 plan tests => 143;
10
11 $_ = 'abc';
12 $c = foo();
13 is ($c . $_, 'cab', 'optimized');
14
15 $_ = 'abc';
16 $c = chop($_);
17 is ($c . $_ , 'cab', 'unoptimized');
18
19 sub foo {
20     chop;
21 }
22
23 @foo = ("hi \n","there\n","!\n");
24 @bar = @foo;
25 chop(@bar);
26 is (join('',@bar), 'hi there!');
27
28 $foo = "\n";
29 chop($foo,@foo);
30 is (join('',$foo,@foo), 'hi there!');
31
32 $_ = "foo\n\n";
33 $got = chomp();
34 ok ($got == 1) or print "# got $got\n";
35 is ($_, "foo\n");
36
37 $_ = "foo\n";
38 $got = chomp();
39 ok ($got == 1) or print "# got $got\n";
40 is ($_, "foo");
41
42 $_ = "foo";
43 $got = chomp();
44 ok ($got == 0) or print "# got $got\n";
45 is ($_, "foo");
46
47 $_ = "foo";
48 $/ = "oo";
49 $got = chomp();
50 ok ($got == 2) or print "# got $got\n";
51 is ($_, "f");
52
53 $_ = "bar";
54 $/ = "oo";
55 $got = chomp();
56 ok ($got == 0) or print "# got $got\n";
57 is ($_, "bar");
58
59 $_ = "f\n\n\n\n\n";
60 $/ = "";
61 $got = chomp();
62 ok ($got == 5) or print "# got $got\n";
63 is ($_, "f");
64
65 $_ = "f\n\n";
66 $/ = "";
67 $got = chomp();
68 ok ($got == 2) or print "# got $got\n";
69 is ($_, "f");
70
71 $_ = "f\n";
72 $/ = "";
73 $got = chomp();
74 ok ($got == 1) or print "# got $got\n";
75 is ($_, "f");
76
77 $_ = "f";
78 $/ = "";
79 $got = chomp();
80 ok ($got == 0) or print "# got $got\n";
81 is ($_, "f");
82
83 $_ = "xx";
84 $/ = "xx";
85 $got = chomp();
86 ok ($got == 2) or print "# got $got\n";
87 is ($_, "");
88
89 $_ = "axx";
90 $/ = "xx";
91 $got = chomp();
92 ok ($got == 2) or print "# got $got\n";
93 is ($_, "a");
94
95 $_ = "axx";
96 $/ = "yy";
97 $got = chomp();
98 ok ($got == 0) or print "# got $got\n";
99 is ($_, "axx");
100
101 # This case once mistakenly behaved like paragraph mode.
102 $_ = "ab\n";
103 $/ = \3;
104 $got = chomp();
105 ok ($got == 0) or print "# got $got\n";
106 is ($_, "ab\n");
107
108 # Go Unicode.
109
110 $_ = "abc\x{1234}";
111 chop;
112 is ($_, "abc", "Go Unicode");
113
114 $_ = "abc\x{1234}d";
115 chop;
116 is ($_, "abc\x{1234}");
117
118 $_ = "\x{1234}\x{2345}";
119 chop;
120 is ($_, "\x{1234}");
121
122 my @stuff = qw(this that);
123 is (chop(@stuff[0,1]), 't');
124
125 # bug id 20010305.012
126 @stuff = qw(ab cd ef);
127 is (chop(@stuff = @stuff), 'f');
128
129 @stuff = qw(ab cd ef);
130 is (chop(@stuff[0, 2]), 'f');
131
132 my %stuff = (1..4);
133 is (chop(@stuff{1, 3}), '4');
134
135 # chomp should not stringify references unless it decides to modify them
136 $_ = [];
137 $/ = "\n";
138 $got = chomp();
139 ok ($got == 0) or print "# got $got\n";
140 is (ref($_), "ARRAY", "chomp ref (modify)");
141
142 $/ = ")";  # the last char of something like "ARRAY(0x80ff6e4)"
143 $got = chomp();
144 ok ($got == 1) or print "# got $got\n";
145 ok (!ref($_), "chomp ref (no modify)");
146
147 $/ = "\n";
148
149 %chomp = ("One" => "One", "Two\n" => "Two", "" => "");
150 %chop = ("One" => "On", "Two\n" => "Two", "" => "");
151
152 foreach (keys %chomp) {
153   my $key = $_;
154   eval {chomp $_};
155   if ($@) {
156     my $err = $@;
157     $err =~ s/\n$//s;
158     fail ("\$\@ = \"$err\"");
159   } else {
160     is ($_, $chomp{$key}, "chomp hash key");
161   }
162 }
163
164 foreach (keys %chop) {
165   my $key = $_;
166   eval {chop $_};
167   if ($@) {
168     my $err = $@;
169     $err =~ s/\n$//s;
170     fail ("\$\@ = \"$err\"");
171   } else {
172     is ($_, $chop{$key}, "chop hash key");
173   }
174 }
175
176 # chop and chomp can't be lvalues
177 eval 'chop($x) = 1;';
178 ok($@ =~ /Can\'t modify.*chop.*in.*assignment/);
179 eval 'chomp($x) = 1;';
180 ok($@ =~ /Can\'t modify.*chom?p.*in.*assignment/);
181 eval 'chop($x, $y) = (1, 2);';
182 ok($@ =~ /Can\'t modify.*chop.*in.*assignment/);
183 eval 'chomp($x, $y) = (1, 2);';
184 ok($@ =~ /Can\'t modify.*chom?p.*in.*assignment/);
185
186 my @chars = ("N", latin1_to_native("\xd3"), substr ("\xd4\x{100}", 0, 1), chr 1296);
187 foreach my $start (@chars) {
188   foreach my $end (@chars) {
189     local $/ = $end;
190     my $message = "start=" . ord ($start) . " end=" . ord $end;
191     my $string = $start . $end;
192     is (chomp ($string), 1, "$message [returns 1]");
193     is ($string, $start, $message);
194
195     my $end_utf8 = $end;
196     utf8::encode ($end_utf8);
197     next if $end_utf8 eq $end;
198
199     # $end ne $end_utf8, so these should not chomp.
200     $string = $start . $end_utf8;
201     my $chomped = $string;
202     is (chomp ($chomped), 0, "$message (end as bytes) [returns 0]");
203     is ($chomped, $string, "$message (end as bytes)");
204
205     $/ = $end_utf8;
206     $string = $start . $end;
207     $chomped = $string;
208     is (chomp ($chomped), 0, "$message (\$/ as bytes) [returns 0]");
209     is ($chomped, $string, "$message (\$/ as bytes)");
210   }
211 }
212
213 {
214     # returns length in characters, but not in bytes.
215     $/ = "\x{100}";
216     $a = "A$/";
217     $b = chomp $a;
218     is ($b, 1);
219
220     $/ = "\x{100}\x{101}";
221     $a = "A$/";
222     $b = chomp $a;
223     is ($b, 2);
224 }
225
226 {
227     # [perl #36569] chop fails on decoded string with trailing nul
228     my $asc = "perl\0";
229     my $utf = "perl".pack('U',0); # marked as utf8
230     is(chop($asc), "\0", "chopping ascii NUL");
231     is(chop($utf), "\0", "chopping utf8 NUL");
232     is($asc, "perl", "chopped ascii NUL");
233     is($utf, "perl", "chopped utf8 NUL");
234 }
235
236 {
237     # Change 26011: Re: A surprising segfault
238     # to make sure only that these obfuscated sentences will not crash.
239
240     map chop(+()), ('')x68;
241     ok(1, "extend sp in pp_chop");
242
243     map chomp(+()), ('')x68;
244     ok(1, "extend sp in pp_chomp");
245 }
246
247 {
248     # [perl #73246] chop doesn't support utf8
249     # the problem was UTF8_IS_START() didn't handle perl's extended UTF8
250     my $utf = "\x{80000001}\x{80000000}";
251     my $result = chop($utf);
252     is($utf, "\x{80000001}", "chopping high 'unicode'- remnant");
253     is($result, "\x{80000000}", "chopping high 'unicode' - result");
254
255     SKIP: {
256         no warnings 'overflow'; # avoid compile-time warnings below on 32-bit architectures
257         use Config;
258         $Config{ivsize} >= 8
259           or skip("this build can't handle very large characters", 2);
260         my $utf = "\x{ffffffffffffffff}\x{fffffffffffffffe}";
261         my $result = chop $utf;
262         is($utf, "\x{ffffffffffffffff}", "chop even higher 'unicode' - remnant");
263         is($result, "\x{fffffffffffffffe}", "chop even higher 'unicode' - result");
264     }
265 }