57fc9a01d65438c71b8c4e211fe8b7b465425b5b
[p5sagit/p5-mst-13.2.git] / ext / Encode / Encode.xs
1 /*
2  $Id: Encode.xs,v 1.46 2002/05/20 15:25:44 dankogai Exp dankogai $
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(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);
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(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);
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);
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     ST(0) = encode_method(aTHX_ enc, enc->t_utf8, src, check);
392     SvUTF8_on(ST(0));
393     XSRETURN(1);
394 }
395
396 void
397 Method_encode(obj,src,check = 0)
398 SV *    obj
399 SV *    src
400 int     check
401 CODE:
402 {
403     encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
404     sv_utf8_upgrade(src);
405     ST(0) = encode_method(aTHX_ enc, enc->f_utf8, src, check);
406     XSRETURN(1);
407 }
408
409 void
410 Method_needs_lines(obj)
411 SV *    obj
412 CODE:
413 {
414     /* encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj))); */
415     ST(0) = &PL_sv_no;
416     XSRETURN(1);
417 }
418
419 void
420 Method_perlio_ok(obj)
421 SV *    obj
422 CODE:
423 {
424     /* encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj))); */
425     /* require_pv(PERLIO_FILENAME); */
426
427     eval_pv("require PerlIO::encoding", 0);
428
429     if (SvTRUE(get_sv("@", 0))) {
430         ST(0) = &PL_sv_no;
431     }else{
432         ST(0) = &PL_sv_yes;
433     }
434     XSRETURN(1);
435 }
436
437 MODULE = Encode         PACKAGE = Encode
438
439 PROTOTYPES: ENABLE
440
441 I32
442 _bytes_to_utf8(sv, ...)
443 SV *    sv
444 CODE:
445 {
446     SV * encoding = items == 2 ? ST(1) : Nullsv;
447
448     if (encoding)
449     RETVAL = _encoded_bytes_to_utf8(sv, SvPV_nolen(encoding));
450     else {
451         STRLEN len;
452         U8*    s = (U8*)SvPV(sv, len);
453         U8*    converted;
454
455         converted = bytes_to_utf8(s, &len); /* This allocs */
456         sv_setpvn(sv, (char *)converted, len);
457         SvUTF8_on(sv); /* XXX Should we? */
458         Safefree(converted);                /* ... so free it */
459         RETVAL = len;
460     }
461 }
462 OUTPUT:
463     RETVAL
464
465 I32
466 _utf8_to_bytes(sv, ...)
467 SV *    sv
468 CODE:
469 {
470     SV * to    = items > 1 ? ST(1) : Nullsv;
471     SV * check = items > 2 ? ST(2) : Nullsv;
472
473     if (to) {
474         RETVAL = _encoded_utf8_to_bytes(sv, SvPV_nolen(to));
475     } else {
476         STRLEN len;
477         U8 *s = (U8*)SvPV(sv, len);
478
479         RETVAL = 0;
480         if (SvTRUE(check)) {
481             /* Must do things the slow way */
482             U8 *dest;
483             /* We need a copy to pass to check() */
484             U8 *src  = (U8*)savepv((char *)s);
485             U8 *send = s + len;
486
487             New(83, dest, len, U8); /* I think */
488
489             while (s < send) {
490                 if (*s < 0x80){
491                     *dest++ = *s++;
492                 } else {
493                     STRLEN ulen;
494                     UV uv = *s++;
495
496                     /* Have to do it all ourselves because of error routine,
497                        aargh. */
498                     if (!(uv & 0x40)){ goto failure; }
499                     if      (!(uv & 0x20)) { ulen = 2;  uv &= 0x1f; }
500                     else if (!(uv & 0x10)) { ulen = 3;  uv &= 0x0f; }
501                     else if (!(uv & 0x08)) { ulen = 4;  uv &= 0x07; }
502                     else if (!(uv & 0x04)) { ulen = 5;  uv &= 0x03; }
503                     else if (!(uv & 0x02)) { ulen = 6;  uv &= 0x01; }
504                     else if (!(uv & 0x01)) { ulen = 7;  uv = 0; }
505                     else                   { ulen = 13; uv = 0; }
506                 
507                     /* Note change to utf8.c variable naming, for variety */
508                     while (ulen--) {
509                         if ((*s & 0xc0) != 0x80){
510                             goto failure;
511                         } else {
512                             uv = (uv << 6) | (*s++ & 0x3f);
513                         }
514                   }
515                   if (uv > 256) {
516                   failure:
517                       call_failure(check, s, dest, src);
518                       /* Now what happens? */
519                   }
520                   *dest++ = (U8)uv;
521                 }
522             }
523         } else {
524             RETVAL = (utf8_to_bytes(s, &len) ? len : 0);
525         }
526     }
527 }
528 OUTPUT:
529     RETVAL
530
531 bool
532 is_utf8(sv, check = 0)
533 SV *    sv
534 int     check
535 CODE:
536 {
537     if (SvGMAGICAL(sv)) /* it could be $1, for example */
538         sv = newSVsv(sv); /* GMAGIG will be done */
539     if (SvPOK(sv)) {
540         RETVAL = SvUTF8(sv) ? TRUE : FALSE;
541         if (RETVAL &&
542             check  &&
543             !is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
544             RETVAL = FALSE;
545     } else {
546         RETVAL = FALSE;
547     }
548     if (sv != ST(0))
549         SvREFCNT_dec(sv); /* it was a temp copy */
550 }
551 OUTPUT:
552     RETVAL
553
554 SV *
555 _utf8_on(sv)
556 SV *    sv
557 CODE:
558 {
559     if (SvPOK(sv)) {
560         SV *rsv = newSViv(SvUTF8(sv));
561         RETVAL = rsv;
562         SvUTF8_on(sv);
563     } else {
564         RETVAL = &PL_sv_undef;
565     }
566 }
567 OUTPUT:
568     RETVAL
569
570 SV *
571 _utf8_off(sv)
572 SV *    sv
573 CODE:
574 {
575     if (SvPOK(sv)) {
576         SV *rsv = newSViv(SvUTF8(sv));
577         RETVAL = rsv;
578         SvUTF8_off(sv);
579     } else {
580         RETVAL = &PL_sv_undef;
581     }
582 }
583 OUTPUT:
584     RETVAL
585
586 int
587 DIE_ON_ERR()
588 CODE:
589     RETVAL = ENCODE_DIE_ON_ERR;
590 OUTPUT:
591     RETVAL
592
593 int
594 WARN_ON_ERR()
595 CODE:
596     RETVAL = ENCODE_WARN_ON_ERR;
597 OUTPUT:
598     RETVAL
599
600 int
601 LEAVE_SRC()
602 CODE:
603     RETVAL = ENCODE_LEAVE_SRC;
604 OUTPUT:
605     RETVAL
606
607 int
608 RETURN_ON_ERR()
609 CODE:
610     RETVAL = ENCODE_RETURN_ON_ERR;
611 OUTPUT:
612     RETVAL
613
614 int
615 PERLQQ()
616 CODE:
617     RETVAL = ENCODE_PERLQQ;
618 OUTPUT:
619     RETVAL
620
621 int
622 HTMLCREF()
623 CODE:
624     RETVAL = ENCODE_HTMLCREF;
625 OUTPUT:
626     RETVAL
627
628 int
629 XMLCREF()
630 CODE:
631     RETVAL = ENCODE_XMLCREF;
632 OUTPUT:
633     RETVAL
634
635 int
636 FB_DEFAULT()
637 CODE:
638     RETVAL = ENCODE_FB_DEFAULT;
639 OUTPUT:
640     RETVAL
641
642 int
643 FB_CROAK()
644 CODE:
645     RETVAL = ENCODE_FB_CROAK;
646 OUTPUT:
647     RETVAL
648
649 int
650 FB_QUIET()
651 CODE:
652     RETVAL = ENCODE_FB_QUIET;
653 OUTPUT:
654     RETVAL
655
656 int
657 FB_WARN()
658 CODE:
659     RETVAL = ENCODE_FB_WARN;
660 OUTPUT:
661     RETVAL
662
663 int
664 FB_PERLQQ()
665 CODE:
666     RETVAL = ENCODE_FB_PERLQQ;
667 OUTPUT:
668     RETVAL
669
670 int
671 FB_HTMLCREF()
672 CODE:
673     RETVAL = ENCODE_FB_HTMLCREF;
674 OUTPUT:
675     RETVAL
676
677 int
678 FB_XMLCREF()
679 CODE:
680     RETVAL = ENCODE_FB_XMLCREF;
681 OUTPUT:
682     RETVAL
683
684 BOOT:
685 {
686 #include "def_t.h"
687 #include "def_t.exh"
688 }