File Coverage

/usr/local/lib/perl5/5.26.1/x86_64-linux/CORE/inline.h
Criterion Covered Total %
statement 2 4 50.0
total 2 4 50.0


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