This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Integrate mainline
[perl5.git] / ext / Encode / Encode.xs
1 /*
2  $Id: Encode.xs,v 1.52 2002/11/18 17:28:49 dankogai Exp $
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 #include "encode.h"
11
12 # define PERLIO_MODNAME  "PerlIO::encoding"
13 # define PERLIO_FILENAME "PerlIO/encoding.pm"
14
15 /* set 1 or more to profile.  t/encoding.t dumps core because of
16    Perl_warner and PerlIO don't work well */
17 #define ENCODE_XS_PROFILE 0
18
19 /* set 0 to disable floating point to calculate buffer size for
20    encode_method().  1 is recommended. 2 restores NI-S original */
21 #define ENCODE_XS_USEFP   1
22
23 #define UNIMPLEMENTED(x,y) y x (SV *sv, char *encoding) {dTHX;   \
24                          Perl_croak(aTHX_ "panic_unimplemented"); \
25                          return (y)0; /* fool picky compilers */ \
26                          }
27 /**/
28
29 UNIMPLEMENTED(_encoded_utf8_to_bytes, I32)
30 UNIMPLEMENTED(_encoded_bytes_to_utf8, I32)
31
32 void
33 Encode_XSEncoding(pTHX_ encode_t * enc)
34 {
35     dSP;
36     HV *stash = gv_stashpv("Encode::XS", TRUE);
37     SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(enc))), stash);
38     int i = 0;
39     PUSHMARK(sp);
40     XPUSHs(sv);
41     while (enc->name[i]) {
42         const char *name = enc->name[i++];
43         XPUSHs(sv_2mortal(newSVpvn(name, strlen(name))));
44     }
45     PUTBACK;
46     call_pv("Encode::define_encoding", G_DISCARD);
47     SvREFCNT_dec(sv);
48 }
49
50 void
51 call_failure(SV * routine, U8 * done, U8 * dest, U8 * orig)
52 {
53     /* Exists for breakpointing */
54 }
55
56
57 #define ERR_ENCODE_NOMAP "\"\\x{%04" UVxf "}\" does not map to %s"
58 #define ERR_DECODE_NOMAP "%s \"\\x%02" UVXf "\" does not map to Unicode"
59
60 static SV *
61 encode_method(pTHX_ encode_t * enc, encpage_t * dir, SV * src,
62               int check)
63 {
64     STRLEN slen;
65     U8 *s = (U8 *) SvPV(src, slen);
66     STRLEN tlen  = slen;
67     STRLEN ddone = 0;
68     STRLEN sdone = 0;
69
70     /* We allocate slen+1.
71        PerlIO dumps core if this value is smaller than this. */
72     SV *dst = sv_2mortal(newSV(slen+1));
73     U8 *d = (U8 *)SvPVX(dst);
74     STRLEN dlen = SvLEN(dst)-1;
75     int code;
76
77     if (!slen){
78         SvCUR_set(dst, 0);
79         SvPOK_only(dst);
80         goto ENCODE_END;
81     }
82
83     while( (code = do_encode(dir, s, &slen, d, dlen, &dlen, !check)) )
84     {
85         SvCUR_set(dst, dlen+ddone);
86         SvPOK_only(dst);
87
88         if (code == ENCODE_FALLBACK || code == ENCODE_PARTIAL){
89             break;
90         }
91         switch (code) {
92         case ENCODE_NOSPACE:
93         {
94             STRLEN more = 0; /* make sure you initialize! */
95             STRLEN sleft;
96             sdone += slen;
97             ddone += dlen;
98             sleft = tlen - sdone;
99 #if ENCODE_XS_PROFILE >= 2
100             Perl_warn(aTHX_
101                       "more=%d, sdone=%d, sleft=%d, SvLEN(dst)=%d\n",
102                       more, sdone, sleft, SvLEN(dst));
103 #endif
104             if (sdone != 0) { /* has src ever been processed ? */
105 #if   ENCODE_XS_USEFP == 2
106                 more = (1.0*tlen*SvLEN(dst)+sdone-1)/sdone
107                     - SvLEN(dst);
108 #elif ENCODE_XS_USEFP
109                 more = (STRLEN)((1.0*SvLEN(dst)+1)/sdone * sleft);
110 #else
111                 /* safe until SvLEN(dst) == MAX_INT/16 */
112                 more = (16*SvLEN(dst)+1)/sdone/16 * sleft;
113 #endif
114             }
115             more += UTF8_MAXLEN; /* insurance policy */
116             d = (U8 *) SvGROW(dst, SvLEN(dst) + more);
117             /* dst need to grow need MORE bytes! */
118             if (ddone >= SvLEN(dst)) {
119                 Perl_croak(aTHX_ "Destination couldn't be grown.");
120             }
121             dlen = SvLEN(dst)-ddone-1;
122             d   += ddone;
123             s   += slen;
124             slen = tlen-sdone;
125             continue;
126         }
127         case ENCODE_NOREP:
128             /* encoding */
129             if (dir == enc->f_utf8) {
130                 STRLEN clen;
131                 UV ch =
132                     utf8n_to_uvuni(s+slen, (SvCUR(src)-slen),
133                                    &clen, UTF8_ALLOW_ANY|UTF8_CHECK_ONLY);
134                 if (check & ENCODE_DIE_ON_ERR) {
135                     Perl_croak(aTHX_ ERR_ENCODE_NOMAP,
136                                (UV)ch, enc->name[0]);
137                     return &PL_sv_undef; /* never reaches but be safe */
138                 }
139                 if (check & ENCODE_WARN_ON_ERR){
140                     Perl_warner(aTHX_ packWARN(WARN_UTF8),
141                                 ERR_ENCODE_NOMAP, (UV)ch, enc->name[0]);
142                 }
143                 if (check & ENCODE_RETURN_ON_ERR){
144                     goto ENCODE_SET_SRC;
145                 }
146                 if (check & ENCODE_PERLQQ){
147                     SV* perlqq =
148                         sv_2mortal(newSVpvf("\\x{%04"UVxf"}", (UV)ch));
149                     sdone += slen + clen;
150                     ddone += dlen + SvCUR(perlqq);
151                     sv_catsv(dst, perlqq);
152                 }else if (check & ENCODE_HTMLCREF){
153                     SV* htmlcref =
154                         sv_2mortal(newSVpvf("&#%" UVuf ";", (UV)ch));
155                     sdone += slen + clen;
156                     ddone += dlen + SvCUR(htmlcref);
157                     sv_catsv(dst, htmlcref);
158                 }else if (check & ENCODE_XMLCREF){
159                     SV* xmlcref =
160                         sv_2mortal(newSVpvf("&#x%" UVxf ";", (UV)ch));
161                     sdone += slen + clen;
162                     ddone += dlen + SvCUR(xmlcref);
163                     sv_catsv(dst, xmlcref);
164                 } else {
165                     /* fallback char */
166                     sdone += slen + clen;
167                     ddone += dlen + enc->replen;
168                     sv_catpvn(dst, (char*)enc->rep, enc->replen);
169                 }
170             }
171             /* decoding */
172             else {
173                 if (check & ENCODE_DIE_ON_ERR){
174                     Perl_croak(aTHX_ ERR_DECODE_NOMAP,
175                               enc->name[0], (UV)s[slen]);
176                     return &PL_sv_undef; /* never reaches but be safe */
177                 }
178                 if (check & ENCODE_WARN_ON_ERR){
179                     Perl_warner(
180                         aTHX_ packWARN(WARN_UTF8),
181                         ERR_DECODE_NOMAP,
182                         enc->name[0], (UV)s[slen]);
183                 }
184                 if (check & ENCODE_RETURN_ON_ERR){
185                     goto ENCODE_SET_SRC;
186                 }
187                 if (check &
188                     (ENCODE_PERLQQ|ENCODE_HTMLCREF|ENCODE_XMLCREF)){
189                     SV* perlqq =
190                         sv_2mortal(newSVpvf("\\x%02" UVXf, (UV)s[slen]));
191                     sdone += slen + 1;
192                     ddone += dlen + SvCUR(perlqq);
193                     sv_catsv(dst, perlqq);
194                 } else {
195                     sdone += slen + 1;
196                     ddone += dlen + strlen(FBCHAR_UTF8);
197                     sv_catpv(dst, FBCHAR_UTF8);
198                 }
199             }
200             /* settle variables when fallback */
201             d    = (U8 *)SvEND(dst);
202             dlen = SvLEN(dst) - ddone - 1;
203             s    = (U8*)SvPVX(src) + sdone;
204             slen = tlen - sdone;
205             break;
206
207         default:
208             Perl_croak(aTHX_ "Unexpected code %d converting %s %s",
209                        code, (dir == enc->f_utf8) ? "to" : "from",
210                        enc->name[0]);
211             return &PL_sv_undef;
212         }
213     }
214  ENCODE_SET_SRC:
215     if (check && !(check & ENCODE_LEAVE_SRC)){
216         sdone = SvCUR(src) - (slen+sdone);
217         if (sdone) {
218             sv_setpvn(src, (char*)s+slen, sdone);
219         }
220         SvCUR_set(src, sdone);
221     }
222     /* warn("check = 0x%X, code = 0x%d\n", check, code); */
223
224     SvCUR_set(dst, dlen+ddone);
225     SvPOK_only(dst);
226
227 #if ENCODE_XS_PROFILE
228     if (SvCUR(dst) > SvCUR(src)){
229         Perl_warn(aTHX_
230                   "SvLEN(dst)=%d, SvCUR(dst)=%d. %d bytes unused(%f %%)\n",
231                   SvLEN(dst), SvCUR(dst), SvLEN(dst) - SvCUR(dst),
232                   (SvLEN(dst) - SvCUR(dst))*1.0/SvLEN(dst)*100.0);
233     }
234 #endif
235
236  ENCODE_END:
237     *SvEND(dst) = '\0';
238     return dst;
239 }
240
241 MODULE = Encode         PACKAGE = Encode::utf8  PREFIX = Method_
242
243 void
244 Method_decode_xs(obj,src,check = 0)
245 SV *    obj
246 SV *    src
247 int     check
248 CODE:
249 {
250     STRLEN slen;
251     U8 *s = (U8 *) SvPV(src, slen);
252     U8 *e = (U8 *) SvEND(src);
253     SV *dst = newSV(slen>0?slen:1); /* newSV() abhors 0 -- inaba */
254     SvPOK_only(dst);
255     SvCUR_set(dst,0);
256     if (SvUTF8(src)) {
257         s = utf8_to_bytes(s,&slen);
258         if (s) {
259             SvCUR_set(src,slen);
260             SvUTF8_off(src);
261             e = s+slen;
262         }
263         else {
264             croak("Cannot decode string with wide characters");
265         }
266     }
267     while (s < e) {
268         if (UTF8_IS_INVARIANT(*s) || UTF8_IS_START(*s)) {
269             U8 skip = UTF8SKIP(s);
270             if ((s + skip) > e) {
271                 /* Partial character - done */
272                 break;
273             }
274             else if (is_utf8_char(s)) {
275                 /* Whole char is good */
276                 sv_catpvn(dst,(char *)s,skip);
277                 s += skip;
278                 continue;
279             }
280             else {
281                 /* starts ok but isn't "good" */
282             }
283         }
284         else {
285             /* Invalid start byte */
286         }
287         /* If we get here there is something wrong with alleged UTF-8 */
288         if (check & ENCODE_DIE_ON_ERR){
289             Perl_croak(aTHX_ ERR_DECODE_NOMAP, "utf8", (UV)*s);
290             XSRETURN(0);
291         }
292         if (check & ENCODE_WARN_ON_ERR){
293             Perl_warner(aTHX_ packWARN(WARN_UTF8),
294                         ERR_DECODE_NOMAP, "utf8", (UV)*s);
295         }
296         if (check & ENCODE_RETURN_ON_ERR) {
297                 break;
298         }
299         if (check & (ENCODE_PERLQQ|ENCODE_HTMLCREF|ENCODE_XMLCREF)){
300             SV* perlqq = newSVpvf("\\x%02" UVXf, (UV)*s);
301             sv_catsv(dst, perlqq);
302             SvREFCNT_dec(perlqq);
303         } else {
304             sv_catpv(dst, FBCHAR_UTF8);
305         }
306         s++;
307     }
308     *SvEND(dst) = '\0';
309
310     /* Clear out translated part of source unless asked not to */
311     if (check && !(check & ENCODE_LEAVE_SRC)){
312         slen = e-s;
313         if (slen) {
314             sv_setpvn(src, (char*)s, slen);
315         }
316         SvCUR_set(src, slen);
317     }
318     SvUTF8_on(dst);
319     ST(0) = sv_2mortal(dst);
320     XSRETURN(1);
321 }
322
323 void
324 Method_encode_xs(obj,src,check = 0)
325 SV *    obj
326 SV *    src
327 int     check
328 CODE:
329 {
330     STRLEN slen;
331     U8 *s = (U8 *) SvPV(src, slen);
332     U8 *e = (U8 *) SvEND(src);
333     SV *dst = newSV(slen>0?slen:1); /* newSV() abhors 0 -- inaba */
334     if (SvUTF8(src)) {
335         /* Already encoded - trust it and just copy the octets */
336         sv_setpvn(dst,(char *)s,(e-s));
337         s = e;
338     }
339     else {
340         /* Native bytes - can always encode */
341         U8 *d = (U8 *) SvGROW(dst, 2*slen+1); /* +1 or assertion will botch */
342         while (s < e) {
343             UV uv = NATIVE_TO_UNI((UV) *s++);
344             if (UNI_IS_INVARIANT(uv))
345                 *d++ = (U8)UTF_TO_NATIVE(uv);
346             else {
347                 *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
348                 *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
349             }
350         }
351         SvCUR_set(dst, d- (U8 *)SvPVX(dst));
352         *SvEND(dst) = '\0';
353     }
354
355     /* Clear out translated part of source unless asked not to */
356     if (check && !(check & ENCODE_LEAVE_SRC)){
357         slen = e-s;
358         if (slen) {
359             sv_setpvn(src, (char*)s, slen);
360         }
361         SvCUR_set(src, slen);
362     }
363     SvPOK_only(dst);
364     SvUTF8_off(dst);
365     ST(0) = sv_2mortal(dst);
366     XSRETURN(1);
367 }
368
369 MODULE = Encode         PACKAGE = Encode::XS    PREFIX = Method_
370
371 PROTOTYPES: ENABLE
372
373 void
374 Method_name(obj)
375 SV *    obj
376 CODE:
377 {
378     encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
379     ST(0) = sv_2mortal(newSVpvn(enc->name[0],strlen(enc->name[0])));
380     XSRETURN(1);
381 }
382
383 void
384 Method_decode(obj,src,check = 0)
385 SV *    obj
386 SV *    src
387 int     check
388 CODE:
389 {
390     encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
391     if (SvUTF8(src)) {
392         sv_utf8_downgrade(src, FALSE);
393     }
394     ST(0) = encode_method(aTHX_ enc, enc->t_utf8, src, check);
395     SvUTF8_on(ST(0));
396     XSRETURN(1);
397 }
398
399 void
400 Method_encode(obj,src,check = 0)
401 SV *    obj
402 SV *    src
403 int     check
404 CODE:
405 {
406     encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
407     sv_utf8_upgrade(src);
408     ST(0) = encode_method(aTHX_ enc, enc->f_utf8, src, check);
409     XSRETURN(1);
410 }
411
412 void
413 Method_needs_lines(obj)
414 SV *    obj
415 CODE:
416 {
417     /* encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj))); */
418     ST(0) = &PL_sv_no;
419     XSRETURN(1);
420 }
421
422 void
423 Method_perlio_ok(obj)
424 SV *    obj
425 CODE:
426 {
427     /* encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj))); */
428     /* require_pv(PERLIO_FILENAME); */
429
430     eval_pv("require PerlIO::encoding", 0);
431
432     if (SvTRUE(get_sv("@", 0))) {
433         ST(0) = &PL_sv_no;
434     }else{
435         ST(0) = &PL_sv_yes;
436     }
437     XSRETURN(1);
438 }
439
440 MODULE = Encode         PACKAGE = Encode
441
442 PROTOTYPES: ENABLE
443
444 I32
445 _bytes_to_utf8(sv, ...)
446 SV *    sv
447 CODE:
448 {
449     SV * encoding = items == 2 ? ST(1) : Nullsv;
450
451     if (encoding)
452     RETVAL = _encoded_bytes_to_utf8(sv, SvPV_nolen(encoding));
453     else {
454         STRLEN len;
455         U8*    s = (U8*)SvPV(sv, len);
456         U8*    converted;
457
458         converted = bytes_to_utf8(s, &len); /* This allocs */
459         sv_setpvn(sv, (char *)converted, len);
460         SvUTF8_on(sv); /* XXX Should we? */
461         Safefree(converted);                /* ... so free it */
462         RETVAL = len;
463     }
464 }
465 OUTPUT:
466     RETVAL
467
468 I32
469 _utf8_to_bytes(sv, ...)
470 SV *    sv
471 CODE:
472 {
473     SV * to    = items > 1 ? ST(1) : Nullsv;
474     SV * check = items > 2 ? ST(2) : Nullsv;
475
476     if (to) {
477         RETVAL = _encoded_utf8_to_bytes(sv, SvPV_nolen(to));
478     } else {
479         STRLEN len;
480         U8 *s = (U8*)SvPV(sv, len);
481
482         RETVAL = 0;
483         if (SvTRUE(check)) {
484             /* Must do things the slow way */
485             U8 *dest;
486             /* We need a copy to pass to check() */
487             U8 *src  = (U8*)savepv((char *)s);
488             U8 *send = s + len;
489
490             New(83, dest, len, U8); /* I think */
491
492             while (s < send) {
493                 if (*s < 0x80){
494                     *dest++ = *s++;
495                 } else {
496                     STRLEN ulen;
497                     UV uv = *s++;
498
499                     /* Have to do it all ourselves because of error routine,
500                        aargh. */
501                     if (!(uv & 0x40)){ goto failure; }
502                     if      (!(uv & 0x20)) { ulen = 2;  uv &= 0x1f; }
503                     else if (!(uv & 0x10)) { ulen = 3;  uv &= 0x0f; }
504                     else if (!(uv & 0x08)) { ulen = 4;  uv &= 0x07; }
505                     else if (!(uv & 0x04)) { ulen = 5;  uv &= 0x03; }
506                     else if (!(uv & 0x02)) { ulen = 6;  uv &= 0x01; }
507                     else if (!(uv & 0x01)) { ulen = 7;  uv = 0; }
508                     else                   { ulen = 13; uv = 0; }
509
510                     /* Note change to utf8.c variable naming, for variety */
511                     while (ulen--) {
512                         if ((*s & 0xc0) != 0x80){
513                             goto failure;
514                         } else {
515                             uv = (uv << 6) | (*s++ & 0x3f);
516                         }
517                   }
518                   if (uv > 256) {
519                   failure:
520                       call_failure(check, s, dest, src);
521                       /* Now what happens? */
522                   }
523                   *dest++ = (U8)uv;
524                 }
525             }
526         } else {
527             RETVAL = (utf8_to_bytes(s, &len) ? len : 0);
528         }
529     }
530 }
531 OUTPUT:
532     RETVAL
533
534 bool
535 is_utf8(sv, check = 0)
536 SV *    sv
537 int     check
538 CODE:
539 {
540     if (SvGMAGICAL(sv)) /* it could be $1, for example */
541         sv = newSVsv(sv); /* GMAGIG will be done */
542     if (SvPOK(sv)) {
543         RETVAL = SvUTF8(sv) ? TRUE : FALSE;
544         if (RETVAL &&
545             check  &&
546             !is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
547             RETVAL = FALSE;
548     } else {
549         RETVAL = FALSE;
550     }
551     if (sv != ST(0))
552         SvREFCNT_dec(sv); /* it was a temp copy */
553 }
554 OUTPUT:
555     RETVAL
556
557 SV *
558 _utf8_on(sv)
559 SV *    sv
560 CODE:
561 {
562     if (SvPOK(sv)) {
563         SV *rsv = newSViv(SvUTF8(sv));
564         RETVAL = rsv;
565         SvUTF8_on(sv);
566     } else {
567         RETVAL = &PL_sv_undef;
568     }
569 }
570 OUTPUT:
571     RETVAL
572
573 SV *
574 _utf8_off(sv)
575 SV *    sv
576 CODE:
577 {
578     if (SvPOK(sv)) {
579         SV *rsv = newSViv(SvUTF8(sv));
580         RETVAL = rsv;
581         SvUTF8_off(sv);
582     } else {
583         RETVAL = &PL_sv_undef;
584     }
585 }
586 OUTPUT:
587     RETVAL
588
589 int
590 DIE_ON_ERR()
591 CODE:
592     RETVAL = ENCODE_DIE_ON_ERR;
593 OUTPUT:
594     RETVAL
595
596 int
597 WARN_ON_ERR()
598 CODE:
599     RETVAL = ENCODE_WARN_ON_ERR;
600 OUTPUT:
601     RETVAL
602
603 int
604 LEAVE_SRC()
605 CODE:
606     RETVAL = ENCODE_LEAVE_SRC;
607 OUTPUT:
608     RETVAL
609
610 int
611 RETURN_ON_ERR()
612 CODE:
613     RETVAL = ENCODE_RETURN_ON_ERR;
614 OUTPUT:
615     RETVAL
616
617 int
618 PERLQQ()
619 CODE:
620     RETVAL = ENCODE_PERLQQ;
621 OUTPUT:
622     RETVAL
623
624 int
625 HTMLCREF()
626 CODE:
627     RETVAL = ENCODE_HTMLCREF;
628 OUTPUT:
629     RETVAL
630
631 int
632 XMLCREF()
633 CODE:
634     RETVAL = ENCODE_XMLCREF;
635 OUTPUT:
636     RETVAL
637
638 int
639 FB_DEFAULT()
640 CODE:
641     RETVAL = ENCODE_FB_DEFAULT;
642 OUTPUT:
643     RETVAL
644
645 int
646 FB_CROAK()
647 CODE:
648     RETVAL = ENCODE_FB_CROAK;
649 OUTPUT:
650     RETVAL
651
652 int
653 FB_QUIET()
654 CODE:
655     RETVAL = ENCODE_FB_QUIET;
656 OUTPUT:
657     RETVAL
658
659 int
660 FB_WARN()
661 CODE:
662     RETVAL = ENCODE_FB_WARN;
663 OUTPUT:
664     RETVAL
665
666 int
667 FB_PERLQQ()
668 CODE:
669     RETVAL = ENCODE_FB_PERLQQ;
670 OUTPUT:
671     RETVAL
672
673 int
674 FB_HTMLCREF()
675 CODE:
676     RETVAL = ENCODE_FB_HTMLCREF;
677 OUTPUT:
678     RETVAL
679
680 int
681 FB_XMLCREF()
682 CODE:
683     RETVAL = ENCODE_FB_XMLCREF;
684 OUTPUT:
685     RETVAL
686
687 BOOT:
688 {
689 #include "def_t.h"
690 #include "def_t.exh"
691 }