ext/PerlIO/encoding/encoding.xs

   1 /*
   2  * $Id$
   3  */
   4
   5 #define PERL_NO_GET_CONTEXT
   6 #include "EXTERN.h"
   7 #include "perl.h"
   8 #include "XSUB.h"
   9 #define U8 U8
  10
  11 #if defined(USE_PERLIO) && !defined(USE_SFIO)
  12
  13 /* Define an encoding "layer" in the perliol.h sense.
  14
  15    The layer defined here "inherits" in an object-oriented sense from
  16    the "perlio" layer with its PerlIOBuf_* "methods".  The
  17    implementation is particularly efficient as until Encode settles
  18    down there is no point in tryint to tune it.
  19
  20    The layer works by overloading the "fill" and "flush" methods.
  21
  22    "fill" calls "SUPER::fill" in perl terms, then calls the encode OO
  23    perl API to convert the encoded data to UTF-8 form, then copies it
  24    back to the buffer. The "base class's" read methods then see the
  25    UTF-8 data.
  26
  27    "flush" transforms the UTF-8 data deposited by the "base class's
  28    write method in the buffer back into the encoded form using the
  29    encode OO perl API, then copies data back into the buffer and calls
  30    "SUPER::flush.
  31
  32    Note that "flush" is _also_ called for read mode - we still do the
  33    (back)-translate so that the the base class's "flush" sees the
  34    correct number of encoded chars for positioning the seek
  35    pointer. (This double translation is the worst performance issue -
  36    particularly with all-perl encode engine.)
  37
  38 */
  39
  40 #include "perliol.h"
  41
  42 typedef struct {
  43     PerlIOBuf base;             /* PerlIOBuf stuff */
  44     SV *bufsv;                  /* buffer seen by layers above */
  45     SV *dataSV;                 /* data we have read from layer below */
  46     SV *enc;                    /* the encoding object */
  47     SV *chk;                    /* CHECK in Encode methods */
  48     int flags;                  /* Flags currently just needs lines */
  49 } PerlIOEncode;
  50
  51 #define NEEDS_LINES     1
  52
  53 #if 0
  54 #define OUR_ENCODE_FB "Encode::FB_DEFAULT"
  55 #else
  56 #define OUR_ENCODE_FB "Encode::FB_QUIET"
  57 #endif
  58
  59 SV *
  60 PerlIOEncode_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
  61 {
  62     PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
  63     SV *sv = &PL_sv_undef;
  64     if (e->enc) {
  65         dSP;
  66         ENTER;
  67         SAVETMPS;
  68         PUSHMARK(sp);
  69         XPUSHs(e->enc);
  70         PUTBACK;
  71         if (call_method("name", G_SCALAR) == 1) {
  72             SPAGAIN;
  73             sv = newSVsv(POPs);
  74             PUTBACK;
  75         }
  76     }
  77     return sv;
  78 }
  79
  80 IV
  81 PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg)
  82 {
  83     PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
  84     dSP;
  85     IV code;
  86     SV *result = Nullsv;
  87     code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv);
  88     ENTER;
  89     SAVETMPS;
  90
  91     PUSHMARK(sp);
  92     XPUSHs(arg);
  93     PUTBACK;
  94     if (call_pv("Encode::find_encoding", G_SCALAR) != 1) {
  95         /* should never happen */
  96         Perl_die(aTHX_ "Encode::find_encoding did not return a value");
  97         return -1;
  98     }
  99     SPAGAIN;
 100     result = POPs;
 101     PUTBACK;
 102
 103     if (!SvROK(result) || !SvOBJECT(SvRV(result))) {
 104         e->enc = Nullsv;
 105         Perl_warner(aTHX_ packWARN(WARN_IO), "Cannot find encoding \"%" SVf "\"",
 106                     arg);
 107         errno = EINVAL;
 108         code = -1;
 109     }
 110     else {
 111 #ifdef USE_NEW_SEQUENCE
 112         PUSHMARK(sp);
 113         XPUSHs(result);
 114         PUTBACK;
 115         if (call_method("new_sequence",G_SCALAR|G_EVAL) != 1 || SvTRUE(ERRSV)) {
 116             Perl_warner(aTHX_ packWARN(WARN_IO), "\"%" SVf "\" does not support new_sequence",
 117                         arg);
 118         }
 119         else {
 120             SPAGAIN;
 121             result = POPs;
 122             PUTBACK;
 123         }
 124 #endif
 125         e->enc = newSVsv(result);
 126         PUSHMARK(sp);
 127         XPUSHs(e->enc);
 128         PUTBACK;
 129         if (call_method("needs_lines",G_SCALAR|G_EVAL) != 1 || SvTRUE(ERRSV)) {
 130             Perl_warner(aTHX_ packWARN(WARN_IO), "\"%" SVf "\" does not support needs_lines",
 131                         arg);
 132         }
 133         else {
 134             SPAGAIN;
 135             result = POPs;
 136             PUTBACK;
 137             if (SvTRUE(result)) {
 138                 e->flags |= NEEDS_LINES;
 139             }
 140         }
 141         PerlIOBase(f)->flags |= PERLIO_F_UTF8;
 142         if (e->flags & NEEDS_LINES) {
 143             PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
 144         }
 145     }
 146
 147     e->chk = newSVsv(get_sv("PerlIO::encoding::check",0));
 148
 149     FREETMPS;
 150     LEAVE;
 151     return code;
 152 }
 153
 154 IV
 155 PerlIOEncode_popped(pTHX_ PerlIO * f)
 156 {
 157     PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
 158     if (e->enc) {
 159         SvREFCNT_dec(e->enc);
 160         e->enc = Nullsv;
 161     }
 162     if (e->bufsv) {
 163         SvREFCNT_dec(e->bufsv);
 164         e->bufsv = Nullsv;
 165     }
 166     if (e->dataSV) {
 167         SvREFCNT_dec(e->dataSV);
 168         e->dataSV = Nullsv;
 169     }
 170     if (e->chk) {
 171         SvREFCNT_dec(e->chk);
 172         e->dataSV = Nullsv;
 173     }
 174     return 0;
 175 }
 176
 177 STDCHAR *
 178 PerlIOEncode_get_base(pTHX_ PerlIO * f)
 179 {
 180     PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
 181     if (!e->base.bufsiz)
 182         e->base.bufsiz = 1024;
 183     if (!e->bufsv) {
 184         e->bufsv = newSV(e->base.bufsiz);
 185         sv_setpvn(e->bufsv, "", 0);
 186     }
 187     e->base.buf = (STDCHAR *) SvPVX(e->bufsv);
 188     if (!e->base.ptr)
 189         e->base.ptr = e->base.buf;
 190     if (!e->base.end)
 191         e->base.end = e->base.buf;
 192     if (e->base.ptr < e->base.buf
 193         || e->base.ptr > e->base.buf + SvLEN(e->bufsv)) {
 194         Perl_warn(aTHX_ " ptr %p(%p)%p", e->base.buf, e->base.ptr,
 195                   e->base.buf + SvLEN(e->bufsv));
 196         abort();
 197     }
 198     if (SvLEN(e->bufsv) < e->base.bufsiz) {
 199         SSize_t poff = e->base.ptr - e->base.buf;
 200         SSize_t eoff = e->base.end - e->base.buf;
 201         e->base.buf = (STDCHAR *) SvGROW(e->bufsv, e->base.bufsiz);
 202         e->base.ptr = e->base.buf + poff;
 203         e->base.end = e->base.buf + eoff;
 204     }
 205     if (e->base.ptr < e->base.buf
 206         || e->base.ptr > e->base.buf + SvLEN(e->bufsv)) {
 207         Perl_warn(aTHX_ " ptr %p(%p)%p", e->base.buf, e->base.ptr,
 208                   e->base.buf + SvLEN(e->bufsv));
 209         abort();
 210     }
 211     return e->base.buf;
 212 }
 213
 214 IV
 215 PerlIOEncode_fill(pTHX_ PerlIO * f)
 216 {
 217     PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
 218     dSP;
 219     IV code = 0;
 220     PerlIO *n;
 221     SSize_t avail;
 222     if (PerlIO_flush(f) != 0)
 223         return -1;
 224     n  = PerlIONext(f);
 225     if (!PerlIO_fast_gets(n)) {
 226         /* Things get too messy if we don't have a buffer layer
 227            push a :perlio to do the job */
 228         char mode[8];
 229         n  = PerlIO_push(aTHX_ n, &PerlIO_perlio, PerlIO_modestr(f,mode), Nullsv);
 230         if (!n) {
 231             Perl_die(aTHX_ "panic: cannot push :perlio for %p",f);
 232         }
 233     }
 234     ENTER;
 235     SAVETMPS;
 236   retry:
 237     avail = PerlIO_get_cnt(n);
 238     if (avail <= 0) {
 239         avail = PerlIO_fill(n);
 240         if (avail == 0) {
 241             avail = PerlIO_get_cnt(n);
 242         }
 243         else {
 244             if (!PerlIO_error(n) && PerlIO_eof(n))
 245                 avail = 0;
 246         }
 247     }
 248     if (avail > 0 || (e->flags & NEEDS_LINES)) {
 249         STDCHAR *ptr = PerlIO_get_ptr(n);
 250         SSize_t use  = (avail >= 0) ? avail : 0;
 251         SV *uni;
 252         char *s;
 253         STRLEN len = 0;
 254         e->base.ptr = e->base.end = (STDCHAR *) Nullch;
 255         (void) PerlIOEncode_get_base(aTHX_ f);
 256         if (!e->dataSV)
 257             e->dataSV = newSV(0);
 258         if (SvTYPE(e->dataSV) < SVt_PV) {
 259             sv_upgrade(e->dataSV,SVt_PV);
 260         }
 261         if (e->flags & NEEDS_LINES) {
 262             /* Encoding needs whole lines (e.g. iso-2022-*)
 263                search back from end of available data for
 264                and line marker
 265              */
 266             STDCHAR *nl = ptr+use-1;
 267             while (nl >= ptr) {
 268                 if (*nl == '\n') {
 269                     break;
 270                 }
 271                 nl--;
 272             }
 273             if (nl >= ptr && *nl == '\n') {
 274                 /* found a line - take up to and including that */
 275                 use = (nl+1)-ptr;
 276             }
 277             else if (avail > 0) {
 278                 /* No line, but not EOF - append avail to the pending data */
 279                 sv_catpvn(e->dataSV, ptr, use);
 280                 PerlIO_set_ptrcnt(n, ptr+use, 0);
 281                 goto retry;
 282             }
 283             else if (!SvCUR(e->dataSV)) {
 284                 goto end_of_file;
 285             }
 286         }
 287         if (SvCUR(e->dataSV)) {
 288             /* something left over from last time - create a normal
 289                SV with new data appended
 290              */
 291             if (use + SvCUR(e->dataSV) > e->base.bufsiz) {
 292                 if (e->flags & NEEDS_LINES) {
 293                     /* Have to grow buffer */
 294                     e->base.bufsiz = use + SvCUR(e->dataSV);
 295                     PerlIOEncode_get_base(aTHX_ f);
 296                 }
 297                 else {
 298                     use = e->base.bufsiz - SvCUR(e->dataSV);
 299                 }
 300             }
 301             sv_catpvn(e->dataSV,(char*)ptr,use);
 302         }
 303         else {
 304             /* Create a "dummy" SV to represent the available data from layer below */
 305             if (SvLEN(e->dataSV) && SvPVX(e->dataSV)) {
 306                 Safefree(SvPVX(e->dataSV));
 307             }
 308             if (use > e->base.bufsiz) {
 309                 if (e->flags & NEEDS_LINES) {
 310                     /* Have to grow buffer */
 311                     e->base.bufsiz = use;
 312                     PerlIOEncode_get_base(aTHX_ f);
 313                 }
 314                 else {
 315                     use = e->base.bufsiz;
 316                 }
 317             }
 318             SvPVX(e->dataSV) = (char *) ptr;
 319             SvLEN(e->dataSV) = 0;  /* Hands off sv.c - it isn't yours */
 320             SvCUR_set(e->dataSV,use);
 321             SvPOK_only(e->dataSV);
 322         }
 323         SvUTF8_off(e->dataSV);
 324         PUSHMARK(sp);
 325         XPUSHs(e->enc);
 326         XPUSHs(e->dataSV);
 327         XPUSHs(e->chk);
 328         PUTBACK;
 329         if (call_method("decode", G_SCALAR) != 1) {
 330             Perl_die(aTHX_ "panic: decode did not return a value");
 331         }
 332         SPAGAIN;
 333         uni = POPs;
 334         PUTBACK;
 335         /* Now get translated string (forced to UTF-8) and use as buffer */
 336         if (SvPOK(uni)) {
 337             s = SvPVutf8(uni, len);
 338 #ifdef PARANOID_ENCODE_CHECKS
 339             if (len && !is_utf8_string((U8*)s,len)) {
 340                 Perl_warn(aTHX_ "panic: decode did not return UTF-8 '%.*s'",(int) len,s);
 341             }
 342 #endif
 343         }
 344         if (len > 0) {
 345             /* Got _something */
 346             /* if decode gave us back dataSV then data may vanish when
 347                we do ptrcnt adjust - so take our copy now.
 348                (The copy is a pain - need a put-it-here option for decode.)
 349              */
 350             sv_setpvn(e->bufsv,s,len);
 351             e->base.ptr = e->base.buf = (STDCHAR*)SvPVX(e->bufsv);
 352             e->base.end = e->base.ptr + SvCUR(e->bufsv);
 353             PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
 354             SvUTF8_on(e->bufsv);
 355
 356             /* Adjust ptr/cnt not taking anything which
 357                did not translate - not clear this is a win */
 358             /* compute amount we took */
 359             use -= SvCUR(e->dataSV);
 360             PerlIO_set_ptrcnt(n, ptr+use, (avail-use));
 361             /* and as we did not take it it isn't pending */
 362             SvCUR_set(e->dataSV,0);
 363         } else {
 364             /* Got nothing - assume partial character so we need some more */
 365             /* Make sure e->dataSV is a normal SV before re-filling as
 366                buffer alias will change under us
 367              */
 368             s = SvPV(e->dataSV,len);
 369             sv_setpvn(e->dataSV,s,len);
 370             PerlIO_set_ptrcnt(n, ptr+use, (avail-use));
 371             goto retry;
 372         }
 373         FREETMPS;
 374         LEAVE;
 375         return code;
 376     }
 377     else {
 378     end_of_file:
 379         if (avail == 0)
 380             PerlIOBase(f)->flags |= PERLIO_F_EOF;
 381         else
 382             PerlIOBase(f)->flags |= PERLIO_F_ERROR;
 383         return -1;
 384     }
 385 }
 386
 387 IV
 388 PerlIOEncode_flush(pTHX_ PerlIO * f)
 389 {
 390     PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
 391     IV code = 0;
 392     if (e->bufsv && (e->base.ptr > e->base.buf)) {
 393         dSP;
 394         SV *str;
 395         char *s;
 396         STRLEN len;
 397         SSize_t count = 0;
 398         if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
 399             /* Write case encode the buffer and write() to layer below */
 400             ENTER;
 401             SAVETMPS;
 402             PUSHMARK(sp);
 403             XPUSHs(e->enc);
 404             SvCUR_set(e->bufsv, e->base.ptr - e->base.buf);
 405             SvUTF8_on(e->bufsv);
 406             XPUSHs(e->bufsv);
 407             XPUSHs(e->chk);
 408             PUTBACK;
 409             if (call_method("encode", G_SCALAR) != 1) {
 410                 Perl_die(aTHX_ "panic: encode did not return a value");
 411             }
 412             SPAGAIN;
 413             str = POPs;
 414             PUTBACK;
 415             s = SvPV(str, len);
 416             count = PerlIO_write(PerlIONext(f),s,len);
 417             if (count != len) {
 418                 code = -1;
 419             }
 420             FREETMPS;
 421             LEAVE;
 422             if (PerlIO_flush(PerlIONext(f)) != 0) {
 423                 code = -1;
 424             }
 425             if (SvCUR(e->bufsv)) {
 426                 /* Did not all translate */
 427                 e->base.ptr = e->base.buf+SvCUR(e->bufsv);
 428                 return code;
 429             }
 430         }
 431         else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
 432             /* read case */
 433             /* if we have any untranslated stuff then unread that first */
 434             if (e->dataSV && SvCUR(e->dataSV)) {
 435                 s = SvPV(e->dataSV, len);
 436                 count = PerlIO_unread(PerlIONext(f),s,len);
 437                 if (count != len) {
 438                     code = -1;
 439                 }
 440             }
 441             /* See if there is anything left in the buffer */
 442             if (e->base.ptr < e->base.end) {
 443                 /* Bother - have unread data.
 444                    re-encode and unread() to layer below
 445                  */
 446                 ENTER;
 447                 SAVETMPS;
 448                 str = sv_newmortal();
 449                 sv_upgrade(str, SVt_PV);
 450                 SvPVX(str) = (char*)e->base.ptr;
 451                 SvLEN(str) = 0;
 452                 SvCUR_set(str, e->base.end - e->base.ptr);
 453                 SvPOK_only(str);
 454                 SvUTF8_on(str);
 455                 PUSHMARK(sp);
 456                 XPUSHs(e->enc);
 457                 XPUSHs(str);
 458                 XPUSHs(e->chk);
 459                 PUTBACK;
 460                 if (call_method("encode", G_SCALAR) != 1) {
 461                      Perl_die(aTHX_ "panic: encode did not return a value");
 462                 }
 463                 SPAGAIN;
 464                 str = POPs;
 465                 PUTBACK;
 466                 s = SvPV(str, len);
 467                 count = PerlIO_unread(PerlIONext(f),s,len);
 468                 if (count != len) {
 469                     code = -1;
 470                 }
 471                 FREETMPS;
 472                 LEAVE;
 473             }
 474         }
 475         e->base.ptr = e->base.end = e->base.buf;
 476         PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
 477     }
 478     return code;
 479 }
 480
 481 IV
 482 PerlIOEncode_close(pTHX_ PerlIO * f)
 483 {
 484     PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
 485     IV code = PerlIOBase_close(aTHX_ f);
 486     if (e->bufsv) {
 487         if (e->base.buf && e->base.ptr > e->base.buf) {
 488             Perl_croak(aTHX_ "Close with partial character");
 489         }
 490         SvREFCNT_dec(e->bufsv);
 491         e->bufsv = Nullsv;
 492     }
 493     e->base.buf = NULL;
 494     e->base.ptr = NULL;
 495     e->base.end = NULL;
 496     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
 497     return code;
 498 }
 499
 500 Off_t
 501 PerlIOEncode_tell(pTHX_ PerlIO * f)
 502 {
 503     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
 504     /* Unfortunately the only way to get a postion is to (re-)translate,
 505        the UTF8 we have in bufefr and then ask layer below
 506      */
 507     PerlIO_flush(f);
 508     if (b->buf && b->ptr > b->buf) {
 509         Perl_croak(aTHX_ "Cannot tell at partial character");
 510     }
 511     return PerlIO_tell(PerlIONext(f));
 512 }
 513
 514 PerlIO *
 515 PerlIOEncode_dup(pTHX_ PerlIO * f, PerlIO * o,
 516                  CLONE_PARAMS * params, int flags)
 517 {
 518     if ((f = PerlIOBase_dup(aTHX_ f, o, params, flags))) {
 519         PerlIOEncode *fe = PerlIOSelf(f, PerlIOEncode);
 520         PerlIOEncode *oe = PerlIOSelf(o, PerlIOEncode);
 521         if (oe->enc) {
 522             fe->enc = PerlIO_sv_dup(aTHX_ oe->enc, params);
 523         }
 524     }
 525     return f;
 526 }
 527
 528 SSize_t
 529 PerlIOEncode_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
 530 {
 531     SSize_t size = PerlIOBuf_write(aTHX_ f, vbuf, count);
 532     PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
 533     if (e->flags & NEEDS_LINES) {
 534     }
 535     return size;
 536 }
 537
 538 PerlIO_funcs PerlIO_encode = {
 539     "encoding",
 540     sizeof(PerlIOEncode),
 541     PERLIO_K_BUFFERED|PERLIO_K_DESTRUCT,
 542     PerlIOEncode_pushed,
 543     PerlIOEncode_popped,
 544     PerlIOBuf_open,
 545     PerlIOEncode_getarg,
 546     PerlIOBase_fileno,
 547     PerlIOEncode_dup,
 548     PerlIOBuf_read,
 549     PerlIOBuf_unread,
 550     PerlIOEncode_write,
 551     PerlIOBuf_seek,
 552     PerlIOEncode_tell,
 553     PerlIOEncode_close,
 554     PerlIOEncode_flush,
 555     PerlIOEncode_fill,
 556     PerlIOBase_eof,
 557     PerlIOBase_error,
 558     PerlIOBase_clearerr,
 559     PerlIOBase_setlinebuf,
 560     PerlIOEncode_get_base,
 561     PerlIOBuf_bufsiz,
 562     PerlIOBuf_get_ptr,
 563     PerlIOBuf_get_cnt,
 564     PerlIOBuf_set_ptrcnt,
 565 };
 566 #endif                          /* encode layer */
 567
 568 MODULE = PerlIO::encoding PACKAGE = PerlIO::encoding
 569
 570 PROTOTYPES: ENABLE
 571
 572 BOOT:
 573 {
 574     SV *sv = get_sv("PerlIO::encoding::check", GV_ADD|GV_ADDMULTI);
 575     sv_setiv(sv,0);
 576     PUSHMARK(sp);
 577     PUTBACK;
 578     if (call_pv(OUR_ENCODE_FB, G_SCALAR) != 1) {
 579         Perl_warner(aTHX_ packWARN(WARN_IO),
 580                     "Call to %s failed!",OUR_ENCODE_FB);
 581     }
 582     else {
 583         SPAGAIN;
 584         sv_setsv(sv,POPs);
 585         PUTBACK;
 586     }
 587 #ifdef PERLIO_LAYERS
 588  PerlIO_define_layer(aTHX_ &PerlIO_encode);
 589 #endif
 590 }