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