diff options
| -rw-r--r-- | doop.c | 20 | ||||
| -rwxr-xr-x | t/op/chop.t | 136 |
2 files changed, 107 insertions, 49 deletions
@@ -950,8 +950,14 @@ Perl_do_chop(pTHX_ register SV *astr, register SV *sv) do_chop(astr,hv_iterval(hv,entry)); return; } - else if (SvREADONLY(sv)) - Perl_croak(aTHX_ PL_no_modify); + else if (SvREADONLY(sv)) { + if (SvFAKE(sv)) { + /* SV is copy-on-write */ + sv_force_normal_flags(sv, 0); + } + if (SvREADONLY(sv)) + Perl_croak(aTHX_ PL_no_modify); + } s = SvPV(sv, len); if (len && !SvPOK(sv)) s = SvPV_force(sv, len); @@ -1020,8 +1026,14 @@ Perl_do_chomp(pTHX_ register SV *sv) count += do_chomp(hv_iterval(hv,entry)); return count; } - else if (SvREADONLY(sv)) - Perl_croak(aTHX_ PL_no_modify); + else if (SvREADONLY(sv)) { + if (SvFAKE(sv)) { + /* SV is copy-on-write */ + sv_force_normal_flags(sv, 0); + } + if (SvREADONLY(sv)) + Perl_croak(aTHX_ PL_no_modify); + } s = SvPV(sv, len); if (s && len) { s += --len; diff --git a/t/op/chop.t b/t/op/chop.t index e8b777eb6a..abb8aba732 100755 --- a/t/op/chop.t +++ b/t/op/chop.t @@ -1,18 +1,20 @@ #!./perl -print "1..41\n"; +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require './test.pl'; +} -# optimized +plan tests => 47; $_ = 'abc'; $c = do foo(); -if ($c . $_ eq 'cab') {print "ok 1\n";} else {print "not ok 1 $c$_\n";} - -# unoptimized +is ($c . $_, 'cab', 'optimized'); $_ = 'abc'; $c = chop($_); -if ($c . $_ eq 'cab') {print "ok 2\n";} else {print "not ok 2\n";} +is ($c . $_ , 'cab', 'unoptimized'); sub foo { chop; @@ -21,108 +23,152 @@ sub foo { @foo = ("hi \n","there\n","!\n"); @bar = @foo; chop(@bar); -print join('',@bar) eq 'hi there!' ? "ok 3\n" : "not ok 3\n"; +is (join('',@bar), 'hi there!'); $foo = "\n"; chop($foo,@foo); -print join('',$foo,@foo) eq 'hi there!' ? "ok 4\n" : "not ok 4\n"; +is (join('',$foo,@foo), 'hi there!'); $_ = "foo\n\n"; -print chomp() == 1 ? "ok 5\n" : "not ok 5\n"; -print $_ eq "foo\n" ? "ok 6\n" : "not ok 6\n"; +$got = chomp(); +ok ($got == 1) or print "# got $got\n"; +is ($_, "foo\n"); $_ = "foo\n"; -print chomp() == 1 ? "ok 7\n" : "not ok 7\n"; -print $_ eq "foo" ? "ok 8\n" : "not ok 8\n"; +$got = chomp(); +ok ($got == 1) or print "# got $got\n"; +is ($_, "foo"); $_ = "foo"; -print chomp() == 0 ? "ok 9\n" : "not ok 9\n"; -print $_ eq "foo" ? "ok 10\n" : "not ok 10\n"; +$got = chomp(); +ok ($got == 0) or print "# got $got\n"; +is ($_, "foo"); $_ = "foo"; $/ = "oo"; -print chomp() == 2 ? "ok 11\n" : "not ok 11\n"; -print $_ eq "f" ? "ok 12\n" : "not ok 12\n"; +$got = chomp(); +ok ($got == 2) or print "# got $got\n"; +is ($_, "f"); $_ = "bar"; $/ = "oo"; -print chomp() == 0 ? "ok 13\n" : "not ok 13\n"; -print $_ eq "bar" ? "ok 14\n" : "not ok 14\n"; +$got = chomp(); +ok ($got == 0) or print "# got $got\n"; +is ($_, "bar"); $_ = "f\n\n\n\n\n"; $/ = ""; -print chomp() == 5 ? "ok 15\n" : "not ok 15\n"; -print $_ eq "f" ? "ok 16\n" : "not ok 16\n"; +$got = chomp(); +ok ($got == 5) or print "# got $got\n"; +is ($_, "f"); $_ = "f\n\n"; $/ = ""; -print chomp() == 2 ? "ok 17\n" : "not ok 17\n"; -print $_ eq "f" ? "ok 18\n" : "not ok 18\n"; +$got = chomp(); +ok ($got == 2) or print "# got $got\n"; +is ($_, "f"); $_ = "f\n"; $/ = ""; -print chomp() == 1 ? "ok 19\n" : "not ok 19\n"; -print $_ eq "f" ? "ok 20\n" : "not ok 20\n"; +$got = chomp(); +ok ($got == 1) or print "# got $got\n"; +is ($_, "f"); $_ = "f"; $/ = ""; -print chomp() == 0 ? "ok 21\n" : "not ok 21\n"; -print $_ eq "f" ? "ok 22\n" : "not ok 22\n"; +$got = chomp(); +ok ($got == 0) or print "# got $got\n"; +is ($_, "f"); $_ = "xx"; $/ = "xx"; -print chomp() == 2 ? "ok 23\n" : "not ok 23\n"; -print $_ eq "" ? "ok 24\n" : "not ok 24\n"; +$got = chomp(); +ok ($got == 2) or print "# got $got\n"; +is ($_, ""); $_ = "axx"; $/ = "xx"; -print chomp() == 2 ? "ok 25\n" : "not ok 25\n"; -print $_ eq "a" ? "ok 26\n" : "not ok 26\n"; +$got = chomp(); +ok ($got == 2) or print "# got $got\n"; +is ($_, "a"); $_ = "axx"; $/ = "yy"; -print chomp() == 0 ? "ok 27\n" : "not ok 27\n"; -print $_ eq "axx" ? "ok 28\n" : "not ok 28\n"; +$got = chomp(); +ok ($got == 0) or print "# got $got\n"; +is ($_, "axx"); # This case once mistakenly behaved like paragraph mode. $_ = "ab\n"; $/ = \3; -print chomp() == 0 ? "ok 29\n" : "not ok 29\n"; -print $_ eq "ab\n" ? "ok 30\n" : "not ok 30\n"; +$got = chomp(); +ok ($got == 0) or print "# got $got\n"; +is ($_, "ab\n"); # Go Unicode. $_ = "abc\x{1234}"; chop; -print $_ eq "abc" ? "ok 31\n" : "not ok 31\n"; +is ($_, "abc", "Go Unicode"); $_ = "abc\x{1234}d"; chop; -print $_ eq "abc\x{1234}" ? "ok 32\n" : "not ok 32\n"; +is ($_, "abc\x{1234}"); $_ = "\x{1234}\x{2345}"; chop; -print $_ eq "\x{1234}" ? "ok 33\n" : "not ok 33\n"; +is ($_, "\x{1234}"); my @stuff = qw(this that); -print chop(@stuff[0,1]) eq 't' ? "ok 34\n" : "not ok 34\n"; +is (chop(@stuff[0,1]), 't'); # bug id 20010305.012 @stuff = qw(ab cd ef); -print chop(@stuff = @stuff) eq 'f' ? "ok 35\n" : "not ok 35\n"; +is (chop(@stuff = @stuff), 'f'); @stuff = qw(ab cd ef); -print chop(@stuff[0, 2]) eq 'f' ? "ok 36\n" : "not ok 36\n"; +is (chop(@stuff[0, 2]), 'f'); my %stuff = (1..4); -print chop(@stuff{1, 3}) eq '4' ? "ok 37\n" : "not ok 37\n"; +is (chop(@stuff{1, 3}), '4'); # chomp should not stringify references unless it decides to modify them $_ = []; $/ = "\n"; -print chomp() == 0 ? "ok 38\n" : "not ok 38\n"; -print ref($_) eq "ARRAY" ? "ok 39\n" : "not ok 39\n"; +$got = chomp(); +ok ($got == 0) or print "# got $got\n"; +is (ref($_), "ARRAY", "chomp ref (modify)"); $/ = ")"; # the last char of something like "ARRAY(0x80ff6e4)" -print chomp() == 1 ? "ok 40\n" : "not ok 40\n"; -print !ref($_) ? "ok 41\n" : "not ok 41\n"; +$got = chomp(); +ok ($got == 1) or print "# got $got\n"; +ok (!ref($_), "chomp ref (no modify)"); + +$/ = "\n"; + +%chomp = ("One" => "One", "Two\n" => "Two", "" => ""); +%chop = ("One" => "On", "Two\n" => "Two", "" => ""); + +foreach (keys %chomp) { + my $key = $_; + eval {chomp $_}; + if ($@) { + my $err = $@; + $err =~ s/\n$//s; + fail ("\$\@ = \"$err\""); + } else { + is ($_, $chomp{$key}, "chomp hash key"); + } +} + +foreach (keys %chop) { + my $key = $_; + eval {chop $_}; + if ($@) { + my $err = $@; + $err =~ s/\n$//s; + fail ("\$\@ = \"$err\""); + } else { + is ($_, $chop{$key}, "chop hash key"); + } +} |