This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Search for UTF-8 invariants by word
[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 0x8080808080808080
404 #    define PERL_WORD_BOUNDARY_MASK 0x7
405 #  else
406 #    error Unexpected word size
407 #  endif
408
409     /* Process per-byte until reach word boundary.  XXX This loop could be
410      * eliminated if we knew that this platform had fast unaligned reads */
411     while (x < send && (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK)) {
412         if (! UTF8_IS_INVARIANT(*x)) {
413             if (ep) {
414                 *ep = x;
415             }
416
417             return FALSE;
418         }
419         x++;
420     }
421
422     /* Process per-word as long as we have at least a full word left */
423     while (x + PERL_WORDSIZE <= send) {
424         if ((* (PERL_WORDCAST *) x) & PERL_VARIANTS_WORD_MASK)  {
425
426             /* Found a variant.  Just return if caller doesn't want its exact
427              * position */
428             if (! ep) {
429                 return FALSE;
430             }
431
432             /* Otherwise fall into final loop to find which byte it is */
433             break;
434         }
435         x += PERL_WORDSIZE;
436     }
437
438 #  undef PERL_WORDCAST
439 #  undef PERL_WORDSIZE
440 #  undef PERL_WORD_BOUNDARY_MASK
441 #  undef PERL_VARIANTS_WORD_MASK
442 #endif
443
444     /* Process per-byte */
445     while (x < send) {
446         if (! UTF8_IS_INVARIANT(*x)) {
447             if (ep) {
448                 *ep = x;
449             }
450
451             return FALSE;
452         }
453
454         x++;
455     }
456
457     return TRUE;
458 }
459
460 /*
461 =for apidoc is_utf8_string
462
463 Returns TRUE if the first C<len> bytes of string C<s> form a valid
464 Perl-extended-UTF-8 string; returns FALSE otherwise.  If C<len> is 0, it will
465 be calculated using C<strlen(s)> (which means if you use this option, that C<s>
466 can't have embedded C<NUL> characters and has to have a terminating C<NUL>
467 byte).  Note that all characters being ASCII constitute 'a valid UTF-8 string'.
468
469 This function considers Perl's extended UTF-8 to be valid.  That means that
470 code points above Unicode, surrogates, and non-character code points are
471 considered valid by this function.  Use C<L</is_strict_utf8_string>>,
472 C<L</is_c9strict_utf8_string>>, or C<L</is_utf8_string_flags>> to restrict what
473 code points are considered valid.
474
475 See also
476 C<L</is_utf8_invariant_string>>,
477 C<L</is_utf8_invariant_string_loc>>,
478 C<L</is_utf8_string_loc>>,
479 C<L</is_utf8_string_loclen>>,
480 C<L</is_utf8_fixed_width_buf_flags>>,
481 C<L</is_utf8_fixed_width_buf_loc_flags>>,
482 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
483
484 =cut
485 */
486
487 PERL_STATIC_INLINE bool
488 Perl_is_utf8_string(const U8 *s, const STRLEN len)
489 {
490     /* This is now marked pure in embed.fnc, because isUTF8_CHAR now is pure.
491      * Be aware of possible changes to that */
492
493     const U8* const send = s + (len ? len : strlen((const char *)s));
494     const U8* x = s;
495
496     PERL_ARGS_ASSERT_IS_UTF8_STRING;
497
498     while (x < send) {
499         const STRLEN cur_len = isUTF8_CHAR(x, send);
500         if (UNLIKELY(! cur_len)) {
501             return FALSE;
502         }
503         x += cur_len;
504     }
505
506     return TRUE;
507 }
508
509 /*
510 =for apidoc is_strict_utf8_string
511
512 Returns TRUE if the first C<len> bytes of string C<s> form a valid
513 UTF-8-encoded string that is fully interchangeable by any application using
514 Unicode rules; otherwise it returns FALSE.  If C<len> is 0, it will be
515 calculated using C<strlen(s)> (which means if you use this option, that C<s>
516 can't have embedded C<NUL> characters and has to have a terminating C<NUL>
517 byte).  Note that all characters being ASCII constitute 'a valid UTF-8 string'.
518
519 This function returns FALSE for strings containing any
520 code points above the Unicode max of 0x10FFFF, surrogate code points, or
521 non-character code points.
522
523 See also
524 C<L</is_utf8_invariant_string>>,
525 C<L</is_utf8_invariant_string_loc>>,
526 C<L</is_utf8_string>>,
527 C<L</is_utf8_string_flags>>,
528 C<L</is_utf8_string_loc>>,
529 C<L</is_utf8_string_loc_flags>>,
530 C<L</is_utf8_string_loclen>>,
531 C<L</is_utf8_string_loclen_flags>>,
532 C<L</is_utf8_fixed_width_buf_flags>>,
533 C<L</is_utf8_fixed_width_buf_loc_flags>>,
534 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
535 C<L</is_strict_utf8_string_loc>>,
536 C<L</is_strict_utf8_string_loclen>>,
537 C<L</is_c9strict_utf8_string>>,
538 C<L</is_c9strict_utf8_string_loc>>,
539 and
540 C<L</is_c9strict_utf8_string_loclen>>.
541
542 =cut
543 */
544
545 PERL_STATIC_INLINE bool
546 S_is_strict_utf8_string(const U8 *s, const STRLEN len)
547 {
548     const U8* const send = s + (len ? len : strlen((const char *)s));
549     const U8* x = s;
550
551     PERL_ARGS_ASSERT_IS_STRICT_UTF8_STRING;
552
553     while (x < send) {
554         const STRLEN cur_len = isSTRICT_UTF8_CHAR(x, send);
555         if (UNLIKELY(! cur_len)) {
556             return FALSE;
557         }
558         x += cur_len;
559     }
560
561     return TRUE;
562 }
563
564 /*
565 =for apidoc is_c9strict_utf8_string
566
567 Returns TRUE if the first C<len> bytes of string C<s> form a valid
568 UTF-8-encoded string that conforms to
569 L<Unicode Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>;
570 otherwise it returns FALSE.  If C<len> is 0, it will be calculated using
571 C<strlen(s)> (which means if you use this option, that C<s> can't have embedded
572 C<NUL> characters and has to have a terminating C<NUL> byte).  Note that all
573 characters being ASCII constitute 'a valid UTF-8 string'.
574
575 This function returns FALSE for strings containing any code points above the
576 Unicode max of 0x10FFFF or surrogate code points, but accepts non-character
577 code points per
578 L<Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>.
579
580 See also
581 C<L</is_utf8_invariant_string>>,
582 C<L</is_utf8_invariant_string_loc>>,
583 C<L</is_utf8_string>>,
584 C<L</is_utf8_string_flags>>,
585 C<L</is_utf8_string_loc>>,
586 C<L</is_utf8_string_loc_flags>>,
587 C<L</is_utf8_string_loclen>>,
588 C<L</is_utf8_string_loclen_flags>>,
589 C<L</is_utf8_fixed_width_buf_flags>>,
590 C<L</is_utf8_fixed_width_buf_loc_flags>>,
591 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
592 C<L</is_strict_utf8_string>>,
593 C<L</is_strict_utf8_string_loc>>,
594 C<L</is_strict_utf8_string_loclen>>,
595 C<L</is_c9strict_utf8_string_loc>>,
596 and
597 C<L</is_c9strict_utf8_string_loclen>>.
598
599 =cut
600 */
601
602 PERL_STATIC_INLINE bool
603 S_is_c9strict_utf8_string(const U8 *s, const STRLEN len)
604 {
605     const U8* const send = s + (len ? len : strlen((const char *)s));
606     const U8* x = s;
607
608     PERL_ARGS_ASSERT_IS_C9STRICT_UTF8_STRING;
609
610     while (x < send) {
611         const STRLEN cur_len = isC9_STRICT_UTF8_CHAR(x, send);
612         if (UNLIKELY(! cur_len)) {
613             return FALSE;
614         }
615         x += cur_len;
616     }
617
618     return TRUE;
619 }
620
621 /* The above 3 functions could have been moved into the more general one just
622  * below, and made #defines that call it with the right 'flags'.  They are
623  * currently kept separate to increase their chances of getting inlined */
624
625 /*
626 =for apidoc is_utf8_string_flags
627
628 Returns TRUE if the first C<len> bytes of string C<s> form a valid
629 UTF-8 string, subject to the restrictions imposed by C<flags>;
630 returns FALSE otherwise.  If C<len> is 0, it will be calculated
631 using C<strlen(s)> (which means if you use this option, that C<s> can't have
632 embedded C<NUL> characters and has to have a terminating C<NUL> byte).  Note
633 that all characters being ASCII constitute 'a valid UTF-8 string'.
634
635 If C<flags> is 0, this gives the same results as C<L</is_utf8_string>>; if
636 C<flags> is C<UTF8_DISALLOW_ILLEGAL_INTERCHANGE>, this gives the same results
637 as C<L</is_strict_utf8_string>>; and if C<flags> is
638 C<UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE>, this gives the same results as
639 C<L</is_c9strict_utf8_string>>.  Otherwise C<flags> may be any
640 combination of the C<UTF8_DISALLOW_I<foo>> flags understood by
641 C<L</utf8n_to_uvchr>>, with the same meanings.
642
643 See also
644 C<L</is_utf8_invariant_string>>,
645 C<L</is_utf8_invariant_string_loc>>,
646 C<L</is_utf8_string>>,
647 C<L</is_utf8_string_loc>>,
648 C<L</is_utf8_string_loc_flags>>,
649 C<L</is_utf8_string_loclen>>,
650 C<L</is_utf8_string_loclen_flags>>,
651 C<L</is_utf8_fixed_width_buf_flags>>,
652 C<L</is_utf8_fixed_width_buf_loc_flags>>,
653 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
654 C<L</is_strict_utf8_string>>,
655 C<L</is_strict_utf8_string_loc>>,
656 C<L</is_strict_utf8_string_loclen>>,
657 C<L</is_c9strict_utf8_string>>,
658 C<L</is_c9strict_utf8_string_loc>>,
659 and
660 C<L</is_c9strict_utf8_string_loclen>>.
661
662 =cut
663 */
664
665 PERL_STATIC_INLINE bool
666 S_is_utf8_string_flags(const U8 *s, const STRLEN len, const U32 flags)
667 {
668     const U8* const send = s + (len ? len : strlen((const char *)s));
669     const U8* x = s;
670
671     PERL_ARGS_ASSERT_IS_UTF8_STRING_FLAGS;
672     assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
673                           |UTF8_DISALLOW_PERL_EXTENDED)));
674
675     if (flags == 0) {
676         return is_utf8_string(s, len);
677     }
678
679     if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
680                                         == UTF8_DISALLOW_ILLEGAL_INTERCHANGE)
681     {
682         return is_strict_utf8_string(s, len);
683     }
684
685     if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
686                                        == UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE)
687     {
688         return is_c9strict_utf8_string(s, len);
689     }
690
691     while (x < send) {
692         STRLEN cur_len = isUTF8_CHAR_flags(x, send, flags);
693         if (UNLIKELY(! cur_len)) {
694             return FALSE;
695         }
696         x += cur_len;
697     }
698
699     return TRUE;
700 }
701
702 /*
703
704 =for apidoc is_utf8_string_loc
705
706 Like C<L</is_utf8_string>> but stores the location of the failure (in the
707 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
708 "utf8ness success") in the C<ep> pointer.
709
710 See also C<L</is_utf8_string_loclen>>.
711
712 =cut
713 */
714
715 #define is_utf8_string_loc(s, len, ep)  is_utf8_string_loclen(s, len, ep, 0)
716
717 /*
718
719 =for apidoc is_utf8_string_loclen
720
721 Like C<L</is_utf8_string>> but stores the location of the failure (in the
722 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
723 "utf8ness success") in the C<ep> pointer, and the number of UTF-8
724 encoded characters in the C<el> pointer.
725
726 See also C<L</is_utf8_string_loc>>.
727
728 =cut
729 */
730
731 PERL_STATIC_INLINE bool
732 Perl_is_utf8_string_loclen(const U8 *s, const STRLEN len, const U8 **ep, STRLEN *el)
733 {
734     const U8* const send = s + (len ? len : strlen((const char *)s));
735     const U8* x = s;
736     STRLEN outlen = 0;
737
738     PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN;
739
740     while (x < send) {
741         const STRLEN cur_len = isUTF8_CHAR(x, send);
742         if (UNLIKELY(! cur_len)) {
743             break;
744         }
745         x += cur_len;
746         outlen++;
747     }
748
749     if (el)
750         *el = outlen;
751
752     if (ep) {
753         *ep = x;
754     }
755
756     return (x == send);
757 }
758
759 /*
760
761 =for apidoc is_strict_utf8_string_loc
762
763 Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
764 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
765 "utf8ness success") in the C<ep> pointer.
766
767 See also C<L</is_strict_utf8_string_loclen>>.
768
769 =cut
770 */
771
772 #define is_strict_utf8_string_loc(s, len, ep)                               \
773                                 is_strict_utf8_string_loclen(s, len, ep, 0)
774
775 /*
776
777 =for apidoc is_strict_utf8_string_loclen
778
779 Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
780 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
781 "utf8ness success") in the C<ep> pointer, and the number of UTF-8
782 encoded characters in the C<el> pointer.
783
784 See also C<L</is_strict_utf8_string_loc>>.
785
786 =cut
787 */
788
789 PERL_STATIC_INLINE bool
790 S_is_strict_utf8_string_loclen(const U8 *s, const STRLEN len, const U8 **ep, STRLEN *el)
791 {
792     const U8* const send = s + (len ? len : strlen((const char *)s));
793     const U8* x = s;
794     STRLEN outlen = 0;
795
796     PERL_ARGS_ASSERT_IS_STRICT_UTF8_STRING_LOCLEN;
797
798     while (x < send) {
799         const STRLEN cur_len = isSTRICT_UTF8_CHAR(x, send);
800         if (UNLIKELY(! cur_len)) {
801             break;
802         }
803         x += cur_len;
804         outlen++;
805     }
806
807     if (el)
808         *el = outlen;
809
810     if (ep) {
811         *ep = x;
812     }
813
814     return (x == send);
815 }
816
817 /*
818
819 =for apidoc is_c9strict_utf8_string_loc
820
821 Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in
822 the case of "utf8ness failure") or the location C<s>+C<len> (in the case of
823 "utf8ness success") in the C<ep> pointer.
824
825 See also C<L</is_c9strict_utf8_string_loclen>>.
826
827 =cut
828 */
829
830 #define is_c9strict_utf8_string_loc(s, len, ep)                             \
831                             is_c9strict_utf8_string_loclen(s, len, ep, 0)
832
833 /*
834
835 =for apidoc is_c9strict_utf8_string_loclen
836
837 Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in
838 the case of "utf8ness failure") or the location C<s>+C<len> (in the case of
839 "utf8ness success") in the C<ep> pointer, and the number of UTF-8 encoded
840 characters in the C<el> pointer.
841
842 See also C<L</is_c9strict_utf8_string_loc>>.
843
844 =cut
845 */
846
847 PERL_STATIC_INLINE bool
848 S_is_c9strict_utf8_string_loclen(const U8 *s, const STRLEN len, const U8 **ep, STRLEN *el)
849 {
850     const U8* const send = s + (len ? len : strlen((const char *)s));
851     const U8* x = s;
852     STRLEN outlen = 0;
853
854     PERL_ARGS_ASSERT_IS_C9STRICT_UTF8_STRING_LOCLEN;
855
856     while (x < send) {
857         const STRLEN cur_len = isC9_STRICT_UTF8_CHAR(x, send);
858         if (UNLIKELY(! cur_len)) {
859             break;
860         }
861         x += cur_len;
862         outlen++;
863     }
864
865     if (el)
866         *el = outlen;
867
868     if (ep) {
869         *ep = x;
870     }
871
872     return (x == send);
873 }
874
875 /*
876
877 =for apidoc is_utf8_string_loc_flags
878
879 Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the
880 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
881 "utf8ness success") in the C<ep> pointer.
882
883 See also C<L</is_utf8_string_loclen_flags>>.
884
885 =cut
886 */
887
888 #define is_utf8_string_loc_flags(s, len, ep, flags)                         \
889                         is_utf8_string_loclen_flags(s, len, ep, 0, flags)
890
891
892 /* The above 3 actual functions could have been moved into the more general one
893  * just below, and made #defines that call it with the right 'flags'.  They are
894  * currently kept separate to increase their chances of getting inlined */
895
896 /*
897
898 =for apidoc is_utf8_string_loclen_flags
899
900 Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the
901 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
902 "utf8ness success") in the C<ep> pointer, and the number of UTF-8
903 encoded characters in the C<el> pointer.
904
905 See also C<L</is_utf8_string_loc_flags>>.
906
907 =cut
908 */
909
910 PERL_STATIC_INLINE bool
911 S_is_utf8_string_loclen_flags(const U8 *s, const STRLEN len, const U8 **ep, STRLEN *el, const U32 flags)
912 {
913     const U8* const send = s + (len ? len : strlen((const char *)s));
914     const U8* x = s;
915     STRLEN outlen = 0;
916
917     PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN_FLAGS;
918     assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
919                           |UTF8_DISALLOW_PERL_EXTENDED)));
920
921     if (flags == 0) {
922         return is_utf8_string_loclen(s, len, ep, el);
923     }
924
925     if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
926                                         == UTF8_DISALLOW_ILLEGAL_INTERCHANGE)
927     {
928         return is_strict_utf8_string_loclen(s, len, ep, el);
929     }
930
931     if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
932                                     == UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE)
933     {
934         return is_c9strict_utf8_string_loclen(s, len, ep, el);
935     }
936
937     while (x < send) {
938         const STRLEN cur_len = isUTF8_CHAR_flags(x, send, flags);
939         if (UNLIKELY(! cur_len)) {
940             break;
941         }
942         x += cur_len;
943         outlen++;
944     }
945
946     if (el)
947         *el = outlen;
948
949     if (ep) {
950         *ep = x;
951     }
952
953     return (x == send);
954 }
955
956 /*
957 =for apidoc utf8_distance
958
959 Returns the number of UTF-8 characters between the UTF-8 pointers C<a>
960 and C<b>.
961
962 WARNING: use only if you *know* that the pointers point inside the
963 same UTF-8 buffer.
964
965 =cut
966 */
967
968 PERL_STATIC_INLINE IV
969 Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b)
970 {
971     PERL_ARGS_ASSERT_UTF8_DISTANCE;
972
973     return (a < b) ? -1 * (IV) utf8_length(a, b) : (IV) utf8_length(b, a);
974 }
975
976 /*
977 =for apidoc utf8_hop
978
979 Return the UTF-8 pointer C<s> displaced by C<off> characters, either
980 forward or backward.
981
982 WARNING: do not use the following unless you *know* C<off> is within
983 the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
984 on the first byte of character or just after the last byte of a character.
985
986 =cut
987 */
988
989 PERL_STATIC_INLINE U8 *
990 Perl_utf8_hop(const U8 *s, SSize_t off)
991 {
992     PERL_ARGS_ASSERT_UTF8_HOP;
993
994     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
995      * the bitops (especially ~) can create illegal UTF-8.
996      * In other words: in Perl UTF-8 is not just for Unicode. */
997
998     if (off >= 0) {
999         while (off--)
1000             s += UTF8SKIP(s);
1001     }
1002     else {
1003         while (off++) {
1004             s--;
1005             while (UTF8_IS_CONTINUATION(*s))
1006                 s--;
1007         }
1008     }
1009     GCC_DIAG_IGNORE(-Wcast-qual);
1010     return (U8 *)s;
1011     GCC_DIAG_RESTORE;
1012 }
1013
1014 /*
1015 =for apidoc utf8_hop_forward
1016
1017 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1018 forward.
1019
1020 C<off> must be non-negative.
1021
1022 C<s> must be before or equal to C<end>.
1023
1024 When moving forward it will not move beyond C<end>.
1025
1026 Will not exceed this limit even if the string is not valid "UTF-8".
1027
1028 =cut
1029 */
1030
1031 PERL_STATIC_INLINE U8 *
1032 Perl_utf8_hop_forward(const U8 *s, SSize_t off, const U8 *end)
1033 {
1034     PERL_ARGS_ASSERT_UTF8_HOP_FORWARD;
1035
1036     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1037      * the bitops (especially ~) can create illegal UTF-8.
1038      * In other words: in Perl UTF-8 is not just for Unicode. */
1039
1040     assert(s <= end);
1041     assert(off >= 0);
1042
1043     while (off--) {
1044         STRLEN skip = UTF8SKIP(s);
1045         if ((STRLEN)(end - s) <= skip) {
1046             GCC_DIAG_IGNORE(-Wcast-qual);
1047             return (U8 *)end;
1048             GCC_DIAG_RESTORE;
1049         }
1050         s += skip;
1051     }
1052
1053     GCC_DIAG_IGNORE(-Wcast-qual);
1054     return (U8 *)s;
1055     GCC_DIAG_RESTORE;
1056 }
1057
1058 /*
1059 =for apidoc utf8_hop_back
1060
1061 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1062 backward.
1063
1064 C<off> must be non-positive.
1065
1066 C<s> must be after or equal to C<start>.
1067
1068 When moving backward it will not move before C<start>.
1069
1070 Will not exceed this limit even if the string is not valid "UTF-8".
1071
1072 =cut
1073 */
1074
1075 PERL_STATIC_INLINE U8 *
1076 Perl_utf8_hop_back(const U8 *s, SSize_t off, const U8 *start)
1077 {
1078     PERL_ARGS_ASSERT_UTF8_HOP_BACK;
1079
1080     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1081      * the bitops (especially ~) can create illegal UTF-8.
1082      * In other words: in Perl UTF-8 is not just for Unicode. */
1083
1084     assert(start <= s);
1085     assert(off <= 0);
1086
1087     while (off++ && s > start) {
1088         s--;
1089         while (UTF8_IS_CONTINUATION(*s) && s > start)
1090             s--;
1091     }
1092     
1093     GCC_DIAG_IGNORE(-Wcast-qual);
1094     return (U8 *)s;
1095     GCC_DIAG_RESTORE;
1096 }
1097
1098 /*
1099 =for apidoc utf8_hop_safe
1100
1101 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1102 either forward or backward.
1103
1104 When moving backward it will not move before C<start>.
1105
1106 When moving forward it will not move beyond C<end>.
1107
1108 Will not exceed those limits even if the string is not valid "UTF-8".
1109
1110 =cut
1111 */
1112
1113 PERL_STATIC_INLINE U8 *
1114 Perl_utf8_hop_safe(const U8 *s, SSize_t off, const U8 *start, const U8 *end)
1115 {
1116     PERL_ARGS_ASSERT_UTF8_HOP_SAFE;
1117
1118     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1119      * the bitops (especially ~) can create illegal UTF-8.
1120      * In other words: in Perl UTF-8 is not just for Unicode. */
1121
1122     assert(start <= s && s <= end);
1123
1124     if (off >= 0) {
1125         return utf8_hop_forward(s, off, end);
1126     }
1127     else {
1128         return utf8_hop_back(s, off, start);
1129     }
1130 }
1131
1132 /*
1133
1134 =for apidoc is_utf8_valid_partial_char
1135
1136 Returns 0 if the sequence of bytes starting at C<s> and looking no further than
1137 S<C<e - 1>> is the UTF-8 encoding, as extended by Perl, for one or more code
1138 points.  Otherwise, it returns 1 if there exists at least one non-empty
1139 sequence of bytes that when appended to sequence C<s>, starting at position
1140 C<e> causes the entire sequence to be the well-formed UTF-8 of some code point;
1141 otherwise returns 0.
1142
1143 In other words this returns TRUE if C<s> points to a partial UTF-8-encoded code
1144 point.
1145
1146 This is useful when a fixed-length buffer is being tested for being well-formed
1147 UTF-8, but the final few bytes in it don't comprise a full character; that is,
1148 it is split somewhere in the middle of the final code point's UTF-8
1149 representation.  (Presumably when the buffer is refreshed with the next chunk
1150 of data, the new first bytes will complete the partial code point.)   This
1151 function is used to verify that the final bytes in the current buffer are in
1152 fact the legal beginning of some code point, so that if they aren't, the
1153 failure can be signalled without having to wait for the next read.
1154
1155 =cut
1156 */
1157 #define is_utf8_valid_partial_char(s, e)                                    \
1158                                 is_utf8_valid_partial_char_flags(s, e, 0)
1159
1160 /*
1161
1162 =for apidoc is_utf8_valid_partial_char_flags
1163
1164 Like C<L</is_utf8_valid_partial_char>>, it returns a boolean giving whether
1165 or not the input is a valid UTF-8 encoded partial character, but it takes an
1166 extra parameter, C<flags>, which can further restrict which code points are
1167 considered valid.
1168
1169 If C<flags> is 0, this behaves identically to
1170 C<L</is_utf8_valid_partial_char>>.  Otherwise C<flags> can be any combination
1171 of the C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>.  If
1172 there is any sequence of bytes that can complete the input partial character in
1173 such a way that a non-prohibited character is formed, the function returns
1174 TRUE; otherwise FALSE.  Non character code points cannot be determined based on
1175 partial character input.  But many  of the other possible excluded types can be
1176 determined from just the first one or two bytes.
1177
1178 =cut
1179  */
1180
1181 PERL_STATIC_INLINE bool
1182 S_is_utf8_valid_partial_char_flags(const U8 * const s, const U8 * const e, const U32 flags)
1183 {
1184     PERL_ARGS_ASSERT_IS_UTF8_VALID_PARTIAL_CHAR_FLAGS;
1185
1186     assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
1187                           |UTF8_DISALLOW_PERL_EXTENDED)));
1188
1189     if (s >= e || s + UTF8SKIP(s) <= e) {
1190         return FALSE;
1191     }
1192
1193     return cBOOL(_is_utf8_char_helper(s, e, flags));
1194 }
1195
1196 /*
1197
1198 =for apidoc is_utf8_fixed_width_buf_flags
1199
1200 Returns TRUE if the fixed-width buffer starting at C<s> with length C<len>
1201 is entirely valid UTF-8, subject to the restrictions given by C<flags>;
1202 otherwise it returns FALSE.
1203
1204 If C<flags> is 0, any well-formed UTF-8, as extended by Perl, is accepted
1205 without restriction.  If the final few bytes of the buffer do not form a
1206 complete code point, this will return TRUE anyway, provided that
1207 C<L</is_utf8_valid_partial_char_flags>> returns TRUE for them.
1208
1209 If C<flags> in non-zero, it can be any combination of the
1210 C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>, and with the
1211 same meanings.
1212
1213 This function differs from C<L</is_utf8_string_flags>> only in that the latter
1214 returns FALSE if the final few bytes of the string don't form a complete code
1215 point.
1216
1217 =cut
1218  */
1219 #define is_utf8_fixed_width_buf_flags(s, len, flags)                        \
1220                 is_utf8_fixed_width_buf_loclen_flags(s, len, 0, 0, flags)
1221
1222 /*
1223
1224 =for apidoc is_utf8_fixed_width_buf_loc_flags
1225
1226 Like C<L</is_utf8_fixed_width_buf_flags>> but stores the location of the
1227 failure in the C<ep> pointer.  If the function returns TRUE, C<*ep> will point
1228 to the beginning of any partial character at the end of the buffer; if there is
1229 no partial character C<*ep> will contain C<s>+C<len>.
1230
1231 See also C<L</is_utf8_fixed_width_buf_loclen_flags>>.
1232
1233 =cut
1234 */
1235
1236 #define is_utf8_fixed_width_buf_loc_flags(s, len, loc, flags)               \
1237                 is_utf8_fixed_width_buf_loclen_flags(s, len, loc, 0, flags)
1238
1239 /*
1240
1241 =for apidoc is_utf8_fixed_width_buf_loclen_flags
1242
1243 Like C<L</is_utf8_fixed_width_buf_loc_flags>> but stores the number of
1244 complete, valid characters found in the C<el> pointer.
1245
1246 =cut
1247 */
1248
1249 PERL_STATIC_INLINE bool
1250 S_is_utf8_fixed_width_buf_loclen_flags(const U8 * const s,
1251                                        const STRLEN len,
1252                                        const U8 **ep,
1253                                        STRLEN *el,
1254                                        const U32 flags)
1255 {
1256     const U8 * maybe_partial;
1257
1258     PERL_ARGS_ASSERT_IS_UTF8_FIXED_WIDTH_BUF_LOCLEN_FLAGS;
1259
1260     if (! ep) {
1261         ep  = &maybe_partial;
1262     }
1263
1264     /* If it's entirely valid, return that; otherwise see if the only error is
1265      * that the final few bytes are for a partial character */
1266     return    is_utf8_string_loclen_flags(s, len, ep, el, flags)
1267            || is_utf8_valid_partial_char_flags(*ep, s + len, flags);
1268 }
1269
1270 /* ------------------------------- perl.h ----------------------------- */
1271
1272 /*
1273 =head1 Miscellaneous Functions
1274
1275 =for apidoc AiR|bool|is_safe_syscall|const char *pv|STRLEN len|const char *what|const char *op_name
1276
1277 Test that the given C<pv> doesn't contain any internal C<NUL> characters.
1278 If it does, set C<errno> to C<ENOENT>, optionally warn, and return FALSE.
1279
1280 Return TRUE if the name is safe.
1281
1282 Used by the C<IS_SAFE_SYSCALL()> macro.
1283
1284 =cut
1285 */
1286
1287 PERL_STATIC_INLINE bool
1288 S_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name) {
1289     /* While the Windows CE API provides only UCS-16 (or UTF-16) APIs
1290      * perl itself uses xce*() functions which accept 8-bit strings.
1291      */
1292
1293     PERL_ARGS_ASSERT_IS_SAFE_SYSCALL;
1294
1295     if (len > 1) {
1296         char *null_at;
1297         if (UNLIKELY((null_at = (char *)memchr(pv, 0, len-1)) != NULL)) {
1298                 SETERRNO(ENOENT, LIB_INVARG);
1299                 Perl_ck_warner(aTHX_ packWARN(WARN_SYSCALLS),
1300                                    "Invalid \\0 character in %s for %s: %s\\0%s",
1301                                    what, op_name, pv, null_at+1);
1302                 return FALSE;
1303         }
1304     }
1305
1306     return TRUE;
1307 }
1308
1309 /*
1310
1311 Return true if the supplied filename has a newline character
1312 immediately before the first (hopefully only) NUL.
1313
1314 My original look at this incorrectly used the len from SvPV(), but
1315 that's incorrect, since we allow for a NUL in pv[len-1].
1316
1317 So instead, strlen() and work from there.
1318
1319 This allow for the user reading a filename, forgetting to chomp it,
1320 then calling:
1321
1322   open my $foo, "$file\0";
1323
1324 */
1325
1326 #ifdef PERL_CORE
1327
1328 PERL_STATIC_INLINE bool
1329 S_should_warn_nl(const char *pv) {
1330     STRLEN len;
1331
1332     PERL_ARGS_ASSERT_SHOULD_WARN_NL;
1333
1334     len = strlen(pv);
1335
1336     return len > 0 && pv[len-1] == '\n';
1337 }
1338
1339 #endif
1340
1341 /* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */
1342
1343 #define MAX_CHARSET_NAME_LENGTH 2
1344
1345 PERL_STATIC_INLINE const char *
1346 get_regex_charset_name(const U32 flags, STRLEN* const lenp)
1347 {
1348     /* Returns a string that corresponds to the name of the regex character set
1349      * given by 'flags', and *lenp is set the length of that string, which
1350      * cannot exceed MAX_CHARSET_NAME_LENGTH characters */
1351
1352     *lenp = 1;
1353     switch (get_regex_charset(flags)) {
1354         case REGEX_DEPENDS_CHARSET: return DEPENDS_PAT_MODS;
1355         case REGEX_LOCALE_CHARSET:  return LOCALE_PAT_MODS;
1356         case REGEX_UNICODE_CHARSET: return UNICODE_PAT_MODS;
1357         case REGEX_ASCII_RESTRICTED_CHARSET: return ASCII_RESTRICT_PAT_MODS;
1358         case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
1359             *lenp = 2;
1360             return ASCII_MORE_RESTRICT_PAT_MODS;
1361     }
1362     /* The NOT_REACHED; hides an assert() which has a rather complex
1363      * definition in perl.h. */
1364     NOT_REACHED; /* NOTREACHED */
1365     return "?";     /* Unknown */
1366 }
1367
1368 /*
1369
1370 Return false if any get magic is on the SV other than taint magic.
1371
1372 */
1373
1374 PERL_STATIC_INLINE bool
1375 S_sv_only_taint_gmagic(SV *sv) {
1376     MAGIC *mg = SvMAGIC(sv);
1377
1378     PERL_ARGS_ASSERT_SV_ONLY_TAINT_GMAGIC;
1379
1380     while (mg) {
1381         if (mg->mg_type != PERL_MAGIC_taint
1382             && !(mg->mg_flags & MGf_GSKIP)
1383             && mg->mg_virtual->svt_get) {
1384             return FALSE;
1385         }
1386         mg = mg->mg_moremagic;
1387     }
1388
1389     return TRUE;
1390 }
1391
1392 /* ------------------ cop.h ------------------------------------------- */
1393
1394
1395 /* Enter a block. Push a new base context and return its address. */
1396
1397 PERL_STATIC_INLINE PERL_CONTEXT *
1398 S_cx_pushblock(pTHX_ U8 type, U8 gimme, SV** sp, I32 saveix)
1399 {
1400     PERL_CONTEXT * cx;
1401
1402     PERL_ARGS_ASSERT_CX_PUSHBLOCK;
1403
1404     CXINC;
1405     cx = CX_CUR();
1406     cx->cx_type        = type;
1407     cx->blk_gimme      = gimme;
1408     cx->blk_oldsaveix  = saveix;
1409     cx->blk_oldsp      = (I32)(sp - PL_stack_base);
1410     cx->blk_oldcop     = PL_curcop;
1411     cx->blk_oldmarksp  = (I32)(PL_markstack_ptr - PL_markstack);
1412     cx->blk_oldscopesp = PL_scopestack_ix;
1413     cx->blk_oldpm      = PL_curpm;
1414     cx->blk_old_tmpsfloor = PL_tmps_floor;
1415
1416     PL_tmps_floor        = PL_tmps_ix;
1417     CX_DEBUG(cx, "PUSH");
1418     return cx;
1419 }
1420
1421
1422 /* Exit a block (RETURN and LAST). */
1423
1424 PERL_STATIC_INLINE void
1425 S_cx_popblock(pTHX_ PERL_CONTEXT *cx)
1426 {
1427     PERL_ARGS_ASSERT_CX_POPBLOCK;
1428
1429     CX_DEBUG(cx, "POP");
1430     /* these 3 are common to cx_popblock and cx_topblock */
1431     PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
1432     PL_scopestack_ix = cx->blk_oldscopesp;
1433     PL_curpm         = cx->blk_oldpm;
1434
1435     /* LEAVE_SCOPE() should have made this true. /(?{})/ cheats
1436      * and leaves a CX entry lying around for repeated use, so
1437      * skip for multicall */                  \
1438     assert(   (CxTYPE(cx) == CXt_SUB && CxMULTICALL(cx))
1439             || PL_savestack_ix == cx->blk_oldsaveix);
1440     PL_curcop     = cx->blk_oldcop;
1441     PL_tmps_floor = cx->blk_old_tmpsfloor;
1442 }
1443
1444 /* Continue a block elsewhere (e.g. NEXT, REDO, GOTO).
1445  * Whereas cx_popblock() restores the state to the point just before
1446  * cx_pushblock() was called,  cx_topblock() restores it to the point just
1447  * *after* cx_pushblock() was called. */
1448
1449 PERL_STATIC_INLINE void
1450 S_cx_topblock(pTHX_ PERL_CONTEXT *cx)
1451 {
1452     PERL_ARGS_ASSERT_CX_TOPBLOCK;
1453
1454     CX_DEBUG(cx, "TOP");
1455     /* these 3 are common to cx_popblock and cx_topblock */
1456     PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
1457     PL_scopestack_ix = cx->blk_oldscopesp;
1458     PL_curpm         = cx->blk_oldpm;
1459
1460     PL_stack_sp      = PL_stack_base + cx->blk_oldsp;
1461 }
1462
1463
1464 PERL_STATIC_INLINE void
1465 S_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs)
1466 {
1467     U8 phlags = CX_PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub);
1468
1469     PERL_ARGS_ASSERT_CX_PUSHSUB;
1470
1471     PERL_DTRACE_PROBE_ENTRY(cv);
1472     cx->blk_sub.cv = cv;
1473     cx->blk_sub.olddepth = CvDEPTH(cv);
1474     cx->blk_sub.prevcomppad = PL_comppad;
1475     cx->cx_type |= (hasargs) ? CXp_HASARGS : 0;
1476     cx->blk_sub.retop = retop;
1477     SvREFCNT_inc_simple_void_NN(cv);
1478     cx->blk_u16 = PL_op->op_private & (phlags|OPpDEREF);
1479 }
1480
1481
1482 /* subsets of cx_popsub() */
1483
1484 PERL_STATIC_INLINE void
1485 S_cx_popsub_common(pTHX_ PERL_CONTEXT *cx)
1486 {
1487     CV *cv;
1488
1489     PERL_ARGS_ASSERT_CX_POPSUB_COMMON;
1490     assert(CxTYPE(cx) == CXt_SUB);
1491
1492     PL_comppad = cx->blk_sub.prevcomppad;
1493     PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
1494     cv = cx->blk_sub.cv;
1495     CvDEPTH(cv) = cx->blk_sub.olddepth;
1496     cx->blk_sub.cv = NULL;
1497     SvREFCNT_dec(cv);
1498 }
1499
1500
1501 /* handle the @_ part of leaving a sub */
1502
1503 PERL_STATIC_INLINE void
1504 S_cx_popsub_args(pTHX_ PERL_CONTEXT *cx)
1505 {
1506     AV *av;
1507
1508     PERL_ARGS_ASSERT_CX_POPSUB_ARGS;
1509     assert(CxTYPE(cx) == CXt_SUB);
1510     assert(AvARRAY(MUTABLE_AV(
1511         PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
1512                 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
1513
1514     CX_POP_SAVEARRAY(cx);
1515     av = MUTABLE_AV(PAD_SVl(0));
1516     if (UNLIKELY(AvREAL(av)))
1517         /* abandon @_ if it got reified */
1518         clear_defarray(av, 0);
1519     else {
1520         CLEAR_ARGARRAY(av);
1521     }
1522 }
1523
1524
1525 PERL_STATIC_INLINE void
1526 S_cx_popsub(pTHX_ PERL_CONTEXT *cx)
1527 {
1528     PERL_ARGS_ASSERT_CX_POPSUB;
1529     assert(CxTYPE(cx) == CXt_SUB);
1530
1531     PERL_DTRACE_PROBE_RETURN(cx->blk_sub.cv);
1532
1533     if (CxHASARGS(cx))
1534         cx_popsub_args(cx);
1535     cx_popsub_common(cx);
1536 }
1537
1538
1539 PERL_STATIC_INLINE void
1540 S_cx_pushformat(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, GV *gv)
1541 {
1542     PERL_ARGS_ASSERT_CX_PUSHFORMAT;
1543
1544     cx->blk_format.cv          = cv;
1545     cx->blk_format.retop       = retop;
1546     cx->blk_format.gv          = gv;
1547     cx->blk_format.dfoutgv     = PL_defoutgv;
1548     cx->blk_format.prevcomppad = PL_comppad;
1549     cx->blk_u16                = 0;
1550
1551     SvREFCNT_inc_simple_void_NN(cv);
1552     CvDEPTH(cv)++;
1553     SvREFCNT_inc_void(cx->blk_format.dfoutgv);
1554 }
1555
1556
1557 PERL_STATIC_INLINE void
1558 S_cx_popformat(pTHX_ PERL_CONTEXT *cx)
1559 {
1560     CV *cv;
1561     GV *dfout;
1562
1563     PERL_ARGS_ASSERT_CX_POPFORMAT;
1564     assert(CxTYPE(cx) == CXt_FORMAT);
1565
1566     dfout = cx->blk_format.dfoutgv;
1567     setdefout(dfout);
1568     cx->blk_format.dfoutgv = NULL;
1569     SvREFCNT_dec_NN(dfout);
1570
1571     PL_comppad = cx->blk_format.prevcomppad;
1572     PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
1573     cv = cx->blk_format.cv;
1574     cx->blk_format.cv = NULL;
1575     --CvDEPTH(cv);
1576     SvREFCNT_dec_NN(cv);
1577 }
1578
1579
1580 PERL_STATIC_INLINE void
1581 S_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv)
1582 {
1583     PERL_ARGS_ASSERT_CX_PUSHEVAL;
1584
1585     cx->blk_eval.retop         = retop;
1586     cx->blk_eval.old_namesv    = namesv;
1587     cx->blk_eval.old_eval_root = PL_eval_root;
1588     cx->blk_eval.cur_text      = PL_parser ? PL_parser->linestr : NULL;
1589     cx->blk_eval.cv            = NULL; /* later set by doeval_compile() */
1590     cx->blk_eval.cur_top_env   = PL_top_env;
1591
1592     assert(!(PL_in_eval     & ~ 0x3F));
1593     assert(!(PL_op->op_type & ~0x1FF));
1594     cx->blk_u16 = (PL_in_eval & 0x3F) | ((U16)PL_op->op_type << 7);
1595 }
1596
1597
1598 PERL_STATIC_INLINE void
1599 S_cx_popeval(pTHX_ PERL_CONTEXT *cx)
1600 {
1601     SV *sv;
1602
1603     PERL_ARGS_ASSERT_CX_POPEVAL;
1604     assert(CxTYPE(cx) == CXt_EVAL);
1605
1606     PL_in_eval = CxOLD_IN_EVAL(cx);
1607     assert(!(PL_in_eval & 0xc0));
1608     PL_eval_root = cx->blk_eval.old_eval_root;
1609     sv = cx->blk_eval.cur_text;
1610     if (sv && CxEVAL_TXT_REFCNTED(cx)) {
1611         cx->blk_eval.cur_text = NULL;
1612         SvREFCNT_dec_NN(sv);
1613     }
1614
1615     sv = cx->blk_eval.old_namesv;
1616     if (sv) {
1617         cx->blk_eval.old_namesv = NULL;
1618         SvREFCNT_dec_NN(sv);
1619     }
1620 }
1621
1622
1623 /* push a plain loop, i.e.
1624  *     { block }
1625  *     while (cond) { block }
1626  *     for (init;cond;continue) { block }
1627  * This loop can be last/redo'ed etc.
1628  */
1629
1630 PERL_STATIC_INLINE void
1631 S_cx_pushloop_plain(pTHX_ PERL_CONTEXT *cx)
1632 {
1633     PERL_ARGS_ASSERT_CX_PUSHLOOP_PLAIN;
1634     cx->blk_loop.my_op = cLOOP;
1635 }
1636
1637
1638 /* push a true for loop, i.e.
1639  *     for var (list) { block }
1640  */
1641
1642 PERL_STATIC_INLINE void
1643 S_cx_pushloop_for(pTHX_ PERL_CONTEXT *cx, void *itervarp, SV* itersave)
1644 {
1645     PERL_ARGS_ASSERT_CX_PUSHLOOP_FOR;
1646
1647     /* this one line is common with cx_pushloop_plain */
1648     cx->blk_loop.my_op = cLOOP;
1649
1650     cx->blk_loop.itervar_u.svp = (SV**)itervarp;
1651     cx->blk_loop.itersave      = itersave;
1652 #ifdef USE_ITHREADS
1653     cx->blk_loop.oldcomppad = PL_comppad;
1654 #endif
1655 }
1656
1657
1658 /* pop all loop types, including plain */
1659
1660 PERL_STATIC_INLINE void
1661 S_cx_poploop(pTHX_ PERL_CONTEXT *cx)
1662 {
1663     PERL_ARGS_ASSERT_CX_POPLOOP;
1664
1665     assert(CxTYPE_is_LOOP(cx));
1666     if (  CxTYPE(cx) == CXt_LOOP_ARY
1667        || CxTYPE(cx) == CXt_LOOP_LAZYSV)
1668     {
1669         /* Free ary or cur. This assumes that state_u.ary.ary
1670          * aligns with state_u.lazysv.cur. See cx_dup() */
1671         SV *sv = cx->blk_loop.state_u.lazysv.cur;
1672         cx->blk_loop.state_u.lazysv.cur = NULL;
1673         SvREFCNT_dec_NN(sv);
1674         if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1675             sv = cx->blk_loop.state_u.lazysv.end;
1676             cx->blk_loop.state_u.lazysv.end = NULL;
1677             SvREFCNT_dec_NN(sv);
1678         }
1679     }
1680     if (cx->cx_type & (CXp_FOR_PAD|CXp_FOR_GV)) {
1681         SV *cursv;
1682         SV **svp = (cx)->blk_loop.itervar_u.svp;
1683         if ((cx->cx_type & CXp_FOR_GV))
1684             svp = &GvSV((GV*)svp);
1685         cursv = *svp;
1686         *svp = cx->blk_loop.itersave;
1687         cx->blk_loop.itersave = NULL;
1688         SvREFCNT_dec(cursv);
1689     }
1690 }
1691
1692
1693 PERL_STATIC_INLINE void
1694 S_cx_pushwhen(pTHX_ PERL_CONTEXT *cx)
1695 {
1696     PERL_ARGS_ASSERT_CX_PUSHWHEN;
1697
1698     cx->blk_givwhen.leave_op = cLOGOP->op_other;
1699 }
1700
1701
1702 PERL_STATIC_INLINE void
1703 S_cx_popwhen(pTHX_ PERL_CONTEXT *cx)
1704 {
1705     PERL_ARGS_ASSERT_CX_POPWHEN;
1706     assert(CxTYPE(cx) == CXt_WHEN);
1707
1708     PERL_UNUSED_ARG(cx);
1709     PERL_UNUSED_CONTEXT;
1710     /* currently NOOP */
1711 }
1712
1713
1714 PERL_STATIC_INLINE void
1715 S_cx_pushgiven(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv)
1716 {
1717     PERL_ARGS_ASSERT_CX_PUSHGIVEN;
1718
1719     cx->blk_givwhen.leave_op = cLOGOP->op_other;
1720     cx->blk_givwhen.defsv_save = orig_defsv;
1721 }
1722
1723
1724 PERL_STATIC_INLINE void
1725 S_cx_popgiven(pTHX_ PERL_CONTEXT *cx)
1726 {
1727     SV *sv;
1728
1729     PERL_ARGS_ASSERT_CX_POPGIVEN;
1730     assert(CxTYPE(cx) == CXt_GIVEN);
1731
1732     sv = GvSV(PL_defgv);
1733     GvSV(PL_defgv) = cx->blk_givwhen.defsv_save;
1734     cx->blk_givwhen.defsv_save = NULL;
1735     SvREFCNT_dec(sv);
1736 }
1737
1738 /* ------------------ util.h ------------------------------------------- */
1739
1740 /*
1741 =head1 Miscellaneous Functions
1742
1743 =for apidoc foldEQ
1744
1745 Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
1746 same
1747 case-insensitively; false otherwise.  Uppercase and lowercase ASCII range bytes
1748 match themselves and their opposite case counterparts.  Non-cased and non-ASCII
1749 range bytes match only themselves.
1750
1751 =cut
1752 */
1753
1754 PERL_STATIC_INLINE I32
1755 Perl_foldEQ(const char *s1, const char *s2, I32 len)
1756 {
1757     const U8 *a = (const U8 *)s1;
1758     const U8 *b = (const U8 *)s2;
1759
1760     PERL_ARGS_ASSERT_FOLDEQ;
1761
1762     assert(len >= 0);
1763
1764     while (len--) {
1765         if (*a != *b && *a != PL_fold[*b])
1766             return 0;
1767         a++,b++;
1768     }
1769     return 1;
1770 }
1771
1772 PERL_STATIC_INLINE I32
1773 Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
1774 {
1775     /* Compare non-utf8 using Unicode (Latin1) semantics.  Does not work on
1776      * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
1777      * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these.  Nor
1778      * does it check that the strings each have at least 'len' characters */
1779
1780     const U8 *a = (const U8 *)s1;
1781     const U8 *b = (const U8 *)s2;
1782
1783     PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
1784
1785     assert(len >= 0);
1786
1787     while (len--) {
1788         if (*a != *b && *a != PL_fold_latin1[*b]) {
1789             return 0;
1790         }
1791         a++, b++;
1792     }
1793     return 1;
1794 }
1795
1796 /*
1797 =for apidoc foldEQ_locale
1798
1799 Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
1800 same case-insensitively in the current locale; false otherwise.
1801
1802 =cut
1803 */
1804
1805 PERL_STATIC_INLINE I32
1806 Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
1807 {
1808     dVAR;
1809     const U8 *a = (const U8 *)s1;
1810     const U8 *b = (const U8 *)s2;
1811
1812     PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
1813
1814     assert(len >= 0);
1815
1816     while (len--) {
1817         if (*a != *b && *a != PL_fold_locale[*b])
1818             return 0;
1819         a++,b++;
1820     }
1821     return 1;
1822 }
1823
1824 #if ! defined (HAS_MEMRCHR) && (defined(PERL_CORE) || defined(PERL_EXT))
1825
1826 PERL_STATIC_INLINE void *
1827 S_my_memrchr(const char * s, const char c, const STRLEN len)
1828 {
1829     /* memrchr(), since many platforms lack it */
1830
1831     const char * t = s + len - 1;
1832
1833     PERL_ARGS_ASSERT_MY_MEMRCHR;
1834
1835     while (t >= s) {
1836         if (*t == c) {
1837             return (void *) t;
1838         }
1839         t--;
1840     }
1841
1842     return NULL;
1843 }
1844
1845 #endif
1846
1847 /*
1848  * ex: set ts=8 sts=4 sw=4 et:
1849  */