ext/Encode/Encode.xs

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