ext/Encode/Encode.xs

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