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 #include "defcodes.h"
  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_ packWARN(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_ packWARN(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                        for real characters, but some encodings have non-assigned
 560                        codes which may occur.
 561                      */
 562                     Perl_croak(aTHX_ "%s \"\\x%02X\" does not map to Unicode (%d)",
 563                                enc->name[0], (U8) s[slen], code);
 564                 }
 565                 break;
 566
 567             default:
 568                 Perl_croak(aTHX_ "Unexpected code %d converting %s %s",
 569                            code, (dir == enc->f_utf8) ? "to" : "from",
 570                            enc->name[0]);
 571                 return &PL_sv_undef;
 572             }
 573         }
 574         SvCUR_set(dst, dlen+ddone);
 575         SvPOK_only(dst);
 576         if (check) {
 577             sdone = SvCUR(src) - (slen+sdone);
 578             if (sdone) {
 579                 Move(s + slen, SvPVX(src), sdone , U8);
 580             }
 581             SvCUR_set(src, sdone);
 582         }
 583     }
 584     else {
 585         SvCUR_set(dst, 0);
 586         SvPOK_only(dst);
 587     }
 588     *SvEND(dst) = '\0';
 589     return dst;
 590 }
 591
 592 MODULE = Encode         PACKAGE = Encode::XS    PREFIX = Method_
 593
 594 PROTOTYPES: ENABLE
 595
 596 void
 597 Method_name(obj)
 598 SV *    obj
 599 CODE:
 600  {
 601   encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
 602   ST(0) = sv_2mortal(newSVpvn(enc->name[0],strlen(enc->name[0])));
 603   XSRETURN(1);
 604  }
 605
 606 void
 607 Method_decode(obj,src,check = FALSE)
 608 SV *    obj
 609 SV *    src
 610 bool    check
 611 CODE:
 612  {
 613   encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
 614   ST(0) = encode_method(aTHX_ enc, enc->t_utf8, src, check);
 615   SvUTF8_on(ST(0));
 616   XSRETURN(1);
 617  }
 618
 619 void
 620 Method_encode(obj,src,check = FALSE)
 621 SV *    obj
 622 SV *    src
 623 bool    check
 624 CODE:
 625  {
 626   encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
 627   sv_utf8_upgrade(src);
 628   ST(0) = encode_method(aTHX_ enc, enc->f_utf8, src, check);
 629   XSRETURN(1);
 630  }
 631
 632 MODULE = Encode         PACKAGE = Encode
 633
 634 PROTOTYPES: ENABLE
 635
 636 I32
 637 _bytes_to_utf8(sv, ...)
 638         SV *    sv
 639       CODE:
 640         {
 641           SV * encoding = items == 2 ? ST(1) : Nullsv;
 642
 643           if (encoding)
 644             RETVAL = _encoded_bytes_to_utf8(sv, SvPV_nolen(encoding));
 645           else {
 646             STRLEN len;
 647             U8*    s = (U8*)SvPV(sv, len);
 648             U8*    converted;
 649
 650             converted = bytes_to_utf8(s, &len); /* This allocs */
 651             sv_setpvn(sv, (char *)converted, len);
 652             SvUTF8_on(sv); /* XXX Should we? */
 653             Safefree(converted);                /* ... so free it */
 654             RETVAL = len;
 655           }
 656         }
 657       OUTPUT:
 658         RETVAL
 659
 660 I32
 661 _utf8_to_bytes(sv, ...)
 662         SV *    sv
 663       CODE:
 664         {
 665           SV * to    = items > 1 ? ST(1) : Nullsv;
 666           SV * check = items > 2 ? ST(2) : Nullsv;
 667
 668           if (to)
 669             RETVAL = _encoded_utf8_to_bytes(sv, SvPV_nolen(to));
 670           else {
 671             STRLEN len;
 672             U8 *s = (U8*)SvPV(sv, len);
 673
 674             RETVAL = 0;
 675             if (SvTRUE(check)) {
 676               /* Must do things the slow way */
 677               U8 *dest;
 678               U8 *src  = (U8*)savepv((char *)s); /* We need a copy to pass to check() */
 679               U8 *send = s + len;
 680
 681               New(83, dest, len, U8); /* I think */
 682
 683               while (s < send) {
 684                 if (*s < 0x80)
 685                   *dest++ = *s++;
 686                 else {
 687                   STRLEN ulen;
 688                   UV uv = *s++;
 689
 690                   /* Have to do it all ourselves because of error routine,
 691                      aargh. */
 692                   if (!(uv & 0x40))
 693                     goto failure;
 694                   if      (!(uv & 0x20)) { ulen = 2;  uv &= 0x1f; }
 695                   else if (!(uv & 0x10)) { ulen = 3;  uv &= 0x0f; }
 696                   else if (!(uv & 0x08)) { ulen = 4;  uv &= 0x07; }
 697                   else if (!(uv & 0x04)) { ulen = 5;  uv &= 0x03; }
 698                   else if (!(uv & 0x02)) { ulen = 6;  uv &= 0x01; }
 699                   else if (!(uv & 0x01)) { ulen = 7;  uv = 0; }
 700                   else                   { ulen = 13; uv = 0; }
 701
 702                   /* Note change to utf8.c variable naming, for variety */
 703                   while (ulen--) {
 704                     if ((*s & 0xc0) != 0x80)
 705                       goto failure;
 706
 707                     else
 708                       uv = (uv << 6) | (*s++ & 0x3f);
 709                   }
 710                   if (uv > 256) {
 711                   failure:
 712                     call_failure(check, s, dest, src);
 713                     /* Now what happens? */
 714                   }
 715                   *dest++ = (U8)uv;
 716                }
 717                }
 718             } else
 719               RETVAL = (utf8_to_bytes(s, &len) ? len : 0);
 720           }
 721         }
 722       OUTPUT:
 723         RETVAL
 724
 725 bool
 726 is_utf8(sv, check = FALSE)
 727 SV *    sv
 728 bool    check
 729       CODE:
 730         {
 731           if (SvGMAGICAL(sv)) /* it could be $1, for example */
 732             sv = newSVsv(sv); /* GMAGIG will be done */
 733           if (SvPOK(sv)) {
 734             RETVAL = SvUTF8(sv) ? TRUE : FALSE;
 735             if (RETVAL &&
 736                 check  &&
 737                 !is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
 738               RETVAL = FALSE;
 739           } else {
 740             RETVAL = FALSE;
 741           }
 742           if (sv != ST(0))
 743             SvREFCNT_dec(sv); /* it was a temp copy */
 744         }
 745       OUTPUT:
 746         RETVAL
 747
 748 SV *
 749 _utf8_on(sv)
 750         SV *    sv
 751       CODE:
 752         {
 753           if (SvPOK(sv)) {
 754             SV *rsv = newSViv(SvUTF8(sv));
 755             RETVAL = rsv;
 756             SvUTF8_on(sv);
 757           } else {
 758             RETVAL = &PL_sv_undef;
 759           }
 760         }
 761       OUTPUT:
 762         RETVAL
 763
 764 SV *
 765 _utf8_off(sv)
 766         SV *    sv
 767       CODE:
 768         {
 769           if (SvPOK(sv)) {
 770             SV *rsv = newSViv(SvUTF8(sv));
 771             RETVAL = rsv;
 772             SvUTF8_off(sv);
 773           } else {
 774             RETVAL = &PL_sv_undef;
 775           }
 776         }
 777       OUTPUT:
 778         RETVAL
 779
 780 BOOT:
 781 {
 782 #if defined(USE_PERLIO) && !defined(USE_SFIO)
 783  PerlIO_define_layer(aTHX_ &PerlIO_encode);
 784 #endif
 785 /* #include "8859_def.h" */
 786 /* #include "EBCDIC_def.h" */
 787 /* #include "Symbols_def.h" */
 788 #include "defcodes_def.h"
 789 }