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