1 #define PERL_NO_GET_CONTEXT
7 #if defined(USE_PERLIO) && !defined(USE_SFIO)
9 /* Define an encoding "layer" in the perliol.h sense.
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.
16 The layer works by overloading the "fill" and "flush" methods.
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
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
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.)
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 */
46 PerlIOEncode_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
48 PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
49 SV *sv = &PL_sv_undef;
57 if (perl_call_method("name", G_SCALAR) == 1) {
67 PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg)
69 PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
72 code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv);
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");
89 Perl_warner(aTHX_ packWARN(WARN_IO), "Cannot find encoding \"%" SVf "\"",
95 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
103 PerlIOEncode_popped(pTHX_ PerlIO * f)
105 PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
107 SvREFCNT_dec(e->enc);
111 SvREFCNT_dec(e->bufsv);
115 SvREFCNT_dec(e->dataSV);
122 PerlIOEncode_get_base(pTHX_ PerlIO * f)
124 PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
126 e->base.bufsiz = 1024;
128 e->bufsv = newSV(e->base.bufsiz);
129 sv_setpvn(e->bufsv, "", 0);
131 e->base.buf = (STDCHAR *) SvPVX(e->bufsv);
133 e->base.ptr = e->base.buf;
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));
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;
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));
159 PerlIOEncode_fill(pTHX_ PerlIO * f)
161 PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
166 if (PerlIO_flush(f) != 0)
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 */
173 n = PerlIO_push(aTHX_ n, &PerlIO_perlio, PerlIO_modestr(f,mode), Nullsv);
175 Perl_die(aTHX_ "panic: cannot push :perlio for %p",f);
181 avail = PerlIO_get_cnt(n);
183 avail = PerlIO_fill(n);
185 avail = PerlIO_get_cnt(n);
188 if (!PerlIO_error(n) && PerlIO_eof(n))
193 STDCHAR *ptr = PerlIO_get_ptr(n);
198 e->base.ptr = e->base.end = (STDCHAR *) Nullch;
199 (void) PerlIOEncode_get_base(aTHX_ f);
201 e->dataSV = newSV(0);
202 if (SvTYPE(e->dataSV) < SVt_PV) {
203 sv_upgrade(e->dataSV,SVt_PV);
205 if (SvCUR(e->dataSV)) {
206 /* something left over from last time - create a normal
207 SV with new data appended
209 if (use + SvCUR(e->dataSV) > e->base.bufsiz) {
210 use = e->base.bufsiz - SvCUR(e->dataSV);
212 sv_catpvn(e->dataSV,(char*)ptr,use);
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));
219 if (use > e->base.bufsiz) {
220 use = e->base.bufsiz;
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);
227 SvUTF8_off(e->dataSV);
233 if (perl_call_method("decode", G_SCALAR) != 1) {
234 Perl_die(aTHX_ "panic: decode did not return a value");
239 /* Now get translated string (forced to UTF-8) and use as buffer */
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);
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.)
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;
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);
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
272 s = SvPV(e->dataSV,len);
273 sv_setpvn(e->dataSV,s,len);
274 PerlIO_set_ptrcnt(n, ptr+use, (avail-use));
283 PerlIOBase(f)->flags |= PERLIO_F_EOF;
285 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
291 PerlIOEncode_flush(pTHX_ PerlIO * f)
293 PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
295 if (e->bufsv && (e->base.ptr > e->base.buf)) {
301 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
302 /* Write case encode the buffer and write() to layer below */
307 SvCUR_set(e->bufsv, e->base.ptr - e->base.buf);
312 if (perl_call_method("encode", G_SCALAR) != 1) {
313 Perl_die(aTHX_ "panic: encode did not return a value");
319 count = PerlIO_write(PerlIONext(f),s,len);
325 if (PerlIO_flush(PerlIONext(f)) != 0) {
328 if (SvCUR(e->bufsv)) {
329 /* Did not all translate */
330 e->base.ptr = e->base.buf+SvCUR(e->bufsv);
334 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
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);
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
351 str = sv_newmortal();
352 sv_upgrade(str, SVt_PV);
353 SvPVX(str) = (char*)e->base.ptr;
355 SvCUR_set(str, e->base.end - e->base.ptr);
363 if (perl_call_method("encode", G_SCALAR) != 1) {
364 Perl_die(aTHX_ "panic: encode did not return a value");
370 count = PerlIO_unread(PerlIONext(f),s,len);
378 e->base.ptr = e->base.end = e->base.buf;
379 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
385 PerlIOEncode_close(pTHX_ PerlIO * f)
387 PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
388 IV code = PerlIOBase_close(aTHX_ f);
390 if (e->base.buf && e->base.ptr > e->base.buf) {
391 Perl_croak(aTHX_ "Close with partial character");
393 SvREFCNT_dec(e->bufsv);
399 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
404 PerlIOEncode_tell(pTHX_ PerlIO * f)
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
411 if (b->buf && b->ptr > b->buf) {
412 Perl_croak(aTHX_ "Cannot tell at partial character");
414 return PerlIO_tell(PerlIONext(f));
418 PerlIOEncode_dup(pTHX_ PerlIO * f, PerlIO * o,
419 CLONE_PARAMS * params, int flags)
421 if ((f = PerlIOBase_dup(aTHX_ f, o, params, flags))) {
422 PerlIOEncode *fe = PerlIOSelf(f, PerlIOEncode);
423 PerlIOEncode *oe = PerlIOSelf(o, PerlIOEncode);
425 fe->enc = PerlIO_sv_dup(aTHX_ oe->enc, params);
431 PerlIO_funcs PerlIO_encode = {
433 sizeof(PerlIOEncode),
434 PERLIO_K_BUFFERED|PERLIO_K_DESTRUCT,
452 PerlIOBase_setlinebuf,
453 PerlIOEncode_get_base,
457 PerlIOBuf_set_ptrcnt,
459 #endif /* encode layer */
461 MODULE = PerlIO::encoding PACKAGE = PerlIO::encoding
468 PerlIO_define_layer(aTHX_ &PerlIO_encode);