| CARVIEW |
Select Language
HTTP/2 302
server: nginx
date: Thu, 31 Jul 2025 00:43:23 GMT
content-type: text/plain; charset=utf-8
content-length: 0
x-archive-redirect-reason: found capture at 20210117103931
location: https://web.archive.org/web/20210117103931/https://perl5.git.perl.org/perl5.git/blob/HEAD:/inline.h
server-timing: captures_list;dur=0.526937, exclusion.robots;dur=0.022229, exclusion.robots.policy;dur=0.010051, esindex;dur=0.011001, cdx.remote;dur=7.652372, LoadShardBlock;dur=86.048625, PetaboxLoader3.datanode;dur=61.187267
x-app-server: wwwb-app213
x-ts: 302
x-tr: 125
server-timing: TR;dur=0,Tw;dur=0,Tc;dur=0
set-cookie: SERVER=wwwb-app213; path=/
x-location: All
x-rl: 0
x-na: 0
x-page-cache: MISS
server-timing: MISS
x-nid: DigitalOcean
referrer-policy: no-referrer-when-downgrade
permissions-policy: interest-cohort=()
HTTP/2 200
server: nginx
date: Thu, 31 Jul 2025 00:43:24 GMT
content-type: application/xhtml+xml; charset=utf-8
x-archive-orig-date: Sun, 17 Jan 2021 10:39:30 GMT
x-archive-orig-server: Apache/2.4.6 (CentOS) OpenSSL/1.0.2k-fips
x-archive-orig-keep-alive: timeout=5, max=100
x-archive-orig-connection: Keep-Alive
x-archive-orig-x-crawler-transfer-encoding: chunked
x-archive-orig-content-length: 471655
x-archive-guessed-content-type: text/html
x-archive-guessed-charset: utf-8
memento-datetime: Sun, 17 Jan 2021 10:39:31 GMT
link: ; rel="original", ; rel="timemap"; type="application/link-format", ; rel="timegate", ; rel="first memento"; datetime="Sun, 17 Jan 2021 10:39:31 GMT", ; rel="memento"; datetime="Sun, 17 Jan 2021 10:39:31 GMT", ; rel="next memento"; datetime="Tue, 28 Mar 2023 06:25:14 GMT", ; rel="last memento"; datetime="Tue, 28 Mar 2023 06:25:14 GMT"
content-security-policy: default-src 'self' 'unsafe-eval' 'unsafe-inline' data: blob: archive.org web.archive.org web-static.archive.org wayback-api.archive.org athena.archive.org analytics.archive.org pragma.archivelab.org wwwb-events.archive.org
x-archive-src: CC-MAIN-2021-04-1610703511903.11-0012/CC-MAIN-20210117081748-20210117111748-00255.warc.gz
server-timing: captures_list;dur=0.683494, exclusion.robots;dur=0.023007, exclusion.robots.policy;dur=0.010114, esindex;dur=0.013836, cdx.remote;dur=15.477868, LoadShardBlock;dur=204.991482, PetaboxLoader3.datanode;dur=180.224042, load_resource;dur=180.674778, PetaboxLoader3.resolve;dur=66.266922
x-app-server: wwwb-app213
x-ts: 200
x-tr: 1085
server-timing: TR;dur=0,Tw;dur=0,Tc;dur=0
x-location: All
x-rl: 0
x-na: 0
x-page-cache: MISS
server-timing: MISS
x-nid: DigitalOcean
referrer-policy: no-referrer-when-downgrade
permissions-policy: interest-cohort=()
perl5.git.perl.org Git - perl5.git/blob - 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:
12 Copyright (c) 2008-2009 Bjoern Hoehrmann <bjoern@hoehrmann.de>
14 Permission is hereby granted, free of charge, to any person obtaining a copy of
15 this software and associated documentation files (the "Software"), to deal in
16 the Software without restriction, including without limitation the rights to
17 use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies
18 of the Software, and to permit persons to whom the Software is furnished to do
19 so, subject to the following conditions:
21 The above copyright notice and this permission notice shall be included in all
22 copies or substantial portions of the Software.
24 THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
25 IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
26 FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
27 AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
28 LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
29 OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
30 SOFTWARE.
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 */
40 /* ------------------------------- av.h ------------------------------- */
42 /*
43 =for apidoc_section $AV
44 =for apidoc av_count
45 Returns the number of elements in the array C<av>. This is the true length of
46 the array, including any undefined elements. It is always the same as
47 S<C<av_top_index(av) + 1>>.
49 =cut
50 */
51 PERL_STATIC_INLINE Size_t
52 Perl_av_count(pTHX_ AV *av)
53 {
54 PERL_ARGS_ASSERT_AV_COUNT;
55 assert(SvTYPE(av) == SVt_PVAV);
57 return AvFILL(av) + 1;
58 }
60 /* ------------------------------- cv.h ------------------------------- */
62 /*
63 =for apidoc_section $CV
64 =for apidoc CvGV
65 Returns the GV associated with the CV C<sv>, reifying it if necessary.
67 =cut
68 */
69 PERL_STATIC_INLINE GV *
70 Perl_CvGV(pTHX_ CV *sv)
71 {
72 PERL_ARGS_ASSERT_CVGV;
74 return CvNAMED(sv)
75 ? Perl_cvgv_from_hek(aTHX_ sv)
76 : ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_gv;
77 }
79 PERL_STATIC_INLINE I32 *
80 Perl_CvDEPTH(const CV * const sv)
81 {
82 PERL_ARGS_ASSERT_CVDEPTH;
83 assert(SvTYPE(sv) == SVt_PVCV || SvTYPE(sv) == SVt_PVFM);
85 return &((XPVCV*)SvANY(sv))->xcv_depth;
86 }
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 */
99 #ifdef PERL_CORE
100 PERL_STATIC_INLINE char *
101 S_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 }
116 #endif
118 /* ------------------------------- mg.h ------------------------------- */
120 #if defined(PERL_CORE) || defined(PERL_EXT)
121 /* assumes get-magic and stringification have already occurred */
122 PERL_STATIC_INLINE STRLEN
123 S_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
138 /* ------------------------------- pad.h ------------------------------ */
140 #if defined(PERL_IN_PAD_C) || defined(PERL_IN_OP_C)
141 PERL_STATIC_INLINE bool
142 S_PadnameIN_SCOPE(const PADNAME * const pn, const U32 seq)
143 {
144 PERL_ARGS_ASSERT_PADNAMEIN_SCOPE;
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 */
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))
167 : ( seq > COP_SEQ_RANGE_LOW(pn)
168 && seq <= COP_SEQ_RANGE_HIGH(pn))
169 )
170 return TRUE;
171 return FALSE;
172 }
173 #endif
175 /* ------------------------------- pp.h ------------------------------- */
177 PERL_STATIC_INLINE I32
178 Perl_TOPMARK(pTHX)
179 {
180 DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
181 "MARK top %p %" IVdf "\n",
182 PL_markstack_ptr,
183 (IV)*PL_markstack_ptr)));
184 return *PL_markstack_ptr;
185 }
187 PERL_STATIC_INLINE I32
188 Perl_POPMARK(pTHX)
189 {
190 DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
191 "MARK pop %p %" IVdf "\n",
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 }
198 /* ----------------------------- regexp.h ----------------------------- */
200 PERL_STATIC_INLINE struct regexp *
201 Perl_ReANY(const REGEXP * const re)
202 {
203 XPV* const p = (XPV*)SvANY(re);
205 PERL_ARGS_ASSERT_REANY;
206 assert(isREGEXP(re));
208 return SvTYPE(re) == SVt_PVLV ? p->xpv_len_u.xpvlenu_rx
209 : (struct regexp *)p;
210 }
212 /* ------------------------------- sv.h ------------------------------- */
214 PERL_STATIC_INLINE bool
215 Perl_SvTRUE(pTHX_ SV *sv)
216 {
217 PERL_ARGS_ASSERT_SVTRUE;
219 if (UNLIKELY(sv == NULL))
220 return FALSE;
221 SvGETMAGIC(sv);
222 return SvTRUE_nomg_NN(sv);
223 }
225 PERL_STATIC_INLINE bool
226 Perl_SvTRUE_nomg(pTHX_ SV *sv)
227 {
228 PERL_ARGS_ASSERT_SVTRUE_NOMG;
230 if (UNLIKELY(sv == NULL))
231 return FALSE;
232 return SvTRUE_nomg_NN(sv);
233 }
235 PERL_STATIC_INLINE bool
236 Perl_SvTRUE_NN(pTHX_ SV *sv)
237 {
238 PERL_ARGS_ASSERT_SVTRUE_NN;
240 SvGETMAGIC(sv);
241 return SvTRUE_nomg_NN(sv);
242 }
244 PERL_STATIC_INLINE bool
245 Perl_SvTRUE_common(pTHX_ SV * sv, const bool sv_2bool_is_fallback)
246 {
247 PERL_ARGS_ASSERT_SVTRUE_COMMON;
249 if (UNLIKELY(SvIMMORTAL_INTERP(sv)))
250 return SvIMMORTAL_TRUE(sv);
252 if (! SvOK(sv))
253 return FALSE;
255 if (SvPOK(sv))
256 return SvPVXtrue(sv);
258 if (SvIOK(sv))
259 return SvIVX(sv) != 0; /* casts to bool */
261 if (SvROK(sv) && !(SvOBJECT(SvRV(sv)) && HvAMAGIC(SvSTASH(SvRV(sv)))))
262 return TRUE;
264 if (sv_2bool_is_fallback)
265 return sv_2bool_nomg(sv);
267 return isGV_with_GP(sv);
268 }
271 PERL_STATIC_INLINE SV *
272 Perl_SvREFCNT_inc(SV *sv)
273 {
274 if (LIKELY(sv != NULL))
275 SvREFCNT(sv)++;
276 return sv;
277 }
278 PERL_STATIC_INLINE SV *
279 Perl_SvREFCNT_inc_NN(SV *sv)
280 {
281 PERL_ARGS_ASSERT_SVREFCNT_INC_NN;
283 SvREFCNT(sv)++;
284 return sv;
285 }
286 PERL_STATIC_INLINE void
287 Perl_SvREFCNT_inc_void(SV *sv)
288 {
289 if (LIKELY(sv != NULL))
290 SvREFCNT(sv)++;
291 }
292 PERL_STATIC_INLINE void
293 Perl_SvREFCNT_dec(pTHX_ SV *sv)
294 {
295 if (LIKELY(sv != NULL)) {
296 U32 rc = SvREFCNT(sv);
297 if (LIKELY(rc > 1))
298 SvREFCNT(sv) = rc - 1;
299 else
300 Perl_sv_free2(aTHX_ sv, rc);
301 }
302 }
304 PERL_STATIC_INLINE void
305 Perl_SvREFCNT_dec_NN(pTHX_ SV *sv)
306 {
307 U32 rc = SvREFCNT(sv);
309 PERL_ARGS_ASSERT_SVREFCNT_DEC_NN;
311 if (LIKELY(rc > 1))
312 SvREFCNT(sv) = rc - 1;
313 else
314 Perl_sv_free2(aTHX_ sv, rc);
315 }
317 PERL_STATIC_INLINE void
318 Perl_SvAMAGIC_on(SV *sv)
319 {
320 PERL_ARGS_ASSERT_SVAMAGIC_ON;
321 assert(SvROK(sv));
323 if (SvOBJECT(SvRV(sv))) HvAMAGIC_on(SvSTASH(SvRV(sv)));
324 }
325 PERL_STATIC_INLINE void
326 Perl_SvAMAGIC_off(SV *sv)
327 {
328 PERL_ARGS_ASSERT_SVAMAGIC_OFF;
330 if (SvROK(sv) && SvOBJECT(SvRV(sv)))
331 HvAMAGIC_off(SvSTASH(SvRV(sv)));
332 }
334 PERL_STATIC_INLINE U32
335 Perl_SvPADSTALE_on(SV *sv)
336 {
337 assert(!(SvFLAGS(sv) & SVs_PADTMP));
338 return SvFLAGS(sv) |= SVs_PADSTALE;
339 }
340 PERL_STATIC_INLINE U32
341 Perl_SvPADSTALE_off(SV *sv)
342 {
343 assert(!(SvFLAGS(sv) & SVs_PADTMP));
344 return SvFLAGS(sv) &= ~SVs_PADSTALE;
345 }
346 #if defined(PERL_CORE) || defined (PERL_EXT)
347 PERL_STATIC_INLINE STRLEN
348 S_sv_or_pv_pos_u2b(pTHX_ SV *sv, const char *pv, STRLEN pos, STRLEN *lenp)
349 {
350 PERL_ARGS_ASSERT_SV_OR_PV_POS_U2B;
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
360 /* ------------------------------- utf8.h ------------------------------- */
362 /*
363 =for apidoc_section $unicode
364 */
366 PERL_STATIC_INLINE void
367 Perl_append_utf8_from_native_byte(const U8 byte, U8** dest)
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 */
372 PERL_ARGS_ASSERT_APPEND_UTF8_FROM_NATIVE_BYTE;
374 if (NATIVE_BYTE_IS_INVARIANT(byte))
375 *((*dest)++) = byte;
376 else {
377 *((*dest)++) = UTF8_EIGHT_BIT_HI(byte);
378 *((*dest)++) = UTF8_EIGHT_BIT_LO(byte);
379 }
380 }
382 /*
383 =for apidoc valid_utf8_to_uvchr
384 Like C<L<perlapi/utf8_to_uvchr_buf>>, but should only be called when it is
385 known 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
387 points, and non-Unicode code points are allowed.
389 =cut
391 */
393 PERL_STATIC_INLINE UV
394 Perl_valid_utf8_to_uvchr(const U8 *s, STRLEN *retlen)
395 {
396 const UV expectlen = UTF8SKIP(s);
397 const U8* send = s + expectlen;
398 UV uv = *s;
400 PERL_ARGS_ASSERT_VALID_UTF8_TO_UVCHR;
402 if (retlen) {
403 *retlen = expectlen;
404 }
406 /* An invariant is trivially returned */
407 if (expectlen == 1) {
408 return uv;
409 }
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);
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 }
422 return UNI_TO_NATIVE(uv);
424 }
426 /*
427 =for apidoc is_utf8_invariant_string
429 Returns TRUE if the first C<len> bytes of the string C<s> are the same
430 regardless of the UTF-8 encoding of the string (or UTF-EBCDIC encoding on
431 EBCDIC machines); otherwise it returns FALSE. That is, it returns TRUE if they
432 are UTF-8 invariant. On ASCII-ish machines, all the ASCII characters and only
433 the ASCII characters fit this definition. On EBCDIC machines, the ASCII-range
434 characters are invariant, but so also are the C1 controls.
436 If C<len> is 0, it will be calculated using C<strlen(s)>, (which means if you
437 use this option, that C<s> can't have embedded C<NUL> characters and has to
438 have a terminating C<NUL> byte).
440 See also
441 C<L</is_utf8_string>>,
442 C<L</is_utf8_string_flags>>,
443 C<L</is_utf8_string_loc>>,
444 C<L</is_utf8_string_loc_flags>>,
445 C<L</is_utf8_string_loclen>>,
446 C<L</is_utf8_string_loclen_flags>>,
447 C<L</is_utf8_fixed_width_buf_flags>>,
448 C<L</is_utf8_fixed_width_buf_loc_flags>>,
449 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
450 C<L</is_strict_utf8_string>>,
451 C<L</is_strict_utf8_string_loc>>,
452 C<L</is_strict_utf8_string_loclen>>,
453 C<L</is_c9strict_utf8_string>>,
454 C<L</is_c9strict_utf8_string_loc>>,
455 and
456 C<L</is_c9strict_utf8_string_loclen>>.
458 =cut
460 */
462 #define is_utf8_invariant_string(s, len) \
463 is_utf8_invariant_string_loc(s, len, NULL)
465 /*
466 =for apidoc is_utf8_invariant_string_loc
468 Like C<L</is_utf8_invariant_string>> but upon failure, stores the location of
469 the first UTF-8 variant character in the C<ep> pointer; if all characters are
470 UTF-8 invariant, this function does not change the contents of C<*ep>.
472 =cut
474 */
476 PERL_STATIC_INLINE bool
477 Perl_is_utf8_invariant_string_loc(const U8* const s, STRLEN len, const U8 ** ep)
478 {
479 const U8* send;
480 const U8* x = s;
482 PERL_ARGS_ASSERT_IS_UTF8_INVARIANT_STRING_LOC;
484 if (len == 0) {
485 len = strlen((const char *)s);
486 }
488 send = s + len;
490 /* This looks like 0x010101... */
491 # define PERL_COUNT_MULTIPLIER (~ (UINTMAX_C(0)) / 0xFF)
493 /* This looks like 0x808080... */
494 # define PERL_VARIANTS_WORD_MASK (PERL_COUNT_MULTIPLIER * 0x80)
495 # define PERL_WORDSIZE sizeof(PERL_UINTMAX_T)
496 # define PERL_WORD_BOUNDARY_MASK (PERL_WORDSIZE - 1)
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 */
502 # define PERL_IS_SUBWORD_ADDR(x) (1 & ( PTR2nat(x) \
503 | ( PTR2nat(x) >> 1) \
504 | ( ( (PTR2nat(x) \
505 & PERL_WORD_BOUNDARY_MASK) >> 2))))
507 #ifndef EBCDIC
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
515 /* This term is wordsize if subword; 0 if not */
516 + PERL_WORDSIZE * PERL_IS_SUBWORD_ADDR(x)
518 /* 'offset' */
519 - (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK))
520 {
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 */
524 while (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK) {
525 if (! UTF8_IS_INVARIANT(*x)) {
526 if (ep) {
527 *ep = x;
528 }
530 return FALSE;
531 }
532 x++;
533 }
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 {
538 if ((* (PERL_UINTMAX_T *) x) & PERL_VARIANTS_WORD_MASK) {
540 /* Found a variant. Just return if caller doesn't want its
541 * exact position */
542 if (! ep) {
543 return FALSE;
544 }
546 # if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 \
547 || BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
549 *ep = x + variant_byte_number(* (PERL_UINTMAX_T *) x);
550 assert(*ep >= s && *ep < send);
552 return FALSE;
554 # else /* If weird byte order, drop into next loop to do byte-at-a-time
555 checks. */
557 break;
558 # endif
559 }
561 x += PERL_WORDSIZE;
563 } while (x + PERL_WORDSIZE <= send);
564 }
566 #endif /* End of ! EBCDIC */
568 /* Process per-byte */
569 while (x < send) {
570 if (! UTF8_IS_INVARIANT(*x)) {
571 if (ep) {
572 *ep = x;
573 }
575 return FALSE;
576 }
578 x++;
579 }
581 return TRUE;
582 }
584 #ifndef EBCDIC
586 PERL_STATIC_INLINE unsigned int
587 Perl_variant_byte_number(PERL_UINTMAX_T word)
588 {
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 */
593 assert(word);
595 /* Get just the msb bits of each byte */
596 word &= PERL_VARIANTS_WORD_MASK;
598 # if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
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 *
607 * The word will look like this, with a rightmost set bit in position 's':
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
615 * 0..0011..1 The xor with the original, x..xx10..0, clears that
616 * remainder, sets the bottom to all 1
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 */
622 word >>= 1;
623 word = 1 + (word ^ (word - 1));
625 # elif BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
627 /* Bytes are stored like
628 * Byte1 Byte2 ... Byte8
629 * 63..56 55..47 ... 7...0
630 *
631 * Isolate the msb; https://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. */
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);
648 # else
649 # error Unexpected byte order
650 # endif
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
654 * specialized solution: https://stackoverflow.com/a/32339674/1626653,
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));
661 word >>= PERL_WORDSIZE * 7; /* >> by either 56 or 24 */
663 /* Here, word contains the position 7..63 of that bit. Convert to 0..7 */
664 word = ((word + 1) >> 3) - 1;
666 # if BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
668 /* And invert the result */
669 word = CHARBITS - word - 1;
671 # endif
673 return (unsigned int) word;
674 }
676 #endif
677 #if defined(PERL_CORE) || defined(PERL_EXT)
679 /*
680 =for apidoc variant_under_utf8_count
682 This function looks at the sequence of bytes between C<s> and C<e>, which are
683 assumed to be encoded in ASCII/Latin1, and returns how many of them would
684 change should the string be translated into UTF-8. Due to the nature of UTF-8,
685 each of these would occupy two bytes instead of the single one in the input
686 string. Thus, this function returns the precise number of bytes the string
687 would expand by when translated to UTF-8.
689 Unlike most of the other functions that have C<utf8> in their name, the input
690 to this function is NOT a UTF-8-encoded string. The function name is slightly
691 I<odd> to emphasize this.
693 This function is internal to Perl because khw thinks that any XS code that
694 would want this is probably operating too close to the internals. Presenting a
695 valid use case could change that.
697 See also
698 C<L<perlapi/is_utf8_invariant_string>>
699 and
700 C<L<perlapi/is_utf8_invariant_string_loc>>,
702 =cut
704 */
706 PERL_STATIC_INLINE Size_t
707 S_variant_under_utf8_count(const U8* const s, const U8* const e)
708 {
709 const U8* x = s;
710 Size_t count = 0;
712 PERL_ARGS_ASSERT_VARIANT_UNDER_UTF8_COUNT;
714 # ifndef EBCDIC
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()) */
718 if ((STRLEN) (e - x) >= PERL_WORDSIZE
719 + PERL_WORDSIZE * PERL_IS_SUBWORD_ADDR(x)
720 - (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK))
721 {
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 }
729 /* Process per-word as long as we have at least a full word left */
730 do { /* Commit 03c1e4ab1d6ee9062fb3f94b0ba31db6698724b1 contains an
731 explanation of how this works */
732 PERL_UINTMAX_T increment
733 = ((((* (PERL_UINTMAX_T *) x) & PERL_VARIANTS_WORD_MASK) >> 7)
734 * PERL_COUNT_MULTIPLIER)
735 >> ((PERL_WORDSIZE - 1) * CHARBITS);
736 count += (Size_t) increment;
737 x += PERL_WORDSIZE;
738 } while (x + PERL_WORDSIZE <= e);
739 }
741 # endif
743 /* Process per-byte */
744 while (x < e) {
745 if (! UTF8_IS_INVARIANT(*x)) {
746 count++;
747 }
749 x++;
750 }
752 return count;
753 }
755 #endif
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
764 /*
765 =for apidoc is_utf8_string
767 Returns TRUE if the first C<len> bytes of string C<s> form a valid
768 Perl-extended-UTF-8 string; returns FALSE otherwise. If C<len> is 0, it will
769 be calculated using C<strlen(s)> (which means if you use this option, that C<s>
770 can't have embedded C<NUL> characters and has to have a terminating C<NUL>
771 byte). Note that all characters being ASCII constitute 'a valid UTF-8 string'.
773 This function considers Perl's extended UTF-8 to be valid. That means that
774 code points above Unicode, surrogates, and non-character code points are
775 considered valid by this function. Use C<L</is_strict_utf8_string>>,
776 C<L</is_c9strict_utf8_string>>, or C<L</is_utf8_string_flags>> to restrict what
777 code points are considered valid.
779 See also
780 C<L</is_utf8_invariant_string>>,
781 C<L</is_utf8_invariant_string_loc>>,
782 C<L</is_utf8_string_loc>>,
783 C<L</is_utf8_string_loclen>>,
784 C<L</is_utf8_fixed_width_buf_flags>>,
785 C<L</is_utf8_fixed_width_buf_loc_flags>>,
786 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
788 =cut
789 */
791 #define is_utf8_string(s, len) is_utf8_string_loclen(s, len, NULL, NULL)
793 #if defined(PERL_CORE) || defined (PERL_EXT)
795 /*
796 =for apidoc is_utf8_non_invariant_string
798 Returns TRUE if L<perlapi/is_utf8_invariant_string> returns FALSE for the first
799 C<len> bytes of the string C<s>, but they are, nonetheless, legal Perl-extended
800 UTF-8; otherwise returns FALSE.
802 A TRUE return means that at least one code point represented by the sequence
803 either is a wide character not representable as a single byte, or the
804 representation differs depending on whether the sequence is encoded in UTF-8 or
805 not.
807 See also
808 C<L<perlapi/is_utf8_invariant_string>>,
809 C<L<perlapi/is_utf8_string>>
811 =cut
813 This is commonly used to determine if a SV's UTF-8 flag should be turned on.
814 It generally needn't be if its string is entirely UTF-8 invariant, and it
815 shouldn't be if it otherwise contains invalid UTF-8.
817 It is an internal function because khw thinks that XS code shouldn't be working
818 at this low a level. A valid use case could change that.
820 */
822 PERL_STATIC_INLINE bool
823 Perl_is_utf8_non_invariant_string(const U8* const s, STRLEN len)
824 {
825 const U8 * first_variant;
827 PERL_ARGS_ASSERT_IS_UTF8_NON_INVARIANT_STRING;
829 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
830 return FALSE;
831 }
833 return is_utf8_string(first_variant, len - (first_variant - s));
834 }
836 #endif
838 /*
839 =for apidoc is_strict_utf8_string
841 Returns TRUE if the first C<len> bytes of string C<s> form a valid
842 UTF-8-encoded string that is fully interchangeable by any application using
843 Unicode rules; otherwise it returns FALSE. If C<len> is 0, it will be
844 calculated using C<strlen(s)> (which means if you use this option, that C<s>
845 can't have embedded C<NUL> characters and has to have a terminating C<NUL>
846 byte). Note that all characters being ASCII constitute 'a valid UTF-8 string'.
848 This function returns FALSE for strings containing any
849 code points above the Unicode max of 0x10FFFF, surrogate code points, or
850 non-character code points.
852 See also
853 C<L</is_utf8_invariant_string>>,
854 C<L</is_utf8_invariant_string_loc>>,
855 C<L</is_utf8_string>>,
856 C<L</is_utf8_string_flags>>,
857 C<L</is_utf8_string_loc>>,
858 C<L</is_utf8_string_loc_flags>>,
859 C<L</is_utf8_string_loclen>>,
860 C<L</is_utf8_string_loclen_flags>>,
861 C<L</is_utf8_fixed_width_buf_flags>>,
862 C<L</is_utf8_fixed_width_buf_loc_flags>>,
863 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
864 C<L</is_strict_utf8_string_loc>>,
865 C<L</is_strict_utf8_string_loclen>>,
866 C<L</is_c9strict_utf8_string>>,
867 C<L</is_c9strict_utf8_string_loc>>,
868 and
869 C<L</is_c9strict_utf8_string_loclen>>.
871 =cut
872 */
874 #define is_strict_utf8_string(s, len) is_strict_utf8_string_loclen(s, len, NULL, NULL)
876 /*
877 =for apidoc is_c9strict_utf8_string
879 Returns TRUE if the first C<len> bytes of string C<s> form a valid
880 UTF-8-encoded string that conforms to
881 L<Unicode Corrigendum #9|https://www.unicode.org/versions/corrigendum9.html>;
882 otherwise it returns FALSE. If C<len> is 0, it will be calculated using
883 C<strlen(s)> (which means if you use this option, that C<s> can't have embedded
884 C<NUL> characters and has to have a terminating C<NUL> byte). Note that all
885 characters being ASCII constitute 'a valid UTF-8 string'.
887 This function returns FALSE for strings containing any code points above the
888 Unicode max of 0x10FFFF or surrogate code points, but accepts non-character
889 code points per
890 L<Corrigendum #9|https://www.unicode.org/versions/corrigendum9.html>.
892 See also
893 C<L</is_utf8_invariant_string>>,
894 C<L</is_utf8_invariant_string_loc>>,
895 C<L</is_utf8_string>>,
896 C<L</is_utf8_string_flags>>,
897 C<L</is_utf8_string_loc>>,
898 C<L</is_utf8_string_loc_flags>>,
899 C<L</is_utf8_string_loclen>>,
900 C<L</is_utf8_string_loclen_flags>>,
901 C<L</is_utf8_fixed_width_buf_flags>>,
902 C<L</is_utf8_fixed_width_buf_loc_flags>>,
903 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
904 C<L</is_strict_utf8_string>>,
905 C<L</is_strict_utf8_string_loc>>,
906 C<L</is_strict_utf8_string_loclen>>,
907 C<L</is_c9strict_utf8_string_loc>>,
908 and
909 C<L</is_c9strict_utf8_string_loclen>>.
911 =cut
912 */
914 #define is_c9strict_utf8_string(s, len) is_c9strict_utf8_string_loclen(s, len, NULL, 0)
916 /*
917 =for apidoc is_utf8_string_flags
919 Returns TRUE if the first C<len> bytes of string C<s> form a valid
920 UTF-8 string, subject to the restrictions imposed by C<flags>;
921 returns FALSE otherwise. If C<len> is 0, it will be calculated
922 using C<strlen(s)> (which means if you use this option, that C<s> can't have
923 embedded C<NUL> characters and has to have a terminating C<NUL> byte). Note
924 that all characters being ASCII constitute 'a valid UTF-8 string'.
926 If C<flags> is 0, this gives the same results as C<L</is_utf8_string>>; if
927 C<flags> is C<UTF8_DISALLOW_ILLEGAL_INTERCHANGE>, this gives the same results
928 as C<L</is_strict_utf8_string>>; and if C<flags> is
929 C<UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE>, this gives the same results as
930 C<L</is_c9strict_utf8_string>>. Otherwise C<flags> may be any
931 combination of the C<UTF8_DISALLOW_I<foo>> flags understood by
932 C<L</utf8n_to_uvchr>>, with the same meanings.
934 See also
935 C<L</is_utf8_invariant_string>>,
936 C<L</is_utf8_invariant_string_loc>>,
937 C<L</is_utf8_string>>,
938 C<L</is_utf8_string_loc>>,
939 C<L</is_utf8_string_loc_flags>>,
940 C<L</is_utf8_string_loclen>>,
941 C<L</is_utf8_string_loclen_flags>>,
942 C<L</is_utf8_fixed_width_buf_flags>>,
943 C<L</is_utf8_fixed_width_buf_loc_flags>>,
944 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
945 C<L</is_strict_utf8_string>>,
946 C<L</is_strict_utf8_string_loc>>,
947 C<L</is_strict_utf8_string_loclen>>,
948 C<L</is_c9strict_utf8_string>>,
949 C<L</is_c9strict_utf8_string_loc>>,
950 and
951 C<L</is_c9strict_utf8_string_loclen>>.
953 =cut
954 */
956 PERL_STATIC_INLINE bool
957 Perl_is_utf8_string_flags(const U8 *s, STRLEN len, const U32 flags)
958 {
959 const U8 * first_variant;
961 PERL_ARGS_ASSERT_IS_UTF8_STRING_FLAGS;
962 assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
963 |UTF8_DISALLOW_PERL_EXTENDED)));
965 if (len == 0) {
966 len = strlen((const char *)s);
967 }
969 if (flags == 0) {
970 return is_utf8_string(s, len);
971 }
973 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
974 == UTF8_DISALLOW_ILLEGAL_INTERCHANGE)
975 {
976 return is_strict_utf8_string(s, len);
977 }
979 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
980 == UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE)
981 {
982 return is_c9strict_utf8_string(s, len);
983 }
985 if (! is_utf8_invariant_string_loc(s, len, &first_variant)) {
986 const U8* const send = s + len;
987 const U8* x = first_variant;
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;
995 }
996 }
998 return TRUE;
999 }
1001 /*
1003 =for apidoc is_utf8_string_loc
1005 Like C<L</is_utf8_string>> but stores the location of the failure (in the
1006 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1007 "utf8ness success") in the C<ep> pointer.
1009 See also C<L</is_utf8_string_loclen>>.
1011 =cut
1012 */
1014 #define is_utf8_string_loc(s, len, ep) is_utf8_string_loclen(s, len, ep, 0)
1016 /*
1018 =for apidoc is_utf8_string_loclen
1020 Like C<L</is_utf8_string>> but stores the location of the failure (in the
1021 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1022 "utf8ness success") in the C<ep> pointer, and the number of UTF-8
1023 encoded characters in the C<el> pointer.
1025 See also C<L</is_utf8_string_loc>>.
1027 =cut
1028 */
1030 PERL_STATIC_INLINE bool
1031 Perl_is_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
1032 {
1033 const U8 * first_variant;
1035 PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN;
1037 if (len == 0) {
1038 len = strlen((const char *) s);
1039 }
1041 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
1042 if (el)
1043 *el = len;
1045 if (ep) {
1046 *ep = s + len;
1047 }
1049 return TRUE;
1050 }
1052 {
1053 const U8* const send = s + len;
1054 const U8* x = first_variant;
1055 STRLEN outlen = first_variant - s;
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++;
1064 }
1066 if (el)
1067 *el = outlen;
1069 if (ep) {
1070 *ep = x;
1071 }
1073 return (x == send);
1074 }
1075 }
1077 /*
1079 =for apidoc isUTF8_CHAR
1081 Evaluates to non-zero if the first few bytes of the string starting at C<s> and
1082 looking no further than S<C<e - 1>> are well-formed UTF-8, as extended by Perl,
1083 that represents some code point; otherwise it evaluates to 0. If non-zero, the
1084 value gives how many bytes starting at C<s> comprise the code point's
1085 representation. Any bytes remaining before C<e>, but beyond the ones needed to
1086 form the first code point in C<s>, are not examined.
1088 The code point can be any that will fit in an IV on this machine, using Perl's
1089 extension to official UTF-8 to represent those higher than the Unicode maximum
1090 of 0x10FFFF. That means that this macro is used to efficiently decide if the
1091 next few bytes in C<s> is legal UTF-8 for a single character.
1093 Use C<L</isSTRICT_UTF8_CHAR>> to restrict the acceptable code points to those
1094 defined by Unicode to be fully interchangeable across applications;
1095 C<L</isC9_STRICT_UTF8_CHAR>> to use the L<Unicode Corrigendum
1096 #9|https://www.unicode.org/versions/corrigendum9.html> definition of allowable
1097 code points; and C<L</isUTF8_CHAR_flags>> for a more customized definition.
1099 Use C<L</is_utf8_string>>, C<L</is_utf8_string_loc>>, and
1100 C<L</is_utf8_string_loclen>> to check entire strings.
1102 Note also that a UTF-8 "invariant" character (i.e. ASCII on non-EBCDIC
1103 machines) is a valid UTF-8 character.
1105 =cut
1107 This uses an adaptation of the table and algorithm given in
1108 https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
1109 documentation of the original version. A copyright notice for the original
1110 version is given at the beginning of this file. The Perl adapation is
1111 documented at the definition of PL_extended_utf8_dfa_tab[].
1113 */
1115 PERL_STATIC_INLINE Size_t
1116 Perl_isUTF8_CHAR(const U8 * const s0, const U8 * const e)
1117 {
1118 const U8 * s = s0;
1119 UV state = 0;
1121 PERL_ARGS_ASSERT_ISUTF8_CHAR;
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. */
1129 while (s < e && LIKELY(state != 1)) {
1130 state = PL_extended_utf8_dfa_tab[256
1131 + state
1132 + PL_extended_utf8_dfa_tab[*s]];
1133 if (state != 0) {
1134 s++;
1135 continue;
1136 }
1138 return s - s0 + 1;
1139 }
1141 #if defined(UV_IS_QUAD) || defined(EBCDIC)
1143 if (NATIVE_UTF8_TO_I8(*s0) == 0xFF && e - s0 >= UTF8_MAXBYTES) {
1144 return is_utf8_char_helper(s0, e, 0);
1145 }
1147 #endif
1149 return 0;
1150 }
1152 /*
1154 =for apidoc isSTRICT_UTF8_CHAR
1156 Evaluates to non-zero if the first few bytes of the string starting at C<s> and
1157 looking no further than S<C<e - 1>> are well-formed UTF-8 that represents some
1158 Unicode code point completely acceptable for open interchange between all
1159 applications; otherwise it evaluates to 0. If non-zero, the value gives how
1160 many bytes starting at C<s> comprise the code point's representation. Any
1161 bytes remaining before C<e>, but beyond the ones needed to form the first code
1162 point in C<s>, are not examined.
1164 The largest acceptable code point is the Unicode maximum 0x10FFFF, and must not
1165 be a surrogate nor a non-character code point. Thus this excludes any code
1166 point from Perl's extended UTF-8.
1168 This is used to efficiently decide if the next few bytes in C<s> is
1169 legal Unicode-acceptable UTF-8 for a single character.
1171 Use C<L</isC9_STRICT_UTF8_CHAR>> to use the L<Unicode Corrigendum
1172 #9|https://www.unicode.org/versions/corrigendum9.html> definition of allowable
1173 code points; C<L</isUTF8_CHAR>> to check for Perl's extended UTF-8;
1174 and C<L</isUTF8_CHAR_flags>> for a more customized definition.
1176 Use C<L</is_strict_utf8_string>>, C<L</is_strict_utf8_string_loc>>, and
1177 C<L</is_strict_utf8_string_loclen>> to check entire strings.
1179 =cut
1181 This uses an adaptation of the tables and algorithm given in
1182 https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
1183 documentation of the original version. A copyright notice for the original
1184 version is given at the beginning of this file. The Perl adapation is
1185 documented at the definition of strict_extended_utf8_dfa_tab[].
1187 */
1189 PERL_STATIC_INLINE Size_t
1190 Perl_isSTRICT_UTF8_CHAR(const U8 * const s0, const U8 * const e)
1191 {
1192 const U8 * s = s0;
1193 UV state = 0;
1195 PERL_ARGS_ASSERT_ISSTRICT_UTF8_CHAR;
1197 while (s < e && LIKELY(state != 1)) {
1198 state = PL_strict_utf8_dfa_tab[256 + state + PL_strict_utf8_dfa_tab[*s]];
1200 if (state != 0) {
1201 s++;
1202 continue;
1203 }
1205 return s - s0 + 1;
1206 }
1208 #ifndef EBCDIC
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 }
1215 #endif
1217 return 0;
1218 }
1220 /*
1222 =for apidoc isC9_STRICT_UTF8_CHAR
1224 Evaluates to non-zero if the first few bytes of the string starting at C<s> and
1225 looking no further than S<C<e - 1>> are well-formed UTF-8 that represents some
1226 Unicode non-surrogate code point; otherwise it evaluates to 0. If non-zero,
1227 the value gives how many bytes starting at C<s> comprise the code point's
1228 representation. Any bytes remaining before C<e>, but beyond the ones needed to
1229 form the first code point in C<s>, are not examined.
1231 The largest acceptable code point is the Unicode maximum 0x10FFFF. This
1232 differs from C<L</isSTRICT_UTF8_CHAR>> only in that it accepts non-character
1233 code points. This corresponds to
1234 L<Unicode Corrigendum #9|https://www.unicode.org/versions/corrigendum9.html>.
1235 which said that non-character code points are merely discouraged rather than
1236 completely forbidden in open interchange. See
1237 L<perlunicode/Noncharacter code points>.
1239 Use C<L</isUTF8_CHAR>> to check for Perl's extended UTF-8; and
1240 C<L</isUTF8_CHAR_flags>> for a more customized definition.
1242 Use C<L</is_c9strict_utf8_string>>, C<L</is_c9strict_utf8_string_loc>>, and
1243 C<L</is_c9strict_utf8_string_loclen>> to check entire strings.
1245 =cut
1247 This uses an adaptation of the tables and algorithm given in
1248 https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
1249 documentation of the original version. A copyright notice for the original
1250 version is given at the beginning of this file. The Perl adapation is
1251 documented at the definition of PL_c9_utf8_dfa_tab[].
1253 */
1255 PERL_STATIC_INLINE Size_t
1256 Perl_isC9_STRICT_UTF8_CHAR(const U8 * const s0, const U8 * const e)
1257 {
1258 const U8 * s = s0;
1259 UV state = 0;
1261 PERL_ARGS_ASSERT_ISC9_STRICT_UTF8_CHAR;
1263 while (s < e && LIKELY(state != 1)) {
1264 state = PL_c9_utf8_dfa_tab[256 + state + PL_c9_utf8_dfa_tab[*s]];
1266 if (state != 0) {
1267 s++;
1268 continue;
1269 }
1271 return s - s0 + 1;
1272 }
1274 return 0;
1275 }
1277 /*
1279 =for apidoc is_strict_utf8_string_loc
1281 Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
1282 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1283 "utf8ness success") in the C<ep> pointer.
1285 See also C<L</is_strict_utf8_string_loclen>>.
1287 =cut
1288 */
1290 #define is_strict_utf8_string_loc(s, len, ep) \
1291 is_strict_utf8_string_loclen(s, len, ep, 0)
1293 /*
1295 =for apidoc is_strict_utf8_string_loclen
1297 Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
1298 case 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
1300 encoded characters in the C<el> pointer.
1302 See also C<L</is_strict_utf8_string_loc>>.
1304 =cut
1305 */
1307 PERL_STATIC_INLINE bool
1308 Perl_is_strict_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
1309 {
1310 const U8 * first_variant;
1312 PERL_ARGS_ASSERT_IS_STRICT_UTF8_STRING_LOCLEN;
1314 if (len == 0) {
1315 len = strlen((const char *) s);
1316 }
1318 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
1319 if (el)
1320 *el = len;
1322 if (ep) {
1323 *ep = s + len;
1324 }
1326 return TRUE;
1327 }
1329 {
1330 const U8* const send = s + len;
1331 const U8* x = first_variant;
1332 STRLEN outlen = first_variant - s;
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++;
1341 }
1343 if (el)
1344 *el = outlen;
1346 if (ep) {
1347 *ep = x;
1348 }
1350 return (x == send);
1351 }
1352 }
1354 /*
1356 =for apidoc is_c9strict_utf8_string_loc
1358 Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in
1359 the case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1360 "utf8ness success") in the C<ep> pointer.
1362 See also C<L</is_c9strict_utf8_string_loclen>>.
1364 =cut
1365 */
1367 #define is_c9strict_utf8_string_loc(s, len, ep) \
1368 is_c9strict_utf8_string_loclen(s, len, ep, 0)
1370 /*
1372 =for apidoc is_c9strict_utf8_string_loclen
1374 Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in
1375 the 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
1377 characters in the C<el> pointer.
1379 See also C<L</is_c9strict_utf8_string_loc>>.
1381 =cut
1382 */
1384 PERL_STATIC_INLINE bool
1385 Perl_is_c9strict_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
1386 {
1387 const U8 * first_variant;
1389 PERL_ARGS_ASSERT_IS_C9STRICT_UTF8_STRING_LOCLEN;
1391 if (len == 0) {
1392 len = strlen((const char *) s);
1393 }
1395 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
1396 if (el)
1397 *el = len;
1399 if (ep) {
1400 *ep = s + len;
1401 }
1403 return TRUE;
1404 }
1406 {
1407 const U8* const send = s + len;
1408 const U8* x = first_variant;
1409 STRLEN outlen = first_variant - s;
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++;
1418 }
1420 if (el)
1421 *el = outlen;
1423 if (ep) {
1424 *ep = x;
1425 }
1427 return (x == send);
1428 }
1429 }
1431 /*
1433 =for apidoc is_utf8_string_loc_flags
1435 Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the
1436 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1437 "utf8ness success") in the C<ep> pointer.
1439 See also C<L</is_utf8_string_loclen_flags>>.
1441 =cut
1442 */
1444 #define is_utf8_string_loc_flags(s, len, ep, flags) \
1445 is_utf8_string_loclen_flags(s, len, ep, 0, flags)
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 */
1452 /*
1454 =for apidoc is_utf8_string_loclen_flags
1456 Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the
1457 case 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
1459 encoded characters in the C<el> pointer.
1461 See also C<L</is_utf8_string_loc_flags>>.
1463 =cut
1464 */
1466 PERL_STATIC_INLINE bool
1467 Perl_is_utf8_string_loclen_flags(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el, const U32 flags)
1468 {
1469 const U8 * first_variant;
1471 PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN_FLAGS;
1472 assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
1473 |UTF8_DISALLOW_PERL_EXTENDED)));
1475 if (len == 0) {
1476 len = strlen((const char *) s);
1477 }
1479 if (flags == 0) {
1480 return is_utf8_string_loclen(s, len, ep, el);
1481 }
1483 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
1484 == UTF8_DISALLOW_ILLEGAL_INTERCHANGE)
1485 {
1486 return is_strict_utf8_string_loclen(s, len, ep, el);
1487 }
1489 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
1490 == UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE)
1491 {
1492 return is_c9strict_utf8_string_loclen(s, len, ep, el);
1493 }
1495 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
1496 if (el)
1497 *el = len;
1499 if (ep) {
1500 *ep = s + len;
1501 }
1503 return TRUE;
1504 }
1506 {
1507 const U8* send = s + len;
1508 const U8* x = first_variant;
1509 STRLEN outlen = first_variant - s;
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++;
1518 }
1520 if (el)
1521 *el = outlen;
1523 if (ep) {
1524 *ep = x;
1525 }
1527 return (x == send);
1528 }
1529 }
1531 /*
1532 =for apidoc utf8_distance
1534 Returns the number of UTF-8 characters between the UTF-8 pointers C<a>
1535 and C<b>.
1537 WARNING: use only if you *know* that the pointers point inside the
1538 same UTF-8 buffer.
1540 =cut
1541 */
1543 PERL_STATIC_INLINE IV
1544 Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b)
1545 {
1546 PERL_ARGS_ASSERT_UTF8_DISTANCE;
1548 return (a < b) ? -1 * (IV) utf8_length(a, b) : (IV) utf8_length(b, a);
1549 }
1551 /*
1552 =for apidoc utf8_hop
1554 Return the UTF-8 pointer C<s> displaced by C<off> characters, either
1555 forward or backward.
1557 WARNING: do not use the following unless you *know* C<off> is within
1558 the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
1559 on the first byte of character or just after the last byte of a character.
1561 =cut
1562 */
1564 PERL_STATIC_INLINE U8 *
1565 Perl_utf8_hop(const U8 *s, SSize_t off)
1566 {
1567 PERL_ARGS_ASSERT_UTF8_HOP;
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. */
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 }
1584 GCC_DIAG_IGNORE(-Wcast-qual)
1585 return (U8 *)s;
1586 GCC_DIAG_RESTORE
1587 }
1589 /*
1590 =for apidoc utf8_hop_forward
1592 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1593 forward.
1595 C<off> must be non-negative.
1597 C<s> must be before or equal to C<end>.
1599 When moving forward it will not move beyond C<end>.
1601 Will not exceed this limit even if the string is not valid "UTF-8".
1603 =cut
1604 */
1606 PERL_STATIC_INLINE U8 *
1607 Perl_utf8_hop_forward(const U8 *s, SSize_t off, const U8 *end)
1608 {
1609 PERL_ARGS_ASSERT_UTF8_HOP_FORWARD;
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. */
1615 assert(s <= end);
1616 assert(off >= 0);
1618 while (off--) {
1619 STRLEN skip = UTF8SKIP(s);
1620 if ((STRLEN)(end - s) <= skip) {
1621 GCC_DIAG_IGNORE(-Wcast-qual)
1622 return (U8 *)end;
1623 GCC_DIAG_RESTORE
1624 }
1625 s += skip;
1626 }
1628 GCC_DIAG_IGNORE(-Wcast-qual)
1629 return (U8 *)s;
1630 GCC_DIAG_RESTORE
1631 }
1633 /*
1634 =for apidoc utf8_hop_back
1636 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1637 backward.
1639 C<off> must be non-positive.
1641 C<s> must be after or equal to C<start>.
1643 When moving backward it will not move before C<start>.
1645 Will not exceed this limit even if the string is not valid "UTF-8".
1647 =cut
1648 */
1650 PERL_STATIC_INLINE U8 *
1651 Perl_utf8_hop_back(const U8 *s, SSize_t off, const U8 *start)
1652 {
1653 PERL_ARGS_ASSERT_UTF8_HOP_BACK;
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. */
1659 assert(start <= s);
1660 assert(off <= 0);
1662 while (off++ && s > start) {
1663 do {
1664 s--;
1665 } while (UTF8_IS_CONTINUATION(*s) && s > start);
1666 }
1668 GCC_DIAG_IGNORE(-Wcast-qual)
1669 return (U8 *)s;
1670 GCC_DIAG_RESTORE
1671 }
1673 /*
1674 =for apidoc utf8_hop_safe
1676 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1677 either forward or backward.
1679 When moving backward it will not move before C<start>.
1681 When moving forward it will not move beyond C<end>.
1683 Will not exceed those limits even if the string is not valid "UTF-8".
1685 =cut
1686 */
1688 PERL_STATIC_INLINE U8 *
1689 Perl_utf8_hop_safe(const U8 *s, SSize_t off, const U8 *start, const U8 *end)
1690 {
1691 PERL_ARGS_ASSERT_UTF8_HOP_SAFE;
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. */
1697 assert(start <= s && s <= end);
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 }
1707 /*
1709 =for apidoc is_utf8_valid_partial_char
1711 Returns 0 if the sequence of bytes starting at C<s> and looking no further than
1712 S<C<e - 1>> is the UTF-8 encoding, as extended by Perl, for one or more code
1713 points. Otherwise, it returns 1 if there exists at least one non-empty
1714 sequence of bytes that when appended to sequence C<s>, starting at position
1715 C<e> causes the entire sequence to be the well-formed UTF-8 of some code point;
1716 otherwise returns 0.
1718 In other words this returns TRUE if C<s> points to a partial UTF-8-encoded code
1719 point.
1721 This is useful when a fixed-length buffer is being tested for being well-formed
1722 UTF-8, but the final few bytes in it don't comprise a full character; that is,
1723 it is split somewhere in the middle of the final code point's UTF-8
1724 representation. (Presumably when the buffer is refreshed with the next chunk
1725 of data, the new first bytes will complete the partial code point.) This
1726 function is used to verify that the final bytes in the current buffer are in
1727 fact the legal beginning of some code point, so that if they aren't, the
1728 failure can be signalled without having to wait for the next read.
1730 =cut
1731 */
1732 #define is_utf8_valid_partial_char(s, e) \
1733 is_utf8_valid_partial_char_flags(s, e, 0)
1735 /*
1737 =for apidoc is_utf8_valid_partial_char_flags
1739 Like C<L</is_utf8_valid_partial_char>>, it returns a boolean giving whether
1740 or not the input is a valid UTF-8 encoded partial character, but it takes an
1741 extra parameter, C<flags>, which can further restrict which code points are
1742 considered valid.
1744 If C<flags> is 0, this behaves identically to
1745 C<L</is_utf8_valid_partial_char>>. Otherwise C<flags> can be any combination
1746 of the C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>. If
1747 there is any sequence of bytes that can complete the input partial character in
1748 such a way that a non-prohibited character is formed, the function returns
1749 TRUE; otherwise FALSE. Non character code points cannot be determined based on
1750 partial character input. But many of the other possible excluded types can be
1751 determined from just the first one or two bytes.
1753 =cut
1754 */
1756 PERL_STATIC_INLINE bool
1757 Perl_is_utf8_valid_partial_char_flags(const U8 * const s, const U8 * const e, const U32 flags)
1758 {
1759 PERL_ARGS_ASSERT_IS_UTF8_VALID_PARTIAL_CHAR_FLAGS;
1761 assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
1762 |UTF8_DISALLOW_PERL_EXTENDED)));
1764 if (s >= e || s + UTF8SKIP(s) <= e) {
1765 return FALSE;
1766 }
1768 return cBOOL(is_utf8_char_helper(s, e, flags));
1769 }
1771 /*
1773 =for apidoc is_utf8_fixed_width_buf_flags
1775 Returns TRUE if the fixed-width buffer starting at C<s> with length C<len>
1776 is entirely valid UTF-8, subject to the restrictions given by C<flags>;
1777 otherwise it returns FALSE.
1779 If C<flags> is 0, any well-formed UTF-8, as extended by Perl, is accepted
1780 without restriction. If the final few bytes of the buffer do not form a
1781 complete code point, this will return TRUE anyway, provided that
1782 C<L</is_utf8_valid_partial_char_flags>> returns TRUE for them.
1784 If C<flags> in non-zero, it can be any combination of the
1785 C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>, and with the
1786 same meanings.
1788 This function differs from C<L</is_utf8_string_flags>> only in that the latter
1789 returns FALSE if the final few bytes of the string don't form a complete code
1790 point.
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)
1797 /*
1799 =for apidoc is_utf8_fixed_width_buf_loc_flags
1801 Like C<L</is_utf8_fixed_width_buf_flags>> but stores the location of the
1802 failure in the C<ep> pointer. If the function returns TRUE, C<*ep> will point
1803 to the beginning of any partial character at the end of the buffer; if there is
1804 no partial character C<*ep> will contain C<s>+C<len>.
1806 See also C<L</is_utf8_fixed_width_buf_loclen_flags>>.
1808 =cut
1809 */
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)
1814 /*
1816 =for apidoc is_utf8_fixed_width_buf_loclen_flags
1818 Like C<L</is_utf8_fixed_width_buf_loc_flags>> but stores the number of
1819 complete, valid characters found in the C<el> pointer.
1821 =cut
1822 */
1824 PERL_STATIC_INLINE bool
1825 Perl_is_utf8_fixed_width_buf_loclen_flags(const U8 * const s,
1826 STRLEN len,
1827 const U8 **ep,
1828 STRLEN *el,
1829 const U32 flags)
1830 {
1831 const U8 * maybe_partial;
1833 PERL_ARGS_ASSERT_IS_UTF8_FIXED_WIDTH_BUF_LOCLEN_FLAGS;
1835 if (! ep) {
1836 ep = &maybe_partial;
1837 }
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 }
1845 PERL_STATIC_INLINE UV
1846 Perl_utf8n_to_uvchr_msgs(const U8 *s,
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
1860 * https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides
1861 * comprehensive documentation of the original version. A copyright notice
1862 * for the original version is given at the beginning of this file. The
1863 * Perl adapation is documented at the definition of PL_strict_utf8_dfa_tab[].
1864 */
1866 const U8 * const s0 = s;
1867 const U8 * send = s0 + curlen;
1868 UV uv = 0; /* The 0 silences some stupid compilers */
1869 UV state = 0;
1871 PERL_ARGS_ASSERT_UTF8N_TO_UVCHR_MSGS;
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. */
1878 while (s < send && LIKELY(state != 1)) {
1879 UV type = PL_strict_utf8_dfa_tab[*s];
1881 uv = (state == 0)
1882 ? ((0xff >> type) & NATIVE_UTF8_TO_I8(*s))
1883 : UTF8_ACCUMULATE(uv, *s);
1884 state = PL_strict_utf8_dfa_tab[256 + state + type];
1886 if (state != 0) {
1887 s++;
1888 continue;
1889 }
1891 if (retlen) {
1892 *retlen = s - s0 + 1;
1893 }
1894 if (errors) {
1895 *errors = 0;
1896 }
1897 if (msgs) {
1898 *msgs = NULL;
1899 }
1901 return UNI_TO_NATIVE(uv);
1902 }
1904 /* Here is potentially problematic. Use the full mechanism */
1905 return _utf8n_to_uvchr_msgs_helper(s0, curlen, retlen, flags, errors, msgs);
1906 }
1908 PERL_STATIC_INLINE UV
1909 Perl_utf8_to_uvchr_buf_helper(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen)
1910 {
1911 PERL_ARGS_ASSERT_UTF8_TO_UVCHR_BUF_HELPER;
1913 assert(s < send);
1915 if (! ckWARN_d(WARN_UTF8)) {
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 */
1920 return utf8n_to_uvchr(s, send - s, retlen,
1921 (UTF8_ALLOW_ANY | UTF8_ALLOW_EMPTY));
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 }
1929 return ret;
1930 }
1931 }
1933 /* ------------------------------- perl.h ----------------------------- */
1935 /*
1936 =for apidoc_section $utility
1938 =for apidoc is_safe_syscall
1940 Test that the given C<pv> (with length C<len>) doesn't contain any internal
1941 C<NUL> characters.
1942 If it does, set C<errno> to C<ENOENT>, optionally warn using the C<syscalls>
1943 category, and return FALSE.
1945 Return TRUE if the name is safe.
1947 C<what> and C<op_name> are used in any warning.
1949 Used by the C<IS_SAFE_SYSCALL()> macro.
1951 =cut
1952 */
1954 PERL_STATIC_INLINE bool
1955 Perl_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name)
1956 {
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 */
1961 PERL_ARGS_ASSERT_IS_SAFE_SYSCALL;
1963 if (len > 1) {
1964 char *null_at;
1965 if (UNLIKELY((null_at = (char *)memchr(pv, 0, len-1)) != NULL)) {
1966 SETERRNO(ENOENT, LIB_INVARG);
1967 Perl_ck_warner(aTHX_ packWARN(WARN_SYSCALLS),
1968 "Invalid \\0 character in %s for %s: %s\\0%s",
1969 what, op_name, pv, null_at+1);
1970 return FALSE;
1971 }
1972 }
1974 return TRUE;
1975 }
1977 /*
1979 Return true if the supplied filename has a newline character
1980 immediately before the first (hopefully only) NUL.
1982 My original look at this incorrectly used the len from SvPV(), but
1983 that's incorrect, since we allow for a NUL in pv[len-1].
1985 So instead, strlen() and work from there.
1987 This allow for the user reading a filename, forgetting to chomp it,
1988 then calling:
1990 open my $foo, "$file\0";
1992 */
1994 #ifdef PERL_CORE
1996 PERL_STATIC_INLINE bool
1997 S_should_warn_nl(const char *pv)
1998 {
1999 STRLEN len;
2001 PERL_ARGS_ASSERT_SHOULD_WARN_NL;
2003 len = strlen(pv);
2005 return len > 0 && pv[len-1] == '\n';
2006 }
2008 #endif
2010 #if defined(PERL_IN_PP_C) || defined(PERL_IN_PP_HOT_C)
2012 PERL_STATIC_INLINE bool
2013 S_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' */
2020 PERL_ARGS_ASSERT_LOSSLESS_NV_TO_IV;
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 */
2025 if (UNLIKELY(Perl_isnan(nv))) {
2026 return FALSE;
2027 }
2028 # endif
2030 /* Written this way so that with an always-false NaN comparison we
2031 * return false */
2032 if (!(LIKELY(nv >= (NV) IV_MIN) && LIKELY(nv < IV_MAX_P1))) {
2033 return FALSE;
2034 }
2036 if ((IV) nv != nv) {
2037 return FALSE;
2038 }
2040 *ivp = (IV) nv;
2041 return TRUE;
2042 }
2044 #endif
2046 /* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */
2048 #if defined(PERL_IN_PP_C) || defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_TOKE_C) || defined(PERL_IN_UNIVERSAL_C)
2050 #define MAX_CHARSET_NAME_LENGTH 2
2052 PERL_STATIC_INLINE const char *
2053 S_get_regex_charset_name(const U32 flags, STRLEN* const lenp)
2054 {
2055 PERL_ARGS_ASSERT_GET_REGEX_CHARSET_NAME;
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 */
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 }
2077 #endif
2079 /*
2081 Return false if any get magic is on the SV other than taint magic.
2083 */
2085 PERL_STATIC_INLINE bool
2086 Perl_sv_only_taint_gmagic(SV *sv)
2087 {
2088 MAGIC *mg = SvMAGIC(sv);
2090 PERL_ARGS_ASSERT_SV_ONLY_TAINT_GMAGIC;
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 }
2101 return TRUE;
2102 }
2104 /* ------------------ cop.h ------------------------------------------- */
2106 /* implement GIMME_V() macro */
2108 PERL_STATIC_INLINE U8
2109 Perl_gimme_V(pTHX)
2110 {
2111 I32 cxix;
2112 U8 gimme = (PL_op->op_flags & OPf_WANT);
2114 if (gimme)
2115 return gimme;
2116 cxix = PL_curstackinfo->si_cxsubix;
2117 if (cxix < 0)
2118 return PL_curstackinfo->si_type == PERLSI_SORT ? G_SCALAR: G_VOID;
2119 assert(cxstack[cxix].blk_gimme & G_WANT);
2120 return (cxstack[cxix].blk_gimme & G_WANT);
2121 }
2124 /* Enter a block. Push a new base context and return its address. */
2126 PERL_STATIC_INLINE PERL_CONTEXT *
2127 Perl_cx_pushblock(pTHX_ U8 type, U8 gimme, SV** sp, I32 saveix)
2128 {
2129 PERL_CONTEXT * cx;
2131 PERL_ARGS_ASSERT_CX_PUSHBLOCK;
2133 CXINC;
2134 cx = CX_CUR();
2135 cx->cx_type = type;
2136 cx->blk_gimme = gimme;
2137 cx->blk_oldsaveix = saveix;
2138 cx->blk_oldsp = (I32)(sp - PL_stack_base);
2139 cx->blk_oldcop = PL_curcop;
2140 cx->blk_oldmarksp = (I32)(PL_markstack_ptr - PL_markstack);
2141 cx->blk_oldscopesp = PL_scopestack_ix;
2142 cx->blk_oldpm = PL_curpm;
2143 cx->blk_old_tmpsfloor = PL_tmps_floor;
2145 PL_tmps_floor = PL_tmps_ix;
2146 CX_DEBUG(cx, "PUSH");
2147 return cx;
2148 }
2151 /* Exit a block (RETURN and LAST). */
2153 PERL_STATIC_INLINE void
2154 Perl_cx_popblock(pTHX_ PERL_CONTEXT *cx)
2155 {
2156 PERL_ARGS_ASSERT_CX_POPBLOCK;
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;
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;
2170 PL_tmps_floor = cx->blk_old_tmpsfloor;
2171 }
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. */
2178 PERL_STATIC_INLINE void
2179 Perl_cx_topblock(pTHX_ PERL_CONTEXT *cx)
2180 {
2181 PERL_ARGS_ASSERT_CX_TOPBLOCK;
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;
2189 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
2190 }
2193 PERL_STATIC_INLINE void
2194 Perl_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs)
2195 {
2196 U8 phlags = CX_PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub);
2198 PERL_ARGS_ASSERT_CX_PUSHSUB;
2200 PERL_DTRACE_PROBE_ENTRY(cv);
2201 cx->blk_sub.old_cxsubix = PL_curstackinfo->si_cxsubix;
2202 PL_curstackinfo->si_cxsubix = cx - PL_curstackinfo->si_cxstack;
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 }
2213 /* subsets of cx_popsub() */
2215 PERL_STATIC_INLINE void
2216 Perl_cx_popsub_common(pTHX_ PERL_CONTEXT *cx)
2217 {
2218 CV *cv;
2220 PERL_ARGS_ASSERT_CX_POPSUB_COMMON;
2221 assert(CxTYPE(cx) == CXt_SUB);
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);
2229 PL_curstackinfo->si_cxsubix = cx->blk_sub.old_cxsubix;
2230 }
2233 /* handle the @_ part of leaving a sub */
2235 PERL_STATIC_INLINE void
2236 Perl_cx_popsub_args(pTHX_ PERL_CONTEXT *cx)
2237 {
2238 AV *av;
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);
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 }
2257 PERL_STATIC_INLINE void
2258 Perl_cx_popsub(pTHX_ PERL_CONTEXT *cx)
2259 {
2260 PERL_ARGS_ASSERT_CX_POPSUB;
2261 assert(CxTYPE(cx) == CXt_SUB);
2263 PERL_DTRACE_PROBE_RETURN(cx->blk_sub.cv);
2265 if (CxHASARGS(cx))
2266 cx_popsub_args(cx);
2267 cx_popsub_common(cx);
2268 }
2271 PERL_STATIC_INLINE void
2272 Perl_cx_pushformat(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, GV *gv)
2273 {
2274 PERL_ARGS_ASSERT_CX_PUSHFORMAT;
2276 cx->blk_format.old_cxsubix = PL_curstackinfo->si_cxsubix;
2277 PL_curstackinfo->si_cxsubix= cx - PL_curstackinfo->si_cxstack;
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;
2285 SvREFCNT_inc_simple_void_NN(cv);
2286 CvDEPTH(cv)++;
2287 SvREFCNT_inc_void(cx->blk_format.dfoutgv);
2288 }
2291 PERL_STATIC_INLINE void
2292 Perl_cx_popformat(pTHX_ PERL_CONTEXT *cx)
2293 {
2294 CV *cv;
2295 GV *dfout;
2297 PERL_ARGS_ASSERT_CX_POPFORMAT;
2298 assert(CxTYPE(cx) == CXt_FORMAT);
2300 dfout = cx->blk_format.dfoutgv;
2301 setdefout(dfout);
2302 cx->blk_format.dfoutgv = NULL;
2303 SvREFCNT_dec_NN(dfout);
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);
2311 PL_curstackinfo->si_cxsubix = cx->blk_format.old_cxsubix;
2312 }
2315 PERL_STATIC_INLINE void
2316 Perl_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv)
2317 {
2318 PERL_ARGS_ASSERT_CX_PUSHEVAL;
2320 cx->blk_eval.old_cxsubix = PL_curstackinfo->si_cxsubix;
2321 PL_curstackinfo->si_cxsubix= cx - PL_curstackinfo->si_cxstack;
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;
2329 assert(!(PL_in_eval & ~ 0x3F));
2330 assert(!(PL_op->op_type & ~0x1FF));
2331 cx->blk_u16 = (PL_in_eval & 0x3F) | ((U16)PL_op->op_type << 7);
2332 }
2335 PERL_STATIC_INLINE void
2336 Perl_cx_popeval(pTHX_ PERL_CONTEXT *cx)
2337 {
2338 SV *sv;
2340 PERL_ARGS_ASSERT_CX_POPEVAL;
2341 assert(CxTYPE(cx) == CXt_EVAL);
2343 PL_in_eval = CxOLD_IN_EVAL(cx);
2344 assert(!(PL_in_eval & 0xc0));
2345 PL_eval_root = cx->blk_eval.old_eval_root;
2346 sv = cx->blk_eval.cur_text;
2347 if (sv && CxEVAL_TXT_REFCNTED(cx)) {
2348 cx->blk_eval.cur_text = NULL;
2349 SvREFCNT_dec_NN(sv);
2350 }
2352 sv = cx->blk_eval.old_namesv;
2353 if (sv) {
2354 cx->blk_eval.old_namesv = NULL;
2355 SvREFCNT_dec_NN(sv);
2356 }
2357 PL_curstackinfo->si_cxsubix = cx->blk_eval.old_cxsubix;
2358 }
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 */
2368 PERL_STATIC_INLINE void
2369 Perl_cx_pushloop_plain(pTHX_ PERL_CONTEXT *cx)
2370 {
2371 PERL_ARGS_ASSERT_CX_PUSHLOOP_PLAIN;
2372 cx->blk_loop.my_op = cLOOP;
2373 }
2376 /* push a true for loop, i.e.
2377 * for var (list) { block }
2378 */
2380 PERL_STATIC_INLINE void
2381 Perl_cx_pushloop_for(pTHX_ PERL_CONTEXT *cx, void *itervarp, SV* itersave)
2382 {
2383 PERL_ARGS_ASSERT_CX_PUSHLOOP_FOR;
2385 /* this one line is common with cx_pushloop_plain */
2386 cx->blk_loop.my_op = cLOOP;
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 }
2396 /* pop all loop types, including plain */
2398 PERL_STATIC_INLINE void
2399 Perl_cx_poploop(pTHX_ PERL_CONTEXT *cx)
2400 {
2401 PERL_ARGS_ASSERT_CX_POPLOOP;
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 }
2431 PERL_STATIC_INLINE void
2432 Perl_cx_pushwhen(pTHX_ PERL_CONTEXT *cx)
2433 {
2434 PERL_ARGS_ASSERT_CX_PUSHWHEN;
2436 cx->blk_givwhen.leave_op = cLOGOP->op_other;
2437 }
2440 PERL_STATIC_INLINE void
2441 Perl_cx_popwhen(pTHX_ PERL_CONTEXT *cx)
2442 {
2443 PERL_ARGS_ASSERT_CX_POPWHEN;
2444 assert(CxTYPE(cx) == CXt_WHEN);
2446 PERL_UNUSED_ARG(cx);
2447 PERL_UNUSED_CONTEXT;
2448 /* currently NOOP */
2449 }
2452 PERL_STATIC_INLINE void
2453 Perl_cx_pushgiven(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv)
2454 {
2455 PERL_ARGS_ASSERT_CX_PUSHGIVEN;
2457 cx->blk_givwhen.leave_op = cLOGOP->op_other;
2458 cx->blk_givwhen.defsv_save = orig_defsv;
2459 }
2462 PERL_STATIC_INLINE void
2463 Perl_cx_popgiven(pTHX_ PERL_CONTEXT *cx)
2464 {
2465 SV *sv;
2467 PERL_ARGS_ASSERT_CX_POPGIVEN;
2468 assert(CxTYPE(cx) == CXt_GIVEN);
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 }
2476 /* ------------------ util.h ------------------------------------------- */
2478 /*
2479 =for apidoc_section $string
2481 =for apidoc foldEQ
2483 Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
2484 same
2485 case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes
2486 match themselves and their opposite case counterparts. Non-cased and non-ASCII
2487 range bytes match only themselves.
2489 =cut
2490 */
2492 PERL_STATIC_INLINE I32
2493 Perl_foldEQ(const char *s1, const char *s2, I32 len)
2494 {
2495 const U8 *a = (const U8 *)s1;
2496 const U8 *b = (const U8 *)s2;
2498 PERL_ARGS_ASSERT_FOLDEQ;
2500 assert(len >= 0);
2502 while (len--) {
2503 if (*a != *b && *a != PL_fold[*b])
2504 return 0;
2505 a++,b++;
2506 }
2507 return 1;
2508 }
2510 PERL_STATIC_INLINE I32
2511 Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
2512 {
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. */
2518 const U8 *a = (const U8 *)s1;
2519 const U8 *b = (const U8 *)s2;
2521 PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
2523 assert(len >= 0);
2525 while (len--) {
2526 if (*a != *b && *a != PL_fold_latin1[*b]) {
2527 return 0;
2528 }
2529 a++, b++;
2530 }
2531 return 1;
2532 }
2534 /*
2535 =for apidoc_section $locale
2536 =for apidoc foldEQ_locale
2538 Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
2539 same case-insensitively in the current locale; false otherwise.
2541 =cut
2542 */
2544 PERL_STATIC_INLINE I32
2545 Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
2546 {
2547 const U8 *a = (const U8 *)s1;
2548 const U8 *b = (const U8 *)s2;
2550 PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
2552 assert(len >= 0);
2554 while (len--) {
2555 if (*a != *b && *a != PL_fold_locale[*b])
2556 return 0;
2557 a++,b++;
2558 }
2559 return 1;
2560 }
2562 /*
2563 =for apidoc_section $string
2564 =for apidoc my_strnlen
2566 The C library C<strnlen> if available, or a Perl implementation of it.
2568 C<my_strnlen()> computes the length of the string, up to C<maxlen>
2569 characters. It will never attempt to address more than C<maxlen>
2570 characters, making it suitable for use with strings that are not
2571 guaranteed to be NUL-terminated.
2573 =cut
2575 Description stolen from https://man.openbsd.org/strnlen.3,
2576 implementation stolen from PostgreSQL.
2577 */
2578 #ifndef HAS_STRNLEN
2580 PERL_STATIC_INLINE Size_t
2581 Perl_my_strnlen(const char *str, Size_t maxlen)
2582 {
2583 const char *end = (char *) memchr(str, '\0', maxlen);
2585 PERL_ARGS_ASSERT_MY_STRNLEN;
2587 if (end == NULL) return maxlen;
2588 return end - str;
2589 }
2591 #endif
2593 #if ! defined (HAS_MEMRCHR) && (defined(PERL_CORE) || defined(PERL_EXT))
2595 PERL_STATIC_INLINE void *
2596 S_my_memrchr(const char * s, const char c, const STRLEN len)
2597 {
2598 /* memrchr(), since many platforms lack it */
2600 const char * t = s + len - 1;
2602 PERL_ARGS_ASSERT_MY_MEMRCHR;
2604 while (t >= s) {
2605 if (*t == c) {
2606 return (void *) t;
2607 }
2608 t--;
2609 }
2611 return NULL;
2612 }
2614 #endif
2616 PERL_STATIC_INLINE char *
2617 Perl_mortal_getenv(const char * str)
2618 {
2619 /* This implements a (mostly) thread-safe, sequential-call-safe getenv().
2620 *
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
2627 *
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.
2632 *
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..
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. */
2653 char * ret;
2654 dTHX;
2656 PERL_ARGS_ASSERT_MORTAL_GETENV;
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 }
2665 #ifdef PERL_MEM_LOG
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 }
2717 #endif
2719 GETENV_LOCK;
2721 #ifdef PERL_MEM_LOG
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 */
2728 /* Return that immediately if called from the logging code */
2729 if (PL_mem_log[0] & 0x2) {
2730 GETENV_UNLOCK;
2731 return NULL;
2732 }
2734 PL_mem_log[1] = '\0';
2735 }
2736 else {
2737 char *mem_log_meat = PL_mem_log + 1; /* first byte reserved */
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')) {
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 }
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 }
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';
2775 assert(mem_log_meat < PL_mem_log + sizeof(PL_mem_log));
2776 }
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 }
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;
2793 #endif
2795 /* Now get the value of the real desired variable, and save a copy */
2796 ret = getenv(str);
2798 if (ret != NULL) {
2799 ret = SvPVX(sv_2mortal(newSVpv(ret, 0)));
2800 }
2802 GETENV_UNLOCK;
2804 #ifdef PERL_MEM_LOG
2806 /* Clear the buffer */
2807 Zero(PL_mem_log, sizeof(PL_mem_log), char);
2809 #endif
2811 return ret;
2812 }
2814 /*
2815 * ex: set ts=8 sts=4 sw=4 et:
2816 */