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