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  /* FIXME - Almost certainly needs more work */
 332  return PerlIOBase_dup(aTHX_ f, o, params);
 333 }
 334
 335 PerlIO_funcs PerlIO_encode = {
 336  "encoding",
 337  sizeof(PerlIOEncode),
 338  PERLIO_K_BUFFERED,
 339  PerlIOEncode_pushed,
 340  PerlIOEncode_popped,
 341  PerlIOBuf_open,
 342  PerlIOEncode_getarg,
 343  PerlIOBase_fileno,
 344  PerlIOEncode_dup,
 345  PerlIOBuf_read,
 346  PerlIOBuf_unread,
 347  PerlIOBuf_write,
 348  PerlIOBuf_seek,
 349  PerlIOEncode_tell,
 350  PerlIOEncode_close,
 351  PerlIOEncode_flush,
 352  PerlIOEncode_fill,
 353  PerlIOBase_eof,
 354  PerlIOBase_error,
 355  PerlIOBase_clearerr,
 356  PerlIOBase_setlinebuf,
 357  PerlIOEncode_get_base,
 358  PerlIOBuf_bufsiz,
 359  PerlIOBuf_get_ptr,
 360  PerlIOBuf_get_cnt,
 361  PerlIOBuf_set_ptrcnt,
 362 };
 363 #endif /* encode layer */
 364
 365 void
 366 Encode_Define(pTHX_ encode_t *enc)
 367 {
 368  dSP;
 369  HV *stash = gv_stashpv("Encode::XS", TRUE);
 370  SV *sv    = sv_bless(newRV_noinc(newSViv(PTR2IV(enc))),stash);
 371  int i = 0;
 372  PUSHMARK(sp);
 373  XPUSHs(sv);
 374  while (enc->name[i])
 375   {
 376    const char *name = enc->name[i++];
 377    XPUSHs(sv_2mortal(newSVpvn(name,strlen(name))));
 378   }
 379  PUTBACK;
 380  call_pv("Encode::define_encoding",G_DISCARD);
 381  SvREFCNT_dec(sv);
 382 }
 383
 384 void call_failure (SV *routine, U8* done, U8* dest, U8* orig) {}
 385
 386 static SV *
 387 encode_method(pTHX_ encode_t *enc, encpage_t *dir, SV *src, int check)
 388 {
 389  STRLEN slen;
 390  U8 *s = (U8 *) SvPV(src,slen);
 391  SV *dst = sv_2mortal(newSV(2*slen+1));
 392  if (slen)
 393   {
 394    U8 *d = (U8 *) SvGROW(dst, 2*slen+1);
 395    STRLEN dlen = SvLEN(dst);
 396    int code;
 397    while ((code = do_encode(dir,s,&slen,d,dlen,&dlen,!check)))
 398     {
 399      SvCUR_set(dst,dlen);
 400      SvPOK_on(dst);
 401
 402      if (code == ENCODE_FALLBACK)
 403       break;
 404
 405      switch(code)
 406       {
 407        case ENCODE_NOSPACE:
 408         {
 409          STRLEN need = (slen) ? (SvLEN(dst)*SvCUR(src)/slen) : (dlen + UTF8_MAXLEN);
 410          if (need <= SvLEN(dst))
 411           need += UTF8_MAXLEN;
 412          d = (U8 *) SvGROW(dst, need);
 413          dlen = SvLEN(dst);
 414          slen = SvCUR(src);
 415          break;
 416         }
 417
 418        case ENCODE_NOREP:
 419         if (dir == enc->f_utf8)
 420          {
 421           if (!check && ckWARN_d(WARN_UTF8))
 422            {
 423             STRLEN clen;
 424             UV ch = utf8n_to_uvuni(s+slen,(SvCUR(src)-slen),&clen,0);
 425             Perl_warner(aTHX_ WARN_UTF8, "\"\\N{U+%"UVxf"}\" does not map to %s", ch, enc->name[0]);
 426             /* FIXME: Skip over the character, copy in replacement and continue
 427              * but that is messy so for now just fail.
 428              */
 429             return &PL_sv_undef;
 430            }
 431           else
 432            {
 433             return &PL_sv_undef;
 434            }
 435          }
 436         else
 437          {
 438           /* UTF-8 is supposed to be "Universal" so should not happen */
 439           Perl_croak(aTHX_ "%s '%.*s' does not map to UTF-8",
 440                  enc->name[0], (int)(SvCUR(src)-slen),s+slen);
 441          }
 442         break;
 443
 444        case ENCODE_PARTIAL:
 445          if (!check && ckWARN_d(WARN_UTF8))
 446           {
 447            Perl_warner(aTHX_ WARN_UTF8, "Partial %s character",
 448                        (dir == enc->f_utf8) ? "UTF-8" : enc->name[0]);
 449           }
 450          return &PL_sv_undef;
 451
 452        default:
 453         Perl_croak(aTHX_ "Unexpected code %d converting %s %s",
 454                  code, (dir == enc->f_utf8) ? "to" : "from",enc->name[0]);
 455         return &PL_sv_undef;
 456       }
 457     }
 458    SvCUR_set(dst,dlen);
 459    SvPOK_on(dst);
 460    if (check)
 461     {
 462      if (slen < SvCUR(src))
 463       {
 464        Move(s+slen,s,SvCUR(src)-slen,U8);
 465       }
 466      SvCUR_set(src,SvCUR(src)-slen);
 467     }
 468   }
 469  else
 470   {
 471    SvCUR_set(dst,slen);
 472    SvPOK_on(dst);
 473   }
 474  return dst;
 475 }
 476
 477 MODULE = Encode         PACKAGE = Encode::XS    PREFIX = Method_
 478
 479 PROTOTYPES: ENABLE
 480
 481 void
 482 Method_decode(obj,src,check = FALSE)
 483 SV *    obj
 484 SV *    src
 485 bool    check
 486 CODE:
 487  {
 488   encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
 489   ST(0) = encode_method(aTHX_ enc, enc->t_utf8, src, check);
 490   SvUTF8_on(ST(0));
 491   XSRETURN(1);
 492  }
 493
 494 void
 495 Method_encode(obj,src,check = FALSE)
 496 SV *    obj
 497 SV *    src
 498 bool    check
 499 CODE:
 500  {
 501   encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
 502   sv_utf8_upgrade(src);
 503   ST(0) = encode_method(aTHX_ enc, enc->f_utf8, src, check);
 504   XSRETURN(1);
 505  }
 506
 507 MODULE = Encode         PACKAGE = Encode
 508
 509 PROTOTYPES: ENABLE
 510
 511 I32
 512 _bytes_to_utf8(sv, ...)
 513         SV *    sv
 514       CODE:
 515         {
 516           SV * encoding = items == 2 ? ST(1) : Nullsv;
 517
 518           if (encoding)
 519             RETVAL = _encoded_bytes_to_utf8(sv, SvPV_nolen(encoding));
 520           else {
 521             STRLEN len;
 522             U8*    s = (U8*)SvPV(sv, len);
 523             U8*    converted;
 524
 525             converted = bytes_to_utf8(s, &len); /* This allocs */
 526             sv_setpvn(sv, (char *)converted, len);
 527             SvUTF8_on(sv); /* XXX Should we? */
 528             Safefree(converted);                /* ... so free it */
 529             RETVAL = len;
 530           }
 531         }
 532       OUTPUT:
 533         RETVAL
 534
 535 I32
 536 _utf8_to_bytes(sv, ...)
 537         SV *    sv
 538       CODE:
 539         {
 540           SV * to    = items > 1 ? ST(1) : Nullsv;
 541           SV * check = items > 2 ? ST(2) : Nullsv;
 542
 543           if (to)
 544             RETVAL = _encoded_utf8_to_bytes(sv, SvPV_nolen(to));
 545           else {
 546             STRLEN len;
 547             U8 *s = (U8*)SvPV(sv, len);
 548
 549             RETVAL = 0;
 550             if (SvTRUE(check)) {
 551               /* Must do things the slow way */
 552               U8 *dest;
 553               U8 *src  = (U8*)savepv((char *)s); /* We need a copy to pass to check() */
 554               U8 *send = s + len;
 555
 556               New(83, dest, len, U8); /* I think */
 557
 558               while (s < send) {
 559                 if (*s < 0x80)
 560                   *dest++ = *s++;
 561                 else {
 562                   STRLEN ulen;
 563                   UV uv = *s++;
 564
 565                   /* Have to do it all ourselves because of error routine,
 566                      aargh. */
 567                   if (!(uv & 0x40))
 568                     goto failure;
 569                   if      (!(uv & 0x20)) { ulen = 2;  uv &= 0x1f; }
 570                   else if (!(uv & 0x10)) { ulen = 3;  uv &= 0x0f; }
 571                   else if (!(uv & 0x08)) { ulen = 4;  uv &= 0x07; }
 572                   else if (!(uv & 0x04)) { ulen = 5;  uv &= 0x03; }
 573                   else if (!(uv & 0x02)) { ulen = 6;  uv &= 0x01; }
 574                   else if (!(uv & 0x01)) { ulen = 7;  uv = 0; }
 575                   else                   { ulen = 13; uv = 0; }
 576
 577                   /* Note change to utf8.c variable naming, for variety */
 578                   while (ulen--) {
 579                     if ((*s & 0xc0) != 0x80)
 580                       goto failure;
 581
 582                     else
 583                       uv = (uv << 6) | (*s++ & 0x3f);
 584                   }
 585                   if (uv > 256) {
 586                   failure:
 587                     call_failure(check, s, dest, src);
 588                     /* Now what happens? */
 589                   }
 590                   *dest++ = (U8)uv;
 591                }
 592                }
 593             } else
 594               RETVAL = (utf8_to_bytes(s, &len) ? len : 0);
 595           }
 596         }
 597       OUTPUT:
 598         RETVAL
 599
 600 bool
 601 is_utf8(sv, check = FALSE)
 602 SV *    sv
 603 bool    check
 604       CODE:
 605         {
 606           if (SvPOK(sv)) {
 607             RETVAL = SvUTF8(sv) ? TRUE : FALSE;
 608             if (RETVAL &&
 609                 check  &&
 610                 !is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
 611               RETVAL = FALSE;
 612           } else {
 613             RETVAL = FALSE;
 614           }
 615         }
 616       OUTPUT:
 617         RETVAL
 618
 619 SV *
 620 _utf8_on(sv)
 621         SV *    sv
 622       CODE:
 623         {
 624           if (SvPOK(sv)) {
 625             SV *rsv = newSViv(SvUTF8(sv));
 626             RETVAL = rsv;
 627             SvUTF8_on(sv);
 628           } else {
 629             RETVAL = &PL_sv_undef;
 630           }
 631         }
 632       OUTPUT:
 633         RETVAL
 634
 635 SV *
 636 _utf8_off(sv)
 637         SV *    sv
 638       CODE:
 639         {
 640           if (SvPOK(sv)) {
 641             SV *rsv = newSViv(SvUTF8(sv));
 642             RETVAL = rsv;
 643             SvUTF8_off(sv);
 644           } else {
 645             RETVAL = &PL_sv_undef;
 646           }
 647         }
 648       OUTPUT:
 649         RETVAL
 650
 651 BOOT:
 652 {
 653 #if defined(USE_PERLIO) && !defined(USE_SFIO)
 654  PerlIO_define_layer(aTHX_ &PerlIO_encode);
 655 #endif
 656 #include "iso8859.def"
 657 #include "EBCDIC.def"
 658 #include "Symbols.def"
 659 }