summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/CORE/inline.h
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/CORE/inline.h')
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CORE/inline.h189
1 files changed, 183 insertions, 6 deletions
diff --git a/Master/tlpkg/tlperl/lib/CORE/inline.h b/Master/tlpkg/tlperl/lib/CORE/inline.h
index 953bb33cffb..0fe8a0eee1a 100755
--- a/Master/tlpkg/tlperl/lib/CORE/inline.h
+++ b/Master/tlpkg/tlperl/lib/CORE/inline.h
@@ -14,7 +14,7 @@
/* ------------------------------- av.h ------------------------------- */
-PERL_STATIC_INLINE I32
+PERL_STATIC_INLINE SSize_t
S_av_top_index(pTHX_ AV *av)
{
PERL_ARGS_ASSERT_AV_TOP_INDEX;
@@ -32,6 +32,56 @@ S_CvDEPTHp(const CV * const sv)
return &((XPVCV*)SvANY(sv))->xcv_depth;
}
+/*
+ CvPROTO returns the prototype as stored, which is not necessarily what
+ the interpreter should be using. Specifically, the interpreter assumes
+ that spaces have been stripped, which has been the case if the prototype
+ was added by toke.c, but is generally not the case if it was added elsewhere.
+ Since we can't enforce the spacelessness at assignment time, this routine
+ provides a temporary copy at parse time with spaces removed.
+ I<orig> is the start of the original buffer, I<len> is the length of the
+ prototype and will be updated when this returns.
+ */
+
+#ifdef PERL_CORE
+PERL_STATIC_INLINE char *
+S_strip_spaces(pTHX_ const char * orig, STRLEN * const len)
+{
+ SV * tmpsv;
+ char * tmps;
+ tmpsv = newSVpvn_flags(orig, *len, SVs_TEMP);
+ tmps = SvPVX(tmpsv);
+ while ((*len)--) {
+ if (!isSPACE(*orig))
+ *tmps++ = *orig;
+ orig++;
+ }
+ *tmps = '\0';
+ *len = tmps - SvPVX(tmpsv);
+ return SvPVX(tmpsv);
+}
+#endif
+
+/* ------------------------------- mg.h ------------------------------- */
+
+#if defined(PERL_CORE) || defined(PERL_EXT)
+/* assumes get-magic and stringification have already occurred */
+PERL_STATIC_INLINE STRLEN
+S_MgBYTEPOS(pTHX_ MAGIC *mg, SV *sv, const char *s, STRLEN len)
+{
+ 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;
+ 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);
+ }
+}
+#endif
+
/* ----------------------------- regexp.h ----------------------------- */
PERL_STATIC_INLINE struct regexp *
@@ -67,7 +117,7 @@ S_SvREFCNT_dec(pTHX_ SV *sv)
{
if (LIKELY(sv != NULL)) {
U32 rc = SvREFCNT(sv);
- if (rc > 1)
+ if (LIKELY(rc > 1))
SvREFCNT(sv) = rc - 1;
else
Perl_sv_free2(aTHX_ sv, rc);
@@ -78,7 +128,7 @@ PERL_STATIC_INLINE void
S_SvREFCNT_dec_NN(pTHX_ SV *sv)
{
U32 rc = SvREFCNT(sv);
- if (rc > 1)
+ if (LIKELY(rc > 1))
SvREFCNT(sv) = rc - 1;
else
Perl_sv_free2(aTHX_ sv, rc);
@@ -121,10 +171,11 @@ S_SvPADSTALE_off(SV *sv)
assert(SvFLAGS(sv) & SVs_PADMY);
return SvFLAGS(sv) &= ~SVs_PADSTALE;
}
-#ifdef PERL_CORE
+#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);
@@ -134,10 +185,89 @@ S_sv_or_pv_pos_u2b(pTHX_ SV *sv, const char *pv, STRLEN pos, STRLEN *lenp)
}
#endif
+/* ------------------------------- handy.h ------------------------------- */
+
+/* saves machine code for a common noreturn idiom typically used in Newx*() */
+#ifdef __clang__
+#pragma clang diagnostic push
+#pragma clang diagnostic ignored "-Wunused-function"
+#endif
+static void
+S_croak_memory_wrap(void)
+{
+ Perl_croak_nocontext("%s",PL_memory_wrap);
+}
+#ifdef __clang__
+#pragma clang diagnostic pop
+#endif
+
+#ifdef BOOTSTRAP_CHARSET
+static bool
+S_bootstrap_ctype(U8 character, UV classnum, bool full_Latin1)
+{
+ /* See comments in handy.h. This is placed in this file primarily to avoid
+ * having to have an entry for it in embed.fnc */
+
+ dTHX;
+
+ if (! full_Latin1 && ! isASCII(character)) {
+ return FALSE;
+ }
+
+ switch (classnum) {
+ case _CC_ALPHANUMERIC: return isALPHANUMERIC_L1(character);
+ case _CC_ALPHA: return isALPHA_L1(character);
+ case _CC_ASCII: return isASCII_L1(character);
+ case _CC_BLANK: return isBLANK_L1(character);
+ case _CC_CASED: return isLOWER_L1(character)
+ || isUPPER_L1(character);
+ case _CC_CNTRL: return isCNTRL_L1(character);
+ case _CC_DIGIT: return isDIGIT_L1(character);
+ case _CC_GRAPH: return isGRAPH_L1(character);
+ case _CC_LOWER: return isLOWER_L1(character);
+ case _CC_PRINT: return isPRINT_L1(character);
+ case _CC_PSXSPC: return isPSXSPC_L1(character);
+ case _CC_PUNCT: return isPUNCT_L1(character);
+ case _CC_SPACE: return isSPACE_L1(character);
+ case _CC_UPPER: return isUPPER_L1(character);
+ case _CC_WORDCHAR: return isWORDCHAR_L1(character);
+ case _CC_XDIGIT: return isXDIGIT_L1(character);
+ case _CC_VERTSPACE: return isSPACE_L1(character) && ! isBLANK_L1(character);
+ case _CC_IDFIRST: return isIDFIRST_L1(character);
+ case _CC_QUOTEMETA: return _isQUOTEMETA(character);
+ case _CC_CHARNAME_CONT: return isCHARNAME_CONT(character);
+ case _CC_NONLATIN1_FOLD: return _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(character);
+ case _CC_NON_FINAL_FOLD: return _IS_NON_FINAL_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(character);
+ case _CC_IS_IN_SOME_FOLD: return _IS_IN_SOME_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(character);
+ case _CC_BACKSLASH_FOO_LBRACE_IS_META: return 0;
+
+
+ default: break;
+ }
+ Perl_croak(aTHX_ "panic: bootstrap_ctype() has an unexpected character class '%" UVxf "'", classnum);
+}
+#endif
+
/* ------------------------------- utf8.h ------------------------------- */
-/* These exist only to replace the macros they formerly were so that their use
- * can be deprecated */
+PERL_STATIC_INLINE void
+S_append_utf8_from_native_byte(const U8 byte, U8** dest)
+{
+ /* Takes an input 'byte' (Latin1 or EBCDIC) and appends it to the UTF-8
+ * encoded string at '*dest', updating '*dest' to include it */
+
+ PERL_ARGS_ASSERT_APPEND_UTF8_FROM_NATIVE_BYTE;
+
+ if (NATIVE_BYTE_IS_INVARIANT(byte))
+ *(*dest)++ = byte;
+ else {
+ *(*dest)++ = UTF8_EIGHT_BIT_HI(byte);
+ *(*dest)++ = UTF8_EIGHT_BIT_LO(byte);
+ }
+}
+
+/* These two exist only to replace the macros they formerly were so that their
+ * use can be deprecated */
PERL_STATIC_INLINE bool
S_isIDFIRST_lazy(pTHX_ const char* p)
@@ -154,3 +284,50 @@ S_isALNUM_lazy(pTHX_ const char* p)
return isALNUM_lazy_if(p,1);
}
+
+/* ------------------------------- perl.h ----------------------------- */
+
+/*
+=for apidoc AiR|bool|is_safe_syscall|const char *pv|STRLEN len|const char *what|const char *op_name
+
+Test that the given C<pv> doesn't contain any internal C<NUL> characters.
+If it does, set C<errno> to ENOENT, optionally warn, and return FALSE.
+
+Return TRUE if the name is safe.
+
+Used by the IS_SAFE_SYSCALL() macro.
+
+=cut
+*/
+
+PERL_STATIC_INLINE bool
+S_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.
+ */
+
+ PERL_ARGS_ASSERT_IS_SAFE_SYSCALL;
+
+ if (pv && len > 1) {
+ char *null_at;
+ if (UNLIKELY((null_at = (char *)memchr(pv, 0, len-1)) != NULL)) {
+ SETERRNO(ENOENT, LIB_INVARG);
+ Perl_ck_warner(aTHX_ packWARN(WARN_SYSCALLS),
+ "Invalid \\0 character in %s for %s: %s\\0%s",
+ what, op_name, pv, null_at+1);
+ return FALSE;
+ }
+ }
+
+ return TRUE;
+}
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: nil
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 et:
+ */