ext/Encode/Encode.xs

   1 #define PERL_NO_GET_CONTEXT
   2
   3 #include "EXTERN.h"
   4 #include "perl.h"
   5 #include "XSUB.h"
   6 #define U8 U8
   7 #include "encode.h"
   8 #include "8859.h"
   9 #include "EBCDIC.h"
  10 #include "Symbols.h"
  11
  12
  13 #define UNIMPLEMENTED(x,y) y x (SV *sv, char *encoding) {dTHX;   \
  14                          Perl_croak(aTHX_ "panic_unimplemented"); \
  15                          return (y)0; /* fool picky compilers */ \
  16                          }
  17 UNIMPLEMENTED(_encoded_utf8_to_bytes, I32)
  18     UNIMPLEMENTED(_encoded_bytes_to_utf8, I32)
  19 #if defined(USE_PERLIO) && !defined(USE_SFIO)
  20 /* Define an encoding "layer" in the perliol.h sense.
  21    The layer defined here "inherits" in an object-oriented sense from the
  22    "perlio" layer with its PerlIOBuf_* "methods".
  23    The implementation is particularly efficient as until Encode settles down
  24    there is no point in tryint to tune it.
  25
  26    The layer works by overloading the "fill" and "flush" methods.
  27
  28    "fill" calls "SUPER::fill" in perl terms, then calls the encode OO perl API
  29    to convert the encoded data to UTF-8 form, then copies it back to the
  30    buffer. The "base class's" read methods then see the UTF-8 data.
  31
  32    "flush" transforms the UTF-8 data deposited by the "base class's write
  33    method in the buffer back into the encoded form using the encode OO perl API,
  34    then copies data back into the buffer and calls "SUPER::flush.
  35
  36    Note that "flush" is _also_ called for read mode - we still do the (back)-translate
  37    so that the the base class's "flush" sees the correct number of encoded chars
  38    for positioning the seek pointer. (This double translation is the worst performance
  39    issue - particularly with all-perl encode engine.)
  40
  41 */
  42 #include "perliol.h"
  43 typedef struct {
  44     PerlIOBuf base;             /* PerlIOBuf stuff */
  45     SV *bufsv;                  /* buffer seen by layers above */
  46     SV *dataSV;                 /* data we have read from layer below */
  47     SV *enc;                    /* the encoding object */
  48 } PerlIOEncode;
  49
  50 SV *
  51 PerlIOEncode_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
  52 {
  53     PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
  54     SV *sv = &PL_sv_undef;
  55     if (e->enc) {
  56         dSP;
  57         ENTER;
  58         SAVETMPS;
  59         PUSHMARK(sp);
  60         XPUSHs(e->enc);
  61         PUTBACK;
  62         if (perl_call_method("name", G_SCALAR) == 1) {
  63             SPAGAIN;
  64             sv = newSVsv(POPs);
  65             PUTBACK;
  66         }
  67     }
  68     return sv;
  69 }
  70
  71 IV
  72 PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg)
  73 {
  74     PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
  75     dSP;
  76     IV code;
  77     code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv);
  78     ENTER;
  79     SAVETMPS;
  80     PUSHMARK(sp);
  81     XPUSHs(arg);
  82     PUTBACK;
  83     if (perl_call_pv("Encode::find_encoding", G_SCALAR) != 1) {
  84         /* should never happen */
  85         Perl_die(aTHX_ "Encode::find_encoding did not return a value");
  86         return -1;
  87     }
  88     SPAGAIN;
  89     e->enc = POPs;
  90     PUTBACK;
  91     if (!SvROK(e->enc)) {
  92         e->enc = Nullsv;
  93         errno = EINVAL;
  94         Perl_warner(aTHX_ WARN_IO, "Cannot find encoding \"%" SVf "\"",
  95                     arg);
  96         code = -1;
  97     }
  98     else {
  99         SvREFCNT_inc(e->enc);
 100         PerlIOBase(f)->flags |= PERLIO_F_UTF8;
 101     }
 102     FREETMPS;
 103     LEAVE;
 104     return code;
 105 }
 106
 107 IV
 108 PerlIOEncode_popped(pTHX_ PerlIO * f)
 109 {
 110     PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
 111     if (e->enc) {
 112         SvREFCNT_dec(e->enc);
 113         e->enc = Nullsv;
 114     }
 115     if (e->bufsv) {
 116         SvREFCNT_dec(e->bufsv);
 117         e->bufsv = Nullsv;
 118     }
 119     if (e->dataSV) {
 120         SvREFCNT_dec(e->dataSV);
 121         e->bufsv = Nullsv;
 122     }
 123     return 0;
 124 }
 125
 126 STDCHAR *
 127 PerlIOEncode_get_base(pTHX_ PerlIO * f)
 128 {
 129     PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
 130     if (!e->base.bufsiz)
 131         e->base.bufsiz = 1024;
 132     if (!e->bufsv) {
 133         e->bufsv = newSV(e->base.bufsiz);
 134         sv_setpvn(e->bufsv, "", 0);
 135     }
 136     e->base.buf = (STDCHAR *) SvPVX(e->bufsv);
 137     if (!e->base.ptr)
 138         e->base.ptr = e->base.buf;
 139     if (!e->base.end)
 140         e->base.end = e->base.buf;
 141     if (e->base.ptr < e->base.buf
 142         || e->base.ptr > e->base.buf + SvLEN(e->bufsv)) {
 143         Perl_warn(aTHX_ " ptr %p(%p)%p", e->base.buf, e->base.ptr,
 144                   e->base.buf + SvLEN(e->bufsv));
 145         abort();
 146     }
 147     if (SvLEN(e->bufsv) < e->base.bufsiz) {
 148         SSize_t poff = e->base.ptr - e->base.buf;
 149         SSize_t eoff = e->base.end - e->base.buf;
 150         e->base.buf = (STDCHAR *) SvGROW(e->bufsv, e->base.bufsiz);
 151         e->base.ptr = e->base.buf + poff;
 152         e->base.end = e->base.buf + eoff;
 153     }
 154     if (e->base.ptr < e->base.buf
 155         || e->base.ptr > e->base.buf + SvLEN(e->bufsv)) {
 156         Perl_warn(aTHX_ " ptr %p(%p)%p", e->base.buf, e->base.ptr,
 157                   e->base.buf + SvLEN(e->bufsv));
 158         abort();
 159     }
 160     return e->base.buf;
 161 }
 162
 163 IV
 164 PerlIOEncode_fill(pTHX_ PerlIO * f)
 165 {
 166     PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
 167     dSP;
 168     IV code = 0;
 169     PerlIO *n;
 170     SSize_t avail;
 171     if (PerlIO_flush(f) != 0)
 172         return -1;
 173     n  = PerlIONext(f);
 174     if (!PerlIO_fast_gets(n)) {
 175         /* Things get too messy if we don't have a buffer layer
 176            push a :perlio to do the job */
 177         char mode[8];
 178         n  = PerlIO_push(aTHX_ n, &PerlIO_perlio, PerlIO_modestr(f,mode), Nullsv);
 179         if (!n) {
 180             Perl_die(aTHX_ "panic: cannot push :perlio for %p",f);
 181         }
 182     }
 183     ENTER;
 184     SAVETMPS;
 185   retry:
 186     avail = PerlIO_get_cnt(n);
 187     if (avail <= 0) {
 188         avail = PerlIO_fill(n);
 189         if (avail == 0) {
 190             avail = PerlIO_get_cnt(n);
 191         }
 192         else {
 193             if (!PerlIO_error(n) && PerlIO_eof(n))
 194                 avail = 0;
 195         }
 196     }
 197     if (avail > 0) {
 198         STDCHAR *ptr = PerlIO_get_ptr(n);
 199         SSize_t use  = avail;
 200         SV *uni;
 201         char *s;
 202         STRLEN len = 0;
 203         e->base.ptr = e->base.end = (STDCHAR *) Nullch;
 204         (void) PerlIOEncode_get_base(aTHX_ f);
 205         if (!e->dataSV)
 206             e->dataSV = newSV(0);
 207         if (SvTYPE(e->dataSV) < SVt_PV) {
 208             sv_upgrade(e->dataSV,SVt_PV);
 209         }
 210         if (SvCUR(e->dataSV)) {
 211             /* something left over from last time - create a normal
 212                SV with new data appended
 213              */
 214             if (use + SvCUR(e->dataSV) > e->base.bufsiz) {
 215                use = e->base.bufsiz - SvCUR(e->dataSV);
 216             }
 217             sv_catpvn(e->dataSV,ptr,use);
 218         }
 219         else {
 220             /* Create a "dummy" SV to represent the available data from layer below */
 221             if (SvLEN(e->dataSV) && SvPVX(e->dataSV)) {
 222                 Safefree(SvPVX(e->dataSV));
 223             }
 224             if (use > e->base.bufsiz) {
 225                use = e->base.bufsiz;
 226             }
 227             SvPVX(e->dataSV) = (char *) ptr;
 228             SvLEN(e->dataSV) = 0;  /* Hands off sv.c - it isn't yours */
 229             SvCUR_set(e->dataSV,use);
 230             SvPOK_on(e->dataSV);
 231         }
 232         SvUTF8_off(e->dataSV);
 233         PUSHMARK(sp);
 234         XPUSHs(e->enc);
 235         XPUSHs(e->dataSV);
 236         XPUSHs(&PL_sv_yes);
 237         PUTBACK;
 238         if (perl_call_method("decode", G_SCALAR) != 1) {
 239             Perl_die(aTHX_ "panic: decode did not return a value");
 240         }
 241         SPAGAIN;
 242         uni = POPs;
 243         PUTBACK;
 244         /* Now get translated string (forced to UTF-8) and use as buffer */
 245         if (SvPOK(uni)) {
 246             s = SvPVutf8(uni, len);
 247             if (len && !is_utf8_string(s,len)) {
 248                 Perl_warn(aTHX_ "panic: decode did not return UTF-8 '%.*s'",(int) len,s);
 249             }
 250         }
 251         if (len > 0) {
 252             /* Got _something */
 253             /* if decode gave us back dataSV then data may vanish when
 254                we do ptrcnt adjust - so take our copy now.
 255                (The copy is a pain - need a put-it-here option for decode.)
 256              */
 257             sv_setpvn(e->bufsv,s,len);
 258             e->base.ptr = e->base.buf = SvPVX(e->bufsv);
 259             e->base.end = e->base.ptr + SvCUR(e->bufsv);
 260             PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
 261             SvUTF8_on(e->bufsv);
 262
 263             /* Adjust ptr/cnt not taking anything which
 264                did not translate - not clear this is a win */
 265             /* compute amount we took */
 266             use -= SvCUR(e->dataSV);
 267             PerlIO_set_ptrcnt(n, ptr+use, (avail-use));
 268             /* and as we did not take it it isn't pending */
 269             SvCUR_set(e->dataSV,0);
 270         } else {
 271             /* Got nothing - assume partial character so we need some more */
 272             /* Make sure e->dataSV is a normal SV before re-filling as
 273                buffer alias will change under us
 274              */
 275             s = SvPV(e->dataSV,len);
 276             sv_setpvn(e->dataSV,s,len);
 277             PerlIO_set_ptrcnt(n, ptr+use, (avail-use));
 278             goto retry;
 279         }
 280         FREETMPS;
 281         LEAVE;
 282         return code;
 283     }
 284     else {
 285         if (avail == 0)
 286             PerlIOBase(f)->flags |= PERLIO_F_EOF;
 287         else
 288             PerlIOBase(f)->flags |= PERLIO_F_ERROR;
 289         return -1;
 290     }
 291 }
 292
 293 IV
 294 PerlIOEncode_flush(pTHX_ PerlIO * f)
 295 {
 296     PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
 297     IV code = 0;
 298     if (e->bufsv && (e->base.ptr > e->base.buf)) {
 299         dSP;
 300         SV *str;
 301         char *s;
 302         STRLEN len;
 303         SSize_t count = 0;
 304         if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
 305             /* Write case encode the buffer and write() to layer below */
 306             ENTER;
 307             SAVETMPS;
 308             PUSHMARK(sp);
 309             XPUSHs(e->enc);
 310             SvCUR_set(e->bufsv, e->base.ptr - e->base.buf);
 311             SvUTF8_on(e->bufsv);
 312 #if 0
 313             Perl_warn(aTHX_ "flush %_",e->bufsv);
 314 #endif
 315             XPUSHs(e->bufsv);
 316             XPUSHs(&PL_sv_yes);
 317             PUTBACK;
 318             if (perl_call_method("encode", G_SCALAR) != 1)
 319                 code = -1;
 320             SPAGAIN;
 321             str = POPs;
 322             PUTBACK;
 323             s = SvPV(str, len);
 324             count = PerlIO_write(PerlIONext(f),s,len);
 325             if (count != len) {
 326                 code = -1;
 327             }
 328             FREETMPS;
 329             LEAVE;
 330             if (PerlIO_flush(PerlIONext(f)) != 0) {
 331                 code = -1;
 332             }
 333         }
 334         else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
 335             /* read case */
 336             /* if we have any untranslated stuff then unread that first */
 337             if (e->dataSV && SvCUR(e->dataSV)) {
 338                 s = SvPV(e->dataSV, len);
 339                 count = PerlIO_unread(PerlIONext(f),s,len);
 340                 if (count != len) {
 341                     code = -1;
 342                 }
 343             }
 344             /* See if there is anything left in the buffer */
 345             if (e->base.ptr < e->base.end) {
 346                 /* Bother - have unread data.
 347                    re-encode and unread() to layer below
 348                  */
 349                 ENTER;
 350                 SAVETMPS;
 351                 str = sv_newmortal();
 352                 sv_upgrade(str, SVt_PV);
 353                 SvPVX(str) = e->base.ptr;
 354                 SvLEN(str) = 0;
 355                 SvCUR_set(str, e->base.end - e->base.ptr);
 356                 SvUTF8_on(str);
 357                 PUSHMARK(sp);
 358                 XPUSHs(e->enc);
 359                 XPUSHs(str);
 360                 XPUSHs(&PL_sv_yes);
 361                 PUTBACK;
 362                 if (perl_call_method("encode", G_SCALAR) != 1)
 363                     code = -1;
 364                 SPAGAIN;
 365                 str = POPs;
 366                 PUTBACK;
 367                 s = SvPV(str, len);
 368                 count = PerlIO_unread(PerlIONext(f),s,len);
 369                 if (count != len) {
 370                     code = -1;
 371                 }
 372                 FREETMPS;
 373                 LEAVE;
 374             }
 375         }
 376         e->base.ptr = e->base.end = e->base.buf;
 377         PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
 378     }
 379     return code;
 380 }
 381
 382 IV
 383 PerlIOEncode_close(pTHX_ PerlIO * f)
 384 {
 385     PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
 386     IV code = PerlIOBase_close(aTHX_ f);
 387     if (e->bufsv) {
 388         SvREFCNT_dec(e->bufsv);
 389         e->bufsv = Nullsv;
 390     }
 391     e->base.buf = NULL;
 392     e->base.ptr = NULL;
 393     e->base.end = NULL;
 394     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
 395     return code;
 396 }
 397
 398 Off_t
 399 PerlIOEncode_tell(pTHX_ PerlIO * f)
 400 {
 401     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
 402     /* Unfortunately the only way to get a postion is to (re-)translate,
 403        the UTF8 we have in bufefr and then ask layer below
 404      */
 405     PerlIO_flush(f);
 406     return PerlIO_tell(PerlIONext(f));
 407 }
 408
 409 PerlIO *
 410 PerlIOEncode_dup(pTHX_ PerlIO * f, PerlIO * o,
 411                  CLONE_PARAMS * params, int flags)
 412 {
 413     if ((f = PerlIOBase_dup(aTHX_ f, o, params, flags))) {
 414         PerlIOEncode *fe = PerlIOSelf(f, PerlIOEncode);
 415         PerlIOEncode *oe = PerlIOSelf(o, PerlIOEncode);
 416         if (oe->enc) {
 417             fe->enc = PerlIO_sv_dup(aTHX_ oe->enc, params);
 418         }
 419     }
 420     return f;
 421 }
 422
 423 PerlIO_funcs PerlIO_encode = {
 424     "encoding",
 425     sizeof(PerlIOEncode),
 426     PERLIO_K_BUFFERED,
 427     PerlIOEncode_pushed,
 428     PerlIOEncode_popped,
 429     PerlIOBuf_open,
 430     PerlIOEncode_getarg,
 431     PerlIOBase_fileno,
 432     PerlIOEncode_dup,
 433     PerlIOBuf_read,
 434     PerlIOBuf_unread,
 435     PerlIOBuf_write,
 436     PerlIOBuf_seek,
 437     PerlIOEncode_tell,
 438     PerlIOEncode_close,
 439     PerlIOEncode_flush,
 440     PerlIOEncode_fill,
 441     PerlIOBase_eof,
 442     PerlIOBase_error,
 443     PerlIOBase_clearerr,
 444     PerlIOBase_setlinebuf,
 445     PerlIOEncode_get_base,
 446     PerlIOBuf_bufsiz,
 447     PerlIOBuf_get_ptr,
 448     PerlIOBuf_get_cnt,
 449     PerlIOBuf_set_ptrcnt,
 450 };
 451 #endif                          /* encode layer */
 452
 453 void
 454 Encode_XSEncoding(pTHX_ encode_t * enc)
 455 {
 456     dSP;
 457     HV *stash = gv_stashpv("Encode::XS", TRUE);
 458     SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(enc))), stash);
 459     int i = 0;
 460     PUSHMARK(sp);
 461     XPUSHs(sv);
 462     while (enc->name[i]) {
 463         const char *name = enc->name[i++];
 464         XPUSHs(sv_2mortal(newSVpvn(name, strlen(name))));
 465     }
 466     PUTBACK;
 467     call_pv("Encode::define_encoding", G_DISCARD);
 468     SvREFCNT_dec(sv);
 469 }
 470
 471 void
 472 call_failure(SV * routine, U8 * done, U8 * dest, U8 * orig)
 473 {
 474 }
 475
 476 static SV *
 477 encode_method(pTHX_ encode_t * enc, encpage_t * dir, SV * src,
 478                          int check)
 479 {
 480     STRLEN slen;
 481     U8 *s = (U8 *) SvPV(src, slen);
 482     STRLEN tlen = slen;
 483     SV *dst = sv_2mortal(newSV(slen+1));
 484     if (slen) {
 485         U8 *d = (U8 *) SvPVX(dst);
 486         STRLEN dlen = SvLEN(dst)-1;
 487         int code;
 488         while ((code = do_encode(dir, s, &slen, d, dlen, &dlen, !check))) {
 489             SvCUR_set(dst, dlen);
 490             SvPOK_on(dst);
 491
 492 #if 0
 493             Perl_warn(aTHX_ "code=%d @ s=%d/%d d=%d",code,slen,tlen,dlen);
 494 #endif
 495
 496             if (code == ENCODE_FALLBACK || code == ENCODE_PARTIAL)
 497                 break;
 498
 499             switch (code) {
 500             case ENCODE_NOSPACE:
 501                 {
 502                     STRLEN done = tlen-slen;
 503                     STRLEN need ;
 504                     if (done) {
 505                         need = (tlen*dlen)/done+1;
 506                     }
 507                     else {
 508                         need = dlen + UTF8_MAXLEN;
 509                     }
 510
 511                     d = (U8 *) SvGROW(dst, need);
 512                     if (dlen >= SvLEN(dst)) {
 513                         Perl_croak(aTHX_
 514                                    "Destination couldn't be grown (the need may be miscalculated).");
 515                     }
 516                     dlen = SvLEN(dst);
 517                     slen = tlen;
 518                     break;
 519                 }
 520
 521             case ENCODE_NOREP:
 522                 if (dir == enc->f_utf8) {
 523                     if (!check && ckWARN_d(WARN_UTF8)) {
 524                         STRLEN clen;
 525                         UV ch =
 526                             utf8n_to_uvuni(s + slen, (SvCUR(src) - slen),
 527                                            &clen, 0);
 528                         Perl_warner(aTHX_ WARN_UTF8,
 529                                     "\"\\N{U+%" UVxf
 530                                     "}\" does not map to %s", ch,
 531                                     enc->name[0]);
 532                         /* FIXME: Skip over the character, copy in replacement and continue
 533                          * but that is messy so for now just fail.
 534                          */
 535                         return &PL_sv_undef;
 536                     }
 537                     else {
 538                         return &PL_sv_undef;
 539                     }
 540                 }
 541                 else {
 542                     /* UTF-8 is supposed to be "Universal" so should not happen */
 543                     Perl_croak(aTHX_ "%s '%.*s' does not map to UTF-8",
 544                                enc->name[0], (int) (SvCUR(src) - slen),
 545                                s + slen);
 546                 }
 547                 break;
 548
 549             default:
 550                 Perl_croak(aTHX_ "Unexpected code %d converting %s %s",
 551                            code, (dir == enc->f_utf8) ? "to" : "from",
 552                            enc->name[0]);
 553                 return &PL_sv_undef;
 554             }
 555         }
 556         SvCUR_set(dst, dlen);
 557         SvPOK_on(dst);
 558         if (check) {
 559             if (slen < SvCUR(src)) {
 560                 Move(s + slen, s, SvCUR(src) - slen, U8);
 561             }
 562             SvCUR_set(src, SvCUR(src) - slen);
 563             *SvEND(src) = '\0';
 564         }
 565     }
 566     else {
 567         SvCUR_set(dst, 0);
 568         SvPOK_on(dst);
 569     }
 570     *SvEND(dst) = '\0';
 571     return dst;
 572 }
 573
 574 MODULE = Encode         PACKAGE = Encode::XS    PREFIX = Method_
 575
 576 PROTOTYPES: ENABLE
 577
 578 void
 579 Method_decode(obj,src,check = FALSE)
 580 SV *    obj
 581 SV *    src
 582 bool    check
 583 CODE:
 584  {
 585   encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
 586   ST(0) = encode_method(aTHX_ enc, enc->t_utf8, src, check);
 587   SvUTF8_on(ST(0));
 588   XSRETURN(1);
 589  }
 590
 591 void
 592 Method_encode(obj,src,check = FALSE)
 593 SV *    obj
 594 SV *    src
 595 bool    check
 596 CODE:
 597  {
 598   encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
 599   sv_utf8_upgrade(src);
 600   ST(0) = encode_method(aTHX_ enc, enc->f_utf8, src, check);
 601   XSRETURN(1);
 602  }
 603
 604 MODULE = Encode         PACKAGE = Encode
 605
 606 PROTOTYPES: ENABLE
 607
 608 I32
 609 _bytes_to_utf8(sv, ...)
 610         SV *    sv
 611       CODE:
 612         {
 613           SV * encoding = items == 2 ? ST(1) : Nullsv;
 614
 615           if (encoding)
 616             RETVAL = _encoded_bytes_to_utf8(sv, SvPV_nolen(encoding));
 617           else {
 618             STRLEN len;
 619             U8*    s = (U8*)SvPV(sv, len);
 620             U8*    converted;
 621
 622             converted = bytes_to_utf8(s, &len); /* This allocs */
 623             sv_setpvn(sv, (char *)converted, len);
 624             SvUTF8_on(sv); /* XXX Should we? */
 625             Safefree(converted);                /* ... so free it */
 626             RETVAL = len;
 627           }
 628         }
 629       OUTPUT:
 630         RETVAL
 631
 632 I32
 633 _utf8_to_bytes(sv, ...)
 634         SV *    sv
 635       CODE:
 636         {
 637           SV * to    = items > 1 ? ST(1) : Nullsv;
 638           SV * check = items > 2 ? ST(2) : Nullsv;
 639
 640           if (to)
 641             RETVAL = _encoded_utf8_to_bytes(sv, SvPV_nolen(to));
 642           else {
 643             STRLEN len;
 644             U8 *s = (U8*)SvPV(sv, len);
 645
 646             RETVAL = 0;
 647             if (SvTRUE(check)) {
 648               /* Must do things the slow way */
 649               U8 *dest;
 650               U8 *src  = (U8*)savepv((char *)s); /* We need a copy to pass to check() */
 651               U8 *send = s + len;
 652
 653               New(83, dest, len, U8); /* I think */
 654
 655               while (s < send) {
 656                 if (*s < 0x80)
 657                   *dest++ = *s++;
 658                 else {
 659                   STRLEN ulen;
 660                   UV uv = *s++;
 661
 662                   /* Have to do it all ourselves because of error routine,
 663                      aargh. */
 664                   if (!(uv & 0x40))
 665                     goto failure;
 666                   if      (!(uv & 0x20)) { ulen = 2;  uv &= 0x1f; }
 667                   else if (!(uv & 0x10)) { ulen = 3;  uv &= 0x0f; }
 668                   else if (!(uv & 0x08)) { ulen = 4;  uv &= 0x07; }
 669                   else if (!(uv & 0x04)) { ulen = 5;  uv &= 0x03; }
 670                   else if (!(uv & 0x02)) { ulen = 6;  uv &= 0x01; }
 671                   else if (!(uv & 0x01)) { ulen = 7;  uv = 0; }
 672                   else                   { ulen = 13; uv = 0; }
 673
 674                   /* Note change to utf8.c variable naming, for variety */
 675                   while (ulen--) {
 676                     if ((*s & 0xc0) != 0x80)
 677                       goto failure;
 678
 679                     else
 680                       uv = (uv << 6) | (*s++ & 0x3f);
 681                   }
 682                   if (uv > 256) {
 683                   failure:
 684                     call_failure(check, s, dest, src);
 685                     /* Now what happens? */
 686                   }
 687                   *dest++ = (U8)uv;
 688                }
 689                }
 690             } else
 691               RETVAL = (utf8_to_bytes(s, &len) ? len : 0);
 692           }
 693         }
 694       OUTPUT:
 695         RETVAL
 696
 697 bool
 698 is_utf8(sv, check = FALSE)
 699 SV *    sv
 700 bool    check
 701       CODE:
 702         {
 703           if (SvGMAGICAL(sv)) /* it could be $1, for example */
 704             sv = newSVsv(sv); /* GMAGIG will be done */
 705           if (SvPOK(sv)) {
 706             RETVAL = SvUTF8(sv) ? TRUE : FALSE;
 707             if (RETVAL &&
 708                 check  &&
 709                 !is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
 710               RETVAL = FALSE;
 711           } else {
 712             RETVAL = FALSE;
 713           }
 714           if (sv != ST(0))
 715             SvREFCNT_dec(sv); /* it was a temp copy */
 716         }
 717       OUTPUT:
 718         RETVAL
 719
 720 SV *
 721 _utf8_on(sv)
 722         SV *    sv
 723       CODE:
 724         {
 725           if (SvPOK(sv)) {
 726             SV *rsv = newSViv(SvUTF8(sv));
 727             RETVAL = rsv;
 728             SvUTF8_on(sv);
 729           } else {
 730             RETVAL = &PL_sv_undef;
 731           }
 732         }
 733       OUTPUT:
 734         RETVAL
 735
 736 SV *
 737 _utf8_off(sv)
 738         SV *    sv
 739       CODE:
 740         {
 741           if (SvPOK(sv)) {
 742             SV *rsv = newSViv(SvUTF8(sv));
 743             RETVAL = rsv;
 744             SvUTF8_off(sv);
 745           } else {
 746             RETVAL = &PL_sv_undef;
 747           }
 748         }
 749       OUTPUT:
 750         RETVAL
 751
 752 BOOT:
 753 {
 754 #if defined(USE_PERLIO) && !defined(USE_SFIO)
 755  PerlIO_define_layer(aTHX_ &PerlIO_encode);
 756 #endif
 757 #include "8859_def.h"
 758 #include "EBCDIC_def.h"
 759 #include "Symbols_def.h"
 760 }