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