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 */ 12static unsigned int encode_stop_at_partial = 0; 13static 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 46typedef 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 58static const MGVTBL PerlIOEncode_tag = { 0, 0, 0, 0, 0, 0, 0, 0 }; 59 60static SV * 61PerlIOEncode_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 96static IV 97PerlIOEncode_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 184static IV 185PerlIOEncode_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 207static STDCHAR * 208PerlIOEncode_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 244static IV 245PerlIOEncode_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(0); 290 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 403static IV 404PerlIOEncode_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 = sv_newmortal(); 484 sv_upgrade(str, SVt_PV); 485 SvPV_set(str, (char*)e->base.ptr); 486 SvLEN_set(str, 0); 487 SvCUR_set(str, e->base.end - e->base.ptr); 488 SvPOK_only(str); 489 SvUTF8_on(str); 490 PUSHMARK(sp); 491 XPUSHs(e->enc); 492 XPUSHs(str); 493 XPUSHs(e->chk); 494 PUTBACK; 495 e->inEncodeCall = 1; 496 if (call_method("encode", G_SCALAR) != 1) { 497 e->inEncodeCall = 0; 498 Perl_die(aTHX_ "panic: encode did not return a value"); 499 } 500 e->inEncodeCall = 0; 501 SPAGAIN; 502 str = POPs; 503 PUTBACK; 504 s = SvPV(str, len); 505 count = PerlIO_unread(PerlIONext(f),s,len); 506 if ((STRLEN)count != len) { 507 code = -1; 508 } 509 FREETMPS; 510 LEAVE; 511 POPSTACK; 512 } 513 } 514 e->base.ptr = e->base.end = e->base.buf; 515 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF); 516 } 517 return code; 518} 519 520static IV 521PerlIOEncode_close(pTHX_ PerlIO * f) 522{ 523 PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode); 524 IV code; 525 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) { 526 /* Discard partial character */ 527 if (e->dataSV) { 528 SvCUR_set(e->dataSV,0); 529 } 530 /* Don't back decode and unread any pending data */ 531 e->base.ptr = e->base.end = e->base.buf; 532 } 533 code = PerlIOBase_close(aTHX_ f); 534 if (e->bufsv) { 535 /* This should only fire for write case */ 536 if (e->base.buf && e->base.ptr > e->base.buf) { 537 Perl_croak(aTHX_ "Close with partial character"); 538 } 539 SvREFCNT_dec(e->bufsv); 540 e->bufsv = Nullsv; 541 } 542 e->base.buf = NULL; 543 e->base.ptr = NULL; 544 e->base.end = NULL; 545 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF); 546 return code; 547} 548 549static Off_t 550PerlIOEncode_tell(pTHX_ PerlIO * f) 551{ 552 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 553 /* Unfortunately the only way to get a position is to (re-)translate, 554 the UTF8 we have in buffer and then ask layer below 555 */ 556 PerlIO_flush(f); 557 if (b->buf && b->ptr > b->buf) { 558 Perl_croak(aTHX_ "Cannot tell at partial character"); 559 } 560 return PerlIO_tell(PerlIONext(f)); 561} 562 563static PerlIO * 564PerlIOEncode_dup(pTHX_ PerlIO * f, PerlIO * o, 565 CLONE_PARAMS * params, int flags) 566{ 567 if ((f = PerlIOBase_dup(aTHX_ f, o, params, flags))) { 568 PerlIOEncode *fe = PerlIOSelf(f, PerlIOEncode); 569 PerlIOEncode *oe = PerlIOSelf(o, PerlIOEncode); 570 if (oe->enc) { 571 fe->enc = PerlIO_sv_dup(aTHX_ oe->enc, params); 572 } 573 if (oe->chk) { 574 fe->chk = PerlIO_sv_dup(aTHX_ oe->chk, params); 575 } 576 } 577 return f; 578} 579 580static SSize_t 581PerlIOEncode_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 582{ 583 PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode); 584 if (e->flags & NEEDS_LINES) { 585 SSize_t done = 0; 586 const char *ptr = (const char *) vbuf; 587 const char *end = ptr+count; 588 while (ptr < end) { 589 const char *nl = ptr; 590 while (nl < end && *nl++ != '\n') /* empty body */; 591 done = PerlIOBuf_write(aTHX_ f, ptr, nl-ptr); 592 if (done != nl-ptr) { 593 if (done > 0) { 594 ptr += done; 595 } 596 break; 597 } 598 ptr += done; 599 if (ptr[-1] == '\n') { 600 if (PerlIOEncode_flush(aTHX_ f) != 0) { 601 break; 602 } 603 } 604 } 605 return (SSize_t) (ptr - (const char *) vbuf); 606 } 607 else { 608 return PerlIOBuf_write(aTHX_ f, vbuf, count); 609 } 610} 611 612static PERLIO_FUNCS_DECL(PerlIO_encode) = { 613 sizeof(PerlIO_funcs), 614 "encoding", 615 sizeof(PerlIOEncode), 616 PERLIO_K_BUFFERED|PERLIO_K_DESTRUCT, 617 PerlIOEncode_pushed, 618 PerlIOEncode_popped, 619 PerlIOBuf_open, 620 NULL, /* binmode - always pop */ 621 PerlIOEncode_getarg, 622 PerlIOBase_fileno, 623 PerlIOEncode_dup, 624 PerlIOBuf_read, 625 PerlIOBuf_unread, 626 PerlIOEncode_write, 627 PerlIOBuf_seek, 628 PerlIOEncode_tell, 629 PerlIOEncode_close, 630 PerlIOEncode_flush, 631 PerlIOEncode_fill, 632 PerlIOBase_eof, 633 PerlIOBase_error, 634 PerlIOBase_clearerr, 635 PerlIOBase_setlinebuf, 636 PerlIOEncode_get_base, 637 PerlIOBuf_bufsiz, 638 PerlIOBuf_get_ptr, 639 PerlIOBuf_get_cnt, 640 PerlIOBuf_set_ptrcnt, 641}; 642#endif /* encode layer */ 643 644MODULE = PerlIO::encoding PACKAGE = PerlIO::encoding 645 646PROTOTYPES: ENABLE 647 648BOOT: 649{ 650 /* 651 * we now "use Encode ()" here instead of 652 * PerlIO/encoding.pm. This avoids SEGV when ":encoding()" 653 * is invoked without prior "use Encode". -- dankogai 654 */ 655 PUSHSTACKi(PERLSI_MAGIC); 656 if (!get_cvs(OUR_STOP_AT_PARTIAL, 0)) { 657 /* The SV is magically freed by load_module */ 658 load_module(PERL_LOADMOD_NOIMPORT, newSVpvs("Encode"), Nullsv, Nullsv); 659 assert(sp == PL_stack_sp); 660 } 661 662 PUSHMARK(sp); 663 PUTBACK; 664 if (call_pv(OUR_STOP_AT_PARTIAL, G_SCALAR) != 1) { 665 /* should never happen */ 666 Perl_die(aTHX_ "%s did not return a value", OUR_STOP_AT_PARTIAL); 667 } 668 SPAGAIN; 669 encode_stop_at_partial = POPu; 670 671 PUSHMARK(sp); 672 PUTBACK; 673 if (call_pv(OUR_LEAVE_SRC, G_SCALAR) != 1) { 674 /* should never happen */ 675 Perl_die(aTHX_ "%s did not return a value", OUR_LEAVE_SRC); 676 } 677 SPAGAIN; 678 encode_leave_src = POPu; 679 680 PUTBACK; 681#ifdef PERLIO_LAYERS 682 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_encode)); 683#endif 684 POPSTACK; 685} 686