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

/*
 * $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.

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

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