This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade Encode from version 2.67 to 2.68
[perl5.git] / cpan / Encode / Encode.xs
1 /*
2  $Id: Encode.xs,v 2.33 2015/01/22 10:17:32 dankogai Exp dankogai $
3  */
4
5 #define PERL_NO_GET_CONTEXT
6 #include "EXTERN.h"
7 #include "perl.h"
8 #include "XSUB.h"
9 #include "encode.h"
10 #include "def_t.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) {               \
24                         Perl_croak_nocontext("panic_unimplemented");    \
25                         PERL_UNUSED_VAR(sv); \
26                         PERL_UNUSED_VAR(encoding); \
27              return (y)0; /* fool picky compilers */ \
28                          }
29 /**/
30
31 UNIMPLEMENTED(_encoded_utf8_to_bytes, I32)
32 UNIMPLEMENTED(_encoded_bytes_to_utf8, I32)
33
34 #ifdef UTF8_DISALLOW_ILLEGAL_INTERCHANGE
35 #   define UTF8_ALLOW_STRICT UTF8_DISALLOW_ILLEGAL_INTERCHANGE
36 #else
37 #   define UTF8_ALLOW_STRICT 0
38 #endif
39
40 #define UTF8_ALLOW_NONSTRICT (UTF8_ALLOW_ANY &                    \
41                               ~(UTF8_ALLOW_CONTINUATION |         \
42                                 UTF8_ALLOW_NON_CONTINUATION |     \
43                                 UTF8_ALLOW_LONG))
44
45 void
46 Encode_XSEncoding(pTHX_ encode_t * enc)
47 {
48     dSP;
49     HV *stash = gv_stashpv("Encode::XS", TRUE);
50     SV *iv    = newSViv(PTR2IV(enc));
51     SV *sv    = sv_bless(newRV_noinc(iv),stash);
52     int i = 0;
53     /* with the SvLEN() == 0 hack, PVX won't be freed. We cast away name's
54     constness, in the hope that perl won't mess with it. */
55     assert(SvTYPE(iv) >= SVt_PV); assert(SvLEN(iv) == 0);
56     SvFLAGS(iv) |= SVp_POK;
57     SvPVX(iv) = (char*) enc->name[0];
58     PUSHMARK(sp);
59     XPUSHs(sv);
60     while (enc->name[i]) {
61     const char *name = enc->name[i++];
62     XPUSHs(sv_2mortal(newSVpvn(name, strlen(name))));
63     }
64     PUTBACK;
65     call_pv("Encode::define_encoding", G_DISCARD);
66     SvREFCNT_dec(sv);
67 }
68
69 void
70 call_failure(SV * routine, U8 * done, U8 * dest, U8 * orig)
71 {
72     /* Exists for breakpointing */
73     PERL_UNUSED_VAR(routine);
74     PERL_UNUSED_VAR(done);
75     PERL_UNUSED_VAR(dest);
76     PERL_UNUSED_VAR(orig);
77 }
78
79
80 #define ERR_ENCODE_NOMAP "\"\\x{%04" UVxf "}\" does not map to %s"
81 #define ERR_DECODE_NOMAP "%s \"\\x%02" UVXf "\" does not map to Unicode"
82
83 static SV *
84 do_fallback_cb(pTHX_ UV ch, SV *fallback_cb)
85 {
86     dSP;
87     int argc;
88     SV *retval = newSVpv("",0);
89     ENTER;
90     SAVETMPS;
91     PUSHMARK(sp);
92     XPUSHs(sv_2mortal(newSVnv((UV)ch)));
93     PUTBACK;
94     argc = call_sv(fallback_cb, G_SCALAR);
95     SPAGAIN;
96     if (argc != 1){
97         croak("fallback sub must return scalar!");
98     }
99     sv_catsv(retval, POPs);
100     PUTBACK;
101     FREETMPS;
102     LEAVE;
103     return retval;
104 }
105
106 static SV *
107 encode_method(pTHX_ const encode_t * enc, const encpage_t * dir, SV * src,
108               int check, STRLEN * offset, SV * term, int * retcode, 
109               SV *fallback_cb)
110 {
111     STRLEN slen;
112     U8 *s = (U8 *) SvPV(src, slen);
113     STRLEN tlen  = slen;
114     STRLEN ddone = 0;
115     STRLEN sdone = 0;
116     /* We allocate slen+1.
117        PerlIO dumps core if this value is smaller than this. */
118     SV *dst = sv_2mortal(newSV(slen+1));
119     U8 *d = (U8 *)SvPVX(dst);
120     STRLEN dlen = SvLEN(dst)-1;
121     int code = 0;
122     STRLEN trmlen = 0;
123     U8 *trm = term ? (U8*) SvPV(term, trmlen) : NULL;
124
125     if (SvTAINTED(src)) SvTAINTED_on(dst); /* propagate taintedness */
126
127     if (offset) {
128       s += *offset;
129       if (slen > *offset){ /* safeguard against slen overflow */
130       slen -= *offset;
131       }else{
132       slen = 0;
133       }
134       tlen = slen;
135     }
136
137     if (slen == 0){
138     SvCUR_set(dst, 0);
139     SvPOK_only(dst);
140     goto ENCODE_END;
141     }
142
143     while( (code = do_encode(dir, s, &slen, d, dlen, &dlen, !check,
144                  trm, trmlen)) ) 
145     {
146     SvCUR_set(dst, dlen+ddone);
147     SvPOK_only(dst);
148     
149     if (code == ENCODE_FALLBACK || code == ENCODE_PARTIAL ||
150         code == ENCODE_FOUND_TERM) {
151         break;
152     }
153     switch (code) {
154     case ENCODE_NOSPACE:
155     {   
156         STRLEN more = 0; /* make sure you initialize! */
157         STRLEN sleft;
158         sdone += slen;
159         ddone += dlen;
160         sleft = tlen - sdone;
161 #if ENCODE_XS_PROFILE >= 2
162         Perl_warn(aTHX_
163               "more=%d, sdone=%d, sleft=%d, SvLEN(dst)=%d\n",
164               more, sdone, sleft, SvLEN(dst));
165 #endif
166         if (sdone != 0) { /* has src ever been processed ? */
167 #if   ENCODE_XS_USEFP == 2
168         more = (1.0*tlen*SvLEN(dst)+sdone-1)/sdone
169             - SvLEN(dst);
170 #elif ENCODE_XS_USEFP
171         more = (STRLEN)((1.0*SvLEN(dst)+1)/sdone * sleft);
172 #else
173         /* safe until SvLEN(dst) == MAX_INT/16 */
174         more = (16*SvLEN(dst)+1)/sdone/16 * sleft;
175 #endif
176         }
177         more += UTF8_MAXLEN; /* insurance policy */
178         d = (U8 *) SvGROW(dst, SvLEN(dst) + more);
179         /* dst need to grow need MORE bytes! */
180         if (ddone >= SvLEN(dst)) {
181         Perl_croak(aTHX_ "Destination couldn't be grown.");
182         }
183         dlen = SvLEN(dst)-ddone-1;
184         d   += ddone;
185         s   += slen;
186         slen = tlen-sdone;
187         continue;
188     }
189     case ENCODE_NOREP:
190         /* encoding */  
191         if (dir == enc->f_utf8) {
192         STRLEN clen;
193         UV ch =
194             utf8n_to_uvuni(s+slen, (SvCUR(src)-slen),
195                    &clen, UTF8_ALLOW_ANY|UTF8_CHECK_ONLY);
196         /* if non-representable multibyte prefix at end of current buffer - break*/
197         if (clen > tlen - sdone) break;
198         if (check & ENCODE_DIE_ON_ERR) {
199             Perl_croak(aTHX_ ERR_ENCODE_NOMAP,
200                    (UV)ch, enc->name[0]);
201             return &PL_sv_undef; /* never reaches but be safe */
202         }
203         if (check & ENCODE_WARN_ON_ERR){
204             Perl_warner(aTHX_ packWARN(WARN_UTF8),
205                 ERR_ENCODE_NOMAP, (UV)ch, enc->name[0]);
206         }
207         if (check & ENCODE_RETURN_ON_ERR){
208             goto ENCODE_SET_SRC;
209         }
210         if (check & (ENCODE_PERLQQ|ENCODE_HTMLCREF|ENCODE_XMLCREF)){
211             SV* subchar = 
212             (fallback_cb != &PL_sv_undef)
213                 ? do_fallback_cb(aTHX_ ch, fallback_cb)
214                 : newSVpvf(check & ENCODE_PERLQQ ? "\\x{%04"UVxf"}" :
215                  check & ENCODE_HTMLCREF ? "&#%" UVuf ";" :
216                  "&#x%" UVxf ";", (UV)ch);
217             SvUTF8_off(subchar); /* make sure no decoded string gets in */
218             sdone += slen + clen;
219             ddone += dlen + SvCUR(subchar);
220             sv_catsv(dst, subchar);
221             SvREFCNT_dec(subchar);
222         } else {
223             /* fallback char */
224             sdone += slen + clen;
225             ddone += dlen + enc->replen;
226             sv_catpvn(dst, (char*)enc->rep, enc->replen);
227         }
228         }
229         /* decoding */
230         else {
231         if (check & ENCODE_DIE_ON_ERR){
232             Perl_croak(aTHX_ ERR_DECODE_NOMAP,
233                               enc->name[0], (UV)s[slen]);
234             return &PL_sv_undef; /* never reaches but be safe */
235         }
236         if (check & ENCODE_WARN_ON_ERR){
237             Perl_warner(
238             aTHX_ packWARN(WARN_UTF8),
239             ERR_DECODE_NOMAP,
240                         enc->name[0], (UV)s[slen]);
241         }
242         if (check & ENCODE_RETURN_ON_ERR){
243             goto ENCODE_SET_SRC;
244         }
245         if (check &
246             (ENCODE_PERLQQ|ENCODE_HTMLCREF|ENCODE_XMLCREF)){
247             SV* subchar = 
248             (fallback_cb != &PL_sv_undef)
249                 ? do_fallback_cb(aTHX_ (UV)s[slen], fallback_cb) 
250                 : newSVpvf("\\x%02" UVXf, (UV)s[slen]);
251             sdone += slen + 1;
252             ddone += dlen + SvCUR(subchar);
253             sv_catsv(dst, subchar);
254             SvREFCNT_dec(subchar);
255         } else {
256             sdone += slen + 1;
257             ddone += dlen + strlen(FBCHAR_UTF8);
258             sv_catpv(dst, FBCHAR_UTF8);
259         }
260         }
261         /* settle variables when fallback */
262         d    = (U8 *)SvEND(dst);
263             dlen = SvLEN(dst) - ddone - 1;
264         s    = (U8*)SvPVX(src) + sdone;
265         slen = tlen - sdone;
266         break;
267
268     default:
269         Perl_croak(aTHX_ "Unexpected code %d converting %s %s",
270                code, (dir == enc->f_utf8) ? "to" : "from",
271                enc->name[0]);
272         return &PL_sv_undef;
273     }
274     }
275  ENCODE_SET_SRC:
276     if (check && !(check & ENCODE_LEAVE_SRC)){
277     sdone = SvCUR(src) - (slen+sdone);
278     if (sdone) {
279         sv_setpvn(src, (char*)s+slen, sdone);
280     }
281     SvCUR_set(src, sdone);
282     }
283     /* warn("check = 0x%X, code = 0x%d\n", check, code); */
284
285     SvCUR_set(dst, dlen+ddone);
286     SvPOK_only(dst);
287
288 #if ENCODE_XS_PROFILE
289     if (SvCUR(dst) > SvCUR(src)){
290     Perl_warn(aTHX_
291           "SvLEN(dst)=%d, SvCUR(dst)=%d. %d bytes unused(%f %%)\n",
292           SvLEN(dst), SvCUR(dst), SvLEN(dst) - SvCUR(dst),
293           (SvLEN(dst) - SvCUR(dst))*1.0/SvLEN(dst)*100.0);
294     }
295 #endif
296
297     if (offset) 
298       *offset += sdone + slen;
299
300  ENCODE_END:
301     *SvEND(dst) = '\0';
302     if (retcode) *retcode = code;
303     return dst;
304 }
305
306 static bool
307 strict_utf8(pTHX_ SV* sv)
308 {
309     HV* hv;
310     SV** svp;
311     sv = SvRV(sv);
312     if (!sv || SvTYPE(sv) != SVt_PVHV)
313         return 0;
314     hv = (HV*)sv;
315     svp = hv_fetch(hv, "strict_utf8", 11, 0);
316     if (!svp)
317         return 0;
318     return SvTRUE(*svp);
319 }
320
321 static U8*
322 process_utf8(pTHX_ SV* dst, U8* s, U8* e, SV *check_sv,
323              bool encode, bool strict, bool stop_at_partial)
324 {
325     UV uv;
326     STRLEN ulen;
327     SV *fallback_cb;
328     int check;
329
330     if (SvROK(check_sv)) {
331         /* croak("UTF-8 decoder doesn't support callback CHECK"); */
332         fallback_cb = check_sv;
333         check = ENCODE_PERLQQ|ENCODE_LEAVE_SRC; /* same as perlqq */
334     }
335     else {
336         fallback_cb = &PL_sv_undef;
337         check = SvIV(check_sv);
338     }
339
340     SvPOK_only(dst);
341     SvCUR_set(dst,0);
342
343     while (s < e) {
344         if (UTF8_IS_INVARIANT(*s)) {
345             sv_catpvn(dst, (char *)s, 1);
346             s++;
347             continue;
348         }
349
350         if (UTF8_IS_START(*s)) {
351             U8 skip = UTF8SKIP(s);
352             if ((s + skip) > e) {
353                 if (stop_at_partial || (check & ENCODE_STOP_AT_PARTIAL)) {
354                     const U8 *p = s + 1;
355                     for (; p < e; p++) {
356                         if (!UTF8_IS_CONTINUATION(*p))
357                             goto malformed_byte;
358                     }
359                     break;
360                 }
361
362                 goto malformed_byte;
363             }
364
365             uv = utf8n_to_uvuni(s, e - s, &ulen,
366                                 UTF8_CHECK_ONLY | (strict ? UTF8_ALLOW_STRICT :
367                                                             UTF8_ALLOW_NONSTRICT)
368                                );
369 #if 1 /* perl-5.8.6 and older do not check UTF8_ALLOW_LONG */
370         if (strict && uv > PERL_UNICODE_MAX)
371         ulen = (STRLEN) -1;
372 #endif
373             if (ulen == (STRLEN) -1) {
374                 if (strict) {
375                     uv = utf8n_to_uvuni(s, e - s, &ulen,
376                                         UTF8_CHECK_ONLY | UTF8_ALLOW_NONSTRICT);
377                     if (ulen == (STRLEN) -1)
378                         goto malformed_byte;
379                     goto malformed;
380                 }
381                 goto malformed_byte;
382             }
383
384
385              /* Whole char is good */
386              sv_catpvn(dst,(char *)s,skip);
387              s += skip;
388              continue;
389         }
390
391         /* If we get here there is something wrong with alleged UTF-8 */
392     malformed_byte:
393         uv = (UV)*s;
394         ulen = 1;
395
396     malformed:
397         if (check & ENCODE_DIE_ON_ERR){
398             if (encode)
399                 Perl_croak(aTHX_ ERR_ENCODE_NOMAP, uv, "utf8");
400             else
401                 Perl_croak(aTHX_ ERR_DECODE_NOMAP, "utf8", uv);
402         }
403         if (check & ENCODE_WARN_ON_ERR){
404             if (encode)
405                 Perl_warner(aTHX_ packWARN(WARN_UTF8),
406                             ERR_ENCODE_NOMAP, uv, "utf8");
407             else
408                 Perl_warner(aTHX_ packWARN(WARN_UTF8),
409                             ERR_DECODE_NOMAP, "utf8", uv);
410         }
411         if (check & ENCODE_RETURN_ON_ERR) {
412                 break;
413         }
414         if (check & (ENCODE_PERLQQ|ENCODE_HTMLCREF|ENCODE_XMLCREF)){
415             SV* subchar =
416                 (fallback_cb != &PL_sv_undef)
417                 ? do_fallback_cb(aTHX_ uv, fallback_cb)
418                 : newSVpvf(check & ENCODE_PERLQQ 
419                            ? (ulen == 1 ? "\\x%02" UVXf : "\\x{%04" UVXf "}")
420                            :  check & ENCODE_HTMLCREF ? "&#%" UVuf ";" 
421                            : "&#x%" UVxf ";", uv);
422             if (encode){
423                 SvUTF8_off(subchar); /* make sure no decoded string gets in */
424             }
425             sv_catsv(dst, subchar);
426             SvREFCNT_dec(subchar);
427         } else {
428             sv_catpv(dst, FBCHAR_UTF8);
429         }
430         s += ulen;
431     }
432     *SvEND(dst) = '\0';
433
434     return s;
435 }
436
437
438 MODULE = Encode         PACKAGE = Encode::utf8  PREFIX = Method_
439
440 PROTOTYPES: DISABLE
441
442 void
443 Method_decode_xs(obj,src,check_sv = &PL_sv_no)
444 SV *    obj
445 SV *    src
446 SV *    check_sv
447 PREINIT:
448     STRLEN slen;
449     U8 *s;
450     U8 *e;
451     SV *dst;
452     bool renewed = 0;
453     int check;
454 CODE:
455 {
456     dSP; ENTER; SAVETMPS;
457     if (src == &PL_sv_undef || SvROK(src)) src = sv_2mortal(newSV(0));
458     s = (U8 *) SvPV(src, slen);
459     e = (U8 *) SvEND(src);
460     check = SvROK(check_sv) ? ENCODE_PERLQQ|ENCODE_LEAVE_SRC : SvIV(check_sv);
461     /* 
462      * PerlIO check -- we assume the object is of PerlIO if renewed
463      */
464     PUSHMARK(sp);
465     XPUSHs(obj);
466     PUTBACK;
467     if (call_method("renewed",G_SCALAR) == 1) {
468     SPAGAIN;
469     renewed = (bool)POPi;
470     PUTBACK; 
471 #if 0
472     fprintf(stderr, "renewed == %d\n", renewed);
473 #endif
474     }
475     FREETMPS; LEAVE;
476     /* end PerlIO check */
477
478     if (SvUTF8(src)) {
479     s = utf8_to_bytes(s,&slen);
480     if (s) {
481         SvCUR_set(src,slen);
482         SvUTF8_off(src);
483         e = s+slen;
484     }
485     else {
486         croak("Cannot decode string with wide characters");
487     }
488     }
489
490     dst = sv_2mortal(newSV(slen>0?slen:1)); /* newSV() abhors 0 -- inaba */
491     s = process_utf8(aTHX_ dst, s, e, check_sv, 0, strict_utf8(aTHX_ obj), renewed);
492
493     /* Clear out translated part of source unless asked not to */
494     if (check && !(check & ENCODE_LEAVE_SRC)){
495     slen = e-s;
496     if (slen) {
497         sv_setpvn(src, (char*)s, slen);
498     }
499     SvCUR_set(src, slen);
500     }
501     SvUTF8_on(dst);
502     if (SvTAINTED(src)) SvTAINTED_on(dst); /* propagate taintedness */
503     ST(0) = dst;
504     XSRETURN(1);
505 }
506
507 void
508 Method_encode_xs(obj,src,check_sv = &PL_sv_no)
509 SV *    obj
510 SV *    src
511 SV *    check_sv
512 PREINIT:
513     STRLEN slen;
514     U8 *s;
515     U8 *e;
516     SV *dst;
517     int check;
518 CODE:
519 {
520     check = SvROK(check_sv) ? ENCODE_PERLQQ|ENCODE_LEAVE_SRC : SvIV(check_sv);
521     if (src == &PL_sv_undef || SvROK(src)) src = sv_2mortal(newSV(0));
522     s = (U8 *) SvPV(src, slen);
523     e = (U8 *) SvEND(src);
524     dst = sv_2mortal(newSV(slen>0?slen:1)); /* newSV() abhors 0 -- inaba */
525     if (SvUTF8(src)) {
526     /* Already encoded */
527     if (strict_utf8(aTHX_ obj)) {
528         s = process_utf8(aTHX_ dst, s, e, check_sv, 1, 1, 0);
529     }
530         else {
531             /* trust it and just copy the octets */
532             sv_setpvn(dst,(char *)s,(e-s));
533         s = e;
534         }
535     }
536     else {
537         /* Native bytes - can always encode */
538     U8 *d = (U8 *) SvGROW(dst, 2*slen+1); /* +1 or assertion will botch */
539         while (s < e) {
540             UV uv = NATIVE_TO_UNI((UV) *s);
541             s++; /* Above expansion of NATIVE_TO_UNI() is safer this way. */
542             if (UNI_IS_INVARIANT(uv))
543                 *d++ = (U8)UTF_TO_NATIVE(uv);
544             else {
545                 *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
546                 *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
547             }
548     }
549         SvCUR_set(dst, d- (U8 *)SvPVX(dst));
550         *SvEND(dst) = '\0';
551     }
552
553     /* Clear out translated part of source unless asked not to */
554     if (check && !(check & ENCODE_LEAVE_SRC)){
555     slen = e-s;
556     if (slen) {
557         sv_setpvn(src, (char*)s, slen);
558     }
559     SvCUR_set(src, slen);
560     }
561     SvPOK_only(dst);
562     SvUTF8_off(dst);
563     if (SvTAINTED(src)) SvTAINTED_on(dst); /* propagate taintedness */
564     ST(0) = dst;
565     XSRETURN(1);
566 }
567
568 MODULE = Encode         PACKAGE = Encode::XS    PREFIX = Method_
569
570 PROTOTYPES: ENABLE
571
572 void
573 Method_renew(obj)
574 SV *    obj
575 CODE:
576 {
577     PERL_UNUSED_VAR(obj);
578     XSRETURN(1);
579 }
580
581 int
582 Method_renewed(obj)
583 SV *    obj
584 CODE:
585     RETVAL = 0;
586     PERL_UNUSED_VAR(obj);
587 OUTPUT:
588     RETVAL
589
590 void
591 Method_name(obj)
592 SV *    obj
593 CODE:
594 {
595     encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
596     ST(0) = sv_2mortal(newSVpvn(enc->name[0],strlen(enc->name[0])));
597     XSRETURN(1);
598 }
599
600 void
601 Method_cat_decode(obj, dst, src, off, term, check_sv = &PL_sv_no)
602 SV *    obj
603 SV *    dst
604 SV *    src
605 SV *    off
606 SV *    term
607 SV *    check_sv
608 CODE:
609 {
610     int check;
611     SV *fallback_cb = &PL_sv_undef;
612     encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
613     STRLEN offset = (STRLEN)SvIV(off);
614     int code = 0;
615     if (SvUTF8(src)) {
616         sv_utf8_downgrade(src, FALSE);
617     }
618     if (SvROK(check_sv)){
619         fallback_cb = check_sv;
620         check = ENCODE_PERLQQ|ENCODE_LEAVE_SRC; /* same as FB_PERLQQ */
621     }else{
622         check = SvIV(check_sv);
623     }
624     sv_catsv(dst, encode_method(aTHX_ enc, enc->t_utf8, src, check,
625                 &offset, term, &code, fallback_cb));
626     SvIV_set(off, (IV)offset);
627     if (code == ENCODE_FOUND_TERM) {
628     ST(0) = &PL_sv_yes;
629     }else{
630     ST(0) = &PL_sv_no;
631     }
632     XSRETURN(1);
633 }
634
635 void
636 Method_decode(obj,src,check_sv = &PL_sv_no)
637 SV *    obj
638 SV *    src
639 SV *    check_sv
640 CODE:
641 {
642     int check;
643     SV *fallback_cb = &PL_sv_undef;
644     encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
645     if (SvUTF8(src)) {
646         sv_utf8_downgrade(src, FALSE);
647     }
648     if (SvROK(check_sv)){
649         fallback_cb = check_sv;
650         check = ENCODE_PERLQQ|ENCODE_LEAVE_SRC; /* same as FB_PERLQQ */
651     }else{
652         check = SvIV(check_sv);
653     }
654     ST(0) = encode_method(aTHX_ enc, enc->t_utf8, src, check,
655               NULL, Nullsv, NULL, fallback_cb);
656     SvUTF8_on(ST(0));
657     XSRETURN(1);
658 }
659
660 void
661 Method_encode(obj,src,check_sv = &PL_sv_no)
662 SV *    obj
663 SV *    src
664 SV *    check_sv
665 CODE:
666 {
667     int check;
668     SV *fallback_cb = &PL_sv_undef;
669     encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
670     sv_utf8_upgrade(src);
671     if (SvROK(check_sv)){
672         fallback_cb = check_sv;
673         check = ENCODE_PERLQQ|ENCODE_LEAVE_SRC; /* same as FB_PERLQQ */
674     }else{
675         check = SvIV(check_sv);
676     }
677     ST(0) = encode_method(aTHX_ enc, enc->f_utf8, src, check,
678               NULL, Nullsv, NULL, fallback_cb);
679     XSRETURN(1);
680 }
681
682 void
683 Method_needs_lines(obj)
684 SV *    obj
685 CODE:
686 {
687     /* encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj))); */
688     PERL_UNUSED_VAR(obj);
689     ST(0) = &PL_sv_no;
690     XSRETURN(1);
691 }
692
693 void
694 Method_perlio_ok(obj)
695 SV *    obj
696 CODE:
697 {
698     /* encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj))); */
699     /* require_pv(PERLIO_FILENAME); */
700
701     PERL_UNUSED_VAR(obj);
702     eval_pv("require PerlIO::encoding", 0);
703     SPAGAIN;
704
705     if (SvTRUE(get_sv("@", 0))) {
706     ST(0) = &PL_sv_no;
707     }else{
708     ST(0) = &PL_sv_yes;
709     }
710     XSRETURN(1);
711 }
712
713 void
714 Method_mime_name(obj)
715 SV *    obj
716 CODE:
717 {
718     encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
719     SV *retval;
720     eval_pv("require Encode::MIME::Name", 0);
721     SPAGAIN;
722
723     if (SvTRUE(get_sv("@", 0))) {
724         ST(0) = &PL_sv_undef;
725     }else{
726         ENTER;
727         SAVETMPS;
728         PUSHMARK(sp);
729         XPUSHs(sv_2mortal(newSVpvn(enc->name[0], strlen(enc->name[0]))));
730         PUTBACK;
731         call_pv("Encode::MIME::Name::get_mime_name", G_SCALAR);
732         SPAGAIN;
733         retval = newSVsv(POPs);
734         PUTBACK;
735         FREETMPS;
736         LEAVE;
737         /* enc->name[0] */
738         ST(0) = retval;
739     }
740     XSRETURN(1);
741 }
742
743 MODULE = Encode         PACKAGE = Encode
744
745 PROTOTYPES: ENABLE
746
747 I32
748 _bytes_to_utf8(sv, ...)
749 SV *    sv
750 CODE:
751 {
752     SV * encoding = items == 2 ? ST(1) : Nullsv;
753
754     if (encoding)
755     RETVAL = _encoded_bytes_to_utf8(sv, SvPV_nolen(encoding));
756     else {
757     STRLEN len;
758     U8*    s = (U8*)SvPV(sv, len);
759     U8*    converted;
760
761     converted = bytes_to_utf8(s, &len); /* This allocs */
762     sv_setpvn(sv, (char *)converted, len);
763     SvUTF8_on(sv); /* XXX Should we? */
764     Safefree(converted);                /* ... so free it */
765     RETVAL = len;
766     }
767 }
768 OUTPUT:
769     RETVAL
770
771 I32
772 _utf8_to_bytes(sv, ...)
773 SV *    sv
774 CODE:
775 {
776     SV * to    = items > 1 ? ST(1) : Nullsv;
777     SV * check = items > 2 ? ST(2) : Nullsv;
778
779     if (to) {
780     RETVAL = _encoded_utf8_to_bytes(sv, SvPV_nolen(to));
781     } else {
782     STRLEN len;
783     U8 *s = (U8*)SvPV(sv, len);
784
785     RETVAL = 0;
786     if (SvTRUE(check)) {
787         /* Must do things the slow way */
788         U8 *dest;
789             /* We need a copy to pass to check() */
790         U8 *src  = s;
791         U8 *send = s + len;
792         U8 *d0;
793
794         New(83, dest, len, U8); /* I think */
795         d0 = dest;
796
797         while (s < send) {
798                 if (*s < 0x80){
799             *dest++ = *s++;
800                 } else {
801             STRLEN ulen;
802             UV uv = *s++;
803
804             /* Have to do it all ourselves because of error routine,
805                aargh. */
806             if (!(uv & 0x40)){ goto failure; }
807             if      (!(uv & 0x20)) { ulen = 2;  uv &= 0x1f; }
808             else if (!(uv & 0x10)) { ulen = 3;  uv &= 0x0f; }
809             else if (!(uv & 0x08)) { ulen = 4;  uv &= 0x07; }
810             else if (!(uv & 0x04)) { ulen = 5;  uv &= 0x03; }
811             else if (!(uv & 0x02)) { ulen = 6;  uv &= 0x01; }
812             else if (!(uv & 0x01)) { ulen = 7;  uv = 0; }
813             else                   { ulen = 13; uv = 0; }
814         
815             /* Note change to utf8.c variable naming, for variety */
816             while (ulen--) {
817             if ((*s & 0xc0) != 0x80){
818                 goto failure;
819             } else {
820                 uv = (uv << 6) | (*s++ & 0x3f);
821             }
822           }
823           if (uv > 256) {
824           failure:
825               call_failure(check, s, dest, src);
826               /* Now what happens? */
827           }
828           *dest++ = (U8)uv;
829         }
830         }
831         RETVAL = dest - d0;
832         sv_usepvn(sv, (char *)dest, RETVAL);
833         SvUTF8_off(sv);
834     } else {
835         RETVAL = (utf8_to_bytes(s, &len) ? len : 0);
836     }
837     }
838 }
839 OUTPUT:
840     RETVAL
841
842 bool
843 is_utf8(sv, check = 0)
844 SV *    sv
845 int     check
846 CODE:
847 {
848     if (SvGMAGICAL(sv)) /* it could be $1, for example */
849     sv = newSVsv(sv); /* GMAGIG will be done */
850     RETVAL = SvUTF8(sv) ? TRUE : FALSE;
851     if (RETVAL &&
852         check  &&
853         !is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
854         RETVAL = FALSE;
855     if (sv != ST(0))
856     SvREFCNT_dec(sv); /* it was a temp copy */
857 }
858 OUTPUT:
859     RETVAL
860
861 #ifndef SvIsCOW
862 # define SvIsCOW(sv) (SvREADONLY(sv) && SvFAKE(sv))
863 #endif
864
865 SV *
866 _utf8_on(sv)
867 SV *    sv
868 CODE:
869 {
870     if (SvPOK(sv)) {
871     SV *rsv = newSViv(SvUTF8(sv));
872     RETVAL = rsv;
873     if (SvIsCOW(sv)) sv_force_normal(sv);
874     SvUTF8_on(sv);
875     } else {
876     RETVAL = &PL_sv_undef;
877     }
878 }
879 OUTPUT:
880     RETVAL
881
882 SV *
883 _utf8_off(sv)
884 SV *    sv
885 CODE:
886 {
887     if (SvPOK(sv)) {
888     SV *rsv = newSViv(SvUTF8(sv));
889     RETVAL = rsv;
890     if (SvIsCOW(sv)) sv_force_normal(sv);
891     SvUTF8_off(sv);
892     } else {
893     RETVAL = &PL_sv_undef;
894     }
895 }
896 OUTPUT:
897     RETVAL
898
899 int
900 DIE_ON_ERR()
901 CODE:
902     RETVAL = ENCODE_DIE_ON_ERR;
903 OUTPUT:
904     RETVAL
905
906 int
907 WARN_ON_ERR()
908 CODE:
909     RETVAL = ENCODE_WARN_ON_ERR;
910 OUTPUT:
911     RETVAL
912
913 int
914 LEAVE_SRC()
915 CODE:
916     RETVAL = ENCODE_LEAVE_SRC;
917 OUTPUT:
918     RETVAL
919
920 int
921 RETURN_ON_ERR()
922 CODE:
923     RETVAL = ENCODE_RETURN_ON_ERR;
924 OUTPUT:
925     RETVAL
926
927 int
928 PERLQQ()
929 CODE:
930     RETVAL = ENCODE_PERLQQ;
931 OUTPUT:
932     RETVAL
933
934 int
935 HTMLCREF()
936 CODE:
937     RETVAL = ENCODE_HTMLCREF;
938 OUTPUT:
939     RETVAL
940
941 int
942 XMLCREF()
943 CODE:
944     RETVAL = ENCODE_XMLCREF;
945 OUTPUT:
946     RETVAL
947
948 int
949 STOP_AT_PARTIAL()
950 CODE:
951     RETVAL = ENCODE_STOP_AT_PARTIAL;
952 OUTPUT:
953     RETVAL
954
955 int
956 FB_DEFAULT()
957 CODE:
958     RETVAL = ENCODE_FB_DEFAULT;
959 OUTPUT:
960     RETVAL
961
962 int
963 FB_CROAK()
964 CODE:
965     RETVAL = ENCODE_FB_CROAK;
966 OUTPUT:
967     RETVAL
968
969 int
970 FB_QUIET()
971 CODE:
972     RETVAL = ENCODE_FB_QUIET;
973 OUTPUT:
974     RETVAL
975
976 int
977 FB_WARN()
978 CODE:
979     RETVAL = ENCODE_FB_WARN;
980 OUTPUT:
981     RETVAL
982
983 int
984 FB_PERLQQ()
985 CODE:
986     RETVAL = ENCODE_FB_PERLQQ;
987 OUTPUT:
988     RETVAL
989
990 int
991 FB_HTMLCREF()
992 CODE:
993     RETVAL = ENCODE_FB_HTMLCREF;
994 OUTPUT:
995     RETVAL
996
997 int
998 FB_XMLCREF()
999 CODE:
1000     RETVAL = ENCODE_FB_XMLCREF;
1001 OUTPUT:
1002     RETVAL
1003
1004 BOOT:
1005 {
1006 #include "def_t.exh"
1007 }