ext/Encode/Encode.xs

   1 #include "EXTERN.h"
   2 #include "perl.h"
   3 #include "XSUB.h"
   4 #define U8 U8
   5 #include "encode.h"
   6 #include "iso8859.h"
   7 #include "EBCDIC.h"
   8 #include "Symbols.h"
   9
  10 #define UNIMPLEMENTED(x,y) y x (SV *sv, char *encoding) {   \
  11                          Perl_croak(aTHX_ "panic_unimplemented"); \
  12                          return (y)0; /* fool picky compilers */ \
  13                          }
  14 UNIMPLEMENTED(_encoded_utf8_to_bytes, I32)
  15 UNIMPLEMENTED(_encoded_bytes_to_utf8, I32)
  16
  17 #if defined(USE_PERLIO) && !defined(USE_SFIO)
  18 /* Define an encoding "layer" in the perliol.h sense.
  19    The layer defined here "inherits" in an object-oriented sense from the
  20    "perlio" layer with its PerlIOBuf_* "methods".
  21    The implementation is particularly efficient as until Encode settles down
  22    there is no point in tryint to tune it.
  23
  24    The layer works by overloading the "fill" and "flush" methods.
  25
  26    "fill" calls "SUPER::fill" in perl terms, then calls the encode OO perl API
  27    to convert the encoded data to UTF-8 form, then copies it back to the
  28    buffer. The "base class's" read methods then see the UTF-8 data.
  29
  30    "flush" transforms the UTF-8 data deposited by the "base class's write
  31    method in the buffer back into the encoded form using the encode OO perl API,
  32    then copies data back into the buffer and calls "SUPER::flush.
  33
  34    Note that "flush" is _also_ called for read mode - we still do the (back)-translate
  35    so that the the base class's "flush" sees the correct number of encoded chars
  36    for positioning the seek pointer. (This double translation is the worst performance
  37    issue - particularly with all-perl encode engine.)
  38
  39 */
  40
  41
  42 #include "perliol.h"
  43
  44 typedef struct
  45 {
  46  PerlIOBuf      base;         /* PerlIOBuf stuff */
  47  SV *           bufsv;
  48  SV *           enc;
  49 } PerlIOEncode;
  50
  51
  52 IV
  53 PerlIOEncode_pushed(PerlIO *f, const char *mode,const char *arg,STRLEN len)
  54 {
  55  PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
  56  dTHX;
  57  dSP;
  58  IV code;
  59  code = PerlIOBuf_pushed(f,mode,Nullch,0);
  60  ENTER;
  61  SAVETMPS;
  62  PUSHMARK(sp);
  63  XPUSHs(sv_2mortal(newSVpvn(arg,len)));
  64  PUTBACK;
  65  if (perl_call_pv("Encode::find_encoding",G_SCALAR) != 1)
  66   {
  67    /* should never happen */
  68    Perl_die(aTHX_ "Encode::find_encoding did not return a value");
  69    return -1;
  70   }
  71  SPAGAIN;
  72  e->enc = POPs;
  73  PUTBACK;
  74  if (!SvROK(e->enc))
  75   {
  76    e->enc = Nullsv;
  77    errno  = EINVAL;
  78    Perl_warner(aTHX_ WARN_IO, "Cannot find encoding \"%.*s\"", (int) len, arg);
  79    return -1;
  80   }
  81  SvREFCNT_inc(e->enc);
  82  FREETMPS;
  83  LEAVE;
  84  PerlIOBase(f)->flags |= PERLIO_F_UTF8;
  85  return code;
  86 }
  87
  88 IV
  89 PerlIOEncode_popped(PerlIO *f)
  90 {
  91  PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
  92  dTHX;
  93  if (e->enc)
  94   {
  95    SvREFCNT_dec(e->enc);
  96    e->enc = Nullsv;
  97   }
  98  if (e->bufsv)
  99   {
 100    SvREFCNT_dec(e->bufsv);
 101    e->bufsv = Nullsv;
 102   }
 103  return 0;
 104 }
 105
 106 STDCHAR *
 107 PerlIOEncode_get_base(PerlIO *f)
 108 {
 109  PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
 110  dTHX;
 111  if (!e->base.bufsiz)
 112   e->base.bufsiz = 1024;
 113  if (!e->bufsv)
 114   {
 115    e->bufsv = newSV(e->base.bufsiz);
 116    sv_setpvn(e->bufsv,"",0);
 117   }
 118  e->base.buf = (STDCHAR *)SvPVX(e->bufsv);
 119  if (!e->base.ptr)
 120   e->base.ptr = e->base.buf;
 121  if (!e->base.end)
 122   e->base.end = e->base.buf;
 123  if (e->base.ptr < e->base.buf || e->base.ptr > e->base.buf+SvLEN(e->bufsv))
 124   {
 125    Perl_warn(aTHX_ " ptr %p(%p)%p",
 126              e->base.buf,e->base.ptr,e->base.buf+SvLEN(e->bufsv));
 127    abort();
 128   }
 129  if (SvLEN(e->bufsv) < e->base.bufsiz)
 130   {
 131    SSize_t poff = e->base.ptr - e->base.buf;
 132    SSize_t eoff = e->base.end - e->base.buf;
 133    e->base.buf  = (STDCHAR *)SvGROW(e->bufsv,e->base.bufsiz);
 134    e->base.ptr  = e->base.buf + poff;
 135    e->base.end  = e->base.buf + eoff;
 136   }
 137  if (e->base.ptr < e->base.buf || e->base.ptr > e->base.buf+SvLEN(e->bufsv))
 138   {
 139    Perl_warn(aTHX_ " ptr %p(%p)%p",
 140              e->base.buf,e->base.ptr,e->base.buf+SvLEN(e->bufsv));
 141    abort();
 142   }
 143  return e->base.buf;
 144 }
 145
 146 IV
 147 PerlIOEncode_fill(PerlIO *f)
 148 {
 149  PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
 150  dTHX;
 151  dSP;
 152  IV code;
 153  code = PerlIOBuf_fill(f);
 154  if (code == 0)
 155   {
 156    SV *uni;
 157    STRLEN len;
 158    char *s;
 159    /* Set SV that is the buffer to be buf..ptr */
 160    SvCUR_set(e->bufsv, e->base.end - e->base.buf);
 161    SvUTF8_off(e->bufsv);
 162    ENTER;
 163    SAVETMPS;
 164    PUSHMARK(sp);
 165    XPUSHs(e->enc);
 166    XPUSHs(e->bufsv);
 167    XPUSHs(&PL_sv_yes);
 168    PUTBACK;
 169    if (perl_call_method("decode",G_SCALAR) != 1)
 170     code = -1;
 171    SPAGAIN;
 172    uni = POPs;
 173    PUTBACK;
 174    /* Now get translated string (forced to UTF-8) and copy back to buffer
 175       don't use sv_setsv as that may "steal" PV from returned temp
 176       and so free() our known-large-enough buffer.
 177       sv_setpvn() should do but let us do it long hand.
 178     */
 179    s = SvPVutf8(uni,len);
 180    if (s != SvPVX(e->bufsv))
 181     {
 182      e->base.buf = (STDCHAR *)SvGROW(e->bufsv,len);
 183      Move(s,e->base.buf,len,char);
 184      SvCUR_set(e->bufsv,len);
 185     }
 186    SvUTF8_on(e->bufsv);
 187    e->base.end    = e->base.buf+len;
 188    e->base.ptr    = e->base.buf;
 189    FREETMPS;
 190    LEAVE;
 191   }
 192  return code;
 193 }
 194
 195 IV
 196 PerlIOEncode_flush(PerlIO *f)
 197 {
 198  PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
 199  IV code = 0;
 200  dTHX;
 201  if (e->bufsv && (PerlIOBase(f)->flags & (PERLIO_F_RDBUF|PERLIO_F_WRBUF)))
 202   {
 203    dSP;
 204    SV *str;
 205    char *s;
 206    STRLEN len;
 207    SSize_t left = 0;
 208    if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
 209     {
 210      /* This is really just a flag to see if we took all the data, if
 211         we did PerlIOBase_flush avoids a seek to lower layer.
 212         Need to revisit if we start getting clever with unreads or seeks-in-buffer
 213       */
 214      left = e->base.end - e->base.ptr;
 215     }
 216    ENTER;
 217    SAVETMPS;
 218    PUSHMARK(sp);
 219    XPUSHs(e->enc);
 220    SvCUR_set(e->bufsv, e->base.ptr - e->base.buf);
 221    SvUTF8_on(e->bufsv);
 222    XPUSHs(e->bufsv);
 223    XPUSHs(&PL_sv_yes);
 224    PUTBACK;
 225    if (perl_call_method("encode",G_SCALAR) != 1)
 226     code = -1;
 227    SPAGAIN;
 228    str = POPs;
 229    PUTBACK;
 230    s = SvPV(str,len);
 231    if (s != SvPVX(e->bufsv))
 232     {
 233      e->base.buf = (STDCHAR *)SvGROW(e->bufsv,len);
 234      Move(s,e->base.buf,len,char);
 235      SvCUR_set(e->bufsv,len);
 236     }
 237    SvUTF8_off(e->bufsv);
 238    e->base.ptr = e->base.buf+len;
 239    /* restore end != ptr as inequality is used by PerlIOBuf_flush in read case */
 240    e->base.end = e->base.ptr + left;
 241    FREETMPS;
 242    LEAVE;
 243    if (PerlIOBuf_flush(f) != 0)
 244     code = -1;
 245   }
 246  return code;
 247 }
 248
 249 IV
 250 PerlIOEncode_close(PerlIO *f)
 251 {
 252  PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
 253  IV code = PerlIOBase_close(f);
 254  dTHX;
 255  if (e->bufsv)
 256   {
 257    SvREFCNT_dec(e->bufsv);
 258    e->bufsv = Nullsv;
 259   }
 260  e->base.buf = NULL;
 261  e->base.ptr = NULL;
 262  e->base.end = NULL;
 263  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
 264  return code;
 265 }
 266
 267 Off_t
 268 PerlIOEncode_tell(PerlIO *f)
 269 {
 270  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
 271  /* Unfortunately the only way to get a postion is to back-translate,
 272     the UTF8-bytes we have buf..ptr and adjust accordingly.
 273     But we will try and save any unread data in case stream
 274     is un-seekable.
 275   */
 276  if ((PerlIOBase(f)->flags & PERLIO_F_RDBUF) && b->ptr < b->end)
 277   {
 278    Size_t count = b->end - b->ptr;
 279    PerlIO_push(f,&PerlIO_pending,"r",Nullch,0);
 280    /* Save what we have left to read */
 281    PerlIOSelf(f,PerlIOBuf)->bufsiz = count;
 282    PerlIO_unread(f,b->ptr,count);
 283    /* There isn't any unread data - we just saved it - so avoid the lower seek */
 284    b->end = b->ptr;
 285    /* Flush ourselves - now one layer down,
 286       this does the back translate and adjusts position
 287     */
 288    PerlIO_flush(PerlIONext(f));
 289    /* Set position of the saved data */
 290    PerlIOSelf(f,PerlIOBuf)->posn = b->posn;
 291   }
 292  else
 293   {
 294    PerlIO_flush(f);
 295   }
 296  return b->posn;
 297 }
 298
 299 PerlIO_funcs PerlIO_encode = {
 300  "encoding",
 301  sizeof(PerlIOEncode),
 302  PERLIO_K_BUFFERED,
 303  PerlIOBase_fileno,
 304  PerlIOBuf_fdopen,
 305  PerlIOBuf_open,
 306  PerlIOBuf_reopen,
 307  PerlIOEncode_pushed,
 308  PerlIOEncode_popped,
 309  PerlIOBuf_read,
 310  PerlIOBuf_unread,
 311  PerlIOBuf_write,
 312  PerlIOBuf_seek,
 313  PerlIOEncode_tell,
 314  PerlIOEncode_close,
 315  PerlIOEncode_flush,
 316  PerlIOEncode_fill,
 317  PerlIOBase_eof,
 318  PerlIOBase_error,
 319  PerlIOBase_clearerr,
 320  PerlIOBuf_setlinebuf,
 321  PerlIOEncode_get_base,
 322  PerlIOBuf_bufsiz,
 323  PerlIOBuf_get_ptr,
 324  PerlIOBuf_get_cnt,
 325  PerlIOBuf_set_ptrcnt,
 326 };
 327 #endif /* encode layer */
 328
 329 void
 330 Encode_Define(pTHX_ encode_t *enc)
 331 {
 332  dSP;
 333  HV *stash = gv_stashpv("Encode::XS", TRUE);
 334  SV *sv    = sv_bless(newRV_noinc(newSViv(PTR2IV(enc))),stash);
 335  int i = 0;
 336  PUSHMARK(sp);
 337  XPUSHs(sv);
 338  while (enc->name[i])
 339   {
 340    const char *name = enc->name[i++];
 341    XPUSHs(sv_2mortal(newSVpvn(name,strlen(name))));
 342   }
 343  PUTBACK;
 344  call_pv("Encode::define_encoding",G_DISCARD);
 345  SvREFCNT_dec(sv);
 346 }
 347
 348 void call_failure (SV *routine, U8* done, U8* dest, U8* orig) {}
 349
 350 static SV *
 351 encode_method(pTHX_ encode_t *enc, encpage_t *dir, SV *src, int check)
 352 {
 353  STRLEN slen;
 354  U8 *s = (U8 *) SvPV(src,slen);
 355  SV *dst = sv_2mortal(newSV(2*slen+1));
 356  if (slen)
 357   {
 358    U8 *d = (U8 *) SvGROW(dst, 2*slen+1);
 359    STRLEN dlen = SvLEN(dst);
 360    int code;
 361    while ((code = do_encode(dir,s,&slen,d,dlen,&dlen,!check)))
 362     {
 363      SvCUR_set(dst,dlen);
 364      SvPOK_on(dst);
 365
 366      if (code == ENCODE_FALLBACK)
 367       break;
 368
 369      switch(code)
 370       {
 371        case ENCODE_NOSPACE:
 372         {
 373          STRLEN need = (slen) ? (SvLEN(dst)*SvCUR(src)/slen) : (dlen + UTF8_MAXLEN);
 374          if (need <= SvLEN(dst))
 375           need += UTF8_MAXLEN;
 376          d = (U8 *) SvGROW(dst, need);
 377          dlen = SvLEN(dst);
 378          slen = SvCUR(src);
 379          break;
 380         }
 381
 382        case ENCODE_NOREP:
 383         if (dir == enc->f_utf8)
 384          {
 385           if (!check && ckWARN_d(WARN_UTF8))
 386            {
 387             STRLEN clen;
 388             UV ch = utf8n_to_uvuni(s+slen,(SvCUR(src)-slen),&clen,0);
 389             Perl_warner(aTHX_ WARN_UTF8, "\"\\N{U+%"UVxf"}\" does not map to %s", ch, enc->name[0]);
 390             /* FIXME: Skip over the character, copy in replacement and continue
 391              * but that is messy so for now just fail.
 392              */
 393             return &PL_sv_undef;
 394            }
 395           else
 396            {
 397             return &PL_sv_undef;
 398            }
 399          }
 400         else
 401          {
 402           /* UTF-8 is supposed to be "Universal" so should not happen */
 403           Perl_croak(aTHX_ "%s '%.*s' does not map to UTF-8",
 404                  enc->name[0], (int)(SvCUR(src)-slen),s+slen);
 405          }
 406         break;
 407
 408        case ENCODE_PARTIAL:
 409          if (!check && ckWARN_d(WARN_UTF8))
 410           {
 411            Perl_warner(aTHX_ WARN_UTF8, "Partial %s character",
 412                        (dir == enc->f_utf8) ? "UTF-8" : enc->name[0]);
 413           }
 414          return &PL_sv_undef;
 415
 416        default:
 417         Perl_croak(aTHX_ "Unexpected code %d converting %s %s",
 418                  code, (dir == enc->f_utf8) ? "to" : "from",enc->name[0]);
 419         return &PL_sv_undef;
 420       }
 421     }
 422    SvCUR_set(dst,dlen);
 423    SvPOK_on(dst);
 424    if (check)
 425     {
 426      if (slen < SvCUR(src))
 427       {
 428        Move(s+slen,s,SvCUR(src)-slen,U8);
 429       }
 430      SvCUR_set(src,SvCUR(src)-slen);
 431     }
 432   }
 433  return dst;
 434 }
 435
 436 MODULE = Encode         PACKAGE = Encode        PREFIX = sv_
 437
 438 void
 439 valid_utf8(sv)
 440 SV *    sv
 441 CODE:
 442  {
 443   STRLEN len;
 444   char *s = SvPV(sv,len);
 445   if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
 446    XSRETURN_YES;
 447   else
 448    XSRETURN_NO;
 449  }
 450
 451 void
 452 sv_utf8_encode(sv)
 453 SV *    sv
 454
 455 bool
 456 sv_utf8_decode(sv)
 457 SV *    sv
 458
 459 STRLEN
 460 sv_utf8_upgrade(sv)
 461 SV *    sv
 462
 463 bool
 464 sv_utf8_downgrade(sv,failok=0)
 465 SV *    sv
 466 bool    failok
 467
 468 MODULE = Encode         PACKAGE = Encode::XS    PREFIX = Method_
 469
 470 PROTOTYPES: ENABLE
 471
 472 void
 473 Method_decode(obj,src,check = 0)
 474 SV *    obj
 475 SV *    src
 476 int     check
 477 CODE:
 478  {
 479   encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
 480   ST(0) = encode_method(aTHX_ enc, enc->t_utf8, src, check);
 481   SvUTF8_on(ST(0));
 482   XSRETURN(1);
 483  }
 484
 485 void
 486 Method_encode(obj,src,check = 0)
 487 SV *    obj
 488 SV *    src
 489 int     check
 490 CODE:
 491  {
 492   encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
 493   sv_utf8_upgrade(src);
 494   ST(0) = encode_method(aTHX_ enc, enc->f_utf8, src, check);
 495   XSRETURN(1);
 496  }
 497
 498 MODULE = Encode         PACKAGE = Encode
 499
 500 PROTOTYPES: ENABLE
 501
 502 I32
 503 _bytes_to_utf8(sv, ...)
 504         SV *    sv
 505       CODE:
 506         {
 507           SV * encoding = items == 2 ? ST(1) : Nullsv;
 508
 509           if (encoding)
 510             RETVAL = _encoded_bytes_to_utf8(sv, SvPV_nolen(encoding));
 511           else {
 512             STRLEN len;
 513             U8*    s = (U8*)SvPV(sv, len);
 514             U8*    converted;
 515
 516             converted = bytes_to_utf8(s, &len); /* This allocs */
 517             sv_setpvn(sv, (char *)converted, len);
 518             SvUTF8_on(sv); /* XXX Should we? */
 519             Safefree(converted);                /* ... so free it */
 520             RETVAL = len;
 521           }
 522         }
 523       OUTPUT:
 524         RETVAL
 525
 526 I32
 527 _utf8_to_bytes(sv, ...)
 528         SV *    sv
 529       CODE:
 530         {
 531           SV * to    = items > 1 ? ST(1) : Nullsv;
 532           SV * check = items > 2 ? ST(2) : Nullsv;
 533
 534           if (to)
 535             RETVAL = _encoded_utf8_to_bytes(sv, SvPV_nolen(to));
 536           else {
 537             STRLEN len;
 538             U8 *s = (U8*)SvPV(sv, len);
 539
 540             if (SvTRUE(check)) {
 541               /* Must do things the slow way */
 542               U8 *dest;
 543               U8 *src  = (U8*)savepv((char *)s); /* We need a copy to pass to check() */
 544               U8 *send = s + len;
 545
 546               New(83, dest, len, U8); /* I think */
 547
 548               while (s < send) {
 549                 if (*s < 0x80)
 550                   *dest++ = *s++;
 551                 else {
 552                   STRLEN ulen;
 553                   UV uv = *s++;
 554
 555                   /* Have to do it all ourselves because of error routine,
 556                      aargh. */
 557                   if (!(uv & 0x40))
 558                     goto failure;
 559                   if      (!(uv & 0x20)) { ulen = 2;  uv &= 0x1f; }
 560                   else if (!(uv & 0x10)) { ulen = 3;  uv &= 0x0f; }
 561                   else if (!(uv & 0x08)) { ulen = 4;  uv &= 0x07; }
 562                   else if (!(uv & 0x04)) { ulen = 5;  uv &= 0x03; }
 563                   else if (!(uv & 0x02)) { ulen = 6;  uv &= 0x01; }
 564                   else if (!(uv & 0x01)) { ulen = 7;  uv = 0; }
 565                   else                   { ulen = 13; uv = 0; }
 566
 567                   /* Note change to utf8.c variable naming, for variety */
 568                   while (ulen--) {
 569                     if ((*s & 0xc0) != 0x80)
 570                       goto failure;
 571
 572                     else
 573                       uv = (uv << 6) | (*s++ & 0x3f);
 574                   }
 575                   if (uv > 256) {
 576                   failure:
 577                     call_failure(check, s, dest, src);
 578                     /* Now what happens? */
 579                   }
 580                   *dest++ = (U8)uv;
 581                }
 582                }
 583             } else
 584               RETVAL = (utf8_to_bytes(s, &len) ? len : 0);
 585           }
 586         }
 587       OUTPUT:
 588         RETVAL
 589
 590 bool
 591 is_utf8(sv, check = FALSE)
 592 SV *    sv
 593 bool    check
 594       CODE:
 595         {
 596           if (SvPOK(sv)) {
 597             RETVAL = SvUTF8(sv) ? TRUE : FALSE;
 598             if (RETVAL &&
 599                 check  &&
 600                 !is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
 601               RETVAL = FALSE;
 602           } else {
 603             RETVAL = FALSE;
 604           }
 605         }
 606       OUTPUT:
 607         RETVAL
 608
 609 SV *
 610 _utf8_on(sv)
 611         SV *    sv
 612       CODE:
 613         {
 614           if (SvPOK(sv)) {
 615             SV *rsv = newSViv(SvUTF8(sv));
 616             RETVAL = rsv;
 617             SvUTF8_on(sv);
 618           } else {
 619             RETVAL = &PL_sv_undef;
 620           }
 621         }
 622       OUTPUT:
 623         RETVAL
 624
 625 SV *
 626 _utf8_off(sv)
 627         SV *    sv
 628       CODE:
 629         {
 630           if (SvPOK(sv)) {
 631             SV *rsv = newSViv(SvUTF8(sv));
 632             RETVAL = rsv;
 633             SvUTF8_off(sv);
 634           } else {
 635             RETVAL = &PL_sv_undef;
 636           }
 637         }
 638       OUTPUT:
 639         RETVAL
 640
 641 BOOT:
 642 {
 643 #if defined(USE_PERLIO) && !defined(USE_SFIO)
 644  PerlIO_define_layer(&PerlIO_encode);
 645 #endif
 646 #include "iso8859.def"
 647 #include "EBCDIC.def"
 648 #include "Symbols.def"
 649 }