This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
SvTRUE might need to take aTHX
[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 PERL_STATIC_INLINE SSize_t
43 Perl_av_top_index(pTHX_ AV *av)
44 {
45     PERL_ARGS_ASSERT_AV_TOP_INDEX;
46     assert(SvTYPE(av) == SVt_PVAV);
47
48     return AvFILL(av);
49 }
50
51 /* ------------------------------- cv.h ------------------------------- */
52
53 PERL_STATIC_INLINE GV *
54 Perl_CvGV(pTHX_ CV *sv)
55 {
56     PERL_ARGS_ASSERT_CVGV;
57
58     return CvNAMED(sv)
59         ? Perl_cvgv_from_hek(aTHX_ sv)
60         : ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_gv;
61 }
62
63 PERL_STATIC_INLINE I32 *
64 Perl_CvDEPTH(const CV * const sv)
65 {
66     PERL_ARGS_ASSERT_CVDEPTH;
67     assert(SvTYPE(sv) == SVt_PVCV || SvTYPE(sv) == SVt_PVFM);
68
69     return &((XPVCV*)SvANY(sv))->xcv_depth;
70 }
71
72 /*
73  CvPROTO returns the prototype as stored, which is not necessarily what
74  the interpreter should be using. Specifically, the interpreter assumes
75  that spaces have been stripped, which has been the case if the prototype
76  was added by toke.c, but is generally not the case if it was added elsewhere.
77  Since we can't enforce the spacelessness at assignment time, this routine
78  provides a temporary copy at parse time with spaces removed.
79  I<orig> is the start of the original buffer, I<len> is the length of the
80  prototype and will be updated when this returns.
81  */
82
83 #ifdef PERL_CORE
84 PERL_STATIC_INLINE char *
85 S_strip_spaces(pTHX_ const char * orig, STRLEN * const len)
86 {
87     SV * tmpsv;
88     char * tmps;
89     tmpsv = newSVpvn_flags(orig, *len, SVs_TEMP);
90     tmps = SvPVX(tmpsv);
91     while ((*len)--) {
92         if (!isSPACE(*orig))
93             *tmps++ = *orig;
94         orig++;
95     }
96     *tmps = '\0';
97     *len = tmps - SvPVX(tmpsv);
98                 return SvPVX(tmpsv);
99 }
100 #endif
101
102 /* ------------------------------- mg.h ------------------------------- */
103
104 #if defined(PERL_CORE) || defined(PERL_EXT)
105 /* assumes get-magic and stringification have already occurred */
106 PERL_STATIC_INLINE STRLEN
107 S_MgBYTEPOS(pTHX_ MAGIC *mg, SV *sv, const char *s, STRLEN len)
108 {
109     assert(mg->mg_type == PERL_MAGIC_regex_global);
110     assert(mg->mg_len != -1);
111     if (mg->mg_flags & MGf_BYTES || !DO_UTF8(sv))
112         return (STRLEN)mg->mg_len;
113     else {
114         const STRLEN pos = (STRLEN)mg->mg_len;
115         /* Without this check, we may read past the end of the buffer: */
116         if (pos > sv_or_pv_len_utf8(sv, s, len)) return len+1;
117         return sv_or_pv_pos_u2b(sv, s, pos, NULL);
118     }
119 }
120 #endif
121
122 /* ------------------------------- pad.h ------------------------------ */
123
124 #if defined(PERL_IN_PAD_C) || defined(PERL_IN_OP_C)
125 PERL_STATIC_INLINE bool
126 S_PadnameIN_SCOPE(const PADNAME * const pn, const U32 seq)
127 {
128     PERL_ARGS_ASSERT_PADNAMEIN_SCOPE;
129
130     /* is seq within the range _LOW to _HIGH ?
131      * This is complicated by the fact that PL_cop_seqmax
132      * may have wrapped around at some point */
133     if (COP_SEQ_RANGE_LOW(pn) == PERL_PADSEQ_INTRO)
134         return FALSE; /* not yet introduced */
135
136     if (COP_SEQ_RANGE_HIGH(pn) == PERL_PADSEQ_INTRO) {
137     /* in compiling scope */
138         if (
139             (seq >  COP_SEQ_RANGE_LOW(pn))
140             ? (seq - COP_SEQ_RANGE_LOW(pn) < (U32_MAX >> 1))
141             : (COP_SEQ_RANGE_LOW(pn) - seq > (U32_MAX >> 1))
142         )
143             return TRUE;
144     }
145     else if (
146         (COP_SEQ_RANGE_LOW(pn) > COP_SEQ_RANGE_HIGH(pn))
147         ?
148             (  seq >  COP_SEQ_RANGE_LOW(pn)
149             || seq <= COP_SEQ_RANGE_HIGH(pn))
150
151         :    (  seq >  COP_SEQ_RANGE_LOW(pn)
152              && seq <= COP_SEQ_RANGE_HIGH(pn))
153     )
154         return TRUE;
155     return FALSE;
156 }
157 #endif
158
159 /* ------------------------------- pp.h ------------------------------- */
160
161 PERL_STATIC_INLINE I32
162 Perl_TOPMARK(pTHX)
163 {
164     DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
165                                  "MARK top  %p %" IVdf "\n",
166                                   PL_markstack_ptr,
167                                   (IV)*PL_markstack_ptr)));
168     return *PL_markstack_ptr;
169 }
170
171 PERL_STATIC_INLINE I32
172 Perl_POPMARK(pTHX)
173 {
174     DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
175                                  "MARK pop  %p %" IVdf "\n",
176                                   (PL_markstack_ptr-1),
177                                   (IV)*(PL_markstack_ptr-1))));
178     assert((PL_markstack_ptr > PL_markstack) || !"MARK underflow");
179     return *PL_markstack_ptr--;
180 }
181
182 /* ----------------------------- regexp.h ----------------------------- */
183
184 PERL_STATIC_INLINE struct regexp *
185 Perl_ReANY(const REGEXP * const re)
186 {
187     XPV* const p = (XPV*)SvANY(re);
188
189     PERL_ARGS_ASSERT_REANY;
190     assert(isREGEXP(re));
191
192     return SvTYPE(re) == SVt_PVLV ? p->xpv_len_u.xpvlenu_rx
193                                    : (struct regexp *)p;
194 }
195
196 /* ------------------------------- sv.h ------------------------------- */
197
198 PERL_STATIC_INLINE bool
199 Perl_SvTRUE(pTHX_ SV *sv) {
200     if (!LIKELY(sv))
201         return FALSE;
202     return SvTRUE_NN(sv);
203 }
204
205 PERL_STATIC_INLINE SV *
206 Perl_SvREFCNT_inc(SV *sv)
207 {
208     if (LIKELY(sv != NULL))
209         SvREFCNT(sv)++;
210     return sv;
211 }
212 PERL_STATIC_INLINE SV *
213 Perl_SvREFCNT_inc_NN(SV *sv)
214 {
215     PERL_ARGS_ASSERT_SVREFCNT_INC_NN;
216
217     SvREFCNT(sv)++;
218     return sv;
219 }
220 PERL_STATIC_INLINE void
221 Perl_SvREFCNT_inc_void(SV *sv)
222 {
223     if (LIKELY(sv != NULL))
224         SvREFCNT(sv)++;
225 }
226 PERL_STATIC_INLINE void
227 Perl_SvREFCNT_dec(pTHX_ SV *sv)
228 {
229     if (LIKELY(sv != NULL)) {
230         U32 rc = SvREFCNT(sv);
231         if (LIKELY(rc > 1))
232             SvREFCNT(sv) = rc - 1;
233         else
234             Perl_sv_free2(aTHX_ sv, rc);
235     }
236 }
237
238 PERL_STATIC_INLINE void
239 Perl_SvREFCNT_dec_NN(pTHX_ SV *sv)
240 {
241     U32 rc = SvREFCNT(sv);
242
243     PERL_ARGS_ASSERT_SVREFCNT_DEC_NN;
244
245     if (LIKELY(rc > 1))
246         SvREFCNT(sv) = rc - 1;
247     else
248         Perl_sv_free2(aTHX_ sv, rc);
249 }
250
251 PERL_STATIC_INLINE void
252 Perl_SvAMAGIC_on(SV *sv)
253 {
254     PERL_ARGS_ASSERT_SVAMAGIC_ON;
255     assert(SvROK(sv));
256
257     if (SvOBJECT(SvRV(sv))) HvAMAGIC_on(SvSTASH(SvRV(sv)));
258 }
259 PERL_STATIC_INLINE void
260 Perl_SvAMAGIC_off(SV *sv)
261 {
262     PERL_ARGS_ASSERT_SVAMAGIC_OFF;
263
264     if (SvROK(sv) && SvOBJECT(SvRV(sv)))
265         HvAMAGIC_off(SvSTASH(SvRV(sv)));
266 }
267
268 PERL_STATIC_INLINE U32
269 Perl_SvPADSTALE_on(SV *sv)
270 {
271     assert(!(SvFLAGS(sv) & SVs_PADTMP));
272     return SvFLAGS(sv) |= SVs_PADSTALE;
273 }
274 PERL_STATIC_INLINE U32
275 Perl_SvPADSTALE_off(SV *sv)
276 {
277     assert(!(SvFLAGS(sv) & SVs_PADTMP));
278     return SvFLAGS(sv) &= ~SVs_PADSTALE;
279 }
280 #if defined(PERL_CORE) || defined (PERL_EXT)
281 PERL_STATIC_INLINE STRLEN
282 S_sv_or_pv_pos_u2b(pTHX_ SV *sv, const char *pv, STRLEN pos, STRLEN *lenp)
283 {
284     PERL_ARGS_ASSERT_SV_OR_PV_POS_U2B;
285     if (SvGAMAGIC(sv)) {
286         U8 *hopped = utf8_hop((U8 *)pv, pos);
287         if (lenp) *lenp = (STRLEN)(utf8_hop(hopped, *lenp) - hopped);
288         return (STRLEN)(hopped - (U8 *)pv);
289     }
290     return sv_pos_u2b_flags(sv,pos,lenp,SV_CONST_RETURN);
291 }
292 #endif
293
294 /* ------------------------------- handy.h ------------------------------- */
295
296 /* saves machine code for a common noreturn idiom typically used in Newx*() */
297 GCC_DIAG_IGNORE_DECL(-Wunused-function);
298 static void
299 Perl_croak_memory_wrap(void)
300 {
301     Perl_croak_nocontext("%s",PL_memory_wrap);
302 }
303 GCC_DIAG_RESTORE_DECL;
304
305 /* ------------------------------- utf8.h ------------------------------- */
306
307 /*
308 =head1 Unicode Support
309 */
310
311 PERL_STATIC_INLINE void
312 Perl_append_utf8_from_native_byte(const U8 byte, U8** dest)
313 {
314     /* Takes an input 'byte' (Latin1 or EBCDIC) and appends it to the UTF-8
315      * encoded string at '*dest', updating '*dest' to include it */
316
317     PERL_ARGS_ASSERT_APPEND_UTF8_FROM_NATIVE_BYTE;
318
319     if (NATIVE_BYTE_IS_INVARIANT(byte))
320         *((*dest)++) = byte;
321     else {
322         *((*dest)++) = UTF8_EIGHT_BIT_HI(byte);
323         *((*dest)++) = UTF8_EIGHT_BIT_LO(byte);
324     }
325 }
326
327 /*
328 =for apidoc valid_utf8_to_uvchr
329 Like C<L<perlapi/utf8_to_uvchr_buf>>, but should only be called when it is
330 known that the next character in the input UTF-8 string C<s> is well-formed
331 (I<e.g.>, it passes C<L<perlapi/isUTF8_CHAR>>.  Surrogates, non-character code
332 points, and non-Unicode code points are allowed.
333
334 =cut
335
336  */
337
338 PERL_STATIC_INLINE UV
339 Perl_valid_utf8_to_uvchr(const U8 *s, STRLEN *retlen)
340 {
341     const UV expectlen = UTF8SKIP(s);
342     const U8* send = s + expectlen;
343     UV uv = *s;
344
345     PERL_ARGS_ASSERT_VALID_UTF8_TO_UVCHR;
346
347     if (retlen) {
348         *retlen = expectlen;
349     }
350
351     /* An invariant is trivially returned */
352     if (expectlen == 1) {
353         return uv;
354     }
355
356     /* Remove the leading bits that indicate the number of bytes, leaving just
357      * the bits that are part of the value */
358     uv = NATIVE_UTF8_TO_I8(uv) & UTF_START_MASK(expectlen);
359
360     /* Now, loop through the remaining bytes, accumulating each into the
361      * working total as we go.  (I khw tried unrolling the loop for up to 4
362      * bytes, but there was no performance improvement) */
363     for (++s; s < send; s++) {
364         uv = UTF8_ACCUMULATE(uv, *s);
365     }
366
367     return UNI_TO_NATIVE(uv);
368
369 }
370
371 /*
372 =for apidoc is_utf8_invariant_string
373
374 Returns TRUE if the first C<len> bytes of the string C<s> are the same
375 regardless of the UTF-8 encoding of the string (or UTF-EBCDIC encoding on
376 EBCDIC machines); otherwise it returns FALSE.  That is, it returns TRUE if they
377 are UTF-8 invariant.  On ASCII-ish machines, all the ASCII characters and only
378 the ASCII characters fit this definition.  On EBCDIC machines, the ASCII-range
379 characters are invariant, but so also are the C1 controls.
380
381 If C<len> is 0, it will be calculated using C<strlen(s)>, (which means if you
382 use this option, that C<s> can't have embedded C<NUL> characters and has to
383 have a terminating C<NUL> byte).
384
385 See also
386 C<L</is_utf8_string>>,
387 C<L</is_utf8_string_flags>>,
388 C<L</is_utf8_string_loc>>,
389 C<L</is_utf8_string_loc_flags>>,
390 C<L</is_utf8_string_loclen>>,
391 C<L</is_utf8_string_loclen_flags>>,
392 C<L</is_utf8_fixed_width_buf_flags>>,
393 C<L</is_utf8_fixed_width_buf_loc_flags>>,
394 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
395 C<L</is_strict_utf8_string>>,
396 C<L</is_strict_utf8_string_loc>>,
397 C<L</is_strict_utf8_string_loclen>>,
398 C<L</is_c9strict_utf8_string>>,
399 C<L</is_c9strict_utf8_string_loc>>,
400 and
401 C<L</is_c9strict_utf8_string_loclen>>.
402
403 =cut
404
405 */
406
407 #define is_utf8_invariant_string(s, len)                                    \
408                                 is_utf8_invariant_string_loc(s, len, NULL)
409
410 /*
411 =for apidoc is_utf8_invariant_string_loc
412
413 Like C<L</is_utf8_invariant_string>> but upon failure, stores the location of
414 the first UTF-8 variant character in the C<ep> pointer; if all characters are
415 UTF-8 invariant, this function does not change the contents of C<*ep>.
416
417 =cut
418
419 */
420
421 PERL_STATIC_INLINE bool
422 Perl_is_utf8_invariant_string_loc(const U8* const s, STRLEN len, const U8 ** ep)
423 {
424     const U8* send;
425     const U8* x = s;
426
427     PERL_ARGS_ASSERT_IS_UTF8_INVARIANT_STRING_LOC;
428
429     if (len == 0) {
430         len = strlen((const char *)s);
431     }
432
433     send = s + len;
434
435 /* This looks like 0x010101... */
436 #  define PERL_COUNT_MULTIPLIER   (~ (UINTMAX_C(0)) / 0xFF)
437
438 /* This looks like 0x808080... */
439 #  define PERL_VARIANTS_WORD_MASK (PERL_COUNT_MULTIPLIER * 0x80)
440 #  define PERL_WORDSIZE            sizeof(PERL_UINTMAX_T)
441 #  define PERL_WORD_BOUNDARY_MASK (PERL_WORDSIZE - 1)
442
443 /* Evaluates to 0 if 'x' is at a word boundary; otherwise evaluates to 1, by
444  * or'ing together the lowest bits of 'x'.  Hopefully the final term gets
445  * optimized out completely on a 32-bit system, and its mask gets optimized out
446  * on a 64-bit system */
447 #  define PERL_IS_SUBWORD_ADDR(x) (1 & (       PTR2nat(x)                     \
448                                       |   (  PTR2nat(x) >> 1)                 \
449                                       | ( ( (PTR2nat(x)                       \
450                                            & PERL_WORD_BOUNDARY_MASK) >> 2))))
451
452 #ifndef EBCDIC
453
454     /* Do the word-at-a-time iff there is at least one usable full word.  That
455      * means that after advancing to a word boundary, there still is at least a
456      * full word left.  The number of bytes needed to advance is 'wordsize -
457      * offset' unless offset is 0. */
458     if ((STRLEN) (send - x) >= PERL_WORDSIZE
459
460                             /* This term is wordsize if subword; 0 if not */
461                           + PERL_WORDSIZE * PERL_IS_SUBWORD_ADDR(x)
462
463                             /* 'offset' */
464                           - (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK))
465     {
466
467         /* Process per-byte until reach word boundary.  XXX This loop could be
468          * eliminated if we knew that this platform had fast unaligned reads */
469         while (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK) {
470             if (! UTF8_IS_INVARIANT(*x)) {
471                 if (ep) {
472                     *ep = x;
473                 }
474
475                 return FALSE;
476             }
477             x++;
478         }
479
480         /* Here, we know we have at least one full word to process.  Process
481          * per-word as long as we have at least a full word left */
482         do {
483             if ((* (PERL_UINTMAX_T *) x) & PERL_VARIANTS_WORD_MASK)  {
484
485                 /* Found a variant.  Just return if caller doesn't want its
486                  * exact position */
487                 if (! ep) {
488                     return FALSE;
489                 }
490
491 #  if   BYTEORDER == 0x1234 || BYTEORDER == 0x12345678    \
492      || BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
493
494                 *ep = x + variant_byte_number(* (PERL_UINTMAX_T *) x);
495                 assert(*ep >= s && *ep < send);
496
497                 return FALSE;
498
499 #  else   /* If weird byte order, drop into next loop to do byte-at-a-time
500            checks. */
501
502                 break;
503 #  endif
504             }
505
506             x += PERL_WORDSIZE;
507
508         } while (x + PERL_WORDSIZE <= send);
509     }
510
511 #endif      /* End of ! EBCDIC */
512
513     /* Process per-byte */
514     while (x < send) {
515         if (! UTF8_IS_INVARIANT(*x)) {
516             if (ep) {
517                 *ep = x;
518             }
519
520             return FALSE;
521         }
522
523         x++;
524     }
525
526     return TRUE;
527 }
528
529 #ifndef EBCDIC
530
531 PERL_STATIC_INLINE unsigned int
532 Perl_variant_byte_number(PERL_UINTMAX_T word)
533 {
534
535     /* This returns the position in a word (0..7) of the first variant byte in
536      * it.  This is a helper function.  Note that there are no branches */
537
538     assert(word);
539
540     /* Get just the msb bits of each byte */
541     word &= PERL_VARIANTS_WORD_MASK;
542
543 #  if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
544
545     /* Bytes are stored like
546      *  Byte8 ... Byte2 Byte1
547      *  63..56...15...8 7...0
548      *
549      *  Isolate the lsb;
550      * https://stackoverflow.com/questions/757059/position-of-least-significant-bit-that-is-set
551      *
552      * The word will look this this, with a rightmost set bit in position 's':
553      * ('x's are don't cares)
554      *      s
555      *  x..x100..0
556      *  x..xx10..0      Right shift (rightmost 0 is shifted off)
557      *  x..xx01..1      Subtract 1, turns all the trailing zeros into 1's and
558      *                  the 1 just to their left into a 0; the remainder is
559      *                  untouched
560      *  0..0011..1      The xor with the original, x..xx10..0, clears that
561      *                  remainder, sets the bottom to all 1
562      *  0..0100..0      Add 1 to clear the word except for the bit in 's'
563      *
564      * Another method is to do 'word &= -word'; but it generates a compiler
565      * message on some platforms about taking the negative of an unsigned */
566
567     word >>= 1;
568     word = 1 + (word ^ (word - 1));
569
570 #  elif BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
571
572     /* Bytes are stored like
573      *  Byte1 Byte2  ... Byte8
574      * 63..56 55..47 ... 7...0
575      *
576      * Isolate the msb; http://codeforces.com/blog/entry/10330
577      *
578      * Only the most significant set bit matters.  Or'ing word with its right
579      * shift of 1 makes that bit and the next one to its right both 1.  Then
580      * right shifting by 2 makes for 4 1-bits in a row. ...  We end with the
581      * msb and all to the right being 1. */
582     word |= word >>  1;
583     word |= word >>  2;
584     word |= word >>  4;
585     word |= word >>  8;
586     word |= word >> 16;
587     word |= word >> 32;  /* This should get optimized out on 32-bit systems. */
588
589     /* Then subtracting the right shift by 1 clears all but the left-most of
590      * the 1 bits, which is our desired result */
591     word -= (word >> 1);
592
593 #  else
594 #    error Unexpected byte order
595 #  endif
596
597     /* Here 'word' has a single bit set: the  msb of the first byte in which it
598      * is set.  Calculate that position in the word.  We can use this
599      * specialized solution: https://stackoverflow.com/a/32339674/1626653,
600      * assumes an 8-bit byte.  (On a 32-bit machine, the larger numbers should
601      * just get shifted off at compile time) */
602     word = (word >> 7) * ((UINTMAX_C( 7) << 56) | (UINTMAX_C(15) << 48)
603                         | (UINTMAX_C(23) << 40) | (UINTMAX_C(31) << 32)
604                         |           (39 <<  24) |           (47 <<  16)
605                         |           (55 <<   8) |           (63 <<   0));
606     word >>= PERL_WORDSIZE * 7; /* >> by either 56 or 24 */
607
608     /* Here, word contains the position 7..63 of that bit.  Convert to 0..7 */
609     word = ((word + 1) >> 3) - 1;
610
611 #  if BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
612
613     /* And invert the result */
614     word = CHARBITS - word - 1;
615
616 #  endif
617
618     return (unsigned int) word;
619 }
620
621 #endif
622 #if defined(PERL_CORE) || defined(PERL_EXT)
623
624 /*
625 =for apidoc variant_under_utf8_count
626
627 This function looks at the sequence of bytes between C<s> and C<e>, which are
628 assumed to be encoded in ASCII/Latin1, and returns how many of them would
629 change should the string be translated into UTF-8.  Due to the nature of UTF-8,
630 each of these would occupy two bytes instead of the single one in the input
631 string.  Thus, this function returns the precise number of bytes the string
632 would expand by when translated to UTF-8.
633
634 Unlike most of the other functions that have C<utf8> in their name, the input
635 to this function is NOT a UTF-8-encoded string.  The function name is slightly
636 I<odd> to emphasize this.
637
638 This function is internal to Perl because khw thinks that any XS code that
639 would want this is probably operating too close to the internals.  Presenting a
640 valid use case could change that.
641
642 See also
643 C<L<perlapi/is_utf8_invariant_string>>
644 and
645 C<L<perlapi/is_utf8_invariant_string_loc>>,
646
647 =cut
648
649 */
650
651 PERL_STATIC_INLINE Size_t
652 S_variant_under_utf8_count(const U8* const s, const U8* const e)
653 {
654     const U8* x = s;
655     Size_t count = 0;
656
657     PERL_ARGS_ASSERT_VARIANT_UNDER_UTF8_COUNT;
658
659 #  ifndef EBCDIC
660
661     /* Test if the string is long enough to use word-at-a-time.  (Logic is the
662      * same as for is_utf8_invariant_string()) */
663     if ((STRLEN) (e - x) >= PERL_WORDSIZE
664                           + PERL_WORDSIZE * PERL_IS_SUBWORD_ADDR(x)
665                           - (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK))
666     {
667
668         /* Process per-byte until reach word boundary.  XXX This loop could be
669          * eliminated if we knew that this platform had fast unaligned reads */
670         while (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK) {
671             count += ! UTF8_IS_INVARIANT(*x++);
672         }
673
674         /* Process per-word as long as we have at least a full word left */
675         do {    /* Commit 03c1e4ab1d6ee9062fb3f94b0ba31db6698724b1 contains an
676                    explanation of how this works */
677             PERL_UINTMAX_T increment
678                 = ((((* (PERL_UINTMAX_T *) x) & PERL_VARIANTS_WORD_MASK) >> 7)
679                       * PERL_COUNT_MULTIPLIER)
680                     >> ((PERL_WORDSIZE - 1) * CHARBITS);
681             count += (Size_t) increment;
682             x += PERL_WORDSIZE;
683         } while (x + PERL_WORDSIZE <= e);
684     }
685
686 #  endif
687
688     /* Process per-byte */
689     while (x < e) {
690         if (! UTF8_IS_INVARIANT(*x)) {
691             count++;
692         }
693
694         x++;
695     }
696
697     return count;
698 }
699
700 #endif
701
702 #ifndef PERL_IN_REGEXEC_C   /* Keep  these around for that file */
703 #  undef PERL_WORDSIZE
704 #  undef PERL_COUNT_MULTIPLIER
705 #  undef PERL_WORD_BOUNDARY_MASK
706 #  undef PERL_VARIANTS_WORD_MASK
707 #endif
708
709 /*
710 =for apidoc is_utf8_string
711
712 Returns TRUE if the first C<len> bytes of string C<s> form a valid
713 Perl-extended-UTF-8 string; returns FALSE otherwise.  If C<len> is 0, it will
714 be calculated using C<strlen(s)> (which means if you use this option, that C<s>
715 can't have embedded C<NUL> characters and has to have a terminating C<NUL>
716 byte).  Note that all characters being ASCII constitute 'a valid UTF-8 string'.
717
718 This function considers Perl's extended UTF-8 to be valid.  That means that
719 code points above Unicode, surrogates, and non-character code points are
720 considered valid by this function.  Use C<L</is_strict_utf8_string>>,
721 C<L</is_c9strict_utf8_string>>, or C<L</is_utf8_string_flags>> to restrict what
722 code points are considered valid.
723
724 See also
725 C<L</is_utf8_invariant_string>>,
726 C<L</is_utf8_invariant_string_loc>>,
727 C<L</is_utf8_string_loc>>,
728 C<L</is_utf8_string_loclen>>,
729 C<L</is_utf8_fixed_width_buf_flags>>,
730 C<L</is_utf8_fixed_width_buf_loc_flags>>,
731 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
732
733 =cut
734 */
735
736 #define is_utf8_string(s, len)  is_utf8_string_loclen(s, len, NULL, NULL)
737
738 #if defined(PERL_CORE) || defined (PERL_EXT)
739
740 /*
741 =for apidoc is_utf8_non_invariant_string
742
743 Returns TRUE if L<perlapi/is_utf8_invariant_string> returns FALSE for the first
744 C<len> bytes of the string C<s>, but they are, nonetheless, legal Perl-extended
745 UTF-8; otherwise returns FALSE.
746
747 A TRUE return means that at least one code point represented by the sequence
748 either is a wide character not representable as a single byte, or the
749 representation differs depending on whether the sequence is encoded in UTF-8 or
750 not.
751
752 See also
753 C<L<perlapi/is_utf8_invariant_string>>,
754 C<L<perlapi/is_utf8_string>>
755
756 =cut
757
758 This is commonly used to determine if a SV's UTF-8 flag should be turned on.
759 It generally needn't be if its string is entirely UTF-8 invariant, and it
760 shouldn't be if it otherwise contains invalid UTF-8.
761
762 It is an internal function because khw thinks that XS code shouldn't be working
763 at this low a level.  A valid use case could change that.
764
765 */
766
767 PERL_STATIC_INLINE bool
768 Perl_is_utf8_non_invariant_string(const U8* const s, STRLEN len)
769 {
770     const U8 * first_variant;
771
772     PERL_ARGS_ASSERT_IS_UTF8_NON_INVARIANT_STRING;
773
774     if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
775         return FALSE;
776     }
777
778     return is_utf8_string(first_variant, len - (first_variant - s));
779 }
780
781 #endif
782
783 /*
784 =for apidoc is_strict_utf8_string
785
786 Returns TRUE if the first C<len> bytes of string C<s> form a valid
787 UTF-8-encoded string that is fully interchangeable by any application using
788 Unicode rules; otherwise it returns FALSE.  If C<len> is 0, it will be
789 calculated using C<strlen(s)> (which means if you use this option, that C<s>
790 can't have embedded C<NUL> characters and has to have a terminating C<NUL>
791 byte).  Note that all characters being ASCII constitute 'a valid UTF-8 string'.
792
793 This function returns FALSE for strings containing any
794 code points above the Unicode max of 0x10FFFF, surrogate code points, or
795 non-character code points.
796
797 See also
798 C<L</is_utf8_invariant_string>>,
799 C<L</is_utf8_invariant_string_loc>>,
800 C<L</is_utf8_string>>,
801 C<L</is_utf8_string_flags>>,
802 C<L</is_utf8_string_loc>>,
803 C<L</is_utf8_string_loc_flags>>,
804 C<L</is_utf8_string_loclen>>,
805 C<L</is_utf8_string_loclen_flags>>,
806 C<L</is_utf8_fixed_width_buf_flags>>,
807 C<L</is_utf8_fixed_width_buf_loc_flags>>,
808 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
809 C<L</is_strict_utf8_string_loc>>,
810 C<L</is_strict_utf8_string_loclen>>,
811 C<L</is_c9strict_utf8_string>>,
812 C<L</is_c9strict_utf8_string_loc>>,
813 and
814 C<L</is_c9strict_utf8_string_loclen>>.
815
816 =cut
817 */
818
819 #define is_strict_utf8_string(s, len)  is_strict_utf8_string_loclen(s, len, NULL, NULL)
820
821 /*
822 =for apidoc is_c9strict_utf8_string
823
824 Returns TRUE if the first C<len> bytes of string C<s> form a valid
825 UTF-8-encoded string that conforms to
826 L<Unicode Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>;
827 otherwise it returns FALSE.  If C<len> is 0, it will be calculated using
828 C<strlen(s)> (which means if you use this option, that C<s> can't have embedded
829 C<NUL> characters and has to have a terminating C<NUL> byte).  Note that all
830 characters being ASCII constitute 'a valid UTF-8 string'.
831
832 This function returns FALSE for strings containing any code points above the
833 Unicode max of 0x10FFFF or surrogate code points, but accepts non-character
834 code points per
835 L<Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>.
836
837 See also
838 C<L</is_utf8_invariant_string>>,
839 C<L</is_utf8_invariant_string_loc>>,
840 C<L</is_utf8_string>>,
841 C<L</is_utf8_string_flags>>,
842 C<L</is_utf8_string_loc>>,
843 C<L</is_utf8_string_loc_flags>>,
844 C<L</is_utf8_string_loclen>>,
845 C<L</is_utf8_string_loclen_flags>>,
846 C<L</is_utf8_fixed_width_buf_flags>>,
847 C<L</is_utf8_fixed_width_buf_loc_flags>>,
848 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
849 C<L</is_strict_utf8_string>>,
850 C<L</is_strict_utf8_string_loc>>,
851 C<L</is_strict_utf8_string_loclen>>,
852 C<L</is_c9strict_utf8_string_loc>>,
853 and
854 C<L</is_c9strict_utf8_string_loclen>>.
855
856 =cut
857 */
858
859 #define is_c9strict_utf8_string(s, len)  is_c9strict_utf8_string_loclen(s, len, NULL, 0)
860
861 /*
862 =for apidoc is_utf8_string_flags
863
864 Returns TRUE if the first C<len> bytes of string C<s> form a valid
865 UTF-8 string, subject to the restrictions imposed by C<flags>;
866 returns FALSE otherwise.  If C<len> is 0, it will be calculated
867 using C<strlen(s)> (which means if you use this option, that C<s> can't have
868 embedded C<NUL> characters and has to have a terminating C<NUL> byte).  Note
869 that all characters being ASCII constitute 'a valid UTF-8 string'.
870
871 If C<flags> is 0, this gives the same results as C<L</is_utf8_string>>; if
872 C<flags> is C<UTF8_DISALLOW_ILLEGAL_INTERCHANGE>, this gives the same results
873 as C<L</is_strict_utf8_string>>; and if C<flags> is
874 C<UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE>, this gives the same results as
875 C<L</is_c9strict_utf8_string>>.  Otherwise C<flags> may be any
876 combination of the C<UTF8_DISALLOW_I<foo>> flags understood by
877 C<L</utf8n_to_uvchr>>, with the same meanings.
878
879 See also
880 C<L</is_utf8_invariant_string>>,
881 C<L</is_utf8_invariant_string_loc>>,
882 C<L</is_utf8_string>>,
883 C<L</is_utf8_string_loc>>,
884 C<L</is_utf8_string_loc_flags>>,
885 C<L</is_utf8_string_loclen>>,
886 C<L</is_utf8_string_loclen_flags>>,
887 C<L</is_utf8_fixed_width_buf_flags>>,
888 C<L</is_utf8_fixed_width_buf_loc_flags>>,
889 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
890 C<L</is_strict_utf8_string>>,
891 C<L</is_strict_utf8_string_loc>>,
892 C<L</is_strict_utf8_string_loclen>>,
893 C<L</is_c9strict_utf8_string>>,
894 C<L</is_c9strict_utf8_string_loc>>,
895 and
896 C<L</is_c9strict_utf8_string_loclen>>.
897
898 =cut
899 */
900
901 PERL_STATIC_INLINE bool
902 Perl_is_utf8_string_flags(const U8 *s, STRLEN len, const U32 flags)
903 {
904     const U8 * first_variant;
905
906     PERL_ARGS_ASSERT_IS_UTF8_STRING_FLAGS;
907     assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
908                           |UTF8_DISALLOW_PERL_EXTENDED)));
909
910     if (len == 0) {
911         len = strlen((const char *)s);
912     }
913
914     if (flags == 0) {
915         return is_utf8_string(s, len);
916     }
917
918     if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
919                                         == UTF8_DISALLOW_ILLEGAL_INTERCHANGE)
920     {
921         return is_strict_utf8_string(s, len);
922     }
923
924     if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
925                                        == UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE)
926     {
927         return is_c9strict_utf8_string(s, len);
928     }
929
930     if (! is_utf8_invariant_string_loc(s, len, &first_variant)) {
931         const U8* const send = s + len;
932         const U8* x = first_variant;
933
934         while (x < send) {
935             STRLEN cur_len = isUTF8_CHAR_flags(x, send, flags);
936             if (UNLIKELY(! cur_len)) {
937                 return FALSE;
938             }
939             x += cur_len;
940         }
941     }
942
943     return TRUE;
944 }
945
946 /*
947
948 =for apidoc is_utf8_string_loc
949
950 Like C<L</is_utf8_string>> but stores the location of the failure (in the
951 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
952 "utf8ness success") in the C<ep> pointer.
953
954 See also C<L</is_utf8_string_loclen>>.
955
956 =cut
957 */
958
959 #define is_utf8_string_loc(s, len, ep)  is_utf8_string_loclen(s, len, ep, 0)
960
961 /*
962
963 =for apidoc is_utf8_string_loclen
964
965 Like C<L</is_utf8_string>> but stores the location of the failure (in the
966 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
967 "utf8ness success") in the C<ep> pointer, and the number of UTF-8
968 encoded characters in the C<el> pointer.
969
970 See also C<L</is_utf8_string_loc>>.
971
972 =cut
973 */
974
975 PERL_STATIC_INLINE bool
976 Perl_is_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
977 {
978     const U8 * first_variant;
979
980     PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN;
981
982     if (len == 0) {
983         len = strlen((const char *) s);
984     }
985
986     if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
987         if (el)
988             *el = len;
989
990         if (ep) {
991             *ep = s + len;
992         }
993
994         return TRUE;
995     }
996
997     {
998         const U8* const send = s + len;
999         const U8* x = first_variant;
1000         STRLEN outlen = first_variant - s;
1001
1002         while (x < send) {
1003             const STRLEN cur_len = isUTF8_CHAR(x, send);
1004             if (UNLIKELY(! cur_len)) {
1005                 break;
1006             }
1007             x += cur_len;
1008             outlen++;
1009         }
1010
1011         if (el)
1012             *el = outlen;
1013
1014         if (ep) {
1015             *ep = x;
1016         }
1017
1018         return (x == send);
1019     }
1020 }
1021
1022 /*
1023
1024 =for apidoc isUTF8_CHAR
1025
1026 Evaluates to non-zero if the first few bytes of the string starting at C<s> and
1027 looking no further than S<C<e - 1>> are well-formed UTF-8, as extended by Perl,
1028 that represents some code point; otherwise it evaluates to 0.  If non-zero, the
1029 value gives how many bytes starting at C<s> comprise the code point's
1030 representation.  Any bytes remaining before C<e>, but beyond the ones needed to
1031 form the first code point in C<s>, are not examined.
1032
1033 The code point can be any that will fit in an IV on this machine, using Perl's
1034 extension to official UTF-8 to represent those higher than the Unicode maximum
1035 of 0x10FFFF.  That means that this macro is used to efficiently decide if the
1036 next few bytes in C<s> is legal UTF-8 for a single character.
1037
1038 Use C<L</isSTRICT_UTF8_CHAR>> to restrict the acceptable code points to those
1039 defined by Unicode to be fully interchangeable across applications;
1040 C<L</isC9_STRICT_UTF8_CHAR>> to use the L<Unicode Corrigendum
1041 #9|http://www.unicode.org/versions/corrigendum9.html> definition of allowable
1042 code points; and C<L</isUTF8_CHAR_flags>> for a more customized definition.
1043
1044 Use C<L</is_utf8_string>>, C<L</is_utf8_string_loc>>, and
1045 C<L</is_utf8_string_loclen>> to check entire strings.
1046
1047 Note also that a UTF-8 "invariant" character (i.e. ASCII on non-EBCDIC
1048 machines) is a valid UTF-8 character.
1049
1050 =cut
1051
1052 This uses an adaptation of the table and algorithm given in
1053 https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
1054 documentation of the original version.  A copyright notice for the original
1055 version is given at the beginning of this file.  The Perl adapation is
1056 documented at the definition of PL_extended_utf8_dfa_tab[].
1057
1058 */
1059
1060 PERL_STATIC_INLINE Size_t
1061 Perl_isUTF8_CHAR(const U8 * const s0, const U8 * const e)
1062 {
1063     const U8 * s = s0;
1064     UV state = 0;
1065
1066     PERL_ARGS_ASSERT_ISUTF8_CHAR;
1067
1068     /* This dfa is fast.  If it accepts the input, it was for a well-formed,
1069      * code point, which can be returned immediately.  Otherwise, it is either
1070      * malformed, or for the start byte FF which the dfa doesn't handle (except
1071      * on 32-bit ASCII platforms where it trivially is an error).  Call a
1072      * helper function for the other platforms. */
1073
1074     while (s < e && LIKELY(state != 1)) {
1075         state = PL_extended_utf8_dfa_tab[256
1076                                          + state
1077                                          + PL_extended_utf8_dfa_tab[*s]];
1078         if (state != 0) {
1079             s++;
1080             continue;
1081         }
1082
1083         return s - s0 + 1;
1084     }
1085
1086 #if defined(UV_IS_QUAD) || defined(EBCDIC)
1087
1088     if (NATIVE_UTF8_TO_I8(*s0) == 0xFF && e - s0 >= UTF8_MAXBYTES) {
1089        return is_utf8_char_helper(s0, e, 0);
1090     }
1091
1092 #endif
1093
1094     return 0;
1095 }
1096
1097 /*
1098
1099 =for apidoc isSTRICT_UTF8_CHAR
1100
1101 Evaluates to non-zero if the first few bytes of the string starting at C<s> and
1102 looking no further than S<C<e - 1>> are well-formed UTF-8 that represents some
1103 Unicode code point completely acceptable for open interchange between all
1104 applications; otherwise it evaluates to 0.  If non-zero, the value gives how
1105 many bytes starting at C<s> comprise the code point's representation.  Any
1106 bytes remaining before C<e>, but beyond the ones needed to form the first code
1107 point in C<s>, are not examined.
1108
1109 The largest acceptable code point is the Unicode maximum 0x10FFFF, and must not
1110 be a surrogate nor a non-character code point.  Thus this excludes any code
1111 point from Perl's extended UTF-8.
1112
1113 This is used to efficiently decide if the next few bytes in C<s> is
1114 legal Unicode-acceptable UTF-8 for a single character.
1115
1116 Use C<L</isC9_STRICT_UTF8_CHAR>> to use the L<Unicode Corrigendum
1117 #9|http://www.unicode.org/versions/corrigendum9.html> definition of allowable
1118 code points; C<L</isUTF8_CHAR>> to check for Perl's extended UTF-8;
1119 and C<L</isUTF8_CHAR_flags>> for a more customized definition.
1120
1121 Use C<L</is_strict_utf8_string>>, C<L</is_strict_utf8_string_loc>>, and
1122 C<L</is_strict_utf8_string_loclen>> to check entire strings.
1123
1124 =cut
1125
1126 This uses an adaptation of the tables and algorithm given in
1127 https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
1128 documentation of the original version.  A copyright notice for the original
1129 version is given at the beginning of this file.  The Perl adapation is
1130 documented at the definition of strict_extended_utf8_dfa_tab[].
1131
1132 */
1133
1134 PERL_STATIC_INLINE Size_t
1135 Perl_isSTRICT_UTF8_CHAR(const U8 * const s0, const U8 * const e)
1136 {
1137     const U8 * s = s0;
1138     UV state = 0;
1139
1140     PERL_ARGS_ASSERT_ISSTRICT_UTF8_CHAR;
1141
1142     while (s < e && LIKELY(state != 1)) {
1143         state = PL_strict_utf8_dfa_tab[256 + state + PL_strict_utf8_dfa_tab[*s]];
1144
1145         if (state != 0) {
1146             s++;
1147             continue;
1148         }
1149
1150         return s - s0 + 1;
1151     }
1152
1153 #ifndef EBCDIC
1154
1155     /* The dfa above drops out for certain Hanguls; handle them specially */
1156     if (is_HANGUL_ED_utf8_safe(s0, e)) {
1157         return 3;
1158     }
1159
1160 #endif
1161
1162     return 0;
1163 }
1164
1165 /*
1166
1167 =for apidoc isC9_STRICT_UTF8_CHAR
1168
1169 Evaluates to non-zero if the first few bytes of the string starting at C<s> and
1170 looking no further than S<C<e - 1>> are well-formed UTF-8 that represents some
1171 Unicode non-surrogate code point; otherwise it evaluates to 0.  If non-zero,
1172 the value gives how many bytes starting at C<s> comprise the code point's
1173 representation.  Any bytes remaining before C<e>, but beyond the ones needed to
1174 form the first code point in C<s>, are not examined.
1175
1176 The largest acceptable code point is the Unicode maximum 0x10FFFF.  This
1177 differs from C<L</isSTRICT_UTF8_CHAR>> only in that it accepts non-character
1178 code points.  This corresponds to
1179 L<Unicode Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>.
1180 which said that non-character code points are merely discouraged rather than
1181 completely forbidden in open interchange.  See
1182 L<perlunicode/Noncharacter code points>.
1183
1184 Use C<L</isUTF8_CHAR>> to check for Perl's extended UTF-8; and
1185 C<L</isUTF8_CHAR_flags>> for a more customized definition.
1186
1187 Use C<L</is_c9strict_utf8_string>>, C<L</is_c9strict_utf8_string_loc>>, and
1188 C<L</is_c9strict_utf8_string_loclen>> to check entire strings.
1189
1190 =cut
1191
1192 This uses an adaptation of the tables and algorithm given in
1193 https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
1194 documentation of the original version.  A copyright notice for the original
1195 version is given at the beginning of this file.  The Perl adapation is
1196 documented at the definition of PL_c9_utf8_dfa_tab[].
1197
1198 */
1199
1200 PERL_STATIC_INLINE Size_t
1201 Perl_isC9_STRICT_UTF8_CHAR(const U8 * const s0, const U8 * const e)
1202 {
1203     const U8 * s = s0;
1204     UV state = 0;
1205
1206     PERL_ARGS_ASSERT_ISC9_STRICT_UTF8_CHAR;
1207
1208     while (s < e && LIKELY(state != 1)) {
1209         state = PL_c9_utf8_dfa_tab[256 + state + PL_c9_utf8_dfa_tab[*s]];
1210
1211         if (state != 0) {
1212             s++;
1213             continue;
1214         }
1215
1216         return s - s0 + 1;
1217     }
1218
1219     return 0;
1220 }
1221
1222 /*
1223
1224 =for apidoc is_strict_utf8_string_loc
1225
1226 Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
1227 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1228 "utf8ness success") in the C<ep> pointer.
1229
1230 See also C<L</is_strict_utf8_string_loclen>>.
1231
1232 =cut
1233 */
1234
1235 #define is_strict_utf8_string_loc(s, len, ep)                               \
1236                                 is_strict_utf8_string_loclen(s, len, ep, 0)
1237
1238 /*
1239
1240 =for apidoc is_strict_utf8_string_loclen
1241
1242 Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
1243 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1244 "utf8ness success") in the C<ep> pointer, and the number of UTF-8
1245 encoded characters in the C<el> pointer.
1246
1247 See also C<L</is_strict_utf8_string_loc>>.
1248
1249 =cut
1250 */
1251
1252 PERL_STATIC_INLINE bool
1253 Perl_is_strict_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
1254 {
1255     const U8 * first_variant;
1256
1257     PERL_ARGS_ASSERT_IS_STRICT_UTF8_STRING_LOCLEN;
1258
1259     if (len == 0) {
1260         len = strlen((const char *) s);
1261     }
1262
1263     if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
1264         if (el)
1265             *el = len;
1266
1267         if (ep) {
1268             *ep = s + len;
1269         }
1270
1271         return TRUE;
1272     }
1273
1274     {
1275         const U8* const send = s + len;
1276         const U8* x = first_variant;
1277         STRLEN outlen = first_variant - s;
1278
1279         while (x < send) {
1280             const STRLEN cur_len = isSTRICT_UTF8_CHAR(x, send);
1281             if (UNLIKELY(! cur_len)) {
1282                 break;
1283             }
1284             x += cur_len;
1285             outlen++;
1286         }
1287
1288         if (el)
1289             *el = outlen;
1290
1291         if (ep) {
1292             *ep = x;
1293         }
1294
1295         return (x == send);
1296     }
1297 }
1298
1299 /*
1300
1301 =for apidoc is_c9strict_utf8_string_loc
1302
1303 Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in
1304 the case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1305 "utf8ness success") in the C<ep> pointer.
1306
1307 See also C<L</is_c9strict_utf8_string_loclen>>.
1308
1309 =cut
1310 */
1311
1312 #define is_c9strict_utf8_string_loc(s, len, ep)                             \
1313                             is_c9strict_utf8_string_loclen(s, len, ep, 0)
1314
1315 /*
1316
1317 =for apidoc is_c9strict_utf8_string_loclen
1318
1319 Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in
1320 the case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1321 "utf8ness success") in the C<ep> pointer, and the number of UTF-8 encoded
1322 characters in the C<el> pointer.
1323
1324 See also C<L</is_c9strict_utf8_string_loc>>.
1325
1326 =cut
1327 */
1328
1329 PERL_STATIC_INLINE bool
1330 Perl_is_c9strict_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
1331 {
1332     const U8 * first_variant;
1333
1334     PERL_ARGS_ASSERT_IS_C9STRICT_UTF8_STRING_LOCLEN;
1335
1336     if (len == 0) {
1337         len = strlen((const char *) s);
1338     }
1339
1340     if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
1341         if (el)
1342             *el = len;
1343
1344         if (ep) {
1345             *ep = s + len;
1346         }
1347
1348         return TRUE;
1349     }
1350
1351     {
1352         const U8* const send = s + len;
1353         const U8* x = first_variant;
1354         STRLEN outlen = first_variant - s;
1355
1356         while (x < send) {
1357             const STRLEN cur_len = isC9_STRICT_UTF8_CHAR(x, send);
1358             if (UNLIKELY(! cur_len)) {
1359                 break;
1360             }
1361             x += cur_len;
1362             outlen++;
1363         }
1364
1365         if (el)
1366             *el = outlen;
1367
1368         if (ep) {
1369             *ep = x;
1370         }
1371
1372         return (x == send);
1373     }
1374 }
1375
1376 /*
1377
1378 =for apidoc is_utf8_string_loc_flags
1379
1380 Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the
1381 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1382 "utf8ness success") in the C<ep> pointer.
1383
1384 See also C<L</is_utf8_string_loclen_flags>>.
1385
1386 =cut
1387 */
1388
1389 #define is_utf8_string_loc_flags(s, len, ep, flags)                         \
1390                         is_utf8_string_loclen_flags(s, len, ep, 0, flags)
1391
1392
1393 /* The above 3 actual functions could have been moved into the more general one
1394  * just below, and made #defines that call it with the right 'flags'.  They are
1395  * currently kept separate to increase their chances of getting inlined */
1396
1397 /*
1398
1399 =for apidoc is_utf8_string_loclen_flags
1400
1401 Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the
1402 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1403 "utf8ness success") in the C<ep> pointer, and the number of UTF-8
1404 encoded characters in the C<el> pointer.
1405
1406 See also C<L</is_utf8_string_loc_flags>>.
1407
1408 =cut
1409 */
1410
1411 PERL_STATIC_INLINE bool
1412 Perl_is_utf8_string_loclen_flags(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el, const U32 flags)
1413 {
1414     const U8 * first_variant;
1415
1416     PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN_FLAGS;
1417     assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
1418                           |UTF8_DISALLOW_PERL_EXTENDED)));
1419
1420     if (len == 0) {
1421         len = strlen((const char *) s);
1422     }
1423
1424     if (flags == 0) {
1425         return is_utf8_string_loclen(s, len, ep, el);
1426     }
1427
1428     if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
1429                                         == UTF8_DISALLOW_ILLEGAL_INTERCHANGE)
1430     {
1431         return is_strict_utf8_string_loclen(s, len, ep, el);
1432     }
1433
1434     if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
1435                                     == UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE)
1436     {
1437         return is_c9strict_utf8_string_loclen(s, len, ep, el);
1438     }
1439
1440     if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
1441         if (el)
1442             *el = len;
1443
1444         if (ep) {
1445             *ep = s + len;
1446         }
1447
1448         return TRUE;
1449     }
1450
1451     {
1452         const U8* send = s + len;
1453         const U8* x = first_variant;
1454         STRLEN outlen = first_variant - s;
1455
1456         while (x < send) {
1457             const STRLEN cur_len = isUTF8_CHAR_flags(x, send, flags);
1458             if (UNLIKELY(! cur_len)) {
1459                 break;
1460             }
1461             x += cur_len;
1462             outlen++;
1463         }
1464
1465         if (el)
1466             *el = outlen;
1467
1468         if (ep) {
1469             *ep = x;
1470         }
1471
1472         return (x == send);
1473     }
1474 }
1475
1476 /*
1477 =for apidoc utf8_distance
1478
1479 Returns the number of UTF-8 characters between the UTF-8 pointers C<a>
1480 and C<b>.
1481
1482 WARNING: use only if you *know* that the pointers point inside the
1483 same UTF-8 buffer.
1484
1485 =cut
1486 */
1487
1488 PERL_STATIC_INLINE IV
1489 Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b)
1490 {
1491     PERL_ARGS_ASSERT_UTF8_DISTANCE;
1492
1493     return (a < b) ? -1 * (IV) utf8_length(a, b) : (IV) utf8_length(b, a);
1494 }
1495
1496 /*
1497 =for apidoc utf8_hop
1498
1499 Return the UTF-8 pointer C<s> displaced by C<off> characters, either
1500 forward or backward.
1501
1502 WARNING: do not use the following unless you *know* C<off> is within
1503 the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
1504 on the first byte of character or just after the last byte of a character.
1505
1506 =cut
1507 */
1508
1509 PERL_STATIC_INLINE U8 *
1510 Perl_utf8_hop(const U8 *s, SSize_t off)
1511 {
1512     PERL_ARGS_ASSERT_UTF8_HOP;
1513
1514     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1515      * the bitops (especially ~) can create illegal UTF-8.
1516      * In other words: in Perl UTF-8 is not just for Unicode. */
1517
1518     if (off >= 0) {
1519         while (off--)
1520             s += UTF8SKIP(s);
1521     }
1522     else {
1523         while (off++) {
1524             s--;
1525             while (UTF8_IS_CONTINUATION(*s))
1526                 s--;
1527         }
1528     }
1529     GCC_DIAG_IGNORE(-Wcast-qual)
1530     return (U8 *)s;
1531     GCC_DIAG_RESTORE
1532 }
1533
1534 /*
1535 =for apidoc utf8_hop_forward
1536
1537 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1538 forward.
1539
1540 C<off> must be non-negative.
1541
1542 C<s> must be before or equal to C<end>.
1543
1544 When moving forward it will not move beyond C<end>.
1545
1546 Will not exceed this limit even if the string is not valid "UTF-8".
1547
1548 =cut
1549 */
1550
1551 PERL_STATIC_INLINE U8 *
1552 Perl_utf8_hop_forward(const U8 *s, SSize_t off, const U8 *end)
1553 {
1554     PERL_ARGS_ASSERT_UTF8_HOP_FORWARD;
1555
1556     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1557      * the bitops (especially ~) can create illegal UTF-8.
1558      * In other words: in Perl UTF-8 is not just for Unicode. */
1559
1560     assert(s <= end);
1561     assert(off >= 0);
1562
1563     while (off--) {
1564         STRLEN skip = UTF8SKIP(s);
1565         if ((STRLEN)(end - s) <= skip) {
1566             GCC_DIAG_IGNORE(-Wcast-qual)
1567             return (U8 *)end;
1568             GCC_DIAG_RESTORE
1569         }
1570         s += skip;
1571     }
1572
1573     GCC_DIAG_IGNORE(-Wcast-qual)
1574     return (U8 *)s;
1575     GCC_DIAG_RESTORE
1576 }
1577
1578 /*
1579 =for apidoc utf8_hop_back
1580
1581 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1582 backward.
1583
1584 C<off> must be non-positive.
1585
1586 C<s> must be after or equal to C<start>.
1587
1588 When moving backward it will not move before C<start>.
1589
1590 Will not exceed this limit even if the string is not valid "UTF-8".
1591
1592 =cut
1593 */
1594
1595 PERL_STATIC_INLINE U8 *
1596 Perl_utf8_hop_back(const U8 *s, SSize_t off, const U8 *start)
1597 {
1598     PERL_ARGS_ASSERT_UTF8_HOP_BACK;
1599
1600     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1601      * the bitops (especially ~) can create illegal UTF-8.
1602      * In other words: in Perl UTF-8 is not just for Unicode. */
1603
1604     assert(start <= s);
1605     assert(off <= 0);
1606
1607     while (off++ && s > start) {
1608         do {
1609             s--;
1610         } while (UTF8_IS_CONTINUATION(*s) && s > start);
1611     }
1612
1613     GCC_DIAG_IGNORE(-Wcast-qual)
1614     return (U8 *)s;
1615     GCC_DIAG_RESTORE
1616 }
1617
1618 /*
1619 =for apidoc utf8_hop_safe
1620
1621 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1622 either forward or backward.
1623
1624 When moving backward it will not move before C<start>.
1625
1626 When moving forward it will not move beyond C<end>.
1627
1628 Will not exceed those limits even if the string is not valid "UTF-8".
1629
1630 =cut
1631 */
1632
1633 PERL_STATIC_INLINE U8 *
1634 Perl_utf8_hop_safe(const U8 *s, SSize_t off, const U8 *start, const U8 *end)
1635 {
1636     PERL_ARGS_ASSERT_UTF8_HOP_SAFE;
1637
1638     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1639      * the bitops (especially ~) can create illegal UTF-8.
1640      * In other words: in Perl UTF-8 is not just for Unicode. */
1641
1642     assert(start <= s && s <= end);
1643
1644     if (off >= 0) {
1645         return utf8_hop_forward(s, off, end);
1646     }
1647     else {
1648         return utf8_hop_back(s, off, start);
1649     }
1650 }
1651
1652 /*
1653
1654 =for apidoc is_utf8_valid_partial_char
1655
1656 Returns 0 if the sequence of bytes starting at C<s> and looking no further than
1657 S<C<e - 1>> is the UTF-8 encoding, as extended by Perl, for one or more code
1658 points.  Otherwise, it returns 1 if there exists at least one non-empty
1659 sequence of bytes that when appended to sequence C<s>, starting at position
1660 C<e> causes the entire sequence to be the well-formed UTF-8 of some code point;
1661 otherwise returns 0.
1662
1663 In other words this returns TRUE if C<s> points to a partial UTF-8-encoded code
1664 point.
1665
1666 This is useful when a fixed-length buffer is being tested for being well-formed
1667 UTF-8, but the final few bytes in it don't comprise a full character; that is,
1668 it is split somewhere in the middle of the final code point's UTF-8
1669 representation.  (Presumably when the buffer is refreshed with the next chunk
1670 of data, the new first bytes will complete the partial code point.)   This
1671 function is used to verify that the final bytes in the current buffer are in
1672 fact the legal beginning of some code point, so that if they aren't, the
1673 failure can be signalled without having to wait for the next read.
1674
1675 =cut
1676 */
1677 #define is_utf8_valid_partial_char(s, e)                                    \
1678                                 is_utf8_valid_partial_char_flags(s, e, 0)
1679
1680 /*
1681
1682 =for apidoc is_utf8_valid_partial_char_flags
1683
1684 Like C<L</is_utf8_valid_partial_char>>, it returns a boolean giving whether
1685 or not the input is a valid UTF-8 encoded partial character, but it takes an
1686 extra parameter, C<flags>, which can further restrict which code points are
1687 considered valid.
1688
1689 If C<flags> is 0, this behaves identically to
1690 C<L</is_utf8_valid_partial_char>>.  Otherwise C<flags> can be any combination
1691 of the C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>.  If
1692 there is any sequence of bytes that can complete the input partial character in
1693 such a way that a non-prohibited character is formed, the function returns
1694 TRUE; otherwise FALSE.  Non character code points cannot be determined based on
1695 partial character input.  But many  of the other possible excluded types can be
1696 determined from just the first one or two bytes.
1697
1698 =cut
1699  */
1700
1701 PERL_STATIC_INLINE bool
1702 Perl_is_utf8_valid_partial_char_flags(const U8 * const s, const U8 * const e, const U32 flags)
1703 {
1704     PERL_ARGS_ASSERT_IS_UTF8_VALID_PARTIAL_CHAR_FLAGS;
1705
1706     assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
1707                           |UTF8_DISALLOW_PERL_EXTENDED)));
1708
1709     if (s >= e || s + UTF8SKIP(s) <= e) {
1710         return FALSE;
1711     }
1712
1713     return cBOOL(is_utf8_char_helper(s, e, flags));
1714 }
1715
1716 /*
1717
1718 =for apidoc is_utf8_fixed_width_buf_flags
1719
1720 Returns TRUE if the fixed-width buffer starting at C<s> with length C<len>
1721 is entirely valid UTF-8, subject to the restrictions given by C<flags>;
1722 otherwise it returns FALSE.
1723
1724 If C<flags> is 0, any well-formed UTF-8, as extended by Perl, is accepted
1725 without restriction.  If the final few bytes of the buffer do not form a
1726 complete code point, this will return TRUE anyway, provided that
1727 C<L</is_utf8_valid_partial_char_flags>> returns TRUE for them.
1728
1729 If C<flags> in non-zero, it can be any combination of the
1730 C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>, and with the
1731 same meanings.
1732
1733 This function differs from C<L</is_utf8_string_flags>> only in that the latter
1734 returns FALSE if the final few bytes of the string don't form a complete code
1735 point.
1736
1737 =cut
1738  */
1739 #define is_utf8_fixed_width_buf_flags(s, len, flags)                        \
1740                 is_utf8_fixed_width_buf_loclen_flags(s, len, 0, 0, flags)
1741
1742 /*
1743
1744 =for apidoc is_utf8_fixed_width_buf_loc_flags
1745
1746 Like C<L</is_utf8_fixed_width_buf_flags>> but stores the location of the
1747 failure in the C<ep> pointer.  If the function returns TRUE, C<*ep> will point
1748 to the beginning of any partial character at the end of the buffer; if there is
1749 no partial character C<*ep> will contain C<s>+C<len>.
1750
1751 See also C<L</is_utf8_fixed_width_buf_loclen_flags>>.
1752
1753 =cut
1754 */
1755
1756 #define is_utf8_fixed_width_buf_loc_flags(s, len, loc, flags)               \
1757                 is_utf8_fixed_width_buf_loclen_flags(s, len, loc, 0, flags)
1758
1759 /*
1760
1761 =for apidoc is_utf8_fixed_width_buf_loclen_flags
1762
1763 Like C<L</is_utf8_fixed_width_buf_loc_flags>> but stores the number of
1764 complete, valid characters found in the C<el> pointer.
1765
1766 =cut
1767 */
1768
1769 PERL_STATIC_INLINE bool
1770 Perl_is_utf8_fixed_width_buf_loclen_flags(const U8 * const s,
1771                                        STRLEN len,
1772                                        const U8 **ep,
1773                                        STRLEN *el,
1774                                        const U32 flags)
1775 {
1776     const U8 * maybe_partial;
1777
1778     PERL_ARGS_ASSERT_IS_UTF8_FIXED_WIDTH_BUF_LOCLEN_FLAGS;
1779
1780     if (! ep) {
1781         ep  = &maybe_partial;
1782     }
1783
1784     /* If it's entirely valid, return that; otherwise see if the only error is
1785      * that the final few bytes are for a partial character */
1786     return    is_utf8_string_loclen_flags(s, len, ep, el, flags)
1787            || is_utf8_valid_partial_char_flags(*ep, s + len, flags);
1788 }
1789
1790 PERL_STATIC_INLINE UV
1791 Perl_utf8n_to_uvchr_msgs(const U8 *s,
1792                       STRLEN curlen,
1793                       STRLEN *retlen,
1794                       const U32 flags,
1795                       U32 * errors,
1796                       AV ** msgs)
1797 {
1798     /* This is the inlined portion of utf8n_to_uvchr_msgs.  It handles the
1799      * simple cases, and, if necessary calls a helper function to deal with the
1800      * more complex ones.  Almost all well-formed non-problematic code points
1801      * are considered simple, so that it's unlikely that the helper function
1802      * will need to be called.
1803      *
1804      * This is an adaptation of the tables and algorithm given in
1805      * https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides
1806      * comprehensive documentation of the original version.  A copyright notice
1807      * for the original version is given at the beginning of this file.  The
1808      * Perl adapation is documented at the definition of PL_strict_utf8_dfa_tab[].
1809      */
1810
1811     const U8 * const s0 = s;
1812     const U8 * send = s0 + curlen;
1813     UV uv = 0;      /* The 0 silences some stupid compilers */
1814     UV state = 0;
1815
1816     PERL_ARGS_ASSERT_UTF8N_TO_UVCHR_MSGS;
1817
1818     /* This dfa is fast.  If it accepts the input, it was for a well-formed,
1819      * non-problematic code point, which can be returned immediately.
1820      * Otherwise we call a helper function to figure out the more complicated
1821      * cases. */
1822
1823     while (s < send && LIKELY(state != 1)) {
1824         UV type = PL_strict_utf8_dfa_tab[*s];
1825
1826         uv = (state == 0)
1827              ?  ((0xff >> type) & NATIVE_UTF8_TO_I8(*s))
1828              : UTF8_ACCUMULATE(uv, *s);
1829         state = PL_strict_utf8_dfa_tab[256 + state + type];
1830
1831         if (state != 0) {
1832             s++;
1833             continue;
1834         }
1835
1836         if (retlen) {
1837             *retlen = s - s0 + 1;
1838         }
1839         if (errors) {
1840             *errors = 0;
1841         }
1842         if (msgs) {
1843             *msgs = NULL;
1844         }
1845
1846         return UNI_TO_NATIVE(uv);
1847     }
1848
1849     /* Here is potentially problematic.  Use the full mechanism */
1850     return _utf8n_to_uvchr_msgs_helper(s0, curlen, retlen, flags, errors, msgs);
1851 }
1852
1853 PERL_STATIC_INLINE UV
1854 Perl_utf8_to_uvchr_buf_helper(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen)
1855 {
1856     PERL_ARGS_ASSERT_UTF8_TO_UVCHR_BUF_HELPER;
1857
1858     assert(s < send);
1859
1860     if (! ckWARN_d(WARN_UTF8)) {
1861
1862         /* EMPTY is not really allowed, and asserts on debugging builds.  But
1863          * on non-debugging we have to deal with it, and this causes it to
1864          * return the REPLACEMENT CHARACTER, as the documentation indicates */
1865         return utf8n_to_uvchr(s, send - s, retlen,
1866                               (UTF8_ALLOW_ANY | UTF8_ALLOW_EMPTY));
1867     }
1868     else {
1869         UV ret = utf8n_to_uvchr(s, send - s, retlen, 0);
1870         if (retlen && ret == 0 && *s != '\0') {
1871             *retlen = (STRLEN) -1;
1872         }
1873
1874         return ret;
1875     }
1876 }
1877
1878 /* ------------------------------- perl.h ----------------------------- */
1879
1880 /*
1881 =head1 Miscellaneous Functions
1882
1883 =for apidoc is_safe_syscall
1884
1885 Test that the given C<pv> (with length C<len>) doesn't contain any internal
1886 C<NUL> characters.
1887 If it does, set C<errno> to C<ENOENT>, optionally warn using the C<syscalls>
1888 category, and return FALSE.
1889
1890 Return TRUE if the name is safe.
1891
1892 C<what> and C<op_name> are used in any warning.
1893
1894 Used by the C<IS_SAFE_SYSCALL()> macro.
1895
1896 =cut
1897 */
1898
1899 PERL_STATIC_INLINE bool
1900 Perl_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name)
1901 {
1902     /* While the Windows CE API provides only UCS-16 (or UTF-16) APIs
1903      * perl itself uses xce*() functions which accept 8-bit strings.
1904      */
1905
1906     PERL_ARGS_ASSERT_IS_SAFE_SYSCALL;
1907
1908     if (len > 1) {
1909         char *null_at;
1910         if (UNLIKELY((null_at = (char *)memchr(pv, 0, len-1)) != NULL)) {
1911                 SETERRNO(ENOENT, LIB_INVARG);
1912                 Perl_ck_warner(aTHX_ packWARN(WARN_SYSCALLS),
1913                                    "Invalid \\0 character in %s for %s: %s\\0%s",
1914                                    what, op_name, pv, null_at+1);
1915                 return FALSE;
1916         }
1917     }
1918
1919     return TRUE;
1920 }
1921
1922 /*
1923
1924 Return true if the supplied filename has a newline character
1925 immediately before the first (hopefully only) NUL.
1926
1927 My original look at this incorrectly used the len from SvPV(), but
1928 that's incorrect, since we allow for a NUL in pv[len-1].
1929
1930 So instead, strlen() and work from there.
1931
1932 This allow for the user reading a filename, forgetting to chomp it,
1933 then calling:
1934
1935   open my $foo, "$file\0";
1936
1937 */
1938
1939 #ifdef PERL_CORE
1940
1941 PERL_STATIC_INLINE bool
1942 S_should_warn_nl(const char *pv)
1943 {
1944     STRLEN len;
1945
1946     PERL_ARGS_ASSERT_SHOULD_WARN_NL;
1947
1948     len = strlen(pv);
1949
1950     return len > 0 && pv[len-1] == '\n';
1951 }
1952
1953 #endif
1954
1955 #if defined(PERL_IN_PP_C) || defined(PERL_IN_PP_HOT_C)
1956
1957 PERL_STATIC_INLINE bool
1958 S_lossless_NV_to_IV(const NV nv, IV *ivp)
1959 {
1960     /* This function determines if the input NV 'nv' may be converted without
1961      * loss of data to an IV.  If not, it returns FALSE taking no other action.
1962      * But if it is possible, it does the conversion, returning TRUE, and
1963      * storing the converted result in '*ivp' */
1964
1965     PERL_ARGS_ASSERT_LOSSLESS_NV_TO_IV;
1966
1967 #  if  defined(Perl_isnan)
1968
1969     if (UNLIKELY(Perl_isnan(nv))) {
1970         return FALSE;
1971     }
1972
1973 #  endif
1974
1975     if (UNLIKELY(nv < IV_MIN) || UNLIKELY(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 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     dVAR;
2520     const U8 *a = (const U8 *)s1;
2521     const U8 *b = (const U8 *)s2;
2522
2523     PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
2524
2525     assert(len >= 0);
2526
2527     while (len--) {
2528         if (*a != *b && *a != PL_fold_locale[*b])
2529             return 0;
2530         a++,b++;
2531     }
2532     return 1;
2533 }
2534
2535 /*
2536 =for apidoc my_strnlen
2537
2538 The C library C<strnlen> if available, or a Perl implementation of it.
2539
2540 C<my_strnlen()> computes the length of the string, up to C<maxlen>
2541 characters.  It will will never attempt to address more than C<maxlen>
2542 characters, making it suitable for use with strings that are not
2543 guaranteed to be NUL-terminated.
2544
2545 =cut
2546
2547 Description stolen from http://man.openbsd.org/strnlen.3,
2548 implementation stolen from PostgreSQL.
2549 */
2550 #ifndef HAS_STRNLEN
2551
2552 PERL_STATIC_INLINE Size_t
2553 Perl_my_strnlen(const char *str, Size_t maxlen)
2554 {
2555     const char *end = (char *) memchr(str, '\0', maxlen);
2556
2557     PERL_ARGS_ASSERT_MY_STRNLEN;
2558
2559     if (end == NULL) return maxlen;
2560     return end - str;
2561 }
2562
2563 #endif
2564
2565 #if ! defined (HAS_MEMRCHR) && (defined(PERL_CORE) || defined(PERL_EXT))
2566
2567 PERL_STATIC_INLINE void *
2568 S_my_memrchr(const char * s, const char c, const STRLEN len)
2569 {
2570     /* memrchr(), since many platforms lack it */
2571
2572     const char * t = s + len - 1;
2573
2574     PERL_ARGS_ASSERT_MY_MEMRCHR;
2575
2576     while (t >= s) {
2577         if (*t == c) {
2578             return (void *) t;
2579         }
2580         t--;
2581     }
2582
2583     return NULL;
2584 }
2585
2586 #endif
2587
2588 /*
2589  * ex: set ts=8 sts=4 sw=4 et:
2590  */