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