* 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>
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_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;
}
#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 */
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) {
+ if (!LIKELY(sv))
+ return FALSE;
+ SvGETMAGIC(sv);
+ return SvTRUE_nomg_NN(sv);
+}
+
PERL_STATIC_INLINE SV *
Perl_SvREFCNT_inc(SV *sv)
{
}
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)));
}
}
#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 ------------------------------- */
/*
/* 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
*/
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[].
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[].
=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;
#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)
+
#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 */
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 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_ARGS_ASSERT_CX_PUSHEVAL;
+ cx->blk_eval.old_cxsubix = PL_curstackinfo->si_cxsubix;
+ PL_curstackinfo->si_cxsubix= cx - PL_curstackinfo->si_cxstack;
cx->blk_eval.retop = retop;
cx->blk_eval.old_namesv = namesv;
cx->blk_eval.old_eval_root = PL_eval_root;
cx->blk_eval.old_namesv = NULL;
SvREFCNT_dec_NN(sv);
}
+ PL_curstackinfo->si_cxsubix = cx->blk_eval.old_cxsubix;
}
return 1;
}
+/*
+=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, 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
+ * 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:
*/