ext/PerlIO-encoding/encoding.xs

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