This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Encode: synch with CPAN version 3.01
[perl5.git] / cpan / Encode / Encode.xs
1 /*
2  $Id: Encode.xs,v 2.47 2019/03/13 00:26:18 dankogai Exp dankogai $
3  */
4
5 #define PERL_NO_GET_CONTEXT
6 #define IN_ENCODE_XS
7 #include "EXTERN.h"
8 #include "perl.h"
9 #include "XSUB.h"
10 #include "encode.h"
11 #include "def_t.h"
12
13 # define PERLIO_MODNAME  "PerlIO::encoding"
14 # define PERLIO_FILENAME "PerlIO/encoding.pm"
15
16 /* set 1 or more to profile.  t/encoding.t dumps core because of
17    Perl_warner and PerlIO don't work well */
18 #define ENCODE_XS_PROFILE 0
19
20 /* set 0 to disable floating point to calculate buffer size for
21    encode_method().  1 is recommended. 2 restores NI-S original */
22 #define ENCODE_XS_USEFP   1
23
24 #ifndef SvIV_nomg
25 #define SvIV_nomg SvIV
26 #endif
27
28 #ifndef SvTRUE_nomg
29 #define SvTRUE_nomg SvTRUE
30 #endif
31
32 #ifndef SVfARG
33 #define SVfARG(p) ((void*)(p))
34 #endif
35
36 static void
37 Encode_XSEncoding(pTHX_ encode_t * enc)
38 {
39     dSP;
40     HV *stash = gv_stashpv("Encode::XS", TRUE);
41     SV *iv    = newSViv(PTR2IV(enc));
42     SV *sv    = sv_bless(newRV_noinc(iv),stash);
43     int i = 0;
44     /* with the SvLEN() == 0 hack, PVX won't be freed. We cast away name's
45     constness, in the hope that perl won't mess with it. */
46     assert(SvTYPE(iv) >= SVt_PV); assert(SvLEN(iv) == 0);
47     SvFLAGS(iv) |= SVp_POK;
48     SvPVX(iv) = (char*) enc->name[0];
49     PUSHMARK(sp);
50     XPUSHs(sv);
51     while (enc->name[i]) {
52     const char *name = enc->name[i++];
53     XPUSHs(sv_2mortal(newSVpvn(name, strlen(name))));
54     }
55     PUTBACK;
56     call_pv("Encode::define_encoding", G_DISCARD);
57     SvREFCNT_dec(sv);
58 }
59
60 static void
61 utf8_safe_downgrade(pTHX_ SV ** src, U8 ** s, STRLEN * slen, bool modify)
62 {
63     if (!modify) {
64         SV *tmp = sv_2mortal(newSVpvn((char *)*s, *slen));
65         SvUTF8_on(tmp);
66         if (SvTAINTED(*src))
67             SvTAINTED_on(tmp);
68         *src = tmp;
69         *s = (U8 *)SvPVX(*src);
70     }
71     if (*slen) {
72         if (!utf8_to_bytes(*s, slen))
73             croak("Wide character");
74         SvCUR_set(*src, *slen);
75     }
76     SvUTF8_off(*src);
77 }
78
79 static void
80 utf8_safe_upgrade(pTHX_ SV ** src, U8 ** s, STRLEN * slen, bool modify)
81 {
82     if (!modify) {
83         SV *tmp = sv_2mortal(newSVpvn((char *)*s, *slen));
84         if (SvTAINTED(*src))
85             SvTAINTED_on(tmp);
86         *src = tmp;
87     }
88     sv_utf8_upgrade_nomg(*src);
89     *s = (U8 *)SvPV_nomg(*src, *slen);
90 }
91
92 #define ERR_ENCODE_NOMAP "\"\\x{%04" UVxf "}\" does not map to %s"
93 #define ERR_DECODE_NOMAP "%s \"\\x%02" UVXf "\" does not map to Unicode"
94 #define ERR_DECODE_STR_NOMAP "%s \"%s\" does not map to Unicode"
95
96 static SV *
97 do_fallback_cb(pTHX_ UV ch, SV *fallback_cb)
98 {
99     dSP;
100     int argc;
101     SV *retval;
102     ENTER;
103     SAVETMPS;
104     PUSHMARK(sp);
105     XPUSHs(sv_2mortal(newSVuv(ch)));
106     PUTBACK;
107     argc = call_sv(fallback_cb, G_SCALAR);
108     SPAGAIN;
109     if (argc != 1){
110         croak("fallback sub must return scalar!");
111     }
112     retval = POPs;
113     SvREFCNT_inc(retval);
114     PUTBACK;
115     FREETMPS;
116     LEAVE;
117     return retval;
118 }
119
120 static SV *
121 do_bytes_fallback_cb(pTHX_ U8 *s, STRLEN slen, SV *fallback_cb)
122 {
123     dSP;
124     int argc;
125     STRLEN i;
126     SV *retval;
127     ENTER;
128     SAVETMPS;
129     PUSHMARK(sp);
130     for (i=0; i<slen; ++i)
131         XPUSHs(sv_2mortal(newSVuv(s[i])));
132     PUTBACK;
133     argc = call_sv(fallback_cb, G_SCALAR);
134     SPAGAIN;
135     if (argc != 1){
136         croak("fallback sub must return scalar!");
137     }
138     retval = POPs;
139     SvREFCNT_inc(retval);
140     PUTBACK;
141     FREETMPS;
142     LEAVE;
143     return retval;
144 }
145
146 static SV *
147 encode_method(pTHX_ const encode_t * enc, const encpage_t * dir, SV * src, U8 * s, STRLEN slen,
148               IV check, STRLEN * offset, SV * term, int * retcode, 
149               SV *fallback_cb)
150 {
151     U8 *sorig    = s;
152     STRLEN tlen  = slen;
153     STRLEN ddone = 0;
154     STRLEN sdone = 0;
155     /* We allocate slen+1.
156        PerlIO dumps core if this value is smaller than this. */
157     SV *dst = newSV(slen+1);
158     U8 *d = (U8 *)SvPVX(dst);
159     STRLEN dlen = SvLEN(dst)-1;
160     int code = 0;
161     STRLEN trmlen = 0;
162     U8 *trm = term ? (U8*) SvPV(term, trmlen) : NULL;
163
164     if (SvTAINTED(src)) SvTAINTED_on(dst); /* propagate taintedness */
165
166     if (offset) {
167       s += *offset;
168       if (slen > *offset){ /* safeguard against slen overflow */
169           slen -= *offset;
170       }else{
171           slen = 0;
172       }
173       tlen = slen;
174     }
175
176     if (slen == 0){
177         SvCUR_set(dst, 0);
178         SvPOK_only(dst);
179         goto ENCODE_END;
180     }
181
182     while( (code = do_encode(dir, s, &slen, d, dlen, &dlen, !check,
183                  trm, trmlen)) )
184     {
185         SvCUR_set(dst, dlen+ddone);
186         SvPOK_only(dst);
187
188         if (code == ENCODE_FALLBACK || code == ENCODE_PARTIAL ||
189             code == ENCODE_FOUND_TERM) {
190             break;
191         }
192         switch (code) {
193         case ENCODE_NOSPACE:
194         {
195             STRLEN more = 0; /* make sure you initialize! */
196             STRLEN sleft;
197             sdone += slen;
198             ddone += dlen;
199             sleft = tlen - sdone;
200 #if ENCODE_XS_PROFILE >= 2
201             Perl_warn(aTHX_
202                   "more=%d, sdone=%d, sleft=%d, SvLEN(dst)=%d\n",
203                   more, sdone, sleft, SvLEN(dst));
204 #endif
205             if (sdone != 0) { /* has src ever been processed ? */
206 #if   ENCODE_XS_USEFP == 2
207                 more = (1.0*tlen*SvLEN(dst)+sdone-1)/sdone
208                     - SvLEN(dst);
209 #elif ENCODE_XS_USEFP
210                 more = (STRLEN)((1.0*SvLEN(dst)+1)/sdone * sleft);
211 #else
212             /* safe until SvLEN(dst) == MAX_INT/16 */
213                 more = (16*SvLEN(dst)+1)/sdone/16 * sleft;
214 #endif
215             }
216             more += UTF8_MAXLEN; /* insurance policy */
217             d = (U8 *) SvGROW(dst, SvLEN(dst) + more);
218             /* dst need to grow need MORE bytes! */
219             if (ddone >= SvLEN(dst)) {
220                 Perl_croak(aTHX_ "Destination couldn't be grown.");
221             }
222             dlen = SvLEN(dst)-ddone-1;
223             d   += ddone;
224             s   += slen;
225             slen = tlen-sdone;
226             continue;
227         }
228
229     case ENCODE_NOREP:
230         /* encoding */  
231         if (dir == enc->f_utf8) {
232         STRLEN clen;
233         UV ch =
234             utf8n_to_uvuni(s+slen, (tlen-sdone-slen),
235                    &clen, UTF8_ALLOW_ANY|UTF8_CHECK_ONLY);
236         /* if non-representable multibyte prefix at end of current buffer - break*/
237         if (clen > tlen - sdone - slen) break;
238         if (check & ENCODE_DIE_ON_ERR) {
239             Perl_croak(aTHX_ ERR_ENCODE_NOMAP,
240                    (UV)ch, enc->name[0]);
241             return &PL_sv_undef; /* never reaches but be safe */
242         }
243         if (encode_ckWARN(check, WARN_UTF8)) {
244             Perl_warner(aTHX_ packWARN(WARN_UTF8),
245                 ERR_ENCODE_NOMAP, (UV)ch, enc->name[0]);
246         }
247         if (check & ENCODE_RETURN_ON_ERR){
248             goto ENCODE_SET_SRC;
249         }
250         if (check & (ENCODE_PERLQQ|ENCODE_HTMLCREF|ENCODE_XMLCREF)){
251             STRLEN sublen;
252             char *substr;
253             SV* subchar = 
254             (fallback_cb != &PL_sv_undef)
255                 ? do_fallback_cb(aTHX_ ch, fallback_cb)
256                 : newSVpvf(check & ENCODE_PERLQQ ? "\\x{%04" UVxf "}" :
257                  check & ENCODE_HTMLCREF ? "&#%" UVuf ";" :
258                  "&#x%" UVxf ";", (UV)ch);
259             substr = SvPV(subchar, sublen);
260             if (SvUTF8(subchar) && sublen && !utf8_to_bytes((U8 *)substr, &sublen)) { /* make sure no decoded string gets in */
261                 SvREFCNT_dec(subchar);
262                 croak("Wide character");
263             }
264             sdone += slen + clen;
265             ddone += dlen + sublen;
266             sv_catpvn(dst, substr, sublen);
267             SvREFCNT_dec(subchar);
268         } else {
269             /* fallback char */
270             sdone += slen + clen;
271             ddone += dlen + enc->replen;
272             sv_catpvn(dst, (char*)enc->rep, enc->replen);
273         }
274         }
275         /* decoding */
276         else {
277         if (check & ENCODE_DIE_ON_ERR){
278             Perl_croak(aTHX_ ERR_DECODE_NOMAP,
279                               enc->name[0], (UV)s[slen]);
280             return &PL_sv_undef; /* never reaches but be safe */
281         }
282         if (encode_ckWARN(check, WARN_UTF8)) {
283             Perl_warner(
284             aTHX_ packWARN(WARN_UTF8),
285             ERR_DECODE_NOMAP,
286                         enc->name[0], (UV)s[slen]);
287         }
288         if (check & ENCODE_RETURN_ON_ERR){
289             goto ENCODE_SET_SRC;
290         }
291         if (check &
292             (ENCODE_PERLQQ|ENCODE_HTMLCREF|ENCODE_XMLCREF)){
293             STRLEN sublen;
294             char *substr;
295             SV* subchar = 
296             (fallback_cb != &PL_sv_undef)
297                 ? do_fallback_cb(aTHX_ (UV)s[slen], fallback_cb) 
298                 : newSVpvf("\\x%02" UVXf, (UV)s[slen]);
299             substr = SvPVutf8(subchar, sublen);
300             sdone += slen + 1;
301             ddone += dlen + sublen;
302             sv_catpvn(dst, substr, sublen);
303             SvREFCNT_dec(subchar);
304         } else {
305             sdone += slen + 1;
306             ddone += dlen + strlen(FBCHAR_UTF8);
307             sv_catpvn(dst, FBCHAR_UTF8, strlen(FBCHAR_UTF8));
308         }
309         }
310         /* settle variables when fallback */
311         d    = (U8 *)SvEND(dst);
312         dlen = SvLEN(dst) - ddone - 1;
313         s    = sorig + sdone;
314         slen = tlen - sdone;
315         break;
316
317         default:
318             Perl_croak(aTHX_ "Unexpected code %d converting %s %s",
319                    code, (dir == enc->f_utf8) ? "to" : "from",
320                    enc->name[0]);
321             return &PL_sv_undef;
322         }
323     }   /* End of looping through the string */
324  ENCODE_SET_SRC:
325     if (check && !(check & ENCODE_LEAVE_SRC)){
326         sdone = tlen - (slen+sdone);
327         sv_setpvn(src, (char*)s+slen, sdone);
328         SvSETMAGIC(src);
329     }
330     /* warn("check = 0x%X, code = 0x%d\n", check, code); */
331
332     SvCUR_set(dst, dlen+ddone);
333     SvPOK_only(dst);
334
335 #if ENCODE_XS_PROFILE
336     if (SvCUR(dst) > tlen){
337     Perl_warn(aTHX_
338           "SvLEN(dst)=%d, SvCUR(dst)=%d. %d bytes unused(%f %%)\n",
339           SvLEN(dst), SvCUR(dst), SvLEN(dst) - SvCUR(dst),
340           (SvLEN(dst) - SvCUR(dst))*1.0/SvLEN(dst)*100.0);
341     }
342 #endif
343
344     if (offset)
345       *offset += sdone + slen;
346
347  ENCODE_END:
348     *SvEND(dst) = '\0';
349     if (retcode) *retcode = code;
350     return dst;
351 }
352
353 static bool
354 strict_utf8(pTHX_ SV* sv)
355 {
356     HV* hv;
357     SV** svp;
358     sv = SvRV(sv);
359     if (!sv || SvTYPE(sv) != SVt_PVHV)
360         return 0;
361     hv = (HV*)sv;
362     svp = hv_fetch(hv, "strict_utf8", 11, 0);
363     if (!svp)
364         return 0;
365     return SvTRUE(*svp);
366 }
367
368 static U8*
369 process_utf8(pTHX_ SV* dst, U8* s, U8* e, SV *check_sv,
370              bool encode, bool strict, bool stop_at_partial)
371 {
372     /* Copies the purportedly UTF-8 encoded string starting at 's' and ending
373      * at 'e' - 1 to 'dst', checking as it goes along that the string actually
374      * is valid UTF-8.  There are two levels of strictness checking.  If
375      * 'strict' is FALSE, the string is checked for being well-formed UTF-8, as
376      * extended by Perl.  Additionally, if 'strict' is TRUE, above-Unicode code
377      * points, surrogates, and non-character code points are checked for.  When
378      * invalid input is encountered, some action is taken, exactly what depends
379      * on the flags in 'check_sv'.  'encode' gives if this is from an encode
380      * operation (if TRUE), or a decode one.  This function returns the
381      * position in 's' of the start of the next character beyond where it got
382      * to.  If there were no problems, that will be 'e'.  If 'stop_at_partial'
383      * is TRUE, if the final character before 'e' is incomplete, but valid as
384      * far as is available, no action will be taken on that partial character,
385      * and the return value will point to its first byte */
386
387     UV uv;
388     STRLEN ulen;
389     SV *fallback_cb;
390     IV check;
391     U8 *d;
392     STRLEN dlen;
393     char esc[UTF8_MAXLEN * 6 + 1];
394     STRLEN i;
395     const U32 flags = (strict)
396                     ? UTF8_DISALLOW_ILLEGAL_INTERCHANGE
397                     : 0;
398
399     if (!SvOK(check_sv)) {
400         fallback_cb = &PL_sv_undef;
401         check = 0;
402     }
403     else if (SvROK(check_sv)) {
404         /* croak("UTF-8 decoder doesn't support callback CHECK"); */
405         fallback_cb = check_sv;
406         check = ENCODE_PERLQQ|ENCODE_LEAVE_SRC; /* same as perlqq */
407     }
408     else {
409         fallback_cb = &PL_sv_undef;
410         check = SvIV_nomg(check_sv);
411     }
412
413     SvPOK_only(dst);
414     SvCUR_set(dst,0);
415
416     dlen = (s && e && s < e) ? e-s+1 : 1;
417     d = (U8 *) SvGROW(dst, dlen);
418
419     stop_at_partial = stop_at_partial || (check & ENCODE_STOP_AT_PARTIAL);
420
421     while (s < e) {
422
423         /* If there were no errors, this will be 'e'; otherwise it will point
424          * to the first byte of the erroneous input */
425         const U8* e_or_where_failed;
426         bool valid = is_utf8_string_loc_flags(s, e - s, &e_or_where_failed, flags);
427         STRLEN len = e_or_where_failed - s;
428
429         /* Copy as far as was successful */
430         Move(s, d, len, U8);
431         d += len;
432         s = (U8 *) e_or_where_failed;
433
434         /* Are done if it was valid, or we are accepting partial characters and
435          * the only error is that the final bytes form a partial character */
436         if (    LIKELY(valid)
437             || (   stop_at_partial
438                 && is_utf8_valid_partial_char_flags(s, e, flags)))
439         {
440             break;
441         }
442
443         /* Here, was not valid.  If is 'strict', and is legal extended UTF-8,
444          * we know it is a code point whose value we can calculate, just not
445          * one accepted under strict.  Otherwise, it is malformed in some way.
446          * In either case, the system function can calculate either the code
447          * point, or the best substitution for it */
448         uv = utf8n_to_uvchr(s, e - s, &ulen, UTF8_ALLOW_ANY);
449
450         /*
451          * Here, we are looping through the input and found an error.
452          * 'uv' is the code point in error if calculable, or the REPLACEMENT
453          *      CHARACTER if not.
454          * 'ulen' is how many bytes of input this iteration of the loop
455          *        consumes */
456
457         if (!encode && (check & (ENCODE_DIE_ON_ERR|ENCODE_WARN_ON_ERR|ENCODE_PERLQQ)))
458             for (i=0; i<ulen; ++i) sprintf(esc+4*i, "\\x%02X", s[i]);
459         if (check & ENCODE_DIE_ON_ERR){
460             if (encode)
461                 Perl_croak(aTHX_ ERR_ENCODE_NOMAP, uv, (strict ? "UTF-8" : "utf8"));
462             else
463                 Perl_croak(aTHX_ ERR_DECODE_STR_NOMAP, (strict ? "UTF-8" : "utf8"), esc);
464         }
465         if (encode_ckWARN(check, WARN_UTF8)) {
466             if (encode)
467                 Perl_warner(aTHX_ packWARN(WARN_UTF8),
468                             ERR_ENCODE_NOMAP, uv, (strict ? "UTF-8" : "utf8"));
469             else
470                 Perl_warner(aTHX_ packWARN(WARN_UTF8),
471                             ERR_DECODE_STR_NOMAP, (strict ? "UTF-8" : "utf8"), esc);
472         }
473         if (check & ENCODE_RETURN_ON_ERR) {
474                 break;
475         }
476         if (check & (ENCODE_PERLQQ|ENCODE_HTMLCREF|ENCODE_XMLCREF)){
477             STRLEN sublen;
478             char *substr;
479             SV* subchar;
480             if (encode) {
481                 subchar =
482                     (fallback_cb != &PL_sv_undef)
483                     ? do_fallback_cb(aTHX_ uv, fallback_cb)
484                     : newSVpvf(check & ENCODE_PERLQQ
485                         ? (ulen == 1 ? "\\x%02" UVXf : "\\x{%04" UVXf "}")
486                         :  check & ENCODE_HTMLCREF ? "&#%" UVuf ";"
487                         : "&#x%" UVxf ";", uv);
488                 substr = SvPV(subchar, sublen);
489                 if (SvUTF8(subchar) && sublen && !utf8_to_bytes((U8 *)substr, &sublen)) { /* make sure no decoded string gets in */
490                     SvREFCNT_dec(subchar);
491                     croak("Wide character");
492                 }
493             } else {
494                 if (fallback_cb != &PL_sv_undef) {
495                     /* in decode mode we have sequence of wrong bytes */
496                     subchar = do_bytes_fallback_cb(aTHX_ s, ulen, fallback_cb);
497                 } else {
498                     char *ptr = esc;
499                     /* ENCODE_PERLQQ is already stored in esc */
500                     if (check & (ENCODE_HTMLCREF|ENCODE_XMLCREF))
501                         for (i=0; i<ulen; ++i) ptr += sprintf(ptr, ((check & ENCODE_HTMLCREF) ? "&#%u;" : "&#x%02X;"), s[i]);
502                     subchar = newSVpvn(esc, strlen(esc));
503                 }
504                 substr = SvPVutf8(subchar, sublen);
505             }
506             dlen += sublen - ulen;
507             SvCUR_set(dst, d-(U8 *)SvPVX(dst));
508             *SvEND(dst) = '\0';
509             sv_catpvn(dst, substr, sublen);
510             SvREFCNT_dec(subchar);
511             d = (U8 *) SvGROW(dst, dlen) + SvCUR(dst);
512         } else {
513             STRLEN fbcharlen = strlen(FBCHAR_UTF8);
514             dlen += fbcharlen - ulen;
515             if (SvLEN(dst) < dlen) {
516                 SvCUR_set(dst, d-(U8 *)SvPVX(dst));
517                 d = (U8 *) sv_grow(dst, dlen) + SvCUR(dst);
518             }
519             memcpy(d, FBCHAR_UTF8, fbcharlen);
520             d += fbcharlen;
521         }
522         s += ulen;
523     }
524     SvCUR_set(dst, d-(U8 *)SvPVX(dst));
525     *SvEND(dst) = '\0';
526
527     return s;
528 }
529
530 static SV *
531 find_encoding(pTHX_ SV *enc)
532 {
533     dSP;
534     I32 count;
535     SV *m_enc;
536     SV *obj = &PL_sv_undef;
537 #ifndef SV_NOSTEAL
538     U32 tmp;
539 #endif
540
541     ENTER;
542     SAVETMPS;
543     PUSHMARK(sp);
544
545     m_enc = sv_newmortal();
546 #ifndef SV_NOSTEAL
547     tmp = SvFLAGS(enc) & SVs_TEMP;
548     SvTEMP_off(enc);
549     sv_setsv_flags(m_enc, enc, 0);
550     SvFLAGS(enc) |= tmp;
551 #else
552 #if SV_NOSTEAL == 0
553     #error You have broken SV_NOSTEAL which cause memory corruption in sv_setsv_flags()
554     #error Most probably broken SV_NOSTEAL was defined by buggy version of ppport.h
555 #else
556     sv_setsv_flags(m_enc, enc, SV_NOSTEAL);
557 #endif
558 #endif
559     XPUSHs(m_enc);
560
561     PUTBACK;
562
563     count = call_pv("Encode::find_encoding", G_SCALAR);
564
565     SPAGAIN;
566
567     if (count > 0) {
568         obj = POPs;
569         SvREFCNT_inc(obj);
570     }
571
572     PUTBACK;
573     FREETMPS;
574     LEAVE;
575     return sv_2mortal(obj);
576 }
577
578 static SV *
579 call_encoding(pTHX_ const char *method, SV *obj, SV *src, SV *check)
580 {
581     dSP;
582     I32 count;
583     SV *dst = &PL_sv_undef;
584
585     PUSHMARK(sp);
586
587     if (check)
588         check = sv_2mortal(newSVsv(check));
589
590     if (!check || SvROK(check) || !SvTRUE_nomg(check) || (SvIV_nomg(check) & ENCODE_LEAVE_SRC))
591         src = sv_2mortal(newSVsv(src));
592
593     XPUSHs(obj);
594     XPUSHs(src);
595     XPUSHs(check ? check : &PL_sv_no);
596
597     PUTBACK;
598
599     count = call_method(method, G_SCALAR);
600
601     SPAGAIN;
602
603     if (count > 0) {
604         dst = POPs;
605         SvREFCNT_inc(dst);
606     }
607
608     PUTBACK;
609     return dst;
610 }
611
612
613 MODULE = Encode         PACKAGE = Encode::utf8  PREFIX = Method_
614
615 PROTOTYPES: DISABLE
616
617 void
618 Method_decode(obj,src,check_sv = &PL_sv_no)
619 SV *    obj
620 SV *    src
621 SV *    check_sv
622 PREINIT:
623     STRLEN slen;
624     U8 *s;
625     U8 *e;
626     SV *dst;
627     bool renewed = 0;
628     IV check;
629     bool modify;
630     dSP;
631 INIT:
632     SvGETMAGIC(src);
633     SvGETMAGIC(check_sv);
634     check = SvROK(check_sv) ? ENCODE_PERLQQ|ENCODE_LEAVE_SRC : SvOK(check_sv) ? SvIV_nomg(check_sv) : 0;
635     modify = (check && !(check & ENCODE_LEAVE_SRC));
636 PPCODE:
637     if (!SvOK(src))
638         XSRETURN_UNDEF;
639     s = modify ? (U8 *)SvPV_force_nomg(src, slen) : (U8 *)SvPV_nomg(src, slen);
640     if (SvUTF8(src))
641         utf8_safe_downgrade(aTHX_ &src, &s, &slen, modify);
642     e = s+slen;
643
644     /*
645      * PerlIO check -- we assume the object is of PerlIO if renewed
646      */
647     ENTER; SAVETMPS;
648     PUSHMARK(sp);
649     XPUSHs(obj);
650     PUTBACK;
651     if (call_method("renewed",G_SCALAR) == 1) {
652     SPAGAIN;
653     renewed = (bool)POPi;
654     PUTBACK;
655 #if 0
656     fprintf(stderr, "renewed == %d\n", renewed);
657 #endif
658     }
659     FREETMPS; LEAVE;
660     /* end PerlIO check */
661
662     dst = sv_2mortal(newSV(slen>0?slen:1)); /* newSV() abhors 0 -- inaba */
663     s = process_utf8(aTHX_ dst, s, e, check_sv, 0, strict_utf8(aTHX_ obj), renewed);
664
665     /* Clear out translated part of source unless asked not to */
666     if (modify) {
667         slen = e-s;
668         sv_setpvn(src, (char*)s, slen);
669         SvSETMAGIC(src);
670     }
671     SvUTF8_on(dst);
672     if (SvTAINTED(src)) SvTAINTED_on(dst); /* propagate taintedness */
673     ST(0) = dst;
674     XSRETURN(1);
675
676 void
677 Method_encode(obj,src,check_sv = &PL_sv_no)
678 SV *    obj
679 SV *    src
680 SV *    check_sv
681 PREINIT:
682     STRLEN slen;
683     U8 *s;
684     U8 *e;
685     SV *dst;
686     IV check;
687     bool modify;
688 INIT:
689     SvGETMAGIC(src);
690     SvGETMAGIC(check_sv);
691     check = SvROK(check_sv) ? ENCODE_PERLQQ|ENCODE_LEAVE_SRC : SvOK(check_sv) ? SvIV_nomg(check_sv) : 0;
692     modify = (check && !(check & ENCODE_LEAVE_SRC));
693 PPCODE:
694     if (!SvOK(src))
695         XSRETURN_UNDEF;
696     s = modify ? (U8 *)SvPV_force_nomg(src, slen) : (U8 *)SvPV_nomg(src, slen);
697     e = s+slen;
698     dst = sv_2mortal(newSV(slen>0?slen:1)); /* newSV() abhors 0 -- inaba */
699     if (SvUTF8(src)) {
700     /* Already encoded */
701     if (strict_utf8(aTHX_ obj)) {
702         s = process_utf8(aTHX_ dst, s, e, check_sv, 1, 1, 0);
703     }
704         else {
705             /* trust it and just copy the octets */
706             sv_setpvn(dst,(char *)s,(e-s));
707         s = e;
708         }
709     }
710     else {
711         /* Native bytes - can always encode */
712         U8 *d = (U8 *) SvGROW(dst, 2*slen+1); /* +1 or assertion will botch */
713         while (s < e) {
714 #ifdef append_utf8_from_native_byte
715             append_utf8_from_native_byte(*s, &d);
716             s++;
717 #else
718             UV uv = NATIVE_TO_UNI((UV) *s);
719             s++; /* Above expansion of NATIVE_TO_UNI() is safer this way. */
720             if (UNI_IS_INVARIANT(uv))
721                 *d++ = (U8)UTF_TO_NATIVE(uv);
722             else {
723                 *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
724                 *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
725             }
726 #endif
727         }
728         SvCUR_set(dst, d- (U8 *)SvPVX(dst));
729         *SvEND(dst) = '\0';
730     }
731
732     /* Clear out translated part of source unless asked not to */
733     if (modify) {
734         slen = e-s;
735         sv_setpvn(src, (char*)s, slen);
736         SvSETMAGIC(src);
737     }
738     SvPOK_only(dst);
739     SvUTF8_off(dst);
740     if (SvTAINTED(src)) SvTAINTED_on(dst); /* propagate taintedness */
741     ST(0) = dst;
742     XSRETURN(1);
743
744 MODULE = Encode         PACKAGE = Encode::XS    PREFIX = Method_
745
746 PROTOTYPES: DISABLE
747
748 SV *
749 Method_renew(obj)
750 SV *    obj
751 CODE:
752     PERL_UNUSED_VAR(obj);
753     RETVAL = newSVsv(obj);
754 OUTPUT:
755     RETVAL
756
757 int
758 Method_renewed(obj)
759 SV *    obj
760 CODE:
761     RETVAL = 0;
762     PERL_UNUSED_VAR(obj);
763 OUTPUT:
764     RETVAL
765
766 SV *
767 Method_name(obj)
768 SV *    obj
769 PREINIT:
770     encode_t *enc;
771 INIT:
772     enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
773 CODE:
774     RETVAL = newSVpvn(enc->name[0], strlen(enc->name[0]));
775 OUTPUT:
776     RETVAL
777
778 bool
779 Method_cat_decode(obj, dst, src, off, term, check_sv = &PL_sv_no)
780 SV *    obj
781 SV *    dst
782 SV *    src
783 SV *    off
784 SV *    term
785 SV *    check_sv
786 PREINIT:
787     IV check;
788     SV *fallback_cb;
789     bool modify;
790     encode_t *enc;
791     STRLEN offset;
792     int code = 0;
793     U8 *s;
794     STRLEN slen;
795     SV *tmp;
796 INIT:
797     SvGETMAGIC(src);
798     SvGETMAGIC(check_sv);
799     check = SvROK(check_sv) ? ENCODE_PERLQQ|ENCODE_LEAVE_SRC : SvOK(check_sv) ? SvIV_nomg(check_sv) : 0;
800     fallback_cb = SvROK(check_sv) ? check_sv : &PL_sv_undef;
801     modify = (check && !(check & ENCODE_LEAVE_SRC));
802     enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
803     offset = (STRLEN)SvIV(off);
804 CODE:
805     if (!SvOK(src))
806         XSRETURN_NO;
807     s = modify ? (U8 *)SvPV_force_nomg(src, slen) : (U8 *)SvPV_nomg(src, slen);
808     if (SvUTF8(src))
809         utf8_safe_downgrade(aTHX_ &src, &s, &slen, modify);
810     tmp = encode_method(aTHX_ enc, enc->t_utf8, src, s, slen, check,
811                 &offset, term, &code, fallback_cb);
812     sv_catsv(dst, tmp);
813     SvREFCNT_dec(tmp);
814     SvIV_set(off, (IV)offset);
815     RETVAL = (code == ENCODE_FOUND_TERM);
816 OUTPUT:
817     RETVAL
818
819 SV *
820 Method_decode(obj,src,check_sv = &PL_sv_no)
821 SV *    obj
822 SV *    src
823 SV *    check_sv
824 PREINIT:
825     IV check;
826     SV *fallback_cb;
827     bool modify;
828     encode_t *enc;
829     U8 *s;
830     STRLEN slen;
831 INIT:
832     SvGETMAGIC(src);
833     SvGETMAGIC(check_sv);
834     check = SvROK(check_sv) ? ENCODE_PERLQQ|ENCODE_LEAVE_SRC : SvOK(check_sv) ? SvIV_nomg(check_sv) : 0;
835     fallback_cb = SvROK(check_sv) ? check_sv : &PL_sv_undef;
836     modify = (check && !(check & ENCODE_LEAVE_SRC));
837     enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
838 CODE:
839     if (!SvOK(src))
840         XSRETURN_UNDEF;
841     s = modify ? (U8 *)SvPV_force_nomg(src, slen) : (U8 *)SvPV_nomg(src, slen);
842     if (SvUTF8(src))
843         utf8_safe_downgrade(aTHX_ &src, &s, &slen, modify);
844     RETVAL = encode_method(aTHX_ enc, enc->t_utf8, src, s, slen, check,
845               NULL, Nullsv, NULL, fallback_cb);
846     SvUTF8_on(RETVAL);
847 OUTPUT:
848     RETVAL
849
850 SV *
851 Method_encode(obj,src,check_sv = &PL_sv_no)
852 SV *    obj
853 SV *    src
854 SV *    check_sv
855 PREINIT:
856     IV check;
857     SV *fallback_cb;
858     bool modify;
859     encode_t *enc;
860     U8 *s;
861     STRLEN slen;
862 INIT:
863     SvGETMAGIC(src);
864     SvGETMAGIC(check_sv);
865     check = SvROK(check_sv) ? ENCODE_PERLQQ|ENCODE_LEAVE_SRC : SvOK(check_sv) ? SvIV_nomg(check_sv) : 0;
866     fallback_cb = SvROK(check_sv) ? check_sv : &PL_sv_undef;
867     modify = (check && !(check & ENCODE_LEAVE_SRC));
868     enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
869 CODE:
870     if (!SvOK(src))
871         XSRETURN_UNDEF;
872     s = modify ? (U8 *)SvPV_force_nomg(src, slen) : (U8 *)SvPV_nomg(src, slen);
873     if (!SvUTF8(src))
874         utf8_safe_upgrade(aTHX_ &src, &s, &slen, modify);
875     RETVAL = encode_method(aTHX_ enc, enc->f_utf8, src, s, slen, check,
876               NULL, Nullsv, NULL, fallback_cb);
877 OUTPUT:
878     RETVAL
879
880 bool
881 Method_needs_lines(obj)
882 SV *    obj
883 CODE:
884     PERL_UNUSED_VAR(obj);
885     RETVAL = FALSE;
886 OUTPUT:
887     RETVAL
888
889 bool
890 Method_perlio_ok(obj)
891 SV *    obj
892 PREINIT:
893     SV *sv;
894 CODE:
895     PERL_UNUSED_VAR(obj);
896     sv = eval_pv("require PerlIO::encoding", 0);
897     RETVAL = SvTRUE(sv);
898 OUTPUT:
899     RETVAL
900
901 SV *
902 Method_mime_name(obj)
903 SV *    obj
904 PREINIT:
905     encode_t *enc;
906 INIT:
907     enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
908 CODE:
909     ENTER;
910     SAVETMPS;
911     PUSHMARK(sp);
912     XPUSHs(sv_2mortal(newSVpvn(enc->name[0], strlen(enc->name[0]))));
913     PUTBACK;
914     call_pv("Encode::MIME::Name::get_mime_name", G_SCALAR);
915     SPAGAIN;
916     RETVAL = newSVsv(POPs);
917     PUTBACK;
918     FREETMPS;
919     LEAVE;
920 OUTPUT:
921     RETVAL
922
923 MODULE = Encode         PACKAGE = Encode
924
925 PROTOTYPES: ENABLE
926
927 bool
928 is_utf8(sv, check = 0)
929 SV *    sv
930 int     check
931 PREINIT:
932     char *str;
933     STRLEN len;
934 CODE:
935     SvGETMAGIC(sv); /* SvGETMAGIC() can modify SvOK flag */
936     str = SvOK(sv) ? SvPV_nomg(sv, len) : NULL; /* SvPV() can modify SvUTF8 flag */
937     RETVAL = SvUTF8(sv) ? TRUE : FALSE;
938     if (RETVAL && check && (!str || !is_utf8_string((U8 *)str, len)))
939         RETVAL = FALSE;
940 OUTPUT:
941     RETVAL
942
943 SV *
944 _utf8_on(sv)
945 SV *    sv
946 CODE:
947     SvGETMAGIC(sv);
948     if (!SvTAINTED(sv) && SvPOKp(sv)) {
949         if (SvTHINKFIRST(sv)) sv_force_normal(sv);
950         RETVAL = boolSV(SvUTF8(sv));
951         SvUTF8_on(sv);
952         SvSETMAGIC(sv);
953     } else {
954         RETVAL = &PL_sv_undef;
955     }
956 OUTPUT:
957     RETVAL
958
959 SV *
960 _utf8_off(sv)
961 SV *    sv
962 CODE:
963     SvGETMAGIC(sv);
964     if (!SvTAINTED(sv) && SvPOKp(sv)) {
965         if (SvTHINKFIRST(sv)) sv_force_normal(sv);
966         RETVAL = boolSV(SvUTF8(sv));
967         SvUTF8_off(sv);
968         SvSETMAGIC(sv);
969     } else {
970         RETVAL = &PL_sv_undef;
971     }
972 OUTPUT:
973     RETVAL
974
975 SV *
976 decode(encoding, octets, check = NULL)
977 SV *    encoding
978 SV *    octets
979 SV *    check
980 ALIAS:
981     bytes2str = 0
982 PREINIT:
983     SV *obj;
984 INIT:
985     SvGETMAGIC(encoding);
986 CODE:
987     if (!SvOK(encoding))
988         croak("Encoding name should not be undef");
989     obj = find_encoding(aTHX_ encoding);
990     if (!SvOK(obj))
991         croak("Unknown encoding '%" SVf "'", SVfARG(encoding));
992     RETVAL = call_encoding(aTHX_ "decode", obj, octets, check);
993 OUTPUT:
994     RETVAL
995
996 SV *
997 encode(encoding, string, check = NULL)
998 SV *    encoding
999 SV *    string
1000 SV *    check
1001 ALIAS:
1002     str2bytes = 0
1003 PREINIT:
1004     SV *obj;
1005 INIT:
1006     SvGETMAGIC(encoding);
1007 CODE:
1008     if (!SvOK(encoding))
1009         croak("Encoding name should not be undef");
1010     obj = find_encoding(aTHX_ encoding);
1011     if (!SvOK(obj))
1012         croak("Unknown encoding '%" SVf "'", SVfARG(encoding));
1013     RETVAL = call_encoding(aTHX_ "encode", obj, string, check);
1014 OUTPUT:
1015     RETVAL
1016
1017 SV *
1018 decode_utf8(octets, check = NULL)
1019 SV *    octets
1020 SV *    check
1021 PREINIT:
1022     HV *hv;
1023     SV **sv;
1024 CODE:
1025     hv = get_hv("Encode::Encoding", 0);
1026     if (!hv)
1027         croak("utf8 encoding was not found");
1028     sv = hv_fetch(hv, "utf8", 4, 0);
1029     if (!sv || !*sv || !SvOK(*sv))
1030         croak("utf8 encoding was not found");
1031     RETVAL = call_encoding(aTHX_ "decode", *sv, octets, check);
1032 OUTPUT:
1033     RETVAL
1034
1035 SV *
1036 encode_utf8(string)
1037 SV *    string
1038 CODE:
1039     RETVAL = newSVsv(string);
1040     if (SvOK(RETVAL))
1041         sv_utf8_encode(RETVAL);
1042 OUTPUT:
1043     RETVAL
1044
1045 SV *
1046 from_to(octets, from, to, check = NULL)
1047 SV *    octets
1048 SV *    from
1049 SV *    to
1050 SV *    check
1051 PREINIT:
1052     SV *from_obj;
1053     SV *to_obj;
1054     SV *string;
1055     SV *new_octets;
1056     U8 *ptr;
1057     STRLEN len;
1058 INIT:
1059     SvGETMAGIC(from);
1060     SvGETMAGIC(to);
1061 CODE:
1062     if (!SvOK(from) || !SvOK(to))
1063         croak("Encoding name should not be undef");
1064     from_obj = find_encoding(aTHX_ from);
1065     if (!SvOK(from_obj))
1066         croak("Unknown encoding '%" SVf "'", SVfARG(from));
1067     to_obj = find_encoding(aTHX_ to);
1068     if (!SvOK(to_obj))
1069         croak("Unknown encoding '%" SVf "'", SVfARG(to));
1070     string = sv_2mortal(call_encoding(aTHX_ "decode", from_obj, octets, NULL));
1071     new_octets = sv_2mortal(call_encoding(aTHX_ "encode", to_obj, string, check));
1072     SvGETMAGIC(new_octets);
1073     if (SvOK(new_octets) && (!check || SvROK(check) || !SvTRUE_nomg(check) || sv_len(string) == 0)) {
1074         ptr = (U8 *)SvPV_nomg(new_octets, len);
1075         if (SvUTF8(new_octets))
1076             len = utf8_length(ptr, ptr+len);
1077         RETVAL = newSVuv(len);
1078     } else {
1079         RETVAL = &PL_sv_undef;
1080     }
1081     sv_setsv_nomg(octets, new_octets);
1082     SvSETMAGIC(octets);
1083 OUTPUT:
1084     RETVAL
1085
1086 void
1087 onBOOT()
1088 CODE:
1089 {
1090 #include "def_t.exh"
1091 }
1092
1093 BOOT:
1094 {
1095     HV *stash = gv_stashpvn("Encode", (U32)strlen("Encode"), GV_ADD);
1096     newCONSTSUB(stash, "DIE_ON_ERR", newSViv(ENCODE_DIE_ON_ERR));
1097     newCONSTSUB(stash, "WARN_ON_ERR", newSViv(ENCODE_WARN_ON_ERR));
1098     newCONSTSUB(stash, "RETURN_ON_ERR", newSViv(ENCODE_RETURN_ON_ERR));
1099     newCONSTSUB(stash, "LEAVE_SRC", newSViv(ENCODE_LEAVE_SRC));
1100     newCONSTSUB(stash, "ONLY_PRAGMA_WARNINGS", newSViv(ENCODE_ONLY_PRAGMA_WARNINGS));
1101     newCONSTSUB(stash, "PERLQQ", newSViv(ENCODE_PERLQQ));
1102     newCONSTSUB(stash, "HTMLCREF", newSViv(ENCODE_HTMLCREF));
1103     newCONSTSUB(stash, "XMLCREF", newSViv(ENCODE_XMLCREF));
1104     newCONSTSUB(stash, "STOP_AT_PARTIAL", newSViv(ENCODE_STOP_AT_PARTIAL));
1105     newCONSTSUB(stash, "FB_DEFAULT", newSViv(ENCODE_FB_DEFAULT));
1106     newCONSTSUB(stash, "FB_CROAK", newSViv(ENCODE_FB_CROAK));
1107     newCONSTSUB(stash, "FB_QUIET", newSViv(ENCODE_FB_QUIET));
1108     newCONSTSUB(stash, "FB_WARN", newSViv(ENCODE_FB_WARN));
1109     newCONSTSUB(stash, "FB_PERLQQ", newSViv(ENCODE_FB_PERLQQ));
1110     newCONSTSUB(stash, "FB_HTMLCREF", newSViv(ENCODE_FB_HTMLCREF));
1111     newCONSTSUB(stash, "FB_XMLCREF", newSViv(ENCODE_FB_XMLCREF));
1112 }