[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);
	SvPVCLEAR(e->bufsv);
    }
    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))
	    SvPVCLEAR(e->dataSV);
	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);
	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);
68fbdc7c	206	SvPVCLEAR(e->bufsv);
59035dcc JH	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	}
fed9fe5b Z	310	if (!SvCUR(e->dataSV))
	311	SvPVCLEAR(e->dataSV);
	312	if (use + SvCUR(e->dataSV) > e->base.bufsiz) {
	313	if (e->flags & NEEDS_LINES) {
	314	/* Have to grow buffer */
	315	e->base.bufsiz = use + SvCUR(e->dataSV);
	316	PerlIOEncode_get_base(aTHX_ f);
c657f685	317	}
fed9fe5b Z	318	else {
fed9fe5b Z	319	use = e->base.bufsiz - SvCUR(e->dataSV);
59035dcc	320	}
59035dcc	321	}
fed9fe5b	322	sv_catpvn(e->dataSV,(char*)ptr,use);
59035dcc JH	323	SvUTF8_off(e->dataSV);
	324	PUSHMARK(sp);
	325	XPUSHs(e->enc);
	326	XPUSHs(e->dataSV);
918951dd	327	XPUSHs(e->chk);
59035dcc	328	PUTBACK;
918951dd	329	if (call_method("decode", G_SCALAR) != 1) {
59035dcc JH	330	Perl_die(aTHX_ "panic: decode did not return a value");
	331	}
	332	SPAGAIN;
	333	uni = POPs;
	334	PUTBACK;
8f79eb5b FC	335	/* No cows allowed. */
8f79eb5b FC	336	if (SvTHINKFIRST(e->dataSV)) SvPV_force_nolen(e->dataSV);
59035dcc JH	337	/* Now get translated string (forced to UTF-8) and use as buffer */
	338	if (SvPOK(uni)) {
	339	s = SvPVutf8(uni, len);
	340	#ifdef PARANOID_ENCODE_CHECKS
	341	if (len && !is_utf8_string((U8*)s,len)) {
	342	Perl_warn(aTHX_ "panic: decode did not return UTF-8 '%.*s'",(int) len,s);
	343	}
	344	#endif
	345	}
	346	if (len > 0) {
	347	/* Got _something */
	348	/* if decode gave us back dataSV then data may vanish when
	349	we do ptrcnt adjust - so take our copy now.
	350	(The copy is a pain - need a put-it-here option for decode.)
	351	*/
	352	sv_setpvn(e->bufsv,s,len);
	353	e->base.ptr = e->base.buf = (STDCHAR*)SvPVX(e->bufsv);
	354	e->base.end = e->base.ptr + SvCUR(e->bufsv);
	355	PerlIOBase(f)->flags \|= PERLIO_F_RDBUF;
	356	SvUTF8_on(e->bufsv);
	357
	358	/* Adjust ptr/cnt not taking anything which
	359	did not translate - not clear this is a win */
	360	/* compute amount we took */
667763bd	361	if (!SvPOKp(e->dataSV)) (void)SvPV_force_nolen(e->dataSV);
59035dcc JH	362	use -= SvCUR(e->dataSV);
59035dcc JH	363	PerlIO_set_ptrcnt(n, ptr+use, (avail-use));
06cc5386	364	/* and as we did not take it, it isn't pending */
59035dcc JH	365	SvCUR_set(e->dataSV,0);
	366	} else {
	367	/* Got nothing - assume partial character so we need some more */
	368	/* Make sure e->dataSV is a normal SV before re-filling as
	369	buffer alias will change under us
	370	*/
	371	s = SvPV(e->dataSV,len);
	372	sv_setpvn(e->dataSV,s,len);
	373	PerlIO_set_ptrcnt(n, ptr+use, (avail-use));
	374	goto retry;
	375	}
59035dcc JH	376	}
59035dcc JH	377	else {
c00aecee	378	end_of_file:
24f59afc	379	code = -1;
59035dcc JH	380	if (avail == 0)
	381	PerlIOBase(f)->flags \|= PERLIO_F_EOF;
	382	else
0ea86a10	383	{
59035dcc	384	PerlIOBase(f)->flags \|= PERLIO_F_ERROR;
0ea86a10 FC	385	Perl_PerlIO_save_errno(aTHX_ f);
0ea86a10 FC	386	}
59035dcc	387	}
24f59afc NIS	388	FREETMPS;
	389	LEAVE;
	390	POPSTACK;
	391	return code;
59035dcc JH	392	}
59035dcc JH	393
0b057af7	394	static IV
59035dcc JH	395	PerlIOEncode_flush(pTHX_ PerlIO * f)
	396	{
	397	PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
	398	IV code = 0;
c657f685	399
b4bd11bc	400	if (e->bufsv) {
59035dcc JH	401	dSP;
	402	SV *str;
	403	char *s;
	404	STRLEN len;
	405	SSize_t count = 0;
b4bd11bc	406	if ((PerlIOBase(f)->flags & PERLIO_F_WRBUF) && (e->base.ptr > e->base.buf)) {
74f6c1ca	407	if (e->inEncodeCall) return 0;
b4bd11bc	408	/* Write case - encode the buffer and write() to layer below */
24f59afc	409	PUSHSTACKi(PERLSI_MAGIC);
59035dcc JH	410	ENTER;
	411	SAVETMPS;
	412	PUSHMARK(sp);
	413	XPUSHs(e->enc);
	414	SvCUR_set(e->bufsv, e->base.ptr - e->base.buf);
	415	SvUTF8_on(e->bufsv);
	416	XPUSHs(e->bufsv);
918951dd	417	XPUSHs(e->chk);
59035dcc	418	PUTBACK;
74f6c1ca	419	e->inEncodeCall = 1;
918951dd	420	if (call_method("encode", G_SCALAR) != 1) {
74f6c1ca	421	e->inEncodeCall = 0;
59035dcc JH	422	Perl_die(aTHX_ "panic: encode did not return a value");
59035dcc JH	423	}
74f6c1ca	424	e->inEncodeCall = 0;
59035dcc JH	425	SPAGAIN;
	426	str = POPs;
	427	PUTBACK;
	428	s = SvPV(str, len);
	429	count = PerlIO_write(PerlIONext(f),s,len);
7c436af3	430	if ((STRLEN)count != len) {
59035dcc JH	431	code = -1;
	432	}
	433	FREETMPS;
	434	LEAVE;
24f59afc	435	POPSTACK;
59035dcc JH	436	if (PerlIO_flush(PerlIONext(f)) != 0) {
	437	code = -1;
	438	}
667763bd FC	439	if (!SvPOKp(e->bufsv) \|\| SvTHINKFIRST(e->bufsv))
667763bd FC	440	(void)SvPV_force_nolen(e->bufsv);
e9a8753a	441	if ((STDCHAR *)SvPVX(e->bufsv) != e->base.buf) {
0bca550c LM	442	e->base.ptr = (STDCHAR *)SvEND(e->bufsv);
0bca550c LM	443	e->base.end = (STDCHAR *)SvPVX(e->bufsv) + (e->base.end-e->base.buf);
667763bd	444	e->base.buf = (STDCHAR *)SvPVX(e->bufsv);
e9a8753a FC	445	}
e9a8753a FC	446	(void)PerlIOEncode_get_base(aTHX_ f);
59035dcc JH	447	if (SvCUR(e->bufsv)) {
	448	/* Did not all translate */
	449	e->base.ptr = e->base.buf+SvCUR(e->bufsv);
	450	return code;
	451	}
	452	}
b4bd11bc	453	else if ((PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
59035dcc JH	454	/* read case */
59035dcc JH	455	/* if we have any untranslated stuff then unread that first */
8849edfd	456	/* FIXME - unread is fragile is there a better way ? */
59035dcc JH	457	if (e->dataSV && SvCUR(e->dataSV)) {
	458	s = SvPV(e->dataSV, len);
	459	count = PerlIO_unread(PerlIONext(f),s,len);
7c436af3	460	if ((STRLEN)count != len) {
59035dcc JH	461	code = -1;
59035dcc JH	462	}
b4bd11bc	463	SvCUR_set(e->dataSV,0);
59035dcc JH	464	}
	465	/* See if there is anything left in the buffer */
	466	if (e->base.ptr < e->base.end) {
74f6c1ca	467	if (e->inEncodeCall) return 0;
59035dcc JH	468	/* Bother - have unread data.
	469	re-encode and unread() to layer below
	470	*/
24f59afc	471	PUSHSTACKi(PERLSI_MAGIC);
59035dcc JH	472	ENTER;
	473	SAVETMPS;
	474	str = sv_newmortal();
	475	sv_upgrade(str, SVt_PV);
f880fe2f	476	SvPV_set(str, (char*)e->base.ptr);
b162af07	477	SvLEN_set(str, 0);
59035dcc JH	478	SvCUR_set(str, e->base.end - e->base.ptr);
	479	SvPOK_only(str);
	480	SvUTF8_on(str);
	481	PUSHMARK(sp);
	482	XPUSHs(e->enc);
	483	XPUSHs(str);
918951dd	484	XPUSHs(e->chk);
59035dcc	485	PUTBACK;
74f6c1ca	486	e->inEncodeCall = 1;
918951dd	487	if (call_method("encode", G_SCALAR) != 1) {
74f6c1ca SR	488	e->inEncodeCall = 0;
74f6c1ca SR	489	Perl_die(aTHX_ "panic: encode did not return a value");
59035dcc	490	}
74f6c1ca	491	e->inEncodeCall = 0;
59035dcc JH	492	SPAGAIN;
	493	str = POPs;
	494	PUTBACK;
	495	s = SvPV(str, len);
	496	count = PerlIO_unread(PerlIONext(f),s,len);
7c436af3	497	if ((STRLEN)count != len) {
59035dcc JH	498	code = -1;
	499	}
	500	FREETMPS;
	501	LEAVE;
24f59afc	502	POPSTACK;
59035dcc JH	503	}
	504	}
	505	e->base.ptr = e->base.end = e->base.buf;
	506	PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF \| PERLIO_F_WRBUF);
	507	}
	508	return code;
	509	}
	510
0b057af7	511	static IV
59035dcc JH	512	PerlIOEncode_close(pTHX_ PerlIO * f)
	513	{
	514	PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
b4bd11bc NIS	515	IV code;
	516	if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
	517	/* Discard partial character */
	518	if (e->dataSV) {
	519	SvCUR_set(e->dataSV,0);
	520	}
	521	/* Don't back decode and unread any pending data */
	522	e->base.ptr = e->base.end = e->base.buf;
	523	}
	524	code = PerlIOBase_close(aTHX_ f);
59035dcc	525	if (e->bufsv) {
b4bd11bc	526	/* This should only fire for write case */
59035dcc JH	527	if (e->base.buf && e->base.ptr > e->base.buf) {
	528	Perl_croak(aTHX_ "Close with partial character");
	529	}
	530	SvREFCNT_dec(e->bufsv);
	531	e->bufsv = Nullsv;
	532	}
	533	e->base.buf = NULL;
	534	e->base.ptr = NULL;
	535	e->base.end = NULL;
	536	PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF \| PERLIO_F_WRBUF);
	537	return code;
	538	}
	539
0b057af7	540	static Off_t
59035dcc JH	541	PerlIOEncode_tell(pTHX_ PerlIO * f)
	542	{
	543	PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
1c2e8cca MG	544	/* Unfortunately the only way to get a position is to (re-)translate,
1c2e8cca MG	545	the UTF8 we have in buffer and then ask layer below
59035dcc JH	546	*/
	547	PerlIO_flush(f);
	548	if (b->buf && b->ptr > b->buf) {
	549	Perl_croak(aTHX_ "Cannot tell at partial character");
	550	}
	551	return PerlIO_tell(PerlIONext(f));
	552	}
	553
0b057af7	554	static PerlIO *
59035dcc JH	555	PerlIOEncode_dup(pTHX_ PerlIO * f, PerlIO * o,
	556	CLONE_PARAMS * params, int flags)
	557	{
	558	if ((f = PerlIOBase_dup(aTHX_ f, o, params, flags))) {
	559	PerlIOEncode *fe = PerlIOSelf(f, PerlIOEncode);
	560	PerlIOEncode *oe = PerlIOSelf(o, PerlIOEncode);
	561	if (oe->enc) {
	562	fe->enc = PerlIO_sv_dup(aTHX_ oe->enc, params);
	563	}
0ee3fa26 VP	564	if (oe->chk) {
	565	fe->chk = PerlIO_sv_dup(aTHX_ oe->chk, params);
	566	}
59035dcc JH	567	}
	568	return f;
	569	}
	570
0b057af7	571	static SSize_t
c00aecee NIS	572	PerlIOEncode_write(pTHX_ PerlIO f, const void vbuf, Size_t count)
	573	{
	574	PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
	575	if (e->flags & NEEDS_LINES) {
	576	SSize_t done = 0;
	577	const char ptr = (const char ) vbuf;
	578	const char *end = ptr+count;
	579	while (ptr < end) {
	580	const char *nl = ptr;
	581	while (nl < end && nl++ != '\n') / empty body */;
	582	done = PerlIOBuf_write(aTHX_ f, ptr, nl-ptr);
	583	if (done != nl-ptr) {
	584	if (done > 0) {
	585	ptr += done;
	586	}
	587	break;
	588	}
	589	ptr += done;
	590	if (ptr[-1] == '\n') {
	591	if (PerlIOEncode_flush(aTHX_ f) != 0) {
	592	break;
	593	}
	594	}
	595	}
	596	return (SSize_t) (ptr - (const char *) vbuf);
	597	}
	598	else {
	599	return PerlIOBuf_write(aTHX_ f, vbuf, count);
	600	}
	601	}
	602
0b057af7	603	static PERLIO_FUNCS_DECL(PerlIO_encode) = {
2dc2558e	604	sizeof(PerlIO_funcs),
59035dcc JH	605	"encoding",
	606	sizeof(PerlIOEncode),
	607	PERLIO_K_BUFFERED\|PERLIO_K_DESTRUCT,
	608	PerlIOEncode_pushed,
	609	PerlIOEncode_popped,
	610	PerlIOBuf_open,
86e05cf2	611	NULL, /* binmode - always pop */
59035dcc JH	612	PerlIOEncode_getarg,
	613	PerlIOBase_fileno,
	614	PerlIOEncode_dup,
	615	PerlIOBuf_read,
	616	PerlIOBuf_unread,
c00aecee	617	PerlIOEncode_write,
59035dcc JH	618	PerlIOBuf_seek,
	619	PerlIOEncode_tell,
	620	PerlIOEncode_close,
	621	PerlIOEncode_flush,
	622	PerlIOEncode_fill,
	623	PerlIOBase_eof,
	624	PerlIOBase_error,
	625	PerlIOBase_clearerr,
	626	PerlIOBase_setlinebuf,
	627	PerlIOEncode_get_base,
	628	PerlIOBuf_bufsiz,
	629	PerlIOBuf_get_ptr,
	630	PerlIOBuf_get_cnt,
	631	PerlIOBuf_set_ptrcnt,
	632	};
	633	#endif /* encode layer */
	634
	635	MODULE = PerlIO::encoding PACKAGE = PerlIO::encoding
	636
	637	PROTOTYPES: ENABLE
	638
	639	BOOT:
	640	{
1982da40	641	SV *chk = get_sv("PerlIO::encoding::fallback", GV_ADD\|GV_ADDMULTI);
54871a3c NIS	642	/*
	643	* we now "use Encode ()" here instead of
	644	* PerlIO/encoding.pm. This avoids SEGV when ":encoding()"
	645	* is invoked without prior "use Encode". -- dankogai
	646	*/
24f59afc	647	PUSHSTACKi(PERLSI_MAGIC);
b96d8cd9	648	if (!get_cvs(OUR_DEFAULT_FB, 0)) {
9b683d95 NIS	649	#if 0
9b683d95 NIS	650	/* This would just be an irritant now loading works */
54871a3c	651	Perl_warner(aTHX_ packWARN(WARN_IO), ":encoding without 'use Encode'");
9b683d95	652	#endif
54871a3c	653	/* The SV is magically freed by load_module */
c2b90b61	654	load_module(PERL_LOADMOD_NOIMPORT, newSVpvs("Encode"), Nullsv, Nullsv);
61bac25c	655	assert(sp == PL_stack_sp);
54871a3c NIS	656	}
	657	PUSHMARK(sp);
	658	PUTBACK;
	659	if (call_pv(OUR_DEFAULT_FB, G_SCALAR) != 1) {
	660	/* should never happen */
	661	Perl_die(aTHX_ "%s did not return a value",OUR_DEFAULT_FB);
	662	}
	663	SPAGAIN;
	664	sv_setsv(chk, POPs);
	665	PUTBACK;
dc54c799	666	#ifdef PERLIO_LAYERS
8f6555bf	667	PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_encode));
59035dcc	668	#endif
24f59afc	669	POPSTACK;
59035dcc	670	}