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