t/op/chop.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     require './test.pl'; require './charset_tools.pl';
   7 }
   8
   9 my $tests_count = 148;
  10 $tests_count -= 2 if $::IS_EBCDIC;
  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
 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     skip("Not representable in EBCDIC", 2) if $::IS_EBCDIC;
 256
 257     # We use hex constants instead of literal chars to avoid compilation
 258     # errors in EBCDIC.
 259     my $first_char =  0x80000001;
 260     my $second_char = 0x80000000;
 261     my $utf = chr($first_char) . chr($second_char);
 262     my $result = chop($utf);
 263     is($utf, chr $first_char, "chopping high 'unicode'- remnant");
 264     is($result, chr $second_char, "chopping high 'unicode' - result");
 265
 266     SKIP: {
 267         no warnings 'overflow'; # avoid compile-time warnings below on 32-bit architectures
 268         use Config;
 269         $Config{ivsize} >= 8
 270           or skip("this build can't handle very large characters", 2);
 271         my $first_char =  0xffffffffffffffff;
 272         my $second_char = 0xfffffffffffffffe;
 273         my $utf = chr($first_char) . chr($second_char);
 274         my $result = chop $utf;
 275         is($utf, chr $first_char, "chop even higher 'unicode' - remnant");
 276         is($result, chr $second_char, "chop even higher 'unicode' - result");
 277     }
 278 }
 279
 280 $/ = "\n";
 281 {
 282     my $expected = 99999;
 283     my $input = "UserID\talpha $expected\n";
 284     my $uid = '';
 285     chomp(my @line = split (/ |\t/,$input));
 286     $uid = $line[-1];
 287     is($uid, $expected,
 288         "RT #123057: chomp works as expected on split");
 289 }
 290
 291 {
 292     my $a = local $/ = 7;
 293     $a = chomp $a;
 294     is $a, 1, 'lexical $a = chomp $a when $a eq $/ eq 7';
 295     $a = $/ = 0;
 296     $a = chomp $a;
 297     is $a, 1, 'lexical $a = chomp $a when $a eq $/ eq 0';
 298     my @a = "7";
 299     for my $b($a[0]) {
 300         $/ = 7;
 301         $b = chomp @a;
 302         is $b, 1,
 303           'lexical $b = chomp @a when $b eq $/ eq 7 and \$a[0] == \$b';
 304         $b = $/ = 0;
 305         $b = chomp @a;
 306         is $b, 1,
 307           'lexical $b = chomp @a when $b eq $/ eq 0 and \$a[0] == \$b';
 308     }
 309 }