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
Encode_XSEncoding(pTHX_ encode_t * enc)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
utf8_safe_downgrade(pTHX_ SV ** src,U8 ** s,STRLEN * slen,bool modify)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
utf8_safe_upgrade(pTHX_ SV ** src,U8 ** s,STRLEN * slen,bool modify)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 *
do_fallback_cb(pTHX_ UV ch,SV * fallback_cb)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 *
do_bytes_fallback_cb(pTHX_ U8 * s,STRLEN slen,SV * fallback_cb)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 *
encode_method(pTHX_ const encode_t * enc,const encpage_t * dir,SV * src,U8 * s,STRLEN slen,IV check,STRLEN * offset,SV * term,int * retcode,SV * fallback_cb)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
strict_utf8(pTHX_ SV * sv)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*
process_utf8(pTHX_ SV * dst,U8 * s,U8 * e,SV * check_sv,bool encode,bool strict,bool stop_at_partial)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 *
find_encoding(pTHX_ SV * enc)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 *
call_encoding(pTHX_ const char * method,SV * obj,SV * src,SV * check)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
onBOOT()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 }
1113