[p5sagit/p5-mst-13.2.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 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)
{
    PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
    dSP;
    IV  code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv);
    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 {
#ifdef USE_NEW_SEQUENCE
	PUSHMARK(sp);
	XPUSHs(result);
	PUTBACK;
	if (call_method("new_sequence",G_SCALAR|G_EVAL) != 1 || SvTRUE(ERRSV)) {
	    Perl_warner(aTHX_ packWARN(WARN_IO), "\"%" SVf "\" does not support new_sequence",
			arg);
	}
	else {
	    SPAGAIN;
	    result = POPs;
	    PUTBACK;
	}
#endif
	e->enc = newSVsv(result);
	PUSHMARK(sp);
	XPUSHs(e->enc);
	PUTBACK;
	if (call_method("needs_lines",G_SCALAR|G_EVAL) != 1 || SvTRUE(ERRSV)) {
	    Perl_warner(aTHX_ packWARN(WARN_IO), "\"%" SVf "\" does not support needs_lines",
			arg);
	}
	else {
	    SPAGAIN;
	    result = POPs;
	    PUTBACK;
	    if (SvTRUE(result)) {
		e->flags |= NEEDS_LINES;
	    }
	}
	PerlIOBase(f)->flags |= PERLIO_F_UTF8;
    }

    e->chk = newSVsv(get_sv("PerlIO::encoding::fallback", 0));

    FREETMPS;
    LEAVE;
    POPSTACK;
    return code;
}

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;
	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(e->dataSV)) {
		Safefree(SvPVX(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;
	    }
	    }
	    SvPVX(e->dataSV) = (char *) ptr;
	    SvLEN(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 */
	    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);
		SvPVX(str) = (char*)e->base.ptr;
		SvLEN(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 = {
    "encoding",
    sizeof(PerlIOEncode),
    PERLIO_K_BUFFERED|PERLIO_K_DESTRUCT,
    PerlIOEncode_pushed,
    PerlIOEncode_popped,
    PerlIOBuf_open,
    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	3	*/
918951dd	4
59035dcc	5	#define PERL_NO_GET_CONTEXT
	6	#include "EXTERN.h"
	7	#include "perl.h"
	8	#include "XSUB.h"
	9	#define U8 U8
	10
dc54c799	11	#define OUR_DEFAULT_FB "Encode::PERLQQ"
dc54c799	12
59035dcc	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
	35	(back)-translate so that the the base class's "flush" sees the
	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	51	} PerlIOEncode;
59035dcc	52
c00aecee	53	#define NEEDS_LINES 1
918951dd	54
59035dcc	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	62	/* Not 100% sure stack swap is right thing to do during dup ... */
	63	PUSHSTACKi(PERLSI_MAGIC);
	64	SPAGAIN;
59035dcc	65	ENTER;
	66	SAVETMPS;
	67	PUSHMARK(sp);
	68	XPUSHs(e->enc);
	69	PUTBACK;
918951dd	70	if (call_method("name", G_SCALAR) == 1) {
59035dcc	71	SPAGAIN;
	72	sv = newSVsv(POPs);
	73	PUTBACK;
	74	}
24f59afc	75	FREETMPS;
	76	LEAVE;
	77	POPSTACK;
59035dcc	78	}
	79	return sv;
	80	}
	81
	82	IV
	83	PerlIOEncode_pushed(pTHX_ PerlIO * f, const char mode, SV arg)
	84	{
	85	PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
	86	dSP;
c657f685	87	IV code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv);
c00aecee	88	SV *result = Nullsv;
c657f685	89
24f59afc	90	PUSHSTACKi(PERLSI_MAGIC);
	91	SPAGAIN;
	92
59035dcc	93	ENTER;
59035dcc	94	SAVETMPS;
918951dd	95
918951dd	96	PUSHMARK(sp);
59035dcc	97	XPUSHs(arg);
59035dcc	98	PUTBACK;
918951dd	99	if (call_pv("Encode::find_encoding", G_SCALAR) != 1) {
59035dcc	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	113	code = -1;
	114	}
	115	else {
c00aecee	116	#ifdef USE_NEW_SEQUENCE
	117	PUSHMARK(sp);
	118	XPUSHs(result);
	119	PUTBACK;
	120	if (call_method("new_sequence",G_SCALAR\|G_EVAL) != 1 \|\| SvTRUE(ERRSV)) {
	121	Perl_warner(aTHX_ packWARN(WARN_IO), "\"%" SVf "\" does not support new_sequence",
	122	arg);
	123	}
	124	else {
	125	SPAGAIN;
	126	result = POPs;
	127	PUTBACK;
	128	}
	129	#endif
	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	146	PerlIOBase(f)->flags \|= PERLIO_F_UTF8;
59035dcc	147	}
c00aecee	148
1982da40	149	e->chk = newSVsv(get_sv("PerlIO::encoding::fallback", 0));
54871a3c	150
59035dcc	151	FREETMPS;
59035dcc	152	LEAVE;
24f59afc	153	POPSTACK;
59035dcc	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	173	if (e->chk) {
c00aecee	174	SvREFCNT_dec(e->chk);
9b683d95	175	e->chk = Nullsv;
c00aecee	176	}
59035dcc	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	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);
24f59afc	239	SPAGAIN;
59035dcc	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;
	258	char *s;
	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	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	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	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	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	304	use = e->base.bufsiz - SvCUR(e->dataSV);
c657f685	305	}
59035dcc	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 */
	311	if (SvLEN(e->dataSV) && SvPVX(e->dataSV)) {
	312	Safefree(SvPVX(e->dataSV));
	313	}
7c436af3	314	if (use > (SSize_t)e->base.bufsiz) {
c00aecee	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	321	use = e->base.bufsiz;
c657f685	322	}
59035dcc	323	}
	324	SvPVX(e->dataSV) = (char *) ptr;
	325	SvLEN(e->dataSV) = 0; /* Hands off sv.c - it isn't yours */
	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	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	379	}
59035dcc	380	else {
c00aecee	381	end_of_file:
24f59afc	382	code = -1;
59035dcc	383	if (avail == 0)
	384	PerlIOBase(f)->flags \|= PERLIO_F_EOF;
	385	else
	386	PerlIOBase(f)->flags \|= PERLIO_F_ERROR;
59035dcc	387	}
24f59afc	388	FREETMPS;
	389	LEAVE;
	390	POPSTACK;
	391	return code;
59035dcc	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	401	dSP;
	402	SV *str;
	403	char *s;
	404	STRLEN len;
	405	SSize_t count = 0;
b4bd11bc	406	if ((PerlIOBase(f)->flags & PERLIO_F_WRBUF) && (e->base.ptr > e->base.buf)) {
b4bd11bc	407	/* Write case - encode the buffer and write() to layer below */
24f59afc	408	PUSHSTACKi(PERLSI_MAGIC);
24f59afc	409	SPAGAIN;
59035dcc	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	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	428	code = -1;
	429	}
	430	FREETMPS;
	431	LEAVE;
24f59afc	432	POPSTACK;
59035dcc	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	443	/* read case */
	444	/* if we have any untranslated stuff then unread that first */
	445	if (e->dataSV && SvCUR(e->dataSV)) {
	446	s = SvPV(e->dataSV, len);
	447	count = PerlIO_unread(PerlIONext(f),s,len);
7c436af3	448	if ((STRLEN)count != len) {
59035dcc	449	code = -1;
59035dcc	450	}
b4bd11bc	451	SvCUR_set(e->dataSV,0);
59035dcc	452	}
	453	/* See if there is anything left in the buffer */
	454	if (e->base.ptr < e->base.end) {
	455	/* Bother - have unread data.
	456	re-encode and unread() to layer below
	457	*/
24f59afc	458	PUSHSTACKi(PERLSI_MAGIC);
24f59afc	459	SPAGAIN;
59035dcc	460	ENTER;
	461	SAVETMPS;
	462	str = sv_newmortal();
	463	sv_upgrade(str, SVt_PV);
	464	SvPVX(str) = (char*)e->base.ptr;
	465	SvLEN(str) = 0;
	466	SvCUR_set(str, e->base.end - e->base.ptr);
	467	SvPOK_only(str);
	468	SvUTF8_on(str);
	469	PUSHMARK(sp);
	470	XPUSHs(e->enc);
	471	XPUSHs(str);
918951dd	472	XPUSHs(e->chk);
59035dcc	473	PUTBACK;
918951dd	474	if (call_method("encode", G_SCALAR) != 1) {
59035dcc	475	Perl_die(aTHX_ "panic: encode did not return a value");
	476	}
	477	SPAGAIN;
	478	str = POPs;
	479	PUTBACK;
	480	s = SvPV(str, len);
	481	count = PerlIO_unread(PerlIONext(f),s,len);
7c436af3	482	if ((STRLEN)count != len) {
59035dcc	483	code = -1;
	484	}
	485	FREETMPS;
	486	LEAVE;
24f59afc	487	POPSTACK;
59035dcc	488	}
	489	}
	490	e->base.ptr = e->base.end = e->base.buf;
	491	PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF \| PERLIO_F_WRBUF);
	492	}
	493	return code;
	494	}
	495
	496	IV
	497	PerlIOEncode_close(pTHX_ PerlIO * f)
	498	{
	499	PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
b4bd11bc	500	IV code;
	501	if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
	502	/* Discard partial character */
	503	if (e->dataSV) {
	504	SvCUR_set(e->dataSV,0);
	505	}
	506	/* Don't back decode and unread any pending data */
	507	e->base.ptr = e->base.end = e->base.buf;
	508	}
	509	code = PerlIOBase_close(aTHX_ f);
59035dcc	510	if (e->bufsv) {
b4bd11bc	511	/* This should only fire for write case */
59035dcc	512	if (e->base.buf && e->base.ptr > e->base.buf) {
	513	Perl_croak(aTHX_ "Close with partial character");
	514	}
	515	SvREFCNT_dec(e->bufsv);
	516	e->bufsv = Nullsv;
	517	}
	518	e->base.buf = NULL;
	519	e->base.ptr = NULL;
	520	e->base.end = NULL;
	521	PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF \| PERLIO_F_WRBUF);
	522	return code;
	523	}
	524
	525	Off_t
	526	PerlIOEncode_tell(pTHX_ PerlIO * f)
	527	{
	528	PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
	529	/* Unfortunately the only way to get a postion is to (re-)translate,
	530	the UTF8 we have in bufefr and then ask layer below
	531	*/
	532	PerlIO_flush(f);
	533	if (b->buf && b->ptr > b->buf) {
	534	Perl_croak(aTHX_ "Cannot tell at partial character");
	535	}
	536	return PerlIO_tell(PerlIONext(f));
	537	}
	538
	539	PerlIO *
	540	PerlIOEncode_dup(pTHX_ PerlIO * f, PerlIO * o,
	541	CLONE_PARAMS * params, int flags)
	542	{
	543	if ((f = PerlIOBase_dup(aTHX_ f, o, params, flags))) {
	544	PerlIOEncode *fe = PerlIOSelf(f, PerlIOEncode);
	545	PerlIOEncode *oe = PerlIOSelf(o, PerlIOEncode);
	546	if (oe->enc) {
	547	fe->enc = PerlIO_sv_dup(aTHX_ oe->enc, params);
	548	}
	549	}
	550	return f;
	551	}
	552
c00aecee	553	SSize_t
	554	PerlIOEncode_write(pTHX_ PerlIO f, const void vbuf, Size_t count)
	555	{
	556	PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
	557	if (e->flags & NEEDS_LINES) {
	558	SSize_t done = 0;
	559	const char ptr = (const char ) vbuf;
	560	const char *end = ptr+count;
	561	while (ptr < end) {
	562	const char *nl = ptr;
	563	while (nl < end && nl++ != '\n') / empty body */;
	564	done = PerlIOBuf_write(aTHX_ f, ptr, nl-ptr);
	565	if (done != nl-ptr) {
	566	if (done > 0) {
	567	ptr += done;
	568	}
	569	break;
	570	}
	571	ptr += done;
	572	if (ptr[-1] == '\n') {
	573	if (PerlIOEncode_flush(aTHX_ f) != 0) {
	574	break;
	575	}
	576	}
	577	}
	578	return (SSize_t) (ptr - (const char *) vbuf);
	579	}
	580	else {
	581	return PerlIOBuf_write(aTHX_ f, vbuf, count);
	582	}
	583	}
	584
59035dcc	585	PerlIO_funcs PerlIO_encode = {
	586	"encoding",
	587	sizeof(PerlIOEncode),
	588	PERLIO_K_BUFFERED\|PERLIO_K_DESTRUCT,
	589	PerlIOEncode_pushed,
	590	PerlIOEncode_popped,
	591	PerlIOBuf_open,
	592	PerlIOEncode_getarg,
	593	PerlIOBase_fileno,
	594	PerlIOEncode_dup,
	595	PerlIOBuf_read,
	596	PerlIOBuf_unread,
c00aecee	597	PerlIOEncode_write,
59035dcc	598	PerlIOBuf_seek,
	599	PerlIOEncode_tell,
	600	PerlIOEncode_close,
	601	PerlIOEncode_flush,
	602	PerlIOEncode_fill,
	603	PerlIOBase_eof,
	604	PerlIOBase_error,
	605	PerlIOBase_clearerr,
	606	PerlIOBase_setlinebuf,
	607	PerlIOEncode_get_base,
	608	PerlIOBuf_bufsiz,
	609	PerlIOBuf_get_ptr,
	610	PerlIOBuf_get_cnt,
	611	PerlIOBuf_set_ptrcnt,
	612	};
	613	#endif /* encode layer */
	614
	615	MODULE = PerlIO::encoding PACKAGE = PerlIO::encoding
	616
	617	PROTOTYPES: ENABLE
	618
	619	BOOT:
	620	{
1982da40	621	SV *chk = get_sv("PerlIO::encoding::fallback", GV_ADD\|GV_ADDMULTI);
54871a3c	622	/*
	623	* we now "use Encode ()" here instead of
	624	* PerlIO/encoding.pm. This avoids SEGV when ":encoding()"
	625	* is invoked without prior "use Encode". -- dankogai
	626	*/
24f59afc	627	PUSHSTACKi(PERLSI_MAGIC);
24f59afc	628	SPAGAIN;
dc54c799	629	if (!get_cv(OUR_DEFAULT_FB, 0)) {
9b683d95	630	#if 0
9b683d95	631	/* This would just be an irritant now loading works */
54871a3c	632	Perl_warner(aTHX_ packWARN(WARN_IO), ":encoding without 'use Encode'");
9b683d95	633	#endif
54871a3c	634	ENTER;
9b683d95	635	/* Encode needs a lot of stack - it is likely to move ... */
9b683d95	636	PUTBACK;
54871a3c	637	/* The SV is magically freed by load_module */
54871a3c	638	load_module(PERL_LOADMOD_NOIMPORT, newSVpvn("Encode", 6), Nullsv, Nullsv);
9b683d95	639	SPAGAIN;
54871a3c	640	LEAVE;
	641	}
	642	PUSHMARK(sp);
	643	PUTBACK;
	644	if (call_pv(OUR_DEFAULT_FB, G_SCALAR) != 1) {
	645	/* should never happen */
	646	Perl_die(aTHX_ "%s did not return a value",OUR_DEFAULT_FB);
	647	}
	648	SPAGAIN;
	649	sv_setsv(chk, POPs);
	650	PUTBACK;
dc54c799	651	#ifdef PERLIO_LAYERS
54871a3c	652	PerlIO_define_layer(aTHX_ &PerlIO_encode);
59035dcc	653	#endif
24f59afc	654	POPSTACK;
59035dcc	655	}