summaryrefslogtreecommitdiff
path: root/ext/PerlIO-encoding/t
diff options
context:
space:
mode:
authorFather Chrysostomos <sprout@cpan.org>2012-10-15 23:06:31 -0700
committerFather Chrysostomos <sprout@cpan.org>2012-10-15 23:06:31 -0700
commit8f79eb5b229ed80688d6f2b3bfed18e5e48ad29a (patch)
tree597566bdc29cb6021d568e74e2e02ccfd2cd6114 /ext/PerlIO-encoding/t
parentbc1df6c26399cfc1a6171e049edcc6a5a21de2a6 (diff)
downloadperl-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.t31
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;