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=ea15e5687744a6da1e5d69c4ca33eb268e154ee2;hpb=918951dd0701a3fa3c94ff1b2b9eb544b527e3e1;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/ext/PerlIO/encoding/encoding.xs b/ext/PerlIO/encoding/encoding.xs
index ea15e56..038dd92 100644
--- a/ext/PerlIO/encoding/encoding.xs
+++ b/ext/PerlIO/encoding/encoding.xs
@@ -1,5 +1,5 @@
 /*
- * $Id$
+ * $Id: encoding.xs,v 0.3 2002/04/21 22:14:41 dankogai Exp $
  */
 
 #define PERL_NO_GET_CONTEXT
@@ -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.
@@ -45,11 +47,10 @@ 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 ENCODE_FB_QUIET "Encode::FB_QUIET"
-
+#define NEEDS_LINES	1
 
 SV *
 PerlIOEncode_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
@@ -58,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);
@@ -68,6 +72,9 @@ PerlIOEncode_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
 	    sv = newSVsv(POPs);
 	    PUTBACK;
 	}
+	FREETMPS;
+	LEAVE;
+	POPSTACK;
     }
     return sv;
 }
@@ -77,20 +84,14 @@ PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg)
 {
     PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
     dSP;
-    IV code;
-    code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv);
-    ENTER;
-    SAVETMPS;
+    IV  code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv);
+    SV *result = Nullsv;
 
-    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;
-    }
+    PUSHSTACKi(PERLSI_MAGIC);
     SPAGAIN;
-    e->chk = newSVsv(POPs);
-    PUTBACK;
+
+    ENTER;
+    SAVETMPS;
 
     PUSHMARK(sp);
     XPUSHs(arg);
@@ -101,22 +102,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;
     }
+
+    e->chk = newSVsv(get_sv("PerlIO::encoding::fallback", 0));
+
     FREETMPS;
     LEAVE;
+    POPSTACK;
     return code;
 }
 
@@ -136,6 +170,10 @@ PerlIOEncode_popped(pTHX_ PerlIO * f)
 	SvREFCNT_dec(e->dataSV);
 	e->dataSV = Nullsv;
     }
+    if (e->chk) {
+	SvREFCNT_dec(e->chk);
+	e->chk = Nullsv;
+    }
     return 0;
 }
 
@@ -184,6 +222,7 @@ PerlIOEncode_fill(pTHX_ PerlIO * f)
     IV code = 0;
     PerlIO *n;
     SSize_t avail;
+
     if (PerlIO_flush(f) != 0)
 	return -1;
     n  = PerlIONext(f);
@@ -196,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:
@@ -210,9 +251,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,13 +264,46 @@ 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, (char*)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) {
+		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);
 	}
 	else {
@@ -237,9 +311,16 @@ PerlIOEncode_fill(pTHX_ PerlIO * f)
 	    if (SvLEN(e->dataSV) && SvPVX(e->dataSV)) {
 		Safefree(SvPVX(e->dataSV));
 	    }
-	    if (use > e->base.bufsiz) {
+	    if (use > (SSize_t)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 */
 	    SvCUR_set(e->dataSV,use);
@@ -295,17 +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
@@ -313,6 +396,7 @@ PerlIOEncode_flush(pTHX_ PerlIO * f)
 {
     PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
     IV code = 0;
+
     if (e->bufsv && (e->base.ptr > e->base.buf)) {
 	dSP;
 	SV *str;
@@ -321,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);
@@ -338,11 +424,12 @@ PerlIOEncode_flush(pTHX_ PerlIO * f)
 	    PUTBACK;
 	    s = SvPV(str, len);
 	    count = PerlIO_write(PerlIONext(f),s,len);
-	    if (count != len) {
+	    if ((STRLEN)count != len) {
 		code = -1;
 	    }
 	    FREETMPS;
 	    LEAVE;
+	    POPSTACK;
 	    if (PerlIO_flush(PerlIONext(f)) != 0) {
 		code = -1;
 	    }
@@ -358,7 +445,7 @@ PerlIOEncode_flush(pTHX_ PerlIO * f)
 	    if (e->dataSV && SvCUR(e->dataSV)) {
 		s = SvPV(e->dataSV, len);
 		count = PerlIO_unread(PerlIONext(f),s,len);
-		if (count != len) {
+		if ((STRLEN)count != len) {
 		    code = -1;
 		}
 	    }
@@ -367,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();
@@ -389,11 +478,12 @@ PerlIOEncode_flush(pTHX_ PerlIO * f)
 		PUTBACK;
 		s = SvPV(str, len);
 		count = PerlIO_unread(PerlIONext(f),s,len);
-		if (count != len) {
+		if ((STRLEN)count != len) {
 		    code = -1;
 		}
 		FREETMPS;
 		LEAVE;
+		POPSTACK;
 	    }
 	}
 	e->base.ptr = e->base.end = e->base.buf;
@@ -407,6 +497,7 @@ PerlIOEncode_close(pTHX_ PerlIO * f)
 {
     PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
     IV code = PerlIOBase_close(aTHX_ f);
+
     if (e->bufsv) {
 	if (e->base.buf && e->base.ptr > e->base.buf) {
 	    Perl_croak(aTHX_ "Close with partial character");
@@ -449,6 +540,38 @@ PerlIOEncode_dup(pTHX_ PerlIO * f, PerlIO * o,
     return f;
 }
 
+SSize_t
+PerlIOEncode_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
+{
+    PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
+    if (e->flags & NEEDS_LINES) {
+	SSize_t done = 0;
+	const char *ptr = (const char *) vbuf;
+	const char *end = ptr+count;
+	while (ptr < end) {
+	    const char *nl = ptr;
+	    while (nl < end && *nl++ != '\n') /* empty body */;
+	    done = PerlIOBuf_write(aTHX_ f, ptr, nl-ptr);
+	    if (done != nl-ptr) {
+		if (done > 0) {
+		    ptr += done;
+		}
+		break;
+	    }
+	    ptr += done;
+	    if (ptr[-1] == '\n') {
+		if (PerlIOEncode_flush(aTHX_ f) != 0) {
+		    break;
+		}
+	    }
+	}
+	return (SSize_t) (ptr - (const char *) vbuf);
+    }
+    else {
+	return PerlIOBuf_write(aTHX_ f, vbuf, count);
+    }
+}
+
 PerlIO_funcs PerlIO_encode = {
     "encoding",
     sizeof(PerlIOEncode),
@@ -461,7 +584,7 @@ PerlIO_funcs PerlIO_encode = {
     PerlIOEncode_dup,
     PerlIOBuf_read,
     PerlIOBuf_unread,
-    PerlIOBuf_write,
+    PerlIOEncode_write,
     PerlIOBuf_seek,
     PerlIOEncode_tell,
     PerlIOEncode_close,
@@ -485,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;
 }