[perl5.git] / ext / PerlIO-encoding / encoding.xs

#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)

/* Define an encoding "layer" in the perliol.h sense.

   The layer defined here "inherits" in an object-oriented sense from
   the "perlio" layer with its PerlIOBuf_* "methods".  The
   implementation is particularly efficient as until Encode settles
   down there is no point in tryint to tune it.

   The layer works by overloading the "fill" and "flush" methods.

   "fill" calls "SUPER::fill" in perl terms, then calls the encode OO
   perl API to convert the encoded data to UTF-8 form, then copies it
   back to the buffer. The "base class's" read methods then see the
   UTF-8 data.

   "flush" transforms the UTF-8 data deposited by the "base class's
   write method in the buffer back into the encoded form using the
   encode OO perl API, then copies data back into the buffer and calls
   "SUPER::flush.

   Note that "flush" is _also_ called for read mode - we still do the
   (back)-translate so that the base class's "flush" sees the
   correct number of encoded chars for positioning the seek
   pointer. (This double translation is the worst performance issue -
   particularly with all-perl encode engine.)

*/

#include "perliol.h"

typedef struct {
    PerlIOBuf base;		/* PerlIOBuf stuff */
    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 */
    int inEncodeCall;		/* trap recursive encode calls */
} PerlIOEncode;

#define NEEDS_LINES	1

SV *
PerlIOEncode_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
{
    PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
    SV *sv = &PL_sv_undef;
    PERL_UNUSED_ARG(param);
    PERL_UNUSED_ARG(flags);
    if (e->enc) {
	dSP;
	/* Not 100% sure stack swap is right thing to do during dup ... */
	PUSHSTACKi(PERLSI_MAGIC);
	ENTER;
	SAVETMPS;
	PUSHMARK(sp);
	XPUSHs(e->enc);
	PUTBACK;
	if (call_method("name", G_SCALAR) == 1) {
	    SPAGAIN;
	    sv = newSVsv(POPs);
	    PUTBACK;
	}
	FREETMPS;
	LEAVE;
	POPSTACK;
    }
    return sv;
}

IV
PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg, PerlIO_funcs *tab)
{
    PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
    dSP;
    IV  code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv,tab);
    SV *result = Nullsv;

    PUSHSTACKi(PERLSI_MAGIC);
    ENTER;
    SAVETMPS;

    PUSHMARK(sp);
    XPUSHs(arg);
    PUTBACK;
    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;
    result = POPs;
    PUTBACK;

    if (!SvROK(result) || !SvOBJECT(SvRV(result))) {
	e->enc = Nullsv;
        if (ckWARN_d(WARN_IO))
            Perl_warner(aTHX_ packWARN(WARN_IO), "Cannot find encoding \"%" SVf "\"",
                    arg);
	errno = EINVAL;
	code = -1;
    }
    else {

       /* $enc->renew */
	PUSHMARK(sp);
	XPUSHs(result);
	PUTBACK;
	if (call_method("renew",G_SCALAR|G_EVAL) != 1 || SvTRUE(ERRSV)) {
            if (ckWARN_d(WARN_IO))
                Perl_warner(aTHX_ packWARN(WARN_IO), "\"%" SVf "\" does not support renew method",
                        arg);
	}
	else {
	    SPAGAIN;
	    result = POPs;
	    PUTBACK;
	}
	e->enc = newSVsv(result);
	PUSHMARK(sp);
	XPUSHs(e->enc);
	PUTBACK;
	if (call_method("needs_lines",G_SCALAR|G_EVAL) != 1 || SvTRUE(ERRSV)) {
            if (ckWARN_d(WARN_IO))
                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));
    e->inEncodeCall = 0;

    FREETMPS;
    LEAVE;
    POPSTACK;
    return code;
}

IV
PerlIOEncode_popped(pTHX_ PerlIO * f)
{
    PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
    if (e->enc) {
	SvREFCNT_dec(e->enc);
	e->enc = Nullsv;
    }
    if (e->bufsv) {
	SvREFCNT_dec(e->bufsv);
	e->bufsv = Nullsv;
    }
    if (e->dataSV) {
	SvREFCNT_dec(e->dataSV);
	e->dataSV = Nullsv;
    }
    if (e->chk) {
	SvREFCNT_dec(e->chk);
	e->chk = Nullsv;
    }
    return 0;
}

STDCHAR *
PerlIOEncode_get_base(pTHX_ PerlIO * f)
{
    PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
    if (!e->base.bufsiz)
	e->base.bufsiz = 1024;
    if (!e->bufsv) {
	e->bufsv = newSV(e->base.bufsiz);
	sv_setpvn(e->bufsv, "", 0);
    }
    e->base.buf = (STDCHAR *) SvPVX(e->bufsv);
    if (!e->base.ptr)
	e->base.ptr = e->base.buf;
    if (!e->base.end)
	e->base.end = e->base.buf;
    if (e->base.ptr < e->base.buf
	|| e->base.ptr > e->base.buf + SvLEN(e->bufsv)) {
	Perl_warn(aTHX_ " ptr %p(%p)%p", e->base.buf, e->base.ptr,
		  e->base.buf + SvLEN(e->bufsv));
	abort();
    }
    if (SvLEN(e->bufsv) < e->base.bufsiz) {
	SSize_t poff = e->base.ptr - e->base.buf;
	SSize_t eoff = e->base.end - e->base.buf;
	e->base.buf = (STDCHAR *) SvGROW(e->bufsv, e->base.bufsiz);
	e->base.ptr = e->base.buf + poff;
	e->base.end = e->base.buf + eoff;
    }
    if (e->base.ptr < e->base.buf
	|| e->base.ptr > e->base.buf + SvLEN(e->bufsv)) {
	Perl_warn(aTHX_ " ptr %p(%p)%p", e->base.buf, e->base.ptr,
		  e->base.buf + SvLEN(e->bufsv));
	abort();
    }
    return e->base.buf;
}

IV
PerlIOEncode_fill(pTHX_ PerlIO * f)
{
    PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
    dSP;
    IV code = 0;
    PerlIO *n;
    SSize_t avail;

    if (PerlIO_flush(f) != 0)
	return -1;
    n  = PerlIONext(f);
    if (!PerlIO_fast_gets(n)) {
	/* Things get too messy if we don't have a buffer layer
	   push a :perlio to do the job */
	char mode[8];
	n  = PerlIO_push(aTHX_ n, &PerlIO_perlio, PerlIO_modestr(f,mode), Nullsv);
	if (!n) {
	    Perl_die(aTHX_ "panic: cannot push :perlio for %p",f);
	}
    }
    PUSHSTACKi(PERLSI_MAGIC);
    ENTER;
    SAVETMPS;
  retry:
    avail = PerlIO_get_cnt(n);
    if (avail <= 0) {
	avail = PerlIO_fill(n);
	if (avail == 0) {
	    avail = PerlIO_get_cnt(n);
	}
	else {
	    if (!PerlIO_error(n) && PerlIO_eof(n))
		avail = 0;
	}
    }
    if (avail > 0 || (e->flags & NEEDS_LINES)) {
	STDCHAR *ptr = PerlIO_get_ptr(n);
	SSize_t use  = (avail >= 0) ? avail : 0;
	SV *uni;
	char *s = NULL;
	STRLEN len = 0;
	e->base.ptr = e->base.end = (STDCHAR *) NULL;
	(void) PerlIOEncode_get_base(aTHX_ f);
	if (!e->dataSV)
	    e->dataSV = newSV(0);
	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 {
	    /* Create a "dummy" SV to represent the available data from layer below */
	    if (SvLEN(e->dataSV) && SvPVX_const(e->dataSV)) {
		Safefree(SvPVX_mutable(e->dataSV));
	    }
	    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;
	    }
	    }
	    SvPV_set(e->dataSV, (char *) ptr);
	    SvLEN_set(e->dataSV, 0);  /* Hands off sv.c - it isn't yours */
	    SvCUR_set(e->dataSV,use);
	    SvPOK_only(e->dataSV);
	}
	SvUTF8_off(e->dataSV);
	PUSHMARK(sp);
	XPUSHs(e->enc);
	XPUSHs(e->dataSV);
	XPUSHs(e->chk);
	PUTBACK;
	if (call_method("decode", G_SCALAR) != 1) {
	    Perl_die(aTHX_ "panic: decode did not return a value");
	}
	SPAGAIN;
	uni = POPs;
	PUTBACK;
	/* No cows allowed. */
	if (SvTHINKFIRST(e->dataSV)) SvPV_force_nolen(e->dataSV);
	/* Now get translated string (forced to UTF-8) and use as buffer */
	if (SvPOK(uni)) {
	    s = SvPVutf8(uni, len);
#ifdef PARANOID_ENCODE_CHECKS
	    if (len && !is_utf8_string((U8*)s,len)) {
		Perl_warn(aTHX_ "panic: decode did not return UTF-8 '%.*s'",(int) len,s);
	    }
#endif
	}
	if (len > 0) {
	    /* Got _something */
	    /* if decode gave us back dataSV then data may vanish when
	       we do ptrcnt adjust - so take our copy now.
	       (The copy is a pain - need a put-it-here option for decode.)
	     */
	    sv_setpvn(e->bufsv,s,len);
	    e->base.ptr = e->base.buf = (STDCHAR*)SvPVX(e->bufsv);
	    e->base.end = e->base.ptr + SvCUR(e->bufsv);
	    PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
	    SvUTF8_on(e->bufsv);

	    /* Adjust ptr/cnt not taking anything which
	       did not translate - not clear this is a win */
	    /* compute amount we took */
	    if (!SvPOKp(e->dataSV)) (void)SvPV_force_nolen(e->dataSV);
	    use -= SvCUR(e->dataSV);
	    PerlIO_set_ptrcnt(n, ptr+use, (avail-use));
	    /* and as we did not take it it isn't pending */
	    SvCUR_set(e->dataSV,0);
	} else {
	    /* Got nothing - assume partial character so we need some more */
	    /* Make sure e->dataSV is a normal SV before re-filling as
	       buffer alias will change under us
	     */
	    s = SvPV(e->dataSV,len);
	    sv_setpvn(e->dataSV,s,len);
	    PerlIO_set_ptrcnt(n, ptr+use, (avail-use));
	    goto retry;
	}
    }
    else {
    end_of_file:
	code = -1;
	if (avail == 0)
	    PerlIOBase(f)->flags |= PERLIO_F_EOF;
	else
	    PerlIOBase(f)->flags |= PERLIO_F_ERROR;
    }
    FREETMPS;
    LEAVE;
    POPSTACK;
    return code;
}

IV
PerlIOEncode_flush(pTHX_ PerlIO * f)
{
    PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
    IV code = 0;

    if (e->bufsv) {
	dSP;
	SV *str;
	char *s;
	STRLEN len;
	SSize_t count = 0;
	if ((PerlIOBase(f)->flags & PERLIO_F_WRBUF) && (e->base.ptr > e->base.buf)) {
	    if (e->inEncodeCall) return 0;
	    /* Write case - encode the buffer and write() to layer below */
	    PUSHSTACKi(PERLSI_MAGIC);
	    ENTER;
	    SAVETMPS;
	    PUSHMARK(sp);
	    XPUSHs(e->enc);
	    SvCUR_set(e->bufsv, e->base.ptr - e->base.buf);
	    SvUTF8_on(e->bufsv);
	    XPUSHs(e->bufsv);
	    XPUSHs(e->chk);
	    PUTBACK;
	    e->inEncodeCall = 1;
	    if (call_method("encode", G_SCALAR) != 1) {
		e->inEncodeCall = 0;
		Perl_die(aTHX_ "panic: encode did not return a value");
	    }
	    e->inEncodeCall = 0;
	    SPAGAIN;
	    str = POPs;
	    PUTBACK;
	    s = SvPV(str, len);
	    count = PerlIO_write(PerlIONext(f),s,len);
	    if ((STRLEN)count != len) {
		code = -1;
	    }
	    FREETMPS;
	    LEAVE;
	    POPSTACK;
	    if (PerlIO_flush(PerlIONext(f)) != 0) {
		code = -1;
	    }
	    if (!SvPOKp(e->bufsv) || SvTHINKFIRST(e->bufsv))
		(void)SvPV_force_nolen(e->bufsv);
	    if ((STDCHAR *)SvPVX(e->bufsv) != e->base.buf) {
		e->base.ptr = SvEND(e->bufsv);
		e->base.end = SvPVX(e->bufsv) + (e->base.end-e->base.buf);
		e->base.buf = (STDCHAR *)SvPVX(e->bufsv);
	    }
	    (void)PerlIOEncode_get_base(aTHX_ f);
	    if (SvCUR(e->bufsv)) {
		/* Did not all translate */
		e->base.ptr = e->base.buf+SvCUR(e->bufsv);
		return code;
	    }
	}
	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) {
		if (e->inEncodeCall) return 0;
		/* Bother - have unread data.
		   re-encode and unread() to layer below
		 */
		PUSHSTACKi(PERLSI_MAGIC);
		ENTER;
		SAVETMPS;
		str = sv_newmortal();
		sv_upgrade(str, SVt_PV);
		SvPV_set(str, (char*)e->base.ptr);
		SvLEN_set(str, 0);
		SvCUR_set(str, e->base.end - e->base.ptr);
		SvPOK_only(str);
		SvUTF8_on(str);
		PUSHMARK(sp);
		XPUSHs(e->enc);
		XPUSHs(str);
		XPUSHs(e->chk);
		PUTBACK;
		e->inEncodeCall = 1;
		if (call_method("encode", G_SCALAR) != 1) {
		    e->inEncodeCall = 0;
		    Perl_die(aTHX_ "panic: encode did not return a value");
		}
		e->inEncodeCall = 0;
		SPAGAIN;
		str = POPs;
		PUTBACK;
		s = SvPV(str, len);
		count = PerlIO_unread(PerlIONext(f),s,len);
		if ((STRLEN)count != len) {
		    code = -1;
		}
		FREETMPS;
		LEAVE;
		POPSTACK;
	    }
	}
	e->base.ptr = e->base.end = e->base.buf;
	PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
    }
    return code;
}

IV
PerlIOEncode_close(pTHX_ PerlIO * f)
{
    PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
    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");
	}
	SvREFCNT_dec(e->bufsv);
	e->bufsv = Nullsv;
    }
    e->base.buf = NULL;
    e->base.ptr = NULL;
    e->base.end = NULL;
    PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
    return code;
}

Off_t
PerlIOEncode_tell(pTHX_ PerlIO * f)
{
    PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
    /* Unfortunately the only way to get a position is to (re-)translate,
       the UTF8 we have in buffer and then ask layer below
     */
    PerlIO_flush(f);
    if (b->buf && b->ptr > b->buf) {
	Perl_croak(aTHX_ "Cannot tell at partial character");
    }
    return PerlIO_tell(PerlIONext(f));
}

PerlIO *
PerlIOEncode_dup(pTHX_ PerlIO * f, PerlIO * o,
		 CLONE_PARAMS * params, int flags)
{
    if ((f = PerlIOBase_dup(aTHX_ f, o, params, flags))) {
	PerlIOEncode *fe = PerlIOSelf(f, PerlIOEncode);
	PerlIOEncode *oe = PerlIOSelf(o, PerlIOEncode);
	if (oe->enc) {
	    fe->enc = PerlIO_sv_dup(aTHX_ oe->enc, params);
	}
    }
    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 = {
    sizeof(PerlIO_funcs),
    "encoding",
    sizeof(PerlIOEncode),
    PERLIO_K_BUFFERED|PERLIO_K_DESTRUCT,
    PerlIOEncode_pushed,
    PerlIOEncode_popped,
    PerlIOBuf_open,
    NULL, /* binmode - always pop */
    PerlIOEncode_getarg,
    PerlIOBase_fileno,
    PerlIOEncode_dup,
    PerlIOBuf_read,
    PerlIOBuf_unread,
    PerlIOEncode_write,
    PerlIOBuf_seek,
    PerlIOEncode_tell,
    PerlIOEncode_close,
    PerlIOEncode_flush,
    PerlIOEncode_fill,
    PerlIOBase_eof,
    PerlIOBase_error,
    PerlIOBase_clearerr,
    PerlIOBase_setlinebuf,
    PerlIOEncode_get_base,
    PerlIOBuf_bufsiz,
    PerlIOBuf_get_ptr,
    PerlIOBuf_get_cnt,
    PerlIOBuf_set_ptrcnt,
};
#endif				/* encode layer */

MODULE = PerlIO::encoding PACKAGE = PerlIO::encoding

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);
    if (!get_cvs(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
	/* The SV is magically freed by load_module */
	load_module(PERL_LOADMOD_NOIMPORT, newSVpvs("Encode"), Nullsv, Nullsv);
	assert(sp == PL_stack_sp);
    }
    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);
#endif
    POPSTACK;
}
Commit	Line	Data
59035dcc JH	1	#define PERL_NO_GET_CONTEXT
	2	#include "EXTERN.h"
	3	#include "perl.h"
	4	#include "XSUB.h"
	5	#define U8 U8
	6
dc54c799 NIS	7	#define OUR_DEFAULT_FB "Encode::PERLQQ"
dc54c799 NIS	8
97cb92d6	9	#if defined(USE_PERLIO)
59035dcc JH	10
	11	/* Define an encoding "layer" in the perliol.h sense.
	12
	13	The layer defined here "inherits" in an object-oriented sense from
	14	the "perlio" layer with its PerlIOBuf_* "methods". The
	15	implementation is particularly efficient as until Encode settles
	16	down there is no point in tryint to tune it.
	17
	18	The layer works by overloading the "fill" and "flush" methods.
	19
	20	"fill" calls "SUPER::fill" in perl terms, then calls the encode OO
	21	perl API to convert the encoded data to UTF-8 form, then copies it
	22	back to the buffer. The "base class's" read methods then see the
	23	UTF-8 data.
	24
	25	"flush" transforms the UTF-8 data deposited by the "base class's
	26	write method in the buffer back into the encoded form using the
	27	encode OO perl API, then copies data back into the buffer and calls
	28	"SUPER::flush.
	29
	30	Note that "flush" is _also_ called for read mode - we still do the
a6d05634	31	(back)-translate so that the base class's "flush" sees the
59035dcc JH	32	correct number of encoded chars for positioning the seek
	33	pointer. (This double translation is the worst performance issue -
	34	particularly with all-perl encode engine.)
	35
	36	*/
	37
	38	#include "perliol.h"
	39
	40	typedef struct {
	41	PerlIOBuf base; /* PerlIOBuf stuff */
	42	SV bufsv; / buffer seen by layers above */
	43	SV dataSV; / data we have read from layer below */
	44	SV enc; / the encoding object */
918951dd	45	SV chk; / CHECK in Encode methods */
c00aecee	46	int flags; /* Flags currently just needs lines */
74f6c1ca	47	int inEncodeCall; /* trap recursive encode calls */
59035dcc JH	48	} PerlIOEncode;
59035dcc JH	49
c00aecee	50	#define NEEDS_LINES 1
918951dd	51
59035dcc JH	52	SV *
	53	PerlIOEncode_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
	54	{
	55	PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
	56	SV *sv = &PL_sv_undef;
c33e8be1 Z	57	PERL_UNUSED_ARG(param);
c33e8be1 Z	58	PERL_UNUSED_ARG(flags);
59035dcc JH	59	if (e->enc) {
59035dcc JH	60	dSP;
24f59afc NIS	61	/* Not 100% sure stack swap is right thing to do during dup ... */
24f59afc NIS	62	PUSHSTACKi(PERLSI_MAGIC);
59035dcc JH	63	ENTER;
	64	SAVETMPS;
	65	PUSHMARK(sp);
	66	XPUSHs(e->enc);
	67	PUTBACK;
918951dd	68	if (call_method("name", G_SCALAR) == 1) {
59035dcc JH	69	SPAGAIN;
	70	sv = newSVsv(POPs);
	71	PUTBACK;
	72	}
24f59afc NIS	73	FREETMPS;
	74	LEAVE;
	75	POPSTACK;
59035dcc JH	76	}
	77	return sv;
	78	}
	79
	80	IV
2dc2558e	81	PerlIOEncode_pushed(pTHX_ PerlIO * f, const char mode, SV arg, PerlIO_funcs *tab)
59035dcc JH	82	{
	83	PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
	84	dSP;
2dc2558e	85	IV code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv,tab);
c00aecee	86	SV *result = Nullsv;
c657f685	87
24f59afc	88	PUSHSTACKi(PERLSI_MAGIC);
59035dcc JH	89	ENTER;
59035dcc JH	90	SAVETMPS;
918951dd JH	91
918951dd JH	92	PUSHMARK(sp);
59035dcc JH	93	XPUSHs(arg);
59035dcc JH	94	PUTBACK;
918951dd	95	if (call_pv("Encode::find_encoding", G_SCALAR) != 1) {
59035dcc JH	96	/* should never happen */
	97	Perl_die(aTHX_ "Encode::find_encoding did not return a value");
	98	return -1;
	99	}
	100	SPAGAIN;
c00aecee	101	result = POPs;
59035dcc	102	PUTBACK;
918951dd	103
c00aecee	104	if (!SvROK(result) \|\| !SvOBJECT(SvRV(result))) {
59035dcc	105	e->enc = Nullsv;
1bb5f205 RGS	106	if (ckWARN_d(WARN_IO))
	107	Perl_warner(aTHX_ packWARN(WARN_IO), "Cannot find encoding \"%" SVf "\"",
	108	arg);
c00aecee	109	errno = EINVAL;
59035dcc JH	110	code = -1;
	111	}
	112	else {
a0d8a30e DK	113
a0d8a30e DK	114	/* $enc->renew */
c00aecee NIS	115	PUSHMARK(sp);
	116	XPUSHs(result);
	117	PUTBACK;
a0d8a30e	118	if (call_method("renew",G_SCALAR\|G_EVAL) != 1 \|\| SvTRUE(ERRSV)) {
1bb5f205 RGS	119	if (ckWARN_d(WARN_IO))
	120	Perl_warner(aTHX_ packWARN(WARN_IO), "\"%" SVf "\" does not support renew method",
	121	arg);
c00aecee NIS	122	}
	123	else {
	124	SPAGAIN;
	125	result = POPs;
	126	PUTBACK;
	127	}
c00aecee NIS	128	e->enc = newSVsv(result);
	129	PUSHMARK(sp);
	130	XPUSHs(e->enc);
	131	PUTBACK;
	132	if (call_method("needs_lines",G_SCALAR\|G_EVAL) != 1 \|\| SvTRUE(ERRSV)) {
1bb5f205 RGS	133	if (ckWARN_d(WARN_IO))
1bb5f205 RGS	134	Perl_warner(aTHX_ packWARN(WARN_IO), "\"%" SVf "\" does not support needs_lines",
c00aecee NIS	135	arg);
	136	}
	137	else {
	138	SPAGAIN;
	139	result = POPs;
	140	PUTBACK;
	141	if (SvTRUE(result)) {
	142	e->flags \|= NEEDS_LINES;
	143	}
	144	}
59035dcc JH	145	PerlIOBase(f)->flags \|= PERLIO_F_UTF8;
59035dcc JH	146	}
c00aecee	147
1982da40	148	e->chk = newSVsv(get_sv("PerlIO::encoding::fallback", 0));
74f6c1ca	149	e->inEncodeCall = 0;
54871a3c	150
59035dcc JH	151	FREETMPS;
59035dcc JH	152	LEAVE;
24f59afc	153	POPSTACK;
59035dcc JH	154	return code;
	155	}
	156
	157	IV
	158	PerlIOEncode_popped(pTHX_ PerlIO * f)
	159	{
	160	PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
	161	if (e->enc) {
	162	SvREFCNT_dec(e->enc);
	163	e->enc = Nullsv;
	164	}
	165	if (e->bufsv) {
	166	SvREFCNT_dec(e->bufsv);
	167	e->bufsv = Nullsv;
	168	}
	169	if (e->dataSV) {
	170	SvREFCNT_dec(e->dataSV);
	171	e->dataSV = Nullsv;
	172	}
c00aecee NIS	173	if (e->chk) {
c00aecee NIS	174	SvREFCNT_dec(e->chk);
9b683d95	175	e->chk = Nullsv;
c00aecee	176	}
59035dcc JH	177	return 0;
	178	}
	179
	180	STDCHAR *
	181	PerlIOEncode_get_base(pTHX_ PerlIO * f)
	182	{
	183	PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
	184	if (!e->base.bufsiz)
	185	e->base.bufsiz = 1024;
	186	if (!e->bufsv) {
	187	e->bufsv = newSV(e->base.bufsiz);
	188	sv_setpvn(e->bufsv, "", 0);
	189	}
	190	e->base.buf = (STDCHAR *) SvPVX(e->bufsv);
	191	if (!e->base.ptr)
	192	e->base.ptr = e->base.buf;
	193	if (!e->base.end)
	194	e->base.end = e->base.buf;
	195	if (e->base.ptr < e->base.buf
	196	\|\| e->base.ptr > e->base.buf + SvLEN(e->bufsv)) {
	197	Perl_warn(aTHX_ " ptr %p(%p)%p", e->base.buf, e->base.ptr,
	198	e->base.buf + SvLEN(e->bufsv));
	199	abort();
	200	}
	201	if (SvLEN(e->bufsv) < e->base.bufsiz) {
	202	SSize_t poff = e->base.ptr - e->base.buf;
	203	SSize_t eoff = e->base.end - e->base.buf;
	204	e->base.buf = (STDCHAR *) SvGROW(e->bufsv, e->base.bufsiz);
	205	e->base.ptr = e->base.buf + poff;
	206	e->base.end = e->base.buf + eoff;
	207	}
	208	if (e->base.ptr < e->base.buf
	209	\|\| e->base.ptr > e->base.buf + SvLEN(e->bufsv)) {
	210	Perl_warn(aTHX_ " ptr %p(%p)%p", e->base.buf, e->base.ptr,
	211	e->base.buf + SvLEN(e->bufsv));
	212	abort();
	213	}
	214	return e->base.buf;
	215	}
	216
	217	IV
	218	PerlIOEncode_fill(pTHX_ PerlIO * f)
	219	{
	220	PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
	221	dSP;
	222	IV code = 0;
	223	PerlIO *n;
	224	SSize_t avail;
c657f685	225
59035dcc JH	226	if (PerlIO_flush(f) != 0)
	227	return -1;
	228	n = PerlIONext(f);
	229	if (!PerlIO_fast_gets(n)) {
	230	/* Things get too messy if we don't have a buffer layer
	231	push a :perlio to do the job */
	232	char mode[8];
	233	n = PerlIO_push(aTHX_ n, &PerlIO_perlio, PerlIO_modestr(f,mode), Nullsv);
	234	if (!n) {
	235	Perl_die(aTHX_ "panic: cannot push :perlio for %p",f);
	236	}
	237	}
24f59afc	238	PUSHSTACKi(PERLSI_MAGIC);
59035dcc JH	239	ENTER;
	240	SAVETMPS;
	241	retry:
	242	avail = PerlIO_get_cnt(n);
	243	if (avail <= 0) {
	244	avail = PerlIO_fill(n);
	245	if (avail == 0) {
	246	avail = PerlIO_get_cnt(n);
	247	}
	248	else {
	249	if (!PerlIO_error(n) && PerlIO_eof(n))
	250	avail = 0;
	251	}
	252	}
c00aecee	253	if (avail > 0 \|\| (e->flags & NEEDS_LINES)) {
59035dcc	254	STDCHAR *ptr = PerlIO_get_ptr(n);
c00aecee	255	SSize_t use = (avail >= 0) ? avail : 0;
59035dcc	256	SV *uni;
9849c14c	257	char *s = NULL;
59035dcc	258	STRLEN len = 0;
9849c14c	259	e->base.ptr = e->base.end = (STDCHAR *) NULL;
59035dcc JH	260	(void) PerlIOEncode_get_base(aTHX_ f);
	261	if (!e->dataSV)
	262	e->dataSV = newSV(0);
	263	if (SvTYPE(e->dataSV) < SVt_PV) {
	264	sv_upgrade(e->dataSV,SVt_PV);
	265	}
c00aecee NIS	266	if (e->flags & NEEDS_LINES) {
	267	/* Encoding needs whole lines (e.g. iso-2022-*)
	268	search back from end of available data for
	269	and line marker
	270	*/
	271	STDCHAR *nl = ptr+use-1;
	272	while (nl >= ptr) {
	273	if (*nl == '\n') {
	274	break;
	275	}
	276	nl--;
	277	}
	278	if (nl >= ptr && *nl == '\n') {
	279	/* found a line - take up to and including that */
	280	use = (nl+1)-ptr;
	281	}
	282	else if (avail > 0) {
	283	/* No line, but not EOF - append avail to the pending data */
8994bf69	284	sv_catpvn(e->dataSV, (char*)ptr, use);
c00aecee NIS	285	PerlIO_set_ptrcnt(n, ptr+use, 0);
	286	goto retry;
	287	}
	288	else if (!SvCUR(e->dataSV)) {
	289	goto end_of_file;
	290	}
	291	}
59035dcc JH	292	if (SvCUR(e->dataSV)) {
	293	/* something left over from last time - create a normal
	294	SV with new data appended
	295	*/
	296	if (use + SvCUR(e->dataSV) > e->base.bufsiz) {
c00aecee NIS	297	if (e->flags & NEEDS_LINES) {
	298	/* Have to grow buffer */
	299	e->base.bufsiz = use + SvCUR(e->dataSV);
	300	PerlIOEncode_get_base(aTHX_ f);
	301	}
	302	else {
c657f685 JH	303	use = e->base.bufsiz - SvCUR(e->dataSV);
c657f685 JH	304	}
59035dcc JH	305	}
	306	sv_catpvn(e->dataSV,(char*)ptr,use);
	307	}
	308	else {
	309	/* Create a "dummy" SV to represent the available data from layer below */
aa07b2f6	310	if (SvLEN(e->dataSV) && SvPVX_const(e->dataSV)) {
94010e71	311	Safefree(SvPVX_mutable(e->dataSV));
59035dcc	312	}
7c436af3	313	if (use > (SSize_t)e->base.bufsiz) {
c00aecee NIS	314	if (e->flags & NEEDS_LINES) {
	315	/* Have to grow buffer */
	316	e->base.bufsiz = use;
	317	PerlIOEncode_get_base(aTHX_ f);
	318	}
	319	else {
c657f685 JH	320	use = e->base.bufsiz;
c657f685 JH	321	}
59035dcc	322	}
f880fe2f	323	SvPV_set(e->dataSV, (char *) ptr);
b162af07	324	SvLEN_set(e->dataSV, 0); /* Hands off sv.c - it isn't yours */
59035dcc JH	325	SvCUR_set(e->dataSV,use);
	326	SvPOK_only(e->dataSV);
	327	}
	328	SvUTF8_off(e->dataSV);
	329	PUSHMARK(sp);
	330	XPUSHs(e->enc);
	331	XPUSHs(e->dataSV);
918951dd	332	XPUSHs(e->chk);
59035dcc	333	PUTBACK;
918951dd	334	if (call_method("decode", G_SCALAR) != 1) {
59035dcc JH	335	Perl_die(aTHX_ "panic: decode did not return a value");
	336	}
	337	SPAGAIN;
	338	uni = POPs;
	339	PUTBACK;
8f79eb5b FC	340	/* No cows allowed. */
8f79eb5b FC	341	if (SvTHINKFIRST(e->dataSV)) SvPV_force_nolen(e->dataSV);
59035dcc JH	342	/* Now get translated string (forced to UTF-8) and use as buffer */
	343	if (SvPOK(uni)) {
	344	s = SvPVutf8(uni, len);
	345	#ifdef PARANOID_ENCODE_CHECKS
	346	if (len && !is_utf8_string((U8*)s,len)) {
	347	Perl_warn(aTHX_ "panic: decode did not return UTF-8 '%.*s'",(int) len,s);
	348	}
	349	#endif
	350	}
	351	if (len > 0) {
	352	/* Got _something */
	353	/* if decode gave us back dataSV then data may vanish when
	354	we do ptrcnt adjust - so take our copy now.
	355	(The copy is a pain - need a put-it-here option for decode.)
	356	*/
	357	sv_setpvn(e->bufsv,s,len);
	358	e->base.ptr = e->base.buf = (STDCHAR*)SvPVX(e->bufsv);
	359	e->base.end = e->base.ptr + SvCUR(e->bufsv);
	360	PerlIOBase(f)->flags \|= PERLIO_F_RDBUF;
	361	SvUTF8_on(e->bufsv);
	362
	363	/* Adjust ptr/cnt not taking anything which
	364	did not translate - not clear this is a win */
	365	/* compute amount we took */
667763bd	366	if (!SvPOKp(e->dataSV)) (void)SvPV_force_nolen(e->dataSV);
59035dcc JH	367	use -= SvCUR(e->dataSV);
	368	PerlIO_set_ptrcnt(n, ptr+use, (avail-use));
	369	/* and as we did not take it it isn't pending */
	370	SvCUR_set(e->dataSV,0);
	371	} else {
	372	/* Got nothing - assume partial character so we need some more */
	373	/* Make sure e->dataSV is a normal SV before re-filling as
	374	buffer alias will change under us
	375	*/
	376	s = SvPV(e->dataSV,len);
	377	sv_setpvn(e->dataSV,s,len);
	378	PerlIO_set_ptrcnt(n, ptr+use, (avail-use));
	379	goto retry;
	380	}
59035dcc JH	381	}
59035dcc JH	382	else {
c00aecee	383	end_of_file:
24f59afc	384	code = -1;
59035dcc JH	385	if (avail == 0)
	386	PerlIOBase(f)->flags \|= PERLIO_F_EOF;
	387	else
	388	PerlIOBase(f)->flags \|= PERLIO_F_ERROR;
59035dcc	389	}
24f59afc NIS	390	FREETMPS;
	391	LEAVE;
	392	POPSTACK;
	393	return code;
59035dcc JH	394	}
	395
	396	IV
	397	PerlIOEncode_flush(pTHX_ PerlIO * f)
	398	{
	399	PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
	400	IV code = 0;
c657f685	401
b4bd11bc	402	if (e->bufsv) {
59035dcc JH	403	dSP;
	404	SV *str;
	405	char *s;
	406	STRLEN len;
	407	SSize_t count = 0;
b4bd11bc	408	if ((PerlIOBase(f)->flags & PERLIO_F_WRBUF) && (e->base.ptr > e->base.buf)) {
74f6c1ca	409	if (e->inEncodeCall) return 0;
b4bd11bc	410	/* Write case - encode the buffer and write() to layer below */
24f59afc	411	PUSHSTACKi(PERLSI_MAGIC);
59035dcc JH	412	ENTER;
	413	SAVETMPS;
	414	PUSHMARK(sp);
	415	XPUSHs(e->enc);
	416	SvCUR_set(e->bufsv, e->base.ptr - e->base.buf);
	417	SvUTF8_on(e->bufsv);
	418	XPUSHs(e->bufsv);
918951dd	419	XPUSHs(e->chk);
59035dcc	420	PUTBACK;
74f6c1ca	421	e->inEncodeCall = 1;
918951dd	422	if (call_method("encode", G_SCALAR) != 1) {
74f6c1ca	423	e->inEncodeCall = 0;
59035dcc JH	424	Perl_die(aTHX_ "panic: encode did not return a value");
59035dcc JH	425	}
74f6c1ca	426	e->inEncodeCall = 0;
59035dcc JH	427	SPAGAIN;
	428	str = POPs;
	429	PUTBACK;
	430	s = SvPV(str, len);
	431	count = PerlIO_write(PerlIONext(f),s,len);
7c436af3	432	if ((STRLEN)count != len) {
59035dcc JH	433	code = -1;
	434	}
	435	FREETMPS;
	436	LEAVE;
24f59afc	437	POPSTACK;
59035dcc JH	438	if (PerlIO_flush(PerlIONext(f)) != 0) {
	439	code = -1;
	440	}
667763bd FC	441	if (!SvPOKp(e->bufsv) \|\| SvTHINKFIRST(e->bufsv))
667763bd FC	442	(void)SvPV_force_nolen(e->bufsv);
e9a8753a FC	443	if ((STDCHAR *)SvPVX(e->bufsv) != e->base.buf) {
	444	e->base.ptr = SvEND(e->bufsv);
	445	e->base.end = SvPVX(e->bufsv) + (e->base.end-e->base.buf);
667763bd	446	e->base.buf = (STDCHAR *)SvPVX(e->bufsv);
e9a8753a FC	447	}
e9a8753a FC	448	(void)PerlIOEncode_get_base(aTHX_ f);
59035dcc JH	449	if (SvCUR(e->bufsv)) {
	450	/* Did not all translate */
	451	e->base.ptr = e->base.buf+SvCUR(e->bufsv);
	452	return code;
	453	}
	454	}
b4bd11bc	455	else if ((PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
59035dcc JH	456	/* read case */
59035dcc JH	457	/* if we have any untranslated stuff then unread that first */
8849edfd	458	/* FIXME - unread is fragile is there a better way ? */
59035dcc JH	459	if (e->dataSV && SvCUR(e->dataSV)) {
	460	s = SvPV(e->dataSV, len);
	461	count = PerlIO_unread(PerlIONext(f),s,len);
7c436af3	462	if ((STRLEN)count != len) {
59035dcc JH	463	code = -1;
59035dcc JH	464	}
b4bd11bc	465	SvCUR_set(e->dataSV,0);
59035dcc JH	466	}
	467	/* See if there is anything left in the buffer */
	468	if (e->base.ptr < e->base.end) {
74f6c1ca	469	if (e->inEncodeCall) return 0;
59035dcc JH	470	/* Bother - have unread data.
	471	re-encode and unread() to layer below
	472	*/
24f59afc	473	PUSHSTACKi(PERLSI_MAGIC);
59035dcc JH	474	ENTER;
	475	SAVETMPS;
	476	str = sv_newmortal();
	477	sv_upgrade(str, SVt_PV);
f880fe2f	478	SvPV_set(str, (char*)e->base.ptr);
b162af07	479	SvLEN_set(str, 0);
59035dcc JH	480	SvCUR_set(str, e->base.end - e->base.ptr);
	481	SvPOK_only(str);
	482	SvUTF8_on(str);
	483	PUSHMARK(sp);
	484	XPUSHs(e->enc);
	485	XPUSHs(str);
918951dd	486	XPUSHs(e->chk);
59035dcc	487	PUTBACK;
74f6c1ca	488	e->inEncodeCall = 1;
918951dd	489	if (call_method("encode", G_SCALAR) != 1) {
74f6c1ca SR	490	e->inEncodeCall = 0;
74f6c1ca SR	491	Perl_die(aTHX_ "panic: encode did not return a value");
59035dcc	492	}
74f6c1ca	493	e->inEncodeCall = 0;
59035dcc JH	494	SPAGAIN;
	495	str = POPs;
	496	PUTBACK;
	497	s = SvPV(str, len);
	498	count = PerlIO_unread(PerlIONext(f),s,len);
7c436af3	499	if ((STRLEN)count != len) {
59035dcc JH	500	code = -1;
	501	}
	502	FREETMPS;
	503	LEAVE;
24f59afc	504	POPSTACK;
59035dcc JH	505	}
	506	}
	507	e->base.ptr = e->base.end = e->base.buf;
	508	PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF \| PERLIO_F_WRBUF);
	509	}
	510	return code;
	511	}
	512
	513	IV
	514	PerlIOEncode_close(pTHX_ PerlIO * f)
	515	{
	516	PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
b4bd11bc NIS	517	IV code;
	518	if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
	519	/* Discard partial character */
	520	if (e->dataSV) {
	521	SvCUR_set(e->dataSV,0);
	522	}
	523	/* Don't back decode and unread any pending data */
	524	e->base.ptr = e->base.end = e->base.buf;
	525	}
	526	code = PerlIOBase_close(aTHX_ f);
59035dcc	527	if (e->bufsv) {
b4bd11bc	528	/* This should only fire for write case */
59035dcc JH	529	if (e->base.buf && e->base.ptr > e->base.buf) {
	530	Perl_croak(aTHX_ "Close with partial character");
	531	}
	532	SvREFCNT_dec(e->bufsv);
	533	e->bufsv = Nullsv;
	534	}
	535	e->base.buf = NULL;
	536	e->base.ptr = NULL;
	537	e->base.end = NULL;
	538	PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF \| PERLIO_F_WRBUF);
	539	return code;
	540	}
	541
	542	Off_t
	543	PerlIOEncode_tell(pTHX_ PerlIO * f)
	544	{
	545	PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
1c2e8cca MG	546	/* Unfortunately the only way to get a position is to (re-)translate,
1c2e8cca MG	547	the UTF8 we have in buffer and then ask layer below
59035dcc JH	548	*/
	549	PerlIO_flush(f);
	550	if (b->buf && b->ptr > b->buf) {
	551	Perl_croak(aTHX_ "Cannot tell at partial character");
	552	}
	553	return PerlIO_tell(PerlIONext(f));
	554	}
	555
	556	PerlIO *
	557	PerlIOEncode_dup(pTHX_ PerlIO * f, PerlIO * o,
	558	CLONE_PARAMS * params, int flags)
	559	{
	560	if ((f = PerlIOBase_dup(aTHX_ f, o, params, flags))) {
	561	PerlIOEncode *fe = PerlIOSelf(f, PerlIOEncode);
	562	PerlIOEncode *oe = PerlIOSelf(o, PerlIOEncode);
	563	if (oe->enc) {
	564	fe->enc = PerlIO_sv_dup(aTHX_ oe->enc, params);
	565	}
	566	}
	567	return f;
	568	}
	569
c00aecee NIS	570	SSize_t
	571	PerlIOEncode_write(pTHX_ PerlIO f, const void vbuf, Size_t count)
	572	{
	573	PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
	574	if (e->flags & NEEDS_LINES) {
	575	SSize_t done = 0;
	576	const char ptr = (const char ) vbuf;
	577	const char *end = ptr+count;
	578	while (ptr < end) {
	579	const char *nl = ptr;
	580	while (nl < end && nl++ != '\n') / empty body */;
	581	done = PerlIOBuf_write(aTHX_ f, ptr, nl-ptr);
	582	if (done != nl-ptr) {
	583	if (done > 0) {
	584	ptr += done;
	585	}
	586	break;
	587	}
	588	ptr += done;
	589	if (ptr[-1] == '\n') {
	590	if (PerlIOEncode_flush(aTHX_ f) != 0) {
	591	break;
	592	}
	593	}
	594	}
	595	return (SSize_t) (ptr - (const char *) vbuf);
	596	}
	597	else {
	598	return PerlIOBuf_write(aTHX_ f, vbuf, count);
	599	}
	600	}
	601
59035dcc	602	PerlIO_funcs PerlIO_encode = {
2dc2558e	603	sizeof(PerlIO_funcs),
59035dcc JH	604	"encoding",
	605	sizeof(PerlIOEncode),
	606	PERLIO_K_BUFFERED\|PERLIO_K_DESTRUCT,
	607	PerlIOEncode_pushed,
	608	PerlIOEncode_popped,
	609	PerlIOBuf_open,
86e05cf2	610	NULL, /* binmode - always pop */
59035dcc JH	611	PerlIOEncode_getarg,
	612	PerlIOBase_fileno,
	613	PerlIOEncode_dup,
	614	PerlIOBuf_read,
	615	PerlIOBuf_unread,
c00aecee	616	PerlIOEncode_write,
59035dcc JH	617	PerlIOBuf_seek,
	618	PerlIOEncode_tell,
	619	PerlIOEncode_close,
	620	PerlIOEncode_flush,
	621	PerlIOEncode_fill,
	622	PerlIOBase_eof,
	623	PerlIOBase_error,
	624	PerlIOBase_clearerr,
	625	PerlIOBase_setlinebuf,
	626	PerlIOEncode_get_base,
	627	PerlIOBuf_bufsiz,
	628	PerlIOBuf_get_ptr,
	629	PerlIOBuf_get_cnt,
	630	PerlIOBuf_set_ptrcnt,
	631	};
	632	#endif /* encode layer */
	633
	634	MODULE = PerlIO::encoding PACKAGE = PerlIO::encoding
	635
	636	PROTOTYPES: ENABLE
	637
	638	BOOT:
	639	{
1982da40	640	SV *chk = get_sv("PerlIO::encoding::fallback", GV_ADD\|GV_ADDMULTI);
54871a3c NIS	641	/*
	642	* we now "use Encode ()" here instead of
	643	* PerlIO/encoding.pm. This avoids SEGV when ":encoding()"
	644	* is invoked without prior "use Encode". -- dankogai
	645	*/
24f59afc	646	PUSHSTACKi(PERLSI_MAGIC);
b96d8cd9	647	if (!get_cvs(OUR_DEFAULT_FB, 0)) {
9b683d95 NIS	648	#if 0
9b683d95 NIS	649	/* This would just be an irritant now loading works */
54871a3c	650	Perl_warner(aTHX_ packWARN(WARN_IO), ":encoding without 'use Encode'");
9b683d95	651	#endif
54871a3c	652	/* The SV is magically freed by load_module */
c2b90b61	653	load_module(PERL_LOADMOD_NOIMPORT, newSVpvs("Encode"), Nullsv, Nullsv);
61bac25c	654	assert(sp == PL_stack_sp);
54871a3c NIS	655	}
	656	PUSHMARK(sp);
	657	PUTBACK;
	658	if (call_pv(OUR_DEFAULT_FB, G_SCALAR) != 1) {
	659	/* should never happen */
	660	Perl_die(aTHX_ "%s did not return a value",OUR_DEFAULT_FB);
	661	}
	662	SPAGAIN;
	663	sv_setsv(chk, POPs);
	664	PUTBACK;
dc54c799	665	#ifdef PERLIO_LAYERS
54871a3c	666	PerlIO_define_layer(aTHX_ &PerlIO_encode);
59035dcc	667	#endif
24f59afc	668	POPSTACK;
59035dcc	669	}