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             /* FIXME - unread is fragile is there a better way ? */
 446             if (e->dataSV && SvCUR(e->dataSV)) {
 447                 s = SvPV(e->dataSV, len);
 448                 count = PerlIO_unread(PerlIONext(f),s,len);
 449                 if ((STRLEN)count != len) {
 450                     code = -1;
 451                 }
 452                 SvCUR_set(e->dataSV,0);
 453             }
 454             /* See if there is anything left in the buffer */
 455             if (e->base.ptr < e->base.end) {
 456                 /* Bother - have unread data.
 457                    re-encode and unread() to layer below
 458                  */
 459                 PUSHSTACKi(PERLSI_MAGIC);
 460                 SPAGAIN;
 461                 ENTER;
 462                 SAVETMPS;
 463                 str = sv_newmortal();
 464                 sv_upgrade(str, SVt_PV);
 465                 SvPVX(str) = (char*)e->base.ptr;
 466                 SvLEN(str) = 0;
 467                 SvCUR_set(str, e->base.end - e->base.ptr);
 468                 SvPOK_only(str);
 469                 SvUTF8_on(str);
 470                 PUSHMARK(sp);
 471                 XPUSHs(e->enc);
 472                 XPUSHs(str);
 473                 XPUSHs(e->chk);
 474                 PUTBACK;
 475                 if (call_method("encode", G_SCALAR) != 1) {
 476                      Perl_die(aTHX_ "panic: encode did not return a value");
 477                 }
 478                 SPAGAIN;
 479                 str = POPs;
 480                 PUTBACK;
 481                 s = SvPV(str, len);
 482                 count = PerlIO_unread(PerlIONext(f),s,len);
 483                 if ((STRLEN)count != len) {
 484                     code = -1;
 485                 }
 486                 FREETMPS;
 487                 LEAVE;
 488                 POPSTACK;
 489             }
 490         }
 491         e->base.ptr = e->base.end = e->base.buf;
 492         PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
 493     }
 494     return code;
 495 }
 496
 497 IV
 498 PerlIOEncode_close(pTHX_ PerlIO * f)
 499 {
 500     PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
 501     IV code;
 502     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
 503         /* Discard partial character */
 504         if (e->dataSV) {
 505             SvCUR_set(e->dataSV,0);
 506         }
 507         /* Don't back decode and unread any pending data */
 508         e->base.ptr = e->base.end = e->base.buf;
 509     }
 510     code = PerlIOBase_close(aTHX_ f);
 511     if (e->bufsv) {
 512         /* This should only fire for write case */
 513         if (e->base.buf && e->base.ptr > e->base.buf) {
 514             Perl_croak(aTHX_ "Close with partial character");
 515         }
 516         SvREFCNT_dec(e->bufsv);
 517         e->bufsv = Nullsv;
 518     }
 519     e->base.buf = NULL;
 520     e->base.ptr = NULL;
 521     e->base.end = NULL;
 522     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
 523     return code;
 524 }
 525
 526 Off_t
 527 PerlIOEncode_tell(pTHX_ PerlIO * f)
 528 {
 529     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
 530     /* Unfortunately the only way to get a postion is to (re-)translate,
 531        the UTF8 we have in bufefr and then ask layer below
 532      */
 533     PerlIO_flush(f);
 534     if (b->buf && b->ptr > b->buf) {
 535         Perl_croak(aTHX_ "Cannot tell at partial character");
 536     }
 537     return PerlIO_tell(PerlIONext(f));
 538 }
 539
 540 PerlIO *
 541 PerlIOEncode_dup(pTHX_ PerlIO * f, PerlIO * o,
 542                  CLONE_PARAMS * params, int flags)
 543 {
 544     if ((f = PerlIOBase_dup(aTHX_ f, o, params, flags))) {
 545         PerlIOEncode *fe = PerlIOSelf(f, PerlIOEncode);
 546         PerlIOEncode *oe = PerlIOSelf(o, PerlIOEncode);
 547         if (oe->enc) {
 548             fe->enc = PerlIO_sv_dup(aTHX_ oe->enc, params);
 549         }
 550     }
 551     return f;
 552 }
 553
 554 SSize_t
 555 PerlIOEncode_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
 556 {
 557     PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
 558     if (e->flags & NEEDS_LINES) {
 559         SSize_t done = 0;
 560         const char *ptr = (const char *) vbuf;
 561         const char *end = ptr+count;
 562         while (ptr < end) {
 563             const char *nl = ptr;
 564             while (nl < end && *nl++ != '\n') /* empty body */;
 565             done = PerlIOBuf_write(aTHX_ f, ptr, nl-ptr);
 566             if (done != nl-ptr) {
 567                 if (done > 0) {
 568                     ptr += done;
 569                 }
 570                 break;
 571             }
 572             ptr += done;
 573             if (ptr[-1] == '\n') {
 574                 if (PerlIOEncode_flush(aTHX_ f) != 0) {
 575                     break;
 576                 }
 577             }
 578         }
 579         return (SSize_t) (ptr - (const char *) vbuf);
 580     }
 581     else {
 582         return PerlIOBuf_write(aTHX_ f, vbuf, count);
 583     }
 584 }
 585
 586 PerlIO_funcs PerlIO_encode = {
 587     "encoding",
 588     sizeof(PerlIOEncode),
 589     PERLIO_K_BUFFERED|PERLIO_K_DESTRUCT,
 590     PerlIOEncode_pushed,
 591     PerlIOEncode_popped,
 592     PerlIOBuf_open,
 593     NULL, /* binmode - always pop */
 594     PerlIOEncode_getarg,
 595     PerlIOBase_fileno,
 596     PerlIOEncode_dup,
 597     PerlIOBuf_read,
 598     PerlIOBuf_unread,
 599     PerlIOEncode_write,
 600     PerlIOBuf_seek,
 601     PerlIOEncode_tell,
 602     PerlIOEncode_close,
 603     PerlIOEncode_flush,
 604     PerlIOEncode_fill,
 605     PerlIOBase_eof,
 606     PerlIOBase_error,
 607     PerlIOBase_clearerr,
 608     PerlIOBase_setlinebuf,
 609     PerlIOEncode_get_base,
 610     PerlIOBuf_bufsiz,
 611     PerlIOBuf_get_ptr,
 612     PerlIOBuf_get_cnt,
 613     PerlIOBuf_set_ptrcnt,
 614 };
 615 #endif                          /* encode layer */
 616
 617 MODULE = PerlIO::encoding PACKAGE = PerlIO::encoding
 618
 619 PROTOTYPES: ENABLE
 620
 621 BOOT:
 622 {
 623     SV *chk = get_sv("PerlIO::encoding::fallback", GV_ADD|GV_ADDMULTI);
 624     /*
 625      * we now "use Encode ()" here instead of
 626      * PerlIO/encoding.pm.  This avoids SEGV when ":encoding()"
 627      * is invoked without prior "use Encode". -- dankogai
 628      */
 629     PUSHSTACKi(PERLSI_MAGIC);
 630     SPAGAIN;
 631     if (!get_cv(OUR_DEFAULT_FB, 0)) {
 632 #if 0
 633         /* This would just be an irritant now loading works */
 634         Perl_warner(aTHX_ packWARN(WARN_IO), ":encoding without 'use Encode'");
 635 #endif
 636         ENTER;
 637         /* Encode needs a lot of stack - it is likely to move ... */
 638         PUTBACK;
 639         /* The SV is magically freed by load_module */
 640         load_module(PERL_LOADMOD_NOIMPORT, newSVpvn("Encode", 6), Nullsv, Nullsv);
 641         SPAGAIN;
 642         LEAVE;
 643     }
 644     PUSHMARK(sp);
 645     PUTBACK;
 646     if (call_pv(OUR_DEFAULT_FB, G_SCALAR) != 1) {
 647             /* should never happen */
 648             Perl_die(aTHX_ "%s did not return a value",OUR_DEFAULT_FB);
 649     }
 650     SPAGAIN;
 651     sv_setsv(chk, POPs);
 652     PUTBACK;
 653 #ifdef PERLIO_LAYERS
 654     PerlIO_define_layer(aTHX_ &PerlIO_encode);
 655 #endif
 656     POPSTACK;
 657 }