X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FPerlIO%2Fencoding%2Fencoding.xs;h=038dd92861059324b48a00bd992ac42b51bd2769;hb=dc54c7994351acc5ef5bb312ef93ea76de59c190;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..038dd92 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
@@ -410,6 +405,8 @@ PerlIOEncode_flush(pTHX_ PerlIO * f)
 	SSize_t count = 0;
 	if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
 	    /* 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;
 	    }
@@ -456,6 +454,8 @@ PerlIOEncode_flush(pTHX_ PerlIO * f)
 		/* Bother - have unread data.
 		   re-encode and unread() to layer below
 		 */
+		PUSHSTACKi(PERLSI_MAGIC);
+		SPAGAIN;
 		ENTER;
 		SAVETMPS;
 		str = sv_newmortal();
@@ -483,6 +483,7 @@ PerlIOEncode_flush(pTHX_ PerlIO * f)
 		}
 		FREETMPS;
 		LEAVE;
+		POPSTACK;
 	    }
 	}
 	e->base.ptr = e->base.end = e->base.buf;
@@ -607,7 +608,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;
 }