ext/Encode/Encode.xs

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