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