This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
t/lib/Cname.pm: Comment, white-space only
[perl5.git] / inline.h
CommitLineData
25468daa
FC
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 *
8ed185f9 8 * This file contains tables and code adapted from
f6521f7c 9 * https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which requires this
8ed185f9
KW
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 *
25468daa 33 * This file is a home for static inline functions that cannot go in other
e15e54ff 34 * header files, because they depend on proto.h (included after most other
25468daa
FC
35 * headers) or struct definitions.
36 *
37 * Each section names the header file that the functions "belong" to.
38 */
27669aa4 39
be3a7a5d
KW
40/* ------------------------------- av.h ------------------------------- */
41
87306e06 42/*
3f620621 43=for apidoc_section $AV
87306e06
KW
44=for apidoc av_count
45Returns the number of elements in the array C<av>. This is the true length of
46the array, including any undefined elements. It is always the same as
47S<C<av_top_index(av) + 1>>.
48
49=cut
50*/
51PERL_STATIC_INLINE Size_t
52Perl_av_count(pTHX_ AV *av)
be3a7a5d 53{
87306e06 54 PERL_ARGS_ASSERT_AV_COUNT;
be3a7a5d
KW
55 assert(SvTYPE(av) == SVt_PVAV);
56
87306e06 57 return AvFILL(av) + 1;
be3a7a5d
KW
58}
59
1afe1db1
FC
60/* ------------------------------- cv.h ------------------------------- */
61
fa3e44c0 62/*
3f620621 63=for apidoc_section $CV
fa3e44c0
KW
64=for apidoc CvGV
65Returns the GV associated with the CV C<sv>, reifying it if necessary.
66
67=cut
68*/
ae77754a 69PERL_STATIC_INLINE GV *
c9182d9c 70Perl_CvGV(pTHX_ CV *sv)
ae77754a 71{
74804ad1
KW
72 PERL_ARGS_ASSERT_CVGV;
73
ae77754a
FC
74 return CvNAMED(sv)
75 ? Perl_cvgv_from_hek(aTHX_ sv)
76 : ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_gv;
77}
78
1afe1db1 79PERL_STATIC_INLINE I32 *
74804ad1 80Perl_CvDEPTH(const CV * const sv)
1afe1db1 81{
74804ad1 82 PERL_ARGS_ASSERT_CVDEPTH;
1afe1db1 83 assert(SvTYPE(sv) == SVt_PVCV || SvTYPE(sv) == SVt_PVFM);
74804ad1 84
8de47657 85 return &((XPVCV*)SvANY(sv))->xcv_depth;
1afe1db1
FC
86}
87
d16269d8
PM
88/*
89 CvPROTO returns the prototype as stored, which is not necessarily what
90 the interpreter should be using. Specifically, the interpreter assumes
91 that spaces have been stripped, which has been the case if the prototype
92 was added by toke.c, but is generally not the case if it was added elsewhere.
93 Since we can't enforce the spacelessness at assignment time, this routine
94 provides a temporary copy at parse time with spaces removed.
95 I<orig> is the start of the original buffer, I<len> is the length of the
96 prototype and will be updated when this returns.
97 */
98
5b67adb8 99#ifdef PERL_CORE
d16269d8
PM
100PERL_STATIC_INLINE char *
101S_strip_spaces(pTHX_ const char * orig, STRLEN * const len)
102{
103 SV * tmpsv;
104 char * tmps;
105 tmpsv = newSVpvn_flags(orig, *len, SVs_TEMP);
106 tmps = SvPVX(tmpsv);
107 while ((*len)--) {
108 if (!isSPACE(*orig))
109 *tmps++ = *orig;
110 orig++;
111 }
112 *tmps = '\0';
113 *len = tmps - SvPVX(tmpsv);
114 return SvPVX(tmpsv);
115}
5b67adb8 116#endif
d16269d8 117
25fdce4a
FC
118/* ------------------------------- mg.h ------------------------------- */
119
120#if defined(PERL_CORE) || defined(PERL_EXT)
121/* assumes get-magic and stringification have already occurred */
122PERL_STATIC_INLINE STRLEN
123S_MgBYTEPOS(pTHX_ MAGIC *mg, SV *sv, const char *s, STRLEN len)
124{
125 assert(mg->mg_type == PERL_MAGIC_regex_global);
126 assert(mg->mg_len != -1);
127 if (mg->mg_flags & MGf_BYTES || !DO_UTF8(sv))
128 return (STRLEN)mg->mg_len;
129 else {
130 const STRLEN pos = (STRLEN)mg->mg_len;
131 /* Without this check, we may read past the end of the buffer: */
132 if (pos > sv_or_pv_len_utf8(sv, s, len)) return len+1;
133 return sv_or_pv_pos_u2b(sv, s, pos, NULL);
134 }
135}
136#endif
137
03414f05
FC
138/* ------------------------------- pad.h ------------------------------ */
139
140#if defined(PERL_IN_PAD_C) || defined(PERL_IN_OP_C)
141PERL_STATIC_INLINE bool
b9d5702c 142S_PadnameIN_SCOPE(const PADNAME * const pn, const U32 seq)
03414f05 143{
b9d5702c
KW
144 PERL_ARGS_ASSERT_PADNAMEIN_SCOPE;
145
03414f05
FC
146 /* is seq within the range _LOW to _HIGH ?
147 * This is complicated by the fact that PL_cop_seqmax
148 * may have wrapped around at some point */
149 if (COP_SEQ_RANGE_LOW(pn) == PERL_PADSEQ_INTRO)
150 return FALSE; /* not yet introduced */
151
152 if (COP_SEQ_RANGE_HIGH(pn) == PERL_PADSEQ_INTRO) {
153 /* in compiling scope */
154 if (
155 (seq > COP_SEQ_RANGE_LOW(pn))
156 ? (seq - COP_SEQ_RANGE_LOW(pn) < (U32_MAX >> 1))
157 : (COP_SEQ_RANGE_LOW(pn) - seq > (U32_MAX >> 1))
158 )
159 return TRUE;
160 }
161 else if (
162 (COP_SEQ_RANGE_LOW(pn) > COP_SEQ_RANGE_HIGH(pn))
163 ?
164 ( seq > COP_SEQ_RANGE_LOW(pn)
165 || seq <= COP_SEQ_RANGE_HIGH(pn))
166
167 : ( seq > COP_SEQ_RANGE_LOW(pn)
168 && seq <= COP_SEQ_RANGE_HIGH(pn))
169 )
170 return TRUE;
171 return FALSE;
172}
173#endif
174
33a4312b
FC
175/* ------------------------------- pp.h ------------------------------- */
176
177PERL_STATIC_INLINE I32
c9182d9c 178Perl_TOPMARK(pTHX)
33a4312b
FC
179{
180 DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
147e3846 181 "MARK top %p %" IVdf "\n",
33a4312b
FC
182 PL_markstack_ptr,
183 (IV)*PL_markstack_ptr)));
184 return *PL_markstack_ptr;
185}
186
187PERL_STATIC_INLINE I32
c9182d9c 188Perl_POPMARK(pTHX)
33a4312b
FC
189{
190 DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
147e3846 191 "MARK pop %p %" IVdf "\n",
33a4312b
FC
192 (PL_markstack_ptr-1),
193 (IV)*(PL_markstack_ptr-1))));
194 assert((PL_markstack_ptr > PL_markstack) || !"MARK underflow");
195 return *PL_markstack_ptr--;
196}
197
8d919b0a
FC
198/* ----------------------------- regexp.h ----------------------------- */
199
200PERL_STATIC_INLINE struct regexp *
c9182d9c 201Perl_ReANY(const REGEXP * const re)
8d919b0a 202{
df6b4bd5 203 XPV* const p = (XPV*)SvANY(re);
bdef45de
KW
204
205 PERL_ARGS_ASSERT_REANY;
8d919b0a 206 assert(isREGEXP(re));
bdef45de 207
df6b4bd5
DM
208 return SvTYPE(re) == SVt_PVLV ? p->xpv_len_u.xpvlenu_rx
209 : (struct regexp *)p;
8d919b0a
FC
210}
211
27669aa4
FC
212/* ------------------------------- sv.h ------------------------------- */
213
a887b094 214PERL_STATIC_INLINE bool
4eff5eb8
KW
215Perl_SvTRUE(pTHX_ SV *sv)
216{
217 PERL_ARGS_ASSERT_SVTRUE;
218
6aa30f5e 219 if (UNLIKELY(sv == NULL))
9d0469db 220 return FALSE;
7b9b9e32
PLE
221 SvGETMAGIC(sv);
222 return SvTRUE_nomg_NN(sv);
a887b094
PLE
223}
224
4eff5eb8
KW
225PERL_STATIC_INLINE bool
226Perl_SvTRUE_nomg(pTHX_ SV *sv)
227{
228 PERL_ARGS_ASSERT_SVTRUE_NOMG;
229
230 if (UNLIKELY(sv == NULL))
231 return FALSE;
232 return SvTRUE_nomg_NN(sv);
233}
234
235PERL_STATIC_INLINE bool
236Perl_SvTRUE_NN(pTHX_ SV *sv)
237{
238 PERL_ARGS_ASSERT_SVTRUE_NN;
239
240 SvGETMAGIC(sv);
241 return SvTRUE_nomg_NN(sv);
242}
243
244PERL_STATIC_INLINE bool
245Perl_SvTRUE_common(pTHX_ SV * sv, const bool sv_2bool_is_fallback)
246{
247 PERL_ARGS_ASSERT_SVTRUE_COMMON;
248
249 if (UNLIKELY(SvIMMORTAL_INTERP(sv)))
250 return SvIMMORTAL_TRUE(sv);
251
252 if (! SvOK(sv))
253 return FALSE;
254
255 if (SvPOK(sv))
256 return SvPVXtrue(sv);
257
258 if (SvIOK(sv))
259 return SvIVX(sv) != 0; /* casts to bool */
260
261 if (SvROK(sv) && !(SvOBJECT(SvRV(sv)) && HvAMAGIC(SvSTASH(SvRV(sv)))))
262 return TRUE;
263
264 if (sv_2bool_is_fallback)
265 return sv_2bool_nomg(sv);
266
267 return isGV_with_GP(sv);
268}
269
270
27669aa4 271PERL_STATIC_INLINE SV *
c9182d9c 272Perl_SvREFCNT_inc(SV *sv)
27669aa4 273{
2439e033 274 if (LIKELY(sv != NULL))
27669aa4
FC
275 SvREFCNT(sv)++;
276 return sv;
277}
278PERL_STATIC_INLINE SV *
c9182d9c 279Perl_SvREFCNT_inc_NN(SV *sv)
27669aa4 280{
3f2f854a
KW
281 PERL_ARGS_ASSERT_SVREFCNT_INC_NN;
282
27669aa4
FC
283 SvREFCNT(sv)++;
284 return sv;
285}
286PERL_STATIC_INLINE void
c9182d9c 287Perl_SvREFCNT_inc_void(SV *sv)
27669aa4 288{
2439e033 289 if (LIKELY(sv != NULL))
27669aa4
FC
290 SvREFCNT(sv)++;
291}
75e16a44 292PERL_STATIC_INLINE void
c9182d9c 293Perl_SvREFCNT_dec(pTHX_ SV *sv)
75e16a44 294{
2439e033 295 if (LIKELY(sv != NULL)) {
75a9bf96 296 U32 rc = SvREFCNT(sv);
79e2a32a 297 if (LIKELY(rc > 1))
75a9bf96
DM
298 SvREFCNT(sv) = rc - 1;
299 else
300 Perl_sv_free2(aTHX_ sv, rc);
75e16a44
FC
301 }
302}
541377b1
FC
303
304PERL_STATIC_INLINE void
c9182d9c 305Perl_SvREFCNT_dec_NN(pTHX_ SV *sv)
4a9a56a7
DM
306{
307 U32 rc = SvREFCNT(sv);
3f2f854a
KW
308
309 PERL_ARGS_ASSERT_SVREFCNT_DEC_NN;
310
79e2a32a 311 if (LIKELY(rc > 1))
4a9a56a7
DM
312 SvREFCNT(sv) = rc - 1;
313 else
314 Perl_sv_free2(aTHX_ sv, rc);
315}
316
317PERL_STATIC_INLINE void
1bd041dc 318Perl_SvAMAGIC_on(SV *sv)
541377b1 319{
1bd041dc 320 PERL_ARGS_ASSERT_SVAMAGIC_ON;
541377b1 321 assert(SvROK(sv));
1bd041dc 322
541377b1
FC
323 if (SvOBJECT(SvRV(sv))) HvAMAGIC_on(SvSTASH(SvRV(sv)));
324}
325PERL_STATIC_INLINE void
1bd041dc 326Perl_SvAMAGIC_off(SV *sv)
541377b1 327{
1bd041dc
KW
328 PERL_ARGS_ASSERT_SVAMAGIC_OFF;
329
541377b1
FC
330 if (SvROK(sv) && SvOBJECT(SvRV(sv)))
331 HvAMAGIC_off(SvSTASH(SvRV(sv)));
332}
333
334PERL_STATIC_INLINE U32
c9182d9c 335Perl_SvPADSTALE_on(SV *sv)
541377b1 336{
c0683843 337 assert(!(SvFLAGS(sv) & SVs_PADTMP));
541377b1
FC
338 return SvFLAGS(sv) |= SVs_PADSTALE;
339}
340PERL_STATIC_INLINE U32
c9182d9c 341Perl_SvPADSTALE_off(SV *sv)
541377b1 342{
c0683843 343 assert(!(SvFLAGS(sv) & SVs_PADTMP));
541377b1
FC
344 return SvFLAGS(sv) &= ~SVs_PADSTALE;
345}
25fdce4a 346#if defined(PERL_CORE) || defined (PERL_EXT)
4ddea69a 347PERL_STATIC_INLINE STRLEN
6964422a 348S_sv_or_pv_pos_u2b(pTHX_ SV *sv, const char *pv, STRLEN pos, STRLEN *lenp)
4ddea69a 349{
25fdce4a 350 PERL_ARGS_ASSERT_SV_OR_PV_POS_U2B;
4ddea69a
FC
351 if (SvGAMAGIC(sv)) {
352 U8 *hopped = utf8_hop((U8 *)pv, pos);
353 if (lenp) *lenp = (STRLEN)(utf8_hop(hopped, *lenp) - hopped);
354 return (STRLEN)(hopped - (U8 *)pv);
355 }
356 return sv_pos_u2b_flags(sv,pos,lenp,SV_CONST_RETURN);
357}
358#endif
f019c49e 359
a8a2ceaa
KW
360/* ------------------------------- utf8.h ------------------------------- */
361
2fe720e2 362/*
3f620621 363=for apidoc_section $unicode
2fe720e2
KW
364*/
365
55d09dc8 366PERL_STATIC_INLINE void
c9182d9c 367Perl_append_utf8_from_native_byte(const U8 byte, U8** dest)
55d09dc8
KW
368{
369 /* Takes an input 'byte' (Latin1 or EBCDIC) and appends it to the UTF-8
370 * encoded string at '*dest', updating '*dest' to include it */
371
55d09dc8
KW
372 PERL_ARGS_ASSERT_APPEND_UTF8_FROM_NATIVE_BYTE;
373
6f2d5cbc 374 if (NATIVE_BYTE_IS_INVARIANT(byte))
a09ec51a 375 *((*dest)++) = byte;
55d09dc8 376 else {
a09ec51a
KW
377 *((*dest)++) = UTF8_EIGHT_BIT_HI(byte);
378 *((*dest)++) = UTF8_EIGHT_BIT_LO(byte);
55d09dc8
KW
379 }
380}
381
e123187a 382/*
2fe720e2 383=for apidoc valid_utf8_to_uvchr
09232555
KW
384Like C<L<perlapi/utf8_to_uvchr_buf>>, but should only be called when it is
385known that the next character in the input UTF-8 string C<s> is well-formed
386(I<e.g.>, it passes C<L<perlapi/isUTF8_CHAR>>. Surrogates, non-character code
387points, and non-Unicode code points are allowed.
2fe720e2
KW
388
389=cut
390
391 */
392
393PERL_STATIC_INLINE UV
394Perl_valid_utf8_to_uvchr(const U8 *s, STRLEN *retlen)
395{
c41b2540 396 const UV expectlen = UTF8SKIP(s);
2fe720e2
KW
397 const U8* send = s + expectlen;
398 UV uv = *s;
399
400 PERL_ARGS_ASSERT_VALID_UTF8_TO_UVCHR;
401
402 if (retlen) {
403 *retlen = expectlen;
404 }
405
406 /* An invariant is trivially returned */
407 if (expectlen == 1) {
408 return uv;
409 }
410
411 /* Remove the leading bits that indicate the number of bytes, leaving just
412 * the bits that are part of the value */
413 uv = NATIVE_UTF8_TO_I8(uv) & UTF_START_MASK(expectlen);
414
415 /* Now, loop through the remaining bytes, accumulating each into the
416 * working total as we go. (I khw tried unrolling the loop for up to 4
417 * bytes, but there was no performance improvement) */
418 for (++s; s < send; s++) {
419 uv = UTF8_ACCUMULATE(uv, *s);
420 }
421
422 return UNI_TO_NATIVE(uv);
423
424}
425
1e599354
KW
426/*
427=for apidoc is_utf8_invariant_string
428
82c5d941 429Returns TRUE if the first C<len> bytes of the string C<s> are the same
1e599354 430regardless of the UTF-8 encoding of the string (or UTF-EBCDIC encoding on
82c5d941
KW
431EBCDIC machines); otherwise it returns FALSE. That is, it returns TRUE if they
432are UTF-8 invariant. On ASCII-ish machines, all the ASCII characters and only
433the ASCII characters fit this definition. On EBCDIC machines, the ASCII-range
434characters are invariant, but so also are the C1 controls.
1e599354
KW
435
436If C<len> is 0, it will be calculated using C<strlen(s)>, (which means if you
437use this option, that C<s> can't have embedded C<NUL> characters and has to
438have a terminating C<NUL> byte).
439
9f2abfde
KW
440See also
441C<L</is_utf8_string>>,
442C<L</is_utf8_string_flags>>,
443C<L</is_utf8_string_loc>>,
444C<L</is_utf8_string_loc_flags>>,
445C<L</is_utf8_string_loclen>>,
446C<L</is_utf8_string_loclen_flags>>,
8bc127bf
KW
447C<L</is_utf8_fixed_width_buf_flags>>,
448C<L</is_utf8_fixed_width_buf_loc_flags>>,
449C<L</is_utf8_fixed_width_buf_loclen_flags>>,
9f2abfde
KW
450C<L</is_strict_utf8_string>>,
451C<L</is_strict_utf8_string_loc>>,
452C<L</is_strict_utf8_string_loclen>>,
453C<L</is_c9strict_utf8_string>>,
454C<L</is_c9strict_utf8_string_loc>>,
455and
456C<L</is_c9strict_utf8_string_loclen>>.
1e599354
KW
457
458=cut
0cbf5865
KW
459
460*/
461
462#define is_utf8_invariant_string(s, len) \
463 is_utf8_invariant_string_loc(s, len, NULL)
464
465/*
466=for apidoc is_utf8_invariant_string_loc
467
468Like C<L</is_utf8_invariant_string>> but upon failure, stores the location of
469the first UTF-8 variant character in the C<ep> pointer; if all characters are
470UTF-8 invariant, this function does not change the contents of C<*ep>.
471
472=cut
473
1e599354
KW
474*/
475
476PERL_STATIC_INLINE bool
c9182d9c 477Perl_is_utf8_invariant_string_loc(const U8* const s, STRLEN len, const U8 ** ep)
1e599354 478{
e17544a6 479 const U8* send;
1e599354
KW
480 const U8* x = s;
481
0cbf5865
KW
482 PERL_ARGS_ASSERT_IS_UTF8_INVARIANT_STRING_LOC;
483
e17544a6
KW
484 if (len == 0) {
485 len = strlen((const char *)s);
486 }
487
488 send = s + len;
489
4ab2fd9b 490/* This looks like 0x010101... */
2c5c8af5 491# define PERL_COUNT_MULTIPLIER (~ (UINTMAX_C(0)) / 0xFF)
4ab2fd9b
KW
492
493/* This looks like 0x808080... */
2c5c8af5 494# define PERL_VARIANTS_WORD_MASK (PERL_COUNT_MULTIPLIER * 0x80)
e099ea69 495# define PERL_WORDSIZE sizeof(PERL_UINTMAX_T)
2c5c8af5 496# define PERL_WORD_BOUNDARY_MASK (PERL_WORDSIZE - 1)
e17544a6 497
099e59a4
KW
498/* Evaluates to 0 if 'x' is at a word boundary; otherwise evaluates to 1, by
499 * or'ing together the lowest bits of 'x'. Hopefully the final term gets
500 * optimized out completely on a 32-bit system, and its mask gets optimized out
501 * on a 64-bit system */
2c5c8af5 502# define PERL_IS_SUBWORD_ADDR(x) (1 & ( PTR2nat(x) \
5eabe374
KW
503 | ( PTR2nat(x) >> 1) \
504 | ( ( (PTR2nat(x) \
505 & PERL_WORD_BOUNDARY_MASK) >> 2))))
099e59a4 506
3f515a2e
KW
507#ifndef EBCDIC
508
099e59a4
KW
509 /* Do the word-at-a-time iff there is at least one usable full word. That
510 * means that after advancing to a word boundary, there still is at least a
511 * full word left. The number of bytes needed to advance is 'wordsize -
512 * offset' unless offset is 0. */
513 if ((STRLEN) (send - x) >= PERL_WORDSIZE
514
515 /* This term is wordsize if subword; 0 if not */
516 + PERL_WORDSIZE * PERL_IS_SUBWORD_ADDR(x)
517
518 /* 'offset' */
519 - (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK))
520 {
b40579ff 521
46bb68f6
KW
522 /* Process per-byte until reach word boundary. XXX This loop could be
523 * eliminated if we knew that this platform had fast unaligned reads */
b40579ff 524 while (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK) {
46bb68f6
KW
525 if (! UTF8_IS_INVARIANT(*x)) {
526 if (ep) {
527 *ep = x;
528 }
e17544a6 529
46bb68f6
KW
530 return FALSE;
531 }
532 x++;
e17544a6 533 }
e17544a6 534
099e59a4
KW
535 /* Here, we know we have at least one full word to process. Process
536 * per-word as long as we have at least a full word left */
537 do {
4ab2fd9b 538 if ((* (PERL_UINTMAX_T *) x) & PERL_VARIANTS_WORD_MASK) {
e17544a6 539
46bb68f6
KW
540 /* Found a variant. Just return if caller doesn't want its
541 * exact position */
542 if (! ep) {
543 return FALSE;
544 }
e17544a6 545
2c5c8af5
KW
546# if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 \
547 || BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
1d2af574 548
73f0a2eb 549 *ep = x + variant_byte_number(* (PERL_UINTMAX_T *) x);
1d2af574
KW
550 assert(*ep >= s && *ep < send);
551
552 return FALSE;
553
2c5c8af5 554# else /* If weird byte order, drop into next loop to do byte-at-a-time
1d2af574
KW
555 checks. */
556
46bb68f6 557 break;
2c5c8af5 558# endif
46bb68f6 559 }
1d2af574 560
46bb68f6 561 x += PERL_WORDSIZE;
1d2af574 562
099e59a4 563 } while (x + PERL_WORDSIZE <= send);
b40579ff 564 }
e17544a6 565
0b08cab0 566#endif /* End of ! EBCDIC */
e17544a6
KW
567
568 /* Process per-byte */
569 while (x < send) {
570 if (! UTF8_IS_INVARIANT(*x)) {
571 if (ep) {
572 *ep = x;
573 }
0cbf5865 574
e17544a6 575 return FALSE;
0cbf5865 576 }
1e599354 577
e17544a6 578 x++;
1e599354
KW
579 }
580
581 return TRUE;
582}
583
23a7ee81
KW
584#ifndef EBCDIC
585
1d2af574 586PERL_STATIC_INLINE unsigned int
73f0a2eb 587Perl_variant_byte_number(PERL_UINTMAX_T word)
1d2af574
KW
588{
589
590 /* This returns the position in a word (0..7) of the first variant byte in
591 * it. This is a helper function. Note that there are no branches */
592
593 assert(word);
594
595 /* Get just the msb bits of each byte */
596 word &= PERL_VARIANTS_WORD_MASK;
597
7adf2470 598# if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
1d2af574
KW
599
600 /* Bytes are stored like
601 * Byte8 ... Byte2 Byte1
602 * 63..56...15...8 7...0
603 *
604 * Isolate the lsb;
605 * https://stackoverflow.com/questions/757059/position-of-least-significant-bit-that-is-set
606 *
a3815e44 607 * The word will look like this, with a rightmost set bit in position 's':
1d2af574
KW
608 * ('x's are don't cares)
609 * s
610 * x..x100..0
611 * x..xx10..0 Right shift (rightmost 0 is shifted off)
612 * x..xx01..1 Subtract 1, turns all the trailing zeros into 1's and
613 * the 1 just to their left into a 0; the remainder is
614 * untouched
4fa92663
KW
615 * 0..0011..1 The xor with the original, x..xx10..0, clears that
616 * remainder, sets the bottom to all 1
1d2af574
KW
617 * 0..0100..0 Add 1 to clear the word except for the bit in 's'
618 *
619 * Another method is to do 'word &= -word'; but it generates a compiler
620 * message on some platforms about taking the negative of an unsigned */
621
622 word >>= 1;
623 word = 1 + (word ^ (word - 1));
624
625# elif BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
626
627 /* Bytes are stored like
628 * Byte1 Byte2 ... Byte8
629 * 63..56 55..47 ... 7...0
630 *
631 * Isolate the msb; http://codeforces.com/blog/entry/10330
632 *
633 * Only the most significant set bit matters. Or'ing word with its right
634 * shift of 1 makes that bit and the next one to its right both 1. Then
635 * right shifting by 2 makes for 4 1-bits in a row. ... We end with the
636 * msb and all to the right being 1. */
637 word |= word >> 1;
638 word |= word >> 2;
639 word |= word >> 4;
640 word |= word >> 8;
641 word |= word >> 16;
642 word |= word >> 32; /* This should get optimized out on 32-bit systems. */
643
644 /* Then subtracting the right shift by 1 clears all but the left-most of
645 * the 1 bits, which is our desired result */
646 word -= (word >> 1);
647
648# else
649# error Unexpected byte order
650# endif
651
7cf2d6c7
KW
652 /* Here 'word' has a single bit set: the msb of the first byte in which it
653 * is set. Calculate that position in the word. We can use this
1d2af574 654 * specialized solution: https://stackoverflow.com/a/32339674/1626653,
67e12c5c
KW
655 * assumes an 8-bit byte. (On a 32-bit machine, the larger numbers should
656 * just get shifted off at compile time) */
657 word = (word >> 7) * ((UINTMAX_C( 7) << 56) | (UINTMAX_C(15) << 48)
658 | (UINTMAX_C(23) << 40) | (UINTMAX_C(31) << 32)
659 | (39 << 24) | (47 << 16)
660 | (55 << 8) | (63 << 0));
1d2af574
KW
661 word >>= PERL_WORDSIZE * 7; /* >> by either 56 or 24 */
662
663 /* Here, word contains the position 7..63 of that bit. Convert to 0..7 */
664 word = ((word + 1) >> 3) - 1;
665
666# if BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
667
668 /* And invert the result */
669 word = CHARBITS - word - 1;
670
671# endif
672
673 return (unsigned int) word;
674}
675
23a7ee81 676#endif
03c1e4ab
KW
677#if defined(PERL_CORE) || defined(PERL_EXT)
678
679/*
680=for apidoc variant_under_utf8_count
681
682This function looks at the sequence of bytes between C<s> and C<e>, which are
683assumed to be encoded in ASCII/Latin1, and returns how many of them would
684change should the string be translated into UTF-8. Due to the nature of UTF-8,
685each of these would occupy two bytes instead of the single one in the input
686string. Thus, this function returns the precise number of bytes the string
687would expand by when translated to UTF-8.
688
689Unlike most of the other functions that have C<utf8> in their name, the input
690to this function is NOT a UTF-8-encoded string. The function name is slightly
691I<odd> to emphasize this.
692
693This function is internal to Perl because khw thinks that any XS code that
694would want this is probably operating too close to the internals. Presenting a
695valid use case could change that.
696
697See also
698C<L<perlapi/is_utf8_invariant_string>>
699and
700C<L<perlapi/is_utf8_invariant_string_loc>>,
701
702=cut
703
704*/
705
706PERL_STATIC_INLINE Size_t
707S_variant_under_utf8_count(const U8* const s, const U8* const e)
708{
709 const U8* x = s;
710 Size_t count = 0;
711
712 PERL_ARGS_ASSERT_VARIANT_UNDER_UTF8_COUNT;
713
714# ifndef EBCDIC
715
5d0379de
KW
716 /* Test if the string is long enough to use word-at-a-time. (Logic is the
717 * same as for is_utf8_invariant_string()) */
03c1e4ab
KW
718 if ((STRLEN) (e - x) >= PERL_WORDSIZE
719 + PERL_WORDSIZE * PERL_IS_SUBWORD_ADDR(x)
720 - (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK))
721 {
722
723 /* Process per-byte until reach word boundary. XXX This loop could be
724 * eliminated if we knew that this platform had fast unaligned reads */
725 while (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK) {
726 count += ! UTF8_IS_INVARIANT(*x++);
727 }
728
729 /* Process per-word as long as we have at least a full word left */
74472cc2
KW
730 do { /* Commit 03c1e4ab1d6ee9062fb3f94b0ba31db6698724b1 contains an
731 explanation of how this works */
e5863284
KW
732 PERL_UINTMAX_T increment
733 = ((((* (PERL_UINTMAX_T *) x) & PERL_VARIANTS_WORD_MASK) >> 7)
03c1e4ab
KW
734 * PERL_COUNT_MULTIPLIER)
735 >> ((PERL_WORDSIZE - 1) * CHARBITS);
e5863284 736 count += (Size_t) increment;
03c1e4ab
KW
737 x += PERL_WORDSIZE;
738 } while (x + PERL_WORDSIZE <= e);
739 }
740
741# endif
742
743 /* Process per-byte */
744 while (x < e) {
745 if (! UTF8_IS_INVARIANT(*x)) {
746 count++;
747 }
748
749 x++;
750 }
751
752 return count;
753}
754
755#endif
756
aff4cafe
KW
757#ifndef PERL_IN_REGEXEC_C /* Keep these around for that file */
758# undef PERL_WORDSIZE
759# undef PERL_COUNT_MULTIPLIER
760# undef PERL_WORD_BOUNDARY_MASK
761# undef PERL_VARIANTS_WORD_MASK
762#endif
03c1e4ab 763
7c93d8f0 764/*
5ff889fb
KW
765=for apidoc is_utf8_string
766
82c5d941
KW
767Returns TRUE if the first C<len> bytes of string C<s> form a valid
768Perl-extended-UTF-8 string; returns FALSE otherwise. If C<len> is 0, it will
769be calculated using C<strlen(s)> (which means if you use this option, that C<s>
770can't have embedded C<NUL> characters and has to have a terminating C<NUL>
771byte). Note that all characters being ASCII constitute 'a valid UTF-8 string'.
772
2717076a
KW
773This function considers Perl's extended UTF-8 to be valid. That means that
774code points above Unicode, surrogates, and non-character code points are
9f2abfde
KW
775considered valid by this function. Use C<L</is_strict_utf8_string>>,
776C<L</is_c9strict_utf8_string>>, or C<L</is_utf8_string_flags>> to restrict what
777code points are considered valid.
5ff889fb 778
9f2abfde
KW
779See also
780C<L</is_utf8_invariant_string>>,
0cbf5865 781C<L</is_utf8_invariant_string_loc>>,
9f2abfde
KW
782C<L</is_utf8_string_loc>>,
783C<L</is_utf8_string_loclen>>,
8bc127bf
KW
784C<L</is_utf8_fixed_width_buf_flags>>,
785C<L</is_utf8_fixed_width_buf_loc_flags>>,
786C<L</is_utf8_fixed_width_buf_loclen_flags>>,
5ff889fb
KW
787
788=cut
789*/
790
dd237e82 791#define is_utf8_string(s, len) is_utf8_string_loclen(s, len, NULL, NULL)
5ff889fb 792
c9cd936b
KW
793#if defined(PERL_CORE) || defined (PERL_EXT)
794
795/*
796=for apidoc is_utf8_non_invariant_string
797
798Returns TRUE if L<perlapi/is_utf8_invariant_string> returns FALSE for the first
799C<len> bytes of the string C<s>, but they are, nonetheless, legal Perl-extended
800UTF-8; otherwise returns FALSE.
801
802A TRUE return means that at least one code point represented by the sequence
803either is a wide character not representable as a single byte, or the
804representation differs depending on whether the sequence is encoded in UTF-8 or
805not.
806
807See also
808C<L<perlapi/is_utf8_invariant_string>>,
809C<L<perlapi/is_utf8_string>>
810
811=cut
812
813This is commonly used to determine if a SV's UTF-8 flag should be turned on.
b3b93dfe
KW
814It generally needn't be if its string is entirely UTF-8 invariant, and it
815shouldn't be if it otherwise contains invalid UTF-8.
c9cd936b
KW
816
817It is an internal function because khw thinks that XS code shouldn't be working
818at this low a level. A valid use case could change that.
819
820*/
821
822PERL_STATIC_INLINE bool
86a87e17 823Perl_is_utf8_non_invariant_string(const U8* const s, STRLEN len)
c9cd936b
KW
824{
825 const U8 * first_variant;
826
827 PERL_ARGS_ASSERT_IS_UTF8_NON_INVARIANT_STRING;
828
829 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
830 return FALSE;
831 }
832
833 return is_utf8_string(first_variant, len - (first_variant - s));
834}
835
836#endif
837
5ff889fb 838/*
9f2abfde
KW
839=for apidoc is_strict_utf8_string
840
841Returns TRUE if the first C<len> bytes of string C<s> form a valid
842UTF-8-encoded string that is fully interchangeable by any application using
843Unicode rules; otherwise it returns FALSE. If C<len> is 0, it will be
844calculated using C<strlen(s)> (which means if you use this option, that C<s>
845can't have embedded C<NUL> characters and has to have a terminating C<NUL>
846byte). Note that all characters being ASCII constitute 'a valid UTF-8 string'.
847
848This function returns FALSE for strings containing any
849code points above the Unicode max of 0x10FFFF, surrogate code points, or
850non-character code points.
851
852See also
853C<L</is_utf8_invariant_string>>,
0cbf5865 854C<L</is_utf8_invariant_string_loc>>,
9f2abfde
KW
855C<L</is_utf8_string>>,
856C<L</is_utf8_string_flags>>,
857C<L</is_utf8_string_loc>>,
858C<L</is_utf8_string_loc_flags>>,
859C<L</is_utf8_string_loclen>>,
860C<L</is_utf8_string_loclen_flags>>,
8bc127bf
KW
861C<L</is_utf8_fixed_width_buf_flags>>,
862C<L</is_utf8_fixed_width_buf_loc_flags>>,
863C<L</is_utf8_fixed_width_buf_loclen_flags>>,
9f2abfde
KW
864C<L</is_strict_utf8_string_loc>>,
865C<L</is_strict_utf8_string_loclen>>,
866C<L</is_c9strict_utf8_string>>,
867C<L</is_c9strict_utf8_string_loc>>,
868and
869C<L</is_c9strict_utf8_string_loclen>>.
870
871=cut
872*/
873
dd237e82 874#define is_strict_utf8_string(s, len) is_strict_utf8_string_loclen(s, len, NULL, NULL)
9f2abfde
KW
875
876/*
877=for apidoc is_c9strict_utf8_string
878
879Returns TRUE if the first C<len> bytes of string C<s> form a valid
880UTF-8-encoded string that conforms to
881L<Unicode Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>;
882otherwise it returns FALSE. If C<len> is 0, it will be calculated using
883C<strlen(s)> (which means if you use this option, that C<s> can't have embedded
884C<NUL> characters and has to have a terminating C<NUL> byte). Note that all
885characters being ASCII constitute 'a valid UTF-8 string'.
886
887This function returns FALSE for strings containing any code points above the
888Unicode max of 0x10FFFF or surrogate code points, but accepts non-character
889code points per
890L<Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>.
891
892See also
893C<L</is_utf8_invariant_string>>,
0cbf5865 894C<L</is_utf8_invariant_string_loc>>,
9f2abfde
KW
895C<L</is_utf8_string>>,
896C<L</is_utf8_string_flags>>,
897C<L</is_utf8_string_loc>>,
898C<L</is_utf8_string_loc_flags>>,
899C<L</is_utf8_string_loclen>>,
900C<L</is_utf8_string_loclen_flags>>,
8bc127bf
KW
901C<L</is_utf8_fixed_width_buf_flags>>,
902C<L</is_utf8_fixed_width_buf_loc_flags>>,
903C<L</is_utf8_fixed_width_buf_loclen_flags>>,
9f2abfde
KW
904C<L</is_strict_utf8_string>>,
905C<L</is_strict_utf8_string_loc>>,
906C<L</is_strict_utf8_string_loclen>>,
907C<L</is_c9strict_utf8_string_loc>>,
908and
909C<L</is_c9strict_utf8_string_loclen>>.
910
911=cut
912*/
913
dd237e82 914#define is_c9strict_utf8_string(s, len) is_c9strict_utf8_string_loclen(s, len, NULL, 0)
9f2abfde
KW
915
916/*
917=for apidoc is_utf8_string_flags
918
919Returns TRUE if the first C<len> bytes of string C<s> form a valid
920UTF-8 string, subject to the restrictions imposed by C<flags>;
921returns FALSE otherwise. If C<len> is 0, it will be calculated
922using C<strlen(s)> (which means if you use this option, that C<s> can't have
923embedded C<NUL> characters and has to have a terminating C<NUL> byte). Note
924that all characters being ASCII constitute 'a valid UTF-8 string'.
925
926If C<flags> is 0, this gives the same results as C<L</is_utf8_string>>; if
927C<flags> is C<UTF8_DISALLOW_ILLEGAL_INTERCHANGE>, this gives the same results
928as C<L</is_strict_utf8_string>>; and if C<flags> is
929C<UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE>, this gives the same results as
930C<L</is_c9strict_utf8_string>>. Otherwise C<flags> may be any
931combination of the C<UTF8_DISALLOW_I<foo>> flags understood by
932C<L</utf8n_to_uvchr>>, with the same meanings.
933
934See also
935C<L</is_utf8_invariant_string>>,
0cbf5865 936C<L</is_utf8_invariant_string_loc>>,
9f2abfde
KW
937C<L</is_utf8_string>>,
938C<L</is_utf8_string_loc>>,
939C<L</is_utf8_string_loc_flags>>,
940C<L</is_utf8_string_loclen>>,
941C<L</is_utf8_string_loclen_flags>>,
8bc127bf
KW
942C<L</is_utf8_fixed_width_buf_flags>>,
943C<L</is_utf8_fixed_width_buf_loc_flags>>,
944C<L</is_utf8_fixed_width_buf_loclen_flags>>,
9f2abfde
KW
945C<L</is_strict_utf8_string>>,
946C<L</is_strict_utf8_string_loc>>,
947C<L</is_strict_utf8_string_loclen>>,
948C<L</is_c9strict_utf8_string>>,
949C<L</is_c9strict_utf8_string_loc>>,
950and
951C<L</is_c9strict_utf8_string_loclen>>.
952
953=cut
954*/
955
956PERL_STATIC_INLINE bool
c9182d9c 957Perl_is_utf8_string_flags(const U8 *s, STRLEN len, const U32 flags)
9f2abfde 958{
33756530 959 const U8 * first_variant;
9f2abfde
KW
960
961 PERL_ARGS_ASSERT_IS_UTF8_STRING_FLAGS;
962 assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
d044b7a7 963 |UTF8_DISALLOW_PERL_EXTENDED)));
9f2abfde 964
f60f61fd
KW
965 if (len == 0) {
966 len = strlen((const char *)s);
967 }
968
9f2abfde
KW
969 if (flags == 0) {
970 return is_utf8_string(s, len);
971 }
972
d044b7a7 973 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
9f2abfde
KW
974 == UTF8_DISALLOW_ILLEGAL_INTERCHANGE)
975 {
976 return is_strict_utf8_string(s, len);
977 }
978
d044b7a7 979 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
9f2abfde
KW
980 == UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE)
981 {
982 return is_c9strict_utf8_string(s, len);
983 }
984
33756530
KW
985 if (! is_utf8_invariant_string_loc(s, len, &first_variant)) {
986 const U8* const send = s + len;
987 const U8* x = first_variant;
988
a0d7f935
KW
989 while (x < send) {
990 STRLEN cur_len = isUTF8_CHAR_flags(x, send, flags);
991 if (UNLIKELY(! cur_len)) {
992 return FALSE;
993 }
994 x += cur_len;
9f2abfde 995 }
33756530 996 }
9f2abfde
KW
997
998 return TRUE;
999}
1000
1001/*
5ff889fb
KW
1002
1003=for apidoc is_utf8_string_loc
1004
2717076a 1005Like C<L</is_utf8_string>> but stores the location of the failure (in the
5ff889fb 1006case of "utf8ness failure") or the location C<s>+C<len> (in the case of
82c5d941 1007"utf8ness success") in the C<ep> pointer.
5ff889fb 1008
2717076a 1009See also C<L</is_utf8_string_loclen>>.
5ff889fb 1010
3964c812
KW
1011=cut
1012*/
1013
1014#define is_utf8_string_loc(s, len, ep) is_utf8_string_loclen(s, len, ep, 0)
1015
1016/*
1017
5ff889fb
KW
1018=for apidoc is_utf8_string_loclen
1019
2717076a 1020Like C<L</is_utf8_string>> but stores the location of the failure (in the
5ff889fb 1021case of "utf8ness failure") or the location C<s>+C<len> (in the case of
9f2abfde 1022"utf8ness success") in the C<ep> pointer, and the number of UTF-8
82c5d941 1023encoded characters in the C<el> pointer.
5ff889fb 1024
2717076a 1025See also C<L</is_utf8_string_loc>>.
5ff889fb
KW
1026
1027=cut
1028*/
1029
56e4cf64 1030PERL_STATIC_INLINE bool
33756530 1031Perl_is_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
5ff889fb 1032{
33756530 1033 const U8 * first_variant;
5ff889fb
KW
1034
1035 PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN;
1036
33756530
KW
1037 if (len == 0) {
1038 len = strlen((const char *) s);
1039 }
1040
1041 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
1042 if (el)
1043 *el = len;
1044
1045 if (ep) {
1046 *ep = s + len;
1047 }
1048
1049 return TRUE;
1050 }
1051
1052 {
1053 const U8* const send = s + len;
1054 const U8* x = first_variant;
1055 STRLEN outlen = first_variant - s;
1056
a0d7f935
KW
1057 while (x < send) {
1058 const STRLEN cur_len = isUTF8_CHAR(x, send);
1059 if (UNLIKELY(! cur_len)) {
1060 break;
1061 }
1062 x += cur_len;
1063 outlen++;
5ff889fb 1064 }
5ff889fb 1065
a0d7f935
KW
1066 if (el)
1067 *el = outlen;
5ff889fb 1068
a0d7f935
KW
1069 if (ep) {
1070 *ep = x;
1071 }
5ff889fb 1072
a0d7f935 1073 return (x == send);
33756530 1074 }
5ff889fb
KW
1075}
1076
1077/*
9f2abfde 1078
44170c9a 1079=for apidoc isUTF8_CHAR
8ed185f9
KW
1080
1081Evaluates to non-zero if the first few bytes of the string starting at C<s> and
1082looking no further than S<C<e - 1>> are well-formed UTF-8, as extended by Perl,
1083that represents some code point; otherwise it evaluates to 0. If non-zero, the
1084value gives how many bytes starting at C<s> comprise the code point's
1085representation. Any bytes remaining before C<e>, but beyond the ones needed to
1086form the first code point in C<s>, are not examined.
1087
13aab5dd 1088The code point can be any that will fit in an IV on this machine, using Perl's
8ed185f9
KW
1089extension to official UTF-8 to represent those higher than the Unicode maximum
1090of 0x10FFFF. That means that this macro is used to efficiently decide if the
1091next few bytes in C<s> is legal UTF-8 for a single character.
1092
1093Use C<L</isSTRICT_UTF8_CHAR>> to restrict the acceptable code points to those
1094defined by Unicode to be fully interchangeable across applications;
1095C<L</isC9_STRICT_UTF8_CHAR>> to use the L<Unicode Corrigendum
1096#9|http://www.unicode.org/versions/corrigendum9.html> definition of allowable
1097code points; and C<L</isUTF8_CHAR_flags>> for a more customized definition.
1098
1099Use C<L</is_utf8_string>>, C<L</is_utf8_string_loc>>, and
1100C<L</is_utf8_string_loclen>> to check entire strings.
1101
13aab5dd
KW
1102Note also that a UTF-8 "invariant" character (i.e. ASCII on non-EBCDIC
1103machines) is a valid UTF-8 character.
8ed185f9
KW
1104
1105=cut
1106
1107This uses an adaptation of the table and algorithm given in
f6521f7c 1108https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
8ed185f9
KW
1109documentation of the original version. A copyright notice for the original
1110version is given at the beginning of this file. The Perl adapation is
71525f77 1111documented at the definition of PL_extended_utf8_dfa_tab[].
8ed185f9
KW
1112
1113*/
1114
1115PERL_STATIC_INLINE Size_t
c9182d9c 1116Perl_isUTF8_CHAR(const U8 * const s0, const U8 * const e)
8ed185f9
KW
1117{
1118 const U8 * s = s0;
1119 UV state = 0;
1120
1121 PERL_ARGS_ASSERT_ISUTF8_CHAR;
1122
1123 /* This dfa is fast. If it accepts the input, it was for a well-formed,
1124 * code point, which can be returned immediately. Otherwise, it is either
1125 * malformed, or for the start byte FF which the dfa doesn't handle (except
1126 * on 32-bit ASCII platforms where it trivially is an error). Call a
1127 * helper function for the other platforms. */
1128
1129 while (s < e && LIKELY(state != 1)) {
71525f77 1130 state = PL_extended_utf8_dfa_tab[256
8ed185f9 1131 + state
71525f77 1132 + PL_extended_utf8_dfa_tab[*s]];
8ed185f9
KW
1133 if (state != 0) {
1134 s++;
1135 continue;
1136 }
1137
1138 return s - s0 + 1;
1139 }
1140
1141#if defined(UV_IS_QUAD) || defined(EBCDIC)
1142
1143 if (NATIVE_UTF8_TO_I8(*s0) == 0xFF && e - s0 >= UTF8_MAXBYTES) {
1376b35c 1144 return is_utf8_char_helper(s0, e, 0);
8ed185f9
KW
1145 }
1146
1147#endif
1148
1149 return 0;
1150}
1151
1152/*
1153
67049a5f
KW
1154=for apidoc isSTRICT_UTF8_CHAR
1155
1156Evaluates to non-zero if the first few bytes of the string starting at C<s> and
1157looking no further than S<C<e - 1>> are well-formed UTF-8 that represents some
1158Unicode code point completely acceptable for open interchange between all
1159applications; otherwise it evaluates to 0. If non-zero, the value gives how
1160many bytes starting at C<s> comprise the code point's representation. Any
1161bytes remaining before C<e>, but beyond the ones needed to form the first code
1162point in C<s>, are not examined.
1163
1164The largest acceptable code point is the Unicode maximum 0x10FFFF, and must not
1165be a surrogate nor a non-character code point. Thus this excludes any code
1166point from Perl's extended UTF-8.
1167
1168This is used to efficiently decide if the next few bytes in C<s> is
1169legal Unicode-acceptable UTF-8 for a single character.
1170
1171Use C<L</isC9_STRICT_UTF8_CHAR>> to use the L<Unicode Corrigendum
1172#9|http://www.unicode.org/versions/corrigendum9.html> definition of allowable
1173code points; C<L</isUTF8_CHAR>> to check for Perl's extended UTF-8;
1174and C<L</isUTF8_CHAR_flags>> for a more customized definition.
1175
1176Use C<L</is_strict_utf8_string>>, C<L</is_strict_utf8_string_loc>>, and
1177C<L</is_strict_utf8_string_loclen>> to check entire strings.
1178
1179=cut
1180
1181This uses an adaptation of the tables and algorithm given in
f6521f7c 1182https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
67049a5f
KW
1183documentation of the original version. A copyright notice for the original
1184version is given at the beginning of this file. The Perl adapation is
1185documented at the definition of strict_extended_utf8_dfa_tab[].
1186
1187*/
1188
1189PERL_STATIC_INLINE Size_t
c9182d9c 1190Perl_isSTRICT_UTF8_CHAR(const U8 * const s0, const U8 * const e)
67049a5f
KW
1191{
1192 const U8 * s = s0;
1193 UV state = 0;
1194
1195 PERL_ARGS_ASSERT_ISSTRICT_UTF8_CHAR;
1196
1197 while (s < e && LIKELY(state != 1)) {
71525f77 1198 state = PL_strict_utf8_dfa_tab[256 + state + PL_strict_utf8_dfa_tab[*s]];
67049a5f
KW
1199
1200 if (state != 0) {
1201 s++;
1202 continue;
1203 }
1204
1205 return s - s0 + 1;
1206 }
1207
1208#ifndef EBCDIC
1209
1210 /* The dfa above drops out for certain Hanguls; handle them specially */
1211 if (is_HANGUL_ED_utf8_safe(s0, e)) {
1212 return 3;
1213 }
1214
1215#endif
1216
1217 return 0;
1218}
1219
1220/*
1221
44170c9a 1222=for apidoc isC9_STRICT_UTF8_CHAR
c5bfbb64
KW
1223
1224Evaluates to non-zero if the first few bytes of the string starting at C<s> and
1225looking no further than S<C<e - 1>> are well-formed UTF-8 that represents some
1226Unicode non-surrogate code point; otherwise it evaluates to 0. If non-zero,
1227the value gives how many bytes starting at C<s> comprise the code point's
1228representation. Any bytes remaining before C<e>, but beyond the ones needed to
1229form the first code point in C<s>, are not examined.
1230
1231The largest acceptable code point is the Unicode maximum 0x10FFFF. This
1232differs from C<L</isSTRICT_UTF8_CHAR>> only in that it accepts non-character
1233code points. This corresponds to
1234L<Unicode Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>.
1235which said that non-character code points are merely discouraged rather than
1236completely forbidden in open interchange. See
1237L<perlunicode/Noncharacter code points>.
1238
1239Use C<L</isUTF8_CHAR>> to check for Perl's extended UTF-8; and
1240C<L</isUTF8_CHAR_flags>> for a more customized definition.
1241
1242Use C<L</is_c9strict_utf8_string>>, C<L</is_c9strict_utf8_string_loc>>, and
1243C<L</is_c9strict_utf8_string_loclen>> to check entire strings.
1244
1245=cut
1246
1247This uses an adaptation of the tables and algorithm given in
f6521f7c 1248https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
c5bfbb64
KW
1249documentation of the original version. A copyright notice for the original
1250version is given at the beginning of this file. The Perl adapation is
71525f77 1251documented at the definition of PL_c9_utf8_dfa_tab[].
c5bfbb64
KW
1252
1253*/
1254
1255PERL_STATIC_INLINE Size_t
c9182d9c 1256Perl_isC9_STRICT_UTF8_CHAR(const U8 * const s0, const U8 * const e)
c5bfbb64
KW
1257{
1258 const U8 * s = s0;
1259 UV state = 0;
1260
1261 PERL_ARGS_ASSERT_ISC9_STRICT_UTF8_CHAR;
1262
1263 while (s < e && LIKELY(state != 1)) {
71525f77 1264 state = PL_c9_utf8_dfa_tab[256 + state + PL_c9_utf8_dfa_tab[*s]];
c5bfbb64
KW
1265
1266 if (state != 0) {
1267 s++;
1268 continue;
1269 }
1270
1271 return s - s0 + 1;
1272 }
1273
1274 return 0;
1275}
1276
1277/*
1278
9f2abfde
KW
1279=for apidoc is_strict_utf8_string_loc
1280
1281Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
1282case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1283"utf8ness success") in the C<ep> pointer.
1284
1285See also C<L</is_strict_utf8_string_loclen>>.
1286
1287=cut
1288*/
1289
1290#define is_strict_utf8_string_loc(s, len, ep) \
1291 is_strict_utf8_string_loclen(s, len, ep, 0)
1292
1293/*
1294
1295=for apidoc is_strict_utf8_string_loclen
1296
1297Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
1298case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1299"utf8ness success") in the C<ep> pointer, and the number of UTF-8
1300encoded characters in the C<el> pointer.
1301
1302See also C<L</is_strict_utf8_string_loc>>.
1303
1304=cut
1305*/
1306
1307PERL_STATIC_INLINE bool
c9182d9c 1308Perl_is_strict_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
9f2abfde 1309{
33756530 1310 const U8 * first_variant;
9f2abfde
KW
1311
1312 PERL_ARGS_ASSERT_IS_STRICT_UTF8_STRING_LOCLEN;
1313
33756530
KW
1314 if (len == 0) {
1315 len = strlen((const char *) s);
1316 }
1317
1318 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
1319 if (el)
1320 *el = len;
1321
1322 if (ep) {
1323 *ep = s + len;
1324 }
1325
1326 return TRUE;
1327 }
1328
1329 {
1330 const U8* const send = s + len;
1331 const U8* x = first_variant;
1332 STRLEN outlen = first_variant - s;
1333
a0d7f935
KW
1334 while (x < send) {
1335 const STRLEN cur_len = isSTRICT_UTF8_CHAR(x, send);
1336 if (UNLIKELY(! cur_len)) {
1337 break;
1338 }
1339 x += cur_len;
1340 outlen++;
9f2abfde 1341 }
9f2abfde 1342
a0d7f935
KW
1343 if (el)
1344 *el = outlen;
9f2abfde 1345
a0d7f935
KW
1346 if (ep) {
1347 *ep = x;
1348 }
9f2abfde 1349
a0d7f935 1350 return (x == send);
33756530 1351 }
9f2abfde
KW
1352}
1353
1354/*
1355
1356=for apidoc is_c9strict_utf8_string_loc
1357
1358Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in
1359the case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1360"utf8ness success") in the C<ep> pointer.
1361
1362See also C<L</is_c9strict_utf8_string_loclen>>.
1363
1364=cut
1365*/
1366
1367#define is_c9strict_utf8_string_loc(s, len, ep) \
1368 is_c9strict_utf8_string_loclen(s, len, ep, 0)
1369
1370/*
1371
1372=for apidoc is_c9strict_utf8_string_loclen
1373
1374Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in
1375the case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1376"utf8ness success") in the C<ep> pointer, and the number of UTF-8 encoded
1377characters in the C<el> pointer.
1378
1379See also C<L</is_c9strict_utf8_string_loc>>.
1380
1381=cut
1382*/
1383
1384PERL_STATIC_INLINE bool
c9182d9c 1385Perl_is_c9strict_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
9f2abfde 1386{
33756530 1387 const U8 * first_variant;
9f2abfde
KW
1388
1389 PERL_ARGS_ASSERT_IS_C9STRICT_UTF8_STRING_LOCLEN;
1390
33756530
KW
1391 if (len == 0) {
1392 len = strlen((const char *) s);
1393 }
1394
1395 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
1396 if (el)
1397 *el = len;
1398
1399 if (ep) {
1400 *ep = s + len;
1401 }
1402
1403 return TRUE;
1404 }
1405
1406 {
1407 const U8* const send = s + len;
1408 const U8* x = first_variant;
1409 STRLEN outlen = first_variant - s;
1410
a0d7f935
KW
1411 while (x < send) {
1412 const STRLEN cur_len = isC9_STRICT_UTF8_CHAR(x, send);
1413 if (UNLIKELY(! cur_len)) {
1414 break;
1415 }
1416 x += cur_len;
1417 outlen++;
9f2abfde 1418 }
9f2abfde 1419
a0d7f935
KW
1420 if (el)
1421 *el = outlen;
9f2abfde 1422
a0d7f935
KW
1423 if (ep) {
1424 *ep = x;
1425 }
9f2abfde 1426
a0d7f935 1427 return (x == send);
33756530 1428 }
9f2abfde
KW
1429}
1430
1431/*
1432
1433=for apidoc is_utf8_string_loc_flags
1434
1435Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the
1436case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1437"utf8ness success") in the C<ep> pointer.
1438
1439See also C<L</is_utf8_string_loclen_flags>>.
1440
1441=cut
1442*/
1443
1444#define is_utf8_string_loc_flags(s, len, ep, flags) \
1445 is_utf8_string_loclen_flags(s, len, ep, 0, flags)
1446
1447
1448/* The above 3 actual functions could have been moved into the more general one
1449 * just below, and made #defines that call it with the right 'flags'. They are
1450 * currently kept separate to increase their chances of getting inlined */
1451
1452/*
1453
1454=for apidoc is_utf8_string_loclen_flags
1455
1456Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the
1457case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1458"utf8ness success") in the C<ep> pointer, and the number of UTF-8
1459encoded characters in the C<el> pointer.
1460
1461See also C<L</is_utf8_string_loc_flags>>.
1462
1463=cut
1464*/
1465
1466PERL_STATIC_INLINE bool
c9182d9c 1467Perl_is_utf8_string_loclen_flags(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el, const U32 flags)
9f2abfde 1468{
33756530 1469 const U8 * first_variant;
9f2abfde
KW
1470
1471 PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN_FLAGS;
1472 assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
d044b7a7 1473 |UTF8_DISALLOW_PERL_EXTENDED)));
9f2abfde 1474
f60f61fd 1475 if (len == 0) {
a0d7f935 1476 len = strlen((const char *) s);
f60f61fd
KW
1477 }
1478
9f2abfde
KW
1479 if (flags == 0) {
1480 return is_utf8_string_loclen(s, len, ep, el);
1481 }
1482
d044b7a7 1483 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
9f2abfde
KW
1484 == UTF8_DISALLOW_ILLEGAL_INTERCHANGE)
1485 {
1486 return is_strict_utf8_string_loclen(s, len, ep, el);
1487 }
1488
d044b7a7 1489 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
9f2abfde
KW
1490 == UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE)
1491 {
1492 return is_c9strict_utf8_string_loclen(s, len, ep, el);
1493 }
1494
33756530
KW
1495 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
1496 if (el)
1497 *el = len;
1498
1499 if (ep) {
1500 *ep = s + len;
1501 }
1502
1503 return TRUE;
1504 }
1505
1506 {
1507 const U8* send = s + len;
1508 const U8* x = first_variant;
1509 STRLEN outlen = first_variant - s;
1510
a0d7f935
KW
1511 while (x < send) {
1512 const STRLEN cur_len = isUTF8_CHAR_flags(x, send, flags);
1513 if (UNLIKELY(! cur_len)) {
1514 break;
1515 }
1516 x += cur_len;
1517 outlen++;
9f2abfde 1518 }
9f2abfde 1519
a0d7f935
KW
1520 if (el)
1521 *el = outlen;
9f2abfde 1522
a0d7f935
KW
1523 if (ep) {
1524 *ep = x;
1525 }
9f2abfde 1526
a0d7f935 1527 return (x == send);
33756530 1528 }
9f2abfde
KW
1529}
1530
1531/*
7c93d8f0
KW
1532=for apidoc utf8_distance
1533
1534Returns the number of UTF-8 characters between the UTF-8 pointers C<a>
1535and C<b>.
1536
1537WARNING: use only if you *know* that the pointers point inside the
1538same UTF-8 buffer.
1539
1540=cut
1541*/
1542
1543PERL_STATIC_INLINE IV
1544Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b)
1545{
1546 PERL_ARGS_ASSERT_UTF8_DISTANCE;
1547
1548 return (a < b) ? -1 * (IV) utf8_length(a, b) : (IV) utf8_length(b, a);
1549}
1550
1551/*
1552=for apidoc utf8_hop
1553
1554Return the UTF-8 pointer C<s> displaced by C<off> characters, either
1555forward or backward.
1556
1557WARNING: do not use the following unless you *know* C<off> is within
1558the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
1559on the first byte of character or just after the last byte of a character.
1560
1561=cut
1562*/
1563
1564PERL_STATIC_INLINE U8 *
1565Perl_utf8_hop(const U8 *s, SSize_t off)
1566{
1567 PERL_ARGS_ASSERT_UTF8_HOP;
1568
1569 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1570 * the bitops (especially ~) can create illegal UTF-8.
1571 * In other words: in Perl UTF-8 is not just for Unicode. */
1572
1573 if (off >= 0) {
1574 while (off--)
1575 s += UTF8SKIP(s);
1576 }
1577 else {
1578 while (off++) {
1579 s--;
1580 while (UTF8_IS_CONTINUATION(*s))
1581 s--;
1582 }
1583 }
e099ea69 1584 GCC_DIAG_IGNORE(-Wcast-qual)
7c93d8f0 1585 return (U8 *)s;
e099ea69 1586 GCC_DIAG_RESTORE
7c93d8f0
KW
1587}
1588
4dab108f 1589/*
65df57a8
TC
1590=for apidoc utf8_hop_forward
1591
1592Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1593forward.
1594
1595C<off> must be non-negative.
1596
1597C<s> must be before or equal to C<end>.
1598
1599When moving forward it will not move beyond C<end>.
1600
1601Will not exceed this limit even if the string is not valid "UTF-8".
1602
1603=cut
1604*/
1605
1606PERL_STATIC_INLINE U8 *
1607Perl_utf8_hop_forward(const U8 *s, SSize_t off, const U8 *end)
1608{
1609 PERL_ARGS_ASSERT_UTF8_HOP_FORWARD;
1610
1611 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1612 * the bitops (especially ~) can create illegal UTF-8.
1613 * In other words: in Perl UTF-8 is not just for Unicode. */
1614
1615 assert(s <= end);
1616 assert(off >= 0);
1617
1618 while (off--) {
1619 STRLEN skip = UTF8SKIP(s);
de979548 1620 if ((STRLEN)(end - s) <= skip) {
e099ea69 1621 GCC_DIAG_IGNORE(-Wcast-qual)
65df57a8 1622 return (U8 *)end;
e099ea69 1623 GCC_DIAG_RESTORE
de979548 1624 }
65df57a8
TC
1625 s += skip;
1626 }
1627
e099ea69 1628 GCC_DIAG_IGNORE(-Wcast-qual)
65df57a8 1629 return (U8 *)s;
e099ea69 1630 GCC_DIAG_RESTORE
65df57a8
TC
1631}
1632
1633/*
1634=for apidoc utf8_hop_back
1635
1636Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1637backward.
1638
1639C<off> must be non-positive.
1640
1641C<s> must be after or equal to C<start>.
1642
1643When moving backward it will not move before C<start>.
1644
1645Will not exceed this limit even if the string is not valid "UTF-8".
1646
1647=cut
1648*/
1649
1650PERL_STATIC_INLINE U8 *
1651Perl_utf8_hop_back(const U8 *s, SSize_t off, const U8 *start)
1652{
1653 PERL_ARGS_ASSERT_UTF8_HOP_BACK;
1654
1655 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1656 * the bitops (especially ~) can create illegal UTF-8.
1657 * In other words: in Perl UTF-8 is not just for Unicode. */
1658
1659 assert(start <= s);
1660 assert(off <= 0);
1661
1662 while (off++ && s > start) {
e7185695 1663 do {
65df57a8 1664 s--;
e7185695 1665 } while (UTF8_IS_CONTINUATION(*s) && s > start);
65df57a8 1666 }
f6521f7c 1667
e099ea69 1668 GCC_DIAG_IGNORE(-Wcast-qual)
65df57a8 1669 return (U8 *)s;
e099ea69 1670 GCC_DIAG_RESTORE
65df57a8
TC
1671}
1672
1673/*
1674=for apidoc utf8_hop_safe
1675
1676Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1677either forward or backward.
1678
1679When moving backward it will not move before C<start>.
1680
1681When moving forward it will not move beyond C<end>.
1682
1683Will not exceed those limits even if the string is not valid "UTF-8".
1684
1685=cut
1686*/
1687
1688PERL_STATIC_INLINE U8 *
1689Perl_utf8_hop_safe(const U8 *s, SSize_t off, const U8 *start, const U8 *end)
1690{
1691 PERL_ARGS_ASSERT_UTF8_HOP_SAFE;
1692
1693 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1694 * the bitops (especially ~) can create illegal UTF-8.
1695 * In other words: in Perl UTF-8 is not just for Unicode. */
1696
1697 assert(start <= s && s <= end);
1698
1699 if (off >= 0) {
1700 return utf8_hop_forward(s, off, end);
1701 }
1702 else {
1703 return utf8_hop_back(s, off, start);
1704 }
1705}
1706
1707/*
4dab108f
KW
1708
1709=for apidoc is_utf8_valid_partial_char
1710
6cbb9248
KW
1711Returns 0 if the sequence of bytes starting at C<s> and looking no further than
1712S<C<e - 1>> is the UTF-8 encoding, as extended by Perl, for one or more code
1713points. Otherwise, it returns 1 if there exists at least one non-empty
1714sequence of bytes that when appended to sequence C<s>, starting at position
1715C<e> causes the entire sequence to be the well-formed UTF-8 of some code point;
1716otherwise returns 0.
1717
1718In other words this returns TRUE if C<s> points to a partial UTF-8-encoded code
1719point.
1720
1721This is useful when a fixed-length buffer is being tested for being well-formed
1722UTF-8, but the final few bytes in it don't comprise a full character; that is,
1723it is split somewhere in the middle of the final code point's UTF-8
1724representation. (Presumably when the buffer is refreshed with the next chunk
1725of data, the new first bytes will complete the partial code point.) This
1726function is used to verify that the final bytes in the current buffer are in
1727fact the legal beginning of some code point, so that if they aren't, the
1728failure can be signalled without having to wait for the next read.
4dab108f
KW
1729
1730=cut
1731*/
2717076a
KW
1732#define is_utf8_valid_partial_char(s, e) \
1733 is_utf8_valid_partial_char_flags(s, e, 0)
f1c999a7
KW
1734
1735/*
1736
1737=for apidoc is_utf8_valid_partial_char_flags
1738
1739Like C<L</is_utf8_valid_partial_char>>, it returns a boolean giving whether
1740or not the input is a valid UTF-8 encoded partial character, but it takes an
1741extra parameter, C<flags>, which can further restrict which code points are
1742considered valid.
1743
1744If C<flags> is 0, this behaves identically to
1745C<L</is_utf8_valid_partial_char>>. Otherwise C<flags> can be any combination
1746of the C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>. If
1747there is any sequence of bytes that can complete the input partial character in
1748such a way that a non-prohibited character is formed, the function returns
2717076a
KW
1749TRUE; otherwise FALSE. Non character code points cannot be determined based on
1750partial character input. But many of the other possible excluded types can be
f1c999a7
KW
1751determined from just the first one or two bytes.
1752
1753=cut
1754 */
1755
56e4cf64 1756PERL_STATIC_INLINE bool
c9182d9c 1757Perl_is_utf8_valid_partial_char_flags(const U8 * const s, const U8 * const e, const U32 flags)
4dab108f 1758{
f1c999a7 1759 PERL_ARGS_ASSERT_IS_UTF8_VALID_PARTIAL_CHAR_FLAGS;
4dab108f 1760
f1c999a7 1761 assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
d044b7a7 1762 |UTF8_DISALLOW_PERL_EXTENDED)));
4dab108f 1763
8875bd48 1764 if (s >= e || s + UTF8SKIP(s) <= e) {
4dab108f
KW
1765 return FALSE;
1766 }
1767
1376b35c 1768 return cBOOL(is_utf8_char_helper(s, e, flags));
4dab108f
KW
1769}
1770
8bc127bf
KW
1771/*
1772
1773=for apidoc is_utf8_fixed_width_buf_flags
1774
1775Returns TRUE if the fixed-width buffer starting at C<s> with length C<len>
1776is entirely valid UTF-8, subject to the restrictions given by C<flags>;
1777otherwise it returns FALSE.
1778
1779If C<flags> is 0, any well-formed UTF-8, as extended by Perl, is accepted
1780without restriction. If the final few bytes of the buffer do not form a
1781complete code point, this will return TRUE anyway, provided that
1782C<L</is_utf8_valid_partial_char_flags>> returns TRUE for them.
1783
1784If C<flags> in non-zero, it can be any combination of the
1785C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>, and with the
1786same meanings.
1787
1788This function differs from C<L</is_utf8_string_flags>> only in that the latter
1789returns FALSE if the final few bytes of the string don't form a complete code
1790point.
1791
1792=cut
1793 */
1794#define is_utf8_fixed_width_buf_flags(s, len, flags) \
1795 is_utf8_fixed_width_buf_loclen_flags(s, len, 0, 0, flags)
1796
1797/*
1798
1799=for apidoc is_utf8_fixed_width_buf_loc_flags
1800
1801Like C<L</is_utf8_fixed_width_buf_flags>> but stores the location of the
1802failure in the C<ep> pointer. If the function returns TRUE, C<*ep> will point
1803to the beginning of any partial character at the end of the buffer; if there is
1804no partial character C<*ep> will contain C<s>+C<len>.
1805
1806See also C<L</is_utf8_fixed_width_buf_loclen_flags>>.
1807
1808=cut
1809*/
1810
1811#define is_utf8_fixed_width_buf_loc_flags(s, len, loc, flags) \
1812 is_utf8_fixed_width_buf_loclen_flags(s, len, loc, 0, flags)
1813
1814/*
1815
1816=for apidoc is_utf8_fixed_width_buf_loclen_flags
1817
1818Like C<L</is_utf8_fixed_width_buf_loc_flags>> but stores the number of
1819complete, valid characters found in the C<el> pointer.
1820
1821=cut
1822*/
1823
1824PERL_STATIC_INLINE bool
c9182d9c 1825Perl_is_utf8_fixed_width_buf_loclen_flags(const U8 * const s,
33756530 1826 STRLEN len,
8bc127bf
KW
1827 const U8 **ep,
1828 STRLEN *el,
1829 const U32 flags)
1830{
1831 const U8 * maybe_partial;
1832
1833 PERL_ARGS_ASSERT_IS_UTF8_FIXED_WIDTH_BUF_LOCLEN_FLAGS;
1834
1835 if (! ep) {
1836 ep = &maybe_partial;
1837 }
1838
1839 /* If it's entirely valid, return that; otherwise see if the only error is
1840 * that the final few bytes are for a partial character */
1841 return is_utf8_string_loclen_flags(s, len, ep, el, flags)
1842 || is_utf8_valid_partial_char_flags(*ep, s + len, flags);
1843}
1844
e6a4ffc3 1845PERL_STATIC_INLINE UV
c9182d9c 1846Perl_utf8n_to_uvchr_msgs(const U8 *s,
e6a4ffc3
KW
1847 STRLEN curlen,
1848 STRLEN *retlen,
1849 const U32 flags,
1850 U32 * errors,
1851 AV ** msgs)
1852{
1853 /* This is the inlined portion of utf8n_to_uvchr_msgs. It handles the
1854 * simple cases, and, if necessary calls a helper function to deal with the
1855 * more complex ones. Almost all well-formed non-problematic code points
1856 * are considered simple, so that it's unlikely that the helper function
1857 * will need to be called.
1858 *
1859 * This is an adaptation of the tables and algorithm given in
f6521f7c 1860 * https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides
e6a4ffc3
KW
1861 * comprehensive documentation of the original version. A copyright notice
1862 * for the original version is given at the beginning of this file. The
71525f77 1863 * Perl adapation is documented at the definition of PL_strict_utf8_dfa_tab[].
e6a4ffc3
KW
1864 */
1865
1866 const U8 * const s0 = s;
1867 const U8 * send = s0 + curlen;
f73cfe7d 1868 UV uv = 0; /* The 0 silences some stupid compilers */
e6a4ffc3
KW
1869 UV state = 0;
1870
1871 PERL_ARGS_ASSERT_UTF8N_TO_UVCHR_MSGS;
1872
1873 /* This dfa is fast. If it accepts the input, it was for a well-formed,
1874 * non-problematic code point, which can be returned immediately.
1875 * Otherwise we call a helper function to figure out the more complicated
1876 * cases. */
1877
1878 while (s < send && LIKELY(state != 1)) {
71525f77 1879 UV type = PL_strict_utf8_dfa_tab[*s];
e6a4ffc3
KW
1880
1881 uv = (state == 0)
1882 ? ((0xff >> type) & NATIVE_UTF8_TO_I8(*s))
1883 : UTF8_ACCUMULATE(uv, *s);
71525f77 1884 state = PL_strict_utf8_dfa_tab[256 + state + type];
e6a4ffc3
KW
1885
1886 if (state != 0) {
1887 s++;
1888 continue;
1889 }
1890
1891 if (retlen) {
1892 *retlen = s - s0 + 1;
1893 }
1894 if (errors) {
1895 *errors = 0;
1896 }
1897 if (msgs) {
1898 *msgs = NULL;
1899 }
1900
cfebc7aa 1901 return UNI_TO_NATIVE(uv);
e6a4ffc3
KW
1902 }
1903
1904 /* Here is potentially problematic. Use the full mechanism */
1905 return _utf8n_to_uvchr_msgs_helper(s0, curlen, retlen, flags, errors, msgs);
1906}
1907
82651abe 1908PERL_STATIC_INLINE UV
9a9a6c98 1909Perl_utf8_to_uvchr_buf_helper(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen)
82651abe 1910{
9a9a6c98 1911 PERL_ARGS_ASSERT_UTF8_TO_UVCHR_BUF_HELPER;
82651abe
KW
1912
1913 assert(s < send);
1914
1915 if (! ckWARN_d(WARN_UTF8)) {
3eaa7592
KW
1916
1917 /* EMPTY is not really allowed, and asserts on debugging builds. But
1918 * on non-debugging we have to deal with it, and this causes it to
1919 * return the REPLACEMENT CHARACTER, as the documentation indicates */
82651abe 1920 return utf8n_to_uvchr(s, send - s, retlen,
3eaa7592 1921 (UTF8_ALLOW_ANY | UTF8_ALLOW_EMPTY));
82651abe
KW
1922 }
1923 else {
1924 UV ret = utf8n_to_uvchr(s, send - s, retlen, 0);
1925 if (retlen && ret == 0 && *s != '\0') {
1926 *retlen = (STRLEN) -1;
1927 }
1928
1929 return ret;
1930 }
1931}
1932
c8028aa6
TC
1933/* ------------------------------- perl.h ----------------------------- */
1934
1935/*
3f620621 1936=for apidoc_section $utility
dcccc8ff 1937
44170c9a 1938=for apidoc is_safe_syscall
c8028aa6 1939
1a0efc9a
KW
1940Test that the given C<pv> (with length C<len>) doesn't contain any internal
1941C<NUL> characters.
1942If it does, set C<errno> to C<ENOENT>, optionally warn using the C<syscalls>
1943category, and return FALSE.
c8028aa6
TC
1944
1945Return TRUE if the name is safe.
1946
1a0efc9a
KW
1947C<what> and C<op_name> are used in any warning.
1948
796b6530 1949Used by the C<IS_SAFE_SYSCALL()> macro.
c8028aa6
TC
1950
1951=cut
1952*/
1953
1954PERL_STATIC_INLINE bool
ffd62fc2
KW
1955Perl_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name)
1956{
c8028aa6
TC
1957 /* While the Windows CE API provides only UCS-16 (or UTF-16) APIs
1958 * perl itself uses xce*() functions which accept 8-bit strings.
1959 */
1960
1961 PERL_ARGS_ASSERT_IS_SAFE_SYSCALL;
1962
6c4650b3 1963 if (len > 1) {
c8028aa6 1964 char *null_at;
41188aa0 1965 if (UNLIKELY((null_at = (char *)memchr(pv, 0, len-1)) != NULL)) {
c8028aa6 1966 SETERRNO(ENOENT, LIB_INVARG);
1d505182 1967 Perl_ck_warner(aTHX_ packWARN(WARN_SYSCALLS),
c8028aa6 1968 "Invalid \\0 character in %s for %s: %s\\0%s",
41188aa0 1969 what, op_name, pv, null_at+1);
c8028aa6
TC
1970 return FALSE;
1971 }
1972 }
1973
1974 return TRUE;
1975}
1976
1977/*
7cb3f959
TC
1978
1979Return true if the supplied filename has a newline character
fa6c7d00 1980immediately before the first (hopefully only) NUL.
7cb3f959
TC
1981
1982My original look at this incorrectly used the len from SvPV(), but
1983that's incorrect, since we allow for a NUL in pv[len-1].
1984
1985So instead, strlen() and work from there.
1986
1987This allow for the user reading a filename, forgetting to chomp it,
1988then calling:
1989
1990 open my $foo, "$file\0";
1991
1992*/
1993
1994#ifdef PERL_CORE
1995
1996PERL_STATIC_INLINE bool
ffd62fc2
KW
1997S_should_warn_nl(const char *pv)
1998{
7cb3f959
TC
1999 STRLEN len;
2000
2001 PERL_ARGS_ASSERT_SHOULD_WARN_NL;
2002
2003 len = strlen(pv);
2004
2005 return len > 0 && pv[len-1] == '\n';
2006}
2007
2008#endif
2009
3a019afd
KW
2010#if defined(PERL_IN_PP_C) || defined(PERL_IN_PP_HOT_C)
2011
2012PERL_STATIC_INLINE bool
2013S_lossless_NV_to_IV(const NV nv, IV *ivp)
2014{
2015 /* This function determines if the input NV 'nv' may be converted without
2016 * loss of data to an IV. If not, it returns FALSE taking no other action.
2017 * But if it is possible, it does the conversion, returning TRUE, and
2018 * storing the converted result in '*ivp' */
2019
2020 PERL_ARGS_ASSERT_LOSSLESS_NV_TO_IV;
2021
cd304e76
DM
2022# if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2023 /* Normally any comparison with a NaN returns false; if we can't rely
2024 * on that behaviour, check explicitly */
3a019afd
KW
2025 if (UNLIKELY(Perl_isnan(nv))) {
2026 return FALSE;
2027 }
3a019afd
KW
2028# endif
2029
cd304e76
DM
2030 /* Written this way so that with an always-false NaN comparison we
2031 * return false */
ef0a8475 2032 if (!(LIKELY(nv >= (NV) IV_MIN) && LIKELY(nv < IV_MAX_P1))) {
3a019afd
KW
2033 return FALSE;
2034 }
2035
2036 if ((IV) nv != nv) {
2037 return FALSE;
2038 }
2039
2040 *ivp = (IV) nv;
2041 return TRUE;
2042}
2043
2044#endif
2045
81d52ecd
JH
2046/* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */
2047
94b0cb42
KW
2048#if defined(PERL_IN_PP_C) || defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_TOKE_C) || defined(PERL_IN_UNIVERSAL_C)
2049
81d52ecd
JH
2050#define MAX_CHARSET_NAME_LENGTH 2
2051
2052PERL_STATIC_INLINE const char *
94b0cb42 2053S_get_regex_charset_name(const U32 flags, STRLEN* const lenp)
81d52ecd 2054{
94b0cb42
KW
2055 PERL_ARGS_ASSERT_GET_REGEX_CHARSET_NAME;
2056
81d52ecd
JH
2057 /* Returns a string that corresponds to the name of the regex character set
2058 * given by 'flags', and *lenp is set the length of that string, which
2059 * cannot exceed MAX_CHARSET_NAME_LENGTH characters */
2060
2061 *lenp = 1;
2062 switch (get_regex_charset(flags)) {
2063 case REGEX_DEPENDS_CHARSET: return DEPENDS_PAT_MODS;
2064 case REGEX_LOCALE_CHARSET: return LOCALE_PAT_MODS;
2065 case REGEX_UNICODE_CHARSET: return UNICODE_PAT_MODS;
2066 case REGEX_ASCII_RESTRICTED_CHARSET: return ASCII_RESTRICT_PAT_MODS;
2067 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
2068 *lenp = 2;
2069 return ASCII_MORE_RESTRICT_PAT_MODS;
2070 }
2071 /* The NOT_REACHED; hides an assert() which has a rather complex
2072 * definition in perl.h. */
2073 NOT_REACHED; /* NOTREACHED */
2074 return "?"; /* Unknown */
2075}
2076
94b0cb42
KW
2077#endif
2078
7cb3f959 2079/*
ed382232
TC
2080
2081Return false if any get magic is on the SV other than taint magic.
2082
2083*/
2084
2085PERL_STATIC_INLINE bool
ffd62fc2
KW
2086Perl_sv_only_taint_gmagic(SV *sv)
2087{
ed382232
TC
2088 MAGIC *mg = SvMAGIC(sv);
2089
2090 PERL_ARGS_ASSERT_SV_ONLY_TAINT_GMAGIC;
2091
2092 while (mg) {
2093 if (mg->mg_type != PERL_MAGIC_taint
2094 && !(mg->mg_flags & MGf_GSKIP)
2095 && mg->mg_virtual->svt_get) {
2096 return FALSE;
2097 }
2098 mg = mg->mg_moremagic;
2099 }
2100
2101 return TRUE;
2102}
2103
ed8ff0f3
DM
2104/* ------------------ cop.h ------------------------------------------- */
2105
5b6f7443
DM
2106/* implement GIMME_V() macro */
2107
2108PERL_STATIC_INLINE U8
2109Perl_gimme_V(pTHX)
2110{
2111 I32 cxix;
2112 U8 gimme = (PL_op->op_flags & OPf_WANT);
2113
2114 if (gimme)
2115 return gimme;
2116 cxix = PL_curstackinfo->si_cxsubix;
2117 if (cxix < 0)
390fe0c0 2118 return PL_curstackinfo->si_type == PERLSI_SORT ? G_SCALAR: G_VOID;
5b6f7443
DM
2119 assert(cxstack[cxix].blk_gimme & G_WANT);
2120 return (cxstack[cxix].blk_gimme & G_WANT);
2121}
2122
ed8ff0f3
DM
2123
2124/* Enter a block. Push a new base context and return its address. */
2125
2126PERL_STATIC_INLINE PERL_CONTEXT *
c9182d9c 2127Perl_cx_pushblock(pTHX_ U8 type, U8 gimme, SV** sp, I32 saveix)
ed8ff0f3
DM
2128{
2129 PERL_CONTEXT * cx;
2130
2131 PERL_ARGS_ASSERT_CX_PUSHBLOCK;
2132
2133 CXINC;
2134 cx = CX_CUR();
2135 cx->cx_type = type;
2136 cx->blk_gimme = gimme;
2137 cx->blk_oldsaveix = saveix;
4caf7d8c 2138 cx->blk_oldsp = (I32)(sp - PL_stack_base);
ed8ff0f3 2139 cx->blk_oldcop = PL_curcop;
4caf7d8c 2140 cx->blk_oldmarksp = (I32)(PL_markstack_ptr - PL_markstack);
ed8ff0f3
DM
2141 cx->blk_oldscopesp = PL_scopestack_ix;
2142 cx->blk_oldpm = PL_curpm;
ce8bb8d8 2143 cx->blk_old_tmpsfloor = PL_tmps_floor;
ed8ff0f3
DM
2144
2145 PL_tmps_floor = PL_tmps_ix;
2146 CX_DEBUG(cx, "PUSH");
2147 return cx;
2148}
2149
2150
2151/* Exit a block (RETURN and LAST). */
2152
2153PERL_STATIC_INLINE void
c9182d9c 2154Perl_cx_popblock(pTHX_ PERL_CONTEXT *cx)
ed8ff0f3
DM
2155{
2156 PERL_ARGS_ASSERT_CX_POPBLOCK;
2157
2158 CX_DEBUG(cx, "POP");
2159 /* these 3 are common to cx_popblock and cx_topblock */
2160 PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
2161 PL_scopestack_ix = cx->blk_oldscopesp;
2162 PL_curpm = cx->blk_oldpm;
2163
2164 /* LEAVE_SCOPE() should have made this true. /(?{})/ cheats
2165 * and leaves a CX entry lying around for repeated use, so
2166 * skip for multicall */ \
2167 assert( (CxTYPE(cx) == CXt_SUB && CxMULTICALL(cx))
2168 || PL_savestack_ix == cx->blk_oldsaveix);
2169 PL_curcop = cx->blk_oldcop;
ce8bb8d8 2170 PL_tmps_floor = cx->blk_old_tmpsfloor;
ed8ff0f3
DM
2171}
2172
2173/* Continue a block elsewhere (e.g. NEXT, REDO, GOTO).
2174 * Whereas cx_popblock() restores the state to the point just before
2175 * cx_pushblock() was called, cx_topblock() restores it to the point just
2176 * *after* cx_pushblock() was called. */
2177
2178PERL_STATIC_INLINE void
c9182d9c 2179Perl_cx_topblock(pTHX_ PERL_CONTEXT *cx)
ed8ff0f3
DM
2180{
2181 PERL_ARGS_ASSERT_CX_TOPBLOCK;
2182
2183 CX_DEBUG(cx, "TOP");
2184 /* these 3 are common to cx_popblock and cx_topblock */
2185 PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
2186 PL_scopestack_ix = cx->blk_oldscopesp;
2187 PL_curpm = cx->blk_oldpm;
2188
2189 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
2190}
2191
2192
a73d8813 2193PERL_STATIC_INLINE void
c9182d9c 2194Perl_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs)
a73d8813
DM
2195{
2196 U8 phlags = CX_PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub);
2197
2198 PERL_ARGS_ASSERT_CX_PUSHSUB;
2199
3f6bd23a 2200 PERL_DTRACE_PROBE_ENTRY(cv);
5b6f7443
DM
2201 cx->blk_sub.old_cxsubix = PL_curstackinfo->si_cxsubix;
2202 PL_curstackinfo->si_cxsubix = cx - PL_curstackinfo->si_cxstack;
a73d8813
DM
2203 cx->blk_sub.cv = cv;
2204 cx->blk_sub.olddepth = CvDEPTH(cv);
2205 cx->blk_sub.prevcomppad = PL_comppad;
2206 cx->cx_type |= (hasargs) ? CXp_HASARGS : 0;
2207 cx->blk_sub.retop = retop;
2208 SvREFCNT_inc_simple_void_NN(cv);
2209 cx->blk_u16 = PL_op->op_private & (phlags|OPpDEREF);
2210}
2211
2212
2213/* subsets of cx_popsub() */
2214
2215PERL_STATIC_INLINE void
c9182d9c 2216Perl_cx_popsub_common(pTHX_ PERL_CONTEXT *cx)
a73d8813
DM
2217{
2218 CV *cv;
2219
2220 PERL_ARGS_ASSERT_CX_POPSUB_COMMON;
2221 assert(CxTYPE(cx) == CXt_SUB);
2222
2223 PL_comppad = cx->blk_sub.prevcomppad;
2224 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
2225 cv = cx->blk_sub.cv;
2226 CvDEPTH(cv) = cx->blk_sub.olddepth;
2227 cx->blk_sub.cv = NULL;
2228 SvREFCNT_dec(cv);
5b6f7443 2229 PL_curstackinfo->si_cxsubix = cx->blk_sub.old_cxsubix;
a73d8813
DM
2230}
2231
2232
2233/* handle the @_ part of leaving a sub */
2234
2235PERL_STATIC_INLINE void
c9182d9c 2236Perl_cx_popsub_args(pTHX_ PERL_CONTEXT *cx)
a73d8813
DM
2237{
2238 AV *av;
2239
2240 PERL_ARGS_ASSERT_CX_POPSUB_ARGS;
2241 assert(CxTYPE(cx) == CXt_SUB);
2242 assert(AvARRAY(MUTABLE_AV(
2243 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
2244 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
2245
2246 CX_POP_SAVEARRAY(cx);
2247 av = MUTABLE_AV(PAD_SVl(0));
2248 if (UNLIKELY(AvREAL(av)))
2249 /* abandon @_ if it got reified */
2250 clear_defarray(av, 0);
2251 else {
2252 CLEAR_ARGARRAY(av);
2253 }
2254}
2255
2256
2257PERL_STATIC_INLINE void
c9182d9c 2258Perl_cx_popsub(pTHX_ PERL_CONTEXT *cx)
a73d8813
DM
2259{
2260 PERL_ARGS_ASSERT_CX_POPSUB;
2261 assert(CxTYPE(cx) == CXt_SUB);
2262
3f6bd23a 2263 PERL_DTRACE_PROBE_RETURN(cx->blk_sub.cv);
a73d8813
DM
2264
2265 if (CxHASARGS(cx))
2266 cx_popsub_args(cx);
2267 cx_popsub_common(cx);
2268}
2269
2270
6a7d52cc 2271PERL_STATIC_INLINE void
c9182d9c 2272Perl_cx_pushformat(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, GV *gv)
6a7d52cc
DM
2273{
2274 PERL_ARGS_ASSERT_CX_PUSHFORMAT;
2275
5b6f7443
DM
2276 cx->blk_format.old_cxsubix = PL_curstackinfo->si_cxsubix;
2277 PL_curstackinfo->si_cxsubix= cx - PL_curstackinfo->si_cxstack;
6a7d52cc
DM
2278 cx->blk_format.cv = cv;
2279 cx->blk_format.retop = retop;
2280 cx->blk_format.gv = gv;
2281 cx->blk_format.dfoutgv = PL_defoutgv;
2282 cx->blk_format.prevcomppad = PL_comppad;
2283 cx->blk_u16 = 0;
2284
2285 SvREFCNT_inc_simple_void_NN(cv);
2286 CvDEPTH(cv)++;
2287 SvREFCNT_inc_void(cx->blk_format.dfoutgv);
2288}
2289
2290
2291PERL_STATIC_INLINE void
c9182d9c 2292Perl_cx_popformat(pTHX_ PERL_CONTEXT *cx)
6a7d52cc
DM
2293{
2294 CV *cv;
2295 GV *dfout;
2296
2297 PERL_ARGS_ASSERT_CX_POPFORMAT;
2298 assert(CxTYPE(cx) == CXt_FORMAT);
2299
2300 dfout = cx->blk_format.dfoutgv;
2301 setdefout(dfout);
2302 cx->blk_format.dfoutgv = NULL;
2303 SvREFCNT_dec_NN(dfout);
2304
2305 PL_comppad = cx->blk_format.prevcomppad;
2306 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
2307 cv = cx->blk_format.cv;
2308 cx->blk_format.cv = NULL;
2309 --CvDEPTH(cv);
2310 SvREFCNT_dec_NN(cv);
5b6f7443 2311 PL_curstackinfo->si_cxsubix = cx->blk_format.old_cxsubix;
6a7d52cc
DM
2312}
2313
2314
13febba5 2315PERL_STATIC_INLINE void
c9182d9c 2316Perl_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv)
13febba5
DM
2317{
2318 PERL_ARGS_ASSERT_CX_PUSHEVAL;
2319
5b6f7443
DM
2320 cx->blk_eval.old_cxsubix = PL_curstackinfo->si_cxsubix;
2321 PL_curstackinfo->si_cxsubix= cx - PL_curstackinfo->si_cxstack;
13febba5
DM
2322 cx->blk_eval.retop = retop;
2323 cx->blk_eval.old_namesv = namesv;
2324 cx->blk_eval.old_eval_root = PL_eval_root;
2325 cx->blk_eval.cur_text = PL_parser ? PL_parser->linestr : NULL;
2326 cx->blk_eval.cv = NULL; /* later set by doeval_compile() */
2327 cx->blk_eval.cur_top_env = PL_top_env;
2328
4c57ced5 2329 assert(!(PL_in_eval & ~ 0x3F));
13febba5 2330 assert(!(PL_op->op_type & ~0x1FF));
4c57ced5 2331 cx->blk_u16 = (PL_in_eval & 0x3F) | ((U16)PL_op->op_type << 7);
13febba5
DM
2332}
2333
2334
2335PERL_STATIC_INLINE void
c9182d9c 2336Perl_cx_popeval(pTHX_ PERL_CONTEXT *cx)
13febba5
DM
2337{
2338 SV *sv;
2339
2340 PERL_ARGS_ASSERT_CX_POPEVAL;
2341 assert(CxTYPE(cx) == CXt_EVAL);
2342
2343 PL_in_eval = CxOLD_IN_EVAL(cx);
4c57ced5 2344 assert(!(PL_in_eval & 0xc0));
13febba5
DM
2345 PL_eval_root = cx->blk_eval.old_eval_root;
2346 sv = cx->blk_eval.cur_text;
4c57ced5 2347 if (sv && CxEVAL_TXT_REFCNTED(cx)) {
13febba5
DM
2348 cx->blk_eval.cur_text = NULL;
2349 SvREFCNT_dec_NN(sv);
2350 }
2351
2352 sv = cx->blk_eval.old_namesv;
2a1e0dfe
DM
2353 if (sv) {
2354 cx->blk_eval.old_namesv = NULL;
2355 SvREFCNT_dec_NN(sv);
2356 }
5b6f7443 2357 PL_curstackinfo->si_cxsubix = cx->blk_eval.old_cxsubix;
13febba5 2358}
6a7d52cc 2359
a73d8813 2360
d1b6bf72
DM
2361/* push a plain loop, i.e.
2362 * { block }
2363 * while (cond) { block }
2364 * for (init;cond;continue) { block }
2365 * This loop can be last/redo'ed etc.
2366 */
2367
2368PERL_STATIC_INLINE void
c9182d9c 2369Perl_cx_pushloop_plain(pTHX_ PERL_CONTEXT *cx)
d1b6bf72
DM
2370{
2371 PERL_ARGS_ASSERT_CX_PUSHLOOP_PLAIN;
2372 cx->blk_loop.my_op = cLOOP;
2373}
2374
2375
2376/* push a true for loop, i.e.
2377 * for var (list) { block }
2378 */
2379
2380PERL_STATIC_INLINE void
c9182d9c 2381Perl_cx_pushloop_for(pTHX_ PERL_CONTEXT *cx, void *itervarp, SV* itersave)
d1b6bf72
DM
2382{
2383 PERL_ARGS_ASSERT_CX_PUSHLOOP_FOR;
2384
2385 /* this one line is common with cx_pushloop_plain */
2386 cx->blk_loop.my_op = cLOOP;
2387
2388 cx->blk_loop.itervar_u.svp = (SV**)itervarp;
2389 cx->blk_loop.itersave = itersave;
2390#ifdef USE_ITHREADS
2391 cx->blk_loop.oldcomppad = PL_comppad;
2392#endif
2393}
2394
2395
2396/* pop all loop types, including plain */
2397
2398PERL_STATIC_INLINE void
c9182d9c 2399Perl_cx_poploop(pTHX_ PERL_CONTEXT *cx)
d1b6bf72
DM
2400{
2401 PERL_ARGS_ASSERT_CX_POPLOOP;
2402
2403 assert(CxTYPE_is_LOOP(cx));
2404 if ( CxTYPE(cx) == CXt_LOOP_ARY
2405 || CxTYPE(cx) == CXt_LOOP_LAZYSV)
2406 {
2407 /* Free ary or cur. This assumes that state_u.ary.ary
2408 * aligns with state_u.lazysv.cur. See cx_dup() */
2409 SV *sv = cx->blk_loop.state_u.lazysv.cur;
2410 cx->blk_loop.state_u.lazysv.cur = NULL;
2411 SvREFCNT_dec_NN(sv);
2412 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
2413 sv = cx->blk_loop.state_u.lazysv.end;
2414 cx->blk_loop.state_u.lazysv.end = NULL;
2415 SvREFCNT_dec_NN(sv);
2416 }
2417 }
2418 if (cx->cx_type & (CXp_FOR_PAD|CXp_FOR_GV)) {
2419 SV *cursv;
2420 SV **svp = (cx)->blk_loop.itervar_u.svp;
2421 if ((cx->cx_type & CXp_FOR_GV))
2422 svp = &GvSV((GV*)svp);
2423 cursv = *svp;
2424 *svp = cx->blk_loop.itersave;
2425 cx->blk_loop.itersave = NULL;
2426 SvREFCNT_dec(cursv);
2427 }
2428}
2429
2a7b7c61
DM
2430
2431PERL_STATIC_INLINE void
c9182d9c 2432Perl_cx_pushwhen(pTHX_ PERL_CONTEXT *cx)
2a7b7c61 2433{
7896dde7 2434 PERL_ARGS_ASSERT_CX_PUSHWHEN;
2a7b7c61 2435
7896dde7 2436 cx->blk_givwhen.leave_op = cLOGOP->op_other;
2a7b7c61
DM
2437}
2438
2439
2440PERL_STATIC_INLINE void
c9182d9c 2441Perl_cx_popwhen(pTHX_ PERL_CONTEXT *cx)
2a7b7c61 2442{
7896dde7
Z
2443 PERL_ARGS_ASSERT_CX_POPWHEN;
2444 assert(CxTYPE(cx) == CXt_WHEN);
2a7b7c61
DM
2445
2446 PERL_UNUSED_ARG(cx);
59a14f30 2447 PERL_UNUSED_CONTEXT;
2a7b7c61
DM
2448 /* currently NOOP */
2449}
2450
2451
7896dde7 2452PERL_STATIC_INLINE void
c9182d9c 2453Perl_cx_pushgiven(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv)
7896dde7
Z
2454{
2455 PERL_ARGS_ASSERT_CX_PUSHGIVEN;
2456
2457 cx->blk_givwhen.leave_op = cLOGOP->op_other;
2458 cx->blk_givwhen.defsv_save = orig_defsv;
2459}
2460
2461
2462PERL_STATIC_INLINE void
c9182d9c 2463Perl_cx_popgiven(pTHX_ PERL_CONTEXT *cx)
7896dde7
Z
2464{
2465 SV *sv;
2466
2467 PERL_ARGS_ASSERT_CX_POPGIVEN;
2468 assert(CxTYPE(cx) == CXt_GIVEN);
2469
2470 sv = GvSV(PL_defgv);
2471 GvSV(PL_defgv) = cx->blk_givwhen.defsv_save;
2472 cx->blk_givwhen.defsv_save = NULL;
2473 SvREFCNT_dec(sv);
2474}
2475
ec2c235b
KW
2476/* ------------------ util.h ------------------------------------------- */
2477
2478/*
3f620621 2479=for apidoc_section $string
ec2c235b
KW
2480
2481=for apidoc foldEQ
2482
2483Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
2484same
2485case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes
2486match themselves and their opposite case counterparts. Non-cased and non-ASCII
2487range bytes match only themselves.
2488
2489=cut
2490*/
2491
2492PERL_STATIC_INLINE I32
2493Perl_foldEQ(const char *s1, const char *s2, I32 len)
2494{
2495 const U8 *a = (const U8 *)s1;
2496 const U8 *b = (const U8 *)s2;
2497
2498 PERL_ARGS_ASSERT_FOLDEQ;
2499
2500 assert(len >= 0);
2501
2502 while (len--) {
2503 if (*a != *b && *a != PL_fold[*b])
2504 return 0;
2505 a++,b++;
2506 }
2507 return 1;
2508}
2509
0f9cb40c 2510PERL_STATIC_INLINE I32
ec2c235b
KW
2511Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
2512{
79a1fabd
KW
2513 /* Compare non-UTF-8 using Unicode (Latin1) semantics. Works on all folds
2514 * representable without UTF-8, except for LATIN_SMALL_LETTER_SHARP_S, and
2515 * does not check for this. Nor does it check that the strings each have
2516 * at least 'len' characters. */
ec2c235b
KW
2517
2518 const U8 *a = (const U8 *)s1;
2519 const U8 *b = (const U8 *)s2;
2520
2521 PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
2522
2523 assert(len >= 0);
2524
2525 while (len--) {
2526 if (*a != *b && *a != PL_fold_latin1[*b]) {
2527 return 0;
2528 }
2529 a++, b++;
2530 }
2531 return 1;
2532}
2533
2534/*
3f620621 2535=for apidoc_section $locale
ec2c235b
KW
2536=for apidoc foldEQ_locale
2537
2538Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
2539same case-insensitively in the current locale; false otherwise.
2540
2541=cut
2542*/
2543
0f9cb40c 2544PERL_STATIC_INLINE I32
ec2c235b
KW
2545Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
2546{
ec2c235b
KW
2547 const U8 *a = (const U8 *)s1;
2548 const U8 *b = (const U8 *)s2;
2549
2550 PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
2551
2552 assert(len >= 0);
2553
2554 while (len--) {
2555 if (*a != *b && *a != PL_fold_locale[*b])
2556 return 0;
2557 a++,b++;
2558 }
2559 return 1;
2560}
2561
1ab100a8 2562/*
3f620621 2563=for apidoc_section $string
1ab100a8
KW
2564=for apidoc my_strnlen
2565
2566The C library C<strnlen> if available, or a Perl implementation of it.
2567
2568C<my_strnlen()> computes the length of the string, up to C<maxlen>
a3815e44 2569characters. It will never attempt to address more than C<maxlen>
1ab100a8
KW
2570characters, making it suitable for use with strings that are not
2571guaranteed to be NUL-terminated.
2572
2573=cut
2574
2575Description stolen from http://man.openbsd.org/strnlen.3,
2576implementation stolen from PostgreSQL.
2577*/
2578#ifndef HAS_STRNLEN
2579
2580PERL_STATIC_INLINE Size_t
2581Perl_my_strnlen(const char *str, Size_t maxlen)
2582{
2583 const char *end = (char *) memchr(str, '\0', maxlen);
2584
2585 PERL_ARGS_ASSERT_MY_STRNLEN;
2586
2587 if (end == NULL) return maxlen;
2588 return end - str;
2589}
2590
2591#endif
2592
6dba01e2
KW
2593#if ! defined (HAS_MEMRCHR) && (defined(PERL_CORE) || defined(PERL_EXT))
2594
2595PERL_STATIC_INLINE void *
2596S_my_memrchr(const char * s, const char c, const STRLEN len)
2597{
2598 /* memrchr(), since many platforms lack it */
2599
2600 const char * t = s + len - 1;
2601
2602 PERL_ARGS_ASSERT_MY_MEMRCHR;
2603
2604 while (t >= s) {
2605 if (*t == c) {
2606 return (void *) t;
2607 }
2608 t--;
2609 }
2610
2611 return NULL;
2612}
2613
2614#endif
2615
24f3e849
KW
2616PERL_STATIC_INLINE char *
2617Perl_mortal_getenv(const char * str)
2618{
2619 /* This implements a (mostly) thread-safe, sequential-call-safe getenv().
2620 *
03694582
KW
2621 * It's (mostly) thread-safe because it uses a mutex to prevent other
2622 * threads (that look at this mutex) from destroying the result before this
2623 * routine has a chance to copy the result to a place that won't be
2624 * destroyed before the caller gets a chance to handle it. That place is a
2625 * mortal SV. khw chose this over SAVEFREEPV because he is under the
2626 * impression that the SV will hang around longer under more circumstances
24f3e849 2627 *
03694582
KW
2628 * The reason it isn't completely thread-safe is that other code could
2629 * simply not pay attention to the mutex. All of the Perl core uses the
2630 * mutex, but it is possible for code from, say XS, to not use this mutex,
2631 * defeating the safety.
24f3e849 2632 *
03694582
KW
2633 * getenv() returns, in some implementations, a pointer to a spot in the
2634 * **environ array, which could be invalidated at any time by this or
2635 * another thread changing the environment. Other implementations copy the
2636 * **environ value to a static buffer, returning a pointer to that. That
2637 * buffer might or might not be invalidated by a getenv() call in another
2638 * thread. If it does get zapped, we need an exclusive lock. Otherwise,
2639 * many getenv() calls can safely be running simultaneously, so a
2640 * many-reader (but no simultaneous writers) lock is ok. There is a
2641 * Configure probe to see if another thread destroys the buffer, and the
2642 * mutex is defined accordingly.
2643 *
2644 * But in all cases, using the mutex prevents these problems, as long as
2645 * all code uses the same mutex..
24f3e849
KW
2646 *
2647 * A complication is that this can be called during phases where the
2648 * mortalization process isn't available. These are in interpreter
2649 * destruction or early in construction. khw believes that at these times
2650 * there shouldn't be anything else going on, so plain getenv is safe AS
2651 * LONG AS the caller acts on the return before calling it again. */
2652
2653 char * ret;
2654 dTHX;
2655
2656 PERL_ARGS_ASSERT_MORTAL_GETENV;
2657
2658 /* Can't mortalize without stacks. khw believes that no other threads
2659 * should be running, so no need to lock things, and this may be during a
2660 * phase when locking isn't even available */
2661 if (UNLIKELY(PL_scopestack_ix == 0)) {
2662 return getenv(str);
2663 }
2664
03694582
KW
2665#ifdef PERL_MEM_LOG
2666
2667 /* A major complication arises under PERL_MEM_LOG. When that is active,
2668 * every memory allocation may result in logging, depending on the value of
2669 * ENV{PERL_MEM_LOG} at the moment. That means, as we create the SV for
2670 * saving ENV{foo}'s value (but before saving it), the logging code will
2671 * call us recursively to find out what ENV{PERL_MEM_LOG} is. Without some
2672 * care that could lead to: 1) infinite recursion; or 2) deadlock (trying to
2673 * lock a boolean mutex recursively); 3) destroying the getenv() static
2674 * buffer; or 4) destroying the temporary created by this for the copy
2675 * causes a log entry to be made which could cause a new temporary to be
2676 * created, which will need to be destroyed at some point, leading to an
2677 * infinite loop.
2678 *
2679 * The solution adopted here (after some gnashing of teeth) is to detect
2680 * the recursive calls and calls from the logger, and treat them specially.
2681 * Let's say we want to do getenv("foo"). We first find
2682 * getenv(PERL_MEM_LOG) and save it to a fixed-length per-interpreter
2683 * variable, so no temporary is required. Then we do getenv(foo}, and in
2684 * the process of creating a temporary to save it, this function will be
2685 * called recursively to do a getenv(PERL_MEM_LOG). On the recursed call,
2686 * we detect that it is such a call and return our saved value instead of
2687 * locking and doing a new getenv(). This solves all of problems 1), 2),
2688 * and 3). Because all the getenv()s are done while the mutex is locked,
2689 * the state cannot have changed. To solve 4), we don't create a temporary
2690 * when this is called from the logging code. That code disposes of the
2691 * return value while the mutex is still locked.
2692 *
2693 * The value of getenv(PERL_MEM_LOG) can be anything, but only initial
2694 * digits and 3 particular letters are significant; the rest are ignored by
2695 * the memory logging code. Thus the per-interpreter variable only needs
2696 * to be large enough to save the significant information, the size of
2697 * which is known at compile time. The first byte is extra, reserved for
2698 * flags for our use. To protect against overflowing, only the reserved
2699 * byte, as many digits as don't overflow, and the three letters are
2700 * stored.
2701 *
2702 * The reserved byte has two bits:
2703 * 0x1 if set indicates that if we get here, it is a recursive call of
2704 * getenv()
2705 * 0x2 if set indicates that the call is from the logging code.
2706 *
2707 * If the flag indicates this is a recursive call, just return the stored
2708 * value of PL_mem_log; An empty value gets turned into NULL. */
2709 if (strEQ(str, "PERL_MEM_LOG") && PL_mem_log[0] & 0x1) {
2710 if (PL_mem_log[1] == '\0') {
2711 return NULL;
2712 } else {
2713 return PL_mem_log + 1;
2714 }
2715 }
2716
2717#endif
2718
35bcf7ff 2719 GETENV_LOCK;
24f3e849 2720
03694582
KW
2721#ifdef PERL_MEM_LOG
2722
2723 /* Here we are in a critical section. As explained above, we do our own
2724 * getenv(PERL_MEM_LOG), saving the result safely. */
2725 ret = getenv("PERL_MEM_LOG");
2726 if (ret == NULL) { /* No logging active */
2727
2728 /* Return that immediately if called from the logging code */
2729 if (PL_mem_log[0] & 0x2) {
2730 GETENV_UNLOCK;
2731 return NULL;
2732 }
2733
2734 PL_mem_log[1] = '\0';
2735 }
2736 else {
2737 char *mem_log_meat = PL_mem_log + 1; /* first byte reserved */
2738
2739 /* There is nothing to prevent the value of PERL_MEM_LOG from being an
2740 * extremely long string. But we want only a few characters from it.
2741 * PL_mem_log has been made large enough to hold just the ones we need.
2742 * First the file descriptor. */
2743 if (isDIGIT(*ret)) {
2744 const char * s = ret;
2745 if (UNLIKELY(*s == '0')) {
2746
2747 /* Reduce multiple leading zeros to a single one. This is to
2748 * allow the caller to change what to do with leading zeros. */
2749 *mem_log_meat++ = '0';
2750 s++;
2751 while (*s == '0') {
2752 s++;
2753 }
2754 }
2755
2756 /* If the input overflows, copy just enough for the result to also
2757 * overflow, plus 1 to make sure */
2758 while (isDIGIT(*s) && s < ret + TYPE_DIGITS(UV) + 1) {
2759 *mem_log_meat++ = *s++;
2760 }
2761 }
2762
2763 /* Then each of the three significant characters */
2764 if (strchr(ret, 'm')) {
2765 *mem_log_meat++ = 'm';
2766 }
2767 if (strchr(ret, 's')) {
2768 *mem_log_meat++ = 's';
2769 }
2770 if (strchr(ret, 't')) {
2771 *mem_log_meat++ = 't';
2772 }
2773 *mem_log_meat = '\0';
2774
2775 assert(mem_log_meat < PL_mem_log + sizeof(PL_mem_log));
2776 }
2777
2778 /* If we are being called from the logger, it only needs the significant
2779 * portion of PERL_MEM_LOG, and doesn't need a safe copy */
2780 if (PL_mem_log[0] & 0x2) {
2781 assert(strEQ(str, "PERL_MEM_LOG"));
2782 GETENV_UNLOCK;
2783 return PL_mem_log + 1;
2784 }
2785
2786 /* Here is a generic getenv(). This could be a getenv("PERL_MEM_LOG") that
2787 * is coming from other than the logging code, so it should be treated the
2788 * same as any other getenv(), returning the full value, not just the
2789 * significant part, and having its value saved. Set the flag that
2790 * indicates any call to this routine will be a recursion from here */
2791 PL_mem_log[0] = 0x1;
2792
2793#endif
2794
2795 /* Now get the value of the real desired variable, and save a copy */
24f3e849
KW
2796 ret = getenv(str);
2797
2798 if (ret != NULL) {
2799 ret = SvPVX(sv_2mortal(newSVpv(ret, 0)));
2800 }
2801
35bcf7ff
KW
2802 GETENV_UNLOCK;
2803
03694582
KW
2804#ifdef PERL_MEM_LOG
2805
2806 /* Clear the buffer */
2807 Zero(PL_mem_log, sizeof(PL_mem_log), char);
2808
2809#endif
2810
24f3e849
KW
2811 return ret;
2812}
2813
ed382232 2814/*
c8028aa6
TC
2815 * ex: set ts=8 sts=4 sw=4 et:
2816 */