Some tweaks for encodings which need lines.

Also disabled trial of using fallbacks.

p4raw-id: //depot/perlio@16023

2 files changed, 131 insertions, 24 deletions

diff --git a/ext/PerlIO/encoding/encoding.pm b/ext/PerlIO/encoding/encoding.pm
index 9aa0e9a8b1..1d9c73f242 100644
--- a/ext/PerlIO/encoding/encoding.pm
+++ b/ext/PerlIO/encoding/encoding.pm
@@ -1,7 +1,8 @@
 package PerlIO::encoding;
-our $VERSION = '0.02';
+our $VERSION = '0.03';
 use XSLoader ();
-use Encode;
+use Encode (); # Load but do not import anything.
+our $check;
 XSLoader::load 'PerlIO::encoding';
 1;
 __END__
@@ -15,6 +16,9 @@ PerlIO::encoding - encoding layer
   open($f, "<:encoding(foo)", "infoo");
   open($f, ">:encoding(bar)", "outbar");
 
+  use Encode;
+  $PerlIO::encoding::check = Encode::FB_PERLQQ();
+
 =head1 DESCRIPTION
 
 Open a filehandle with a transparent encoding filter.
@@ -24,6 +28,10 @@ character set and encoding to Perl string data (Unicode and
 Perl's internal Unicode encoding, UTF-8).  On output, convert
 Perl string data into the specified character set and encoding.
 
+When the layer is pushed the current value of C<$PerlIO::encoding::check>
+is saved and used as the check argument when calling the Encodings
+encode and decode.
+
 =head1 SEE ALSO
 
 L<open>, L<Encode>, L<perlfunc/binmode>, L<perluniintro>
diff --git a/ext/PerlIO/encoding/encoding.xs b/ext/PerlIO/encoding/encoding.xs
index ea15e56877..5bdc0c7d2e 100644
--- a/ext/PerlIO/encoding/encoding.xs
+++ b/ext/PerlIO/encoding/encoding.xs
@@ -45,11 +45,16 @@ typedef struct {
     SV *dataSV;			/* data we have read from layer below */
     SV *enc;			/* the encoding object */
     SV *chk;                    /* CHECK in Encode methods */
+    int flags;			/* Flags currently just needs lines */
 } PerlIOEncode;
 
+#define NEEDS_LINES	1
 
-#define ENCODE_FB_QUIET "Encode::FB_QUIET"
-
+#if 0
+#define OUR_ENCODE_FB "Encode::FB_DEFAULT"
+#else
+#define OUR_ENCODE_FB "Encode::FB_QUIET"
+#endif
 
 SV *
 PerlIOEncode_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
@@ -78,21 +83,12 @@ PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg)
     PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
     dSP;
     IV code;
+    SV *result = Nullsv;
     code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv);
     ENTER;
     SAVETMPS;
 
     PUSHMARK(sp);
-    PUTBACK;
-    if (call_pv(ENCODE_FB_QUIET, G_SCALAR|G_NOARGS) != 1) {
-	Perl_die(aTHX_ "Call to Encode::FB_QUIET failed!");
-	code = -1;
-    }
-    SPAGAIN;
-    e->chk = newSVsv(POPs);
-    PUTBACK;
-
-    PUSHMARK(sp);
     XPUSHs(arg);
     PUTBACK;
     if (call_pv("Encode::find_encoding", G_SCALAR) != 1) {
@@ -101,20 +97,55 @@ PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg)
 	return -1;
     }
     SPAGAIN;
-    e->enc = POPs;
+    result = POPs;
     PUTBACK;
 
-    if (!SvROK(e->enc)) {
+    if (!SvROK(result) || !SvOBJECT(SvRV(result))) {
 	e->enc = Nullsv;
-	errno = EINVAL;
 	Perl_warner(aTHX_ packWARN(WARN_IO), "Cannot find encoding \"%" SVf "\"",
-		    arg); 
+		    arg);
+	errno = EINVAL;
 	code = -1;
     }
     else {
-	SvREFCNT_inc(e->enc);
+#ifdef USE_NEW_SEQUENCE
+	PUSHMARK(sp);
+	XPUSHs(result);
+	PUTBACK;
+	if (call_method("new_sequence",G_SCALAR|G_EVAL) != 1 || SvTRUE(ERRSV)) {
+	    Perl_warner(aTHX_ packWARN(WARN_IO), "\"%" SVf "\" does not support new_sequence",
+			arg);
+	}
+	else {
+	    SPAGAIN;
+	    result = POPs;
+	    PUTBACK;
+	}
+#endif
+	e->enc = newSVsv(result);
+	PUSHMARK(sp);
+	XPUSHs(e->enc);
+	PUTBACK;
+	if (call_method("needs_lines",G_SCALAR|G_EVAL) != 1 || SvTRUE(ERRSV)) {
+	    Perl_warner(aTHX_ packWARN(WARN_IO), "\"%" SVf "\" does not support needs_lines",
+			arg);
+	}
+	else {
+	    SPAGAIN;
+	    result = POPs;
+	    PUTBACK;
+	    if (SvTRUE(result)) {
+		e->flags |= NEEDS_LINES;
+	    }
+	}
 	PerlIOBase(f)->flags |= PERLIO_F_UTF8;
+	if (e->flags & NEEDS_LINES) {
+	    PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
+	}
     }
+
+    e->chk = newSVsv(get_sv("PerlIO::encoding::check",0));
+
     FREETMPS;
     LEAVE;
     return code;
@@ -136,6 +167,10 @@ PerlIOEncode_popped(pTHX_ PerlIO * f)
 	SvREFCNT_dec(e->dataSV);
 	e->dataSV = Nullsv;
     }
+    if (e->chk) {
+	SvREFCNT_dec(e->chk);
+	e->dataSV = Nullsv;
+    }
     return 0;
 }
 
@@ -210,9 +245,9 @@ PerlIOEncode_fill(pTHX_ PerlIO * f)
 		avail = 0;
 	}
     }
-    if (avail > 0) {
+    if (avail > 0 || (e->flags & NEEDS_LINES)) {
 	STDCHAR *ptr = PerlIO_get_ptr(n);
-	SSize_t use  = avail;
+	SSize_t use  = (avail >= 0) ? avail : 0;
 	SV *uni;
 	char *s;
 	STRLEN len = 0;
@@ -223,12 +258,45 @@ PerlIOEncode_fill(pTHX_ PerlIO * f)
 	if (SvTYPE(e->dataSV) < SVt_PV) {
 	    sv_upgrade(e->dataSV,SVt_PV);
 	}
+	if (e->flags & NEEDS_LINES) {
+	    /* Encoding needs whole lines (e.g. iso-2022-*)
+	       search back from end of available data for
+	       and line marker
+	     */
+	    STDCHAR *nl = ptr+use-1;
+	    while (nl >= ptr) {
+		if (*nl == '\n') {
+		    break;
+		}
+		nl--;
+	    }
+	    if (nl >= ptr && *nl == '\n') {
+		/* found a line - take up to and including that */
+		use = (nl+1)-ptr;
+	    }
+	    else if (avail > 0) {
+		/* No line, but not EOF - append avail to the pending data */
+		sv_catpvn(e->dataSV, ptr, use);
+		PerlIO_set_ptrcnt(n, ptr+use, 0);
+		goto retry;
+	    }
+	    else if (!SvCUR(e->dataSV)) {
+		goto end_of_file;
+	    }
+	}
 	if (SvCUR(e->dataSV)) {
 	    /* something left over from last time - create a normal
 	       SV with new data appended
 	     */
 	    if (use + SvCUR(e->dataSV) > e->base.bufsiz) {
-	       use = e->base.bufsiz - SvCUR(e->dataSV);
+		if (e->flags & NEEDS_LINES) {
+		    /* Have to grow buffer */
+		    e->base.bufsiz = use + SvCUR(e->dataSV);
+		    PerlIOEncode_get_base(aTHX_ f);
+		}
+		else {
+		    use = e->base.bufsiz - SvCUR(e->dataSV);
+		}
 	    }
 	    sv_catpvn(e->dataSV,(char*)ptr,use);
 	}
@@ -238,7 +306,14 @@ PerlIOEncode_fill(pTHX_ PerlIO * f)
 		Safefree(SvPVX(e->dataSV));
 	    }
 	    if (use > e->base.bufsiz) {
-	       use = e->base.bufsiz;
+		if (e->flags & NEEDS_LINES) {
+		    /* Have to grow buffer */
+		    e->base.bufsiz = use;
+		    PerlIOEncode_get_base(aTHX_ f);
+		}
+		else {
+		    use = e->base.bufsiz;
+		}
 	    }
 	    SvPVX(e->dataSV) = (char *) ptr;
 	    SvLEN(e->dataSV) = 0;  /* Hands off sv.c - it isn't yours */
@@ -300,6 +375,7 @@ PerlIOEncode_fill(pTHX_ PerlIO * f)
 	return code;
     }
     else {
+    end_of_file:
 	if (avail == 0)
 	    PerlIOBase(f)->flags |= PERLIO_F_EOF;
 	else
@@ -449,6 +525,16 @@ PerlIOEncode_dup(pTHX_ PerlIO * f, PerlIO * o,
     return f;
 }
 
+SSize_t
+PerlIOEncode_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
+{
+    SSize_t size = PerlIOBuf_write(aTHX_ f, vbuf, count);
+    PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
+    if (e->flags & NEEDS_LINES) {
+    }
+    return size;
+}
+
 PerlIO_funcs PerlIO_encode = {
     "encoding",
     sizeof(PerlIOEncode),
@@ -461,7 +547,7 @@ PerlIO_funcs PerlIO_encode = {
     PerlIOEncode_dup,
     PerlIOBuf_read,
     PerlIOBuf_unread,
-    PerlIOBuf_write,
+    PerlIOEncode_write,
     PerlIOBuf_seek,
     PerlIOEncode_tell,
     PerlIOEncode_close,
@@ -485,6 +571,19 @@ PROTOTYPES: ENABLE
 
 BOOT:
 {
+    SV *sv = get_sv("PerlIO::encoding::check", GV_ADD|GV_ADDMULTI);
+    sv_setiv(sv,0);
+    PUSHMARK(sp);
+    PUTBACK;
+    if (call_pv(OUR_ENCODE_FB, G_SCALAR) != 1) {
+	Perl_warner(aTHX_ packWARN(WARN_IO),
+		    "Call to %s failed!",OUR_ENCODE_FB);
+    }
+    else {
+	SPAGAIN;
+	sv_setsv(sv,POPs);
+	PUTBACK;
+    }
 #ifdef PERLIO_LAYERS
  PerlIO_define_layer(aTHX_ &PerlIO_encode);
 #endif