X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FPerlIO%2Fencoding%2Fencoding.xs;h=df911ed705a59884f0a79841c55fefa308d2b7d8;hb=15af043884e0520355045b5d53efce3cdf6f3094;hp=bff16e73f6002652f7e2449ac4b521e0460b9b8f;hpb=7c436af33814ce716234caa65f470fe47c2a0efa;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/ext/PerlIO/encoding/encoding.xs b/ext/PerlIO/encoding/encoding.xs
index bff16e7..df911ed 100644
--- a/ext/PerlIO/encoding/encoding.xs
+++ b/ext/PerlIO/encoding/encoding.xs
@@ -8,6 +8,8 @@
 #include "XSUB.h"
 #define U8 U8
 
+#define OUR_DEFAULT_FB	"Encode::PERLQQ"
+
 #if defined(USE_PERLIO) && !defined(USE_SFIO)
 
 /* Define an encoding "layer" in the perliol.h sense.
@@ -57,6 +59,9 @@ PerlIOEncode_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
     SV *sv = &PL_sv_undef;
     if (e->enc) {
 	dSP;
+	/* Not 100% sure stack swap is right thing to do during dup ... */
+	PUSHSTACKi(PERLSI_MAGIC);
+	SPAGAIN;
 	ENTER;
 	SAVETMPS;
 	PUSHMARK(sp);
@@ -67,6 +72,9 @@ PerlIOEncode_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
 	    sv = newSVsv(POPs);
 	    PUTBACK;
 	}
+	FREETMPS;
+	LEAVE;
+	POPSTACK;
     }
     return sv;
 }
@@ -79,12 +87,8 @@ PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg)
     IV  code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv);
     SV *result = Nullsv;
 
-    /*
-     * we now "use Encode qw(:fallbacks)" here instead of
-     * PerlIO/encoding.pm.  This avoids SEGV when ":encoding()"
-     * is invoked without prior "use Encode". -- dankogai
-     */
-    require_pv("Encode.pm");
+    PUSHSTACKi(PERLSI_MAGIC);
+    SPAGAIN;
 
     ENTER;
     SAVETMPS;
@@ -104,7 +108,7 @@ PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg)
     if (!SvROK(result) || !SvOBJECT(SvRV(result))) {
 	e->enc = Nullsv;
 	Perl_warner(aTHX_ packWARN(WARN_IO), "Cannot find encoding \"%" SVf "\"",
-		    arg); 
+		    arg);
 	errno = EINVAL;
 	code = -1;
     }
@@ -142,23 +146,11 @@ PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg)
 	PerlIOBase(f)->flags |= PERLIO_F_UTF8;
     }
 
-    if (SvIV(result = get_sv("PerlIO::encoding::check", 1)) == 0){
-	PUSHMARK(sp);
-	PUTBACK;
-       if (call_pv("Encode::FB_QUIET", G_SCALAR) != 1) {
-	    /* should never happen */
-	    Perl_die(aTHX_ "Encode::FB_QUIET did not return a value");
-	    return -1;
-	}
-	SPAGAIN;
-	e->chk = newSVsv(POPs);
-	PUTBACK;
-	sv_setsv(result, e->chk);
-    }else{
-	e->chk = newSVsv(result);
-    }
+    e->chk = newSVsv(get_sv("PerlIO::encoding::fallback", 0));
+
     FREETMPS;
     LEAVE;
+    POPSTACK;
     return code;
 }
 
@@ -180,7 +172,7 @@ PerlIOEncode_popped(pTHX_ PerlIO * f)
     }
     if (e->chk) {
 	SvREFCNT_dec(e->chk);
-	e->dataSV = Nullsv;
+	e->chk = Nullsv;
     }
     return 0;
 }
@@ -243,6 +235,8 @@ PerlIOEncode_fill(pTHX_ PerlIO * f)
 	    Perl_die(aTHX_ "panic: cannot push :perlio for %p",f);
 	}
     }
+    PUSHSTACKi(PERLSI_MAGIC);
+    SPAGAIN;
     ENTER;
     SAVETMPS;
   retry:
@@ -382,18 +376,19 @@ PerlIOEncode_fill(pTHX_ PerlIO * f)
 	    PerlIO_set_ptrcnt(n, ptr+use, (avail-use));
 	    goto retry;
 	}
-	FREETMPS;
-	LEAVE;
-	return code;
     }
     else {
     end_of_file:
+	code = -1;
 	if (avail == 0)
 	    PerlIOBase(f)->flags |= PERLIO_F_EOF;
 	else
 	    PerlIOBase(f)->flags |= PERLIO_F_ERROR;
-	return -1;
     }
+    FREETMPS;
+    LEAVE;
+    POPSTACK;
+    return code;
 }
 
 IV
@@ -402,14 +397,16 @@ PerlIOEncode_flush(pTHX_ PerlIO * f)
     PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
     IV code = 0;
 
-    if (e->bufsv && (e->base.ptr > e->base.buf)) {
+    if (e->bufsv) {
 	dSP;
 	SV *str;
 	char *s;
 	STRLEN len;
 	SSize_t count = 0;
-	if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
-	    /* Write case encode the buffer and write() to layer below */
+	if ((PerlIOBase(f)->flags & PERLIO_F_WRBUF) && (e->base.ptr > e->base.buf)) {
+	    /* Write case - encode the buffer and write() to layer below */
+	    PUSHSTACKi(PERLSI_MAGIC);
+	    SPAGAIN;
 	    ENTER;
 	    SAVETMPS;
 	    PUSHMARK(sp);
@@ -432,6 +429,7 @@ PerlIOEncode_flush(pTHX_ PerlIO * f)
 	    }
 	    FREETMPS;
 	    LEAVE;
+	    POPSTACK;
 	    if (PerlIO_flush(PerlIONext(f)) != 0) {
 		code = -1;
 	    }
@@ -441,21 +439,25 @@ PerlIOEncode_flush(pTHX_ PerlIO * f)
 		return code;
 	    }
 	}
-	else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
+	else if ((PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
 	    /* read case */
 	    /* if we have any untranslated stuff then unread that first */
+	    /* FIXME - unread is fragile is there a better way ? */
 	    if (e->dataSV && SvCUR(e->dataSV)) {
 		s = SvPV(e->dataSV, len);
 		count = PerlIO_unread(PerlIONext(f),s,len);
 		if ((STRLEN)count != len) {
 		    code = -1;
 		}
+		SvCUR_set(e->dataSV,0);
 	    }
 	    /* See if there is anything left in the buffer */
 	    if (e->base.ptr < e->base.end) {
 		/* Bother - have unread data.
 		   re-encode and unread() to layer below
 		 */
+		PUSHSTACKi(PERLSI_MAGIC);
+		SPAGAIN;
 		ENTER;
 		SAVETMPS;
 		str = sv_newmortal();
@@ -483,6 +485,7 @@ PerlIOEncode_flush(pTHX_ PerlIO * f)
 		}
 		FREETMPS;
 		LEAVE;
+		POPSTACK;
 	    }
 	}
 	e->base.ptr = e->base.end = e->base.buf;
@@ -495,9 +498,18 @@ IV
 PerlIOEncode_close(pTHX_ PerlIO * f)
 {
     PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
-    IV code = PerlIOBase_close(aTHX_ f);
-
+    IV code;
+    if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
+	/* Discard partial character */
+	if (e->dataSV) {
+	    SvCUR_set(e->dataSV,0);
+	}
+	/* Don't back decode and unread any pending data */
+	e->base.ptr = e->base.end = e->base.buf;
+    }
+    code = PerlIOBase_close(aTHX_ f);
     if (e->bufsv) {
+	/* This should only fire for write case */
 	if (e->base.buf && e->base.ptr > e->base.buf) {
 	    Perl_croak(aTHX_ "Close with partial character");
 	}
@@ -578,6 +590,7 @@ PerlIO_funcs PerlIO_encode = {
     PerlIOEncode_pushed,
     PerlIOEncode_popped,
     PerlIOBuf_open,
+    NULL, /* binmode - always pop */
     PerlIOEncode_getarg,
     PerlIOBase_fileno,
     PerlIOEncode_dup,
@@ -607,7 +620,38 @@ PROTOTYPES: ENABLE
 
 BOOT:
 {
+    SV *chk = get_sv("PerlIO::encoding::fallback", GV_ADD|GV_ADDMULTI);
+    /*
+     * we now "use Encode ()" here instead of
+     * PerlIO/encoding.pm.  This avoids SEGV when ":encoding()"
+     * is invoked without prior "use Encode". -- dankogai
+     */
+    PUSHSTACKi(PERLSI_MAGIC);
+    SPAGAIN;
+    if (!get_cv(OUR_DEFAULT_FB, 0)) {
+#if 0
+	/* This would just be an irritant now loading works */
+	Perl_warner(aTHX_ packWARN(WARN_IO), ":encoding without 'use Encode'");
+#endif
+	ENTER;
+	/* Encode needs a lot of stack - it is likely to move ... */
+	PUTBACK;
+	/* The SV is magically freed by load_module */
+	load_module(PERL_LOADMOD_NOIMPORT, newSVpvn("Encode", 6), Nullsv, Nullsv);
+	SPAGAIN;
+	LEAVE;
+    }
+    PUSHMARK(sp);
+    PUTBACK;
+    if (call_pv(OUR_DEFAULT_FB, G_SCALAR) != 1) {
+	    /* should never happen */
+	    Perl_die(aTHX_ "%s did not return a value",OUR_DEFAULT_FB);
+    }
+    SPAGAIN;
+    sv_setsv(chk, POPs);
+    PUTBACK;
 #ifdef PERLIO_LAYERS
- PerlIO_define_layer(aTHX_ &PerlIO_encode);
+    PerlIO_define_layer(aTHX_ &PerlIO_encode);
 #endif
+    POPSTACK;
 }