ext/Encode/Encode.xs

   1 #define PERL_NO_GET_CONTEXT
   2 #include "EXTERN.h"
   3 #include "perl.h"
   4 #include "XSUB.h"
   5 #define U8 U8
   6 #include "encode.h"
   7 #include "def_t.h"
   8
   9 #define FBCHAR                  0xFFFd
  10 #define BOM_BE                  0xFeFF
  11 #define BOM16LE                 0xFFFe
  12 #define BOM32LE                 0xFFFe0000
  13
  14 #define valid_ucs2(x)           ((0 <= (x) && (x) < 0xD800) || (0xDFFF < (x) && (x) <= 0xFFFF))
  15
  16 #define issurrogate(x)          (0xD800 <= (x)  && (x) <= 0xDFFF )
  17 #define isHiSurrogate(x)        (0xD800 <= (x)  && (x) <  0xDC00 )
  18 #define isLoSurrogate(x)        (0xDC00 <= (x)  && (x) <= 0xDFFF )
  19
  20 static UV
  21 enc_unpack(pTHX_ U8 **sp,U8 *e,STRLEN size,U8 endian)
  22 {
  23     U8 *s = *sp;
  24     UV v = 0;
  25     if (s+size > e) {
  26         croak("Partial character %c",(char) endian);
  27     }
  28     switch(endian) {
  29         case 'N':
  30             v = *s++;
  31             v = (v << 8) | *s++;
  32         case 'n':
  33             v = (v << 8) | *s++;
  34             v = (v << 8) | *s++;
  35             break;
  36         case 'V':
  37         case 'v':
  38             v |= *s++;
  39             v |= (*s++ << 8);
  40             if (endian == 'v')
  41                 break;
  42             v |= (*s++ << 16);
  43             v |= (*s++ << 24);
  44             break;
  45         default:
  46             croak("Unknown endian %c",(char) endian);
  47             break;
  48     }
  49     *sp = s;
  50     return v;
  51 }
  52
  53 void
  54 enc_pack(pTHX_ SV *result,STRLEN size,U8 endian,UV value)
  55 {
  56     U8 *d = SvGROW(result,SvCUR(result)+size);
  57     switch(endian) {
  58         case 'v':
  59         case 'V':
  60             d += SvCUR(result);
  61             SvCUR_set(result,SvCUR(result)+size);
  62             while (size--) {
  63                 *d++ = value & 0xFF;
  64                 value >>= 8;
  65             }
  66             break;
  67         case 'n':
  68         case 'N':
  69             SvCUR_set(result,SvCUR(result)+size);
  70             d += SvCUR(result);
  71             while (size--) {
  72                 *--d = value & 0xFF;
  73                 value >>= 8;
  74             }
  75             break;
  76         default:
  77             croak("Unknown endian %c",(char) endian);
  78             break;
  79     }
  80 }
  81
  82 #define ENCODE_XS_PROFILE 0 /* set 1 or more to profile.
  83                                t/encoding.t dumps core because of
  84                                Perl_warner and PerlIO don't work well */
  85
  86 #define ENCODE_XS_USEFP   1 /* set 0 to disable floating point to calculate
  87                                buffer size for encode_method().
  88                                1 is recommended. 2 restores NI-S original  */
  89
  90 #define UNIMPLEMENTED(x,y) y x (SV *sv, char *encoding) {dTHX;   \
  91                          Perl_croak(aTHX_ "panic_unimplemented"); \
  92                          return (y)0; /* fool picky compilers */ \
  93                          }
  94 UNIMPLEMENTED(_encoded_utf8_to_bytes, I32)
  95     UNIMPLEMENTED(_encoded_bytes_to_utf8, I32)
  96 #if defined(USE_PERLIO) && !defined(USE_SFIO)
  97 /* Define an encoding "layer" in the perliol.h sense.
  98    The layer defined here "inherits" in an object-oriented sense from the
  99    "perlio" layer with its PerlIOBuf_* "methods".
 100    The implementation is particularly efficient as until Encode settles down
 101    there is no point in tryint to tune it.
 102
 103    The layer works by overloading the "fill" and "flush" methods.
 104
 105    "fill" calls "SUPER::fill" in perl terms, then calls the encode OO perl API
 106    to convert the encoded data to UTF-8 form, then copies it back to the
 107    buffer. The "base class's" read methods then see the UTF-8 data.
 108
 109    "flush" transforms the UTF-8 data deposited by the "base class's write
 110    method in the buffer back into the encoded form using the encode OO perl API,
 111    then copies data back into the buffer and calls "SUPER::flush.
 112
 113    Note that "flush" is _also_ called for read mode - we still do the (back)-translate
 114    so that the the base class's "flush" sees the correct number of encoded chars
 115    for positioning the seek pointer. (This double translation is the worst performance
 116    issue - particularly with all-perl encode engine.)
 117
 118 */
 119 #include "perliol.h"
 120 typedef struct {
 121     PerlIOBuf base;             /* PerlIOBuf stuff */
 122     SV *bufsv;                  /* buffer seen by layers above */
 123     SV *dataSV;                 /* data we have read from layer below */
 124     SV *enc;                    /* the encoding object */
 125 } PerlIOEncode;
 126
 127 SV *
 128 PerlIOEncode_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
 129 {
 130     PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
 131     SV *sv = &PL_sv_undef;
 132     if (e->enc) {
 133         dSP;
 134         ENTER;
 135         SAVETMPS;
 136         PUSHMARK(sp);
 137         XPUSHs(e->enc);
 138         PUTBACK;
 139         if (perl_call_method("name", G_SCALAR) == 1) {
 140             SPAGAIN;
 141             sv = newSVsv(POPs);
 142             PUTBACK;
 143         }
 144     }
 145     return sv;
 146 }
 147
 148 IV
 149 PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg)
 150 {
 151     PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
 152     dSP;
 153     IV code;
 154     code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv);
 155     ENTER;
 156     SAVETMPS;
 157     PUSHMARK(sp);
 158     XPUSHs(arg);
 159     PUTBACK;
 160     if (perl_call_pv("Encode::find_encoding", G_SCALAR) != 1) {
 161         /* should never happen */
 162         Perl_die(aTHX_ "Encode::find_encoding did not return a value");
 163         return -1;
 164     }
 165     SPAGAIN;
 166     e->enc = POPs;
 167     PUTBACK;
 168     if (!SvROK(e->enc)) {
 169         e->enc = Nullsv;
 170         errno = EINVAL;
 171         Perl_warner(aTHX_ packWARN(WARN_IO), "Cannot find encoding \"%" SVf "\"",
 172                     arg);
 173         code = -1;
 174     }
 175     else {
 176         SvREFCNT_inc(e->enc);
 177         PerlIOBase(f)->flags |= PERLIO_F_UTF8;
 178     }
 179     FREETMPS;
 180     LEAVE;
 181     return code;
 182 }
 183
 184 IV
 185 PerlIOEncode_popped(pTHX_ PerlIO * f)
 186 {
 187     PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
 188     if (e->enc) {
 189         SvREFCNT_dec(e->enc);
 190         e->enc = Nullsv;
 191     }
 192     if (e->bufsv) {
 193         SvREFCNT_dec(e->bufsv);
 194         e->bufsv = Nullsv;
 195     }
 196     if (e->dataSV) {
 197         SvREFCNT_dec(e->dataSV);
 198         e->dataSV = Nullsv;
 199     }
 200     return 0;
 201 }
 202
 203 STDCHAR *
 204 PerlIOEncode_get_base(pTHX_ PerlIO * f)
 205 {
 206     PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
 207     if (!e->base.bufsiz)
 208         e->base.bufsiz = 1024;
 209     if (!e->bufsv) {
 210         e->bufsv = newSV(e->base.bufsiz);
 211         sv_setpvn(e->bufsv, "", 0);
 212     }
 213     e->base.buf = (STDCHAR *) SvPVX(e->bufsv);
 214     if (!e->base.ptr)
 215         e->base.ptr = e->base.buf;
 216     if (!e->base.end)
 217         e->base.end = e->base.buf;
 218     if (e->base.ptr < e->base.buf
 219         || e->base.ptr > e->base.buf + SvLEN(e->bufsv)) {
 220         Perl_warn(aTHX_ " ptr %p(%p)%p", e->base.buf, e->base.ptr,
 221                   e->base.buf + SvLEN(e->bufsv));
 222         abort();
 223     }
 224     if (SvLEN(e->bufsv) < e->base.bufsiz) {
 225         SSize_t poff = e->base.ptr - e->base.buf;
 226         SSize_t eoff = e->base.end - e->base.buf;
 227         e->base.buf = (STDCHAR *) SvGROW(e->bufsv, e->base.bufsiz);
 228         e->base.ptr = e->base.buf + poff;
 229         e->base.end = e->base.buf + eoff;
 230     }
 231     if (e->base.ptr < e->base.buf
 232         || e->base.ptr > e->base.buf + SvLEN(e->bufsv)) {
 233         Perl_warn(aTHX_ " ptr %p(%p)%p", e->base.buf, e->base.ptr,
 234                   e->base.buf + SvLEN(e->bufsv));
 235         abort();
 236     }
 237     return e->base.buf;
 238 }
 239
 240 IV
 241 PerlIOEncode_fill(pTHX_ PerlIO * f)
 242 {
 243     PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
 244     dSP;
 245     IV code = 0;
 246     PerlIO *n;
 247     SSize_t avail;
 248     if (PerlIO_flush(f) != 0)
 249         return -1;
 250     n  = PerlIONext(f);
 251     if (!PerlIO_fast_gets(n)) {
 252         /* Things get too messy if we don't have a buffer layer
 253            push a :perlio to do the job */
 254         char mode[8];
 255         n  = PerlIO_push(aTHX_ n, &PerlIO_perlio, PerlIO_modestr(f,mode), Nullsv);
 256         if (!n) {
 257             Perl_die(aTHX_ "panic: cannot push :perlio for %p",f);
 258         }
 259     }
 260     ENTER;
 261     SAVETMPS;
 262   retry:
 263     avail = PerlIO_get_cnt(n);
 264     if (avail <= 0) {
 265         avail = PerlIO_fill(n);
 266         if (avail == 0) {
 267             avail = PerlIO_get_cnt(n);
 268         }
 269         else {
 270             if (!PerlIO_error(n) && PerlIO_eof(n))
 271                 avail = 0;
 272         }
 273     }
 274     if (avail > 0) {
 275         STDCHAR *ptr = PerlIO_get_ptr(n);
 276         SSize_t use  = avail;
 277         SV *uni;
 278         char *s;
 279         STRLEN len = 0;
 280         e->base.ptr = e->base.end = (STDCHAR *) Nullch;
 281         (void) PerlIOEncode_get_base(aTHX_ f);
 282         if (!e->dataSV)
 283             e->dataSV = newSV(0);
 284         if (SvTYPE(e->dataSV) < SVt_PV) {
 285             sv_upgrade(e->dataSV,SVt_PV);
 286         }
 287         if (SvCUR(e->dataSV)) {
 288             /* something left over from last time - create a normal
 289                SV with new data appended
 290              */
 291             if (use + SvCUR(e->dataSV) > e->base.bufsiz) {
 292                use = e->base.bufsiz - SvCUR(e->dataSV);
 293             }
 294             sv_catpvn(e->dataSV,(char*)ptr,use);
 295         }
 296         else {
 297             /* Create a "dummy" SV to represent the available data from layer below */
 298             if (SvLEN(e->dataSV) && SvPVX(e->dataSV)) {
 299                 Safefree(SvPVX(e->dataSV));
 300             }
 301             if (use > e->base.bufsiz) {
 302                use = e->base.bufsiz;
 303             }
 304             SvPVX(e->dataSV) = (char *) ptr;
 305             SvLEN(e->dataSV) = 0;  /* Hands off sv.c - it isn't yours */
 306             SvCUR_set(e->dataSV,use);
 307             SvPOK_only(e->dataSV);
 308         }
 309         SvUTF8_off(e->dataSV);
 310         PUSHMARK(sp);
 311         XPUSHs(e->enc);
 312         XPUSHs(e->dataSV);
 313         XPUSHs(&PL_sv_yes);
 314         PUTBACK;
 315         if (perl_call_method("decode", G_SCALAR) != 1) {
 316             Perl_die(aTHX_ "panic: decode did not return a value");
 317         }
 318         SPAGAIN;
 319         uni = POPs;
 320         PUTBACK;
 321         /* Now get translated string (forced to UTF-8) and use as buffer */
 322         if (SvPOK(uni)) {
 323             s = SvPVutf8(uni, len);
 324 #ifdef PARANOID_ENCODE_CHECKS
 325             if (len && !is_utf8_string((U8*)s,len)) {
 326                 Perl_warn(aTHX_ "panic: decode did not return UTF-8 '%.*s'",(int) len,s);
 327             }
 328 #endif
 329         }
 330         if (len > 0) {
 331             /* Got _something */
 332             /* if decode gave us back dataSV then data may vanish when
 333                we do ptrcnt adjust - so take our copy now.
 334                (The copy is a pain - need a put-it-here option for decode.)
 335              */
 336             sv_setpvn(e->bufsv,s,len);
 337             e->base.ptr = e->base.buf = (STDCHAR*)SvPVX(e->bufsv);
 338             e->base.end = e->base.ptr + SvCUR(e->bufsv);
 339             PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
 340             SvUTF8_on(e->bufsv);
 341
 342             /* Adjust ptr/cnt not taking anything which
 343                did not translate - not clear this is a win */
 344             /* compute amount we took */
 345             use -= SvCUR(e->dataSV);
 346             PerlIO_set_ptrcnt(n, ptr+use, (avail-use));
 347             /* and as we did not take it it isn't pending */
 348             SvCUR_set(e->dataSV,0);
 349         } else {
 350             /* Got nothing - assume partial character so we need some more */
 351             /* Make sure e->dataSV is a normal SV before re-filling as
 352                buffer alias will change under us
 353              */
 354             s = SvPV(e->dataSV,len);
 355             sv_setpvn(e->dataSV,s,len);
 356             PerlIO_set_ptrcnt(n, ptr+use, (avail-use));
 357             goto retry;
 358         }
 359         FREETMPS;
 360         LEAVE;
 361         return code;
 362     }
 363     else {
 364         if (avail == 0)
 365             PerlIOBase(f)->flags |= PERLIO_F_EOF;
 366         else
 367             PerlIOBase(f)->flags |= PERLIO_F_ERROR;
 368         return -1;
 369     }
 370 }
 371
 372 IV
 373 PerlIOEncode_flush(pTHX_ PerlIO * f)
 374 {
 375     PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
 376     IV code = 0;
 377     if (e->bufsv && (e->base.ptr > e->base.buf)) {
 378         dSP;
 379         SV *str;
 380         char *s;
 381         STRLEN len;
 382         SSize_t count = 0;
 383         if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
 384             /* Write case encode the buffer and write() to layer below */
 385             ENTER;
 386             SAVETMPS;
 387             PUSHMARK(sp);
 388             XPUSHs(e->enc);
 389             SvCUR_set(e->bufsv, e->base.ptr - e->base.buf);
 390             SvUTF8_on(e->bufsv);
 391             XPUSHs(e->bufsv);
 392             XPUSHs(&PL_sv_yes);
 393             PUTBACK;
 394             if (perl_call_method("encode", G_SCALAR) != 1) {
 395                 Perl_die(aTHX_ "panic: encode did not return a value");
 396             }
 397             SPAGAIN;
 398             str = POPs;
 399             PUTBACK;
 400             s = SvPV(str, len);
 401             count = PerlIO_write(PerlIONext(f),s,len);
 402             if (count != len) {
 403                 code = -1;
 404             }
 405             FREETMPS;
 406             LEAVE;
 407             if (PerlIO_flush(PerlIONext(f)) != 0) {
 408                 code = -1;
 409             }
 410             if (SvCUR(e->bufsv)) {
 411                 /* Did not all translate */
 412                 e->base.ptr = e->base.buf+SvCUR(e->bufsv);
 413                 return code;
 414             }
 415         }
 416         else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
 417             /* read case */
 418             /* if we have any untranslated stuff then unread that first */
 419             if (e->dataSV && SvCUR(e->dataSV)) {
 420                 s = SvPV(e->dataSV, len);
 421                 count = PerlIO_unread(PerlIONext(f),s,len);
 422                 if (count != len) {
 423                     code = -1;
 424                 }
 425             }
 426             /* See if there is anything left in the buffer */
 427             if (e->base.ptr < e->base.end) {
 428                 /* Bother - have unread data.
 429                    re-encode and unread() to layer below
 430                  */
 431                 ENTER;
 432                 SAVETMPS;
 433                 str = sv_newmortal();
 434                 sv_upgrade(str, SVt_PV);
 435                 SvPVX(str) = (char*)e->base.ptr;
 436                 SvLEN(str) = 0;
 437                 SvCUR_set(str, e->base.end - e->base.ptr);
 438                 SvPOK_only(str);
 439                 SvUTF8_on(str);
 440                 PUSHMARK(sp);
 441                 XPUSHs(e->enc);
 442                 XPUSHs(str);
 443                 XPUSHs(&PL_sv_yes);
 444                 PUTBACK;
 445                 if (perl_call_method("encode", G_SCALAR) != 1) {
 446                      Perl_die(aTHX_ "panic: encode did not return a value");
 447                 }
 448                 SPAGAIN;
 449                 str = POPs;
 450                 PUTBACK;
 451                 s = SvPV(str, len);
 452                 count = PerlIO_unread(PerlIONext(f),s,len);
 453                 if (count != len) {
 454                     code = -1;
 455                 }
 456                 FREETMPS;
 457                 LEAVE;
 458             }
 459         }
 460         e->base.ptr = e->base.end = e->base.buf;
 461         PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
 462     }
 463     return code;
 464 }
 465
 466 IV
 467 PerlIOEncode_close(pTHX_ PerlIO * f)
 468 {
 469     PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
 470     IV code = PerlIOBase_close(aTHX_ f);
 471     if (e->bufsv) {
 472         if (e->base.buf && e->base.ptr > e->base.buf) {
 473             Perl_croak(aTHX_ "Close with partial character");
 474         }
 475         SvREFCNT_dec(e->bufsv);
 476         e->bufsv = Nullsv;
 477     }
 478     e->base.buf = NULL;
 479     e->base.ptr = NULL;
 480     e->base.end = NULL;
 481     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
 482     return code;
 483 }
 484
 485 Off_t
 486 PerlIOEncode_tell(pTHX_ PerlIO * f)
 487 {
 488     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
 489     /* Unfortunately the only way to get a postion is to (re-)translate,
 490        the UTF8 we have in bufefr and then ask layer below
 491      */
 492     PerlIO_flush(f);
 493     if (b->buf && b->ptr > b->buf) {
 494         Perl_croak(aTHX_ "Cannot tell at partial character");
 495     }
 496     return PerlIO_tell(PerlIONext(f));
 497 }
 498
 499 PerlIO *
 500 PerlIOEncode_dup(pTHX_ PerlIO * f, PerlIO * o,
 501                  CLONE_PARAMS * params, int flags)
 502 {
 503     if ((f = PerlIOBase_dup(aTHX_ f, o, params, flags))) {
 504         PerlIOEncode *fe = PerlIOSelf(f, PerlIOEncode);
 505         PerlIOEncode *oe = PerlIOSelf(o, PerlIOEncode);
 506         if (oe->enc) {
 507             fe->enc = PerlIO_sv_dup(aTHX_ oe->enc, params);
 508         }
 509     }
 510     return f;
 511 }
 512
 513 PerlIO_funcs PerlIO_encode = {
 514     "encoding",
 515     sizeof(PerlIOEncode),
 516     PERLIO_K_BUFFERED|PERLIO_K_DESTRUCT,
 517     PerlIOEncode_pushed,
 518     PerlIOEncode_popped,
 519     PerlIOBuf_open,
 520     PerlIOEncode_getarg,
 521     PerlIOBase_fileno,
 522     PerlIOEncode_dup,
 523     PerlIOBuf_read,
 524     PerlIOBuf_unread,
 525     PerlIOBuf_write,
 526     PerlIOBuf_seek,
 527     PerlIOEncode_tell,
 528     PerlIOEncode_close,
 529     PerlIOEncode_flush,
 530     PerlIOEncode_fill,
 531     PerlIOBase_eof,
 532     PerlIOBase_error,
 533     PerlIOBase_clearerr,
 534     PerlIOBase_setlinebuf,
 535     PerlIOEncode_get_base,
 536     PerlIOBuf_bufsiz,
 537     PerlIOBuf_get_ptr,
 538     PerlIOBuf_get_cnt,
 539     PerlIOBuf_set_ptrcnt,
 540 };
 541 #endif                          /* encode layer */
 542
 543 void
 544 Encode_XSEncoding(pTHX_ encode_t * enc)
 545 {
 546     dSP;
 547     HV *stash = gv_stashpv("Encode::XS", TRUE);
 548     SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(enc))), stash);
 549     int i = 0;
 550     PUSHMARK(sp);
 551     XPUSHs(sv);
 552     while (enc->name[i]) {
 553         const char *name = enc->name[i++];
 554         XPUSHs(sv_2mortal(newSVpvn(name, strlen(name))));
 555     }
 556     PUTBACK;
 557     call_pv("Encode::define_encoding", G_DISCARD);
 558     SvREFCNT_dec(sv);
 559 }
 560
 561 void
 562 call_failure(SV * routine, U8 * done, U8 * dest, U8 * orig)
 563 {
 564  /* Exists for breakpointing */
 565 }
 566
 567 static SV *
 568 encode_method(pTHX_ encode_t * enc, encpage_t * dir, SV * src,
 569                          int check)
 570 {
 571     STRLEN slen;
 572     U8 *s = (U8 *) SvPV(src, slen);
 573     STRLEN tlen  = slen;
 574     STRLEN ddone = 0;
 575     STRLEN sdone = 0;
 576
 577     /* We allocate slen+1.
 578         PerlIO dumps core if this value is smaller than this. */
 579     SV *dst = sv_2mortal(newSV(slen+1));
 580     if (slen) {
 581         U8 *d = (U8 *) SvPVX(dst);
 582         STRLEN dlen = SvLEN(dst)-1;
 583         int code;
 584         while ((code = do_encode(dir, s, &slen, d, dlen, &dlen, !check))) {
 585             SvCUR_set(dst, dlen+ddone);
 586             SvPOK_only(dst);
 587
 588 #if ENCODE_XS_PROFILE >= 3
 589             Perl_warn(aTHX_ "code=%d @ s=%d/%d/%d d=%d/%d/%d\n",code,slen,sdone,tlen,dlen,ddone,SvLEN(dst)-1);
 590 #endif
 591
 592             if (code == ENCODE_FALLBACK || code == ENCODE_PARTIAL)
 593                 break;
 594
 595             switch (code) {
 596             case ENCODE_NOSPACE:
 597             {
 598                     STRLEN more = 0; /* make sure you initialize! */
 599                     STRLEN sleft;
 600                     sdone += slen;
 601                     ddone += dlen;
 602                     sleft = tlen - sdone;
 603 #if ENCODE_XS_PROFILE >= 2
 604                   Perl_warn(aTHX_
 605                   "more=%d, sdone=%d, sleft=%d, SvLEN(dst)=%d\n",
 606                             more, sdone, sleft, SvLEN(dst));
 607 #endif
 608                     if (sdone != 0) { /* has src ever been processed ? */
 609 #if   ENCODE_XS_USEFP == 2
 610                             more = (1.0*tlen*SvLEN(dst)+sdone-1)/sdone
 611                                     - SvLEN(dst);
 612 #elif ENCODE_XS_USEFP
 613                             more = (1.0*SvLEN(dst)+1)/sdone * sleft;
 614 #else
 615                             /* safe until SvLEN(dst) == MAX_INT/16 */
 616                             more = (16*SvLEN(dst)+1)/sdone/16 * sleft;
 617 #endif
 618                     }
 619                     more += UTF8_MAXLEN; /* insurance policy */
 620 #if ENCODE_XS_PROFILE >= 2
 621                   Perl_warn(aTHX_
 622                   "more=%d, sdone=%d, sleft=%d, SvLEN(dst)=%d\n",
 623                             more, sdone, sleft, SvLEN(dst));
 624 #endif
 625                     d = (U8 *) SvGROW(dst, SvLEN(dst) + more);
 626                     /* dst need to grow need MORE bytes! */
 627                     if (ddone >= SvLEN(dst)) {
 628                         Perl_croak(aTHX_ "Destination couldn't be grown.");
 629                     }
 630                     dlen = SvLEN(dst)-ddone-1;
 631                     d   += ddone;
 632                     s   += slen;
 633                     slen = tlen-sdone;
 634                     continue;
 635             }
 636
 637             case ENCODE_NOREP:
 638                 if (dir == enc->f_utf8) {
 639                     if (!check && ckWARN_d(WARN_UTF8)) {
 640                         STRLEN clen;
 641                         UV ch =
 642                             utf8n_to_uvuni(s + slen, (SvCUR(src) - slen),
 643                                            &clen, 0);
 644                         Perl_warner(aTHX_ packWARN(WARN_UTF8),
 645                                     "\"\\N{U+%" UVxf
 646                                     "}\" does not map to %s", ch,
 647                                     enc->name[0]);
 648                         /* FIXME: Skip over the character, copy in replacement and continue
 649                          * but that is messy so for now just fail.
 650                          */
 651                         return &PL_sv_undef;
 652                     }
 653                     else {
 654                         return &PL_sv_undef;
 655                     }
 656                 }
 657                 else {
 658                     /* UTF-8 is supposed to be "Universal" so should not happen
 659                        for real characters, but some encodings have non-assigned
 660                        codes which may occur.
 661                      */
 662                     Perl_croak(aTHX_ "%s \"\\x%02X\" does not map to Unicode (%d)",
 663                                enc->name[0], (U8) s[slen], code);
 664                 }
 665                 break;
 666
 667             default:
 668                 Perl_croak(aTHX_ "Unexpected code %d converting %s %s",
 669                            code, (dir == enc->f_utf8) ? "to" : "from",
 670                            enc->name[0]);
 671                 return &PL_sv_undef;
 672             }
 673         }
 674         SvCUR_set(dst, dlen+ddone);
 675         SvPOK_only(dst);
 676         if (check) {
 677             sdone = SvCUR(src) - (slen+sdone);
 678             if (sdone) {
 679 #if 1
 680                 /* FIXME: A Move() is dangerous - PV could be mmap'ed readonly
 681                    SvOOK would be ideal - but sv_backoff does not understand SvLEN == 0
 682                    type SVs and sv_clear() calls it ...
 683                  */
 684                  sv_setpvn(src, (char*)s+slen, sdone);
 685 #else
 686                 Move(s + slen, SvPVX(src), sdone , U8);
 687 #endif
 688             }
 689             SvCUR_set(src, sdone);
 690         }
 691     }
 692     else {
 693         SvCUR_set(dst, 0);
 694         SvPOK_only(dst);
 695     }
 696 #if ENCODE_XS_PROFILE
 697     if (SvCUR(dst) > SvCUR(src)){
 698             Perl_warn(aTHX_
 699                       "SvLEN(dst)=%d, SvCUR(dst)=%d. "
 700                       "%d bytes unused(%f %%)\n",
 701                       SvLEN(dst), SvCUR(dst), SvLEN(dst) - SvCUR(dst),
 702                       (SvLEN(dst) - SvCUR(dst))*1.0/SvLEN(dst)*100.0);
 703
 704     }
 705 #endif
 706     *SvEND(dst) = '\0';
 707     return dst;
 708 }
 709
 710 MODULE = Encode         PACKAGE = Encode::XS    PREFIX = Method_
 711
 712 PROTOTYPES: ENABLE
 713
 714 void
 715 Method_name(obj)
 716 SV *    obj
 717 CODE:
 718  {
 719   encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
 720   ST(0) = sv_2mortal(newSVpvn(enc->name[0],strlen(enc->name[0])));
 721   XSRETURN(1);
 722  }
 723
 724 void
 725 Method_decode(obj,src,check = FALSE)
 726 SV *    obj
 727 SV *    src
 728 bool    check
 729 CODE:
 730  {
 731   encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
 732   ST(0) = encode_method(aTHX_ enc, enc->t_utf8, src, check);
 733   SvUTF8_on(ST(0));
 734   XSRETURN(1);
 735  }
 736
 737 void
 738 Method_encode(obj,src,check = FALSE)
 739 SV *    obj
 740 SV *    src
 741 bool    check
 742 CODE:
 743  {
 744   encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
 745   sv_utf8_upgrade(src);
 746   ST(0) = encode_method(aTHX_ enc, enc->f_utf8, src, check);
 747   XSRETURN(1);
 748  }
 749
 750 MODULE = Encode         PACKAGE = Encode::Unicode
 751
 752 void
 753 decode_xs(obj, str, chk = &PL_sv_undef)
 754 SV *    obj
 755 SV *    str
 756 SV *    chk
 757 CODE:
 758 {
 759     int size    = SvIV(*hv_fetch((HV *)SvRV(obj),"size",4,0));
 760     U8 endian   = *((U8 *)SvPV_nolen(*hv_fetch((HV *)SvRV(obj),"endian",6,0)));
 761     int ucs2    = SvTRUE(*hv_fetch((HV *)SvRV(obj),"ucs2",4,0));
 762     SV *result = newSVpvn("",0);
 763     STRLEN ulen;
 764     U8 *s = SvPVbyte(str,ulen);
 765     U8 *e = SvEND(str);
 766     ST(0) = sv_2mortal(result);
 767     SvUTF8_on(result);
 768
 769     if (!endian && s+size <= e) {
 770         UV bom;
 771         endian = (size == 4) ? 'N' : 'n';
 772         bom = enc_unpack(aTHX_ &s,e,size,endian);
 773         if (bom != BOM_BE) {
 774             if (bom == BOM16LE) {
 775                 endian = 'v';
 776             }
 777             else if (bom == BOM32LE) {
 778                 endian = 'V';
 779             }
 780             else {
 781                 croak("%s:Unregognised BOM %"UVxf,
 782                       SvPV_nolen(*hv_fetch((HV *)SvRV(obj),"Name",4,0)),bom);
 783             }
 784         }
 785 #if 0
 786         /* Update endian for this sequence */
 787         hv_store((HV *)SvRV(obj),"endian",6,newSVpv((char *)&endian,1),0);
 788 #endif
 789     }
 790     while (s < e && s+size <= e) {
 791         UV ord = enc_unpack(aTHX_ &s,e,size,endian);
 792         U8 *d;
 793         if (size != 4 && !valid_ucs2(ord)) {
 794             if (ucs2) {
 795                 if (SvTRUE(chk)) {
 796                     croak("%s:no surrogates allowed %"UVxf,
 797                           SvPV_nolen(*hv_fetch((HV *)SvRV(obj),"Name",4,0)),ord);
 798                 }
 799                 if (s+size <= e) {
 800                      enc_unpack(aTHX_ &s,e,size,endian); /* skip the next one as well */
 801                 }
 802                 ord = FBCHAR;
 803             }
 804             else {
 805                 UV lo;
 806                 if (!isHiSurrogate(ord)) {
 807                     croak("%s:Malformed HI surrogate %"UVxf,
 808                           SvPV_nolen(*hv_fetch((HV *)SvRV(obj),"Name",4,0)),ord);
 809                 }
 810                 if (s+size > e) {
 811                     /* Partial character */
 812                     s -= size;   /* back up to 1st half */
 813                     break;       /* And exit loop */
 814                 }
 815                 lo = enc_unpack(aTHX_ &s,e,size,endian);
 816                 if (!isLoSurrogate(lo)){
 817                     croak("%s:Malformed LO surrogate %"UVxf,
 818                           SvPV_nolen(*hv_fetch((HV *)SvRV(obj),"Name",4,0)),ord);
 819                 }
 820                 ord = 0x10000 + ((ord - 0xD800) << 10) + (lo - 0xDC00);
 821             }
 822         }
 823         d = (U8 *) SvGROW(result,SvCUR(result)+UTF8_MAXLEN+1);
 824         d = uvuni_to_utf8_flags(d+SvCUR(result), ord, 0);
 825         SvCUR_set(result,d - (U8 *)SvPVX(result));
 826     }
 827     if (SvTRUE(chk)) {
 828         if (s < e) {
 829              Perl_warner(aTHX_ packWARN(WARN_UTF8),"%s:Partial character",
 830                           SvPV_nolen(*hv_fetch((HV *)SvRV(obj),"Name",4,0)));
 831              Move(s,SvPVX(str),e-s,U8);
 832              SvCUR_set(str,(e-s));
 833         }
 834         else {
 835             SvCUR_set(str,0);
 836         }
 837         *SvEND(str) = '\0';
 838     }
 839     XSRETURN(1);
 840 }
 841
 842 void
 843 encode_xs(obj, utf8, chk = &PL_sv_undef)
 844 SV *    obj
 845 SV *    utf8
 846 SV *    chk
 847 CODE:
 848 {
 849     int size   = SvIV(*hv_fetch((HV *)SvRV(obj),"size",4,0));
 850     U8 endian = *((U8 *)SvPV_nolen(*hv_fetch((HV *)SvRV(obj),"endian",6,0)));
 851     int ucs2   = SvTRUE(*hv_fetch((HV *)SvRV(obj),"ucs2",4,0));
 852     SV *result = newSVpvn("",0);
 853     STRLEN ulen;
 854     U8 *s = SvPVutf8(utf8,ulen);
 855     U8 *e = SvEND(utf8);
 856     ST(0) = sv_2mortal(result);
 857     if (!endian) {
 858         endian = (size == 4) ? 'N' : 'n';
 859         enc_pack(aTHX_ result,size,endian,BOM_BE);
 860 #if 0
 861         /* Update endian for this sequence */
 862         hv_store((HV *)SvRV(obj),"endian",6,newSVpv((char *)&endian,1),0);
 863 #endif
 864     }
 865     while (s < e && s+UTF8SKIP(s) <= e) {
 866         STRLEN len;
 867         UV ord = utf8n_to_uvuni(s, e-s, &len, 0);
 868         s += len;
 869         if (size != 4 && !valid_ucs2(ord)) {
 870             if (!issurrogate(ord)){
 871                 if (ucs2) {
 872                     if (SvTRUE(chk)) {
 873                         croak("%s:code point \"\\x{"UVxf"}\" too high",
 874                           SvPV_nolen(*hv_fetch((HV *)SvRV(obj),"Name",4,0)),ord);
 875                     }
 876                     enc_pack(aTHX_ result,size,endian,FBCHAR);
 877                 }else{
 878                     UV hi = ((ord - 0x10000) >> 10)   + 0xD800;
 879                     UV lo = ((ord - 0x10000) & 0x3FF) + 0xDC00;
 880                     enc_pack(aTHX_ result,size,endian,hi);
 881                     enc_pack(aTHX_ result,size,endian,lo);
 882                 }
 883             }
 884             else {
 885                 /* not supposed to happen */
 886                 enc_pack(aTHX_ result,size,endian,FBCHAR);
 887             }
 888         }
 889         else {
 890             enc_pack(aTHX_ result,size,endian,ord);
 891         }
 892     }
 893     if (SvTRUE(chk)) {
 894         if (s < e) {
 895              Perl_warner(aTHX_ packWARN(WARN_UTF8),"%s:Partial character",
 896                           SvPV_nolen(*hv_fetch((HV *)SvRV(obj),"Name",4,0)));
 897              Move(s,SvPVX(utf8),e-s,U8);
 898              SvCUR_set(utf8,(e-s));
 899         }
 900         else {
 901             SvCUR_set(utf8,0);
 902         }
 903         *SvEND(utf8) = '\0';
 904     }
 905     XSRETURN(1);
 906 }
 907
 908 MODULE = Encode         PACKAGE = Encode
 909
 910 PROTOTYPES: ENABLE
 911
 912 I32
 913 _bytes_to_utf8(sv, ...)
 914         SV *    sv
 915       CODE:
 916         {
 917           SV * encoding = items == 2 ? ST(1) : Nullsv;
 918
 919           if (encoding)
 920             RETVAL = _encoded_bytes_to_utf8(sv, SvPV_nolen(encoding));
 921           else {
 922             STRLEN len;
 923             U8*    s = (U8*)SvPV(sv, len);
 924             U8*    converted;
 925
 926             converted = bytes_to_utf8(s, &len); /* This allocs */
 927             sv_setpvn(sv, (char *)converted, len);
 928             SvUTF8_on(sv); /* XXX Should we? */
 929             Safefree(converted);                /* ... so free it */
 930             RETVAL = len;
 931           }
 932         }
 933       OUTPUT:
 934         RETVAL
 935
 936 I32
 937 _utf8_to_bytes(sv, ...)
 938         SV *    sv
 939       CODE:
 940         {
 941           SV * to    = items > 1 ? ST(1) : Nullsv;
 942           SV * check = items > 2 ? ST(2) : Nullsv;
 943
 944           if (to)
 945             RETVAL = _encoded_utf8_to_bytes(sv, SvPV_nolen(to));
 946           else {
 947             STRLEN len;
 948             U8 *s = (U8*)SvPV(sv, len);
 949
 950             RETVAL = 0;
 951             if (SvTRUE(check)) {
 952               /* Must do things the slow way */
 953               U8 *dest;
 954               U8 *src  = (U8*)savepv((char *)s); /* We need a copy to pass to check() */
 955               U8 *send = s + len;
 956
 957               New(83, dest, len, U8); /* I think */
 958
 959               while (s < send) {
 960                 if (*s < 0x80)
 961                   *dest++ = *s++;
 962                 else {
 963                   STRLEN ulen;
 964                   UV uv = *s++;
 965
 966                   /* Have to do it all ourselves because of error routine,
 967                      aargh. */
 968                   if (!(uv & 0x40))
 969                     goto failure;
 970                   if      (!(uv & 0x20)) { ulen = 2;  uv &= 0x1f; }
 971                   else if (!(uv & 0x10)) { ulen = 3;  uv &= 0x0f; }
 972                   else if (!(uv & 0x08)) { ulen = 4;  uv &= 0x07; }
 973                   else if (!(uv & 0x04)) { ulen = 5;  uv &= 0x03; }
 974                   else if (!(uv & 0x02)) { ulen = 6;  uv &= 0x01; }
 975                   else if (!(uv & 0x01)) { ulen = 7;  uv = 0; }
 976                   else                   { ulen = 13; uv = 0; }
 977
 978                   /* Note change to utf8.c variable naming, for variety */
 979                   while (ulen--) {
 980                     if ((*s & 0xc0) != 0x80)
 981                       goto failure;
 982
 983                     else
 984                       uv = (uv << 6) | (*s++ & 0x3f);
 985                   }
 986                   if (uv > 256) {
 987                   failure:
 988                     call_failure(check, s, dest, src);
 989                     /* Now what happens? */
 990                   }
 991                   *dest++ = (U8)uv;
 992                }
 993                }
 994             } else
 995               RETVAL = (utf8_to_bytes(s, &len) ? len : 0);
 996           }
 997         }
 998       OUTPUT:
 999         RETVAL
1000
1001 bool
1002 is_utf8(sv, check = FALSE)
1003 SV *    sv
1004 bool    check
1005       CODE:
1006         {
1007           if (SvGMAGICAL(sv)) /* it could be $1, for example */
1008             sv = newSVsv(sv); /* GMAGIG will be done */
1009           if (SvPOK(sv)) {
1010             RETVAL = SvUTF8(sv) ? TRUE : FALSE;
1011             if (RETVAL &&
1012                 check  &&
1013                 !is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
1014               RETVAL = FALSE;
1015           } else {
1016             RETVAL = FALSE;
1017           }
1018           if (sv != ST(0))
1019             SvREFCNT_dec(sv); /* it was a temp copy */
1020         }
1021       OUTPUT:
1022         RETVAL
1023
1024 SV *
1025 _utf8_on(sv)
1026         SV *    sv
1027       CODE:
1028         {
1029           if (SvPOK(sv)) {
1030             SV *rsv = newSViv(SvUTF8(sv));
1031             RETVAL = rsv;
1032             SvUTF8_on(sv);
1033           } else {
1034             RETVAL = &PL_sv_undef;
1035           }
1036         }
1037       OUTPUT:
1038         RETVAL
1039
1040 SV *
1041 _utf8_off(sv)
1042         SV *    sv
1043       CODE:
1044         {
1045           if (SvPOK(sv)) {
1046             SV *rsv = newSViv(SvUTF8(sv));
1047             RETVAL = rsv;
1048             SvUTF8_off(sv);
1049           } else {
1050             RETVAL = &PL_sv_undef;
1051           }
1052         }
1053       OUTPUT:
1054         RETVAL
1055
1056 BOOT:
1057 {
1058 #if defined(USE_PERLIO) && !defined(USE_SFIO)
1059  PerlIO_define_layer(aTHX_ &PerlIO_encode);
1060 #endif
1061 #include "def_t.exh"
1062 }