Commit | Line | Data |
---|---|---|
8d063cd8 LW |
1 | #!./perl |
2 | ||
991e6d41 NC |
3 | BEGIN { |
4 | chdir 't' if -d 't'; | |
624c42e2 N |
5 | require './test.pl'; |
6 | set_up_inc('../lib'); | |
7 | require './charset_tools.pl'; | |
991e6d41 | 8 | } |
8d063cd8 | 9 | |
76513bdc | 10 | my $tests_count = 148; |
e53ec980 | 11 | plan tests => $tests_count; |
8d063cd8 LW |
12 | |
13 | $_ = 'abc'; | |
bb19cdcd | 14 | $c = foo(); |
991e6d41 | 15 | is ($c . $_, 'cab', 'optimized'); |
8d063cd8 LW |
16 | |
17 | $_ = 'abc'; | |
18 | $c = chop($_); | |
991e6d41 | 19 | is ($c . $_ , 'cab', 'unoptimized'); |
8d063cd8 LW |
20 | |
21 | sub foo { | |
22 | chop; | |
23 | } | |
a687059c LW |
24 | |
25 | @foo = ("hi \n","there\n","!\n"); | |
26 | @bar = @foo; | |
27 | chop(@bar); | |
ff64f327 | 28 | is (join('',@bar), 'hi there!', 'chop list of strings'); |
a687059c LW |
29 | |
30 | $foo = "\n"; | |
31 | chop($foo,@foo); | |
ff64f327 | 32 | is (join('',$foo,@foo), 'hi there!', 'chop on list reduces one-character element to an empty string'); |
a0d0e21e LW |
33 | |
34 | $_ = "foo\n\n"; | |
991e6d41 | 35 | $got = chomp(); |
ff64f327 JA |
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' ); | |
a0d0e21e LW |
38 | |
39 | $_ = "foo\n"; | |
991e6d41 | 40 | $got = chomp(); |
ff64f327 JA |
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'); | |
a0d0e21e LW |
43 | |
44 | $_ = "foo"; | |
991e6d41 | 45 | $got = chomp(); |
ff64f327 JA |
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 $/'); | |
a0d0e21e LW |
48 | |
49 | $_ = "foo"; | |
50 | $/ = "oo"; | |
991e6d41 | 51 | $got = chomp(); |
ff64f327 JA |
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'); | |
a0d0e21e LW |
54 | |
55 | $_ = "bar"; | |
56 | $/ = "oo"; | |
991e6d41 | 57 | $got = chomp(); |
ff64f327 JA |
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'); | |
a0d0e21e LW |
60 | |
61 | $_ = "f\n\n\n\n\n"; | |
62 | $/ = ""; | |
991e6d41 | 63 | $got = chomp(); |
ff64f327 JA |
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'); | |
a0d0e21e LW |
66 | |
67 | $_ = "f\n\n"; | |
68 | $/ = ""; | |
991e6d41 | 69 | $got = chomp(); |
ff64f327 JA |
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'); | |
a0d0e21e LW |
72 | |
73 | $_ = "f\n"; | |
74 | $/ = ""; | |
991e6d41 | 75 | $got = chomp(); |
ff64f327 JA |
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'); | |
a0d0e21e LW |
78 | |
79 | $_ = "f"; | |
80 | $/ = ""; | |
991e6d41 | 81 | $got = chomp(); |
ff64f327 JA |
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'); | |
c85b29f8 | 84 | |
85 | $_ = "xx"; | |
86 | $/ = "xx"; | |
991e6d41 | 87 | $got = chomp(); |
ff64f327 JA |
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'); | |
c85b29f8 | 90 | |
91 | $_ = "axx"; | |
92 | $/ = "xx"; | |
991e6d41 | 93 | $got = chomp(); |
ff64f327 JA |
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'); | |
c85b29f8 | 96 | |
97 | $_ = "axx"; | |
98 | $/ = "yy"; | |
991e6d41 | 99 | $got = chomp(); |
ff64f327 JA |
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'); | |
4c5a6083 GS |
102 | |
103 | # This case once mistakenly behaved like paragraph mode. | |
104 | $_ = "ab\n"; | |
105 | $/ = \3; | |
991e6d41 | 106 | $got = chomp(); |
ff64f327 JA |
107 | is ($got, 0, 'check return value when call chomp with $_ = "ab\\n", $/ = \3' ); |
108 | is ($_, "ab\n", 'chomp with $_ = "ab\\n", $/ = \3' ); | |
9b83640a JH |
109 | |
110 | # Go Unicode. | |
111 | ||
112 | $_ = "abc\x{1234}"; | |
113 | chop; | |
ff64f327 | 114 | is ($_, "abc", 'Go Unicode'); |
9b83640a JH |
115 | |
116 | $_ = "abc\x{1234}d"; | |
117 | chop; | |
991e6d41 | 118 | is ($_, "abc\x{1234}"); |
9b83640a JH |
119 | |
120 | $_ = "\x{1234}\x{2345}"; | |
121 | chop; | |
991e6d41 | 122 | is ($_, "\x{1234}"); |
37ce32a7 | 123 | |
37ce32a7 | 124 | my @stuff = qw(this that); |
991e6d41 | 125 | is (chop(@stuff[0,1]), 't'); |
2ec6af5f | 126 | |
ee95e30c | 127 | # bug id 20010305.012 (#5972) |
2ec6af5f | 128 | @stuff = qw(ab cd ef); |
991e6d41 | 129 | is (chop(@stuff = @stuff), 'f'); |
2ec6af5f RG |
130 | |
131 | @stuff = qw(ab cd ef); | |
991e6d41 | 132 | is (chop(@stuff[0, 2]), 'f'); |
2ec6af5f RG |
133 | |
134 | my %stuff = (1..4); | |
991e6d41 | 135 | is (chop(@stuff{1, 3}), '4'); |
9b33ce3b GA |
136 | |
137 | # chomp should not stringify references unless it decides to modify them | |
138 | $_ = []; | |
139 | $/ = "\n"; | |
991e6d41 NC |
140 | $got = chomp(); |
141 | ok ($got == 0) or print "# got $got\n"; | |
142 | is (ref($_), "ARRAY", "chomp ref (modify)"); | |
9b33ce3b GA |
143 | |
144 | $/ = ")"; # the last char of something like "ARRAY(0x80ff6e4)" | |
991e6d41 NC |
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 | } | |
75ea820e SM |
177 | |
178 | # chop and chomp can't be lvalues | |
179 | eval 'chop($x) = 1;'; | |
30ebab2d | 180 | ok($@ =~ /Can\'t modify.*chop.*in.*assignment/); |
75ea820e | 181 | eval 'chomp($x) = 1;'; |
30ebab2d | 182 | ok($@ =~ /Can\'t modify.*chom?p.*in.*assignment/); |
75ea820e | 183 | eval 'chop($x, $y) = (1, 2);'; |
30ebab2d | 184 | ok($@ =~ /Can\'t modify.*chop.*in.*assignment/); |
75ea820e | 185 | eval 'chomp($x, $y) = (1, 2);'; |
30ebab2d | 186 | ok($@ =~ /Can\'t modify.*chom?p.*in.*assignment/); |
75ea820e | 187 | |
e53ec980 KW |
188 | my @chars = ("N", |
189 | uni_to_native("\xd3"), | |
190 | substr (uni_to_native("\xd4") . "\x{100}", 0, 1), | |
191 | chr 1296); | |
c4c87a06 NC |
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; | |
132d8bbf | 197 | is (chomp ($string), 1, "$message [returns 1]"); |
c4c87a06 NC |
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; | |
132d8bbf | 207 | is (chomp ($chomped), 0, "$message (end as bytes) [returns 0]"); |
c4c87a06 NC |
208 | is ($chomped, $string, "$message (end as bytes)"); |
209 | ||
210 | $/ = $end_utf8; | |
211 | $string = $start . $end; | |
212 | $chomped = $string; | |
132d8bbf | 213 | is (chomp ($chomped), 0, "$message (\$/ as bytes) [returns 0]"); |
c4c87a06 NC |
214 | is ($chomped, $string, "$message (\$/ as bytes)"); |
215 | } | |
216 | } | |
a6aa349d TS |
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 | } | |
ace7757b TS |
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 | } | |
1937c63e TS |
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 | } | |
65ab9279 | 251 | |
5139efdd | 252 | SKIP: { |
65ab9279 TC |
253 | # [perl #73246] chop doesn't support utf8 |
254 | # the problem was UTF8_IS_START() didn't handle perl's extended UTF8 | |
5139efdd KW |
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); | |
e53ec980 | 261 | |
5139efdd KW |
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); | |
65ab9279 | 265 | my $result = chop($utf); |
5139efdd KW |
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"); | |
65ab9279 | 274 | } |
6c7f10b5 | 275 | |
e4e95921 | 276 | $/ = "\n"; |
6c7f10b5 JK |
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 | } | |
f595e19f FC |
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 | } |