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