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

#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#define U8 U8

#define OUR_DEFAULT_FB	"Encode::PERLQQ"

#if defined(USE_PERLIO)

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

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

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

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

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

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

*/

#include "perliol.h"

typedef struct {
    PerlIOBuf base;		/* PerlIOBuf stuff */
    SV *bufsv;			/* buffer seen by layers above */
    SV *dataSV;			/* data we have read from layer below */
    SV *enc;			/* the encoding object */
    SV *chk;                    /* CHECK in Encode methods */
    int flags;			/* Flags currently just needs lines */
    int inEncodeCall;		/* trap recursive encode calls */
} PerlIOEncode;

#define NEEDS_LINES	1

static const MGVTBL PerlIOEncode_tag = { 0, 0, 0, 0, 0, 0, 0, 0 };

static SV *
PerlIOEncode_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
{
    PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
    SV *sv;
    PERL_UNUSED_ARG(flags);
    /* During cloning, return an undef token object so that _pushed() knows
     * that it should not call methods and wait for _dup() to actually dup the
     * encoding object. */
    if (param) {
	sv = newSV(0);
	sv_magicext(sv, NULL, PERL_MAGIC_ext, &PerlIOEncode_tag, 0, 0);
	return sv;
    }
    sv = &PL_sv_undef;
    if (e->enc) {
	dSP;
	/* Not 100% sure stack swap is right thing to do during dup ... */
	PUSHSTACKi(PERLSI_MAGIC);
	ENTER;
	SAVETMPS;
	PUSHMARK(sp);
	XPUSHs(e->enc);
	PUTBACK;
	if (call_method("name", G_SCALAR) == 1) {
	    SPAGAIN;
	    sv = newSVsv(POPs);
	    PUTBACK;
	}
	FREETMPS;
	LEAVE;
	POPSTACK;
    }
    return sv;
}

static 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;

    if (SvTYPE(arg) >= SVt_PVMG
		&& mg_findext(arg, PERL_MAGIC_ext, &PerlIOEncode_tag)) {
	e->enc = NULL;
	e->chk = NULL;
	e->inEncodeCall = 0;
	return code;
    }

    PUSHSTACKi(PERLSI_MAGIC);
    ENTER;
    SAVETMPS;

    PUSHMARK(sp);
    XPUSHs(arg);
    PUTBACK;
    if (call_pv("Encode::find_encoding", G_SCALAR) != 1) {
	/* should never happen */
	Perl_die(aTHX_ "Encode::find_encoding did not return a value");
	return -1;
    }
    SPAGAIN;
    result = POPs;
    PUTBACK;

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

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

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

    FREETMPS;
    LEAVE;
    POPSTACK;
    return code;
}

static 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;
}

static 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;
}

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

    if (PerlIO_flush(f) != 0)
	return -1;
    n  = PerlIONext(f);
    if (!PerlIO_fast_gets(n)) {
	/* Things get too messy if we don't have a buffer layer
	   push a :perlio to do the job */
	char mode[8];
	n  = PerlIO_push(aTHX_ n, &PerlIO_perlio, PerlIO_modestr(f,mode), Nullsv);
	if (!n) {
	    Perl_die(aTHX_ "panic: cannot push :perlio for %p",f);
	}
    }
    PUSHSTACKi(PERLSI_MAGIC);
    ENTER;
    SAVETMPS;
  retry:
    avail = PerlIO_get_cnt(n);
    if (avail <= 0) {
	avail = PerlIO_fill(n);
	if (avail == 0) {
	    avail = PerlIO_get_cnt(n);
	}
	else {
	    if (!PerlIO_error(n) && PerlIO_eof(n))
		avail = 0;
	}
    }
    if (avail > 0 || (e->flags & NEEDS_LINES)) {
	STDCHAR *ptr = PerlIO_get_ptr(n);
	SSize_t use  = (avail >= 0) ? avail : 0;
	SV *uni;
	char *s = NULL;
	STRLEN len = 0;
	e->base.ptr = e->base.end = (STDCHAR *) NULL;
	(void) PerlIOEncode_get_base(aTHX_ f);
	if (!e->dataSV)
	    e->dataSV = newSV(0);
	if (SvTYPE(e->dataSV) < SVt_PV) {
	    sv_upgrade(e->dataSV,SVt_PV);
	}
	if (e->flags & NEEDS_LINES) {
	    /* Encoding needs whole lines (e.g. iso-2022-*)
	       search back from end of available data for
	       and line marker
	     */
	    STDCHAR *nl = ptr+use-1;
	    while (nl >= ptr) {
		if (*nl == '\n') {
		    break;
		}
		nl--;
	    }
	    if (nl >= ptr && *nl == '\n') {
		/* found a line - take up to and including that */
		use = (nl+1)-ptr;
	    }
	    else if (avail > 0) {
		/* No line, but not EOF - append avail to the pending data */
		sv_catpvn(e->dataSV, (char*)ptr, use);
		PerlIO_set_ptrcnt(n, ptr+use, 0);
		goto retry;
	    }
	    else if (!SvCUR(e->dataSV)) {
		goto end_of_file;
	    }
	}
	if (SvCUR(e->dataSV)) {
	    /* something left over from last time - create a normal
	       SV with new data appended
	     */
	    if (use + SvCUR(e->dataSV) > e->base.bufsiz) {
		if (e->flags & NEEDS_LINES) {
		    /* Have to grow buffer */
		    e->base.bufsiz = use + SvCUR(e->dataSV);
		    PerlIOEncode_get_base(aTHX_ f);
		}
		else {
	       use = e->base.bufsiz - SvCUR(e->dataSV);
	    }
	    }
	    sv_catpvn(e->dataSV,(char*)ptr,use);
	}
	else {
	    /* Create a "dummy" SV to represent the available data from layer below */
	    if (SvLEN(e->dataSV) && SvPVX_const(e->dataSV)) {
		Safefree(SvPVX_mutable(e->dataSV));
	    }
	    if (use > (SSize_t)e->base.bufsiz) {
		if (e->flags & NEEDS_LINES) {
		    /* Have to grow buffer */
		    e->base.bufsiz = use;
		    PerlIOEncode_get_base(aTHX_ f);
		}
		else {
	       use = e->base.bufsiz;
	    }
	    }
	    SvPV_set(e->dataSV, (char *) ptr);
	    SvLEN_set(e->dataSV, 0);  /* Hands off sv.c - it isn't yours */
	    SvCUR_set(e->dataSV,use);
	    SvPOK_only(e->dataSV);
	}
	SvUTF8_off(e->dataSV);
	PUSHMARK(sp);
	XPUSHs(e->enc);
	XPUSHs(e->dataSV);
	XPUSHs(e->chk);
	PUTBACK;
	if (call_method("decode", G_SCALAR) != 1) {
	    Perl_die(aTHX_ "panic: decode did not return a value");
	}
	SPAGAIN;
	uni = POPs;
	PUTBACK;
	/* No cows allowed. */
	if (SvTHINKFIRST(e->dataSV)) SvPV_force_nolen(e->dataSV);
	/* Now get translated string (forced to UTF-8) and use as buffer */
	if (SvPOK(uni)) {
	    s = SvPVutf8(uni, len);
#ifdef PARANOID_ENCODE_CHECKS
	    if (len && !is_utf8_string((U8*)s,len)) {
		Perl_warn(aTHX_ "panic: decode did not return UTF-8 '%.*s'",(int) len,s);
	    }
#endif
	}
	if (len > 0) {
	    /* Got _something */
	    /* if decode gave us back dataSV then data may vanish when
	       we do ptrcnt adjust - so take our copy now.
	       (The copy is a pain - need a put-it-here option for decode.)
	     */
	    sv_setpvn(e->bufsv,s,len);
	    e->base.ptr = e->base.buf = (STDCHAR*)SvPVX(e->bufsv);
	    e->base.end = e->base.ptr + SvCUR(e->bufsv);
	    PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
	    SvUTF8_on(e->bufsv);

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

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

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

static 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;
}

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

static 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);
	}
	if (oe->chk) {
	    fe->chk = PerlIO_sv_dup(aTHX_ oe->chk, params);
	}
    }
    return f;
}

static 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);
    }
}

static PERLIO_FUNCS_DECL(PerlIO_encode) = {
    sizeof(PerlIO_funcs),
    "encoding",
    sizeof(PerlIOEncode),
    PERLIO_K_BUFFERED|PERLIO_K_DESTRUCT,
    PerlIOEncode_pushed,
    PerlIOEncode_popped,
    PerlIOBuf_open,
    NULL, /* binmode - always pop */
    PerlIOEncode_getarg,
    PerlIOBase_fileno,
    PerlIOEncode_dup,
    PerlIOBuf_read,
    PerlIOBuf_unread,
    PerlIOEncode_write,
    PerlIOBuf_seek,
    PerlIOEncode_tell,
    PerlIOEncode_close,
    PerlIOEncode_flush,
    PerlIOEncode_fill,
    PerlIOBase_eof,
    PerlIOBase_error,
    PerlIOBase_clearerr,
    PerlIOBase_setlinebuf,
    PerlIOEncode_get_base,
    PerlIOBuf_bufsiz,
    PerlIOBuf_get_ptr,
    PerlIOBuf_get_cnt,
    PerlIOBuf_set_ptrcnt,
};
#endif				/* encode layer */

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

PROTOTYPES: ENABLE

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