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