diff options
author | Father Chrysostomos <sprout@cpan.org> | 2012-10-15 23:06:31 -0700 |
---|---|---|
committer | Father Chrysostomos <sprout@cpan.org> | 2012-10-15 23:06:31 -0700 |
commit | 8f79eb5b229ed80688d6f2b3bfed18e5e48ad29a (patch) | |
tree | 597566bdc29cb6021d568e74e2e02ccfd2cd6114 /ext/PerlIO-encoding/t | |
parent | bc1df6c26399cfc1a6171e049edcc6a5a21de2a6 (diff) | |
download | perl-8f79eb5b229ed80688d6f2b3bfed18e5e48ad29a.tar.gz |
Make PerlIO::encoding handle cows
Commits 667763bdbf and e9a8753af fixed bugs involving buffer realloca-
tions during encode and decode. But what was not taken into account
was that the COW flags could still be left on even when buffer real-
ocations were accounted for. This could result in SvPV_set and
SvLEN_set(sv,0) being called on an SV with the COW flags still on,
so SvPVX would be treated as a key inside a shared_he, resulting in
assertion failures.
Diffstat (limited to 'ext/PerlIO-encoding/t')
-rw-r--r-- | ext/PerlIO-encoding/t/encoding.t | 31 |
1 files changed, 30 insertions, 1 deletions
diff --git a/ext/PerlIO-encoding/t/encoding.t b/ext/PerlIO-encoding/t/encoding.t index 0c6bcda9fe..b9193b92f8 100644 --- a/ext/PerlIO-encoding/t/encoding.t +++ b/ext/PerlIO-encoding/t/encoding.t @@ -11,7 +11,7 @@ BEGIN { } } -use Test::More tests => 22; +use Test::More tests => 24; my $grk = "grk$$"; my $utf = "utf$$"; @@ -161,6 +161,35 @@ open $fh, "<:encoding(extensive)", \$buf; is join("", <$fh>), "Sheila surely shod Sean\nin shoddy shoes.\n", 'buffer realloc during decoding'; +package Cower { + @ISA = Encode::Encoding; + __PACKAGE__->Define('cower'); + sub encode($$;$) { + my ($self,$buf,$chk) = @_; + my $leftovers = ''; + if ($buf =~ /(.*\n)(?!\z)/) { + $buf = $1; + $leftovers = $'; + } + if ($chk) { + no warnings; # stupid @_[1] warning + @_[1] = keys %{{$leftovers=>1}}; # shared hash key (copy-on-write) + } + $buf; + } + no warnings 'once'; + *decode = *encode; +} +open $fh, ">:encoding(cower)", \$buf; +$fh->autoflush; +print $fh $_ for qw "pumping plum pits"; +close $fh; +is $buf, "pumpingplumpits", 'cowing buffer during encoding'; +$buf = "pumping\nplum\npits\n"; +open $fh, "<:encoding(cower)", \$buf; +is join("", <$fh>), "pumping\nplum\npits\n", + 'cowing buffer during decoding'; + package Globber { no warnings 'once'; @ISA = Encode::Encoding; |