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=9d46e01b0c038bd0a3b6db26334d32dcb638fa3f;hpb=59035dcc924f096b164c1e73d87f1ee955a0d9be;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/ext/PerlIO/encoding/encoding.xs b/ext/PerlIO/encoding/encoding.xs
index 9d46e01..df911ed 100644
--- a/ext/PerlIO/encoding/encoding.xs
+++ b/ext/PerlIO/encoding/encoding.xs
@@ -1,9 +1,15 @@
+/*
+ * $Id: encoding.xs,v 0.3 2002/04/21 22:14:41 dankogai Exp $
+ */
+
 #define PERL_NO_GET_CONTEXT
 #include "EXTERN.h"
 #include "perl.h"
 #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.
@@ -40,8 +46,12 @@ typedef struct {
     SV *bufsv;			/* buffer seen by layers above */
     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
+
 SV *
 PerlIOEncode_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
 {
@@ -49,16 +59,22 @@ 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);
 	XPUSHs(e->enc);
 	PUTBACK;
-	if (perl_call_method("name", G_SCALAR) == 1) {
+	if (call_method("name", G_SCALAR) == 1) {
 	    SPAGAIN;
 	    sv = newSVsv(POPs);
 	    PUTBACK;
 	}
+	FREETMPS;
+	LEAVE;
+	POPSTACK;
     }
     return sv;
 }
@@ -68,34 +84,73 @@ 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);
+    IV  code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv);
+    SV *result = Nullsv;
+
+    PUSHSTACKi(PERLSI_MAGIC);
+    SPAGAIN;
+
     ENTER;
     SAVETMPS;
+
     PUSHMARK(sp);
     XPUSHs(arg);
     PUTBACK;
-    if (perl_call_pv("Encode::find_encoding", G_SCALAR) != 1) {
+    if (call_pv("Encode::find_encoding", G_SCALAR) != 1) {
 	/* should never happen */
 	Perl_die(aTHX_ "Encode::find_encoding did not return a value");
 	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;
 }
 
@@ -115,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;
 }
 
@@ -163,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);
@@ -175,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:
@@ -189,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;
@@ -202,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 {
@@ -216,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);
@@ -228,9 +330,9 @@ PerlIOEncode_fill(pTHX_ PerlIO * f)
 	PUSHMARK(sp);
 	XPUSHs(e->enc);
 	XPUSHs(e->dataSV);
-	XPUSHs(&PL_sv_yes);
+	XPUSHs(e->chk);
 	PUTBACK;
-	if (perl_call_method("decode", G_SCALAR) != 1) {
+	if (call_method("decode", G_SCALAR) != 1) {
 	    Perl_die(aTHX_ "panic: decode did not return a value");
 	}
 	SPAGAIN;
@@ -274,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
@@ -292,14 +396,17 @@ 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);
@@ -307,9 +414,9 @@ PerlIOEncode_flush(pTHX_ PerlIO * f)
 	    SvCUR_set(e->bufsv, e->base.ptr - e->base.buf);
 	    SvUTF8_on(e->bufsv);
 	    XPUSHs(e->bufsv);
-	    XPUSHs(&PL_sv_yes);
+	    XPUSHs(e->chk);
 	    PUTBACK;
-	    if (perl_call_method("encode", G_SCALAR) != 1) {
+	    if (call_method("encode", G_SCALAR) != 1) {
 		Perl_die(aTHX_ "panic: encode did not return a value");
 	    }
 	    SPAGAIN;
@@ -317,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;
 	    }
@@ -331,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 (count != 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();
@@ -358,9 +470,9 @@ PerlIOEncode_flush(pTHX_ PerlIO * f)
 		PUSHMARK(sp);
 		XPUSHs(e->enc);
 		XPUSHs(str);
-		XPUSHs(&PL_sv_yes);
+		XPUSHs(e->chk);
 		PUTBACK;
-		if (perl_call_method("encode", G_SCALAR) != 1) {
+		if (call_method("encode", G_SCALAR) != 1) {
 		     Perl_die(aTHX_ "panic: encode did not return a value");
 		}
 		SPAGAIN;
@@ -368,11 +480,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;
@@ -385,8 +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");
 	}
@@ -428,6 +551,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),
@@ -435,12 +590,13 @@ PerlIO_funcs PerlIO_encode = {
     PerlIOEncode_pushed,
     PerlIOEncode_popped,
     PerlIOBuf_open,
+    NULL, /* binmode - always pop */
     PerlIOEncode_getarg,
     PerlIOBase_fileno,
     PerlIOEncode_dup,
     PerlIOBuf_read,
     PerlIOBuf_unread,
-    PerlIOBuf_write,
+    PerlIOEncode_write,
     PerlIOBuf_seek,
     PerlIOEncode_tell,
     PerlIOEncode_close,
@@ -464,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;
 }