ext/Encode/Encode.xs

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