[p5sagit/p5-mst-13.2.git] / ext / PerlIO / encoding / encoding.xs

/*
 * $Id: encoding.xs,v 0.3 2002/04/21 22:14:41 dankogai Exp $
 */

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

#define OUR_DEFAULT_FB	"Encode::PERLQQ"

#if defined(USE_PERLIO) && !defined(USE_SFIO)

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

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

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

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

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

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

*/

#include "perliol.h"

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

#define NEEDS_LINES	1

SV *
PerlIOEncode_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
{
    PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
    SV *sv = &PL_sv_undef;
    if (e->enc) {
	dSP;
	/* Not 100% sure stack swap is right thing to do during dup ... */
	PUSHSTACKi(PERLSI_MAGIC);
	SPAGAIN;
	ENTER;
	SAVETMPS;
	PUSHMARK(sp);
	XPUSHs(e->enc);
	PUTBACK;
	if (call_method("name", G_SCALAR) == 1) {
	    SPAGAIN;
	    sv = newSVsv(POPs);
	    PUTBACK;
	}
	FREETMPS;
	LEAVE;
	POPSTACK;
    }
    return sv;
}

IV
PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg)
{
    PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
    dSP;
    IV  code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv);
    SV *result = Nullsv;

    PUSHSTACKi(PERLSI_MAGIC);
    SPAGAIN;

    ENTER;
    SAVETMPS;

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

    if (!SvROK(result) || !SvOBJECT(SvRV(result))) {
	e->enc = Nullsv;
	Perl_warner(aTHX_ packWARN(WARN_IO), "Cannot find encoding \"%" SVf "\"",
		    arg);
	errno = EINVAL;
	code = -1;
    }
    else {
#ifdef USE_NEW_SEQUENCE
	PUSHMARK(sp);
	XPUSHs(result);
	PUTBACK;
	if (call_method("new_sequence",G_SCALAR|G_EVAL) != 1 || SvTRUE(ERRSV)) {
	    Perl_warner(aTHX_ packWARN(WARN_IO), "\"%" SVf "\" does not support new_sequence",
			arg);
	}
	else {
	    SPAGAIN;
	    result = POPs;
	    PUTBACK;
	}
#endif
	e->enc = newSVsv(result);
	PUSHMARK(sp);
	XPUSHs(e->enc);
	PUTBACK;
	if (call_method("needs_lines",G_SCALAR|G_EVAL) != 1 || SvTRUE(ERRSV)) {
	    Perl_warner(aTHX_ packWARN(WARN_IO), "\"%" SVf "\" does not support needs_lines",
			arg);
	}
	else {
	    SPAGAIN;
	    result = POPs;
	    PUTBACK;
	    if (SvTRUE(result)) {
		e->flags |= NEEDS_LINES;
	    }
	}
	PerlIOBase(f)->flags |= PERLIO_F_UTF8;
    }

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

    FREETMPS;
    LEAVE;
    POPSTACK;
    return code;
}

IV
PerlIOEncode_popped(pTHX_ PerlIO * f)
{
    PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
    if (e->enc) {
	SvREFCNT_dec(e->enc);
	e->enc = Nullsv;
    }
    if (e->bufsv) {
	SvREFCNT_dec(e->bufsv);
	e->bufsv = Nullsv;
    }
    if (e->dataSV) {
	SvREFCNT_dec(e->dataSV);
	e->dataSV = Nullsv;
    }
    if (e->chk) {
	SvREFCNT_dec(e->chk);
	e->chk = Nullsv;
    }
    return 0;
}

STDCHAR *
PerlIOEncode_get_base(pTHX_ PerlIO * f)
{
    PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
    if (!e->base.bufsiz)
	e->base.bufsiz = 1024;
    if (!e->bufsv) {
	e->bufsv = newSV(e->base.bufsiz);
	sv_setpvn(e->bufsv, "", 0);
    }
    e->base.buf = (STDCHAR *) SvPVX(e->bufsv);
    if (!e->base.ptr)
	e->base.ptr = e->base.buf;
    if (!e->base.end)
	e->base.end = e->base.buf;
    if (e->base.ptr < e->base.buf
	|| e->base.ptr > e->base.buf + SvLEN(e->bufsv)) {
	Perl_warn(aTHX_ " ptr %p(%p)%p", e->base.buf, e->base.ptr,
		  e->base.buf + SvLEN(e->bufsv));
	abort();
    }
    if (SvLEN(e->bufsv) < e->base.bufsiz) {
	SSize_t poff = e->base.ptr - e->base.buf;
	SSize_t eoff = e->base.end - e->base.buf;
	e->base.buf = (STDCHAR *) SvGROW(e->bufsv, e->base.bufsiz);
	e->base.ptr = e->base.buf + poff;
	e->base.end = e->base.buf + eoff;
    }
    if (e->base.ptr < e->base.buf
	|| e->base.ptr > e->base.buf + SvLEN(e->bufsv)) {
	Perl_warn(aTHX_ " ptr %p(%p)%p", e->base.buf, e->base.ptr,
		  e->base.buf + SvLEN(e->bufsv));
	abort();
    }
    return e->base.buf;
}

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

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

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

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

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

IV
PerlIOEncode_close(pTHX_ PerlIO * f)
{
    PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
    IV code = PerlIOBase_close(aTHX_ f);

    if (e->bufsv) {
	if (e->base.buf && e->base.ptr > e->base.buf) {
	    Perl_croak(aTHX_ "Close with partial character");
	}
	SvREFCNT_dec(e->bufsv);
	e->bufsv = Nullsv;
    }
    e->base.buf = NULL;
    e->base.ptr = NULL;
    e->base.end = NULL;
    PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
    return code;
}

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

PerlIO *
PerlIOEncode_dup(pTHX_ PerlIO * f, PerlIO * o,
		 CLONE_PARAMS * params, int flags)
{
    if ((f = PerlIOBase_dup(aTHX_ f, o, params, flags))) {
	PerlIOEncode *fe = PerlIOSelf(f, PerlIOEncode);
	PerlIOEncode *oe = PerlIOSelf(o, PerlIOEncode);
	if (oe->enc) {
	    fe->enc = PerlIO_sv_dup(aTHX_ oe->enc, params);
	}
    }
    return f;
}

SSize_t
PerlIOEncode_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
{
    PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
    if (e->flags & NEEDS_LINES) {
	SSize_t done = 0;
	const char *ptr = (const char *) vbuf;
	const char *end = ptr+count;
	while (ptr < end) {
	    const char *nl = ptr;
	    while (nl < end && *nl++ != '\n') /* empty body */;
	    done = PerlIOBuf_write(aTHX_ f, ptr, nl-ptr);
	    if (done != nl-ptr) {
		if (done > 0) {
		    ptr += done;
		}
		break;
	    }
	    ptr += done;
	    if (ptr[-1] == '\n') {
		if (PerlIOEncode_flush(aTHX_ f) != 0) {
		    break;
		}
	    }
	}
	return (SSize_t) (ptr - (const char *) vbuf);
    }
    else {
	return PerlIOBuf_write(aTHX_ f, vbuf, count);
    }
}

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

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

PROTOTYPES: ENABLE

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