[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) && !defined(USE_SFIO)

/* 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);
	SPAGAIN;
	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);
    SPAGAIN;

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