/* ------------------------------- av.h ------------------------------- */
-PERL_STATIC_INLINE SSize_t
-Perl_av_top_index(pTHX_ AV *av)
+/*
+=for apidoc_section $AV
+=for apidoc av_count
+Returns the number of elements in the array C<av>. This is the true length of
+the array, including any undefined elements. It is always the same as
+S<C<av_top_index(av) + 1>>.
+
+=cut
+*/
+PERL_STATIC_INLINE Size_t
+Perl_av_count(pTHX_ AV *av)
{
- PERL_ARGS_ASSERT_AV_TOP_INDEX;
+ PERL_ARGS_ASSERT_AV_COUNT;
assert(SvTYPE(av) == SVt_PVAV);
- return AvFILL(av);
+ return AvFILL(av) + 1;
}
/* ------------------------------- cv.h ------------------------------- */
+/*
+=for apidoc_section $CV
+=for apidoc CvGV
+Returns the GV associated with the CV C<sv>, reifying it if necessary.
+
+=cut
+*/
PERL_STATIC_INLINE GV *
Perl_CvGV(pTHX_ CV *sv)
{
/* ------------------------------- sv.h ------------------------------- */
PERL_STATIC_INLINE bool
-Perl_SvTRUE(SV *sv) {
- return LIKELY(sv) && SvTRUE_NN(sv);
+Perl_SvTRUE(pTHX_ SV *sv) {
+ if (UNLIKELY(sv == NULL))
+ return FALSE;
+ SvGETMAGIC(sv);
+ return SvTRUE_nomg_NN(sv);
}
PERL_STATIC_INLINE SV *
}
#endif
-/* ------------------------------- handy.h ------------------------------- */
-
-/* saves machine code for a common noreturn idiom typically used in Newx*() */
-GCC_DIAG_IGNORE_DECL(-Wunused-function);
-static void
-Perl_croak_memory_wrap(void)
-{
- Perl_croak_nocontext("%s",PL_memory_wrap);
-}
-GCC_DIAG_RESTORE_DECL;
-
/* ------------------------------- utf8.h ------------------------------- */
/*
-=head1 Unicode Support
+=for apidoc_section $unicode
*/
PERL_STATIC_INLINE void
* Isolate the lsb;
* https://stackoverflow.com/questions/757059/position-of-least-significant-bit-that-is-set
*
- * The word will look this this, with a rightmost set bit in position 's':
+ * The word will look like this, with a rightmost set bit in position 's':
* ('x's are don't cares)
* s
* x..x100..0
/* ------------------------------- perl.h ----------------------------- */
/*
-=head1 Miscellaneous Functions
+=for apidoc_section $utility
=for apidoc is_safe_syscall
PERL_ARGS_ASSERT_LOSSLESS_NV_TO_IV;
-# if defined(Perl_isnan)
-
+# if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+ /* Normally any comparison with a NaN returns false; if we can't rely
+ * on that behaviour, check explicitly */
if (UNLIKELY(Perl_isnan(nv))) {
return FALSE;
}
-
# endif
- if (UNLIKELY(nv < IV_MIN) || UNLIKELY(nv > IV_MAX)) {
+ /* Written this way so that with an always-false NaN comparison we
+ * return false */
+ if (!(LIKELY(nv >= (NV) IV_MIN) && LIKELY(nv < IV_MAX_P1))) {
return FALSE;
}
#endif
-/* ------------------ regcomp.c, toke.c ------------ */
-
-#if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_TOKE_C)
-
-/*
- - regcurly - a little FSA that accepts {\d+,?\d*}
- Pulled from reg.c.
- */
-PERL_STATIC_INLINE bool
-S_regcurly(const char *s)
-{
- PERL_ARGS_ASSERT_REGCURLY;
-
- if (*s++ != '{')
- return FALSE;
- if (!isDIGIT(*s))
- return FALSE;
- while (isDIGIT(*s))
- s++;
- if (*s == ',') {
- s++;
- while (isDIGIT(*s))
- s++;
- }
-
- return *s == '}';
-}
-
-#endif
-
/* ------------------ 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)
return gimme;
cxix = PL_curstackinfo->si_cxsubix;
if (cxix < 0)
- return G_VOID;
+ return PL_curstackinfo->si_type == PERLSI_SORT ? G_SCALAR: G_VOID;
assert(cxstack[cxix].blk_gimme & G_WANT);
return (cxstack[cxix].blk_gimme & G_WANT);
}
/* ------------------ util.h ------------------------------------------- */
/*
-=head1 Miscellaneous Functions
+=for apidoc_section $string
=for apidoc foldEQ
}
/*
+=for apidoc_section $locale
=for apidoc foldEQ_locale
Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
PERL_STATIC_INLINE I32
Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
{
- dVAR;
const U8 *a = (const U8 *)s1;
const U8 *b = (const U8 *)s2;
}
/*
+=for apidoc_section $string
=for apidoc my_strnlen
The C library C<strnlen> if available, or a Perl implementation of it.
C<my_strnlen()> computes the length of the string, up to C<maxlen>
-characters. It will will never attempt to address more than C<maxlen>
+characters. It will never attempt to address more than C<maxlen>
characters, making it suitable for use with strings that are not
guaranteed to be NUL-terminated.
#endif
+PERL_STATIC_INLINE char *
+Perl_mortal_getenv(const char * str)
+{
+ /* This implements a (mostly) thread-safe, sequential-call-safe getenv().
+ *
+ * It's (mostly) thread-safe because it uses a mutex to prevent
+ * simultaneous access from other threads that use the same mutex, and
+ * makes a copy of the result before releasing that mutex. All of the Perl
+ * core uses that mutex, but, like all mutexes, everything has to cooperate
+ * for it to completely work. It is possible for code from, say XS, to not
+ * use this mutex, defeating the safety.
+ *
+ * On some platforms, getenv() is not sequential-call-safe, because
+ * subsequent calls destroy the static storage inside the C library
+ * returned by an earlier call. The result must be copied or completely
+ * acted upon before a subsequent getenv call. Those calls could come from
+ * another thread. Again, making a copy while controlling the mutex
+ * prevents these problems..
+ *
+ * To prevent leaks, the copy is made by creating a new SV containing it,
+ * mortalizing the SV, and returning the SV's string (the copy). Thus this
+ * is a drop-in replacement for getenv().
+ *
+ * A complication is that this can be called during phases where the
+ * mortalization process isn't available. These are in interpreter
+ * destruction or early in construction. khw believes that at these times
+ * there shouldn't be anything else going on, so plain getenv is safe AS
+ * LONG AS the caller acts on the return before calling it again. */
+
+ char * ret;
+ dTHX;
+
+ PERL_ARGS_ASSERT_MORTAL_GETENV;
+
+ /* Can't mortalize without stacks. khw believes that no other threads
+ * should be running, so no need to lock things, and this may be during a
+ * phase when locking isn't even available */
+ if (UNLIKELY(PL_scopestack_ix == 0)) {
+ return getenv(str);
+ }
+
+ ENV_LOCK;
+
+ ret = getenv(str);
+
+ if (ret != NULL) {
+ ret = SvPVX(sv_2mortal(newSVpv(ret, 0)));
+ }
+
+ ENV_UNLOCK;
+ return ret;
+}
+
/*
* ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff