5 #define PERL_NO_GET_CONTEXT
11 #if defined(USE_PERLIO) && !defined(USE_SFIO)
13 /* Define an encoding "layer" in the perliol.h sense.
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.
20 The layer works by overloading the "fill" and "flush" methods.
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
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
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.)
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 */
47 SV *chk; /* CHECK in Encode methods */
48 int flags; /* Flags currently just needs lines */
54 #define OUR_ENCODE_FB "Encode::FB_PERLQQ"
56 #define OUR_ENCODE_FB "Encode::FB_QUIET"
60 PerlIOEncode_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
62 PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
63 SV *sv = &PL_sv_undef;
71 if (call_method("name", G_SCALAR) == 1) {
81 PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg)
83 PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
87 code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv);
94 if (call_pv("Encode::find_encoding", G_SCALAR) != 1) {
95 /* should never happen */
96 Perl_die(aTHX_ "Encode::find_encoding did not return a value");
103 if (!SvROK(result) || !SvOBJECT(SvRV(result))) {
105 Perl_warner(aTHX_ packWARN(WARN_IO), "Cannot find encoding \"%" SVf "\"",
111 #ifdef USE_NEW_SEQUENCE
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",
125 e->enc = newSVsv(result);
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",
137 if (SvTRUE(result)) {
138 e->flags |= NEEDS_LINES;
141 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
144 e->chk = newSVsv(get_sv("PerlIO::encoding::check",0));
152 PerlIOEncode_popped(pTHX_ PerlIO * f)
154 PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
156 SvREFCNT_dec(e->enc);
160 SvREFCNT_dec(e->bufsv);
164 SvREFCNT_dec(e->dataSV);
168 SvREFCNT_dec(e->chk);
175 PerlIOEncode_get_base(pTHX_ PerlIO * f)
177 PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
179 e->base.bufsiz = 1024;
181 e->bufsv = newSV(e->base.bufsiz);
182 sv_setpvn(e->bufsv, "", 0);
184 e->base.buf = (STDCHAR *) SvPVX(e->bufsv);
186 e->base.ptr = e->base.buf;
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));
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;
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));
212 PerlIOEncode_fill(pTHX_ PerlIO * f)
214 PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
219 if (PerlIO_flush(f) != 0)
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 */
226 n = PerlIO_push(aTHX_ n, &PerlIO_perlio, PerlIO_modestr(f,mode), Nullsv);
228 Perl_die(aTHX_ "panic: cannot push :perlio for %p",f);
234 avail = PerlIO_get_cnt(n);
236 avail = PerlIO_fill(n);
238 avail = PerlIO_get_cnt(n);
241 if (!PerlIO_error(n) && PerlIO_eof(n))
245 if (avail > 0 || (e->flags & NEEDS_LINES)) {
246 STDCHAR *ptr = PerlIO_get_ptr(n);
247 SSize_t use = (avail >= 0) ? avail : 0;
251 e->base.ptr = e->base.end = (STDCHAR *) Nullch;
252 (void) PerlIOEncode_get_base(aTHX_ f);
254 e->dataSV = newSV(0);
255 if (SvTYPE(e->dataSV) < SVt_PV) {
256 sv_upgrade(e->dataSV,SVt_PV);
258 if (e->flags & NEEDS_LINES) {
259 /* Encoding needs whole lines (e.g. iso-2022-*)
260 search back from end of available data for
263 STDCHAR *nl = ptr+use-1;
270 if (nl >= ptr && *nl == '\n') {
271 /* found a line - take up to and including that */
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);
280 else if (!SvCUR(e->dataSV)) {
284 if (SvCUR(e->dataSV)) {
285 /* something left over from last time - create a normal
286 SV with new data appended
288 if (use + SvCUR(e->dataSV) > e->base.bufsiz) {
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);
295 use = e->base.bufsiz - SvCUR(e->dataSV);
298 sv_catpvn(e->dataSV,(char*)ptr,use);
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));
305 if (use > e->base.bufsiz) {
306 if (e->flags & NEEDS_LINES) {
307 /* Have to grow buffer */
308 e->base.bufsiz = use;
309 PerlIOEncode_get_base(aTHX_ f);
312 use = e->base.bufsiz;
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);
320 SvUTF8_off(e->dataSV);
326 if (call_method("decode", G_SCALAR) != 1) {
327 Perl_die(aTHX_ "panic: decode did not return a value");
332 /* Now get translated string (forced to UTF-8) and use as buffer */
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);
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.)
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;
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);
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
365 s = SvPV(e->dataSV,len);
366 sv_setpvn(e->dataSV,s,len);
367 PerlIO_set_ptrcnt(n, ptr+use, (avail-use));
377 PerlIOBase(f)->flags |= PERLIO_F_EOF;
379 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
385 PerlIOEncode_flush(pTHX_ PerlIO * f)
387 PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
389 if (e->bufsv && (e->base.ptr > e->base.buf)) {
395 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
396 /* Write case encode the buffer and write() to layer below */
401 SvCUR_set(e->bufsv, e->base.ptr - e->base.buf);
406 if (call_method("encode", G_SCALAR) != 1) {
407 Perl_die(aTHX_ "panic: encode did not return a value");
413 count = PerlIO_write(PerlIONext(f),s,len);
419 if (PerlIO_flush(PerlIONext(f)) != 0) {
422 if (SvCUR(e->bufsv)) {
423 /* Did not all translate */
424 e->base.ptr = e->base.buf+SvCUR(e->bufsv);
428 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
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);
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
445 str = sv_newmortal();
446 sv_upgrade(str, SVt_PV);
447 SvPVX(str) = (char*)e->base.ptr;
449 SvCUR_set(str, e->base.end - e->base.ptr);
457 if (call_method("encode", G_SCALAR) != 1) {
458 Perl_die(aTHX_ "panic: encode did not return a value");
464 count = PerlIO_unread(PerlIONext(f),s,len);
472 e->base.ptr = e->base.end = e->base.buf;
473 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
479 PerlIOEncode_close(pTHX_ PerlIO * f)
481 PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
482 IV code = PerlIOBase_close(aTHX_ f);
484 if (e->base.buf && e->base.ptr > e->base.buf) {
485 Perl_croak(aTHX_ "Close with partial character");
487 SvREFCNT_dec(e->bufsv);
493 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
498 PerlIOEncode_tell(pTHX_ PerlIO * f)
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
505 if (b->buf && b->ptr > b->buf) {
506 Perl_croak(aTHX_ "Cannot tell at partial character");
508 return PerlIO_tell(PerlIONext(f));
512 PerlIOEncode_dup(pTHX_ PerlIO * f, PerlIO * o,
513 CLONE_PARAMS * params, int flags)
515 if ((f = PerlIOBase_dup(aTHX_ f, o, params, flags))) {
516 PerlIOEncode *fe = PerlIOSelf(f, PerlIOEncode);
517 PerlIOEncode *oe = PerlIOSelf(o, PerlIOEncode);
519 fe->enc = PerlIO_sv_dup(aTHX_ oe->enc, params);
526 PerlIOEncode_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
528 PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
529 if (e->flags & NEEDS_LINES) {
531 const char *ptr = (const char *) vbuf;
532 const char *end = ptr+count;
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) {
544 if (ptr[-1] == '\n') {
545 if (PerlIOEncode_flush(aTHX_ f) != 0) {
550 return (SSize_t) (ptr - (const char *) vbuf);
553 return PerlIOBuf_write(aTHX_ f, vbuf, count);
557 PerlIO_funcs PerlIO_encode = {
559 sizeof(PerlIOEncode),
560 PERLIO_K_BUFFERED|PERLIO_K_DESTRUCT,
578 PerlIOBase_setlinebuf,
579 PerlIOEncode_get_base,
583 PerlIOBuf_set_ptrcnt,
585 #endif /* encode layer */
587 MODULE = PerlIO::encoding PACKAGE = PerlIO::encoding
593 SV *sv = get_sv("PerlIO::encoding::check", GV_ADD|GV_ADDMULTI);
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);
607 PerlIO_define_layer(aTHX_ &PerlIO_encode);