diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/CORE/inline.h')
-rwxr-xr-x | Master/tlpkg/tlperl/lib/CORE/inline.h | 189 |
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: + */ |