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             XPUSHs(e->bufsv);
 313             XPUSHs(&PL_sv_yes);
 314             PUTBACK;
 315             if (perl_call_method("encode", G_SCALAR) != 1) {
 316                 Perl_die(aTHX_ "panic: encode did not return a value");
 317             }
 318             SPAGAIN;
 319             str = POPs;
 320             PUTBACK;
 321             s = SvPV(str, len);
 322             count = PerlIO_write(PerlIONext(f),s,len);
 323             if (count != len) {
 324                 code = -1;
 325             }
 326             FREETMPS;
 327             LEAVE;
 328             if (PerlIO_flush(PerlIONext(f)) != 0) {
 329                 code = -1;
 330             }
 331         }
 332         else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
 333             /* read case */
 334             /* if we have any untranslated stuff then unread that first */
 335             if (e->dataSV && SvCUR(e->dataSV)) {
 336                 s = SvPV(e->dataSV, len);
 337                 count = PerlIO_unread(PerlIONext(f),s,len);
 338                 if (count != len) {
 339                     code = -1;
 340                 }
 341             }
 342             /* See if there is anything left in the buffer */
 343             if (e->base.ptr < e->base.end) {
 344                 /* Bother - have unread data.
 345                    re-encode and unread() to layer below
 346                  */
 347                 ENTER;
 348                 SAVETMPS;
 349                 str = sv_newmortal();
 350                 sv_upgrade(str, SVt_PV);
 351                 SvPVX(str) = e->base.ptr;
 352                 SvLEN(str) = 0;
 353                 SvCUR_set(str, e->base.end - e->base.ptr);
 354                 SvUTF8_on(str);
 355                 PUSHMARK(sp);
 356                 XPUSHs(e->enc);
 357                 XPUSHs(str);
 358                 XPUSHs(&PL_sv_yes);
 359                 PUTBACK;
 360                 if (perl_call_method("encode", G_SCALAR) != 1) {
 361                      Perl_die(aTHX_ "panic: encode did not return a value");
 362                 }
 363                 SPAGAIN;
 364                 str = POPs;
 365                 PUTBACK;
 366                 s = SvPV(str, len);
 367                 count = PerlIO_unread(PerlIONext(f),s,len);
 368                 if (count != len) {
 369                     code = -1;
 370                 }
 371                 FREETMPS;
 372                 LEAVE;
 373             }
 374         }
 375         e->base.ptr = e->base.end = e->base.buf;
 376         PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
 377     }
 378     return code;
 379 }
 380
 381 IV
 382 PerlIOEncode_close(pTHX_ PerlIO * f)
 383 {
 384     PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
 385     IV code = PerlIOBase_close(aTHX_ f);
 386     if (e->bufsv) {
 387         SvREFCNT_dec(e->bufsv);
 388         e->bufsv = Nullsv;
 389     }
 390     e->base.buf = NULL;
 391     e->base.ptr = NULL;
 392     e->base.end = NULL;
 393     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
 394     return code;
 395 }
 396
 397 Off_t
 398 PerlIOEncode_tell(pTHX_ PerlIO * f)
 399 {
 400     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
 401     /* Unfortunately the only way to get a postion is to (re-)translate,
 402        the UTF8 we have in bufefr and then ask layer below
 403      */
 404     PerlIO_flush(f);
 405     return PerlIO_tell(PerlIONext(f));
 406 }
 407
 408 PerlIO *
 409 PerlIOEncode_dup(pTHX_ PerlIO * f, PerlIO * o,
 410                  CLONE_PARAMS * params, int flags)
 411 {
 412     if ((f = PerlIOBase_dup(aTHX_ f, o, params, flags))) {
 413         PerlIOEncode *fe = PerlIOSelf(f, PerlIOEncode);
 414         PerlIOEncode *oe = PerlIOSelf(o, PerlIOEncode);
 415         if (oe->enc) {
 416             fe->enc = PerlIO_sv_dup(aTHX_ oe->enc, params);
 417         }
 418     }
 419     return f;
 420 }
 421
 422 PerlIO_funcs PerlIO_encode = {
 423     "encoding",
 424     sizeof(PerlIOEncode),
 425     PERLIO_K_BUFFERED,
 426     PerlIOEncode_pushed,
 427     PerlIOEncode_popped,
 428     PerlIOBuf_open,
 429     PerlIOEncode_getarg,
 430     PerlIOBase_fileno,
 431     PerlIOEncode_dup,
 432     PerlIOBuf_read,
 433     PerlIOBuf_unread,
 434     PerlIOBuf_write,
 435     PerlIOBuf_seek,
 436     PerlIOEncode_tell,
 437     PerlIOEncode_close,
 438     PerlIOEncode_flush,
 439     PerlIOEncode_fill,
 440     PerlIOBase_eof,
 441     PerlIOBase_error,
 442     PerlIOBase_clearerr,
 443     PerlIOBase_setlinebuf,
 444     PerlIOEncode_get_base,
 445     PerlIOBuf_bufsiz,
 446     PerlIOBuf_get_ptr,
 447     PerlIOBuf_get_cnt,
 448     PerlIOBuf_set_ptrcnt,
 449 };
 450 #endif                          /* encode layer */
 451
 452 void
 453 Encode_XSEncoding(pTHX_ encode_t * enc)
 454 {
 455     dSP;
 456     HV *stash = gv_stashpv("Encode::XS", TRUE);
 457     SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(enc))), stash);
 458     int i = 0;
 459     PUSHMARK(sp);
 460     XPUSHs(sv);
 461     while (enc->name[i]) {
 462         const char *name = enc->name[i++];
 463         XPUSHs(sv_2mortal(newSVpvn(name, strlen(name))));
 464     }
 465     PUTBACK;
 466     call_pv("Encode::define_encoding", G_DISCARD);
 467     SvREFCNT_dec(sv);
 468 }
 469
 470 void
 471 call_failure(SV * routine, U8 * done, U8 * dest, U8 * orig)
 472 {
 473 }
 474
 475 static SV *
 476 encode_method(pTHX_ encode_t * enc, encpage_t * dir, SV * src,
 477                          int check)
 478 {
 479     STRLEN slen;
 480     U8 *s = (U8 *) SvPV(src, slen);
 481     STRLEN tlen  = slen;
 482     STRLEN ddone = 0;
 483     STRLEN sdone = 0;
 484     SV *dst = sv_2mortal(newSV(slen+1));
 485     if (slen) {
 486         U8 *d = (U8 *) SvPVX(dst);
 487         STRLEN dlen = SvLEN(dst)-1;
 488         int code;
 489         while ((code = do_encode(dir, s, &slen, d, dlen, &dlen, !check))) {
 490             SvCUR_set(dst, dlen+ddone);
 491             SvPOK_on(dst);
 492
 493 #if 0
 494             Perl_warn(aTHX_ "code=%d @ s=%d/%d/%d d=%d/%d/%d",code,slen,sdone,tlen,dlen,ddone,SvLEN(dst)-1);
 495 #endif
 496
 497             if (code == ENCODE_FALLBACK || code == ENCODE_PARTIAL)
 498                 break;
 499
 500             switch (code) {
 501             case ENCODE_NOSPACE:
 502                 {
 503                     STRLEN need ;
 504                     sdone += slen;
 505                     ddone += dlen;
 506                     if (sdone) {
 507                         need = (tlen*SvLEN(dst)+sdone-1)/sdone+UTF8_MAXLEN;
 508                     }
 509                     else {
 510                         need = SvLEN(dst) + UTF8_MAXLEN;
 511                     }
 512
 513                     d = (U8 *) SvGROW(dst, need);
 514                     if (ddone >= SvLEN(dst)) {
 515                         Perl_croak(aTHX_ "Destination couldn't be grown.");
 516                     }
 517                     dlen = SvLEN(dst)-ddone-1;
 518                     d   += ddone;
 519                     s   += slen;
 520                     slen = tlen-sdone;
 521                     continue;
 522                 }
 523
 524             case ENCODE_NOREP:
 525                 if (dir == enc->f_utf8) {
 526                     if (!check && ckWARN_d(WARN_UTF8)) {
 527                         STRLEN clen;
 528                         UV ch =
 529                             utf8n_to_uvuni(s + slen, (SvCUR(src) - slen),
 530                                            &clen, 0);
 531                         Perl_warner(aTHX_ WARN_UTF8,
 532                                     "\"\\N{U+%" UVxf
 533                                     "}\" does not map to %s", ch,
 534                                     enc->name[0]);
 535                         /* FIXME: Skip over the character, copy in replacement and continue
 536                          * but that is messy so for now just fail.
 537                          */
 538                         return &PL_sv_undef;
 539                     }
 540                     else {
 541                         return &PL_sv_undef;
 542                     }
 543                 }
 544                 else {
 545                     /* UTF-8 is supposed to be "Universal" so should not happen */
 546                     Perl_croak(aTHX_ "%s '%.*s' does not map to UTF-8",
 547                                enc->name[0], (int) (SvCUR(src) - slen),
 548                                s + slen);
 549                 }
 550                 break;
 551
 552             default:
 553                 Perl_croak(aTHX_ "Unexpected code %d converting %s %s",
 554                            code, (dir == enc->f_utf8) ? "to" : "from",
 555                            enc->name[0]);
 556                 return &PL_sv_undef;
 557             }
 558         }
 559         SvCUR_set(dst, dlen+ddone);
 560         SvPOK_on(dst);
 561         if (check) {
 562             sdone = SvCUR(src) - (slen+sdone);
 563             if (sdone) {
 564                 Move(s + slen, SvPVX(src), sdone , U8);
 565             }
 566             SvCUR_set(src, sdone);
 567             *SvEND(src) = '\0';
 568         }
 569     }
 570     else {
 571         SvCUR_set(dst, 0);
 572         SvPOK_on(dst);
 573     }
 574     *SvEND(dst) = '\0';
 575     return dst;
 576 }
 577
 578 MODULE = Encode         PACKAGE = Encode::XS    PREFIX = Method_
 579
 580 PROTOTYPES: ENABLE
 581
 582 void
 583 Method_decode(obj,src,check = FALSE)
 584 SV *    obj
 585 SV *    src
 586 bool    check
 587 CODE:
 588  {
 589   encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
 590   ST(0) = encode_method(aTHX_ enc, enc->t_utf8, src, check);
 591   SvUTF8_on(ST(0));
 592   XSRETURN(1);
 593  }
 594
 595 void
 596 Method_encode(obj,src,check = FALSE)
 597 SV *    obj
 598 SV *    src
 599 bool    check
 600 CODE:
 601  {
 602   encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
 603   sv_utf8_upgrade(src);
 604   ST(0) = encode_method(aTHX_ enc, enc->f_utf8, src, check);
 605   XSRETURN(1);
 606  }
 607
 608 MODULE = Encode         PACKAGE = Encode
 609
 610 PROTOTYPES: ENABLE
 611
 612 I32
 613 _bytes_to_utf8(sv, ...)
 614         SV *    sv
 615       CODE:
 616         {
 617           SV * encoding = items == 2 ? ST(1) : Nullsv;
 618
 619           if (encoding)
 620             RETVAL = _encoded_bytes_to_utf8(sv, SvPV_nolen(encoding));
 621           else {
 622             STRLEN len;
 623             U8*    s = (U8*)SvPV(sv, len);
 624             U8*    converted;
 625
 626             converted = bytes_to_utf8(s, &len); /* This allocs */
 627             sv_setpvn(sv, (char *)converted, len);
 628             SvUTF8_on(sv); /* XXX Should we? */
 629             Safefree(converted);                /* ... so free it */
 630             RETVAL = len;
 631           }
 632         }
 633       OUTPUT:
 634         RETVAL
 635
 636 I32
 637 _utf8_to_bytes(sv, ...)
 638         SV *    sv
 639       CODE:
 640         {
 641           SV * to    = items > 1 ? ST(1) : Nullsv;
 642           SV * check = items > 2 ? ST(2) : Nullsv;
 643
 644           if (to)
 645             RETVAL = _encoded_utf8_to_bytes(sv, SvPV_nolen(to));
 646           else {
 647             STRLEN len;
 648             U8 *s = (U8*)SvPV(sv, len);
 649
 650             RETVAL = 0;
 651             if (SvTRUE(check)) {
 652               /* Must do things the slow way */
 653               U8 *dest;
 654               U8 *src  = (U8*)savepv((char *)s); /* We need a copy to pass to check() */
 655               U8 *send = s + len;
 656
 657               New(83, dest, len, U8); /* I think */
 658
 659               while (s < send) {
 660                 if (*s < 0x80)
 661                   *dest++ = *s++;
 662                 else {
 663                   STRLEN ulen;
 664                   UV uv = *s++;
 665
 666                   /* Have to do it all ourselves because of error routine,
 667                      aargh. */
 668                   if (!(uv & 0x40))
 669                     goto failure;
 670                   if      (!(uv & 0x20)) { ulen = 2;  uv &= 0x1f; }
 671                   else if (!(uv & 0x10)) { ulen = 3;  uv &= 0x0f; }
 672                   else if (!(uv & 0x08)) { ulen = 4;  uv &= 0x07; }
 673                   else if (!(uv & 0x04)) { ulen = 5;  uv &= 0x03; }
 674                   else if (!(uv & 0x02)) { ulen = 6;  uv &= 0x01; }
 675                   else if (!(uv & 0x01)) { ulen = 7;  uv = 0; }
 676                   else                   { ulen = 13; uv = 0; }
 677
 678                   /* Note change to utf8.c variable naming, for variety */
 679                   while (ulen--) {
 680                     if ((*s & 0xc0) != 0x80)
 681                       goto failure;
 682
 683                     else
 684                       uv = (uv << 6) | (*s++ & 0x3f);
 685                   }
 686                   if (uv > 256) {
 687                   failure:
 688                     call_failure(check, s, dest, src);
 689                     /* Now what happens? */
 690                   }
 691                   *dest++ = (U8)uv;
 692                }
 693                }
 694             } else
 695               RETVAL = (utf8_to_bytes(s, &len) ? len : 0);
 696           }
 697         }
 698       OUTPUT:
 699         RETVAL
 700
 701 bool
 702 is_utf8(sv, check = FALSE)
 703 SV *    sv
 704 bool    check
 705       CODE:
 706         {
 707           if (SvGMAGICAL(sv)) /* it could be $1, for example */
 708             sv = newSVsv(sv); /* GMAGIG will be done */
 709           if (SvPOK(sv)) {
 710             RETVAL = SvUTF8(sv) ? TRUE : FALSE;
 711             if (RETVAL &&
 712                 check  &&
 713                 !is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
 714               RETVAL = FALSE;
 715           } else {
 716             RETVAL = FALSE;
 717           }
 718           if (sv != ST(0))
 719             SvREFCNT_dec(sv); /* it was a temp copy */
 720         }
 721       OUTPUT:
 722         RETVAL
 723
 724 SV *
 725 _utf8_on(sv)
 726         SV *    sv
 727       CODE:
 728         {
 729           if (SvPOK(sv)) {
 730             SV *rsv = newSViv(SvUTF8(sv));
 731             RETVAL = rsv;
 732             SvUTF8_on(sv);
 733           } else {
 734             RETVAL = &PL_sv_undef;
 735           }
 736         }
 737       OUTPUT:
 738         RETVAL
 739
 740 SV *
 741 _utf8_off(sv)
 742         SV *    sv
 743       CODE:
 744         {
 745           if (SvPOK(sv)) {
 746             SV *rsv = newSViv(SvUTF8(sv));
 747             RETVAL = rsv;
 748             SvUTF8_off(sv);
 749           } else {
 750             RETVAL = &PL_sv_undef;
 751           }
 752         }
 753       OUTPUT:
 754         RETVAL
 755
 756 BOOT:
 757 {
 758 #if defined(USE_PERLIO) && !defined(USE_SFIO)
 759  PerlIO_define_layer(aTHX_ &PerlIO_encode);
 760 #endif
 761 #include "8859_def.h"
 762 #include "EBCDIC_def.h"
 763 #include "Symbols_def.h"
 764 }