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