Bug Summary

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

Annotated Source Code

Press '?' to see keyboard shortcuts

clang -cc1 -cc1 -triple amd64-unknown-openbsd7.0 -analyze -disable-free -disable-llvm-verifier -discard-value-names -main-file-name Encode.c -analyzer-store=region -analyzer-opt-analyze-nested-blocks -analyzer-checker=core -analyzer-checker=apiModeling -analyzer-checker=unix -analyzer-checker=deadcode -analyzer-checker=security.insecureAPI.UncheckedReturn -analyzer-checker=security.insecureAPI.getpw -analyzer-checker=security.insecureAPI.gets -analyzer-checker=security.insecureAPI.mktemp -analyzer-checker=security.insecureAPI.mkstemp -analyzer-checker=security.insecureAPI.vfork -analyzer-checker=nullability.NullPassedToNonnull -analyzer-checker=nullability.NullReturnedFromNonnull -analyzer-output plist -w -setup-static-analyzer -mrelocation-model pic -pic-level 1 -fhalf-no-semantic-interposition -fno-delete-null-pointer-checks -mframe-pointer=all -relaxed-aliasing -fno-rounding-math -mconstructor-aliases -munwind-tables -target-cpu x86-64 -target-feature +retpoline-indirect-calls -target-feature +retpoline-indirect-branches -tune-cpu generic -debugger-tuning=gdb -fcoverage-compilation-dir=/usr/obj/gnu/usr.bin/perl/cpan/Encode -resource-dir /usr/local/lib/clang/13.0.0 -I ./Encode -D NO_LOCALE_NUMERIC -D NO_LOCALE_COLLATE -D VERSION="3.06_01" -D XS_VERSION="3.06_01" -D PIC -I ../.. -internal-isystem /usr/local/lib/clang/13.0.0/include -internal-externc-isystem /usr/include -O2 -Wwrite-strings -fconst-strings -fdebug-compilation-dir=/usr/obj/gnu/usr.bin/perl/cpan/Encode -ferror-limit 19 -fwrapv -D_RET_PROTECTOR -ret-protector -fgnuc-version=4.2.1 -vectorize-loops -vectorize-slp -fno-builtin-malloc -fno-builtin-calloc -fno-builtin-realloc -fno-builtin-valloc -fno-builtin-free -fno-builtin-strdup -fno-builtin-strndup -analyzer-output=html -faddrsig -D__GCC_HAVE_DWARF2_CFI_ASM=1 -o /home/ben/Projects/vmm/scan-build/2022-01-12-194120-40624-1 -x c Encode.c

Encode.c

→
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
45static void
46Encode_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
69static void
70utf8_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
88static void
89utf8_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
105static SV *
106do_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
129static SV *
130do_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
155static SV *
156encode_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
362static bool_Bool
363strict_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
377static U8*
378process_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)
1
Assuming 'strict' is false
→
2
←
'?' condition is false
→
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))) {
3
←
Assuming the condition is false
→
4
←
Taking false branch
→
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)) {
5
←
Assuming the condition is false
→
6
←
Taking false branch
→
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));
7
←
Assuming the condition is false
→
8
←
'?' condition is false
→
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);
9
←
Loop condition is false. Exiting loop
→
424
425 dlen = (s && e && s < e) ? e-s+1 : 1;
10
←
Assuming 's' is null
→
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));
11
←
Assuming the condition is true
→
427
428 stop_at_partial = stop_at_partial || (check & ENCODE_STOP_AT_PARTIAL0x0800);
12
←
Assuming 'stop_at_partial' is true
→
429
430 while (s < e) {
13
←
Assuming 's' is < 'e'
→
14
←
Loop condition is true. Entering loop body
→
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);
15
←
Passing null pointer value via 1st parameter 's'
→
16
←
Calling 'Perl_is_utf8_string_loclen_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
539static SV *
540find_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
587static SV *
588call_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 */
721STATICstatic void
722S_croak_xs_usage(const CV *const cv, const char *const params);
723
724STATICstatic void
725S_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
768XS_EUPXS(XS_Encode__utf8_decode)static void XS_Encode__utf8_decode( CV* cv __attribute__((unused
))); /* prototype to pass -Wmissing-prototypes */
769XS_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
851XS_EUPXS(XS_Encode__utf8_encode)static void XS_Encode__utf8_encode( CV* cv __attribute__((unused
))); /* prototype to pass -Wmissing-prototypes */
852XS_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
943XS_EUPXS(XS_Encode__XS_renew)static void XS_Encode__XS_renew( CV* cv __attribute__((unused
))); /* prototype to pass -Wmissing-prototypes */
944XS_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
964XS_EUPXS(XS_Encode__XS_renewed)static void XS_Encode__XS_renewed( CV* cv __attribute__((unused
))); /* prototype to pass -Wmissing-prototypes */
965XS_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
985XS_EUPXS(XS_Encode__XS_name)static void XS_Encode__XS_name( CV* cv __attribute__((unused)
)); /* prototype to pass -Wmissing-prototypes */
986XS_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
1011XS_EUPXS(XS_Encode__XS_cat_decode)static void XS_Encode__XS_cat_decode( CV* cv __attribute__((unused
))); /* prototype to pass -Wmissing-prototypes */
1012XS_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
1076XS_EUPXS(XS_Encode__XS_decode)static void XS_Encode__XS_decode( CV* cv __attribute__((unused
))); /* prototype to pass -Wmissing-prototypes */
1077XS_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
1129XS_EUPXS(XS_Encode__XS_encode)static void XS_Encode__XS_encode( CV* cv __attribute__((unused
))); /* prototype to pass -Wmissing-prototypes */
1130XS_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
1181XS_EUPXS(XS_Encode__XS_needs_lines)static void XS_Encode__XS_needs_lines( CV* cv __attribute__((
unused))); /* prototype to pass -Wmissing-prototypes */
1182XS_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
1201XS_EUPXS(XS_Encode__XS_perlio_ok)static void XS_Encode__XS_perlio_ok( CV* cv __attribute__((unused
))); /* prototype to pass -Wmissing-prototypes */
1202XS_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
1225XS_EUPXS(XS_Encode__XS_mime_name)static void XS_Encode__XS_mime_name( CV* cv __attribute__((unused
))); /* prototype to pass -Wmissing-prototypes */
1226XS_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
1261XS_EUPXS(XS_Encode_is_utf8)static void XS_Encode_is_utf8( CV* cv __attribute__((unused))
); /* prototype to pass -Wmissing-prototypes */
1262XS_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
1296XS_EUPXS(XS_Encode__utf8_on)static void XS_Encode__utf8_on( CV* cv __attribute__((unused)
)); /* prototype to pass -Wmissing-prototypes */
1297XS_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
1324XS_EUPXS(XS_Encode__utf8_off)static void XS_Encode__utf8_off( CV* cv __attribute__((unused
))); /* prototype to pass -Wmissing-prototypes */
1325XS_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
1352XS_EUPXS(XS_Encode_decode)static void XS_Encode_decode( CV* cv __attribute__((unused))); /* prototype to pass -Wmissing-prototypes */
1353XS_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
1395XS_EUPXS(XS_Encode_encode)static void XS_Encode_encode( CV* cv __attribute__((unused))); /* prototype to pass -Wmissing-prototypes */
1396XS_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
1438XS_EUPXS(XS_Encode_decode_utf8)static void XS_Encode_decode_utf8( CV* cv __attribute__((unused
))); /* prototype to pass -Wmissing-prototypes */
1439XS_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
1476XS_EUPXS(XS_Encode_encode_utf8)static void XS_Encode_encode_utf8( CV* cv __attribute__((unused
))); /* prototype to pass -Wmissing-prototypes */
1477XS_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
1498XS_EUPXS(XS_Encode_from_to)static void XS_Encode_from_to( CV* cv __attribute__((unused))
); /* prototype to pass -Wmissing-prototypes */
1499XS_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
1562XS_EUPXS(XS_Encode_onBOOT)static void XS_Encode_onBOOT( CV* cv __attribute__((unused))); /* prototype to pass -Wmissing-prototypes */
1563XS_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
1579extern "C"
1580#endif
1581XS_EXTERNAL(boot_Encode)void boot_Encode( CV* cv __attribute__((unused))); /* prototype to pass -Wmissing-prototypes */
1582XS_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
←

../../inline.h

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
12Copyright (c) 2008-2009 Bjoern Hoehrmann <bjoern@hoehrmann.de>
13
14Permission is hereby granted, free of charge, to any person obtaining a copy of
15this software and associated documentation files (the "Software"), to deal in
16the Software without restriction, including without limitation the rights to
17use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies
18of the Software, and to permit persons to whom the Software is furnished to do
19so, subject to the following conditions:
20
21The above copyright notice and this permission notice shall be included in all
22copies or substantial portions of the Software.
23
24THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
25IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
26FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
27AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
28LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
29OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
30SOFTWARE.
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
42PERL_STATIC_INLINEstatic __inline__ SSize_tssize_t
43Perl_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
53PERL_STATIC_INLINEstatic __inline__ GV *
54Perl_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
63PERL_STATIC_INLINEstatic __inline__ I32 *
64Perl_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
84PERL_STATIC_INLINEstatic __inline__ char *
85S_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 */
106PERL_STATIC_INLINEstatic __inline__ STRLEN
107S_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)
125PERL_STATIC_INLINEstatic __inline__ bool_Bool
126S_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
161PERL_STATIC_INLINEstatic __inline__ I32
162Perl_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
171PERL_STATIC_INLINEstatic __inline__ I32
172Perl_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
184PERL_STATIC_INLINEstatic __inline__ struct regexp *
185Perl_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
198PERL_STATIC_INLINEstatic __inline__ bool_Bool
199Perl_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
206PERL_STATIC_INLINEstatic __inline__ SV *
207Perl_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}
213PERL_STATIC_INLINEstatic __inline__ SV *
214Perl_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}
221PERL_STATIC_INLINEstatic __inline__ void
222Perl_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}
227PERL_STATIC_INLINEstatic __inline__ void
228Perl_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
239PERL_STATIC_INLINEstatic __inline__ void
240Perl_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
252PERL_STATIC_INLINEstatic __inline__ void
253Perl_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}
260PERL_STATIC_INLINEstatic __inline__ void
261Perl_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
269PERL_STATIC_INLINEstatic __inline__ U32
270Perl_SvPADSTALE_on(SV *sv)
271{
272 assert(!(SvFLAGS(sv) & SVs_PADTMP))((void)0);
273 return SvFLAGS(sv)(sv)->sv_flags |= SVs_PADSTALE0x00040000;
274}
275PERL_STATIC_INLINEstatic __inline__ U32
276Perl_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)
282PERL_STATIC_INLINEstatic __inline__ STRLEN
283S_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
301PERL_STATIC_INLINEstatic __inline__ void
302Perl_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
319Like C<L<perlapi/utf8_to_uvchr_buf>>, but should only be called when it is
320known 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
322points, and non-Unicode code points are allowed.
323
324=cut
325
326 */
327
328PERL_STATIC_INLINEstatic __inline__ UV
329Perl_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
364Returns TRUE if the first C<len> bytes of the string C<s> are the same
365regardless of the UTF-8 encoding of the string (or UTF-EBCDIC encoding on
366EBCDIC machines); otherwise it returns FALSE. That is, it returns TRUE if they
367are UTF-8 invariant. On ASCII-ish machines, all the ASCII characters and only
368the ASCII characters fit this definition. On EBCDIC machines, the ASCII-range
369characters are invariant, but so also are the C1 controls.
370
371If C<len> is 0, it will be calculated using C<strlen(s)>, (which means if you
372use this option, that C<s> can't have embedded C<NUL> characters and has to
373have a terminating C<NUL> byte).
374
375See also
376C<L</is_utf8_string>>,
377C<L</is_utf8_string_flags>>,
378C<L</is_utf8_string_loc>>,
379C<L</is_utf8_string_loc_flags>>,
380C<L</is_utf8_string_loclen>>,
381C<L</is_utf8_string_loclen_flags>>,
382C<L</is_utf8_fixed_width_buf_flags>>,
383C<L</is_utf8_fixed_width_buf_loc_flags>>,
384C<L</is_utf8_fixed_width_buf_loclen_flags>>,
385C<L</is_strict_utf8_string>>,
386C<L</is_strict_utf8_string_loc>>,
387C<L</is_strict_utf8_string_loclen>>,
388C<L</is_c9strict_utf8_string>>,
389C<L</is_c9strict_utf8_string_loc>>,
390and
391C<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
403Like C<L</is_utf8_invariant_string>> but upon failure, stores the location of
404the first UTF-8 variant character in the C<ep> pointer; if all characters are
405UTF-8 invariant, this function does not change the contents of C<*ep>.
406
407=cut
408
409*/
410
411PERL_STATIC_INLINEstatic __inline__ bool_Bool
412Perl_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
521PERL_STATIC_INLINEstatic __inline__ unsigned int
522Perl_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
617This function looks at the sequence of bytes between C<s> and C<e>, which are
618assumed to be encoded in ASCII/Latin1, and returns how many of them would
619change should the string be translated into UTF-8. Due to the nature of UTF-8,
620each of these would occupy two bytes instead of the single one in the input
621string. Thus, this function returns the precise number of bytes the string
622would expand by when translated to UTF-8.
623
624Unlike most of the other functions that have C<utf8> in their name, the input
625to this function is NOT a UTF-8-encoded string. The function name is slightly
626I<odd> to emphasize this.
627
628This function is internal to Perl because khw thinks that any XS code that
629would want this is probably operating too close to the internals. Presenting a
630valid use case could change that.
631
632See also
633C<L<perlapi/is_utf8_invariant_string>>
634and
635C<L<perlapi/is_utf8_invariant_string_loc>>,
636
637=cut
638
639*/
640
641PERL_STATIC_INLINEstatic __inline__ Size_tsize_t
642S_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
702Returns TRUE if the first C<len> bytes of string C<s> form a valid
703Perl-extended-UTF-8 string; returns FALSE otherwise. If C<len> is 0, it will
704be calculated using C<strlen(s)> (which means if you use this option, that C<s>
705can't have embedded C<NUL> characters and has to have a terminating C<NUL>
706byte). Note that all characters being ASCII constitute 'a valid UTF-8 string'.
707
708This function considers Perl's extended UTF-8 to be valid. That means that
709code points above Unicode, surrogates, and non-character code points are
710considered valid by this function. Use C<L</is_strict_utf8_string>>,
711C<L</is_c9strict_utf8_string>>, or C<L</is_utf8_string_flags>> to restrict what
712code points are considered valid.
713
714See also
715C<L</is_utf8_invariant_string>>,
716C<L</is_utf8_invariant_string_loc>>,
717C<L</is_utf8_string_loc>>,
718C<L</is_utf8_string_loclen>>,
719C<L</is_utf8_fixed_width_buf_flags>>,
720C<L</is_utf8_fixed_width_buf_loc_flags>>,
721C<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
733Returns TRUE if L<perlapi/is_utf8_invariant_string> returns FALSE for the first
734C<len> bytes of the string C<s>, but they are, nonetheless, legal Perl-extended
735UTF-8; otherwise returns FALSE.
736
737A TRUE return means that at least one code point represented by the sequence
738either is a wide character not representable as a single byte, or the
739representation differs depending on whether the sequence is encoded in UTF-8 or
740not.
741
742See also
743C<L<perlapi/is_utf8_invariant_string>>,
744C<L<perlapi/is_utf8_string>>
745
746=cut
747
748This is commonly used to determine if a SV's UTF-8 flag should be turned on.
749It generally needn't be if its string is entirely UTF-8 invariant, and it
750shouldn't be if it otherwise contains invalid UTF-8.
751
752It is an internal function because khw thinks that XS code shouldn't be working
753at this low a level. A valid use case could change that.
754
755*/
756
757PERL_STATIC_INLINEstatic __inline__ bool_Bool
758Perl_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
776Returns TRUE if the first C<len> bytes of string C<s> form a valid
777UTF-8-encoded string that is fully interchangeable by any application using
778Unicode rules; otherwise it returns FALSE. If C<len> is 0, it will be
779calculated using C<strlen(s)> (which means if you use this option, that C<s>
780can't have embedded C<NUL> characters and has to have a terminating C<NUL>
781byte). Note that all characters being ASCII constitute 'a valid UTF-8 string'.
782
783This function returns FALSE for strings containing any
784code points above the Unicode max of 0x10FFFF, surrogate code points, or
785non-character code points.
786
787See also
788C<L</is_utf8_invariant_string>>,
789C<L</is_utf8_invariant_string_loc>>,
790C<L</is_utf8_string>>,
791C<L</is_utf8_string_flags>>,
792C<L</is_utf8_string_loc>>,
793C<L</is_utf8_string_loc_flags>>,
794C<L</is_utf8_string_loclen>>,
795C<L</is_utf8_string_loclen_flags>>,
796C<L</is_utf8_fixed_width_buf_flags>>,
797C<L</is_utf8_fixed_width_buf_loc_flags>>,
798C<L</is_utf8_fixed_width_buf_loclen_flags>>,
799C<L</is_strict_utf8_string_loc>>,
800C<L</is_strict_utf8_string_loclen>>,
801C<L</is_c9strict_utf8_string>>,
802C<L</is_c9strict_utf8_string_loc>>,
803and
804C<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
814Returns TRUE if the first C<len> bytes of string C<s> form a valid
815UTF-8-encoded string that conforms to
816L<Unicode Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>;
817otherwise it returns FALSE. If C<len> is 0, it will be calculated using
818C<strlen(s)> (which means if you use this option, that C<s> can't have embedded
819C<NUL> characters and has to have a terminating C<NUL> byte). Note that all
820characters being ASCII constitute 'a valid UTF-8 string'.
821
822This function returns FALSE for strings containing any code points above the
823Unicode max of 0x10FFFF or surrogate code points, but accepts non-character
824code points per
825L<Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>.
826
827See also
828C<L</is_utf8_invariant_string>>,
829C<L</is_utf8_invariant_string_loc>>,
830C<L</is_utf8_string>>,
831C<L</is_utf8_string_flags>>,
832C<L</is_utf8_string_loc>>,
833C<L</is_utf8_string_loc_flags>>,
834C<L</is_utf8_string_loclen>>,
835C<L</is_utf8_string_loclen_flags>>,
836C<L</is_utf8_fixed_width_buf_flags>>,
837C<L</is_utf8_fixed_width_buf_loc_flags>>,
838C<L</is_utf8_fixed_width_buf_loclen_flags>>,
839C<L</is_strict_utf8_string>>,
840C<L</is_strict_utf8_string_loc>>,
841C<L</is_strict_utf8_string_loclen>>,
842C<L</is_c9strict_utf8_string_loc>>,
843and
844C<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
854Returns TRUE if the first C<len> bytes of string C<s> form a valid
855UTF-8 string, subject to the restrictions imposed by C<flags>;
856returns FALSE otherwise. If C<len> is 0, it will be calculated
857using C<strlen(s)> (which means if you use this option, that C<s> can't have
858embedded C<NUL> characters and has to have a terminating C<NUL> byte). Note
859that all characters being ASCII constitute 'a valid UTF-8 string'.
860
861If C<flags> is 0, this gives the same results as C<L</is_utf8_string>>; if
862C<flags> is C<UTF8_DISALLOW_ILLEGAL_INTERCHANGE>, this gives the same results
863as C<L</is_strict_utf8_string>>; and if C<flags> is
864C<UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE>, this gives the same results as
865C<L</is_c9strict_utf8_string>>. Otherwise C<flags> may be any
866combination of the C<UTF8_DISALLOW_I<foo>> flags understood by
867C<L</utf8n_to_uvchr>>, with the same meanings.
868
869See also
870C<L</is_utf8_invariant_string>>,
871C<L</is_utf8_invariant_string_loc>>,
872C<L</is_utf8_string>>,
873C<L</is_utf8_string_loc>>,
874C<L</is_utf8_string_loc_flags>>,
875C<L</is_utf8_string_loclen>>,
876C<L</is_utf8_string_loclen_flags>>,
877C<L</is_utf8_fixed_width_buf_flags>>,
878C<L</is_utf8_fixed_width_buf_loc_flags>>,
879C<L</is_utf8_fixed_width_buf_loclen_flags>>,
880C<L</is_strict_utf8_string>>,
881C<L</is_strict_utf8_string_loc>>,
882C<L</is_strict_utf8_string_loclen>>,
883C<L</is_c9strict_utf8_string>>,
884C<L</is_c9strict_utf8_string_loc>>,
885and
886C<L</is_c9strict_utf8_string_loclen>>.
887
888=cut
889*/
890
891PERL_STATIC_INLINEstatic __inline__ bool_Bool
892Perl_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
940Like C<L</is_utf8_string>> but stores the location of the failure (in the
941case of "utf8ness failure") or the location C<s>+C<len> (in the case of
942"utf8ness success") in the C<ep> pointer.
943
944See 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
955Like C<L</is_utf8_string>> but stores the location of the failure (in the
956case 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
958encoded characters in the C<el> pointer.
959
960See also C<L</is_utf8_string_loc>>.
961
962=cut
963*/
964
965PERL_STATIC_INLINEstatic __inline__ bool_Bool
966Perl_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
1016Evaluates to non-zero if the first few bytes of the string starting at C<s> and
1017looking no further than S<C<e - 1>> are well-formed UTF-8, as extended by Perl,
1018that represents some code point; otherwise it evaluates to 0. If non-zero, the
1019value gives how many bytes starting at C<s> comprise the code point's
1020representation. Any bytes remaining before C<e>, but beyond the ones needed to
1021form the first code point in C<s>, are not examined.
1022
1023The code point can be any that will fit in an IV on this machine, using Perl's
1024extension to official UTF-8 to represent those higher than the Unicode maximum
1025of 0x10FFFF. That means that this macro is used to efficiently decide if the
1026next few bytes in C<s> is legal UTF-8 for a single character.
1027
1028Use C<L</isSTRICT_UTF8_CHAR>> to restrict the acceptable code points to those
1029defined by Unicode to be fully interchangeable across applications;
1030C<L</isC9_STRICT_UTF8_CHAR>> to use the L<Unicode Corrigendum
1031#9|http://www.unicode.org/versions/corrigendum9.html> definition of allowable
1032code points; and C<L</isUTF8_CHAR_flags>> for a more customized definition.
1033
1034Use C<L</is_utf8_string>>, C<L</is_utf8_string_loc>>, and
1035C<L</is_utf8_string_loclen>> to check entire strings.
1036
1037Note also that a UTF-8 "invariant" character (i.e. ASCII on non-EBCDIC
1038machines) is a valid UTF-8 character.
1039
1040=cut
1041
1042This uses an adaptation of the table and algorithm given in
1043https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
1044documentation of the original version. A copyright notice for the original
1045version is given at the beginning of this file. The Perl adapation is
1046documented at the definition of PL_extended_utf8_dfa_tab[].
1047
1048*/
1049
1050PERL_STATIC_INLINEstatic __inline__ Size_tsize_t
1051Perl_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
1091Evaluates to non-zero if the first few bytes of the string starting at C<s> and
1092looking no further than S<C<e - 1>> are well-formed UTF-8 that represents some
1093Unicode code point completely acceptable for open interchange between all
1094applications; otherwise it evaluates to 0. If non-zero, the value gives how
1095many bytes starting at C<s> comprise the code point's representation. Any
1096bytes remaining before C<e>, but beyond the ones needed to form the first code
1097point in C<s>, are not examined.
1098
1099The largest acceptable code point is the Unicode maximum 0x10FFFF, and must not
1100be a surrogate nor a non-character code point. Thus this excludes any code
1101point from Perl's extended UTF-8.
1102
1103This is used to efficiently decide if the next few bytes in C<s> is
1104legal Unicode-acceptable UTF-8 for a single character.
1105
1106Use C<L</isC9_STRICT_UTF8_CHAR>> to use the L<Unicode Corrigendum
1107#9|http://www.unicode.org/versions/corrigendum9.html> definition of allowable
1108code points; C<L</isUTF8_CHAR>> to check for Perl's extended UTF-8;
1109and C<L</isUTF8_CHAR_flags>> for a more customized definition.
1110
1111Use C<L</is_strict_utf8_string>>, C<L</is_strict_utf8_string_loc>>, and
1112C<L</is_strict_utf8_string_loclen>> to check entire strings.
1113
1114=cut
1115
1116This uses an adaptation of the tables and algorithm given in
1117https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
1118documentation of the original version. A copyright notice for the original
1119version is given at the beginning of this file. The Perl adapation is
1120documented at the definition of strict_extended_utf8_dfa_tab[].
1121
1122*/
1123
1124PERL_STATIC_INLINEstatic __inline__ Size_tsize_t
1125Perl_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
1159Evaluates to non-zero if the first few bytes of the string starting at C<s> and
1160looking no further than S<C<e - 1>> are well-formed UTF-8 that represents some
1161Unicode non-surrogate code point; otherwise it evaluates to 0. If non-zero,
1162the value gives how many bytes starting at C<s> comprise the code point's
1163representation. Any bytes remaining before C<e>, but beyond the ones needed to
1164form the first code point in C<s>, are not examined.
1165
1166The largest acceptable code point is the Unicode maximum 0x10FFFF. This
1167differs from C<L</isSTRICT_UTF8_CHAR>> only in that it accepts non-character
1168code points. This corresponds to
1169L<Unicode Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>.
1170which said that non-character code points are merely discouraged rather than
1171completely forbidden in open interchange. See
1172L<perlunicode/Noncharacter code points>.
1173
1174Use C<L</isUTF8_CHAR>> to check for Perl's extended UTF-8; and
1175C<L</isUTF8_CHAR_flags>> for a more customized definition.
1176
1177Use C<L</is_c9strict_utf8_string>>, C<L</is_c9strict_utf8_string_loc>>, and
1178C<L</is_c9strict_utf8_string_loclen>> to check entire strings.
1179
1180=cut
1181
1182This uses an adaptation of the tables and algorithm given in
1183https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
1184documentation of the original version. A copyright notice for the original
1185version is given at the beginning of this file. The Perl adapation is
1186documented at the definition of PL_c9_utf8_dfa_tab[].
1187
1188*/
1189
1190PERL_STATIC_INLINEstatic __inline__ Size_tsize_t
1191Perl_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
1216Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
1217case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1218"utf8ness success") in the C<ep> pointer.
1219
1220See 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
1232Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
1233case 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
1235encoded characters in the C<el> pointer.
1236
1237See also C<L</is_strict_utf8_string_loc>>.
1238
1239=cut
1240*/
1241
1242PERL_STATIC_INLINEstatic __inline__ bool_Bool
1243Perl_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
1293Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in
1294the case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1295"utf8ness success") in the C<ep> pointer.
1296
1297See 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
1309Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in
1310the 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
1312characters in the C<el> pointer.
1313
1314See also C<L</is_c9strict_utf8_string_loc>>.
1315
1316=cut
1317*/
1318
1319PERL_STATIC_INLINEstatic __inline__ bool_Bool
1320Perl_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
1370Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the
1371case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1372"utf8ness success") in the C<ep> pointer.
1373
1374See 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
1391Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the
1392case 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
1394encoded characters in the C<el> pointer.
1395
1396See also C<L</is_utf8_string_loc_flags>>.
1397
1398=cut
1399*/
1400
1401PERL_STATIC_INLINEstatic __inline__ bool_Bool
1402Perl_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) {
17
←
Assuming 'len' is equal to 0
→
18
←
Taking true branch
→
1411 len = strlen((const char *) s);
19
←
Null pointer passed as 1st argument to string length function
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
1469Returns the number of UTF-8 characters between the UTF-8 pointers C<a>
1470and C<b>.
1471
1472WARNING: use only if you *know* that the pointers point inside the
1473same UTF-8 buffer.
1474
1475=cut
1476*/
1477
1478PERL_STATIC_INLINEstatic __inline__ IV
1479Perl_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
1489Return the UTF-8 pointer C<s> displaced by C<off> characters, either
1490forward or backward.
1491
1492WARNING: do not use the following unless you *know* C<off> is within
1493the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
1494on the first byte of character or just after the last byte of a character.
1495
1496=cut
1497*/
1498
1499PERL_STATIC_INLINEstatic __inline__ U8 *
1500Perl_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
1527Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1528forward.
1529
1530C<off> must be non-negative.
1531
1532C<s> must be before or equal to C<end>.
1533
1534When moving forward it will not move beyond C<end>.
1535
1536Will not exceed this limit even if the string is not valid "UTF-8".
1537
1538=cut
1539*/
1540
1541PERL_STATIC_INLINEstatic __inline__ U8 *
1542Perl_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
1571Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1572backward.
1573
1574C<off> must be non-positive.
1575
1576C<s> must be after or equal to C<start>.
1577
1578When moving backward it will not move before C<start>.
1579
1580Will not exceed this limit even if the string is not valid "UTF-8".
1581
1582=cut
1583*/
1584
1585PERL_STATIC_INLINEstatic __inline__ U8 *
1586Perl_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
1611Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1612either forward or backward.
1613
1614When moving backward it will not move before C<start>.
1615
1616When moving forward it will not move beyond C<end>.
1617
1618Will not exceed those limits even if the string is not valid "UTF-8".
1619
1620=cut
1621*/
1622
1623PERL_STATIC_INLINEstatic __inline__ U8 *
1624Perl_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
1646Returns 0 if the sequence of bytes starting at C<s> and looking no further than
1647S<C<e - 1>> is the UTF-8 encoding, as extended by Perl, for one or more code
1648points. Otherwise, it returns 1 if there exists at least one non-empty
1649sequence of bytes that when appended to sequence C<s>, starting at position
1650C<e> causes the entire sequence to be the well-formed UTF-8 of some code point;
1651otherwise returns 0.
1652
1653In other words this returns TRUE if C<s> points to a partial UTF-8-encoded code
1654point.
1655
1656This is useful when a fixed-length buffer is being tested for being well-formed
1657UTF-8, but the final few bytes in it don't comprise a full character; that is,
1658it is split somewhere in the middle of the final code point's UTF-8
1659representation. (Presumably when the buffer is refreshed with the next chunk
1660of data, the new first bytes will complete the partial code point.) This
1661function is used to verify that the final bytes in the current buffer are in
1662fact the legal beginning of some code point, so that if they aren't, the
1663failure 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
1674Like C<L</is_utf8_valid_partial_char>>, it returns a boolean giving whether
1675or not the input is a valid UTF-8 encoded partial character, but it takes an
1676extra parameter, C<flags>, which can further restrict which code points are
1677considered valid.
1678
1679If C<flags> is 0, this behaves identically to
1680C<L</is_utf8_valid_partial_char>>. Otherwise C<flags> can be any combination
1681of the C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>. If
1682there is any sequence of bytes that can complete the input partial character in
1683such a way that a non-prohibited character is formed, the function returns
1684TRUE; otherwise FALSE. Non character code points cannot be determined based on
1685partial character input. But many of the other possible excluded types can be
1686determined from just the first one or two bytes.
1687
1688=cut
1689 */
1690
1691PERL_STATIC_INLINEstatic __inline__ bool_Bool
1692Perl_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
1710Returns TRUE if the fixed-width buffer starting at C<s> with length C<len>
1711is entirely valid UTF-8, subject to the restrictions given by C<flags>;
1712otherwise it returns FALSE.
1713
1714If C<flags> is 0, any well-formed UTF-8, as extended by Perl, is accepted
1715without restriction. If the final few bytes of the buffer do not form a
1716complete code point, this will return TRUE anyway, provided that
1717C<L</is_utf8_valid_partial_char_flags>> returns TRUE for them.
1718
1719If C<flags> in non-zero, it can be any combination of the
1720C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>, and with the
1721same meanings.
1722
1723This function differs from C<L</is_utf8_string_flags>> only in that the latter
1724returns FALSE if the final few bytes of the string don't form a complete code
1725point.
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
1736Like C<L</is_utf8_fixed_width_buf_flags>> but stores the location of the
1737failure in the C<ep> pointer. If the function returns TRUE, C<*ep> will point
1738to the beginning of any partial character at the end of the buffer; if there is
1739no partial character C<*ep> will contain C<s>+C<len>.
1740
1741See 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
1753Like C<L</is_utf8_fixed_width_buf_loc_flags>> but stores the number of
1754complete, valid characters found in the C<el> pointer.
1755
1756=cut
1757*/
1758
1759PERL_STATIC_INLINEstatic __inline__ bool_Bool
1760Perl_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
1780PERL_STATIC_INLINEstatic __inline__ UV
1781Perl_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
1843PERL_STATIC_INLINEstatic __inline__ UV
1844Perl_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
1875Test that the given C<pv> (with length C<len>) doesn't contain any internal
1876C<NUL> characters.
1877If it does, set C<errno> to C<ENOENT>, optionally warn using the C<syscalls>
1878category, and return FALSE.
1879
1880Return TRUE if the name is safe.
1881
1882C<what> and C<op_name> are used in any warning.
1883
1884Used by the C<IS_SAFE_SYSCALL()> macro.
1885
1886=cut
1887*/
1888
1889PERL_STATIC_INLINEstatic __inline__ bool_Bool
1890Perl_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
1914Return true if the supplied filename has a newline character
1915immediately before the first (hopefully only) NUL.
1916
1917My original look at this incorrectly used the len from SvPV(), but
1918that's incorrect, since we allow for a NUL in pv[len-1].
1919
1920So instead, strlen() and work from there.
1921
1922This allow for the user reading a filename, forgetting to chomp it,
1923then calling:
1924
1925 open my $foo, "$file\0";
1926
1927*/
1928
1929#ifdef PERL_CORE
1930
1931PERL_STATIC_INLINEstatic __inline__ bool_Bool
1932S_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
1947PERL_STATIC_INLINEstatic __inline__ bool_Bool
1948S_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 */
1987PERL_STATIC_INLINEstatic __inline__ bool_Bool
1988S_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
2015PERL_STATIC_INLINEstatic __inline__ const char *
2016S_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
2044Return false if any get magic is on the SV other than taint magic.
2045
2046*/
2047
2048PERL_STATIC_INLINEstatic __inline__ bool_Bool
2049Perl_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
2071PERL_STATIC_INLINEstatic __inline__ U8
2072Perl_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
2089PERL_STATIC_INLINEstatic __inline__ PERL_CONTEXT *
2090Perl_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
2116PERL_STATIC_INLINEstatic __inline__ void
2117Perl_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
2141PERL_STATIC_INLINEstatic __inline__ void
2142Perl_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
2156PERL_STATIC_INLINEstatic __inline__ void
2157Perl_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
2178PERL_STATIC_INLINEstatic __inline__ void
2179Perl_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
2198PERL_STATIC_INLINEstatic __inline__ void
2199Perl_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
2220PERL_STATIC_INLINEstatic __inline__ void
2221Perl_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
2234PERL_STATIC_INLINEstatic __inline__ void
2235Perl_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
2254PERL_STATIC_INLINEstatic __inline__ void
2255Perl_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
2278PERL_STATIC_INLINEstatic __inline__ void
2279Perl_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
2298PERL_STATIC_INLINEstatic __inline__ void
2299Perl_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
2331PERL_STATIC_INLINEstatic __inline__ void
2332Perl_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
2343PERL_STATIC_INLINEstatic __inline__ void
2344Perl_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
2361PERL_STATIC_INLINEstatic __inline__ void
2362Perl_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
2394PERL_STATIC_INLINEstatic __inline__ void
2395Perl_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
2403PERL_STATIC_INLINEstatic __inline__ void
2404Perl_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
2415PERL_STATIC_INLINEstatic __inline__ void
2416Perl_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
2425PERL_STATIC_INLINEstatic __inline__ void
2426Perl_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
2446Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
2447same
2448case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes
2449match themselves and their opposite case counterparts. Non-cased and non-ASCII
2450range bytes match only themselves.
2451
2452=cut
2453*/
2454
2455PERL_STATIC_INLINEstatic __inline__ I32
2456Perl_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
2473PERL_STATIC_INLINEstatic __inline__ I32
2474Perl_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
2500Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
2501same case-insensitively in the current locale; false otherwise.
2502
2503=cut
2504*/
2505
2506PERL_STATIC_INLINEstatic __inline__ I32
2507Perl_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
2528The C library C<strnlen> if available, or a Perl implementation of it.
2529
2530C<my_strnlen()> computes the length of the string, up to C<maxlen>
2531characters. It will never attempt to address more than C<maxlen>
2532characters, making it suitable for use with strings that are not
2533guaranteed to be NUL-terminated.
2534
2535=cut
2536
2537Description stolen from http://man.openbsd.org/strnlen.3,
2538implementation stolen from PostgreSQL.
2539*/
2540#ifndef HAS_STRNLEN
2541
2542PERL_STATIC_INLINEstatic __inline__ Size_tsize_t
2543Perl_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
2557PERL_STATIC_INLINEstatic __inline__ void *
2558S_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
2578PERL_STATIC_INLINEstatic __inline__ char *
2579Perl_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 */