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

/*
 * $Id$
 */

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

#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

#if 0
#define OUR_ENCODE_FB "Encode::FB_PERLQQ"
#else
#define OUR_ENCODE_FB "Encode::FB_QUIET"
#endif

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;
	ENTER;
	SAVETMPS;
	PUSHMARK(sp);
	XPUSHs(e->enc);
	PUTBACK;
	if (call_method("name", G_SCALAR) == 1) {
	    SPAGAIN;
	    sv = newSVsv(POPs);
	    PUTBACK;
	}
    }
    return sv;
}

IV
PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg)
{
    PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
    dSP;
    IV code;
    SV *result = Nullsv;
    code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv);
    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::check",0));

    FREETMPS;
    LEAVE;
    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->dataSV = 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);
	}
    }
    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, 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;
	}
	FREETMPS;
	LEAVE;
	return code;
    }
    else {
    end_of_file:
	if (avail == 0)
	    PerlIOBase(f)->flags |= PERLIO_F_EOF;
	else
	    PerlIOBase(f)->flags |= PERLIO_F_ERROR;
	return -1;
    }
}

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