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