X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/7e337ee0bc836d3147f3b2579c7e35127637e377..d34786ba12ee5b96d9e34dd6fcdda158d7d2597b:/pp_ctl.c

diff --git a/pp_ctl.c b/pp_ctl.c
index 5621db6..f88d401 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -113,7 +113,7 @@ PP(pp_regcomp)
 	tmpstr = POPs;
 
     if (SvROK(tmpstr)) {
-	SV *sv = SvRV(tmpstr);
+	SV * const sv = SvRV(tmpstr);
 	if(SvMAGICAL(sv))
 	    mg = mg_find(sv, PERL_MAGIC_qr);
     }
@@ -125,14 +125,14 @@ PP(pp_regcomp)
     else {
 	STRLEN len;
 	const char *t = SvPV_const(tmpstr, len);
+	regexp * const re = PM_GETRE(pm);
 
 	/* Check against the last compiled regexp. */
-	if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
-	    PM_GETRE(pm)->prelen != (I32)len ||
-	    memNE(PM_GETRE(pm)->precomp, t, len))
+	if (!re || !re->precomp || re->prelen != (I32)len ||
+	    memNE(re->precomp, t, len))
 	{
-	    if (PM_GETRE(pm)) {
-	        ReREFCNT_dec(PM_GETRE(pm));
+	    if (re) {
+	        ReREFCNT_dec(re);
 		PM_SETRE(pm, NULL);	/* crucial if regcomp aborts */
 	    }
 	    if (PL_op->op_flags & OPf_SPECIAL)
@@ -831,7 +831,11 @@ PP(pp_formline)
 	    /* Formats aren't yet marked for locales, so assume "yes". */
 	    {
 		STORE_NUMERIC_STANDARD_SET_LOCAL();
+#ifdef USE_SNPRINTF
+		snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
+#else
 		sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value);
+#endif /* ifdef USE_SNPRINTF */
 		RESTORE_NUMERIC_STANDARD();
 	    }
 	    t += fieldsize;
@@ -1450,7 +1454,7 @@ Perl_qerror(pTHX_ SV *err)
     else if (PL_errors)
 	sv_catsv(PL_errors, err);
     else
-	Perl_warn(aTHX_ "%"SVf, err);
+	Perl_warn(aTHX_ "%"SVf, (void*)err);
     ++PL_error_count;
 }
 
@@ -1620,7 +1624,7 @@ PP(pp_caller)
 	RETURN;
     }
 
-    EXTEND(SP, 10);
+    EXTEND(SP, 11);
 
     if (!stashname)
 	PUSHs(&PL_sv_undef);
@@ -1695,11 +1699,10 @@ PP(pp_caller)
     /* XXX only hints propagated via op_private are currently
      * visible (others are not easily accessible, since they
      * use the global PL_hints) */
-    PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
-			     HINT_PRIVATE_MASK)));
+    PUSHs(sv_2mortal(newSViv(CopHINTS_get(cx->blk_oldcop))));
     {
 	SV * mask ;
-	SV * const old_warnings = cx->blk_oldcop->cop_warnings ;
+	STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
 
 	if  (old_warnings == pWARN_NONE ||
 		(old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
@@ -1718,9 +1721,15 @@ PP(pp_caller)
 	    }
 	}
         else
-            mask = newSVsv(old_warnings);
+            mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
         PUSHs(sv_2mortal(mask));
     }
+
+    PUSHs(cx->blk_oldcop->cop_hints ?
+	  sv_2mortal(newRV_noinc(
+		(SV*)Perl_refcounted_he_chain_2hv(aTHX_
+						  cx->blk_oldcop->cop_hints)))
+	  : &PL_sv_undef);
     RETURN;
 }
 
@@ -1920,7 +1929,7 @@ PP(pp_leaveloop)
 
     TAINT_NOT;
     if (gimme == G_VOID)
-	/*EMPTY*/; /* do nothing */
+	NOOP;
     else if (gimme == G_SCALAR) {
 	if (mark < SP)
 	    *++newsp = sv_mortalcopy(*SP);
@@ -2007,7 +2016,7 @@ PP(pp_return)
 	    /* Unassume the success we assumed earlier. */
 	    SV * const nsv = cx->blk_eval.old_namesv;
 	    (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
-	    DIE(aTHX_ "%"SVf" did not return a true value", nsv);
+	    DIE(aTHX_ "%"SVf" did not return a true value", (void*)nsv);
 	}
 	break;
     case CXt_FORMAT:
@@ -2315,7 +2324,7 @@ PP(pp_goto)
 			goto retry;
 		    tmpstr = sv_newmortal();
 		    gv_efullname3(tmpstr, gv, NULL);
-		    DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
+		    DIE(aTHX_ "Goto undefined subroutine &%"SVf"",(void*)tmpstr);
 		}
 		DIE(aTHX_ "Goto undefined subroutine");
 	    }
@@ -2502,7 +2511,7 @@ PP(pp_goto)
 
 	/* find label */
 
-	PL_lastgotoprobe = 0;
+	PL_lastgotoprobe = NULL;
 	*enterops = 0;
 	for (ix = cxstack_ix; ix >= 0; ix--) {
 	    cx = &cxstack[ix];
@@ -2764,8 +2773,13 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
 	len = SvCUR(sv);
     }
     else
+#ifdef USE_SNPRINTF
+	len = snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
+		       (unsigned long)++PL_evalseq);
+#else
 	len = my_sprintf(tmpbuf, "_<(%.10s_eval %lu)", code,
 			 (unsigned long)++PL_evalseq);
+#endif /* ifdef USE_SNPRINTF */
     SAVECOPFILE_FREE(&PL_compiling);
     CopFILE_set(&PL_compiling, tmpbuf+2);
     SAVECOPLINE(&PL_compiling);
@@ -2809,7 +2823,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
     *padp = (AV*)SvREFCNT_inc_simple(PL_comppad);
     LEAVE;
     if (IN_PERL_COMPILETIME)
-	PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
+	CopHINTS_set(&PL_compiling, PL_hints);
 #ifdef OP_IN_REGISTER
     op = PL_opsave;
 #endif
@@ -2893,6 +2907,7 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
     /* set up a scratch pad */
 
     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
+    PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
 
 
     if (!PL_madskills)
@@ -2919,7 +2934,7 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
     PL_eval_root = NULL;
     PL_error_count = 0;
     PL_curcop = &PL_compiling;
-    PL_curcop->cop_arybase = 0;
+    CopARYBASE_set(PL_curcop, 0);
     if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
 	PL_in_eval |= EVAL_KEEPERR;
     else
@@ -2989,7 +3004,7 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
     DEBUG_x(dump_eval());
 
     /* Register with debugger: */
-    if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
+    if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
 	CV * const cv = get_cv("DB::postponed", FALSE);
 	if (cv) {
 	    dSP;
@@ -3011,10 +3026,11 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
 }
 
 STATIC PerlIO *
-S_check_type_and_open(pTHX_ const char *name, const char *mode)
+S_check_type_and_open(const char *name, const char *mode)
 {
     Stat_t st;
     const int st_rc = PerlLIO_stat(name, &st);
+
     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
 	return NULL;
     }
@@ -3062,7 +3078,7 @@ PP(pp_require)
     const I32 gimme = GIMME_V;
     int filter_has_file = 0;
     PerlIO *tryrsfp = NULL;
-    GV *filter_child_proc = NULL;
+    SV *filter_cache = NULL;
     SV *filter_state = NULL;
     SV *filter_sub = NULL;
     SV *hook_sv = NULL;
@@ -3081,12 +3097,12 @@ PP(pp_require)
 	if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
 	    if ( vcmp(sv,PL_patchlevel) < 0 )
 		DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
-		    vnormal(sv), vnormal(PL_patchlevel));
+		    (void*)vnormal(sv), (void*)vnormal(PL_patchlevel));
 	}
 	else {
 	    if ( vcmp(sv,PL_patchlevel) > 0 )
 		DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
-		    vnormal(sv), vnormal(PL_patchlevel));
+		    (void*)vnormal(sv), (void*)vnormal(PL_patchlevel));
 	}
 
 	    RETPUSHYES;
@@ -3132,7 +3148,7 @@ PP(pp_require)
 	{
 	    namesv = newSV(0);
 	    for (i = 0; i <= AvFILL(ar); i++) {
-		SV *dirsv = *av_fetch(ar, i, TRUE);
+		SV * const dirsv = *av_fetch(ar, i, TRUE);
 
 		if (SvROK(dirsv)) {
 		    int count;
@@ -3170,34 +3186,32 @@ PP(pp_require)
 			SP -= count - 1;
 			arg = SP[i++];
 
+			if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
+			    && !isGV_with_GP(SvRV(arg))) {
+			    filter_cache = SvRV(arg);
+			    SvREFCNT_inc_void_NN(filter_cache);
+
+			    if (i < count) {
+				arg = SP[i++];
+			    }
+			}
+
 			if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
 			    arg = SvRV(arg);
 			}
 
 			if (SvTYPE(arg) == SVt_PVGV) {
-			    IO *io = GvIO((GV *)arg);
+			    IO * const io = GvIO((GV *)arg);
 
 			    ++filter_has_file;
 
 			    if (io) {
 				tryrsfp = IoIFP(io);
-				if (IoTYPE(io) == IoTYPE_PIPE) {
-				    /* reading from a child process doesn't
-				       nest -- when returning from reading
-				       the inner module, the outer one is
-				       unreadable (closed?)  I've tried to
-				       save the gv to manage the lifespan of
-				       the pipe, but this didn't help. XXX */
-				    filter_child_proc = (GV *)arg;
-				    SvREFCNT_inc_simple_void(filter_child_proc);
-				}
-				else {
-				    if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
-					PerlIO_close(IoOFP(io));
-				    }
-				    IoIFP(io) = NULL;
-				    IoOFP(io) = NULL;
+				if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
+				    PerlIO_close(IoOFP(io));
 				}
+				IoIFP(io) = NULL;
+				IoOFP(io) = NULL;
 			    }
 
 			    if (i < count) {
@@ -3213,10 +3227,11 @@ PP(pp_require)
 				filter_state = SP[i];
 				SvREFCNT_inc_simple_void(filter_state);
 			    }
+			}
 
-			    if (!tryrsfp) {
-				tryrsfp = PerlIO_open("/dev/null", PERL_SCRIPT_MODE);
-			    }
+			if (!tryrsfp && (filter_cache || filter_sub)) {
+			    tryrsfp = PerlIO_open(BIT_BUCKET,
+						  PERL_SCRIPT_MODE);
 			}
 			SP--;
 		    }
@@ -3231,9 +3246,9 @@ PP(pp_require)
 		    }
 
 		    filter_has_file = 0;
-		    if (filter_child_proc) {
-			SvREFCNT_dec(filter_child_proc);
-			filter_child_proc = NULL;
+		    if (filter_cache) {
+			SvREFCNT_dec(filter_cache);
+			filter_cache = NULL;
 		    }
 		    if (filter_state) {
 			SvREFCNT_dec(filter_state);
@@ -3358,24 +3373,26 @@ PP(pp_require)
     PL_rsfp = tryrsfp;
     SAVEHINTS();
     PL_hints = 0;
-    SAVESPTR(PL_compiling.cop_warnings);
+    SAVECOMPILEWARNINGS();
     if (PL_dowarn & G_WARN_ALL_ON)
         PL_compiling.cop_warnings = pWARN_ALL ;
     else if (PL_dowarn & G_WARN_ALL_OFF)
         PL_compiling.cop_warnings = pWARN_NONE ;
-    else if (PL_taint_warn)
-        PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
+    else if (PL_taint_warn) {
+        PL_compiling.cop_warnings
+	    = Perl_new_warnings_bitfield(aTHX_ NULL, WARN_TAINTstring, WARNsize);
+    }
     else
         PL_compiling.cop_warnings = pWARN_STD ;
     SAVESPTR(PL_compiling.cop_io);
     PL_compiling.cop_io = NULL;
 
-    if (filter_sub || filter_child_proc) {
+    if (filter_sub || filter_cache) {
 	SV * const datasv = filter_add(S_run_user_filter, NULL);
 	IoLINES(datasv) = filter_has_file;
-	IoFMT_GV(datasv) = (GV *)filter_child_proc;
 	IoTOP_GV(datasv) = (GV *)filter_state;
 	IoBOTTOM_GV(datasv) = (GV *)filter_sub;
+	IoFMT_GV(datasv) = (GV *)filter_cache;
     }
 
     /* switch to eval mode */
@@ -3415,6 +3432,10 @@ PP(pp_entereval)
     CV* runcv;
     U32 seq;
     HV *saved_hh = NULL;
+    const char * const fakestr = "_<(eval )";
+#ifdef HAS_STRLCPY
+    const int fakelen = 9 + 1;
+#endif
     
     if (PL_op->op_private & OPpEVAL_HAS_HH) {
 	saved_hh = (HV*) SvREFCNT_inc(POPs);
@@ -3440,7 +3461,11 @@ PP(pp_entereval)
 	len = SvCUR(temp_sv);
     }
     else
+#ifdef USE_SNPRINTF
+	len = snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
+#else
 	len = my_sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
+#endif /* ifdef USE_SNPRINTF */
     SAVECOPFILE_FREE(&PL_compiling);
     CopFILE_set(&PL_compiling, tmpbuf+2);
     SAVECOPLINE(&PL_compiling);
@@ -3456,13 +3481,8 @@ PP(pp_entereval)
     PL_hints = PL_op->op_targ;
     if (saved_hh)
 	GvHV(PL_hintgv) = saved_hh;
-    SAVESPTR(PL_compiling.cop_warnings);
-    if (specialWARN(PL_curcop->cop_warnings))
-        PL_compiling.cop_warnings = PL_curcop->cop_warnings;
-    else {
-        PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
-        SAVEFREESV(PL_compiling.cop_warnings);
-    }
+    SAVECOMPILEWARNINGS();
+    PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
     SAVESPTR(PL_compiling.cop_io);
     if (specialCopIO(PL_curcop->cop_io))
         PL_compiling.cop_io = PL_curcop->cop_io;
@@ -3470,6 +3490,15 @@ PP(pp_entereval)
         PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
         SAVEFREESV(PL_compiling.cop_io);
     }
+    if (PL_compiling.cop_hints) {
+	Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints);
+    }
+    PL_compiling.cop_hints = PL_curcop->cop_hints;
+    if (PL_compiling.cop_hints) {
+	HINTS_REFCNT_LOCK;
+	PL_compiling.cop_hints->refcounted_he_refcnt++;
+	HINTS_REFCNT_UNLOCK;
+    }
     /* special case: an eval '' executed within the DB package gets lexically
      * placed in the first non-DB CV rather than the current CV - this
      * allows the debugger to execute code, find lexicals etc, in the
@@ -3489,7 +3518,12 @@ PP(pp_entereval)
     ret = doeval(gimme, NULL, runcv, seq);
     if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
 	&& ret != PL_op->op_next) {	/* Successive compilation. */
-	strcpy(safestr, "_<(eval )");	/* Anything fake and short. */
+	/* Copy in anything fake and short. */
+#ifdef HAS_STRLCPY
+	strlcpy(safestr, fakestr, fakelen);
+#else
+	strcpy(safestr, fakestr);
+#endif /* #ifdef HAS_STRLCPY */
     }
     return DOCATCH(ret);
 }
@@ -3550,7 +3584,7 @@ PP(pp_leaveeval)
 	/* Unassume the success we assumed earlier. */
 	SV * const nsv = cx->blk_eval.old_namesv;
 	(void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
-	retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
+	retop = Perl_die(aTHX_ "%"SVf" did not return a true value", (void*)nsv);
 	/* die_where() did LEAVE, or we won't be here */
     }
     else {
@@ -3611,7 +3645,7 @@ Perl_create_eval_scope(pTHX_ U32 flags)
 PP(pp_entertry)
 {
     dVAR;
-    PERL_CONTEXT *cx = create_eval_scope(0);
+    PERL_CONTEXT * const cx = create_eval_scope(0);
     cx->blk_eval.retop = cLOGOP->op_other->op_next;
     return DOCATCH(PL_op->op_next);
 }
@@ -3881,7 +3915,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
 	if (c == 0)
 	    PUSHs(&PL_sv_no);
 	else if (SvTEMP(TOPs))
-	    SvREFCNT_inc(TOPs);
+	    SvREFCNT_inc_void(TOPs);
 	FREETMPS;
 	LEAVE;
 	RETURN;
@@ -4062,7 +4096,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
 		PUSHs(other);
 		PUSHs(*svp);
 		PUTBACK;
-		if ((PL_curcop->op_private & HINT_INTEGER) == HINT_INTEGER)
+		if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
 		    (void) pp_i_eq();
 		else
 		    (void) pp_eq();
@@ -4122,7 +4156,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
 	if (c == 0)
 	    PUSHs(&PL_sv_undef);
 	else if (SvTEMP(TOPs))
-	    SvREFCNT_inc(TOPs);
+	    SvREFCNT_inc_void(TOPs);
 
 	if (SM_OTHER_REF(PVCV)) {
 	    /* This one has to be null-proto'd too.
@@ -4133,7 +4167,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
 	    if (c == 0)
 		PUSHs(&PL_sv_undef);
 	    else if (SvTEMP(TOPs))
-		SvREFCNT_inc(TOPs);
+		SvREFCNT_inc_void(TOPs);
 	    FREETMPS;
 	    LEAVE;
 	    PUTBACK;
@@ -4156,7 +4190,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
 	/* Otherwise, numeric comparison */
 	PUSHs(d); PUSHs(e);
 	PUTBACK;
-	if ((PL_curcop->op_private & HINT_INTEGER) == HINT_INTEGER)
+	if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
 	    (void) pp_i_eq();
 	else
 	    (void) pp_eq();
@@ -4522,21 +4556,75 @@ 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;
+    int status = 0;
+    SV *upstream;
+    STRLEN got_len;
+    const char *got_p = NULL;
+    const char *prune_from = NULL;
+    bool read_from_cache = FALSE;
+    STRLEN umaxlen;
+
+    assert(maxlen >= 0);
+    umaxlen = maxlen;
 
     /* I was having segfault trouble under Linux 2.2.5 after a
        parse error occured.  (Had to hack around it with a test
        for PL_error_count == 0.)  Solaris doesn't segfault --
        not sure where the trouble is yet.  XXX */
 
+    if (IoFMT_GV(datasv)) {
+	SV *const cache = (SV *)IoFMT_GV(datasv);
+	if (SvOK(cache)) {
+	    STRLEN cache_len;
+	    const char *cache_p = SvPV(cache, cache_len);
+	    STRLEN take = 0;
+
+	    if (umaxlen) {
+		/* Running in block mode and we have some cached data already.
+		 */
+		if (cache_len >= umaxlen) {
+		    /* In fact, so much data we don't even need to call
+		       filter_read.  */
+		    take = umaxlen;
+		}
+	    } else {
+		const char *const first_nl = memchr(cache_p, '\n', cache_len);
+		if (first_nl) {
+		    take = first_nl + 1 - cache_p;
+		}
+	    }
+	    if (take) {
+		sv_catpvn(buf_sv, cache_p, take);
+		sv_chop(cache, cache_p + take);
+		/* Definately not EOF  */
+		return 1;
+	    }
+
+	    sv_catsv(buf_sv, cache);
+	    if (umaxlen) {
+		umaxlen -= cache_len;
+	    }
+	    SvOK_off(cache);
+	    read_from_cache = TRUE;
+	}
+    }
+
+    /* Filter API says that the filter appends to the contents of the buffer.
+       Usually the buffer is "", so the details don't matter. But if it's not,
+       then clearly what it contains is already filtered by this filter, so we
+       don't want to pass it in a second time.
+       I'm going to use a mortal in case the upstream filter croaks.  */
+    upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
+	? sv_newmortal() : buf_sv;
+    SvUPGRADE(upstream, SVt_PV);
+	
     if (filter_has_file) {
-	len = FILTER_READ(idx+1, buf_sv, maxlen);
+	status = FILTER_READ(idx+1, upstream, 0);
     }
 
-    if (filter_sub && len >= 0) {
+    if (filter_sub && status >= 0) {
 	dSP;
 	int count;
 
@@ -4545,9 +4633,9 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
 	SAVETMPS;
 	EXTEND(SP, 2);
 
-	DEFSV = buf_sv;
+	DEFSV = upstream;
 	PUSHMARK(SP);
-	PUSHs(sv_2mortal(newSViv(maxlen)));
+	PUSHs(sv_2mortal(newSViv(0)));
 	if (filter_state) {
 	    PUSHs(filter_state);
 	}
@@ -4558,7 +4646,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
 	if (count > 0) {
 	    SV *out = POPs;
 	    if (SvOK(out)) {
-		len = SvIV(out);
+		status = SvIV(out);
 	    }
 	}
 
@@ -4567,12 +4655,57 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
 	LEAVE;
     }
 
-    if (len <= 0) {
-	IoLINES(datasv) = 0;
-	if (filter_child_proc) {
-	    SvREFCNT_dec(filter_child_proc);
-	    IoFMT_GV(datasv) = NULL;
+    if(SvOK(upstream)) {
+	got_p = SvPV(upstream, got_len);
+	if (umaxlen) {
+	    if (got_len > umaxlen) {
+		prune_from = got_p + umaxlen;
+	    }
+	} else {
+	    const char *const first_nl = memchr(got_p, '\n', got_len);
+	    if (first_nl && first_nl + 1 < got_p + got_len) {
+		/* There's a second line here... */
+		prune_from = first_nl + 1;
+	    }
 	}
+    }
+    if (prune_from) {
+	/* Oh. Too long. Stuff some in our cache.  */
+	STRLEN cached_len = got_p + got_len - prune_from;
+	SV *cache = (SV *)IoFMT_GV(datasv);
+
+	if (!cache) {
+	    IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen));
+	} else if (SvOK(cache)) {
+	    /* Cache should be empty.  */
+	    assert(!SvCUR(cache));
+	}
+
+	sv_setpvn(cache, prune_from, cached_len);
+	/* 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, got_len - cached_len);
+	/* Can't yet be EOF  */
+	if (status == 0)
+	    status = 1;
+    }
+
+    /* If they are at EOF but buf_sv has something in it, then they may never
+       have touched the SV upstream, so it may be undefined.  If we naively
+       concatenate it then we get a warning about use of uninitialised value.
+    */
+    if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
+	sv_catsv(buf_sv, upstream);
+    }
+
+    if (status <= 0) {
+	IoLINES(datasv) = 0;
+	SvREFCNT_dec(IoFMT_GV(datasv));
 	if (filter_state) {
 	    SvREFCNT_dec(filter_state);
 	    IoTOP_GV(datasv) = NULL;
@@ -4583,8 +4716,13 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
 	}
 	filter_del(S_run_user_filter);
     }
-
-    return len;
+    if (status == 0 && read_from_cache) {
+	/* If we read some data from the cache (and by getting here it implies
+	   that we emptied the cache) then we aren't yet at EOF, and mustn't
+	   report that to our caller.  */
+	return 1;
+    }
+    return status;
 }
 
 /* perhaps someone can come up with a better name for