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