If the downstream caller wants block mode, and we're in line mode,

then don't return more bytes than they asked for. Hold bytes over
until next time if necessary.

p4raw-id: //depot/perl@27816

diff --git a/pp_ctl.c b/pp_ctl.c
index 2c36b59..7ea62e5 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -4516,7 +4516,6 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
     dVAR;
     SV * const datasv = FILTER_DATA(idx);
     const int filter_has_file = IoLINES(datasv);
-    GV * const filter_child_proc = (GV *)IoFMT_GV(datasv);
     SV * const filter_state = (SV *)IoTOP_GV(datasv);
     SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
     int len = 0;
@@ -4535,6 +4534,26 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
        for PL_error_count == 0.)  Solaris doesn't segfault --
        not sure where the trouble is yet.  XXX */
 
+    if (maxlen && IoFMT_GV(datasv)) {
+       SV *const cache = (SV *)IoFMT_GV(datasv);
+       if (SvOK(cache)) {
+           STRLEN cache_len;
+           const char *cache_p = SvPV(cache, cache_len);
+           /* Running in block mode and we have some cached data already.  */
+           if (cache_len >= maxlen) {
+               /* In fact, so much data we don't even need to call
+                  filter_read.  */
+               sv_catpvn(buf_sv, cache_p, maxlen);
+               sv_chop(cache, cache_p + maxlen);
+               /* Definately not EOF  */
+               return 1;
+           }
+           sv_catsv(buf_sv, cache);
+           maxlen -= cache_len;
+           SvOK_off(cache);
+       }
+    }
+       
     if (filter_has_file) {
        len = FILTER_READ(idx+1, upstream, maxlen);
     }
@@ -4570,12 +4589,41 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
        LEAVE;
     }
 
+    if (maxlen) {
+       /* Running in block mode.  */
+       STRLEN got_len;
+       const char *got_p = SvPV(upstream, got_len);
+
+       if (got_len > maxlen) {
+           /* Oh. Too long. Stuff some in our cache.  */
+           SV *cache = (SV *)IoFMT_GV(datasv);
+
+           if (!cache) {
+               IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - maxlen));
+           } else if (SvOK(cache)) {
+               /* Cache should be empty.  */
+               assert(!SvCUR(cache));
+           }
+
+           sv_setpvn(cache, got_p + maxlen, got_len - maxlen);
+           /* If you ask for block mode, you may well split UTF-8 characters.
+              "If it breaks, you get to keep both parts"
+              (Your code is broken if you  don't put them back together again
+              before something notices.) */
+           if (SvUTF8(upstream)) {
+               SvUTF8_on(cache);
+           }
+           SvCUR_set(upstream, maxlen);
+       }
+    }
+
+    if (upstream != buf_sv) {
+       sv_catsv(buf_sv, upstream);
+    }
+
     if (len <= 0) {
        IoLINES(datasv) = 0;
-       if (filter_child_proc) {
-           SvREFCNT_dec(filter_child_proc);
-           IoFMT_GV(datasv) = NULL;
-       }
+       SvREFCNT_dec(IoFMT_GV(datasv));
        if (filter_state) {
            SvREFCNT_dec(filter_state);
            IoTOP_GV(datasv) = NULL;
@@ -4586,10 +4634,6 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
        }
        filter_del(S_run_user_filter);
     }
-
-    if (upstream != buf_sv) {
-       sv_catsv(buf_sv, upstream);
-    }
     return len;
 }
 

diff --git a/t/op/incfilter.t b/t/op/incfilter.t
index 2ca4704..650aa15 100644 (file)
--- a/t/op/incfilter.t
+++ b/t/op/incfilter.t
@@ -14,7 +14,7 @@ BEGIN {
 use strict;
 use Filter::Util::Call;
 
-plan(tests => 19);
+plan(tests => 108);
 
 unshift @INC, sub {
     no warnings 'uninitialized';
@@ -103,8 +103,6 @@ sub prepend_rot13_filter {
                   my $test = "fzrt!";
                   $_ = $test;
                   my $status = filter_read();
-                  # Sadly, doing this inside the source filter causes an
-                  # infinte loop
                   my $got = substr $_, 0, length $test, '';
                   is $got, $test, "Upstream didn't alter existing data";
                   tr/A-Za-z/N-ZA-Mn-za-m/;
@@ -120,3 +118,39 @@ pass("This will rot13'ed twice");
 EOC
 
 do [$fh, sub {tr/A-Za-z/N-ZA-Mn-za-m/; return;}] or die;
+
+# This generates a heck of a lot of oks, but I think it's necessary.
+my $amount = 1;
+sub prepend_block_counting_filter {
+    filter_add(sub {
+                  my $output = defined $_ ? $_ : '';
+                  my $count = 256;
+                  while (--$count) {
+                      $_ = '';
+                      my $status = filter_read($amount);
+                      cmp_ok (length $_, '<=', $amount, "block mode works?");
+                      $output .= $_;
+                      if ($status <= 0 or /\n/s) {
+                          $_ = $output;
+                          return $status;
+                      }
+                  }
+                  die "Looping infinitely";
+                         
+              })
+}
+
+open $fh, "<", \<<'EOC';
+BEGIN {prepend_block_counting_filter};
+pass("one by one");
+pass("and again");
+EOC
+
+do [$fh, sub {return;}] or die;
+
+open $fh, "<", \<<'EOC';
+BEGIN {prepend_block_counting_filter};
+pas("SSS make s fast SSS");
+EOC
+
+do [$fh, sub {s/s/ss/gs; s/([\nS])/$1$1$1/gs; return;}] or die;