cpan/Encode/Encode.xs

   1 /*
   2  $Id: Encode.xs,v 2.17 2009/11/16 14:08:13 dankogai Exp dankogai $
   3  */
   4
   5 #define PERL_NO_GET_CONTEXT
   6 #include "EXTERN.h"
   7 #include "perl.h"
   8 #include "XSUB.h"
   9 #define U8 U8
  10 #include "encode.h"
  11
  12 # define PERLIO_MODNAME  "PerlIO::encoding"
  13 # define PERLIO_FILENAME "PerlIO/encoding.pm"
  14
  15 /* set 1 or more to profile.  t/encoding.t dumps core because of
  16    Perl_warner and PerlIO don't work well */
  17 #define ENCODE_XS_PROFILE 0
  18
  19 /* set 0 to disable floating point to calculate buffer size for
  20    encode_method().  1 is recommended. 2 restores NI-S original */
  21 #define ENCODE_XS_USEFP   1
  22
  23 #define UNIMPLEMENTED(x,y) y x (SV *sv, char *encoding) {dTHX;   \
  24                          Perl_croak(aTHX_ "panic_unimplemented"); \
  25              return (y)0; /* fool picky compilers */ \
  26                          }
  27 /**/
  28
  29 UNIMPLEMENTED(_encoded_utf8_to_bytes, I32)
  30 UNIMPLEMENTED(_encoded_bytes_to_utf8, I32)
  31
  32 #define UTF8_ALLOW_STRICT 0
  33 #define UTF8_ALLOW_NONSTRICT (UTF8_ALLOW_ANY &                    \
  34                               ~(UTF8_ALLOW_CONTINUATION |         \
  35                                 UTF8_ALLOW_NON_CONTINUATION |     \
  36                                 UTF8_ALLOW_LONG))
  37
  38 void
  39 Encode_XSEncoding(pTHX_ encode_t * enc)
  40 {
  41     dSP;
  42     HV *stash = gv_stashpv("Encode::XS", TRUE);
  43     SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(enc))), stash);
  44     int i = 0;
  45     PUSHMARK(sp);
  46     XPUSHs(sv);
  47     while (enc->name[i]) {
  48     const char *name = enc->name[i++];
  49     XPUSHs(sv_2mortal(newSVpvn(name, strlen(name))));
  50     }
  51     PUTBACK;
  52     call_pv("Encode::define_encoding", G_DISCARD);
  53     SvREFCNT_dec(sv);
  54 }
  55
  56 void
  57 call_failure(SV * routine, U8 * done, U8 * dest, U8 * orig)
  58 {
  59     /* Exists for breakpointing */
  60 }
  61
  62
  63 #define ERR_ENCODE_NOMAP "\"\\x{%04" UVxf "}\" does not map to %s"
  64 #define ERR_DECODE_NOMAP "%s \"\\x%02" UVXf "\" does not map to Unicode"
  65
  66 static SV *
  67 do_fallback_cb(pTHX_ UV ch, SV *fallback_cb)
  68 {
  69     dSP;
  70     int argc;
  71     SV *retval = newSVpv("",0);
  72     ENTER;
  73     SAVETMPS;
  74     PUSHMARK(sp);
  75     XPUSHs(sv_2mortal(newSVnv((UV)ch)));
  76     PUTBACK;
  77     argc = call_sv(fallback_cb, G_SCALAR);
  78     SPAGAIN;
  79     if (argc != 1){
  80         croak("fallback sub must return scalar!");
  81     }
  82     sv_catsv(retval, POPs);
  83     PUTBACK;
  84     FREETMPS;
  85     LEAVE;
  86     return retval;
  87 }
  88
  89 static SV *
  90 encode_method(pTHX_ const encode_t * enc, const encpage_t * dir, SV * src,
  91               int check, STRLEN * offset, SV * term, int * retcode,
  92               SV *fallback_cb)
  93 {
  94     STRLEN slen;
  95     U8 *s = (U8 *) SvPV(src, slen);
  96     STRLEN tlen  = slen;
  97     STRLEN ddone = 0;
  98     STRLEN sdone = 0;
  99
 100     /* We allocate slen+1.
 101        PerlIO dumps core if this value is smaller than this. */
 102     SV *dst = sv_2mortal(newSV(slen+1));
 103     U8 *d = (U8 *)SvPVX(dst);
 104     STRLEN dlen = SvLEN(dst)-1;
 105     int code = 0;
 106     STRLEN trmlen = 0;
 107     U8 *trm = term ? (U8*) SvPV(term, trmlen) : NULL;
 108
 109     if (offset) {
 110       s += *offset;
 111       if (slen > *offset){ /* safeguard against slen overflow */
 112       slen -= *offset;
 113       }else{
 114       slen = 0;
 115       }
 116       tlen = slen;
 117     }
 118
 119     if (slen == 0){
 120     SvCUR_set(dst, 0);
 121     SvPOK_only(dst);
 122     goto ENCODE_END;
 123     }
 124
 125     while( (code = do_encode(dir, s, &slen, d, dlen, &dlen, !check,
 126                  trm, trmlen)) )
 127     {
 128     SvCUR_set(dst, dlen+ddone);
 129     SvPOK_only(dst);
 130
 131     if (code == ENCODE_FALLBACK || code == ENCODE_PARTIAL ||
 132         code == ENCODE_FOUND_TERM) {
 133         break;
 134     }
 135     switch (code) {
 136     case ENCODE_NOSPACE:
 137     {
 138         STRLEN more = 0; /* make sure you initialize! */
 139         STRLEN sleft;
 140         sdone += slen;
 141         ddone += dlen;
 142         sleft = tlen - sdone;
 143 #if ENCODE_XS_PROFILE >= 2
 144         Perl_warn(aTHX_
 145               "more=%d, sdone=%d, sleft=%d, SvLEN(dst)=%d\n",
 146               more, sdone, sleft, SvLEN(dst));
 147 #endif
 148         if (sdone != 0) { /* has src ever been processed ? */
 149 #if   ENCODE_XS_USEFP == 2
 150         more = (1.0*tlen*SvLEN(dst)+sdone-1)/sdone
 151             - SvLEN(dst);
 152 #elif ENCODE_XS_USEFP
 153         more = (STRLEN)((1.0*SvLEN(dst)+1)/sdone * sleft);
 154 #else
 155         /* safe until SvLEN(dst) == MAX_INT/16 */
 156         more = (16*SvLEN(dst)+1)/sdone/16 * sleft;
 157 #endif
 158         }
 159         more += UTF8_MAXLEN; /* insurance policy */
 160         d = (U8 *) SvGROW(dst, SvLEN(dst) + more);
 161         /* dst need to grow need MORE bytes! */
 162         if (ddone >= SvLEN(dst)) {
 163         Perl_croak(aTHX_ "Destination couldn't be grown.");
 164         }
 165         dlen = SvLEN(dst)-ddone-1;
 166         d   += ddone;
 167         s   += slen;
 168         slen = tlen-sdone;
 169         continue;
 170     }
 171     case ENCODE_NOREP:
 172         /* encoding */
 173         if (dir == enc->f_utf8) {
 174         STRLEN clen;
 175         UV ch =
 176             utf8n_to_uvuni(s+slen, (SvCUR(src)-slen),
 177                    &clen, UTF8_ALLOW_ANY|UTF8_CHECK_ONLY);
 178         /* if non-representable multibyte prefix at end of current buffer - break*/
 179         if (clen > tlen - sdone) break;
 180         if (check & ENCODE_DIE_ON_ERR) {
 181             Perl_croak(aTHX_ ERR_ENCODE_NOMAP,
 182                    (UV)ch, enc->name[0]);
 183             return &PL_sv_undef; /* never reaches but be safe */
 184         }
 185         if (check & ENCODE_WARN_ON_ERR){
 186             Perl_warner(aTHX_ packWARN(WARN_UTF8),
 187                 ERR_ENCODE_NOMAP, (UV)ch, enc->name[0]);
 188         }
 189         if (check & ENCODE_RETURN_ON_ERR){
 190             goto ENCODE_SET_SRC;
 191         }
 192         if (check & (ENCODE_PERLQQ|ENCODE_HTMLCREF|ENCODE_XMLCREF)){
 193             SV* subchar =
 194             (fallback_cb != &PL_sv_undef)
 195                 ? do_fallback_cb(aTHX_ ch, fallback_cb)
 196                 : newSVpvf(check & ENCODE_PERLQQ ? "\\x{%04"UVxf"}" :
 197                  check & ENCODE_HTMLCREF ? "&#%" UVuf ";" :
 198                  "&#x%" UVxf ";", (UV)ch);
 199             SvUTF8_off(subchar); /* make sure no decoded string gets in */
 200             sdone += slen + clen;
 201             ddone += dlen + SvCUR(subchar);
 202             sv_catsv(dst, subchar);
 203             SvREFCNT_dec(subchar);
 204         } else {
 205             /* fallback char */
 206             sdone += slen + clen;
 207             ddone += dlen + enc->replen;
 208             sv_catpvn(dst, (char*)enc->rep, enc->replen);
 209         }
 210         }
 211         /* decoding */
 212         else {
 213         if (check & ENCODE_DIE_ON_ERR){
 214             Perl_croak(aTHX_ ERR_DECODE_NOMAP,
 215                               enc->name[0], (UV)s[slen]);
 216             return &PL_sv_undef; /* never reaches but be safe */
 217         }
 218         if (check & ENCODE_WARN_ON_ERR){
 219             Perl_warner(
 220             aTHX_ packWARN(WARN_UTF8),
 221             ERR_DECODE_NOMAP,
 222                         enc->name[0], (UV)s[slen]);
 223         }
 224         if (check & ENCODE_RETURN_ON_ERR){
 225             goto ENCODE_SET_SRC;
 226         }
 227         if (check &
 228             (ENCODE_PERLQQ|ENCODE_HTMLCREF|ENCODE_XMLCREF)){
 229             SV* subchar =
 230             (fallback_cb != &PL_sv_undef)
 231                 ? do_fallback_cb(aTHX_ (UV)s[slen], fallback_cb)
 232                 : newSVpvf("\\x%02" UVXf, (UV)s[slen]);
 233             sdone += slen + 1;
 234             ddone += dlen + SvCUR(subchar);
 235             sv_catsv(dst, subchar);
 236             SvREFCNT_dec(subchar);
 237         } else {
 238             sdone += slen + 1;
 239             ddone += dlen + strlen(FBCHAR_UTF8);
 240             sv_catpv(dst, FBCHAR_UTF8);
 241         }
 242         }
 243         /* settle variables when fallback */
 244         d    = (U8 *)SvEND(dst);
 245             dlen = SvLEN(dst) - ddone - 1;
 246         s    = (U8*)SvPVX(src) + sdone;
 247         slen = tlen - sdone;
 248         break;
 249
 250     default:
 251         Perl_croak(aTHX_ "Unexpected code %d converting %s %s",
 252                code, (dir == enc->f_utf8) ? "to" : "from",
 253                enc->name[0]);
 254         return &PL_sv_undef;
 255     }
 256     }
 257  ENCODE_SET_SRC:
 258     if (check && !(check & ENCODE_LEAVE_SRC)){
 259     sdone = SvCUR(src) - (slen+sdone);
 260     if (sdone) {
 261         sv_setpvn(src, (char*)s+slen, sdone);
 262     }
 263     SvCUR_set(src, sdone);
 264     }
 265     /* warn("check = 0x%X, code = 0x%d\n", check, code); */
 266
 267     SvCUR_set(dst, dlen+ddone);
 268     SvPOK_only(dst);
 269
 270 #if ENCODE_XS_PROFILE
 271     if (SvCUR(dst) > SvCUR(src)){
 272     Perl_warn(aTHX_
 273           "SvLEN(dst)=%d, SvCUR(dst)=%d. %d bytes unused(%f %%)\n",
 274           SvLEN(dst), SvCUR(dst), SvLEN(dst) - SvCUR(dst),
 275           (SvLEN(dst) - SvCUR(dst))*1.0/SvLEN(dst)*100.0);
 276     }
 277 #endif
 278
 279     if (offset)
 280       *offset += sdone + slen;
 281
 282  ENCODE_END:
 283     *SvEND(dst) = '\0';
 284     if (retcode) *retcode = code;
 285     return dst;
 286 }
 287
 288 static bool
 289 strict_utf8(pTHX_ SV* sv)
 290 {
 291     HV* hv;
 292     SV** svp;
 293     sv = SvRV(sv);
 294     if (!sv || SvTYPE(sv) != SVt_PVHV)
 295         return 0;
 296     hv = (HV*)sv;
 297     svp = hv_fetch(hv, "strict_utf8", 11, 0);
 298     if (!svp)
 299         return 0;
 300     return SvTRUE(*svp);
 301 }
 302
 303 static U8*
 304 process_utf8(pTHX_ SV* dst, U8* s, U8* e, int check,
 305              bool encode, bool strict, bool stop_at_partial)
 306 {
 307     UV uv;
 308     STRLEN ulen;
 309
 310     SvPOK_only(dst);
 311     SvCUR_set(dst,0);
 312
 313     while (s < e) {
 314         if (UTF8_IS_INVARIANT(*s)) {
 315             sv_catpvn(dst, (char *)s, 1);
 316             s++;
 317             continue;
 318         }
 319
 320         if (UTF8_IS_START(*s)) {
 321             U8 skip = UTF8SKIP(s);
 322             if ((s + skip) > e) {
 323                 /* Partial character */
 324                 /* XXX could check that rest of bytes are UTF8_IS_CONTINUATION(ch) */
 325                 if (stop_at_partial || (check & ENCODE_STOP_AT_PARTIAL))
 326                     break;
 327
 328                 goto malformed_byte;
 329             }
 330
 331             uv = utf8n_to_uvuni(s, e - s, &ulen,
 332                                 UTF8_CHECK_ONLY | (strict ? UTF8_ALLOW_STRICT :
 333                                                             UTF8_ALLOW_NONSTRICT)
 334                                );
 335 #if 1 /* perl-5.8.6 and older do not check UTF8_ALLOW_LONG */
 336         if (strict && uv > PERL_UNICODE_MAX)
 337         ulen = (STRLEN) -1;
 338 #endif
 339             if (ulen == -1) {
 340                 if (strict) {
 341                     uv = utf8n_to_uvuni(s, e - s, &ulen,
 342                                         UTF8_CHECK_ONLY | UTF8_ALLOW_NONSTRICT);
 343                     if (ulen == -1)
 344                         goto malformed_byte;
 345                     goto malformed;
 346                 }
 347                 goto malformed_byte;
 348             }
 349
 350
 351              /* Whole char is good */
 352              sv_catpvn(dst,(char *)s,skip);
 353              s += skip;
 354              continue;
 355         }
 356
 357         /* If we get here there is something wrong with alleged UTF-8 */
 358     malformed_byte:
 359         uv = (UV)*s;
 360         ulen = 1;
 361
 362     malformed:
 363         if (check & ENCODE_DIE_ON_ERR){
 364             if (encode)
 365                 Perl_croak(aTHX_ ERR_ENCODE_NOMAP, uv, "utf8");
 366             else
 367                 Perl_croak(aTHX_ ERR_DECODE_NOMAP, "utf8", uv);
 368         }
 369         if (check & ENCODE_WARN_ON_ERR){
 370             if (encode)
 371                 Perl_warner(aTHX_ packWARN(WARN_UTF8),
 372                             ERR_ENCODE_NOMAP, uv, "utf8");
 373             else
 374                 Perl_warner(aTHX_ packWARN(WARN_UTF8),
 375                             ERR_DECODE_NOMAP, "utf8", uv);
 376         }
 377         if (check & ENCODE_RETURN_ON_ERR) {
 378                 break;
 379         }
 380         if (check & (ENCODE_PERLQQ|ENCODE_HTMLCREF|ENCODE_XMLCREF)){
 381             SV* subchar = newSVpvf(check & ENCODE_PERLQQ ? (ulen == 1 ? "\\x%02" UVXf : "\\x{%04" UVXf "}"):
 382                                    check & ENCODE_HTMLCREF ? "&#%" UVuf ";" :
 383                                    "&#x%" UVxf ";", uv);
 384             sv_catsv(dst, subchar);
 385             SvREFCNT_dec(subchar);
 386         } else {
 387             sv_catpv(dst, FBCHAR_UTF8);
 388         }
 389         s += ulen;
 390     }
 391     *SvEND(dst) = '\0';
 392
 393     return s;
 394 }
 395
 396
 397 MODULE = Encode         PACKAGE = Encode::utf8  PREFIX = Method_
 398
 399 PROTOTYPES: DISABLE
 400
 401 void
 402 Method_decode_xs(obj,src,check_sv = &PL_sv_no)
 403 SV *    obj
 404 SV *    src
 405 SV *    check_sv
 406 PREINIT:
 407     STRLEN slen;
 408     U8 *s;
 409     U8 *e;
 410     SV *dst;
 411     bool renewed = 0;
 412     int check;
 413 CODE:
 414 {
 415     dSP; ENTER; SAVETMPS;
 416     if (SvROK(check_sv)) {
 417         croak("UTF-8 decoder doesn't support callback CHECK");
 418     }
 419     else {
 420         check = SvIV(check_sv);
 421     }
 422     if (src == &PL_sv_undef) src = newSV(0);
 423     s = (U8 *) SvPV(src, slen);
 424     e = (U8 *) SvEND(src);
 425     dst = newSV(slen>0?slen:1); /* newSV() abhors 0 -- inaba */
 426
 427     /*
 428      * PerlIO check -- we assume the object is of PerlIO if renewed
 429      */
 430     PUSHMARK(sp);
 431     XPUSHs(obj);
 432     PUTBACK;
 433     if (call_method("renewed",G_SCALAR) == 1) {
 434     SPAGAIN;
 435     renewed = (bool)POPi;
 436     PUTBACK;
 437 #if 0
 438     fprintf(stderr, "renewed == %d\n", renewed);
 439 #endif
 440     }
 441     FREETMPS; LEAVE;
 442     /* end PerlIO check */
 443
 444     if (SvUTF8(src)) {
 445     s = utf8_to_bytes(s,&slen);
 446     if (s) {
 447         SvCUR_set(src,slen);
 448         SvUTF8_off(src);
 449         e = s+slen;
 450     }
 451     else {
 452         croak("Cannot decode string with wide characters");
 453     }
 454     }
 455
 456     s = process_utf8(aTHX_ dst, s, e, check, 0, strict_utf8(aTHX_ obj), renewed);
 457
 458     /* Clear out translated part of source unless asked not to */
 459     if (check && !(check & ENCODE_LEAVE_SRC)){
 460     slen = e-s;
 461     if (slen) {
 462         sv_setpvn(src, (char*)s, slen);
 463     }
 464     SvCUR_set(src, slen);
 465     }
 466     SvUTF8_on(dst);
 467     ST(0) = sv_2mortal(dst);
 468     XSRETURN(1);
 469 }
 470
 471 void
 472 Method_encode_xs(obj,src,check_sv = &PL_sv_no)
 473 SV *    obj
 474 SV *    src
 475 SV *    check_sv
 476 PREINIT:
 477     STRLEN slen;
 478     U8 *s;
 479     U8 *e;
 480     SV *dst;
 481     bool renewed = 0;
 482     int check;
 483 CODE:
 484 {
 485     if (SvROK(check_sv)) {
 486         croak("UTF-8 encoder doesn't support callback CHECK");
 487     }
 488     else {
 489         check = SvIV(check_sv);
 490     }
 491     if (src == &PL_sv_undef) src = newSV(0);
 492     s = (U8 *) SvPV(src, slen);
 493     e = (U8 *) SvEND(src);
 494     dst = newSV(slen>0?slen:1); /* newSV() abhors 0 -- inaba */
 495     if (SvUTF8(src)) {
 496     /* Already encoded */
 497     if (strict_utf8(aTHX_ obj)) {
 498         s = process_utf8(aTHX_ dst, s, e, check, 1, 1, 0);
 499     }
 500         else {
 501             /* trust it and just copy the octets */
 502             sv_setpvn(dst,(char *)s,(e-s));
 503         s = e;
 504         }
 505     }
 506     else {
 507         /* Native bytes - can always encode */
 508     U8 *d = (U8 *) SvGROW(dst, 2*slen+1); /* +1 or assertion will botch */
 509         while (s < e) {
 510             UV uv = NATIVE_TO_UNI((UV) *s);
 511             s++; /* Above expansion of NATIVE_TO_UNI() is safer this way. */
 512             if (UNI_IS_INVARIANT(uv))
 513                 *d++ = (U8)UTF_TO_NATIVE(uv);
 514             else {
 515                 *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
 516                 *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
 517             }
 518     }
 519         SvCUR_set(dst, d- (U8 *)SvPVX(dst));
 520         *SvEND(dst) = '\0';
 521     }
 522
 523     /* Clear out translated part of source unless asked not to */
 524     if (check && !(check & ENCODE_LEAVE_SRC)){
 525     slen = e-s;
 526     if (slen) {
 527         sv_setpvn(src, (char*)s, slen);
 528     }
 529     SvCUR_set(src, slen);
 530     }
 531     SvPOK_only(dst);
 532     SvUTF8_off(dst);
 533     ST(0) = sv_2mortal(dst);
 534     XSRETURN(1);
 535 }
 536
 537 MODULE = Encode         PACKAGE = Encode::XS    PREFIX = Method_
 538
 539 PROTOTYPES: ENABLE
 540
 541 void
 542 Method_renew(obj)
 543 SV *    obj
 544 CODE:
 545 {
 546     XSRETURN(1);
 547 }
 548
 549 int
 550 Method_renewed(obj)
 551 SV *    obj
 552 CODE:
 553     RETVAL = 0;
 554 OUTPUT:
 555     RETVAL
 556
 557 void
 558 Method_name(obj)
 559 SV *    obj
 560 CODE:
 561 {
 562     encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
 563     ST(0) = sv_2mortal(newSVpvn(enc->name[0],strlen(enc->name[0])));
 564     XSRETURN(1);
 565 }
 566
 567 void
 568 Method_cat_decode(obj, dst, src, off, term, check_sv = &PL_sv_no)
 569 SV *    obj
 570 SV *    dst
 571 SV *    src
 572 SV *    off
 573 SV *    term
 574 SV *    check_sv
 575 CODE:
 576 {
 577     int check;
 578     SV *fallback_cb = &PL_sv_undef;
 579     encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
 580     STRLEN offset = (STRLEN)SvIV(off);
 581     int code = 0;
 582     if (SvUTF8(src)) {
 583         sv_utf8_downgrade(src, FALSE);
 584     }
 585     if (SvROK(check_sv)){
 586         fallback_cb = check_sv;
 587         check = ENCODE_PERLQQ|ENCODE_LEAVE_SRC; /* same as FB_PERLQQ */
 588     }else{
 589         check = SvIV(check_sv);
 590     }
 591     sv_catsv(dst, encode_method(aTHX_ enc, enc->t_utf8, src, check,
 592                 &offset, term, &code, fallback_cb));
 593     SvIV_set(off, (IV)offset);
 594     if (code == ENCODE_FOUND_TERM) {
 595     ST(0) = &PL_sv_yes;
 596     }else{
 597     ST(0) = &PL_sv_no;
 598     }
 599     XSRETURN(1);
 600 }
 601
 602 void
 603 Method_decode(obj,src,check_sv = &PL_sv_no)
 604 SV *    obj
 605 SV *    src
 606 SV *    check_sv
 607 CODE:
 608 {
 609     int check;
 610     SV *fallback_cb = &PL_sv_undef;
 611     encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
 612     if (SvUTF8(src)) {
 613         sv_utf8_downgrade(src, FALSE);
 614     }
 615     if (SvROK(check_sv)){
 616         fallback_cb = check_sv;
 617         check = ENCODE_PERLQQ|ENCODE_LEAVE_SRC; /* same as FB_PERLQQ */
 618     }else{
 619         check = SvIV(check_sv);
 620     }
 621     ST(0) = encode_method(aTHX_ enc, enc->t_utf8, src, check,
 622               NULL, Nullsv, NULL, fallback_cb);
 623     SvUTF8_on(ST(0));
 624     XSRETURN(1);
 625 }
 626
 627 void
 628 Method_encode(obj,src,check_sv = &PL_sv_no)
 629 SV *    obj
 630 SV *    src
 631 SV *    check_sv
 632 CODE:
 633 {
 634     int check;
 635     SV *fallback_cb = &PL_sv_undef;
 636     encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
 637     sv_utf8_upgrade(src);
 638     if (SvROK(check_sv)){
 639         fallback_cb = check_sv;
 640         check = ENCODE_PERLQQ|ENCODE_LEAVE_SRC; /* same as FB_PERLQQ */
 641     }else{
 642         check = SvIV(check_sv);
 643     }
 644     ST(0) = encode_method(aTHX_ enc, enc->f_utf8, src, check,
 645               NULL, Nullsv, NULL, fallback_cb);
 646     XSRETURN(1);
 647 }
 648
 649 void
 650 Method_needs_lines(obj)
 651 SV *    obj
 652 CODE:
 653 {
 654     /* encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj))); */
 655     ST(0) = &PL_sv_no;
 656     XSRETURN(1);
 657 }
 658
 659 void
 660 Method_perlio_ok(obj)
 661 SV *    obj
 662 CODE:
 663 {
 664     /* encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj))); */
 665     /* require_pv(PERLIO_FILENAME); */
 666
 667     eval_pv("require PerlIO::encoding", 0);
 668
 669     if (SvTRUE(get_sv("@", 0))) {
 670     ST(0) = &PL_sv_no;
 671     }else{
 672     ST(0) = &PL_sv_yes;
 673     }
 674     XSRETURN(1);
 675 }
 676
 677 void
 678 Method_mime_name(obj)
 679 SV *    obj
 680 CODE:
 681 {
 682     encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
 683     SV *retval;
 684     eval_pv("require Encode::MIME::Name", 0);
 685
 686     if (SvTRUE(get_sv("@", 0))) {
 687         ST(0) = &PL_sv_undef;
 688     }else{
 689         ENTER;
 690         SAVETMPS;
 691         PUSHMARK(sp);
 692         XPUSHs(sv_2mortal(newSVpvn(enc->name[0], strlen(enc->name[0]))));
 693         PUTBACK;
 694         call_pv("Encode::MIME::Name::get_mime_name", G_SCALAR);
 695         SPAGAIN;
 696         retval = newSVsv(POPs);
 697         PUTBACK;
 698         FREETMPS;
 699         LEAVE;
 700         /* enc->name[0] */
 701         ST(0) = retval;
 702     }
 703     XSRETURN(1);
 704 }
 705
 706 MODULE = Encode         PACKAGE = Encode
 707
 708 PROTOTYPES: ENABLE
 709
 710 I32
 711 _bytes_to_utf8(sv, ...)
 712 SV *    sv
 713 CODE:
 714 {
 715     SV * encoding = items == 2 ? ST(1) : Nullsv;
 716
 717     if (encoding)
 718     RETVAL = _encoded_bytes_to_utf8(sv, SvPV_nolen(encoding));
 719     else {
 720     STRLEN len;
 721     U8*    s = (U8*)SvPV(sv, len);
 722     U8*    converted;
 723
 724     converted = bytes_to_utf8(s, &len); /* This allocs */
 725     sv_setpvn(sv, (char *)converted, len);
 726     SvUTF8_on(sv); /* XXX Should we? */
 727     Safefree(converted);                /* ... so free it */
 728     RETVAL = len;
 729     }
 730 }
 731 OUTPUT:
 732     RETVAL
 733
 734 I32
 735 _utf8_to_bytes(sv, ...)
 736 SV *    sv
 737 CODE:
 738 {
 739     SV * to    = items > 1 ? ST(1) : Nullsv;
 740     SV * check = items > 2 ? ST(2) : Nullsv;
 741
 742     if (to) {
 743     RETVAL = _encoded_utf8_to_bytes(sv, SvPV_nolen(to));
 744     } else {
 745     STRLEN len;
 746     U8 *s = (U8*)SvPV(sv, len);
 747
 748     RETVAL = 0;
 749     if (SvTRUE(check)) {
 750         /* Must do things the slow way */
 751         U8 *dest;
 752             /* We need a copy to pass to check() */
 753         U8 *src  = s;
 754         U8 *send = s + len;
 755         U8 *d0;
 756
 757         New(83, dest, len, U8); /* I think */
 758         d0 = dest;
 759
 760         while (s < send) {
 761                 if (*s < 0x80){
 762             *dest++ = *s++;
 763                 } else {
 764             STRLEN ulen;
 765             UV uv = *s++;
 766
 767             /* Have to do it all ourselves because of error routine,
 768                aargh. */
 769             if (!(uv & 0x40)){ goto failure; }
 770             if      (!(uv & 0x20)) { ulen = 2;  uv &= 0x1f; }
 771             else if (!(uv & 0x10)) { ulen = 3;  uv &= 0x0f; }
 772             else if (!(uv & 0x08)) { ulen = 4;  uv &= 0x07; }
 773             else if (!(uv & 0x04)) { ulen = 5;  uv &= 0x03; }
 774             else if (!(uv & 0x02)) { ulen = 6;  uv &= 0x01; }
 775             else if (!(uv & 0x01)) { ulen = 7;  uv = 0; }
 776             else                   { ulen = 13; uv = 0; }
 777
 778             /* Note change to utf8.c variable naming, for variety */
 779             while (ulen--) {
 780             if ((*s & 0xc0) != 0x80){
 781                 goto failure;
 782             } else {
 783                 uv = (uv << 6) | (*s++ & 0x3f);
 784             }
 785           }
 786           if (uv > 256) {
 787           failure:
 788               call_failure(check, s, dest, src);
 789               /* Now what happens? */
 790           }
 791           *dest++ = (U8)uv;
 792         }
 793         }
 794         RETVAL = dest - d0;
 795         sv_usepvn(sv, (char *)dest, RETVAL);
 796         SvUTF8_off(sv);
 797     } else {
 798         RETVAL = (utf8_to_bytes(s, &len) ? len : 0);
 799     }
 800     }
 801 }
 802 OUTPUT:
 803     RETVAL
 804
 805 bool
 806 is_utf8(sv, check = 0)
 807 SV *    sv
 808 int     check
 809 CODE:
 810 {
 811     if (SvGMAGICAL(sv)) /* it could be $1, for example */
 812     sv = newSVsv(sv); /* GMAGIG will be done */
 813     RETVAL = SvUTF8(sv) ? TRUE : FALSE;
 814     if (RETVAL &&
 815         check  &&
 816         !is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
 817         RETVAL = FALSE;
 818     if (sv != ST(0))
 819     SvREFCNT_dec(sv); /* it was a temp copy */
 820 }
 821 OUTPUT:
 822     RETVAL
 823
 824 SV *
 825 _utf8_on(sv)
 826 SV *    sv
 827 CODE:
 828 {
 829     if (SvPOK(sv)) {
 830     SV *rsv = newSViv(SvUTF8(sv));
 831     RETVAL = rsv;
 832     SvUTF8_on(sv);
 833     } else {
 834     RETVAL = &PL_sv_undef;
 835     }
 836 }
 837 OUTPUT:
 838     RETVAL
 839
 840 SV *
 841 _utf8_off(sv)
 842 SV *    sv
 843 CODE:
 844 {
 845     if (SvPOK(sv)) {
 846     SV *rsv = newSViv(SvUTF8(sv));
 847     RETVAL = rsv;
 848     SvUTF8_off(sv);
 849     } else {
 850     RETVAL = &PL_sv_undef;
 851     }
 852 }
 853 OUTPUT:
 854     RETVAL
 855
 856 int
 857 DIE_ON_ERR()
 858 CODE:
 859     RETVAL = ENCODE_DIE_ON_ERR;
 860 OUTPUT:
 861     RETVAL
 862
 863 int
 864 WARN_ON_ERR()
 865 CODE:
 866     RETVAL = ENCODE_WARN_ON_ERR;
 867 OUTPUT:
 868     RETVAL
 869
 870 int
 871 LEAVE_SRC()
 872 CODE:
 873     RETVAL = ENCODE_LEAVE_SRC;
 874 OUTPUT:
 875     RETVAL
 876
 877 int
 878 RETURN_ON_ERR()
 879 CODE:
 880     RETVAL = ENCODE_RETURN_ON_ERR;
 881 OUTPUT:
 882     RETVAL
 883
 884 int
 885 PERLQQ()
 886 CODE:
 887     RETVAL = ENCODE_PERLQQ;
 888 OUTPUT:
 889     RETVAL
 890
 891 int
 892 HTMLCREF()
 893 CODE:
 894     RETVAL = ENCODE_HTMLCREF;
 895 OUTPUT:
 896     RETVAL
 897
 898 int
 899 XMLCREF()
 900 CODE:
 901     RETVAL = ENCODE_XMLCREF;
 902 OUTPUT:
 903     RETVAL
 904
 905 int
 906 STOP_AT_PARTIAL()
 907 CODE:
 908     RETVAL = ENCODE_STOP_AT_PARTIAL;
 909 OUTPUT:
 910     RETVAL
 911
 912 int
 913 FB_DEFAULT()
 914 CODE:
 915     RETVAL = ENCODE_FB_DEFAULT;
 916 OUTPUT:
 917     RETVAL
 918
 919 int
 920 FB_CROAK()
 921 CODE:
 922     RETVAL = ENCODE_FB_CROAK;
 923 OUTPUT:
 924     RETVAL
 925
 926 int
 927 FB_QUIET()
 928 CODE:
 929     RETVAL = ENCODE_FB_QUIET;
 930 OUTPUT:
 931     RETVAL
 932
 933 int
 934 FB_WARN()
 935 CODE:
 936     RETVAL = ENCODE_FB_WARN;
 937 OUTPUT:
 938     RETVAL
 939
 940 int
 941 FB_PERLQQ()
 942 CODE:
 943     RETVAL = ENCODE_FB_PERLQQ;
 944 OUTPUT:
 945     RETVAL
 946
 947 int
 948 FB_HTMLCREF()
 949 CODE:
 950     RETVAL = ENCODE_FB_HTMLCREF;
 951 OUTPUT:
 952     RETVAL
 953
 954 int
 955 FB_XMLCREF()
 956 CODE:
 957     RETVAL = ENCODE_FB_XMLCREF;
 958 OUTPUT:
 959     RETVAL
 960
 961 BOOT:
 962 {
 963 #include "def_t.h"
 964 #include "def_t.exh"
 965 }