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