* header files, because they depend on proto.h (included after most other
* headers) or struct definitions.
*
+ * Note also perlstatic.h for functions that can't or shouldn't be inlined, but
+ * whose details should be exposed to the compiler, for such things as tail
+ * call optimization.
+ *
* Each section names the header file that the functions "belong" to.
*/
assert(key > -1);
if ( (key > AvFILLp(av)) || !AvARRAY(av)[key]) {
- return lval ? av_store_simple(av,key,newSV(0)) : NULL;
+ return lval ? av_store_simple(av,key,newSV_type(SVt_NULL)) : NULL;
} else {
return &AvARRAY(av)[key];
}
}
+/*
+=for apidoc av_push_simple
+
+This is a cut-down version of av_push that assumes that the array is very
+straightforward - no magic, not readonly, and AvREAL - and that C<key> is
+not less than -1. This function MUST NOT be used in situations where any
+of those assumptions may not hold.
+
+Pushes an SV (transferring control of one reference count) onto the end of the
+array. The array will grow automatically to accommodate the addition.
+
+Perl equivalent: C<push @myarray, $val;>.
+
+=cut
+*/
+
+PERL_STATIC_INLINE void
+Perl_av_push_simple(pTHX_ AV *av, SV *val)
+{
+ PERL_ARGS_ASSERT_AV_PUSH_SIMPLE;
+ assert(SvTYPE(av) == SVt_PVAV);
+ assert(!SvMAGICAL(av));
+ assert(!SvREADONLY(av));
+ assert(AvREAL(av));
+ assert(AvFILLp(av) > -2);
+
+ (void)av_store_simple(av,AvFILLp(av)+1,val);
+}
+
+/*
+=for apidoc av_new_alloc
+
+This implements L<perlapi/C<newAV_alloc_x>>
+and L<perlapi/C<newAV_alloc_xz>>, which are the public API for this
+functionality.
+
+Creates a new AV and allocates its SV* array.
+
+This is similar to, but more efficient than doing:
+
+ AV *av = newAV();
+ av_extend(av, key);
+
+The size parameter is used to pre-allocate a SV* array large enough to
+hold at least elements C<0..(size-1)>. C<size> must be at least 1.
+
+The C<zeroflag> parameter controls whether or not the array is NULL
+initialized.
+
+=cut
+*/
+
+PERL_STATIC_INLINE AV *
+Perl_av_new_alloc(pTHX_ SSize_t size, bool zeroflag)
+{
+ AV * const av = newAV();
+ SV** ary;
+ PERL_ARGS_ASSERT_AV_NEW_ALLOC;
+ assert(size > 0);
+
+ Newx(ary, size, SV*); /* Newx performs the memwrap check */
+ AvALLOC(av) = ary;
+ AvARRAY(av) = ary;
+ AvMAX(av) = size - 1;
+
+ if (zeroflag)
+ Zero(ary, size, SV*);
+
+ return av;
+}
+
+
/* ------------------------------- cv.h ------------------------------- */
/*
: ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_gv;
}
+/*
+=for apidoc CvDEPTH
+Returns the recursion level of the CV C<sv>. Hence >= 2 indicates we are in a
+recursive call.
+
+=cut
+*/
PERL_STATIC_INLINE I32 *
Perl_CvDEPTH(const CV * const sv)
{
: (struct regexp *)p;
}
-/* ------------------------------- sv.h ------------------------------- */
-
-PERL_STATIC_INLINE bool
-Perl_SvTRUE(pTHX_ SV *sv)
-{
- PERL_ARGS_ASSERT_SVTRUE;
-
- if (UNLIKELY(sv == NULL))
- return FALSE;
- SvGETMAGIC(sv);
- return SvTRUE_nomg_NN(sv);
-}
-
-PERL_STATIC_INLINE bool
-Perl_SvTRUE_nomg(pTHX_ SV *sv)
-{
- PERL_ARGS_ASSERT_SVTRUE_NOMG;
-
- if (UNLIKELY(sv == NULL))
- return FALSE;
- return SvTRUE_nomg_NN(sv);
-}
-
-PERL_STATIC_INLINE bool
-Perl_SvTRUE_NN(pTHX_ SV *sv)
-{
- PERL_ARGS_ASSERT_SVTRUE_NN;
-
- SvGETMAGIC(sv);
- return SvTRUE_nomg_NN(sv);
-}
-
-PERL_STATIC_INLINE bool
-Perl_SvTRUE_common(pTHX_ SV * sv, const bool sv_2bool_is_fallback)
-{
- PERL_ARGS_ASSERT_SVTRUE_COMMON;
-
- if (UNLIKELY(SvIMMORTAL_INTERP(sv)))
- return SvIMMORTAL_TRUE(sv);
-
- if (! SvOK(sv))
- return FALSE;
-
- if (SvPOK(sv))
- return SvPVXtrue(sv);
-
- if (SvIOK(sv))
- return SvIVX(sv) != 0; /* casts to bool */
-
- if (SvROK(sv) && !(SvOBJECT(SvRV(sv)) && HvAMAGIC(SvSTASH(SvRV(sv)))))
- return TRUE;
-
- if (sv_2bool_is_fallback)
- return sv_2bool_nomg(sv);
-
- return isGV_with_GP(sv);
-}
-
-
-PERL_STATIC_INLINE SV *
-Perl_SvREFCNT_inc(SV *sv)
-{
- if (LIKELY(sv != NULL))
- SvREFCNT(sv)++;
- return sv;
-}
-PERL_STATIC_INLINE SV *
-Perl_SvREFCNT_inc_NN(SV *sv)
-{
- PERL_ARGS_ASSERT_SVREFCNT_INC_NN;
-
- SvREFCNT(sv)++;
- return sv;
-}
-PERL_STATIC_INLINE void
-Perl_SvREFCNT_inc_void(SV *sv)
-{
- if (LIKELY(sv != NULL))
- SvREFCNT(sv)++;
-}
-PERL_STATIC_INLINE void
-Perl_SvREFCNT_dec(pTHX_ SV *sv)
-{
- if (LIKELY(sv != NULL)) {
- U32 rc = SvREFCNT(sv);
- if (LIKELY(rc > 1))
- SvREFCNT(sv) = rc - 1;
- else
- Perl_sv_free2(aTHX_ sv, rc);
- }
-}
-
-PERL_STATIC_INLINE void
-Perl_SvREFCNT_dec_NN(pTHX_ SV *sv)
-{
- U32 rc = SvREFCNT(sv);
-
- PERL_ARGS_ASSERT_SVREFCNT_DEC_NN;
-
- if (LIKELY(rc > 1))
- SvREFCNT(sv) = rc - 1;
- else
- Perl_sv_free2(aTHX_ sv, rc);
-}
-
-PERL_STATIC_INLINE void
-Perl_SvAMAGIC_on(SV *sv)
-{
- PERL_ARGS_ASSERT_SVAMAGIC_ON;
- assert(SvROK(sv));
-
- if (SvOBJECT(SvRV(sv))) HvAMAGIC_on(SvSTASH(SvRV(sv)));
-}
-PERL_STATIC_INLINE void
-Perl_SvAMAGIC_off(SV *sv)
-{
- PERL_ARGS_ASSERT_SVAMAGIC_OFF;
-
- if (SvROK(sv) && SvOBJECT(SvRV(sv)))
- HvAMAGIC_off(SvSTASH(SvRV(sv)));
-}
-
-PERL_STATIC_INLINE U32
-Perl_SvPADSTALE_on(SV *sv)
-{
- assert(!(SvFLAGS(sv) & SVs_PADTMP));
- return SvFLAGS(sv) |= SVs_PADSTALE;
-}
-PERL_STATIC_INLINE U32
-Perl_SvPADSTALE_off(SV *sv)
-{
- assert(!(SvFLAGS(sv) & SVs_PADTMP));
- return SvFLAGS(sv) &= ~SVs_PADSTALE;
-}
-#if defined(PERL_CORE) || defined (PERL_EXT)
-PERL_STATIC_INLINE STRLEN
-S_sv_or_pv_pos_u2b(pTHX_ SV *sv, const char *pv, STRLEN pos, STRLEN *lenp)
-{
- PERL_ARGS_ASSERT_SV_OR_PV_POS_U2B;
- if (SvGAMAGIC(sv)) {
- U8 *hopped = utf8_hop((U8 *)pv, pos);
- if (lenp) *lenp = (STRLEN)(utf8_hop(hopped, *lenp) - hopped);
- return (STRLEN)(hopped - (U8 *)pv);
- }
- return sv_pos_u2b_flags(sv,pos,lenp,SV_CONST_RETURN);
-}
-#endif
-
/* ------------------------------- utf8.h ------------------------------- */
/*
#endif
-#ifndef PERL_IN_REGEXEC_C /* Keep these around for that file */
+ /* Keep these around for these files */
+#if ! defined(PERL_IN_REGEXEC_C) && ! defined(PERL_IN_UTF8_C)
# undef PERL_WORDSIZE
# undef PERL_COUNT_MULTIPLIER
# undef PERL_WORD_BOUNDARY_MASK
incomplete_char_action) \
STMT_START { \
const U8 * s = s0; \
+ const U8 * e_ = e; \
UV state = 0; \
\
- PERL_NON_CORE_CHECK_EMPTY(s,e); \
+ PERL_NON_CORE_CHECK_EMPTY(s, e_); \
\
do { \
state = dfa_tab[256 + state + dfa_tab[*s]]; \
if (UNLIKELY(state == 1)) { /* Rejecting state */ \
reject_action; \
} \
- } while (s < e); \
+ } while (s < e_); \
\
/* Here, dropped out of loop before end-of-char */ \
incomplete_char_action; \
=for apidoc utf8_hop
Return the UTF-8 pointer C<s> displaced by C<off> characters, either
-forward or backward.
+forward (if C<off> is positive) or backward (if negative). C<s> does not need
+to be pointing to the starting byte of a character. If it isn't, one count of
+C<off> will be used up to get to the start of the next character for forward
+hops, and to the start of the current character for negative ones.
+
+WARNING: Prefer L</utf8_hop_safe> to this one.
-WARNING: do not use the following unless you *know* C<off> is within
-the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
-on the first byte of character or just after the last byte of a character.
+Do NOT use this function unless you B<know> C<off> is within
+the UTF-8 data pointed to by C<s> B<and> that on entry C<s> is aligned
+on the first byte of a character or just after the last byte of a character.
=cut
*/
PERL_ARGS_ASSERT_UTF8_HOP;
/* Note: cannot use UTF8_IS_...() too eagerly here since e.g
- * the bitops (especially ~) can create illegal UTF-8.
+ * the XXX bitops (especially ~) can create illegal UTF-8.
* In other words: in Perl UTF-8 is not just for Unicode. */
- if (off >= 0) {
+ if (off > 0) {
+
+ /* Get to next non-continuation byte */
+ if (UNLIKELY(UTF8_IS_CONTINUATION(*s))) {
+ do {
+ s++;
+ }
+ while (UTF8_IS_CONTINUATION(*s));
+ off--;
+ }
+
while (off--)
s += UTF8SKIP(s);
}
s--;
}
}
+
GCC_DIAG_IGNORE(-Wcast-qual)
return (U8 *)s;
GCC_DIAG_RESTORE
=for apidoc utf8_hop_forward
Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
-forward.
+forward. C<s> does not need to be pointing to the starting byte of a
+character. If it isn't, one count of C<off> will be used up to get to the
+start of the next character.
C<off> must be non-negative.
assert(s <= end);
assert(off >= 0);
+ if (off && UNLIKELY(UTF8_IS_CONTINUATION(*s))) {
+ /* Get to next non-continuation byte */
+ do {
+ s++;
+ }
+ while (UTF8_IS_CONTINUATION(*s));
+ off--;
+ }
+
while (off--) {
STRLEN skip = UTF8SKIP(s);
if ((STRLEN)(end - s) <= skip) {
=for apidoc utf8_hop_back
Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
-backward.
+backward. C<s> does not need to be pointing to the starting byte of a
+character. If it isn't, one count of C<off> will be used up to get to that
+start.
C<off> must be non-positive.
assert(start <= s);
assert(off <= 0);
+ /* Note: if we know that the input is well-formed, we can do per-word
+ * hop-back. Commit d6ad3b72778369a84a215b498d8d60d5b03aa1af implemented
+ * that. But it was reverted because doing per-word has some
+ * start-up/tear-down overhead, so only makes sense if the distance to be
+ * moved is large, and core perl doesn't currently move more than a few
+ * characters at a time. You can reinstate it if it does become
+ * advantageous. */
while (off++ && s > start) {
do {
s--;
=for apidoc utf8_hop_safe
Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
-either forward or backward.
+either forward or backward. C<s> does not need to be pointing to the starting
+byte of a character. If it isn't, one count of C<off> will be used up to get
+to the start of the next character for forward hops, and to the start of the
+current character for negative ones.
When moving backward it will not move before C<start>.
PERL_STATIC_INLINE UV
Perl_utf8n_to_uvchr_msgs(const U8 *s,
- STRLEN curlen,
- STRLEN *retlen,
- const U32 flags,
- U32 * errors,
- AV ** msgs)
+ STRLEN curlen,
+ STRLEN *retlen,
+ const U32 flags,
+ U32 * errors,
+ AV ** msgs)
{
/* This is the inlined portion of utf8n_to_uvchr_msgs. It handles the
* simple cases, and, if necessary calls a helper function to deal with the
* cases. */
/* No calls from core pass in an empty string; non-core need a check */
- PERL_NON_CORE_CHECK_EMPTY(s, send);
+#ifdef PERL_CORE
+ assert(curlen > 0);
+#else
+ if (curlen == 0) return _utf8n_to_uvchr_msgs_helper(s0, 0, retlen,
+ flags, errors, msgs);
+#endif
type = PL_strict_utf8_dfa_tab[*s];
uv = UTF8_ACCUMULATE(uv, *s);
if (state == 0) {
+#ifdef EBCDIC
+ uv = UNI_TO_NATIVE(uv);
+#endif
goto success;
}
*msgs = NULL;
}
- return UNI_TO_NATIVE(uv);
+ return uv;
}
PERL_STATIC_INLINE UV
/* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */
-#if defined(PERL_IN_PP_C) || defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_TOKE_C) || defined(PERL_IN_UNIVERSAL_C)
+#if defined(PERL_IN_PP_C) || defined(PERL_IN_REGCOMP_ANY) || defined(PERL_IN_TOKE_C) || defined(PERL_IN_UNIVERSAL_C)
#define MAX_CHARSET_NAME_LENGTH 2
SvREFCNT_dec(sv);
}
+/*
+=for apidoc newPADxVOP
+
+Constructs, checks and returns an op containing a pad offset. C<type> is
+the opcode, which should be one of C<OP_PADSV>, C<OP_PADAV>, C<OP_PADHV>
+or C<OP_PADCV>. The returned op will have the C<op_targ> field set by
+the C<padix> argument.
+
+This is convenient when constructing a large optree in nested function
+calls, as it avoids needing to store the pad op directly to set the
+C<op_targ> field as a side-effect. For example
+
+ o = op_append_elem(OP_LINESEQ, o,
+ newPADxVOP(OP_PADSV, 0, padix));
+
+=cut
+*/
+
+PERL_STATIC_INLINE OP *
+Perl_newPADxVOP(pTHX_ I32 type, I32 flags, PADOFFSET padix)
+{
+ PERL_ARGS_ASSERT_NEWPADXVOP;
+
+ assert(type == OP_PADSV || type == OP_PADAV || type == OP_PADHV
+ || type == OP_PADCV);
+ OP *o = newOP(type, flags);
+ o->op_targ = padix;
+ return o;
+}
+
/* ------------------ util.h ------------------------------------------- */
/*
*/
PERL_STATIC_INLINE I32
-Perl_foldEQ(const char *s1, const char *s2, I32 len)
+Perl_foldEQ(pTHX_ const char *s1, const char *s2, I32 len)
{
const U8 *a = (const U8 *)s1;
const U8 *b = (const U8 *)s2;
}
PERL_STATIC_INLINE I32
-Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
+Perl_foldEQ_latin1(pTHX_ const char *s1, const char *s2, I32 len)
{
/* Compare non-UTF-8 using Unicode (Latin1) semantics. Works on all folds
* representable without UTF-8, except for LATIN_SMALL_LETTER_SHARP_S, and
*/
PERL_STATIC_INLINE I32
-Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
+Perl_foldEQ_locale(pTHX_ const char *s1, const char *s2, I32 len)
{
const U8 *a = (const U8 *)s1;
const U8 *b = (const U8 *)s2;
assert(len >= 0);
while (len--) {
- if (*a != *b && *a != PL_fold_locale[*b])
+ if (*a != *b && *a != PL_fold_locale[*b]) {
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log,
+ "%s:%d: Our records indicate %02x is not a fold of %02x"
+ " or its mate %02x\n",
+ __FILE__, __LINE__, *a, *b, PL_fold_locale[*b]));
+
return 0;
+ }
a++,b++;
}
return 1;
* mutex is defined accordingly.
*
* But in all cases, using the mutex prevents these problems, as long as
- * all code uses the same mutex..
+ * all code uses the same mutex.
*
* A complication is that this can be called during phases where the
* mortalization process isn't available. These are in interpreter
}
}
- /* Then each of the three significant characters */
+ /* Then each of the four significant characters */
if (strchr(ret, 'm')) {
*mem_log_meat++ = 'm';
}
if (strchr(ret, 't')) {
*mem_log_meat++ = 't';
}
+ if (strchr(ret, 'c')) {
+ *mem_log_meat++ = 'c';
+ }
*mem_log_meat = '\0';
assert(mem_log_meat < PL_mem_log + sizeof(PL_mem_log));
PERL_STATIC_INLINE bool
Perl_sv_isbool(pTHX_ const SV *sv)
{
+ /* change to the following in 5.37, logically the same but
+ * more efficient and more future proof */
+#if 0
+ return (SvBoolFlagsOK(sv) && BOOL_INTERNALS_sv_isbool(sv));
+#else
return SvIOK(sv) && SvPOK(sv) && SvIsCOW_static(sv) &&
(SvPVX_const(sv) == PL_Yes || SvPVX_const(sv) == PL_No);
+#endif
+
}
#ifdef USE_ITHREADS
#endif
+PERL_STATIC_INLINE PADNAME *
+Perl_padname_refcnt_inc(PADNAME *pn)
+{
+ PadnameREFCNT(pn)++;
+ return pn;
+}
+
/*
* ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff