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