ext/Encode/Encode.xs

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