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