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