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