* License or the Artistic License, as specified in the README file.
*
* This file contains tables and code adapted from
- * http://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which requires this
+ * https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which requires this
* copyright notice:
Copyright (c) 2008-2009 Bjoern Hoehrmann <bjoern@hoehrmann.de>
/* ------------------------------- 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)
{
+ PERL_ARGS_ASSERT_CVGV;
+
return CvNAMED(sv)
- ? Perl_cvgv_from_hek(aTHX_ sv)
- : ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_gv;
+ ? Perl_cvgv_from_hek(aTHX_ sv)
+ : ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_gv;
}
PERL_STATIC_INLINE I32 *
-Perl_CvDEPTHp(const CV * const sv)
+Perl_CvDEPTH(const CV * const sv)
{
+ PERL_ARGS_ASSERT_CVDEPTH;
assert(SvTYPE(sv) == SVt_PVCV || SvTYPE(sv) == SVt_PVFM);
+
return &((XPVCV*)SvANY(sv))->xcv_depth;
}
tmpsv = newSVpvn_flags(orig, *len, SVs_TEMP);
tmps = SvPVX(tmpsv);
while ((*len)--) {
- if (!isSPACE(*orig))
- *tmps++ = *orig;
- orig++;
+ if (!isSPACE(*orig))
+ *tmps++ = *orig;
+ orig++;
}
*tmps = '\0';
*len = tmps - SvPVX(tmpsv);
- return SvPVX(tmpsv);
+ return SvPVX(tmpsv);
}
#endif
assert(mg->mg_type == PERL_MAGIC_regex_global);
assert(mg->mg_len != -1);
if (mg->mg_flags & MGf_BYTES || !DO_UTF8(sv))
- return (STRLEN)mg->mg_len;
+ return (STRLEN)mg->mg_len;
else {
- const STRLEN pos = (STRLEN)mg->mg_len;
- /* Without this check, we may read past the end of the buffer: */
- if (pos > sv_or_pv_len_utf8(sv, s, len)) return len+1;
- return sv_or_pv_pos_u2b(sv, s, pos, NULL);
+ const STRLEN pos = (STRLEN)mg->mg_len;
+ /* Without this check, we may read past the end of the buffer: */
+ if (pos > sv_or_pv_len_utf8(sv, s, len)) return len+1;
+ return sv_or_pv_pos_u2b(sv, s, pos, NULL);
}
}
#endif
#if defined(PERL_IN_PAD_C) || defined(PERL_IN_OP_C)
PERL_STATIC_INLINE bool
-PadnameIN_SCOPE(const PADNAME * const pn, const U32 seq)
+S_PadnameIN_SCOPE(const PADNAME * const pn, const U32 seq)
{
+ PERL_ARGS_ASSERT_PADNAMEIN_SCOPE;
+
/* is seq within the range _LOW to _HIGH ?
* This is complicated by the fact that PL_cop_seqmax
* may have wrapped around at some point */
if (COP_SEQ_RANGE_LOW(pn) == PERL_PADSEQ_INTRO)
- return FALSE; /* not yet introduced */
+ return FALSE; /* not yet introduced */
if (COP_SEQ_RANGE_HIGH(pn) == PERL_PADSEQ_INTRO) {
/* in compiling scope */
- if (
- (seq > COP_SEQ_RANGE_LOW(pn))
- ? (seq - COP_SEQ_RANGE_LOW(pn) < (U32_MAX >> 1))
- : (COP_SEQ_RANGE_LOW(pn) - seq > (U32_MAX >> 1))
- )
- return TRUE;
+ if (
+ (seq > COP_SEQ_RANGE_LOW(pn))
+ ? (seq - COP_SEQ_RANGE_LOW(pn) < (U32_MAX >> 1))
+ : (COP_SEQ_RANGE_LOW(pn) - seq > (U32_MAX >> 1))
+ )
+ return TRUE;
}
else if (
- (COP_SEQ_RANGE_LOW(pn) > COP_SEQ_RANGE_HIGH(pn))
- ?
- ( seq > COP_SEQ_RANGE_LOW(pn)
- || seq <= COP_SEQ_RANGE_HIGH(pn))
+ (COP_SEQ_RANGE_LOW(pn) > COP_SEQ_RANGE_HIGH(pn))
+ ?
+ ( seq > COP_SEQ_RANGE_LOW(pn)
+ || seq <= COP_SEQ_RANGE_HIGH(pn))
- : ( seq > COP_SEQ_RANGE_LOW(pn)
- && seq <= COP_SEQ_RANGE_HIGH(pn))
+ : ( seq > COP_SEQ_RANGE_LOW(pn)
+ && seq <= COP_SEQ_RANGE_HIGH(pn))
)
- return TRUE;
+ return TRUE;
return FALSE;
}
#endif
Perl_TOPMARK(pTHX)
{
DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
- "MARK top %p %" IVdf "\n",
- PL_markstack_ptr,
- (IV)*PL_markstack_ptr)));
+ "MARK top %p %" IVdf "\n",
+ PL_markstack_ptr,
+ (IV)*PL_markstack_ptr)));
return *PL_markstack_ptr;
}
Perl_POPMARK(pTHX)
{
DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
- "MARK pop %p %" IVdf "\n",
- (PL_markstack_ptr-1),
- (IV)*(PL_markstack_ptr-1))));
+ "MARK pop %p %" IVdf "\n",
+ (PL_markstack_ptr-1),
+ (IV)*(PL_markstack_ptr-1))));
assert((PL_markstack_ptr > PL_markstack) || !"MARK underflow");
return *PL_markstack_ptr--;
}
Perl_ReANY(const REGEXP * const re)
{
XPV* const p = (XPV*)SvANY(re);
+
+ PERL_ARGS_ASSERT_REANY;
assert(isREGEXP(re));
+
return SvTYPE(re) == SVt_PVLV ? p->xpv_len_u.xpvlenu_rx
: (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)++;
+ 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_SvREFCNT_inc_void(SV *sv)
{
if (LIKELY(sv != NULL))
- SvREFCNT(sv)++;
+ 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);
+ U32 rc = SvREFCNT(sv);
+ if (LIKELY(rc > 1))
+ SvREFCNT(sv) = rc - 1;
+ else
+ Perl_sv_free2(aTHX_ sv, rc);
}
}
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;
+ SvREFCNT(sv) = rc - 1;
else
- Perl_sv_free2(aTHX_ sv, rc);
+ Perl_sv_free2(aTHX_ sv, rc);
}
PERL_STATIC_INLINE void
-SvAMAGIC_on(SV *sv)
+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
-SvAMAGIC_off(SV *sv)
+Perl_SvAMAGIC_off(SV *sv)
{
+ PERL_ARGS_ASSERT_SVAMAGIC_OFF;
+
if (SvROK(sv) && SvOBJECT(SvRV(sv)))
- HvAMAGIC_off(SvSTASH(SvRV(sv)));
+ HvAMAGIC_off(SvSTASH(SvRV(sv)));
}
PERL_STATIC_INLINE U32
{
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);
+ 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
-/* ------------------------------- 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
/* An invariant is trivially returned */
if (expectlen == 1) {
- return uv;
+ return uv;
}
/* Remove the leading bits that indicate the number of bytes, leaving just
/* Process per-byte */
while (x < send) {
- if (! UTF8_IS_INVARIANT(*x)) {
+ if (! UTF8_IS_INVARIANT(*x)) {
if (ep) {
*ep = x;
}
/* Get just the msb bits of each byte */
word &= PERL_VARIANTS_WORD_MASK;
-# ifdef USING_MSVC6 /* VC6 has some issues with the normal code, and the
- easiest thing is to hide that from the callers */
- {
- unsigned int i;
- const U8 * s = (U8 *) &word;
- dTHX;
-
- for (i = 0; i < sizeof(word); i++ ) {
- if (s[i]) {
- return i;
- }
- }
-
- Perl_croak(aTHX_ "panic: %s: %d: unexpected zero word\n",
- __FILE__, __LINE__);
- }
-
-# elif BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
+# if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
/* Bytes are stored like
* Byte8 ... Byte2 Byte1
* 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
/* Process per-byte */
while (x < e) {
- if (! UTF8_IS_INVARIANT(*x)) {
+ if (! UTF8_IS_INVARIANT(*x)) {
count++;
}
*/
PERL_STATIC_INLINE bool
-S_is_utf8_non_invariant_string(const U8* const s, STRLEN len)
+Perl_is_utf8_non_invariant_string(const U8* const s, STRLEN len)
{
const U8 * first_variant;
=cut
This uses an adaptation of the table and algorithm given in
-http://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
+https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
documentation of the original version. A copyright notice for the original
version is given at the beginning of this file. The Perl adapation is
documented at the definition of PL_extended_utf8_dfa_tab[].
=cut
This uses an adaptation of the tables and algorithm given in
-http://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
+https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
documentation of the original version. A copyright notice for the original
version is given at the beginning of this file. The Perl adapation is
documented at the definition of strict_extended_utf8_dfa_tab[].
=cut
This uses an adaptation of the tables and algorithm given in
-http://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
+https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
documentation of the original version. A copyright notice for the original
version is given at the beginning of this file. The Perl adapation is
documented at the definition of PL_c9_utf8_dfa_tab[].
* In other words: in Perl UTF-8 is not just for Unicode. */
if (off >= 0) {
- while (off--)
- s += UTF8SKIP(s);
+ while (off--)
+ s += UTF8SKIP(s);
}
else {
- while (off++) {
- s--;
- while (UTF8_IS_CONTINUATION(*s))
- s--;
- }
+ while (off++) {
+ s--;
+ while (UTF8_IS_CONTINUATION(*s))
+ s--;
+ }
}
GCC_DIAG_IGNORE(-Wcast-qual)
return (U8 *)s;
s--;
} while (UTF8_IS_CONTINUATION(*s) && s > start);
}
-
+
GCC_DIAG_IGNORE(-Wcast-qual)
return (U8 *)s;
GCC_DIAG_RESTORE
* will need to be called.
*
* This is an adaptation of the tables and algorithm given in
- * http://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides
+ * https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides
* comprehensive documentation of the original version. A copyright notice
* for the original version is given at the beginning of this file. The
* Perl adapation is documented at the definition of PL_strict_utf8_dfa_tab[].
/* ------------------------------- perl.h ----------------------------- */
/*
-=head1 Miscellaneous Functions
+=for apidoc_section $utility
=for apidoc is_safe_syscall
-Test that the given C<pv> doesn't contain any internal C<NUL> characters.
-If it does, set C<errno> to C<ENOENT>, optionally warn, and return FALSE.
+Test that the given C<pv> (with length C<len>) doesn't contain any internal
+C<NUL> characters.
+If it does, set C<errno> to C<ENOENT>, optionally warn using the C<syscalls>
+category, and return FALSE.
Return TRUE if the name is safe.
+C<what> and C<op_name> are used in any warning.
+
Used by the C<IS_SAFE_SYSCALL()> macro.
=cut
*/
PERL_STATIC_INLINE bool
-Perl_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name) {
+Perl_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name)
+{
/* While the Windows CE API provides only UCS-16 (or UTF-16) APIs
* perl itself uses xce*() functions which accept 8-bit strings.
*/
#ifdef PERL_CORE
PERL_STATIC_INLINE bool
-S_should_warn_nl(const char *pv) {
+S_should_warn_nl(const char *pv)
+{
STRLEN len;
PERL_ARGS_ASSERT_SHOULD_WARN_NL;
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;
}
/* ------------------ 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)
+
#define MAX_CHARSET_NAME_LENGTH 2
PERL_STATIC_INLINE const char *
-get_regex_charset_name(const U32 flags, STRLEN* const lenp)
+S_get_regex_charset_name(const U32 flags, STRLEN* const lenp)
{
+ PERL_ARGS_ASSERT_GET_REGEX_CHARSET_NAME;
+
/* Returns a string that corresponds to the name of the regex character set
* given by 'flags', and *lenp is set the length of that string, which
* cannot exceed MAX_CHARSET_NAME_LENGTH characters */
case REGEX_DEPENDS_CHARSET: return DEPENDS_PAT_MODS;
case REGEX_LOCALE_CHARSET: return LOCALE_PAT_MODS;
case REGEX_UNICODE_CHARSET: return UNICODE_PAT_MODS;
- case REGEX_ASCII_RESTRICTED_CHARSET: return ASCII_RESTRICT_PAT_MODS;
- case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
- *lenp = 2;
- return ASCII_MORE_RESTRICT_PAT_MODS;
+ case REGEX_ASCII_RESTRICTED_CHARSET: return ASCII_RESTRICT_PAT_MODS;
+ case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
+ *lenp = 2;
+ return ASCII_MORE_RESTRICT_PAT_MODS;
}
/* The NOT_REACHED; hides an assert() which has a rather complex
* definition in perl.h. */
return "?"; /* Unknown */
}
+#endif
+
/*
Return false if any get magic is on the SV other than taint magic.
*/
PERL_STATIC_INLINE bool
-Perl_sv_only_taint_gmagic(SV *sv) {
+Perl_sv_only_taint_gmagic(SV *sv)
+{
MAGIC *mg = SvMAGIC(sv);
PERL_ARGS_ASSERT_SV_ONLY_TAINT_GMAGIC;
/* ------------------ cop.h ------------------------------------------- */
+/* implement GIMME_V() macro */
+
+PERL_STATIC_INLINE U8
+Perl_gimme_V(pTHX)
+{
+ I32 cxix;
+ U8 gimme = (PL_op->op_flags & OPf_WANT);
+
+ if (gimme)
+ return gimme;
+ cxix = PL_curstackinfo->si_cxsubix;
+ if (cxix < 0)
+ 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);
+}
+
/* Enter a block. Push a new base context and return its address. */
PERL_ARGS_ASSERT_CX_PUSHSUB;
PERL_DTRACE_PROBE_ENTRY(cv);
+ cx->blk_sub.old_cxsubix = PL_curstackinfo->si_cxsubix;
+ PL_curstackinfo->si_cxsubix = cx - PL_curstackinfo->si_cxstack;
cx->blk_sub.cv = cv;
cx->blk_sub.olddepth = CvDEPTH(cv);
cx->blk_sub.prevcomppad = PL_comppad;
CvDEPTH(cv) = cx->blk_sub.olddepth;
cx->blk_sub.cv = NULL;
SvREFCNT_dec(cv);
+ PL_curstackinfo->si_cxsubix = cx->blk_sub.old_cxsubix;
}
{
PERL_ARGS_ASSERT_CX_PUSHFORMAT;
+ cx->blk_format.old_cxsubix = PL_curstackinfo->si_cxsubix;
+ PL_curstackinfo->si_cxsubix= cx - PL_curstackinfo->si_cxstack;
cx->blk_format.cv = cv;
cx->blk_format.retop = retop;
cx->blk_format.gv = gv;
cx->blk_format.cv = NULL;
--CvDEPTH(cv);
SvREFCNT_dec_NN(cv);
+ PL_curstackinfo->si_cxsubix = cx->blk_format.old_cxsubix;
}
PERL_STATIC_INLINE void
-Perl_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv)
+Perl_push_evalortry_common(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv)
{
- PERL_ARGS_ASSERT_CX_PUSHEVAL;
-
cx->blk_eval.retop = retop;
cx->blk_eval.old_namesv = namesv;
cx->blk_eval.old_eval_root = PL_eval_root;
cx->blk_u16 = (PL_in_eval & 0x3F) | ((U16)PL_op->op_type << 7);
}
+PERL_STATIC_INLINE void
+Perl_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv)
+{
+ PERL_ARGS_ASSERT_CX_PUSHEVAL;
+
+ Perl_push_evalortry_common(aTHX_ cx, retop, namesv);
+
+ cx->blk_eval.old_cxsubix = PL_curstackinfo->si_cxsubix;
+ PL_curstackinfo->si_cxsubix = cx - PL_curstackinfo->si_cxstack;
+}
+
+PERL_STATIC_INLINE void
+Perl_cx_pushtry(pTHX_ PERL_CONTEXT *cx, OP *retop)
+{
+ PERL_ARGS_ASSERT_CX_PUSHTRY;
+
+ Perl_push_evalortry_common(aTHX_ cx, retop, NULL);
+
+ /* Don't actually change it, just store the current value so it's restored
+ * by the common popeval */
+ cx->blk_eval.old_cxsubix = PL_curstackinfo->si_cxsubix;
+}
+
PERL_STATIC_INLINE void
Perl_cx_popeval(pTHX_ PERL_CONTEXT *cx)
cx->blk_eval.old_namesv = NULL;
SvREFCNT_dec_NN(sv);
}
+ PL_curstackinfo->si_cxsubix = cx->blk_eval.old_cxsubix;
}
/* ------------------ util.h ------------------------------------------- */
/*
-=head1 Miscellaneous Functions
+=for apidoc_section $string
=for apidoc foldEQ
assert(len >= 0);
while (len--) {
- if (*a != *b && *a != PL_fold[*b])
- return 0;
- a++,b++;
+ if (*a != *b && *a != PL_fold[*b])
+ return 0;
+ a++,b++;
}
return 1;
}
assert(len >= 0);
while (len--) {
- if (*a != *b && *a != PL_fold_latin1[*b]) {
- return 0;
- }
- a++, b++;
+ if (*a != *b && *a != PL_fold_latin1[*b]) {
+ return 0;
+ }
+ a++, b++;
}
return 1;
}
/*
+=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;
assert(len >= 0);
while (len--) {
- if (*a != *b && *a != PL_fold_locale[*b])
- return 0;
- a++,b++;
+ if (*a != *b && *a != PL_fold_locale[*b])
+ return 0;
+ a++,b++;
}
return 1;
}
+/*
+=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 never attempt to address more than C<maxlen>
+characters, making it suitable for use with strings that are not
+guaranteed to be NUL-terminated.
+
+=cut
+
+Description stolen from http://man.openbsd.org/strnlen.3,
+implementation stolen from PostgreSQL.
+*/
+#ifndef HAS_STRNLEN
+
+PERL_STATIC_INLINE Size_t
+Perl_my_strnlen(const char *str, Size_t maxlen)
+{
+ const char *end = (char *) memchr(str, '\0', maxlen);
+
+ PERL_ARGS_ASSERT_MY_STRNLEN;
+
+ if (end == NULL) return maxlen;
+ return end - str;
+}
+
+#endif
+
#if ! defined (HAS_MEMRCHR) && (defined(PERL_CORE) || defined(PERL_EXT))
PERL_STATIC_INLINE void *
#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 other
+ * threads (that look at this mutex) from destroying the result before this
+ * routine has a chance to copy the result to a place that won't be
+ * destroyed before the caller gets a chance to handle it. That place is a
+ * mortal SV. khw chose this over SAVEFREEPV because he is under the
+ * impression that the SV will hang around longer under more circumstances
+ *
+ * The reason it isn't completely thread-safe is that other code could
+ * simply not pay attention to the mutex. All of the Perl core uses the
+ * mutex, but it is possible for code from, say XS, to not use this mutex,
+ * defeating the safety.
+ *
+ * getenv() returns, in some implementations, a pointer to a spot in the
+ * **environ array, which could be invalidated at any time by this or
+ * another thread changing the environment. Other implementations copy the
+ * **environ value to a static buffer, returning a pointer to that. That
+ * buffer might or might not be invalidated by a getenv() call in another
+ * thread. If it does get zapped, we need an exclusive lock. Otherwise,
+ * many getenv() calls can safely be running simultaneously, so a
+ * many-reader (but no simultaneous writers) lock is ok. There is a
+ * Configure probe to see if another thread destroys the buffer, and the
+ * mutex is defined accordingly.
+ *
+ * But in all cases, using the mutex prevents these problems, as long as
+ * 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
+ * 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);
+ }
+
+#ifdef PERL_MEM_LOG
+
+ /* A major complication arises under PERL_MEM_LOG. When that is active,
+ * every memory allocation may result in logging, depending on the value of
+ * ENV{PERL_MEM_LOG} at the moment. That means, as we create the SV for
+ * saving ENV{foo}'s value (but before saving it), the logging code will
+ * call us recursively to find out what ENV{PERL_MEM_LOG} is. Without some
+ * care that could lead to: 1) infinite recursion; or 2) deadlock (trying to
+ * lock a boolean mutex recursively); 3) destroying the getenv() static
+ * buffer; or 4) destroying the temporary created by this for the copy
+ * causes a log entry to be made which could cause a new temporary to be
+ * created, which will need to be destroyed at some point, leading to an
+ * infinite loop.
+ *
+ * The solution adopted here (after some gnashing of teeth) is to detect
+ * the recursive calls and calls from the logger, and treat them specially.
+ * Let's say we want to do getenv("foo"). We first find
+ * getenv(PERL_MEM_LOG) and save it to a fixed-length per-interpreter
+ * variable, so no temporary is required. Then we do getenv(foo}, and in
+ * the process of creating a temporary to save it, this function will be
+ * called recursively to do a getenv(PERL_MEM_LOG). On the recursed call,
+ * we detect that it is such a call and return our saved value instead of
+ * locking and doing a new getenv(). This solves all of problems 1), 2),
+ * and 3). Because all the getenv()s are done while the mutex is locked,
+ * the state cannot have changed. To solve 4), we don't create a temporary
+ * when this is called from the logging code. That code disposes of the
+ * return value while the mutex is still locked.
+ *
+ * The value of getenv(PERL_MEM_LOG) can be anything, but only initial
+ * digits and 3 particular letters are significant; the rest are ignored by
+ * the memory logging code. Thus the per-interpreter variable only needs
+ * to be large enough to save the significant information, the size of
+ * which is known at compile time. The first byte is extra, reserved for
+ * flags for our use. To protect against overflowing, only the reserved
+ * byte, as many digits as don't overflow, and the three letters are
+ * stored.
+ *
+ * The reserved byte has two bits:
+ * 0x1 if set indicates that if we get here, it is a recursive call of
+ * getenv()
+ * 0x2 if set indicates that the call is from the logging code.
+ *
+ * If the flag indicates this is a recursive call, just return the stored
+ * value of PL_mem_log; An empty value gets turned into NULL. */
+ if (strEQ(str, "PERL_MEM_LOG") && PL_mem_log[0] & 0x1) {
+ if (PL_mem_log[1] == '\0') {
+ return NULL;
+ } else {
+ return PL_mem_log + 1;
+ }
+ }
+
+#endif
+
+ GETENV_LOCK;
+
+#ifdef PERL_MEM_LOG
+
+ /* Here we are in a critical section. As explained above, we do our own
+ * getenv(PERL_MEM_LOG), saving the result safely. */
+ ret = getenv("PERL_MEM_LOG");
+ if (ret == NULL) { /* No logging active */
+
+ /* Return that immediately if called from the logging code */
+ if (PL_mem_log[0] & 0x2) {
+ GETENV_UNLOCK;
+ return NULL;
+ }
+
+ PL_mem_log[1] = '\0';
+ }
+ else {
+ char *mem_log_meat = PL_mem_log + 1; /* first byte reserved */
+
+ /* There is nothing to prevent the value of PERL_MEM_LOG from being an
+ * extremely long string. But we want only a few characters from it.
+ * PL_mem_log has been made large enough to hold just the ones we need.
+ * First the file descriptor. */
+ if (isDIGIT(*ret)) {
+ const char * s = ret;
+ if (UNLIKELY(*s == '0')) {
+
+ /* Reduce multiple leading zeros to a single one. This is to
+ * allow the caller to change what to do with leading zeros. */
+ *mem_log_meat++ = '0';
+ s++;
+ while (*s == '0') {
+ s++;
+ }
+ }
+
+ /* If the input overflows, copy just enough for the result to also
+ * overflow, plus 1 to make sure */
+ while (isDIGIT(*s) && s < ret + TYPE_DIGITS(UV) + 1) {
+ *mem_log_meat++ = *s++;
+ }
+ }
+
+ /* Then each of the three significant characters */
+ if (strchr(ret, 'm')) {
+ *mem_log_meat++ = 'm';
+ }
+ if (strchr(ret, 's')) {
+ *mem_log_meat++ = 's';
+ }
+ if (strchr(ret, 't')) {
+ *mem_log_meat++ = 't';
+ }
+ *mem_log_meat = '\0';
+
+ assert(mem_log_meat < PL_mem_log + sizeof(PL_mem_log));
+ }
+
+ /* If we are being called from the logger, it only needs the significant
+ * portion of PERL_MEM_LOG, and doesn't need a safe copy */
+ if (PL_mem_log[0] & 0x2) {
+ assert(strEQ(str, "PERL_MEM_LOG"));
+ GETENV_UNLOCK;
+ return PL_mem_log + 1;
+ }
+
+ /* Here is a generic getenv(). This could be a getenv("PERL_MEM_LOG") that
+ * is coming from other than the logging code, so it should be treated the
+ * same as any other getenv(), returning the full value, not just the
+ * significant part, and having its value saved. Set the flag that
+ * indicates any call to this routine will be a recursion from here */
+ PL_mem_log[0] = 0x1;
+
+#endif
+
+ /* Now get the value of the real desired variable, and save a copy */
+ ret = getenv(str);
+
+ if (ret != NULL) {
+ ret = SvPVX(sv_2mortal(newSVpv(ret, 0)));
+ }
+
+ GETENV_UNLOCK;
+
+#ifdef PERL_MEM_LOG
+
+ /* Clear the buffer */
+ Zero(PL_mem_log, sizeof(PL_mem_log), char);
+
+#endif
+
+ return ret;
+}
+
/*
* ex: set ts=8 sts=4 sw=4 et:
*/