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