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 */
51 #define ENCODE_FB_QUIET "Encode::FB_QUIET"
55 PerlIOEncode_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
57 PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
58 SV *sv = &PL_sv_undef;
66 if (call_method("name", G_SCALAR) == 1) {
76 PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg)
78 PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
81 code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv);
87 if (call_pv(ENCODE_FB_QUIET, G_SCALAR|G_NOARGS) != 1) {
88 Perl_die(aTHX_ "Call to Encode::FB_QUIET failed!");
92 e->chk = newSVsv(POPs);
98 if (call_pv("Encode::find_encoding", G_SCALAR) != 1) {
99 /* should never happen */
100 Perl_die(aTHX_ "Encode::find_encoding did not return a value");
107 if (!SvROK(e->enc)) {
110 Perl_warner(aTHX_ packWARN(WARN_IO), "Cannot find encoding \"%" SVf "\"",
115 SvREFCNT_inc(e->enc);
116 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
124 PerlIOEncode_popped(pTHX_ PerlIO * f)
126 PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
128 SvREFCNT_dec(e->enc);
132 SvREFCNT_dec(e->bufsv);
136 SvREFCNT_dec(e->dataSV);
143 PerlIOEncode_get_base(pTHX_ PerlIO * f)
145 PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
147 e->base.bufsiz = 1024;
149 e->bufsv = newSV(e->base.bufsiz);
150 sv_setpvn(e->bufsv, "", 0);
152 e->base.buf = (STDCHAR *) SvPVX(e->bufsv);
154 e->base.ptr = e->base.buf;
156 e->base.end = e->base.buf;
157 if (e->base.ptr < e->base.buf
158 || e->base.ptr > e->base.buf + SvLEN(e->bufsv)) {
159 Perl_warn(aTHX_ " ptr %p(%p)%p", e->base.buf, e->base.ptr,
160 e->base.buf + SvLEN(e->bufsv));
163 if (SvLEN(e->bufsv) < e->base.bufsiz) {
164 SSize_t poff = e->base.ptr - e->base.buf;
165 SSize_t eoff = e->base.end - e->base.buf;
166 e->base.buf = (STDCHAR *) SvGROW(e->bufsv, e->base.bufsiz);
167 e->base.ptr = e->base.buf + poff;
168 e->base.end = e->base.buf + eoff;
170 if (e->base.ptr < e->base.buf
171 || e->base.ptr > e->base.buf + SvLEN(e->bufsv)) {
172 Perl_warn(aTHX_ " ptr %p(%p)%p", e->base.buf, e->base.ptr,
173 e->base.buf + SvLEN(e->bufsv));
180 PerlIOEncode_fill(pTHX_ PerlIO * f)
182 PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
187 if (PerlIO_flush(f) != 0)
190 if (!PerlIO_fast_gets(n)) {
191 /* Things get too messy if we don't have a buffer layer
192 push a :perlio to do the job */
194 n = PerlIO_push(aTHX_ n, &PerlIO_perlio, PerlIO_modestr(f,mode), Nullsv);
196 Perl_die(aTHX_ "panic: cannot push :perlio for %p",f);
202 avail = PerlIO_get_cnt(n);
204 avail = PerlIO_fill(n);
206 avail = PerlIO_get_cnt(n);
209 if (!PerlIO_error(n) && PerlIO_eof(n))
214 STDCHAR *ptr = PerlIO_get_ptr(n);
219 e->base.ptr = e->base.end = (STDCHAR *) Nullch;
220 (void) PerlIOEncode_get_base(aTHX_ f);
222 e->dataSV = newSV(0);
223 if (SvTYPE(e->dataSV) < SVt_PV) {
224 sv_upgrade(e->dataSV,SVt_PV);
226 if (SvCUR(e->dataSV)) {
227 /* something left over from last time - create a normal
228 SV with new data appended
230 if (use + SvCUR(e->dataSV) > e->base.bufsiz) {
231 use = e->base.bufsiz - SvCUR(e->dataSV);
233 sv_catpvn(e->dataSV,(char*)ptr,use);
236 /* Create a "dummy" SV to represent the available data from layer below */
237 if (SvLEN(e->dataSV) && SvPVX(e->dataSV)) {
238 Safefree(SvPVX(e->dataSV));
240 if (use > e->base.bufsiz) {
241 use = e->base.bufsiz;
243 SvPVX(e->dataSV) = (char *) ptr;
244 SvLEN(e->dataSV) = 0; /* Hands off sv.c - it isn't yours */
245 SvCUR_set(e->dataSV,use);
246 SvPOK_only(e->dataSV);
248 SvUTF8_off(e->dataSV);
254 if (call_method("decode", G_SCALAR) != 1) {
255 Perl_die(aTHX_ "panic: decode did not return a value");
260 /* Now get translated string (forced to UTF-8) and use as buffer */
262 s = SvPVutf8(uni, len);
263 #ifdef PARANOID_ENCODE_CHECKS
264 if (len && !is_utf8_string((U8*)s,len)) {
265 Perl_warn(aTHX_ "panic: decode did not return UTF-8 '%.*s'",(int) len,s);
271 /* if decode gave us back dataSV then data may vanish when
272 we do ptrcnt adjust - so take our copy now.
273 (The copy is a pain - need a put-it-here option for decode.)
275 sv_setpvn(e->bufsv,s,len);
276 e->base.ptr = e->base.buf = (STDCHAR*)SvPVX(e->bufsv);
277 e->base.end = e->base.ptr + SvCUR(e->bufsv);
278 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
281 /* Adjust ptr/cnt not taking anything which
282 did not translate - not clear this is a win */
283 /* compute amount we took */
284 use -= SvCUR(e->dataSV);
285 PerlIO_set_ptrcnt(n, ptr+use, (avail-use));
286 /* and as we did not take it it isn't pending */
287 SvCUR_set(e->dataSV,0);
289 /* Got nothing - assume partial character so we need some more */
290 /* Make sure e->dataSV is a normal SV before re-filling as
291 buffer alias will change under us
293 s = SvPV(e->dataSV,len);
294 sv_setpvn(e->dataSV,s,len);
295 PerlIO_set_ptrcnt(n, ptr+use, (avail-use));
304 PerlIOBase(f)->flags |= PERLIO_F_EOF;
306 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
312 PerlIOEncode_flush(pTHX_ PerlIO * f)
314 PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
316 if (e->bufsv && (e->base.ptr > e->base.buf)) {
322 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
323 /* Write case encode the buffer and write() to layer below */
328 SvCUR_set(e->bufsv, e->base.ptr - e->base.buf);
333 if (call_method("encode", G_SCALAR) != 1) {
334 Perl_die(aTHX_ "panic: encode did not return a value");
340 count = PerlIO_write(PerlIONext(f),s,len);
346 if (PerlIO_flush(PerlIONext(f)) != 0) {
349 if (SvCUR(e->bufsv)) {
350 /* Did not all translate */
351 e->base.ptr = e->base.buf+SvCUR(e->bufsv);
355 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
357 /* if we have any untranslated stuff then unread that first */
358 if (e->dataSV && SvCUR(e->dataSV)) {
359 s = SvPV(e->dataSV, len);
360 count = PerlIO_unread(PerlIONext(f),s,len);
365 /* See if there is anything left in the buffer */
366 if (e->base.ptr < e->base.end) {
367 /* Bother - have unread data.
368 re-encode and unread() to layer below
372 str = sv_newmortal();
373 sv_upgrade(str, SVt_PV);
374 SvPVX(str) = (char*)e->base.ptr;
376 SvCUR_set(str, e->base.end - e->base.ptr);
384 if (call_method("encode", G_SCALAR) != 1) {
385 Perl_die(aTHX_ "panic: encode did not return a value");
391 count = PerlIO_unread(PerlIONext(f),s,len);
399 e->base.ptr = e->base.end = e->base.buf;
400 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
406 PerlIOEncode_close(pTHX_ PerlIO * f)
408 PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
409 IV code = PerlIOBase_close(aTHX_ f);
411 if (e->base.buf && e->base.ptr > e->base.buf) {
412 Perl_croak(aTHX_ "Close with partial character");
414 SvREFCNT_dec(e->bufsv);
420 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
425 PerlIOEncode_tell(pTHX_ PerlIO * f)
427 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
428 /* Unfortunately the only way to get a postion is to (re-)translate,
429 the UTF8 we have in bufefr and then ask layer below
432 if (b->buf && b->ptr > b->buf) {
433 Perl_croak(aTHX_ "Cannot tell at partial character");
435 return PerlIO_tell(PerlIONext(f));
439 PerlIOEncode_dup(pTHX_ PerlIO * f, PerlIO * o,
440 CLONE_PARAMS * params, int flags)
442 if ((f = PerlIOBase_dup(aTHX_ f, o, params, flags))) {
443 PerlIOEncode *fe = PerlIOSelf(f, PerlIOEncode);
444 PerlIOEncode *oe = PerlIOSelf(o, PerlIOEncode);
446 fe->enc = PerlIO_sv_dup(aTHX_ oe->enc, params);
452 PerlIO_funcs PerlIO_encode = {
454 sizeof(PerlIOEncode),
455 PERLIO_K_BUFFERED|PERLIO_K_DESTRUCT,
473 PerlIOBase_setlinebuf,
474 PerlIOEncode_get_base,
478 PerlIOBuf_set_ptrcnt,
480 #endif /* encode layer */
482 MODULE = PerlIO::encoding PACKAGE = PerlIO::encoding
489 PerlIO_define_layer(aTHX_ &PerlIO_encode);