File: | obj/gnu/usr.bin/perl/cpan/Encode/../../inline.h |
Warning: | line 1411, column 15 Null pointer passed as 1st argument to string length function |
Press '?' to see keyboard shortcuts
Keyboard shortcuts:
1 | /* | |||
2 | * This file was generated automatically by ExtUtils::ParseXS version 3.40 from the | |||
3 | * contents of Encode.xs. Do not edit this file, edit Encode.xs instead. | |||
4 | * | |||
5 | * ANY CHANGES MADE HERE WILL BE LOST! | |||
6 | * | |||
7 | */ | |||
8 | ||||
9 | #line 1 "Encode.xs" | |||
10 | /* | |||
11 | $Id: Encode.xs,v 2.48 2020/03/02 04:34:34 dankogai Exp $ | |||
12 | */ | |||
13 | ||||
14 | #define PERL_NO_GET_CONTEXT | |||
15 | #define IN_ENCODE_XS | |||
16 | #include "EXTERN.h" | |||
17 | #include "perl.h" | |||
18 | #include "XSUB.h" | |||
19 | #include "encode.h" | |||
20 | #include "def_t.h" | |||
21 | ||||
22 | # define PERLIO_MODNAME"PerlIO::encoding" "PerlIO::encoding" | |||
23 | # define PERLIO_FILENAME"PerlIO/encoding.pm" "PerlIO/encoding.pm" | |||
24 | ||||
25 | /* set 1 or more to profile. t/encoding.t dumps core because of | |||
26 | Perl_warner and PerlIO don't work well */ | |||
27 | #define ENCODE_XS_PROFILE0 0 | |||
28 | ||||
29 | /* set 0 to disable floating point to calculate buffer size for | |||
30 | encode_method(). 1 is recommended. 2 restores NI-S original */ | |||
31 | #define ENCODE_XS_USEFP1 1 | |||
32 | ||||
33 | #ifndef SvIV_nomg | |||
34 | #define SvIV_nomg SvIV | |||
35 | #endif | |||
36 | ||||
37 | #ifndef SvTRUE_nomg | |||
38 | #define SvTRUE_nomg SvTRUE | |||
39 | #endif | |||
40 | ||||
41 | #ifndef SVfARG | |||
42 | #define SVfARG(p)((void*)(p)) ((void*)(p)) | |||
43 | #endif | |||
44 | ||||
45 | static void | |||
46 | Encode_XSEncoding(pTHX_ encode_t * enc) | |||
47 | { | |||
48 | dSPSV **sp = PL_stack_sp; | |||
49 | HV *stash = gv_stashpv("Encode::XS", TRUE)Perl_gv_stashpv( "Encode::XS",(1)); | |||
50 | SV *iv = newSViv(PTR2IV(enc))Perl_newSViv( (IV)(enc)); | |||
51 | SV *sv = sv_bless(newRV_noinc(iv),stash)Perl_sv_bless( Perl_newRV_noinc( iv),stash); | |||
52 | int i = 0; | |||
53 | /* with the SvLEN() == 0 hack, PVX won't be freed. We cast away name's | |||
54 | constness, in the hope that perl won't mess with it. */ | |||
55 | assert(SvTYPE(iv) >= SVt_PV)((void)0); assert(SvLEN(iv) == 0)((void)0); | |||
56 | SvFLAGS(iv)(iv)->sv_flags |= SVp_POK0x00004000; | |||
57 | SvPVX(iv)((iv)->sv_u.svu_pv) = (char*) enc->name[0]; | |||
58 | PUSHMARK(sp)do { I32 * mark_stack_entry; if (__builtin_expect((((mark_stack_entry = ++PL_markstack_ptr) == PL_markstack_max) ? (_Bool)1 : (_Bool )0),(0))) mark_stack_entry = Perl_markstack_grow(); *mark_stack_entry = (I32)((sp) - PL_stack_base); ; } while (0); | |||
59 | XPUSHs(sv)do { do { (void)0; if (__builtin_expect(((((1) < 0 || PL_stack_max - (sp) < (1))) ? (_Bool)1 : (_Bool)0),(0))) { sp = Perl_stack_grow ( sp,sp,(sizeof(1) > sizeof(ssize_t) && ((ssize_t) (1) != (1)) ? -1 : (1))); ((void)sizeof(sp)); } } while (0); * ++sp = (sv); } while (0); | |||
60 | while (enc->name[i]) { | |||
61 | const char *name = enc->name[i++]; | |||
62 | XPUSHs(sv_2mortal(newSVpvn(name, strlen(name))))do { do { (void)0; if (__builtin_expect(((((1) < 0 || PL_stack_max - (sp) < (1))) ? (_Bool)1 : (_Bool)0),(0))) { sp = Perl_stack_grow ( sp,sp,(sizeof(1) > sizeof(ssize_t) && ((ssize_t) (1) != (1)) ? -1 : (1))); ((void)sizeof(sp)); } } while (0); * ++sp = (Perl_sv_2mortal( Perl_newSVpvn( name,strlen(name)))); } while (0); | |||
63 | } | |||
64 | PUTBACKPL_stack_sp = sp; | |||
65 | call_pv("Encode::define_encoding", G_DISCARD)Perl_call_pv( "Encode::define_encoding",0x4); | |||
66 | SvREFCNT_dec(sv)Perl_SvREFCNT_dec( ((SV *)({ void *_p = (sv); _p; }))); | |||
67 | } | |||
68 | ||||
69 | static void | |||
70 | utf8_safe_downgrade(pTHX_ SV ** src, U8 ** s, STRLEN * slen, bool_Bool modify) | |||
71 | { | |||
72 | if (!modify) { | |||
73 | SV *tmp = sv_2mortal(newSVpvn((char *)*s, *slen))Perl_sv_2mortal( Perl_newSVpvn( (char *)*s,*slen)); | |||
74 | SvUTF8_on(tmp)((tmp)->sv_flags |= (0x20000000)); | |||
75 | if (SvTAINTED(*src)(((*src)->sv_flags & (0x00200000|0x00400000|0x00800000 )) && Perl_sv_tainted( *src))) | |||
76 | SvTAINTED_on(tmp)do{ if(__builtin_expect((((((__builtin_expect(((PL_tainting) ? (_Bool)1 : (_Bool)0),(0))) ? (_Bool)1 : (_Bool)0))) ? (_Bool )1 : (_Bool)0),(0))){Perl_sv_magic( (tmp),((void*)0),'t',((void *)0),0);} }while (0); | |||
77 | *src = tmp; | |||
78 | *s = (U8 *)SvPVX(*src)((*src)->sv_u.svu_pv); | |||
79 | } | |||
80 | if (*slen) { | |||
81 | if (!utf8_to_bytes(*s, slen)Perl_utf8_to_bytes( *s,slen)) | |||
82 | croakPerl_croak("Wide character"); | |||
83 | SvCUR_set(*src, *slen)do { ((void)0); ((void)0); ((void)0); (((XPV*) (*src)->sv_any )->xpv_cur = (*slen)); } while (0); | |||
84 | } | |||
85 | SvUTF8_off(*src)((*src)->sv_flags &= ~(0x20000000)); | |||
86 | } | |||
87 | ||||
88 | static void | |||
89 | utf8_safe_upgrade(pTHX_ SV ** src, U8 ** s, STRLEN * slen, bool_Bool modify) | |||
90 | { | |||
91 | if (!modify) { | |||
92 | SV *tmp = sv_2mortal(newSVpvn((char *)*s, *slen))Perl_sv_2mortal( Perl_newSVpvn( (char *)*s,*slen)); | |||
93 | if (SvTAINTED(*src)(((*src)->sv_flags & (0x00200000|0x00400000|0x00800000 )) && Perl_sv_tainted( *src))) | |||
94 | SvTAINTED_on(tmp)do{ if(__builtin_expect((((((__builtin_expect(((PL_tainting) ? (_Bool)1 : (_Bool)0),(0))) ? (_Bool)1 : (_Bool)0))) ? (_Bool )1 : (_Bool)0),(0))){Perl_sv_magic( (tmp),((void*)0),'t',((void *)0),0);} }while (0); | |||
95 | *src = tmp; | |||
96 | } | |||
97 | sv_utf8_upgrade_nomg(*src)Perl_sv_utf8_upgrade_flags_grow( *src,0,0); | |||
98 | *s = (U8 *)SvPV_nomg(*src, *slen)((((*src)->sv_flags & (0x00000400|0x00200000)) == 0x00000400 ) ? ((*slen = ((XPV*) (*src)->sv_any)->xpv_cur), ((*src )->sv_u.svu_pv)) : Perl_sv_2pv_flags( *src,&*slen,0)); | |||
99 | } | |||
100 | ||||
101 | #define ERR_ENCODE_NOMAP"\"\\x{%04" "lx" "}\" does not map to %s" "\"\\x{%04" UVxf"lx" "}\" does not map to %s" | |||
102 | #define ERR_DECODE_NOMAP"%s \"\\x%02" "lX" "\" does not map to Unicode" "%s \"\\x%02" UVXf"lX" "\" does not map to Unicode" | |||
103 | #define ERR_DECODE_STR_NOMAP"%s \"%s\" does not map to Unicode" "%s \"%s\" does not map to Unicode" | |||
104 | ||||
105 | static SV * | |||
106 | do_fallback_cb(pTHX_ UV ch, SV *fallback_cb) | |||
107 | { | |||
108 | dSPSV **sp = PL_stack_sp; | |||
109 | int argc; | |||
110 | SV *retval; | |||
111 | ENTERPerl_push_scope(); | |||
112 | SAVETMPSPerl_savetmps(); | |||
113 | PUSHMARK(sp)do { I32 * mark_stack_entry; if (__builtin_expect((((mark_stack_entry = ++PL_markstack_ptr) == PL_markstack_max) ? (_Bool)1 : (_Bool )0),(0))) mark_stack_entry = Perl_markstack_grow(); *mark_stack_entry = (I32)((sp) - PL_stack_base); ; } while (0); | |||
114 | XPUSHs(sv_2mortal(newSVuv(ch)))do { do { (void)0; if (__builtin_expect(((((1) < 0 || PL_stack_max - (sp) < (1))) ? (_Bool)1 : (_Bool)0),(0))) { sp = Perl_stack_grow ( sp,sp,(sizeof(1) > sizeof(ssize_t) && ((ssize_t) (1) != (1)) ? -1 : (1))); ((void)sizeof(sp)); } } while (0); * ++sp = (Perl_sv_2mortal( Perl_newSVuv( ch))); } while (0); | |||
115 | PUTBACKPL_stack_sp = sp; | |||
116 | argc = call_sv(fallback_cb, G_SCALAR)Perl_call_sv( fallback_cb,2); | |||
117 | SPAGAINsp = PL_stack_sp; | |||
118 | if (argc != 1){ | |||
119 | croakPerl_croak("fallback sub must return scalar!"); | |||
120 | } | |||
121 | retval = POPs(*sp--); | |||
122 | SvREFCNT_inc(retval)Perl_SvREFCNT_inc(((SV *)({ void *_p = (retval); _p; }))); | |||
123 | PUTBACKPL_stack_sp = sp; | |||
124 | FREETMPSif (PL_tmps_ix > PL_tmps_floor) Perl_free_tmps(); | |||
125 | LEAVEPerl_pop_scope(); | |||
126 | return retval; | |||
127 | } | |||
128 | ||||
129 | static SV * | |||
130 | do_bytes_fallback_cb(pTHX_ U8 *s, STRLEN slen, SV *fallback_cb) | |||
131 | { | |||
132 | dSPSV **sp = PL_stack_sp; | |||
133 | int argc; | |||
134 | STRLEN i; | |||
135 | SV *retval; | |||
136 | ENTERPerl_push_scope(); | |||
137 | SAVETMPSPerl_savetmps(); | |||
138 | PUSHMARK(sp)do { I32 * mark_stack_entry; if (__builtin_expect((((mark_stack_entry = ++PL_markstack_ptr) == PL_markstack_max) ? (_Bool)1 : (_Bool )0),(0))) mark_stack_entry = Perl_markstack_grow(); *mark_stack_entry = (I32)((sp) - PL_stack_base); ; } while (0); | |||
139 | for (i=0; i<slen; ++i) | |||
140 | XPUSHs(sv_2mortal(newSVuv(s[i])))do { do { (void)0; if (__builtin_expect(((((1) < 0 || PL_stack_max - (sp) < (1))) ? (_Bool)1 : (_Bool)0),(0))) { sp = Perl_stack_grow ( sp,sp,(sizeof(1) > sizeof(ssize_t) && ((ssize_t) (1) != (1)) ? -1 : (1))); ((void)sizeof(sp)); } } while (0); * ++sp = (Perl_sv_2mortal( Perl_newSVuv( s[i]))); } while (0); | |||
141 | PUTBACKPL_stack_sp = sp; | |||
142 | argc = call_sv(fallback_cb, G_SCALAR)Perl_call_sv( fallback_cb,2); | |||
143 | SPAGAINsp = PL_stack_sp; | |||
144 | if (argc != 1){ | |||
145 | croakPerl_croak("fallback sub must return scalar!"); | |||
146 | } | |||
147 | retval = POPs(*sp--); | |||
148 | SvREFCNT_inc(retval)Perl_SvREFCNT_inc(((SV *)({ void *_p = (retval); _p; }))); | |||
149 | PUTBACKPL_stack_sp = sp; | |||
150 | FREETMPSif (PL_tmps_ix > PL_tmps_floor) Perl_free_tmps(); | |||
151 | LEAVEPerl_pop_scope(); | |||
152 | return retval; | |||
153 | } | |||
154 | ||||
155 | static SV * | |||
156 | encode_method(pTHX_ const encode_t * enc, const encpage_t * dir, SV * src, U8 * s, STRLEN slen, | |||
157 | IV check, STRLEN * offset, SV * term, int * retcode, | |||
158 | SV *fallback_cb) | |||
159 | { | |||
160 | U8 *sorig = s; | |||
161 | STRLEN tlen = slen; | |||
162 | STRLEN ddone = 0; | |||
163 | STRLEN sdone = 0; | |||
164 | /* We allocate slen+1. | |||
165 | PerlIO dumps core if this value is smaller than this. */ | |||
166 | SV *dst = newSV(slen+1)Perl_newSV( slen+1); | |||
167 | U8 *d = (U8 *)SvPVX(dst)((dst)->sv_u.svu_pv); | |||
168 | STRLEN dlen = SvLEN(dst)((XPV*) (dst)->sv_any)->xpv_len_u.xpvlenu_len-1; | |||
169 | int code = 0; | |||
170 | STRLEN trmlen = 0; | |||
171 | U8 *trm = term ? (U8*) SvPV(term, trmlen)((((term)->sv_flags & (0x00000400|0x00200000)) == 0x00000400 ) ? ((trmlen = ((XPV*) (term)->sv_any)->xpv_cur), ((term )->sv_u.svu_pv)) : Perl_sv_2pv_flags( term,&trmlen,2)) : NULL((void*)0); | |||
172 | ||||
173 | if (SvTAINTED(src)(((src)->sv_flags & (0x00200000|0x00400000|0x00800000) ) && Perl_sv_tainted( src))) SvTAINTED_on(dst)do{ if(__builtin_expect((((((__builtin_expect(((PL_tainting) ? (_Bool)1 : (_Bool)0),(0))) ? (_Bool)1 : (_Bool)0))) ? (_Bool )1 : (_Bool)0),(0))){Perl_sv_magic( (dst),((void*)0),'t',((void *)0),0);} }while (0); /* propagate taintedness */ | |||
174 | ||||
175 | if (offset) { | |||
176 | s += *offset; | |||
177 | if (slen > *offset){ /* safeguard against slen overflow */ | |||
178 | slen -= *offset; | |||
179 | }else{ | |||
180 | slen = 0; | |||
181 | } | |||
182 | tlen = slen; | |||
183 | } | |||
184 | ||||
185 | if (slen == 0){ | |||
186 | SvCUR_set(dst, 0)do { ((void)0); ((void)0); ((void)0); (((XPV*) (dst)->sv_any )->xpv_cur = (0)); } while (0); | |||
187 | SvPOK_only(dst)( (dst)->sv_flags &= ~((0x00000100|0x00000200|0x00000400 |0x00000800| 0x00001000|0x00002000|0x00004000|0x00008000)| 0x80000000 |0x20000000), (dst)->sv_flags |= (0x00000400|0x00004000)); | |||
188 | goto ENCODE_END; | |||
189 | } | |||
190 | ||||
191 | while( (code = do_encode(dir, s, &slen, d, dlen, &dlen, !check, | |||
192 | trm, trmlen)) ) | |||
193 | { | |||
194 | SvCUR_set(dst, dlen+ddone)do { ((void)0); ((void)0); ((void)0); (((XPV*) (dst)->sv_any )->xpv_cur = (dlen+ddone)); } while (0); | |||
195 | SvPOK_only(dst)( (dst)->sv_flags &= ~((0x00000100|0x00000200|0x00000400 |0x00000800| 0x00001000|0x00002000|0x00004000|0x00008000)| 0x80000000 |0x20000000), (dst)->sv_flags |= (0x00000400|0x00004000)); | |||
196 | ||||
197 | if (code == ENCODE_FALLBACK4 || code == ENCODE_PARTIAL2 || | |||
198 | code == ENCODE_FOUND_TERM5) { | |||
199 | break; | |||
200 | } | |||
201 | switch (code) { | |||
202 | case ENCODE_NOSPACE1: | |||
203 | { | |||
204 | STRLEN more = 0; /* make sure you initialize! */ | |||
205 | STRLEN sleft; | |||
206 | sdone += slen; | |||
207 | ddone += dlen; | |||
208 | sleft = tlen - sdone; | |||
209 | #if ENCODE_XS_PROFILE0 >= 2 | |||
210 | Perl_warn(aTHX_ | |||
211 | "more=%d, sdone=%d, sleft=%d, SvLEN(dst)=%d\n", | |||
212 | more, sdone, sleft, SvLEN(dst)((XPV*) (dst)->sv_any)->xpv_len_u.xpvlenu_len); | |||
213 | #endif | |||
214 | if (sdone != 0) { /* has src ever been processed ? */ | |||
215 | #if ENCODE_XS_USEFP1 == 2 | |||
216 | more = (1.0*tlen*SvLEN(dst)((XPV*) (dst)->sv_any)->xpv_len_u.xpvlenu_len+sdone-1)/sdone | |||
217 | - SvLEN(dst)((XPV*) (dst)->sv_any)->xpv_len_u.xpvlenu_len; | |||
218 | #elif ENCODE_XS_USEFP1 | |||
219 | more = (STRLEN)((1.0*SvLEN(dst)((XPV*) (dst)->sv_any)->xpv_len_u.xpvlenu_len+1)/sdone * sleft); | |||
220 | #else | |||
221 | /* safe until SvLEN(dst) == MAX_INT/16 */ | |||
222 | more = (16*SvLEN(dst)((XPV*) (dst)->sv_any)->xpv_len_u.xpvlenu_len+1)/sdone/16 * sleft; | |||
223 | #endif | |||
224 | } | |||
225 | more += UTF8_MAXLEN13; /* insurance policy */ | |||
226 | d = (U8 *) SvGROW(dst, SvLEN(dst) + more)(((dst)->sv_flags & 0x10000000) || ((XPV*) (dst)->sv_any )->xpv_len_u.xpvlenu_len < (((XPV*) (dst)->sv_any)-> xpv_len_u.xpvlenu_len + more) ? Perl_sv_grow( dst,((XPV*) (dst )->sv_any)->xpv_len_u.xpvlenu_len + more) : ((dst)-> sv_u.svu_pv)); | |||
227 | /* dst need to grow need MORE bytes! */ | |||
228 | if (ddone >= SvLEN(dst)((XPV*) (dst)->sv_any)->xpv_len_u.xpvlenu_len) { | |||
229 | Perl_croak(aTHX_ "Destination couldn't be grown."); | |||
230 | } | |||
231 | dlen = SvLEN(dst)((XPV*) (dst)->sv_any)->xpv_len_u.xpvlenu_len-ddone-1; | |||
232 | d += ddone; | |||
233 | s += slen; | |||
234 | slen = tlen-sdone; | |||
235 | continue; | |||
236 | } | |||
237 | ||||
238 | case ENCODE_NOREP3: | |||
239 | /* encoding */ | |||
240 | if (dir == enc->f_utf8) { | |||
241 | STRLEN clen; | |||
242 | UV ch = | |||
243 | utf8n_to_uvchr(s+slen, (tlen-sdone-slen),Perl_utf8n_to_uvchr_msgs(s+slen, (tlen-sdone-slen), &clen , ( 0x0002 |0x0004 |0x0008 |0x0010 |0x0080)|0x10000, 0, 0) | |||
244 | &clen, UTF8_ALLOW_ANY|UTF8_CHECK_ONLY)Perl_utf8n_to_uvchr_msgs(s+slen, (tlen-sdone-slen), &clen , ( 0x0002 |0x0004 |0x0008 |0x0010 |0x0080)|0x10000, 0, 0); | |||
245 | /* if non-representable multibyte prefix at end of current buffer - break*/ | |||
246 | if (clen > tlen - sdone - slen) break; | |||
247 | if (check & ENCODE_DIE_ON_ERR0x0001) { | |||
248 | Perl_croak(aTHX_ ERR_ENCODE_NOMAP"\"\\x{%04" "lx" "}\" does not map to %s", | |||
249 | (UV)ch, enc->name[0]); | |||
250 | return &PL_sv_undef(PL_sv_immortals[1]); /* never reaches but be safe */ | |||
251 | } | |||
252 | if (encode_ckWARN(check, WARN_UTF8)((check & 0x0002) && (!(check & 0x0010) || Perl_ckwarn ( (44 ))))) { | |||
253 | Perl_warner(aTHX_ packWARN(WARN_UTF8)(44 ), | |||
254 | ERR_ENCODE_NOMAP"\"\\x{%04" "lx" "}\" does not map to %s", (UV)ch, enc->name[0]); | |||
255 | } | |||
256 | if (check & ENCODE_RETURN_ON_ERR0x0004){ | |||
257 | goto ENCODE_SET_SRC; | |||
258 | } | |||
259 | if (check & (ENCODE_PERLQQ0x0100|ENCODE_HTMLCREF0x0200|ENCODE_XMLCREF0x0400)){ | |||
260 | STRLEN sublen; | |||
261 | char *substr; | |||
262 | SV* subchar = | |||
263 | (fallback_cb != &PL_sv_undef(PL_sv_immortals[1])) | |||
264 | ? do_fallback_cb(aTHX_ ch, fallback_cb) | |||
265 | : newSVpvfPerl_newSVpvf(check & ENCODE_PERLQQ0x0100 ? "\\x{%04" UVxf"lx" "}" : | |||
266 | check & ENCODE_HTMLCREF0x0200 ? "&#%" UVuf"lu" ";" : | |||
267 | "&#x%" UVxf"lx" ";", (UV)ch); | |||
268 | substr = SvPV(subchar, sublen)((((subchar)->sv_flags & (0x00000400|0x00200000)) == 0x00000400 ) ? ((sublen = ((XPV*) (subchar)->sv_any)->xpv_cur), (( subchar)->sv_u.svu_pv)) : Perl_sv_2pv_flags( subchar,& sublen,2)); | |||
269 | if (SvUTF8(subchar)((subchar)->sv_flags & 0x20000000) && sublen && !utf8_to_bytes((U8 *)substr, &sublen)Perl_utf8_to_bytes( (U8 *)substr,&sublen)) { /* make sure no decoded string gets in */ | |||
270 | SvREFCNT_dec(subchar)Perl_SvREFCNT_dec( ((SV *)({ void *_p = (subchar); _p; }))); | |||
271 | croakPerl_croak("Wide character"); | |||
272 | } | |||
273 | sdone += slen + clen; | |||
274 | ddone += dlen + sublen; | |||
275 | sv_catpvn(dst, substr, sublen)Perl_sv_catpvn_flags( dst,substr,sublen,2); | |||
276 | SvREFCNT_dec(subchar)Perl_SvREFCNT_dec( ((SV *)({ void *_p = (subchar); _p; }))); | |||
277 | } else { | |||
278 | /* fallback char */ | |||
279 | sdone += slen + clen; | |||
280 | ddone += dlen + enc->replen; | |||
281 | sv_catpvn(dst, (char*)enc->rep, enc->replen)Perl_sv_catpvn_flags( dst,(char*)enc->rep,enc->replen,2 ); | |||
282 | } | |||
283 | } | |||
284 | /* decoding */ | |||
285 | else { | |||
286 | if (check & ENCODE_DIE_ON_ERR0x0001){ | |||
287 | Perl_croak(aTHX_ ERR_DECODE_NOMAP"%s \"\\x%02" "lX" "\" does not map to Unicode", | |||
288 | enc->name[0], (UV)s[slen]); | |||
289 | return &PL_sv_undef(PL_sv_immortals[1]); /* never reaches but be safe */ | |||
290 | } | |||
291 | if (encode_ckWARN(check, WARN_UTF8)((check & 0x0002) && (!(check & 0x0010) || Perl_ckwarn ( (44 ))))) { | |||
292 | Perl_warner( | |||
293 | aTHX_ packWARN(WARN_UTF8)(44 ), | |||
294 | ERR_DECODE_NOMAP"%s \"\\x%02" "lX" "\" does not map to Unicode", | |||
295 | enc->name[0], (UV)s[slen]); | |||
296 | } | |||
297 | if (check & ENCODE_RETURN_ON_ERR0x0004){ | |||
298 | goto ENCODE_SET_SRC; | |||
299 | } | |||
300 | if (check & | |||
301 | (ENCODE_PERLQQ0x0100|ENCODE_HTMLCREF0x0200|ENCODE_XMLCREF0x0400)){ | |||
302 | STRLEN sublen; | |||
303 | char *substr; | |||
304 | SV* subchar = | |||
305 | (fallback_cb != &PL_sv_undef(PL_sv_immortals[1])) | |||
306 | ? do_fallback_cb(aTHX_ (UV)s[slen], fallback_cb) | |||
307 | : newSVpvfPerl_newSVpvf("\\x%02" UVXf"lX", (UV)s[slen]); | |||
308 | substr = SvPVutf8(subchar, sublen)((((subchar)->sv_flags & (0x00000400|0x20000000|0x00200000 )) == (0x00000400|0x20000000)) ? ((sublen = ((XPV*) (subchar) ->sv_any)->xpv_cur), ((subchar)->sv_u.svu_pv)) : Perl_sv_2pvutf8_flags ( subchar,&sublen,2)); | |||
309 | sdone += slen + 1; | |||
310 | ddone += dlen + sublen; | |||
311 | sv_catpvn(dst, substr, sublen)Perl_sv_catpvn_flags( dst,substr,sublen,2); | |||
312 | SvREFCNT_dec(subchar)Perl_SvREFCNT_dec( ((SV *)({ void *_p = (subchar); _p; }))); | |||
313 | } else { | |||
314 | sdone += slen + 1; | |||
315 | ddone += dlen + strlen(FBCHAR_UTF8"\xEF\xBF\xBD"); | |||
316 | sv_catpvn(dst, FBCHAR_UTF8, strlen(FBCHAR_UTF8))Perl_sv_catpvn_flags( dst,"\xEF\xBF\xBD",strlen("\xEF\xBF\xBD" ),2); | |||
317 | } | |||
318 | } | |||
319 | /* settle variables when fallback */ | |||
320 | d = (U8 *)SvEND(dst)((dst)->sv_u.svu_pv + ((XPV*)(dst)->sv_any)->xpv_cur ); | |||
321 | dlen = SvLEN(dst)((XPV*) (dst)->sv_any)->xpv_len_u.xpvlenu_len - ddone - 1; | |||
322 | s = sorig + sdone; | |||
323 | slen = tlen - sdone; | |||
324 | break; | |||
325 | ||||
326 | default: | |||
327 | Perl_croak(aTHX_ "Unexpected code %d converting %s %s", | |||
328 | code, (dir == enc->f_utf8) ? "to" : "from", | |||
329 | enc->name[0]); | |||
330 | return &PL_sv_undef(PL_sv_immortals[1]); | |||
331 | } | |||
332 | } /* End of looping through the string */ | |||
333 | ENCODE_SET_SRC: | |||
334 | if (check && !(check & ENCODE_LEAVE_SRC0x0008)){ | |||
335 | sdone = tlen - (slen+sdone); | |||
336 | sv_setpvn(src, (char*)s+slen, sdone)Perl_sv_setpvn( src,(char*)s+slen,sdone); | |||
337 | SvSETMAGIC(src)do { if (__builtin_expect(((((src)->sv_flags & 0x00400000 )) ? (_Bool)1 : (_Bool)0),(0))) Perl_mg_set( src); } while (0 ); | |||
338 | } | |||
339 | /* warn("check = 0x%X, code = 0x%d\n", check, code); */ | |||
340 | ||||
341 | SvCUR_set(dst, dlen+ddone)do { ((void)0); ((void)0); ((void)0); (((XPV*) (dst)->sv_any )->xpv_cur = (dlen+ddone)); } while (0); | |||
342 | SvPOK_only(dst)( (dst)->sv_flags &= ~((0x00000100|0x00000200|0x00000400 |0x00000800| 0x00001000|0x00002000|0x00004000|0x00008000)| 0x80000000 |0x20000000), (dst)->sv_flags |= (0x00000400|0x00004000)); | |||
343 | ||||
344 | #if ENCODE_XS_PROFILE0 | |||
345 | if (SvCUR(dst)((XPV*) (dst)->sv_any)->xpv_cur > tlen){ | |||
346 | Perl_warn(aTHX_ | |||
347 | "SvLEN(dst)=%d, SvCUR(dst)=%d. %d bytes unused(%f %%)\n", | |||
348 | SvLEN(dst)((XPV*) (dst)->sv_any)->xpv_len_u.xpvlenu_len, SvCUR(dst)((XPV*) (dst)->sv_any)->xpv_cur, SvLEN(dst)((XPV*) (dst)->sv_any)->xpv_len_u.xpvlenu_len - SvCUR(dst)((XPV*) (dst)->sv_any)->xpv_cur, | |||
349 | (SvLEN(dst)((XPV*) (dst)->sv_any)->xpv_len_u.xpvlenu_len - SvCUR(dst)((XPV*) (dst)->sv_any)->xpv_cur)*1.0/SvLEN(dst)((XPV*) (dst)->sv_any)->xpv_len_u.xpvlenu_len*100.0); | |||
350 | } | |||
351 | #endif | |||
352 | ||||
353 | if (offset) | |||
354 | *offset += sdone + slen; | |||
355 | ||||
356 | ENCODE_END: | |||
357 | *SvEND(dst)((dst)->sv_u.svu_pv + ((XPV*)(dst)->sv_any)->xpv_cur ) = '\0'; | |||
358 | if (retcode) *retcode = code; | |||
359 | return dst; | |||
360 | } | |||
361 | ||||
362 | static bool_Bool | |||
363 | strict_utf8(pTHX_ SV* sv) | |||
364 | { | |||
365 | HV* hv; | |||
366 | SV** svp; | |||
367 | sv = SvRV(sv)((sv)->sv_u.svu_rv); | |||
368 | if (!sv || SvTYPE(sv)((svtype)((sv)->sv_flags & 0xff)) != SVt_PVHV) | |||
369 | return 0; | |||
370 | hv = (HV*)sv; | |||
371 | svp = hv_fetch(hv, "strict_utf8", 11, 0)((SV**) Perl_hv_common_key_len( (hv),("strict_utf8"),(11),(0) ? (0x20 | 0x10) : 0x20,((void*)0),0)); | |||
372 | if (!svp) | |||
373 | return 0; | |||
374 | return SvTRUE(*svp)Perl_SvTRUE( *svp); | |||
375 | } | |||
376 | ||||
377 | static U8* | |||
378 | process_utf8(pTHX_ SV* dst, U8* s, U8* e, SV *check_sv, | |||
379 | bool_Bool encode, bool_Bool strict, bool_Bool stop_at_partial) | |||
380 | { | |||
381 | /* Copies the purportedly UTF-8 encoded string starting at 's' and ending | |||
382 | * at 'e' - 1 to 'dst', checking as it goes along that the string actually | |||
383 | * is valid UTF-8. There are two levels of strictness checking. If | |||
384 | * 'strict' is FALSE, the string is checked for being well-formed UTF-8, as | |||
385 | * extended by Perl. Additionally, if 'strict' is TRUE, above-Unicode code | |||
386 | * points, surrogates, and non-character code points are checked for. When | |||
387 | * invalid input is encountered, some action is taken, exactly what depends | |||
388 | * on the flags in 'check_sv'. 'encode' gives if this is from an encode | |||
389 | * operation (if TRUE), or a decode one. This function returns the | |||
390 | * position in 's' of the start of the next character beyond where it got | |||
391 | * to. If there were no problems, that will be 'e'. If 'stop_at_partial' | |||
392 | * is TRUE, if the final character before 'e' is incomplete, but valid as | |||
393 | * far as is available, no action will be taken on that partial character, | |||
394 | * and the return value will point to its first byte */ | |||
395 | ||||
396 | UV uv; | |||
397 | STRLEN ulen; | |||
398 | SV *fallback_cb; | |||
399 | IV check; | |||
400 | U8 *d; | |||
401 | STRLEN dlen; | |||
402 | char esc[UTF8_MAXLEN13 * 6 + 1]; | |||
403 | STRLEN i; | |||
404 | const U32 flags = (strict) | |||
| ||||
405 | ? UTF8_DISALLOW_ILLEGAL_INTERCHANGE((0x1000|0x0100)|0x0400) | |||
406 | : 0; | |||
407 | ||||
408 | if (!SvOK(check_sv)((check_sv)->sv_flags & (0x00000100|0x00000200|0x00000400 |0x00000800| 0x00001000|0x00002000|0x00004000|0x00008000))) { | |||
409 | fallback_cb = &PL_sv_undef(PL_sv_immortals[1]); | |||
410 | check = 0; | |||
411 | } | |||
412 | else if (SvROK(check_sv)((check_sv)->sv_flags & 0x00000800)) { | |||
413 | /* croak("UTF-8 decoder doesn't support callback CHECK"); */ | |||
414 | fallback_cb = check_sv; | |||
415 | check = ENCODE_PERLQQ0x0100|ENCODE_LEAVE_SRC0x0008; /* same as perlqq */ | |||
416 | } | |||
417 | else { | |||
418 | fallback_cb = &PL_sv_undef(PL_sv_immortals[1]); | |||
419 | check = SvIV_nomg(check_sv)(((check_sv)->sv_flags & 0x00000100) ? ((XPVIV*) (check_sv )->sv_any)->xiv_u.xivu_iv : Perl_sv_2iv_flags( check_sv ,0)); | |||
420 | } | |||
421 | ||||
422 | SvPOK_only(dst)( (dst)->sv_flags &= ~((0x00000100|0x00000200|0x00000400 |0x00000800| 0x00001000|0x00002000|0x00004000|0x00008000)| 0x80000000 |0x20000000), (dst)->sv_flags |= (0x00000400|0x00004000)); | |||
423 | SvCUR_set(dst,0)do { ((void)0); ((void)0); ((void)0); (((XPV*) (dst)->sv_any )->xpv_cur = (0)); } while (0); | |||
424 | ||||
425 | dlen = (s && e && s < e) ? e-s+1 : 1; | |||
426 | d = (U8 *) SvGROW(dst, dlen)(((dst)->sv_flags & 0x10000000) || ((XPV*) (dst)->sv_any )->xpv_len_u.xpvlenu_len < (dlen) ? Perl_sv_grow( dst,dlen ) : ((dst)->sv_u.svu_pv)); | |||
427 | ||||
428 | stop_at_partial = stop_at_partial || (check & ENCODE_STOP_AT_PARTIAL0x0800); | |||
429 | ||||
430 | while (s < e) { | |||
431 | ||||
432 | /* If there were no errors, this will be 'e'; otherwise it will point | |||
433 | * to the first byte of the erroneous input */ | |||
434 | const U8* e_or_where_failed; | |||
435 | bool_Bool valid = is_utf8_string_loc_flags(s, e - s, &e_or_where_failed, flags)Perl_is_utf8_string_loclen_flags(s, e - s, &e_or_where_failed , 0, flags); | |||
436 | STRLEN len = e_or_where_failed - s; | |||
437 | ||||
438 | /* Copy as far as was successful */ | |||
439 | Move(s, d, len, U8)((void)(__builtin_expect(((((( sizeof(size_t) < sizeof(len ) || sizeof(U8) > ((size_t)1 << 8*(sizeof(size_t) - sizeof (len)))) ? (size_t)(len) : ((size_t)-1)/sizeof(U8)) > ((size_t )-1)/sizeof(U8))) ? (_Bool)1 : (_Bool)0),(0)) && (Perl_croak_memory_wrap (),0)), ((void)0), ((void)0), (void)memmove((char*)(d),(const char*)(s), (len) * sizeof(U8))); | |||
440 | d += len; | |||
441 | s = (U8 *) e_or_where_failed; | |||
442 | ||||
443 | /* Are done if it was valid, or we are accepting partial characters and | |||
444 | * the only error is that the final bytes form a partial character */ | |||
445 | if ( LIKELY(valid)__builtin_expect(((valid) ? (_Bool)1 : (_Bool)0),(1)) | |||
446 | || ( stop_at_partial | |||
447 | && is_utf8_valid_partial_char_flagsPerl_is_utf8_valid_partial_char_flags(s, e, flags))) | |||
448 | { | |||
449 | break; | |||
450 | } | |||
451 | ||||
452 | /* Here, was not valid. If is 'strict', and is legal extended UTF-8, | |||
453 | * we know it is a code point whose value we can calculate, just not | |||
454 | * one accepted under strict. Otherwise, it is malformed in some way. | |||
455 | * In either case, the system function can calculate either the code | |||
456 | * point, or the best substitution for it */ | |||
457 | uv = utf8n_to_uvchr(s, e - s, &ulen, UTF8_ALLOW_ANY)Perl_utf8n_to_uvchr_msgs(s, e - s, &ulen, ( 0x0002 |0x0004 |0x0008 |0x0010 |0x0080), 0, 0); | |||
458 | ||||
459 | /* | |||
460 | * Here, we are looping through the input and found an error. | |||
461 | * 'uv' is the code point in error if calculable, or the REPLACEMENT | |||
462 | * CHARACTER if not. | |||
463 | * 'ulen' is how many bytes of input this iteration of the loop | |||
464 | * consumes */ | |||
465 | ||||
466 | if (!encode && (check & (ENCODE_DIE_ON_ERR0x0001|ENCODE_WARN_ON_ERR0x0002|ENCODE_PERLQQ0x0100))) | |||
467 | for (i=0; i<ulen; ++i) sprintf(esc+4*i, "\\x%02X", s[i]); | |||
468 | if (check & ENCODE_DIE_ON_ERR0x0001){ | |||
469 | if (encode) | |||
470 | Perl_croak(aTHX_ ERR_ENCODE_NOMAP"\"\\x{%04" "lx" "}\" does not map to %s", uv, (strict ? "UTF-8" : "utf8")); | |||
471 | else | |||
472 | Perl_croak(aTHX_ ERR_DECODE_STR_NOMAP"%s \"%s\" does not map to Unicode", (strict ? "UTF-8" : "utf8"), esc); | |||
473 | } | |||
474 | if (encode_ckWARN(check, WARN_UTF8)((check & 0x0002) && (!(check & 0x0010) || Perl_ckwarn ( (44 ))))) { | |||
475 | if (encode) | |||
476 | Perl_warner(aTHX_ packWARN(WARN_UTF8)(44 ), | |||
477 | ERR_ENCODE_NOMAP"\"\\x{%04" "lx" "}\" does not map to %s", uv, (strict ? "UTF-8" : "utf8")); | |||
478 | else | |||
479 | Perl_warner(aTHX_ packWARN(WARN_UTF8)(44 ), | |||
480 | ERR_DECODE_STR_NOMAP"%s \"%s\" does not map to Unicode", (strict ? "UTF-8" : "utf8"), esc); | |||
481 | } | |||
482 | if (check & ENCODE_RETURN_ON_ERR0x0004) { | |||
483 | break; | |||
484 | } | |||
485 | if (check & (ENCODE_PERLQQ0x0100|ENCODE_HTMLCREF0x0200|ENCODE_XMLCREF0x0400)){ | |||
486 | STRLEN sublen; | |||
487 | char *substr; | |||
488 | SV* subchar; | |||
489 | if (encode) { | |||
490 | subchar = | |||
491 | (fallback_cb != &PL_sv_undef(PL_sv_immortals[1])) | |||
492 | ? do_fallback_cb(aTHX_ uv, fallback_cb) | |||
493 | : newSVpvfPerl_newSVpvf(check & ENCODE_PERLQQ0x0100 | |||
494 | ? (ulen == 1 ? "\\x%02" UVXf"lX" : "\\x{%04" UVXf"lX" "}") | |||
495 | : check & ENCODE_HTMLCREF0x0200 ? "&#%" UVuf"lu" ";" | |||
496 | : "&#x%" UVxf"lx" ";", uv); | |||
497 | substr = SvPV(subchar, sublen)((((subchar)->sv_flags & (0x00000400|0x00200000)) == 0x00000400 ) ? ((sublen = ((XPV*) (subchar)->sv_any)->xpv_cur), (( subchar)->sv_u.svu_pv)) : Perl_sv_2pv_flags( subchar,& sublen,2)); | |||
498 | if (SvUTF8(subchar)((subchar)->sv_flags & 0x20000000) && sublen && !utf8_to_bytes((U8 *)substr, &sublen)Perl_utf8_to_bytes( (U8 *)substr,&sublen)) { /* make sure no decoded string gets in */ | |||
499 | SvREFCNT_dec(subchar)Perl_SvREFCNT_dec( ((SV *)({ void *_p = (subchar); _p; }))); | |||
500 | croakPerl_croak("Wide character"); | |||
501 | } | |||
502 | } else { | |||
503 | if (fallback_cb != &PL_sv_undef(PL_sv_immortals[1])) { | |||
504 | /* in decode mode we have sequence of wrong bytes */ | |||
505 | subchar = do_bytes_fallback_cb(aTHX_ s, ulen, fallback_cb); | |||
506 | } else { | |||
507 | char *ptr = esc; | |||
508 | /* ENCODE_PERLQQ is already stored in esc */ | |||
509 | if (check & (ENCODE_HTMLCREF0x0200|ENCODE_XMLCREF0x0400)) | |||
510 | for (i=0; i<ulen; ++i) ptr += sprintf(ptr, ((check & ENCODE_HTMLCREF0x0200) ? "&#%u;" : "&#x%02X;"), s[i]); | |||
511 | subchar = newSVpvn(esc, strlen(esc))Perl_newSVpvn( esc,strlen(esc)); | |||
512 | } | |||
513 | substr = SvPVutf8(subchar, sublen)((((subchar)->sv_flags & (0x00000400|0x20000000|0x00200000 )) == (0x00000400|0x20000000)) ? ((sublen = ((XPV*) (subchar) ->sv_any)->xpv_cur), ((subchar)->sv_u.svu_pv)) : Perl_sv_2pvutf8_flags ( subchar,&sublen,2)); | |||
514 | } | |||
515 | dlen += sublen - ulen; | |||
516 | SvCUR_set(dst, d-(U8 *)SvPVX(dst))do { ((void)0); ((void)0); ((void)0); (((XPV*) (dst)->sv_any )->xpv_cur = (d-(U8 *)((dst)->sv_u.svu_pv))); } while ( 0); | |||
517 | *SvEND(dst)((dst)->sv_u.svu_pv + ((XPV*)(dst)->sv_any)->xpv_cur ) = '\0'; | |||
518 | sv_catpvn(dst, substr, sublen)Perl_sv_catpvn_flags( dst,substr,sublen,2); | |||
519 | SvREFCNT_dec(subchar)Perl_SvREFCNT_dec( ((SV *)({ void *_p = (subchar); _p; }))); | |||
520 | d = (U8 *) SvGROW(dst, dlen)(((dst)->sv_flags & 0x10000000) || ((XPV*) (dst)->sv_any )->xpv_len_u.xpvlenu_len < (dlen) ? Perl_sv_grow( dst,dlen ) : ((dst)->sv_u.svu_pv)) + SvCUR(dst)((XPV*) (dst)->sv_any)->xpv_cur; | |||
521 | } else { | |||
522 | STRLEN fbcharlen = strlen(FBCHAR_UTF8"\xEF\xBF\xBD"); | |||
523 | dlen += fbcharlen - ulen; | |||
524 | if (SvLEN(dst)((XPV*) (dst)->sv_any)->xpv_len_u.xpvlenu_len < dlen) { | |||
525 | SvCUR_set(dst, d-(U8 *)SvPVX(dst))do { ((void)0); ((void)0); ((void)0); (((XPV*) (dst)->sv_any )->xpv_cur = (d-(U8 *)((dst)->sv_u.svu_pv))); } while ( 0); | |||
526 | d = (U8 *) sv_grow(dst, dlen)Perl_sv_grow( dst,dlen) + SvCUR(dst)((XPV*) (dst)->sv_any)->xpv_cur; | |||
527 | } | |||
528 | memcpy(d, FBCHAR_UTF8"\xEF\xBF\xBD", fbcharlen); | |||
529 | d += fbcharlen; | |||
530 | } | |||
531 | s += ulen; | |||
532 | } | |||
533 | SvCUR_set(dst, d-(U8 *)SvPVX(dst))do { ((void)0); ((void)0); ((void)0); (((XPV*) (dst)->sv_any )->xpv_cur = (d-(U8 *)((dst)->sv_u.svu_pv))); } while ( 0); | |||
534 | *SvEND(dst)((dst)->sv_u.svu_pv + ((XPV*)(dst)->sv_any)->xpv_cur ) = '\0'; | |||
535 | ||||
536 | return s; | |||
537 | } | |||
538 | ||||
539 | static SV * | |||
540 | find_encoding(pTHX_ SV *enc) | |||
541 | { | |||
542 | dSPSV **sp = PL_stack_sp; | |||
543 | I32 count; | |||
544 | SV *m_enc; | |||
545 | SV *obj = &PL_sv_undef(PL_sv_immortals[1]); | |||
546 | #ifndef SV_NOSTEAL16 | |||
547 | U32 tmp; | |||
548 | #endif | |||
549 | ||||
550 | ENTERPerl_push_scope(); | |||
551 | SAVETMPSPerl_savetmps(); | |||
552 | PUSHMARK(sp)do { I32 * mark_stack_entry; if (__builtin_expect((((mark_stack_entry = ++PL_markstack_ptr) == PL_markstack_max) ? (_Bool)1 : (_Bool )0),(0))) mark_stack_entry = Perl_markstack_grow(); *mark_stack_entry = (I32)((sp) - PL_stack_base); ; } while (0); | |||
553 | ||||
554 | m_enc = sv_newmortal()Perl_sv_newmortal(); | |||
555 | #ifndef SV_NOSTEAL16 | |||
556 | tmp = SvFLAGS(enc)(enc)->sv_flags & SVs_TEMP0x00080000; | |||
557 | SvTEMP_off(enc)((enc)->sv_flags &= ~0x00080000); | |||
558 | sv_setsv_flags(m_enc, enc, 0)Perl_sv_setsv_flags( m_enc,enc,0); | |||
559 | SvFLAGS(enc)(enc)->sv_flags |= tmp; | |||
560 | #else | |||
561 | #if SV_NOSTEAL16 == 0 | |||
562 | #error You have broken SV_NOSTEAL16 which cause memory corruption in sv_setsv_flags() | |||
563 | #error Most probably broken SV_NOSTEAL16 was defined by buggy version of ppport.h | |||
564 | #else | |||
565 | sv_setsv_flags(m_enc, enc, SV_NOSTEAL)Perl_sv_setsv_flags( m_enc,enc,16); | |||
566 | #endif | |||
567 | #endif | |||
568 | XPUSHs(m_enc)do { do { (void)0; if (__builtin_expect(((((1) < 0 || PL_stack_max - (sp) < (1))) ? (_Bool)1 : (_Bool)0),(0))) { sp = Perl_stack_grow ( sp,sp,(sizeof(1) > sizeof(ssize_t) && ((ssize_t) (1) != (1)) ? -1 : (1))); ((void)sizeof(sp)); } } while (0); * ++sp = (m_enc); } while (0); | |||
569 | ||||
570 | PUTBACKPL_stack_sp = sp; | |||
571 | ||||
572 | count = call_pv("Encode::find_encoding", G_SCALAR)Perl_call_pv( "Encode::find_encoding",2); | |||
573 | ||||
574 | SPAGAINsp = PL_stack_sp; | |||
575 | ||||
576 | if (count > 0) { | |||
577 | obj = POPs(*sp--); | |||
578 | SvREFCNT_inc(obj)Perl_SvREFCNT_inc(((SV *)({ void *_p = (obj); _p; }))); | |||
579 | } | |||
580 | ||||
581 | PUTBACKPL_stack_sp = sp; | |||
582 | FREETMPSif (PL_tmps_ix > PL_tmps_floor) Perl_free_tmps(); | |||
583 | LEAVEPerl_pop_scope(); | |||
584 | return sv_2mortal(obj)Perl_sv_2mortal( obj); | |||
585 | } | |||
586 | ||||
587 | static SV * | |||
588 | call_encoding(pTHX_ const char *method, SV *obj, SV *src, SV *check) | |||
589 | { | |||
590 | dSPSV **sp = PL_stack_sp; | |||
591 | I32 count; | |||
592 | SV *dst = &PL_sv_undef(PL_sv_immortals[1]); | |||
593 | ||||
594 | PUSHMARK(sp)do { I32 * mark_stack_entry; if (__builtin_expect((((mark_stack_entry = ++PL_markstack_ptr) == PL_markstack_max) ? (_Bool)1 : (_Bool )0),(0))) mark_stack_entry = Perl_markstack_grow(); *mark_stack_entry = (I32)((sp) - PL_stack_base); ; } while (0); | |||
595 | ||||
596 | if (check) | |||
597 | check = sv_2mortal(newSVsv(check))Perl_sv_2mortal( Perl_newSVsv_flags( (check),2|16)); | |||
598 | ||||
599 | if (!check || SvROK(check)((check)->sv_flags & 0x00000800) || !SvTRUE_nomg(check)(__builtin_expect(((check) ? (_Bool)1 : (_Bool)0),(1)) && (( ((size_t)((check) - &(PL_sv_immortals[0])) < 4) ? ( (check) == &(PL_sv_immortals[0])) : !((check)->sv_flags & (0x00000100|0x00000200|0x00000400|0x00000800| 0x00001000 |0x00002000|0x00004000|0x00008000)) ? 0 : ((check)->sv_flags & 0x00000400) ? ( ((XPV*)((check))->sv_any) && ( ((XPV*)((check))->sv_any)->xpv_cur > 1 || ( ((XPV *)((check))->sv_any)->xpv_cur && *(check)->sv_u .svu_pv != '0' ) ) ) : ((check)->sv_flags & 0x00000100 ) ? (((XPVIV*) (check)->sv_any)->xiv_u.xivu_iv != 0 ) : (((check)->sv_flags & 0x00000800) && !( ((((check )->sv_u.svu_rv))->sv_flags & 0x00100000) && ((((XPVMG*) (((check)->sv_u.svu_rv))->sv_any)->xmg_stash )->sv_flags & 0x10000000))) ? (1) : (Perl_sv_2bool_flags ( check,0))))) || (SvIV_nomg(check)(((check)->sv_flags & 0x00000100) ? ((XPVIV*) (check)-> sv_any)->xiv_u.xivu_iv : Perl_sv_2iv_flags( check,0)) & ENCODE_LEAVE_SRC0x0008)) | |||
600 | src = sv_2mortal(newSVsv(src))Perl_sv_2mortal( Perl_newSVsv_flags( (src),2|16)); | |||
601 | ||||
602 | XPUSHs(obj)do { do { (void)0; if (__builtin_expect(((((1) < 0 || PL_stack_max - (sp) < (1))) ? (_Bool)1 : (_Bool)0),(0))) { sp = Perl_stack_grow ( sp,sp,(sizeof(1) > sizeof(ssize_t) && ((ssize_t) (1) != (1)) ? -1 : (1))); ((void)sizeof(sp)); } } while (0); * ++sp = (obj); } while (0); | |||
603 | XPUSHs(src)do { do { (void)0; if (__builtin_expect(((((1) < 0 || PL_stack_max - (sp) < (1))) ? (_Bool)1 : (_Bool)0),(0))) { sp = Perl_stack_grow ( sp,sp,(sizeof(1) > sizeof(ssize_t) && ((ssize_t) (1) != (1)) ? -1 : (1))); ((void)sizeof(sp)); } } while (0); * ++sp = (src); } while (0); | |||
604 | XPUSHs(check ? check : &PL_sv_no)do { do { (void)0; if (__builtin_expect(((((1) < 0 || PL_stack_max - (sp) < (1))) ? (_Bool)1 : (_Bool)0),(0))) { sp = Perl_stack_grow ( sp,sp,(sizeof(1) > sizeof(ssize_t) && ((ssize_t) (1) != (1)) ? -1 : (1))); ((void)sizeof(sp)); } } while (0); * ++sp = (check ? check : &(PL_sv_immortals[2])); } while ( 0); | |||
605 | ||||
606 | PUTBACKPL_stack_sp = sp; | |||
607 | ||||
608 | count = call_method(method, G_SCALAR)Perl_call_method( method,2); | |||
609 | ||||
610 | SPAGAINsp = PL_stack_sp; | |||
611 | ||||
612 | if (count > 0) { | |||
613 | dst = POPs(*sp--); | |||
614 | SvREFCNT_inc(dst)Perl_SvREFCNT_inc(((SV *)({ void *_p = (dst); _p; }))); | |||
615 | } | |||
616 | ||||
617 | PUTBACKPL_stack_sp = sp; | |||
618 | return dst; | |||
619 | } | |||
620 | ||||
621 | ||||
622 | #line 623 "Encode.c" | |||
623 | #ifndef PERL_UNUSED_VAR | |||
624 | # define PERL_UNUSED_VAR(var)((void)sizeof(var)) if (0) var = var | |||
625 | #endif | |||
626 | ||||
627 | #ifndef dVARstruct Perl___notused_struct | |||
628 | # define dVARstruct Perl___notused_struct dNOOPstruct Perl___notused_struct | |||
629 | #endif | |||
630 | ||||
631 | ||||
632 | /* This stuff is not part of the API! You have been warned. */ | |||
633 | #ifndef PERL_VERSION_DECIMAL | |||
634 | # define PERL_VERSION_DECIMAL(r,v,s)(r*1000000 + v*1000 + s) (r*1000000 + v*1000 + s) | |||
635 | #endif | |||
636 | #ifndef PERL_DECIMAL_VERSION(5*1000000 + 32*1000 + 1) | |||
637 | # define PERL_DECIMAL_VERSION(5*1000000 + 32*1000 + 1) \ | |||
638 | PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION)(5*1000000 + 32*1000 + 1) | |||
639 | #endif | |||
640 | #ifndef PERL_VERSION_GE | |||
641 | # define PERL_VERSION_GE(r,v,s)((5*1000000 + 32*1000 + 1) >= (r*1000000 + v*1000 + s)) \ | |||
642 | (PERL_DECIMAL_VERSION(5*1000000 + 32*1000 + 1) >= PERL_VERSION_DECIMAL(r,v,s)(r*1000000 + v*1000 + s)) | |||
643 | #endif | |||
644 | #ifndef PERL_VERSION_LE | |||
645 | # define PERL_VERSION_LE(r,v,s)((5*1000000 + 32*1000 + 1) <= (r*1000000 + v*1000 + s)) \ | |||
646 | (PERL_DECIMAL_VERSION(5*1000000 + 32*1000 + 1) <= PERL_VERSION_DECIMAL(r,v,s)(r*1000000 + v*1000 + s)) | |||
647 | #endif | |||
648 | ||||
649 | /* XS_INTERNAL is the explicit static-linkage variant of the default | |||
650 | * XS macro. | |||
651 | * | |||
652 | * XS_EXTERNAL is the same as XS_INTERNAL except it does not include | |||
653 | * "STATIC", ie. it exports XSUB symbols. You probably don't want that | |||
654 | * for anything but the BOOT XSUB. | |||
655 | * | |||
656 | * See XSUB.h in core! | |||
657 | */ | |||
658 | ||||
659 | ||||
660 | /* TODO: This might be compatible further back than 5.10.0. */ | |||
661 | #if PERL_VERSION_GE(5, 10, 0)((5*1000000 + 32*1000 + 1) >= (5*1000000 + 10*1000 + 0)) && PERL_VERSION_LE(5, 15, 1)((5*1000000 + 32*1000 + 1) <= (5*1000000 + 15*1000 + 1)) | |||
662 | # undef XS_EXTERNAL | |||
663 | # undef XS_INTERNAL | |||
664 | # if defined(__CYGWIN__) && defined(USE_DYNAMIC_LOADING) | |||
665 | # define XS_EXTERNAL(name)void name( CV* cv __attribute__((unused))) __declspec(dllexport) XSPROTO(name)void name( CV* cv __attribute__((unused))) | |||
666 | # define XS_INTERNAL(name)static void name( CV* cv __attribute__((unused))) STATICstatic XSPROTO(name)void name( CV* cv __attribute__((unused))) | |||
667 | # endif | |||
668 | # if defined(__SYMBIAN32__) | |||
669 | # define XS_EXTERNAL(name)void name( CV* cv __attribute__((unused))) EXPORT_C XSPROTO(name)void name( CV* cv __attribute__((unused))) | |||
670 | # define XS_INTERNAL(name)static void name( CV* cv __attribute__((unused))) EXPORT_C STATICstatic XSPROTO(name)void name( CV* cv __attribute__((unused))) | |||
671 | # endif | |||
672 | # ifndef XS_EXTERNAL | |||
673 | # if defined(HASATTRIBUTE_UNUSED) && !defined(__cplusplus) | |||
674 | # define XS_EXTERNAL(name)void name( CV* cv __attribute__((unused))) void name(pTHX_ CV* cv __attribute__unused____attribute__((unused))) | |||
675 | # define XS_INTERNAL(name)static void name( CV* cv __attribute__((unused))) STATICstatic void name(pTHX_ CV* cv __attribute__unused____attribute__((unused))) | |||
676 | # else | |||
677 | # ifdef __cplusplus | |||
678 | # define XS_EXTERNAL(name)void name( CV* cv __attribute__((unused))) extern "C" XSPROTO(name)void name( CV* cv __attribute__((unused))) | |||
679 | # define XS_INTERNAL(name)static void name( CV* cv __attribute__((unused))) static XSPROTO(name)void name( CV* cv __attribute__((unused))) | |||
680 | # else | |||
681 | # define XS_EXTERNAL(name)void name( CV* cv __attribute__((unused))) XSPROTO(name)void name( CV* cv __attribute__((unused))) | |||
682 | # define XS_INTERNAL(name)static void name( CV* cv __attribute__((unused))) STATICstatic XSPROTO(name)void name( CV* cv __attribute__((unused))) | |||
683 | # endif | |||
684 | # endif | |||
685 | # endif | |||
686 | #endif | |||
687 | ||||
688 | /* perl >= 5.10.0 && perl <= 5.15.1 */ | |||
689 | ||||
690 | ||||
691 | /* The XS_EXTERNAL macro is used for functions that must not be static | |||
692 | * like the boot XSUB of a module. If perl didn't have an XS_EXTERNAL | |||
693 | * macro defined, the best we can do is assume XS is the same. | |||
694 | * Dito for XS_INTERNAL. | |||
695 | */ | |||
696 | #ifndef XS_EXTERNAL | |||
697 | # define XS_EXTERNAL(name)void name( CV* cv __attribute__((unused))) XS(name)void name( CV* cv __attribute__((unused))) | |||
698 | #endif | |||
699 | #ifndef XS_INTERNAL | |||
700 | # define XS_INTERNAL(name)static void name( CV* cv __attribute__((unused))) XS(name)void name( CV* cv __attribute__((unused))) | |||
701 | #endif | |||
702 | ||||
703 | /* Now, finally, after all this mess, we want an ExtUtils::ParseXS | |||
704 | * internal macro that we're free to redefine for varying linkage due | |||
705 | * to the EXPORT_XSUB_SYMBOLS XS keyword. This is internal, use | |||
706 | * XS_EXTERNAL(name) or XS_INTERNAL(name) in your code if you need to! | |||
707 | */ | |||
708 | ||||
709 | #undef XS_EUPXS | |||
710 | #if defined(PERL_EUPXS_ALWAYS_EXPORT) | |||
711 | # define XS_EUPXS(name)static void name( CV* cv __attribute__((unused))) XS_EXTERNAL(name)void name( CV* cv __attribute__((unused))) | |||
712 | #else | |||
713 | /* default to internal */ | |||
714 | # define XS_EUPXS(name)static void name( CV* cv __attribute__((unused))) XS_INTERNAL(name)static void name( CV* cv __attribute__((unused))) | |||
715 | #endif | |||
716 | ||||
717 | #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE((void)0); ((void)0) | |||
718 | #define PERL_ARGS_ASSERT_CROAK_XS_USAGE((void)0); ((void)0) assert(cv)((void)0); assert(params)((void)0) | |||
719 | ||||
720 | /* prototype to pass -Wmissing-prototypes */ | |||
721 | STATICstatic void | |||
722 | S_croak_xs_usage(const CV *const cv, const char *const params); | |||
723 | ||||
724 | STATICstatic void | |||
725 | S_croak_xs_usage(const CV *const cv, const char *const params) | |||
726 | { | |||
727 | const GV *const gv = CvGV(cv)Perl_CvGV( (CV *)(cv)); | |||
728 | ||||
729 | PERL_ARGS_ASSERT_CROAK_XS_USAGE((void)0); ((void)0); | |||
730 | ||||
731 | if (gv) { | |||
732 | const char *const gvname = GvNAME(gv)((((XPVGV*)(gv)->sv_any)->xiv_u.xivu_namehek))->hek_key; | |||
733 | const HV *const stash = GvSTASH(gv)(((XPVGV*)(gv)->sv_any)->xnv_u.xgv_stash); | |||
734 | const char *const hvname = stash ? HvNAME(stash)((((stash)->sv_flags & 0x02000000) && ((struct xpvhv_aux*)&(((stash)->sv_u.svu_hash)[((XPVHV*) (stash )->sv_any)->xhv_max+1]))->xhv_name_u.xhvnameu_name && ( ((struct xpvhv_aux*)&(((stash)->sv_u.svu_hash)[((XPVHV *) (stash)->sv_any)->xhv_max+1]))->xhv_name_count ? * ((struct xpvhv_aux*)&(((stash)->sv_u.svu_hash)[((XPVHV *) (stash)->sv_any)->xhv_max+1]))->xhv_name_u.xhvnameu_names : ((struct xpvhv_aux*)&(((stash)->sv_u.svu_hash)[((XPVHV *) (stash)->sv_any)->xhv_max+1]))->xhv_name_u.xhvnameu_name )) ? (( ((struct xpvhv_aux*)&(((stash)->sv_u.svu_hash )[((XPVHV*) (stash)->sv_any)->xhv_max+1]))->xhv_name_count ? *((struct xpvhv_aux*)&(((stash)->sv_u.svu_hash)[((XPVHV *) (stash)->sv_any)->xhv_max+1]))->xhv_name_u.xhvnameu_names : ((struct xpvhv_aux*)&(((stash)->sv_u.svu_hash)[((XPVHV *) (stash)->sv_any)->xhv_max+1]))->xhv_name_u.xhvnameu_name ))->hek_key : ((void*)0)) : NULL((void*)0); | |||
735 | ||||
736 | if (hvname) | |||
737 | Perl_croak_nocontextPerl_croak("Usage: %s::%s(%s)", hvname, gvname, params); | |||
738 | else | |||
739 | Perl_croak_nocontextPerl_croak("Usage: %s(%s)", gvname, params); | |||
740 | } else { | |||
741 | /* Pants. I don't think that it should be possible to get here. */ | |||
742 | Perl_croak_nocontextPerl_croak("Usage: CODE(0x%" UVxf"lx" ")(%s)", PTR2UV(cv)(UV)(cv), params); | |||
743 | } | |||
744 | } | |||
745 | #undef PERL_ARGS_ASSERT_CROAK_XS_USAGE((void)0); ((void)0) | |||
746 | ||||
747 | #define croak_xs_usagePerl_croak_xs_usage S_croak_xs_usage | |||
748 | ||||
749 | #endif | |||
750 | ||||
751 | /* NOTE: the prototype of newXSproto() is different in versions of perls, | |||
752 | * so we define a portable version of newXSproto() | |||
753 | */ | |||
754 | #ifdef newXS_flags | |||
755 | #define newXSproto_portable(name, c_impl, file, proto)Perl_newXS_flags( name,c_impl,file,proto,0) newXS_flags(name, c_impl, file, proto, 0)Perl_newXS_flags( name,c_impl,file,proto,0) | |||
756 | #else | |||
757 | #define newXSproto_portable(name, c_impl, file, proto)Perl_newXS_flags( name,c_impl,file,proto,0) (PL_Sv=(SV*)newXS(name, c_impl, file)Perl_newXS( name,c_impl,file), sv_setpv(PL_Sv, proto)Perl_sv_setpv( PL_Sv,proto), (CV*)PL_Sv) | |||
758 | #endif /* !defined(newXS_flags) */ | |||
759 | ||||
760 | #if PERL_VERSION_LE(5, 21, 5)((5*1000000 + 32*1000 + 1) <= (5*1000000 + 21*1000 + 5)) | |||
761 | # define newXS_deffile(a,b)Perl_newXS_deffile( a,b) Perl_newXS(aTHX_ a,b,file) | |||
762 | #else | |||
763 | # define newXS_deffile(a,b)Perl_newXS_deffile( a,b) Perl_newXS_deffile(aTHX_ a,b) | |||
764 | #endif | |||
765 | ||||
766 | #line 767 "Encode.c" | |||
767 | ||||
768 | XS_EUPXS(XS_Encode__utf8_decode)static void XS_Encode__utf8_decode( CV* cv __attribute__((unused ))); /* prototype to pass -Wmissing-prototypes */ | |||
769 | XS_EUPXS(XS_Encode__utf8_decode)static void XS_Encode__utf8_decode( CV* cv __attribute__((unused ))) | |||
770 | { | |||
771 | dVARstruct Perl___notused_struct; dXSARGSSV **sp = PL_stack_sp; I32 ax = Perl_POPMARK(); SV **mark = PL_stack_base + ax++; I32 items = (I32)(sp - mark); | |||
772 | if (items < 2 || items > 3) | |||
773 | croak_xs_usagePerl_croak_xs_usage(cv, "obj, src, check_sv = &PL_sv_no"); | |||
774 | PERL_UNUSED_VAR(ax)((void)sizeof(ax)); /* -Wall */ | |||
775 | SPsp -= items; | |||
776 | { | |||
777 | SV * obj = ST(0)PL_stack_base[ax + (0)] | |||
778 | ; | |||
779 | SV * src = ST(1)PL_stack_base[ax + (1)] | |||
780 | ; | |||
781 | SV * check_sv; | |||
782 | #line 623 "Encode.xs" | |||
783 | STRLEN slen; | |||
784 | U8 *s; | |||
785 | U8 *e; | |||
786 | SV *dst; | |||
787 | bool_Bool renewed = 0; | |||
788 | IV check; | |||
789 | bool_Bool modify; | |||
790 | dSPSV **sp = PL_stack_sp; | |||
791 | #line 792 "Encode.c" | |||
792 | ||||
793 | if (items < 3) | |||
794 | check_sv = &PL_sv_no(PL_sv_immortals[2]); | |||
795 | else { | |||
796 | check_sv = ST(2)PL_stack_base[ax + (2)] | |||
797 | ; | |||
798 | } | |||
799 | #line 632 "Encode.xs" | |||
800 | SvGETMAGIC(src)((void)(__builtin_expect(((((src)->sv_flags & 0x00200000 )) ? (_Bool)1 : (_Bool)0),(0)) && Perl_mg_get( src))); | |||
801 | SvGETMAGIC(check_sv)((void)(__builtin_expect(((((check_sv)->sv_flags & 0x00200000 )) ? (_Bool)1 : (_Bool)0),(0)) && Perl_mg_get( check_sv ))); | |||
802 | check = SvROK(check_sv)((check_sv)->sv_flags & 0x00000800) ? ENCODE_PERLQQ0x0100|ENCODE_LEAVE_SRC0x0008 : SvOK(check_sv)((check_sv)->sv_flags & (0x00000100|0x00000200|0x00000400 |0x00000800| 0x00001000|0x00002000|0x00004000|0x00008000)) ? SvIV_nomg(check_sv)(((check_sv)->sv_flags & 0x00000100) ? ((XPVIV*) (check_sv )->sv_any)->xiv_u.xivu_iv : Perl_sv_2iv_flags( check_sv ,0)) : 0; | |||
803 | modify = (check && !(check & ENCODE_LEAVE_SRC0x0008)); | |||
804 | #line 805 "Encode.c" | |||
805 | #line 637 "Encode.xs" | |||
806 | if (!SvOK(src)((src)->sv_flags & (0x00000100|0x00000200|0x00000400|0x00000800 | 0x00001000|0x00002000|0x00004000|0x00008000))) | |||
807 | XSRETURN_UNDEFdo { (PL_stack_base[ax + (0)] = &(PL_sv_immortals[1])); do { const IV tmpXSoff = (1); ((void)0); PL_stack_sp = PL_stack_base + ax + (tmpXSoff - 1); return; } while (0); } while (0); | |||
808 | s = modify ? (U8 *)SvPV_force_nomg(src, slen)((((src)->sv_flags & (0x00000400|0x00000100|0x00000200 |0x00000800|0x00008000|(0x08000000|0x00010000|0x00000800|0x01000000 |0x00800000|0x10000000)|0x00200000)) == 0x00000400) ? ((slen = ((XPV*) (src)->sv_any)->xpv_cur), ((src)->sv_u.svu_pv )) : Perl_sv_pvn_force_flags( src,&slen,0)) : (U8 *)SvPV_nomg(src, slen)((((src)->sv_flags & (0x00000400|0x00200000)) == 0x00000400 ) ? ((slen = ((XPV*) (src)->sv_any)->xpv_cur), ((src)-> sv_u.svu_pv)) : Perl_sv_2pv_flags( src,&slen,0)); | |||
809 | if (SvUTF8(src)((src)->sv_flags & 0x20000000)) | |||
810 | utf8_safe_downgrade(aTHX_ &src, &s, &slen, modify); | |||
811 | e = s+slen; | |||
812 | ||||
813 | /* | |||
814 | * PerlIO check -- we assume the object is of PerlIO if renewed | |||
815 | */ | |||
816 | ENTERPerl_push_scope(); SAVETMPSPerl_savetmps(); | |||
817 | PUSHMARK(sp)do { I32 * mark_stack_entry; if (__builtin_expect((((mark_stack_entry = ++PL_markstack_ptr) == PL_markstack_max) ? (_Bool)1 : (_Bool )0),(0))) mark_stack_entry = Perl_markstack_grow(); *mark_stack_entry = (I32)((sp) - PL_stack_base); ; } while (0); | |||
818 | XPUSHs(obj)do { do { (void)0; if (__builtin_expect(((((1) < 0 || PL_stack_max - (sp) < (1))) ? (_Bool)1 : (_Bool)0),(0))) { sp = Perl_stack_grow ( sp,sp,(sizeof(1) > sizeof(ssize_t) && ((ssize_t) (1) != (1)) ? -1 : (1))); ((void)sizeof(sp)); } } while (0); * ++sp = (obj); } while (0); | |||
819 | PUTBACKPL_stack_sp = sp; | |||
820 | if (call_method("renewed",G_SCALAR)Perl_call_method( "renewed",2) == 1) { | |||
821 | SPAGAINsp = PL_stack_sp; | |||
822 | renewed = (bool_Bool)POPi((IV)({SV *_sv = ((SV *)({ void *_p = ((*sp--)); _p; })); ((( (_sv)->sv_flags & (0x00000100|0x00200000)) == 0x00000100 ) ? ((XPVIV*) (_sv)->sv_any)->xiv_u.xivu_iv : Perl_sv_2iv_flags ( _sv,2)); })); | |||
823 | PUTBACKPL_stack_sp = sp; | |||
824 | #if 0 | |||
825 | fprintf(stderr(&__sF[2]), "renewed == %d\n", renewed); | |||
826 | #endif | |||
827 | } | |||
828 | FREETMPSif (PL_tmps_ix > PL_tmps_floor) Perl_free_tmps(); LEAVEPerl_pop_scope(); | |||
829 | /* end PerlIO check */ | |||
830 | ||||
831 | dst = sv_2mortal(newSV(slen>0?slen:1))Perl_sv_2mortal( Perl_newSV( slen>0?slen:1)); /* newSV() abhors 0 -- inaba */ | |||
832 | s = process_utf8(aTHX_ dst, s, e, check_sv, 0, strict_utf8(aTHX_ obj), renewed); | |||
833 | ||||
834 | /* Clear out translated part of source unless asked not to */ | |||
835 | if (modify) { | |||
836 | slen = e-s; | |||
837 | sv_setpvn(src, (char*)s, slen)Perl_sv_setpvn( src,(char*)s,slen); | |||
838 | SvSETMAGIC(src)do { if (__builtin_expect(((((src)->sv_flags & 0x00400000 )) ? (_Bool)1 : (_Bool)0),(0))) Perl_mg_set( src); } while (0 ); | |||
839 | } | |||
840 | SvUTF8_on(dst)((dst)->sv_flags |= (0x20000000)); | |||
841 | if (SvTAINTED(src)(((src)->sv_flags & (0x00200000|0x00400000|0x00800000) ) && Perl_sv_tainted( src))) SvTAINTED_on(dst)do{ if(__builtin_expect((((((__builtin_expect(((PL_tainting) ? (_Bool)1 : (_Bool)0),(0))) ? (_Bool)1 : (_Bool)0))) ? (_Bool )1 : (_Bool)0),(0))){Perl_sv_magic( (dst),((void*)0),'t',((void *)0),0);} }while (0); /* propagate taintedness */ | |||
842 | ST(0)PL_stack_base[ax + (0)] = dst; | |||
843 | XSRETURN(1)do { const IV tmpXSoff = (1); ((void)0); PL_stack_sp = PL_stack_base + ax + (tmpXSoff - 1); return; } while (0); | |||
844 | #line 845 "Encode.c" | |||
845 | PUTBACKPL_stack_sp = sp; | |||
846 | return; | |||
847 | } | |||
848 | } | |||
849 | ||||
850 | ||||
851 | XS_EUPXS(XS_Encode__utf8_encode)static void XS_Encode__utf8_encode( CV* cv __attribute__((unused ))); /* prototype to pass -Wmissing-prototypes */ | |||
852 | XS_EUPXS(XS_Encode__utf8_encode)static void XS_Encode__utf8_encode( CV* cv __attribute__((unused ))) | |||
853 | { | |||
854 | dVARstruct Perl___notused_struct; dXSARGSSV **sp = PL_stack_sp; I32 ax = Perl_POPMARK(); SV **mark = PL_stack_base + ax++; I32 items = (I32)(sp - mark); | |||
855 | if (items < 2 || items > 3) | |||
856 | croak_xs_usagePerl_croak_xs_usage(cv, "obj, src, check_sv = &PL_sv_no"); | |||
857 | PERL_UNUSED_VAR(ax)((void)sizeof(ax)); /* -Wall */ | |||
858 | SPsp -= items; | |||
859 | { | |||
860 | SV * obj = ST(0)PL_stack_base[ax + (0)] | |||
861 | ; | |||
862 | SV * src = ST(1)PL_stack_base[ax + (1)] | |||
863 | ; | |||
864 | SV * check_sv; | |||
865 | #line 682 "Encode.xs" | |||
866 | STRLEN slen; | |||
867 | U8 *s; | |||
868 | U8 *e; | |||
869 | SV *dst; | |||
870 | IV check; | |||
871 | bool_Bool modify; | |||
872 | #line 873 "Encode.c" | |||
873 | ||||
874 | if (items < 3) | |||
875 | check_sv = &PL_sv_no(PL_sv_immortals[2]); | |||
876 | else { | |||
877 | check_sv = ST(2)PL_stack_base[ax + (2)] | |||
878 | ; | |||
879 | } | |||
880 | #line 689 "Encode.xs" | |||
881 | SvGETMAGIC(src)((void)(__builtin_expect(((((src)->sv_flags & 0x00200000 )) ? (_Bool)1 : (_Bool)0),(0)) && Perl_mg_get( src))); | |||
882 | SvGETMAGIC(check_sv)((void)(__builtin_expect(((((check_sv)->sv_flags & 0x00200000 )) ? (_Bool)1 : (_Bool)0),(0)) && Perl_mg_get( check_sv ))); | |||
883 | check = SvROK(check_sv)((check_sv)->sv_flags & 0x00000800) ? ENCODE_PERLQQ0x0100|ENCODE_LEAVE_SRC0x0008 : SvOK(check_sv)((check_sv)->sv_flags & (0x00000100|0x00000200|0x00000400 |0x00000800| 0x00001000|0x00002000|0x00004000|0x00008000)) ? SvIV_nomg(check_sv)(((check_sv)->sv_flags & 0x00000100) ? ((XPVIV*) (check_sv )->sv_any)->xiv_u.xivu_iv : Perl_sv_2iv_flags( check_sv ,0)) : 0; | |||
884 | modify = (check && !(check & ENCODE_LEAVE_SRC0x0008)); | |||
885 | #line 886 "Encode.c" | |||
886 | #line 694 "Encode.xs" | |||
887 | if (!SvOK(src)((src)->sv_flags & (0x00000100|0x00000200|0x00000400|0x00000800 | 0x00001000|0x00002000|0x00004000|0x00008000))) | |||
888 | XSRETURN_UNDEFdo { (PL_stack_base[ax + (0)] = &(PL_sv_immortals[1])); do { const IV tmpXSoff = (1); ((void)0); PL_stack_sp = PL_stack_base + ax + (tmpXSoff - 1); return; } while (0); } while (0); | |||
889 | s = modify ? (U8 *)SvPV_force_nomg(src, slen)((((src)->sv_flags & (0x00000400|0x00000100|0x00000200 |0x00000800|0x00008000|(0x08000000|0x00010000|0x00000800|0x01000000 |0x00800000|0x10000000)|0x00200000)) == 0x00000400) ? ((slen = ((XPV*) (src)->sv_any)->xpv_cur), ((src)->sv_u.svu_pv )) : Perl_sv_pvn_force_flags( src,&slen,0)) : (U8 *)SvPV_nomg(src, slen)((((src)->sv_flags & (0x00000400|0x00200000)) == 0x00000400 ) ? ((slen = ((XPV*) (src)->sv_any)->xpv_cur), ((src)-> sv_u.svu_pv)) : Perl_sv_2pv_flags( src,&slen,0)); | |||
890 | e = s+slen; | |||
891 | dst = sv_2mortal(newSV(slen>0?slen:1))Perl_sv_2mortal( Perl_newSV( slen>0?slen:1)); /* newSV() abhors 0 -- inaba */ | |||
892 | if (SvUTF8(src)((src)->sv_flags & 0x20000000)) { | |||
893 | /* Already encoded */ | |||
894 | if (strict_utf8(aTHX_ obj)) { | |||
895 | s = process_utf8(aTHX_ dst, s, e, check_sv, 1, 1, 0); | |||
896 | } | |||
897 | else { | |||
898 | /* trust it and just copy the octets */ | |||
899 | sv_setpvn(dst,(char *)s,(e-s))Perl_sv_setpvn( dst,(char *)s,(e-s)); | |||
900 | s = e; | |||
901 | } | |||
902 | } | |||
903 | else { | |||
904 | /* Native bytes - can always encode */ | |||
905 | U8 *d = (U8 *) SvGROW(dst, 2*slen+1)(((dst)->sv_flags & 0x10000000) || ((XPV*) (dst)->sv_any )->xpv_len_u.xpvlenu_len < (2*slen+1) ? Perl_sv_grow( dst ,2*slen+1) : ((dst)->sv_u.svu_pv)); /* +1 or assertion will botch */ | |||
906 | while (s < e) { | |||
907 | #ifdef append_utf8_from_native_byte | |||
908 | append_utf8_from_native_byte(*s, &d); | |||
909 | s++; | |||
910 | #else | |||
911 | UV uv = NATIVE_TO_UNI((UV) *s)((UV) (((UV) *s) | 0)); | |||
912 | s++; /* Above expansion of NATIVE_TO_UNI() is safer this way. */ | |||
913 | if (UNI_IS_INVARIANT(uv)((((U64)(((UV) ((uv) | 0)))) < (((U8) (0xFF << 6)) & 0xB0)))) | |||
914 | *d++ = (U8)UTF_TO_NATIVE(uv)( ((U8) ((uv) | 0))); | |||
915 | else { | |||
916 | *d++ = (U8)UTF8_EIGHT_BIT_HI(uv)( ( ( ( ((U8) (((( ((U8) ((uv) | 0))) >> 6) | (((2) > 7) ? 0xFF : ((U8) (0xFE << (7-(2)))))) | 0)))))); | |||
917 | *d++ = (U8)UTF8_EIGHT_BIT_LO(uv)( (( ( ((U8) (((( ((U8) ((uv) | 0))) & ((U8) ((1U << 6) - 1))) | (((U8) (0xFF << 6)) & 0xB0)) | 0)))))); | |||
918 | } | |||
919 | #endif | |||
920 | } | |||
921 | SvCUR_set(dst, d- (U8 *)SvPVX(dst))do { ((void)0); ((void)0); ((void)0); (((XPV*) (dst)->sv_any )->xpv_cur = (d- (U8 *)((dst)->sv_u.svu_pv))); } while ( 0); | |||
922 | *SvEND(dst)((dst)->sv_u.svu_pv + ((XPV*)(dst)->sv_any)->xpv_cur ) = '\0'; | |||
923 | } | |||
924 | ||||
925 | /* Clear out translated part of source unless asked not to */ | |||
926 | if (modify) { | |||
927 | slen = e-s; | |||
928 | sv_setpvn(src, (char*)s, slen)Perl_sv_setpvn( src,(char*)s,slen); | |||
929 | SvSETMAGIC(src)do { if (__builtin_expect(((((src)->sv_flags & 0x00400000 )) ? (_Bool)1 : (_Bool)0),(0))) Perl_mg_set( src); } while (0 ); | |||
930 | } | |||
931 | SvPOK_only(dst)( (dst)->sv_flags &= ~((0x00000100|0x00000200|0x00000400 |0x00000800| 0x00001000|0x00002000|0x00004000|0x00008000)| 0x80000000 |0x20000000), (dst)->sv_flags |= (0x00000400|0x00004000)); | |||
932 | SvUTF8_off(dst)((dst)->sv_flags &= ~(0x20000000)); | |||
933 | if (SvTAINTED(src)(((src)->sv_flags & (0x00200000|0x00400000|0x00800000) ) && Perl_sv_tainted( src))) SvTAINTED_on(dst)do{ if(__builtin_expect((((((__builtin_expect(((PL_tainting) ? (_Bool)1 : (_Bool)0),(0))) ? (_Bool)1 : (_Bool)0))) ? (_Bool )1 : (_Bool)0),(0))){Perl_sv_magic( (dst),((void*)0),'t',((void *)0),0);} }while (0); /* propagate taintedness */ | |||
934 | ST(0)PL_stack_base[ax + (0)] = dst; | |||
935 | XSRETURN(1)do { const IV tmpXSoff = (1); ((void)0); PL_stack_sp = PL_stack_base + ax + (tmpXSoff - 1); return; } while (0); | |||
936 | #line 937 "Encode.c" | |||
937 | PUTBACKPL_stack_sp = sp; | |||
938 | return; | |||
939 | } | |||
940 | } | |||
941 | ||||
942 | ||||
943 | XS_EUPXS(XS_Encode__XS_renew)static void XS_Encode__XS_renew( CV* cv __attribute__((unused ))); /* prototype to pass -Wmissing-prototypes */ | |||
944 | XS_EUPXS(XS_Encode__XS_renew)static void XS_Encode__XS_renew( CV* cv __attribute__((unused ))) | |||
945 | { | |||
946 | dVARstruct Perl___notused_struct; dXSARGSSV **sp = PL_stack_sp; I32 ax = Perl_POPMARK(); SV **mark = PL_stack_base + ax++; I32 items = (I32)(sp - mark); | |||
947 | if (items != 1) | |||
948 | croak_xs_usagePerl_croak_xs_usage(cv, "obj"); | |||
949 | { | |||
950 | SV * obj = ST(0)PL_stack_base[ax + (0)] | |||
951 | ; | |||
952 | SV * RETVAL; | |||
953 | #line 752 "Encode.xs" | |||
954 | PERL_UNUSED_VAR(obj)((void)sizeof(obj)); | |||
955 | RETVAL = newSVsv(obj)Perl_newSVsv_flags( (obj),2|16); | |||
956 | #line 957 "Encode.c" | |||
957 | RETVAL = sv_2mortal(RETVAL)Perl_sv_2mortal( RETVAL); | |||
958 | ST(0)PL_stack_base[ax + (0)] = RETVAL; | |||
959 | } | |||
960 | XSRETURN(1)do { const IV tmpXSoff = (1); ((void)0); PL_stack_sp = PL_stack_base + ax + (tmpXSoff - 1); return; } while (0); | |||
961 | } | |||
962 | ||||
963 | ||||
964 | XS_EUPXS(XS_Encode__XS_renewed)static void XS_Encode__XS_renewed( CV* cv __attribute__((unused ))); /* prototype to pass -Wmissing-prototypes */ | |||
965 | XS_EUPXS(XS_Encode__XS_renewed)static void XS_Encode__XS_renewed( CV* cv __attribute__((unused ))) | |||
966 | { | |||
967 | dVARstruct Perl___notused_struct; dXSARGSSV **sp = PL_stack_sp; I32 ax = Perl_POPMARK(); SV **mark = PL_stack_base + ax++; I32 items = (I32)(sp - mark); | |||
968 | if (items != 1) | |||
969 | croak_xs_usagePerl_croak_xs_usage(cv, "obj"); | |||
970 | { | |||
971 | SV * obj = ST(0)PL_stack_base[ax + (0)] | |||
972 | ; | |||
973 | int RETVAL; | |||
974 | dXSTARGSV * const targ = ((PL_op->op_private & 0x04) ? (PL_curpad [PL_op->op_targ]) : Perl_sv_newmortal()); | |||
975 | #line 761 "Encode.xs" | |||
976 | RETVAL = 0; | |||
977 | PERL_UNUSED_VAR(obj)((void)sizeof(obj)); | |||
978 | #line 979 "Encode.c" | |||
979 | XSprePUSH(sp = PL_stack_base + ax - 1); PUSHi((IV)RETVAL)do { do { IV TARGi_iv = (IV)RETVAL; if (__builtin_expect((((( (targ)->sv_flags & (0xff|(0x08000000|0x00010000|0x00000800 |0x01000000 |0x00800000|0x10000000)|0x80000000)) == SVt_IV) & (1 ? !(((__builtin_expect(((PL_tainted) ? (_Bool)1 : (_Bool) 0),(0))) ? (_Bool)1 : (_Bool)0)) : 1)) ? (_Bool)1 : (_Bool)0) ,(1))) { ((void)0); (targ)->sv_flags |= (0x00000100|0x00001000 ); targ->sv_u.svu_iv = TARGi_iv; } else Perl_sv_setiv_mg( targ ,TARGi_iv); } while (0); (*++sp = (targ)); } while (0); | |||
980 | } | |||
981 | XSRETURN(1)do { const IV tmpXSoff = (1); ((void)0); PL_stack_sp = PL_stack_base + ax + (tmpXSoff - 1); return; } while (0); | |||
982 | } | |||
983 | ||||
984 | ||||
985 | XS_EUPXS(XS_Encode__XS_name)static void XS_Encode__XS_name( CV* cv __attribute__((unused) )); /* prototype to pass -Wmissing-prototypes */ | |||
986 | XS_EUPXS(XS_Encode__XS_name)static void XS_Encode__XS_name( CV* cv __attribute__((unused) )) | |||
987 | { | |||
988 | dVARstruct Perl___notused_struct; dXSARGSSV **sp = PL_stack_sp; I32 ax = Perl_POPMARK(); SV **mark = PL_stack_base + ax++; I32 items = (I32)(sp - mark); | |||
989 | if (items != 1) | |||
990 | croak_xs_usagePerl_croak_xs_usage(cv, "obj"); | |||
991 | { | |||
992 | SV * obj = ST(0)PL_stack_base[ax + (0)] | |||
993 | ; | |||
994 | #line 770 "Encode.xs" | |||
995 | encode_t *enc; | |||
996 | #line 997 "Encode.c" | |||
997 | SV * RETVAL; | |||
998 | #line 772 "Encode.xs" | |||
999 | enc = INT2PTR(encode_t *, SvIV(SvRV(obj)))(encode_t *)(((((((obj)->sv_u.svu_rv))->sv_flags & ( 0x00000100|0x00200000)) == 0x00000100) ? ((XPVIV*) (((obj)-> sv_u.svu_rv))->sv_any)->xiv_u.xivu_iv : Perl_sv_2iv_flags ( ((obj)->sv_u.svu_rv),2))); | |||
1000 | #line 1001 "Encode.c" | |||
1001 | #line 774 "Encode.xs" | |||
1002 | RETVAL = newSVpvn(enc->name[0], strlen(enc->name[0]))Perl_newSVpvn( enc->name[0],strlen(enc->name[0])); | |||
1003 | #line 1004 "Encode.c" | |||
1004 | RETVAL = sv_2mortal(RETVAL)Perl_sv_2mortal( RETVAL); | |||
1005 | ST(0)PL_stack_base[ax + (0)] = RETVAL; | |||
1006 | } | |||
1007 | XSRETURN(1)do { const IV tmpXSoff = (1); ((void)0); PL_stack_sp = PL_stack_base + ax + (tmpXSoff - 1); return; } while (0); | |||
1008 | } | |||
1009 | ||||
1010 | ||||
1011 | XS_EUPXS(XS_Encode__XS_cat_decode)static void XS_Encode__XS_cat_decode( CV* cv __attribute__((unused ))); /* prototype to pass -Wmissing-prototypes */ | |||
1012 | XS_EUPXS(XS_Encode__XS_cat_decode)static void XS_Encode__XS_cat_decode( CV* cv __attribute__((unused ))) | |||
1013 | { | |||
1014 | dVARstruct Perl___notused_struct; dXSARGSSV **sp = PL_stack_sp; I32 ax = Perl_POPMARK(); SV **mark = PL_stack_base + ax++; I32 items = (I32)(sp - mark); | |||
1015 | if (items < 5 || items > 6) | |||
1016 | croak_xs_usagePerl_croak_xs_usage(cv, "obj, dst, src, off, term, check_sv = &PL_sv_no"); | |||
1017 | { | |||
1018 | SV * obj = ST(0)PL_stack_base[ax + (0)] | |||
1019 | ; | |||
1020 | SV * dst = ST(1)PL_stack_base[ax + (1)] | |||
1021 | ; | |||
1022 | SV * src = ST(2)PL_stack_base[ax + (2)] | |||
1023 | ; | |||
1024 | SV * off = ST(3)PL_stack_base[ax + (3)] | |||
1025 | ; | |||
1026 | SV * term = ST(4)PL_stack_base[ax + (4)] | |||
1027 | ; | |||
1028 | SV * check_sv; | |||
1029 | #line 787 "Encode.xs" | |||
1030 | IV check; | |||
1031 | SV *fallback_cb; | |||
1032 | bool_Bool modify; | |||
1033 | encode_t *enc; | |||
1034 | STRLEN offset; | |||
1035 | int code = 0; | |||
1036 | U8 *s; | |||
1037 | STRLEN slen; | |||
1038 | SV *tmp; | |||
1039 | #line 1040 "Encode.c" | |||
1040 | bool_Bool RETVAL; | |||
1041 | ||||
1042 | if (items < 6) | |||
1043 | check_sv = &PL_sv_no(PL_sv_immortals[2]); | |||
1044 | else { | |||
1045 | check_sv = ST(5)PL_stack_base[ax + (5)] | |||
1046 | ; | |||
1047 | } | |||
1048 | #line 797 "Encode.xs" | |||
1049 | SvGETMAGIC(src)((void)(__builtin_expect(((((src)->sv_flags & 0x00200000 )) ? (_Bool)1 : (_Bool)0),(0)) && Perl_mg_get( src))); | |||
1050 | SvGETMAGIC(check_sv)((void)(__builtin_expect(((((check_sv)->sv_flags & 0x00200000 )) ? (_Bool)1 : (_Bool)0),(0)) && Perl_mg_get( check_sv ))); | |||
1051 | check = SvROK(check_sv)((check_sv)->sv_flags & 0x00000800) ? ENCODE_PERLQQ0x0100|ENCODE_LEAVE_SRC0x0008 : SvOK(check_sv)((check_sv)->sv_flags & (0x00000100|0x00000200|0x00000400 |0x00000800| 0x00001000|0x00002000|0x00004000|0x00008000)) ? SvIV_nomg(check_sv)(((check_sv)->sv_flags & 0x00000100) ? ((XPVIV*) (check_sv )->sv_any)->xiv_u.xivu_iv : Perl_sv_2iv_flags( check_sv ,0)) : 0; | |||
1052 | fallback_cb = SvROK(check_sv)((check_sv)->sv_flags & 0x00000800) ? check_sv : &PL_sv_undef(PL_sv_immortals[1]); | |||
1053 | modify = (check && !(check & ENCODE_LEAVE_SRC0x0008)); | |||
1054 | enc = INT2PTR(encode_t *, SvIV(SvRV(obj)))(encode_t *)(((((((obj)->sv_u.svu_rv))->sv_flags & ( 0x00000100|0x00200000)) == 0x00000100) ? ((XPVIV*) (((obj)-> sv_u.svu_rv))->sv_any)->xiv_u.xivu_iv : Perl_sv_2iv_flags ( ((obj)->sv_u.svu_rv),2))); | |||
1055 | offset = (STRLEN)SvIV(off)((((off)->sv_flags & (0x00000100|0x00200000)) == 0x00000100 ) ? ((XPVIV*) (off)->sv_any)->xiv_u.xivu_iv : Perl_sv_2iv_flags ( off,2)); | |||
1056 | #line 1057 "Encode.c" | |||
1057 | #line 805 "Encode.xs" | |||
1058 | if (!SvOK(src)((src)->sv_flags & (0x00000100|0x00000200|0x00000400|0x00000800 | 0x00001000|0x00002000|0x00004000|0x00008000))) | |||
1059 | XSRETURN_NOdo { (PL_stack_base[ax + (0)] = &(PL_sv_immortals[2]) ); do { const IV tmpXSoff = (1); ((void)0); PL_stack_sp = PL_stack_base + ax + (tmpXSoff - 1); return; } while (0); } while (0); | |||
1060 | s = modify ? (U8 *)SvPV_force_nomg(src, slen)((((src)->sv_flags & (0x00000400|0x00000100|0x00000200 |0x00000800|0x00008000|(0x08000000|0x00010000|0x00000800|0x01000000 |0x00800000|0x10000000)|0x00200000)) == 0x00000400) ? ((slen = ((XPV*) (src)->sv_any)->xpv_cur), ((src)->sv_u.svu_pv )) : Perl_sv_pvn_force_flags( src,&slen,0)) : (U8 *)SvPV_nomg(src, slen)((((src)->sv_flags & (0x00000400|0x00200000)) == 0x00000400 ) ? ((slen = ((XPV*) (src)->sv_any)->xpv_cur), ((src)-> sv_u.svu_pv)) : Perl_sv_2pv_flags( src,&slen,0)); | |||
1061 | if (SvUTF8(src)((src)->sv_flags & 0x20000000)) | |||
1062 | utf8_safe_downgrade(aTHX_ &src, &s, &slen, modify); | |||
1063 | tmp = encode_method(aTHX_ enc, enc->t_utf8, src, s, slen, check, | |||
1064 | &offset, term, &code, fallback_cb); | |||
1065 | sv_catsv(dst, tmp)Perl_sv_catsv_flags( dst,tmp,2); | |||
1066 | SvREFCNT_dec(tmp)Perl_SvREFCNT_dec( ((SV *)({ void *_p = (tmp); _p; }))); | |||
1067 | SvIV_set(off, (IV)offset)do { ((void)0); ((void)0); (((XPVIV*) (off)->sv_any)->xiv_u .xivu_iv = ((IV)offset)); } while (0); | |||
1068 | RETVAL = (code == ENCODE_FOUND_TERM5); | |||
1069 | #line 1070 "Encode.c" | |||
1070 | ST(0)PL_stack_base[ax + (0)] = boolSV(RETVAL)((RETVAL) ? &(PL_sv_immortals[0]) : &(PL_sv_immortals [2])); | |||
1071 | } | |||
1072 | XSRETURN(1)do { const IV tmpXSoff = (1); ((void)0); PL_stack_sp = PL_stack_base + ax + (tmpXSoff - 1); return; } while (0); | |||
1073 | } | |||
1074 | ||||
1075 | ||||
1076 | XS_EUPXS(XS_Encode__XS_decode)static void XS_Encode__XS_decode( CV* cv __attribute__((unused ))); /* prototype to pass -Wmissing-prototypes */ | |||
1077 | XS_EUPXS(XS_Encode__XS_decode)static void XS_Encode__XS_decode( CV* cv __attribute__((unused ))) | |||
1078 | { | |||
1079 | dVARstruct Perl___notused_struct; dXSARGSSV **sp = PL_stack_sp; I32 ax = Perl_POPMARK(); SV **mark = PL_stack_base + ax++; I32 items = (I32)(sp - mark); | |||
1080 | if (items < 2 || items > 3) | |||
1081 | croak_xs_usagePerl_croak_xs_usage(cv, "obj, src, check_sv = &PL_sv_no"); | |||
1082 | { | |||
1083 | SV * obj = ST(0)PL_stack_base[ax + (0)] | |||
1084 | ; | |||
1085 | SV * src = ST(1)PL_stack_base[ax + (1)] | |||
1086 | ; | |||
1087 | SV * check_sv; | |||
1088 | #line 825 "Encode.xs" | |||
1089 | IV check; | |||
1090 | SV *fallback_cb; | |||
1091 | bool_Bool modify; | |||
1092 | encode_t *enc; | |||
1093 | U8 *s; | |||
1094 | STRLEN slen; | |||
1095 | #line 1096 "Encode.c" | |||
1096 | SV * RETVAL; | |||
1097 | ||||
1098 | if (items < 3) | |||
1099 | check_sv = &PL_sv_no(PL_sv_immortals[2]); | |||
1100 | else { | |||
1101 | check_sv = ST(2)PL_stack_base[ax + (2)] | |||
1102 | ; | |||
1103 | } | |||
1104 | #line 832 "Encode.xs" | |||
1105 | SvGETMAGIC(src)((void)(__builtin_expect(((((src)->sv_flags & 0x00200000 )) ? (_Bool)1 : (_Bool)0),(0)) && Perl_mg_get( src))); | |||
1106 | SvGETMAGIC(check_sv)((void)(__builtin_expect(((((check_sv)->sv_flags & 0x00200000 )) ? (_Bool)1 : (_Bool)0),(0)) && Perl_mg_get( check_sv ))); | |||
1107 | check = SvROK(check_sv)((check_sv)->sv_flags & 0x00000800) ? ENCODE_PERLQQ0x0100|ENCODE_LEAVE_SRC0x0008 : SvOK(check_sv)((check_sv)->sv_flags & (0x00000100|0x00000200|0x00000400 |0x00000800| 0x00001000|0x00002000|0x00004000|0x00008000)) ? SvIV_nomg(check_sv)(((check_sv)->sv_flags & 0x00000100) ? ((XPVIV*) (check_sv )->sv_any)->xiv_u.xivu_iv : Perl_sv_2iv_flags( check_sv ,0)) : 0; | |||
1108 | fallback_cb = SvROK(check_sv)((check_sv)->sv_flags & 0x00000800) ? check_sv : &PL_sv_undef(PL_sv_immortals[1]); | |||
1109 | modify = (check && !(check & ENCODE_LEAVE_SRC0x0008)); | |||
1110 | enc = INT2PTR(encode_t *, SvIV(SvRV(obj)))(encode_t *)(((((((obj)->sv_u.svu_rv))->sv_flags & ( 0x00000100|0x00200000)) == 0x00000100) ? ((XPVIV*) (((obj)-> sv_u.svu_rv))->sv_any)->xiv_u.xivu_iv : Perl_sv_2iv_flags ( ((obj)->sv_u.svu_rv),2))); | |||
1111 | #line 1112 "Encode.c" | |||
1112 | #line 839 "Encode.xs" | |||
1113 | if (!SvOK(src)((src)->sv_flags & (0x00000100|0x00000200|0x00000400|0x00000800 | 0x00001000|0x00002000|0x00004000|0x00008000))) | |||
1114 | XSRETURN_UNDEFdo { (PL_stack_base[ax + (0)] = &(PL_sv_immortals[1])); do { const IV tmpXSoff = (1); ((void)0); PL_stack_sp = PL_stack_base + ax + (tmpXSoff - 1); return; } while (0); } while (0); | |||
1115 | s = modify ? (U8 *)SvPV_force_nomg(src, slen)((((src)->sv_flags & (0x00000400|0x00000100|0x00000200 |0x00000800|0x00008000|(0x08000000|0x00010000|0x00000800|0x01000000 |0x00800000|0x10000000)|0x00200000)) == 0x00000400) ? ((slen = ((XPV*) (src)->sv_any)->xpv_cur), ((src)->sv_u.svu_pv )) : Perl_sv_pvn_force_flags( src,&slen,0)) : (U8 *)SvPV_nomg(src, slen)((((src)->sv_flags & (0x00000400|0x00200000)) == 0x00000400 ) ? ((slen = ((XPV*) (src)->sv_any)->xpv_cur), ((src)-> sv_u.svu_pv)) : Perl_sv_2pv_flags( src,&slen,0)); | |||
1116 | if (SvUTF8(src)((src)->sv_flags & 0x20000000)) | |||
1117 | utf8_safe_downgrade(aTHX_ &src, &s, &slen, modify); | |||
1118 | RETVAL = encode_method(aTHX_ enc, enc->t_utf8, src, s, slen, check, | |||
1119 | NULL((void*)0), Nullsv((SV*)((void*)0)), NULL((void*)0), fallback_cb); | |||
1120 | SvUTF8_on(RETVAL)((RETVAL)->sv_flags |= (0x20000000)); | |||
1121 | #line 1122 "Encode.c" | |||
1122 | RETVAL = sv_2mortal(RETVAL)Perl_sv_2mortal( RETVAL); | |||
1123 | ST(0)PL_stack_base[ax + (0)] = RETVAL; | |||
1124 | } | |||
1125 | XSRETURN(1)do { const IV tmpXSoff = (1); ((void)0); PL_stack_sp = PL_stack_base + ax + (tmpXSoff - 1); return; } while (0); | |||
1126 | } | |||
1127 | ||||
1128 | ||||
1129 | XS_EUPXS(XS_Encode__XS_encode)static void XS_Encode__XS_encode( CV* cv __attribute__((unused ))); /* prototype to pass -Wmissing-prototypes */ | |||
1130 | XS_EUPXS(XS_Encode__XS_encode)static void XS_Encode__XS_encode( CV* cv __attribute__((unused ))) | |||
1131 | { | |||
1132 | dVARstruct Perl___notused_struct; dXSARGSSV **sp = PL_stack_sp; I32 ax = Perl_POPMARK(); SV **mark = PL_stack_base + ax++; I32 items = (I32)(sp - mark); | |||
1133 | if (items < 2 || items > 3) | |||
1134 | croak_xs_usagePerl_croak_xs_usage(cv, "obj, src, check_sv = &PL_sv_no"); | |||
1135 | { | |||
1136 | SV * obj = ST(0)PL_stack_base[ax + (0)] | |||
1137 | ; | |||
1138 | SV * src = ST(1)PL_stack_base[ax + (1)] | |||
1139 | ; | |||
1140 | SV * check_sv; | |||
1141 | #line 856 "Encode.xs" | |||
1142 | IV check; | |||
1143 | SV *fallback_cb; | |||
1144 | bool_Bool modify; | |||
1145 | encode_t *enc; | |||
1146 | U8 *s; | |||
1147 | STRLEN slen; | |||
1148 | #line 1149 "Encode.c" | |||
1149 | SV * RETVAL; | |||
1150 | ||||
1151 | if (items < 3) | |||
1152 | check_sv = &PL_sv_no(PL_sv_immortals[2]); | |||
1153 | else { | |||
1154 | check_sv = ST(2)PL_stack_base[ax + (2)] | |||
1155 | ; | |||
1156 | } | |||
1157 | #line 863 "Encode.xs" | |||
1158 | SvGETMAGIC(src)((void)(__builtin_expect(((((src)->sv_flags & 0x00200000 )) ? (_Bool)1 : (_Bool)0),(0)) && Perl_mg_get( src))); | |||
1159 | SvGETMAGIC(check_sv)((void)(__builtin_expect(((((check_sv)->sv_flags & 0x00200000 )) ? (_Bool)1 : (_Bool)0),(0)) && Perl_mg_get( check_sv ))); | |||
1160 | check = SvROK(check_sv)((check_sv)->sv_flags & 0x00000800) ? ENCODE_PERLQQ0x0100|ENCODE_LEAVE_SRC0x0008 : SvOK(check_sv)((check_sv)->sv_flags & (0x00000100|0x00000200|0x00000400 |0x00000800| 0x00001000|0x00002000|0x00004000|0x00008000)) ? SvIV_nomg(check_sv)(((check_sv)->sv_flags & 0x00000100) ? ((XPVIV*) (check_sv )->sv_any)->xiv_u.xivu_iv : Perl_sv_2iv_flags( check_sv ,0)) : 0; | |||
1161 | fallback_cb = SvROK(check_sv)((check_sv)->sv_flags & 0x00000800) ? check_sv : &PL_sv_undef(PL_sv_immortals[1]); | |||
1162 | modify = (check && !(check & ENCODE_LEAVE_SRC0x0008)); | |||
1163 | enc = INT2PTR(encode_t *, SvIV(SvRV(obj)))(encode_t *)(((((((obj)->sv_u.svu_rv))->sv_flags & ( 0x00000100|0x00200000)) == 0x00000100) ? ((XPVIV*) (((obj)-> sv_u.svu_rv))->sv_any)->xiv_u.xivu_iv : Perl_sv_2iv_flags ( ((obj)->sv_u.svu_rv),2))); | |||
1164 | #line 1165 "Encode.c" | |||
1165 | #line 870 "Encode.xs" | |||
1166 | if (!SvOK(src)((src)->sv_flags & (0x00000100|0x00000200|0x00000400|0x00000800 | 0x00001000|0x00002000|0x00004000|0x00008000))) | |||
1167 | XSRETURN_UNDEFdo { (PL_stack_base[ax + (0)] = &(PL_sv_immortals[1])); do { const IV tmpXSoff = (1); ((void)0); PL_stack_sp = PL_stack_base + ax + (tmpXSoff - 1); return; } while (0); } while (0); | |||
1168 | s = modify ? (U8 *)SvPV_force_nomg(src, slen)((((src)->sv_flags & (0x00000400|0x00000100|0x00000200 |0x00000800|0x00008000|(0x08000000|0x00010000|0x00000800|0x01000000 |0x00800000|0x10000000)|0x00200000)) == 0x00000400) ? ((slen = ((XPV*) (src)->sv_any)->xpv_cur), ((src)->sv_u.svu_pv )) : Perl_sv_pvn_force_flags( src,&slen,0)) : (U8 *)SvPV_nomg(src, slen)((((src)->sv_flags & (0x00000400|0x00200000)) == 0x00000400 ) ? ((slen = ((XPV*) (src)->sv_any)->xpv_cur), ((src)-> sv_u.svu_pv)) : Perl_sv_2pv_flags( src,&slen,0)); | |||
1169 | if (!SvUTF8(src)((src)->sv_flags & 0x20000000)) | |||
1170 | utf8_safe_upgrade(aTHX_ &src, &s, &slen, modify); | |||
1171 | RETVAL = encode_method(aTHX_ enc, enc->f_utf8, src, s, slen, check, | |||
1172 | NULL((void*)0), Nullsv((SV*)((void*)0)), NULL((void*)0), fallback_cb); | |||
1173 | #line 1174 "Encode.c" | |||
1174 | RETVAL = sv_2mortal(RETVAL)Perl_sv_2mortal( RETVAL); | |||
1175 | ST(0)PL_stack_base[ax + (0)] = RETVAL; | |||
1176 | } | |||
1177 | XSRETURN(1)do { const IV tmpXSoff = (1); ((void)0); PL_stack_sp = PL_stack_base + ax + (tmpXSoff - 1); return; } while (0); | |||
1178 | } | |||
1179 | ||||
1180 | ||||
1181 | XS_EUPXS(XS_Encode__XS_needs_lines)static void XS_Encode__XS_needs_lines( CV* cv __attribute__(( unused))); /* prototype to pass -Wmissing-prototypes */ | |||
1182 | XS_EUPXS(XS_Encode__XS_needs_lines)static void XS_Encode__XS_needs_lines( CV* cv __attribute__(( unused))) | |||
1183 | { | |||
1184 | dVARstruct Perl___notused_struct; dXSARGSSV **sp = PL_stack_sp; I32 ax = Perl_POPMARK(); SV **mark = PL_stack_base + ax++; I32 items = (I32)(sp - mark); | |||
1185 | if (items != 1) | |||
1186 | croak_xs_usagePerl_croak_xs_usage(cv, "obj"); | |||
1187 | { | |||
1188 | SV * obj = ST(0)PL_stack_base[ax + (0)] | |||
1189 | ; | |||
1190 | bool_Bool RETVAL; | |||
1191 | #line 884 "Encode.xs" | |||
1192 | PERL_UNUSED_VAR(obj)((void)sizeof(obj)); | |||
1193 | RETVAL = FALSE(0); | |||
1194 | #line 1195 "Encode.c" | |||
1195 | ST(0)PL_stack_base[ax + (0)] = boolSV(RETVAL)((RETVAL) ? &(PL_sv_immortals[0]) : &(PL_sv_immortals [2])); | |||
1196 | } | |||
1197 | XSRETURN(1)do { const IV tmpXSoff = (1); ((void)0); PL_stack_sp = PL_stack_base + ax + (tmpXSoff - 1); return; } while (0); | |||
1198 | } | |||
1199 | ||||
1200 | ||||
1201 | XS_EUPXS(XS_Encode__XS_perlio_ok)static void XS_Encode__XS_perlio_ok( CV* cv __attribute__((unused ))); /* prototype to pass -Wmissing-prototypes */ | |||
1202 | XS_EUPXS(XS_Encode__XS_perlio_ok)static void XS_Encode__XS_perlio_ok( CV* cv __attribute__((unused ))) | |||
1203 | { | |||
1204 | dVARstruct Perl___notused_struct; dXSARGSSV **sp = PL_stack_sp; I32 ax = Perl_POPMARK(); SV **mark = PL_stack_base + ax++; I32 items = (I32)(sp - mark); | |||
1205 | if (items != 1) | |||
1206 | croak_xs_usagePerl_croak_xs_usage(cv, "obj"); | |||
1207 | { | |||
1208 | SV * obj = ST(0)PL_stack_base[ax + (0)] | |||
1209 | ; | |||
1210 | #line 893 "Encode.xs" | |||
1211 | SV *sv; | |||
1212 | #line 1213 "Encode.c" | |||
1213 | bool_Bool RETVAL; | |||
1214 | #line 895 "Encode.xs" | |||
1215 | PERL_UNUSED_VAR(obj)((void)sizeof(obj)); | |||
1216 | sv = eval_pv("require PerlIO::encoding", 0)Perl_eval_pv( "require PerlIO::encoding",0); | |||
1217 | RETVAL = SvTRUE(sv)Perl_SvTRUE( sv); | |||
1218 | #line 1219 "Encode.c" | |||
1219 | ST(0)PL_stack_base[ax + (0)] = boolSV(RETVAL)((RETVAL) ? &(PL_sv_immortals[0]) : &(PL_sv_immortals [2])); | |||
1220 | } | |||
1221 | XSRETURN(1)do { const IV tmpXSoff = (1); ((void)0); PL_stack_sp = PL_stack_base + ax + (tmpXSoff - 1); return; } while (0); | |||
1222 | } | |||
1223 | ||||
1224 | ||||
1225 | XS_EUPXS(XS_Encode__XS_mime_name)static void XS_Encode__XS_mime_name( CV* cv __attribute__((unused ))); /* prototype to pass -Wmissing-prototypes */ | |||
1226 | XS_EUPXS(XS_Encode__XS_mime_name)static void XS_Encode__XS_mime_name( CV* cv __attribute__((unused ))) | |||
1227 | { | |||
1228 | dVARstruct Perl___notused_struct; dXSARGSSV **sp = PL_stack_sp; I32 ax = Perl_POPMARK(); SV **mark = PL_stack_base + ax++; I32 items = (I32)(sp - mark); | |||
1229 | if (items != 1) | |||
1230 | croak_xs_usagePerl_croak_xs_usage(cv, "obj"); | |||
1231 | { | |||
1232 | SV * obj = ST(0)PL_stack_base[ax + (0)] | |||
1233 | ; | |||
1234 | #line 905 "Encode.xs" | |||
1235 | encode_t *enc; | |||
1236 | #line 1237 "Encode.c" | |||
1237 | SV * RETVAL; | |||
1238 | #line 907 "Encode.xs" | |||
1239 | enc = INT2PTR(encode_t *, SvIV(SvRV(obj)))(encode_t *)(((((((obj)->sv_u.svu_rv))->sv_flags & ( 0x00000100|0x00200000)) == 0x00000100) ? ((XPVIV*) (((obj)-> sv_u.svu_rv))->sv_any)->xiv_u.xivu_iv : Perl_sv_2iv_flags ( ((obj)->sv_u.svu_rv),2))); | |||
1240 | #line 1241 "Encode.c" | |||
1241 | #line 909 "Encode.xs" | |||
1242 | ENTERPerl_push_scope(); | |||
1243 | SAVETMPSPerl_savetmps(); | |||
1244 | PUSHMARK(sp)do { I32 * mark_stack_entry; if (__builtin_expect((((mark_stack_entry = ++PL_markstack_ptr) == PL_markstack_max) ? (_Bool)1 : (_Bool )0),(0))) mark_stack_entry = Perl_markstack_grow(); *mark_stack_entry = (I32)((sp) - PL_stack_base); ; } while (0); | |||
1245 | XPUSHs(sv_2mortal(newSVpvn(enc->name[0], strlen(enc->name[0]))))do { do { (void)0; if (__builtin_expect(((((1) < 0 || PL_stack_max - (sp) < (1))) ? (_Bool)1 : (_Bool)0),(0))) { sp = Perl_stack_grow ( sp,sp,(sizeof(1) > sizeof(ssize_t) && ((ssize_t) (1) != (1)) ? -1 : (1))); ((void)sizeof(sp)); } } while (0); * ++sp = (Perl_sv_2mortal( Perl_newSVpvn( enc->name[0],strlen (enc->name[0])))); } while (0); | |||
1246 | PUTBACKPL_stack_sp = sp; | |||
1247 | call_pv("Encode::MIME::Name::get_mime_name", G_SCALAR)Perl_call_pv( "Encode::MIME::Name::get_mime_name",2); | |||
1248 | SPAGAINsp = PL_stack_sp; | |||
1249 | RETVAL = newSVsv(POPs)Perl_newSVsv_flags( ((*sp--)),2|16); | |||
1250 | PUTBACKPL_stack_sp = sp; | |||
1251 | FREETMPSif (PL_tmps_ix > PL_tmps_floor) Perl_free_tmps(); | |||
1252 | LEAVEPerl_pop_scope(); | |||
1253 | #line 1254 "Encode.c" | |||
1254 | RETVAL = sv_2mortal(RETVAL)Perl_sv_2mortal( RETVAL); | |||
1255 | ST(0)PL_stack_base[ax + (0)] = RETVAL; | |||
1256 | } | |||
1257 | XSRETURN(1)do { const IV tmpXSoff = (1); ((void)0); PL_stack_sp = PL_stack_base + ax + (tmpXSoff - 1); return; } while (0); | |||
1258 | } | |||
1259 | ||||
1260 | ||||
1261 | XS_EUPXS(XS_Encode_is_utf8)static void XS_Encode_is_utf8( CV* cv __attribute__((unused)) ); /* prototype to pass -Wmissing-prototypes */ | |||
1262 | XS_EUPXS(XS_Encode_is_utf8)static void XS_Encode_is_utf8( CV* cv __attribute__((unused)) ) | |||
1263 | { | |||
1264 | dVARstruct Perl___notused_struct; dXSARGSSV **sp = PL_stack_sp; I32 ax = Perl_POPMARK(); SV **mark = PL_stack_base + ax++; I32 items = (I32)(sp - mark); | |||
1265 | if (items < 1 || items > 2) | |||
1266 | croak_xs_usagePerl_croak_xs_usage(cv, "sv, check = 0"); | |||
1267 | { | |||
1268 | SV * sv = ST(0)PL_stack_base[ax + (0)] | |||
1269 | ; | |||
1270 | int check; | |||
1271 | #line 932 "Encode.xs" | |||
1272 | char *str; | |||
1273 | STRLEN len; | |||
1274 | #line 1275 "Encode.c" | |||
1275 | bool_Bool RETVAL; | |||
1276 | ||||
1277 | if (items < 2) | |||
1278 | check = 0; | |||
1279 | else { | |||
1280 | check = (int)SvIV(ST(1))((((PL_stack_base[ax + (1)])->sv_flags & (0x00000100|0x00200000 )) == 0x00000100) ? ((XPVIV*) (PL_stack_base[ax + (1)])->sv_any )->xiv_u.xivu_iv : Perl_sv_2iv_flags( PL_stack_base[ax + ( 1)],2)) | |||
1281 | ; | |||
1282 | } | |||
1283 | #line 935 "Encode.xs" | |||
1284 | SvGETMAGIC(sv)((void)(__builtin_expect(((((sv)->sv_flags & 0x00200000 )) ? (_Bool)1 : (_Bool)0),(0)) && Perl_mg_get( sv))); /* SvGETMAGIC() can modify SvOK flag */ | |||
1285 | str = SvOK(sv)((sv)->sv_flags & (0x00000100|0x00000200|0x00000400|0x00000800 | 0x00001000|0x00002000|0x00004000|0x00008000)) ? SvPV_nomg(sv, len)((((sv)->sv_flags & (0x00000400|0x00200000)) == 0x00000400 ) ? ((len = ((XPV*) (sv)->sv_any)->xpv_cur), ((sv)-> sv_u.svu_pv)) : Perl_sv_2pv_flags( sv,&len,0)) : NULL((void*)0); /* SvPV() can modify SvUTF8 flag */ | |||
1286 | RETVAL = SvUTF8(sv)((sv)->sv_flags & 0x20000000) ? TRUE(1) : FALSE(0); | |||
1287 | if (RETVAL && check && (!str || !is_utf8_string((U8 *)str, len)Perl_is_utf8_string_loclen((U8 *)str, len, ((void*)0), ((void *)0)))) | |||
1288 | RETVAL = FALSE(0); | |||
1289 | #line 1290 "Encode.c" | |||
1290 | ST(0)PL_stack_base[ax + (0)] = boolSV(RETVAL)((RETVAL) ? &(PL_sv_immortals[0]) : &(PL_sv_immortals [2])); | |||
1291 | } | |||
1292 | XSRETURN(1)do { const IV tmpXSoff = (1); ((void)0); PL_stack_sp = PL_stack_base + ax + (tmpXSoff - 1); return; } while (0); | |||
1293 | } | |||
1294 | ||||
1295 | ||||
1296 | XS_EUPXS(XS_Encode__utf8_on)static void XS_Encode__utf8_on( CV* cv __attribute__((unused) )); /* prototype to pass -Wmissing-prototypes */ | |||
1297 | XS_EUPXS(XS_Encode__utf8_on)static void XS_Encode__utf8_on( CV* cv __attribute__((unused) )) | |||
1298 | { | |||
1299 | dVARstruct Perl___notused_struct; dXSARGSSV **sp = PL_stack_sp; I32 ax = Perl_POPMARK(); SV **mark = PL_stack_base + ax++; I32 items = (I32)(sp - mark); | |||
1300 | if (items != 1) | |||
1301 | croak_xs_usagePerl_croak_xs_usage(cv, "sv"); | |||
1302 | { | |||
1303 | SV * sv = ST(0)PL_stack_base[ax + (0)] | |||
1304 | ; | |||
1305 | SV * RETVAL; | |||
1306 | #line 947 "Encode.xs" | |||
1307 | SvGETMAGIC(sv)((void)(__builtin_expect(((((sv)->sv_flags & 0x00200000 )) ? (_Bool)1 : (_Bool)0),(0)) && Perl_mg_get( sv))); | |||
1308 | if (!SvTAINTED(sv)(((sv)->sv_flags & (0x00200000|0x00400000|0x00800000)) && Perl_sv_tainted( sv)) && SvPOKp(sv)((sv)->sv_flags & 0x00004000)) { | |||
1309 | if (SvTHINKFIRST(sv)((sv)->sv_flags & (0x08000000|0x00010000|0x00000800|0x01000000 |0x00800000|0x10000000))) sv_force_normal(sv)Perl_sv_force_normal_flags( sv,0); | |||
1310 | RETVAL = boolSV(SvUTF8(sv))((((sv)->sv_flags & 0x20000000)) ? &(PL_sv_immortals [0]) : &(PL_sv_immortals[2])); | |||
1311 | SvUTF8_on(sv)((sv)->sv_flags |= (0x20000000)); | |||
1312 | SvSETMAGIC(sv)do { if (__builtin_expect(((((sv)->sv_flags & 0x00400000 )) ? (_Bool)1 : (_Bool)0),(0))) Perl_mg_set( sv); } while (0); | |||
1313 | } else { | |||
1314 | RETVAL = &PL_sv_undef(PL_sv_immortals[1]); | |||
1315 | } | |||
1316 | #line 1317 "Encode.c" | |||
1317 | RETVAL = sv_2mortal(RETVAL)Perl_sv_2mortal( RETVAL); | |||
1318 | ST(0)PL_stack_base[ax + (0)] = RETVAL; | |||
1319 | } | |||
1320 | XSRETURN(1)do { const IV tmpXSoff = (1); ((void)0); PL_stack_sp = PL_stack_base + ax + (tmpXSoff - 1); return; } while (0); | |||
1321 | } | |||
1322 | ||||
1323 | ||||
1324 | XS_EUPXS(XS_Encode__utf8_off)static void XS_Encode__utf8_off( CV* cv __attribute__((unused ))); /* prototype to pass -Wmissing-prototypes */ | |||
1325 | XS_EUPXS(XS_Encode__utf8_off)static void XS_Encode__utf8_off( CV* cv __attribute__((unused ))) | |||
1326 | { | |||
1327 | dVARstruct Perl___notused_struct; dXSARGSSV **sp = PL_stack_sp; I32 ax = Perl_POPMARK(); SV **mark = PL_stack_base + ax++; I32 items = (I32)(sp - mark); | |||
1328 | if (items != 1) | |||
1329 | croak_xs_usagePerl_croak_xs_usage(cv, "sv"); | |||
1330 | { | |||
1331 | SV * sv = ST(0)PL_stack_base[ax + (0)] | |||
1332 | ; | |||
1333 | SV * RETVAL; | |||
1334 | #line 963 "Encode.xs" | |||
1335 | SvGETMAGIC(sv)((void)(__builtin_expect(((((sv)->sv_flags & 0x00200000 )) ? (_Bool)1 : (_Bool)0),(0)) && Perl_mg_get( sv))); | |||
1336 | if (!SvTAINTED(sv)(((sv)->sv_flags & (0x00200000|0x00400000|0x00800000)) && Perl_sv_tainted( sv)) && SvPOKp(sv)((sv)->sv_flags & 0x00004000)) { | |||
1337 | if (SvTHINKFIRST(sv)((sv)->sv_flags & (0x08000000|0x00010000|0x00000800|0x01000000 |0x00800000|0x10000000))) sv_force_normal(sv)Perl_sv_force_normal_flags( sv,0); | |||
1338 | RETVAL = boolSV(SvUTF8(sv))((((sv)->sv_flags & 0x20000000)) ? &(PL_sv_immortals [0]) : &(PL_sv_immortals[2])); | |||
1339 | SvUTF8_off(sv)((sv)->sv_flags &= ~(0x20000000)); | |||
1340 | SvSETMAGIC(sv)do { if (__builtin_expect(((((sv)->sv_flags & 0x00400000 )) ? (_Bool)1 : (_Bool)0),(0))) Perl_mg_set( sv); } while (0); | |||
1341 | } else { | |||
1342 | RETVAL = &PL_sv_undef(PL_sv_immortals[1]); | |||
1343 | } | |||
1344 | #line 1345 "Encode.c" | |||
1345 | RETVAL = sv_2mortal(RETVAL)Perl_sv_2mortal( RETVAL); | |||
1346 | ST(0)PL_stack_base[ax + (0)] = RETVAL; | |||
1347 | } | |||
1348 | XSRETURN(1)do { const IV tmpXSoff = (1); ((void)0); PL_stack_sp = PL_stack_base + ax + (tmpXSoff - 1); return; } while (0); | |||
1349 | } | |||
1350 | ||||
1351 | ||||
1352 | XS_EUPXS(XS_Encode_decode)static void XS_Encode_decode( CV* cv __attribute__((unused))); /* prototype to pass -Wmissing-prototypes */ | |||
1353 | XS_EUPXS(XS_Encode_decode)static void XS_Encode_decode( CV* cv __attribute__((unused))) | |||
1354 | { | |||
1355 | dVARstruct Perl___notused_struct; dXSARGSSV **sp = PL_stack_sp; I32 ax = Perl_POPMARK(); SV **mark = PL_stack_base + ax++; I32 items = (I32)(sp - mark); | |||
1356 | dXSI32I32 ix = ((XPVCV*)({ void *_p = ((cv)->sv_any); _p; }))-> xcv_start_u.xcv_xsubany.any_i32; | |||
1357 | if (items < 2 || items > 3) | |||
1358 | croak_xs_usagePerl_croak_xs_usage(cv, "encoding, octets, check = NULL"); | |||
1359 | { | |||
1360 | SV * encoding = ST(0)PL_stack_base[ax + (0)] | |||
1361 | ; | |||
1362 | SV * octets = ST(1)PL_stack_base[ax + (1)] | |||
1363 | ; | |||
1364 | SV * check; | |||
1365 | #line 983 "Encode.xs" | |||
1366 | SV *obj; | |||
1367 | #line 1368 "Encode.c" | |||
1368 | SV * RETVAL; | |||
1369 | ||||
1370 | if (items < 3) | |||
1371 | check = NULL((void*)0); | |||
1372 | else { | |||
1373 | check = ST(2)PL_stack_base[ax + (2)] | |||
1374 | ; | |||
1375 | } | |||
1376 | #line 985 "Encode.xs" | |||
1377 | PERL_UNUSED_VAR(ix)((void)sizeof(ix)); | |||
1378 | SvGETMAGIC(encoding)((void)(__builtin_expect(((((encoding)->sv_flags & 0x00200000 )) ? (_Bool)1 : (_Bool)0),(0)) && Perl_mg_get( encoding ))); | |||
1379 | #line 1380 "Encode.c" | |||
1380 | #line 988 "Encode.xs" | |||
1381 | if (!SvOK(encoding)((encoding)->sv_flags & (0x00000100|0x00000200|0x00000400 |0x00000800| 0x00001000|0x00002000|0x00004000|0x00008000))) | |||
1382 | croakPerl_croak("Encoding name should not be undef"); | |||
1383 | obj = find_encoding(aTHX_ encoding); | |||
1384 | if (!SvOK(obj)((obj)->sv_flags & (0x00000100|0x00000200|0x00000400|0x00000800 | 0x00001000|0x00002000|0x00004000|0x00008000))) | |||
1385 | croakPerl_croak("Unknown encoding '%" SVf"-p" "'", SVfARG(encoding)((void*)(encoding))); | |||
1386 | RETVAL = call_encoding(aTHX_ "decode", obj, octets, check); | |||
1387 | #line 1388 "Encode.c" | |||
1388 | RETVAL = sv_2mortal(RETVAL)Perl_sv_2mortal( RETVAL); | |||
1389 | ST(0)PL_stack_base[ax + (0)] = RETVAL; | |||
1390 | } | |||
1391 | XSRETURN(1)do { const IV tmpXSoff = (1); ((void)0); PL_stack_sp = PL_stack_base + ax + (tmpXSoff - 1); return; } while (0); | |||
1392 | } | |||
1393 | ||||
1394 | ||||
1395 | XS_EUPXS(XS_Encode_encode)static void XS_Encode_encode( CV* cv __attribute__((unused))); /* prototype to pass -Wmissing-prototypes */ | |||
1396 | XS_EUPXS(XS_Encode_encode)static void XS_Encode_encode( CV* cv __attribute__((unused))) | |||
1397 | { | |||
1398 | dVARstruct Perl___notused_struct; dXSARGSSV **sp = PL_stack_sp; I32 ax = Perl_POPMARK(); SV **mark = PL_stack_base + ax++; I32 items = (I32)(sp - mark); | |||
1399 | dXSI32I32 ix = ((XPVCV*)({ void *_p = ((cv)->sv_any); _p; }))-> xcv_start_u.xcv_xsubany.any_i32; | |||
1400 | if (items < 2 || items > 3) | |||
1401 | croak_xs_usagePerl_croak_xs_usage(cv, "encoding, string, check = NULL"); | |||
1402 | { | |||
1403 | SV * encoding = ST(0)PL_stack_base[ax + (0)] | |||
1404 | ; | |||
1405 | SV * string = ST(1)PL_stack_base[ax + (1)] | |||
1406 | ; | |||
1407 | SV * check; | |||
1408 | #line 1005 "Encode.xs" | |||
1409 | SV *obj; | |||
1410 | #line 1411 "Encode.c" | |||
1411 | SV * RETVAL; | |||
1412 | ||||
1413 | if (items < 3) | |||
1414 | check = NULL((void*)0); | |||
1415 | else { | |||
1416 | check = ST(2)PL_stack_base[ax + (2)] | |||
1417 | ; | |||
1418 | } | |||
1419 | #line 1007 "Encode.xs" | |||
1420 | PERL_UNUSED_VAR(ix)((void)sizeof(ix)); | |||
1421 | SvGETMAGIC(encoding)((void)(__builtin_expect(((((encoding)->sv_flags & 0x00200000 )) ? (_Bool)1 : (_Bool)0),(0)) && Perl_mg_get( encoding ))); | |||
1422 | #line 1423 "Encode.c" | |||
1423 | #line 1010 "Encode.xs" | |||
1424 | if (!SvOK(encoding)((encoding)->sv_flags & (0x00000100|0x00000200|0x00000400 |0x00000800| 0x00001000|0x00002000|0x00004000|0x00008000))) | |||
1425 | croakPerl_croak("Encoding name should not be undef"); | |||
1426 | obj = find_encoding(aTHX_ encoding); | |||
1427 | if (!SvOK(obj)((obj)->sv_flags & (0x00000100|0x00000200|0x00000400|0x00000800 | 0x00001000|0x00002000|0x00004000|0x00008000))) | |||
1428 | croakPerl_croak("Unknown encoding '%" SVf"-p" "'", SVfARG(encoding)((void*)(encoding))); | |||
1429 | RETVAL = call_encoding(aTHX_ "encode", obj, string, check); | |||
1430 | #line 1431 "Encode.c" | |||
1431 | RETVAL = sv_2mortal(RETVAL)Perl_sv_2mortal( RETVAL); | |||
1432 | ST(0)PL_stack_base[ax + (0)] = RETVAL; | |||
1433 | } | |||
1434 | XSRETURN(1)do { const IV tmpXSoff = (1); ((void)0); PL_stack_sp = PL_stack_base + ax + (tmpXSoff - 1); return; } while (0); | |||
1435 | } | |||
1436 | ||||
1437 | ||||
1438 | XS_EUPXS(XS_Encode_decode_utf8)static void XS_Encode_decode_utf8( CV* cv __attribute__((unused ))); /* prototype to pass -Wmissing-prototypes */ | |||
1439 | XS_EUPXS(XS_Encode_decode_utf8)static void XS_Encode_decode_utf8( CV* cv __attribute__((unused ))) | |||
1440 | { | |||
1441 | dVARstruct Perl___notused_struct; dXSARGSSV **sp = PL_stack_sp; I32 ax = Perl_POPMARK(); SV **mark = PL_stack_base + ax++; I32 items = (I32)(sp - mark); | |||
1442 | if (items < 1 || items > 2) | |||
1443 | croak_xs_usagePerl_croak_xs_usage(cv, "octets, check = NULL"); | |||
1444 | { | |||
1445 | SV * octets = ST(0)PL_stack_base[ax + (0)] | |||
1446 | ; | |||
1447 | SV * check; | |||
1448 | #line 1024 "Encode.xs" | |||
1449 | HV *hv; | |||
1450 | SV **sv; | |||
1451 | #line 1452 "Encode.c" | |||
1452 | SV * RETVAL; | |||
1453 | ||||
1454 | if (items < 2) | |||
1455 | check = NULL((void*)0); | |||
1456 | else { | |||
1457 | check = ST(1)PL_stack_base[ax + (1)] | |||
1458 | ; | |||
1459 | } | |||
1460 | #line 1027 "Encode.xs" | |||
1461 | hv = get_hv("Encode::Encoding", 0)Perl_get_hv( "Encode::Encoding",0); | |||
1462 | if (!hv) | |||
1463 | croakPerl_croak("utf8 encoding was not found"); | |||
1464 | sv = hv_fetch(hv, "utf8", 4, 0)((SV**) Perl_hv_common_key_len( (hv),("utf8"),(4),(0) ? (0x20 | 0x10) : 0x20,((void*)0),0)); | |||
1465 | if (!sv || !*sv || !SvOK(*sv)((*sv)->sv_flags & (0x00000100|0x00000200|0x00000400|0x00000800 | 0x00001000|0x00002000|0x00004000|0x00008000))) | |||
1466 | croakPerl_croak("utf8 encoding was not found"); | |||
1467 | RETVAL = call_encoding(aTHX_ "decode", *sv, octets, check); | |||
1468 | #line 1469 "Encode.c" | |||
1469 | RETVAL = sv_2mortal(RETVAL)Perl_sv_2mortal( RETVAL); | |||
1470 | ST(0)PL_stack_base[ax + (0)] = RETVAL; | |||
1471 | } | |||
1472 | XSRETURN(1)do { const IV tmpXSoff = (1); ((void)0); PL_stack_sp = PL_stack_base + ax + (tmpXSoff - 1); return; } while (0); | |||
1473 | } | |||
1474 | ||||
1475 | ||||
1476 | XS_EUPXS(XS_Encode_encode_utf8)static void XS_Encode_encode_utf8( CV* cv __attribute__((unused ))); /* prototype to pass -Wmissing-prototypes */ | |||
1477 | XS_EUPXS(XS_Encode_encode_utf8)static void XS_Encode_encode_utf8( CV* cv __attribute__((unused ))) | |||
1478 | { | |||
1479 | dVARstruct Perl___notused_struct; dXSARGSSV **sp = PL_stack_sp; I32 ax = Perl_POPMARK(); SV **mark = PL_stack_base + ax++; I32 items = (I32)(sp - mark); | |||
1480 | if (items != 1) | |||
1481 | croak_xs_usagePerl_croak_xs_usage(cv, "string"); | |||
1482 | { | |||
1483 | SV * string = ST(0)PL_stack_base[ax + (0)] | |||
1484 | ; | |||
1485 | SV * RETVAL; | |||
1486 | #line 1041 "Encode.xs" | |||
1487 | RETVAL = newSVsv(string)Perl_newSVsv_flags( (string),2|16); | |||
1488 | if (SvOK(RETVAL)((RETVAL)->sv_flags & (0x00000100|0x00000200|0x00000400 |0x00000800| 0x00001000|0x00002000|0x00004000|0x00008000))) | |||
1489 | sv_utf8_encode(RETVAL)Perl_sv_utf8_encode( RETVAL); | |||
1490 | #line 1491 "Encode.c" | |||
1491 | RETVAL = sv_2mortal(RETVAL)Perl_sv_2mortal( RETVAL); | |||
1492 | ST(0)PL_stack_base[ax + (0)] = RETVAL; | |||
1493 | } | |||
1494 | XSRETURN(1)do { const IV tmpXSoff = (1); ((void)0); PL_stack_sp = PL_stack_base + ax + (tmpXSoff - 1); return; } while (0); | |||
1495 | } | |||
1496 | ||||
1497 | ||||
1498 | XS_EUPXS(XS_Encode_from_to)static void XS_Encode_from_to( CV* cv __attribute__((unused)) ); /* prototype to pass -Wmissing-prototypes */ | |||
1499 | XS_EUPXS(XS_Encode_from_to)static void XS_Encode_from_to( CV* cv __attribute__((unused)) ) | |||
1500 | { | |||
1501 | dVARstruct Perl___notused_struct; dXSARGSSV **sp = PL_stack_sp; I32 ax = Perl_POPMARK(); SV **mark = PL_stack_base + ax++; I32 items = (I32)(sp - mark); | |||
1502 | if (items < 3 || items > 4) | |||
1503 | croak_xs_usagePerl_croak_xs_usage(cv, "octets, from, to, check = NULL"); | |||
1504 | { | |||
1505 | SV * octets = ST(0)PL_stack_base[ax + (0)] | |||
1506 | ; | |||
1507 | SV * from = ST(1)PL_stack_base[ax + (1)] | |||
1508 | ; | |||
1509 | SV * to = ST(2)PL_stack_base[ax + (2)] | |||
1510 | ; | |||
1511 | SV * check; | |||
1512 | #line 1054 "Encode.xs" | |||
1513 | SV *from_obj; | |||
1514 | SV *to_obj; | |||
1515 | SV *string; | |||
1516 | SV *new_octets; | |||
1517 | U8 *ptr; | |||
1518 | STRLEN len; | |||
1519 | #line 1520 "Encode.c" | |||
1520 | SV * RETVAL; | |||
1521 | ||||
1522 | if (items < 4) | |||
1523 | check = NULL((void*)0); | |||
1524 | else { | |||
1525 | check = ST(3)PL_stack_base[ax + (3)] | |||
1526 | ; | |||
1527 | } | |||
1528 | #line 1061 "Encode.xs" | |||
1529 | SvGETMAGIC(from)((void)(__builtin_expect(((((from)->sv_flags & 0x00200000 )) ? (_Bool)1 : (_Bool)0),(0)) && Perl_mg_get( from)) ); | |||
1530 | SvGETMAGIC(to)((void)(__builtin_expect(((((to)->sv_flags & 0x00200000 )) ? (_Bool)1 : (_Bool)0),(0)) && Perl_mg_get( to))); | |||
1531 | #line 1532 "Encode.c" | |||
1532 | #line 1064 "Encode.xs" | |||
1533 | if (!SvOK(from)((from)->sv_flags & (0x00000100|0x00000200|0x00000400| 0x00000800| 0x00001000|0x00002000|0x00004000|0x00008000)) || !SvOK(to)((to)->sv_flags & (0x00000100|0x00000200|0x00000400|0x00000800 | 0x00001000|0x00002000|0x00004000|0x00008000))) | |||
1534 | croakPerl_croak("Encoding name should not be undef"); | |||
1535 | from_obj = find_encoding(aTHX_ from); | |||
1536 | if (!SvOK(from_obj)((from_obj)->sv_flags & (0x00000100|0x00000200|0x00000400 |0x00000800| 0x00001000|0x00002000|0x00004000|0x00008000))) | |||
1537 | croakPerl_croak("Unknown encoding '%" SVf"-p" "'", SVfARG(from)((void*)(from))); | |||
1538 | to_obj = find_encoding(aTHX_ to); | |||
1539 | if (!SvOK(to_obj)((to_obj)->sv_flags & (0x00000100|0x00000200|0x00000400 |0x00000800| 0x00001000|0x00002000|0x00004000|0x00008000))) | |||
1540 | croakPerl_croak("Unknown encoding '%" SVf"-p" "'", SVfARG(to)((void*)(to))); | |||
1541 | string = sv_2mortal(call_encoding(aTHX_ "decode", from_obj, octets, NULL))Perl_sv_2mortal( call_encoding( "decode", from_obj, octets, ( (void*)0))); | |||
1542 | new_octets = sv_2mortal(call_encoding(aTHX_ "encode", to_obj, string, check))Perl_sv_2mortal( call_encoding( "encode", to_obj, string, check )); | |||
1543 | SvGETMAGIC(new_octets)((void)(__builtin_expect(((((new_octets)->sv_flags & 0x00200000 )) ? (_Bool)1 : (_Bool)0),(0)) && Perl_mg_get( new_octets ))); | |||
1544 | if (SvOK(new_octets)((new_octets)->sv_flags & (0x00000100|0x00000200|0x00000400 |0x00000800| 0x00001000|0x00002000|0x00004000|0x00008000)) && (!check || SvROK(check)((check)->sv_flags & 0x00000800) || !SvTRUE_nomg(check)(__builtin_expect(((check) ? (_Bool)1 : (_Bool)0),(1)) && (( ((size_t)((check) - &(PL_sv_immortals[0])) < 4) ? ( (check) == &(PL_sv_immortals[0])) : !((check)->sv_flags & (0x00000100|0x00000200|0x00000400|0x00000800| 0x00001000 |0x00002000|0x00004000|0x00008000)) ? 0 : ((check)->sv_flags & 0x00000400) ? ( ((XPV*)((check))->sv_any) && ( ((XPV*)((check))->sv_any)->xpv_cur > 1 || ( ((XPV *)((check))->sv_any)->xpv_cur && *(check)->sv_u .svu_pv != '0' ) ) ) : ((check)->sv_flags & 0x00000100 ) ? (((XPVIV*) (check)->sv_any)->xiv_u.xivu_iv != 0 ) : (((check)->sv_flags & 0x00000800) && !( ((((check )->sv_u.svu_rv))->sv_flags & 0x00100000) && ((((XPVMG*) (((check)->sv_u.svu_rv))->sv_any)->xmg_stash )->sv_flags & 0x10000000))) ? (1) : (Perl_sv_2bool_flags ( check,0))))) || sv_len(string)Perl_sv_len( string) == 0)) { | |||
1545 | ptr = (U8 *)SvPV_nomg(new_octets, len)((((new_octets)->sv_flags & (0x00000400|0x00200000)) == 0x00000400) ? ((len = ((XPV*) (new_octets)->sv_any)->xpv_cur ), ((new_octets)->sv_u.svu_pv)) : Perl_sv_2pv_flags( new_octets ,&len,0)); | |||
1546 | if (SvUTF8(new_octets)((new_octets)->sv_flags & 0x20000000)) | |||
1547 | len = utf8_length(ptr, ptr+len)Perl_utf8_length( ptr,ptr+len); | |||
1548 | RETVAL = newSVuv(len)Perl_newSVuv( len); | |||
1549 | } else { | |||
1550 | RETVAL = &PL_sv_undef(PL_sv_immortals[1]); | |||
1551 | } | |||
1552 | sv_setsv_nomg(octets, new_octets)Perl_sv_setsv_flags( octets,new_octets,0); | |||
1553 | SvSETMAGIC(octets)do { if (__builtin_expect(((((octets)->sv_flags & 0x00400000 )) ? (_Bool)1 : (_Bool)0),(0))) Perl_mg_set( octets); } while (0); | |||
1554 | #line 1555 "Encode.c" | |||
1555 | RETVAL = sv_2mortal(RETVAL)Perl_sv_2mortal( RETVAL); | |||
1556 | ST(0)PL_stack_base[ax + (0)] = RETVAL; | |||
1557 | } | |||
1558 | XSRETURN(1)do { const IV tmpXSoff = (1); ((void)0); PL_stack_sp = PL_stack_base + ax + (tmpXSoff - 1); return; } while (0); | |||
1559 | } | |||
1560 | ||||
1561 | ||||
1562 | XS_EUPXS(XS_Encode_onBOOT)static void XS_Encode_onBOOT( CV* cv __attribute__((unused))); /* prototype to pass -Wmissing-prototypes */ | |||
1563 | XS_EUPXS(XS_Encode_onBOOT)static void XS_Encode_onBOOT( CV* cv __attribute__((unused))) | |||
1564 | { | |||
1565 | dVARstruct Perl___notused_struct; dXSARGSSV **sp = PL_stack_sp; I32 ax = Perl_POPMARK(); SV **mark = PL_stack_base + ax++; I32 items = (I32)(sp - mark); | |||
1566 | if (items != 0) | |||
1567 | croak_xs_usagePerl_croak_xs_usage(cv, ""); | |||
1568 | { | |||
1569 | #line 1091 "Encode.xs" | |||
1570 | { | |||
1571 | #include "def_t.exh" | |||
1572 | } | |||
1573 | #line 1574 "Encode.c" | |||
1574 | } | |||
1575 | XSRETURN_EMPTYdo { do { const IV tmpXSoff = (0); ((void)0); PL_stack_sp = PL_stack_base + ax + (tmpXSoff - 1); return; } while (0); } while (0); | |||
1576 | } | |||
1577 | ||||
1578 | #ifdef __cplusplus | |||
1579 | extern "C" | |||
1580 | #endif | |||
1581 | XS_EXTERNAL(boot_Encode)void boot_Encode( CV* cv __attribute__((unused))); /* prototype to pass -Wmissing-prototypes */ | |||
1582 | XS_EXTERNAL(boot_Encode)void boot_Encode( CV* cv __attribute__((unused))) | |||
1583 | { | |||
1584 | #if PERL_VERSION_LE(5, 21, 5)((5*1000000 + 32*1000 + 1) <= (5*1000000 + 21*1000 + 5)) | |||
1585 | dVARstruct Perl___notused_struct; dXSARGSSV **sp = PL_stack_sp; I32 ax = Perl_POPMARK(); SV **mark = PL_stack_base + ax++; I32 items = (I32)(sp - mark); | |||
1586 | #else | |||
1587 | dVARstruct Perl___notused_struct; dXSBOOTARGSXSAPIVERCHKI32 ax = Perl_xs_handshake((((sizeof(struct PerlHandShakeInterpreter )) << 16) | ((sizeof("" "3.06_01" "")-1) > 0xFF ? (Perl_croak ("panic: handshake overflow"), 0xFF) : (sizeof("" "3.06_01" "" )-1) << 8) | ((((1)) ? (_Bool)1 : (_Bool)0) ? 0x00000020 : 0) | ((((0)) ? (_Bool)1 : (_Bool)0) ? 0x00000080 : 0) | (( ((1)) ? (_Bool)1 : (_Bool)0) ? 0x00000040 : 0) | ((sizeof("" "v" "5" "." "32" "." "0" "")-1) > 0x0000001F ? (Perl_croak("panic: handshake overflow" ), 0x0000001F) : (sizeof("" "v" "5" "." "32" "." "0" "")-1))) , cv, "Encode.c", "v" "5" "." "32" "." "0", "3.06_01"); SV ** mark = PL_stack_base + ax; SV **sp = PL_stack_sp; I32 items = (I32)(sp - mark); | |||
1588 | #endif | |||
1589 | #if (PERL_REVISION5 == 5 && PERL_VERSION32 < 9) | |||
1590 | char* file = __FILE__"Encode.c"; | |||
1591 | #else | |||
1592 | const char* file = __FILE__"Encode.c"; | |||
1593 | #endif | |||
1594 | ||||
1595 | PERL_UNUSED_VAR(file)((void)sizeof(file)); | |||
1596 | ||||
1597 | PERL_UNUSED_VAR(cv)((void)sizeof(cv)); /* -W */ | |||
1598 | PERL_UNUSED_VAR(items)((void)sizeof(items)); /* -W */ | |||
1599 | #if PERL_VERSION_LE(5, 21, 5)((5*1000000 + 32*1000 + 1) <= (5*1000000 + 21*1000 + 5)) | |||
1600 | XS_VERSION_BOOTCHECKPerl_xs_handshake((((sizeof(struct PerlHandShakeInterpreter)) << 16) | ((sizeof("" "3.06_01" "")-1) > 0xFF ? (Perl_croak ("panic: handshake overflow"), 0xFF) : (sizeof("" "3.06_01" "" )-1) << 8) | ((((0)) ? (_Bool)1 : (_Bool)0) ? 0x00000020 : 0) | ((((0)) ? (_Bool)1 : (_Bool)0) ? 0x00000080 : 0) | (( ((0)) ? (_Bool)1 : (_Bool)0) ? 0x00000040 : 0) | ((sizeof("" "" "")-1) > 0x0000001F ? (Perl_croak("panic: handshake overflow" ), 0x0000001F) : (sizeof("" "" "")-1))), cv, "Encode.c", items , ax, "3.06_01"); | |||
1601 | # ifdef XS_APIVERSION_BOOTCHECKPerl_xs_handshake((((sizeof(struct PerlHandShakeInterpreter)) << 16) | ((sizeof("" "" "")-1) > 0xFF ? (Perl_croak ("panic: handshake overflow"), 0xFF) : (sizeof("" "" "")-1) << 8) | ((((0)) ? (_Bool)1 : (_Bool)0) ? 0x00000020 : 0) | (((( 0)) ? (_Bool)1 : (_Bool)0) ? 0x00000080 : 0) | ((((0)) ? (_Bool )1 : (_Bool)0) ? 0x00000040 : 0) | ((sizeof("" "v" "5" "." "32" "." "0" "")-1) > 0x0000001F ? (Perl_croak("panic: handshake overflow" ), 0x0000001F) : (sizeof("" "v" "5" "." "32" "." "0" "")-1))) , cv, "Encode.c", items, ax, "v" "5" "." "32" "." "0") | |||
1602 | XS_APIVERSION_BOOTCHECKPerl_xs_handshake((((sizeof(struct PerlHandShakeInterpreter)) << 16) | ((sizeof("" "" "")-1) > 0xFF ? (Perl_croak ("panic: handshake overflow"), 0xFF) : (sizeof("" "" "")-1) << 8) | ((((0)) ? (_Bool)1 : (_Bool)0) ? 0x00000020 : 0) | (((( 0)) ? (_Bool)1 : (_Bool)0) ? 0x00000080 : 0) | ((((0)) ? (_Bool )1 : (_Bool)0) ? 0x00000040 : 0) | ((sizeof("" "v" "5" "." "32" "." "0" "")-1) > 0x0000001F ? (Perl_croak("panic: handshake overflow" ), 0x0000001F) : (sizeof("" "v" "5" "." "32" "." "0" "")-1))) , cv, "Encode.c", items, ax, "v" "5" "." "32" "." "0"); | |||
1603 | # endif | |||
1604 | #endif | |||
1605 | ||||
1606 | newXS_deffile("Encode::utf8::decode", XS_Encode__utf8_decode)Perl_newXS_deffile( "Encode::utf8::decode",XS_Encode__utf8_decode ); | |||
1607 | newXS_deffile("Encode::utf8::encode", XS_Encode__utf8_encode)Perl_newXS_deffile( "Encode::utf8::encode",XS_Encode__utf8_encode ); | |||
1608 | newXS_deffile("Encode::XS::renew", XS_Encode__XS_renew)Perl_newXS_deffile( "Encode::XS::renew",XS_Encode__XS_renew); | |||
1609 | newXS_deffile("Encode::XS::renewed", XS_Encode__XS_renewed)Perl_newXS_deffile( "Encode::XS::renewed",XS_Encode__XS_renewed ); | |||
1610 | newXS_deffile("Encode::XS::name", XS_Encode__XS_name)Perl_newXS_deffile( "Encode::XS::name",XS_Encode__XS_name); | |||
1611 | newXS_deffile("Encode::XS::cat_decode", XS_Encode__XS_cat_decode)Perl_newXS_deffile( "Encode::XS::cat_decode",XS_Encode__XS_cat_decode ); | |||
1612 | newXS_deffile("Encode::XS::decode", XS_Encode__XS_decode)Perl_newXS_deffile( "Encode::XS::decode",XS_Encode__XS_decode ); | |||
1613 | newXS_deffile("Encode::XS::encode", XS_Encode__XS_encode)Perl_newXS_deffile( "Encode::XS::encode",XS_Encode__XS_encode ); | |||
1614 | newXS_deffile("Encode::XS::needs_lines", XS_Encode__XS_needs_lines)Perl_newXS_deffile( "Encode::XS::needs_lines",XS_Encode__XS_needs_lines ); | |||
1615 | newXS_deffile("Encode::XS::perlio_ok", XS_Encode__XS_perlio_ok)Perl_newXS_deffile( "Encode::XS::perlio_ok",XS_Encode__XS_perlio_ok ); | |||
1616 | newXS_deffile("Encode::XS::mime_name", XS_Encode__XS_mime_name)Perl_newXS_deffile( "Encode::XS::mime_name",XS_Encode__XS_mime_name ); | |||
1617 | (void)newXSproto_portable("Encode::is_utf8", XS_Encode_is_utf8, file, "$;$")Perl_newXS_flags( "Encode::is_utf8",XS_Encode_is_utf8,file,"$;$" ,0); | |||
1618 | (void)newXSproto_portable("Encode::_utf8_on", XS_Encode__utf8_on, file, "$")Perl_newXS_flags( "Encode::_utf8_on",XS_Encode__utf8_on,file, "$",0); | |||
1619 | (void)newXSproto_portable("Encode::_utf8_off", XS_Encode__utf8_off, file, "$")Perl_newXS_flags( "Encode::_utf8_off",XS_Encode__utf8_off,file ,"$",0); | |||
1620 | cv = newXSproto_portable("Encode::bytes2str", XS_Encode_decode, file, "$$;$")Perl_newXS_flags( "Encode::bytes2str",XS_Encode_decode,file,"$$;$" ,0); | |||
1621 | XSANY((XPVCV*)({ void *_p = ((cv)->sv_any); _p; }))->xcv_start_u .xcv_xsubany.any_i32 = 0; | |||
1622 | cv = newXSproto_portable("Encode::decode", XS_Encode_decode, file, "$$;$")Perl_newXS_flags( "Encode::decode",XS_Encode_decode,file,"$$;$" ,0); | |||
1623 | XSANY((XPVCV*)({ void *_p = ((cv)->sv_any); _p; }))->xcv_start_u .xcv_xsubany.any_i32 = 0; | |||
1624 | cv = newXSproto_portable("Encode::encode", XS_Encode_encode, file, "$$;$")Perl_newXS_flags( "Encode::encode",XS_Encode_encode,file,"$$;$" ,0); | |||
1625 | XSANY((XPVCV*)({ void *_p = ((cv)->sv_any); _p; }))->xcv_start_u .xcv_xsubany.any_i32 = 0; | |||
1626 | cv = newXSproto_portable("Encode::str2bytes", XS_Encode_encode, file, "$$;$")Perl_newXS_flags( "Encode::str2bytes",XS_Encode_encode,file,"$$;$" ,0); | |||
1627 | XSANY((XPVCV*)({ void *_p = ((cv)->sv_any); _p; }))->xcv_start_u .xcv_xsubany.any_i32 = 0; | |||
1628 | (void)newXSproto_portable("Encode::decode_utf8", XS_Encode_decode_utf8, file, "$;$")Perl_newXS_flags( "Encode::decode_utf8",XS_Encode_decode_utf8 ,file,"$;$",0); | |||
1629 | (void)newXSproto_portable("Encode::encode_utf8", XS_Encode_encode_utf8, file, "$")Perl_newXS_flags( "Encode::encode_utf8",XS_Encode_encode_utf8 ,file,"$",0); | |||
1630 | (void)newXSproto_portable("Encode::from_to", XS_Encode_from_to, file, "$$$;$")Perl_newXS_flags( "Encode::from_to",XS_Encode_from_to,file,"$$$;$" ,0); | |||
1631 | (void)newXSproto_portable("Encode::onBOOT", XS_Encode_onBOOT, file, "")Perl_newXS_flags( "Encode::onBOOT",XS_Encode_onBOOT,file,"",0 ); | |||
1632 | ||||
1633 | /* Initialisation Section */ | |||
1634 | ||||
1635 | #line 1096 "Encode.xs" | |||
1636 | { | |||
1637 | HV *stash = gv_stashpvn("Encode", (U32)strlen("Encode"), GV_ADD)Perl_gv_stashpvn( "Encode",(U32)strlen("Encode"),0x01); | |||
1638 | newCONSTSUB(stash, "DIE_ON_ERR", newSViv(ENCODE_DIE_ON_ERR))Perl_newCONSTSUB( stash,"DIE_ON_ERR",Perl_newSViv( 0x0001)); | |||
1639 | newCONSTSUB(stash, "WARN_ON_ERR", newSViv(ENCODE_WARN_ON_ERR))Perl_newCONSTSUB( stash,"WARN_ON_ERR",Perl_newSViv( 0x0002)); | |||
1640 | newCONSTSUB(stash, "RETURN_ON_ERR", newSViv(ENCODE_RETURN_ON_ERR))Perl_newCONSTSUB( stash,"RETURN_ON_ERR",Perl_newSViv( 0x0004) ); | |||
1641 | newCONSTSUB(stash, "LEAVE_SRC", newSViv(ENCODE_LEAVE_SRC))Perl_newCONSTSUB( stash,"LEAVE_SRC",Perl_newSViv( 0x0008)); | |||
1642 | newCONSTSUB(stash, "ONLY_PRAGMA_WARNINGS", newSViv(ENCODE_ONLY_PRAGMA_WARNINGS))Perl_newCONSTSUB( stash,"ONLY_PRAGMA_WARNINGS",Perl_newSViv( 0x0010 )); | |||
1643 | newCONSTSUB(stash, "PERLQQ", newSViv(ENCODE_PERLQQ))Perl_newCONSTSUB( stash,"PERLQQ",Perl_newSViv( 0x0100)); | |||
1644 | newCONSTSUB(stash, "HTMLCREF", newSViv(ENCODE_HTMLCREF))Perl_newCONSTSUB( stash,"HTMLCREF",Perl_newSViv( 0x0200)); | |||
1645 | newCONSTSUB(stash, "XMLCREF", newSViv(ENCODE_XMLCREF))Perl_newCONSTSUB( stash,"XMLCREF",Perl_newSViv( 0x0400)); | |||
1646 | newCONSTSUB(stash, "STOP_AT_PARTIAL", newSViv(ENCODE_STOP_AT_PARTIAL))Perl_newCONSTSUB( stash,"STOP_AT_PARTIAL",Perl_newSViv( 0x0800 )); | |||
1647 | newCONSTSUB(stash, "FB_DEFAULT", newSViv(ENCODE_FB_DEFAULT))Perl_newCONSTSUB( stash,"FB_DEFAULT",Perl_newSViv( 0x0000)); | |||
1648 | newCONSTSUB(stash, "FB_CROAK", newSViv(ENCODE_FB_CROAK))Perl_newCONSTSUB( stash,"FB_CROAK",Perl_newSViv( 0x0001)); | |||
1649 | newCONSTSUB(stash, "FB_QUIET", newSViv(ENCODE_FB_QUIET))Perl_newCONSTSUB( stash,"FB_QUIET",Perl_newSViv( 0x0004)); | |||
1650 | newCONSTSUB(stash, "FB_WARN", newSViv(ENCODE_FB_WARN))Perl_newCONSTSUB( stash,"FB_WARN",Perl_newSViv( (0x0004|0x0002 ))); | |||
1651 | newCONSTSUB(stash, "FB_PERLQQ", newSViv(ENCODE_FB_PERLQQ))Perl_newCONSTSUB( stash,"FB_PERLQQ",Perl_newSViv( (0x0100|0x0008 ))); | |||
1652 | newCONSTSUB(stash, "FB_HTMLCREF", newSViv(ENCODE_FB_HTMLCREF))Perl_newCONSTSUB( stash,"FB_HTMLCREF",Perl_newSViv( (0x0200|0x0008 ))); | |||
1653 | newCONSTSUB(stash, "FB_XMLCREF", newSViv(ENCODE_FB_XMLCREF))Perl_newCONSTSUB( stash,"FB_XMLCREF",Perl_newSViv( (0x0400|0x0008 ))); | |||
1654 | } | |||
1655 | ||||
1656 | #line 1657 "Encode.c" | |||
1657 | ||||
1658 | /* End of Initialisation Section */ | |||
1659 | ||||
1660 | #if PERL_VERSION_LE(5, 21, 5)((5*1000000 + 32*1000 + 1) <= (5*1000000 + 21*1000 + 5)) | |||
1661 | # if PERL_VERSION_GE(5, 9, 0)((5*1000000 + 32*1000 + 1) >= (5*1000000 + 9*1000 + 0)) | |||
1662 | if (PL_unitcheckav) | |||
1663 | call_list(PL_scopestack_ix, PL_unitcheckav)Perl_call_list( PL_scopestack_ix,PL_unitcheckav); | |||
1664 | # endif | |||
1665 | XSRETURN_YESdo { (PL_stack_base[ax + (0)] = &(PL_sv_immortals[0]) ); do { const IV tmpXSoff = (1); ((void)0); PL_stack_sp = PL_stack_base + ax + (tmpXSoff - 1); return; } while (0); } while (0); | |||
1666 | #else | |||
1667 | Perl_xs_boot_epilog(aTHX_ ax); | |||
1668 | #endif | |||
1669 | } | |||
1670 |
1 | /* inline.h | |||
2 | * | |||
3 | * Copyright (C) 2012 by Larry Wall and others | |||
4 | * | |||
5 | * You may distribute under the terms of either the GNU General Public | |||
6 | * License or the Artistic License, as specified in the README file. | |||
7 | * | |||
8 | * This file contains tables and code adapted from | |||
9 | * https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which requires this | |||
10 | * copyright notice: | |||
11 | ||||
12 | Copyright (c) 2008-2009 Bjoern Hoehrmann <bjoern@hoehrmann.de> | |||
13 | ||||
14 | Permission is hereby granted, free of charge, to any person obtaining a copy of | |||
15 | this software and associated documentation files (the "Software"), to deal in | |||
16 | the Software without restriction, including without limitation the rights to | |||
17 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies | |||
18 | of the Software, and to permit persons to whom the Software is furnished to do | |||
19 | so, subject to the following conditions: | |||
20 | ||||
21 | The above copyright notice and this permission notice shall be included in all | |||
22 | copies or substantial portions of the Software. | |||
23 | ||||
24 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR | |||
25 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, | |||
26 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE | |||
27 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER | |||
28 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, | |||
29 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE | |||
30 | SOFTWARE. | |||
31 | ||||
32 | * | |||
33 | * This file is a home for static inline functions that cannot go in other | |||
34 | * header files, because they depend on proto.h (included after most other | |||
35 | * headers) or struct definitions. | |||
36 | * | |||
37 | * Each section names the header file that the functions "belong" to. | |||
38 | */ | |||
39 | ||||
40 | /* ------------------------------- av.h ------------------------------- */ | |||
41 | ||||
42 | PERL_STATIC_INLINEstatic __inline__ SSize_tssize_t | |||
43 | Perl_av_top_index(pTHX_ AV *av) | |||
44 | { | |||
45 | PERL_ARGS_ASSERT_AV_TOP_INDEX((void)0); | |||
46 | assert(SvTYPE(av) == SVt_PVAV)((void)0); | |||
47 | ||||
48 | return AvFILL(av)(((((const SV *) (av))->sv_flags & 0x00800000)) ? Perl_mg_size ( ((SV *)({ void *_p = (av); _p; }))) : ((XPVAV*) (av)->sv_any )->xav_fill); | |||
49 | } | |||
50 | ||||
51 | /* ------------------------------- cv.h ------------------------------- */ | |||
52 | ||||
53 | PERL_STATIC_INLINEstatic __inline__ GV * | |||
54 | Perl_CvGV(pTHX_ CV *sv) | |||
55 | { | |||
56 | PERL_ARGS_ASSERT_CVGV((void)0); | |||
57 | ||||
58 | return CvNAMED(sv)(((XPVCV*)({ void *_p = ((sv)->sv_any); _p; }))->xcv_flags & 0x8000) | |||
59 | ? Perl_cvgv_from_hek(aTHX_ sv) | |||
60 | : ((XPVCV*)MUTABLE_PTR(SvANY(sv))({ void *_p = ((sv)->sv_any); _p; }))->xcv_gv_u.xcv_gv; | |||
61 | } | |||
62 | ||||
63 | PERL_STATIC_INLINEstatic __inline__ I32 * | |||
64 | Perl_CvDEPTH(const CV * const sv) | |||
65 | { | |||
66 | PERL_ARGS_ASSERT_CVDEPTH((void)0); | |||
67 | assert(SvTYPE(sv) == SVt_PVCV || SvTYPE(sv) == SVt_PVFM)((void)0); | |||
68 | ||||
69 | return &((XPVCV*)SvANY(sv)(sv)->sv_any)->xcv_depth; | |||
70 | } | |||
71 | ||||
72 | /* | |||
73 | CvPROTO returns the prototype as stored, which is not necessarily what | |||
74 | the interpreter should be using. Specifically, the interpreter assumes | |||
75 | that spaces have been stripped, which has been the case if the prototype | |||
76 | was added by toke.c, but is generally not the case if it was added elsewhere. | |||
77 | Since we can't enforce the spacelessness at assignment time, this routine | |||
78 | provides a temporary copy at parse time with spaces removed. | |||
79 | I<orig> is the start of the original buffer, I<len> is the length of the | |||
80 | prototype and will be updated when this returns. | |||
81 | */ | |||
82 | ||||
83 | #ifdef PERL_CORE | |||
84 | PERL_STATIC_INLINEstatic __inline__ char * | |||
85 | S_strip_spaces(pTHX_ const char * orig, STRLEN * const len) | |||
86 | { | |||
87 | SV * tmpsv; | |||
88 | char * tmps; | |||
89 | tmpsv = newSVpvn_flags(orig, *len, SVs_TEMP)Perl_newSVpvn_flags( orig,*len,0x00080000); | |||
90 | tmps = SvPVX(tmpsv)((tmpsv)->sv_u.svu_pv); | |||
91 | while ((*len)--) { | |||
92 | if (!isSPACE(*orig)(( (sizeof(*orig) == 1) || !(((U64)((*orig) | 0)) & ~0xFF )) && ((PL_charclass[(U8) (*orig)] & ((1U << (10)) | (1U << (14)))) == ((1U << (10)) | (1U << (14)))))) | |||
93 | *tmps++ = *orig; | |||
94 | orig++; | |||
95 | } | |||
96 | *tmps = '\0'; | |||
97 | *len = tmps - SvPVX(tmpsv)((tmpsv)->sv_u.svu_pv); | |||
98 | return SvPVX(tmpsv)((tmpsv)->sv_u.svu_pv); | |||
99 | } | |||
100 | #endif | |||
101 | ||||
102 | /* ------------------------------- mg.h ------------------------------- */ | |||
103 | ||||
104 | #if defined(PERL_CORE) || defined(PERL_EXT) | |||
105 | /* assumes get-magic and stringification have already occurred */ | |||
106 | PERL_STATIC_INLINEstatic __inline__ STRLEN | |||
107 | S_MgBYTEPOS(pTHX_ MAGIC *mg, SV *sv, const char *s, STRLEN len) | |||
108 | { | |||
109 | assert(mg->mg_type == PERL_MAGIC_regex_global)((void)0); | |||
110 | assert(mg->mg_len != -1)((void)0); | |||
111 | if (mg->mg_flags & MGf_BYTES0x40 || !DO_UTF8(sv)(((sv)->sv_flags & 0x20000000) && !__builtin_expect (((((PL_curcop)->cop_hints + 0) & 0x00000008) ? (_Bool )1 : (_Bool)0),(0)))) | |||
112 | return (STRLEN)mg->mg_len; | |||
113 | else { | |||
114 | const STRLEN pos = (STRLEN)mg->mg_len; | |||
115 | /* Without this check, we may read past the end of the buffer: */ | |||
116 | if (pos > sv_or_pv_len_utf8(sv, s, len)) return len+1; | |||
117 | return sv_or_pv_pos_u2b(sv, s, pos, NULL((void*)0)); | |||
118 | } | |||
119 | } | |||
120 | #endif | |||
121 | ||||
122 | /* ------------------------------- pad.h ------------------------------ */ | |||
123 | ||||
124 | #if defined(PERL_IN_PAD_C) || defined(PERL_IN_OP_C) | |||
125 | PERL_STATIC_INLINEstatic __inline__ bool_Bool | |||
126 | S_PadnameIN_SCOPE(const PADNAME * const pn, const U32 seq) | |||
127 | { | |||
128 | PERL_ARGS_ASSERT_PADNAMEIN_SCOPE; | |||
129 | ||||
130 | /* is seq within the range _LOW to _HIGH ? | |||
131 | * This is complicated by the fact that PL_cop_seqmax | |||
132 | * may have wrapped around at some point */ | |||
133 | if (COP_SEQ_RANGE_LOW(pn)(pn)->xpadn_low == PERL_PADSEQ_INTRO0xffffffffU) | |||
134 | return FALSE(0); /* not yet introduced */ | |||
135 | ||||
136 | if (COP_SEQ_RANGE_HIGH(pn)(pn)->xpadn_high == PERL_PADSEQ_INTRO0xffffffffU) { | |||
137 | /* in compiling scope */ | |||
138 | if ( | |||
139 | (seq > COP_SEQ_RANGE_LOW(pn)(pn)->xpadn_low) | |||
140 | ? (seq - COP_SEQ_RANGE_LOW(pn)(pn)->xpadn_low < (U32_MAX0xffffffffU >> 1)) | |||
141 | : (COP_SEQ_RANGE_LOW(pn)(pn)->xpadn_low - seq > (U32_MAX0xffffffffU >> 1)) | |||
142 | ) | |||
143 | return TRUE(1); | |||
144 | } | |||
145 | else if ( | |||
146 | (COP_SEQ_RANGE_LOW(pn)(pn)->xpadn_low > COP_SEQ_RANGE_HIGH(pn)(pn)->xpadn_high) | |||
147 | ? | |||
148 | ( seq > COP_SEQ_RANGE_LOW(pn)(pn)->xpadn_low | |||
149 | || seq <= COP_SEQ_RANGE_HIGH(pn)(pn)->xpadn_high) | |||
150 | ||||
151 | : ( seq > COP_SEQ_RANGE_LOW(pn)(pn)->xpadn_low | |||
152 | && seq <= COP_SEQ_RANGE_HIGH(pn)(pn)->xpadn_high) | |||
153 | ) | |||
154 | return TRUE(1); | |||
155 | return FALSE(0); | |||
156 | } | |||
157 | #endif | |||
158 | ||||
159 | /* ------------------------------- pp.h ------------------------------- */ | |||
160 | ||||
161 | PERL_STATIC_INLINEstatic __inline__ I32 | |||
162 | Perl_TOPMARK(pTHXvoid) | |||
163 | { | |||
164 | DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log, | |||
165 | "MARK top %p %" IVdf "\n", | |||
166 | PL_markstack_ptr, | |||
167 | (IV)*PL_markstack_ptr))); | |||
168 | return *PL_markstack_ptr; | |||
169 | } | |||
170 | ||||
171 | PERL_STATIC_INLINEstatic __inline__ I32 | |||
172 | Perl_POPMARK(pTHXvoid) | |||
173 | { | |||
174 | DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log, | |||
175 | "MARK pop %p %" IVdf "\n", | |||
176 | (PL_markstack_ptr-1), | |||
177 | (IV)*(PL_markstack_ptr-1)))); | |||
178 | assert((PL_markstack_ptr > PL_markstack) || !"MARK underflow")((void)0); | |||
179 | return *PL_markstack_ptr--; | |||
180 | } | |||
181 | ||||
182 | /* ----------------------------- regexp.h ----------------------------- */ | |||
183 | ||||
184 | PERL_STATIC_INLINEstatic __inline__ struct regexp * | |||
185 | Perl_ReANY(const REGEXP * const re) | |||
186 | { | |||
187 | XPV* const p = (XPV*)SvANY(re)(re)->sv_any; | |||
188 | ||||
189 | PERL_ARGS_ASSERT_REANY((void)0); | |||
190 | assert(isREGEXP(re))((void)0); | |||
191 | ||||
192 | return SvTYPE(re)((svtype)((re)->sv_flags & 0xff)) == SVt_PVLV ? p->xpv_len_u.xpvlenu_rx | |||
193 | : (struct regexp *)p; | |||
194 | } | |||
195 | ||||
196 | /* ------------------------------- sv.h ------------------------------- */ | |||
197 | ||||
198 | PERL_STATIC_INLINEstatic __inline__ bool_Bool | |||
199 | Perl_SvTRUE(pTHX_ SV *sv) { | |||
200 | if (!LIKELY(sv)__builtin_expect(((sv) ? (_Bool)1 : (_Bool)0),(1))) | |||
201 | return FALSE(0); | |||
202 | SvGETMAGIC(sv)((void)(__builtin_expect(((((sv)->sv_flags & 0x00200000 )) ? (_Bool)1 : (_Bool)0),(0)) && Perl_mg_get( sv))); | |||
203 | return SvTRUE_nomg_NN(sv)(( ((size_t)((sv) - &(PL_sv_immortals[0])) < 4) ? ((sv ) == &(PL_sv_immortals[0])) : !((sv)->sv_flags & ( 0x00000100|0x00000200|0x00000400|0x00000800| 0x00001000|0x00002000 |0x00004000|0x00008000)) ? 0 : ((sv)->sv_flags & 0x00000400 ) ? ( ((XPV*)((sv))->sv_any) && ( ((XPV*)((sv))-> sv_any)->xpv_cur > 1 || ( ((XPV*)((sv))->sv_any)-> xpv_cur && *(sv)->sv_u.svu_pv != '0' ) ) ) : ((sv) ->sv_flags & 0x00000100) ? (((XPVIV*) (sv)->sv_any) ->xiv_u.xivu_iv != 0 ) : (((sv)->sv_flags & 0x00000800 ) && !( ((((sv)->sv_u.svu_rv))->sv_flags & 0x00100000 ) && ((((XPVMG*) (((sv)->sv_u.svu_rv))->sv_any) ->xmg_stash)->sv_flags & 0x10000000))) ? (1) : (Perl_sv_2bool_flags ( sv,0)))); | |||
204 | } | |||
205 | ||||
206 | PERL_STATIC_INLINEstatic __inline__ SV * | |||
207 | Perl_SvREFCNT_inc(SV *sv) | |||
208 | { | |||
209 | if (LIKELY(sv != NULL)__builtin_expect(((sv != ((void*)0)) ? (_Bool)1 : (_Bool)0),( 1))) | |||
210 | SvREFCNT(sv)(sv)->sv_refcnt++; | |||
211 | return sv; | |||
212 | } | |||
213 | PERL_STATIC_INLINEstatic __inline__ SV * | |||
214 | Perl_SvREFCNT_inc_NN(SV *sv) | |||
215 | { | |||
216 | PERL_ARGS_ASSERT_SVREFCNT_INC_NN((void)0); | |||
217 | ||||
218 | SvREFCNT(sv)(sv)->sv_refcnt++; | |||
219 | return sv; | |||
220 | } | |||
221 | PERL_STATIC_INLINEstatic __inline__ void | |||
222 | Perl_SvREFCNT_inc_void(SV *sv) | |||
223 | { | |||
224 | if (LIKELY(sv != NULL)__builtin_expect(((sv != ((void*)0)) ? (_Bool)1 : (_Bool)0),( 1))) | |||
225 | SvREFCNT(sv)(sv)->sv_refcnt++; | |||
226 | } | |||
227 | PERL_STATIC_INLINEstatic __inline__ void | |||
228 | Perl_SvREFCNT_dec(pTHX_ SV *sv) | |||
229 | { | |||
230 | if (LIKELY(sv != NULL)__builtin_expect(((sv != ((void*)0)) ? (_Bool)1 : (_Bool)0),( 1))) { | |||
231 | U32 rc = SvREFCNT(sv)(sv)->sv_refcnt; | |||
232 | if (LIKELY(rc > 1)__builtin_expect(((rc > 1) ? (_Bool)1 : (_Bool)0),(1))) | |||
233 | SvREFCNT(sv)(sv)->sv_refcnt = rc - 1; | |||
234 | else | |||
235 | Perl_sv_free2(aTHX_ sv, rc); | |||
236 | } | |||
237 | } | |||
238 | ||||
239 | PERL_STATIC_INLINEstatic __inline__ void | |||
240 | Perl_SvREFCNT_dec_NN(pTHX_ SV *sv) | |||
241 | { | |||
242 | U32 rc = SvREFCNT(sv)(sv)->sv_refcnt; | |||
243 | ||||
244 | PERL_ARGS_ASSERT_SVREFCNT_DEC_NN((void)0); | |||
245 | ||||
246 | if (LIKELY(rc > 1)__builtin_expect(((rc > 1) ? (_Bool)1 : (_Bool)0),(1))) | |||
247 | SvREFCNT(sv)(sv)->sv_refcnt = rc - 1; | |||
248 | else | |||
249 | Perl_sv_free2(aTHX_ sv, rc); | |||
250 | } | |||
251 | ||||
252 | PERL_STATIC_INLINEstatic __inline__ void | |||
253 | Perl_SvAMAGIC_on(SV *sv) | |||
254 | { | |||
255 | PERL_ARGS_ASSERT_SVAMAGIC_ON((void)0); | |||
256 | assert(SvROK(sv))((void)0); | |||
257 | ||||
258 | if (SvOBJECT(SvRV(sv))((((sv)->sv_u.svu_rv))->sv_flags & 0x00100000)) HvAMAGIC_on(SvSTASH(SvRV(sv)))((((XPVMG*) (((sv)->sv_u.svu_rv))->sv_any)->xmg_stash )->sv_flags |= 0x10000000); | |||
259 | } | |||
260 | PERL_STATIC_INLINEstatic __inline__ void | |||
261 | Perl_SvAMAGIC_off(SV *sv) | |||
262 | { | |||
263 | PERL_ARGS_ASSERT_SVAMAGIC_OFF((void)0); | |||
264 | ||||
265 | if (SvROK(sv)((sv)->sv_flags & 0x00000800) && SvOBJECT(SvRV(sv))((((sv)->sv_u.svu_rv))->sv_flags & 0x00100000)) | |||
266 | HvAMAGIC_off(SvSTASH(SvRV(sv)))((((XPVMG*) (((sv)->sv_u.svu_rv))->sv_any)->xmg_stash )->sv_flags &=~ 0x10000000); | |||
267 | } | |||
268 | ||||
269 | PERL_STATIC_INLINEstatic __inline__ U32 | |||
270 | Perl_SvPADSTALE_on(SV *sv) | |||
271 | { | |||
272 | assert(!(SvFLAGS(sv) & SVs_PADTMP))((void)0); | |||
273 | return SvFLAGS(sv)(sv)->sv_flags |= SVs_PADSTALE0x00040000; | |||
274 | } | |||
275 | PERL_STATIC_INLINEstatic __inline__ U32 | |||
276 | Perl_SvPADSTALE_off(SV *sv) | |||
277 | { | |||
278 | assert(!(SvFLAGS(sv) & SVs_PADTMP))((void)0); | |||
279 | return SvFLAGS(sv)(sv)->sv_flags &= ~SVs_PADSTALE0x00040000; | |||
280 | } | |||
281 | #if defined(PERL_CORE) || defined (PERL_EXT) | |||
282 | PERL_STATIC_INLINEstatic __inline__ STRLEN | |||
283 | S_sv_or_pv_pos_u2b(pTHX_ SV *sv, const char *pv, STRLEN pos, STRLEN *lenp) | |||
284 | { | |||
285 | PERL_ARGS_ASSERT_SV_OR_PV_POS_U2B; | |||
286 | if (SvGAMAGIC(sv)(((sv)->sv_flags & 0x00200000) || (((sv)->sv_flags & 0x00000800) && ((((sv)->sv_u.svu_rv))->sv_flags & 0x00100000) && ((((XPVMG*) (((sv)->sv_u.svu_rv ))->sv_any)->xmg_stash)->sv_flags & 0x10000000)) )) { | |||
287 | U8 *hopped = utf8_hopPerl_utf8_hop((U8 *)pv, pos); | |||
288 | if (lenp) *lenp = (STRLEN)(utf8_hopPerl_utf8_hop(hopped, *lenp) - hopped); | |||
289 | return (STRLEN)(hopped - (U8 *)pv); | |||
290 | } | |||
291 | return sv_pos_u2b_flags(sv,pos,lenp,SV_CONST_RETURN)Perl_sv_pos_u2b_flags( sv,pos,lenp,32); | |||
292 | } | |||
293 | #endif | |||
294 | ||||
295 | /* ------------------------------- utf8.h ------------------------------- */ | |||
296 | ||||
297 | /* | |||
298 | =head1 Unicode Support | |||
299 | */ | |||
300 | ||||
301 | PERL_STATIC_INLINEstatic __inline__ void | |||
302 | Perl_append_utf8_from_native_byte(const U8 byte, U8** dest) | |||
303 | { | |||
304 | /* Takes an input 'byte' (Latin1 or EBCDIC) and appends it to the UTF-8 | |||
305 | * encoded string at '*dest', updating '*dest' to include it */ | |||
306 | ||||
307 | PERL_ARGS_ASSERT_APPEND_UTF8_FROM_NATIVE_BYTE((void)0); | |||
308 | ||||
309 | if (NATIVE_BYTE_IS_INVARIANT(byte)((((U64)(((UV) ((byte) | 0)))) < (((U8) (0xFF << 6)) & 0xB0)))) | |||
310 | *((*dest)++) = byte; | |||
311 | else { | |||
312 | *((*dest)++) = UTF8_EIGHT_BIT_HI(byte)( ( ( ( ((U8) (((( ((U8) ((byte) | 0))) >> 6) | (((2) > 7) ? 0xFF : ((U8) (0xFE << (7-(2)))))) | 0)))))); | |||
313 | *((*dest)++) = UTF8_EIGHT_BIT_LO(byte)( (( ( ((U8) (((( ((U8) ((byte) | 0))) & ((U8) ((1U << 6) - 1))) | (((U8) (0xFF << 6)) & 0xB0)) | 0)))))); | |||
314 | } | |||
315 | } | |||
316 | ||||
317 | /* | |||
318 | =for apidoc valid_utf8_to_uvchr | |||
319 | Like C<L<perlapi/utf8_to_uvchr_buf>>, but should only be called when it is | |||
320 | known that the next character in the input UTF-8 string C<s> is well-formed | |||
321 | (I<e.g.>, it passes C<L<perlapi/isUTF8_CHAR>>. Surrogates, non-character code | |||
322 | points, and non-Unicode code points are allowed. | |||
323 | ||||
324 | =cut | |||
325 | ||||
326 | */ | |||
327 | ||||
328 | PERL_STATIC_INLINEstatic __inline__ UV | |||
329 | Perl_valid_utf8_to_uvchr(const U8 *s, STRLEN *retlen) | |||
330 | { | |||
331 | const UV expectlen = UTF8SKIP(s)PL_utf8skip[*(const U8*)(s)]; | |||
332 | const U8* send = s + expectlen; | |||
333 | UV uv = *s; | |||
334 | ||||
335 | PERL_ARGS_ASSERT_VALID_UTF8_TO_UVCHR((void)0); | |||
336 | ||||
337 | if (retlen) { | |||
338 | *retlen = expectlen; | |||
339 | } | |||
340 | ||||
341 | /* An invariant is trivially returned */ | |||
342 | if (expectlen == 1) { | |||
343 | return uv; | |||
344 | } | |||
345 | ||||
346 | /* Remove the leading bits that indicate the number of bytes, leaving just | |||
347 | * the bits that are part of the value */ | |||
348 | uv = NATIVE_UTF8_TO_I8(uv)( ((U8) ((uv) | 0))) & UTF_START_MASK(expectlen)(((expectlen) >= 7) ? 0x00 : (0x1F >> ((expectlen)-2 ))); | |||
349 | ||||
350 | /* Now, loop through the remaining bytes, accumulating each into the | |||
351 | * working total as we go. (I khw tried unrolling the loop for up to 4 | |||
352 | * bytes, but there was no performance improvement) */ | |||
353 | for (++s; s < send; s++) { | |||
354 | uv = UTF8_ACCUMULATE(uv, *s)( ((uv) << 6) | ((( ((U8) ((*s) | 0)))) & ((U8) ((1U << 6) - 1)))); | |||
355 | } | |||
356 | ||||
357 | return UNI_TO_NATIVE(uv)((UV) ((uv) | 0)); | |||
358 | ||||
359 | } | |||
360 | ||||
361 | /* | |||
362 | =for apidoc is_utf8_invariant_string | |||
363 | ||||
364 | Returns TRUE if the first C<len> bytes of the string C<s> are the same | |||
365 | regardless of the UTF-8 encoding of the string (or UTF-EBCDIC encoding on | |||
366 | EBCDIC machines); otherwise it returns FALSE. That is, it returns TRUE if they | |||
367 | are UTF-8 invariant. On ASCII-ish machines, all the ASCII characters and only | |||
368 | the ASCII characters fit this definition. On EBCDIC machines, the ASCII-range | |||
369 | characters are invariant, but so also are the C1 controls. | |||
370 | ||||
371 | If C<len> is 0, it will be calculated using C<strlen(s)>, (which means if you | |||
372 | use this option, that C<s> can't have embedded C<NUL> characters and has to | |||
373 | have a terminating C<NUL> byte). | |||
374 | ||||
375 | See also | |||
376 | C<L</is_utf8_string>>, | |||
377 | C<L</is_utf8_string_flags>>, | |||
378 | C<L</is_utf8_string_loc>>, | |||
379 | C<L</is_utf8_string_loc_flags>>, | |||
380 | C<L</is_utf8_string_loclen>>, | |||
381 | C<L</is_utf8_string_loclen_flags>>, | |||
382 | C<L</is_utf8_fixed_width_buf_flags>>, | |||
383 | C<L</is_utf8_fixed_width_buf_loc_flags>>, | |||
384 | C<L</is_utf8_fixed_width_buf_loclen_flags>>, | |||
385 | C<L</is_strict_utf8_string>>, | |||
386 | C<L</is_strict_utf8_string_loc>>, | |||
387 | C<L</is_strict_utf8_string_loclen>>, | |||
388 | C<L</is_c9strict_utf8_string>>, | |||
389 | C<L</is_c9strict_utf8_string_loc>>, | |||
390 | and | |||
391 | C<L</is_c9strict_utf8_string_loclen>>. | |||
392 | ||||
393 | =cut | |||
394 | ||||
395 | */ | |||
396 | ||||
397 | #define is_utf8_invariant_string(s, len)Perl_is_utf8_invariant_string_loc(s, len, ((void*)0)) \ | |||
398 | is_utf8_invariant_string_locPerl_is_utf8_invariant_string_loc(s, len, NULL((void*)0)) | |||
399 | ||||
400 | /* | |||
401 | =for apidoc is_utf8_invariant_string_loc | |||
402 | ||||
403 | Like C<L</is_utf8_invariant_string>> but upon failure, stores the location of | |||
404 | the first UTF-8 variant character in the C<ep> pointer; if all characters are | |||
405 | UTF-8 invariant, this function does not change the contents of C<*ep>. | |||
406 | ||||
407 | =cut | |||
408 | ||||
409 | */ | |||
410 | ||||
411 | PERL_STATIC_INLINEstatic __inline__ bool_Bool | |||
412 | Perl_is_utf8_invariant_string_loc(const U8* const s, STRLEN len, const U8 ** ep) | |||
413 | { | |||
414 | const U8* send; | |||
415 | const U8* x = s; | |||
416 | ||||
417 | PERL_ARGS_ASSERT_IS_UTF8_INVARIANT_STRING_LOC((void)0); | |||
418 | ||||
419 | if (len == 0) { | |||
420 | len = strlen((const char *)s); | |||
421 | } | |||
422 | ||||
423 | send = s + len; | |||
424 | ||||
425 | /* This looks like 0x010101... */ | |||
426 | # define PERL_COUNT_MULTIPLIER (~ (UINTMAX_C(0)0ULL) / 0xFF) | |||
427 | ||||
428 | /* This looks like 0x808080... */ | |||
429 | # define PERL_VARIANTS_WORD_MASK (PERL_COUNT_MULTIPLIER * 0x80) | |||
430 | # define PERL_WORDSIZE sizeof(PERL_UINTMAX_T) | |||
431 | # define PERL_WORD_BOUNDARY_MASK (PERL_WORDSIZE - 1) | |||
432 | ||||
433 | /* Evaluates to 0 if 'x' is at a word boundary; otherwise evaluates to 1, by | |||
434 | * or'ing together the lowest bits of 'x'. Hopefully the final term gets | |||
435 | * optimized out completely on a 32-bit system, and its mask gets optimized out | |||
436 | * on a 64-bit system */ | |||
437 | # define PERL_IS_SUBWORD_ADDR(x)(1 & ( (UV)(x) | ( (UV)(x) >> 1) | ( ( ((UV)(x) & PERL_WORD_BOUNDARY_MASK) >> 2)))) (1 & ( PTR2nat(x)(UV)(x) \ | |||
438 | | ( PTR2nat(x)(UV)(x) >> 1) \ | |||
439 | | ( ( (PTR2nat(x)(UV)(x) \ | |||
440 | & PERL_WORD_BOUNDARY_MASK) >> 2)))) | |||
441 | ||||
442 | #ifndef EBCDIC | |||
443 | ||||
444 | /* Do the word-at-a-time iff there is at least one usable full word. That | |||
445 | * means that after advancing to a word boundary, there still is at least a | |||
446 | * full word left. The number of bytes needed to advance is 'wordsize - | |||
447 | * offset' unless offset is 0. */ | |||
448 | if ((STRLEN) (send - x) >= PERL_WORDSIZE | |||
449 | ||||
450 | /* This term is wordsize if subword; 0 if not */ | |||
451 | + PERL_WORDSIZE * PERL_IS_SUBWORD_ADDR(x)(1 & ( (UV)(x) | ( (UV)(x) >> 1) | ( ( ((UV)(x) & PERL_WORD_BOUNDARY_MASK) >> 2)))) | |||
452 | ||||
453 | /* 'offset' */ | |||
454 | - (PTR2nat(x)(UV)(x) & PERL_WORD_BOUNDARY_MASK)) | |||
455 | { | |||
456 | ||||
457 | /* Process per-byte until reach word boundary. XXX This loop could be | |||
458 | * eliminated if we knew that this platform had fast unaligned reads */ | |||
459 | while (PTR2nat(x)(UV)(x) & PERL_WORD_BOUNDARY_MASK) { | |||
460 | if (! UTF8_IS_INVARIANT(*x)((((U64)(((UV) (((*x) | 0) | 0)))) < (((U8) (0xFF << 6)) & 0xB0)))) { | |||
461 | if (ep) { | |||
462 | *ep = x; | |||
463 | } | |||
464 | ||||
465 | return FALSE(0); | |||
466 | } | |||
467 | x++; | |||
468 | } | |||
469 | ||||
470 | /* Here, we know we have at least one full word to process. Process | |||
471 | * per-word as long as we have at least a full word left */ | |||
472 | do { | |||
473 | if ((* (PERL_UINTMAX_T *) x) & PERL_VARIANTS_WORD_MASK) { | |||
474 | ||||
475 | /* Found a variant. Just return if caller doesn't want its | |||
476 | * exact position */ | |||
477 | if (! ep) { | |||
478 | return FALSE(0); | |||
479 | } | |||
480 | ||||
481 | # if BYTEORDER0x12345678 == 0x1234 || BYTEORDER0x12345678 == 0x12345678 \ | |||
482 | || BYTEORDER0x12345678 == 0x4321 || BYTEORDER0x12345678 == 0x87654321 | |||
483 | ||||
484 | *ep = x + variant_byte_numberPerl_variant_byte_number(* (PERL_UINTMAX_T *) x); | |||
485 | assert(*ep >= s && *ep < send)((void)0); | |||
486 | ||||
487 | return FALSE(0); | |||
488 | ||||
489 | # else /* If weird byte order, drop into next loop to do byte-at-a-time | |||
490 | checks. */ | |||
491 | ||||
492 | break; | |||
493 | # endif | |||
494 | } | |||
495 | ||||
496 | x += PERL_WORDSIZE; | |||
497 | ||||
498 | } while (x + PERL_WORDSIZE <= send); | |||
499 | } | |||
500 | ||||
501 | #endif /* End of ! EBCDIC */ | |||
502 | ||||
503 | /* Process per-byte */ | |||
504 | while (x < send) { | |||
505 | if (! UTF8_IS_INVARIANT(*x)((((U64)(((UV) (((*x) | 0) | 0)))) < (((U8) (0xFF << 6)) & 0xB0)))) { | |||
506 | if (ep) { | |||
507 | *ep = x; | |||
508 | } | |||
509 | ||||
510 | return FALSE(0); | |||
511 | } | |||
512 | ||||
513 | x++; | |||
514 | } | |||
515 | ||||
516 | return TRUE(1); | |||
517 | } | |||
518 | ||||
519 | #ifndef EBCDIC | |||
520 | ||||
521 | PERL_STATIC_INLINEstatic __inline__ unsigned int | |||
522 | Perl_variant_byte_number(PERL_UINTMAX_T word) | |||
523 | { | |||
524 | ||||
525 | /* This returns the position in a word (0..7) of the first variant byte in | |||
526 | * it. This is a helper function. Note that there are no branches */ | |||
527 | ||||
528 | assert(word)((void)0); | |||
529 | ||||
530 | /* Get just the msb bits of each byte */ | |||
531 | word &= PERL_VARIANTS_WORD_MASK; | |||
532 | ||||
533 | # if BYTEORDER0x12345678 == 0x1234 || BYTEORDER0x12345678 == 0x12345678 | |||
534 | ||||
535 | /* Bytes are stored like | |||
536 | * Byte8 ... Byte2 Byte1 | |||
537 | * 63..56...15...8 7...0 | |||
538 | * | |||
539 | * Isolate the lsb; | |||
540 | * https://stackoverflow.com/questions/757059/position-of-least-significant-bit-that-is-set | |||
541 | * | |||
542 | * The word will look like this, with a rightmost set bit in position 's': | |||
543 | * ('x's are don't cares) | |||
544 | * s | |||
545 | * x..x100..0 | |||
546 | * x..xx10..0 Right shift (rightmost 0 is shifted off) | |||
547 | * x..xx01..1 Subtract 1, turns all the trailing zeros into 1's and | |||
548 | * the 1 just to their left into a 0; the remainder is | |||
549 | * untouched | |||
550 | * 0..0011..1 The xor with the original, x..xx10..0, clears that | |||
551 | * remainder, sets the bottom to all 1 | |||
552 | * 0..0100..0 Add 1 to clear the word except for the bit in 's' | |||
553 | * | |||
554 | * Another method is to do 'word &= -word'; but it generates a compiler | |||
555 | * message on some platforms about taking the negative of an unsigned */ | |||
556 | ||||
557 | word >>= 1; | |||
558 | word = 1 + (word ^ (word - 1)); | |||
559 | ||||
560 | # elif BYTEORDER0x12345678 == 0x4321 || BYTEORDER0x12345678 == 0x87654321 | |||
561 | ||||
562 | /* Bytes are stored like | |||
563 | * Byte1 Byte2 ... Byte8 | |||
564 | * 63..56 55..47 ... 7...0 | |||
565 | * | |||
566 | * Isolate the msb; http://codeforces.com/blog/entry/10330 | |||
567 | * | |||
568 | * Only the most significant set bit matters. Or'ing word with its right | |||
569 | * shift of 1 makes that bit and the next one to its right both 1. Then | |||
570 | * right shifting by 2 makes for 4 1-bits in a row. ... We end with the | |||
571 | * msb and all to the right being 1. */ | |||
572 | word |= word >> 1; | |||
573 | word |= word >> 2; | |||
574 | word |= word >> 4; | |||
575 | word |= word >> 8; | |||
576 | word |= word >> 16; | |||
577 | word |= word >> 32; /* This should get optimized out on 32-bit systems. */ | |||
578 | ||||
579 | /* Then subtracting the right shift by 1 clears all but the left-most of | |||
580 | * the 1 bits, which is our desired result */ | |||
581 | word -= (word >> 1); | |||
582 | ||||
583 | # else | |||
584 | # error Unexpected byte order | |||
585 | # endif | |||
586 | ||||
587 | /* Here 'word' has a single bit set: the msb of the first byte in which it | |||
588 | * is set. Calculate that position in the word. We can use this | |||
589 | * specialized solution: https://stackoverflow.com/a/32339674/1626653, | |||
590 | * assumes an 8-bit byte. (On a 32-bit machine, the larger numbers should | |||
591 | * just get shifted off at compile time) */ | |||
592 | word = (word >> 7) * ((UINTMAX_C( 7)7ULL << 56) | (UINTMAX_C(15)15ULL << 48) | |||
593 | | (UINTMAX_C(23)23ULL << 40) | (UINTMAX_C(31)31ULL << 32) | |||
594 | | (39 << 24) | (47 << 16) | |||
595 | | (55 << 8) | (63 << 0)); | |||
596 | word >>= PERL_WORDSIZE * 7; /* >> by either 56 or 24 */ | |||
597 | ||||
598 | /* Here, word contains the position 7..63 of that bit. Convert to 0..7 */ | |||
599 | word = ((word + 1) >> 3) - 1; | |||
600 | ||||
601 | # if BYTEORDER0x12345678 == 0x4321 || BYTEORDER0x12345678 == 0x87654321 | |||
602 | ||||
603 | /* And invert the result */ | |||
604 | word = CHARBITS8 - word - 1; | |||
605 | ||||
606 | # endif | |||
607 | ||||
608 | return (unsigned int) word; | |||
609 | } | |||
610 | ||||
611 | #endif | |||
612 | #if defined(PERL_CORE) || defined(PERL_EXT) | |||
613 | ||||
614 | /* | |||
615 | =for apidoc variant_under_utf8_count | |||
616 | ||||
617 | This function looks at the sequence of bytes between C<s> and C<e>, which are | |||
618 | assumed to be encoded in ASCII/Latin1, and returns how many of them would | |||
619 | change should the string be translated into UTF-8. Due to the nature of UTF-8, | |||
620 | each of these would occupy two bytes instead of the single one in the input | |||
621 | string. Thus, this function returns the precise number of bytes the string | |||
622 | would expand by when translated to UTF-8. | |||
623 | ||||
624 | Unlike most of the other functions that have C<utf8> in their name, the input | |||
625 | to this function is NOT a UTF-8-encoded string. The function name is slightly | |||
626 | I<odd> to emphasize this. | |||
627 | ||||
628 | This function is internal to Perl because khw thinks that any XS code that | |||
629 | would want this is probably operating too close to the internals. Presenting a | |||
630 | valid use case could change that. | |||
631 | ||||
632 | See also | |||
633 | C<L<perlapi/is_utf8_invariant_string>> | |||
634 | and | |||
635 | C<L<perlapi/is_utf8_invariant_string_loc>>, | |||
636 | ||||
637 | =cut | |||
638 | ||||
639 | */ | |||
640 | ||||
641 | PERL_STATIC_INLINEstatic __inline__ Size_tsize_t | |||
642 | S_variant_under_utf8_count(const U8* const s, const U8* const e) | |||
643 | { | |||
644 | const U8* x = s; | |||
645 | Size_tsize_t count = 0; | |||
646 | ||||
647 | PERL_ARGS_ASSERT_VARIANT_UNDER_UTF8_COUNT; | |||
648 | ||||
649 | # ifndef EBCDIC | |||
650 | ||||
651 | /* Test if the string is long enough to use word-at-a-time. (Logic is the | |||
652 | * same as for is_utf8_invariant_string()) */ | |||
653 | if ((STRLEN) (e - x) >= PERL_WORDSIZE | |||
654 | + PERL_WORDSIZE * PERL_IS_SUBWORD_ADDR(x)(1 & ( (UV)(x) | ( (UV)(x) >> 1) | ( ( ((UV)(x) & PERL_WORD_BOUNDARY_MASK) >> 2)))) | |||
655 | - (PTR2nat(x)(UV)(x) & PERL_WORD_BOUNDARY_MASK)) | |||
656 | { | |||
657 | ||||
658 | /* Process per-byte until reach word boundary. XXX This loop could be | |||
659 | * eliminated if we knew that this platform had fast unaligned reads */ | |||
660 | while (PTR2nat(x)(UV)(x) & PERL_WORD_BOUNDARY_MASK) { | |||
661 | count += ! UTF8_IS_INVARIANT(*x++)((((U64)(((UV) (((*x++) | 0) | 0)))) < (((U8) (0xFF << 6)) & 0xB0))); | |||
662 | } | |||
663 | ||||
664 | /* Process per-word as long as we have at least a full word left */ | |||
665 | do { /* Commit 03c1e4ab1d6ee9062fb3f94b0ba31db6698724b1 contains an | |||
666 | explanation of how this works */ | |||
667 | PERL_UINTMAX_T increment | |||
668 | = ((((* (PERL_UINTMAX_T *) x) & PERL_VARIANTS_WORD_MASK) >> 7) | |||
669 | * PERL_COUNT_MULTIPLIER) | |||
670 | >> ((PERL_WORDSIZE - 1) * CHARBITS8); | |||
671 | count += (Size_tsize_t) increment; | |||
672 | x += PERL_WORDSIZE; | |||
673 | } while (x + PERL_WORDSIZE <= e); | |||
674 | } | |||
675 | ||||
676 | # endif | |||
677 | ||||
678 | /* Process per-byte */ | |||
679 | while (x < e) { | |||
680 | if (! UTF8_IS_INVARIANT(*x)((((U64)(((UV) (((*x) | 0) | 0)))) < (((U8) (0xFF << 6)) & 0xB0)))) { | |||
681 | count++; | |||
682 | } | |||
683 | ||||
684 | x++; | |||
685 | } | |||
686 | ||||
687 | return count; | |||
688 | } | |||
689 | ||||
690 | #endif | |||
691 | ||||
692 | #ifndef PERL_IN_REGEXEC_C /* Keep these around for that file */ | |||
693 | # undef PERL_WORDSIZE | |||
694 | # undef PERL_COUNT_MULTIPLIER | |||
695 | # undef PERL_WORD_BOUNDARY_MASK | |||
696 | # undef PERL_VARIANTS_WORD_MASK | |||
697 | #endif | |||
698 | ||||
699 | /* | |||
700 | =for apidoc is_utf8_string | |||
701 | ||||
702 | Returns TRUE if the first C<len> bytes of string C<s> form a valid | |||
703 | Perl-extended-UTF-8 string; returns FALSE otherwise. If C<len> is 0, it will | |||
704 | be calculated using C<strlen(s)> (which means if you use this option, that C<s> | |||
705 | can't have embedded C<NUL> characters and has to have a terminating C<NUL> | |||
706 | byte). Note that all characters being ASCII constitute 'a valid UTF-8 string'. | |||
707 | ||||
708 | This function considers Perl's extended UTF-8 to be valid. That means that | |||
709 | code points above Unicode, surrogates, and non-character code points are | |||
710 | considered valid by this function. Use C<L</is_strict_utf8_string>>, | |||
711 | C<L</is_c9strict_utf8_string>>, or C<L</is_utf8_string_flags>> to restrict what | |||
712 | code points are considered valid. | |||
713 | ||||
714 | See also | |||
715 | C<L</is_utf8_invariant_string>>, | |||
716 | C<L</is_utf8_invariant_string_loc>>, | |||
717 | C<L</is_utf8_string_loc>>, | |||
718 | C<L</is_utf8_string_loclen>>, | |||
719 | C<L</is_utf8_fixed_width_buf_flags>>, | |||
720 | C<L</is_utf8_fixed_width_buf_loc_flags>>, | |||
721 | C<L</is_utf8_fixed_width_buf_loclen_flags>>, | |||
722 | ||||
723 | =cut | |||
724 | */ | |||
725 | ||||
726 | #define is_utf8_string(s, len)Perl_is_utf8_string_loclen(s, len, ((void*)0), ((void*)0)) is_utf8_string_loclenPerl_is_utf8_string_loclen(s, len, NULL((void*)0), NULL((void*)0)) | |||
727 | ||||
728 | #if defined(PERL_CORE) || defined (PERL_EXT) | |||
729 | ||||
730 | /* | |||
731 | =for apidoc is_utf8_non_invariant_string | |||
732 | ||||
733 | Returns TRUE if L<perlapi/is_utf8_invariant_string> returns FALSE for the first | |||
734 | C<len> bytes of the string C<s>, but they are, nonetheless, legal Perl-extended | |||
735 | UTF-8; otherwise returns FALSE. | |||
736 | ||||
737 | A TRUE return means that at least one code point represented by the sequence | |||
738 | either is a wide character not representable as a single byte, or the | |||
739 | representation differs depending on whether the sequence is encoded in UTF-8 or | |||
740 | not. | |||
741 | ||||
742 | See also | |||
743 | C<L<perlapi/is_utf8_invariant_string>>, | |||
744 | C<L<perlapi/is_utf8_string>> | |||
745 | ||||
746 | =cut | |||
747 | ||||
748 | This is commonly used to determine if a SV's UTF-8 flag should be turned on. | |||
749 | It generally needn't be if its string is entirely UTF-8 invariant, and it | |||
750 | shouldn't be if it otherwise contains invalid UTF-8. | |||
751 | ||||
752 | It is an internal function because khw thinks that XS code shouldn't be working | |||
753 | at this low a level. A valid use case could change that. | |||
754 | ||||
755 | */ | |||
756 | ||||
757 | PERL_STATIC_INLINEstatic __inline__ bool_Bool | |||
758 | Perl_is_utf8_non_invariant_string(const U8* const s, STRLEN len) | |||
759 | { | |||
760 | const U8 * first_variant; | |||
761 | ||||
762 | PERL_ARGS_ASSERT_IS_UTF8_NON_INVARIANT_STRING; | |||
763 | ||||
764 | if (is_utf8_invariant_string_locPerl_is_utf8_invariant_string_loc(s, len, &first_variant)) { | |||
765 | return FALSE(0); | |||
766 | } | |||
767 | ||||
768 | return is_utf8_string(first_variant, len - (first_variant - s))Perl_is_utf8_string_loclen(first_variant, len - (first_variant - s), ((void*)0), ((void*)0)); | |||
769 | } | |||
770 | ||||
771 | #endif | |||
772 | ||||
773 | /* | |||
774 | =for apidoc is_strict_utf8_string | |||
775 | ||||
776 | Returns TRUE if the first C<len> bytes of string C<s> form a valid | |||
777 | UTF-8-encoded string that is fully interchangeable by any application using | |||
778 | Unicode rules; otherwise it returns FALSE. If C<len> is 0, it will be | |||
779 | calculated using C<strlen(s)> (which means if you use this option, that C<s> | |||
780 | can't have embedded C<NUL> characters and has to have a terminating C<NUL> | |||
781 | byte). Note that all characters being ASCII constitute 'a valid UTF-8 string'. | |||
782 | ||||
783 | This function returns FALSE for strings containing any | |||
784 | code points above the Unicode max of 0x10FFFF, surrogate code points, or | |||
785 | non-character code points. | |||
786 | ||||
787 | See also | |||
788 | C<L</is_utf8_invariant_string>>, | |||
789 | C<L</is_utf8_invariant_string_loc>>, | |||
790 | C<L</is_utf8_string>>, | |||
791 | C<L</is_utf8_string_flags>>, | |||
792 | C<L</is_utf8_string_loc>>, | |||
793 | C<L</is_utf8_string_loc_flags>>, | |||
794 | C<L</is_utf8_string_loclen>>, | |||
795 | C<L</is_utf8_string_loclen_flags>>, | |||
796 | C<L</is_utf8_fixed_width_buf_flags>>, | |||
797 | C<L</is_utf8_fixed_width_buf_loc_flags>>, | |||
798 | C<L</is_utf8_fixed_width_buf_loclen_flags>>, | |||
799 | C<L</is_strict_utf8_string_loc>>, | |||
800 | C<L</is_strict_utf8_string_loclen>>, | |||
801 | C<L</is_c9strict_utf8_string>>, | |||
802 | C<L</is_c9strict_utf8_string_loc>>, | |||
803 | and | |||
804 | C<L</is_c9strict_utf8_string_loclen>>. | |||
805 | ||||
806 | =cut | |||
807 | */ | |||
808 | ||||
809 | #define is_strict_utf8_string(s, len)Perl_is_strict_utf8_string_loclen(s, len, ((void*)0), ((void* )0)) is_strict_utf8_string_loclenPerl_is_strict_utf8_string_loclen(s, len, NULL((void*)0), NULL((void*)0)) | |||
810 | ||||
811 | /* | |||
812 | =for apidoc is_c9strict_utf8_string | |||
813 | ||||
814 | Returns TRUE if the first C<len> bytes of string C<s> form a valid | |||
815 | UTF-8-encoded string that conforms to | |||
816 | L<Unicode Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>; | |||
817 | otherwise it returns FALSE. If C<len> is 0, it will be calculated using | |||
818 | C<strlen(s)> (which means if you use this option, that C<s> can't have embedded | |||
819 | C<NUL> characters and has to have a terminating C<NUL> byte). Note that all | |||
820 | characters being ASCII constitute 'a valid UTF-8 string'. | |||
821 | ||||
822 | This function returns FALSE for strings containing any code points above the | |||
823 | Unicode max of 0x10FFFF or surrogate code points, but accepts non-character | |||
824 | code points per | |||
825 | L<Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>. | |||
826 | ||||
827 | See also | |||
828 | C<L</is_utf8_invariant_string>>, | |||
829 | C<L</is_utf8_invariant_string_loc>>, | |||
830 | C<L</is_utf8_string>>, | |||
831 | C<L</is_utf8_string_flags>>, | |||
832 | C<L</is_utf8_string_loc>>, | |||
833 | C<L</is_utf8_string_loc_flags>>, | |||
834 | C<L</is_utf8_string_loclen>>, | |||
835 | C<L</is_utf8_string_loclen_flags>>, | |||
836 | C<L</is_utf8_fixed_width_buf_flags>>, | |||
837 | C<L</is_utf8_fixed_width_buf_loc_flags>>, | |||
838 | C<L</is_utf8_fixed_width_buf_loclen_flags>>, | |||
839 | C<L</is_strict_utf8_string>>, | |||
840 | C<L</is_strict_utf8_string_loc>>, | |||
841 | C<L</is_strict_utf8_string_loclen>>, | |||
842 | C<L</is_c9strict_utf8_string_loc>>, | |||
843 | and | |||
844 | C<L</is_c9strict_utf8_string_loclen>>. | |||
845 | ||||
846 | =cut | |||
847 | */ | |||
848 | ||||
849 | #define is_c9strict_utf8_string(s, len)Perl_is_c9strict_utf8_string_loclen(s, len, ((void*)0), 0) is_c9strict_utf8_string_loclenPerl_is_c9strict_utf8_string_loclen(s, len, NULL((void*)0), 0) | |||
850 | ||||
851 | /* | |||
852 | =for apidoc is_utf8_string_flags | |||
853 | ||||
854 | Returns TRUE if the first C<len> bytes of string C<s> form a valid | |||
855 | UTF-8 string, subject to the restrictions imposed by C<flags>; | |||
856 | returns FALSE otherwise. If C<len> is 0, it will be calculated | |||
857 | using C<strlen(s)> (which means if you use this option, that C<s> can't have | |||
858 | embedded C<NUL> characters and has to have a terminating C<NUL> byte). Note | |||
859 | that all characters being ASCII constitute 'a valid UTF-8 string'. | |||
860 | ||||
861 | If C<flags> is 0, this gives the same results as C<L</is_utf8_string>>; if | |||
862 | C<flags> is C<UTF8_DISALLOW_ILLEGAL_INTERCHANGE>, this gives the same results | |||
863 | as C<L</is_strict_utf8_string>>; and if C<flags> is | |||
864 | C<UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE>, this gives the same results as | |||
865 | C<L</is_c9strict_utf8_string>>. Otherwise C<flags> may be any | |||
866 | combination of the C<UTF8_DISALLOW_I<foo>> flags understood by | |||
867 | C<L</utf8n_to_uvchr>>, with the same meanings. | |||
868 | ||||
869 | See also | |||
870 | C<L</is_utf8_invariant_string>>, | |||
871 | C<L</is_utf8_invariant_string_loc>>, | |||
872 | C<L</is_utf8_string>>, | |||
873 | C<L</is_utf8_string_loc>>, | |||
874 | C<L</is_utf8_string_loc_flags>>, | |||
875 | C<L</is_utf8_string_loclen>>, | |||
876 | C<L</is_utf8_string_loclen_flags>>, | |||
877 | C<L</is_utf8_fixed_width_buf_flags>>, | |||
878 | C<L</is_utf8_fixed_width_buf_loc_flags>>, | |||
879 | C<L</is_utf8_fixed_width_buf_loclen_flags>>, | |||
880 | C<L</is_strict_utf8_string>>, | |||
881 | C<L</is_strict_utf8_string_loc>>, | |||
882 | C<L</is_strict_utf8_string_loclen>>, | |||
883 | C<L</is_c9strict_utf8_string>>, | |||
884 | C<L</is_c9strict_utf8_string_loc>>, | |||
885 | and | |||
886 | C<L</is_c9strict_utf8_string_loclen>>. | |||
887 | ||||
888 | =cut | |||
889 | */ | |||
890 | ||||
891 | PERL_STATIC_INLINEstatic __inline__ bool_Bool | |||
892 | Perl_is_utf8_string_flags(const U8 *s, STRLEN len, const U32 flags) | |||
893 | { | |||
894 | const U8 * first_variant; | |||
895 | ||||
896 | PERL_ARGS_ASSERT_IS_UTF8_STRING_FLAGS((void)0); | |||
897 | assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE((void)0) | |||
898 | |UTF8_DISALLOW_PERL_EXTENDED)))((void)0); | |||
899 | ||||
900 | if (len == 0) { | |||
901 | len = strlen((const char *)s); | |||
902 | } | |||
903 | ||||
904 | if (flags == 0) { | |||
905 | return is_utf8_string(s, len)Perl_is_utf8_string_loclen(s, len, ((void*)0), ((void*)0)); | |||
906 | } | |||
907 | ||||
908 | if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED0x4000) | |||
909 | == UTF8_DISALLOW_ILLEGAL_INTERCHANGE((0x1000|0x0100)|0x0400)) | |||
910 | { | |||
911 | return is_strict_utf8_string(s, len)Perl_is_strict_utf8_string_loclen(s, len, ((void*)0), ((void* )0)); | |||
912 | } | |||
913 | ||||
914 | if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED0x4000) | |||
915 | == UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE(0x1000|0x0100)) | |||
916 | { | |||
917 | return is_c9strict_utf8_string(s, len)Perl_is_c9strict_utf8_string_loclen(s, len, ((void*)0), 0); | |||
918 | } | |||
919 | ||||
920 | if (! is_utf8_invariant_string_locPerl_is_utf8_invariant_string_loc(s, len, &first_variant)) { | |||
921 | const U8* const send = s + len; | |||
922 | const U8* x = first_variant; | |||
923 | ||||
924 | while (x < send) { | |||
925 | STRLEN cur_len = isUTF8_CHAR_flags(x, send, flags)(__builtin_expect((((send) <= (x)) ? (_Bool)1 : (_Bool)0), (0)) ? 0 : (((((U64)(((UV) (((*x) | 0) | 0)))) < (((U8) (0xFF << 6)) & 0xB0)))) ? 1 : __builtin_expect(((((send) - (x)) < PL_utf8skip[*(const U8*)(x)]) ? (_Bool)1 : (_Bool )0),(0)) ? 0 : Perl_is_utf8_char_helper(x, send, flags)); | |||
926 | if (UNLIKELY(! cur_len)__builtin_expect(((! cur_len) ? (_Bool)1 : (_Bool)0),(0))) { | |||
927 | return FALSE(0); | |||
928 | } | |||
929 | x += cur_len; | |||
930 | } | |||
931 | } | |||
932 | ||||
933 | return TRUE(1); | |||
934 | } | |||
935 | ||||
936 | /* | |||
937 | ||||
938 | =for apidoc is_utf8_string_loc | |||
939 | ||||
940 | Like C<L</is_utf8_string>> but stores the location of the failure (in the | |||
941 | case of "utf8ness failure") or the location C<s>+C<len> (in the case of | |||
942 | "utf8ness success") in the C<ep> pointer. | |||
943 | ||||
944 | See also C<L</is_utf8_string_loclen>>. | |||
945 | ||||
946 | =cut | |||
947 | */ | |||
948 | ||||
949 | #define is_utf8_string_loc(s, len, ep)Perl_is_utf8_string_loclen(s, len, ep, 0) is_utf8_string_loclenPerl_is_utf8_string_loclen(s, len, ep, 0) | |||
950 | ||||
951 | /* | |||
952 | ||||
953 | =for apidoc is_utf8_string_loclen | |||
954 | ||||
955 | Like C<L</is_utf8_string>> but stores the location of the failure (in the | |||
956 | case of "utf8ness failure") or the location C<s>+C<len> (in the case of | |||
957 | "utf8ness success") in the C<ep> pointer, and the number of UTF-8 | |||
958 | encoded characters in the C<el> pointer. | |||
959 | ||||
960 | See also C<L</is_utf8_string_loc>>. | |||
961 | ||||
962 | =cut | |||
963 | */ | |||
964 | ||||
965 | PERL_STATIC_INLINEstatic __inline__ bool_Bool | |||
966 | Perl_is_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el) | |||
967 | { | |||
968 | const U8 * first_variant; | |||
969 | ||||
970 | PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN((void)0); | |||
971 | ||||
972 | if (len == 0) { | |||
973 | len = strlen((const char *) s); | |||
974 | } | |||
975 | ||||
976 | if (is_utf8_invariant_string_locPerl_is_utf8_invariant_string_loc(s, len, &first_variant)) { | |||
977 | if (el) | |||
978 | *el = len; | |||
979 | ||||
980 | if (ep) { | |||
981 | *ep = s + len; | |||
982 | } | |||
983 | ||||
984 | return TRUE(1); | |||
985 | } | |||
986 | ||||
987 | { | |||
988 | const U8* const send = s + len; | |||
989 | const U8* x = first_variant; | |||
990 | STRLEN outlen = first_variant - s; | |||
991 | ||||
992 | while (x < send) { | |||
993 | const STRLEN cur_len = isUTF8_CHARPerl_isUTF8_CHAR(x, send); | |||
994 | if (UNLIKELY(! cur_len)__builtin_expect(((! cur_len) ? (_Bool)1 : (_Bool)0),(0))) { | |||
995 | break; | |||
996 | } | |||
997 | x += cur_len; | |||
998 | outlen++; | |||
999 | } | |||
1000 | ||||
1001 | if (el) | |||
1002 | *el = outlen; | |||
1003 | ||||
1004 | if (ep) { | |||
1005 | *ep = x; | |||
1006 | } | |||
1007 | ||||
1008 | return (x == send); | |||
1009 | } | |||
1010 | } | |||
1011 | ||||
1012 | /* | |||
1013 | ||||
1014 | =for apidoc isUTF8_CHAR | |||
1015 | ||||
1016 | Evaluates to non-zero if the first few bytes of the string starting at C<s> and | |||
1017 | looking no further than S<C<e - 1>> are well-formed UTF-8, as extended by Perl, | |||
1018 | that represents some code point; otherwise it evaluates to 0. If non-zero, the | |||
1019 | value gives how many bytes starting at C<s> comprise the code point's | |||
1020 | representation. Any bytes remaining before C<e>, but beyond the ones needed to | |||
1021 | form the first code point in C<s>, are not examined. | |||
1022 | ||||
1023 | The code point can be any that will fit in an IV on this machine, using Perl's | |||
1024 | extension to official UTF-8 to represent those higher than the Unicode maximum | |||
1025 | of 0x10FFFF. That means that this macro is used to efficiently decide if the | |||
1026 | next few bytes in C<s> is legal UTF-8 for a single character. | |||
1027 | ||||
1028 | Use C<L</isSTRICT_UTF8_CHAR>> to restrict the acceptable code points to those | |||
1029 | defined by Unicode to be fully interchangeable across applications; | |||
1030 | C<L</isC9_STRICT_UTF8_CHAR>> to use the L<Unicode Corrigendum | |||
1031 | #9|http://www.unicode.org/versions/corrigendum9.html> definition of allowable | |||
1032 | code points; and C<L</isUTF8_CHAR_flags>> for a more customized definition. | |||
1033 | ||||
1034 | Use C<L</is_utf8_string>>, C<L</is_utf8_string_loc>>, and | |||
1035 | C<L</is_utf8_string_loclen>> to check entire strings. | |||
1036 | ||||
1037 | Note also that a UTF-8 "invariant" character (i.e. ASCII on non-EBCDIC | |||
1038 | machines) is a valid UTF-8 character. | |||
1039 | ||||
1040 | =cut | |||
1041 | ||||
1042 | This uses an adaptation of the table and algorithm given in | |||
1043 | https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive | |||
1044 | documentation of the original version. A copyright notice for the original | |||
1045 | version is given at the beginning of this file. The Perl adapation is | |||
1046 | documented at the definition of PL_extended_utf8_dfa_tab[]. | |||
1047 | ||||
1048 | */ | |||
1049 | ||||
1050 | PERL_STATIC_INLINEstatic __inline__ Size_tsize_t | |||
1051 | Perl_isUTF8_CHAR(const U8 * const s0, const U8 * const e) | |||
1052 | { | |||
1053 | const U8 * s = s0; | |||
1054 | UV state = 0; | |||
1055 | ||||
1056 | PERL_ARGS_ASSERT_ISUTF8_CHAR((void)0); ((void)0); | |||
1057 | ||||
1058 | /* This dfa is fast. If it accepts the input, it was for a well-formed, | |||
1059 | * code point, which can be returned immediately. Otherwise, it is either | |||
1060 | * malformed, or for the start byte FF which the dfa doesn't handle (except | |||
1061 | * on 32-bit ASCII platforms where it trivially is an error). Call a | |||
1062 | * helper function for the other platforms. */ | |||
1063 | ||||
1064 | while (s < e && LIKELY(state != 1)__builtin_expect(((state != 1) ? (_Bool)1 : (_Bool)0),(1))) { | |||
1065 | state = PL_extended_utf8_dfa_tab[256 | |||
1066 | + state | |||
1067 | + PL_extended_utf8_dfa_tab[*s]]; | |||
1068 | if (state != 0) { | |||
1069 | s++; | |||
1070 | continue; | |||
1071 | } | |||
1072 | ||||
1073 | return s - s0 + 1; | |||
1074 | } | |||
1075 | ||||
1076 | #if defined(UV_IS_QUAD) || defined(EBCDIC) | |||
1077 | ||||
1078 | if (NATIVE_UTF8_TO_I8(*s0)( ((U8) ((*s0) | 0))) == 0xFF && e - s0 >= UTF8_MAXBYTES13) { | |||
1079 | return is_utf8_char_helperPerl_is_utf8_char_helper(s0, e, 0); | |||
1080 | } | |||
1081 | ||||
1082 | #endif | |||
1083 | ||||
1084 | return 0; | |||
1085 | } | |||
1086 | ||||
1087 | /* | |||
1088 | ||||
1089 | =for apidoc isSTRICT_UTF8_CHAR | |||
1090 | ||||
1091 | Evaluates to non-zero if the first few bytes of the string starting at C<s> and | |||
1092 | looking no further than S<C<e - 1>> are well-formed UTF-8 that represents some | |||
1093 | Unicode code point completely acceptable for open interchange between all | |||
1094 | applications; otherwise it evaluates to 0. If non-zero, the value gives how | |||
1095 | many bytes starting at C<s> comprise the code point's representation. Any | |||
1096 | bytes remaining before C<e>, but beyond the ones needed to form the first code | |||
1097 | point in C<s>, are not examined. | |||
1098 | ||||
1099 | The largest acceptable code point is the Unicode maximum 0x10FFFF, and must not | |||
1100 | be a surrogate nor a non-character code point. Thus this excludes any code | |||
1101 | point from Perl's extended UTF-8. | |||
1102 | ||||
1103 | This is used to efficiently decide if the next few bytes in C<s> is | |||
1104 | legal Unicode-acceptable UTF-8 for a single character. | |||
1105 | ||||
1106 | Use C<L</isC9_STRICT_UTF8_CHAR>> to use the L<Unicode Corrigendum | |||
1107 | #9|http://www.unicode.org/versions/corrigendum9.html> definition of allowable | |||
1108 | code points; C<L</isUTF8_CHAR>> to check for Perl's extended UTF-8; | |||
1109 | and C<L</isUTF8_CHAR_flags>> for a more customized definition. | |||
1110 | ||||
1111 | Use C<L</is_strict_utf8_string>>, C<L</is_strict_utf8_string_loc>>, and | |||
1112 | C<L</is_strict_utf8_string_loclen>> to check entire strings. | |||
1113 | ||||
1114 | =cut | |||
1115 | ||||
1116 | This uses an adaptation of the tables and algorithm given in | |||
1117 | https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive | |||
1118 | documentation of the original version. A copyright notice for the original | |||
1119 | version is given at the beginning of this file. The Perl adapation is | |||
1120 | documented at the definition of strict_extended_utf8_dfa_tab[]. | |||
1121 | ||||
1122 | */ | |||
1123 | ||||
1124 | PERL_STATIC_INLINEstatic __inline__ Size_tsize_t | |||
1125 | Perl_isSTRICT_UTF8_CHAR(const U8 * const s0, const U8 * const e) | |||
1126 | { | |||
1127 | const U8 * s = s0; | |||
1128 | UV state = 0; | |||
1129 | ||||
1130 | PERL_ARGS_ASSERT_ISSTRICT_UTF8_CHAR((void)0); ((void)0); | |||
1131 | ||||
1132 | while (s < e && LIKELY(state != 1)__builtin_expect(((state != 1) ? (_Bool)1 : (_Bool)0),(1))) { | |||
1133 | state = PL_strict_utf8_dfa_tab[256 + state + PL_strict_utf8_dfa_tab[*s]]; | |||
1134 | ||||
1135 | if (state != 0) { | |||
1136 | s++; | |||
1137 | continue; | |||
1138 | } | |||
1139 | ||||
1140 | return s - s0 + 1; | |||
1141 | } | |||
1142 | ||||
1143 | #ifndef EBCDIC | |||
1144 | ||||
1145 | /* The dfa above drops out for certain Hanguls; handle them specially */ | |||
1146 | if (is_HANGUL_ED_utf8_safe(s0, e)( ( ( ( ( ((e) - (s0)) >= 3 ) && ( 0xED == ((const U8*)s0)[0] ) ) && ( ( ( (sizeof(((const U8*)s0)[1]) == sizeof(U8)) ? ( (((U64) (((((U8) (((const U8*)s0)[1])))) - ( ((0x80)) | 0))) <= (((U64) ((((0x9F) - (0x80))) | 0))))) : (sizeof(((const U8*)s0)[1]) == sizeof(U32)) ? ( (((U64) (((( (U32) (((const U8*)s0)[1])))) - (((0x80)) | 0))) <= (((U64 ) ((((0x9F) - (0x80))) | 0))))) : ( ( (((U64) (((((U64) (((const U8*)s0)[1])))) - (((0x80)) | 0))) <= (((U64) ((((0x9F) - ( 0x80))) | 0)))))))) ) ) && ( ( ( (sizeof(((const U8*) s0)[2]) == sizeof(U8)) ? ( (((U64) (((((U8) (((const U8*)s0)[ 2])))) - (((0x80)) | 0))) <= (((U64) ((((0xBF) - (0x80))) | 0))))) : (sizeof(((const U8*)s0)[2]) == sizeof(U32)) ? ( ((( U64) (((((U32) (((const U8*)s0)[2])))) - (((0x80)) | 0))) <= (((U64) ((((0xBF) - (0x80))) | 0))))) : ( ( (((U64) (((((U64 ) (((const U8*)s0)[2])))) - (((0x80)) | 0))) <= (((U64) (( ((0xBF) - (0x80))) | 0)))))))) ) ) ? 3 : 0 )) { | |||
1147 | return 3; | |||
1148 | } | |||
1149 | ||||
1150 | #endif | |||
1151 | ||||
1152 | return 0; | |||
1153 | } | |||
1154 | ||||
1155 | /* | |||
1156 | ||||
1157 | =for apidoc isC9_STRICT_UTF8_CHAR | |||
1158 | ||||
1159 | Evaluates to non-zero if the first few bytes of the string starting at C<s> and | |||
1160 | looking no further than S<C<e - 1>> are well-formed UTF-8 that represents some | |||
1161 | Unicode non-surrogate code point; otherwise it evaluates to 0. If non-zero, | |||
1162 | the value gives how many bytes starting at C<s> comprise the code point's | |||
1163 | representation. Any bytes remaining before C<e>, but beyond the ones needed to | |||
1164 | form the first code point in C<s>, are not examined. | |||
1165 | ||||
1166 | The largest acceptable code point is the Unicode maximum 0x10FFFF. This | |||
1167 | differs from C<L</isSTRICT_UTF8_CHAR>> only in that it accepts non-character | |||
1168 | code points. This corresponds to | |||
1169 | L<Unicode Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>. | |||
1170 | which said that non-character code points are merely discouraged rather than | |||
1171 | completely forbidden in open interchange. See | |||
1172 | L<perlunicode/Noncharacter code points>. | |||
1173 | ||||
1174 | Use C<L</isUTF8_CHAR>> to check for Perl's extended UTF-8; and | |||
1175 | C<L</isUTF8_CHAR_flags>> for a more customized definition. | |||
1176 | ||||
1177 | Use C<L</is_c9strict_utf8_string>>, C<L</is_c9strict_utf8_string_loc>>, and | |||
1178 | C<L</is_c9strict_utf8_string_loclen>> to check entire strings. | |||
1179 | ||||
1180 | =cut | |||
1181 | ||||
1182 | This uses an adaptation of the tables and algorithm given in | |||
1183 | https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive | |||
1184 | documentation of the original version. A copyright notice for the original | |||
1185 | version is given at the beginning of this file. The Perl adapation is | |||
1186 | documented at the definition of PL_c9_utf8_dfa_tab[]. | |||
1187 | ||||
1188 | */ | |||
1189 | ||||
1190 | PERL_STATIC_INLINEstatic __inline__ Size_tsize_t | |||
1191 | Perl_isC9_STRICT_UTF8_CHAR(const U8 * const s0, const U8 * const e) | |||
1192 | { | |||
1193 | const U8 * s = s0; | |||
1194 | UV state = 0; | |||
1195 | ||||
1196 | PERL_ARGS_ASSERT_ISC9_STRICT_UTF8_CHAR((void)0); ((void)0); | |||
1197 | ||||
1198 | while (s < e && LIKELY(state != 1)__builtin_expect(((state != 1) ? (_Bool)1 : (_Bool)0),(1))) { | |||
1199 | state = PL_c9_utf8_dfa_tab[256 + state + PL_c9_utf8_dfa_tab[*s]]; | |||
1200 | ||||
1201 | if (state != 0) { | |||
1202 | s++; | |||
1203 | continue; | |||
1204 | } | |||
1205 | ||||
1206 | return s - s0 + 1; | |||
1207 | } | |||
1208 | ||||
1209 | return 0; | |||
1210 | } | |||
1211 | ||||
1212 | /* | |||
1213 | ||||
1214 | =for apidoc is_strict_utf8_string_loc | |||
1215 | ||||
1216 | Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the | |||
1217 | case of "utf8ness failure") or the location C<s>+C<len> (in the case of | |||
1218 | "utf8ness success") in the C<ep> pointer. | |||
1219 | ||||
1220 | See also C<L</is_strict_utf8_string_loclen>>. | |||
1221 | ||||
1222 | =cut | |||
1223 | */ | |||
1224 | ||||
1225 | #define is_strict_utf8_string_loc(s, len, ep)Perl_is_strict_utf8_string_loclen(s, len, ep, 0) \ | |||
1226 | is_strict_utf8_string_loclenPerl_is_strict_utf8_string_loclen(s, len, ep, 0) | |||
1227 | ||||
1228 | /* | |||
1229 | ||||
1230 | =for apidoc is_strict_utf8_string_loclen | |||
1231 | ||||
1232 | Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the | |||
1233 | case of "utf8ness failure") or the location C<s>+C<len> (in the case of | |||
1234 | "utf8ness success") in the C<ep> pointer, and the number of UTF-8 | |||
1235 | encoded characters in the C<el> pointer. | |||
1236 | ||||
1237 | See also C<L</is_strict_utf8_string_loc>>. | |||
1238 | ||||
1239 | =cut | |||
1240 | */ | |||
1241 | ||||
1242 | PERL_STATIC_INLINEstatic __inline__ bool_Bool | |||
1243 | Perl_is_strict_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el) | |||
1244 | { | |||
1245 | const U8 * first_variant; | |||
1246 | ||||
1247 | PERL_ARGS_ASSERT_IS_STRICT_UTF8_STRING_LOCLEN((void)0); | |||
1248 | ||||
1249 | if (len == 0) { | |||
1250 | len = strlen((const char *) s); | |||
1251 | } | |||
1252 | ||||
1253 | if (is_utf8_invariant_string_locPerl_is_utf8_invariant_string_loc(s, len, &first_variant)) { | |||
1254 | if (el) | |||
1255 | *el = len; | |||
1256 | ||||
1257 | if (ep) { | |||
1258 | *ep = s + len; | |||
1259 | } | |||
1260 | ||||
1261 | return TRUE(1); | |||
1262 | } | |||
1263 | ||||
1264 | { | |||
1265 | const U8* const send = s + len; | |||
1266 | const U8* x = first_variant; | |||
1267 | STRLEN outlen = first_variant - s; | |||
1268 | ||||
1269 | while (x < send) { | |||
1270 | const STRLEN cur_len = isSTRICT_UTF8_CHARPerl_isSTRICT_UTF8_CHAR(x, send); | |||
1271 | if (UNLIKELY(! cur_len)__builtin_expect(((! cur_len) ? (_Bool)1 : (_Bool)0),(0))) { | |||
1272 | break; | |||
1273 | } | |||
1274 | x += cur_len; | |||
1275 | outlen++; | |||
1276 | } | |||
1277 | ||||
1278 | if (el) | |||
1279 | *el = outlen; | |||
1280 | ||||
1281 | if (ep) { | |||
1282 | *ep = x; | |||
1283 | } | |||
1284 | ||||
1285 | return (x == send); | |||
1286 | } | |||
1287 | } | |||
1288 | ||||
1289 | /* | |||
1290 | ||||
1291 | =for apidoc is_c9strict_utf8_string_loc | |||
1292 | ||||
1293 | Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in | |||
1294 | the case of "utf8ness failure") or the location C<s>+C<len> (in the case of | |||
1295 | "utf8ness success") in the C<ep> pointer. | |||
1296 | ||||
1297 | See also C<L</is_c9strict_utf8_string_loclen>>. | |||
1298 | ||||
1299 | =cut | |||
1300 | */ | |||
1301 | ||||
1302 | #define is_c9strict_utf8_string_loc(s, len, ep)Perl_is_c9strict_utf8_string_loclen(s, len, ep, 0) \ | |||
1303 | is_c9strict_utf8_string_loclenPerl_is_c9strict_utf8_string_loclen(s, len, ep, 0) | |||
1304 | ||||
1305 | /* | |||
1306 | ||||
1307 | =for apidoc is_c9strict_utf8_string_loclen | |||
1308 | ||||
1309 | Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in | |||
1310 | the case of "utf8ness failure") or the location C<s>+C<len> (in the case of | |||
1311 | "utf8ness success") in the C<ep> pointer, and the number of UTF-8 encoded | |||
1312 | characters in the C<el> pointer. | |||
1313 | ||||
1314 | See also C<L</is_c9strict_utf8_string_loc>>. | |||
1315 | ||||
1316 | =cut | |||
1317 | */ | |||
1318 | ||||
1319 | PERL_STATIC_INLINEstatic __inline__ bool_Bool | |||
1320 | Perl_is_c9strict_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el) | |||
1321 | { | |||
1322 | const U8 * first_variant; | |||
1323 | ||||
1324 | PERL_ARGS_ASSERT_IS_C9STRICT_UTF8_STRING_LOCLEN((void)0); | |||
1325 | ||||
1326 | if (len == 0) { | |||
1327 | len = strlen((const char *) s); | |||
1328 | } | |||
1329 | ||||
1330 | if (is_utf8_invariant_string_locPerl_is_utf8_invariant_string_loc(s, len, &first_variant)) { | |||
1331 | if (el) | |||
1332 | *el = len; | |||
1333 | ||||
1334 | if (ep) { | |||
1335 | *ep = s + len; | |||
1336 | } | |||
1337 | ||||
1338 | return TRUE(1); | |||
1339 | } | |||
1340 | ||||
1341 | { | |||
1342 | const U8* const send = s + len; | |||
1343 | const U8* x = first_variant; | |||
1344 | STRLEN outlen = first_variant - s; | |||
1345 | ||||
1346 | while (x < send) { | |||
1347 | const STRLEN cur_len = isC9_STRICT_UTF8_CHARPerl_isC9_STRICT_UTF8_CHAR(x, send); | |||
1348 | if (UNLIKELY(! cur_len)__builtin_expect(((! cur_len) ? (_Bool)1 : (_Bool)0),(0))) { | |||
1349 | break; | |||
1350 | } | |||
1351 | x += cur_len; | |||
1352 | outlen++; | |||
1353 | } | |||
1354 | ||||
1355 | if (el) | |||
1356 | *el = outlen; | |||
1357 | ||||
1358 | if (ep) { | |||
1359 | *ep = x; | |||
1360 | } | |||
1361 | ||||
1362 | return (x == send); | |||
1363 | } | |||
1364 | } | |||
1365 | ||||
1366 | /* | |||
1367 | ||||
1368 | =for apidoc is_utf8_string_loc_flags | |||
1369 | ||||
1370 | Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the | |||
1371 | case of "utf8ness failure") or the location C<s>+C<len> (in the case of | |||
1372 | "utf8ness success") in the C<ep> pointer. | |||
1373 | ||||
1374 | See also C<L</is_utf8_string_loclen_flags>>. | |||
1375 | ||||
1376 | =cut | |||
1377 | */ | |||
1378 | ||||
1379 | #define is_utf8_string_loc_flags(s, len, ep, flags)Perl_is_utf8_string_loclen_flags(s, len, ep, 0, flags) \ | |||
1380 | is_utf8_string_loclen_flagsPerl_is_utf8_string_loclen_flags(s, len, ep, 0, flags) | |||
1381 | ||||
1382 | ||||
1383 | /* The above 3 actual functions could have been moved into the more general one | |||
1384 | * just below, and made #defines that call it with the right 'flags'. They are | |||
1385 | * currently kept separate to increase their chances of getting inlined */ | |||
1386 | ||||
1387 | /* | |||
1388 | ||||
1389 | =for apidoc is_utf8_string_loclen_flags | |||
1390 | ||||
1391 | Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the | |||
1392 | case of "utf8ness failure") or the location C<s>+C<len> (in the case of | |||
1393 | "utf8ness success") in the C<ep> pointer, and the number of UTF-8 | |||
1394 | encoded characters in the C<el> pointer. | |||
1395 | ||||
1396 | See also C<L</is_utf8_string_loc_flags>>. | |||
1397 | ||||
1398 | =cut | |||
1399 | */ | |||
1400 | ||||
1401 | PERL_STATIC_INLINEstatic __inline__ bool_Bool | |||
1402 | Perl_is_utf8_string_loclen_flags(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el, const U32 flags) | |||
1403 | { | |||
1404 | const U8 * first_variant; | |||
1405 | ||||
1406 | PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN_FLAGS((void)0); | |||
1407 | assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE((void)0) | |||
1408 | |UTF8_DISALLOW_PERL_EXTENDED)))((void)0); | |||
1409 | ||||
1410 | if (len == 0) { | |||
1411 | len = strlen((const char *) s); | |||
| ||||
1412 | } | |||
1413 | ||||
1414 | if (flags == 0) { | |||
1415 | return is_utf8_string_loclenPerl_is_utf8_string_loclen(s, len, ep, el); | |||
1416 | } | |||
1417 | ||||
1418 | if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED0x4000) | |||
1419 | == UTF8_DISALLOW_ILLEGAL_INTERCHANGE((0x1000|0x0100)|0x0400)) | |||
1420 | { | |||
1421 | return is_strict_utf8_string_loclenPerl_is_strict_utf8_string_loclen(s, len, ep, el); | |||
1422 | } | |||
1423 | ||||
1424 | if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED0x4000) | |||
1425 | == UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE(0x1000|0x0100)) | |||
1426 | { | |||
1427 | return is_c9strict_utf8_string_loclenPerl_is_c9strict_utf8_string_loclen(s, len, ep, el); | |||
1428 | } | |||
1429 | ||||
1430 | if (is_utf8_invariant_string_locPerl_is_utf8_invariant_string_loc(s, len, &first_variant)) { | |||
1431 | if (el) | |||
1432 | *el = len; | |||
1433 | ||||
1434 | if (ep) { | |||
1435 | *ep = s + len; | |||
1436 | } | |||
1437 | ||||
1438 | return TRUE(1); | |||
1439 | } | |||
1440 | ||||
1441 | { | |||
1442 | const U8* send = s + len; | |||
1443 | const U8* x = first_variant; | |||
1444 | STRLEN outlen = first_variant - s; | |||
1445 | ||||
1446 | while (x < send) { | |||
1447 | const STRLEN cur_len = isUTF8_CHAR_flags(x, send, flags)(__builtin_expect((((send) <= (x)) ? (_Bool)1 : (_Bool)0), (0)) ? 0 : (((((U64)(((UV) (((*x) | 0) | 0)))) < (((U8) (0xFF << 6)) & 0xB0)))) ? 1 : __builtin_expect(((((send) - (x)) < PL_utf8skip[*(const U8*)(x)]) ? (_Bool)1 : (_Bool )0),(0)) ? 0 : Perl_is_utf8_char_helper(x, send, flags)); | |||
1448 | if (UNLIKELY(! cur_len)__builtin_expect(((! cur_len) ? (_Bool)1 : (_Bool)0),(0))) { | |||
1449 | break; | |||
1450 | } | |||
1451 | x += cur_len; | |||
1452 | outlen++; | |||
1453 | } | |||
1454 | ||||
1455 | if (el) | |||
1456 | *el = outlen; | |||
1457 | ||||
1458 | if (ep) { | |||
1459 | *ep = x; | |||
1460 | } | |||
1461 | ||||
1462 | return (x == send); | |||
1463 | } | |||
1464 | } | |||
1465 | ||||
1466 | /* | |||
1467 | =for apidoc utf8_distance | |||
1468 | ||||
1469 | Returns the number of UTF-8 characters between the UTF-8 pointers C<a> | |||
1470 | and C<b>. | |||
1471 | ||||
1472 | WARNING: use only if you *know* that the pointers point inside the | |||
1473 | same UTF-8 buffer. | |||
1474 | ||||
1475 | =cut | |||
1476 | */ | |||
1477 | ||||
1478 | PERL_STATIC_INLINEstatic __inline__ IV | |||
1479 | Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b) | |||
1480 | { | |||
1481 | PERL_ARGS_ASSERT_UTF8_DISTANCE((void)0); ((void)0); | |||
1482 | ||||
1483 | return (a < b) ? -1 * (IV) utf8_length(a, b)Perl_utf8_length( a,b) : (IV) utf8_length(b, a)Perl_utf8_length( b,a); | |||
1484 | } | |||
1485 | ||||
1486 | /* | |||
1487 | =for apidoc utf8_hop | |||
1488 | ||||
1489 | Return the UTF-8 pointer C<s> displaced by C<off> characters, either | |||
1490 | forward or backward. | |||
1491 | ||||
1492 | WARNING: do not use the following unless you *know* C<off> is within | |||
1493 | the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned | |||
1494 | on the first byte of character or just after the last byte of a character. | |||
1495 | ||||
1496 | =cut | |||
1497 | */ | |||
1498 | ||||
1499 | PERL_STATIC_INLINEstatic __inline__ U8 * | |||
1500 | Perl_utf8_hop(const U8 *s, SSize_tssize_t off) | |||
1501 | { | |||
1502 | PERL_ARGS_ASSERT_UTF8_HOP((void)0); | |||
1503 | ||||
1504 | /* Note: cannot use UTF8_IS_...() too eagerly here since e.g | |||
1505 | * the bitops (especially ~) can create illegal UTF-8. | |||
1506 | * In other words: in Perl UTF-8 is not just for Unicode. */ | |||
1507 | ||||
1508 | if (off >= 0) { | |||
1509 | while (off--) | |||
1510 | s += UTF8SKIP(s)PL_utf8skip[*(const U8*)(s)]; | |||
1511 | } | |||
1512 | else { | |||
1513 | while (off++) { | |||
1514 | s--; | |||
1515 | while (UTF8_IS_CONTINUATION(*s)( (((( ((U8) ((*s) | 0))) & ((U8) (0xFF << 6))) == ( ((U8) (0xFF << 6)) & 0xB0))))) | |||
1516 | s--; | |||
1517 | } | |||
1518 | } | |||
1519 | GCC_DIAG_IGNORE(-Wcast-qual)GCC diagnostic push GCC diagnostic ignored "-Wcast-qual" | |||
1520 | return (U8 *)s; | |||
1521 | GCC_DIAG_RESTOREGCC diagnostic pop | |||
1522 | } | |||
1523 | ||||
1524 | /* | |||
1525 | =for apidoc utf8_hop_forward | |||
1526 | ||||
1527 | Return the UTF-8 pointer C<s> displaced by up to C<off> characters, | |||
1528 | forward. | |||
1529 | ||||
1530 | C<off> must be non-negative. | |||
1531 | ||||
1532 | C<s> must be before or equal to C<end>. | |||
1533 | ||||
1534 | When moving forward it will not move beyond C<end>. | |||
1535 | ||||
1536 | Will not exceed this limit even if the string is not valid "UTF-8". | |||
1537 | ||||
1538 | =cut | |||
1539 | */ | |||
1540 | ||||
1541 | PERL_STATIC_INLINEstatic __inline__ U8 * | |||
1542 | Perl_utf8_hop_forward(const U8 *s, SSize_tssize_t off, const U8 *end) | |||
1543 | { | |||
1544 | PERL_ARGS_ASSERT_UTF8_HOP_FORWARD((void)0); ((void)0); | |||
1545 | ||||
1546 | /* Note: cannot use UTF8_IS_...() too eagerly here since e.g | |||
1547 | * the bitops (especially ~) can create illegal UTF-8. | |||
1548 | * In other words: in Perl UTF-8 is not just for Unicode. */ | |||
1549 | ||||
1550 | assert(s <= end)((void)0); | |||
1551 | assert(off >= 0)((void)0); | |||
1552 | ||||
1553 | while (off--) { | |||
1554 | STRLEN skip = UTF8SKIP(s)PL_utf8skip[*(const U8*)(s)]; | |||
1555 | if ((STRLEN)(end - s) <= skip) { | |||
1556 | GCC_DIAG_IGNORE(-Wcast-qual)GCC diagnostic push GCC diagnostic ignored "-Wcast-qual" | |||
1557 | return (U8 *)end; | |||
1558 | GCC_DIAG_RESTOREGCC diagnostic pop | |||
1559 | } | |||
1560 | s += skip; | |||
1561 | } | |||
1562 | ||||
1563 | GCC_DIAG_IGNORE(-Wcast-qual)GCC diagnostic push GCC diagnostic ignored "-Wcast-qual" | |||
1564 | return (U8 *)s; | |||
1565 | GCC_DIAG_RESTOREGCC diagnostic pop | |||
1566 | } | |||
1567 | ||||
1568 | /* | |||
1569 | =for apidoc utf8_hop_back | |||
1570 | ||||
1571 | Return the UTF-8 pointer C<s> displaced by up to C<off> characters, | |||
1572 | backward. | |||
1573 | ||||
1574 | C<off> must be non-positive. | |||
1575 | ||||
1576 | C<s> must be after or equal to C<start>. | |||
1577 | ||||
1578 | When moving backward it will not move before C<start>. | |||
1579 | ||||
1580 | Will not exceed this limit even if the string is not valid "UTF-8". | |||
1581 | ||||
1582 | =cut | |||
1583 | */ | |||
1584 | ||||
1585 | PERL_STATIC_INLINEstatic __inline__ U8 * | |||
1586 | Perl_utf8_hop_back(const U8 *s, SSize_tssize_t off, const U8 *start) | |||
1587 | { | |||
1588 | PERL_ARGS_ASSERT_UTF8_HOP_BACK((void)0); ((void)0); | |||
1589 | ||||
1590 | /* Note: cannot use UTF8_IS_...() too eagerly here since e.g | |||
1591 | * the bitops (especially ~) can create illegal UTF-8. | |||
1592 | * In other words: in Perl UTF-8 is not just for Unicode. */ | |||
1593 | ||||
1594 | assert(start <= s)((void)0); | |||
1595 | assert(off <= 0)((void)0); | |||
1596 | ||||
1597 | while (off++ && s > start) { | |||
1598 | do { | |||
1599 | s--; | |||
1600 | } while (UTF8_IS_CONTINUATION(*s)( (((( ((U8) ((*s) | 0))) & ((U8) (0xFF << 6))) == ( ((U8) (0xFF << 6)) & 0xB0)))) && s > start); | |||
1601 | } | |||
1602 | ||||
1603 | GCC_DIAG_IGNORE(-Wcast-qual)GCC diagnostic push GCC diagnostic ignored "-Wcast-qual" | |||
1604 | return (U8 *)s; | |||
1605 | GCC_DIAG_RESTOREGCC diagnostic pop | |||
1606 | } | |||
1607 | ||||
1608 | /* | |||
1609 | =for apidoc utf8_hop_safe | |||
1610 | ||||
1611 | Return the UTF-8 pointer C<s> displaced by up to C<off> characters, | |||
1612 | either forward or backward. | |||
1613 | ||||
1614 | When moving backward it will not move before C<start>. | |||
1615 | ||||
1616 | When moving forward it will not move beyond C<end>. | |||
1617 | ||||
1618 | Will not exceed those limits even if the string is not valid "UTF-8". | |||
1619 | ||||
1620 | =cut | |||
1621 | */ | |||
1622 | ||||
1623 | PERL_STATIC_INLINEstatic __inline__ U8 * | |||
1624 | Perl_utf8_hop_safe(const U8 *s, SSize_tssize_t off, const U8 *start, const U8 *end) | |||
1625 | { | |||
1626 | PERL_ARGS_ASSERT_UTF8_HOP_SAFE((void)0); ((void)0); ((void)0); | |||
1627 | ||||
1628 | /* Note: cannot use UTF8_IS_...() too eagerly here since e.g | |||
1629 | * the bitops (especially ~) can create illegal UTF-8. | |||
1630 | * In other words: in Perl UTF-8 is not just for Unicode. */ | |||
1631 | ||||
1632 | assert(start <= s && s <= end)((void)0); | |||
1633 | ||||
1634 | if (off >= 0) { | |||
1635 | return utf8_hop_forwardPerl_utf8_hop_forward(s, off, end); | |||
1636 | } | |||
1637 | else { | |||
1638 | return utf8_hop_backPerl_utf8_hop_back(s, off, start); | |||
1639 | } | |||
1640 | } | |||
1641 | ||||
1642 | /* | |||
1643 | ||||
1644 | =for apidoc is_utf8_valid_partial_char | |||
1645 | ||||
1646 | Returns 0 if the sequence of bytes starting at C<s> and looking no further than | |||
1647 | S<C<e - 1>> is the UTF-8 encoding, as extended by Perl, for one or more code | |||
1648 | points. Otherwise, it returns 1 if there exists at least one non-empty | |||
1649 | sequence of bytes that when appended to sequence C<s>, starting at position | |||
1650 | C<e> causes the entire sequence to be the well-formed UTF-8 of some code point; | |||
1651 | otherwise returns 0. | |||
1652 | ||||
1653 | In other words this returns TRUE if C<s> points to a partial UTF-8-encoded code | |||
1654 | point. | |||
1655 | ||||
1656 | This is useful when a fixed-length buffer is being tested for being well-formed | |||
1657 | UTF-8, but the final few bytes in it don't comprise a full character; that is, | |||
1658 | it is split somewhere in the middle of the final code point's UTF-8 | |||
1659 | representation. (Presumably when the buffer is refreshed with the next chunk | |||
1660 | of data, the new first bytes will complete the partial code point.) This | |||
1661 | function is used to verify that the final bytes in the current buffer are in | |||
1662 | fact the legal beginning of some code point, so that if they aren't, the | |||
1663 | failure can be signalled without having to wait for the next read. | |||
1664 | ||||
1665 | =cut | |||
1666 | */ | |||
1667 | #define is_utf8_valid_partial_char(s, e)Perl_is_utf8_valid_partial_char_flags(s, e, 0) \ | |||
1668 | is_utf8_valid_partial_char_flagsPerl_is_utf8_valid_partial_char_flags(s, e, 0) | |||
1669 | ||||
1670 | /* | |||
1671 | ||||
1672 | =for apidoc is_utf8_valid_partial_char_flags | |||
1673 | ||||
1674 | Like C<L</is_utf8_valid_partial_char>>, it returns a boolean giving whether | |||
1675 | or not the input is a valid UTF-8 encoded partial character, but it takes an | |||
1676 | extra parameter, C<flags>, which can further restrict which code points are | |||
1677 | considered valid. | |||
1678 | ||||
1679 | If C<flags> is 0, this behaves identically to | |||
1680 | C<L</is_utf8_valid_partial_char>>. Otherwise C<flags> can be any combination | |||
1681 | of the C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>. If | |||
1682 | there is any sequence of bytes that can complete the input partial character in | |||
1683 | such a way that a non-prohibited character is formed, the function returns | |||
1684 | TRUE; otherwise FALSE. Non character code points cannot be determined based on | |||
1685 | partial character input. But many of the other possible excluded types can be | |||
1686 | determined from just the first one or two bytes. | |||
1687 | ||||
1688 | =cut | |||
1689 | */ | |||
1690 | ||||
1691 | PERL_STATIC_INLINEstatic __inline__ bool_Bool | |||
1692 | Perl_is_utf8_valid_partial_char_flags(const U8 * const s, const U8 * const e, const U32 flags) | |||
1693 | { | |||
1694 | PERL_ARGS_ASSERT_IS_UTF8_VALID_PARTIAL_CHAR_FLAGS((void)0); ((void)0); | |||
1695 | ||||
1696 | assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE((void)0) | |||
1697 | |UTF8_DISALLOW_PERL_EXTENDED)))((void)0); | |||
1698 | ||||
1699 | if (s >= e || s + UTF8SKIP(s)PL_utf8skip[*(const U8*)(s)] <= e) { | |||
1700 | return FALSE(0); | |||
1701 | } | |||
1702 | ||||
1703 | return cBOOL(is_utf8_char_helper(s, e, flags))((Perl_is_utf8_char_helper(s, e, flags)) ? (_Bool)1 : (_Bool) 0); | |||
1704 | } | |||
1705 | ||||
1706 | /* | |||
1707 | ||||
1708 | =for apidoc is_utf8_fixed_width_buf_flags | |||
1709 | ||||
1710 | Returns TRUE if the fixed-width buffer starting at C<s> with length C<len> | |||
1711 | is entirely valid UTF-8, subject to the restrictions given by C<flags>; | |||
1712 | otherwise it returns FALSE. | |||
1713 | ||||
1714 | If C<flags> is 0, any well-formed UTF-8, as extended by Perl, is accepted | |||
1715 | without restriction. If the final few bytes of the buffer do not form a | |||
1716 | complete code point, this will return TRUE anyway, provided that | |||
1717 | C<L</is_utf8_valid_partial_char_flags>> returns TRUE for them. | |||
1718 | ||||
1719 | If C<flags> in non-zero, it can be any combination of the | |||
1720 | C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>, and with the | |||
1721 | same meanings. | |||
1722 | ||||
1723 | This function differs from C<L</is_utf8_string_flags>> only in that the latter | |||
1724 | returns FALSE if the final few bytes of the string don't form a complete code | |||
1725 | point. | |||
1726 | ||||
1727 | =cut | |||
1728 | */ | |||
1729 | #define is_utf8_fixed_width_buf_flags(s, len, flags)Perl_is_utf8_fixed_width_buf_loclen_flags(s, len, 0, 0, flags ) \ | |||
1730 | is_utf8_fixed_width_buf_loclen_flagsPerl_is_utf8_fixed_width_buf_loclen_flags(s, len, 0, 0, flags) | |||
1731 | ||||
1732 | /* | |||
1733 | ||||
1734 | =for apidoc is_utf8_fixed_width_buf_loc_flags | |||
1735 | ||||
1736 | Like C<L</is_utf8_fixed_width_buf_flags>> but stores the location of the | |||
1737 | failure in the C<ep> pointer. If the function returns TRUE, C<*ep> will point | |||
1738 | to the beginning of any partial character at the end of the buffer; if there is | |||
1739 | no partial character C<*ep> will contain C<s>+C<len>. | |||
1740 | ||||
1741 | See also C<L</is_utf8_fixed_width_buf_loclen_flags>>. | |||
1742 | ||||
1743 | =cut | |||
1744 | */ | |||
1745 | ||||
1746 | #define is_utf8_fixed_width_buf_loc_flags(s, len, loc, flags)Perl_is_utf8_fixed_width_buf_loclen_flags(s, len, loc, 0, flags ) \ | |||
1747 | is_utf8_fixed_width_buf_loclen_flagsPerl_is_utf8_fixed_width_buf_loclen_flags(s, len, loc, 0, flags) | |||
1748 | ||||
1749 | /* | |||
1750 | ||||
1751 | =for apidoc is_utf8_fixed_width_buf_loclen_flags | |||
1752 | ||||
1753 | Like C<L</is_utf8_fixed_width_buf_loc_flags>> but stores the number of | |||
1754 | complete, valid characters found in the C<el> pointer. | |||
1755 | ||||
1756 | =cut | |||
1757 | */ | |||
1758 | ||||
1759 | PERL_STATIC_INLINEstatic __inline__ bool_Bool | |||
1760 | Perl_is_utf8_fixed_width_buf_loclen_flags(const U8 * const s, | |||
1761 | STRLEN len, | |||
1762 | const U8 **ep, | |||
1763 | STRLEN *el, | |||
1764 | const U32 flags) | |||
1765 | { | |||
1766 | const U8 * maybe_partial; | |||
1767 | ||||
1768 | PERL_ARGS_ASSERT_IS_UTF8_FIXED_WIDTH_BUF_LOCLEN_FLAGS((void)0); | |||
1769 | ||||
1770 | if (! ep) { | |||
1771 | ep = &maybe_partial; | |||
1772 | } | |||
1773 | ||||
1774 | /* If it's entirely valid, return that; otherwise see if the only error is | |||
1775 | * that the final few bytes are for a partial character */ | |||
1776 | return is_utf8_string_loclen_flagsPerl_is_utf8_string_loclen_flags(s, len, ep, el, flags) | |||
1777 | || is_utf8_valid_partial_char_flagsPerl_is_utf8_valid_partial_char_flags(*ep, s + len, flags); | |||
1778 | } | |||
1779 | ||||
1780 | PERL_STATIC_INLINEstatic __inline__ UV | |||
1781 | Perl_utf8n_to_uvchr_msgs(const U8 *s, | |||
1782 | STRLEN curlen, | |||
1783 | STRLEN *retlen, | |||
1784 | const U32 flags, | |||
1785 | U32 * errors, | |||
1786 | AV ** msgs) | |||
1787 | { | |||
1788 | /* This is the inlined portion of utf8n_to_uvchr_msgs. It handles the | |||
1789 | * simple cases, and, if necessary calls a helper function to deal with the | |||
1790 | * more complex ones. Almost all well-formed non-problematic code points | |||
1791 | * are considered simple, so that it's unlikely that the helper function | |||
1792 | * will need to be called. | |||
1793 | * | |||
1794 | * This is an adaptation of the tables and algorithm given in | |||
1795 | * https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides | |||
1796 | * comprehensive documentation of the original version. A copyright notice | |||
1797 | * for the original version is given at the beginning of this file. The | |||
1798 | * Perl adapation is documented at the definition of PL_strict_utf8_dfa_tab[]. | |||
1799 | */ | |||
1800 | ||||
1801 | const U8 * const s0 = s; | |||
1802 | const U8 * send = s0 + curlen; | |||
1803 | UV uv = 0; /* The 0 silences some stupid compilers */ | |||
1804 | UV state = 0; | |||
1805 | ||||
1806 | PERL_ARGS_ASSERT_UTF8N_TO_UVCHR_MSGS((void)0); | |||
1807 | ||||
1808 | /* This dfa is fast. If it accepts the input, it was for a well-formed, | |||
1809 | * non-problematic code point, which can be returned immediately. | |||
1810 | * Otherwise we call a helper function to figure out the more complicated | |||
1811 | * cases. */ | |||
1812 | ||||
1813 | while (s < send && LIKELY(state != 1)__builtin_expect(((state != 1) ? (_Bool)1 : (_Bool)0),(1))) { | |||
1814 | UV type = PL_strict_utf8_dfa_tab[*s]; | |||
1815 | ||||
1816 | uv = (state == 0) | |||
1817 | ? ((0xff >> type) & NATIVE_UTF8_TO_I8(*s)( ((U8) ((*s) | 0)))) | |||
1818 | : UTF8_ACCUMULATE(uv, *s)( ((uv) << 6) | ((( ((U8) ((*s) | 0)))) & ((U8) ((1U << 6) - 1)))); | |||
1819 | state = PL_strict_utf8_dfa_tab[256 + state + type]; | |||
1820 | ||||
1821 | if (state != 0) { | |||
1822 | s++; | |||
1823 | continue; | |||
1824 | } | |||
1825 | ||||
1826 | if (retlen) { | |||
1827 | *retlen = s - s0 + 1; | |||
1828 | } | |||
1829 | if (errors) { | |||
1830 | *errors = 0; | |||
1831 | } | |||
1832 | if (msgs) { | |||
1833 | *msgs = NULL((void*)0); | |||
1834 | } | |||
1835 | ||||
1836 | return UNI_TO_NATIVE(uv)((UV) ((uv) | 0)); | |||
1837 | } | |||
1838 | ||||
1839 | /* Here is potentially problematic. Use the full mechanism */ | |||
1840 | return _utf8n_to_uvchr_msgs_helperPerl__utf8n_to_uvchr_msgs_helper(s0, curlen, retlen, flags, errors, msgs); | |||
1841 | } | |||
1842 | ||||
1843 | PERL_STATIC_INLINEstatic __inline__ UV | |||
1844 | Perl_utf8_to_uvchr_buf_helper(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen) | |||
1845 | { | |||
1846 | PERL_ARGS_ASSERT_UTF8_TO_UVCHR_BUF_HELPER((void)0); ((void)0); | |||
1847 | ||||
1848 | assert(s < send)((void)0); | |||
1849 | ||||
1850 | if (! ckWARN_d(WARN_UTF8)Perl_ckwarn_d( (44 ))) { | |||
1851 | ||||
1852 | /* EMPTY is not really allowed, and asserts on debugging builds. But | |||
1853 | * on non-debugging we have to deal with it, and this causes it to | |||
1854 | * return the REPLACEMENT CHARACTER, as the documentation indicates */ | |||
1855 | return utf8n_to_uvchr(s, send - s, retlen,Perl_utf8n_to_uvchr_msgs(s, send - s, retlen, (( 0x0002 |0x0004 |0x0008 |0x0010 |0x0080) | 0x0001), 0, 0) | |||
1856 | (UTF8_ALLOW_ANY | UTF8_ALLOW_EMPTY))Perl_utf8n_to_uvchr_msgs(s, send - s, retlen, (( 0x0002 |0x0004 |0x0008 |0x0010 |0x0080) | 0x0001), 0, 0); | |||
1857 | } | |||
1858 | else { | |||
1859 | UV ret = utf8n_to_uvchr(s, send - s, retlen, 0)Perl_utf8n_to_uvchr_msgs(s, send - s, retlen, 0, 0, 0); | |||
1860 | if (retlen && ret == 0 && *s != '\0') { | |||
1861 | *retlen = (STRLEN) -1; | |||
1862 | } | |||
1863 | ||||
1864 | return ret; | |||
1865 | } | |||
1866 | } | |||
1867 | ||||
1868 | /* ------------------------------- perl.h ----------------------------- */ | |||
1869 | ||||
1870 | /* | |||
1871 | =head1 Miscellaneous Functions | |||
1872 | ||||
1873 | =for apidoc is_safe_syscall | |||
1874 | ||||
1875 | Test that the given C<pv> (with length C<len>) doesn't contain any internal | |||
1876 | C<NUL> characters. | |||
1877 | If it does, set C<errno> to C<ENOENT>, optionally warn using the C<syscalls> | |||
1878 | category, and return FALSE. | |||
1879 | ||||
1880 | Return TRUE if the name is safe. | |||
1881 | ||||
1882 | C<what> and C<op_name> are used in any warning. | |||
1883 | ||||
1884 | Used by the C<IS_SAFE_SYSCALL()> macro. | |||
1885 | ||||
1886 | =cut | |||
1887 | */ | |||
1888 | ||||
1889 | PERL_STATIC_INLINEstatic __inline__ bool_Bool | |||
1890 | Perl_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name) | |||
1891 | { | |||
1892 | /* While the Windows CE API provides only UCS-16 (or UTF-16) APIs | |||
1893 | * perl itself uses xce*() functions which accept 8-bit strings. | |||
1894 | */ | |||
1895 | ||||
1896 | PERL_ARGS_ASSERT_IS_SAFE_SYSCALL((void)0); ((void)0); ((void)0); | |||
1897 | ||||
1898 | if (len > 1) { | |||
1899 | char *null_at; | |||
1900 | if (UNLIKELY((null_at = (char *)memchr(pv, 0, len-1)) != NULL)__builtin_expect((((null_at = (char *)memchr(pv, 0, len-1)) != ((void*)0)) ? (_Bool)1 : (_Bool)0),(0))) { | |||
1901 | SETERRNO(ENOENT, LIB_INVARG)((*__errno()) = (2)); | |||
1902 | Perl_ck_warner(aTHX_ packWARN(WARN_SYSCALLS)(57 ), | |||
1903 | "Invalid \\0 character in %s for %s: %s\\0%s", | |||
1904 | what, op_name, pv, null_at+1); | |||
1905 | return FALSE(0); | |||
1906 | } | |||
1907 | } | |||
1908 | ||||
1909 | return TRUE(1); | |||
1910 | } | |||
1911 | ||||
1912 | /* | |||
1913 | ||||
1914 | Return true if the supplied filename has a newline character | |||
1915 | immediately before the first (hopefully only) NUL. | |||
1916 | ||||
1917 | My original look at this incorrectly used the len from SvPV(), but | |||
1918 | that's incorrect, since we allow for a NUL in pv[len-1]. | |||
1919 | ||||
1920 | So instead, strlen() and work from there. | |||
1921 | ||||
1922 | This allow for the user reading a filename, forgetting to chomp it, | |||
1923 | then calling: | |||
1924 | ||||
1925 | open my $foo, "$file\0"; | |||
1926 | ||||
1927 | */ | |||
1928 | ||||
1929 | #ifdef PERL_CORE | |||
1930 | ||||
1931 | PERL_STATIC_INLINEstatic __inline__ bool_Bool | |||
1932 | S_should_warn_nl(const char *pv) | |||
1933 | { | |||
1934 | STRLEN len; | |||
1935 | ||||
1936 | PERL_ARGS_ASSERT_SHOULD_WARN_NL; | |||
1937 | ||||
1938 | len = strlen(pv); | |||
1939 | ||||
1940 | return len > 0 && pv[len-1] == '\n'; | |||
1941 | } | |||
1942 | ||||
1943 | #endif | |||
1944 | ||||
1945 | #if defined(PERL_IN_PP_C) || defined(PERL_IN_PP_HOT_C) | |||
1946 | ||||
1947 | PERL_STATIC_INLINEstatic __inline__ bool_Bool | |||
1948 | S_lossless_NV_to_IV(const NV nv, IV *ivp) | |||
1949 | { | |||
1950 | /* This function determines if the input NV 'nv' may be converted without | |||
1951 | * loss of data to an IV. If not, it returns FALSE taking no other action. | |||
1952 | * But if it is possible, it does the conversion, returning TRUE, and | |||
1953 | * storing the converted result in '*ivp' */ | |||
1954 | ||||
1955 | PERL_ARGS_ASSERT_LOSSLESS_NV_TO_IV; | |||
1956 | ||||
1957 | # if defined(Perl_isnan) | |||
1958 | ||||
1959 | if (UNLIKELY(Perl_isnan(nv))__builtin_expect(((((sizeof (nv) == sizeof (float)) ? __isnanf (nv) : (sizeof (nv) == sizeof (double)) ? __isnan(nv) : __isnanl (nv))) ? (_Bool)1 : (_Bool)0),(0))) { | |||
1960 | return FALSE(0); | |||
1961 | } | |||
1962 | ||||
1963 | # endif | |||
1964 | ||||
1965 | if (UNLIKELY(nv < IV_MIN)__builtin_expect(((nv < (-((IV) ((~(UV)0) >> 1)) - ( (3 & -1) == 3))) ? (_Bool)1 : (_Bool)0),(0)) || UNLIKELY(nv > IV_MAX)__builtin_expect(((nv > ((IV) ((~(UV)0) >> 1))) ? (_Bool )1 : (_Bool)0),(0))) { | |||
1966 | return FALSE(0); | |||
1967 | } | |||
1968 | ||||
1969 | if ((IV) nv != nv) { | |||
1970 | return FALSE(0); | |||
1971 | } | |||
1972 | ||||
1973 | *ivp = (IV) nv; | |||
1974 | return TRUE(1); | |||
1975 | } | |||
1976 | ||||
1977 | #endif | |||
1978 | ||||
1979 | /* ------------------ regcomp.c, toke.c ------------ */ | |||
1980 | ||||
1981 | #if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_TOKE_C) | |||
1982 | ||||
1983 | /* | |||
1984 | - regcurly - a little FSA that accepts {\d+,?\d*} | |||
1985 | Pulled from reg.c. | |||
1986 | */ | |||
1987 | PERL_STATIC_INLINEstatic __inline__ bool_Bool | |||
1988 | S_regcurly(const char *s) | |||
1989 | { | |||
1990 | PERL_ARGS_ASSERT_REGCURLY; | |||
1991 | ||||
1992 | if (*s++ != '{') | |||
1993 | return FALSE(0); | |||
1994 | if (!isDIGIT(*s)( ( (sizeof(*s) == sizeof(U8)) ? ( (((U64) (((((U8) (*s)))) - ((('0')) | 0))) <= (((U64) (((('9') - ('0'))) | 0))))) : ( sizeof(*s) == sizeof(U32)) ? ( (((U64) (((((U32) (*s)))) - (( ('0')) | 0))) <= (((U64) (((('9') - ('0'))) | 0))))) : ( ( (((U64) (((((U64) (*s)))) - ((('0')) | 0))) <= (((U64) (( (('9') - ('0'))) | 0))))))))) | |||
1995 | return FALSE(0); | |||
1996 | while (isDIGIT(*s)( ( (sizeof(*s) == sizeof(U8)) ? ( (((U64) (((((U8) (*s)))) - ((('0')) | 0))) <= (((U64) (((('9') - ('0'))) | 0))))) : ( sizeof(*s) == sizeof(U32)) ? ( (((U64) (((((U32) (*s)))) - (( ('0')) | 0))) <= (((U64) (((('9') - ('0'))) | 0))))) : ( ( (((U64) (((((U64) (*s)))) - ((('0')) | 0))) <= (((U64) (( (('9') - ('0'))) | 0))))))))) | |||
1997 | s++; | |||
1998 | if (*s == ',') { | |||
1999 | s++; | |||
2000 | while (isDIGIT(*s)( ( (sizeof(*s) == sizeof(U8)) ? ( (((U64) (((((U8) (*s)))) - ((('0')) | 0))) <= (((U64) (((('9') - ('0'))) | 0))))) : ( sizeof(*s) == sizeof(U32)) ? ( (((U64) (((((U32) (*s)))) - (( ('0')) | 0))) <= (((U64) (((('9') - ('0'))) | 0))))) : ( ( (((U64) (((((U64) (*s)))) - ((('0')) | 0))) <= (((U64) (( (('9') - ('0'))) | 0))))))))) | |||
2001 | s++; | |||
2002 | } | |||
2003 | ||||
2004 | return *s == '}'; | |||
2005 | } | |||
2006 | ||||
2007 | #endif | |||
2008 | ||||
2009 | /* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */ | |||
2010 | ||||
2011 | #if defined(PERL_IN_PP_C) || defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_TOKE_C) || defined(PERL_IN_UNIVERSAL_C) | |||
2012 | ||||
2013 | #define MAX_CHARSET_NAME_LENGTH 2 | |||
2014 | ||||
2015 | PERL_STATIC_INLINEstatic __inline__ const char * | |||
2016 | S_get_regex_charset_name(const U32 flags, STRLEN* const lenp) | |||
2017 | { | |||
2018 | PERL_ARGS_ASSERT_GET_REGEX_CHARSET_NAME; | |||
2019 | ||||
2020 | /* Returns a string that corresponds to the name of the regex character set | |||
2021 | * given by 'flags', and *lenp is set the length of that string, which | |||
2022 | * cannot exceed MAX_CHARSET_NAME_LENGTH characters */ | |||
2023 | ||||
2024 | *lenp = 1; | |||
2025 | switch (get_regex_charset(flags)) { | |||
2026 | case REGEX_DEPENDS_CHARSET: return DEPENDS_PAT_MODS"d"; | |||
2027 | case REGEX_LOCALE_CHARSET: return LOCALE_PAT_MODS"l"; | |||
2028 | case REGEX_UNICODE_CHARSET: return UNICODE_PAT_MODS"u"; | |||
2029 | case REGEX_ASCII_RESTRICTED_CHARSET: return ASCII_RESTRICT_PAT_MODS"a"; | |||
2030 | case REGEX_ASCII_MORE_RESTRICTED_CHARSET: | |||
2031 | *lenp = 2; | |||
2032 | return ASCII_MORE_RESTRICT_PAT_MODS"aa"; | |||
2033 | } | |||
2034 | /* The NOT_REACHED; hides an assert() which has a rather complex | |||
2035 | * definition in perl.h. */ | |||
2036 | NOT_REACHED((!"UNREACHABLE") ? (void) 0 : __builtin_unreachable()); /* NOTREACHED */ | |||
2037 | return "?"; /* Unknown */ | |||
2038 | } | |||
2039 | ||||
2040 | #endif | |||
2041 | ||||
2042 | /* | |||
2043 | ||||
2044 | Return false if any get magic is on the SV other than taint magic. | |||
2045 | ||||
2046 | */ | |||
2047 | ||||
2048 | PERL_STATIC_INLINEstatic __inline__ bool_Bool | |||
2049 | Perl_sv_only_taint_gmagic(SV *sv) | |||
2050 | { | |||
2051 | MAGIC *mg = SvMAGIC(sv)((XPVMG*) (sv)->sv_any)->xmg_u.xmg_magic; | |||
2052 | ||||
2053 | PERL_ARGS_ASSERT_SV_ONLY_TAINT_GMAGIC((void)0); | |||
2054 | ||||
2055 | while (mg) { | |||
2056 | if (mg->mg_type != PERL_MAGIC_taint't' | |||
2057 | && !(mg->mg_flags & MGf_GSKIP4) | |||
2058 | && mg->mg_virtual->svt_get) { | |||
2059 | return FALSE(0); | |||
2060 | } | |||
2061 | mg = mg->mg_moremagic; | |||
2062 | } | |||
2063 | ||||
2064 | return TRUE(1); | |||
2065 | } | |||
2066 | ||||
2067 | /* ------------------ cop.h ------------------------------------------- */ | |||
2068 | ||||
2069 | /* implement GIMME_V() macro */ | |||
2070 | ||||
2071 | PERL_STATIC_INLINEstatic __inline__ U8 | |||
2072 | Perl_gimme_V(pTHXvoid) | |||
2073 | { | |||
2074 | I32 cxix; | |||
2075 | U8 gimme = (PL_op->op_flags & OPf_WANT3); | |||
2076 | ||||
2077 | if (gimme) | |||
2078 | return gimme; | |||
2079 | cxix = PL_curstackinfo->si_cxsubix; | |||
2080 | if (cxix < 0) | |||
2081 | return G_VOID1; | |||
2082 | assert(cxstack[cxix].blk_gimme & G_WANT)((void)0); | |||
2083 | return (cxstack(PL_curstackinfo->si_cxstack)[cxix].blk_gimmecx_u.cx_blk.blku_gimme & G_WANT3); | |||
2084 | } | |||
2085 | ||||
2086 | ||||
2087 | /* Enter a block. Push a new base context and return its address. */ | |||
2088 | ||||
2089 | PERL_STATIC_INLINEstatic __inline__ PERL_CONTEXT * | |||
2090 | Perl_cx_pushblock(pTHX_ U8 type, U8 gimme, SV** sp, I32 saveix) | |||
2091 | { | |||
2092 | PERL_CONTEXT * cx; | |||
2093 | ||||
2094 | PERL_ARGS_ASSERT_CX_PUSHBLOCK((void)0); | |||
2095 | ||||
2096 | CXINC((PL_curstackinfo->si_cxix) < (PL_curstackinfo->si_cxmax ) ? ++(PL_curstackinfo->si_cxix) : ((PL_curstackinfo->si_cxix ) = Perl_cxinc())); | |||
2097 | cx = CX_CUR()(&(PL_curstackinfo->si_cxstack)[(PL_curstackinfo->si_cxix )]); | |||
2098 | cx->cx_typecx_u.cx_subst.sbu_type = type; | |||
2099 | cx->blk_gimmecx_u.cx_blk.blku_gimme = gimme; | |||
2100 | cx->blk_oldsaveixcx_u.cx_blk.blku_oldsaveix = saveix; | |||
2101 | cx->blk_oldspcx_u.cx_blk.blku_oldsp = (I32)(sp - PL_stack_base); | |||
2102 | cx->blk_oldcopcx_u.cx_blk.blku_oldcop = PL_curcop; | |||
2103 | cx->blk_oldmarkspcx_u.cx_blk.blku_oldmarksp = (I32)(PL_markstack_ptr - PL_markstack); | |||
2104 | cx->blk_oldscopespcx_u.cx_blk.blku_oldscopesp = PL_scopestack_ix; | |||
2105 | cx->blk_oldpmcx_u.cx_blk.blku_oldpm = PL_curpm; | |||
2106 | cx->blk_old_tmpsfloorcx_u.cx_blk.blku_old_tmpsfloor = PL_tmps_floor; | |||
2107 | ||||
2108 | PL_tmps_floor = PL_tmps_ix; | |||
2109 | CX_DEBUG(cx, "PUSH");; | |||
2110 | return cx; | |||
2111 | } | |||
2112 | ||||
2113 | ||||
2114 | /* Exit a block (RETURN and LAST). */ | |||
2115 | ||||
2116 | PERL_STATIC_INLINEstatic __inline__ void | |||
2117 | Perl_cx_popblock(pTHX_ PERL_CONTEXT *cx) | |||
2118 | { | |||
2119 | PERL_ARGS_ASSERT_CX_POPBLOCK((void)0); | |||
2120 | ||||
2121 | CX_DEBUG(cx, "POP");; | |||
2122 | /* these 3 are common to cx_popblock and cx_topblock */ | |||
2123 | PL_markstack_ptr = PL_markstack + cx->blk_oldmarkspcx_u.cx_blk.blku_oldmarksp; | |||
2124 | PL_scopestack_ix = cx->blk_oldscopespcx_u.cx_blk.blku_oldscopesp; | |||
2125 | PL_curpm = cx->blk_oldpmcx_u.cx_blk.blku_oldpm; | |||
2126 | ||||
2127 | /* LEAVE_SCOPE() should have made this true. /(?{})/ cheats | |||
2128 | * and leaves a CX entry lying around for repeated use, so | |||
2129 | * skip for multicall */ \ | |||
2130 | assert( (CxTYPE(cx) == CXt_SUB && CxMULTICALL(cx))((void)0) | |||
2131 | || PL_savestack_ix == cx->blk_oldsaveix)((void)0); | |||
2132 | PL_curcop = cx->blk_oldcopcx_u.cx_blk.blku_oldcop; | |||
2133 | PL_tmps_floor = cx->blk_old_tmpsfloorcx_u.cx_blk.blku_old_tmpsfloor; | |||
2134 | } | |||
2135 | ||||
2136 | /* Continue a block elsewhere (e.g. NEXT, REDO, GOTO). | |||
2137 | * Whereas cx_popblock() restores the state to the point just before | |||
2138 | * cx_pushblock() was called, cx_topblock() restores it to the point just | |||
2139 | * *after* cx_pushblock() was called. */ | |||
2140 | ||||
2141 | PERL_STATIC_INLINEstatic __inline__ void | |||
2142 | Perl_cx_topblock(pTHX_ PERL_CONTEXT *cx) | |||
2143 | { | |||
2144 | PERL_ARGS_ASSERT_CX_TOPBLOCK((void)0); | |||
2145 | ||||
2146 | CX_DEBUG(cx, "TOP");; | |||
2147 | /* these 3 are common to cx_popblock and cx_topblock */ | |||
2148 | PL_markstack_ptr = PL_markstack + cx->blk_oldmarkspcx_u.cx_blk.blku_oldmarksp; | |||
2149 | PL_scopestack_ix = cx->blk_oldscopespcx_u.cx_blk.blku_oldscopesp; | |||
2150 | PL_curpm = cx->blk_oldpmcx_u.cx_blk.blku_oldpm; | |||
2151 | ||||
2152 | PL_stack_sp = PL_stack_base + cx->blk_oldspcx_u.cx_blk.blku_oldsp; | |||
2153 | } | |||
2154 | ||||
2155 | ||||
2156 | PERL_STATIC_INLINEstatic __inline__ void | |||
2157 | Perl_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool_Bool hasargs) | |||
2158 | { | |||
2159 | U8 phlags = CX_PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub)( (PL_op->op_flags & 3) ? (0x80|0x01) : !(PL_op->op_private & (0x80|0x01)) ? 0 : (U8)Perl_was_lvalue_sub() ); | |||
2160 | ||||
2161 | PERL_ARGS_ASSERT_CX_PUSHSUB((void)0); ((void)0); | |||
2162 | ||||
2163 | PERL_DTRACE_PROBE_ENTRY(cv); | |||
2164 | cx->blk_subcx_u.cx_blk.blk_u.blku_sub.old_cxsubix = PL_curstackinfo->si_cxsubix; | |||
2165 | PL_curstackinfo->si_cxsubix = cx - PL_curstackinfo->si_cxstack; | |||
2166 | cx->blk_subcx_u.cx_blk.blk_u.blku_sub.cv = cv; | |||
2167 | cx->blk_subcx_u.cx_blk.blk_u.blku_sub.olddepth = CvDEPTH(cv)(*Perl_CvDEPTH((const CV *)cv)); | |||
2168 | cx->blk_subcx_u.cx_blk.blk_u.blku_sub.prevcomppad = PL_comppad; | |||
2169 | cx->cx_typecx_u.cx_subst.sbu_type |= (hasargs) ? CXp_HASARGS0x20 : 0; | |||
2170 | cx->blk_subcx_u.cx_blk.blk_u.blku_sub.retop = retop; | |||
2171 | SvREFCNT_inc_simple_void_NN(cv)(void)(++(((SV *)({ void *_p = (cv); _p; })))->sv_refcnt); | |||
2172 | cx->blk_u16cx_u.cx_blk.blku_u16 = PL_op->op_private & (phlags|OPpDEREF0x30); | |||
2173 | } | |||
2174 | ||||
2175 | ||||
2176 | /* subsets of cx_popsub() */ | |||
2177 | ||||
2178 | PERL_STATIC_INLINEstatic __inline__ void | |||
2179 | Perl_cx_popsub_common(pTHX_ PERL_CONTEXT *cx) | |||
2180 | { | |||
2181 | CV *cv; | |||
2182 | ||||
2183 | PERL_ARGS_ASSERT_CX_POPSUB_COMMON((void)0); | |||
2184 | assert(CxTYPE(cx) == CXt_SUB)((void)0); | |||
2185 | ||||
2186 | PL_comppad = cx->blk_subcx_u.cx_blk.blk_u.blku_sub.prevcomppad; | |||
2187 | PL_curpad = LIKELY(PL_comppad)__builtin_expect(((PL_comppad) ? (_Bool)1 : (_Bool)0),(1)) ? AvARRAY(PL_comppad)((PL_comppad)->sv_u.svu_array) : NULL((void*)0); | |||
2188 | cv = cx->blk_subcx_u.cx_blk.blk_u.blku_sub.cv; | |||
2189 | CvDEPTH(cv)(*Perl_CvDEPTH((const CV *)cv)) = cx->blk_subcx_u.cx_blk.blk_u.blku_sub.olddepth; | |||
2190 | cx->blk_subcx_u.cx_blk.blk_u.blku_sub.cv = NULL((void*)0); | |||
2191 | SvREFCNT_dec(cv)Perl_SvREFCNT_dec( ((SV *)({ void *_p = (cv); _p; }))); | |||
2192 | PL_curstackinfo->si_cxsubix = cx->blk_subcx_u.cx_blk.blk_u.blku_sub.old_cxsubix; | |||
2193 | } | |||
2194 | ||||
2195 | ||||
2196 | /* handle the @_ part of leaving a sub */ | |||
2197 | ||||
2198 | PERL_STATIC_INLINEstatic __inline__ void | |||
2199 | Perl_cx_popsub_args(pTHX_ PERL_CONTEXT *cx) | |||
2200 | { | |||
2201 | AV *av; | |||
2202 | ||||
2203 | PERL_ARGS_ASSERT_CX_POPSUB_ARGS((void)0); | |||
2204 | assert(CxTYPE(cx) == CXt_SUB)((void)0); | |||
2205 | assert(AvARRAY(MUTABLE_AV(((void)0) | |||
2206 | PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[((void)0) | |||
2207 | CvDEPTH(cx->blk_sub.cv)])) == PL_curpad)((void)0); | |||
2208 | ||||
2209 | CX_POP_SAVEARRAY(cx)do { AV *cx_pop_savearray_av = ((0+(PL_defgv)->sv_u.svu_gp )->gp_av); ((0+(PL_defgv)->sv_u.svu_gp)->gp_av) = cx ->cx_u.cx_blk.blk_u.blku_sub.savearray; cx->cx_u.cx_blk .blk_u.blku_sub.savearray = ((void*)0); Perl_SvREFCNT_dec( (( SV *)({ void *_p = (cx_pop_savearray_av); _p; }))); } while ( 0); | |||
2210 | av = MUTABLE_AV(PAD_SVl(0))((AV *)({ void *_p = ((PL_curpad[0])); _p; })); | |||
2211 | if (UNLIKELY(AvREAL(av))__builtin_expect(((((av)->sv_flags & 0x40000000)) ? (_Bool )1 : (_Bool)0),(0))) | |||
2212 | /* abandon @_ if it got reified */ | |||
2213 | clear_defarray(av, 0)Perl_clear_defarray( av,0); | |||
2214 | else { | |||
2215 | CLEAR_ARGARRAY(av)do { ((XPVAV*) (av)->sv_any)->xav_max += ((av)->sv_u .svu_array) - ((XPVAV*) (av)->sv_any)->xav_alloc; ((av) ->sv_u.svu_array) = ((XPVAV*) (av)->sv_any)->xav_alloc ; ((XPVAV*) (av)->sv_any)->xav_fill = -1; } while (0); | |||
2216 | } | |||
2217 | } | |||
2218 | ||||
2219 | ||||
2220 | PERL_STATIC_INLINEstatic __inline__ void | |||
2221 | Perl_cx_popsub(pTHX_ PERL_CONTEXT *cx) | |||
2222 | { | |||
2223 | PERL_ARGS_ASSERT_CX_POPSUB((void)0); | |||
2224 | assert(CxTYPE(cx) == CXt_SUB)((void)0); | |||
2225 | ||||
2226 | PERL_DTRACE_PROBE_RETURN(cx->blk_sub.cv); | |||
2227 | ||||
2228 | if (CxHASARGS(cx)(((cx)->cx_u.cx_subst.sbu_type & 0x20) == 0x20)) | |||
2229 | cx_popsub_args(cx)Perl_cx_popsub_args( cx); | |||
2230 | cx_popsub_common(cx)Perl_cx_popsub_common( cx); | |||
2231 | } | |||
2232 | ||||
2233 | ||||
2234 | PERL_STATIC_INLINEstatic __inline__ void | |||
2235 | Perl_cx_pushformat(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, GV *gv) | |||
2236 | { | |||
2237 | PERL_ARGS_ASSERT_CX_PUSHFORMAT((void)0); ((void)0); | |||
2238 | ||||
2239 | cx->blk_formatcx_u.cx_blk.blk_u.blku_format.old_cxsubix = PL_curstackinfo->si_cxsubix; | |||
2240 | PL_curstackinfo->si_cxsubix= cx - PL_curstackinfo->si_cxstack; | |||
2241 | cx->blk_formatcx_u.cx_blk.blk_u.blku_format.cv = cv; | |||
2242 | cx->blk_formatcx_u.cx_blk.blk_u.blku_format.retop = retop; | |||
2243 | cx->blk_formatcx_u.cx_blk.blk_u.blku_format.gv = gv; | |||
2244 | cx->blk_formatcx_u.cx_blk.blk_u.blku_format.dfoutgv = PL_defoutgv; | |||
2245 | cx->blk_formatcx_u.cx_blk.blk_u.blku_format.prevcomppad = PL_comppad; | |||
2246 | cx->blk_u16cx_u.cx_blk.blku_u16 = 0; | |||
2247 | ||||
2248 | SvREFCNT_inc_simple_void_NN(cv)(void)(++(((SV *)({ void *_p = (cv); _p; })))->sv_refcnt); | |||
2249 | CvDEPTH(cv)(*Perl_CvDEPTH((const CV *)cv))++; | |||
2250 | SvREFCNT_inc_void(cx->blk_format.dfoutgv)Perl_SvREFCNT_inc_void(((SV *)({ void *_p = (cx->cx_u.cx_blk .blk_u.blku_format.dfoutgv); _p; }))); | |||
2251 | } | |||
2252 | ||||
2253 | ||||
2254 | PERL_STATIC_INLINEstatic __inline__ void | |||
2255 | Perl_cx_popformat(pTHX_ PERL_CONTEXT *cx) | |||
2256 | { | |||
2257 | CV *cv; | |||
2258 | GV *dfout; | |||
2259 | ||||
2260 | PERL_ARGS_ASSERT_CX_POPFORMAT((void)0); | |||
2261 | assert(CxTYPE(cx) == CXt_FORMAT)((void)0); | |||
2262 | ||||
2263 | dfout = cx->blk_formatcx_u.cx_blk.blk_u.blku_format.dfoutgv; | |||
2264 | setdefout(dfout)Perl_setdefout( dfout); | |||
2265 | cx->blk_formatcx_u.cx_blk.blk_u.blku_format.dfoutgv = NULL((void*)0); | |||
2266 | SvREFCNT_dec_NN(dfout)Perl_SvREFCNT_dec_NN( ((SV *)({ void *_p = (dfout); _p; }))); | |||
2267 | ||||
2268 | PL_comppad = cx->blk_formatcx_u.cx_blk.blk_u.blku_format.prevcomppad; | |||
2269 | PL_curpad = LIKELY(PL_comppad)__builtin_expect(((PL_comppad) ? (_Bool)1 : (_Bool)0),(1)) ? AvARRAY(PL_comppad)((PL_comppad)->sv_u.svu_array) : NULL((void*)0); | |||
2270 | cv = cx->blk_formatcx_u.cx_blk.blk_u.blku_format.cv; | |||
2271 | cx->blk_formatcx_u.cx_blk.blk_u.blku_format.cv = NULL((void*)0); | |||
2272 | --CvDEPTH(cv)(*Perl_CvDEPTH((const CV *)cv)); | |||
2273 | SvREFCNT_dec_NN(cv)Perl_SvREFCNT_dec_NN( ((SV *)({ void *_p = (cv); _p; }))); | |||
2274 | PL_curstackinfo->si_cxsubix = cx->blk_formatcx_u.cx_blk.blk_u.blku_format.old_cxsubix; | |||
2275 | } | |||
2276 | ||||
2277 | ||||
2278 | PERL_STATIC_INLINEstatic __inline__ void | |||
2279 | Perl_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv) | |||
2280 | { | |||
2281 | PERL_ARGS_ASSERT_CX_PUSHEVAL((void)0); | |||
2282 | ||||
2283 | cx->blk_evalcx_u.cx_blk.blk_u.blku_eval.old_cxsubix = PL_curstackinfo->si_cxsubix; | |||
2284 | PL_curstackinfo->si_cxsubix= cx - PL_curstackinfo->si_cxstack; | |||
2285 | cx->blk_evalcx_u.cx_blk.blk_u.blku_eval.retop = retop; | |||
2286 | cx->blk_evalcx_u.cx_blk.blk_u.blku_eval.old_namesv = namesv; | |||
2287 | cx->blk_evalcx_u.cx_blk.blk_u.blku_eval.old_eval_root = PL_eval_root; | |||
2288 | cx->blk_evalcx_u.cx_blk.blk_u.blku_eval.cur_text = PL_parser ? PL_parser->linestr : NULL((void*)0); | |||
2289 | cx->blk_evalcx_u.cx_blk.blk_u.blku_eval.cv = NULL((void*)0); /* later set by doeval_compile() */ | |||
2290 | cx->blk_evalcx_u.cx_blk.blk_u.blku_eval.cur_top_env = PL_top_env; | |||
2291 | ||||
2292 | assert(!(PL_in_eval & ~ 0x3F))((void)0); | |||
2293 | assert(!(PL_op->op_type & ~0x1FF))((void)0); | |||
2294 | cx->blk_u16cx_u.cx_blk.blku_u16 = (PL_in_eval & 0x3F) | ((U16)PL_op->op_type << 7); | |||
2295 | } | |||
2296 | ||||
2297 | ||||
2298 | PERL_STATIC_INLINEstatic __inline__ void | |||
2299 | Perl_cx_popeval(pTHX_ PERL_CONTEXT *cx) | |||
2300 | { | |||
2301 | SV *sv; | |||
2302 | ||||
2303 | PERL_ARGS_ASSERT_CX_POPEVAL((void)0); | |||
2304 | assert(CxTYPE(cx) == CXt_EVAL)((void)0); | |||
2305 | ||||
2306 | PL_in_eval = CxOLD_IN_EVAL(cx)(((cx)->cx_u.cx_blk.blku_u16) & 0x3F); | |||
2307 | assert(!(PL_in_eval & 0xc0))((void)0); | |||
2308 | PL_eval_root = cx->blk_evalcx_u.cx_blk.blk_u.blku_eval.old_eval_root; | |||
2309 | sv = cx->blk_evalcx_u.cx_blk.blk_u.blku_eval.cur_text; | |||
2310 | if (sv && CxEVAL_TXT_REFCNTED(cx)(((cx)->cx_u.cx_blk.blku_u16) & 0x40)) { | |||
2311 | cx->blk_evalcx_u.cx_blk.blk_u.blku_eval.cur_text = NULL((void*)0); | |||
2312 | SvREFCNT_dec_NN(sv)Perl_SvREFCNT_dec_NN( ((SV *)({ void *_p = (sv); _p; }))); | |||
2313 | } | |||
2314 | ||||
2315 | sv = cx->blk_evalcx_u.cx_blk.blk_u.blku_eval.old_namesv; | |||
2316 | if (sv) { | |||
2317 | cx->blk_evalcx_u.cx_blk.blk_u.blku_eval.old_namesv = NULL((void*)0); | |||
2318 | SvREFCNT_dec_NN(sv)Perl_SvREFCNT_dec_NN( ((SV *)({ void *_p = (sv); _p; }))); | |||
2319 | } | |||
2320 | PL_curstackinfo->si_cxsubix = cx->blk_evalcx_u.cx_blk.blk_u.blku_eval.old_cxsubix; | |||
2321 | } | |||
2322 | ||||
2323 | ||||
2324 | /* push a plain loop, i.e. | |||
2325 | * { block } | |||
2326 | * while (cond) { block } | |||
2327 | * for (init;cond;continue) { block } | |||
2328 | * This loop can be last/redo'ed etc. | |||
2329 | */ | |||
2330 | ||||
2331 | PERL_STATIC_INLINEstatic __inline__ void | |||
2332 | Perl_cx_pushloop_plain(pTHX_ PERL_CONTEXT *cx) | |||
2333 | { | |||
2334 | PERL_ARGS_ASSERT_CX_PUSHLOOP_PLAIN((void)0); | |||
2335 | cx->blk_loopcx_u.cx_blk.blk_u.blku_loop.my_op = cLOOP((LOOP*)(PL_op)); | |||
2336 | } | |||
2337 | ||||
2338 | ||||
2339 | /* push a true for loop, i.e. | |||
2340 | * for var (list) { block } | |||
2341 | */ | |||
2342 | ||||
2343 | PERL_STATIC_INLINEstatic __inline__ void | |||
2344 | Perl_cx_pushloop_for(pTHX_ PERL_CONTEXT *cx, void *itervarp, SV* itersave) | |||
2345 | { | |||
2346 | PERL_ARGS_ASSERT_CX_PUSHLOOP_FOR((void)0); ((void)0); | |||
2347 | ||||
2348 | /* this one line is common with cx_pushloop_plain */ | |||
2349 | cx->blk_loopcx_u.cx_blk.blk_u.blku_loop.my_op = cLOOP((LOOP*)(PL_op)); | |||
2350 | ||||
2351 | cx->blk_loopcx_u.cx_blk.blk_u.blku_loop.itervar_u.svp = (SV**)itervarp; | |||
2352 | cx->blk_loopcx_u.cx_blk.blk_u.blku_loop.itersave = itersave; | |||
2353 | #ifdef USE_ITHREADS | |||
2354 | cx->blk_loopcx_u.cx_blk.blk_u.blku_loop.oldcomppad = PL_comppad; | |||
2355 | #endif | |||
2356 | } | |||
2357 | ||||
2358 | ||||
2359 | /* pop all loop types, including plain */ | |||
2360 | ||||
2361 | PERL_STATIC_INLINEstatic __inline__ void | |||
2362 | Perl_cx_poploop(pTHX_ PERL_CONTEXT *cx) | |||
2363 | { | |||
2364 | PERL_ARGS_ASSERT_CX_POPLOOP((void)0); | |||
2365 | ||||
2366 | assert(CxTYPE_is_LOOP(cx))((void)0); | |||
2367 | if ( CxTYPE(cx)((cx)->cx_u.cx_subst.sbu_type & 0xf) == CXt_LOOP_ARY4 | |||
2368 | || CxTYPE(cx)((cx)->cx_u.cx_subst.sbu_type & 0xf) == CXt_LOOP_LAZYSV5) | |||
2369 | { | |||
2370 | /* Free ary or cur. This assumes that state_u.ary.ary | |||
2371 | * aligns with state_u.lazysv.cur. See cx_dup() */ | |||
2372 | SV *sv = cx->blk_loopcx_u.cx_blk.blk_u.blku_loop.state_u.lazysv.cur; | |||
2373 | cx->blk_loopcx_u.cx_blk.blk_u.blku_loop.state_u.lazysv.cur = NULL((void*)0); | |||
2374 | SvREFCNT_dec_NN(sv)Perl_SvREFCNT_dec_NN( ((SV *)({ void *_p = (sv); _p; }))); | |||
2375 | if (CxTYPE(cx)((cx)->cx_u.cx_subst.sbu_type & 0xf) == CXt_LOOP_LAZYSV5) { | |||
2376 | sv = cx->blk_loopcx_u.cx_blk.blk_u.blku_loop.state_u.lazysv.end; | |||
2377 | cx->blk_loopcx_u.cx_blk.blk_u.blku_loop.state_u.lazysv.end = NULL((void*)0); | |||
2378 | SvREFCNT_dec_NN(sv)Perl_SvREFCNT_dec_NN( ((SV *)({ void *_p = (sv); _p; }))); | |||
2379 | } | |||
2380 | } | |||
2381 | if (cx->cx_typecx_u.cx_subst.sbu_type & (CXp_FOR_PAD0x80|CXp_FOR_GV0x40)) { | |||
2382 | SV *cursv; | |||
2383 | SV **svp = (cx)->blk_loopcx_u.cx_blk.blk_u.blku_loop.itervar_u.svp; | |||
2384 | if ((cx->cx_typecx_u.cx_subst.sbu_type & CXp_FOR_GV0x40)) | |||
2385 | svp = &GvSV((GV*)svp)((0+((GV*)svp)->sv_u.svu_gp)->gp_sv); | |||
2386 | cursv = *svp; | |||
2387 | *svp = cx->blk_loopcx_u.cx_blk.blk_u.blku_loop.itersave; | |||
2388 | cx->blk_loopcx_u.cx_blk.blk_u.blku_loop.itersave = NULL((void*)0); | |||
2389 | SvREFCNT_dec(cursv)Perl_SvREFCNT_dec( ((SV *)({ void *_p = (cursv); _p; }))); | |||
2390 | } | |||
2391 | } | |||
2392 | ||||
2393 | ||||
2394 | PERL_STATIC_INLINEstatic __inline__ void | |||
2395 | Perl_cx_pushwhen(pTHX_ PERL_CONTEXT *cx) | |||
2396 | { | |||
2397 | PERL_ARGS_ASSERT_CX_PUSHWHEN((void)0); | |||
2398 | ||||
2399 | cx->blk_givwhencx_u.cx_blk.blk_u.blku_givwhen.leave_op = cLOGOP((LOGOP*)(PL_op))->op_other; | |||
2400 | } | |||
2401 | ||||
2402 | ||||
2403 | PERL_STATIC_INLINEstatic __inline__ void | |||
2404 | Perl_cx_popwhen(pTHX_ PERL_CONTEXT *cx) | |||
2405 | { | |||
2406 | PERL_ARGS_ASSERT_CX_POPWHEN((void)0); | |||
2407 | assert(CxTYPE(cx) == CXt_WHEN)((void)0); | |||
2408 | ||||
2409 | PERL_UNUSED_ARG(cx)((void)sizeof(cx)); | |||
2410 | PERL_UNUSED_CONTEXT; | |||
2411 | /* currently NOOP */ | |||
2412 | } | |||
2413 | ||||
2414 | ||||
2415 | PERL_STATIC_INLINEstatic __inline__ void | |||
2416 | Perl_cx_pushgiven(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv) | |||
2417 | { | |||
2418 | PERL_ARGS_ASSERT_CX_PUSHGIVEN((void)0); | |||
2419 | ||||
2420 | cx->blk_givwhencx_u.cx_blk.blk_u.blku_givwhen.leave_op = cLOGOP((LOGOP*)(PL_op))->op_other; | |||
2421 | cx->blk_givwhencx_u.cx_blk.blk_u.blku_givwhen.defsv_save = orig_defsv; | |||
2422 | } | |||
2423 | ||||
2424 | ||||
2425 | PERL_STATIC_INLINEstatic __inline__ void | |||
2426 | Perl_cx_popgiven(pTHX_ PERL_CONTEXT *cx) | |||
2427 | { | |||
2428 | SV *sv; | |||
2429 | ||||
2430 | PERL_ARGS_ASSERT_CX_POPGIVEN((void)0); | |||
2431 | assert(CxTYPE(cx) == CXt_GIVEN)((void)0); | |||
2432 | ||||
2433 | sv = GvSV(PL_defgv)((0+(PL_defgv)->sv_u.svu_gp)->gp_sv); | |||
2434 | GvSV(PL_defgv)((0+(PL_defgv)->sv_u.svu_gp)->gp_sv) = cx->blk_givwhencx_u.cx_blk.blk_u.blku_givwhen.defsv_save; | |||
2435 | cx->blk_givwhencx_u.cx_blk.blk_u.blku_givwhen.defsv_save = NULL((void*)0); | |||
2436 | SvREFCNT_dec(sv)Perl_SvREFCNT_dec( ((SV *)({ void *_p = (sv); _p; }))); | |||
2437 | } | |||
2438 | ||||
2439 | /* ------------------ util.h ------------------------------------------- */ | |||
2440 | ||||
2441 | /* | |||
2442 | =head1 Miscellaneous Functions | |||
2443 | ||||
2444 | =for apidoc foldEQ | |||
2445 | ||||
2446 | Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the | |||
2447 | same | |||
2448 | case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes | |||
2449 | match themselves and their opposite case counterparts. Non-cased and non-ASCII | |||
2450 | range bytes match only themselves. | |||
2451 | ||||
2452 | =cut | |||
2453 | */ | |||
2454 | ||||
2455 | PERL_STATIC_INLINEstatic __inline__ I32 | |||
2456 | Perl_foldEQ(const char *s1, const char *s2, I32 len) | |||
2457 | { | |||
2458 | const U8 *a = (const U8 *)s1; | |||
2459 | const U8 *b = (const U8 *)s2; | |||
2460 | ||||
2461 | PERL_ARGS_ASSERT_FOLDEQ((void)0); ((void)0); | |||
2462 | ||||
2463 | assert(len >= 0)((void)0); | |||
2464 | ||||
2465 | while (len--) { | |||
2466 | if (*a != *b && *a != PL_fold[*b]) | |||
2467 | return 0; | |||
2468 | a++,b++; | |||
2469 | } | |||
2470 | return 1; | |||
2471 | } | |||
2472 | ||||
2473 | PERL_STATIC_INLINEstatic __inline__ I32 | |||
2474 | Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len) | |||
2475 | { | |||
2476 | /* Compare non-UTF-8 using Unicode (Latin1) semantics. Works on all folds | |||
2477 | * representable without UTF-8, except for LATIN_SMALL_LETTER_SHARP_S, and | |||
2478 | * does not check for this. Nor does it check that the strings each have | |||
2479 | * at least 'len' characters. */ | |||
2480 | ||||
2481 | const U8 *a = (const U8 *)s1; | |||
2482 | const U8 *b = (const U8 *)s2; | |||
2483 | ||||
2484 | PERL_ARGS_ASSERT_FOLDEQ_LATIN1((void)0); ((void)0); | |||
2485 | ||||
2486 | assert(len >= 0)((void)0); | |||
2487 | ||||
2488 | while (len--) { | |||
2489 | if (*a != *b && *a != PL_fold_latin1[*b]) { | |||
2490 | return 0; | |||
2491 | } | |||
2492 | a++, b++; | |||
2493 | } | |||
2494 | return 1; | |||
2495 | } | |||
2496 | ||||
2497 | /* | |||
2498 | =for apidoc foldEQ_locale | |||
2499 | ||||
2500 | Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the | |||
2501 | same case-insensitively in the current locale; false otherwise. | |||
2502 | ||||
2503 | =cut | |||
2504 | */ | |||
2505 | ||||
2506 | PERL_STATIC_INLINEstatic __inline__ I32 | |||
2507 | Perl_foldEQ_locale(const char *s1, const char *s2, I32 len) | |||
2508 | { | |||
2509 | dVARstruct Perl___notused_struct; | |||
2510 | const U8 *a = (const U8 *)s1; | |||
2511 | const U8 *b = (const U8 *)s2; | |||
2512 | ||||
2513 | PERL_ARGS_ASSERT_FOLDEQ_LOCALE((void)0); ((void)0); | |||
2514 | ||||
2515 | assert(len >= 0)((void)0); | |||
2516 | ||||
2517 | while (len--) { | |||
2518 | if (*a != *b && *a != PL_fold_locale[*b]) | |||
2519 | return 0; | |||
2520 | a++,b++; | |||
2521 | } | |||
2522 | return 1; | |||
2523 | } | |||
2524 | ||||
2525 | /* | |||
2526 | =for apidoc my_strnlen | |||
2527 | ||||
2528 | The C library C<strnlen> if available, or a Perl implementation of it. | |||
2529 | ||||
2530 | C<my_strnlen()> computes the length of the string, up to C<maxlen> | |||
2531 | characters. It will never attempt to address more than C<maxlen> | |||
2532 | characters, making it suitable for use with strings that are not | |||
2533 | guaranteed to be NUL-terminated. | |||
2534 | ||||
2535 | =cut | |||
2536 | ||||
2537 | Description stolen from http://man.openbsd.org/strnlen.3, | |||
2538 | implementation stolen from PostgreSQL. | |||
2539 | */ | |||
2540 | #ifndef HAS_STRNLEN | |||
2541 | ||||
2542 | PERL_STATIC_INLINEstatic __inline__ Size_tsize_t | |||
2543 | Perl_my_strnlen(const char *str, Size_tsize_t maxlen) | |||
2544 | { | |||
2545 | const char *end = (char *) memchr(str, '\0', maxlen); | |||
2546 | ||||
2547 | PERL_ARGS_ASSERT_MY_STRNLEN; | |||
2548 | ||||
2549 | if (end == NULL((void*)0)) return maxlen; | |||
2550 | return end - str; | |||
2551 | } | |||
2552 | ||||
2553 | #endif | |||
2554 | ||||
2555 | #if ! defined (HAS_MEMRCHR) && (defined(PERL_CORE) || defined(PERL_EXT)) | |||
2556 | ||||
2557 | PERL_STATIC_INLINEstatic __inline__ void * | |||
2558 | S_my_memrchr(const char * s, const char c, const STRLEN len) | |||
2559 | { | |||
2560 | /* memrchr(), since many platforms lack it */ | |||
2561 | ||||
2562 | const char * t = s + len - 1; | |||
2563 | ||||
2564 | PERL_ARGS_ASSERT_MY_MEMRCHR; | |||
2565 | ||||
2566 | while (t >= s) { | |||
2567 | if (*t == c) { | |||
2568 | return (void *) t; | |||
2569 | } | |||
2570 | t--; | |||
2571 | } | |||
2572 | ||||
2573 | return NULL((void*)0); | |||
2574 | } | |||
2575 | ||||
2576 | #endif | |||
2577 | ||||
2578 | PERL_STATIC_INLINEstatic __inline__ char * | |||
2579 | Perl_mortal_getenv(const char * str) | |||
2580 | { | |||
2581 | /* This implements a (mostly) thread-safe, sequential-call-safe getenv(). | |||
2582 | * | |||
2583 | * It's (mostly) thread-safe because it uses a mutex to prevent | |||
2584 | * simultaneous access from other threads that use the same mutex, and | |||
2585 | * makes a copy of the result before releasing that mutex. All of the Perl | |||
2586 | * core uses that mutex, but, like all mutexes, everything has to cooperate | |||
2587 | * for it to completely work. It is possible for code from, say XS, to not | |||
2588 | * use this mutex, defeating the safety. | |||
2589 | * | |||
2590 | * On some platforms, getenv() is not sequential-call-safe, because | |||
2591 | * subsequent calls destroy the static storage inside the C library | |||
2592 | * returned by an earlier call. The result must be copied or completely | |||
2593 | * acted upon before a subsequent getenv call. Those calls could come from | |||
2594 | * another thread. Again, making a copy while controlling the mutex | |||
2595 | * prevents these problems.. | |||
2596 | * | |||
2597 | * To prevent leaks, the copy is made by creating a new SV containing it, | |||
2598 | * mortalizing the SV, and returning the SV's string (the copy). Thus this | |||
2599 | * is a drop-in replacement for getenv(). | |||
2600 | * | |||
2601 | * A complication is that this can be called during phases where the | |||
2602 | * mortalization process isn't available. These are in interpreter | |||
2603 | * destruction or early in construction. khw believes that at these times | |||
2604 | * there shouldn't be anything else going on, so plain getenv is safe AS | |||
2605 | * LONG AS the caller acts on the return before calling it again. */ | |||
2606 | ||||
2607 | char * ret; | |||
2608 | dTHXstruct Perl___notused_struct; | |||
2609 | ||||
2610 | PERL_ARGS_ASSERT_MORTAL_GETENV((void)0); | |||
2611 | ||||
2612 | /* Can't mortalize without stacks. khw believes that no other threads | |||
2613 | * should be running, so no need to lock things, and this may be during a | |||
2614 | * phase when locking isn't even available */ | |||
2615 | if (UNLIKELY(PL_scopestack_ix == 0)__builtin_expect(((PL_scopestack_ix == 0) ? (_Bool)1 : (_Bool )0),(0))) { | |||
2616 | return getenv(str); | |||
2617 | } | |||
2618 | ||||
2619 | ENV_LOCK(void)0;; | |||
2620 | ||||
2621 | ret = getenv(str); | |||
2622 | ||||
2623 | if (ret != NULL((void*)0)) { | |||
2624 | ret = SvPVX(sv_2mortal(newSVpv(ret, 0)))((Perl_sv_2mortal( Perl_newSVpv( ret,0)))->sv_u.svu_pv); | |||
2625 | } | |||
2626 | ||||
2627 | ENV_UNLOCK(void)0;; | |||
2628 | return ret; | |||
2629 | } | |||
2630 | ||||
2631 | /* | |||
2632 | * ex: set ts=8 sts=4 sw=4 et: | |||
2633 | */ |