File Coverage

ext/PerlIO-encoding/encoding.xs
Criterion Covered Total %
statement 326 354 92.1
branch n/a
condition n/a
subroutine n/a
total 326 354 92.1


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