Make PerlIO::encoding even more resilient to moving buffers
authorFather Chrysostomos <sprout@cpan.org>
Mon, 15 Oct 2012 06:09:56 +0000 (23:09 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Mon, 15 Oct 2012 14:54:20 +0000 (07:54 -0700)
Commit 667763bdbf was not good enough.

If the buffer passed to an encode method is reallocated, it may be
smaller than the size (bufsiz) stored inside the encoding layer.  So
we need to extend the buffer in that case and make sure the buffer
pointer is not pointing to freed memory.

The test as modified by this commit causes malloc errors on stderr
when I try it without the encoding.xs changes.

ext/PerlIO-encoding/encoding.xs
ext/PerlIO-encoding/t/encoding.t

index 3f27dec..114b7e1 100644 (file)
@@ -443,8 +443,12 @@ PerlIOEncode_flush(pTHX_ PerlIO * f)
            }
            if (!SvPOKp(e->bufsv) || SvTHINKFIRST(e->bufsv))
                (void)SvPV_force_nolen(e->bufsv);
-           if ((STDCHAR *)SvPVX(e->bufsv) != e->base.buf)
+           if ((STDCHAR *)SvPVX(e->bufsv) != e->base.buf) {
+               e->base.ptr = SvEND(e->bufsv);
+               e->base.end = SvPVX(e->bufsv) + (e->base.end-e->base.buf);
                e->base.buf = (STDCHAR *)SvPVX(e->bufsv);
+           }
+           (void)PerlIOEncode_get_base(aTHX_ f);
            if (SvCUR(e->bufsv)) {
                /* Did not all translate */
                e->base.ptr = e->base.buf+SvCUR(e->bufsv);
index 71ba493..0c6bcda 100644 (file)
@@ -138,10 +138,10 @@ package Extensive {
     $leftovers = $';
   }
   if ($chk) {
-   my $x = ' ' x 8000;  # prevent realloc from simply extending the buffer
-   $_[1] = ' ' x 8000;  # make SvPVX point elsewhere
-   $_[1] = $leftovers;
-  }
+   undef $_[1];
+   my @x = (' ') x 8000; # reuse the just-freed buffer
+   $_[1] = $leftovers;   # SvPVX now points elsewhere and is shorter
+  }                      # than bufsiz
   $buf;
  }
  no warnings 'once'; 
@@ -151,8 +151,11 @@ open my $fh, ">:encoding(extensive)", \$buf;
 $fh->autoflush;
 print $fh "doughnut\n";
 print $fh "quaffee\n";
+# Print something longer than the buffer that encode() shrunk:
+print $fh "The beech leaves beech leaves on the beach by the beech.\n";
 close $fh;
-is $buf, "doughnut\nquaffee\n", 'buffer realloc during encoding';
+is $buf, "doughnut\nquaffee\nThe beech leaves beech leaves on the beach by"
+        ." the beech.\n", 'buffer realloc during encoding';
 $buf = "Sheila surely shod Sean\nin shoddy shoes.\n";
 open $fh, "<:encoding(extensive)", \$buf;
 is join("", <$fh>), "Sheila surely shod Sean\nin shoddy shoes.\n",