This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
inline.h: White space only
[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 is a home for static inline functions that cannot go in other
9  * headers files, because they depend on proto.h (included after most other
10  * headers) or struct definitions.
11  *
12  * Each section names the header file that the functions "belong" to.
13  */
14
15 /* ------------------------------- av.h ------------------------------- */
16
17 PERL_STATIC_INLINE SSize_t
18 S_av_top_index(pTHX_ AV *av)
19 {
20     PERL_ARGS_ASSERT_AV_TOP_INDEX;
21     assert(SvTYPE(av) == SVt_PVAV);
22
23     return AvFILL(av);
24 }
25
26 /* ------------------------------- cv.h ------------------------------- */
27
28 PERL_STATIC_INLINE GV *
29 S_CvGV(pTHX_ CV *sv)
30 {
31     return CvNAMED(sv)
32         ? Perl_cvgv_from_hek(aTHX_ sv)
33         : ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_gv;
34 }
35
36 PERL_STATIC_INLINE I32 *
37 S_CvDEPTHp(const CV * const sv)
38 {
39     assert(SvTYPE(sv) == SVt_PVCV || SvTYPE(sv) == SVt_PVFM);
40     return &((XPVCV*)SvANY(sv))->xcv_depth;
41 }
42
43 /*
44  CvPROTO returns the prototype as stored, which is not necessarily what
45  the interpreter should be using. Specifically, the interpreter assumes
46  that spaces have been stripped, which has been the case if the prototype
47  was added by toke.c, but is generally not the case if it was added elsewhere.
48  Since we can't enforce the spacelessness at assignment time, this routine
49  provides a temporary copy at parse time with spaces removed.
50  I<orig> is the start of the original buffer, I<len> is the length of the
51  prototype and will be updated when this returns.
52  */
53
54 #ifdef PERL_CORE
55 PERL_STATIC_INLINE char *
56 S_strip_spaces(pTHX_ const char * orig, STRLEN * const len)
57 {
58     SV * tmpsv;
59     char * tmps;
60     tmpsv = newSVpvn_flags(orig, *len, SVs_TEMP);
61     tmps = SvPVX(tmpsv);
62     while ((*len)--) {
63         if (!isSPACE(*orig))
64             *tmps++ = *orig;
65         orig++;
66     }
67     *tmps = '\0';
68     *len = tmps - SvPVX(tmpsv);
69                 return SvPVX(tmpsv);
70 }
71 #endif
72
73 /* ------------------------------- mg.h ------------------------------- */
74
75 #if defined(PERL_CORE) || defined(PERL_EXT)
76 /* assumes get-magic and stringification have already occurred */
77 PERL_STATIC_INLINE STRLEN
78 S_MgBYTEPOS(pTHX_ MAGIC *mg, SV *sv, const char *s, STRLEN len)
79 {
80     assert(mg->mg_type == PERL_MAGIC_regex_global);
81     assert(mg->mg_len != -1);
82     if (mg->mg_flags & MGf_BYTES || !DO_UTF8(sv))
83         return (STRLEN)mg->mg_len;
84     else {
85         const STRLEN pos = (STRLEN)mg->mg_len;
86         /* Without this check, we may read past the end of the buffer: */
87         if (pos > sv_or_pv_len_utf8(sv, s, len)) return len+1;
88         return sv_or_pv_pos_u2b(sv, s, pos, NULL);
89     }
90 }
91 #endif
92
93 /* ------------------------------- pad.h ------------------------------ */
94
95 #if defined(PERL_IN_PAD_C) || defined(PERL_IN_OP_C)
96 PERL_STATIC_INLINE bool
97 PadnameIN_SCOPE(const PADNAME * const pn, const U32 seq)
98 {
99     /* is seq within the range _LOW to _HIGH ?
100      * This is complicated by the fact that PL_cop_seqmax
101      * may have wrapped around at some point */
102     if (COP_SEQ_RANGE_LOW(pn) == PERL_PADSEQ_INTRO)
103         return FALSE; /* not yet introduced */
104
105     if (COP_SEQ_RANGE_HIGH(pn) == PERL_PADSEQ_INTRO) {
106     /* in compiling scope */
107         if (
108             (seq >  COP_SEQ_RANGE_LOW(pn))
109             ? (seq - COP_SEQ_RANGE_LOW(pn) < (U32_MAX >> 1))
110             : (COP_SEQ_RANGE_LOW(pn) - seq > (U32_MAX >> 1))
111         )
112             return TRUE;
113     }
114     else if (
115         (COP_SEQ_RANGE_LOW(pn) > COP_SEQ_RANGE_HIGH(pn))
116         ?
117             (  seq >  COP_SEQ_RANGE_LOW(pn)
118             || seq <= COP_SEQ_RANGE_HIGH(pn))
119
120         :    (  seq >  COP_SEQ_RANGE_LOW(pn)
121              && seq <= COP_SEQ_RANGE_HIGH(pn))
122     )
123         return TRUE;
124     return FALSE;
125 }
126 #endif
127
128 /* ------------------------------- pp.h ------------------------------- */
129
130 PERL_STATIC_INLINE I32
131 S_TOPMARK(pTHX)
132 {
133     DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
134                                  "MARK top  %p %" IVdf "\n",
135                                   PL_markstack_ptr,
136                                   (IV)*PL_markstack_ptr)));
137     return *PL_markstack_ptr;
138 }
139
140 PERL_STATIC_INLINE I32
141 S_POPMARK(pTHX)
142 {
143     DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
144                                  "MARK pop  %p %" IVdf "\n",
145                                   (PL_markstack_ptr-1),
146                                   (IV)*(PL_markstack_ptr-1))));
147     assert((PL_markstack_ptr > PL_markstack) || !"MARK underflow");
148     return *PL_markstack_ptr--;
149 }
150
151 /* ----------------------------- regexp.h ----------------------------- */
152
153 PERL_STATIC_INLINE struct regexp *
154 S_ReANY(const REGEXP * const re)
155 {
156     XPV* const p = (XPV*)SvANY(re);
157     assert(isREGEXP(re));
158     return SvTYPE(re) == SVt_PVLV ? p->xpv_len_u.xpvlenu_rx
159                                    : (struct regexp *)p;
160 }
161
162 /* ------------------------------- sv.h ------------------------------- */
163
164 PERL_STATIC_INLINE SV *
165 S_SvREFCNT_inc(SV *sv)
166 {
167     if (LIKELY(sv != NULL))
168         SvREFCNT(sv)++;
169     return sv;
170 }
171 PERL_STATIC_INLINE SV *
172 S_SvREFCNT_inc_NN(SV *sv)
173 {
174     SvREFCNT(sv)++;
175     return sv;
176 }
177 PERL_STATIC_INLINE void
178 S_SvREFCNT_inc_void(SV *sv)
179 {
180     if (LIKELY(sv != NULL))
181         SvREFCNT(sv)++;
182 }
183 PERL_STATIC_INLINE void
184 S_SvREFCNT_dec(pTHX_ SV *sv)
185 {
186     if (LIKELY(sv != NULL)) {
187         U32 rc = SvREFCNT(sv);
188         if (LIKELY(rc > 1))
189             SvREFCNT(sv) = rc - 1;
190         else
191             Perl_sv_free2(aTHX_ sv, rc);
192     }
193 }
194
195 PERL_STATIC_INLINE void
196 S_SvREFCNT_dec_NN(pTHX_ SV *sv)
197 {
198     U32 rc = SvREFCNT(sv);
199     if (LIKELY(rc > 1))
200         SvREFCNT(sv) = rc - 1;
201     else
202         Perl_sv_free2(aTHX_ sv, rc);
203 }
204
205 PERL_STATIC_INLINE void
206 SvAMAGIC_on(SV *sv)
207 {
208     assert(SvROK(sv));
209     if (SvOBJECT(SvRV(sv))) HvAMAGIC_on(SvSTASH(SvRV(sv)));
210 }
211 PERL_STATIC_INLINE void
212 SvAMAGIC_off(SV *sv)
213 {
214     if (SvROK(sv) && SvOBJECT(SvRV(sv)))
215         HvAMAGIC_off(SvSTASH(SvRV(sv)));
216 }
217
218 PERL_STATIC_INLINE U32
219 S_SvPADSTALE_on(SV *sv)
220 {
221     assert(!(SvFLAGS(sv) & SVs_PADTMP));
222     return SvFLAGS(sv) |= SVs_PADSTALE;
223 }
224 PERL_STATIC_INLINE U32
225 S_SvPADSTALE_off(SV *sv)
226 {
227     assert(!(SvFLAGS(sv) & SVs_PADTMP));
228     return SvFLAGS(sv) &= ~SVs_PADSTALE;
229 }
230 #if defined(PERL_CORE) || defined (PERL_EXT)
231 PERL_STATIC_INLINE STRLEN
232 S_sv_or_pv_pos_u2b(pTHX_ SV *sv, const char *pv, STRLEN pos, STRLEN *lenp)
233 {
234     PERL_ARGS_ASSERT_SV_OR_PV_POS_U2B;
235     if (SvGAMAGIC(sv)) {
236         U8 *hopped = utf8_hop((U8 *)pv, pos);
237         if (lenp) *lenp = (STRLEN)(utf8_hop(hopped, *lenp) - hopped);
238         return (STRLEN)(hopped - (U8 *)pv);
239     }
240     return sv_pos_u2b_flags(sv,pos,lenp,SV_CONST_RETURN);
241 }
242 #endif
243
244 /* ------------------------------- handy.h ------------------------------- */
245
246 /* saves machine code for a common noreturn idiom typically used in Newx*() */
247 #ifdef GCC_DIAG_PRAGMA
248 GCC_DIAG_IGNORE(-Wunused-function) /* Intentionally left semicolonless. */
249 #endif
250 static void
251 S_croak_memory_wrap(void)
252 {
253     Perl_croak_nocontext("%s",PL_memory_wrap);
254 }
255 #ifdef GCC_DIAG_PRAGMA
256 GCC_DIAG_RESTORE /* Intentionally left semicolonless. */
257 #endif
258
259 /* ------------------------------- utf8.h ------------------------------- */
260
261 /*
262 =head1 Unicode Support
263 */
264
265 PERL_STATIC_INLINE void
266 S_append_utf8_from_native_byte(const U8 byte, U8** dest)
267 {
268     /* Takes an input 'byte' (Latin1 or EBCDIC) and appends it to the UTF-8
269      * encoded string at '*dest', updating '*dest' to include it */
270
271     PERL_ARGS_ASSERT_APPEND_UTF8_FROM_NATIVE_BYTE;
272
273     if (NATIVE_BYTE_IS_INVARIANT(byte))
274         *((*dest)++) = byte;
275     else {
276         *((*dest)++) = UTF8_EIGHT_BIT_HI(byte);
277         *((*dest)++) = UTF8_EIGHT_BIT_LO(byte);
278     }
279 }
280
281 /*
282 =for apidoc valid_utf8_to_uvchr
283 Like C<L</utf8_to_uvchr_buf>>, but should only be called when it is known that
284 the next character in the input UTF-8 string C<s> is well-formed (I<e.g.>,
285 it passes C<L</isUTF8_CHAR>>.  Surrogates, non-character code points, and
286 non-Unicode code points are allowed.
287
288 =cut
289
290  */
291
292 PERL_STATIC_INLINE UV
293 Perl_valid_utf8_to_uvchr(const U8 *s, STRLEN *retlen)
294 {
295     const UV expectlen = UTF8SKIP(s);
296     const U8* send = s + expectlen;
297     UV uv = *s;
298
299     PERL_ARGS_ASSERT_VALID_UTF8_TO_UVCHR;
300
301     if (retlen) {
302         *retlen = expectlen;
303     }
304
305     /* An invariant is trivially returned */
306     if (expectlen == 1) {
307         return uv;
308     }
309
310     /* Remove the leading bits that indicate the number of bytes, leaving just
311      * the bits that are part of the value */
312     uv = NATIVE_UTF8_TO_I8(uv) & UTF_START_MASK(expectlen);
313
314     /* Now, loop through the remaining bytes, accumulating each into the
315      * working total as we go.  (I khw tried unrolling the loop for up to 4
316      * bytes, but there was no performance improvement) */
317     for (++s; s < send; s++) {
318         uv = UTF8_ACCUMULATE(uv, *s);
319     }
320
321     return UNI_TO_NATIVE(uv);
322
323 }
324
325 /*
326 =for apidoc is_utf8_invariant_string
327
328 Returns TRUE if the first C<len> bytes of the string C<s> are the same
329 regardless of the UTF-8 encoding of the string (or UTF-EBCDIC encoding on
330 EBCDIC machines); otherwise it returns FALSE.  That is, it returns TRUE if they
331 are UTF-8 invariant.  On ASCII-ish machines, all the ASCII characters and only
332 the ASCII characters fit this definition.  On EBCDIC machines, the ASCII-range
333 characters are invariant, but so also are the C1 controls.
334
335 If C<len> is 0, it will be calculated using C<strlen(s)>, (which means if you
336 use this option, that C<s> can't have embedded C<NUL> characters and has to
337 have a terminating C<NUL> byte).
338
339 See also
340 C<L</is_utf8_string>>,
341 C<L</is_utf8_string_flags>>,
342 C<L</is_utf8_string_loc>>,
343 C<L</is_utf8_string_loc_flags>>,
344 C<L</is_utf8_string_loclen>>,
345 C<L</is_utf8_string_loclen_flags>>,
346 C<L</is_utf8_fixed_width_buf_flags>>,
347 C<L</is_utf8_fixed_width_buf_loc_flags>>,
348 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
349 C<L</is_strict_utf8_string>>,
350 C<L</is_strict_utf8_string_loc>>,
351 C<L</is_strict_utf8_string_loclen>>,
352 C<L</is_c9strict_utf8_string>>,
353 C<L</is_c9strict_utf8_string_loc>>,
354 and
355 C<L</is_c9strict_utf8_string_loclen>>.
356
357 =cut
358
359 */
360
361 #define is_utf8_invariant_string(s, len)                                    \
362                                 is_utf8_invariant_string_loc(s, len, NULL)
363
364 /*
365 =for apidoc is_utf8_invariant_string_loc
366
367 Like C<L</is_utf8_invariant_string>> but upon failure, stores the location of
368 the first UTF-8 variant character in the C<ep> pointer; if all characters are
369 UTF-8 invariant, this function does not change the contents of C<*ep>.
370
371 =cut
372
373 */
374
375 PERL_STATIC_INLINE bool
376 S_is_utf8_invariant_string_loc(const U8* const s, STRLEN len, const U8 ** ep)
377 {
378     const U8* send;
379     const U8* x = s;
380
381     PERL_ARGS_ASSERT_IS_UTF8_INVARIANT_STRING_LOC;
382
383     if (len == 0) {
384         len = strlen((const char *)s);
385     }
386
387     send = s + len;
388
389 #ifndef EBCDIC
390     /* Try to get the widest word on this platform */
391 #  ifdef HAS_LONG_LONG
392 #    define PERL_WORDCAST unsigned long long
393 #    define PERL_WORDSIZE LONGLONGSIZE
394 #  else
395 #    define PERL_WORDCAST UV
396 #    define PERL_WORDSIZE UVSIZE
397 #  endif
398
399 #  if PERL_WORDSIZE == 4
400 #    define PERL_VARIANTS_WORD_MASK 0x80808080
401 #    define PERL_WORD_BOUNDARY_MASK 0x3
402 #  elif PERL_WORDSIZE == 8
403 #    define PERL_VARIANTS_WORD_MASK UINT64_C(0x8080808080808080)
404 #    define PERL_WORD_BOUNDARY_MASK 0x7
405 #  else
406 #    error Unexpected word size
407 #  endif
408
409     if ((STRLEN) (send - x) >= PERL_WORDSIZE) {
410
411         /* Process per-byte until reach word boundary.  XXX This loop could be
412          * eliminated if we knew that this platform had fast unaligned reads */
413         while (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK) {
414             if (! UTF8_IS_INVARIANT(*x)) {
415                 if (ep) {
416                     *ep = x;
417                 }
418
419                 return FALSE;
420             }
421             x++;
422         }
423
424         /* Process per-word as long as we have at least a full word left */
425         while (x + PERL_WORDSIZE <= send) {
426             if ((* (PERL_WORDCAST *) x) & PERL_VARIANTS_WORD_MASK)  {
427
428                 /* Found a variant.  Just return if caller doesn't want its
429                  * exact position */
430                 if (! ep) {
431                     return FALSE;
432                 }
433
434                 /* Otherwise fall into final loop to find which byte it is */
435                 break;
436             }
437             x += PERL_WORDSIZE;
438         }
439     }
440
441 #  undef PERL_WORDCAST
442 #  undef PERL_WORDSIZE
443 #  undef PERL_WORD_BOUNDARY_MASK
444 #  undef PERL_VARIANTS_WORD_MASK
445 #endif
446
447     /* Process per-byte */
448     while (x < send) {
449         if (! UTF8_IS_INVARIANT(*x)) {
450             if (ep) {
451                 *ep = x;
452             }
453
454             return FALSE;
455         }
456
457         x++;
458     }
459
460     return TRUE;
461 }
462
463 /*
464 =for apidoc is_utf8_string
465
466 Returns TRUE if the first C<len> bytes of string C<s> form a valid
467 Perl-extended-UTF-8 string; returns FALSE otherwise.  If C<len> is 0, it will
468 be calculated using C<strlen(s)> (which means if you use this option, that C<s>
469 can't have embedded C<NUL> characters and has to have a terminating C<NUL>
470 byte).  Note that all characters being ASCII constitute 'a valid UTF-8 string'.
471
472 This function considers Perl's extended UTF-8 to be valid.  That means that
473 code points above Unicode, surrogates, and non-character code points are
474 considered valid by this function.  Use C<L</is_strict_utf8_string>>,
475 C<L</is_c9strict_utf8_string>>, or C<L</is_utf8_string_flags>> to restrict what
476 code points are considered valid.
477
478 See also
479 C<L</is_utf8_invariant_string>>,
480 C<L</is_utf8_invariant_string_loc>>,
481 C<L</is_utf8_string_loc>>,
482 C<L</is_utf8_string_loclen>>,
483 C<L</is_utf8_fixed_width_buf_flags>>,
484 C<L</is_utf8_fixed_width_buf_loc_flags>>,
485 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
486
487 =cut
488 */
489
490 #define is_utf8_string(s, len)  is_utf8_string_loclen(s, len, NULL, NULL)
491
492 #if defined(PERL_CORE) || defined (PERL_EXT)
493
494 /*
495 =for apidoc is_utf8_non_invariant_string
496
497 Returns TRUE if L<perlapi/is_utf8_invariant_string> returns FALSE for the first
498 C<len> bytes of the string C<s>, but they are, nonetheless, legal Perl-extended
499 UTF-8; otherwise returns FALSE.
500
501 A TRUE return means that at least one code point represented by the sequence
502 either is a wide character not representable as a single byte, or the
503 representation differs depending on whether the sequence is encoded in UTF-8 or
504 not.
505
506 See also
507 C<L<perlapi/is_utf8_invariant_string>>,
508 C<L<perlapi/is_utf8_string>>
509
510 =cut
511
512 This is commonly used to determine if a SV's UTF-8 flag should be turned on.
513 It needn't be if its string is entirely UTF-8 invariant, and it shouldn't be if
514 it otherwise contains invalid UTF-8.
515
516 It is an internal function because khw thinks that XS code shouldn't be working
517 at this low a level.  A valid use case could change that.
518
519 */
520
521 PERL_STATIC_INLINE bool
522 S_is_utf8_non_invariant_string(const U8* const s, STRLEN len)
523 {
524     const U8 * first_variant;
525
526     PERL_ARGS_ASSERT_IS_UTF8_NON_INVARIANT_STRING;
527
528     if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
529         return FALSE;
530     }
531
532     return is_utf8_string(first_variant, len - (first_variant - s));
533 }
534
535 #endif
536
537 /*
538 =for apidoc is_strict_utf8_string
539
540 Returns TRUE if the first C<len> bytes of string C<s> form a valid
541 UTF-8-encoded string that is fully interchangeable by any application using
542 Unicode rules; otherwise it returns FALSE.  If C<len> is 0, it will be
543 calculated using C<strlen(s)> (which means if you use this option, that C<s>
544 can't have embedded C<NUL> characters and has to have a terminating C<NUL>
545 byte).  Note that all characters being ASCII constitute 'a valid UTF-8 string'.
546
547 This function returns FALSE for strings containing any
548 code points above the Unicode max of 0x10FFFF, surrogate code points, or
549 non-character code points.
550
551 See also
552 C<L</is_utf8_invariant_string>>,
553 C<L</is_utf8_invariant_string_loc>>,
554 C<L</is_utf8_string>>,
555 C<L</is_utf8_string_flags>>,
556 C<L</is_utf8_string_loc>>,
557 C<L</is_utf8_string_loc_flags>>,
558 C<L</is_utf8_string_loclen>>,
559 C<L</is_utf8_string_loclen_flags>>,
560 C<L</is_utf8_fixed_width_buf_flags>>,
561 C<L</is_utf8_fixed_width_buf_loc_flags>>,
562 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
563 C<L</is_strict_utf8_string_loc>>,
564 C<L</is_strict_utf8_string_loclen>>,
565 C<L</is_c9strict_utf8_string>>,
566 C<L</is_c9strict_utf8_string_loc>>,
567 and
568 C<L</is_c9strict_utf8_string_loclen>>.
569
570 =cut
571 */
572
573 #define is_strict_utf8_string(s, len)  is_strict_utf8_string_loclen(s, len, NULL, NULL)
574
575 /*
576 =for apidoc is_c9strict_utf8_string
577
578 Returns TRUE if the first C<len> bytes of string C<s> form a valid
579 UTF-8-encoded string that conforms to
580 L<Unicode Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>;
581 otherwise it returns FALSE.  If C<len> is 0, it will be calculated using
582 C<strlen(s)> (which means if you use this option, that C<s> can't have embedded
583 C<NUL> characters and has to have a terminating C<NUL> byte).  Note that all
584 characters being ASCII constitute 'a valid UTF-8 string'.
585
586 This function returns FALSE for strings containing any code points above the
587 Unicode max of 0x10FFFF or surrogate code points, but accepts non-character
588 code points per
589 L<Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>.
590
591 See also
592 C<L</is_utf8_invariant_string>>,
593 C<L</is_utf8_invariant_string_loc>>,
594 C<L</is_utf8_string>>,
595 C<L</is_utf8_string_flags>>,
596 C<L</is_utf8_string_loc>>,
597 C<L</is_utf8_string_loc_flags>>,
598 C<L</is_utf8_string_loclen>>,
599 C<L</is_utf8_string_loclen_flags>>,
600 C<L</is_utf8_fixed_width_buf_flags>>,
601 C<L</is_utf8_fixed_width_buf_loc_flags>>,
602 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
603 C<L</is_strict_utf8_string>>,
604 C<L</is_strict_utf8_string_loc>>,
605 C<L</is_strict_utf8_string_loclen>>,
606 C<L</is_c9strict_utf8_string_loc>>,
607 and
608 C<L</is_c9strict_utf8_string_loclen>>.
609
610 =cut
611 */
612
613 #define is_c9strict_utf8_string(s, len)  is_c9strict_utf8_string_loclen(s, len, NULL, 0)
614
615 /*
616 =for apidoc is_utf8_string_flags
617
618 Returns TRUE if the first C<len> bytes of string C<s> form a valid
619 UTF-8 string, subject to the restrictions imposed by C<flags>;
620 returns FALSE otherwise.  If C<len> is 0, it will be calculated
621 using C<strlen(s)> (which means if you use this option, that C<s> can't have
622 embedded C<NUL> characters and has to have a terminating C<NUL> byte).  Note
623 that all characters being ASCII constitute 'a valid UTF-8 string'.
624
625 If C<flags> is 0, this gives the same results as C<L</is_utf8_string>>; if
626 C<flags> is C<UTF8_DISALLOW_ILLEGAL_INTERCHANGE>, this gives the same results
627 as C<L</is_strict_utf8_string>>; and if C<flags> is
628 C<UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE>, this gives the same results as
629 C<L</is_c9strict_utf8_string>>.  Otherwise C<flags> may be any
630 combination of the C<UTF8_DISALLOW_I<foo>> flags understood by
631 C<L</utf8n_to_uvchr>>, with the same meanings.
632
633 See also
634 C<L</is_utf8_invariant_string>>,
635 C<L</is_utf8_invariant_string_loc>>,
636 C<L</is_utf8_string>>,
637 C<L</is_utf8_string_loc>>,
638 C<L</is_utf8_string_loc_flags>>,
639 C<L</is_utf8_string_loclen>>,
640 C<L</is_utf8_string_loclen_flags>>,
641 C<L</is_utf8_fixed_width_buf_flags>>,
642 C<L</is_utf8_fixed_width_buf_loc_flags>>,
643 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
644 C<L</is_strict_utf8_string>>,
645 C<L</is_strict_utf8_string_loc>>,
646 C<L</is_strict_utf8_string_loclen>>,
647 C<L</is_c9strict_utf8_string>>,
648 C<L</is_c9strict_utf8_string_loc>>,
649 and
650 C<L</is_c9strict_utf8_string_loclen>>.
651
652 =cut
653 */
654
655 PERL_STATIC_INLINE bool
656 S_is_utf8_string_flags(const U8 *s, STRLEN len, const U32 flags)
657 {
658     const U8 * first_variant;
659
660     PERL_ARGS_ASSERT_IS_UTF8_STRING_FLAGS;
661     assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
662                           |UTF8_DISALLOW_PERL_EXTENDED)));
663
664     if (len == 0) {
665         len = strlen((const char *)s);
666     }
667
668     if (flags == 0) {
669         return is_utf8_string(s, len);
670     }
671
672     if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
673                                         == UTF8_DISALLOW_ILLEGAL_INTERCHANGE)
674     {
675         return is_strict_utf8_string(s, len);
676     }
677
678     if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
679                                        == UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE)
680     {
681         return is_c9strict_utf8_string(s, len);
682     }
683
684     if (! is_utf8_invariant_string_loc(s, len, &first_variant)) {
685         const U8* const send = s + len;
686         const U8* x = first_variant;
687
688         while (x < send) {
689             STRLEN cur_len = isUTF8_CHAR_flags(x, send, flags);
690             if (UNLIKELY(! cur_len)) {
691                 return FALSE;
692             }
693             x += cur_len;
694         }
695     }
696
697     return TRUE;
698 }
699
700 /*
701
702 =for apidoc is_utf8_string_loc
703
704 Like C<L</is_utf8_string>> but stores the location of the failure (in the
705 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
706 "utf8ness success") in the C<ep> pointer.
707
708 See also C<L</is_utf8_string_loclen>>.
709
710 =cut
711 */
712
713 #define is_utf8_string_loc(s, len, ep)  is_utf8_string_loclen(s, len, ep, 0)
714
715 /*
716
717 =for apidoc is_utf8_string_loclen
718
719 Like C<L</is_utf8_string>> but stores the location of the failure (in the
720 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
721 "utf8ness success") in the C<ep> pointer, and the number of UTF-8
722 encoded characters in the C<el> pointer.
723
724 See also C<L</is_utf8_string_loc>>.
725
726 =cut
727 */
728
729 PERL_STATIC_INLINE bool
730 Perl_is_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
731 {
732     const U8 * first_variant;
733
734     PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN;
735
736     if (len == 0) {
737         len = strlen((const char *) s);
738     }
739
740     if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
741         if (el)
742             *el = len;
743
744         if (ep) {
745             *ep = s + len;
746         }
747
748         return TRUE;
749     }
750
751     {
752         const U8* const send = s + len;
753         const U8* x = first_variant;
754         STRLEN outlen = first_variant - s;
755
756         while (x < send) {
757             const STRLEN cur_len = isUTF8_CHAR(x, send);
758             if (UNLIKELY(! cur_len)) {
759                 break;
760             }
761             x += cur_len;
762             outlen++;
763         }
764
765         if (el)
766             *el = outlen;
767
768         if (ep) {
769             *ep = x;
770         }
771
772         return (x == send);
773     }
774 }
775
776 /*
777
778 =for apidoc is_strict_utf8_string_loc
779
780 Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
781 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
782 "utf8ness success") in the C<ep> pointer.
783
784 See also C<L</is_strict_utf8_string_loclen>>.
785
786 =cut
787 */
788
789 #define is_strict_utf8_string_loc(s, len, ep)                               \
790                                 is_strict_utf8_string_loclen(s, len, ep, 0)
791
792 /*
793
794 =for apidoc is_strict_utf8_string_loclen
795
796 Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
797 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
798 "utf8ness success") in the C<ep> pointer, and the number of UTF-8
799 encoded characters in the C<el> pointer.
800
801 See also C<L</is_strict_utf8_string_loc>>.
802
803 =cut
804 */
805
806 PERL_STATIC_INLINE bool
807 S_is_strict_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
808 {
809     const U8 * first_variant;
810
811     PERL_ARGS_ASSERT_IS_STRICT_UTF8_STRING_LOCLEN;
812
813     if (len == 0) {
814         len = strlen((const char *) s);
815     }
816
817     if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
818         if (el)
819             *el = len;
820
821         if (ep) {
822             *ep = s + len;
823         }
824
825         return TRUE;
826     }
827
828     {
829         const U8* const send = s + len;
830         const U8* x = first_variant;
831         STRLEN outlen = first_variant - s;
832
833         while (x < send) {
834             const STRLEN cur_len = isSTRICT_UTF8_CHAR(x, send);
835             if (UNLIKELY(! cur_len)) {
836                 break;
837             }
838             x += cur_len;
839             outlen++;
840         }
841
842         if (el)
843             *el = outlen;
844
845         if (ep) {
846             *ep = x;
847         }
848
849         return (x == send);
850     }
851 }
852
853 /*
854
855 =for apidoc is_c9strict_utf8_string_loc
856
857 Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in
858 the case of "utf8ness failure") or the location C<s>+C<len> (in the case of
859 "utf8ness success") in the C<ep> pointer.
860
861 See also C<L</is_c9strict_utf8_string_loclen>>.
862
863 =cut
864 */
865
866 #define is_c9strict_utf8_string_loc(s, len, ep)                             \
867                             is_c9strict_utf8_string_loclen(s, len, ep, 0)
868
869 /*
870
871 =for apidoc is_c9strict_utf8_string_loclen
872
873 Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in
874 the case of "utf8ness failure") or the location C<s>+C<len> (in the case of
875 "utf8ness success") in the C<ep> pointer, and the number of UTF-8 encoded
876 characters in the C<el> pointer.
877
878 See also C<L</is_c9strict_utf8_string_loc>>.
879
880 =cut
881 */
882
883 PERL_STATIC_INLINE bool
884 S_is_c9strict_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
885 {
886     const U8 * first_variant;
887
888     PERL_ARGS_ASSERT_IS_C9STRICT_UTF8_STRING_LOCLEN;
889
890     if (len == 0) {
891         len = strlen((const char *) s);
892     }
893
894     if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
895         if (el)
896             *el = len;
897
898         if (ep) {
899             *ep = s + len;
900         }
901
902         return TRUE;
903     }
904
905     {
906         const U8* const send = s + len;
907         const U8* x = first_variant;
908         STRLEN outlen = first_variant - s;
909
910         while (x < send) {
911             const STRLEN cur_len = isC9_STRICT_UTF8_CHAR(x, send);
912             if (UNLIKELY(! cur_len)) {
913                 break;
914             }
915             x += cur_len;
916             outlen++;
917         }
918
919         if (el)
920             *el = outlen;
921
922         if (ep) {
923             *ep = x;
924         }
925
926         return (x == send);
927     }
928 }
929
930 /*
931
932 =for apidoc is_utf8_string_loc_flags
933
934 Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the
935 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
936 "utf8ness success") in the C<ep> pointer.
937
938 See also C<L</is_utf8_string_loclen_flags>>.
939
940 =cut
941 */
942
943 #define is_utf8_string_loc_flags(s, len, ep, flags)                         \
944                         is_utf8_string_loclen_flags(s, len, ep, 0, flags)
945
946
947 /* The above 3 actual functions could have been moved into the more general one
948  * just below, and made #defines that call it with the right 'flags'.  They are
949  * currently kept separate to increase their chances of getting inlined */
950
951 /*
952
953 =for apidoc is_utf8_string_loclen_flags
954
955 Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the
956 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
957 "utf8ness success") in the C<ep> pointer, and the number of UTF-8
958 encoded characters in the C<el> pointer.
959
960 See also C<L</is_utf8_string_loc_flags>>.
961
962 =cut
963 */
964
965 PERL_STATIC_INLINE bool
966 S_is_utf8_string_loclen_flags(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el, const U32 flags)
967 {
968     const U8 * first_variant;
969
970     PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN_FLAGS;
971     assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
972                           |UTF8_DISALLOW_PERL_EXTENDED)));
973
974     if (len == 0) {
975         len = strlen((const char *) s);
976     }
977
978     if (flags == 0) {
979         return is_utf8_string_loclen(s, len, ep, el);
980     }
981
982     if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
983                                         == UTF8_DISALLOW_ILLEGAL_INTERCHANGE)
984     {
985         return is_strict_utf8_string_loclen(s, len, ep, el);
986     }
987
988     if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
989                                     == UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE)
990     {
991         return is_c9strict_utf8_string_loclen(s, len, ep, el);
992     }
993
994     if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
995         if (el)
996             *el = len;
997
998         if (ep) {
999             *ep = s + len;
1000         }
1001
1002         return TRUE;
1003     }
1004
1005     {
1006         const U8* send = s + len;
1007         const U8* x = first_variant;
1008         STRLEN outlen = first_variant - s;
1009
1010         while (x < send) {
1011             const STRLEN cur_len = isUTF8_CHAR_flags(x, send, flags);
1012             if (UNLIKELY(! cur_len)) {
1013                 break;
1014             }
1015             x += cur_len;
1016             outlen++;
1017         }
1018
1019         if (el)
1020             *el = outlen;
1021
1022         if (ep) {
1023             *ep = x;
1024         }
1025
1026         return (x == send);
1027     }
1028 }
1029
1030 /*
1031 =for apidoc utf8_distance
1032
1033 Returns the number of UTF-8 characters between the UTF-8 pointers C<a>
1034 and C<b>.
1035
1036 WARNING: use only if you *know* that the pointers point inside the
1037 same UTF-8 buffer.
1038
1039 =cut
1040 */
1041
1042 PERL_STATIC_INLINE IV
1043 Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b)
1044 {
1045     PERL_ARGS_ASSERT_UTF8_DISTANCE;
1046
1047     return (a < b) ? -1 * (IV) utf8_length(a, b) : (IV) utf8_length(b, a);
1048 }
1049
1050 /*
1051 =for apidoc utf8_hop
1052
1053 Return the UTF-8 pointer C<s> displaced by C<off> characters, either
1054 forward or backward.
1055
1056 WARNING: do not use the following unless you *know* C<off> is within
1057 the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
1058 on the first byte of character or just after the last byte of a character.
1059
1060 =cut
1061 */
1062
1063 PERL_STATIC_INLINE U8 *
1064 Perl_utf8_hop(const U8 *s, SSize_t off)
1065 {
1066     PERL_ARGS_ASSERT_UTF8_HOP;
1067
1068     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1069      * the bitops (especially ~) can create illegal UTF-8.
1070      * In other words: in Perl UTF-8 is not just for Unicode. */
1071
1072     if (off >= 0) {
1073         while (off--)
1074             s += UTF8SKIP(s);
1075     }
1076     else {
1077         while (off++) {
1078             s--;
1079             while (UTF8_IS_CONTINUATION(*s))
1080                 s--;
1081         }
1082     }
1083     GCC_DIAG_IGNORE(-Wcast-qual);
1084     return (U8 *)s;
1085     GCC_DIAG_RESTORE;
1086 }
1087
1088 /*
1089 =for apidoc utf8_hop_forward
1090
1091 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1092 forward.
1093
1094 C<off> must be non-negative.
1095
1096 C<s> must be before or equal to C<end>.
1097
1098 When moving forward it will not move beyond C<end>.
1099
1100 Will not exceed this limit even if the string is not valid "UTF-8".
1101
1102 =cut
1103 */
1104
1105 PERL_STATIC_INLINE U8 *
1106 Perl_utf8_hop_forward(const U8 *s, SSize_t off, const U8 *end)
1107 {
1108     PERL_ARGS_ASSERT_UTF8_HOP_FORWARD;
1109
1110     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1111      * the bitops (especially ~) can create illegal UTF-8.
1112      * In other words: in Perl UTF-8 is not just for Unicode. */
1113
1114     assert(s <= end);
1115     assert(off >= 0);
1116
1117     while (off--) {
1118         STRLEN skip = UTF8SKIP(s);
1119         if ((STRLEN)(end - s) <= skip) {
1120             GCC_DIAG_IGNORE(-Wcast-qual);
1121             return (U8 *)end;
1122             GCC_DIAG_RESTORE;
1123         }
1124         s += skip;
1125     }
1126
1127     GCC_DIAG_IGNORE(-Wcast-qual);
1128     return (U8 *)s;
1129     GCC_DIAG_RESTORE;
1130 }
1131
1132 /*
1133 =for apidoc utf8_hop_back
1134
1135 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1136 backward.
1137
1138 C<off> must be non-positive.
1139
1140 C<s> must be after or equal to C<start>.
1141
1142 When moving backward it will not move before C<start>.
1143
1144 Will not exceed this limit even if the string is not valid "UTF-8".
1145
1146 =cut
1147 */
1148
1149 PERL_STATIC_INLINE U8 *
1150 Perl_utf8_hop_back(const U8 *s, SSize_t off, const U8 *start)
1151 {
1152     PERL_ARGS_ASSERT_UTF8_HOP_BACK;
1153
1154     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1155      * the bitops (especially ~) can create illegal UTF-8.
1156      * In other words: in Perl UTF-8 is not just for Unicode. */
1157
1158     assert(start <= s);
1159     assert(off <= 0);
1160
1161     while (off++ && s > start) {
1162         s--;
1163         while (UTF8_IS_CONTINUATION(*s) && s > start)
1164             s--;
1165     }
1166     
1167     GCC_DIAG_IGNORE(-Wcast-qual);
1168     return (U8 *)s;
1169     GCC_DIAG_RESTORE;
1170 }
1171
1172 /*
1173 =for apidoc utf8_hop_safe
1174
1175 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1176 either forward or backward.
1177
1178 When moving backward it will not move before C<start>.
1179
1180 When moving forward it will not move beyond C<end>.
1181
1182 Will not exceed those limits even if the string is not valid "UTF-8".
1183
1184 =cut
1185 */
1186
1187 PERL_STATIC_INLINE U8 *
1188 Perl_utf8_hop_safe(const U8 *s, SSize_t off, const U8 *start, const U8 *end)
1189 {
1190     PERL_ARGS_ASSERT_UTF8_HOP_SAFE;
1191
1192     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1193      * the bitops (especially ~) can create illegal UTF-8.
1194      * In other words: in Perl UTF-8 is not just for Unicode. */
1195
1196     assert(start <= s && s <= end);
1197
1198     if (off >= 0) {
1199         return utf8_hop_forward(s, off, end);
1200     }
1201     else {
1202         return utf8_hop_back(s, off, start);
1203     }
1204 }
1205
1206 /*
1207
1208 =for apidoc is_utf8_valid_partial_char
1209
1210 Returns 0 if the sequence of bytes starting at C<s> and looking no further than
1211 S<C<e - 1>> is the UTF-8 encoding, as extended by Perl, for one or more code
1212 points.  Otherwise, it returns 1 if there exists at least one non-empty
1213 sequence of bytes that when appended to sequence C<s>, starting at position
1214 C<e> causes the entire sequence to be the well-formed UTF-8 of some code point;
1215 otherwise returns 0.
1216
1217 In other words this returns TRUE if C<s> points to a partial UTF-8-encoded code
1218 point.
1219
1220 This is useful when a fixed-length buffer is being tested for being well-formed
1221 UTF-8, but the final few bytes in it don't comprise a full character; that is,
1222 it is split somewhere in the middle of the final code point's UTF-8
1223 representation.  (Presumably when the buffer is refreshed with the next chunk
1224 of data, the new first bytes will complete the partial code point.)   This
1225 function is used to verify that the final bytes in the current buffer are in
1226 fact the legal beginning of some code point, so that if they aren't, the
1227 failure can be signalled without having to wait for the next read.
1228
1229 =cut
1230 */
1231 #define is_utf8_valid_partial_char(s, e)                                    \
1232                                 is_utf8_valid_partial_char_flags(s, e, 0)
1233
1234 /*
1235
1236 =for apidoc is_utf8_valid_partial_char_flags
1237
1238 Like C<L</is_utf8_valid_partial_char>>, it returns a boolean giving whether
1239 or not the input is a valid UTF-8 encoded partial character, but it takes an
1240 extra parameter, C<flags>, which can further restrict which code points are
1241 considered valid.
1242
1243 If C<flags> is 0, this behaves identically to
1244 C<L</is_utf8_valid_partial_char>>.  Otherwise C<flags> can be any combination
1245 of the C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>.  If
1246 there is any sequence of bytes that can complete the input partial character in
1247 such a way that a non-prohibited character is formed, the function returns
1248 TRUE; otherwise FALSE.  Non character code points cannot be determined based on
1249 partial character input.  But many  of the other possible excluded types can be
1250 determined from just the first one or two bytes.
1251
1252 =cut
1253  */
1254
1255 PERL_STATIC_INLINE bool
1256 S_is_utf8_valid_partial_char_flags(const U8 * const s, const U8 * const e, const U32 flags)
1257 {
1258     PERL_ARGS_ASSERT_IS_UTF8_VALID_PARTIAL_CHAR_FLAGS;
1259
1260     assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
1261                           |UTF8_DISALLOW_PERL_EXTENDED)));
1262
1263     if (s >= e || s + UTF8SKIP(s) <= e) {
1264         return FALSE;
1265     }
1266
1267     return cBOOL(_is_utf8_char_helper(s, e, flags));
1268 }
1269
1270 /*
1271
1272 =for apidoc is_utf8_fixed_width_buf_flags
1273
1274 Returns TRUE if the fixed-width buffer starting at C<s> with length C<len>
1275 is entirely valid UTF-8, subject to the restrictions given by C<flags>;
1276 otherwise it returns FALSE.
1277
1278 If C<flags> is 0, any well-formed UTF-8, as extended by Perl, is accepted
1279 without restriction.  If the final few bytes of the buffer do not form a
1280 complete code point, this will return TRUE anyway, provided that
1281 C<L</is_utf8_valid_partial_char_flags>> returns TRUE for them.
1282
1283 If C<flags> in non-zero, it can be any combination of the
1284 C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>, and with the
1285 same meanings.
1286
1287 This function differs from C<L</is_utf8_string_flags>> only in that the latter
1288 returns FALSE if the final few bytes of the string don't form a complete code
1289 point.
1290
1291 =cut
1292  */
1293 #define is_utf8_fixed_width_buf_flags(s, len, flags)                        \
1294                 is_utf8_fixed_width_buf_loclen_flags(s, len, 0, 0, flags)
1295
1296 /*
1297
1298 =for apidoc is_utf8_fixed_width_buf_loc_flags
1299
1300 Like C<L</is_utf8_fixed_width_buf_flags>> but stores the location of the
1301 failure in the C<ep> pointer.  If the function returns TRUE, C<*ep> will point
1302 to the beginning of any partial character at the end of the buffer; if there is
1303 no partial character C<*ep> will contain C<s>+C<len>.
1304
1305 See also C<L</is_utf8_fixed_width_buf_loclen_flags>>.
1306
1307 =cut
1308 */
1309
1310 #define is_utf8_fixed_width_buf_loc_flags(s, len, loc, flags)               \
1311                 is_utf8_fixed_width_buf_loclen_flags(s, len, loc, 0, flags)
1312
1313 /*
1314
1315 =for apidoc is_utf8_fixed_width_buf_loclen_flags
1316
1317 Like C<L</is_utf8_fixed_width_buf_loc_flags>> but stores the number of
1318 complete, valid characters found in the C<el> pointer.
1319
1320 =cut
1321 */
1322
1323 PERL_STATIC_INLINE bool
1324 S_is_utf8_fixed_width_buf_loclen_flags(const U8 * const s,
1325                                        STRLEN len,
1326                                        const U8 **ep,
1327                                        STRLEN *el,
1328                                        const U32 flags)
1329 {
1330     const U8 * maybe_partial;
1331
1332     PERL_ARGS_ASSERT_IS_UTF8_FIXED_WIDTH_BUF_LOCLEN_FLAGS;
1333
1334     if (! ep) {
1335         ep  = &maybe_partial;
1336     }
1337
1338     /* If it's entirely valid, return that; otherwise see if the only error is
1339      * that the final few bytes are for a partial character */
1340     return    is_utf8_string_loclen_flags(s, len, ep, el, flags)
1341            || is_utf8_valid_partial_char_flags(*ep, s + len, flags);
1342 }
1343
1344 /* ------------------------------- perl.h ----------------------------- */
1345
1346 /*
1347 =head1 Miscellaneous Functions
1348
1349 =for apidoc AiR|bool|is_safe_syscall|const char *pv|STRLEN len|const char *what|const char *op_name
1350
1351 Test that the given C<pv> doesn't contain any internal C<NUL> characters.
1352 If it does, set C<errno> to C<ENOENT>, optionally warn, and return FALSE.
1353
1354 Return TRUE if the name is safe.
1355
1356 Used by the C<IS_SAFE_SYSCALL()> macro.
1357
1358 =cut
1359 */
1360
1361 PERL_STATIC_INLINE bool
1362 S_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name) {
1363     /* While the Windows CE API provides only UCS-16 (or UTF-16) APIs
1364      * perl itself uses xce*() functions which accept 8-bit strings.
1365      */
1366
1367     PERL_ARGS_ASSERT_IS_SAFE_SYSCALL;
1368
1369     if (len > 1) {
1370         char *null_at;
1371         if (UNLIKELY((null_at = (char *)memchr(pv, 0, len-1)) != NULL)) {
1372                 SETERRNO(ENOENT, LIB_INVARG);
1373                 Perl_ck_warner(aTHX_ packWARN(WARN_SYSCALLS),
1374                                    "Invalid \\0 character in %s for %s: %s\\0%s",
1375                                    what, op_name, pv, null_at+1);
1376                 return FALSE;
1377         }
1378     }
1379
1380     return TRUE;
1381 }
1382
1383 /*
1384
1385 Return true if the supplied filename has a newline character
1386 immediately before the first (hopefully only) NUL.
1387
1388 My original look at this incorrectly used the len from SvPV(), but
1389 that's incorrect, since we allow for a NUL in pv[len-1].
1390
1391 So instead, strlen() and work from there.
1392
1393 This allow for the user reading a filename, forgetting to chomp it,
1394 then calling:
1395
1396   open my $foo, "$file\0";
1397
1398 */
1399
1400 #ifdef PERL_CORE
1401
1402 PERL_STATIC_INLINE bool
1403 S_should_warn_nl(const char *pv) {
1404     STRLEN len;
1405
1406     PERL_ARGS_ASSERT_SHOULD_WARN_NL;
1407
1408     len = strlen(pv);
1409
1410     return len > 0 && pv[len-1] == '\n';
1411 }
1412
1413 #endif
1414
1415 /* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */
1416
1417 #define MAX_CHARSET_NAME_LENGTH 2
1418
1419 PERL_STATIC_INLINE const char *
1420 get_regex_charset_name(const U32 flags, STRLEN* const lenp)
1421 {
1422     /* Returns a string that corresponds to the name of the regex character set
1423      * given by 'flags', and *lenp is set the length of that string, which
1424      * cannot exceed MAX_CHARSET_NAME_LENGTH characters */
1425
1426     *lenp = 1;
1427     switch (get_regex_charset(flags)) {
1428         case REGEX_DEPENDS_CHARSET: return DEPENDS_PAT_MODS;
1429         case REGEX_LOCALE_CHARSET:  return LOCALE_PAT_MODS;
1430         case REGEX_UNICODE_CHARSET: return UNICODE_PAT_MODS;
1431         case REGEX_ASCII_RESTRICTED_CHARSET: return ASCII_RESTRICT_PAT_MODS;
1432         case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
1433             *lenp = 2;
1434             return ASCII_MORE_RESTRICT_PAT_MODS;
1435     }
1436     /* The NOT_REACHED; hides an assert() which has a rather complex
1437      * definition in perl.h. */
1438     NOT_REACHED; /* NOTREACHED */
1439     return "?";     /* Unknown */
1440 }
1441
1442 /*
1443
1444 Return false if any get magic is on the SV other than taint magic.
1445
1446 */
1447
1448 PERL_STATIC_INLINE bool
1449 S_sv_only_taint_gmagic(SV *sv) {
1450     MAGIC *mg = SvMAGIC(sv);
1451
1452     PERL_ARGS_ASSERT_SV_ONLY_TAINT_GMAGIC;
1453
1454     while (mg) {
1455         if (mg->mg_type != PERL_MAGIC_taint
1456             && !(mg->mg_flags & MGf_GSKIP)
1457             && mg->mg_virtual->svt_get) {
1458             return FALSE;
1459         }
1460         mg = mg->mg_moremagic;
1461     }
1462
1463     return TRUE;
1464 }
1465
1466 /* ------------------ cop.h ------------------------------------------- */
1467
1468
1469 /* Enter a block. Push a new base context and return its address. */
1470
1471 PERL_STATIC_INLINE PERL_CONTEXT *
1472 S_cx_pushblock(pTHX_ U8 type, U8 gimme, SV** sp, I32 saveix)
1473 {
1474     PERL_CONTEXT * cx;
1475
1476     PERL_ARGS_ASSERT_CX_PUSHBLOCK;
1477
1478     CXINC;
1479     cx = CX_CUR();
1480     cx->cx_type        = type;
1481     cx->blk_gimme      = gimme;
1482     cx->blk_oldsaveix  = saveix;
1483     cx->blk_oldsp      = (I32)(sp - PL_stack_base);
1484     cx->blk_oldcop     = PL_curcop;
1485     cx->blk_oldmarksp  = (I32)(PL_markstack_ptr - PL_markstack);
1486     cx->blk_oldscopesp = PL_scopestack_ix;
1487     cx->blk_oldpm      = PL_curpm;
1488     cx->blk_old_tmpsfloor = PL_tmps_floor;
1489
1490     PL_tmps_floor        = PL_tmps_ix;
1491     CX_DEBUG(cx, "PUSH");
1492     return cx;
1493 }
1494
1495
1496 /* Exit a block (RETURN and LAST). */
1497
1498 PERL_STATIC_INLINE void
1499 S_cx_popblock(pTHX_ PERL_CONTEXT *cx)
1500 {
1501     PERL_ARGS_ASSERT_CX_POPBLOCK;
1502
1503     CX_DEBUG(cx, "POP");
1504     /* these 3 are common to cx_popblock and cx_topblock */
1505     PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
1506     PL_scopestack_ix = cx->blk_oldscopesp;
1507     PL_curpm         = cx->blk_oldpm;
1508
1509     /* LEAVE_SCOPE() should have made this true. /(?{})/ cheats
1510      * and leaves a CX entry lying around for repeated use, so
1511      * skip for multicall */                  \
1512     assert(   (CxTYPE(cx) == CXt_SUB && CxMULTICALL(cx))
1513             || PL_savestack_ix == cx->blk_oldsaveix);
1514     PL_curcop     = cx->blk_oldcop;
1515     PL_tmps_floor = cx->blk_old_tmpsfloor;
1516 }
1517
1518 /* Continue a block elsewhere (e.g. NEXT, REDO, GOTO).
1519  * Whereas cx_popblock() restores the state to the point just before
1520  * cx_pushblock() was called,  cx_topblock() restores it to the point just
1521  * *after* cx_pushblock() was called. */
1522
1523 PERL_STATIC_INLINE void
1524 S_cx_topblock(pTHX_ PERL_CONTEXT *cx)
1525 {
1526     PERL_ARGS_ASSERT_CX_TOPBLOCK;
1527
1528     CX_DEBUG(cx, "TOP");
1529     /* these 3 are common to cx_popblock and cx_topblock */
1530     PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
1531     PL_scopestack_ix = cx->blk_oldscopesp;
1532     PL_curpm         = cx->blk_oldpm;
1533
1534     PL_stack_sp      = PL_stack_base + cx->blk_oldsp;
1535 }
1536
1537
1538 PERL_STATIC_INLINE void
1539 S_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs)
1540 {
1541     U8 phlags = CX_PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub);
1542
1543     PERL_ARGS_ASSERT_CX_PUSHSUB;
1544
1545     PERL_DTRACE_PROBE_ENTRY(cv);
1546     cx->blk_sub.cv = cv;
1547     cx->blk_sub.olddepth = CvDEPTH(cv);
1548     cx->blk_sub.prevcomppad = PL_comppad;
1549     cx->cx_type |= (hasargs) ? CXp_HASARGS : 0;
1550     cx->blk_sub.retop = retop;
1551     SvREFCNT_inc_simple_void_NN(cv);
1552     cx->blk_u16 = PL_op->op_private & (phlags|OPpDEREF);
1553 }
1554
1555
1556 /* subsets of cx_popsub() */
1557
1558 PERL_STATIC_INLINE void
1559 S_cx_popsub_common(pTHX_ PERL_CONTEXT *cx)
1560 {
1561     CV *cv;
1562
1563     PERL_ARGS_ASSERT_CX_POPSUB_COMMON;
1564     assert(CxTYPE(cx) == CXt_SUB);
1565
1566     PL_comppad = cx->blk_sub.prevcomppad;
1567     PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
1568     cv = cx->blk_sub.cv;
1569     CvDEPTH(cv) = cx->blk_sub.olddepth;
1570     cx->blk_sub.cv = NULL;
1571     SvREFCNT_dec(cv);
1572 }
1573
1574
1575 /* handle the @_ part of leaving a sub */
1576
1577 PERL_STATIC_INLINE void
1578 S_cx_popsub_args(pTHX_ PERL_CONTEXT *cx)
1579 {
1580     AV *av;
1581
1582     PERL_ARGS_ASSERT_CX_POPSUB_ARGS;
1583     assert(CxTYPE(cx) == CXt_SUB);
1584     assert(AvARRAY(MUTABLE_AV(
1585         PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
1586                 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
1587
1588     CX_POP_SAVEARRAY(cx);
1589     av = MUTABLE_AV(PAD_SVl(0));
1590     if (UNLIKELY(AvREAL(av)))
1591         /* abandon @_ if it got reified */
1592         clear_defarray(av, 0);
1593     else {
1594         CLEAR_ARGARRAY(av);
1595     }
1596 }
1597
1598
1599 PERL_STATIC_INLINE void
1600 S_cx_popsub(pTHX_ PERL_CONTEXT *cx)
1601 {
1602     PERL_ARGS_ASSERT_CX_POPSUB;
1603     assert(CxTYPE(cx) == CXt_SUB);
1604
1605     PERL_DTRACE_PROBE_RETURN(cx->blk_sub.cv);
1606
1607     if (CxHASARGS(cx))
1608         cx_popsub_args(cx);
1609     cx_popsub_common(cx);
1610 }
1611
1612
1613 PERL_STATIC_INLINE void
1614 S_cx_pushformat(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, GV *gv)
1615 {
1616     PERL_ARGS_ASSERT_CX_PUSHFORMAT;
1617
1618     cx->blk_format.cv          = cv;
1619     cx->blk_format.retop       = retop;
1620     cx->blk_format.gv          = gv;
1621     cx->blk_format.dfoutgv     = PL_defoutgv;
1622     cx->blk_format.prevcomppad = PL_comppad;
1623     cx->blk_u16                = 0;
1624
1625     SvREFCNT_inc_simple_void_NN(cv);
1626     CvDEPTH(cv)++;
1627     SvREFCNT_inc_void(cx->blk_format.dfoutgv);
1628 }
1629
1630
1631 PERL_STATIC_INLINE void
1632 S_cx_popformat(pTHX_ PERL_CONTEXT *cx)
1633 {
1634     CV *cv;
1635     GV *dfout;
1636
1637     PERL_ARGS_ASSERT_CX_POPFORMAT;
1638     assert(CxTYPE(cx) == CXt_FORMAT);
1639
1640     dfout = cx->blk_format.dfoutgv;
1641     setdefout(dfout);
1642     cx->blk_format.dfoutgv = NULL;
1643     SvREFCNT_dec_NN(dfout);
1644
1645     PL_comppad = cx->blk_format.prevcomppad;
1646     PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
1647     cv = cx->blk_format.cv;
1648     cx->blk_format.cv = NULL;
1649     --CvDEPTH(cv);
1650     SvREFCNT_dec_NN(cv);
1651 }
1652
1653
1654 PERL_STATIC_INLINE void
1655 S_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv)
1656 {
1657     PERL_ARGS_ASSERT_CX_PUSHEVAL;
1658
1659     cx->blk_eval.retop         = retop;
1660     cx->blk_eval.old_namesv    = namesv;
1661     cx->blk_eval.old_eval_root = PL_eval_root;
1662     cx->blk_eval.cur_text      = PL_parser ? PL_parser->linestr : NULL;
1663     cx->blk_eval.cv            = NULL; /* later set by doeval_compile() */
1664     cx->blk_eval.cur_top_env   = PL_top_env;
1665
1666     assert(!(PL_in_eval     & ~ 0x3F));
1667     assert(!(PL_op->op_type & ~0x1FF));
1668     cx->blk_u16 = (PL_in_eval & 0x3F) | ((U16)PL_op->op_type << 7);
1669 }
1670
1671
1672 PERL_STATIC_INLINE void
1673 S_cx_popeval(pTHX_ PERL_CONTEXT *cx)
1674 {
1675     SV *sv;
1676
1677     PERL_ARGS_ASSERT_CX_POPEVAL;
1678     assert(CxTYPE(cx) == CXt_EVAL);
1679
1680     PL_in_eval = CxOLD_IN_EVAL(cx);
1681     assert(!(PL_in_eval & 0xc0));
1682     PL_eval_root = cx->blk_eval.old_eval_root;
1683     sv = cx->blk_eval.cur_text;
1684     if (sv && CxEVAL_TXT_REFCNTED(cx)) {
1685         cx->blk_eval.cur_text = NULL;
1686         SvREFCNT_dec_NN(sv);
1687     }
1688
1689     sv = cx->blk_eval.old_namesv;
1690     if (sv) {
1691         cx->blk_eval.old_namesv = NULL;
1692         SvREFCNT_dec_NN(sv);
1693     }
1694 }
1695
1696
1697 /* push a plain loop, i.e.
1698  *     { block }
1699  *     while (cond) { block }
1700  *     for (init;cond;continue) { block }
1701  * This loop can be last/redo'ed etc.
1702  */
1703
1704 PERL_STATIC_INLINE void
1705 S_cx_pushloop_plain(pTHX_ PERL_CONTEXT *cx)
1706 {
1707     PERL_ARGS_ASSERT_CX_PUSHLOOP_PLAIN;
1708     cx->blk_loop.my_op = cLOOP;
1709 }
1710
1711
1712 /* push a true for loop, i.e.
1713  *     for var (list) { block }
1714  */
1715
1716 PERL_STATIC_INLINE void
1717 S_cx_pushloop_for(pTHX_ PERL_CONTEXT *cx, void *itervarp, SV* itersave)
1718 {
1719     PERL_ARGS_ASSERT_CX_PUSHLOOP_FOR;
1720
1721     /* this one line is common with cx_pushloop_plain */
1722     cx->blk_loop.my_op = cLOOP;
1723
1724     cx->blk_loop.itervar_u.svp = (SV**)itervarp;
1725     cx->blk_loop.itersave      = itersave;
1726 #ifdef USE_ITHREADS
1727     cx->blk_loop.oldcomppad = PL_comppad;
1728 #endif
1729 }
1730
1731
1732 /* pop all loop types, including plain */
1733
1734 PERL_STATIC_INLINE void
1735 S_cx_poploop(pTHX_ PERL_CONTEXT *cx)
1736 {
1737     PERL_ARGS_ASSERT_CX_POPLOOP;
1738
1739     assert(CxTYPE_is_LOOP(cx));
1740     if (  CxTYPE(cx) == CXt_LOOP_ARY
1741        || CxTYPE(cx) == CXt_LOOP_LAZYSV)
1742     {
1743         /* Free ary or cur. This assumes that state_u.ary.ary
1744          * aligns with state_u.lazysv.cur. See cx_dup() */
1745         SV *sv = cx->blk_loop.state_u.lazysv.cur;
1746         cx->blk_loop.state_u.lazysv.cur = NULL;
1747         SvREFCNT_dec_NN(sv);
1748         if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1749             sv = cx->blk_loop.state_u.lazysv.end;
1750             cx->blk_loop.state_u.lazysv.end = NULL;
1751             SvREFCNT_dec_NN(sv);
1752         }
1753     }
1754     if (cx->cx_type & (CXp_FOR_PAD|CXp_FOR_GV)) {
1755         SV *cursv;
1756         SV **svp = (cx)->blk_loop.itervar_u.svp;
1757         if ((cx->cx_type & CXp_FOR_GV))
1758             svp = &GvSV((GV*)svp);
1759         cursv = *svp;
1760         *svp = cx->blk_loop.itersave;
1761         cx->blk_loop.itersave = NULL;
1762         SvREFCNT_dec(cursv);
1763     }
1764 }
1765
1766
1767 PERL_STATIC_INLINE void
1768 S_cx_pushwhen(pTHX_ PERL_CONTEXT *cx)
1769 {
1770     PERL_ARGS_ASSERT_CX_PUSHWHEN;
1771
1772     cx->blk_givwhen.leave_op = cLOGOP->op_other;
1773 }
1774
1775
1776 PERL_STATIC_INLINE void
1777 S_cx_popwhen(pTHX_ PERL_CONTEXT *cx)
1778 {
1779     PERL_ARGS_ASSERT_CX_POPWHEN;
1780     assert(CxTYPE(cx) == CXt_WHEN);
1781
1782     PERL_UNUSED_ARG(cx);
1783     PERL_UNUSED_CONTEXT;
1784     /* currently NOOP */
1785 }
1786
1787
1788 PERL_STATIC_INLINE void
1789 S_cx_pushgiven(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv)
1790 {
1791     PERL_ARGS_ASSERT_CX_PUSHGIVEN;
1792
1793     cx->blk_givwhen.leave_op = cLOGOP->op_other;
1794     cx->blk_givwhen.defsv_save = orig_defsv;
1795 }
1796
1797
1798 PERL_STATIC_INLINE void
1799 S_cx_popgiven(pTHX_ PERL_CONTEXT *cx)
1800 {
1801     SV *sv;
1802
1803     PERL_ARGS_ASSERT_CX_POPGIVEN;
1804     assert(CxTYPE(cx) == CXt_GIVEN);
1805
1806     sv = GvSV(PL_defgv);
1807     GvSV(PL_defgv) = cx->blk_givwhen.defsv_save;
1808     cx->blk_givwhen.defsv_save = NULL;
1809     SvREFCNT_dec(sv);
1810 }
1811
1812 /* ------------------ util.h ------------------------------------------- */
1813
1814 /*
1815 =head1 Miscellaneous Functions
1816
1817 =for apidoc foldEQ
1818
1819 Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
1820 same
1821 case-insensitively; false otherwise.  Uppercase and lowercase ASCII range bytes
1822 match themselves and their opposite case counterparts.  Non-cased and non-ASCII
1823 range bytes match only themselves.
1824
1825 =cut
1826 */
1827
1828 PERL_STATIC_INLINE I32
1829 Perl_foldEQ(const char *s1, const char *s2, I32 len)
1830 {
1831     const U8 *a = (const U8 *)s1;
1832     const U8 *b = (const U8 *)s2;
1833
1834     PERL_ARGS_ASSERT_FOLDEQ;
1835
1836     assert(len >= 0);
1837
1838     while (len--) {
1839         if (*a != *b && *a != PL_fold[*b])
1840             return 0;
1841         a++,b++;
1842     }
1843     return 1;
1844 }
1845
1846 PERL_STATIC_INLINE I32
1847 Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
1848 {
1849     /* Compare non-utf8 using Unicode (Latin1) semantics.  Does not work on
1850      * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
1851      * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these.  Nor
1852      * does it check that the strings each have at least 'len' characters */
1853
1854     const U8 *a = (const U8 *)s1;
1855     const U8 *b = (const U8 *)s2;
1856
1857     PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
1858
1859     assert(len >= 0);
1860
1861     while (len--) {
1862         if (*a != *b && *a != PL_fold_latin1[*b]) {
1863             return 0;
1864         }
1865         a++, b++;
1866     }
1867     return 1;
1868 }
1869
1870 /*
1871 =for apidoc foldEQ_locale
1872
1873 Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
1874 same case-insensitively in the current locale; false otherwise.
1875
1876 =cut
1877 */
1878
1879 PERL_STATIC_INLINE I32
1880 Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
1881 {
1882     dVAR;
1883     const U8 *a = (const U8 *)s1;
1884     const U8 *b = (const U8 *)s2;
1885
1886     PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
1887
1888     assert(len >= 0);
1889
1890     while (len--) {
1891         if (*a != *b && *a != PL_fold_locale[*b])
1892             return 0;
1893         a++,b++;
1894     }
1895     return 1;
1896 }
1897
1898 #if ! defined (HAS_MEMRCHR) && (defined(PERL_CORE) || defined(PERL_EXT))
1899
1900 PERL_STATIC_INLINE void *
1901 S_my_memrchr(const char * s, const char c, const STRLEN len)
1902 {
1903     /* memrchr(), since many platforms lack it */
1904
1905     const char * t = s + len - 1;
1906
1907     PERL_ARGS_ASSERT_MY_MEMRCHR;
1908
1909     while (t >= s) {
1910         if (*t == c) {
1911             return (void *) t;
1912         }
1913         t--;
1914     }
1915
1916     return NULL;
1917 }
1918
1919 #endif
1920
1921 /*
1922  * ex: set ts=8 sts=4 sw=4 et:
1923  */