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

#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 */
} PerlIOEncode;

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 (perl_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;
    code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv);
    ENTER;
    SAVETMPS;
    PUSHMARK(sp);
    XPUSHs(arg);
    PUTBACK;
    if (perl_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;
    e->enc = POPs;
    PUTBACK;
    if (!SvROK(e->enc)) {
	e->enc = Nullsv;
	errno = EINVAL;
	Perl_warner(aTHX_ packWARN(WARN_IO), "Cannot find encoding \"%" SVf "\"",
		    arg); 
	code = -1;
    }
    else {
	SvREFCNT_inc(e->enc);
	PerlIOBase(f)->flags |= PERLIO_F_UTF8;
    }
    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;
    }
    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) {
	STDCHAR *ptr = PerlIO_get_ptr(n);
	SSize_t use  = avail;
	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 (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) {
	       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 > e->base.bufsiz) {
	       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(&PL_sv_yes);
	PUTBACK;
	if (perl_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 {
	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(&PL_sv_yes);
	    PUTBACK;
	    if (perl_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(&PL_sv_yes);
		PUTBACK;
		if (perl_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;
}

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