1#!./perl
2
3BEGIN {
4    chdir 't' if -d 't';
5    require './test.pl';
6    set_up_inc('../lib');
7    require './charset_tools.pl';
8}
9
10my $tests_count = 148;
11plan tests => $tests_count;
12
13$_ = 'abc';
14$c = foo();
15is ($c . $_, 'cab', 'optimized');
16
17$_ = 'abc';
18$c = chop($_);
19is ($c . $_ , 'cab', 'unoptimized');
20
21sub foo {
22    chop;
23}
24
25@foo = ("hi \n","there\n","!\n");
26@bar = @foo;
27chop(@bar);
28is (join('',@bar), 'hi there!', 'chop list of strings');
29
30$foo = "\n";
31chop($foo,@foo);
32is (join('',$foo,@foo), 'hi there!', 'chop on list reduces one-character element to an empty string');
33
34$_ = "foo\n\n";
35$got = chomp();
36is($got, 1, 'check return value when chomp string ending with two newlines; $/ is set to default of one newline');
37is ($_, "foo\n", 'chomp string ending with two newlines while $/ is set to one newline' );
38
39$_ = "foo\n";
40$got = chomp();
41is($got, 1, 'check return value chomp string ending with one newline while $/ is set to a newline');
42is ($_, "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();
46is($got, 0, 'check return value when chomp a string that does not end with current value of $/, 0 should be returned');
47is ($_, "foo", 'chomp a string that does not end with the current value of $/');
48
49$_ = "foo";
50$/ = "oo";
51$got = chomp();
52is ($got, "2", 'check return value when chomp string with $/ consisting of more than one character, and with the ending of the string matching $/');
53is ($_, "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();
58is($got, "0", 'check return value when call chomp with $/ consisting of more than one character, and with the ending of the string NOT matching $/');
59is ($_, "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();
64is ($got, 5, 'check return value when chomp in paragraph mode on string ending with 5 newlines');
65is ($_, "f", 'chomp in paragraph mode on string ending with 5 newlines');
66
67$_ = "f\n\n";
68$/ = "";
69$got = chomp();
70is ($got, 2, 'check return value when chomp in paragraph mode on string ending with 2 newlines');
71is ($_, "f", 'chomp in paragraph mode on string ending with 2 newlines');
72
73$_ = "f\n";
74$/ = "";
75$got = chomp();
76is ($got, 1, 'check return value when chomp in paragraph mode on string ending with 1 newline');
77is ($_, "f", 'chomp in paragraph mode on string ending with 1 newlines');
78
79$_ = "f";
80$/ = "";
81$got = chomp();
82is ($got, 0, 'check return value when chomp in paragraph mode on string ending with no newlines');
83is ($_, "f", 'chomp in paragraph mode on string lacking trailing newlines');
84
85$_ = "xx";
86$/ = "xx";
87$got = chomp();
88is ($got, 2, 'check return value when chomp string that consists solely of current value of $/');
89is ($_, "", 'chomp on string that consists solely of current value of $/; check that empty string remains');
90
91$_ = "axx";
92$/ = "xx";
93$got = chomp();
94is ($got, 2, 'check return value when chomp string that ends with current value of $/. $/ contains two characters');
95is ($_, "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();
100is ($got, 0, 'check return value when chomp string that does not end with $/');
101is ($_, "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();
107is ($got, 0, 'check return value when call chomp with $_ = "ab\\n", $/ = \3' );
108is ($_, "ab\n", 'chomp with $_ = "ab\\n", $/ = \3' );
109
110# Go Unicode.
111
112$_ = "abc\x{1234}";
113chop;
114is ($_, "abc", 'Go Unicode');
115
116$_ = "abc\x{1234}d";
117chop;
118is ($_, "abc\x{1234}");
119
120$_ = "\x{1234}\x{2345}";
121chop;
122is ($_, "\x{1234}");
123
124my @stuff = qw(this that);
125is (chop(@stuff[0,1]), 't');
126
127# bug id 20010305.012 (#5972)
128@stuff = qw(ab cd ef);
129is (chop(@stuff = @stuff), 'f');
130
131@stuff = qw(ab cd ef);
132is (chop(@stuff[0, 2]), 'f');
133
134my %stuff = (1..4);
135is (chop(@stuff{1, 3}), '4');
136
137# chomp should not stringify references unless it decides to modify them
138$_ = [];
139$/ = "\n";
140$got = chomp();
141ok ($got == 0) or print "# got $got\n";
142is (ref($_), "ARRAY", "chomp ref (modify)");
143
144$/ = ")";  # the last char of something like "ARRAY(0x80ff6e4)"
145$got = chomp();
146ok ($got == 1) or print "# got $got\n";
147ok (!ref($_), "chomp ref (no modify)");
148
149$/ = "\n";
150
151%chomp = ("One" => "One", "Two\n" => "Two", "" => "");
152%chop = ("One" => "On", "Two\n" => "Two", "" => "");
153
154foreach (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
166foreach (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
179eval 'chop($x) = 1;';
180ok($@ =~ /Can\'t modify.*chop.*in.*assignment/);
181eval 'chomp($x) = 1;';
182ok($@ =~ /Can\'t modify.*chom?p.*in.*assignment/);
183eval 'chop($x, $y) = (1, 2);';
184ok($@ =~ /Can\'t modify.*chop.*in.*assignment/);
185eval 'chomp($x, $y) = (1, 2);';
186ok($@ =~ /Can\'t modify.*chom?p.*in.*assignment/);
187
188my @chars = ("N",
189             uni_to_native("\xd3"),
190             substr (uni_to_native("\xd4") . "\x{100}", 0, 1),
191             chr 1296);
192foreach 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
252SKIP: {
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}
306