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.

diff --git a/ext/PerlIO-encoding/encoding.xs b/ext/PerlIO-encoding/encoding.xs
index 114b7e1..2d06d82 100644 (file)
--- a/ext/PerlIO-encoding/encoding.xs
+++ b/ext/PerlIO-encoding/encoding.xs
@@ -341,6 +341,8 @@ PerlIOEncode_fill(pTHX_ PerlIO * f)
        SPAGAIN;
        uni = POPs;
        PUTBACK;
+       /* No cows allowed. */
+       if (SvTHINKFIRST(e->dataSV)) SvPV_force_nolen(e->dataSV);
        /* Now get translated string (forced to UTF-8) and use as buffer */
        if (SvPOK(uni)) {
            s = SvPVutf8(uni, len);

diff --git a/ext/PerlIO-encoding/t/encoding.t b/ext/PerlIO-encoding/t/encoding.t
index 0c6bcda..b9193b9 100644 (file)
--- 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;